fixed recur.el bug in cond expansion, started kanren implementation i…

…n loel.el

loel.el

@@ -0,0 +1,66 @@
+(provide 'loel)
+(require 'cl)
+(require 'recur)
+
+(defvar *var-tag-table* 
+  (make-hash-table :weakness 'key)
+  "var-tag-table is a weak table which helps identifty loel variables.")
+
+(defun* new-var-tag (&optional (prefix ""))
+  (let ((sym (gensym prefix)))
+	(puthash sym t *var-tag-table*)
+	sym))
+
+(defun tag-in-table? (tag)
+  (gethash tag *var-tag-table* nil))
+
+(defun f-var (sym)
+  (vector '--var (new-var-tag) sym))
+
+(defun var? (o)
+  (and (vectorp o)
+	   (= (length o) 3)
+	   (eq (elt o 0) '--var)
+	   (tag-in-table? (elt o 1))))
+
+(defun var-sym (var)
+  (elt var 2))
+
+(defvar *symbol-counter* 0)
+(defun new-symbol ()
+  (prog1 (internf "_%d"  *symbol-counter*)
+	(setq *symbol-counter* (+ 1 *symbol-counter*))))
+
+(defmacro* var (&optional (symbol (new-symbol)))
+  (if (not (symbolp symbol))
+	  (error "Var must be initialized with a symbol.")
+	`(f-var ',symbol)))
+
+(defun rhs (assoc) (cdr assoc))
+(defun lhs (assoc) (car assoc))
+
+(recur-defun* 
+ walk-step 
+ (var sub)
+ (cond
+  ((empty? sub) nil)
+  (t
+   (if (eq (var-sym var)
+		   (var-sym (car (car sub))))
+	   (car sub)
+	 (recur var (cdr sub))))))
+
+(recur-defun* walk (var sub)
+			  (cond
+			   ((var? var)
+				(let ((a (walk-step var sub)))
+				  (cond 
+				   (a (recur (rhs a) sub))
+				   (t var))))
+			   (t var)))
+
+
+   (defmacro substitution (&rest pairs)
+	 `(list ,@(loop for pair in (bunch-list pairs) collect
+					`(cons ,(car pair) ,(cadr pair)))))
+

monads.el

@@ -1,6 +1,7 @@
 (require 'cl)
 (require 'utils)
 (require 'defn)
+(require 'recur)
 
 ;; (setf monad-maybe
 ;; 	  (tbl!
@@ -37,6 +38,18 @@
 			   (funcall f (MaybeVal v)))))
   "The MAYBE monad.  See Just, None, None?, and MaybeVal.")
 
+(defun m-Error (arg)
+  `(Error ,arg))
+
+(defvar monad-error 
+  (tbl! 
+   :m-return (lambda (x) (Just x))
+   :m-bind (lambda (v f) 
+			 (if (eq (car v) 'Error) v
+			   (funcall f (MaybeVal v))))))
+
+
+
 (defvar monad-id 
   (tbl! :m-return (lambda (x) x)
 		:m-bind (lambda (v f) (funcall f v)))
@@ -136,7 +149,7 @@ monad, but only admits unique results under PREDICATE.
   (lexical-let ((lpred predicate))
 	(tbl! 
 	 :m-zero (list)
- 	 :m-return (lambda (x) (list x))
+	 :m-return (lambda (x) (list x))
 	 :m-bind (lambda (v f) (unique (apply #'append (mapcar f v)) lpred)))))
 
 (defun m-m-bind (monad v f)
@@ -187,12 +200,13 @@ monad, but only admits unique results under PREDICATE.
 
 (defmacro* domonad-helper* (forms &body body)
   (cond 
-   ((= 0 (length forms)) `(m-return (progn ,@body)))
+   ((= 0 (length forms))  `(progn ,@body))
    (t 
 	(dlet_ [[form val & rest-forms] forms]
 	  `(m-bind ,val (fn ,(vector form) (domonad-helper* ,rest-forms ,@body)))))))
 
 (defmacro* domonad* (monad forms &body body)
+  "Like DOMONAD but does not warp the BODY of the macro in an M-RETURN."
   (cond 
    ((oddp (length forms)) (error "domonad requires an even number of forms"))
    (t
@@ -314,6 +328,27 @@ monadically, according to the current monad."
 							 ,(gen-m-lift-binding arg-names)
 							 (funcall ,fsym ,@arg-names)))))))
 
+(defmacro m-lift-into (n f monad)
+  "Macro - LIFT F (with N args) into the current monad."
+  (with-gensyms 
+   (fsym monadsym)
+   (let ((arg-names 
+		  (loop for i from 1 to n collect
+				(gensymf "arg%d" i))))
+	 `(lexical-let ((,fsym ,f)
+					(,monadsym ,monad))
+		(lex-lambda ,arg-names
+					(domonad ,monadsym
+							 ,(gen-m-lift-binding arg-names)
+							 (funcall ,fsym ,@arg-names)))))))
+
+(defun m-lift-into1 (f monad) (m-lift-into 1 f monad))
+(defun m-lift-into2 (f monad) (m-lift-into 2 f monad))
+(defun m-lift-into3 (f monad) (m-lift-into 3 f monad))
+(defun m-lift-into4 (f monad) (m-lift-into 4 f monad))
+(defun m-lift-into5 (f monad) (m-lift-into 5 f monad))
+(defun m-lift-into6 (f monad) (m-lift-into 6 f monad))
+
 (defun m-lift1 (f)
   (m-lift 1 f))
 
@@ -332,31 +367,34 @@ monadically, according to the current monad."
 (defun m-lift6 (f)
   (m-lift 6 f))
 
-(defun lift-left (f)
-  (lexical-let ((f f))
-	(lambda (left &rest rest)
-	  (domonad current-monad 
-			   [left left]
-			   (apply f left rest)))))
-
-(defun lift-right (f)
-  (lexical-let ((f f))
-	(lambda (&rest rest)
-	  (lexical-let* ((rrest (reverse rest))
-					 (right (car rrest))
-					 (rest (reverse (cdr rrest))))
-		(domonad current-monad 
-				 [right right]
-				 (apply f (suffix rest right)))))))
-
-(defun lift-nth (f n)
-  (lexical-let ((f f) (n n))
-	(lambda (&rest rest)
-	  (let ((nth-item (elt rest n)))
-		(domonad current-monad
-				 [nth-item nth-item]
-				 (setf (elt rest n) nth-item)
-				 (apply f rest))))))
+;; (defun lift-left (f)
+;;   (lexical-let ((f f))
+;; 	(lambda (left &rest rest)
+;; 	  (domonad current-monad 
+;; 			   [left left]
+;; 			   (apply f left rest)))))
+
+;; (defun lift-right (f)
+;;   (lexical-let ((f f))
+;; 	(lambda (&rest rest)
+;; 	  (lexical-let* ((rrest (reverse rest))
+;; 					 (right (car rrest))
+;; 					 (rest (reverse (cdr rrest))))
+;; 		(domonad current-monad 
+;; 				 [right right]
+;; 				 (apply f (suffix rest right)))))))
+
+;; (defun lift-nth (f n)
+;;   (lexical-let ((f f) (n n))
+;; 	(lambda (&rest rest)
+;; 	  (let ((nth-item (elt rest n)))
+;; 		(domonad* current-monad
+;; 				  [nth-item nth-item]
+;; 				  (setf (elt rest n) nth-item)
+;; 				  (apply f rest))))))
+
+
+
 
 (provide 'monads)
 

mstack.el

@@ -0,0 +1,41 @@
+(require 'monads)
+(require 'utils)
+
+(defun get-options (options) (cdr options))
+(defun options? (mb-options) 
+  (and (listp mb-options)
+	   (eq (car mb-options) 'Options)))
+(defun list->options (lst)
+  (cons 'Options lst))
+
+
+(defun options-bind (v f)
+  (let ((options (get-options v)))
+	(list->options (mapcat (comp #'get-options f) options))))
+
+(defvar options-monad
+  (tbl!
+   :m-bind 
+   #'options-bind
+   :m-return 
+   (lex-lambda (v)
+			   (list->options (list v))))
+  "Options monad - just window dressing on the list monad.")
+
+
+(defun fpush (x stack) (cons x stack))
+(defun fdrop (stack) (cdr stack))
+
+(defun mfpush (mitems mstack)
+  (funcall (m-lift-into2 #'fpush options-monad) mitems mstack))
+(defun mfdrop (mstack)
+  (funcall (m-lift-into1 #'fdrop options-monad) mstack))
+
+(mfdrop (mfpush '(Options a b c) '(Options () (a) (a a))))
+
+(domonad options-monad 
+		 [x '(Options 1 2 3)
+			y '(Options 4 5 6)]
+		 (list x y))
+
+(get-options '(Options a b c))

prolapse.el

@@ -1,49 +1 @@
-(setf fact-db (cl-make-hash-table :test 'equal))
 
-(defmacro fact (name args &rest terms)
-  `(setf (tbl fact-db '(,name ,@args))
-		 ,(if terms `(quote ,terms) t)))
-
-(defun capitilized-symbol? (sym)
-  (let* ((str-version (format "%s" sym))
-		 (first-char (substring str-version 0 1)))
-	(string= first-char (upcase first-char))))
-
-(defun prolog-constant? (sym)
-  (or (numberp sym)
-	  (not (capitilized-symbol? sym))
-	  (stringp sym)))
-
-(defun constant-form? (form)
-  (and-over #'prolog-constant? (cdr form)))
-(defmacro query (&rest form)
-  (cond 
-   ((constant-form? form) `($ ',form in fact-db 'equal))
-   (t 'too-dumb-for-this-query)))
-
-(macroexpand '(fact father (vincent) (child-of X vincent) (married vincent (mother-of Y X))))
-
-(fact human (vincent))
-(fact human (shelley))
-(fact mother (shelley weather))
-(fact father (vincent weather))
-(fact human (X) (mother Y X) (father Z X) (human Y) (human Z))
-(keyshash fact-db)
-(query human vincent)
-(macroexpand '(query human vincent))
-(in '(human vincent) (keyshash fact-db) 'equal)
-(equal '(human vincent) '(human vincent))
-
-(fact parent (vincent weather))
-(fact parent (shelley weather))
-(fact parent (shelley flint))
-(fact parent (vincent flint))
-(fact parent (debbie sophie))
-(fact parent (brian sophie))
-
-
-(query parent X Y)
-; find possible values of X, these are any facts or rules in the data base for which (parent X Y) could possibly be true.  
-; find possible values of Y, these are any facts or rules for which (parent x Y) is true, where x [= X
-
-(parent 

recur.el

@@ -57,7 +57,7 @@
 				   `(
 					 ,(simple-expand-recur condition symbols nil nil)
 					 ,@(cdr (simple-expand-recur
-							 `(progn ,@body) symbols in-tail nil)))))))
+							 `(progn ,@body) symbols in-tail loop-sentinal)))))))
 
 (defun simple-expand-recur-funcall (code symbols in-tail loop-sentinal)
   "Handle recursion expansion for FUNCALL forms.  The de-factor default when the head of a list is not recognized."
@@ -222,6 +222,7 @@ macro expansion."
 (defmacro* recur-defun* (name arglist &body body)
   "Define a recur-enabled function.  It can call itself with a RECUR form without growing the stack.
 Otherwise conforms to a Common-Lisp style defun form."
+  (declare (indent defun))
   (let* ((doc (if (stringp (car body)) (car body) ""))
 		 (body (if (stringp (car body)) (cdr body) body)))
 	(with-gensyms