;;;                        "ontosimula"  (Release 1.0)
;;; A simplified executable model of the principles of "metaphysics"
;;;                    by  George P. Loczewski
;;;                    e-mail: schemer@knuut.de
;;;
;;;                        "dispatcher"
;;;
;;; 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)
;;;
(define creator #t)
(letrec
   ((active? #f)
    (saved-continuation #f)
    (ticks 0)
    (speed 0.2)
    (queue-of-beings '())
    (get-ticks 
      (lambda()
        ticks))
    (reset-ticks 
      (lambda()
        (set! ticks 0)))
    (set-speed! 
      (lambda(val)
        (set! speed val)))
    (wait
      (lambda()
        ;(display "in wait:" )
        ;(newline)
        (if active?
	    (set! active? #f)
	    (error 'wait "nothing active "))
	(if (> ticks 2000)
            (error 'wait "run-time exhausted"))
        (sleep speed)
        (call-with-current-continuation 
	  (lambda (c)
	    (saved-continuation (lambda () (c #f)))))))
     (return
       (lambda (return-value)
         ;(display "in return: " )
         ;(newline)
	 (if active?
	     (set! active? #f)
	     (error 'return "nothing active"))
	 (saved-continuation return-value )))

     (instantiate-act-of-being
       (lambda (thunk)
         ;(display "in instantiate-act-of-being")
         ;(newline)
	 (call-with-current-continuation 
	   (lambda (k)
	     (if active?
	         (error 'act "cannot nest acts"))
	     (set! saved-continuation k)
	     (set! active? #t)
	     (set! ticks (+ 1 ticks))
             (return (thunk))))))
     (wrap-act-of-being
       (lambda (thunk)
         ;(display "in wrap-act-of-being: ")
         ;(newline)
	 (lambda (pause terminate)
	   (let ((return-value (instantiate-act-of-being thunk)))
	        ;(display "behind instantiation of thunk")
                ;(newline)
                (if (procedure? return-value)
		    (pause (wrap-act-of-being return-value))
                    (terminate return-value))))))
     (m-init
       (lambda ()
         (set! queue-of-beings '())))

     (dispatch-time
       (lambda (b-queue)
         ;(display "in dispatch-time")
         ;(newline)
         (if (null? b-queue)
             (begin
               (display "end-of-time")
               (newline)
               '())
             ((car b-queue) 
	        (lambda (act)
	          (dispatch-time (append (cdr b-queue) (list act))))
                (lambda (name)
	          ;(display name)
	          ;(display ": normal termination")
                  ;(newline)
                  (dispatch-time (cdr b-queue)))))))
     (m-create-being
       (lambda (object)
         ;(display "in m-create-being")
         ;(newline)
         (set! queue-of-beings 
               (append queue-of-beings
                       (list (wrap-act-of-being  
                               (lambda() 
                                 (sm object 'act-of-being))))))))
     (self
       (lambda(msg)
         ;(display "in message handler")
         ;(newline)
         (cond
           ((equal? msg 'm-init) m-init)
           ((equal? msg 'm-dispatch) 
              (lambda () (dispatch-time queue-of-beings)))
            ((equal? msg 'm-create) m-create-being)
            ((equal? msg 'get-ticks) get-ticks)
            ((equal? msg 'reset-ticks) reset-ticks)
            ((equal? msg 'set-speed!) set-speed!)
            ((equal? msg 'wait) wait)
            ((equal? msg 'return) return)))))
     (set! creator self))