;;; prometheus-internal.scm --- A prototype-based message-passing object system

;; Copyright (C) 2005 Jorgen Schaefer

;; Author: Jorgen Schaefer <forcer@forcix.cx>

;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License
;; as published by the Free Software Foundation; either version 2
;; of the License, or (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
;; 02111-1307, USA.

;;; Commentary:

;; Prometheus is a prototype-based message-passing object system.

;; Objects are closures which receive messages using normal
;; application. The first argument is the message selector, which is
;; the name to a slot which contains the handler - a procedure - for
;; this message.

;; Some slots are parent slots. If a slot with the message selector
;; name is not found locally, all parents are asked. The lookup method
;; is a faithful reimplementation of the Self lookup algorithm.

;; See the README file for more information, or MAKE-PROMETHEUS-ROOT-OBJECT
;; for a list of messages the root object understands.

;; This is a very basic internal object: Just slots which receive
;; procedures. We also only discern between parent and method slots,
;; nothing else. The user API is defined in prometheus.scm.

;;; Code:

;;;;;;;;;;;;;;;;;;;
;;; Root Object ;;;
;;;;;;;;;;;;;;;;;;;

;; This creates a root object which only provides the bare-bones
;; interface of the prometheus-internal.

(define (make-prometheus-internal-root-object)
  (let ((obj (make-prometheus-object)))
    (for-each (lambda (entry)
                (add-slot! obj #f (car entry) (cadr entry)))
              `((add-slot!        ,add-slot!)
                (delete-slot!     ,delete-slot!)
                (clone            ,clone)
                (message-not-understood ,message-not-understood)
                (ambiguous-message-send ,ambiguous-message-send)))
    obj))

;;;;;;;;;;;;;;;;
;;; Messages ;;;
;;;;;;;;;;;;;;;;

;;; @deffn Message clone
;;;
;;; Return a clone of the message recipient. This creates a new object
;;; with a single slot, @defvar{parent}, which points to the cloned
;;; object.
;;; @end deffn
(define (clone self resend)
  (let ((new (make-prometheus-object)))
    (add-slot! new #f 'parent self #t)
    new))

;;; @deffn Message add-slot! name proc [parent?]
;;;
;;; Add a method to the recipient. Sending the object a @var{name}
;;; message now invokes @var{proc} with the same arguments in addition
;;; to a @var{self} argument pointing to the current object and a
;;; @var{resend} procedure available to resend the message if the
;;; method does not want to handle it directly.
;;; @end deffn
(define (add-slot! self resend name proc . rest)
  ;; FIXME! Maybe at one point do a type check of PROC?
  (let ((parent? (if (null? rest)
                     #f
                     (car rest))))
    (if (not parent?)
        (obj-add-slot! self name proc #f)
        (obj-add-slot! self
                       name
                       (lambda (self resend)
                         proc)
                       proc))))

;;; @deffn Message delete-slot! name
;;;
;;; Delete the slot @var{name} from the receiving object. Beware that
;;; parents might contain the same slot, so a message send can still
;;; succeed even after a slot is deleted.
;;; @end deffn
(define (delete-slot! self resend name)
  (obj-delete-slot! self name))

;;; @deffn message-not-understood message args
;;;
;;; This is received when the message @var{message} with arguments
;;; @var{args} to the object was not understood.
;;; The root object just signals an error.
;;; @end deffn
(define (message-not-understood self resend message args)
  (error "Message not understood" self message args))

;;; @deffn ambiguous-message-send message args
;;;
;;; This is received when the message @var{message} with arguments
;;; @var{args} to the object would have reached multiple parents.
;;; The root object just signals an error.
;;; @end deffn
(define (ambiguous-message-send self resend message args)
  (error "Ambiguous message send" self message args))


;;;;;;;;;;;;;;;;;;;
;;; Object Data ;;;
;;;;;;;;;;;;;;;;;;;

;; Object data stores the data in each object. We retrieve this data
;; with a special private message, and then can operate on it. It
;; would not be necessary to store the parent list separately, but we
;; do that for speed reasons.

(define-record-type prometheus-data
  (make-prometheus-data slots parents)
  prometheus-data?
  (slots prometheus-data-slots
         set-prometheus-data-slots!)
  (parents prometheus-data-parents
           set-prometheus-data-parents!))

;; We don't check for duplicates in this code for speed reasons. The
;; code that uses these procedures should take care of ensuring that
;; no duplicates are added.

(define (data-add-parent! data name parent)
  (set-prometheus-data-parents! data
                                (cons (cons name parent)
                                      (prometheus-data-parents data)))
  (values))

(define (data-delete-parent! data name)
  (set-prometheus-data-parents! data
                                (alist-delete! name
                                               (prometheus-data-parents data)
                                               eq?))
  (values))

(define (data-get-slot data name)
  (assq name (prometheus-data-slots data)))

(define (data-add-slot! data name slot)
  (set-prometheus-data-slots! data
                              (cons (cons name slot)
                                    (prometheus-data-slots data)))
  (values))

(define (data-delete-slot! data name)
  (set-prometheus-data-slots! data
                              (alist-delete! name
                                             (prometheus-data-slots data)))
  (values))

;;;;;;;;;;;;;;;;;;;;
;;; Object Slots ;;;
;;;;;;;;;;;;;;;;;;;;

;; This record type stores the information about the slots within an
;; object. The handler is just the procedure to be called when the
;; message is received; the parent is true only if this slot is a
;; parent, and then this is the parent object. This way, we can avoid
;; calling the handler again to retrieve it.

(define-record-type prometheus-slot
  (make-prometheus-slot handler parent)
  prometheus-slot?
  (handler prometheus-slot-handler)
  (parent prometheus-slot-parent))


;;; This is the internal message sent to the object to retrieve the
;;; data. Since this is a list, it can't be faked from outside the
;;; module.
(define *prometheus-get-data-message* (list '*prometheus-get-data-message*))

(define (make-prometheus-object)
  (let* ((data (make-prometheus-data '() '()))
         (self #f)
         (obj (lambda (message . args)
                (if (eq? message *prometheus-get-data-message*)
                    data
                    (send self message args)))))
    (set! self obj)
    obj))

(define (prometheus-object-data obj)
  (obj *prometheus-get-data-message*))

(define (obj-add-slot! obj name handler parent)
  (let ((new-slot (make-prometheus-slot handler parent))
        (data (prometheus-object-data obj)))
    (cond
     ((data-get-slot data name)
      => (lambda (entry)
           (if (prometheus-slot-parent (cdr entry))
               (data-delete-parent! obj name))
           (if parent
               (data-add-parent! data name parent))
           (set-cdr! entry new-slot)))
     (else
      (data-add-slot! data name new-slot)
      (if parent
          (data-add-parent! data name parent)))))
  (values))

(define (obj-delete-slot! obj name)
  (let ((data (prometheus-object-data obj)))
    (cond
     ((data-get-slot data name)
      => (lambda (entry)
           (data-delete-slot! data name)
           (if (prometheus-slot-parent (cdr entry))
               (data-delete-parent! data name))))))
  (values))

;;;;;;;;;;;;;;;;;;;;;;;
;;; Message Sending ;;;
;;;;;;;;;;;;;;;;;;;;;;;

;; PROC is a handler for the message ARGS in MESSAGE-HOLDER, where the
;; message was originally sent to OBJ. Evaluate this message,
;; providing the resend procedure.
(define (eval-message obj message-holder proc args)
  (apply proc
         obj
         (lambda (parent message . args)
           (cond
            ((eq? parent #f)
             (undirected-resend obj message-holder message args))
            ((eq? parent #t)
             (undirected-local-resend obj message-holder message args))
            (else
             (directed-resend obj message-holder parent message args))))
         args))


;; Inputs: rec  - the receiver of the message
;;         sel  - the message selector
;;         args - the actual arguments
;; Output: res  - the result object
;;
;; send (rec, sel, args) {
;;   M <- lookup(rec, sel, '())
;;   if |M| = 0: error: message-not-understood
;;      |M| = 1: res <- eval(rec, M, args)
;;      |M| > 1: error: ambiguous-message-send
;;   return res
;; }
(define (send obj message args)
  (send-with-receiver obj obj #f message args))

;; Inputs: rec  - the receiver of the message
;;         smh  - the sending method holder
;;         sel  - the message selector
;;         args - the actual arguments
;; Output: res  - the result object
;;
;; undirected_resend (rec, smh, sel, args) {
;;   M <- parent_lookup(smh, sel '())
;;   if |M| = 0: error: message-not-understood
;;      |M| = 1: res <- eval(rec, M, args)
;;      |M| > 1: error: ambiguous-message-send
;;   end
;;   return res
;; }
(define (undirected-resend obj old-message-holder message args)
  (send-with-receiver obj old-message-holder #t message args))

;; This is the same as UNDIRECTED-RESEND, but it starts searching in
;; the current object.
(define (undirected-local-resend obj old-message-holder message args)
  (send-with-receiver obj old-message-holder #f message args))


;; Inputs: rec - the receiver of the message
;;         smh - the sending method holder
;;         del - the name of the delegatee
;;         sel - the message selector
;; Output: res - the result object
;;
;; directed_resend (rec, smh, del, sel, args) {
;;   D <- { s \in smh | s.name = del }
;;   if |D| = 0
;;   then
;;     error: missing-delegatee
;;   fi
;;   M <- lookup(smh.del, sel, '())
;;   if |M| = 0: error: message-not-understood
;;      |M| = 1: res <- eval(rec, M, args)
;;      |M| > 1: error: ambiguous-message-send
;;   end
;;   return res
;; }
(define (directed-resend obj old-message-holder parent message args)
  (send-with-receiver obj
                      (send-with-receiver old-message-holder
                                          old-message-holder
                                          #f
                                          parent
                                          '())
                      #f
                      message
                      args))

;; Send the MESSAGE with ARGS to RECEIVER, but start with lookup only
;; in LOOKUP-OBJ, or in its parents when START-WITH-PARENTS? is true.
(define (send-with-receiver receiver lookup-obj start-with-parents?
                            message args)
  (receive (proc message-holder error-name)
      (if start-with-parents?
          (parent-lookup lookup-obj message '())
          (lookup lookup-obj message '()))
    (if (not error-name)
        (eval-message receiver message-holder proc args)
        (case error-name
          ((message-not-understood)
           (if (eq? message 'message-not-understood)
               (error "No message not understood handler" receiver message args)
               (receiver 'message-not-understood message args)))
          ((ambiguous-message-send)
           (if (eq? message 'ambiguous-message-send)
               (error "No ambiguous message send handler" receiver message args)
               (receiver 'ambiguous-message-send message args)))
          (else
           (error "Unknown error" error-name receiver message args))))))

;; Inputs: obj - the object being searched
;;         sel - the message selector
;;         V   - visited objects
;; Output: M   - set of matching slots
;;
;; lookup (obj, sel, V) {
;;   if obj \in V
;;   then
;;     res <- '()
;;   else
;;     M <- { s \in obj | s.name = sel }
;;     if M = '()
;;     then
;;        M <- parent_lookup(obj, sel, V)
;;     end
;;   end
;;   return M
;; }
(define (lookup obj message visited)
  ;; We use ASSQ for the cycle detection, as ASSQ is a primitive in
  ;; Scheme 48 as compared to MEMQ. This increases speed measurably.
  (cond
   ((assq obj visited)
    (values #f #f 'message-not-understood))
   ((lookup-immediate obj message)
    => (lambda (value)
         (values value obj #f)))
   (else
    (parent-lookup obj message visited))))

(define (lookup-immediate obj message)
  (cond
   ((data-get-slot (prometheus-object-data obj)
                   message)
    => (lambda (entry)
         (prometheus-slot-handler (cdr entry))))
   (else
    #f)))

;; parent_lookup (obj, sel, V) {
;;   P <- { s \in obj | s.isParent }
;;   M <- \union_{s \in P} lookup(s.contents, sel, V \union { obj })
;; }
(define (parent-lookup obj message old-visited)
  (let ((visited (cons (list obj) old-visited)))
    (let loop ((lis (prometheus-data-parents (prometheus-object-data obj)))
               (message-holder #f)
               (value #f))
      (if (null? lis)
          (if message-holder
              (values value message-holder #f)
              (values #f #f 'message-not-understood))
          (receive (proc this-message-holder error)
              (lookup (cdar lis) message visited)
            (cond
             ((and message-holder
                   this-message-holder
                   (not (eq? message-holder this-message-holder)))
              (values #f #f 'ambiguous-message-send))
             (this-message-holder
              (loop (cdr lis)
                    this-message-holder
                    proc))
             (else
              (loop (cdr lis)
                    message-holder
                    value))))))))