private/simulation-control.ss
;;; PLT Scheme Simulation Collection
;;; simulation-control.ss
;;; Copyright (c) 2004 M. Douglas Williams
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
;;; License as published by the Free Software Foundation; either
;;; version 2.1 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free
;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
;;; 02111-1307 USA.
;;;
;;; -------------------------------------------------------------------
;;;
;;; This moduce implements the simulation control routines.
;;;
;;; Note that currently only the future event list is used for
;;; scheduling events.
;;;
;;; Version  Date      Description
;;; 0.1.0    10/16/04  Initial implementation of the simulation control
;;;                    routines.  (Doug Williams)
;;; 0.1.1    03/15/05  Added interrupt and resume routines (Doug
;;;                    Williams)
;;; 0.1.2    07/12/05  Added continuous simulation. (Doug Williams)
;;; 0.1.3    07/23/05  Added hierarchical control.

;;; schedule macro
;;; Schedule a process or event for execution in the specified
;;; simulation environment.
(define-syntax schedule
  (syntax-rules (continuous now at in)
    ((schedule continuous (function . arguments) simulation-environment)
     (schedule 'continuous (function . arguments) simulation-environment))
    ((schedule now (function . arguments) simulation-environment)
     (schedule 'now (function . arguments) simulation-environment))
    ((schedule (at time) (function . arguments) simulation-environment)
     (schedule time (function . arguments) simulation-environment))
    ((schedule (in delay) (function . arguments) simulation-environment)
     (schedule (+ delay (current-simulation-time))
               (function . arguments) simulation-environment))
    ((schedule time (function . arguments) simulation-environment)
     (if (process-name? 'function)
         (let ((process (make-process 'function (list . arguments))))
           (schedule-event (process-event process) time
                           simulation-environment)
           process)
         (make-and-schedule-event time #f function (list . arguments)
                                  simulation-environment)))
    ((schedule time-spec (function . arguments))
     (schedule time-spec (function . arguments)
               (current-simulation-environment)))))

;;; schedule-event: event x time x simulation-environment -> void
;;; schedule-event: event x time -> void
;;; schedule-event: event -> void
;;; Schedule an event for execution in the specified simulation
;;; environment.
(define schedule-event
  (case-lambda
    ((event time simulation-environment)
     (cond ((eq? time 'continuous)
            (set-event-time!
             event
             (simulation-environment-time
              simulation-environment))
            (event-list-add!
             (simulation-environment-continuous-event-list
              simulation-environment)
             event))
           ((eq? time 'now)
            (set-event-time!
             event
             (simulation-environment-time
              simulation-environment))
            (event-list-add!
             (simulation-environment-now-event-list
              simulation-environment)
             event))
           (else
            (set-event-time! event time)
            (event-list-add!
             (simulation-environment-future-event-list
              simulation-environment)
             event))))
    ((event time)
     (schedule-event event time (current-simulation-environment)))
    ((event)
     (event-list-add! (current-simulation-future-event-list) event))))

;;; make-and-schedule-event:
;;;   real x process x procedure x list -> void
;;; Create and schedule an event.  This is just a shortcut for the two
;;; operations.
(define (make-and-schedule-event time process function arguments
                                 simulation-environment)
  (schedule-event
   (make-event 0.0 process function arguments)
   time
   simulation-environment))

;;; start-simulation
;;; Start the simulation main loop.  Exits when there are no more
;;; events to execute or when some routine explicitly calls the
;;; loop-exit continuation.
(define (start-simulation)
  (let ((simulation-environment (current-simulation-environment)))
    (let/cc exit
      ;; Save the main-loop exit continuation
      (set-simulation-environment-loop-exit!
       simulation-environment exit)
      ;; Simulation main loop
      (let main-loop ()
        ;; Update the simulation state
        (let/cc next
          ;; Save the main-loop next continuation
          (set-simulation-environment-loop-next!
           simulation-environment next)
          ;; Determine the next event and how to advance the time
          ;; (discretely or continuously), if necessary.
          (if (not (event-list-empty?
                    (simulation-environment-now-event-list
                     simulation-environment)))
              ;; Execute the next now event
              (let ((event (event-list-pop!
                            (simulation-environment-now-event-list
                             simulation-environment))))
                (execute-discrete-event simulation-environment event))
              ;; Now event list is empty
              (if (not (event-list-empty?
                        (simulation-environment-future-event-list
                         simulation-environment)))
                  ;; The future event list is not empty
                  (let ((event (car (event-list-events
                                     (simulation-environment-future-event-list
                                      simulation-environment)))))
                    (if (and (not (event-list-empty?
                                   (simulation-environment-continuous-event-list
                                    simulation-environment)))
                             (< (simulation-environment-time
                                 simulation-environment)
                                (event-time event)))
                        ;; There are continuous events and we are not
                        ;; at the new time, so advance time continuously
                        (execute-continuous-events
                         simulation-environment (event-time event))
                        ;; Otherwise, advance the time and execute the event
                        (begin
                          (set! event
                                (event-list-pop!
                                 (simulation-environment-future-event-list
                                  simulation-environment)))
                          (set-simulation-environment-time!
                           simulation-environment (event-time event))
                          (execute-discrete-event
                           simulation-environment event))))
                  ;; The future event list is empty
                  (if (not (event-list-empty?
                            (simulation-environment-continuous-event-list
                             simulation-environment)))
                      ;; There are continuous events so advance time
                      ;; to infinity.  (Hopefully, some of the cont-
                      ;; inuous events have termination conditions.
                      ;; Otherwise, the simulation will never end.)
                      (execute-continuous-events
                       simulation-environment +inf.0)
                      ;; Otherwise, there is nothing left to do.
                      (exit)))))
        (main-loop)))
    ;; Reset simulation environment
    (current-simulation-event #f)
    (current-simulation-process #f)
    (current-simulation-loop-next #f)
    (current-simulation-loop-next #f)))

;;; execute-discrete-event: simulation-environment x event -> void
;;; Execute the given event in the given simulation environment.
(define (execute-discrete-event simulation-environment event)
  (let ((process (event-process event)))
    (set-simulation-environment-event!
     simulation-environment event)
    (set-simulation-environment-process!
     simulation-environment process)
    (if process
        (set-process-state! process PROCESS-ACTIVE))
    (apply (event-function event)
           (event-arguments event))
    ;; If we returned here, then the process/event terminated
    ;; Change the process state to terminated
    (if process
        (set-process-state! process PROCESS-TERMINATED))))

;;; execute-continuous-events: simulation-environment x real -> void
;;; Execute the continuous events in the given environment advancing
;;; time to the given time.
(define (execute-continuous-events simulation-environment time-end)
  (if (simulation-environment-state-changed?
       simulation-environment)
      (continuous-initialize simulation-environment))
  (let* ((step (simulation-environment-step simulation-environment))
         (control (simulation-environment-control simulation-environment))
         (evolve (simulation-environment-evolve simulation-environment))
         (system (simulation-environment-system simulation-environment))
         (t (box (simulation-environment-time simulation-environment)))
         (h (box (simulation-environment-step-size simulation-environment)))
         (y (make-vector
             (simulation-environment-dimension simulation-environment)
             0.0))
         (save-step-size (simulation-environment-step-size
                          simulation-environment)))
    (set-state-vector-values! simulation-environment y)
    (ode-evolve-reset evolve)
    (let loop ()
      (if (< (unbox t) time-end)
          (let ((terminating-events '())
                (save-y (simulation-environment-y
                         simulation-environment)))
            ;; Check terminating conditions
            (set-simulation-environment-y!
             simulation-environment y)
            (let event-loop 
                 ((events (event-list-events
                           (simulation-environment-continuous-event-list
                            simulation-environment))))
              (if (not (null? events))
                  (let* ((event (car events))
                         (process (event-process event)))
                    (if (and (process-terminating-condition process)
                             ((process-terminating-condition process)))
                        (set! terminating-events
                              (cons event terminating-events)))
                    (event-loop (cdr events)))))
            (set-simulation-environment-y!
             simulation-environment save-y)
            ;; Are there any terminating events?
            (if (not (null? terminating-events))
                ;; Yes, remove them from the continuous event list
                ;; and exit.
                (let event-loop ((events terminating-events))
                  (if (not (null? events))
                      (let* ((event (car events))
                             (process (event-process event)))
                        (event-list-remove!
                         (simulation-environment-continuous-event-list
                          simulation-environment)
                         event)
                        (let variable-loop
                             ((variables (process-continuous-variables
                                       process)))
                          (if (not (null? variables))
                              (let ((variable (car variables)))
                                (set-variable-state-index! variable -1)
                                (variable-loop (cdr variables)))))
                        (schedule-event event 'now)
                        (set-simulation-environment-state-changed?!
                         simulation-environment #t)
                        (event-loop (cdr events)))))
                ;; No, evolve the system through another time step.
                (begin
                  (ode-evolve-apply
                   evolve control step system
                   t time-end h y)
                  (set-box!
                   h
                   (min (unbox h)
                        (simulation-environment-max-step-size
                         simulation-environment)))
                  (set-simulation-environment-time!
                   simulation-environment (unbox t))
                  (if (simulation-environment-control
                       simulation-environment)
                      (set-simulation-environment-step-size!
                       simulation-environment (unbox h)))
                  (set-variable-values! simulation-environment y)
                  (loop))))))
    (set-simulation-environment-step-size!
     simulation-environment save-step-size)))

(define (continuous-eval t y dydt params)
  (let ((save-time (current-simulation-time))
        (save-y (current-simulation-y))
        (save-dydt (current-simulation-dydt)))
    ;; Set the state variables in the simulation environment
    (current-simulation-time t)
    (current-simulation-y y)
    (current-simulation-dydt dydt)
    ;; Execute the process differentiation functions
    (let loop ((events (event-list-events
                        (current-simulation-continuous-event-list))))
      (if (not (null? events))
          (let* ((event (car events))
                 (process (event-process event)))
            ((process-differentiation-function process))
            (loop (cdr events)))))
    ;; Resore the saved fields
    (current-simulation-time save-time)
    (current-simulation-y save-y)
    (current-simulation-dydt save-dydt)))

;;; continuous-initialize
(define (continuous-initialize simulation-environment)
  (let ((dimension 0))
    ;; Determine the dimension of the system of equations and allocate
    ;; the indices.
    (let event-loop
         ((events
           (event-list-events
            (simulation-environment-continuous-event-list
             simulation-environment))))
      (if (not (null? events))
          (let* ((event (car events))
                 (process (event-process event)))
            (let variable-loop
                 ((variables
                   (process-continuous-variables
                    process)))
              (if (not (null? variables))
                  (let ((variable (car variables))
                        (index dimension))
                    (set-variable-state-index!
                     variable index)
                    (set! dimension (+ 1 dimension))
                    (variable-loop (cdr variables)))))
            (event-loop (cdr events)))))
    (set-simulation-environment-dimension!
     simulation-environment dimension)
    ;; Create ode-system object
    (set-simulation-environment-system!
     simulation-environment
     (make-ode-system
      continuous-eval #f dimension '()))
    ;; Create ode-step object
    (set-simulation-environment-step!
     simulation-environment
     (make-ode-step
      (simulation-environment-step-type simulation-environment)
      dimension))
    ;; The ode-control object should already exist
    ;; Create ode-evolve object
    (set-simulation-environment-evolve!
     simulation-environment
     (make-ode-evolve dimension))
    ;; Reset the state-changed? flag
    (set-simulation-environment-state-changed?!
     simulation-environment #f)))
     
;;; set-variable-values!: simulation-environment x (vectorof real) -> void
(define (set-variable-values! simulation-environment state-vector)
  (let event-loop
      ((events (event-list-events
                (simulation-environment-continuous-event-list
                 simulation-environment))))
    (if (not (null? events))
        (let* ((event (car events))
               (process (event-process event)))
          (let variable-loop
               ((variables (process-continuous-variables
                            process)))
            (if (not (null? variables))
                (let ((variable (car variables)))
                  (set-variable-value!
                   variable
                   (vector-ref
                    state-vector 
                    (variable-state-index variable)))
                  (variable-loop (cdr variables)))))
          (event-loop (cdr events))))))

;;; set-state-vector-values!: simulation-environment x (vectorof real) -> void
(define (set-state-vector-values! simulation-environment state-vector)
  (let event-loop
      ((events (event-list-events
                (simulation-environment-continuous-event-list
                 simulation-environment))))
    (if (not (null? events))
        (let* ((event (car events))
               (process (event-process event)))
          (let variable-loop
               ((variables (process-continuous-variables
                            process)))
            (if (not (null? variables))
                (let ((variable (car variables)))
                  (vector-set!
                   state-vector (variable-state-index variable)
                   (variable-field-ref variable 1))
                  (variable-loop (cdr variables)))))
          (event-loop (cdr events))))))

;;; stop-simulation:
(define (stop-simulation)
  ((current-simulation-loop-exit)))

;;; wait/work: real -> void
;;; Delays the execution of the process or event for the specified
;;; length of time.
(define (wait/work delay)
  (let/cc continue
    ;; Reuse the current event
    (let ((event (current-simulation-event)))
      (set-event-time! event (+ (current-simulation-time) delay))
      (set-event-function! event continue)
      (set-event-arguments! event '())
      ;; Change the process state to waiting/working
      (if (event-process event)
          (set-process-state! (event-process event) PROCESS-WAITING/WORKING))
      (schedule-event event))
    ;; Done with this event
    (current-simulation-event #f)
    ;; Return to main loop
    ((current-simulation-loop-next))))

(define wait wait/work)
(define work wait/work)

;;; work/continuously
(define-syntax work/continuously
  (syntax-rules (until)
    ((work/continuously
      until condition
      body ...)
     (let/cc continue
       (let ((process (current-simulation-process))
             (event (current-simulation-event)))
         ;; Set up process for working continuously
         (set-process-terminating-condition!
          process
          (lambda () condition))
         (set-process-differentiation-function!
          process
          (lambda () body ...))
         (set-process-state! process PROCESS-WORKING-CONTINUOUSLY)
         ;; Set up event
         (set-event-function! event continue)
         (set-event-arguments! event '())
         (schedule-event event 'continuous))
       ;; Done with this event
       (current-simulation-event #f)
       ;; Mark state as being changed
       (current-simulation-state-changed? #t)
       ;; Return to the main loop
       ((current-simulation-loop-next))))
    ((work/continuously
      body ...)
     (work/continuously
      until #f
      body ...))))

;;; suspend-process: -> void
;;; Suspend the execution of the current process.
(define (suspend-process)
  (let/cc continue
    ;; Reuse the current event
    (let ((process (current-simulation-process))
          (event (current-simulation-event)))
      (set-event-time! event 0.0)
      (set-event-function! event continue)
      (set-event-arguments! event '())
      (set-process-state! process PROCESS-SUSPENDED))
    ;; Done with the event
    (current-simulation-event #f)
    ((current-simulation-loop-next))))

;;; interrupt-process: process -> void
;;; Interrupt the execution of a waiting process.
(define (interrupt-process process)
  (let ((event (process-event process)))
    (event-list-remove!
     (current-simulation-future-event-list) event)
    (set-event-time! event (- (event-time event) (current-simulation-time)))
    (set-process-state! process PROCESS-INTERRUPTED)))

;;; resume-process: process -> void
;;; Resume the execution of a suspended or interrupted process.
(define (resume-process process)
  (let ((event (process-event process)))
    (schedule-event event (+ (current-simulation-time)
                             (event-time event)))))