;;; -*-Mode: Lisp; Syntax: Common-lisp; Package: BOOPS -*-

;;; Copyright (c) 1992,1991,1990,1989,1988 Koenraad De Smedt

;;;   Koenraad De Smedt
;;;   Unit of Experimental and Theoretical Psychology 
;;;   Leiden University
;;;   P.O. Box 9555
;;;   2300 RB  Leiden
;;;   The Netherlands
;;;   E-mail: desmedt@rulfsw.leidenuniv.nl

;;; BOOPS (Beginner's Object Oriented Programming System) is an
;;; applicative object-oriented programming system implemented as an
;;; extension of Common LISP. It is a scaled-down version of ORBIT
;;; (Steels 1983) and CommonORBIT (De Smedt 1987) modified under the
;;; influence of OOPS (Luger & Stubblefield 1989, "AI and the design
;;; of expert systems", Chapter 14).

;;; BOOPS is distributed in the hope that it will be useful, but
;;; without any warranty. No author or distributor accepts
;;; responsibility to anyone for the consequences of using it or for
;;; whether it serves any particular purpose or works at all, unless
;;; he says so in writing.

;;; Copyright Release Statement:

;;; Everyone is granted permission to copy, modify and redistribute
;;; BOOPS but only under the conditions that (1) distribution is free
;;; and without cost, (2) any modifications are also sent to the above
;;; address, and (3) this entire notice is preserved on all copies.

(defpackage "BOOPS"
  (:use "COMMON-LISP")
  (:export
   "A"
   "AN"
   "DEFASPECT"
   "DEFOBJECT"
   "EEN"
   "ISA"
   "ISA?"
   "MESSAGE"
   "OBJECT"
   "SET-VALUE"
   "SHOW"
   "TRACE-MESSAGE"
   "UNDEFINED"
   "UNTRACE-MESSAGE"
   ))

(in-package "BOOPS")

;;; ----- Print herald -----

(COND (*LOAD-VERBOSE*
       (TERPRI)
       (PRINC 
	"BOOPS (c) 1992,1990,1989,1988 Koenraad De Smedt")))

;;; ----- Undefined -----

(DEFCONSTANT UNDEFINED 'UNDEFINED
  "The value returned from an object-oriented function call
   when the aspect is not defined for the object.")

;;; ----- Access to internal components of objects -----

;;; the ISA of an object is another object
;;; only single inheritance is supported

(DEFMACRO OBJECT-ISA (OBJECT)
  "Find isa in an object."
  `(GET ,OBJECT 'ISA))

;;; ASPECTS of an object are a list
;;; each aspect consists of a name and a definition
;;; a definition consists of a type and a filler

(DEFMACRO OBJECT-ASPECTS (OBJECT)
  "Find aspects in an object."
  `(GET ,OBJECT 'ASPECTS))

(DEFMACRO FIND-ASPECT (OBJECT ASPECT-NAME)
  "Find aspect in an object."
  `(ASSOC ,ASPECT-NAME (OBJECT-ASPECTS ,OBJECT)))

(DEFMACRO ASPECT-NAME (ASPECT)
  "Return the name of this aspect."
  `(FIRST ,ASPECT))

(DEFMACRO ASPECT-DEFINITION (ASPECT)
  "Return the definition of this aspect, in terms of type and filler."
  `(REST ,ASPECT))

(DEFMACRO ASPECT-TYPE (ASPECT-DEFINITION)
  "Return the type of this aspect definition."
  `(FIRST ,ASPECT-DEFINITION))

(DEFMACRO ASPECT-FILLER (ASPECT-DEFINITION)
  "Return the filler of this aspect definition."
  `(REST ,ASPECT-DEFINITION))

(DEFMACRO MAKE-ASPECT-DEFINITION (TYPE FILLER)
  "Make aspect definition with given type and filler."
  `(CONS ,TYPE ,FILLER))

(DEFMACRO MAKE-ASPECT (NAME TYPE FILLER)
  "Make aspect with given name, type and filler."
  `(CONS ,NAME (MAKE-ASPECT-DEFINITION ,TYPE ,FILLER)))

;;; ----- Making delegation links -----

(DEFUN ISA (OBJECT ISA)
  "Establish an isa relation. The OBJECT will then by
   default delegate all aspects to the ISA."
  (COND ((OR (EQ OBJECT ISA)
	     (ISA? ISA OBJECT))
	 (WARN "Making ~A inherit from ~A would cause circularity."
	       OBJECT ISA))
	(T (SETF (OBJECT-ISA OBJECT) ISA))))

(DEFUN ISA? (OBJECT ISA)
  "True if OBJECT is indeed a object of ISA."
  (LET ((CURRENT-ISA (OBJECT-ISA OBJECT)))
    (COND ((EQ ISA CURRENT-ISA) T)
	  ((NULL CURRENT-ISA) NIL)
	  (T (ISA? CURRENT-ISA ISA)))))

;;; ----- Adding and removing aspects -----

(DEFUN ADD-ASPECT (OBJECT ASPECT-NAME FILLER TYPE)
  "Add an aspect to an object."
  (LET ((CURRENT-ASPECT (FIND-ASPECT OBJECT ASPECT-NAME)))
    (COND ((NULL CURRENT-ASPECT)
           ;; new aspect
           (SETF (OBJECT-ASPECTS OBJECT)
		 (CONS (MAKE-ASPECT ASPECT-NAME TYPE FILLER)
		       (OBJECT-ASPECTS OBJECT))))
          (T            ;there is already an aspect
            (LET ((CURRENT-DEFINITION (ASPECT-DEFINITION CURRENT-ASPECT)))
             (UNLESS (AND (EQ (ASPECT-TYPE CURRENT-DEFINITION) TYPE)
			  (EQ (ASPECT-FILLER CURRENT-DEFINITION) FILLER))
               ;; if type and filler are eq to those in current aspect,
               ;; do nothing
               ;; else replace the definition
               (SETF (ASPECT-DEFINITION CURRENT-ASPECT)
                     (MAKE-ASPECT-DEFINITION TYPE FILLER)))))))
  ASPECT-NAME)

;;; ----- Defining aspects -----

(DEFMACRO DEFASPECT (OBJECT ASPECT-NAME &REST DEFINITION)
  "Define an aspect. The aspect name and object are not evaluated.
   This macro has the following syntax:
        DEFASPECT aspect object [type] filler
   The aspect definition is associated with the given object.
   If the type is omitted, the default is :VALUE.
   The following keywords for explicit aspect types are possible:
        :VALUE filler
   The filler can be any Lisp object which is simply returned.
        :FUNCTION filler
   or   :FUNCTION ([var ...]) form ...
   The filler is a function which is to be applied. The filler is
   a function with the given lambda list and forms.
        :IF-NEEDED filler
   or   :IF-NEEDED ([var ...]) form ...
   Like :FUNCTION but the result is to be memoized."
  (EXPAND-DEFASPECT ASPECT-NAME `',OBJECT DEFINITION))

(DEFUN EXPAND-DEFASPECT (ASPECT-NAME OBJECT DEFINITION)
  "Expansion for DEFASPECT."
  (COND (DEFINITION			;not an empty definition
	 (EXPAND-ASPECT-DEFINITION
	   `',ASPECT-NAME OBJECT
	   (FIRST DEFINITION) (REST DEFINITION)))))

(DEFUN EXPAND-ASPECT-DEFINITION (ASPECT-NAME OBJECT TYPE FILLER-LIST)
  "Expansion for definition in DEFASPECT."
  (COND
     ((NULL FILLER-LIST)           ;implicit type :VALUE
        `(ADD-ASPECT ,OBJECT ,ASPECT-NAME ,TYPE :VALUE))
     (T                            ;explicit type
      (CASE TYPE
        (:VALUE
          `(ADD-ASPECT
             ,OBJECT ,ASPECT-NAME ,(FIRST FILLER-LIST) ,TYPE))
        ((:FUNCTION :IF-NEEDED)                ;expand both the same
         `(ADD-ASPECT
            ,OBJECT
	    ,ASPECT-NAME
            ,(COND ((NULL (REST FILLER-LIST))     ;just one element?
		    ;; assume it contains a function
		    (FIRST FILLER-LIST))
		   (T
		    ;; assume it contains a variable list and body
		    `#'(LAMBDA ,(FIRST FILLER-LIST)
			 ,@(REST FILLER-LIST))))
            ,TYPE))))))

;;; ----- Defining named objects -----

(DEFMACRO DEFOBJECT (NAME ISA &BODY ASPECTS)
  "Define a named BOOPS object by assigning isas and defining
   aspects. The arguments are not evaluated.
   A symbol is a isa, lists are aspect definitions. Example:
     (DEFOBJECT WOMAN PERSON (SEX 'FEMALE))
   Aspect definitions are processed as by DEFASPECT."
  `(PROGN
     (ISA ',NAME ',ISA)
     (SETF (OBJECT-ASPECTS ',NAME) NIL)
     ,@(EXPAND-ASPECT-DEFINITIONS ASPECTS `',NAME)
     ',NAME))

(DEFUN EXPAND-ASPECT-DEFINITIONS (ASPECT-DEFINITIONS OBJECT)
  "Expand isa and aspect definitions in object definition."
  (MAPCAR #'(LAMBDA (ASPECT-DEFINITION)
	      (EXPAND-DEFASPECT (FIRST ASPECT-DEFINITION)
				OBJECT
				(REST ASPECT-DEFINITION)))
	  ASPECT-DEFINITIONS))

;;; ----- Defining anonymous objects -----

(DEFMACRO A (ISA &REST ASPECTS)
  "Define an anonymous BOOPS object by assigning isas and
   defining aspects. The arguments are not evaluated.
   A symbol is a isa, lists are aspect definitions. Example:
     (A PERSON (SEX 'FEMALE))
   Aspect definitions are processed as by DEFASPECT."
   (LET ((OBJECT (GENSYM)))
     `(LET ((,OBJECT (GENSYM (STRING ',ISA))))
        (ISA ,OBJECT ',ISA)
       ,@(EXPAND-ASPECT-DEFINITIONS ASPECTS OBJECT)
       ,OBJECT)))

(DEFMACRO AN (ISA &REST ASPECTS)
  "Synonym of A."
  `(A ,ISA ,@ASPECTS))

(DEFMACRO EEN (ISA &REST ASPECTS)
  "Synonym of A for Dutch."
  `(A ,ISA ,@ASPECTS))

;;; ----- Message passing -----

(DEFUN MESSAGE (OBJECT ASPECT-NAME &REST ARGS)
  "Message passing. Get the definition of the aspect for the
   object (the first argument) and if it is a function, apply
   that function to all the arguments."
  (COND ((GET ASPECT-NAME 'TRACED)
	 (FORMAT *TRACE-OUTPUT* "~%-> ~A ~A ~A"
		 ASPECT-NAME OBJECT ARGS)))
  (LET ((DEFINITION (GET-DEFINITION ASPECT-NAME OBJECT)))
    (LET ((TYPE (ASPECT-TYPE (FIRST DEFINITION)))
	  (FILLER (ASPECT-FILLER (FIRST DEFINITION)))
	  (SOURCE (SECOND DEFINITION)))
      ;; perform action according to type
      (LET ((RESULT
	      (CASE TYPE
		(:VALUE FILLER)
		(:FUNCTION (APPLY FILLER (CONS OBJECT ARGS)))
		(:IF-NEEDED
		  (SETQ FILLER		;reuse variable filler
			(APPLY FILLER (CONS OBJECT ARGS)))
		  (COND ((AND SOURCE
			      (NOT (EQ FILLER UNDEFINED)))
			 ;; inherited and not undefined, so memoize
			 (ADD-ASPECT OBJECT ASPECT-NAME FILLER :VALUE)))
		  FILLER)
		(OTHERWISE UNDEFINED))))
	(COND ((GET ASPECT-NAME 'TRACED)
	       (FORMAT *TRACE-OUTPUT* "~%<- ~A ~A ~A"
		       ASPECT-NAME OBJECT RESULT)))
	RESULT))))

;;; ----- Retrieving the definition of an aspect for an object -----

(DEFUN GET-DEFINITION (ASPECT-NAME OBJECT)
  "Get the definition of an aspect for an object.
   Return a list of the definition and the object providing it (if found
   AND inherited, otherwise NIL)."
  (LET ((OWN-DEFINITION
	  (ASPECT-DEFINITION (FIND-ASPECT OBJECT ASPECT-NAME))))
    (COND (OWN-DEFINITION
	   (LIST OWN-DEFINITION NIL))
	  (T (GET-DEFINITION-FROM-ISA
	       ASPECT-NAME (OBJECT-ISA OBJECT))))))

(DEFUN GET-DEFINITION-FROM-ISA (ASPECT-NAME OBJECT)
  "Get the definition of an aspect from the isa of an object.
   Return a list of the definition and the object providing it or NIL."
  (COND ((NULL OBJECT) (LIST NIL NIL))
	(T
	 (LET ((ASPECT (FIND-ASPECT OBJECT ASPECT-NAME)))
	   (COND (ASPECT
		  (LIST (ASPECT-DEFINITION ASPECT)
			OBJECT))
		 (T
		  (GET-DEFINITION-FROM-ISA ASPECT-NAME
					   (OBJECT-ISA OBJECT))))))))

;;; ----- Tracing messages -----

(DEFMACRO TRACE-MESSAGE (MESSAGE)
  "Trace a message upon receipt and return of result."
  `(SETF (GET ',MESSAGE 'TRACED) T))

(DEFMACRO UNTRACE-MESSAGE (MESSAGE)
  "Untrace a message."
  `(SETF (GET ',MESSAGE 'TRACED) NIL))

;;; ----- The vanilla object -----

(DEFOBJECT OBJECT
	   NIL
  (SHOW
    :FUNCTION
    #'(LAMBDA (SELF &OPTIONAL (OUTPUT-STREAM *STANDARD-OUTPUT*))
	"Display a description of the object to the output stream."
	(COND ((OBJECT-ISA SELF)
	       (FORMAT OUTPUT-STREAM "~&~S is a ~S"
		       SELF (OBJECT-ISA SELF))))
	(DOLIST (ASPECT (OBJECT-ASPECTS SELF))
	  (LET ((TYPE (ASPECT-TYPE (ASPECT-DEFINITION ASPECT)))
		(FILLER (ASPECT-FILLER (ASPECT-DEFINITION ASPECT))))
	    (FORMAT OUTPUT-STREAM "~&  aspect ~A ~S = ~S"
		    (ASPECT-NAME ASPECT) TYPE FILLER)))
	SELF))
  (SET-VALUE
    :FUNCTION
    #'(LAMBDA (SELF ASPECT-NAME NEW-VALUE)
	"Give the aspect a new value."
	(ADD-ASPECT SELF ASPECT-NAME NEW-VALUE :VALUE)
	(LIST ASPECT-NAME NEW-VALUE)))
  )

;;; possible extensions:
;;; - make objects inherit from vanilla object if not otherwise defined
;;; - make messages generic functions: (friend 'peter)
;;;   (advantage = you can apply, map, trace etc. like normal functions)
;;; - add roles (whose 'friend 'peter)
;;; - do multiple inheritance
;;; - implement DELETE-ASPECT, NOT-ISA, etc.