Programmer 7500/MAX_PROGRAMMERS.iso/CLIPPER/MISC/AIE8901.ZIP/POBCODE.CDE

Text File | 1988-05-04 | 26.9 KB | 535 lines

ca oboiecode
WORKING (MESSAGE PENDING)
NO SUCH COMMAND
ca obiecode
WORKING (MESSAGE PENDING)
{slOBIECODE {quKRK-AI    {opKRK   ;12/22,13:37 {hj               {bt
;; POB.LISP

;;; Shawn Amir
;;; P.O. Box 1249
;;; Menlo Park, CA  94026

;;; Dec 11, 1988

;;; This file defines the Property-list OBject (POB) language, an object oriented database
;;; facility, as summarized in the January 1989 issue of AI expert.  This file contains the
;;; entire language definition and implementation.  Please feel free to use, copy, modify,
;;; and generally have a good time with POB!  Written comments and suggestions are welcome.

;;; The other files of interest are:     OBIE.LISP           OBject oriented Inference Engine
;;;                                      MAM-Dialog.LISP     Dialog window for mini application
;;;                                      MAM-KS.LISP         Rules for mini application

;;; Developed on a Macintosh II, 2MB of RAM, and Allegro Common LISP 1.1 from Coral Software
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Everything in the database is an object.  Each object has the following form of a
;;; symbol and its property list.
;;;
;;;     Node
;;;       :POB-NAME      Symbol
;;;       :POB-SUP-L     (Node1 Node2 Node3 ...)
;;;       :POB-SUB-L     (Node1 Node2 Node3 ...)
;;;       :POB-MSG-L     (Msg1 Fn1 Msg2 Fn2 Msg3 Fn3 ...)
;;;       :POB-SLOT-L    (Slot-A Slot-B Slot-C ...)
;;;       :SLot-A       Value
;;;       :Slot-B       Value
;;;       :Slot-C       Value
;;;        . . .        . . .
;;;
;;;
;;; NODE corresponds to a unique symbol name gensym, :POB-NAME is a property, and
;;; SYMBOL is the type of value that it will have.  Slot-A, Slot-B, etc. are
;;; user-defined properties and are listed in the value for the property :POB-SLOT-L.
;;;
;;; Each node has a number of superiors and a number of subordinates, listed in the
;;; values for POB-SUP-L and POB-SUB-L respectively.  When a new object is
;;; instantiated, it will get all the user-defined slots and values that are
;;; associated with its superiors.  In case of overlap and duplications, the values
;;; come from the closest superior in a depth-first left-to-right traversal of the
;;; tree formed by the superiors.
;;;
;;; The SEND function is the method used to get functions to act.  A send takes the
;;; format of a message and the appropriate arguments.  The object then finds a
;;; function for the message and executes it with the appropriate arguments.
;;;
;;; The POB-MSG-L slot of each object contains a property list of messages and
;;; functions associated with them.  Whenever a message is sent to an object, this
;;; list is first searched to find and execute the appropriate function.  However,
;;; if no matching message was found in POB-MSG-L then the tree of superiors is
;;; searched in  a left-to-right and depth-first  manner to locate the first
;;; instance of a matching message.
;;;
;;; Read macros have been defined to simplify accessing properties in objects.
;;; Instead of writing (Get G075 :POB-SLOT-L) we write [G075 :POB-SLOT-L].  In the
;;; future changing the underlying representation of objects will be much easier
;;; if the "[...]" access method is used exclusively.
;;;
;;; The main functions in the database are POB-DEFOBJ and POB-SEND which are used to
;;; define new objects and send them messages for execution.  POB-DEFMSG is used for
;;; defining new messages and associating them with objects.
;;;
;;; By convention, each object in the database will inherit from *POB-OBJ*.  *POB-OBJ*
;;; defines a minimal set of utility messages:
;;;
;;; :ADD-MSG          Adds a message definition to the object
;;; :DEL-MSG          Remove a message definition from the object
;;; :GET-MSG-L        Returns the list of messages store IN the object (No inheritance)
;;; :ADD-SLOT         Add new slot and value to the object
;;; :DEL-SLOT         Remove old slot from the object
;;; :ADD-SUP          Add new superior to the object
;;; :DEL-SUP          delete old superior from the object
;;; :MAKE-Obj         Add new object
;;; :DEL-OBJ          Delete existing object
;;; :GET-SLOT         Return value of existing slot in object
;;; :SET-SLOT         Set the value of slot in object
;;; :PRINT-SELF       Print the contents of the object (For debugging)
;;; :PRINT-SLOT       Prints the contents of specified (or all user-defined slots)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; UTILITIES

;;; Revert-ReadTable changes the current readtable to the standard CommonLisp one.

(Defun Revert-Readtable ()
  (Setq *ReadTable* (Copy-Readtable Nil)))

;;; [-Reader is used to implement data access syntax.  It currently translates to
;;; property list accesses, but this can be easily changed in the future.
;;;
;;; [a b c 'd]                     means get field 'D of field C of field B
;;;                                of data item A and translates into:
;;; (getF (getF (get a b) c) 'd)

(Eval-when (Eval Load Compile)
  (Defun |[-Reader| (Stream Char)
    (Declare (Ignore Char))                                       ; Ignore the char arg
    (Let ((Arg (Read-Delimited-List #\] Stream T)))               ; Read till "]"
      (Cond ((Atom Arg) Arg)                                      ; Ignore if Atom
            ((Null (Cdr Arg)) (Cons 'Symbol-Plist Arg))           ; Length is 1
            (T (Do ((ArgList (Cddr Arg) (Cdr ArgList))
                    (Res (List 'Get (Car Arg) (Cadr Arg))
                         (List 'GetF Res (Car ArgList))))
                   ((Null ArgList) Res)))))))                      ; Until done

;;; "[" starts the [-reader macro.  "]" is stylistically used as a delimiter.  Note
;;; that "]" has the same meaning as ")", but they are not used interchangeably for
;;; stylistic purposes.

(Eval-when (Eval Load Compile)
  (Set-Macro-Character #\[ #'|[-Reader|)                        ; "[" macro calls reader
  (Set-Macro-Character #\] (Get-Macro-Character #\) Nil)))      ; "]" is same as ")"

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; INHERITENCE
;;;
;;; POB-MAKE-TREE will return a non-repeating list of all the nodes visited by a
;;; depth-first left-to-right traversal of the tree formed by nodes in the SLOT of
;;; ROOT.  The return list will start with ROOT and end with the farthest node.

(Defun POB-Make-Tree (Root SLot)
  (Let ((Seen-L (List Root)))                                   ; Start with Root
    (labels ((Down-Tree (Cur)
               (DoList (Node [Cur Slot])                        ; For every node in slot
                 (Unless (Member Node Seen-L)                   ; Unless already seen
                   (Push Node Seen-L)                           ; Add to seen list
                   (Down-Tree Node)))))                         ; Recurse depth first
      (Down-Tree Root))                                         ; Start at root
    (Reverse Seen-L)))                                          ; From Root to farthest

;;; POB-Inherit-Slots will traverse the :POB-SUP-L tree usig POB-MAKE-TREE to find all
;;; the objects.  Each slot belonging to a superior is copied into the object.  The
;;; :POB-SLOT-L is then updated to reflect all the new application slots.  Note that
;;; inherited values are copies (Top list level only).

(Defun POB-Inherit-SLots (Root)
  (Let ((Local-Slot-L [Root :POB-SLOT-L])                       ; Get all local slots first
        (Sup-Val Nil))
    (DoList (Sup (Cdr (POB-Make-Tree Root :POB-SUP-L)))         ; For each superior
      (DoList (Slot [Sup :POB-SLOT-L])                          ; For each of the slots in it
        (Unless (Member Slot Local-SLot-L)                      ; Unless already seen
          (Push Slot Local-SLot-L)                              ; Add to list of slots
          (Setq Sup-Val [Sup Slot])
          (Setf [Root Slot] (If (Atom Sup-Val) Sup-Val          ; Store copy of value
                                (Copy-List Sup-Val))))))        ;  in SLOT of ROOT
    (Setf [Root :POB-SLOT-L] Local-SLot-L)))                    ; Store list of slots in Root


;;; POB-Add-To-Node-L will add NEW-NODE to SLOT-NAME slot of all the nodes in
;;; NODE-L, iff NEW-NODE is not already there.  This function is useful for
;;; adding a new subordinate to SUB-L of all of its superior nodes.

(Defun POB-Add-To-Node-L (New-Node Node-L Slot-Name)
  (DoList (Node Node-L)
    (Unless (Member New-Node [Node Slot-Name])
      (Push New-Node [Node SLot-Name]))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; CREATION
;;;
;;; POB-DefObj creates a new object that inherits from its superiors.  The object is
;;; first created, its slots initialized, slots and values are inherited from the
;;; superiors, the SLOT-VALUE-L information is written in the object, and finally
;;; the new object is recorded on the SUB-L of its DIRECT superiors.  Note that SLOT-VALUE-L
;;; overwrites all other information, inherited or just initialized.  Also note that
;;; elements in the SUP-L are explicitly evaluated so that variables can denote the name
;;; of objects in the SUP-L.
;;;
;;; SLot-Value-L will take the form  (Slot Value Slot Value ...)

(Defun POB-DefObj-Eval (Name Sup-L SLot-Value-L)
  (let ((Self (GenTemp "POB-")))
    (Setf [Self :POB-NAME]    Name
          [Self :POB-SUP-L]   (Copy-List Sup-L)                  ; Give initial list of supers
          [Self :POB-SUB-L]   '()                                ; No subordinates yet
          [Self :POB-MSG-L]   '()                                ; No defined messages yet
          [Self :POB-SLOT-L]  '())                               ; Initialize list of slots
    (Do ((S-V-L SLot-Value-L (Cddr S-V-L))                       ; For each Slot-Value pair
         (Slot-L Nil))
        ((Null S-V-L) (Setf [Self :POB-SLOT-L] SLot-L))          ; Add SLOT-L to self
      (Push (Car S-V-L) Slot-L)                                  ; Add slot name to SLOT-L
      (Setf [Self (Car S-V-L)] (Eval (Cadr S-V-L))))             ; Create the slot and give it value
    (POB-Inherit-Slots Self)                                     ; Inherit slot-values from SUPs
    (POB-Add-To-Node-L Self Sup-L :POB-SUB-L)                    ; Add self to SUB-L of direct SUPs
    Self))                                                       ; Return SELF

(DefMacro POB-DefObj (Name Sup-L &Rest SLot-Value-L)
  `(POB-DefObj-Eval ',Name
                   (List ,@Sup-L)
                   ',Slot-Value-L))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; MESSAGE SENDING
;;;
;;; POB-SEND causes the OBJ to execute the function corresponding to MSG on ARG-L.
;;; POB-SEND will climb the SUP-L tree of OBJ to find the message function.  Note that
;;; OBJ is also passed to MSG-FN as an argument, it will be called POB-SELF inside
;;; the message function.


(Defun POB-Send (Obj Msg &Rest Arg-L)
  (Let ((Msg-Fn Nil))
    (Labels ((Find-Msg-Obj (Node)
                (Or (Setq Msg-Fn [Node :POB-MSG-L Msg])
                    (DoList (Sup [Node :POB-SUP-L])
                      (If (Find-Msg-Obj Sup)
                          (Return T))))))
      (Find-Msg-Obj Obj))
    (If Msg-Fn
      (Apply Msg-Fn (Cons Obj Arg-L))                           ; Obj will act as POB-SELF
      (Error "Message: ~a to ~a went unclaimed." Msg Obj))))

(Defun POB-Send-Arg-L (Obj Msg Arg-L)
  (Let ((Msg-Fn Nil))
    (Labels ((Find-Msg-Obj (Node)
                (Or (Setq Msg-Fn [Node :POB-MSG-L Msg])
                    (DoList (Sup [Node :POB-SUP-L])
                      (If (Find-Msg-Obj Sup)
                          (Return T))))))
      (Find-Msg-Obj Obj))
    (If Msg-Fn
      (Apply Msg-Fn (Cons Obj Arg-L))                           ; Obj will act as POB-SELF
      (Error "Message: ~a to ~a went unclaimed." Msg Obj))))


;;; POB-SEND-IGNORE works just like POB-SEND, but does not signal an error if the message
;;; is not claimed.

(Defun POB-Send-Ignore (Obj Msg &rest Arg-L)
  (Let ((Msg-Fn Nil))
    (Labels ((Find-Msg-Obj (Node)
                (Or (Setq Msg-Fn [Node :POB-MSG-L Msg])
                    (DoList (Sup [Node :POB-SUP-L])
                      (If (Find-Msg-Obj Sup)
                          (Return T))))))
      (Find-Msg-Obj Obj))
    (If Msg-Fn
      (Apply Msg-Fn (Cons Obj Arg-L)))))                        ; Obj will act as POB-SELF


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; DEFINING MESSAGES
;;;
;;; POB-DefMsg is used to define messages and functions for objects.  It adds the
;;; closure for the new function and the matching message name to the POB-MSG-L
;;; slot of the OBJ.  It will replace any function already associated with MSG.
;;; Note that POB-SELF is pushed on to the functions arglist--Refer to POB-SEND.


(DefMacro POB-DefMsg (Obj Msg Arg-L &Rest Form-L)
  `(Setf (Getf [,Obj :POB-MSG-L] ,Msg)
         (Function (Lambda (POB-SELF ,@Arg-L) ,@Form-L))))

;;; POB-DefMsg-Fn is used to define new messages from inside programs.  The macro simply
;;; returns a function closure--with POB-SELF pushed on to the argument list.  This
;;; closure should be added to the object using POB-ADD-MSG function (or :ADD-MSG msg
;;; to the object).

(DefMacro POB-DefMsg-Fn (Arg-L Form-L)
  `(Function (Lambda (POB-SELF ,@(Eval Arg-L)) ,@(Eval Form-L))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; *POB-OBJ*

(DefParameter *POB-OBj* (POB-DefObj POB-BASE-OBJECT ()))         ; No superiors

;;; :ADD-MSG will install a new FN in POB-SELF--the old function matching MSG will be
;;; over-written.

(POB-DefMsg *POB-OBJ* :ADD-MSG (Msg Fn)
    (Setf (Getf [POB-SELF :POB-MSG-L] Msg)
          Fn))

;;; :DEL-MSG removes the MSG and its function from POB-SELF's MSG-L.  Note the
;;; destructive nature of REMF.

(POB-DefMsg *POB-OBJ* :DEL-MSG (Msg)
    (Remf [POB-SELF :POB-MSG-L] Msg))

;;; GET-MSG-L returns a list of all the messages stored in POB-SELF

(POB-DefMsg *POB-OBJ* :GET-MSG-L ()
    (Do ((Msg-Fn-L [POB-SELF :POB-MSG-L] (Cddr Msg-Fn-L))
         (Res Nil))
        ((Null Msg-Fn-L) Res)
      (Push (Car Msg-Fn-L) Res)))

;;; :ADD-SLOT will add SLOT with value VAL to POB-SELF and all its subordinates.
;;; Note that the values in the subordinates will get clobbered if they already have
;;; SLOT.

(POB-DefMsg *POB-OBJ* :ADD-SLOT (New-SLot Val)
    (Do ((Sub-L (POB-Make-Tree POB-SELF :POB-SUB-L) (Cdr Sub-L))) ; Tree of subordinates
        ((Null Sub-L) POB-SELF)                                ; Return POB-SELF
      (Setf [(Car Sub-L) New-Slot] Val)                        ; Add new slot to SUB
      (Unless (Member New-SLot [(Car Sub-L) :POB-SLOT-L])      ; Add to SLOT-L of SUB
        (Push New-SLot [(Car Sub-L) :POB-SLOT-L]))))

;;; :DEL-SLOT removes the slot from POB-SELF and all its subordinates.

(POB-DefMsg *POB-OBJ* :DEL-SLOT (Old-SLot)
     (Do ((Sub-L (POB-Make-Tree POB-SELF :POB-SUB-L) (Cdr Sub-L))) ; Tree of subordinates
         ((Null Sub-L) POB-SELF)                                ; Return POB-SELF
       (Remf [(Car Sub-L)] Old-SLot)                            ; Remove OLD-SLOT
       (Setq Slot-L [(Car Sub-L) :POB-SLOT-L])                  ; Get SUB's SLOT-L
       (Setf [(Car Sub-L) :POB-SLOT-L]                          ; Then remove OLD-SLOT
             (Delete Old-SLot [(Car Sub-L) :POB-SLOT-L]))))

;;; :ADD-SUP will add new superiors to :POB-SELF.  POB-SELF will inherit all the NEW
;;; slots from the superiors--in left to right order.  It will also be added to the
;;; SUB-L of the superiors.  All objects subordinate to POB-SELF will also forcefully
;;; inherit the NEW slots and values that POB-SELF gets--these new values will OVERWRITE
;;; existing slots if the subordinate objects already have them.  (This means that POB-SELF
;;; will not have any of its slots overwritten; while, the subordinates of POB-SELF MAY
;;; get their slot overwritten!)
;;;
;;; POB-ADD-SLOT-VALUE-L is a helper function used to recursively propagate new slot-values
;;; in the subordinate tree.
;;;
;;;; Slot-Value-L is of the form '(Slot Value Slot Value ...)

(Defun POB-Add-Slot-Value-L (Obj Slot-Value-L)
  (Do ((New-Slot-L [OBJ :POB-SLOT-L])                            ; Load up with SLOT-L
       (S-V-L Slot-Value-L (Cddr S-V-L)))                        ; For all SLOT-VALUE pairs
      ((Null S-V-L)                                              ; When no more S-V pairs
       (Setf [Obj :POB-SLOT-L] New-SLot-L)                       ; Store new SLOT-L
       (DoList (Sub [Obj :POB-SUB-L])                            ; For all SUBs
         (POB-Add-Slot-Value-L Sub Slot-Value-L)))               ; Recurse
    (Setf [Obj (Car S-V-L)] (Cadr S-V-L))                        ; Store VALUE in SLOT
    (Unless (Member (Car S-V-L) New-Slot-L)                      ; Unless already in SLOT-L
      (Push (Car S-V-L) New-Slot-L))))                           ; Add to new SLOT-L


(POB-DefMsg *POB-OBJ* :ADD-SUP (&Rest Sup-L)
    (Let ((New-Sup-L [POB-SELF :POB-SUP-L])
          (New-Sub-L [POB-SELF :POB-SUB-L])
          (New-Slot-L [POB-SELF :POB-SLOT-L])
          (Slot-Value-L ())
          (New-Val Nil))
      (DoList (New-Sup Sup-L)                                   ; For each new superior
        (Unless (Member New-Sup New-Sup-L)                      ; If not already on SUP-L
          (Push New-Sup New-Sup-L)                              ; Add to SUP-L
          (Push POB-SELF [New-Sup :POB-SUB-L])                  ; Put on SUPs SUB-L
          (DoList (New-SLot [New-Sup :POB-SLOT-L])              ; For each SLOT in SUP
            (Unless (Member New-Slot New-Slot-L)                ; If not already in POB-SELF
              (Push New-Slot New-Slot-L)                        ; Add to SLOT-L
              (Setq New-Val [New-Sup New-SLot])                 ; Get value of slot
              (Setf [POB-SELF New-SLot] New-Val)                ; Put slot and value in POB-SELF
              (Push New-Val SLot-Value-L)                       ; Record in SLOT-VALUE-L
              (Push New-Slot Slot-Value-L)))))
      (Setf [POB-SELF :POB-SLOT-L] New-Slot-L)                  ; Restore SLOT-L
      (Setf [POB-SELF :POB-SUP-L] New-Sup-L)                    ; Restore SUP-L
      (DoList (Sub New-Sub-L)                                   ; For each subordinate
        (POB-Add-Slot-Value-L Sub Slot-Value-L)))               ; Add all slots and values (Recurse)
    POB-SELF)                                                   ; Return POB-SELF


;;; :ADD-SLOT-VALUE-L is used to add all the slots and their values to self and all its
;;; subordinates.  Note that the addition is not forceful and will not overwrite
;;; existing slots and values in POB-SELF or any of the subordinates.

(POB-DefMsg *POB-OBJ* :ADD-SLOT-VALUE-L (S-V-L)
  (POB-Add-Slot-Value-L POB-SELF S-V-L))

;;; :DEL-SUP will remove members of DEL-SUP-L from the SUP-L of POB-SELF.  POB-SELF
;;; will also be stricken from the superior's POB-SUB-L.  Note that inherited
;;; slots are not removed--only access to inherited functions is discontinued.  Nothing
;;; is done about the subordinates of POB-SELF.

(POB-DefMsg *POB-OBJ* :DEL-SUP (&Rest Del-Sup-L)
   (Let ((New-Sup-L '()))
     (DoList (Sup [POB-SELF :POB-SUP-L])                        ; For all superiors
       (If (Member Sup Del-Sup-L)                               ; If member of delete list
         (Setf [Sup :POB-SUB-L]
               (Delete POB-SELF [Sup :POB-SUB-L]))              ; Remove POB-SELF from their SUB-L
         (Push Sup New-Sup-L)))                                 ; Push sup on new SUP-L
     (Setf [POB-SELF :POB-SUP-L] New-Sup-L)                     ; Store new SUP-L
     POB-SELF))                                                 ; Return POB-SELF


;;; MAKE-OBJ will instantiate an object by treating POB-SELF as a class definition.
;;; The new object will get all its slots from POB-SELF--It will not be a subordinate
;;; to POB-SELF, but rather subordinate to POB-SELF's superiors.
;;;
;;; SLOT-VALUE-L is of the form (Slot Value Slot Value ...)

(POB-DefMsg *POB-OBJ* :MAKE-OBJ (Name &Rest Slot-Value-L)
    (Let ((New-Obj (GenTemp "POB-"))                             ; Create new object
          (Sup-L (Copy-List [POB-SELF :POB-SUP-L]))              ; Get copy of SUP-L
          (Slot-L (Copy-list [POB-SELF :POB-SLOT-L]))            ; Get copy of SLOT-L
          (Val Nil))
      (Setf [New-Obj :POB-NAME] name
            [New-Obj :POB-SUP-L] Sup-L
            [New-Obj :POB-SUB-L] '()
            [New-Obj :POB-MSG-L] (Copy-List [POB-SELF :POB-MSG-L])) ; Get copy of MSG-L
      (DoList (Sup Sup-L)                                       ; For all superiors
        (Push New-Obj [Sup :POB-SUB-L]))                        ; add NEW-OBJ as their sub
      (DoList (New-Slot Slot-L)                                 ; For all slots
        (Setq Val [POB-SELF New-Slot])
        (If (Atom Val)
            (Setf [New-Obj New-Slot] Val)
            (Setf [New-Obj New-Slot] (Copy-List Val))))         ; Create them in NEW-OBJ
      (Do ((S-V-L Slot-Value-L (Cddr S-V-L)))                   ; For all Slot-Value pairs
          ((Null S-V-L) T)                                      ; Until done
        (Setf [New-Obj (Car S-V-L)] (Cadr S-V-L))               ; Put slot and value in NEW-OBJ
        (Unless (Member (Car S-V-L) SLot-L)                     ; If not already in SLOT-L
          (Push (Car S-V-L) SLot-L)))                           ; Add to slot-L
      (Setf [New-Obj :POB-SLOT-L] Slot-L)                       ; Store new SLOT-L in NEW-OBJ
      New-Obj))                                                 ; Return NEW-OBJ

;;; :DEL-OBJ cleans out POB-SELF for garbage collection.  For all subordinates of POB-SELF,
;;; if they have no other superiors, they too are recursively cleaned out.
;;;
;;; Clean-Sub is a helper function for cleaning out the tree of subordinates.

(POB-DefMsg *POB-OBJ* :DEL-OBJ ()
    (Let ((Sub-L [POB-SELF :POB-SUB-L])
          (Del-L (list POB-Self)))                              ; Only self MUST be deleted

      ;; Clean subordinates starting at Node
      (Labels ((Clean-Sub (Node)
                 (Do ((S-L [Node :POB-SUP-L] (Cdr S-L))         ; For all superiors
                      (Rem-Sup-L '()))                          ; Remaining superior list
                     ((Null S-L)
                      (If Rem-Sup-L                             ; Some superior still remains
                        (Setf [Node :POB-SUP-L] Rem-Sup-L)      ; Remove killed superiors
                        ; Else
                        (progn
                          (Push Node Del-L)                     ; Count this node deleted
                          (DoList (S [Node :POB-SUB-L])         ; For all subordinates
                            (Clean-Sub S))                      ; Recursively clean them out
                          (Setf [Node] Nil))))                  ; Clean out self last
                   (Unless (Member (Car S-L) Del-L)             ; If not member of delete list
                     (Push (Car S-L) Rem-Sup-L)))))             ; Then add to remaining list

        (DoList (Sup [POB-SELF :POB-SUP-L])                            ; For all immediate SUPs
          (Setf [Sup :POB-SUB-L] (Delete POB-SELF [Sup :POB-SUB-L])))  ; Remove POB-SELF from SUB-L

        (DoList (S Sub-L)                                       ; For all direct subs
          (Clean-Sub S))
        (Setf [POB-SELF] nil)))                                 ; Clean out all slots
    POB-SELF)                                                   ; Return POB-SELF

;;; :SEPARATE causes self to inherit all the messages that were normally available through
;;; the SUP-L hierarchy.  Self is then removed from the SUB-L slot of its superiors, and
;;; the superiors are in turn removed from the SUP-L slot of self.  :SEPARATE will speed up
;;; message processing of POB-SELF by eliminating the need for hierarchical look-up.

(POB-DefMsg *POB-OBJ* :SEPARATE ()
   (Let ((Par-L [POB-SELF :POB-SUP-L])
         (Sup-L (POB-Make-Tree POB-SELF :POB-SUP-L))
         (Msg-L [POB-SELF :POB-MSG-L]))
     (DoList (Sup (Cdr Sup-L))                                   ; For all ancestors
       (Do ((M-L [Sup :POB-MSG-L] (Cddr M-L)))                   ;  get the messages and functions
           ((Null M-L) T)
         (Unless (Getf Msg-L (Car M-L))
           (Setq Msg-L (List* (Car M-L) (Cadr M-L) msg-L)))))

     (DoList (Par Par-L)                                         ; For all parents of self
       (Setf [Par :POB-SUB-L] (Delete POB-SELF [Par :POB-SUB-L])))   ; remove self from SUB-L

     (Setf [POB-SELF :POB-SUP-L] nil                                 ; Self has no more parents
           [POB-SELF :POB-MSG-L] Msg-L)                              ; But self has all their msgs
     POB-SELF))

;;; :INIT-SLOTS is used to initialize all the slots in SLOT-L to VAL.  It is very handy
;;; for setting a large number of slots to :UNKNOWN or other preset values.

(POB-DefMsg *POB-OBJ* :INIT-SLOTS (Slot-L Val)
   (DoList (Slot SLot-L)
     (Setf [POB-SELF SLot] Val)))

;;; :PRINT-OBJ prints POB-SELF

(POB-DefMsg *POB-OBJ* :PRINT-SELF ()
   (POB-PRINT-OBJ POB-SELF))

(POB-DefMsg *POB-OBJ* :PRINT-SLOT (&Rest SLot-L)
  (If Slot-L
    (POB-Print-Obj-Slots POB-SELF Slot-L)
    (POB-Print-Obj-SLots POB-SELF [POB-SELF :POB-SLOT-L])))

(POB-DefMsg *POB-OBJ* :PRINT-MSG-L ()
  (POB-Print-Msg-L POB-SELF))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; POB-Print-0bj pretty-prints the objects.

(Defun POB-Print-Obj (Obj)
  (Let ((P-L (Symbol-Plist Obj)))
    (format T "~%~%--~A--~%" Obj)
    (Do ((P P-L (Cddr P)))
        ((Null P) (Format T "~%") T)
      (Format T "~A" (Car P))
      (Do ((I (Length (String (Car P))) (1+ I)))
          ((/ I 17) T)
        (Format T " "))
      (If (Equal (Car P) :POB-MSG-L)
        (Format T " ../ ~A~%" (POB-SEND Obj :GET-MSG-L))
        (Format T " --/ ~A~%" (Cadr P))))))

(Defun POB-Print-Obj-Slots (Obj Slot-L)
    (format T "~%~%--~A--~%" Obj)
    (DoList (Slot SLot-L)
      (format T "~A" Slot)
      (Do ((I (Length (String Slot)) (1+ I)))
          ((/ I 17) T)
        (Format T " "))
      (Format T " --/ ~A~%" [Obj Slot]))
    (Format T "~%")
    T)

(defun POB-Print-Msg-L (Obj)
   (format T "~%~%--~A--~%MSG --/ " Obj)
   (Do ((Msg-L [Obj :POB-MSG-L] (Cddr msg-L)))
       ((Null Msg-L) (Format T "~%~%"))
     (Format T "~A~%        " (Car Msg-L)))
   T)
        {et
G-L] (Cddr msg-L)))
       ((Null Msg-L) (Format T "~%~%"))
     (Format T "~A~%        " (Car Msg-L)))
   T)