Direct return extraction

monad.lisp

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Utilities
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun singlep (list)
  (= (length list) 1))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Core Primitives
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(defmacro perform-progn (&body exprs)
  (if (singlep exprs)
      (car exprs)
      (let ((_ (gensym)))
	`(bind ,(car exprs)
	       (lambda (,_)
		 (declare (ignorable ,_))
		 (perform-progn ,@(cdr exprs)))))))

(defmacro perform (bindings &body expression)
  (destructuring-bind ((name value) &rest rest) bindings
    (if rest
	`(bind ,value (lambda (,name) (perform ,rest ,@expression)))
	`(bind ,value (lambda (,name) (perform-progn ,@expression))))))

(defparameter *current-monad-context* nil)

(defun unit (x)
  (funcall *current-monad-context* x))

(defgeneric bind (m f))

(defmacro defmonad (type &body operators)
  (let ((my-bind (cadr (assoc :bind operators)))
	(my-unit (cadr (assoc :unit operators)))
	(m (gensym))
	(f (gensym))
	(x (gensym))
	(g (gensym)))
    `(defmethod bind ((,m ,type) ,f)
       (let ((,g (lambda (,x)
		   (let ((*current-monad-context* ,my-unit))
		     (funcall ,f ,x)))))
	 (funcall ,my-bind ,m ,g)))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; List Monad
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defmonad list
  (:unit (lambda (x) (list x)))
  (:bind (lambda (m f) (apply #'append (mapcar f m)))))


;;; test

(perform ((a (list 1))
	  (b (list 2 3))
	  (c (list 3 4 5)))
  (unit (+ a b c)))

; => (6 7 8 7 8 9)

(defun double-list (x)
  (list x x))

(perform ((a '(1 2 3))
	  (b (double-list a))
	  (c (double-list b)))
  (unit c))

; => (1 1 1 1 2 2 2 2 3 3 3 3)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Maybe Monad
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defstruct (maybe
	     (:constructor maybe (x)))
  x)

(defmonad maybe
  (:unit (lambda (x) (maybe (cons :just x))))
  (:bind (lambda (m f)
	   (case (maybe-x m)
	     (:nothing (maybe :nothing))
	     (t (funcall f (cdr (maybe-x m))))))))


;;; Sorry, no test yet...


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; State Monad
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defstruct (state
	     (:constructor state (run)))
  run)

(defmonad state
  (:unit (lambda (a)
	   (state (lambda (s)
		    (values a s)))))
  (:bind (lambda (m f)
	   (state (lambda (s)
		    (multiple-value-bind (a s*) (run-state m s)
		      (run-state (funcall f a) s*)))))))

(defun eval-state (m v)
  (multiple-value-bind (a s) (run-state m v)
    (declare (ignorable s))
    a))

(defun exec-state (m v)
  (multiple-value-bind (a s) (run-state m v)
    (declare (ignorable a))
    s))

(defun run-state (m v)
  (funcall (state-run m) v))

(defun get-state ()
  (state (lambda (s)
	   (values s s))))

(defun put-state (x)
  (state (lambda (_)
	   (declare (ignorable _))
	   (values nil x))))


;;; test

(defun numcons (head tail)
  (perform ((cnt (get-state)))
    (put-state (+ cnt 1))
    (unit (cons (list head cnt) tail))))

(eval-state (perform ((a (numcons "a" nil))
		      (b (numcons "b" a))
		      (c (numcons "c" b)))
	      (unit c))
	    0)

;;; test


(defstruct cursor x y)

(defun cursor-right (n)
  (make-state
   :run (lambda (cursor)
	  (let ((x (+ (cursor-x cursor) n)))
	    (list x (make-cursor :x x :y (cursor-y cursor)))))))

(defun cursor-down (n)
  (make-state
   :run (lambda (cursor)
	  (let ((y (+ (cursor-y cursor) n)))
	    (list y (make-cursor :x (cursor-x cursor) :y y))))))

(defun square (n)
  (perform ((x (cursor-right n))
	    (s (cursor-down x)))
    s))

;
; cl-user> (make-cursor :x 0 :y 0)
; #S(cursor :x 0 :y 0)
;
; cl-user> (exec-state (square 10) *)
; #S(cursor :x 10 :y 10)
;
; cl-user> **
; #S(cursor :x 0 :y 0)
;