;;;                        "ontosimula"  (Release 1.0)
;;; A simplified executable model of the principles of "metaphysics"
;;;                    by  George P. Loczewski
;;;                    e-mail: schemer@knuut.de
;;;
;;;                    "meta-object protocol"
;;;
;;; The implementation was strongly influenced by the following
;;; books: 
;;;
;;;    "Programmer avec Scheme" by Jacques Chazarain (meta-object protocol),
;;;    "The Programming Language Scheme" by R.Kent Dybvig (multitasking)
;;;    "Scheme and the Art of Programming" by George Springer and
;;;       Daniel P. Friedman (algorithm for pseudo-random numbers)
;;;    "A Little Smalltalk" by Timothy Budd ("Dining Philosophers Problem",
;;;       originally introduced by Edsgar W. Dijkstra)
;;;
;;; mopgpl supports classes interfaces and intelligent objects
;;; An interface is implemented as a class with static methods
;;; which produce an error message. All methods in an interface
;;; stand only for a protocol and must be implemented by a 
;;; concrete class.
;;; The intelligent object allows for customized sophisticated
;;; dispatching procedures.
;;;

(define (display-all . L)
  (for-each display L)
  (display #\space))

(define (append2! L1 L2)
  (cond ((null? L1) L2)
        (else (set-cdr! (last-pair L1) L2) L1)))

(define (append! L1 L2)
  (cond ((null? L1) L2)
        (else (set-cdr! (list-tail L1 (- (length L1) 1)) L2) L1)))

(define (remove m li)
  (cond ((null? li) '()) 
        ((equal? m (car li)) (remove m (cdr li)))
        (else (cons (car li) (remove m (cdr li))))))

(define remove! 
  (lambda(item a-list)
    (let ((nli (remove item a-list)))
      (if nli
        (begin
          (set-car! a-list (car nli))
          (set-cdr! a-list (cdr nli)))
        'unknown-method )
      'undefined)))

(define (last-pair L)
  (if (or (null? L) (null? (cdr L)))
    L
    (last-pair (cdr L))))

(define (assoc-tail x alist) 
     (if (null? alist) 
         #f
         (if (equal?  x (caar alist)) 
             alist
             (assoc-tail x (cdr alist)))))

(define (list-pos x alist ) 
     (list-pos-aux x alist 0))

(define (list-pos-aux x alist indx) 
     (if (null? alist) 
         #f
         (if (equal?  x (caar alist)) 
             indx
             (list-pos-aux x (cdr alist) (+ 1 indx)))))

;(define-syntax defmethod  
;   (syntax-rules()
;     ((defmethod name-of-method name-of-class-var (param1 ...) stmt1 ...)
;      (add-modify! name-of-method 
;                   (lambda (cons 'self (list param1 ...) stmt1 ...))
;                   (list-of-methods name-of-class-var
;     ((defmethod name-of-method name-of-class-var () stmt1 ...)
;      (add-modify! name-of-method 
;                   (lambda ('self ) stmt1 ...)
;                   (list-of-methods name-of-class-var


(define msend
  (lambda(object msg . args)
    (apply (object msg) args)))
       
(define m-dispatch
  (lambda(object msg . args)
    (if (vector? object)
        (let ((odisp (vector-ref object 2)))
          (if odisp
              (apply (odisp msg) args)
              (begin
                (display-alln "object dispatcher not defined!")
                'ERROR)))
        (apply (object msg) args) )))
       
(define obeq?
  (lambda(a b)
    (cond
      ((and (procedure? a) (procedure? b))
       (eq? a b))
      ((and (procedure? a) (vector? b))
       (eq? a (vector-ref b 2)))
      ((and (vector? a) (procedure? b))
       (eq? (vector-ref a 2) b ))
      (else (eq? a b)))))
 
(define get-class 
  (lambda (class-name-var)
    (let ((doublet (assoc class-name-var *the-classes*)))
      (if doublet
        (cdr doublet)
        ;(*error* " class does not exist: " class-name-var)
        #f
        ))))

(define super-class 
  (lambda(class-name-var)
    (vector-ref (get-class class-name-var) 1)))

(define list-of-fields
  (lambda(class-name-var)
    (vector-ref (get-class class-name-var) 2)))

(define list-of-methods 
  (lambda(class-name-var)
    ;(display-alln "name: " class-name-var)
    ;(display-alln "class: " (get-class class-name-var))
    (vector-ref (get-class class-name-var) 3)
    ))

(define name-of-class 
  (lambda(obj)
    (vector-ref obj 0)))

(define make-class 
  (lambda(class-name-var super-class-var lfields-var)
    (let ((new-class (vector class-name-var 
                             super-class-var 
                             lfields-var 
                             (list (cons '() '()) )
                             )))
      (add-modify! class-name-var new-class *the-classes*))))

(define make-nature-of 
  (lambda(class-name-var super-class-var lfields-var)
    (let ((new-class (vector class-name-var 
                             super-class-var 
                             lfields-var 
                             (list (cons '() '()) )
                             )))
      (add-modify! class-name-var new-class *the-classes*))))

(define add-modify! 
  (lambda(key value a-list)
    (let ((doublet (assoc key a-list)))
      (if doublet
        (set-cdr! doublet value)
        (append2! a-list (list (cons key value))))
      'undefined)))


(define add-method 
  (lambda(name-of-class-var name-of-method method)
    ;(display-alln name-of-class-var)
    (add-modify! name-of-method 
                 method
                 (list-of-methods name-of-class-var))))

(define del-method 
  (lambda(name-of-class-var name-of-method )
    (let ((method (find-method name-of-class-var name-of-method)))
      ;(display-alln name-of-class-var)
      (remove! (list name-of-method 
                     method)
               (list-of-methods name-of-class-var)))))

(define make-instance 
  (lambda(class-name-var field-values-var xobject-control)
    (let ((sclass-var '?)
          (oclass-var (get-class class-name-var))
          (odisp #f))
      (if xobject-control
          (set! odisp xobject-control))
      (if (equal? oclass-var #f)
        (*error* " class does not exist: " class-name-var))
      (if (null? field-values-var)
          (vector class-name-var 
                  (list (cons '() '()))
                  odisp)
          (let ((attribute-names  (l-even field-values-var))
                (attribute-values (l-odd field-values-var)))
            (vector class-name-var 
                    (map cons attribute-names 
                              attribute-values)
                    odisp))))))

(define (l-even L)
  (if (null? L)
    '()
    (cons (car L) (l-even (cddr L)))))

(define (l-odd L)
  (if (or (null? L) (null? (cdr L)))
    '()
    (cons (cadr L) (l-odd (cddr L)))))
 
(define (get-val object name-of-var)
  (let ((retval (assoc name-of-var (vector-ref object 1))))
    (if retval
        (cdr retval)
        (let ((odisp (vector-ref object 2)))
          (if odisp
              (apply odisp (cons 'get-val (cons name-of-var (list object))))
              (begin
                (display-alln "uninitialized variable: " name-of-var)
                'ERROR))))))

(define (set-val! object name-of-var value) 
  (let* ((a-list  (vector-ref object 1))
         (retval (assoc name-of-var a-list)))
    (if retval
        (set-cdr! retval value)
        (if (find-attribute name-of-var (name-of-class object ))
            (append2! a-list (list (cons name-of-var value)))
            (let ((odisp (vector-ref object 2)))
              (if odisp
                  (apply odisp (cons 'set-val! 
                                     (cons name-of-var 
                                           (list value object))))
                  (begin
                    (display-alln "invalid attribute : " name-of-var)
                    'ERROR)))))))

(define (find-attribute attribute-name name-of-class-var)
  (if (member? attribute-name (list-of-fields name-of-class-var))
      #t
      (find-attribute attribute-name (super-class name-of-class-var))))

(define (find-method message name-of-class-var)
  (if name-of-class-var
    (let ((doublet (assoc message (list-of-methods name-of-class-var))))
      (if doublet
        (cdr doublet)
        (find-method message (super-class name-of-class-var))))
    (begin
      (display-alln " unknown method: " message)
      #f)))

(define (sm object message . argts)
  (let ((method (find-method message (name-of-class object)))
        (odisp (vector-ref object 2)))
    (if method
      (apply method (cons object argts))
      (if odisp
          (apply odisp (cons message (cons object argts)))
          'ERROR))))

(define (sm-next object name-of-class-var message . argts)
  (let ((method (find-method message (super-class name-of-class-var))))
    (if method
      (apply method (cons object argts)))))

(define make-base-object
   (lambda()
      (lambda(msg)
         'ERROR)))