;; FILE          "yasos.scm"
;; IMPLEMENTS    YASOS: Yet Another Scheme Object System
;; AUTHOR        Ken [dot] Dickey [at] Whidbey [dot] Com
;; DATE          1992 March 1
;; LAST UPDATED  1992 March 5
;; CHICKEN-PORT  2008 February 7
;; MAINTAINER    ju(at)jugilo(dot)de
;; LAST UPDATED  2013 October 5
;; 

;;; AUTHOR: Ken Dickey, Ken(dot)Dickey(at)Whidbey(dot)Com
;;; ported to Chicken and enhanced by Juergen Lorenz, ju(at)jugilo(dot)de
;;;
;;; COPYRIGHT (c) 1992,2008 by Kenneth A Dickey, All rights reserved.
;;;
;;;Permission is hereby granted, free of charge, to any person
;;;obtaining a copy of this software and associated documentation
;;;files (the "Software"), to deal in the Software without
;;;restriction, including without limitation the rights to use,
;;;copy, modify, merge, publish, distribute, sublicense, and/or
;;;sell copies of the Software, and to permit persons to whom
;;;the Software is furnished to do so, subject to the following
;;;conditions:
;;;
;;;The above copyright notice and this permission notice shall
;;;be included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;;EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
;;;OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;;NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;;HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;;WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;;;FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
;;;OTHER DEALINGS IN THE SOFTWARE.

;; NOTES: An object system for Scheme based on the paper by
;; Norman Adams and Jonathan Rees: "Object Oriented Programming in
;; Scheme", Proceedings of the 1988 ACM Conference on LISP and 
;; Functional Programming, July 1988 [ACM #552880].

(module yasos

(yasos
 size
 protocol
 show
 define-predicate
 (object make-instance)
 (define-operation instance? instance-dispatcher)
 (object-with-ancestors make-instance instance-dispatcher)
 (operations instance? make-instance instance-dispatcher)
 (operate-as instance-dispatcher))

(import scheme (chicken base) (chicken format))

;; INSTANCE? MAKE-INSTANCE INSTANCE-DISPATCHER

;; original version

;(define make-instance 'bogus)  ;; defined below
;(define instance?     'bogus)
;
;(let ((instance-tag "instance"))
;      ;; Make a unique tag within a local scope.
;      ;; No other data object is EQ? to this tag.
;  (set! make-instance
;  (lambda (dispatcher) (cons instance-tag dispatcher)))
;  (set! instance?
;  (lambda (obj) (and (pair? obj) (eq? (car obj) instance-tag))))
;      
;(define-syntax instance-dispatcher
;  (syntax-rules ()
;    ((_ <inst>) (cdr <inst>))))

;; internal
(define-record-type instance
  (make-instance dispatcher)
  instance?
  (dispatcher instance-dispatcher))

;; DEFINE-OPERATION

;; original version
;(define-syntax define-operation
;  (syntax-rules ()
;    ((_ (<name> <inst> <arg> ...) <exp1> <exp2> ...) ;; with body
;     (define <name>
;       (letrec ((self
;                  (lambda (<inst> <arg> ...)
;                    (cond
;                      ((and (instance? <inst>) 
;                            ((instance-dispatcher <inst>) self))
;                         => (lambda (operation) (operation <inst> <arg> ...)))
;                      (else <exp1> <exp2> ...)))))
;         self)))
;    ((_ (<name> <inst> <arg> ...)) ;; no body
;     (define-operation (<name> <inst> <arg> ...)
;       (error "Operation not handled" '<name>
;              (format #f (if (instance? <inst>) "#<INSTANCE>" "~s") <inst>))))))

;; the following version handles arbitrary lambda-lists as args
(define-syntax define-operation
  (syntax-rules ()
    ((_ (name inst arg ...) xpr . xprs) ; ordinary argument list
     (define name
       (letrec (
         (self
           (lambda (inst arg ...)
             (cond
               ((and (instance? inst) 
                     ((instance-dispatcher inst) self))
                => (lambda (operation) (operation inst arg ...)))
               (else xpr . xprs))))
         )
         self)))
    ((_ (name inst . args) xpr . xprs) ; dotted argument list
     (define name
       (letrec (
         (self
           (lambda (inst . args)
             (cond
               ((and (instance? inst) 
                     ((instance-dispatcher inst) self))
                => (lambda (operation)
                     (apply operation inst args)))
               (else xpr . xprs))))
         )
         self)))
    ((_ (name inst . args)) ;; no body
     (define-operation (name inst . args)
       (error "Operation not handled" 'name
              (format #f
                      (if (instance? inst) "#YASOS-INSTANCE" "~s")
                      inst))))))

;; DEFINE-PREDICATE
(define-syntax define-predicate
  (syntax-rules ()
    ((_ name)
     (define-operation (name obj) #f))))

;; OBJECT (deprecated, use operations instead)

;; original version
;(define-syntax object
;  (syntax-rules ()
;    ((_ ((<name> <self> <arg> ...) <exp1> <exp2> ...) ...)
;     (let ((table
;             (list (cons <name>
;                   (lambda (<self> <arg> ...) <exp1> <exp2> ...)) ...)))
;       (make-instance
;         (lambda (op)
;           (cond ((assq op table) => cdr)
;                 (else #f))))))))

(define-syntax object
  (syntax-rules ()
    ((_ ((name inst . args) xpr . xprs) ...)
     (let ((table
             (list (cons name
                         (lambda (inst . args) xpr . xprs)) ...)))
       (make-instance
         (lambda (op)
           (cond
             ((assq op table) => cdr)
             ((eq? op protocol)
              (lambda (obj . optional-sym)
                (if (null? optional-sym)
                  '(name ...)
                  (assq (car optional-sym)
                        '((name inst . args) ...)))))
             (else #f))))))))

;; OBJECT with MULTIPLE INHERITANCE  {First Found Rule}
;; (deprecated, use operations instead)

;; original version
;(define-syntax object-with-ancestors
;  (syntax-rules ()
;    ((_ ((<ancestor1> <init1>) ...) <operation> ...)
;     (let ((<ancestor1> <init1>) ... )
;       (let ((child (object <operation> ...)))
;         (make-instance
;           (lambda (op) 
;             (or ((instance-dispatcher child) op)
;                 ((instance-dispatcher <ancestor1>) op) ...))))))))

(define-syntax object-with-ancestors
  (syntax-rules ()
    ((_ ((ancestor init) ...) operation ...)
     (let ((ancestor init) ...)
       (let ((child (object operation ...)))
         (make-instance
           (lambda (op) 
             (if (eq? op protocol)
               (lambda (obj . optional-sym)
                 (if (null? optional-sym)
                   (append (protocol child)
                           (list (protocol ancestor))
                           ...)
                   (let ((sym (car optional-sym)))
                     (or (protocol child sym)
                         (protocol ancestor sym)
                         ...))))
               (or ((instance-dispatcher child) op)
                 ((instance-dispatcher ancestor) op)
                 ...)))))))))

;; OPERATIONS
(define-syntax operations
  (syntax-rules ()
    ((_ () ((name inst . args) xpr . xprs) ...)
     (let ((table
             (list (cons name
                         (lambda (inst . args) xpr . xprs)) ...)))
       (make-instance
         (lambda (op)
           (cond
             ((assq op table) => cdr)
             ((eq? op protocol)
              (lambda (obj . optional-sym)
                (if (null? optional-sym)
                  '(name ...)
                  (assq (car optional-sym)
                        '((name inst . args) ...)))))
             (else #f))))))
    ((_ ((ancestor0 init0) (ancestor1 init1) ...) operation ...)
     (let ((ancestor0 init0) (ancestor1 init1) ...)
       (let ((child (operations () operation ...)))
         (make-instance
           (lambda (op) 
             (if (eq? op protocol)
               (lambda (obj . optional-sym)
                 (if (null? optional-sym)
                   (append (protocol child)
                           (list (protocol ancestor0))
                           (list (protocol ancestor1))
                           ...)
                   (let ((sym (car optional-sym)))
                     (or (protocol child sym)
                         (protocol ancestor0 sym)
                         (protocol ancestor1 sym)
                         ...))))
               (or ((instance-dispatcher child) op)
                 ((instance-dispatcher ancestor0) op)
                 ((instance-dispatcher ancestor1) op)
                 ...)))))))))

    
;; OPERATE-AS  {a.k.a. send-to-super}
;; used in operations/methods
(define-syntax operate-as
  (syntax-rules ()
    ((_ super op)
     ((instance-dispatcher super) op))
    ((_ super op self arg ...)
     (((instance-dispatcher super) op) self arg ...))))

(define-operation (show obj . optional-arg)
  (if (null? optional-arg)
    (show obj #t)
    (if (instance? obj)
       (format (car optional-arg) "<yasos-instance: ~s>~%" obj)
       (format (car optional-arg) "<not-a-yasos-instance: ~s>~%" obj))))
 
(define-operation (size obj)
  ;; default behaviour
  (cond
    ((vector? obj) (vector-length obj))
    ((list? obj) (length obj))
    ((string? obj) (string-length obj))
    ((pair? obj) 2)
    ((char? obj) 1)
    (else (error 'size
                 (format #f "~s doesn't accept operation" obj)))))

(define-operation (protocol obj . args) #f)

(define yasos
  (let ((lst '(define-predicate define-operation operations
               object object-with-ancestors operate-as protocol size
               show)))
    (case-lambda
      (() lst)
      ((arg)
       (case arg
         ((show)
          '(procedure
             ((_ obj)
              "prints obj with format to stdout")
             ((_ obj arg)
              "prints obj with format to arg")))
         ((size)
          '(procedure (result)
             ((_ obj)
              #t
              (and (fixnum result) (fx>= result 0)))))
         ((protocol)
          '(procedure (result)
             ((_ obj)
              (instance? obj)
              (and (list? result) "the names of operations obj accepts"))
             ((_ obj sym)
              (and (instance? obj) (symbol? sym))
              (and (list? result) "signature of exported operation sym"))))
         ((define-predicate)
          '(macro ()
                  ((_ name)
                   (identifier? name)
                   (procedure? result))))
         ((define-operation)
          '(macro ()
                  ((_ (name inst . args) . xprs)
                   (and (instance? inst) (identifier? name))
                   (procedure? result))))
         ((operations)
          '(macro ()
                  ((_ () ((name self . args) xpr . xprs) ...)
                   (and (identifier? name) (instance? self))
                   "multiple operations named name ... with given signature")
                  ((_ ((ancestor init) ...) op . ops))
                  (and (instance? ancestor) ... (operation? op) ...)
                  "new or overridden operaions op . ops"))
         ((object)
          '(macro ()
                  ((_ ((name self . args) xpr . xprs) ...)
                   (and (identifier? name) (instance? self))
                   "multiple operations named name ... with given signature")))
         ((object-with-ancestors)
          '(macro ()
                  ((_ ((ancestor init) ...) op . ops))
                  (and (instance? ancestor) ... (operation? op) ...)
                  "new or overridden operaions op . ops"))
         ((operate-as)
          '(macro ()
                  ((_ super op self . args)
                   (and (instance? super)
                        (instance? self)
                        (operation? op))
                   "send to super")))
         (else
           (error 'yasos "choose one of" lst)))))))

) ;module yasos