;;; ****************************************************************
;;; OPS5 Interpreter ***********************************************
;;; ****************************************************************
;;; This Common Lisp version of OPS5 is in the public domain. It is based
;;; in part on based on a Franz Lisp implementation done by Charles L. Forgy
;;; at Carnegie-Mellon University, which was placed in the public domain by
;;; the author in accordance with CMU policies. Ported to Common Lisp by
;;; George Wood and Jim Kowalski. CMU Common Lisp modifications by
;;; Dario Guise, Skef Wholey, Michael Parzen, and Dan Kuokka.
;;; Modified to work in CLtL1, CLtL2 and X3J13 compatible lisps by
;;; Mark Kantrowitz on 14-OCT-92.
;;;
;;; This code is made available is, and without warranty of any kind by the
;;; authors or by Carnegie-Mellon University.
;;;
;;;; This file contains the top-level functions, function to literalize
;;;; and access attributes, and functions to manage the conflict set.
(in-package "OPS")
;; (export '(literalize p vector-attribute strategy watch reset-ops))
;;; Global variables used in this module only.
(defvar *limit-token* nil)
(defvar *total-wm* nil)
(defvar *max-token* nil)
(defvar *total-token* nil)
(defvar *brkpts* nil)
(defvar *phase* nil)
(defvar *break-flag* nil)
(defvar *remaining-cycles* nil)
(defvar *conflict-set* nil)
(defvar *max-cs* nil)
(defvar *total-cs* nil)
(defvar *limit-cs* nil)
(defvar *strategy* nil)
(defvar *class-list* nil)
(defvar *buckets* nil)
(defun main-init ()
(setq *cycle-count* 0.)
(setq *p-name* nil)
(setq *ptrace* t)
(setq *wtrace* nil)
(setq *limit-token* 1000000.)
(setq *limit-cs* 1000000.)
(setq *total-wm* 0.)
(setq *total-token* (setq *max-token* 0.))
(setq *max-cs* (setq *total-cs* 0.))
(setq *conflict-set* nil)
(setq *strategy* 'lex)
(setq *buckets* 127.) ; regular OPS5 allows 64 named slots
(setq *class-list* nil)
(setq *brkpts* nil)
(setq *remaining-cycles* 1000000))
;;;; Top level commands.
(defmacro run (&body z)
`(ops-run ',z))
(defmacro ppwm (&body avlist)
`(ops-ppwm ',avlist))
(defmacro wm (&body a)
`(ops-wm ',a))
(defmacro pm (&body z)
`(ops-pm ',z))
(defmacro cs (&body z)
`(ops-cs ',z))
(defmacro matches (&body rule-list)
`(ops-matches ',rule-list))
(defmacro strategy (&body z)
`(ops-strategy ',z))
(defmacro watch (&body z)
`(ops-watch ',z))
(defmacro pbreak (&body z)
`(ops-pbreak ',z))
(defmacro excise (&body z)
`(ops-excise ',z))
(defmacro p (&body z)
`(ops-p ',z))
(defmacro external (&body z)
`(ops-external ',z))
(defmacro literal (&body z)
`(ops-literal ',z))
(defmacro literalize (&body z)
`(ops-literalize ',z))
(defmacro vector-attribute (&body l)
`(ops-vector-attribute ',l))
(defun top-level-remove (z)
(cond ((equal z '(*)) (process-changes nil (get-wm nil)))
(t (process-changes nil (get-wm z)))))
;;; Functions for run command
(defun ops-run (z)
(cond ((atom z) (setq *remaining-cycles* 1000000.) (do-continue nil))
((and (atom (cdr z)) (numberp (car z)) (> (car z) 0.))
(setq *remaining-cycles* (car z))
(do-continue nil))
(t 'what?)))
(defun do-continue (wmi)
(cond (*critical*
(terpri)
(princ '|warning: network may be inconsistent|)))
(process-changes wmi nil)
(print-times (main)))
(defun process-changes (adds dels)
(prog (x)
process-deletes (and (atom dels) (go process-adds))
(setq x (car dels))
(setq dels (cdr dels))
(remove-from-wm x)
(go process-deletes)
process-adds (and (atom adds) (return nil))
(setq x (car adds))
(setq adds (cdr adds))
(add-to-wm x nil)
(go process-adds)))
(defun main nil
(prog (instance r)
(setq *halt-flag* nil)
(setq *break-flag* nil)
(setq instance nil)
dil (setq *phase* 'conflict-resolution)
(cond (*halt-flag*
(setq r '|end -- explicit halt|)
(go finis))
((zerop *remaining-cycles*)
(setq r '***break***)
(setq *break-flag* t)
(go finis))
(*break-flag* (setq r '***break***) (go finis)))
(setq *remaining-cycles* (1- *remaining-cycles*))
(setq instance (conflict-resolution))
(cond ((not instance)
(setq r '|end -- no production true|)
(go finis)))
(setq *phase* (car instance))
(accum-stats)
(eval-rhs (car instance) (cdr instance))
(check-limits)
(and (broken (car instance)) (setq *break-flag* t))
(go dil)
finis (setq *p-name* nil)
(return r)))
(defun broken (rule) (member rule *brkpts*))
(defun accum-stats nil
(setq *cycle-count* (1+ *cycle-count*))
(setq *total-token* (+ *total-token* *current-token*))
;"plus" changed to "+" by gdw
(cond ((> *current-token* *max-token*)
(setq *max-token* *current-token*)))
(setq *total-wm* (+ *total-wm* *current-wm*)) ;"plus" changed to "+" by gdw
(cond ((> *current-wm* *max-wm*) (setq *max-wm* *current-wm*))))
(defun check-limits nil
(cond ((> (length *conflict-set*) *limit-cs*)
(format t "~%~%conflict set size exceeded the limit of ~D after ~D~%"
*limit-cs* *p-name*)
(setq *halt-flag* t)))
(cond ((> *current-token* *limit-token*)
(format t "~%~%token memory size exceeded the limit of ~D after ~D~%"
*limit-token* *p-name*)
(setq *halt-flag* t))))
(defun print-times (mess)
(prog (cc)
(cond (*break-flag* (terpri) (return mess)))
(setq cc (+ (float *cycle-count*) 1.0e-20))
(terpri)
(princ mess)
(terpri)
(format t "~3D productions (~D // ~D nodes)~%"
*pcount* *real-cnt* *virtual-cnt*)
(format t "~3D firings (~D rhs actions)~%"
*cycle-count* *action-count*)
(format t "~3D mean working memory size (~D maximum)~%"
(round (float *total-wm*) cc) *max-wm*)
(format t "~3D mean conflict set size (~D maximum)~%"
(round (float *total-cs*) cc) *max-cs*)
(format t "~3D mean token memory size (~D maximum)~%"
(round (float *total-token*) cc)
*max-token*)))
;;; Functions for strategy command
(defun ops-strategy (z)
(cond ((atom z) *strategy*)
((equal z '(lex)) (setq *strategy* 'lex))
((equal z '(mea)) (setq *strategy* 'mea))
(t 'what?)))
;;; Functions for watch command
(defun ops-watch (z)
(cond ((equal z '(0.))
(setq *wtrace* nil)
(setq *ptrace* nil)
0.)
((equal z '(1.)) (setq *wtrace* nil) (setq *ptrace* t) 1.)
((equal z '(2.)) (setq *wtrace* t) (setq *ptrace* t) 2.)
((equal z '(3.))
(setq *wtrace* t)
(setq *ptrace* t)
'(2. -- conflict set trace not supported))
((and (atom z) (null *ptrace*)) 0.)
((and (atom z) (null *wtrace*)) 1.)
((atom z) 2.)
(t 'what?)))
;;; Functions for excise command
(defun ops-excise (z) (mapc (function excise-p) z))
(defun excise-p (name)
(cond ((and (symbolp name) (gethash name *topnode-table*))
(format t "~S is excised~%" name)
(setq *pcount* (1- *pcount*))
(remove-from-conflict-set name)
(kill-node (gethash name *topnode-table*))
(remhash name *production-table*)
(remhash name *backpointers-table*)
(remhash name *topnode-table*))))
(defun kill-node (node)
(prog nil
top (and (atom node) (return nil))
(rplaca node '&old)
(setq node (cdr node))
(go top)))
;;; Functions for external command
(defun ops-external (z) (catch '!error! (external2 z))) ;jgk inverted args
;& quoted tag
(defun external2 (z) (mapc (function external3) z))
(defun external3 (x)
(cond ((symbolp x) (setf (gethash x *external-routine-table*) t))
(t (%error '|not a legal function name| x))))
;;; Functions for pbreak command
(defun ops-pbreak (z)
(cond ((atom z) (terpri) *brkpts*)
(t (mapc (function pbreak2) z) nil)))
(defun pbreak2 (rule)
(cond ((not (symbolp rule)) (%warn '|illegal name| rule))
((not (gethash rule *topnode-table*)) (%warn '|not a production| rule))
((member rule *brkpts*) (setq *brkpts* (rematm rule *brkpts*)))
(t (setq *brkpts* (cons rule *brkpts*)))))
(defun rematm (atm list)
(cond ((atom list) list)
((eq atm (car list)) (rematm atm (cdr list)))
(t (cons (car list) (rematm atm (cdr list))))))
;;; Functions for matches command
(defun ops-matches (rule-list)
(mapc #'matches2 rule-list)
(terpri))
(defun matches2 (p)
(cond ((atom p)
(format t "~2&~A" p)
(matches3 (gethash p *backpointers-table*) 2. (list 1.)))))
(defun matches3 (nodes ce part)
(cond ((not (null nodes))
(format t "~& ** matches for ~A ** "
part)
(mapc #'write-elms (find-left-mem (car nodes)))
(format t "~& ** matches for ~A ** "
(list ce))
(mapc #'write-elms (find-right-mem (car nodes)))
(matches3 (cdr nodes) (1+ ce) (cons ce part)))))
(defun write-elms (wme-or-count)
(cond ((consp wme-or-count) ;dtpr\consp gdw
(terpri)
(mapc #'write-elms2 wme-or-count))))
(defun write-elms2 (x)
(princ '| |)
(princ (creation-time x)))
(defun find-left-mem (node)
(cond ((eq (car node) '&and) (memory-part (caddr node)))
(t (car (caddr node)))))
(defun find-right-mem (node) (memory-part (cadddr node)))
;;; Function for cs command.
(defun ops-cs (z)
(cond ((atom z) (conflict-set))
(t 'what?)))
;;;; Functions for literalize and related operations.
(defun ops-literal (z)
(prog (atm val old)
top (and (atom z) (return 'bound))
(or (eq (cadr z) '=) (return (%warn '|wrong format| z)))
(setq atm (car z))
(setq val (caddr z))
(setq z (cdddr z))
(cond ((not (numberp val))
(%warn '|can bind only to numbers| val))
((or (not (symbolp atm)) (variablep atm))
(%warn '|can bind only constant atoms| atm))
((and (setq old (literal-binding-of atm)) (not (equal old val)))
(%warn '|attempt to rebind attribute| atm))
(t (setf (gethash atm *ops-bind-table*) val)))
(go top)))
(defun ops-literalize (l)
(prog (class-name atts)
(setq class-name (car l))
(cond ((have-compiled-production)
(%warn '|literalize called after p| class-name)
(return nil))
((gethash class-name *att-list-table*)
(%warn '|attempt to redefine class| class-name)
(return nil)))
(setq *class-list* (cons class-name *class-list*))
(setq atts (remove-duplicates (cdr l))) ; ??? should this
; warn of dup atts?
(test-attribute-names atts)
(mark-conflicts atts atts)
(setf (gethash class-name *att-list-table*) atts)))
(defun ops-vector-attribute (l)
(cond ((have-compiled-production)
(%warn '|vector-attribute called after p| l))
(t
(test-attribute-names l)
(mapc #'set-vector-attribute l))))
(defun test-attribute-names (l)
(mapc #'test-attribute-names2 l))
(defun test-attribute-names2 (atm)
(cond ((or (not (symbolp atm)) (variablep atm))
(%warn '|can bind only constant atoms| atm))))
(defun finish-literalize nil
(cond ((not (null *class-list*))
(mapc #'note-user-assigns *class-list*)
(mapc #'assign-scalars *class-list*)
(mapc #'assign-vectors *class-list*)
(mapc #'put-ppdat *class-list*)
(mapc #'erase-literal-info *class-list*)
(setq *class-list* nil)
(setq *buckets* nil))))
(defun have-compiled-production nil (not (zerop *pcount*)))
(defun put-ppdat (class)
(prog (al att ppdat)
(setq ppdat nil)
(setq al (gethash class *att-list-table*))
top (cond ((not (atom al))
(setq att (car al))
(setq al (cdr al))
(setq ppdat
(cons (cons (literal-binding-of att) att)
ppdat))
(go top)))
(setf (gethash class *ppdat-table*) ppdat)))
; note-user-assigns and note-user-vector-assigns are needed only when
; literal and literalize are both used in a program. They make sure that
; the assignments that are made explicitly with literal do not cause problems
; for the literalized classes.
(defun note-user-assigns (class)
(mapc #'note-user-assigns2 (gethash class *att-list-table*)))
(defun note-user-assigns2 (att)
(prog (num conf buck clash)
(setq num (literal-binding-of att))
(and (null num) (return nil))
(setq conf (gethash att *conflicts-table*))
(setq buck (store-binding att num))
(setq clash (find-common-atom buck conf))
(and clash
(%warn '|attributes in a class assigned the same number|
(cons att clash)))
(return nil)))
(defun note-user-vector-assigns (att given needed)
(and (> needed given)
(%warn '|vector attribute assigned too small a value in literal| att)))
(defun assign-scalars (class)
(mapc #'assign-scalars2 (gethash class *att-list-table*)))
(defun assign-scalars2 (att)
(prog (tlist num bucket conf)
(and (literal-binding-of att) (return nil))
(and (is-vector-attribute att) (return nil))
(setq tlist (buckets))
(setq conf (gethash att *conflicts-table*))
top (cond ((atom tlist)
(%warn '|could not generate a binding| att)
(store-binding att -1.)
(return nil)))
(setq num (caar tlist))
(setq bucket (cdar tlist))
(setq tlist (cdr tlist))
(cond ((disjoint bucket conf) (store-binding att num))
(t (go top)))))
(defun assign-vectors (class)
(mapc #'assign-vectors2 (gethash class *att-list-table*)))
(defun assign-vectors2 (att)
(prog (big conf new old need)
(and (not (is-vector-attribute att)) (return nil))
(setq big 1.)
(setq conf (gethash att *conflicts-table*))
top (cond ((not (atom conf))
(setq new (car conf))
(setq conf (cdr conf))
(cond ((is-vector-attribute new)
(%warn '|class has two vector attributes|
(list att new)))
(t (setq big (max (literal-binding-of new) big))))
(go top)))
(setq need (1+ big)) ;"plus" changed to "+" by gdw
(setq old (literal-binding-of att))
(cond (old (note-user-vector-assigns att old need))
(t (store-binding att need)))
(return nil)))
(defun disjoint (la lb) (not (find-common-atom la lb)))
(defun find-common-atom (la lb)
(prog nil
top (cond ((null la) (return nil))
((member (car la) lb) (return (car la)))
(t (setq la (cdr la)) (go top)))))
(defun mark-conflicts (rem all)
(cond ((not (null rem))
(mark-conflicts2 (car rem) all)
(mark-conflicts (cdr rem) all))))
(defun mark-conflicts2 (atm lst)
(prog (l)
(setq l lst)
top (and (atom l) (return nil))
(conflict atm (car l))
(setq l (cdr l))
(go top)))
(defun conflict (a b)
(prog (old)
(setq old (gethash a *conflicts-table*))
(and (not (eq a b))
(not (member b old))
(setf (gethash a *conflicts-table*) (cons b old)))))
;@@@ use intrinsic
;(defun remove-duplicates (lst)
; (cond ((atom lst) nil)
; ((member (car lst) (cdr lst)) (remove-duplicates (cdr lst)))
; (t (cons (car lst) (remove-duplicates (cdr lst))))))
(defun literal-binding-of (name) (gethash name *ops-bind-table*))
(defun store-binding (name lit)
(setf (gethash name *ops-bind-table*) lit)
(add-bucket name lit))
(defun add-bucket (name num)
(prog (buc)
(setq buc (assoc num (buckets)))
(and (not (member name buc))
(rplacd buc (cons name (cdr buc))))
(return buc)))
(defun buckets nil
(and (atom *buckets*) (setq *buckets* (make-nums *buckets*)))
*buckets*)
(defun make-nums (k)
(prog (nums)
(setq nums nil)
l (and (< k 2.) (return nums))
(setq nums (cons (list k) nums))
(setq k (1- k))
(go l)))
(defun erase-literal-info (class)
(mapc #'erase-literal-info2 (gethash class *att-list-table*))
(remhash class *att-list-table*))
(defun erase-literal-info2 (att)
(remhash att *conflicts-table*))
;;;; Functions for conflict set management and resolution.
;;; Each conflict set element is a list of the following form:
;;; ((p-name . data-part) (sorted wm-recency) special-case-number)
(defun conflict-resolution nil
(let ((len (length *conflict-set*)))
(when (> len *max-cs*)
(setq *max-cs* len))
(incf *total-cs* len) ;"plus" changed to "+" by gdw
(when *conflict-set*
(let ((best (best-of *conflict-set*)))
(setq *conflict-set* (delete best *conflict-set* :test #'eq))
(pname-instantiation best)))))
(defun removecs (name data)
(prog (cr-data inst cs)
(setq cr-data (cons name data))
(setq cs *conflict-set*)
loop (cond ((null cs)
(record-refract name data)
(return nil)))
(setq inst (car cs))
(setq cs (cdr cs))
(and (not (top-levels-eq (car inst) cr-data)) (go loop))
(setq *conflict-set* (delete inst *conflict-set* :test #'eq))))
(defun insertcs (name data rating)
(if (refracted name data)
nil
(let ((instan (list (cons name data) (order-tags data) rating)))
(when (atom *conflict-set*)
(setq *conflict-set* nil))
(push instan *conflict-set*))))
(defun remove-from-conflict-set (name)
(prog (cs entry)
l1 (setq cs *conflict-set*)
l2 (cond ((atom cs) (return nil)))
(setq entry (car cs))
(setq cs (cdr cs))
(cond ((eq name (caar entry))
(setq *conflict-set* (delete entry *conflict-set* :test #'eq))
(go l1))
(t (go l2)))))
(defun order-tags (dat)
(prog (tags)
(setq tags nil)
l1p (and (atom dat) (go l2p))
(setq tags (cons (creation-time (car dat)) tags))
(setq dat (cdr dat))
(go l1p)
l2p (cond ((eq *strategy* 'mea)
(return (cons (car tags) (dsort (cdr tags)))))
(t (return (dsort tags))))))
(defun dsort (x)
"Destructively sort x into descending order."
(prog (sorted cur next cval nval)
(and (atom (cdr x)) (return x))
loop (setq sorted t)
(setq cur x)
(setq next (cdr x))
chek (setq cval (car cur))
(setq nval (car next))
(cond ((> nval cval)
(setq sorted nil)
(rplaca cur nval)
(rplaca next cval)))
(setq cur next)
(setq next (cdr cur))
(cond ((not (null next)) (go chek))
(sorted (return x))
(t (go loop)))))
(defun best-of (set)
(best-of* (car set) (cdr set)))
(defun best-of* (best rem)
(cond ((not rem) best)
((conflict-set-compare best (car rem))
(best-of* best (cdr rem)))
(t (best-of* (car rem) (cdr rem)))))
(defun pname-instantiation (conflict-elem) (car conflict-elem))
(defun order-part (conflict-elem) (cdr conflict-elem))
(defun instantiation (conflict-elem)
(cdr (pname-instantiation conflict-elem)))
(defun conflict-set-compare (x y)
(prog (x-order y-order xl yl xv yv)
(setq x-order (order-part x))
(setq y-order (order-part y))
(setq xl (car x-order))
(setq yl (car y-order))
data (cond ((and (null xl) (null yl)) (go ps))
((null yl) (return t))
((null xl) (return nil)))
(setq xv (car xl))
(setq yv (car yl))
(cond ((> xv yv) (return t))
((> yv xv) (return nil)))
(setq xl (cdr xl))
(setq yl (cdr yl))
(go data)
ps (setq xl (cdr x-order))
(setq yl (cdr y-order))
psl (cond ((null xl) (return t)))
(setq xv (car xl))
(setq yv (car yl))
(cond ((> xv yv) (return t))
((> yv xv) (return nil)))
(setq xl (cdr xl))
(setq yl (cdr yl))
(go psl)))
(defun conflict-set nil
(prog (cnts cs p z best)
(setq cnts nil)
(setq cs *conflict-set*)
l1p (and (atom cs) (go l2p))
(setq p (caaar cs))
(setq cs (cdr cs))
(setq z (assoc p cnts))
(cond ((null z) (setq cnts (cons (cons p 1.) cnts)))
(t (rplacd z (1+ (cdr z)))))
(go l1p)
l2p (cond ((atom cnts)
(setq best (best-of *conflict-set*))
(terpri)
(return (list (caar best) 'dominates))))
(terpri)
(princ (caar cnts))
(cond ((> (cdar cnts) 1.)
(princ '| (|)
(princ (cdar cnts))
(princ '| occurrences)|)))
(setq cnts (cdr cnts))
(go l2p)))
;;; *EOF*