home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Simtel MSDOS 1992 June
/
SIMTEL_0692.cdr
/
msdos
/
aijournl
/
ai_nov86.arc
/
EXPERT.NOV
< prev
next >
Wrap
Text File
|
1986-09-25
|
6KB
|
145 lines
Expert's Toolbox
by Jonathan Amsterdam
November 1986 AI EXPERT magazine
;;; SFRL-A Simple Frame Representation Language.
;; Copyright 1986 by Jonathan Amsterdam.
(DEFVAR *FRAMES* NIL) ; A list of all the frames ever created (with
; FPUT or DEFFRAME).
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Interface to SFRL.
;;; DEFFRAME macro lets you peform several FPUTs at once. Example:
;(DEFFRAME MARY-CHUNGS
CLASSIFICATION INDIVIDUAL
AKO CHINESE-RESTAURANT
CITY CAMBRIDGE
LOCATION CENTRAL-SQUARE
PRICE MODERATE
SERVICE POOR
BEST-ITEMS (SUAN-LA-CHOW-SHOW DUN-DUN-NOODLE))
(DEFMACRO DEFFRAME (NAME &REST SLOTS-AND-VALUES)
`(PROGN
(PUSHNEW ',NAME *FRAMES*) ; PUSHNEW adds an item to a list
; if it isn't already there.
,@(LET ((RESULT NIL))
(DO ((S-AND-V SLOTS-AND-VALUES (CDDR S-AND-V)))
((NULL S-AND-V) (REVERSE RESULT))
(PUSH `(FPUT ',NAME ',(CAR S-AND-V) ',(CADR S-AND-V))
RESULT)))))
DEFUN FGET (FRAME SLOT)
(LET ((VALUE (GET-FACET-WITH-INHERITANCE FRAME SLOT 'VALUE)))
(OR VALUE
(RUN-DEMONS-FOR-VALUE
(COLLECT-FACET-WITH-INHERITANCE FRAME SLOT 'IF-NEEDED)
FRAME SLOT))))
; Only runs demons if something new added.
(DOLIST (VALUE (IF (LISTP VALUES) VALUES (LIST VALUES)))
(IF (ADD-TO-FACET FRAME SLOT 'VALUE VALUE)
(RUN-DEMONS (COLLECT-FACET-WITH-INHERITANCE FRAME SLOT
'IF-ADDED)
FRAME SLOT 'IF-ADDED VALUE))))
(DEFUN FREMOVE (FRAME SLOT VALUE)
; Only runs demons if something actually removed.
(IF (REMOVE-FROM-FACET FRAME SLOT 'VALUE VALUE)
(RUN-DEMONS (COLLECT-FACET-WITH-INHERITANCE FRAME SLOT
'IF-REMOVED)
FRAME SLOT 'IF-REMOVED VALUE)))
(DEFUN ADD-DEMON (FRAME SLOT FACET DEMON)
(IF (NOT (MEMBER FACET '(IF-NEEDED IF-ADDED IF-REMOVED)))
(ERROR "ADD-DEMON: Bad facet name: ~a" FACET)
(ADD-TO-FACET FRAME SLOT FACET DEMON)))
(DEFUN REMOVE-DEMON (FRAME SLOT FACET DEMON)
(IF (NOT (MEMBER FACET '(IF-NEEDED IF-ADDED IF-REMOVED)))
(ERROR "REMOVE-DEMON: Bad facet name: ~a" FACET)
(REMOVE-FROM-FACET FRAME SLOT FACET DEMON)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Functions for performing inheritance.
(DEFUN GET-FACET-WITH-INHERITANCE (FRAME SLOT FACET)
(IF (NULL FRAME)
NIL
(OR (GET-FACET FRAME SLOT FACET)
(MAPCAN #'(LAMBDA (F)
(COPY-LIST
(GET-FACET-WITH-INHERITANCE F SLOT FACET)))
(GET-FACET FRAME 'AKO 'VALUE)))))
(DEFUN COLLECT-FACET-WITH-INHERITANCE (FRAME SLOT FACET)
(IF (NULL FRAME)
NIL
(APPEND (GET-FACET FRAME SLOT FACET)
(MAPCAN #'(LAMBDA (F)
(COLLECT-FACET-WITH-INHERITANCE F SLOT
FACET))
(GET-FACET FRAME 'AKO 'VALUE)))))
;;; Demons.;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(DEFUN ASK-DEMON (FRAME SLOT)
; This is a typical IF-NEEDED demon.
(FORMAT T "~&What is the value of ~a for ~a? " SLOT FRAME)
(LET ((ANSWER (READ)))
(FPUT FRAME SLOT ANSWER)
ANSWER))
(DEFUN INFORM-DEMON (FRAME SLOT VALUE FACET)
; This is a typical IF-ADDED/IF-REMOVED demon.
(IF (EQL FACET 'IF-ADDED)
(FORMAT T "~&Adding ~a to " VALUE)
(FORMAT T "~&Removing ~a from " VALUE))
(FORMAT T "the ~a slot of ~a~%" SLOT FRAME))
(DEFUN RUN-DEMONS-FOR-VALUE (DEMON-LIST FRAME SLOT)
; Used for IF-NEEDED demons.
; Note: this could be implemented as
; (SOME #'(LAMBDA (DEMON) (FUNCALL DEMON FRAME SLOT)) DEMON-LIST)
; in Common Lisp.
(LET ((VAL (FUNCALL DEMON FRAME SLOT)))
(IF VAL
(RETURN VAL)))))
(DEFUN RUN-DEMONS (DEMON-LIST FRAME SLOT FACET VALUE)
; Used for IF-ADDED and IF-REMOVED demons.
(DOLIST (DEMON DEMON-LIST)
(FUNCALL DEMON FRAME SLOT VALUE FACET)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Low-level functions.
;;; Facets
;; A facet is a list (<facet-name> . <values>) where values
;; must be a list.
(DEFUN GET-FACET (FRAME SLOT FACET)
(CDR (ASSOC FACET (GET-SLOT FRAME SLOT))))
(DEFUN GET-FACET-FROM-SLOT (SLOT-LIST FACET)
(CDR (ASSOC FACET SLOT-LIST)))
; Returns NIL if VAL is already there.L)
(LET* ((OLD-SLOT (GET-SLOT FRAME SLOT))
(OLD-FACET (ASSOC FACET OLD-SLOT))
(ADDED? T))
(IF OLD-FACET
(IF (MEMBER VAL (CDR OLD-FACET))
(SETQ ADDED? NIL)
(RPLACD OLD-FACET (CONS VAL (CDR OLD-FACET))))
(SET-SLOT FRAME SLOT (CONS (LIST FACET VAL) OLD-SLOT)))
ADDED?))
(DEFUN REMOVE-FROM-FACET (FRAME SLOT FACET VAL)
;; Returns T if something actually removed.
(LET ((OLD-FACET (ASSOC FACET (GET-SLOT FRAME SLOT))))
(WHEN (AND OLD-FACET (MEMBER VAL (CDR OLD-FACET)))
(RPLACD OLD-FACET (DELETE VAL (CDR OLD-FACET)))
T)))
;; Slots
;; A slot is a list (<slot-name> . <contents> where contents
;; is a list of facets.
(CDR (ASSOC SLOT (GET FRAME 'FRAME))))
(DEFUN SET-SLOT (FRAME SLOT VAL)
(LET ((FRAME-LIST (GET FRAME 'FRAME)))
(LET ((OLD-SLOT (ASSOC SLOT FRAME-LIST)))
(IF OLD-SLOT
(RPLACD OLD-SLOT VAL)
(PUSHNEW FRAME *FRAMES*)
(SETF (GET FRAME 'FRAME) (CONS (CONS SLOT VAL)
FRAME-LIST))))))
;;; End of SFRL code.
TF (GET FRAME 'FRAME) (CONS (CONS SLOT VAL)
FRAME-LIST))))))
;;; E