; -*-mode:lisp;package:yaq;readtable:lm-*-. Program: YAQ - Yet Another QLOG. ; Copyright (C) Mats Carlsson 1982. ; ; This interpreter runs at about 500 LIPS on a KL-10. No significant ; time difference between array and list representation of the trail. ; ; Fuller documentation in a (partly obsolete) Upmail report. ; When you talk to PROLOG you should use the toplevel function YAQ. ; It accepts the following syntax: ; ; ( + * ) means PROVE. ; ( + * ) means ASSERT. ; ( = * ) means LIST. ; ( - * ) means RETRACT. ; ! means EVALUATE. ; ; Another way of asserting is to use the DEFINE form. ; ; To make a LISP function callable from PROLOG, perform ; (DEFPROP function (COMMAND) PROLOG-DEF), or ; (DEFPROP function (PREDICATE) PROLOG-DEF). ; ; To access (read only!) a PROLOG variable from LISP, use the THE macro. ; Prolog variables begin with ?. ; ; The evaluable predicate IS is the normal way of getting write access to ; Prolog variables: ; (IS

) ;-----------------------------------------------------------------------------; ; Example append program: ; ((append nil ?l ?l) +) ; ((append (?x . ?l1) ?l2 (?x . ?l3)) + (append ?l1 ?l2 ?l3)) ; ; Then to get all X Y which append to (1 2 3) ask this question: ; (+ (append ?x ?y (1 2 3))) #-NIL (declare (macros t)) (eval-when (eval compile) (defvar *trail-datatype* 'cons) ;tested at compile time ) (eval-when (compile #+NIL EVAL #+(OR NIL LISPM) LOAD) #+MacLisp (fixsw t) (special contgoals superframe subframe exitframe goal frameno port trail the-env the-relation) ;; #+Maclisp (setq defmacro-for-compiling ()) ) #+(OR LispM NIL) (defmacro defalias (label arglist definition) `(defsubst ,label ,arglist (,definition ,@arglist))) #+MacLisp (defmacro defalias (label arglist definition) `(progn 'compile (defun ,label ,arglist (,definition ,@arglist)) (eval-when (compile) (defprop ,label ((lambda (form) (values (cons ',definition (cdr form)) t))) source-trans)))) #+(or MacLisp nil) (defmacro incf (x) `(setq ,x (1+ ,x))) #+(or MacLisp nil) (defmacro decf (x) `(setq ,x (1- ,x))) #+MacLisp (defmacro neq (x y) `(not (eq ,x ,y))) #+(or MacLisp nil) (defalias nlistp (obj) atom) (defalias getprop (symbol propname) get) ; (variable-p symbol) => t iff symbol's pname starts with "?". #+Maclisp (defmacro variable-p (x) `(and (symbolp ,x) (= #/? (getcharn ,x 1)))) ; Old def. ;(defmacro variable-p (x) ; `(and (symbolp ,x) (= #/? (lsh (car (pnget ,x 7)) -29)))) #+LispM (defsubst variable-p (x) (and (symbolp x) (string-equal x "?" 0 0 1))) #+NIL (defmacro variable-p (x) `(and (symbolp ,x) (= #/? (char-code (char (get-pname ,x) 0))))) #+LispM (defun prompt-y-n (msg) (format t "~%~A" msg) (y-or-n-p)) #+MacLisp (defun prompt-y-n (msg) (unwind-protect (progn (format t "~%~A" msg) (clear-input t) (sstatus linmode nil) (y-or-n-p)) (sstatus linmode t))) #+NIL (defun prompt-y-n (msg) (y-or-n-p msg)) #+MacLisp (defmacro make-array (&rest dims) `(*array () t ,@dims)) #+MacLisp (defmacro aref (array &rest is) `(arraycall t ,array ,@is)) #+Maclisp (defmacro array-grow (array new-size) `(*rearray ,array t ,new-size)) #+maclisp (defun simple-prompt-and-read (msg) (format t "~%~A" msg) (read)) #+nil (defun simple-prompt-and-read (msg) (si:read-with-prompt msg)) #+lispm (defun simple-prompt-and-read (msg) (format t "~%~A" msg) (read)) ;; end of system-dependant code. (defun nconc1 (list element) (nconc list (list element))) (defun addprop-unique (atom value prop) (putprop atom (cons value (delq value (getprop atom prop))) prop)) (defmacro define (the-relation &rest clauses) `(let ((the-relation ',the-relation) (clauses ',clauses)) (putprop the-relation (list 'relation) 'prolog-def) (putprop the-relation () 'prolog-vars) (mapc #'(lambda (clause) (cond ((eq the-relation (caar clause)) (assert the-relation (internalize clause) t)) (t (format t "~%~S - invalid clause syntax." clause) (break define)))) clauses) the-relation)) (defun yaq () (do ((form--)) (()) (setq form-- (simple-prompt-and-read "Yaq> ")) (putprop 'prolog-top-level () 'prolog-vars) (cond ((eq form-- '!) (print (eval (simple-prompt-and-read "Lisp> ")))) ((eq (car form--) '+) (prove-internalize 'prolog-top-level (cdr form--))) ((eq (cadr form--) '+) (prove-internalize (caar form--) `((assertz ,(car form--) ,@(cddr form--))))) ((eq (cadr form--) '=) (prove-internalize 'prolog-top-level `((clause ,(car form--) ,@(cddr form--))))) ((eq (cadr form--) '-) (prove-internalize 'prolog-top-level `((retract ,(car form--) ,@(cddr form--))))) (t (format t "~%?Invalid Prolog syntax."))))) (defun prolog-top-level (env) (mapc #'(lambda (p) (cond ((getprop (car p) 'anonymous-var)) (t (format t "~%~S = ~S" (car p) (cdr p))))) (nreverse (lispenv (cdr env)))) (cond ((and exitframe (prompt-y-n "More?")) 'redo) (exitframe 'fail) (t (format t "~%Yes") 'fail))) ;-----------------------------------------------------------------------------; ; Data structure primitives. #.(caseq *trail-datatype* ;Defining TRAIL (cons '(eval-when (compile eval) (defmacro trail-init () `(setq trail (list nil))) (defmacro trail (loc) `(setq trail (cons ,loc trail))) (defmacro untrail () `(prog1 (car trail) (setq trail (cdr trail)))))) (array '(eval-when (load compile eval) (defvar *trail-size* 10000.) (defvar trail-array (make-array *trail-size*)) (eval-when (compile eval) (defmacro trail-init () `(setq trail 0)) (defmacro trail (loc) `(progn (incf trail) (cond ((< trail *trail-size*)) (t (setq *trail-size* (* 2 *trail-size*)) (setq trail-array (array-grow trail-array *trail-size*)))) (setf (aref trail-array trail) ,loc))) (defmacro untrail () `(prog1 (aref trail-array trail) (decf trail))))))) ;Defining ENVIRONMENT (defmacro e-create (relation) `(mapcar #'(lambda(x) (list x '?)) (getprop ,relation 'prolog-vars))) (defalias e-id (environment) car) (defmacro instant (x x-e y y-e) `(cond ((and (eq ,x ,y) (eq ,x-e ,y-e))) (t (setq ,x (cdr (assq ,x (cdr ,x-e)))) (trail ,x) (rplaca ,x ,y) (rplacd ,x ,y-e)))) ;Defining FRAMES (defmacro f-create (goal goal-e) `(cons nil (cons (cons ,goal ,goal-e) (cons contgoals (cons (cons (incf frameno) (e-create (car ,goal))) (cons trail (cdr (getprop (car ,goal) 'prolog-def)))))))) ; ``(nil ,(cons ,goal ,goal-e) ,contgoals ,(cons (incf frameno) (e-create (car ,goal))) ,trail ,@(cdr (getprop (car ,goal) 'prolog-def)))) (defmacro f-body (frame) `(caddr (cdddr ,frame))) (defalias f-body-env (frame) cadddr) (defalias f-continuation (frame) caddr) (defalias f-goal-env (frame) cdadr) (defalias f-goal (frame) caadr) (defmacro f-id (frame) `(caar (cdddr ,frame))) (defmacro f-trail (frame) `(cadr (cdddr ,frame))) (defmacro f-make-determinate (frame) `(rplacd (cddddr ,frame) nil)) (defmacro f-pop (stk) `(prog1 ,stk (setq ,stk (car ,stk)))) (defmacro f-push (frame stk) `(setq ,stk (rplaca ,frame ,stk)))) ;-----------------------------------------------------------------------------; ; The theorem prover. (defun assert (label clause last-p) (let ((def (getprop label 'prolog-def))) (caseq (car def) (relation (cond (last-p (nconc1 def clause)) (t (push clause (cdr def))))) (t (putprop label `(relation ,clause) 'prolog-def))))) (defun backtrack () (prog (undolst clause) (setq undolst (f-trail subframe)) ;Undoing other alts' bindings. lopa(cond ((neq trail undolst) (rplacd (untrail) nil) (go lopa))) ;Get next alternative. (cond ((null (setq clause (f-body subframe))) (return 'fail))) (delq clause subframe) ;Does the goal match a clause? (cond ((unify (f-goal subframe) (f-goal-env subframe) (car clause) (f-body-env subframe)) ;Yes. (setq contgoals (cdr clause)) (return (righttrack))) ;No. Try some other clause. (t (go lopa))))) (defun cut () (prog (frame superid) ;First, cut ancestors including the one carrying begin-env. (setq frame exitframe superid (f-id subframe)) (f-make-determinate subframe) lopa(cond ((and frame (< superid (f-id frame))) (f-make-determinate (f-pop frame)) (go lopa))))) (defmacro dereference (label x x-e) `(and (variable-p ,x) (cdr (setq temp (cdr (assq ,x (cdr ,x-e))))) (setq ,x (car temp)) (setq ,x-e (cdr temp)) (go ,label))) (defun lispenv (env) (cond ((null env) ()) ((cddar env) (cons (cons (caar env) (realization (cadar env) (cddar env))) (lispenv (cdr env)))) (t (lispenv (cdr env))))) (defun prove-internalize (the-relation s) (gensym '?) (prove (internalize s))) (defun prove (contgoals) (prog (goal port frameno trail superframe subframe exitframe) ; (setq frameno 0) (trail-init) (setq port (righttrack)) (setq subframe (f-create '(prolog-top-level) nil)) prove (setq port (caseq port (call (let ((the-goal goal) (the-env (f-body-env subframe)) temp) (prog () derefg (dereference derefg the-goal the-env) (return (cond ((caseq (car (getprop (car the-goal) 'prolog-def)) (relation (f-push subframe superframe) (setq subframe (f-create the-goal the-env)) nil) (command (eval the-goal) t) (predicate (eval the-goal)) (t (format t "~%?PROLOG can't handle ~S" (car the-goal)) (break "U.D.R."))) (righttrack)) (t (backtrack))))))) (exit (f-push subframe exitframe) (setq subframe (f-pop superframe)) (righttrack)) (redo (cond ((null exitframe) (backtrack)) ((> (f-id subframe) (f-id exitframe)) (backtrack)) (t (f-push subframe superframe) (setq subframe (f-pop exitframe)) 'redo))) (fail (cond ((null superframe) (return nil)) (t (setq subframe (f-pop superframe)) 'redo))) (t (break WEIRD-PORT)))) (go prove))) (defun realization (x x-e) (prog (res temp) derefx (dereference derefx x x-e) (cond ((nlistp x) (return (nconc res x))) (t (setq res (nconc1 res (realization (car x) x-e))) (setq x (cdr x)) (go derefx))))) (defun righttrack nil (cond (contgoals (setq goal (car contgoals)) (setq contgoals (cdr contgoals)) 'call) (superframe (setq contgoals (f-continuation subframe)) 'exit) (t (prolog-top-level (f-body-env subframe))))) (defun unify (x x-e y y-e) (*catch 'unify (unify1 x x-e y y-e) t)) (defun unify1 (x x-e y y-e) (prog (temp) derefx (dereference derefx x x-e) derefy (dereference derefy y y-e) (cond ((variable-p x) (instant x x-e y y-e)) ((variable-p y) (instant y y-e x x-e)) ((nlistp x) (or (equal x y) (*throw 'unify nil))) ((nlistp y) (*throw 'unify nil)) (t (unify1 (car x) x-e (car y) y-e) (setq x (cdr x) y (cdr y)) (go derefx))))) (defun internalize (s) (cond ((eq s '?) (setq s (intern (gensym (length (getprop the-relation 'prolog-vars))))) (putprop s t 'anonymous-var) (addprop-unique the-relation s 'prolog-vars) s) ((variable-p s) (addprop-unique the-relation s 'prolog-vars) s) ((nlistp s) s) (t (cons (internalize (car s)) (internalize (cdr s)))))) ;-------------------------------------------------------------------------------; ; Pre-defined relations. (defprop variable-p (predicate) prolog-def) (defprop < (predicate) prolog-def) (defprop = (predicate) prolog-def) (defprop > (predicate) prolog-def) (defprop progn (predicate) prolog-def) (defprop cut (command) prolog-def) (defprop princ (command) prolog-def) (defprop prin1 (command) prolog-def) (defprop print (command) prolog-def) (defprop terpri (command) prolog-def) (defprop format (command) prolog-def) (defmacro the (var) `(realization ',var the-env)) (define is ((is ?var ?form) (progn (unify '?var the-env (eval (realization (the ?form) the-env)) the-env)))) (define clause ;Tricky - First time it modifies ((clause . ?CL) ;self and fails. (progn (nconc (f-body-env subframe) (e-create (caar (the ?CL)))) (nconc subframe (mapcar #'(lambda(x) `((clause ,@x))) (cdr (getprop (caar (the ?CL)) 'prolog-def)))) nil))) (define retract ;Tricky - First time it modifies ((retract . ?CL) ;self and fails. (progn (nconc (f-body-env subframe) (e-create (caar (the ?CL)))) (nconc subframe (mapcar #'(lambda(x) `((retract ,@x) (progn (delq ',x (getprop ',(caar (the ?CL)) 'prolog-def)) t))) (cdr (getprop (caar (the ?CL)) 'prolog-def)))) nil))) (define fail) (define asserta ((asserta . ?R) (progn (let ((clause (the ?R))) (assert (caar clause) clause nil)) nil))) (define assertz ((assertz . ?R) (progn (let ((clause (the ?R))) (assert (caar clause) clause t)) nil)))