Copy Link
Add to Bookmark
Report
AIList Digest Volume 5 Issue 024
AIList Digest Friday, 30 Jan 1987 Volume 5 : Issue 24
Today's Topics:
Code - AI Expert Magazine Sources (Part 5 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 5 of 22)
X;;; Utility functions
X
X
X
X(defun printline (x) (mapc (function printline*) x))
X
X(defun printline* (y) (princ '| |) (print y))
X
X(defun printlinec (x) (mapc (function printlinec*) x))
X
X(defun printlinec* (y) (princ '| |) (princ y))
X
X; intersect two lists using eq for the equality test
X
X(defun interq (x y)
X (intersection x y :test #'eq))
X
X(defun enter (x ll)
X (and (not (member x ll :test #'equal))
X (push x ll)))
X
X
X;Hack read-macro tables to accept single characters -- right out of CL book.
X(defun single-macro-character (stream char)
X (declare (ignore stream))
X (character char))
X
X(defun i-g-v nil
X (prog (x)
X (set-macro-character #\{ #'single-macro-character )
X (set-macro-character #\} #'single-macro-character )
X (set-macro-character #\^ #'single-macro-character )
X; (setsyntax '\{ 66.) ;These are already normal characters in CL
X; (setsyntax '\} 66.)
X; (setsyntax '^ 66.)
X (setq *buckets* 64.) ; OPS5 allows 64 named slots
X (setq *accept-file* nil)
X (setq *write-file* nil)
X (setq *trace-file* nil)
X (and (boundp '*class-list*)
X (mapc #'(lambda(class) (putprop class nil 'att-list)) *class-list*))
X (setq *class-list* nil)
X (setq *brkpts* nil)
X (setq *strategy* 'lex)
X (setq *in-rhs* nil)
X (setq *ptrace* t)
X (setq *wtrace* nil)
X (setq *mtrace* t) ; turn on made-by tracing
X (setq *madeby* nil) ; record makers of wm elements
X (setq *recording* nil)
X (setq *refracts* nil)
X (setq *real-cnt* (setq *virtual-cnt* 0.))
X (setq *max-cs* (setq *total-cs* 0.))
X (setq *limit-token* 1000000.)
X (setq *limit-cs* 1000000.)
X (setq *critical* nil)
X (setq *build-trace* nil)
X (setq *wmpart-list* nil)
X (setq *pnames* nil)
X (setq *literals* nil) ; records literal definitions
X (setq *externals* nil) ; records external definitions
X (setq *vector-attributes* nil) ;records vector attributes
X (setq *size-result-array* 127.)
X (setq *result-array* (make-array 128))
X (setq *record-array* (make-array 128))
X (setq x 0)
X (setq *pnames* nil) ; list of production names
X loop (putvector *result-array* x nil)
X (setq x (1+ x))
X (and (not (> x *size-result-array*)) (go loop))
X (make-bottom-node)
X (setq *pcount* 0.)
X (initialize-record)
X (setq *cycle-count* (setq *action-count* 0.))
X (setq *total-token*
X (setq *max-token* (setq *current-token* 0.)))
X (setq *total-cs* (setq *max-cs* 0.))
X (setq *total-wm* (setq *max-wm* (setq *current-wm* 0.)))
X (setq *conflict-set* nil)
X (setq *wmpart-list* nil)
X (setq *p-name* nil)
X (setq *remaining-cycles* 1000000)
X))
X
X; if the size of result-array changes, change the line in i-g-v which
X; sets the value of *size-result-array*
X
X(defun %warn (what where)
X (prog nil
X (terpri)
X (princ '?)
X (and *p-name* (princ *p-name*))
X (princ '|..|)
X (princ where)
X (princ '|..|)
X (princ what)
X (return where)))
X
X(defun %error (what where)
X (%warn what where)
X (throw '!error! nil))
X
X
X(defun top-levels-eq (la lb)
X (prog nil
X lx (cond ((eq la lb) (return t))
X ((null la) (return nil))
X ((null lb) (return nil))
X ((not (eq (car la) (car lb))) (return nil)))
X (setq la (cdr la))
X (setq lb (cdr lb))
X (go lx)))
X
X
X;;; LITERAL and LITERALIZE
X
X(defmacro literal (&rest z)
X `(prog (atm val old args)
X (setq args ',z)
X top (and (atom args) (return 'bound))
X (or (eq (cadr args) '=) (return (%warn '|wrong format| args)))
X (setq atm (car args))
X (setq val (caddr args))
X (setq args (cdddr args))
X (cond ((not (numberp val))
X (%warn '|can bind only to numbers| val))
X ((or (not (symbolp atm)) (variablep atm))
X (%warn '|can bind only constant atoms| atm))
X ((and (setq old (literal-binding-of atm)) (not (equal old val)))
X (%warn '|attempt to rebind attribute| atm))
X (t (putprop atm val 'ops-bind )))
X (go top)))
X
X(defmacro literalize (&rest l)
X `(prog (class-name atts)
X (setq class-name (car ',l))
X (cond ((have-compiled-production)
X (%warn '|literalize called after p| class-name)
X (return nil))
X ((get class-name 'att-list)
X (%warn '|attempt to redefine class| class-name)
X (return nil)))
X (setq *class-list* (cons class-name *class-list*))
X (setq atts (remove-duplicates (cdr ',l)))
X (test-attribute-names atts)
X (mark-conflicts atts atts)
X (putprop class-name atts 'att-list)))
X
X(defmacro vector-attribute (&rest l)
X `(cond ((have-compiled-production)
X (%warn '|vector-attribute called after p| ',l))
X (t
X (test-attribute-names ',l)
X (mapc (function vector-attribute2) ',l))))
X
X(defun vector-attribute2 (att) (putprop att t 'vector-attribute)
X (setq *vector-attributes*
X (enter att *vector-attributes*)))
X
X(defun is-vector-attribute (att) (get att 'vector-attribute))
X
X(defun test-attribute-names (l)
X (mapc (function test-attribute-names2) l))
X
X(defun test-attribute-names2 (atm)
X (cond ((or (not (symbolp atm)) (variablep atm))
X (%warn '|can bind only constant atoms| atm))))
X
X(defun finish-literalize nil
X (cond ((not (null *class-list*))
X (mapc (function note-user-assigns) *class-list*)
X (mapc (function assign-scalars) *class-list*)
X (mapc (function assign-vectors) *class-list*)
X (mapc (function put-ppdat) *class-list*)
X (mapc (function erase-literal-info) *class-list*)
X (setq *class-list* nil)
X (setq *buckets* nil))))
X
X(defun have-compiled-production nil (not (zerop *pcount*)))
X
X(defun put-ppdat (class)
X (prog (al att ppdat)
X (setq ppdat nil)
X (setq al (get class 'att-list))
X top (cond ((not (atom al))
X (setq att (car al))
X (setq al (cdr al))
X (setq ppdat
X (cons (cons (literal-binding-of att) att)
X ppdat))
X (go top)))
X (putprop class ppdat 'ppdat)))
X
X; note-user-assigns and note-user-vector-assigns are needed only when
X; literal and literalize are both used in a program. They make sure that
X; the assignments that are made explicitly with literal do not cause problems
X; for the literalized classes.
X
X(defun note-user-assigns (class)
X (mapc (function note-user-assigns2) (get class 'att-list)))
X
X(defun note-user-assigns2 (att)
X (prog (num conf buck clash)
X (setq num (literal-binding-of att))
X (and (null num) (return nil))
X (setq conf (get att 'conflicts))
X (setq buck (store-binding att num))
X (setq clash (find-common-atom buck conf))
X (and clash
X (%warn '|attributes in a class assigned the same number|
X (cons att clash)))
X (return nil)))
X
X(defun note-user-vector-assigns (att given needed)
X (and (> needed given)
X (%warn '|vector attribute assigned too small a value in literal| att)))
X
X(defun assign-scalars (class)
X (mapc (function assign-scalars2) (get class 'att-list)))
X
X(defun assign-scalars2 (att)
X (prog (tlist num bucket conf)
X (and (literal-binding-of att) (return nil))
X (and (is-vector-attribute att) (return nil))
X (setq tlist (buckets))
X (setq conf (get att 'conflicts))
X top (cond ((atom tlist)
X (%warn '|could not generate a binding| att)
X (store-binding att -1.)
X (return nil)))
X (setq num (caar tlist))
X (setq bucket (cdar tlist))
X (setq tlist (cdr tlist))
X (cond ((disjoint bucket conf) (store-binding att num))
X (t (go top)))))
X
X(defun assign-vectors (class)
X (mapc (function assign-vectors2) (get class 'att-list)))
X
X(defun assign-vectors2 (att)
X (prog (big conf new old need)
X (and (not (is-vector-attribute att)) (return nil))
X (setq big 1.)
X (setq conf (get att 'conflicts))
X top (cond ((not (atom conf))
X (setq new (car conf))
X (setq conf (cdr conf))
X (cond ((is-vector-attribute new)
X (%warn '|class has two vector attributes|
X (list att new)))
X (t (setq big (max (literal-binding-of new) big))))
X (go top)))
X (setq need (1+ big))
X (setq old (literal-binding-of att))
X (cond (old (note-user-vector-assigns att old need))
X (t (store-binding att need)))
X (return nil)))
X
X(defun disjoint (la lb) (not (find-common-atom la lb)))
X
X(defun find-common-atom (la lb)
X (prog nil
X top (cond ((null la) (return nil))
X ((member (car la) lb :test #'eq) (return (car la)))
X (t (setq la (cdr la)) (go top)))))
X
X(defun mark-conflicts (rem all)
X (cond ((not (null rem))
X (mark-conflicts2 (car rem) all)
X (mark-conflicts (cdr rem) all))))
X
X(defun mark-conflicts2 (atm lst)
X (prog (l)
X (setq l lst)
X top (and (atom l) (return nil))
X (conflict atm (car l))
X (setq l (cdr l))
X (go top)))
X
X(defun conflict (a b)
X (prog (old)
X (setq old (get a 'conflicts))
X (and (not (eq a b))
X (not (member b old :test #'eq))
X (putprop a (cons b old) 'conflicts ))))
X
X;(defun remove-duplicates (lst)
X; (cond ((atom lst) nil)
X; ((member (car lst) (cdr lst) :test #'eq)
(remove-duplicates (cdr lst)))
X; (t (cons (car lst) (remove-duplicates (cdr lst))))))
X
X(defun literal-binding-of (name) (get name 'ops-bind))
X
X(defun store-binding (name lit)
X (putprop name lit 'ops-bind)
X (add-bucket name lit))
X
X(defun add-bucket (name num)
X (prog (buc)
X (setq buc (assoc num (buckets)))
X (and (not (member name buc :test #'eq))
X (rplacd buc (cons name (cdr buc))))
X (return buc)))
X
X(defun buckets nil
X (and (atom *buckets*) (setq *buckets* (make-nums *buckets*)))
X *buckets*)
X
X(defun make-nums (k)
X (prog (nums)
X (setq nums nil)
X l (and (< k 2.) (return nums))
X (setq nums (cons (cons k nil) nums))
X (setq k (1- k))
X (go l)))
X
X;(defun erase-literal-info (class)
X; (mapc (function erase-literal-info2) (get class 'att-list))
X; (remprop class 'att-list))
X
X; modified to record literal info in the variable *literals*
X(defun erase-literal-info (class)
X (setq *literals*
X (cons (cons class (get class 'att-list)) *literals*))
X (mapc (function erase-literal-info2) (get class 'att-list))
X (remprop class 'att-list))
X
X
X(defun erase-literal-info2 (att) (remprop att 'conflicts))
X
X
X;;; LHS Compiler
X
X(defmacro p (&rest z)
X `(progn
X (finish-literalize)
X (princ '*)
X ;(drain);drain probably drains a line feed
X (compile-production (car ',z) (cdr ',z))))
X
X(defun compile-production (name matrix)
X (prog (erm)
X (setq *p-name* name)
X (setq erm (catch '!error! (cmp-p name matrix) ))
X ; following line is modified to save production name on *pnames*
X (and (null erm) (setq *pnames* (enter name *pnames*)))
X (setq *p-name* nil)
X (return erm)))
X
X(defun peek-lex nil (car *matrix*))
X
X(defun lex nil
X (prog2 nil (car *matrix*) (setq *matrix* (cdr *matrix*))))
X
X(defun end-of-p nil (atom *matrix*))
X
X(defun rest-of-p nil *matrix*)
X
X(defun prepare-lex (prod) (setq *matrix* prod))
X
X
X(defun peek-sublex nil (car *curcond*))
X
X(defun sublex nil
X (prog2 nil (car *curcond*) (setq *curcond* (cdr *curcond*))))
X
X(defun end-of-ce nil (atom *curcond*))
X
X(defun rest-of-ce nil *curcond*)
X
X(defun prepare-sublex (ce) (setq *curcond* ce))
X
X(defun make-bottom-node nil (setq *first-node* (list '&bus nil)))
X
X(defun cmp-p (name matrix)
X (prog (m bakptrs)
X (cond ((or (null name) (listp name))
X (%error '|illegal production name| name))
X ((equal (get name 'production) matrix)
X (return nil)))
X (prepare-lex matrix)
X (excise-p name)
X (setq bakptrs nil)
X (setq *pcount* (1+ *pcount*))
X (setq *feature-count* 0.)
X (setq *ce-count* 0)
X (setq *vars* nil)
X (setq *ce-vars* nil)
X (setq *rhs-bound-vars* nil)
X (setq *rhs-bound-ce-vars* nil)
X (setq *last-branch* nil)
X (setq m (rest-of-p))
X l1 (and (end-of-p) (%error '|no '-->' in production| m))
X (cmp-prin)
X (setq bakptrs (cons *last-branch* bakptrs))
X (or (eq '--> (peek-lex)) (go l1))
X (lex)
X (check-rhs (rest-of-p))
X (link-new-node (list '&p
X *feature-count*
X name
X (encode-dope)
X (encode-ce-dope)
X (cons 'progn (rest-of-p))))
X (putprop name (cdr (nreverse bakptrs)) 'backpointers )
X (putprop name matrix 'production)
X (putprop name *last-node* 'topnode)))
X
X(defun rating-part (pnode) (cadr pnode))
X
X(defun var-part (pnode) (car (cdddr pnode)))
X
X(defun ce-var-part (pnode) (cadr (cdddr pnode)))
X
X(defun rhs-part (pnode) (caddr (cdddr pnode)))
X
X(defun excise-p (name)
X (cond ((and (symbolp name) (get name 'topnode))
X (printline (list name 'is 'excised))
X (setq *pcount* (1- *pcount*))
X (remove-from-conflict-set name)
X (kill-node (get name 'topnode))
X (setq *pnames* (delete name *pnames* :test #'eq))
X (remprop name 'production)
X (remprop name 'backpointers)
X (remprop name 'topnode))))
X
X(defun kill-node (node)
X (prog nil
X top (and (atom node) (return nil))
X (rplaca node '&old)
X (setq node (cdr node))
X (go top)))
X
X(defun cmp-prin nil
X (prog nil
X (setq *last-node* *first-node*)
X (cond ((null *last-branch*) (cmp-posce) (cmp-nobeta))
X ((eq (peek-lex) '-) (cmp-negce) (cmp-not))
X (t (cmp-posce) (cmp-and)))))
X
X(defun cmp-negce nil (lex) (cmp-ce))
X
X(defun cmp-posce nil
X (setq *ce-count* (1+ *ce-count*))
X (cond ((eq (peek-lex) #\{) (cmp-ce+cevar))
X (t (cmp-ce))))
X
X(defun cmp-ce+cevar nil
X (prog (z)
X (lex)
X (cond ((atom (peek-lex)) (cmp-cevar) (cmp-ce))
X (t (cmp-ce) (cmp-cevar)))
X (setq z (lex))
X (or (eq z #\}) (%error '|missing '}'| z))))
X
X(defun new-subnum (k)
X (or (numberp k) (%error '|tab must be a number| k))
X (setq *subnum* (round k)))
X
X(defun incr-subnum nil (setq *subnum* (1+ *subnum*)))
X
X(defun cmp-ce nil
X (prog (z)
X (new-subnum 0.)
X (setq *cur-vars* nil)
X (setq z (lex))
X (and (atom z)
X (%error '|atomic conditions are not allowed| z))
X (prepare-sublex z)
X la (and (end-of-ce) (return nil))
X (incr-subnum)
X (cmp-element)
X (go la)))
X
X(defun cmp-element nil
X (and (eq (peek-sublex) #\^) (cmp-tab))
X (cond ((eq (peek-sublex) '#\{) (cmp-product))
X (t (cmp-atomic-or-any))))
X
X(defun cmp-atomic-or-any nil
X (cond ((eq (peek-sublex) '<<) (cmp-any))
X (t (cmp-atomic))))
X
X(defun cmp-any nil
X (prog (a z)
X (sublex)
X (setq z nil)
X la (cond ((end-of-ce) (%error '|missing '>>'| a)))
X (setq a (sublex))
X (cond ((not (eq '>> a)) (setq z (cons a z)) (go la)))
X (link-new-node (list '&any nil (current-field) z))))
X
X
X(defun cmp-tab nil
X (prog (r)
X (sublex)
X (setq r (sublex))
X (setq r ($litbind r))
X (new-subnum r)))
X
X(defun $litbind (x)
X (prog (r)
X (cond ((and (symbolp x) (setq r (literal-binding-of x)))
X (return r))
X (t (return x)))))
X
X(defun get-bind (x)
X (prog (r)
X (cond ((and (symbolp x) (setq r (literal-binding-of x)))
X (return r))
X (t (return nil)))))
X
X(defun cmp-atomic nil
X (prog (test x)
X (setq x (peek-sublex))
X (cond ((eq x '=) (setq test 'eq) (sublex))
X ((eq x '<>) (setq test 'ne) (sublex))
X ((eq x '<) (setq test 'lt) (sublex))
X ((eq x '<=) (setq test 'le) (sublex))
X ((eq x '>) (setq test 'gt) (sublex))
X ((eq x '>=) (setq test 'ge) (sublex))
X ((eq x '<=>) (setq test 'xx) (sublex))
X (t (setq test 'eq)))
X (cmp-symbol test)))
X
X(defun cmp-product nil
X (prog (save)
X (setq save (rest-of-ce))
X (sublex)
X la (cond ((end-of-ce)
X (cond ((member #\} save)
X (%error '|wrong contex for '}'| save))
X (t (%error '|missing '}'| save))))
X ((eq (peek-sublex) #\}) (sublex) (return nil)))
X (cmp-atomic-or-any)
X (go la)))
X
X(defun variablep (x) (and (symbolp x) (char-equal
(char (symbol-name x) 0) #\<)))
X
X(defun cmp-symbol (test)
X (prog (flag)
X (setq flag t)
X (cond ((eq (peek-sublex) '//) (sublex) (setq flag nil)))
X (cond ((and flag (variablep (peek-sublex)))
X (cmp-var test))
X ((numberp (peek-sublex)) (cmp-number test))
X ((symbolp (peek-sublex)) (cmp-constant test))
X (t (%error '|unrecognized symbol| (sublex))))))
X
X(defun concat3(x y z)
X (intern (format nil "~s~s~s" x y z)))
X
X(defun cmp-constant (test)
X (or (member test '(eq ne xx) )
X (%error '|non-numeric constant after numeric predicate| (sublex)))
X (link-new-node (list (concat3 't test 'a)
X nil
X (current-field)
X (sublex))))
X
X
X(defun cmp-number (test)
X (link-new-node (list (concat3 't test 'n)
X nil
X (current-field)
X (sublex))))
X
X(defun current-field nil (field-name *subnum*))
------------------------------
End of AIList Digest
********************
