Copy Link
Add to Bookmark
Report
AIList Digest Volume 5 Issue 027
AIList Digest Friday, 30 Jan 1987 Volume 5 : Issue 27
Today's Topics:
Code - AI Expert Magazine Sources (Part 8 of 22)
----------------------------------------------------------------------
Date: 19 Jan 87 03:36:40 GMT
From: imagen!turner@ucbvax.Berkeley.EDU (D'arc Angel)
Subject: AI Expert Magazine Sources (Part 8 of 22)
X(defun init-ce-var-mem (vlist)
X (prog (v ind r)
X (setq *ce-variable-memory* nil)
X top (and (atom vlist) (return nil))
X (setq v (car vlist))
X (setq ind (cadr vlist))
X (setq vlist (cddr vlist))
X (setq r (ce-gelm *data-matched* ind))
X (setq *ce-variable-memory*
X (cons (cons v r) *ce-variable-memory*))
X (go top)))
X
X(defun make-ce-var-bind (var elem)
X (setq *ce-variable-memory*
X (cons (cons var elem) *ce-variable-memory*)))
X
X(defun make-var-bind (var elem)
X (setq *variable-memory* (cons (cons var elem) *variable-memory*)))
X
X(defun $varbind (x)
X (prog (r)
X (and (not *in-rhs*) (return x))
X (setq r (assoc x *variable-memory* :test #'eq))
X (cond (r (return (cdr r)))
X (t (return x)))))
X
X(defun get-ce-var-bind (x)
X (prog (r)
X (cond ((numberp x) (return (get-num-ce x))))
X (setq r (assoc x *ce-variable-memory* :test #'eq))
X (cond (r (return (cdr r)))
X (t (return nil)))))
X
X(defun get-num-ce (x)
X (prog (r l d)
X (setq r *data-matched*)
X (setq l (length r))
X (setq d (- l x))
X (and (> 0. d) (return nil))
X la (cond ((null r) (return nil))
X ((> 1. d) (return (car r))))
X (setq d (1- d))
X (setq r (cdr r))
X (go la)))
X
X
X(defun build-collect (z)
X (prog (r)
X la (and (atom z) (return nil))
X (setq r (car z))
X (setq z (cdr z))
X (cond ((and r (listp r))
X ($value '\()
X (build-collect r)
X ($value '\)))
X ((eq r '\\) ($change (car z)) (setq z (cdr z)))
X (t ($value r)))
X (go la)))
X
X(defun unflat (x) (setq *rest* x) (unflat*))
X
X(defun unflat* nil
X (prog (c)
X (cond ((atom *rest*) (return nil)))
X (setq c (car *rest*))
X (setq *rest* (cdr *rest*))
X (cond ((eq c '\() (return (cons (unflat*) (unflat*))))
X ((eq c '\)) (return nil))
X (t (return (cons c (unflat*)))))))
X
X
X(defun $change (x)
X (prog nil
X (cond ((and x (listp x)) (eval-function x)) ;modified to check for nil
X (t ($value ($varbind x))))))
X
X(defun eval-args (z)
X (prog (r)
X (rhs-tab 1.)
X la (and (atom z) (return nil))
X (setq r (car z))
X (setq z (cdr z))
X (cond ((eq r #\^)
X (rhs-tab (car z))
X (setq r (cadr z))
X (setq z (cddr z))))
X (cond ((eq r '//) ($value (car z)) (setq z (cdr z)))
X (t ($change r)))
X (go la)))
X
X
X(defun eval-function (form)
X (cond ((not *in-rhs*)
X (%warn '|functions cannot be used at top level| (car form)))
X (t (eval form))))
X
X
X;;; Functions to manipulate the result array
X
X
X(defun $reset nil
X (setq *max-index* 0)
X (setq *next-index* 1))
X
X; rhs-tab implements the tab ('^') function in the rhs. it has
X; four responsibilities:
X; - to move the array pointers
X; - to watch for tabbing off the left end of the array
X; (ie, to watch for pointers less than 1)
X; - to watch for tabbing off the right end of the array
X; - to write nil in all the slots that are skipped
X; the last is necessary if the result array is not to be cleared
X; after each use; if rhs-tab did not do this, $reset
X; would be much slower.
X
X(defun rhs-tab (z) ($tab ($varbind z)))
X
X(defun $tab (z)
X (prog (edge next)
X (setq next ($litbind z))
X (and (floatp next) (setq next (round next)))
X (cond ((or (not (numberp next))
X (> next *size-result-array*)
X (> 1. next))
X (%warn '|illegal index after ^| next)
X (return *next-index*)))
X (setq edge (- next 1.))
X (cond ((> *max-index* edge) (go ok)))
X clear (cond ((== *max-index* edge) (go ok)))
X (putvector *result-array* edge nil)
X (setq edge (1- edge))
X (go clear)
X ok (setq *next-index* next)
X (return next)))
X
X(defun $value (v)
X (cond ((> *next-index* *size-result-array*)
X (%warn '|index too large| *next-index*))
X (t
X (and (> *next-index* *max-index*)
X (setq *max-index* *next-index*))
X (putvector *result-array* *next-index* v)
X (setq *next-index* (1+ *next-index*)))))
X
X(defun use-result-array nil
X (prog (k r)
X (setq k *max-index*)
X (setq r nil)
X top (and (== k 0.) (return r))
X (setq r (cons (getvector *result-array* k) r))
X (setq k (1- k))
X (go top)))
X
X(defun $assert nil
X (setq *last* (use-result-array))
X (add-to-wm *last* nil))
X
X(defun $parametercount nil *max-index*)
X
X(defun $parameter (k)
X (cond ((or (not (numberp k)) (> k *size-result-array*) (< k 1.))
X (%warn '|illegal parameter number | k)
X nil)
X ((> k *max-index*) nil)
X (t (getvector *result-array* k))))
X
X
X;;; RHS actions
X
X
X(defmacro make(&rest z)
X `(prog nil
X ($reset)
X (eval-args ',z)
X ($assert)))
X
X(defmacro modify (&rest z)
X `(prog (old args)
X (setq args ',z)
X (cond ((not *in-rhs*)
X (%warn '|cannot be called at top level| 'modify)
X (return nil)))
X (setq old (get-ce-var-bind (car args)))
X (cond ((null old)
X (%warn '|modify: first argument must be an element variable|
X (car args))
X (return nil)))
X (remove-from-wm old)
X (setq args (cdr args))
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 args)
X ($assert)))
X
X(defmacro bind (&rest 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(defmacro cbind (&rest 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(defmacro oremove (&rest z)
X `(prog (old args)
X (setq args ',z)
X (and (not *in-rhs*)(return (top-level-remove args)))
X top (and (atom args) (return nil))
X (setq old (get-ce-var-bind (car args)))
X (cond ((null old)
X (%warn '|remove: argument not an element variable| (car args))
X (return nil)))
X (remove-from-wm old)
X (setq args (cdr args))
X (go top)))
X
X(defmacro ocall (&rest z)
X `(prog (f)
X (setq f (car ',z))
X ($reset)
X (eval-args (cdr ',z))
X (funcall f)))
X
X(defmacro owrite (&rest 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
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 (length (princ-to-string value )))
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 (eval `(format ,port (concatenate 'string "~" (princ-to-string ,col) "T"))))
X
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(defmacro build (&rest 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 infile(file)
X (open file :direction :input))
X
X(defun outfile(file)
X (open file :direction :output))
X
X(defmacro openfile (&rest 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 ((and x (symbolp x)) (get x 'inputfile))
X (t *standard-input*)))
X
X(defun $ofile (x)
X (cond ((and x (symbolp x)) (get x 'outputfile))
X (t *standard-output*)))
X
X
X(defmacro closefile (&rest z)
X `(progn
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(defmacro default (&rest 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 (member use '(write accept trace)))
X (%warn '|default: illegal use for a file| use)
X (return nil))
X ((and (member 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(defmacro accept (&rest 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 #'char-equal)))
(read-char prt)))
X
X(defmacro acceptline (&rest z)
X `(prog ( 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 (cond ((member (tyipeek port) '(-1. 10.))
X (mapc (function $change) def)
X (return nil)))
X lp1 (flat-value (read port))
X (span-chars '(9. 41.) port)
X (cond ((not (member (tyipeek port) '(-1. 10.))) (go lp1)))))
X
X(defmacro substr (&rest 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 ;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 ;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(defmacro compute (&rest z) `($value (ari ',z)))
X
X; arith is the obsolete form of compute
X(defmacro arith (&rest 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 (+ (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 (/ (ari-unit (car x)) (ari (cddr x))))
X ((eq (cadr x) '\\)
X (mod (round (ari-unit (car x))) (round (ari (cddr x)))))
X (t (%warn '|bad syntax in arithmetic expression | x) 0.)))
X
X(defun ari-unit (a)
X (prog (r)
X (cond ((listp 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(defmacro litval (&rest 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(defmacro rjust (&rest 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
X(defmacro crlf()
X ($value '|=== C R L F ===|))
X
X(defmacro tabto (&rest 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(defmacro ppwm (&rest z)
X `(prog (next a avlist)
X (setq avlist ',z)
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 (round 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
------------------------------
End of AIList Digest
********************
