Monad framework for Common Lisp

list-monad.lisp

;;; List Monad

(defmethod bind ((m list) f)
  (apply #'append (mapcar f m)))

(defmethod fmap ((m list) f)
  (mapcar f m))

monad.lisp

;;; Monad

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

(defgeneric bind (m f))
(defgeneric fmap (m f))

state-monad.lisp

;;; State Monad

(defstruct state run)

(defun eval-state (m v)
  (car (run-state m v)))

(defun exec-state (m v)
  (cadr (run-state m v)))

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

(defun get-state ()
  (make-state
   :run (lambda (s)
	  (list s s))))

(defun put-state (x)
  (make-state
   :run (lambda (_)
	  (declare (ignorable _))
	  (list nil x))))

(defmethod bind ((m state) f)
  (make-state
   :run (lambda (s)
	  (destructuring-bind (a s*) (run-state m s)
	    (run-state (funcall f a) s*)))))

(defmethod fmap ((m state) f)
  (make-state
   :run (lambda (s)
	  (destructuring-bind (a s*) (run-state m s)
	    (list (funcall f a) s*)))))

test.lisp

;;; list

(perform ((a (list 1))
	  (b (list 2 3))
	  (c (list 3 4 5)))
  (+ 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)))
  c)

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



;;; test

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

(eval-state
 (perform ((a (numcons "a" nil))
	   (b (numcons "b" a))
	   (c (numcons "c" b)))
   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)
;