reify/reflect

gistfile1.lisp

(ql:quickload :cl-cont)
(ql:quickload :alexandria)
(ql:quickload :fare-matcher)

(defpackage :reify-reflect
  (:use :cl :cl-cont :fare-matcher :fare-matcher-extensions)
  (:import-from :alexandria :iota))

(in-package :reify-reflect)

(defmacro reset (&body body)
  `(without-call/cc
    (with-call/cc
     ,@body)))

(defstruct monad unit bind)

(defvar *current-monad* nil)

(defmacro reify (thunk)
  `(reset (funcall (monad-unit *current-monad*) ,thunk)))

(defun/cc reflect (meaning)
  (let/cc k
    (funcall (monad-bind *current-monad*) meaning k)))


;;; List monad
(defun list-monad-unit (x)
  (list x))

(defun list-monad-bind (c f)
  (apply #'append (mapcar f c)))

(defstruct (monad-zero (:include monad)) zero)

(defvar *list-monad-zero* '())

(defvar *list-monad*
  (make-monad-zero :unit #'list-monad-unit
                   :bind #'list-monad-bind
                   :zero *list-monad-zero*))

(setf *current-monad* *list-monad*)

(defun/cc guard (x)
  (unless x (reflect (monad-zero-zero *current-monad*))))

(reify
 (let ((x (reflect (iota 10)))
       (y (reflect (iota 10))))
   (guard (< x 3))
   (guard (= 6 (+ x y)))
   (cons x y)))


;;; Writer monad
(defun writer-monad-unit (x)
  (list x ()))

(defun writer-monad-bind (w f)
  (letm (list a l) w
    (letm (list a1 l1) (funcall f a)
      (list a1 (append l l1)))))

(defvar *writer-monad*
  (make-monad :unit #'writer-monad-unit
        :bind #'writer-monad-bind))

(setf *current-monad* *writer-monad*)

(defun tell (s)
  (list nil s))

(reify
 (labels ((fact (n)
            (reflect (tell (list n)))
            (if (= n 1)
                 1
                (* n (fact (1- n))))))
   (fact 10)))


;;; Probability monad
(defun prob-monad-unit (x)
  (list (list x 1)))

(defun prob-monad-bind (p f)
  (list-monad-bind p (mfun ((list x p1)
    (list-monad-bind (funcall f x) (mfun ((list y p2)
      (list-monad-unit (list y (* p1 p2))))))))))

(defvar *prob-monad*
  (make-monad :unit #'prob-monad-unit
              :bind #'prob-monad-bind))

(setf *current-monad* *prob-monad*)

(defun calc-prob (dist event)
  (let ((*current-monad* *list-monad*))
    (apply #'+
      (reify
	(let ((x (reflect dist)))
	  (guard (equalp (car x) event))
	  (cadr x))))))

(defvar *dice*
(mapcar (lambda (x) (list x (float 1/6))) (iota 6 :start 1)))

(defvar *dist*
  (reify
    (let ((x (reflect *dice*))
          (y (reflect *dice*))
          (z (reflect *dice*)))
       (+ x y z))))

(calc-prob *dist* 9)

(calc-prob *dist* 10)