Copy Link
Add to Bookmark
Report
AIList Digest Volume 5 Issue 020
AIList Digest Wednesday, 28 Jan 1987 Volume 5 : Issue 20
Today's Topics:
AI Expert Magazine Sources (Part 3 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 3 of 22)
X
XisAKO
X ^self getSlot: 'AKO' facet:'value'!
X
XisAKO: aFrame
X "set the AKO slot of a frame"
X
X self setSlot:'AKO' value:aFrame!
X
XlookUpAkoChain: slotName
X "Look up the inheritance chain for a slot with the name in slotName.
X If you find it, return the Slot"
X
X ^(self includesKey: 'AKO')
X ifTrue:[((self isAKO) includesKey:slotName)
X ifTrue: [^(self isAKO) getSlot: slotName]
X ifFalse:[^(self isAKO) lookUpAkoChain: slotName]]
X ifFalse:[nil]!
X
XremoveSlot: slotName
X ^self removeKey:slotName ifAbsent:[nil]!
X
XrunDemonForValue: slotName
X
X | aBlock |
X aBlock := self getSlot: slotName facet: 'ifNeeded'.
X (aBlock isNil)
X ifTrue: [^nil]
X ifFalse:[^self setSlot:slotName value:(aBlock value)]!
X
XsetSlot: slotName facet: facetName with: value
X
X | tempSlot |
X tempSlot := self at:slotName
X ifAbsent: [self at:slotName put: Slot new].
X tempSlot setFacet: facetName with: value.
X ^value!
X
XsetSlot:slotName value:aValue
X "set the value facet of a slot"
X
X ^self setSlot:slotName facet:'value' with:aValue.!
X
XsetSlot:slotName with: aSlot
X "associate the slot aSlot with the name slotName. "
X
X ^self at: slotName put: aSlot! !
X
X
XFRMTRM.TXT
X
X| mammal dog fido s askDemon t |
X" Examples of frame and slot classes in use.
X Select and DOIT."
X
Xmammal := Frame new.
Xmammal setSlot: 'hide' value: 'hairy'.
Xmammal setSlot: 'bloodType' value: 'warm'.
X
Xdog := Frame new.
Xdog isAKO: mammal.
Xdog setSlot: 'numberLegs' value: 4.
X
XaskDemon := [Prompter prompt:'What is this dog''s name?' default: 'Bruno'].
Xdog addDemon:askDemon slot:'name' type:'ifNeeded'.
X
Xfido := Frame new.
Xfido addDemon:askDemon slot:'name' type:'ifNeeded'.
Xfido isAKO:dog.
Xfido setSlot:'color' value:'brown'.
X
X" Let's see the demon fire "
Xfido getSlotValue:'name'.
X
X
XSLOT.CLS
X
XDictionary variableSubclass: #Slot
X instanceVariableNames: ''
X classVariableNames: ''
X poolDictionaries: '' !
X
X!Slot class methods ! !
X
X
X!Slot methods !
X
XgetFacet: facetName
X ^self at: facetName ifAbsent: [nil]!
X
XgetValue
X ^self getFacet: 'value'!
X
XremoveFacet: facetName
X ^self removeKey:facetName ifAbsent:[nil]!
X
XsetFacet: facetName with: aValue
X
X self at: facetName put: aValue.
X ^aValue!
X
XsetValue: aValue
X self setFacet: 'value' with: aValue! !
X a
echo shar: "a missing newline was added to 'EXPERT.JAN'"
echo shar: "55 control characters may be missing from 'EXPERT.JAN'"
SHAR_EOF
if test 7019 -ne "`wc -c < 'EXPERT.JAN'`"
then
echo shar: "error transmitting 'EXPERT.JAN'"
'(should have been 7019 characters)'
fi
fi
echo shar: "extracting 'FILES.JAN'" '(837 characters)'
if test -f 'FILES.JAN'
then
echo shar: "will not over-write existing file 'FILES.JAN'"
else
sed 's/^X//' << \SHAR_EOF > 'FILES.JAN'
X
X
X Articles and Departments that have
X Additional On-Line Files
X
X AI EXPERT
X January 1987
X (Note: Contents page is in file CONTNT.JAN)
X
X
X
X
XARTICLES RELEVANT FILES
X-------- --------------
X
XJanuary Table of Contents CONTNT.JAN
X
XAdding Rete Net to Your OPS5 Toolbox OPSNET.JAN
Xby Dan Neiman
X
XPerceptrons & Neural Nets PERCEP.JAN
Xby Peter Reece
X
X
XDEPARTMENTS
X
XExpert's Toolbox EXPERT.JAN
X"Using Smalltalk to Implement Frames"
Xby Marc Rettig
X
XAI Apprentice AIAPP.JAN
X"Creating Expert Systems frm Examples"
Xby Beverly and Bill Thompson
X
SHAR_EOF
if test 837 -ne "`wc -c < 'FILES.JAN'`"
then
echo shar: "error transmitting 'FILES.JAN'"
'(should have been 837 characters)'
fi
fi
echo shar: "extracting 'OPSNET.JAN'" '(359936 characters)'
if test -f 'OPSNET.JAN'
then
echo shar: "will not over-write existing file 'OPSNET.JAN'"
else
sed 's/^X//' << \SHAR_EOF > 'OPSNET.JAN'
X
X
X Adding the Rete Net to Your OPS5 Toolbox
X (Supplemental files arranged by filename headings)
X January 1987 AI EXPERT
X by Dan Neiman
X
X
X
XEditor's Note:
X
XAdditional notes and clarifications for Imperative Pattern Match code,
Xas described in January '87 issue of AI/Expert.
X
XThe code described in AI/Expert is still evolving (i.e. the more I use it,
the more
Xfeatures I add), and there was not sufficient space to give complete
instructions in
Xthe magazine, so the following notes should be used as a supplement to the
Xarticle.
X
XTo use the Rete net modifications, load the code into an existing Common
Lisp OPS5
Ximage. Then use the pmatch and map-pmatch functions as described in the
article.
X
X
XIt was probably not made clear in the article, but both pmatch and map-pmatch
Xreturn the values of the last expression evaluated in the righthand side.
So,
Xfor example, to get the names of all employees making 30K a year, you might
use the
Xcode:
X?(map-pmatch (employees ^name <emp> ^salary > 30000)
X -->
X ?<emp> )
X
XThe RHS of the above function just evaluates and returns the binding
of <emp>.
XBecause the function used was map-pmatch, a list of *all* employees
satisfying the
Xgiven constraints is returned.
X
XThe syntax of the pmatch and map-pmatch commands has been modified slightly
since
Xthe article went to press. The method described for passing Lisp variables
to a
Xpattern match function proved to be inexpressibly awkward for lexically bound
Lisps
X(the system was originally written in Franz). The following modification
makes it
Xconsiderably easier to pass arguments to the pattern match routines.
X
XBecause the pattern match is compiled, the only way to interactively match
a particular
Xvalue is to write that value into working memory, and include that working
memory element
Xin the pattern match. This is fairly awkward to do by hand, so I've
incorporated a macro
Xinto the pmatch and map-pmatch commands which do it automagically. The
arguments are passed
Xby following the pmatch function with an argument list. The argument
list is distinguished
Xfrom a pattern by the "args" keyword. The syntax is:
X
X(pmatch (args arg1 arg2 ... argN)
X (condition element 1)
X (condition element 2)
X -->
X RHS)
X
XAfter macro expansion, the result is effectively
X (let ((tt (make ipm$data arg1 arg2 ... argN)))
X (query1 (ipm$data <arg1> <arg2> <arg3>)
X (condition element 1)
X (condition element 2)
X : : :
X -->
X RHS)
X (oremove tt) )
X
XNote that the working memory element is added and deleted automatically.
X
XAs an example, the code to locate all children of a couple might look like
this
X(defun children(mother father)
X ?(map-pmatch (args mother father)
X (mother ^name <mother> ^child <child>)
X (father ^name <father> ^child <child>)
X -->
X (make parents ^name <child> ^father <father> ^mother <mother>)
X ?<child>)
X
Xand given the working memory:
X(mother ^name ann ^child bob)
X(father ^name fred ^child bob)
X(mother ^name sue ^child alex)
X(father ^name fred ^child john)
X(mother ^name ann ^child john)
X(father ^name fred ^child cheryl)
X
X(children 'ann 'fred) would return (bob john)
X
Xand create the working memory elements
X
X(parents ^name bob ^father fred ^mother ann)
X(parents ^name john ^father fred ^mother ann)
X
XDebugging code: As is the case with OPS5 productions, if you recompile
a pmatch
Xor map-pmatch function, you must remove working memory and replace it.
A pattern match
Xwill only work on data which has been added after compilation. This does
tend to
Xmake debugging tedious.
X
XEverytime a pmatch operation is recompiled, it generates a new body bound
to a variable of
Xthe form queryN. Because queries are not explictly named, it's difficult
to automatically
Xexcise them. So the net will tend to fill with superfluous nodes during
debugging.
XThe function exquery will excise all existing queries. Executing the
sequence,
X(oremove *)
X(exquery)
X(i-g-v)
X
Xwill remove all working memory and queries and reset all global variables.
X
XIf a pmatch or map-pmatch function blows up while evaluating its RHS, reset
the
Xglobal variable *in-rhs* to nil before proceeding.
X
XQuestions about this code can be directed to:
XDan Neiman
XCompuServe 72277,2604
XCSNET dann@UMASS-CS.csnet
X
Xor c/o COINS Dept.
X Lederle Graduate Research Center
X University of Massachusetts
X Amherst, MA 01003
X
X
XIndex to software:
X
XCLSUP.LSP : Common Lisp support functions to define some canonical
X functions missing in Common Lisp.
X
XOPSMODS.L : The OPS5 modifications described in the article.
X
XCOMMON.OPS : OPS5 for Common Lisp
XTI.OPS : OPS5 for TI Explorers
XFRANZ.OPS : OPS5 for Franz Lisp
X
XMONK.OPS : Test file for OPS5
XPRTOWER.OPS : Test file for OPS5
X
X
XNEWOPS.L
X
X;OPS5 modifications for Common Lisp
X; by: Dan Neiman
X; Original idea conceived at ITT ATC May, 1986
X; Converted to Common Lisp and expanded at COINS Dept., UMASS Fall 1986
X
X;Copyright notice: Much of this code is modified or original OPS5 code
; which is
X;copyrighted by C. Lanny Forgy of CMU, and is used with his permission.
; The rest is
X;Copyright (c) Daniel Neiman, COINS Dept. UMass. Permission is given to
; use this
X;code freely for personal, educational, or research applications. It is
; not to be
X;sold, or incorporated into a for-profit product without permission of
; the author.
X;The purpose of this code is to illustrate alternative uses of the Rete
; net and
X;alternative control structures in OPS5. No guarantees are made about
; its fitness
X;any particular application, and no claim is made about the presence or
; absence of
X;bugs.
X;Version of 12/12/86
X
X;This file contains the necessary OPS5 modifications to perform
X;the RHS pattern matching/control function described in the
X;accompanying January '87 AI/Expert article. The code is a supplement
; to OPS5 and is
X;intended to be loaded into a Common Lisp OPS5 image.
X
X;Note: The idea behind this modification is to add memory to the &p node
; and create
X;functions to interrogate that memory at will. Sort of an elegant idea.
; But, because
X;it has to be patched into an implementation which was not designed to do
; so, there's a
X;lot of fairly nasty looking code here. Take heart, most of it is just
; slightly modified
X;ops5 code and can be pretty much ignored.
X
X;This variable is used to determine if we encountered a pmatch
X;or map-pmatch in top-level lisp code or while compiling an
X;OPS5 production.
X
X(proclaim '(special *compiling-rhs* *qnames* *cmp-p-context-stack*
X *system-state-stack* *NMATCHES* *ipm-data-stack*))
X(setq *qnames* nil)
X(setq *system-state-stack* nil)
X(setq *cmp-p-context-stack* nil)
X(setq *compiling-rhs* nil)
X(setq *ipm-data-stack* nil)
X
X;Read macro for variable evaluation on "RHS" of pattern match
X;All &whatever macros on the righthand side must be preceded by
X;a ?. This will expand to ($varbind '&whatever)
X;To avoid having a plethora of read macros, ? will be double-duty.
X;If ? precedes a ?(pmatch ....), then the expression is evaluated
X;and the appropriate match stuff is placed in the rete net. The
;code is replaced by (query queryN pattern-body).
X
X;Read macro ? executes the following function.
X(defun $$ipm$$dofunc$$(strm chr)
X (let ((inp (read strm t nil t)))
X (cond ((atom inp)
X (if (eq '#\< (char (string inp) 0)) ;is it an OPS variable?
X `($varbind ',inp)
X (intern (concatenate 'string "?" (princ-to-string inp)))))
X ((member (car inp) '(map-pmatch pmatch) :test #'eq)
X (eval inp))
X (t
X inp))))
X
X
X;make ? a read macro
X(set-macro-character #\? #'$$ipm$$dofunc$$ t)
X
X(defun &query (rating name var-dope ce-var-dope rhs frhs)
X (prog (fp dp)
X (cond (*sendtocall*
X (setq fp *flag-part*)
X (setq dp *data-part*))
X (t
X (setq fp *alpha-flag-part*)
X (setq dp *alpha-data-part*)))
X (and (member fp '(nil old))
X (ipm-removepm name dp))
X (and fp (ipm-insertpm name dp))))
X
X
X; each conflict set element is a list of the following form:
X; ((p-name . data-part) (sorted wm-recency) special-case-number)
X
X;I'm storing the results of the pattern matches on a property list, pmatches.
X
X;modified OPS5 removecs
X;remove results of the pattern match
X
X(defun ipm-removepm (name cr-data)
X (prog (inst cs pmtchs)
X(setq pmtchs (setq cs (get name 'pmatches)))
X l(cond ((null cs)
X (return nil)))
X(setq inst (car cs))
X(setq cs (cdr cs))
X(and (not (top-levels-eq inst cr-data)) (go l))
X(putprop name (remove inst pmtchs)
X 'pmatches)
X))
X
X;modified OPS5 insertcs
X;store the results of the pattern match
X;Stored as (data ) rather than original conflict set format
X;of ((name . data) (order tags) rating)
X(defun ipm-insertpm (name data)
X (let ((pmtch (get name 'pmatches)))
X (setq pmtch (get name 'pmatches))
X (and (atom pmtch) (setq pmtch nil))
X (setq pmtch (cons data pmtch))
X (putprop name pmtch 'pmatches)
X pmtch
X ))
X
X;PMATCH is the RHS/LISP equivalent of the (p rule) macro. When used from Lisp,
X;it should always be preceded by the ? read macro, so as to force evaluation
X;at read time. Otherwise, the Rete net won't be set up correctly.
X
X(defmacro pmatch(&rest z)
X `(let ((pname (newsym query))
X (level (newsym level)))
X (finish-literalize)
X (princ '*)
X (cond ((and (listp (car ',z)) (eq (caar ',z) 'args))
X (ipm-compile-production pname (add-data-to-prod pname ',z ))
X `(let ((tt (make-ipm-data ',pname ,@(cdar ',z) ))
X (ans (query ',pname)))
X(restore-ipm-data tt)
X ans))
X (t
X (ipm-compile-production pname ',z)
X `(query ',pname)))))
X
X(defun restore-ipm-data(current)
X (let ((inrhsflg *in-rhs*)
X (old (pop *ipm-data-stack*)))
X (setq *in-rhs* nil)
X (eval (list 'oremove current))
X (setq *in-rhs* inrhsflg)
X (if old
X (add-to-wm (car old) (cdr old)))))
X
X;Note, the only way to pass input to the pattern matcher is to create a
X;working memory element containing that input. The following utility
; functions
X;automagically create the ipm$data working memory element and modify the
X;production to use it.
X
X;MAKE-DATA: Make data takes a list of values and a unique level specifier
X;and creates a working memory element of the form (ipm$data val1 val2
; val3 .. )
X;Saves old ipm$data elements on stack so that no interference results.
X(defun make-ipm-data(&rest arglst)
X (let ((inrhsflg *in-rhs*)
X (old (car (get 'ipm$data 'wmpart*))))
X (if old (push old *ipm-data-stack*))
X (setq *in-rhs* nil)
X (eval (list 'oremove (cdr old))) ;needs in-rhs to be nil
X (setq *in-rhs* inrhsflg)
X ($reset)
X ($change 'ipm$data)
(mapc #'(lambda(tab val)
X ($tab tab)
X ($change val))
X '(a b c d e f g h i j k l) (cdr arglst))
X ($tab 'for) ;target data for particular query
X ($change (car arglst))
X ($assert)))
X
X;Modify the production so that it accesses the data passed by the ipm$data wme
X(defun add-data-to-prod(pname prod)
X (let ((args (cdar prod))
X (body (cdr prod)))
X (cons
X `(ipm$data ,@(mapcan #'(lambda(slot arg) (list '^ slot (concat
'\< arg '\> )))
X '(a b c d e f g h i j k l) args)
X ^for ,pname)
X body)))
X
X
X;Finish-literalize: modified to define special wme type ipm$data which
; is used to
X;transfer lisp arguments to working memory.
X(defun finish-literalize nil
X (cond ((not (null *class-list*))
X (cond ((not (member 'ipm$data *class-list*))
X (literalize ipm$data a b c d e f g h i j k l for)))
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
X
X;Map the RHS across all matching data.
X(defmacro map-pmatch(&rest z)
X `(let ((pname (newsym query))
X (level (newsym level)))
X (finish-literalize)
X (princ '*)
X (cond ((and (listp (car ',z)) (eq (caar ',z) 'args))
X (ipm-compile-production pname (add-data-to-prod pname ',z ))
X `(let ((tt (make-ipm-data ',pname ,@(cdar ',z) ))
X (ans (map-query ',pname)))
X(restore-ipm-data tt)
Xans))
X (t
X (ipm-compile-production pname ',z)
X `(map-query ',pname)))))
X
X
X(defun ipm-compile-production (name matrix)
X (prog (erm)
X (setq *p-name* name)
(cond (*compiling-rhs*
X (setq erm (catch (ipm-cmp-p-recursive name matrix) '!error!)))
X (t
X (setq erm (catch (ipm-cmp-p name matrix) '!error!))))
X; following line is modified to save production name on *qnames*
X (pushnew name *qnames*)
X(return erm)))
X
X
X;save globals *feature-count *ce-count* *vars* *ce-vars* *rhs-bound-vars*
X;*rhs-bound-ce-vars* *last-branch* on a push-down stack.
X
X;Push global variables takes a stack name, and a list of global variables,
; creates a
X;list of lists of the form ((varname value) (varname value) ... ) and
; pushes it onto
X;the indicated stack.
X
X(defun push-global-variables(stack &rest vars)
X (push
X (mapcar #'(lambda(var)
X (cons var (eval var))) ;copy may not be needed, but
; better safe....
X vars)
X (symbol-value stack)))
X
X;Pop global variables takes a stack name, pops most recent entry off
; the stack,
X;and resets the values of the variables.
X(defun pop-global-variables(stack)
X (mapcar #'(lambda(varbinding)
X (set (car varbinding) (cdr varbinding)))
X (pop stack)) )
------------------------------
End of AIList Digest
********************
