turner@imagen.UUCP (D'arc Angel) (01/19/87)
X (return nil)))
X (setq old (get-ce-var-bind (car z)))
X (cond ((null old)
X (%warn '|modify: first argument must be an element variable|
X (car z))
X (return nil)))
X (remove-from-wm old)
X (setq z (cdr z))
X ($reset)
X copy (and (atom old) (go fin))
X ($change (car old))
X (setq old (cdr old))
X (go copy)
X fin (eval-args z)
X ($assert)))
X
X(defun bind fexpr (z)
X (prog (val)
X (cond ((not *in-rhs*)
X (%warn '|cannot be called at top level| 'bind)
X (return nil)))
X (cond ((< (length z) 1.)
X (%warn '|bind: wrong number of arguments to| z)
X (return nil))
X ((not (symbolp (car z)))
X (%warn '|bind: illegal argument| (car z))
X (return nil))
X ((= (length z) 1.) (setq val (gensym)))
X (t ($reset)
X (eval-args (cdr z))
X (setq val ($parameter 1.))))
X (make-var-bind (car z) val)))
X
X(defun cbind fexpr (z)
X (cond ((not *in-rhs*)
X (%warn '|cannot be called at top level| 'cbind))
X ((not (= (length z) 1.))
X (%warn '|cbind: wrong number of arguments| z))
X ((not (symbolp (car z)))
X (%warn '|cbind: illegal argument| (car z)))
X ((null *last*)
X (%warn '|cbind: nothing added yet| (car z)))
X (t (make-ce-var-bind (car z) *last*))))
X
X(defun remove fexpr (z)
X (prog (old)
X (and (not *in-rhs*)(return (top-level-remove z)))
X top (and (atom z) (return nil))
X (setq old (get-ce-var-bind (car z)))
X (cond ((null old)
X (%warn '|remove: argument not an element variable| (car z))
X (return nil)))
X (remove-from-wm old)
X (setq z (cdr z))
X (go top)))
X
X(defun call fexpr (z)
X (prog (f)
X (setq f (car z))
X ($reset)
X (eval-args (cdr z))
X (funcall f)))
X
X(defun write fexpr (z)
X (prog (port max k x needspace)
X (cond ((not *in-rhs*)
X (%warn '|cannot be called at top level| 'write)
X (return nil)))
X ($reset)
X (eval-args z)
X (setq k 1.)
X (setq max ($parametercount))
X (cond ((< max 1.)
X (%warn '|write: nothing to print| z)
X (return nil)))
X (setq port (default-write-file))
X (setq x ($parameter 1.))
X (cond ((and (symbolp x) ($ofile x))
X (setq port ($ofile x))
X (setq k 2.)))
X (setq needspace t)
X la (and (> k max) (return nil))
X (setq x ($parameter k))
X (cond ((eq x '|=== C R L F ===|)
X (setq needspace nil)
X (terpri port))
X ((eq x '|=== R J U S T ===|)
X (setq k (+ 2 k))
X (do-rjust ($parameter (1- k)) ($parameter k) port))
X ((eq x '|=== T A B T O ===|)
X (setq needspace nil)
X (setq k (1+ k))
X (do-tabto ($parameter k) port))
X (t
X (and needspace (princ '| | port))
X (setq needspace t)
X (princ x port)))
X (setq k (1+ k))
X (go la)))
X
X(defun default-write-file ()
X (prog (port)
X (setq port t)
X (cond (*write-file*
X (setq port ($ofile *write-file*))
X (cond ((null port)
X (%warn '|write: file has been closed| *write-file*)
X (setq port t)))))
X (return port)))
X
X(defun do-rjust (width value port)
X (prog (size)
X (cond ((eq value '|=== T A B T O ===|)
X (%warn '|rjust cannot precede this function| 'tabto)
X (return nil))
X ((eq value '|=== C R L F ===|)
X (%warn '|rjust cannot precede this function| 'crlf)
X (return nil))
X ((eq value '|=== R J U S T ===|)
X (%warn '|rjust cannot precede this function| 'rjust)
X (return nil)))
X (setq size (flatc value (1+ width)))
X (cond ((> size width)
X (princ '| | port)
X (princ value port)
X (return nil)))
X (do k (- width size) (1- k) (not (> k 0)) (princ '| | port))
X (princ value port)))
X
X(defun do-tabto (col port)
X (prog (pos)
X (setq pos (1+ (nwritn port)))
X (cond ((> pos col)
X (terpri port)
X (setq pos 1)))
X (do k (- col pos) (1- k) (not (> k 0)) (princ '| | port))
X (return nil)))
X
X
X(defun halt nil
X (cond ((not *in-rhs*)
X (%warn '|cannot be called at top level| 'halt))
X (t (setq *halt-flag* t))))
X
X(defun build fexpr (z)
X (prog (r)
X (cond ((not *in-rhs*)
X (%warn '|cannot be called at top level| 'build)
X (return nil)))
X ($reset)
X (build-collect z)
X (setq r (unflat (use-result-array)))
X (and *build-trace* (funcall *build-trace* r))
X (compile-production (car r) (cdr r))))
X
X(defun openfile fexpr (z)
X (prog (file mode id)
X ($reset)
X (eval-args z)
X (cond ((not (equal ($parametercount) 3.))
X (%warn '|openfile: wrong number of arguments| z)
X (return nil)))
X (setq id ($parameter 1))
X (setq file ($parameter 2))
X (setq mode ($parameter 3))
X (cond ((not (symbolp id))
X (%warn '|openfile: file id must be a symbolic atom| id)
X (return nil))
X ((null id)
X (%warn '|openfile: 'nil' is reserved for the terminal| nil)
X (return nil))
X ((or ($ifile id)($ofile id))
X (%warn '|openfile: name already in use| id)
X (return nil)))
X (cond ((eq mode 'in) (putprop id (infile file) 'inputfile))
X ((eq mode 'out) (putprop id (outfile file) 'outputfile))
X (t (%warn '|openfile: illegal mode| mode)
X (return nil)))
X (return nil)))
X
X(defun $ifile (x)
X (cond ((symbolp x) (get x 'inputfile))
X (t nil)))
X
X(defun $ofile (x)
X (cond ((symbolp x) (get x 'outputfile))
X (t nil)))
X
X
X(defun closefile fexpr (z)
X ($reset)
X (eval-args z)
X (mapc (function closefile2) (use-result-array)))
X
X(defun closefile2 (file)
X (prog (port)
X (cond ((not (symbolp file))
X (%warn '|closefile: illegal file identifier| file))
X ((setq port ($ifile file))
X (close port)
X (remprop file 'inputfile))
X ((setq port ($ofile file))
X (close port)
X (remprop file 'outputfile)))
X (return nil)))
X
X(defun default fexpr (z)
X (prog (file use)
X ($reset)
X (eval-args z)
X (cond ((not (equal ($parametercount) 2.))
X (%warn '|default: wrong number of arguments| z)
X (return nil)))
X (setq file ($parameter 1))
X (setq use ($parameter 2))
X (cond ((not (symbolp file))
X (%warn '|default: illegal file identifier| file)
X (return nil))
X ((not (memq use '(write accept trace)))
X (%warn '|default: illegal use for a file| use)
X (return nil))
X ((and (memq use '(write trace))
X (not (null file))
X (not ($ofile file)))
X (%warn '|default: file has not been opened for output| file)
X (return nil))
X ((and (eq use 'accept)
X (not (null file))
X (not ($ifile file)))
X (%warn '|default: file has not been opened for input| file)
X (return nil))
X ((eq use 'write) (setq *write-file* file))
X ((eq use 'accept) (setq *accept-file* file))
X ((eq use 'trace) (setq *trace-file* file)))
X (return nil)))
X
X
X
X;;; RHS Functions
X
X(defun accept fexpr (z)
X (prog (port arg)
X (cond ((> (length z) 1.)
X (%warn '|accept: wrong number of arguments| z)
X (return nil)))
X (setq port t)
X (cond (*accept-file*
X (setq port ($ifile *accept-file*))
X (cond ((null port)
X (%warn '|accept: file has been closed| *accept-file*)
X (return nil)))))
X (cond ((= (length z) 1)
X (setq arg ($varbind (car z)))
X (cond ((not (symbolp arg))
X (%warn '|accept: illegal file name| arg)
X (return nil)))
X (setq port ($ifile arg))
X (cond ((null port)
X (%warn '|accept: file not open for input| arg)
X (return nil)))))
X (cond ((= (tyipeek port) -1.)
X ($value 'end-of-file)
X (return nil)))
X (flat-value (read port))))
X
X(defun flat-value (x)
X (cond ((atom x) ($value x))
X (t (mapc (function flat-value) x))))
X
X(defun span-chars (x prt)
X (do ch (tyipeek prt) (tyipeek prt) (not (member ch x)) (readc prt)))
X
X(defun acceptline fexpr (z)
X (prog (c def arg port)
X (setq port t)
X (setq def z)
X (cond (*accept-file*
X (setq port ($ifile *accept-file*))
X (cond ((null port)
X (%warn '|acceptline: file has been closed|
X *accept-file*)
X (return nil)))))
X (cond ((> (length def) 0)
X (setq arg ($varbind (car def)))
X (cond ((and (symbolp arg) ($ifile arg))
X (setq port ($ifile arg))
X (setq def (cdr def))))))
X (span-chars '(9. 41.) port)
X; (setq c (tyi port)) no idea why this is here
X (cond ((memq (tyipeek port) '(-1. 10.))
X (mapc (function $change) def)
X (return nil)))
X l: (flat-value (read port))
X (span-chars '(9. 41.) port)
X (cond ((not (memq (tyipeek port) '(-1. 10.))) (go l:)))))
X
X(defun substr fexpr (l)
X (prog (k elm start end)
X (cond ((not (= (length l) 3.))
X (%warn '|substr: wrong number of arguments| l)
X (return nil)))
X (setq elm (get-ce-var-bind (car l)))
X (cond ((null elm)
X (%warn '|first argument to substr must be a ce var|
X l)
X (return nil)))
X (setq start ($varbind (cadr l)))
X (setq start ($litbind start))
X (cond ((not (numberp start))
X (%warn '|second argument to substr must be a number|
X l)
X (return nil)))
X (comment |if a variable is bound to INF, the following|
X |will get the binding and treat it as INF is|
X |always treated. that may not be good|)
X (setq end ($varbind (caddr l)))
X (cond ((eq end 'inf) (setq end (length elm))))
X (setq end ($litbind end))
X (cond ((not (numberp end))
X (%warn '|third argument to substr must be a number|
X l)
X (return nil)))
X (comment |this loop does not check for the end of elm|
X |instead it relies on cdr of nil being nil|
X |this may not work in all versions of lisp|)
X (setq k 1.)
X la (cond ((> k end) (return nil))
X ((not (< k start)) ($value (car elm))))
X (setq elm (cdr elm))
X (setq k (1+ k))
X (go la)))
X
X
X(defun compute fexpr (z) ($value (ari z)))
X
X; arith is the obsolete form of compute
X(defun arith fexpr (z) ($value (ari z)))
X
X(defun ari (x)
X (cond ((atom x)
X (%warn '|bad syntax in arithmetic expression | x)
X 0.)
X ((atom (cdr x)) (ari-unit (car x)))
X ((eq (cadr x) '+)
X (plus (ari-unit (car x)) (ari (cddr x))))
X ((eq (cadr x) '-)
X (difference (ari-unit (car x)) (ari (cddr x))))
X ((eq (cadr x) '*)
X (times (ari-unit (car x)) (ari (cddr x))))
X ((eq (cadr x) '//)
X (quotient (ari-unit (car x)) (ari (cddr x))))
X ((eq (cadr x) '\\)
X (mod (fix (ari-unit (car x))) (fix (ari (cddr x)))))
X (t (%warn '|bad syntax in arithmetic expression | x) 0.)))
X
X(defun ari-unit (a)
X (prog (r)
X (cond ((dtpr a) (setq r (ari a)))
X (t (setq r ($varbind a))))
X (cond ((not (numberp r))
X (%warn '|bad value in arithmetic expression| a)
X (return 0.))
X (t (return r)))))
X
X(defun genatom nil ($value (gensym)))
X
X(defun litval fexpr (z)
X (prog (r)
X (cond ((not (= (length z) 1.))
X (%warn '|litval: wrong number of arguments| z)
X ($value 0)
X (return nil))
X ((numberp (car z)) ($value (car z)) (return nil)))
X (setq r ($litbind ($varbind (car z))))
X (cond ((numberp r) ($value r) (return nil)))
X (%warn '|litval: argument has no literal binding| (car z))
X ($value 0)))
X
X
X(defun rjust fexpr (z)
X (prog (val)
X (cond ((not (= (length z) 1.))
X (%warn '|rjust: wrong number of arguments| z)
X (return nil)))
X (setq val ($varbind (car z)))
X (cond ((or (not (numberp val)) (< val 1.) (> val 127.))
X (%warn '|rjust: illegal value for field width| val)
X (return nil)))
X ($value '|=== R J U S T ===|)
X ($value val)))
X
X(defun crlf fexpr (z)
X (cond (z (%warn '|crlf: does not take arguments| z))
X (t ($value '|=== C R L F ===|))))
X
X(defun tabto fexpr (z)
X (prog (val)
X (cond ((not (= (length z) 1.))
X (%warn '|tabto: wrong number of arguments| z)
X (return nil)))
X (setq val ($varbind (car z)))
X (cond ((or (not (numberp val)) (< val 1.) (> val 127.))
X (%warn '|tabto: illegal column number| z)
X (return nil)))
X ($value '|=== T A B T O ===|)
X ($value val)))
X
X
X
X;;; Printing WM
X
X(defun ppwm fexpr (avlist)
X (prog (next a)
X (setq *filters* nil)
X (setq next 1.)
X l: (and (atom avlist) (go print))
X (setq a (car avlist))
X (setq avlist (cdr avlist))
X (cond ((eq a '^)
X (setq next (car avlist))
X (setq avlist (cdr avlist))
X (setq next ($litbind next))
X (and (floatp next) (setq next (fix next)))
X (cond ((or (not (numberp next))
X (> next *size-result-array*)
X (> 1. next))
X (%warn '|illegal index after ^| next)
X (return nil))))
X ((variablep a)
X (%warn '|ppwm does not take variables| a)
X (return nil))
X (t (setq *filters* (cons next (cons a *filters*)))
X (setq next (1+ next))))
X (go l:)
X print (mapwm (function ppwm2))
X (terpri)
X (return nil)))
X
X(defun ppwm2 (elm-tag)
X (cond ((filter (car elm-tag)) (terpri) (ppelm (car elm-tag) t))))
X
X(defun filter (elm)
X (prog (fl indx val)
X (setq fl *filters*)
X top (and (atom fl) (return t))
X (setq indx (car fl))
X (setq val (cadr fl))
X (setq fl (cddr fl))
X (and (ident (nth (1- indx) elm) val) (go top))
X (return nil)))
X
X(defun ident (x y)
X (cond ((eq x y) t)
X ((not (numberp x)) nil)
X ((not (numberp y)) nil)
X ((=alg x y) t)
X (t nil)))
X
X; the new ppelm is designed especially to handle literalize format
X; however, it will do as well as the old ppelm on other formats
X
X(defun ppelm (elm port)
X (prog (ppdat sep val att mode lastpos)
X (princ (creation-time elm) port)
X (princ '|: | port)
X (setq mode 'vector)
X (setq ppdat (get (car elm) 'ppdat))
X (and ppdat (setq mode 'a-v))
X (setq sep '|(|)
X (setq lastpos 0)
X (do
X ((curpos 1 (1+ curpos)) (vlist elm (cdr vlist)))
X ((atom vlist) nil)
X (setq val (car vlist))
X (setq att (assoc curpos ppdat))
X (cond (att (setq att (cdr att)))
X (t (setq att curpos)))
X (and (symbolp att) (is-vector-attribute att) (setq mode 'vector))
X (cond ((or (not (null val)) (eq mode 'vector))
X (princ sep port)
X (ppval val att lastpos port)
X (setq sep '| |)
X (setq lastpos curpos))))
X (princ '|)| port)))
X
X(defun ppval (val att lastpos port)
X (cond ((not (equal att (1+ lastpos)))
X (princ '^ port)
X (princ att port)
X (princ '| | port)))
X (princ val port))
X
X
X
X;;; printing production memory
X
X(defun pm fexpr (z) (mapc (function pprule) z) (terpri) nil)
X
X(defun pprule (name)
X (prog (matrix next lab)
X (and (not (symbolp name)) (return nil))
X (setq matrix (get name 'production))
X (and (null matrix) (return nil))
X (terpri)
X (princ '|(p |)
X (princ name)
X top (and (atom matrix) (go fin))
X (setq next (car matrix))
X (setq matrix (cdr matrix))
X (setq lab nil)
X (terpri)
X (cond ((eq next '-)
X (princ '| - |)
X (setq next (car matrix))
X (setq matrix (cdr matrix)))
X ((eq next '-->)
X (princ '| |))
X ((and (eq next '{) (atom (car matrix)))
X (princ '| {|)
X (setq lab (car matrix))
X (setq next (cadr matrix))
X (setq matrix (cdddr matrix)))
X ((eq next '{)
X (princ '| {|)
X (setq lab (cadr matrix))
X (setq next (car matrix))
X (setq matrix (cdddr matrix)))
X (t (princ '| |)))
X (ppline next)
X (cond (lab (princ '| |) (princ lab) (princ '})))
X (go top)
X fin (princ '|)|)))
X
X(defun ppline (line)
X (prog ()
X (cond ((atom line) (princ line))
X (t
X (princ '|(|)
X (setq *ppline* line)
X (ppline2)
X (princ '|)|)))
X (return nil)))
X
X(defun ppline2 ()
X (prog (needspace)
X (setq needspace nil)
X top (and (atom *ppline*) (return nil))
X (and needspace (princ '| |))
X (cond ((eq (car *ppline*) '^) (ppattval))
X (t (pponlyval)))
X (setq needspace t)
X (go top)))
X
X(defun ppattval ()
X (prog (att val)
X (setq att (cadr *ppline*))
X (setq *ppline* (cddr *ppline*))
X (setq val (getval))
X (cond ((> (+ (nwritn) (flatc att) (flatc val)) 76.)
X (terpri)
X (princ '| |)))
X (princ '^)
X (princ att)
X (mapc (function (lambda (z) (princ '| |) (princ z))) val)))
X
X(defun pponlyval ()
X (prog (val needspace)
X (setq val (getval))
X (setq needspace nil)
X (cond ((> (+ (nwritn) (flatc val)) 76.)
X (setq needspace nil)
X (terpri)
X (princ '| |)))
X top (and (atom val) (return nil))
X (and needspace (princ '| |))
X (setq needspace t)
X (princ (car val))
X (setq val (cdr val))
X (go top)))
X
X(defun getval ()
X (prog (res v1)
X (setq v1 (car *ppline*))
X (setq *ppline* (cdr *ppline*))
X (cond ((memq v1 '(= <> < <= => > <=>))
X (setq res (cons v1 (getval))))
X ((eq v1 '{)
X (setq res (cons v1 (getupto '}))))
X ((eq v1 '<<)
X (setq res (cons v1 (getupto '>>))))
X ((eq v1 '//)
X (setq res (list v1 (car *ppline*)))
X (setq *ppline* (cdr *ppline*)))
X (t (setq res (list v1))))
X (return res)))
X
X(defun getupto (end)
X (prog (v)
X (and (atom *ppline*) (return nil))
X (setq v (car *ppline*))
X (setq *ppline* (cdr *ppline*))
X (cond ((eq v end) (return (list v)))
X (t (return (cons v (getupto end)))))))
X
X
X
X
X
X
X;;; backing up
X
X
X
X(defun record-index-plus (k)
X (setq *record-index* (+ k *record-index*))
X (cond ((< *record-index* 0.)
X (setq *record-index* *max-record-index*))
X ((> *record-index* *max-record-index*)
X (setq *record-index* 0.))))
X
X; the following routine initializes the record. putting nil in the
X; first slot indicates that that the record does not go back further
X; than that. (when the system backs up, it writes nil over the used
X; records so that it will recognize which records it has used. thus
X; the system is set up anyway never to back over a nil.)
X
X(defun initialize-record nil
X (setq *record-index* 0.)
X (setq *recording* nil)
X (setq *max-record-index* 31.)
X (putvector *record-array* 0. nil))
X
X; *max-record-index* holds the maximum legal index for record-array
X; so it and the following must be changed at the same time
X
X(defun begin-record (p data)
X (setq *recording* t)
X (setq *record* (list '=>refract p data)))
X
X(defun end-record nil
X (cond (*recording*
X (setq *record*
X (cons *cycle-count* (cons *p-name* *record*)))
X (record-index-plus 1.)
X (putvector *record-array* *record-index* *record*)
X (setq *record* nil)
X (setq *recording* nil))))
X
X(defun record-change (direct time elm)
X (cond (*recording*
X (setq *record*
X (cons direct (cons time (cons elm *record*)))))))
X
X; to maintain refraction information, need keep only one piece of information:
X; need to record all unsuccessful attempts to delete things from the conflict
X; set. unsuccessful deletes are caused by attempting to delete refracted
X; instantiations. when backing up, have to avoid putting things back into the
X; conflict set if they were not deleted when running forward
X
X(defun record-refract (rule data)
X (and *recording*
X (setq *record* (cons '<=refract (cons rule (cons data *record*)]
X
X(defun refracted (rule data)
X (prog (z)
X (and (null *refracts*) (return nil))
X (setq z (cons rule data))
X (return (member z *refracts*))))
X
X(defun back (k)
X (prog (r)
X l: (and (< k 1.) (return nil))
X (setq r (getvector *record-array* *record-index*))
X (and (null r) (return '|nothing more stored|))
X (putvector *record-array* *record-index* nil)
X (record-index-plus -1.)
X (undo-record r)
X (setq k (1- k))
X (go l:)))
X
X(defun undo-record (r)
X (prog (save act a b rate)
X (comment *recording* must be off during back up)
X (setq save *recording*)
X (setq *refracts* nil)
X (setq *recording* nil)
X (and *ptrace* (back-print (list 'undo: (car r) (cadr r))))
X (setq r (cddr r))
X top (and (atom r) (go fin))
X (setq act (car r))
X (setq a (cadr r))
X (setq b (caddr r))
X (setq r (cdddr r))
X (and *wtrace* (back-print (list 'undo: act a)))
X (cond ((eq act '<=wm) (add-to-wm b a))
X ((eq act '=>wm) (remove-from-wm b))
X ((eq act '<=refract)
X (setq *refracts* (cons (cons a b) *refracts*)))
X ((and (eq act '=>refract) (still-present b))
X (setq *refracts* (delete (cons a b) *refracts*))
X (setq rate (rating-part (get a 'topnode)))
X (removecs a b)
X (insertcs a b rate))
X (t (%warn '|back: cannot undo action| (list act a))))
X (go top)
X fin (setq *recording* save)
X (setq *refracts* nil)
X (return nil)))
X
X; still-present makes sure that the user has not deleted something
X; from wm which occurs in the instantiation about to be restored; it
X; makes the check by determining whether each wme still has a time tag.
X
X(defun still-present (data)
X (prog nil
X l: (cond ((atom data) (return t))
X ((creation-time (car data))
X (setq data (cdr data))
X (go l:))
X (t (return nil)))))
X
X
X(defun back-print (x)
X (prog (port)
X (setq port (trace-file))
X (terpri port)
X (print x port)))
X
X
X
X
X;;; Functions to show how close rules are to firing
X
X(defun matches fexpr (rule-list)
X (mapc (function matches2) rule-list)
X (terpri))
X
X(defun matches2 (p)
X (cond ((atom p)
X (terpri)
X (terpri)
X (princ p)
X (matches3 (get p 'backpointers) 2. (ncons 1.)))))
X
X(defun matches3 (nodes ce part)
X (cond ((not (null nodes))
X (terpri)
X (princ '| ** matches for |)
X (princ part)
X (princ '| ** |)
X (mapc (function write-elms) (find-left-mem (car nodes)))
X (terpri)
X (princ '| ** matches for |)
X (princ (ncons ce))
X (princ '| ** |)
X (mapc (function write-elms) (find-right-mem (car nodes)))
X (matches3 (cdr nodes) (1+ ce) (cons ce part)))))
X
X(defun write-elms (wme-or-count)
X (cond ((dtpr wme-or-count)
X (terpri)
X (mapc (function write-elms2) wme-or-count))))
X
X(defun write-elms2 (x)
X (princ '| |)
X (princ (creation-time x)))
X
X(defun find-left-mem (node)
X (cond ((eq (car node) '&and) (memory-part (caddr node)))
X (t (car (caddr node)))))
X
X(defun find-right-mem (node) (memory-part (cadddr node)))
X
X
X;;; Check the RHSs of productions
X
X
X(defun check-rhs (rhs) (mapc (function check-action) rhs))
X
X(defun check-action (x)
X (prog (a)
X (cond ((atom x)
X (%warn '|atomic action| x)
X (return nil)))
X (setq a (setq *action-type* (car x)))
X (cond ((eq a 'bind) (check-bind x))
X ((eq a 'cbind) (check-cbind x))
X ((eq a 'make) (check-make x))
X ((eq a 'modify) (check-modify x))
X ((eq a 'remove) (check-remove x))
X ((eq a 'write) (check-write x))
X ((eq a 'call) (check-call x))
X ((eq a 'halt) (check-halt x))
X ((eq a 'openfile) (check-openfile x))
X ((eq a 'closefile) (check-closefile x))
X ((eq a 'default) (check-default x))
X ((eq a 'build) (check-build x))
X (t (%warn '|undefined rhs action| a)))))
X
X(defun check-build (z)
X (and (null (cdr z)) (%warn '|needs arguments| z))
X (check-build-collect (cdr z)))
X
X(defun check-build-collect (args)
X (prog (r)
X top (and (null args) (return nil))
X (setq r (car args))
X (setq args (cdr args))
X (cond ((dtpr r) (check-build-collect r))
X ((eq r '\\)
X (and (null args) (%warn '|nothing to evaluate| r))
X (check-rhs-value (car args))
X (setq args (cdr args))))
X (go top)))
X
X(defun check-remove (z)
X (and (null (cdr z)) (%warn '|needs arguments| z))
X (mapc (function check-rhs-ce-var) (cdr z)))
X
X(defun check-make (z)
X (and (null (cdr z)) (%warn '|needs arguments| z))
X (check-change& (cdr z)))
X
X(defun check-openfile (z)
X (and (null (cdr z)) (%warn '|needs arguments| z))
X (check-change& (cdr z)))
X
X(defun check-closefile (z)
X (and (null (cdr z)) (%warn '|needs arguments| z))
X (check-change& (cdr z)))
X
X(defun check-default (z)
X (and (null (cdr z)) (%warn '|needs arguments| z))
X (check-change& (cdr z)))
X
X(defun check-modify (z)
X (and (null (cdr z)) (%warn '|needs arguments| z))
X (check-rhs-ce-var (cadr z))
X (and (null (cddr z)) (%warn '|no changes to make| z))
X (check-change& (cddr z)))
X
X(defun check-write (z)
X (and (null (cdr z)) (%warn '|needs arguments| z))
X (check-change& (cdr z)))
X
X(defun check-call (z)
X (prog (f)
X (and (null (cdr z)) (%warn '|needs arguments| z))
X (setq f (cadr z))
X (and (variablep f)
X (%warn '|function name must be a constant| z))
X (or (symbolp f)
X (%warn '|function name must be a symbolic atom| f))
X (or (externalp f)
X (%warn '|function name not declared external| f))
X (check-change& (cddr z))))
X
X(defun check-halt (z)
X (or (null (cdr z)) (%warn '|does not take arguments| z)))
X
X(defun check-cbind (z)
X (prog (v)
X (or (= (length z) 2.) (%warn '|takes only one argument| z))
X (setq v (cadr z))
X (or (variablep v) (%warn '|takes variable as argument| z))
X (note-ce-variable v)))
X
X(defun check-bind (z)
X (prog (v)
X (or (> (length z) 1.) (%warn '|needs arguments| z))
X (setq v (cadr z))
X (or (variablep v) (%warn '|takes variable as argument| z))
X (note-variable v)
X (check-change& (cddr z))))
X
X
X(defun check-change& (z)
X (prog (r tab-flag)
X (setq tab-flag nil)
X la (and (atom z) (return nil))
X (setq r (car z))
X (setq z (cdr z))
X (cond ((eq r '^)
X (and tab-flag
X (%warn '|no value before this tab| (car z)))
X (setq tab-flag t)
X (check-tab-index (car z))
X (setq z (cdr z)))
X ((eq r '//) (setq tab-flag nil) (setq z (cdr z)))
X (t (setq tab-flag nil) (check-rhs-value r)))
X (go la)))
X
X(defun check-rhs-ce-var (v)
X (cond ((and (not (numberp v)) (not (ce-bound\? v)))
X (%warn '|unbound element variable| v))
X ((and (numberp v) (or (< v 1.) (> v *ce-count*)))
X (%warn '|numeric element designator out of bounds| v))))
X
X(defun check-rhs-value (x)
X (cond ((dtpr x) (check-rhs-function x))
X (t (check-rhs-atomic x))))
X
X(defun check-rhs-atomic (x)
X (and (variablep x)
X (not (bound\? x))
X (%warn '|unbound variable| x)))
X
X(defun check-rhs-function (x)
X (prog (a)
X (setq a (car x))
X (cond ((eq a 'compute) (check-compute x))
X ((eq a 'arith) (check-compute x))
X ((eq a 'substr) (check-substr x))
X ((eq a 'accept) (check-accept x))
X ((eq a 'acceptline) (check-acceptline x))
X ((eq a 'crlf) (check-crlf x))
X ((eq a 'genatom) (check-genatom x))
X ((eq a 'litval) (check-litval x))
X ((eq a 'tabto) (check-tabto x))
X ((eq a 'rjust) (check-rjust x))
X ((not (externalp a))
X (%warn '"rhs function not declared external" a)))))
X
X(defun check-litval (x)
X (or (= (length x) 2) (%warn '|wrong number of arguments| x))
X (check-rhs-atomic (cadr x)))
X
X(defun check-accept (x)
X (cond ((= (length x) 1) nil)
X ((= (length x) 2) (check-rhs-atomic (cadr x)))
X (t (%warn '|too many arguments| x))))
X
X(defun check-acceptline (x)
X (mapc (function check-rhs-atomic) (cdr x)))
X
X(defun check-crlf (x)
X (check-0-args x))
X
X(defun check-genatom (x) (check-0-args x))
X
X(defun check-tabto (x)
X (or (= (length x) 2) (%warn '|wrong number of arguments| x))
X (check-print-control (cadr x)))
X
X(defun check-rjust (x)
X (or (= (length x) 2) (%warn '|wrong number of arguments| x))
X (check-print-control (cadr x)))
X
X(defun check-0-args (x)
X (or (= (length x) 1.) (%warn '|should not have arguments| x)))
X
X(defun check-substr (x)
X (or (= (length x) 4.) (%warn '|wrong number of arguments| x))
X (check-rhs-ce-var (cadr x))
X (check-substr-index (caddr x))
X (check-last-substr-index (cadddr x)))
X
X(defun check-compute (x) (check-arithmetic (cdr x)))
X
X(defun check-arithmetic (l)
X (cond ((atom l)
X (%warn '|syntax error in arithmetic expression| l))
X ((atom (cdr l)) (check-term (car l)))
X ((not (memq (cadr l) '(+ - * // \\)))
X (%warn '|unknown operator| l))
X (t (check-term (car l)) (check-arithmetic (cddr l)))))
X
X(defun check-term (x)
X (cond ((dtpr x) (check-arithmetic x))
X (t (check-rhs-atomic x))))
X
X(defun check-last-substr-index (x)
X (or (eq x 'inf) (check-substr-index x)))
X
X(defun check-substr-index (x)
X (prog (v)
X (cond ((bound\? x) (return x)))
X (setq v ($litbind x))
X (cond ((not (numberp v))
X (%warn '|unbound symbol used as index in substr| x))
X ((or (< v 1.) (> v 127.))
X (%warn '|index out of bounds in tab| x)))))
X
X(defun check-print-control (x)
X (prog ()
X (cond ((bound\? x) (return x)))
X (cond ((or (not (numberp x)) (< x 1.) (> x 127.))
X (%warn '|illegal value for printer control| x)))))
X
X(defun check-tab-index (x)
X (prog (v)
X (cond ((bound\? x) (return x)))
X (setq v ($litbind x))
X (cond ((not (numberp v))
X (%warn '|unbound symbol occurs after ^| x))
X ((or (< v 1.) (> v 127.))
X (%warn '|index out of bounds after ^| x)))))
X
X(defun note-variable (var)
X (setq *rhs-bound-vars* (cons var *rhs-bound-vars*)))
X
X(defun bound\? (var)
X (or (memq var *rhs-bound-vars*)
X (var-dope var)))
X
X(defun note-ce-variable (ce-var)
X (setq *rhs-bound-ce-vars* (cons ce-var *rhs-bound-ce-vars*)))
X
X(defun ce-bound\? (ce-var)
X (or (memq ce-var *rhs-bound-ce-vars*)
X (ce-var-dope ce-var)))
X
X;;; Top level routines
X
X(defun process-changes (adds dels)
X (prog (x)
X process-deletes (and (atom dels) (go process-adds))
X (setq x (car dels))
X (setq dels (cdr dels))
X (remove-from-wm x)
X (go process-deletes)
X process-adds (and (atom adds) (return nil))
X (setq x (car adds))
X (setq adds (cdr adds))
X (add-to-wm x nil)
X (go process-adds)))
X
X(defun main nil
X (prog (instance r)
X (setq *halt-flag* nil)
X (setq *break-flag* nil)
X (setq instance nil)
X dil (setq *phase* 'conflict-resolution)
X (cond (*halt-flag*
X (setq r '|end -- explicit halt|)
X (go finis))
X ((zerop *remaining-cycles*)
X (setq r '***break***)
X (setq *break-flag* t)
X (go finis))
X (*break-flag* (setq r '***break***) (go finis)))
X (setq *remaining-cycles* (1- *remaining-cycles*))
X (setq instance (conflict-resolution))
X (cond ((not instance)
X (setq r '|end -- no production true|)
X (go finis)))
X (setq *phase* (car instance))
X (accum-stats)
X (eval-rhs (car instance) (cdr instance))
X (check-limits)
X (and (broken (car instance)) (setq *break-flag* t))
X (go dil)
X finis (setq *p-name* nil)
X (return r)))
X
X(defun do-continue (wmi)
X (cond (*critical*
X (terpri)
X (princ '|warning: network may be inconsistent|)))
X (process-changes wmi nil)
X (print-times (main)))
X
X(defun accum-stats nil
X (setq *cycle-count* (1+ *cycle-count*))
X (setq *total-token* (+ *total-token* *current-token*))
X (cond ((> *current-token* *max-token*)
X (setq *max-token* *current-token*)))
X (setq *total-wm* (+ *total-wm* *current-wm*))
X (cond ((> *current-wm* *max-wm*) (setq *max-wm* *current-wm*))))
X
X
X(defun print-times (mess)
X (prog (cc ac)
X (cond (*break-flag* (terpri) (return mess)))
X (setq cc (plus (float *cycle-count*) 1.0e-20))
X (setq ac (plus (float *action-count*) 1.0e-20))
X (terpri)
X (princ mess)
X (pm-size)
X (printlinec (list *cycle-count*
X 'firings
X (list *action-count* 'rhs 'actions)))
X (terpri)
X (printlinec (list (round (quotient (float *total-wm*) cc))
X 'mean 'working 'memory 'size
X (list *max-wm* 'maximum)))
X (terpri)
X (printlinec (list (round (quotient (float *total-cs*) cc))
X 'mean 'conflict 'set 'size
X (list *max-cs* 'maximum)))
X (terpri)
X (printlinec (list (round (quotient (float *total-token*) cc))
X 'mean 'token 'memory 'size
X (list *max-token* 'maximum)))
X (terpri)))
X
X(defun pm-size nil
X (terpri)
X (printlinec (list *pcount*
X 'productions
X (list *real-cnt* '// *virtual-cnt* 'nodes)))
X (terpri))
X
X(defun check-limits nil
X (cond ((> (length *conflict-set*) *limit-cs*)
X (terpri)
X (terpri)
X (printlinec (list '|conflict set size exceeded the limit of|
X *limit-cs*
X '|after|
X *p-name*))
X (setq *halt-flag* t)))
X (cond ((> *current-token* *limit-token*)
X (terpri)
X (terpri)
X (printlinec (list '|token memory size exceeded the limit of|
X *limit-token*
X '|after|
X *p-name*))
X (setq *halt-flag* t))))
X
X
X(defun top-level-remove (z)
X (cond ((equal z '(*)) (process-changes nil (get-wm nil)))
X (t (process-changes nil (get-wm z)))))
X
X(defun excise fexpr (z) (mapc (function excise-p) z))
X
X(defun run fexpr (z)
X (cond ((atom z) (setq *remaining-cycles* 1000000.) (do-continue nil))
X ((and (atom (cdr z)) (numberp (car z)) (> (car z) 0.))
X (setq *remaining-cycles* (car z))
X (do-continue nil))
X (t 'what\?)))
X
X(defun strategy fexpr (z)
X (cond ((atom z) *strategy*)
X ((equal z '(lex)) (setq *strategy* 'lex))
X ((equal z '(mea)) (setq *strategy* 'mea))
X (t 'what\?)))
X
X(defun cs fexpr (z)
X (cond ((atom z) (conflict-set))
X (t 'what\?)))
X
X(defun watch fexpr (z)
X (cond ((equal z '(0.))
X (setq *wtrace* nil)
X (setq *ptrace* nil)
X 0.)
X ((equal z '(1.)) (setq *wtrace* nil) (setq *ptrace* t) 1.)
X ((equal z '(2.)) (setq *wtrace* t) (setq *ptrace* t) 2.)
X ((equal z '(3.))
X (setq *wtrace* t)
X (setq *ptrace* t)
X '(2. -- conflict set trace not supported))
X ((and (atom z) (null *ptrace*)) 0.)
X ((and (atom z) (null *wtrace*)) 1.)
X ((atom z) 2.)
X (t 'what\?)))
X
X(defun external fexpr (z) (catch (external2 z) \!error\!))
X
X(defun external2 (z) (mapc (function external3) z))
X
X(defun external3 (x)
X (cond ((symbolp x) (putprop x t 'external-routine)
X (setq *externals* (enter x *externals*)))
X (t (%error '|not a legal function name| x))))
X
X(defun externalp (x)
X (cond ((symbolp x) (get x 'external-routine))
X (t (%warn '|not a legal function name| x) nil)))
X
X(defun pbreak fexpr (z)
X (cond ((atom z) (terpri) *brkpts*)
X (t (mapc (function pbreak2) z) nil)))
X
X(defun pbreak2 (rule)
X (cond ((not (symbolp rule)) (%warn '|illegal name| rule))
X ((not (get rule 'topnode)) (%warn '|not a production| rule))
X ((memq rule *brkpts*) (setq *brkpts* (rematm rule *brkpts*)))
X (t (setq *brkpts* (cons rule *brkpts*)))))
X
X(defun rematm (atm list)
X (cond ((atom list) list)
X ((eq atm (car list)) (rematm atm (cdr list)))
X (t (cons (car list) (rematm atm (cdr list))))))
X
X(defun broken (rule) (memq rule *brkpts*))
X
X
XMONK.OPS
X
X;;; -*- Mode:Common-Lisp; Package:USER; Base:10 -*-
X
X;----------------------------------------------------------------------
X;Here's a monkey-and-banana problem in OPS5 (this comes with the OPS5
X;distribution, which you can get for free from Forgy at CMU)
X
X;To run this demo, load into an OPS5 image, and type
X;(make start 1)
X;(run)
X
X
X
X(i-g-v)
X; a monkey is AT some location and may be ON some object and
X; may be HOLDing something
X;
X(literalize start )
X(literalize monkey
X at
X on
X holds)
X
X; an object has a NAME, is AT somewhere, has a WEIGHT and may
X; be ON something
X;
X(literalize object
X name
X at
X weight
X on)
X
X; a goal is a flag for sequencing actions that may be active,
X; describe the state of an object or monkey, the object may be
X; speciifed and its future location as well
X;
X(literalize goal
X status
X type
X object
X to)
X;
X;make everything new again
X(defun monkoff() (eval `(excise ,@*pnames* ) )) ;handy function to remove all productions from memory
X;
X; if the object someone wants to hold is on the ceiling, move
X;the ladder to the place under the object.
X;
X(p mb1
X (goal ^status active ^type holds ^object <w>)
X (object ^name <w> ^at <p> ^on ceiling)
X -->
X (owrite (crlf) Since the <w> are on the ceiling at position <p> \,)
X (owrite (crlf) I would like to move the ladder under them.)
X (make goal ^status active ^type move ^object ladder ^to <p>))
X
X; if the object is on the ceiling and the ladder is under the
X; object and you want the object, then get on the ladder
X;
X(p mb2
X (goal ^status active ^type holds ^object <w>)
X (object ^name <w> ^at <p> ^on ceiling)
X (object ^name ladder ^at <p>)
X -->
X (owrite (crlf) With the ladder at <p> \, )
X (owrite (crlf) I climb onto the ladder to get the <w> \.)
X (make goal ^status active ^type on ^object ladder))
X;
X; if you're on the ladder under the sought-after object (which
X; is on the ceiling), make grabbing it your own desire
X;
X(p mb3
X (goal ^status active ^type holds ^object <w>)
X (object ^name <w> ^at <p> ^on ceiling)
X (object ^name ladder ^at <p>)
X (monkey ^on ladder)
X -->
X (owrite (crlf) what I want to do now is get the <w> \.)
X (make goal ^status active ^type holds ^object nil))
X
X;
X; so you're under the object and you're on the ladder with empty
X; hands, now grab for the gusto !!
X;
X(p mb4
X (goal ^status active ^type holds ^object <w>)
X (object ^name <w> ^at <p> ^on ceiling)
X (object ^name ladder ^at <p>)
X (monkey ^on ladder ^holds nil)
X -->
X (owrite (crlf) I have the <w> in hand)
X (modify 4 ^holds <w>)
X (modify 1 ^status satified))
X
X; if you want to hold something, and it's on the floor,
X; you must decide to walk over and pick it up
X;
X(p mb5
X (goal ^status active ^type holds ^object <w>)
X (object ^name <w> ^at <p> ^on floor)
X -->
X (owrite (crlf) I think I will walk over to <p> to get the <w>)
X (make goal ^status active ^type walk-to ^object <p>))
X;
X; in order to hold something, one needs ones hands free
X;
X(p mb6
X (goal ^status active ^type holds ^object <w>)
X (object ^name <w> ^at <p> ^on floor)
X (monkey ^at <p>)
X -->
X (owrite (crlf) if I am going to hold <w> here at <p>)
X (owrite (crlf) I am going to need to have empty hands)
X (make goal ^status active ^type holds ^object nil))
X;
X; if you where the object is and its on the floor,
X; pick it up
X;
X(p mb7
X (goal ^status active ^type holds ^object <w>)
X (object ^name <w> ^at <p> ^on floor)
X (monkey ^at <p> ^holds nil)
X -->
X (owrite (crlf) I picked the <w> off the floor)
X (modify 3 ^holds <w>)
X (modify 1 ^status satisfied))
X
X;
X; if the object is light enough, move it where you will
X;
X(p mb8
X (goal ^status active ^type move ^object <o> ^to <p>)
X (object ^name <o> ^weight light ^at <> <p>)
X -->
X (owrite (crlf) since the <o> is light I can move it )
X (make goal ^status active ^type holds ^object <o>))
X
X;
X; since i'm holding the object I can and will move it
X;
X(p mb9
X (goal ^status active ^type move ^object <o> ^to <p>)
X (object ^name <o> ^weight light ^at <> <p>)
X (monkey ^holds <o>)
X -->
X (owrite (crlf) since I can move the <o> to <p> \, I will)
X (make goal ^status active ^type walk-to ^object <p>))
X
X;
X; and it is moved ...
X;
X(p mb10
X (goal ^status active ^type move ^object <o> ^to <p>)
X (object ^name <o> ^weight light ^at <p>)
X -->
X (owrite (crlf) and it is where I want it)
X (modify 1 ^status satisfied))
X
X(p mb11
X (goal ^status active ^type walk-to ^object <p>)
X -->
X (owrite (crlf) since I need to be on the floor to walk \,)
X (owrite (crlf) I better get to the floor)
X (make goal ^status active ^type on ^object floor))
X
X; if the monkey is on the floor and not at his goal location
X; <p> then walk to <p>
X;
X(p mb12
X (goal ^status active ^type walk-to ^object <p>)
X (monkey ^on floor ^at { <c> <> <p> } ^holds nil)
X -->
X (owrite (crlf) I will walk over to <p>)
X (modify 2 ^at <p>)
X (modify 1 ^status satisfied))
X
X; if i walk to <p>, then I am at <p> and so is anything i am
X; holding
X;
X(p mb13
X (goal ^status active ^type walk-to ^object <p>)
X (monkey ^on floor ^at { <c> <> <p> } ^holds <w> <> nil)
X (object ^name <w>)
X -->
X (owrite (crlf) I will carry <w> to <p>)
X (modify 2 ^at <p>)
X (modify 3 ^at <p>)
X (modify 1 ^status satisfied))
X
X;
X; if i am not on the floor and what I want is, I had better
X; jump down to the floor
X;
X(p mb14
X (goal ^status active ^type on ^object floor)
X (monkey ^on { <x> <> floor })
X -->
X (owrite (crlf) I will jump onto the floor)
X (modify 2 ^on floor)
X (modify 1 ^status satisfied))
X
X;
X(p mb15
X (goal ^status active ^type on ^object <o>)
X (object ^name <o> ^at <p>)
X -->
X (owrite (crlf) when does mb15 get fired )
X (make goal ^status active ^type walk-to ^object <p>))
X
X;
X; if i want to get on something and i am at it
X; make it so that I have a goal of holding something
X;
X(p mb16
X (goal ^status active ^type on ^object <o>)
X (object ^name <o> ^at <p>)
X (monkey ^at <p>)
X -->
X (owrite (crlf) I will need free hands to climb the <o> )
X (make goal ^status active ^type holds ^object nil))
X
X;
X; if I have free hands at <p> and my active goal is at <p>
X; climb up the object I am at
X;
X(p mb17
X (goal ^status active ^type on ^object <o>)
X (object ^name <o> ^at <p>)
X (monkey ^at <p> ^holds nil)
X -->
X (owrite (crlf) I will now climb onto <o>)
X (modify 3 ^on <o>)
X (modify 1 ^status satisfied))
X
X;
X; if I want to hold nothing and I have something in hand, drop
X; it
X;
X(p mb18
X (goal ^status active ^type holds ^object nil)
X (monkey ^holds { <x> <> nil })
X -->
X (owrite (crlf) since I need my hands free I will put <x> down )
X (modify 2 ^holds nil)
X (modify 1 ^status satisfied))
X
X(p mb19
X (goal ^status active)
X -->
X (owrite (crlf) when does mb19 get fired )
X (remove 1)
X (make goal ^status not-processed))
X;
X;------------------------------------------------------------
X; STARTING CONDITIONS
X;------------------------------------------------------------
X;
X; in the beginning, the monkey is at loaction [5,7] on the
X; couch. The bananas are on the ceiling at location [2,2].
X; There is a light ladder on the floor at [9,5]. The monkey's
X; goal is to have those bananas.
X;
X(p t1
X (start 1)
X -->
X (make monkey ^at 5-7 ^on couch ^holds nil)
X (owrite (crlf) I am a monkey lying on the couch)
X (make object ^name couch ^at 5-7 ^weight heavy)
X (owrite (crlf) |... a heavy couch|)
X (make object ^name bananas ^on ceiling ^at 2-2)
X (owrite (crlf) there are some bananas on the ceiling at position 2-2)
X (make object ^name ladder ^on floor ^at 9-5 ^weight light)
X (owrite (crlf) there is a ladder on the floor at position 9-5)
X
X (make goal ^status active ^type holds ^object bananas)
X (owrite (crlf) I sure would like those bananas )
X (owrite (crlf)(crlf) |The action begins:| (crlf)))
X
X
XTI.OPS
X
X; VPS2 -- Interpreter for OPS5
X;
X; Copyright (C) 1979, 1980, 1981
X; Charles L. Forgy, Pittsburgh, Pennsylvania
X
X
X
X; Users of this interpreter are requested to contact
X
X;
X; Charles Forgy
X; Computer Science Department
X; Carnegie-Mellon University
X; Pittsburgh, PA 15213
X; or
X; Forgy@CMUA
X;
X; so that they can be added to the mailing list for OPS5. The mailing list
X; is needed when new versions of the interpreter or manual are released.
X
X
X
X;;; Definitions
X
X
X
--
---------------
C'est la vie, C'est la guerre, C'est la pomme de terre
Mail: Imagen Corp. 2650 San Tomas Expressway Santa Clara, CA 95052-8101
UUCP: ...{decvax,ucbvax}!decwrl!imagen!turner AT&T: (408) 986-9400