Skip to content

Instantly share code, notes, and snippets.

@KeenS KeenS/optima.lisp
Last active Jun 24, 2018

What would you like to do?
(ql:quickload :optima)
(use-package :optima)
(defun list-slots (obj slots conc-name)
(loop :for slot :in slots :collect
(funcall (intern (format nil "~a~a" conc-name slot)) obj)))
(defun make-print-object (name gensyms)
`(lambda (obj stream)
(format stream "(~a ~{~a~^ ~})" ',name
(list-slots obj ',gensyms (format nil "~a-" ',name)))))
(defmacro defvariant (name &rest args)
(let ((tags ())
(containers ()))
(loop :for type :in args :do
(match type
((and (TYPE list) it) (push it containers))
(it (push it tags))))
(deftype ,name ()
`(or (member ,@',tags)
,@',(mapcar #'car containers)))
,@(loop :for container :in containers :append
(destructuring-bind (name . types) container
(let ((gensyms (loop :for type :in types :collect
(gensym (symbol-name type)))))
`((defstruct (,name
(:constructor ,name ,gensyms)
,(make-print-object name gensyms)))
:for type :in types
:for gensym :in gensyms :collect
`(,gensym nil :type ,type)))
(defpattern ,name ,gensyms
(list ',(intern (format nil "~A-" name))
,@(loop :for gensym :in gensyms :append
(list (intern (format nil "~:@(~A~)" gensym) :keyword) gensym)))))))))))
;;; Example: Red-Black tree
(defvariant tree
(red tree t tree)
(black tree t tree))
(defun rb-member (x tree)
(match tree
((leaf) nil)
((or (red left label right)
(black left label right))
(cond ((< x label) (rb-member x left))
((> x label) (rb-member x right))
(t t)))))
(defun balance (tree)
(match tree
((or (black (red (red a x b) y c) z d)
(black (red a x (red b y c)) z d)
(black a x (red (red b y c) z d))
(black a x (red b y (red c z d))))
(red (black a x b) y (black c z d)))
(otherwise tree)))
(defun rb-insert (x tree)
(labels ((ins (tree)
(match tree
((leaf) (red (leaf) x (leaf)))
((node color left label right)
(cond ((< x label)
(balance (node color (ins left) label right)))
((> x label)
(balance (node color left label (ins right))))
(t tree))))))
(match (ins tree)
((node left label right)
(black left label right)))))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.