gistfile1.lisp

;;; === common lib
(defmacro aif (test-form then-form &optional else-form)
  `(let ((it ,test-form))
     (if it ,then-form ,else-form)))

(defmacro aif2 (test &optional then else)
  (let ((win (gensym)))
    `(multiple-value-bind (it ,win) ,test
       (if (or it ,win) ,then ,else))))

(defun var? (x)
  (and (symbolp x) (eq (char (symbol-name x) 0) #\?)))

(defun simple? (x) (or (atom x) (eq (car x) 'quote)))

(defun gensym? (s) 
  (and (symbolp s) (not (symbol-package s))))

(defun length-test (pat rest)
  (let ((fin (caadar (last rest))))
    (if (or (consp fin) (eq fin 'elt))
        `(= (length ,pat) ,(length rest))
        `(> (length ,pat) ,(- (length rest) 2)))))

(defun vars-in (expr &optional (atom? #'atom))
  (if (funcall atom? expr)
      (if (var? expr) (list expr))
      (union (vars-in (car expr) atom?)
             (vars-in (cdr expr) atom?))))

(defun binding (x binds)
  (labels ((recbind (x binds)
             (aif (assoc x binds)
                  (or (recbind (cdr it) binds)
                      it))))
    (let ((b (recbind x binds)))
      (values (cdr b) b))))

(defun destruc (pat seq &optional (atom? #'atom) (n 0))
  (if (null pat)
      nil
      (let ((rest (cond ((funcall atom? pat) pat)
                        ((eq (car pat) '&rest) (cadr pat))
                        ((eq (car pat) '&body) (cadr pat))
                        (t nil))))
       (if rest
           `((,rest (subseq ,seq ,n)))
           (let ((p (car pat))
                 (rec (destruc (cdr pat) seq atom? (1+ n))))
             (if (funcall atom? p)
                 (cons `(,p (elt ,seq ,n))
                       rec)
                 (let ((var (gensym)))
                   (cons (cons `(,var (elt ,seq ,n))
                               (destruc p var atom?))
                         rec))))))))

(defmacro dbind (pat seq &body body)
  (let ((gseq (gensym)))
    `(let ((,gseq ,seq))
       ,(dbind-ex (destruc pat gseq #'atom) body))))

(defun dbind-ex (binds body)
  (if (null binds)
      `(progn ,@body)
      `(let ,(mapcar #'(lambda (b)
                         (if (consp (car b))
                             (car b)
                             b))
                     binds)
        ,(dbind-ex (mapcan #'(lambda (b)
                               (if (consp (car b))
                                   (cdr b)))
                           binds)
                   body))))

(defmacro with-gensyms (syms &body body)
  `(let ,(mapcar #'(lambda (s)
                     `(,s (gensym)))
                 syms)
     ,@body))

(define-modify-macro conc1f (obj) 
  (lambda (place obj)
    (nconc place (list obj))))

(defmacro acond2 (&rest clauses)
  (if (null clauses)
      nil
      (let ((cl1 (car clauses))
            (val (gensym))
            (win (gensym)))
        `(multiple-value-bind (,val ,win) ,(car cl1)
           (if (or ,val ,win)
               (let ((it ,val)) ,@(cdr cl1))
               (acond2 ,@(cdr clauses)))))))
;;; ===

;;; === pattern matching
(defmacro pat-match (pat seq then else)
  (if (simple? pat)
      (match1 `((,pat ,seq)) then else)
      (with-gensyms (gseq gelse)
        `(labels ((,gelse () ,else))
           ,(gen-match (cons (list gseq seq) 
                             (destruc pat gseq #'simple?))
                       then 
                       `(,gelse))))))

(defun gen-match (refs then else)
  (if (null refs)
      then
      (let ((then (gen-match (cdr refs) then else)))
        (if (simple? (caar refs))
            (match1 refs then else)
            (gen-match (car refs) then else)))))

(defun match1 (refs then else)
  (dbind ((pat expr) . rest) refs
    (cond ((gensym? pat)
           `(let ((,pat ,expr))
              (if (and (typep ,pat 'sequence)
                       ,(length-test pat rest))
                  ,then
                  ,else)))
          ((eq pat '_) then)
          ((var? pat)
           (let ((ge (gensym)))
             `(let ((,ge ,expr))
                (if (or (gensym? ,pat) (equal ,pat ,ge))
                    (let ((,pat ,ge)) ,then)
                    ,else))))
          (t `(if (equal ,pat ,expr) ,then ,else)))))
;; for prolog impl
(defun match (x y &optional binds)
  (acond2
    ((or (eql x y) (eql x '_) (eql y '_)) (values binds t))
    ((binding x binds) (match it y binds))
    ((binding y binds) (match x it binds))
    ((varsym? x) (values (cons (cons x y) binds) t))
    ((varsym? y) (values (cons (cons y x) binds) t))
    ((and (consp x) (consp y) (match (car x) (car y) binds))
     (match (cdr x) (cdr y) it))
    (t (values nil nil))))
;;
;;; ===

(defun make-db (&optional (size 100))
  (make-hash-table :size size))

(defvar *default-db* (make-db))

(defun clear-db (&optional (db *default-db*))
  (clrhash db))

(defmacro db-query (key &optional (db '*default-db*))
  `(gethash ,key ,db))
  
(defun db-push (key val &optional (db *default-db*))
  (push val (db-query key db)))

(defmacro fact (pred &rest args)
  `(progn (db-push ',pred ',args)
          ',args))

;;; === query compiler
(defmacro with-answer (query &body body)
  `(with-gensyms ,(vars-in query #'simple?)
     ,(compile-query query `(progn ,@body))))

(defun compile-query (q body)
  (case (car q)
    (and  (compile-and (cdr q) body))
    (or   (compile-or  (cdr q) body))
    (not  (compile-not (cadr q) body))
    (lisp `(if ,(cadr q) ,body))
    (t    (compile-simple q body))))

(defun compile-simple (q body)
  (let ((fact (gensym)))
    `(dolist (,fact (db-query ',(car q)))
       (pat-match ,(cdr q) ,fact ,body nil))))

(defun compile-and (clauses body)
  (if (null clauses)
      body
      (compile-query (car clauses)
                     (compile-and (cdr clauses) body))))

(defun compile-or (clauses body)
  (if (null clauses)
      nil
      (let ((gbod (gensym))
            (vars (vars-in body #'simple?)))
        `(labels ((,gbod ,vars ,body))
           ,@(mapcar #'(lambda (cl)
                         (compile-query cl `(,gbod ,@vars)))
                     clauses)))))

(defun compile-not (q body)
  (let ((tag (gensym)))
    `(if (block ,tag
           ,(compile-query q `(return-from ,tag nil))
           t)
         ,body)))
;;; ===

;;; === query interpreter
;;(defun lookup (pred args &optional binds)
;;  (mapcan #'(lambda (x)
;;              (aif2 (match x args binds) (list it)))
;;          (db-query pred)))

;;(defmacro with-answer (query &body body)
;;  (let ((binds (gensym)))
;;    `(dolist (,binds (interpret-query ',query))
;;       (let ,(mapcar #'(lambda (v)
;;                         `(,v (binding ',v ,binds)))
;;                    (vars-in query #'atom))
;;         ,@body))))

;;(defun interpret-query (expr &optional binds)
;;  (case (car expr)   
;;    (and  (interpret-and (reverse (cdr expr)) binds))
;;    (or   (interpret-or (cdr expr) binds))
;;    (not  (interpret-not (cadr expr) binds))
;;    (t    (lookup (car expr) (cdr expr) binds))))

;;(defun interpret-and (clauses binds)
;;  (if (null clauses)
;;      (list binds)
;;      (mapcan #'(lambda (b)
;;                  (interpret-query (car clauses) b))
;;             (interpret-and (cdr clauses) binds))))
 
;;(defun interpret-or (clauses binds)
;;  (mapcan #'(lambda (c)
;;              (interpret-query c binds))
;;          clauses))
 
;;(defun interpret-not (clause binds)
;;  (if (interpret-query clause binds)
;;      nil
;;      (list binds)))
;;; ===

;;; === examples
;;(clear-db)
;;(fact painter hogarth william english)
;;(fact painter canale antonio venetian)
;;(fact painter reynolds joshua english)
;;(fact dates hogarth 1697 1772)
;;(fact dates canale 1697 1768)
;;(fact dates reynolds 1723 1792)

;;(with-answer (painter 'hogarth ?x ?y)
;;  (princ (list ?x ?y)))
;;

;;(with-answer (and (painter ?x _ _)
;;                  (dates ?x 1697 _))
;;  (princ (list ?x)))

;;(with-answer (or (dates ?x ?y 1772)
;;                 (dates ?x ?y 1792))
;;  (princ (list ?x ?y)))

;;(with-answer (and (painter ?x _ 'english)
;;                  (dates ?x ?b _)
;;                  (not (and (painter ?x2 _ 'venetian)
;;                            (dates ?x2 ?b _))))
;;  (princ ?x))

;;(with-answer (and (painter ?x _ _)
;;                  (dates ?x _ ?d)
;;                  (lisp (< 1770 ?d 1800)))
;;  (princ (list ?x ?d)))
;;; ===

;;; === nondeterminism (with CPS)
;(defparameter *cont* #'identity)
(defvar *actual-cont* #'values)
(define-symbol-macro *cont* *actual-cont*)

(defmacro =lambda (parms &body body) 
  `#'(lambda (*cont* ,@parms) ,@body))

(defmacro =defun (name parms &body body)
  (let ((f (intern (concatenate 'string
                                "=" (symbol-name name)))))
    `(progn
       (defmacro ,name ,parms
         `(,',f *cont* ,,@parms))
       (defun ,f (*cont* ,@parms) ,@body))))
 
(defmacro =bind (parms expr &body body)
  `(let ((*cont* #'(lambda ,parms ,@body))) ,expr))
    
(defmacro =values (&rest retvals)
  `(funcall *cont* ,@retvals))

(defmacro =funcall (fn &rest args)
  `(funcall ,fn *cont* ,@args))

(defmacro =apply (fn &rest args)
  `(apply ,fn *cont* ,@args))

(defparameter *paths* nil)
(defconstant failsym '@)

(defmacro choose (&rest choices)
  (if choices
      `(progn
         ,@(mapcar #'(lambda (c)
                       `(push #'(lambda () ,c) *paths*))
                   (reverse (cdr choices)))
         ,(car choices))
      '(fail)))

(defmacro choose-bind (var choices &body body)
  `(cb #'(lambda (,var) ,@body) ,choices))
 
(defun cb (fn choices)
  (if choices
     (progn
       (if (cdr choices)
           (push #'(lambda () (cb fn (cdr choices)))
                 *paths*))
       (funcall fn (car choices)))
     (fail)))
 
(defun fail ()
  (if *paths*
      (funcall (pop *paths*))
      failsym))
;;; ===

;;; === examples
;;(=defun two-numbers ()
;;  (choose-bind n1 '(0 1 2 3 4 5)
;;    (choose-bind n2 '(0 1 2 3 4 5)
;;      (=values n1 n2))))

;;(=defun parlor-trick (sum)
;;  (=bind (n1 n2) (two-numbers)
;;    (if (= (+ n1 n2) sum)
;;        `(the sum of ,n1 ,n2)
;;         (fail))))

;;(parlor-trick 9)
;;; ===

;;; === prolog impl
(defmacro with-inference (query &rest body)
  (let ((vars (vars-in query #'simple?)) (gb (gensym)))
    `(with-gensyms ,vars
       (setq *paths* nil)
       (=bind (,gb) ,(gen-query (rep_ query) nil '*paths*) ;
         (let ,(mapcar #'(lambda (v) 
                           `(,v (fullbind ,v ,gb)))
                       vars)
           ,@body)
         (fail)))))

(defun rep_ (x)
  (if (atom x) 
      (if (eq x '_) (gensym "?") x)
      (cons (rep_ (car x)) (rep_ (cdr x)))))

(defparameter *rules* nil)

(defun varsym? (x) 
  (and (symbolp x) (not (symbol-package x))))

(defun gen-query (expr binds paths)                        ;
  (case (car expr)
    (and  (gen-and (cdr expr) binds paths))                ;
    (or   (gen-or  (cdr expr) binds paths))                ;
    (not  (gen-not (cadr expr) binds paths))               ;
    (lisp (gen-lisp (cadr expr) binds))                    ;
    (is   (gen-is (cadr expr) (third expr) binds))         ;
    (cut  `(progn (setq *paths* ,paths)                    ;
                  (=values ,binds)))                       ;
    (t    `(prove (list ',(car expr) 
                        ,@(mapcar #'form (cdr expr)))
                  ,binds *paths*))))                       ;
 
(=defun prove (query binds paths)                          ;
   (choose-bind r *rules* 
     (=funcall r query binds paths)))                      ;

(defun gen-and (clauses binds paths)                       ;
  (if (null clauses)
      `(=values ,binds)
      (let ((gb (gensym)))
       `(=bind (,gb) ,(gen-query (car clauses) binds paths);
          ,(gen-and (cdr clauses) gb paths)))))            ;

(defun gen-or (clauses binds paths)                        ;
  `(choose
     ,@(mapcar #'(lambda (c) (gen-query c binds paths))    ;
               clauses)))
 
(defun gen-not (expr binds paths)                          ;
  (let ((gpaths (gensym)))
    `(let ((,gpaths *paths*))
       (setq *paths* nil)
       (choose (=bind (b) ,(gen-query expr binds paths)    ;
                 (setq *paths* ,gpaths)
                 (fail))
               (progn
                 (setq *paths* ,gpaths)
                 (=values ,binds))))))
 
(defun fullbind (x b)
  (cond ((varsym? x) (aif2 (binding x b) 
                           (fullbind it b) 
                           (gensym)))
        ((atom x) x)
        (t (cons (fullbind (car x) b) 
                 (fullbind (cdr x) b)))))

(defmacro with-binds (binds expr)
  `(let ,(mapcar #'(lambda (v) `(,v (fullbind ,v ,binds)))
                 (vars-in expr))
     ,expr))
 
(defun gen-lisp (expr binds)
  `(if (with-binds ,binds ,expr)
       (=values ,binds)
       (fail)))
 
(defun gen-is (expr1 expr2 binds)
  `(aif2 (match ,expr1 (with-binds ,binds ,expr2) ,binds)
         (=values it)
         (fail)))

(defun form (pat)
  (if (simple? pat)
      pat
      `(cons ,(form (car pat)) ,(form (cdr pat)))))

(defmacro <- (con &rest ant)
  (let ((ant (if (= (length ant) 1) 
                 (car ant) 
                 `(and ,@ant))))
    `(length (conc1f *rules* 
                     ,(rule-fn (rep_ ant) (rep_ con))))))

(defun rule-fn (ant con)
  (with-gensyms (val win fact binds paths)                 ;
    `(=lambda (,fact ,binds ,paths)                        ;
       (with-gensyms ,(vars-in (list ant con) #'simple?)
         (multiple-value-bind 
             (,val ,win) 
             (match ,fact
                    (list ',(car con) 
                          ,@(mapcar #'form (cdr con))) 
                    ,binds)
           (if ,win 
               ,(gen-query ant val paths)                  ;
               (fail)))))))
;;; ===

;;; === examples
;;(<- (painter ?x) (hungry ?x)
;;    (smells-of ?x 'turpentine))
;;(<- (hungry ?x) (or (gaunt ?x) (eats-ravenously ?x)))
;;(<- (gaunt 'raoul))
;;(<- (smells-of 'raoul 'turpentine))
;;(<- (painter 'rubens))

;;(with-inference (painter ?x)
;;  (print ?x))

;;(<- (append nil ?xs ?xs))
;;(<- (append (?x . ?xs) ?ys (?x . ?zs))
;;    (append ?xs ?ys ?zs))

;;(with-inference (append ?x '(c d) '(a b c d))
;;  (format t "Left: ~A~%" ?x))

;;(with-inference (append '(a b) ?x '(a b c d))
;; (format t "Right: ~A~%" ?x))

;;(with-inference (append '(a b) '(c d) ?x)
;;  (format t "Whole: ~A~%" ?x))

;;(with-inference (append ?x ?y '(a b c))
;;  (format t "Left: ~A Right: ~A~%" ?x ?y))


;; mutually exclusive example
;;(<- (minimum ?x ?y ?x) (lisp (<= ?x ?y)) (cut))
;;(<- (minimum ?x ?y ?y))

;;(with-inference (minimum 230 145 ?x)
;;  (print ?x))

;;(<- (not-equal ?x ?x) (cut) (fail))
;;(<- (not-equal ?x ?y))

;;(with-inference (not-equal 'a 'a)
;;  (print t))

;;(with-inference (not-equal '(a a) '(a b))
;;  (print t))

;;(<- (ordered (?x)))
;;(<- (ordered (?x ?y . ?ys))
;;    (lisp (<= ?x ?y))
;;    (ordered (?y . ?ys)))

;;(with-inference (ordered '(1 2 3))
;;  (print t))

;;(<- (factorial 0 1))
;;(<- (factorial ?n ?f)
;;    (lisp (> ?n 0))
;;    (is ?n1 (- ?n 1))
;;    (factorial ?n1 ?f1)
;;    (is ?f (* ?n ?f1)))

;;(with-inference (factorial 8 ?x)
;;  (print ?x))
;;; ===