(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)))))
(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))))
(define (make-and-schedule-event time process function arguments
simulation-environment)
(schedule-event
(make-event 0.0 process function arguments)
time
simulation-environment))
(define (start-simulation)
(let ((simulation-environment (current-simulation-environment)))
(let/cc exit
(set-simulation-environment-loop-exit!
simulation-environment exit)
(let main-loop ()
(let/cc next
(set-simulation-environment-loop-next!
simulation-environment next)
(if (not (event-list-empty?
(simulation-environment-now-event-list
simulation-environment)))
(let ((event (event-list-pop!
(simulation-environment-now-event-list
simulation-environment))))
(execute-discrete-event simulation-environment event))
(if (not (event-list-empty?
(simulation-environment-future-event-list
simulation-environment)))
(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)))
(execute-continuous-events
simulation-environment (event-time 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))))
(if (not (event-list-empty?
(simulation-environment-continuous-event-list
simulation-environment)))
(execute-continuous-events
simulation-environment +inf.0)
(exit)))))
(main-loop)))
(current-simulation-event #f)
(current-simulation-process #f)
(current-simulation-loop-next #f)
(current-simulation-loop-next #f)))
(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 process
(set-process-state! process PROCESS-TERMINATED))))
(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)))
(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)
(if (not (null? terminating-events))
(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)))))
(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)))
(current-simulation-time t)
(current-simulation-y y)
(current-simulation-dydt dydt)
(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)))))
(current-simulation-time save-time)
(current-simulation-y save-y)
(current-simulation-dydt save-dydt)))
(define (continuous-initialize simulation-environment)
(let ((dimension 0))
(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)
(set-simulation-environment-system!
simulation-environment
(make-ode-system
continuous-eval #f dimension '()))
(set-simulation-environment-step!
simulation-environment
(make-ode-step
(simulation-environment-step-type simulation-environment)
dimension))
(set-simulation-environment-evolve!
simulation-environment
(make-ode-evolve dimension))
(set-simulation-environment-state-changed?!
simulation-environment #f)))
(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))))))
(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))))))
(define (stop-simulation)
((current-simulation-loop-exit)))
(define (wait/work delay)
(let/cc continue
(let ((event (current-simulation-event)))
(set-event-time! event (+ (current-simulation-time) delay))
(set-event-function! event continue)
(set-event-arguments! event '())
(if (event-process event)
(set-process-state! (event-process event) PROCESS-WAITING/WORKING))
(schedule-event event))
(current-simulation-event #f)
((current-simulation-loop-next))))
(define wait wait/work)
(define work wait/work)
(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-process-terminating-condition!
process
(lambda () condition))
(set-process-differentiation-function!
process
(lambda () body ...))
(set-process-state! process PROCESS-WORKING-CONTINUOUSLY)
(set-event-function! event continue)
(set-event-arguments! event '())
(schedule-event event 'continuous))
(current-simulation-event #f)
(current-simulation-state-changed? #t)
((current-simulation-loop-next))))
((work/continuously
body ...)
(work/continuously
until #f
body ...))))
(define (suspend-process)
(let/cc continue
(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))
(current-simulation-event #f)
((current-simulation-loop-next))))
(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)))
(define (resume-process process)
(let ((event (process-event process)))
(schedule-event event (+ (current-simulation-time)
(event-time event)))))