optima.lisp

(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))))
    `(progn
       (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)
			       (:print-object
				,(make-print-object name gensyms)))
		    ,@(loop
			 :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
#+nil
(defvariant tree
  (leaf)
  (red tree t tree)
  (black tree t tree))

#+nil
(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)))))

#+nil
(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)))

#+nil
(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)))))