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