Permalink
Switch branches/tags
Nothing to show
Find file
Fetching contributors…
Cannot retrieve contributors at this time
624 lines (479 sloc) 14.8 KB
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; My ``On Lisp'' based tool box ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(in-package :toolbox)
;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Lazy evaluation ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;
(defconstant +unforced+ (if (boundp '+unforced+)
+unforced+
(gensym "UNFORCED-")))
(defstruct delay forced closure)
(defmacro delay (expr)
(let ((self (gensym "DELAY-")))
`(let ((,self (make-delay :forced +unforced+)))
(setf (delay-closure ,self)
#'(lambda ()
(setf (delay-forced ,self) ,expr)))
,self)))
(defun force (x)
(if (delay-p x)
(if (eq (delay-forced x) +unforced+)
(funcall (delay-closure x))
(delay-forced x))
x))
;; Examples
;; (delay (+ 1 1))
;; (force (delay (+ 1 1)))
;; (defun sinc (x)
;; (let ((arg (delay (/ (sin x) x))))
;; (if (not (= 0 x))
;; (force arg)
;; 1)))
;; (map-into (make-array 10) #'sinc (mapa-b #'identity 0 2 .2))
;; ;;; Delaying input to make a function based if
;; (defun if-func (pred then else)
;; (if (force pred)
;; (force then)
;; (force else)))
;; (if-func t (delay (print 'then)) (delay (print 'else)))
;; (if-func nil (delay (print 'then)) (delay (print 'else)))
;;;;;;;;;;;;;;;;;;;;;;;
;;;; Continuations ;;;;
;;;;;;;;;;;;;;;;;;;;;;;
(setq *cont* #'identity)
(eval-when (:compile-toplevel :load-toplevel :execute)
(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)))
;; Examples
;; (macroexpand-1
;; '(=defun add1 (x) (=values (1+ x))))
;; (defun dft (tree)
;; (cond ((null tree) nil)
;; ((atom tree) (princ tree))
;; (t (dft (car tree))
;; (dft (cdr tree)))))
;; (setq *saved* nil)
;; (=defun dft-node (tree)
;; (cond ((null tree) (restrt))
;; ((atom tree) (=values tree))
;; (t (push #'(lambda () (dft-node (cdr tree)))
;; *saved*)
;; (dft-node (car tree)))))
;; (=defun restrt ()
;; (if *saved*
;; (funcall (pop *saved*))
;; (=values 'done)))
;; (=defun dft2 (tree)
;; (setq *saved* nil)
;; (=bind (node) (dft-node tree)
;; (cond ((eq node 'done) (=values nil))
;; (t (princ node)
;; (restrt)))))
;; (let ((t1 '(a (b (d c)) (c e (f i) g)))
;; (t2 '(1 (2 (3 8 7) 4 5))))
;; (dft2 t1)
;; (dft2 t2))
;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Multiprocessing ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;
(defstruct proc pri state wait)
(proclaim '(special *procs* *proc*))
(defvar *halt* (gensym))
(defvar *default-proc*
(make-proc :state #'(lambda (x)
(format t "~%>> ")
(princ (eval (read)))
(pick-process))))
(defmacro fork (expr pri)
`(prog1 ',expr
(push (make-proc
:state #'(lambda (,(gensym "FORK-"))
,expr
(pick-process))
:pri ,pri)
*procs*)))
(defmacro program (name args &body body)
`(=defun ,name ,args
(setq *procs* nil)
,@body
(catch *halt* (loop (pick-process)))))
(defun pick-process ()
(multiple-value-bind (p val) (most-urgent-process)
(setq *proc* p
*procs* (delete p *procs*))
(funcall (proc-state p) val)))
(defun most-urgent-process ()
(let ((proc1 *default-proc*) (max -1) (val1 t))
(dolist (p *procs*)
(let ((pri (proc-pri p)))
(if (> pri max)
(let ((val (or (not (proc-wait p))
(funcall (proc-wait p)))))
(when val
(setq proc1 p
max pri
val1 val))))))
(values proc1 val1)))
(defun arbitrator (test cont)
(setf (proc-state *proc*) cont
(proc-wait *proc*) test)
(push *proc* *procs*)
(pick-process))
(defmacro wait (parm test &body body)
`(arbitrator #'(lambda () ,test)
#'(lambda (,parm) ,@body)))
(defmacro yield (&body body)
`(arbitrator nil #'(lambda (,(gensym "YIELD-")) ,@body)))
(defun setpri (n) (setf (proc-pri *proc*) n))
(defun halt (&optional val) (throw *halt* val))
(defun kill (&optional obj &rest args)
(if obj
(setq *procs* (apply #'delete obj *procs* args))
(pick-process)))
;; Examples
;; (defvar *open-doors* nil)
;; (=defun pedestrian ()
;; (wait d (car *open-doors*)
;; (format t "Entering ~A~%" d)))
;; (program ped ()
;; (fork (pedestrian) 1))
;; (ped)
;; (defvar *bboard* nil)
;; (defun claim (&rest f) (push f *bboard*))
;; (defun unclaim (&rest f) (pull f *bboard* :test #'equal))
;; (defun check (&rest f) (find f *bboard* :test #'equal))
;; (=defun visitor (door)
;; (format t "Approach ~A. " door)
;; (claim 'knock door)
;; (wait d (check 'open door)
;; (format t "Enter ~A. " door)
;; (unclaim 'knock door)
;; (claim 'inside door)))
;; (=defun host (door)
;; (wait k (check 'knock door)
;; (format t "Open ~A. " door)
;; (claim 'open door)
;; (wait g (check 'inside door)
;; (format t "Close ~A.~%" door)
;; (unclaim 'open door))))
;; (program ballet ()
;; (fork (visitor 'door1) 1)
;; (fork (host 'door1) 1)
;; (fork (visitor 'door2) 1)
;; (fork (host 'door2) 1))
;; (ballet)
;; (=defun capture (city)
;; (take city)
;; (setpri 1)
;; (yield
;; (fortify city)))
;; (=defun plunder (city)
;; (loot city)
;; (ransom city))
;; (defun take (c) (format t "Liberating ~A.~%" c))
;; (defun fortify (c) (format t "Rebuilding ~A.~%" c))
;; (defun loot (c) (format t "Nationalizing ~A.~%" c))
;; (defun ransom (c) (format t "Refinancing ~A.~%" c))
;; (program barbarians ()
;; (fork (capture 'rome) 100)
;; (fork (plunder 'rome) 98))
;; (barbarians)
;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Nondeterminism ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;
(defparameter *paths* nil)
(defconstant failsym '@)
(eval-when (:compile-toplevel :load-toplevel :execute)
(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 do2 (x)
;; (choose (+ x 2) (* x 2) (expt x 2)))
;; (do2 3)
;; (fail)
;; (fail)
;; (fail)
;; (choose-bind x '(marrakesh strambourg vegas)
;; (format nil "Let's go to ~A." x))
;; (fail)(fail)(fail)
;; (=defun parlor-trick (sum)
;; (=bind (n1 n2) (two-numbers)
;; (if (= (+ n1 n2) sum)
;; `(the sum of ,n1 ,n2)
;; (fail))))
;; (=defun two-numbers ()
;; (choose-bind n1 '(0 1 2 3 4 5)
;; (choose-bind n2 '(0 1 2 3 4 5)
;; (=values n1 n2))))
;; (parlor-trick 5)
;;;;;;;;;;;;;
;;;; ATN ;;;;
;;;;;;;;;;;;;
(defmacro defnode (name &rest arcs)
`(=defun ,name (pos regs) (choose ,@arcs)))
(defmacro down (sub next &rest cmds)
`(=bind (* pos regs) (,sub pos (cons nil regs))
(,next pos ,(compile-cmds cmds))))
(defmacro cat (cat next &rest cmds)
`(if (= (length *sent*) pos)
(fail)
(let ((* (nth pos *sent*)))
(if (member ',cat (types *))
(,next (1+ pos) ,(compile-cmds cmds))
(fail)))))
(defmacro jump (next &rest cmds)
`(,next pos ,(compile-cmds cmds)))
(defun compile-cmds (cmds)
(if (null cmds)
'regs
`(,@(car cmds) ,(compile-cmds (cdr cmds)))))
(defmacro up (expr)
`(let ((* (nth pos *sent*)))
(=values ,expr pos (cdr regs))))
(defmacro getr (key &optional (regs 'regs))
`(let ((result (cdr (assoc ',key (car ,regs)))))
(if (cdr result) result (car result))))
(defmacro set-register (key val regs)
`(cons (cons (cons ,key ,val) (car ,regs))
(cdr ,regs)))
(defmacro setr (key val regs)
`(set-register ',key (list ,val) ,regs))
(defmacro pushr (key val regs)
`(set-register ',key
(cons ,val (cdr (assoc ',key (car ,regs))))
,regs))
(defmacro with-parses (node sent &body body)
(with-gensyms (pos regs "WITH-PARSES-")
`(progn
(setq *sent* ,sent)
(setq *paths* nil)
(=bind (parse ,pos ,regs) (,node 0 '(nil))
(if (= ,pos (length *sent*))
(progn ,@body (fail))
(fail))))))
;; Examples
;; (compile-cmds '((setr a b) (setr c d)))
;; (defun types (w)
;; (cdr (assoc w '((spot noun) (runs verb)))))
;; (with-parses s '(spot runs)
;; (format t "Parsing: ~A~%" parse))
;; (defun types (word)
;; (case word
;; ((do does did) '(aux v))
;; ((time times) '(n v))
;; ((fly flies) '(n v))
;; ((like) '(v prep))
;; ((liked likes) '(v))
;; ((a an the) '(det))
;; ((arrow arrows) '(n))
;; ((i you he she him her it) '(pron))))
;; (defnode mods
;; (cat n mods/n
;; (setr mods *)))
;; (defnode mods/n
;; (cat n mods/n
;; (pushr mods *))
;; (up `(n-group ,(getr mods))))
;; (defnode np
;; (cat det np/det
;; (setr det *))
;; (jump np/det
;; (setr det nil))
;; (cat pron pron
;; (setr n *)))
;; (defnode pron
;; (up `(np (pronoun ,(getr n)))))
;; (defnode np/det
;; (down mods np/mods
;; (setr mods *))
;; (jump np/mods
;; (setr mods nil)))
;; (defnode np/mods
;; (cat n np/n
;; (setr n *)))
;; (defnode np/n
;; (up `(np (det ,(getr det))
;; (modifiers ,(getr nods))
;; (noun ,(getr n))))
;; (down pp np/pp
;; (setr pp *)))
;; (defnode np/pp
;; (up `(np (det ,(getr det))
;; (modifiers ,(getr mods))
;; (noun ,(getr n))
;; ,(getr pp))))
;; (defnode pp
;; (cat prep pp/prep
;; (setr prep *)))
;; (defnode pp/prep
;; (down np pp/np
;; (setr op *)))
;; (defnode pp/np
;; (up `(pp (prep ,(getr prep))
;; (obj ,(getr op)))))
;; (defnode s
;; (down np s/subj
;; (setr mood 'decl)
;; (setr subj *))
;; (cat v v
;; (setr mood 'imp)
;; (setr subj '(np (pron you)))
;; (setr aux nil)
;; (setr v *)))
;; (defnode s/subj
;; (cat v v
;; (setr aux nil)
;; (setr v *)))
;; (defnode v
;; (up `(s (mood ,(getr mood))
;; (subj ,(getr subj))
;; (vcl (aux ,(getr aux))
;; (v ,(getr v)))))
;; (down np s/obj
;; (setr obj *)))
;; (defnode s/obj
;; (up `(s (mood ,(getr mood))
;; (subj ,(getr subj))
;; (vcl (aux ,(getr aux))
;; (v ,(getr v)))
;; (obj ,(getr obj)))))
;; (with-parses np '(a time fly like him)
;; (pprint parse))
;; (with-parses s '(time flies like an arrow)
;; (pprint parse))
;; 1
;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Query Compiler ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;
(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))
;; An interpreter implementation
;; (defmacro do-answers (query &body body)
;; (let ((binds (gensym "DO-ANSWERS-")))
;; `(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)))
;; (defun lookup (pred args &optional binds)
;; (mapcan #'(lambda (x)
;; (aif2 (match x args binds) (list it)))
;; (db-query pred)))
;;; Compiled implementation
;; (with-compilation-unit (:override nil)
(defmacro do-answers (query &body body)
`(with-gensyms ,(append1 (vars-in query #'simple?) "DO-ANSWERS-")
,(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 "COMPILE-SIMPLE-")))
`(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 "COMPILE-OR-"))
(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 "COMPILE-NOT-")))
`(if (block ,tag
,(compile-query q `(return-from ,tag nil))
t)
,body))) ;;)
;; 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)
;; (do-answers (painter hogarth ?x ?y)
;; (princ (list ?x ?y)))
;; (do-answers (and (painter ?x _ _)
;; (dates ?x 1697 _))
;; (princ (list ?x)))
;; (do-answers (and (painter ?x _ _)
;; (dates ?x _ ?d)
;; (lisp (< 1770 ?d 1800)))
;; (princ (list ?x ?d)))