;;;                        "ontosimula"  (Release 1.0)
;;; A simplified executable model of the principles of "metaphysics"
;;;                    by  George P. Loczewski
;;;                    e-mail: schemer@knuut.de
;;;

(load "philgraph.zo")

(define make-element 
  (lambda(aName)
    (letrec ((base-object (make-base-object))
             (name aName)

             (get-type 
               (lambda()
                 "element"))

             (get-name 
               (lambda()
                 name))

             (self 
                (lambda(msg)
                  (cond
                     ( (eq? msg 'type) get-type )
                     ( (eq? msg 'name) get-name )
                     ( else  (base-object msg ))))))
      self)))

(define make-mobile-element 
  (lambda(a-name a-room obj)
    (letrec ((super-object (make-element a-name ))
             (room a-room)
             (disp-obj obj)

             (get-type 
               (lambda()
                 "mobile-element"))
          
             (get-room 
               (lambda()
                 room))

             (set
               (lambda(p)
                 (m-dispatch disp-obj 'set p)))

             (set-room 
               (lambda(val)
                 (set! room val)))

             (self 
               (lambda(msg)
                 (cond
                    ( (eq? msg 'type) get-type )
                    ( (eq? msg 'room) get-room )
                    ( (eq? msg 'set) set )
                    ( (eq? msg 'set-room) set-room )
                    ( else  (super-object msg ))))))
      self)))

(define make-room 
  (lambda(a-name)
    (letrec ((super-object (make-element a-name))
             (get-type 
               (lambda()
                 "room"))

             (self 
               (lambda(msg)
                 (cond
                   ( (eq? msg 'type) get-type )
                   ( else  (super-object msg ))))))
      self)))

(define make-thing 
  (lambda(a-name a-room obj)
    (letrec ((super-object (make-mobile-element a-name a-room obj))
             (disp-obj obj)

             (get-disp 
               (lambda()
                 obj))

             (get-type 
               (lambda()
                 "thing"))
          
             (show
               (lambda()
                 (m-dispatch disp-obj 'display)))

             (self 
               (lambda(msg)
                 (cond
                   ( (eq? msg 'type) get-type )
                   ( (eq? msg 'get-disp) get-disp )
                   ( (eq? msg 'show) show )
                   ( else  (super-object msg ))))))
      self)))

(define make-person 
  (lambda(a-name a-room obj)
    (letrec ((super-object (make-mobile-element a-name a-room obj))
             (disp-obj obj)

             (get-disp 
               (lambda()
                 obj))

             (get-type 
               (lambda()
                 "person"))

             (self 
               (lambda(msg)
                 (cond
                   ( (eq? msg 'type) get-type )
                   ( (eq? msg 'get-disp) get-disp)
                   ( else  (super-object msg ))))))
      self)))

(define room-A '?)
(define room-B '?)
(define room-C '?)
(define room-D '?)
(define room-E '?)
(define room-F '?)
(define room-G '?)
(define room-H '?)
(define room-I '?)

(define g-Parmenides '?)
(define g-Plato '?)
(define g-Aristotle '?)
(define g-Sokrates '?)
(define g-Heraklit '?)

(define chopstick-1 '?)
(define chopstick-2 '?)
(define chopstick-3 '?)

(define *count* 1)
(define *castle* #f)
(define *display* #f)

(define init
  (lambda()
    (unless  (graphics-open?)  (open-graphics))
    (set! *display* (init-window 400 500))
    (set! *castle* (make-castle *display*))
    (set! *count* 1)
    (letrec ((list-of-rooms '())
             (d-parmenides (make-person-image *display* #f  COLBLACK))
             (d-plato      (make-person-image *display* #f  COLBLACK))
             (d-aristotle  (make-person-image *display* #f  COLBLACK))
             (d-sokrates   (make-person-image *display* #f  COLBLACK))
             (d-heraklit   (make-person-image *display* #f  COLBLACK))
             (d-chopstick-1     (make-chopstick-image *display* #f  COLRED))
             (d-chopstick-2     (make-chopstick-image *display* #f  COLRED))
             (d-chopstick-3     (make-chopstick-image *display* #f  COLRED))

             (init-disp
               (lambda ()
                 (m-dispatch *castle* 'display)
                 (m-dispatch *castle* 'set-parmenides d-parmenides 'A)
                 (m-dispatch *castle* 'set-plato d-plato 'C)
                 (m-dispatch *castle* 'set-aristotle d-aristotle 'F)
                 (m-dispatch *castle* 'set-sokrates d-sokrates 'H)
                 (m-dispatch *castle* 'set-heraklit d-heraklit 'G)
                 (m-dispatch *castle* 'set-chopstick-1 d-chopstick-1 'I)
                 (m-dispatch *castle* 'set-chopstick-1 d-chopstick-2 'I)
                 (m-dispatch *castle* 'set-chopstick-1 d-chopstick-3 'I)
                  )))
      (display-alln "creating the rooms")
      (set! room-A (make-room 'A))
      (set! room-B (make-room 'B))
      (set! room-C (make-room 'C))
      (set! room-D (make-room 'D))
      (set! room-E (make-room 'E))
      (set! room-F (make-room 'F))
      (set! room-G (make-room 'G))
      (set! room-H (make-room 'H))
      (set! room-I (make-room 'I))
      (display-alln "after creating the rooms")
      (set! list-of-rooms (list room-A 
                                room-B 
                                room-C 
                                room-D 
                                room-E 
                                room-F 
		         	room-G 
                                room-H
                                room-I ))

      (display-alln "creating the persons")

      (init-disp)

      (set! g-Parmenides (make-person 'Parmenides room-A d-parmenides))
      (set! g-Plato (make-person 'Plato room-C d-plato))
      (set! g-Aristotle (make-person 'Aristotle room-F d-aristotle))
      (set! g-Sokrates (make-person 'Sokrates room-H d-sokrates))
      (set! g-Heraklit (make-person 'Heraklit room-G d-heraklit))

      (display-alln "creating the objects")

      (set! chopstick-1 (make-thing 'chopstick-1 room-I d-chopstick-1))
      (set! chopstick-2 (make-thing 'chopstick-2 room-I d-chopstick-2))
      (set! chopstick-3 (make-thing 'chopstick-3 room-I d-chopstick-3))

      (display-alln "putting the objects in rooms")

      (let ((room-chopstick-1 (list-ref list-of-rooms 8))
            (room-chopstick-2 (list-ref list-of-rooms 8))
            (room-chopstick-3 (list-ref list-of-rooms 8)))
        (m-dispatch chopstick-1 'set-room room-chopstick-1)
        (m-dispatch chopstick-2 'set-room room-chopstick-2)
        (m-dispatch chopstick-3 'set-room room-chopstick-3)
        (m-dispatch *castle* 'set-chopstick-1 
                             chopstick-1 (m-dispatch room-chopstick-1 'name))
        (m-dispatch *castle* 'set-chopstick-2 
                             chopstick-2 (m-dispatch room-chopstick-2 'name))
        (m-dispatch *castle* 'set-chopstick-3 
                             chopstick-3 (m-dispatch room-chopstick-3 'name)))
     
      (newline)
      (m-dispatch chopstick-1 'show)
      (m-dispatch chopstick-2 'show)
      (m-dispatch chopstick-3 'show)
      )))

(define *top-level*
  (list
        (list 'help '() 'f 0 (lambda () 'ok))
        (list 'quit '() 'f 0 (lambda () 'ok))
))

(init)
(newline)
'done