Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

weighted graph monad commit

  • Loading branch information...
commit 664a8db2be74bc9427d8b7082668d4e3b624340c 1 parent 25df036
@VincentToups authored
View
11 advanced-utils.el
@@ -1,6 +1,7 @@
(require 'utils)
(require 'with-stack)
(require 'defn)
+(require 'recur)
(defun file-location (filestr)
@@ -18,4 +19,14 @@
(file-extension "/this/is/a/test/press.txt")
)
+(nthcdr 3 '(a b c d))
+
+(recur-defun* bunch-by (n input &optional (output nil))
+ (if input
+ (let ((bunch (elts input (range n)))
+ (rest (nthcdr n input)))
+ (recur n rest (cons bunch output)))
+ (reverse output)))
+
+
(provide 'advanced-utils)
View
107 animator.el
@@ -1,51 +1,36 @@
(require 'utils)
-(setf *animator-funs* (alist>>))
(setf *animator-color-stack* nil)
-
-(defmacro* with-animator (&body body)
- `(labels ,(loop for info in *animator-funs* collect
- (let ((actual-name (car info))
- (local-name (car (cadr info)))
- (arglist (cadr (cadr info)))
- (argsym (gensym "animator-args-")))
- `(,local-name (&rest ,argsym) (apply #',actual-name ,argsym))))
- ,@body))
-(defmacro* defanimatorfun (name arglist docstring &body body)
- (let ((actual-name (internf "animator-%s" name)))
- (setf *animator-funs* (alist>> *animator-funs*
- actual-name (list name arglist)))
- `(defun ,actual-name ,arglist ,docstring (with-animator ,@body))))
(defun start-animator-process ()
(let ((sh (shell "*animator*")))
(comint-send-strings sh "animator")
(setq *animator* sh)))
(start-animator-process)
-(defanimatorfun send (&rest strings)
+(defun animator-send (&rest strings)
(apply #'comint-send-strings *animator* strings))
-(defanimatorfun flush ()
+(defun animator-flush ()
(comint-send-strings *animator* "flush"))
-(defanimatorfun frame ()
+(defun animator-frame ()
(comint-send-strings *animator* "frame"))
-(defanimatorfun color (cc)
+(defun animator-color (cc)
(if (listp cc)
(let* ((s (format "%s" cc))
(n (length s)))
(animator-send (concat "color " (substring s 1 (- n 1)))))
(animator-send (format "color %s" cc))))
-(defanimatorfun push-color (cc)
+(defun animator-push-color (cc)
(push cc *animator-color-stack*)
(if (listp cc)
(let* ((s (format "%s" cc))
(n (length s)))
(animator-send (concat "color " (substring s 1 (- n 1)))))
(animator-send (format "color %s" cc))))
-(defanimatorfun pop-color ()
+(defun animator-pop-color ()
(let ((clr (pop *animator-color-stack*))
(top (car *animator-color-stack*)))
(if top (animator-color top)
@@ -64,22 +49,22 @@
(defmacro* with-flush/frame (&body body)
`(progn (animator-frame) ,@body (animator-flush)))
-(defanimatorfun dot (x y)
+(defun animator-dot (x y)
(comint-send-strings *animator*
(format "dot %f %f" x y)))
-(defanimatorfun dots (pairs)
+(defun animator-dots (pairs)
(loop for pair in pairs do
(apply #'animator-dot pair)))
-(defanimatorfun line (x1 y1 x2 y2)
+(defun animator-line (x1 y1 x2 y2)
(animator-send (format "line %f %f %f %f" x1 y1 x2 y2)))
-(defanimatorfun disjoint-lines (&rest lines)
+(defun animator-disjoint-lines (&rest lines)
(loop for line in lines do
(apply animator-line line)))
-(defanimatorfun connected-lines (&rest args)
+(defun animator-connected-lines (&rest args)
(let ((args (flatten args)))
(animator-send
(concat "lines "
@@ -87,7 +72,7 @@
""
args)))))
-(defanimatorfun poly (&rest args)
+(defun animator-poly (&rest args)
(let ((args (flatten args)))
(animator-send
(concat "poly "
@@ -95,19 +80,80 @@
""
args)))))
-(defanimatorfun circle (x y r &optional verts)
+(defun animator-circle (x y r &optional verts)
(let ((verts (if verts verts 25)))
(animator-send (format "circle %f %f %f %f" x y r verts))))
-(defanimatorfun filled-circle (x y r &optional verts)
+(defun animator-filled-circle (x y r &optional verts)
(let ((verts (if verts verts 25)))
(animator-send (format "fillcircle %f %f %f %f" x y r verts))))
-(defanimatorfun text (x y text &optional alignment)
+(defun animator-text (x y text &optional alignment)
(if alignment
(animator-send (format "text %s %f %f \"%s\"" alignment x y text))
(animator-send (format "text %f %f \"%s\"" x y text))))
+(defun animator-dup ()
+ (animator-send "push"))
+
+(defun animator-pop ()
+ (animator-send "pop"))
+
+(defun animator-ident ()
+ (animator-send "ident"))
+
+(defun animator-shift (x y)
+ (animator-send (format "shift %f %f" x y)))
+
+(defun animator-rotate (degrees)
+ (animator-send (format "rotate %f" degrees)))
+
+(defun animator-scale (x &optional y)
+ (let ((y (if y y x)))
+ (animator-send (format "scale %f %f" x y))))
+
+(defun animator-viewport (left bottom w h)
+ (animator-send (format "viewport %f %f %f %f" left bottom w h)))
+
+(defun create-animator-format-string (name-string args)
+ (loop for i from 1 to (length args) do
+ (setq name-string (concat name-string " %f")))
+ name-string)
+
+(defmacro* def-numeric-animator-primitive (name &optional doc &rest arg-names)
+ (let ((interface-name (internf "animator-%s" name))
+ (name-string (format "%s" name))
+ (doc (if (stringp doc) doc nil))
+ (arg-names (if (stringp doc) arg-names
+ (cons doc arg-names))))
+ `(defun ,interface-name ,arg-names ,doc
+ (animator-send (format ,(create-animator-format-string name-string arg-names)
+ ,@arg-names)))))
+
+(defmacro* def-numeric-animator-primitive-alt-name (interface-name name &optional doc &rest arg-names)
+ (let ((name-string (format "%s" name))
+ (doc (if (stringp doc) doc nil))
+ (arg-names (if (stringp doc) arg-names
+ (cons doc arg-names))))
+ `(defun ,interface-name ,arg-names ,doc
+ (animator-send (format ,(create-animator-format-string name-string arg-names)
+ ,@arg-names)))))
+
+
+(def-numeric-animator-primitive thick "Set animator line thickness"
+ thickness)
+
+(def-numeric-animator-primitive alpha "Set animator transparency." alpha)
+
+(def-numeric-animator-primitive arrow "Draw an arrow pointing towards X2 Y2"
+ x1 y1 x2 x2)
+
+(def-numeric-animator-primitive-alt-name fill-rect fillrect "Fill an animator rectangle with the current color." x y w h)
+
+(def-numeric-animator-primitive rect "Fill an animator rectangle with the current color." x y w h)
+
+(with-flush/frame (animator-rect 0 0 .25 .25))
+
@@ -133,5 +179,4 @@
(color "green"))
)
-
(provide 'animator)
View
BIN  functional.elc
Binary file not shown
View
7 microstack.el
@@ -112,7 +112,7 @@
(|||- {qtn} call))))
(defstackword loop-until-char
- (|||- '(char-at-point->string string=) curry loop-until))
+ (|||- '(char-at-point->string 2>string=) curry loop-until))
(defstackword forward
(forward-char))
@@ -232,7 +232,7 @@
(defstackword kill (|||- 1>move-kill drop))
(setq micro-stack-map
- (alist>>
+ (tbl!
'm 'move ; generic movement. pops an item from the stack, then moves appropriately
'k 'kill ; generic move-and-kil, pops and item of the stack, marks, moves, and kill-region's
'l 'line ; specify that a number indicates a number of lines
@@ -286,7 +286,7 @@
(loop for el in code append
(cond
((symbolp el)
- (let ((trans (alist micro-stack-map el)))
+ (let ((trans (tbl micro-stack-map el)))
(if trans (list trans) (error "Unknown microstack word."))))
((listp el)
(list 'lisp-val: `(quote ,el)))
@@ -304,5 +304,4 @@
(interactive "s")
(let* ((code (parse-microstack str))
(code (translate-microstack code)))
- (print code)
(do-microstack-parsed-translated code)))
View
BIN  microstack.elc
Binary file not shown
View
3  monad-parse.el
@@ -396,6 +396,7 @@
(cons x y)))
(defun parse-string (parser string)
+ (print (funcall parser (->in string)))
(car (car (funcall parser (->in string)))))
(defun parse-sequence (parser sequence)
@@ -407,7 +408,7 @@
(rest (input->string (cdr (car pr)))))
(if (or (not result)
(not rest)) nil
- (list result (input->string rest)))))
+ (list result rest))))
(defun =lit-sym (sym)
(=satisfies (f-and
View
BIN  monad-parse.elc
Binary file not shown
View
9 monad-transformers.el
@@ -0,0 +1,9 @@
+(provide 'monad-transformers)
+(require 'monads)
+(require 'utils)
+
+(defun sequence-t (inner-monad)
+ (alist
+ :m-bind (lambda (v f)
+ (with-monad inner-monad
+ (mapcat
View
313 monads.el
@@ -28,35 +28,48 @@
(apply #'concat (loop for possibility in (cdr v)
collect (cdr (f v)))))))
-(setf monad-maybe
- (tbl!
- :m-return (lambda (x) (Just x))
- :m-bind (lambda (v f)
- (if (eq (car v) 'None) v
- (funcall f (MaybeVal v))))))
-
-(setf monad-id
- (tbl! :m-return (lambda (x) x)
- :m-bind (lambda (v f) (funcall f v))))
-
-(setf monad-state
- (tbl!
- :m-return (fn [x] (fn [s] (list x s)))
- :m-bind (fn [mv f]
- (fn [s]
- (dlet [[val new-state] (funcall mv s)]
- (funcall (funcall f val) new-state))))))
-
-(setf monad-cont
- (tbl!
- :m-return (fn [v]
- (fn [c]
- (funcall c v)))
- :m-bind
- (fn [mv mf]
- (fn [c]
- (funcall mv (fn [v]
- (funcall (mf v) c)))))))
+(defvar monad-maybe
+ (tbl!
+ :m-zero (None)
+ :m-return (lambda (x) (Just x))
+ :m-bind (lambda (v f)
+ (if (eq (car v) 'None) v
+ (funcall f (MaybeVal v)))))
+ "The MAYBE monad. See Just, None, None?, and MaybeVal.")
+
+(defvar monad-id
+ (tbl! :m-return (lambda (x) x)
+ :m-bind (lambda (v f) (funcall f v)))
+ "The identity monad - you know, for kids.")
+
+(defun m-bind (v f)
+ "Monadic BIND. Unless dynamically shadowed, this is the identity BIND."
+ (funcall f v))
+(defun m-return (v)
+ "Monadic return. Unless dynamically shadowed, this is the identity RETURN."
+ v)
+
+(defvar monad-state
+ (tbl!
+ :m-return (fn [x] (fn [s] (list x s)))
+ :m-bind (fn [mv f]
+ (fn [s]
+ (dlet [[val new-state] (funcall mv s)]
+ (funcall (funcall f val) new-state)))))
+ "The STATE monad. Constructs a function which takes a state and
+transforms it out of other such functions.")
+
+(defvar monad-cont
+ (tbl!
+ :m-return (fn [v]
+ (fn [c]
+ (funcall c v)))
+ :m-bind
+ (fn [mv mf]
+ (fn [c]
+ (funcall mv (fn [v]
+ (funcall (mf v) c))))))
+ "The continuation monad. Construct a function which takes a continuation goes.")
(defn call-bind [[:: bind :m-bind] & args]
(apply bind args))
@@ -81,40 +94,75 @@
(list val (alist>> state key val))))
(defmacro* defstatefun (name monad-forms &body body)
+ "Define a function of state using monad-state. IE, bind the result of
+ (DOMONAD MONAD-STATE MONAD-FORMS ...BODY) to the function NAME."
(let ((state (gensym "state")))
`(defun ,name (,state)
(funcall
(domonad monad-state ,monad-forms ,@body)
,state))))
+(defvar monad-seq
+ (tbl!
+ :m-zero (list)
+ :m-return (lambda (x) (list x))
+ :m-bind (lambda (v f) (apply #'append (mapcar f v))))
+ "The list/sequence monad. Combine computations over multiple possibilities.")
+
+
+
-(setf monad-seq
- (tbl! :m-return (lambda (x) (list x))
- :m-bind (lambda (v f) (apply #'append (mapcar f v)))))
(defun monad-set (predicate)
+ "Returns a SET-MONAD with PREDICATE semantics.
+This is similar to the sequence
+monad, but only admits unique results under PREDICATE.
+
+ (domonad (monad-set #'=)
+ [x '(1 2 3)
+ y '(1 2 3)]
+ (+ x y))
+
+ yields: (2 3 4 5 6)
+
+ (domonad monad-seq
+ [x '(1 2 3)
+ y '(1 2 3)]
+ (+ x y))
+
+ yields: (2 3 4 3 4 5 4 5 6)
+
+"
(lexical-let ((lpred predicate))
- (tbl! :m-return (lambda (x) (list x))
- :m-bind (lambda (v f) (unique (apply #'append (mapcar f v)) lpred)))))
+ (tbl!
+ :m-zero (list)
+ :m-return (lambda (x) (list x))
+ :m-bind (lambda (v f) (unique (apply #'append (mapcar f v)) lpred)))))
-(defn m-m-bind [monad v f]
+(defun m-m-bind (monad v f)
+ "Call the bind function in MONAD with args V and F."
(funcall (tbl monad :m-bind) v f))
-(defn m-m-return [monad v]
+(defun m-m-return (monad v)
+ "Call the RETURN function in MONAD with V."
(funcall (tbl monad :m-return) v))
-
(defmacro* with-monad (monad &body body)
- `(labels ((m-return (x) (m-m-return ,monad x))
- (m-bind (v f) (m-m-bind ,monad v f))
- (>>= (v f) (m-m-bind ,monad v f)))
- ,@body))
+ `(let ((current-monad ,monad))
+ (labels ((m-return (x) (m-m-return current-monad x))
+ (m-bind (v f) (m-m-bind current-monad v f))
+ (>>= (v f) (m-m-bind current-monad v f)))
+ (lexical-let ((m-zero (tbl current-monad :m-zero)))
+ ,@body))))
+
(defmacro* with-monad-dyn (monad &body body)
- `(flet ((m-return (x) (m-m-return ,monad x))
- (m-bind (v f) (m-m-bind ,monad v f))
- (>>= (v f) (m-m-bind ,monad v f)))
- ,@body))
+ `(let ((current-monad ,monad))
+ (flet ((m-return (x) (m-m-return current-monad x))
+ (m-bind (v f) (m-m-bind current-monad v f))
+ (>>= (v f) (m-m-bind current-monad v f)))
+ (let ((m-zero (tbl current-monad :m-zero)))
+ ,@body))))
(defn halt [x]
(fn [c] x))
@@ -122,7 +170,7 @@
(defn yield [x]
(fn [c]
(list x (fn []
- (funcall c x)))))
+ (funcall c x)))))
(defn bounce [x]
(fn [c]
@@ -136,26 +184,13 @@
#'m-return
steps))
-(dont-do
- (with-monad monad-seq
- ($ (list 10 11 12) >>= (lambda (x) (m-return (+ x 1)))))
- )
-
-(defmacro* domonad-helper* (forms &body body)
- (cond
- ((= 0 (length forms)) `(m-return (progn ,@body)))
- (t
- (let ((form (car (coerce forms 'list)))
- (val (cadr (coerce forms 'list)))
- (rest-forms (coerce (cddr (coerce forms 'list)) 'vector)))
- `(m-bind ,val (fn ,(vector form) (better-domonad-helper ,rest-forms ,@body)))))))
(defmacro* domonad-helper* (forms &body body)
(cond
((= 0 (length forms)) `(m-return (progn ,@body)))
(t
(dlet_ [[form val & rest-forms] forms]
- `(m-bind ,val (fn ,(vector form) (better-domonad-helper ,rest-forms ,@body)))))))
+ `(m-bind ,val (fn ,(vector form) (domonad-helper* ,rest-forms ,@body)))))))
(defmacro* domonad* (monad forms &body body)
(cond
@@ -165,15 +200,6 @@
(domonad-helper* ,forms ,@body)))))
-(dont-do
- (domonad monad-seq
- [testx (list 1 2) testy (list 1 2)]
- (list testx testy))
-
- (domonad* monad-seq
- [testx (list 1 2) testy (m-return (+ 1 testx))]
- testy)
- )
(defmacro* domonad-inner (m-bind-sym m-return-sym forms &body body)
@@ -183,15 +209,26 @@
`(funcall ,m-bind-sym
,val
(fnc ,(vector form)
- (domonad-inner
- ,m-bind-sym
- ,m-return-sym
- ,rest-forms
- ,@body)))))
+ (domonad-inner
+ ,m-bind-sym
+ ,m-return-sym
+ ,rest-forms
+ ,@body)))))
(t (error "domonad requires an even number of m-bind forms"))))
(defmacro* domonad (monad forms &body body)
+ "DOMONAD: Sequence the computations/bindings in
+FORMS using the monad MONAD, finally, evaluate BODY,
+returning the value of the final form.
+
+Inside a DOMONAD M-BIND and M-RETURN are bound to
+the bind and return functions associated with MONAD.
+Monads are pretty cool.
+
+Note: >>= is also bound as the bind function. This is handy
+to combine with the $ infix macro: ($ v >>= f) -> (>>= v f)
+but resembles Haskell notation for the confused."
(cond
((oddp (length forms)) (error "domonad requires an even number of forms"))
((= 0 (length forms)) `(progn ,@body))
@@ -211,21 +248,19 @@
,m-return-sym
(tbl ,monad-sym :m-return)]
(labels ((m-bind (v f) (funcall ,m-bind-sym v f))
+ (>>= (v f) (funcall ,m-bind-sym v f))
(m-return (x) (funcall ,m-return-sym x)))
- (funcall ,m-bind-sym
+ (funcall ,m-bind-sym
;(funcall ,m-return-sym ,val)
- ,val
- (fnc ,(vector form)
- (domonad-inner
- ,m-bind-sym
- ,m-return-sym
- ,rest-forms
- ,@body)))))))))
+ ,val
+ (fnc ,(vector form)
+ (domonad-inner
+ ,m-bind-sym
+ ,m-return-sym
+ ,rest-forms
+ ,@body)))))))))
-;; (defn Just [x]
-;; (cond ((numberp x) (list 'Just x))
-;; ((and (listp x) (eq (car x) 'None)) (None))))
(defn maybe+ [x y]
(Just (+ x y)))
@@ -233,49 +268,71 @@
(defn maybe/ [x y]
(if (= 0 y) (None)
(Just (/ x y))))
-(comment
-
- (domonad monad-id [x 10 y 11] (+ x y))
- (domonad monad-maybe [x (Just 20) k (maybe/ x 4) y (maybe+ k 1)] k)
- (domonad monad-maybe [x (Just 20) k (maybe/ x 0) y (maybe+ k 1)] k)
- (domonad monad-seq [x (list 1 2 3) y (list 4 5 6)] (list x y))
-
- (defn state-incr [state]
- (list state (+ 1 state)))
-
- (funcall (domonad monad-state
- [a
- #'state-incr
- b
- #'state-incr
- c
- #'state-incr]
- (list a b c)) 0)
-
- (setf monad-what
- (tbl! :m-return (fn [x] (fn [] x))
- :m-bind (fn [v f]
- (funcall f (funcall v)))))
-
- (defun incr (x) (+ x 1))
-
- (with-monad monad-what
- (m-bind (m-return 10) #'incr))
-
- (setf side-effect 0)
-
- (with-monad monad-what
- (setf res (domonad monad-what
- [x (fn [] (progn (setf side-effect 100) 10))
- y (fn [] (list 3))
- z (fn [] (car y))]
- z)))
-
- (setf r (funcall res))
- (funcall (funcall (funcall r)))
-
- (require 'monads)
- )
+
+ ; transformers - more than meets the eye.
+
+(defun m-seq (vlst)
+ "Combine the monadic values in VLST into a monadic value using
+the rules of the current monad."
+ (reduce
+ (lambda (output v)
+ (m-bind v
+ (lambda (x)
+ (m-bind output (lambda (y)
+ (m-return (cons x y)))))))
+ (reverse vlst)
+ :initial-value (m-return nil)))
+
+(defun m-mapcar (f xs)
+ "Map F across the monadic values in XS, combining the results
+monadically, according to the current monad."
+ (m-seq (mapcar f xs)))
+
+(example
+ (with-monad-dyn monad-seq
+ (m-seq
+ '((a b) (c d)))
+ (m-mapcar (lambda (x) (list (+ x 1) (- x 1)))
+ '(1 2 3 4 5))))
+
+(defvar current-monad monad-id "The identity is the current monad by default.")
+
+(defun gen-m-lift-binding (arg-names)
+ "Generate the temporary variable names for a lift."
+ (coerce (loop for a in arg-names append (list a a)) 'vector))
+
+(defmacro m-lift (n f)
+ "Macro - LIFT F (with N args) into the current monad."
+ (with-gensyms
+ (fsym)
+ (let ((arg-names
+ (loop for i from 1 to n collect
+ (gensymf "arg%d" i))))
+ `(lexical-let ((,fsym ,f))
+ (lex-lambda ,arg-names
+ (domonad current-monad
+ ,(gen-m-lift-binding arg-names)
+ (funcall ,fsym ,@arg-names)))))))
+
+(defun m-lift1 (f)
+ (m-lift 1 f))
+
+(defun m-lift2 (f)
+ (m-lift 2 f))
+
+(defun m-lift3 (f)
+ (m-lift 3 f))
+
+(defun m-lift4 (f)
+ (m-lift 4 f))
+
+(defun m-lift5 (f)
+ (m-lift 5 f))
+
+(defun m-lift6 (f)
+ (m-lift 6 f))
+
+
(provide 'monads)
View
83 tree-monads.el
@@ -0,0 +1,83 @@
+(require 'utils)
+(require 'monads)
+(require 'functional)
+
+(defun* btcons (val &optional (left nil) (right nil))
+ (cons val
+ (vector left right)))
+
+(defun btree? (val)
+ (and (consp val)
+ (vectorp (cdr val))))
+
+(defun btleft (node)
+ (first (cdr node)))
+
+(defun btright (node)
+ (second (cdr node)))
+
+(defun btleaf? (val)
+ (and (btree? val)
+ (eq (btleft val) nil)
+ (eq (btright val) nil)))
+
+(defun btnode? (val)
+ (not (btleaf? val)))
+
+(defun btnode-val (val)
+ (car val))
+
+(defun left-nil? (node)
+ (not (btleft node)))
+
+(defun right-nil? (node)
+ (not (btright node)))
+
+(defun graft-left (tree sub-tree)
+ (cond
+ ((not tree) sub-tree)
+ ((not sub-tree) tree)
+ ((left-nil? tree) (btcons
+ (btnode-val tree)
+ sub-tree
+ (btright tree)))
+ (t (btcons (btnode-val tree)
+ (graft-left (btleft tree) sub-tree)
+ (btright tree)))))
+
+(defun graft-right (tree sub-tree)
+ (cond
+ ((not tree) sub-tree)
+ ((not sub-tree) tree)
+ ((right-nil? tree) (btcons
+ (btnode-val tree)
+ (btleft tree)
+ sub-tree
+ ))
+ (t (btcons (btnode-val tree)
+ (btleft tree)
+ (graft-right (btright tree) sub-tree)
+ ))))
+
+(graft-right (graft-left (btcons 10) (btcons 9)) (btcons 11))
+
+(defun bt-bind (v f)
+ (cond
+ ((eq nil v) nil)
+ ((or (btleaf? v)
+ (btnode? v))
+ (let ((res (funcall f (btnode-val v))))
+ (graft-right (graft-left res (bt-bind (btleft v) f))
+ (bt-bind (btright v) f))))
+ ))
+
+(bt-bind (btcons 10 (btcons 9) (btcons 11))
+ (lambda (v) (btcons (+ v 1))))
+
+(setq monad-btree
+ (tbl! :m-return #'btcons
+ :m-bind
+ #'bt-bind))
+
+
+
View
73 utils.el
@@ -655,7 +655,7 @@
"Simple infix macro. ($ a < b) -> (< a b)."
`(,f ,first ,@rest))
-(defun first (l) "Return first element of l." (car l))
+(defun first (l) "Return first element of l." (elt l 0))
(defun shell-to (dir)
"Send the shell to the directory DIR. List newest files there."
@@ -923,34 +923,76 @@
(alist>> root (car keys)
(alist>>-in (alist root (car keys)) (cdr keys) val))))
+(defun alist>>-in-conjugate (root keys fun)
+ "Replaces a deeply nested alist value with the value (FUN VAL)"
+ (let ((val (alist-in root keys)))
+ (alist>>-in root keys (funcall fun val))))
+
(defun alist-conjugate (alst key fun &optional or-val)
"Returns a new alist where the value of key is now (fun (alist alst key)). Accepts an
optional OR-VAL if the key is not in the alist."
(let ((val (alist-or alst key or-val)))
(alist>> alst key (funcall fun val))))
+(defun* pred-alist (pred alist key &optional (or-val nil))
+ "Access an alist with PRED for key equality."
+ (let-if val (car (car (member-if
+ (lexical-let ((pred pred))
+ (lambda (item)
+ (funcall pred item key))) alist)))
+ val
+ or-val))
+
+(defun* pred-alist-conjugate (pred alist key fun &optional (or-val nil))
+ "Conjugate a value in an alist with PRED as the key equality test."
+ (let ((item (pred-alist pred alist key or-val)))
+ (pred-alist>> pred alist key
+ (funcall fun item))))
+
(defun alist-cons (alst key value)
"Cons the element VALUE onto the list at KEY in ALST. If key is not there, obviously this creates a list there."
(alist-conjugate alst key
(lexical-let ((value value))
(lambda (xxx) (cons value xxx)))))
-(defun alist-add-to-set (alst key value)
- "Adds the VALUE to the set held at KEY in ALST."
+(defun* alist-add-to-set (alst key value &optional (pred #'equal))
+ "Adds the VALUE to the set held at KEY in ALST. Optionally specify PRED
+to control set equality. Defaults to EQUAL."
(alist-conjugate alst key
(lexical-let ((value value))
- (lambda (xxx) (if (not ($ value in xxx)) (cons value xxx) xxx)))))
+ (lambda (xxx) (if (not ($ value in xxx pred)) (cons value xxx) xxx)))))
-(defun alist-remove-from-set (alst key value)
- "Removes the VALUE to the set held at KEY in ALST."
+(defun* alist-remove-from-set (alst key value &optional (pred #'equal))
+ "Removes the VALUE to the set held at KEY in ALST. Optionalally specify
+PRED to control set equality. Defaults to EQUAL."
(alist-conjugate alst key
(lexical-let ((value value))
(lambda (xxx)
(filter
(lambda (item)
- (not (equal item value)))
+ (not (funcall pred item value)))
xxx)))))
+(defun pred-dissoc (pred alist &rest keys)
+ "Remove entries with key KEYS from the ALIST using the predicate PRED for key equality."
+ (filter
+ (lexical-let ((pred pred))
+ (lambda (alist-item)
+ (not ($ (car alist-item) in keys pred))))
+ alist))
+
+(defun* pred-alist>> (pred &optional (alist :---alist-sentinal---) &rest kv-pairs)
+ "Create an ALIST or add to one the pairs KV-PAIRS using the key equality predicate PRED."
+ (if (listp alist)
+ (let* ((kv-pairs (unique (bunch-list kv-pairs)
+ (lexical-let ((pred pred))
+ (lambda (a b)
+ (funcall pred (car a) (car b))))))
+ (keys (mapcar #'car kv-pairs))
+ (alist (apply #'pred-dissoc pred alist keys)))
+ (append kv-pairs alist))
+ (apply #'pred-alist>> pred nil (cons alist kv-pairs))))
+
(defun dissoc (alist &rest keys)
"Returns a new ALIST without KEYS."
@@ -974,7 +1016,6 @@ optional OR-VAL if the key is not in the alist."
(not ($ alist-el-key in keys #'equal)))
collect element)))
-
(defun* alist>> (&optional alist &rest rest)
"Create or functionally modifies an ALIST.
(alist>> alist [key val]...) adds key vals to the alist.
@@ -1811,4 +1852,20 @@ which is the identity, by default."
"Print the form FORM and its VALUE."
`(print (format "%S - %s" ',form ,form)))
+(defun second (s)
+ "return the second element of SEQ."
+ (elt s 1))
+
+(defun nil? (s)
+ "Alias for NOT."
+ (not s))
+
+(defmacro* example (&body body)
+ "Ignores the body, but you can go inside and execute the examples."
+ nil)
+
+(defun mapcat (f lst)
+ "Map F across LST and concatenate the results."
+ (loop for x in lst append (funcall f x)))
+
(provide 'utils)
View
BIN  utils.elc
Binary file not shown
View
386 weighted-graph-monad.el
@@ -0,0 +1,386 @@
+(require 'utils)
+(require 'monads)
+(require 'functional)
+(require 'cl)
+(require 'advanced-utils)
+(provide 'weighted-graph-monad)
+(provide 'recur)
+
+(defun* empty-weighted-graph (&key (symmetric t) (pred #'equal))
+ "Create an empty weighted-graph. Not usually called directly."
+ (alist>> :nodes nil ; the nodes
+ :connections nil ; the edges
+ :symmetric symmetric ; whether edges should be symmetric or go both ways.
+ :pred pred)) ; the predicate to test for node equality.
+
+(defun wg-add-node (wg node)
+ "Add a NODE to a weighted graph WG."
+ (alist-add-to-set wg :nodes node (alist wg :pred)))
+
+(defun wg-pair-to-canonical-order (wg node1 node2)
+ "Because nodes need not be sortable, this function puts a pair
+of nodes into Canonical Order based on the nodes already in the
+weighted graph WG. Canonical order is the order in which
+the nodes appear in the node list."
+ (sort (list node1 node2)
+ (decorate-all #'<
+ (lambda (it)
+ (length (member-if
+ (par (alist wg :pred) it)
+ (alist wg :nodes)))))))
+
+(defvar *link-table* (tbl!))
+(defun symmetric-link (node1 node2)
+ (let ((lnkn (tbl-or *link-table* (list node1 node2) nil))
+ (lnku (tbl-or *link-table* (list node2 node1) nil)))
+ (if (or lnkn lnku) lnkn
+ (progn
+ (tbl! *link-table* (list node1 node2) (list node1 node2))
+ (tbl! *link-table* (list node2 node1) (list node1 node2))
+ (list node1 node2)))))
+
+(defun wg-add-connection (wg node1 node2 connection)
+ "Add a connection to the weighted graph WG between NODE1 and
+NODE2 of weight CONNECTION. If the nodes are not already in the
+graph, add them before creating the connection.
+
+If the connection is already in the graph, CONNECTION is
+added to the connection strength.
+
+When the graph is symmetric, the connection between NODE1 and
+NODE2 is the same as that between NODE2 and NODE1.
+"
+ (let* ((wg (alist-add-to-set wg :nodes node1))
+ (wg (alist-add-to-set wg :nodes node2))
+ (c-nodes (symmetric-link node1 node2))
+ (connections (alist wg :connections)))
+ (let ((out
+ (if connection
+ (alist>> wg :connections
+ (pred-alist-conjugate (alist wg :pred) connections c-nodes
+ (lambda (old)
+ (+ old connection))
+ 0))
+ (alist>> wg :connections
+ (pred-dissoc (alist wg :pred) connections c-nodes)))))
+ out)))
+
+(defun weighted-graph (nodes &rest connections)
+ "Create a weighted graph with NODES and optional CONNECTIONS.
+Connections should be a series of PAIR VAL pairs. Connections are
+added with WG-ADD-CONNECTION semantics, and so new nodes will be
+created as needed."
+ (let ((wg (reduce #'wg-add-node nodes
+ :initial-value (empty-weighted-graph)))
+ (connections (bunch-list connections)))
+ (reduce
+ (lambda (wg connection)
+ (wg-add-connection wg (car (car connection))
+ (cadr (car connection))
+ (cadr connection)))
+ connections
+ :initial-value wg)))
+
+(defun* wg (&key (nodes nil) (connections nil)
+ (symmetric t) (pred #'equal))
+ "WG creates a weighted graph with a key/val interface. NODES
+is a list of nodes. CONNECTIONS is a flat list of triples
+describing connections as [N1 N2 STREN].
+
+SYMMETRIC indicates with T/NIL symmetry.
+PRED is the equality predicate for NODES."
+ (let* ((nodes (unique nodes pred))
+ (wg (alist>> (empty-weighted-graph :pred pred :symmetric symmetric)
+ :nodes nodes)))
+ (reduce
+ (lambda (wg conn)
+ (apply #'wg-add-connection wg conn))
+ (bunch-by 3 connections)
+ :initial-value wg)))
+
+(defun wg-combine-nodes (wg1 wg2)
+ (alist>> wg1 :nodes
+ (unique (append (alist wg1 :nodes)
+ (alist wg2 :nodes))
+ (alist wg1 :pred))))
+
+(example
+ (wg-combine-nodes
+ (weighted-graph '(:a :b :c))
+ (weighted-graph '(:d :e))))
+
+(defun wg-combine2 (wg1 wg2)
+ "Combine weighted graphs WG1 and WG2 using the symmetry
+semantics of WG1 by adding the connections in WG2 to WG1. This
+is half of the weighted graph BIND operation."
+ (let* ((wg1 (reduce
+ (lambda (wg conn)
+ (wg-add-connection wg (car (car conn))
+ (cadr (car conn))
+ (cadr conn)))
+ (alist wg2 :connections)
+ :initial-value
+ (wg-combine-nodes wg1 wg2))))
+ wg1))
+
+(defun wg-combine (&rest args)
+ "Combine weighted graphs in ARGS using the symmetry
+semantics of (car ARGS) using REDUCTION with WG-COMBINE2"
+ (cond ((not args) (empty-weighted-graph))
+ (t (reduce #'wg-combine2
+ args))))
+
+(example
+ (require 'weighted-graph-monad)
+ (cl-prettyprint (wg-combine (weighted-graph '(:a :b :c) '(:a :b) 2)
+ (weighted-graph '(:d :e) '(:d :e) 3)))
+
+ )
+
+(defun weighted-graph-bind (v f)
+ "Bind the value V, a weighted graph, with the function F,
+which should take a node value and return a weighted graph
+to be combined with V."
+ (reduce
+ (lambda (wg node)
+ (let ((sub-graph (funcall f node)))
+ (wg-combine wg sub-graph)))
+ (alist v :nodes)
+ :initial-value (alist>> v :symmetric t)))
+
+
+(defun asymmetric-weighted-graph-bind (v f)
+ "Bind the value V, a weighted graph, with the function F,
+which should take a node value and return a weighted graph
+to be combined with V."
+ (reduce
+ (lambda (wg node)
+ (wg-combine wg (funcall f node)))
+ (alist v :nodes)
+ :initial-value (alist>> v :symmetric nil)))
+
+
+(defun wg-return (&optional item)
+ "Monadic return operation for weighted graphcs. Returns a
+weighted graph with one node ITEM and no connections. If ITEM
+is omitted or NIL, return an empty weighted graph."
+ (if item
+ (weighted-graph (list item))
+ (weighted-graph nil)))
+
+(defun asymmetric-wg-return (&optional item)
+ "Asymmetric weighted graph return function."
+ (if item
+ (alist>> (weighted-graph (list item)) :symmetric nil)
+ (empty-weighted-graph :symmetric nil)))
+
+(defvar weighted-graph-monad
+ (tbl! :m-bind #'weighted-graph-bind
+ :m-return #'wg-return)
+ "The weighted graph monad.")
+
+(defvar asymmetric-weighted-graph-monad
+ (tbl! :m-bind #'asymmetric-weighted-graph-bind
+ :m-return #'asymmetric-wg-return)
+ "The assymetric weighted graph monad.")
+
+(example
+ (require 'weighted-graph-monad)
+ (cl-prettyprint (domonad weighted-graph-monad
+ [node1 (weighted-graph '(a b c))
+ node2 (weighted-graph '(a b c))
+ graph (wg-connect node1 node2 1)]
+ graph))
+
+ )
+
+(defun nodes (&rest nodes)
+ "Create a weighted graph with only NODES."
+ (wg :nodes nodes))
+
+(defun node (node)
+ "Create a graph with a single node."
+ (wg :nodes (list node)))
+
+(defun edges (&rest edges)
+ "Create a weighted graph with EDGES. Nodes are added as needed,
+repeated edges are combined. EDGES should be a flat list of
+triples of the form NODE1 NODE2 STREN."
+ (wg :connections edges))
+
+(defun asymmetric-edges (&rest edges)
+ "Create a graph containing the asymmetric EDGES."
+ (wg :symmetric nil :connections edges))
+
+(defun edge (from to stren)
+ "Create a graph with a single edge FROM to TO with strength STREN."
+ (wg :connections (list from to stren)))
+
+(defun asymmetric-edge (from to stren)
+ "Create a graph with a single asymmetric edge FROM to TO with strength STREN."
+ (wg :symmetric nil :connections (list from to stren)))
+
+(defun unedge (from to)
+ "Specify a weighted graph which explicitely doesn't contain an edge FROM TO."
+ (alist>> (empty-weighted-graph) :connections `(((,from ,to) nil))))
+
+(defun asymmetric-unedge (from to)
+ "Specify a weighted graph which explicitely doesn't contain an edge FROM TO."
+ (alist>> (empty-weighted-graph) :symmetric nil :connections `(((,from ,to) nil))))
+
+(defun wg-connect (from to mag)
+ "Return a weighted-graph with a connection between FROM and TO of magnitude MAG."
+ (weighted-graph (list from to) (list from to) mag))
+
+(defun wg-disconnect (from to)
+ "Removes a connection from a weighted graph."
+ (alist>> (empty-weighted-graph) :connections `(((,from ,to) nil))))
+
+(example
+ (require 'weighted-graph-monad)
+
+ (cl-prettyprint
+ (domonad weighted-graph-monad
+ [node1 (nodes 'a 'b 'c)
+ node2 (nodes 'a 'b 'c)
+ final-graph
+ (if (equal node1 node2) (empty-weighted-graph)
+ (edge node1 node2 1))]
+ final-graph))
+ ((:connections (((c a) 1) ((b c) 1) ((a b) 1)))
+ (:nodes (a b c))
+ (:symmetric t)
+ (:pred equal))
+
+
+ "This example builds a network of sexual contact. Men and women
+are network nodes and we use the weighted graph monad to add
+connections between men and women indicating the number of
+encounters they may have had."
+
+ (cl-prettyprint (labels
+ ((man (name) (list (intern "man") name))
+ (woman (name) (list (intern "woman") name))
+ (man? (thing)
+ (and (listp thing)
+ (eq (car thing) (intern "man"))))
+ (two-men? (thing1 thing2)
+ (and (man? thing1)
+ (man? thing2)))
+ (two-women? (thing1 thing2)
+ (and (woman? thing1)
+ (woman? thing2)))
+ (woman? (thing)
+ (and (listp thing)
+ (eq (car thing) (intern "woman")))))
+ (let ((hetero-prob .3) ;set the probability of heterosexual encounters
+ (homo-prob .1) ;set the probability of homosexual encounters
+ (empty-graph (weighted-graph nil)) ; we will be using the empty graph a lot
+ ; this is m-zero anyway.
+ (population ; describe the population as a list of nodes, we will fill in
+ ; connections later.
+ (weighted-graph
+ (list
+ (man :bob)
+ (man :ted)
+ (man :leo)
+ (man :theo)
+ (man :jon)
+ (man :herbert)
+ (woman :sally)
+ (woman :alice)
+ (woman :jane)
+ (woman :elizabeth)
+ (woman :karen)))))
+ (domonad weighted-graph-monad
+ [person1 population
+ person2 population
+ connected-pop
+ (cond
+ ((equal person1 person2) empty-graph) ; lol, people don't have sex with themselves
+ ((or (two-men? person1 person2)
+ (two-women? person1 person2))
+ (if ($ (random* 1.0) < homo-prob) ; ie, there is a homosexual encounter
+ (wg-connect person1 person2 1)
+ empty-graph))
+ (t
+ (if ($ (random* 1.0) < hetero-prob) ; ie, there is a heterosexual encounter
+ (wg-connect person1 person2 1)
+ empty-graph)))]
+ ; return the final connected population after one round of activity.
+ connected-pop))))
+((:connections ((((man :bob)
+ (woman :karen))
+ 1)
+ (((man :bob)
+ (woman :elizabeth))
+ 1)
+ (((man :herbert)
+ (man :bob))
+ 1)
+ (((man :ted)
+ (man :herbert))
+ 1)
+ (((man :leo)
+ (woman :karen))
+ 1)
+ (((man :leo)
+ (woman :sally))
+ 1)
+ (((man :theo)
+ (woman :elizabeth))
+ 1)
+ (((man :theo)
+ (man :jon))
+ 1)
+ (((man :herbert)
+ (woman :elizabeth))
+ 1)
+ (((man :herbert)
+ (man :theo))
+ 1)
+ (((woman :sally)
+ (woman :karen))
+ 1)
+ (((woman :sally)
+ (man :jon))
+ 1)
+ (((woman :alice)
+ (woman :sally))
+ 1)
+ (((woman :alice)
+ (man :theo))
+ 1)
+ (((woman :alice)
+ (man :bob))
+ 1)
+ (((woman :jane)
+ (man :theo))
+ 1)
+ (((woman :jane)
+ (man :bob))
+ 1)
+ (((woman :elizabeth)
+ (man :leo))
+ 1)
+ (((woman :karen)
+ (man :jon))
+ 1)))
+ (:nodes ((woman :karen)
+ (woman :elizabeth)
+ (woman :jane)
+ (woman :alice)
+ (woman :sally)
+ (man :herbert)
+ (man :jon)
+ (man :theo)
+ (man :leo)
+ (man :ted)
+ (man :bob)))
+ (:symmetric t)
+ (:pred equal))
+
+
+ )
+
+
View
BIN  weighted-graph-monad.elc
Binary file not shown
View
425 weighted-graph-monad.md
@@ -0,0 +1,425 @@
+The Weighted Graph Monad
+========================
+
+This document is a monad tutorial/cry for help. It first goes over
+monads in general, as far as I can say I understand them. Then it
+introduces a "novel" monad which I haven't seen described elsewhere on
+the internet. I'm certain that this "weighted graph monad" is not my
+invention, because, as I understand it, any data structure can be
+associated with any number of monads. I think I understand monads
+well enough at this point that this document will be useful to people
+who come from a lisp background as far as getting a deeper
+understanding of some of the things about them. If that is you, you
+can focus on the first section.
+
+N.B.: Lispers who are interested in monads should read Drew Crampsie's
+write up on his SMUG library located
+[here](http://common-lisp.net/~dcrampsie/smug.html) and Jim Duey's
+amazingly excellent [monad tutorial for
+Clojure](http://intensivesystems.net/writings.html), which should
+never the less be useful to a generalized lisper. Although mostly
+directed at OCaml, I also found Chris Barker and Jim Pryor's course
+notes extremely enlightening. They can apparently be found
+[here](http://lambda.jimpryor.net/), though the URL implies this might
+be a link which becomes stale.
+
+The second section is aimed at people who understand monads better
+than I do. In it, I describe the weighted graph monad as I have
+implemented it. Although it seems like a reasonable way to do things,
+its not clear that this is the most "monady" way of implementing such
+a monad. People seeking a better understanding of monads are, of
+course, welcome to read the second part. I think even if it is
+missing some grace and elegance, it is probably useful to see a monad
+built up from nothing, as it were. However, bearing the above
+qualifications in mind, the links above will prove much more useful to
+you than this document.
+
+The Monad
+=========
+
+A monad is defined by at least two functions. Bind takes values out
+of a monadic value, and applies a function to those values. We don't
+worry too much about types in emacs lisp, but its useful to consider
+them here, because bind doesn't just apply ANY function to the value
+inside the monad, and it can't return just any old type. Bind takes a
+monadic value and a function which accepts a value of the kind stored
+_in_ the monad and which returns a monadic value again.
+
+The other function which defines a monad is the monadic Return
+function. This is a function which takese a value of the kind stored
+in the monad and returns the simplest monadic value possible that
+retains the input value. Return is almost the simplest possible
+function which can be passed to Bind - it takese a "naked" value, and
+returns a simple monadic value, just like any _monadic function_
+must.
+
+Some monads define a value called the Monadic Zero, which is sort of
+the simplest possible monadic value for a given monad. It is called a
+zero by analogy to multiplication because binding any function to the
+monadic zero returns the monadic zero. So another simple function
+which we could pass to bind takes a value, ignores it, and returns the
+monadic zero.
+
+People always bring up the sequence monad here, and although it is a
+clear and simple example of a monad, I don't recall it being
+particularly enlightening. But lets go through it anyway. In the
+sequence monad, Sequences are the monadic values, and the monadic
+functions are those functions which take an object of the kind stored
+in the sequence and return a new sequence. If we are dealing with
+lisp data, the sequence monadic values are lists of lisp data. And
+the sequence monadic functions are functions which take some kind of
+lisp data and return a list.
+
+Values we can stick "in" the monad:
+
+ 23
+ "test"
+ (list 1 2 3 4)
+ 'x
+ :z
+
+Monadic values:
+
+ (list 1 2 3 4)
+ (list :x (list 1 2 3 4) "test")
+ (list 'x 'y 'z)
+
+Monadic functions:
+
+ (lambda (x) nil) ; nil is the smallest list
+ (lambda (x) (list x x))
+ (lambda (x) (list x (+ x 1) (- x 1)))
+ (lambda (x) (list 1 2 3 4 5))
+
+The bind operation for the sequence monad is simple.
+
+
+ (defun seq-bind (v f)
+ (let ((monadic-values (mapcar f v)))
+ (apply #'append monadic-values)))
+
+We know we can map f over v because v is a sequence. We know we can
+apply append to the results because f is a monadic function which
+always returns lists. If we misbehave, and pass an f that doesn't
+return lists in, we'll get a run time error. Similarly if v isn't a
+list.
+
+N.B. - seq-bind is often called `mapcat` for "map and concatenate".
+
+The sequence return function is even simpler. It is just the `list`
+function. `List` is obviously a monadic function - it takes an item
+and returns a list.
+
+Using these functions we can write a function which takes a list, and
+returns a list where every element is repeated twice.
+
+ (defun dup (x) (list x x)) ; return a list made of two x's
+ (defun dup-elements (lst)
+ (seq-bind lst #'dup))
+
+ (dup-elements '(1 2 3 4)) -> (1 1 2 2 3 3 4 4)
+
+Note that dup-elements is _not_ a monadic function. It takes _a list_
+as input. You can think of the monad as being an interface layer
+between things and lists, a contract that guarantees that for any
+monadic function it will do something right with the output. Given
+that dup-elements is not a monadic function, what do we do if we want
+to use the sequence monad to dup the elements twice? One possibility
+is:
+
+ (defun double-dup (lst)
+ (seq-bind (seq-bind lst #'dup) #'dup))
+ (double-dup '(1 2 3) -> '(1 1 1 1 2 2 2 2 3 3 3 3)
+
+It is now time to take two birds with one stone. We'd like to be able
+to succinctly chain monadic functions, sometimes without even giving
+them explicit names. We do this with `do notation` in Haskell. In
+Lisp we can roll our own macro, `domonad` (based on the Clojure monad
+library).
+
+ (require 'monads)
+ (defun double-dup (lst)
+ (domonad monad-seq [x lst
+ y (dup x)
+ z (dup y)]
+ z))
+
+This body of double-dup is equivalent to the expression:
+
+ (seq-bind lst
+ (lambda (x)
+ (seq-bind (dup x)
+ (lambda (y)
+ (seq-bind (dup y)
+ (lambda (z) (progn (seq-return z))))))))
+
+Each expression is chained into the monad such that the results of the
+previous expressions are monadically bound to the variables in the do
+form. A do form is a lot like the `let*` form in lisp. In fact,
+`let*` is just `domonad identity-monad`. This isn't a coincidence.
+You can implement `let*` as a nest of function applications.
+
+ (let* ((x 1)
+ (y (+ x 1)))
+ (+ x y))
+
+Is the same as
+
+ (funcall (lambda (x)
+ (funcall (lambda (y)
+ (+ x y)) (+ x 1))) 1)
+
+A monad is just a controlled way of extending the notion of function
+composition and a `do` form is just a `let*` form with those modified
+function composition semantics.
+
+We can do really neat things with monads. The sequence monad lets you
+build up lists a lot like a list comprehension in a language like
+python. Want the list of all possible combinations of three sets of
+symbols?
+
+
+ (domonad monad-seq
+ [s1 '(a b c)
+ s2 '(d e f)
+ s3 '(g h i)]
+ (list s1 s2 s2)) -> ((a d d) (a d d) (a d d) (a e e) (a e e) (a e
+ e) (a f f) (a f f) (a f f) (b d d) (b d d) (b d d) (b e e) (b e
+ e) (b e e) (b f f) (b f f) (b f f) (c d d) (c d d) (c d d) (c e
+ e) (c e e) (c e e) (c f f) (c f f) (c f f) ...)
+
+To the Graph Monad
+------------------
+
+I have it on good authority that one can think of many data structures
+as having an accompaning monad. Can we try to "discover" the monad
+associated with other data structures? Heedless of utility or an
+efficient use of my time, I set out to do just that. The data
+structure I considered was the symmetric weighted graph. This is a
+data structure consisting of a set of nodes and a set of edges, which
+connect nodes. Furthermore, we enforce symmetry, so that the edge '(a
+b) between nodes a and b is considered the same as the edge '(b a).
+We are going to represent this structure using the inefficient but
+easy to grasp association-list. Here is some code to create an empty
+weighted graph:
+
+
+ (defun* empty-weighted-graph (&key (symmetric t) (pred #'equal))
+ "Create an empty weighted-graph. Not usually called directly."
+ (alist>> :nodes nil ; the nodes
+ :connections nil ; the edges
+ :symmetric symmetric ; whether edges should be symmetric or go both ways.
+ :pred pred))
+
+Each entry in the alist is stored as a (key val) pair. We'll use this
+skeleton to store our alist. We can add a node thusly:
+
+ (defun wg-add-node (wg node)
+ "Add a NODE to a weighted graph WG."
+ (alist-add-to-set wg :nodes node (alist wg :pred)))
+
+And a connection as so:
+
+ (defun wg-add-connection (wg node1 node2 connection)
+ "Add a connection to the weighted graph WG between NODE1 and
+ NODE2 of weight CONNECTION. If the nodes are not already in the
+ graph, add them before creating the connection.
+
+ If the connection is already in the graph, CONNECTION is
+ added to the connection strength.
+
+ When the graph is symmetric, the connection between NODE1 and
+ NODE2 is the same as that between NODE2 and NODE1.
+ "
+ (let* ((wg (alist-add-to-set wg :nodes node1))
+ (wg (alist-add-to-set wg :nodes node2))
+ (c-nodes
+ (if (alist wg :symmetric)
+ (wg-pair-to-canonical-order wg node1 node2)
+ (list node1 node2)))
+ (connections (alist wg :connections)))
+ (if connection
+ (alist>> wg :connections
+ (pred-alist-conjugate wg :pred)
+ connections c-nodes (lambda (old) (+ old connection)) 0))
+ (alist>> wg :connections (pred-dissoc (alist wg :pred)
+ connections c-nodes)))))
+
+That is a lot of static just to do something simple: If either node1
+or node2 isn't in the graph (based on the predicate field of the
+graph), they are added to a set stored in :nodes. If the edge is not
+in the graph, it is added. If the edge is in the graph, it is added
+to the value passed in, unless nil is passed in. In the case of a NIL
+connection, the connection is removed from the set. The connections
+are stored as an a-list of node-pair value pairs. The node pairs are
+sorted into "canonical order" before storage, to ensure graph
+symmetry. Canonical order is just the order the nodes were added to
+the graph so that graph nodes for which there is no standard ordering
+can be ordered in a predictable way.
+
+We need just one more function. If you are paying attention, bells
+should go off when we discuss it:
+
+
+ (defun wg-combine (wg1 wg2)
+ "Combine weighted graphcs WG1 and WG2 using the symmetry
+ semantics of WG1 by adding the connections in WG2 to WG1. This
+ is half of the weighted graph BIND operation."
+ (let* ((wg1 (reduce
+ (lambda (wg conn)
+ (wg-add-connection wg (car (car conn))
+ (cadr (car conn))
+ (cadr conn)))
+ (alist wg2 :connections)
+ :initial-value
+ (wg-combine-nodes wg1 wg2))))
+ wg1))
+
+This function uses `wg-add-connection` to add all the connections
+in `WG2` to `WG1`. Since `wg-add-connection` adds connection
+strengths together, the result is a graph reflecting the connectivity
+of both graphs.
+
+The bell that should have gone off in your head is that we've very
+nearly defined our `bind` and `return` operations. If our nodes hold
+our monadic values, then monadic functions are functions which take
+nodes and return a weighted graph. One way of defining bind is then:
+
+ (defun weighted-graph-bind (v f)
+ "Bind the value V, a weighted graph, with the function F,
+ which should take a node value and return a weighted graph
+ to be combined with V."
+ (reduce
+ (lambda (wg node)
+ (wg-combine wg (funcall f node)))
+ (alist v :nodes)
+ :initial-value (alist>> v
+ :symmetry t)))
+
+
+This is pretty straightfoward. `Bind` takes a weighted graph and a
+function which takes nodes and returns a weighted graph, applies `f`
+to all the nodes in the input graph and then mergers them together,
+starting with the input graph.
+
+Since this monad will let us build up graphs out of smaller graphs, we
+should define some convenient functions to create small graphs. These
+will appear in the expression forms of `domonad` and give our
+operations a pleasantly domain-specific-language feel.
+
+ (defun nodes (&rest nodes)
+ "Create a weighted graph with only NODES."
+ (wg :nodes nodes))
+
+ (defun node (node)
+ "Create a graph with a single node."
+ (wg :nodes (list node)))
+
+ (defun edges (&rest edges)
+ "Create a weighted graph with EDGES. Nodes are added as needed,
+ repeated edges are combined. EDGES should be a flat list of
+ triples of the form NODE1 NODE2 STREN."
+ (wg :connections edges))
+
+ (defun edge (from to stren)
+ "Create a graph with a single edge FROM to TO with strength STREN."
+ (wg :connections (list from to stren)))
+
+ (defun unedge (from to)
+ "Specify a weighted graph which
+ explicitely doesn't contain an edge FROM TO."
+ (alist>> (empty-weighted-graph) :connections `(((,from ,to) nil))))
+
+The only weird one here is `unedge` which builds a graph with an
+explicit `nil` edge. `Wg-combine` has a bit of logic built in which
+removes an edge in the result graph when the merged graph contains an
+explicitely `nil` edge. This will let us delete as well as modify
+edges in our graphs from within a monadic function. Note finally that
+`node` is the monad's `return` function.
+
+It takes a value and wraps it in the monad. Using the eclectic monad
+library I've written for emacs lisp, we define a new monad:
+
+ (defvar weighted-graph-monad
+ (tbl! :m-bind #'weighted-graph-bind
+ :m-return #'wg-return)
+ "The weighted graph monad.")
+
+We can now invoke the `domonad` form with `weighted-graph-bind`.
+
+Let's do a simple example. Lets build a graph which has the three
+nodes `(a b c)` and edges between every member and every other except
+when the members are identical.
+
+ (cl-prettyprint
+ (domonad weighted-graph-monad
+ [node1 (nodes 'a 'b 'c)
+ node2 (nodes 'a 'b 'c)
+ final-graph
+ (if (equal node1 node2) (empty-weighted-graph)
+ (edge node1 node2 1))]
+ final-graph))
+ ((:connections (((c a) 1) ((b c) 1) ((a b) 1)))
+ (:nodes (a b c))
+ (:symmetric t)
+ (:pred equal))
+
+A more complex example follows. In it we create a set of constructors
+and predicates to create and identify `men` and `women`. We then use
+the graph monad to simulate a sexual contact network men and women,
+using different probabilities of sexual encounter depending on whether
+relations are homo or hetero-sexual. It occurs to me that this is a
+kind of weird example.
+
+ (labels
+ ((man (name) (list (intern "man") name))
+ (woman (name) (list (intern "woman") name))
+ (man? (thing)
+ (and (listp thing)
+ (eq (car thing) (intern "man"))))
+ (two-men? (thing1 thing2)
+ (and (man? thing1)
+ (man? thing2)))
+ (two-women? (thing1 thing2)
+ (and (woman? thing1)
+ (woman? thing2)))
+ (woman? (thing)
+ (and (listp thing)
+ (eq (car thing) (intern "woman")))))
+ (let ((hetero-prob .3) ;set the probability of heterosexual encounters
+ (homo-prob .1) ;set the probability of homosexual encounters
+ (empty-graph (weighted-graph nil)) ; we will be using the empty graph a lot
+ ; this is m-zero anyway.
+ (population ; describe the population as a list of nodes, we will fill in
+ ; connections later.
+ (weighted-graph
+ (list
+ (man :bob)
+ (man :ted)
+ (man :leo)
+ (man :theo)
+ (man :jon)
+ (man :herbert)
+ (woman :sally)
+ (woman :alice)
+ (woman :jane)
+ (woman :elizabeth)
+ (woman :karen)))))
+ (domonad weighted-graph-monad
+ [person1 population
+ person2 population
+ connected-pop
+ (cond
+ ((equal person1 person2) empty-graph) ; lol, people don't have sex with themselves
+ ((or (two-men? person1 person2)
+ (two-women? person1 person2))
+ (if ($ (random* 1.0) < homo-prob) ; ie, there is a homosexual encounter
+ (wg-connect person1 person2 1)
+ empty-graph))
+ (t
+ (if ($ (random* 1.0) < hetero-prob) ; ie, there is a heterosexual encounter
+ (wg-connect person1 person2 1)
+ empty-graph)))]
+ ; return the final connected population after one round of activity.
+ connected-pop)))
+
View
4 with-stack.el
@@ -34,7 +34,7 @@
(defmacro* defstackword (name &body body)
"Define a new stack word and insert it into the stack word dictionary."
(let ((actual-name (internf "stack-%s-" name)))
- `(progn
+ `(eval-when-compile
(defun ,actual-name () ,@body)
(tbl! *stack-words* ',name (list ',actual-name nil))
(byte-compile ',actual-name))))
@@ -42,7 +42,7 @@
(defmacro* defstackword-immediate (name &body body)
"Define a new stack word and insert it into the stack word dictionary, and mark it as immediate."
(let ((actual-name (internf "stack-%s-" name)))
- `(progn
+ `(eval-when-compile
(defun ,actual-name () ,@body)
(tbl! *stack-words* ',name (list ',actual-name t))
(byte-compile ',actual-name)
View
BIN  with-stack.elc
Binary file not shown
Please sign in to comment.
Something went wrong with that request. Please try again.