;;;                        "ontosimula"  (Release 1.0; 30-July-1999)
;;; A simplified executable model of the principles of "metaphysics"
;;;                    by  George P. Loczewski
;;;                    e-mail: schemer@knuut.de
;;;
;;; For a description of the program please read the README file in
;;; the distribution directory!
;;;

(load "ontutil.zo")
 
(define Being (make-nature-of "Being" #f '(
                                          ;essence-accident-potenial
                                          ;essence-accident-act
                                          ;essence-substance-potenial
                                          ;essence-substance-act
                                          )))

(defmethod act-of-being "Being" ()
  (display "method must be overloaded!")
  (newline))

(define Philosopher (make-nature-of "Philosopher" "Being" 
                                      '(t-time 
                                       e-time 
                                       s-time 
                                       w-time 
                                       k-time 
                                       ticks
                                       old?
                                       room)
                                       ))
  
(defmethod get-chopsticks  "Philosopher" ()
  (let ((ret-val (sm *chopsticks* 'get-two)))
    (while (equal? #f ret-val)
      (m-set-color (name-of-class self) COLGREEN)
      (set-val! self 'w-time (+ (get-val self 'w-time) 1)) 
      ((creator 'wait))
      (set! ret-val (sm *chopsticks* 'get-two)))
    (m-move (m-dispatch (car ret-val) 'name) (get-val self 'room))
    (m-move (m-dispatch (cadr ret-val) 'name) (get-val self 'room))
    ret-val))

(defmethod return-chopsticks  "Philosopher" (sticks)
  (m-move (m-dispatch (car sticks) 'name) 'I)
  (m-move (m-dispatch (cadr sticks) 'name) 'I)
  (sm *chopsticks* 'return-two sticks)
  ((creator 'wait)))

(defmethod think  "Philosopher" (n)
  (let ((x n))
    ;(display (name-of-class self))
    ;(display ": thinking")
    ;(newline)
    (m-set-color (name-of-class self) COLBLUE)
    (while (> x 0)
      ((creator 'wait))
      (set! x (- x 1)))
    (set-val! self 't-time (+ (get-val self 't-time) n)) 
    #t))

(defmethod eat  "Philosopher" (n)
  (let ((x n))
    ;(display (name-of-class self))
    ;(display ": eating")
    ;(newline)
    (m-set-color (name-of-class self) COLRED)
    (while (> x 0)
      ((creator 'wait))
      (set! x (- x 1)))
    (set-val! self 'e-time (+ (get-val self 'e-time) n)) 
    #t))

(defmethod sleep  "Philosopher" (n)
  (let ((x n))
    ;(display (name-of-class self))
    ;(display ": sleeping")
    ;(newline)
    (m-set-color (name-of-class self) COLBLACK)
    (while (> x 0)
      ((creator 'wait))
      (set! x (- x 1)))
    (set-val! self 's-time (+ (get-val self 's-time) n)) 
    #t))
  
(defmethod sick  "Philosopher" (n)
  (let ((x n))
    ;(display (name-of-class self))
    ;(display ": sick")
    ;(newline)
    (m-set-color (name-of-class self) COLGELB)
    (while (> x 0)
      ((creator 'wait))
      (set! x (- x 1)))
    (set-val! self 'k-time (+ (get-val self 'k-time) n)) 
    #t))
  
;(defmethod select-pattern  "Philosopher" (cl-name)
;  (let ((x (srand 1 4))
;        (labels (list 'pattern-normal
;                      'pattern-dedicated
;                      'pattern-above-and-beyond
;                      'pattern-moderate))
;        (patterns (list
;                      (find-method 'pattern-normal cl-name )
;                      (find-method 'pattern-dedicated cl-name )
;                      (find-method 'pattern-above-and-beyond cl-name )
;                      (find-method 'pattern-moderate cl-name )))
;        (label '?)
;        (pattern #f))
;    (set! label (list-ref labels (- x 1)))
;    (set! pattern (list-ref patterns (- x 1)))
;    ;(set! label (list-ref labels 1)) 
;    ;(set! pattern (list-ref patterns 1)) 
;    (cons label pattern)
;    ))
  
(defmethod act-of-being "Philosopher" ()
  (let ((x 5)
        (ticks '?)
        (pat '?)
        (fragm '?))
    (while (> x 0)
      (set! pat (sm self 'select-pattern (name-of-class self)))
      (if (equal? 'pattern-sick (car pat))
          (set! fragm " got sick: ")
          (set! fragm " selected: "))
      (display-alln (name-of-class self) fragm *tab* 
                                         "day: " (- 6 x) *tab*
                    (car pat))
      ((cdr pat) self)
      (set! ticks ((creator 'get-ticks)))
      (if (> ticks 500)
          (sm self 'grow-old))
      (set! x (- x 1)))
    (display-alln (name-of-class self) ":" #\newline
                  "-->thinking: " (get-val self 't-time)
                  ": eating: " (get-val self 'e-time)
                  ": sleeping: " (get-val self 's-time)
                  ": waiting: " (get-val self 'w-time)
                  ": sick: " (get-val self 'k-time)
                  ": ticks: " ((creator 'get-ticks)))
    (name-of-class  self)))

(defmethod pattern-normal "Philosopher" ()
  (let ((sticks '()))
    (set! sticks (sm self 'get-chopsticks))
    (sm self 'eat 1)
    (sm self 'return-chopsticks sticks)
    (sm self 'think 3)
    (set! sticks (sm self 'get-chopsticks))
    (sm self 'eat 1)
    (sm self 'return-chopsticks sticks)
    (sm self 'think 4)
    (set! sticks (sm self 'get-chopsticks))
    (sm self 'eat 1)
    (sm self 'return-chopsticks sticks)
    (sm self 'think 4)
    (set! sticks (sm self 'get-chopsticks))
    (sm self 'eat 2)
    (sm self 'return-chopsticks sticks)
    (sm self 'sleep 8)))
  
(defmethod pattern-sick "Philosopher" ()
  (let ((sticks '()))
    (set! sticks (sm self 'get-chopsticks))
    (sm self 'eat 1)
    (sm self 'return-chopsticks sticks)
    (sm self 'sick 3)
    (set! sticks (sm self 'get-chopsticks))
    (sm self 'eat 1)
    (sm self 'return-chopsticks sticks)
    (sm self 'sick 4)
    (set! sticks (sm self 'get-chopsticks))
    (sm self 'eat 1)
    (sm self 'return-chopsticks sticks)
    (sm self 'sick 5)
    (set! sticks (sm self 'get-chopsticks))
    (sm self 'eat 1)
    (sm self 'return-chopsticks sticks)
    (sm self 'sleep 8)))
  
(defmethod pattern-dedicated "Philosopher" ()
  (let ((sticks '()))
    (set! sticks (sm self 'get-chopsticks))
    (sm self 'eat 1)
    (sm self 'return-chopsticks sticks)
    (sm self 'think 7)
    (set! sticks (sm self 'get-chopsticks))
    (sm self 'eat 1)
    (sm self 'return-chopsticks sticks)
    (sm self 'think 7)
    (set! sticks (sm self 'get-chopsticks))
    (sm self 'eat 1)
    (sm self 'return-chopsticks sticks)
    (sm self 'sleep 7)))

(defmethod pattern-above-and-beyond "Philosopher" ()
  (let ((sticks '()))
    (sm self 'think 8)
    (set! sticks (sm self 'get-chopsticks))
    (sm self 'eat 1)
    (sm self 'return-chopsticks sticks)
    (sm self 'think 8)
    (set! sticks (sm self 'get-chopsticks))
    (sm self 'eat 1)
    (sm self 'return-chopsticks sticks)
    (sm self 'sleep 6)))

(defmethod pattern-moderate "Philosopher" ()
  (let ((sticks '()))
    (set! sticks (sm self 'get-chopsticks))
    (sm self 'eat 1)
    (sm self 'return-chopsticks sticks)
    (sm self 'think 1)
    (set! sticks (sm self 'get-chopsticks))
    (sm self 'eat 1)
    (sm self 'return-chopsticks sticks)
    (sm self 'think 2)
    (set! sticks (sm self 'get-chopsticks))
    (sm self 'eat 2)
    (sm self 'sleep 1)
    (sm self 'return-chopsticks sticks)
    (sm self 'think 2)
    (set! sticks (sm self 'get-chopsticks))
    (sm self 'eat 1)
    (sm self 'return-chopsticks sticks)
    (sm self 'think 3)
    (set! sticks (sm self 'get-chopsticks))
    (sm self 'eat 2)
    (sm self 'return-chopsticks sticks)
    (sm self 'sleep 8)))

(defmethod grow-old "Philosopher" ()
  (let ((oldp (get-val self 'old?)))
    (if oldp
        #f
        (begin
          (set-val! self 'old? #t)
          #t))))

(define Sokrates (make-nature-of "Sokrates" "Philosopher" 
                                      '(
                                       ;individual-nature-potenial
                                       ;individual-nature-act
                                       ;suppositum
                                       )))
  
(define Plato (make-nature-of "Plato" "Philosopher" 
                                      '(
                                        ;individual-nature-potenial
                                        ;individual-nature-act
                                        ;suppositum
                                        )))
  
(define Aristotle (make-nature-of "Aristotle" "Philosopher" 
                                      '(
                                       ;individual-nature-potenial
                                       ;individual-nature-act
                                       ;suppositum
                                       )))
  
(define Parmenides (make-nature-of "Parmenides" "Philosopher" 
                                      '(
                                       ;individual-nature-potenial
                                       ;individual-nature-act
                                       ;suppositum
                                       )))
  
(define Heraklit (make-nature-of "Heraklit" "Philosopher" 
                                       '(
                                        ;individual-nature-potenial
                                        ;individual-nature-act
                                        ;suppositum
                                        )))
  
;(defmethod select-pattern  "Heraklit" (cl-name)
;  (let* ((ticks ((creator 'get-ticks)))
;         (x (if (> ticks 300)
;                (srand 1 3)
;                (srand 1 4)))
;         (labels (list 'pattern-normal
;                       'pattern-dedicated
;                       'pattern-moderate
;                       'pattern-above-and-beyond))
;         (patterns (list
;                       (find-method 'pattern-normal cl-name )
;                       (find-method 'pattern-dedicated cl-name )
;                       (find-method 'pattern-moderate cl-name )
;                       (find-method 'pattern-above-and-beyond cl-name )))
;         (label '?)
;         (pattern #f)
;         (ticks ((creator 'get-ticks))))
;    (set! label (list-ref labels (- x 1)))
;    (set! pattern (list-ref patterns (- x 1)))
;    ;(set! label (list-ref labels 1)) 
;    ;(set! pattern (list-ref patterns 1)) 
;    (cons label pattern)
;    ))

(defmethod grow-old "Heraklit" ()
  (let ((old (get-val self 'old?)))
    (if old
        #f
        (begin
          (set-val! self 'old? #t)
          (add-method "Heraklit" 'pattern-above-and-beyond 
                                 (find-method 'pattern-dedicated "Heraklit"))
          #t))))

(defmethod select-pattern  "Heraklit" (cl-name)
  (let* ((x (srand 1 16))
        (name (name-of-class self))
        (labels (list 
                      'pattern-normal
                      'pattern-dedicated
                      'pattern-normal
                      'pattern-sick
                      'pattern-moderate
                      'pattern-above-and-beyond
                      'pattern-normal
                      'pattern-moderate
                      'pattern-normal
                      'pattern-dedicated
                      'pattern-normal
                      'pattern-sick
                      'pattern-moderate
                      'pattern-above-and-beyond
                      'pattern-normal
                      'pattern-moderate
                      ))
        (patterns (list
                      (find-method 'pattern-normal name )
                      (find-method 'pattern-dedicated name )
                      (find-method 'pattern-normal name )
                      (find-method 'pattern-sick name )
                      (find-method 'pattern-moderate name )
                      (find-method 'pattern-above-and-beyond name )
                      (find-method 'pattern-normal name )
                      (find-method 'pattern-moderate name )
                      (find-method 'pattern-normal name )
                      (find-method 'pattern-dedicated name )
                      (find-method 'pattern-normal name )
                      (find-method 'pattern-sick name )
                      (find-method 'pattern-moderate name )
                      (find-method 'pattern-above-and-beyond name )
                      (find-method 'pattern-normal name )
                      (find-method 'pattern-moderate name )))
        (label '?)
        (pattern #f))
    (set! label (list-ref labels (- x 1)))
    (set! pattern (list-ref patterns (- x 1)))
    ;(set! label (list-ref labels 1)) 
    ;(set! pattern (list-ref patterns 1)) 
    (cons label pattern)
    ))

(defmethod select-pattern  "Parmenides" (cl-name)
  (let* ((x (srand 1 16))
        (name (name-of-class self))
        (labels (list 
                      'pattern-normal
                      'pattern-dedicated
                      'pattern-dedicated
                      'pattern-normal
                      'pattern-above-and-beyond
                      'pattern-dedicated
                      'pattern-normal
                      'pattern-moderate
                      'pattern-normal
                      'pattern-dedicated
                      'pattern-dedicated
                      'pattern-sick
                      'pattern-above-and-beyond
                      'pattern-dedicated
                      'pattern-normal
                      'pattern-moderate
                      ))
        (patterns (list
                      (find-method 'pattern-normal name )
                      (find-method 'pattern-dedicated name )
                      (find-method 'pattern-dedicated name )
                      (find-method 'pattern-normal name )
                      (find-method 'pattern-above-and-beyond name )
                      (find-method 'pattern-dedicated name )
                      (find-method 'pattern-normal name )
                      (find-method 'pattern-moderate name )
                      (find-method 'pattern-normal name )
                      (find-method 'pattern-dedicated name )
                      (find-method 'pattern-dedicated name )
                      (find-method 'pattern-sick name )
                      (find-method 'pattern-above-and-beyond name )
                      (find-method 'pattern-dedicated name )
                      (find-method 'pattern-normal name )
                      (find-method 'pattern-moderate name )))
        (label '?)
        (pattern #f))
    (set! label (list-ref labels (- x 1)))
    (set! pattern (list-ref patterns (- x 1)))
    ;(set! label (list-ref labels 1)) 
    ;(set! pattern (list-ref patterns 1)) 
    (cons label pattern)
    ))
  
(defmethod select-pattern  "Plato" (cl-name)
  (let* ((x (srand 1 16))
        (name (name-of-class self))
        (labels (list 
                      'pattern-normal
                      'pattern-dedicated
                      'pattern-dedicated
                      'pattern-normal
                      'pattern-dedicated
                      'pattern-above-and-beyond
                      'pattern-dedicated
                      'pattern-dedicated
                      'pattern-normal
                      'pattern-dedicated
                      'pattern-dedicated
                      'pattern-sick
                      'pattern-dedicated
                      'pattern-above-and-beyond
                      'pattern-dedicated
                      'pattern-dedicated
                      ))
        (patterns (list
                      (find-method 'pattern-normal name )
                      (find-method 'pattern-dedicated name )
                      (find-method 'pattern-dedicated name )
                      (find-method 'pattern-normal name )
                      (find-method 'pattern-dedicated name )
                      (find-method 'pattern-above-and-beyond name )
                      (find-method 'pattern-dedicated name )
                      (find-method 'pattern-dedicated name )
                      (find-method 'pattern-normal name )
                      (find-method 'pattern-dedicated name )
                      (find-method 'pattern-dedicated name )
                      (find-method 'pattern-sick name )
                      (find-method 'pattern-dedicated name )
                      (find-method 'pattern-above-and-beyond name )
                      (find-method 'pattern-dedicated name )
                      (find-method 'pattern-dedicated name )))
        (label '?)
        (pattern #f))
    (set! label (list-ref labels (- x 1)))
    (set! pattern (list-ref patterns (- x 1)))
    ;(set! label (list-ref labels 1)) 
    ;(set! pattern (list-ref patterns 1)) 
    (cons label pattern)
    ))
  
(defmethod grow-old "Sokrates" ()
  (let ((oldp (get-val self 'old?)))
    (if oldp
        #f
        (begin
          (set-val! self 'old? #t)
          (add-method "Sokrates" 'pattern-above-and-beyond 
                                 (find-method 'pattern-dedicated "Sokrates"))
          #t))))

(defmethod select-pattern  "Sokrates" (cl-name)
  (let* ((x (srand 1 16))
        (name (name-of-class self))
        (labels (list 
                      'pattern-normal
                      'pattern-dedicated
                      'pattern-dedicated
                      'pattern-normal
                      'pattern-dedicated
                      'pattern-above-and-beyond
                      'pattern-normal
                      'pattern-dedicated
                      'pattern-normal
                      'pattern-dedicated
                      'pattern-dedicated
                      'pattern-sick
                      'pattern-dedicated
                      'pattern-above-and-beyond
                      'pattern-normal
                      'pattern-dedicated
                      ))
        (patterns (list
                      (find-method 'pattern-normal name )
                      (find-method 'pattern-dedicated name )
                      (find-method 'pattern-normal name )
                      (find-method 'pattern-normal name )
                      (find-method 'pattern-moderate name )
                      (find-method 'pattern-above-and-beyond name )
                      (find-method 'pattern-normal name )
                      (find-method 'pattern-moderate name )
                      (find-method 'pattern-normal name )
                      (find-method 'pattern-dedicated name )
                      (find-method 'pattern-normal name )
                      (find-method 'pattern-sick name )
                      (find-method 'pattern-moderate name )
                      (find-method 'pattern-above-and-beyond name )
                      (find-method 'pattern-normal name )
                      (find-method 'pattern-moderate name )))
        (label '?)
        (pattern #f))
    (set! label (list-ref labels (- x 1)))
    (set! pattern (list-ref patterns (- x 1)))
    ;(set! label (list-ref labels 1)) 
    ;(set! pattern (list-ref patterns 1)) 
    (cons label pattern)
    ))
  
(defmethod select-pattern  "Aristotle" (cl-name)
  (let* ((x (srand 1 16))
        (name (name-of-class self))
        (labels (list 
                      'pattern-normal
                      'pattern-dedicated
                      'pattern-dedicated
                      'pattern-dedicated
                      'pattern-sick
                      'pattern-above-and-beyond
                      'pattern-above-and-beyond
                      'pattern-dedicated
                      'pattern-normal
                      'pattern-dedicated
                      'pattern-dedicated
                      'pattern-normal
                      'pattern-dedicated
                      'pattern-above-and-beyond
                      'pattern-above-and-beyond
                      'pattern-normal
                      ))
        (patterns (list
                      (find-method 'pattern-normal name )
                      (find-method 'pattern-dedicated name )
                      (find-method 'pattern-dedicated name )
                      (find-method 'pattern-dedicated name )
                      (find-method 'pattern-sick name )
                      (find-method 'pattern-above-and-beyond name )
                      (find-method 'pattern-above-and-beyond name )
                      (find-method 'pattern-dedicated name )
                      (find-method 'pattern-normal name )
                      (find-method 'pattern-dedicated name )
                      (find-method 'pattern-dedicated name )
                      (find-method 'pattern-normal name )
                      (find-method 'pattern-dedicated name )
                      (find-method 'pattern-above-and-beyond name )
                      (find-method 'pattern-above-and-beyond name )
                      (find-method 'pattern-normal name )
                   ))
        (label '?)
        (pattern #f))
    (set! label (list-ref labels (- x 1)))
    (set! pattern (list-ref patterns (- x 1)))
    ;(set! label (list-ref labels 1)) 
    ;(set! pattern (list-ref patterns 1)) 
    (cons label pattern)
    ))
  
(defmethod pattern-normal "Heraklit" ()
  (let ((sticks '()))
    (set! sticks (sm self 'get-chopsticks))
    (sm self 'eat 1)
    (sm self 'return-chopsticks sticks)
    (sm self 'think 3)
    (set! sticks (sm self 'get-chopsticks))
    (sm self 'eat 2)
    (sm self 'return-chopsticks sticks)
    (sm self 'think 3)
    (set! sticks (sm self 'get-chopsticks))
    (sm self 'eat 1)
    (sm self 'return-chopsticks sticks)
    (sm self 'think 3)
    (set! sticks (sm self 'get-chopsticks))
    (sm self 'eat 3)
    (sm self 'return-chopsticks sticks)
    (sm self 'sleep 8)))

(defmethod pattern-dedicated "Heraklit" ()
  (let ((sticks '()))
    (set! sticks (sm self 'get-chopsticks))
    (sm self 'eat 1)
    (sm self 'return-chopsticks sticks)
    (sm self 'think 6)
    (set! sticks (sm self 'get-chopsticks))
    (sm self 'eat 1)
    (sm self 'return-chopsticks sticks)
    (sm self 'think 6)
    (set! sticks (sm self 'get-chopsticks))
    (sm self 'eat 2)
    (sm self 'return-chopsticks sticks)
    (sm self 'sleep 8)))

(defmethod pattern-above-and-beyond "Heraklit" ()
  (let ((sticks '())
        (ticks ((creator 'get-ticks))))
    (if (> ticks 500)
        (display-alln "Heraklit: I should have never been called!"))
    (set! sticks (sm self 'get-chopsticks))
    (sm self 'eat 1)
    (sm self 'return-chopsticks sticks)
    (sm self 'think 6)
    (set! sticks (sm self 'get-chopsticks))
    (sm self 'eat 1)
    (sm self 'return-chopsticks sticks)
    (sm self 'think 6)
    (set! sticks (sm self 'get-chopsticks))
    (sm self 'eat 2)
    (sm self 'return-chopsticks sticks)
    (sm self 'sleep 8)))


(defmethod get-chopsticks  "Sokrates" ()
  (let ((ret-val (sm *chopsticks* 'get-one)))
    (while (equal? #f ret-val)
      (set-val! self 'w-time (+ (get-val self 'w-time) 1)) 
      ((creator 'wait))
      (set! ret-val (sm *chopsticks* 'get-one)))
    (m-move (m-dispatch  ret-val 'name) (get-val self 'room))
    (list ret-val)))

(defmethod return-chopsticks  "Sokrates" (chop)
  (sm *chopsticks* 'return-one chop)
  ;(display-alln "chop: " chop)
  (m-move (m-dispatch (car chop) 'name) 'I)
  ((creator 'wait)))

(define Chopsticks (make-class "Chopsticks" #f
                                     '(bag)))

(defmethod get-two "Chopsticks" ()
  (let ((tbag (get-val self 'bag))
        (lchops #f))
    (if (>= (length tbag) 2)
        (begin
          (set! lchops (list (car tbag) (cadr tbag)))
          (set-val! self 'bag (cdr (cdr tbag)))
          lchops))
    lchops))

(defmethod get-one "Chopsticks" ()
  (let ((tbag (get-val self 'bag))
        (stick '?))
    (if (null? tbag)
        #f
        (begin
          (set! stick (car tbag))
          (set-val! self 'bag (cdr tbag))
          stick))))

(defmethod return-two "Chopsticks" (lchop)
  (set-val! self 'bag (append (get-val self 'bag) lchop))
  ((creator 'wait))
  #t)
  
(defmethod return-one "Chopsticks" (chop)
  (set-val! self 'bag (append (get-val self 'bag) chop))
  ((creator 'wait))
  #t)
  
(define *chopsticks* 
   (make-instance "Chopsticks" 
                  (list 'bag  (list chopstick-1 chopstick-2 chopstick-3))  #f))

(define m-set-color
  (lambda(name col)
    (let ((disp-obj '?))
      (cond
        ((equal? name "Parmenides")
         (set! disp-obj ((g-Parmenides 'get-disp))))
        ((equal? name "Plato")
         (set! disp-obj ((g-Plato 'get-disp))))
        ((equal? name "Aristotle")
         (set! disp-obj ((g-Aristotle 'get-disp))))
        ((equal? name "Sokrates")
         (set! disp-obj ((g-Sokrates 'get-disp))))
        ((equal? name "Heraklit")
         (set! disp-obj ((g-Heraklit 'get-disp))))
        (else (*error* "invalid name")))
      ((disp-obj 'set-color) col)
      ((disp-obj 'display)))))

(define m-move
  (lambda(name rname)
    (let ((disp-obj '?))
      (cond
        ((equal? name 'chopstick-1)
         (set! disp-obj ((chopstick-1 'get-disp)))
         (m-dispatch disp-obj 'hide)
         (m-dispatch *castle* 'set-chopstick-1 disp-obj rname)
         (m-dispatch disp-obj 'display)
         ) 
        ((equal? name 'chopstick-2)
         (set! disp-obj ((chopstick-2 'get-disp)))
         (m-dispatch disp-obj 'hide)
         (m-dispatch *castle* 'set-chopstick-2 disp-obj rname)
         (m-dispatch disp-obj 'display)
           ) 
        ((equal? name 'chopstick-3)
         (set! disp-obj ((chopstick-3 'get-disp)))
         (m-dispatch disp-obj 'hide)
         (m-dispatch *castle* 'set-chopstick-3 disp-obj rname)
         (m-dispatch disp-obj 'display))
        (else (*error* "invalid name")))
      )))

(define sim-run
  (lambda(s)
    (let* ((plato (make-instance "Plato"  
                                      '(t-time 0 
                                       e-time 0 
                                       s-time 0
                                       w-time 0
                                       k-time 0
                                       ticks 0
                                       old? #f
                                       room C) #f))
       (aristotle (make-instance "Aristotle" 
                                     '(t-time 0
                                       e-time 0 
                                       s-time 0
                                       w-time 0
                                       k-time 0
                                       ticks 0
                                       old? #f
                                       room F) #f))
       (parmenides (make-instance "Parmenides" 
                                     '(t-time 0 
                                       e-time 0 
                                       s-time 0
                                       w-time 0
                                       k-time 0
                                       ticks 0
                                       old? #f
                                       room A) #f))
       (heraklit (make-instance "Heraklit" 
                                     '(t-time 0 
                                       e-time 0 
                                       s-time 0
                                       w-time 0
                                       k-time 0
                                       ticks 0
                                       old? #f
                                       room G) #f))
       (sokrates (make-instance "Sokrates" 
                                     '(t-time 0 
                                       e-time 0 
                                       s-time 0
                                       w-time 0
                                       k-time 0
                                       ticks 0
                                       old? #f
                                       room H) #f)))
    
  ((creator 'reset-ticks))
  ((creator 'set-speed!) s)
  ((creator 'm-init))
  ((creator 'm-create) plato)
  ((creator 'm-create) aristotle)
  ((creator 'm-create) parmenides)
  ((creator 'm-create) heraklit)
  ((creator 'm-create) sokrates)
  ((creator 'm-dispatch))
)))

(sim-run 0.2)