#lang racket/base
;;; Racket Simulation Collection
;;; environment.rkt
;;; Copyright (c) 2004-2011 M. Douglas Williams
;;;
;;; This file is part of the Racket Simulation Collection.
;;;
;;; The Racket Simulation Collection 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 3 of the License,
;;; or (at your option) any later version.
;;;
;;; The Racket Simulation Collection 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 the Racket Simulation Collection.  If not, see
;;; <http://www.gnu.org/licenses/>.
;;;
;;; -----------------------------------------------------------------------------
;;;
;;; This module implements the simulation run-time environment.
;;;
;;; Version  Date      Description
;;; 0.1.0    10/16/04  Initial implementation of simulation environments. (MDW)
;;; 0.1.1    06/16/05  Added parent and children slots. (MDW)
;;; 0.1.2    07/11/05  Added continuous simulation. (MDW)
;;; 1.0.0    11/20/07  Removed old macro forms of current simulation  shortcuts
;;;                    (in favor of functional ones). (MDW)
;;; 3.0.0    06/24/08  Updated for V4.0. (MDW)
;;; 3.0.1    11/27/08  Converted to a module. (MDW)
;;; 4.0.0    08/15/10  Converted to Racket. (MDW)
;;; 4.0.1    02/10/11  Combined all of the run-time structures into the
;;;                    environment.rkt file to facilitate automatic data
;;;                    collection of internal structure (e.g., event lists).
;;;                    (MDW)

;;; The simulation environment requires the ordinary differential equation solver
;;; from the science collection. This is used to define the information needed
;;; for continuous simulations.

(require racket/mpair
         (planet williams/science/ode-initval)
         "statistics.rkt"
         "history.rkt")

;;; -----------------------------------------------------------------------------
;;; 1. Events and Event Lists

;;; 1.1 Events

;;; An event represent the future application of a function to its arguments. An
;;; event has the following fields:
;;;   time - the simulated time that the event is to occur. Earlier events occur
;;;          before later ones.
;;;   priority - the priority of the event. For events that are to occur at the
;;;              same simulated time, higher priority events occur before lower
;;;              priority ones. The default priority is 0.
;;;   process - the process owning the event or #f if the event is not associated
;;;             with a process.
;;;   function - the event function or #f.
;;;   arguments - the arguments for the event function. This should be '() if
;;;               the event function is #f.
;;;   event-list - the event list where the event is queued or #f if the event is
;;;                not currently queued. Note that an event can be queued in at
;;;                most one event list.
;;;   linked-event-list - an event list holding other events linked to the event
;;;                       or #f if no other events have been linked to the event.
;;;
;;; An event is not (directly) associated with any specific simulation
;;; environment. There may be an implicit association via an event list (when the
;;; event is queued).

;;; (struct event (time
;;;                priority
;;;                process
;;;                function
;;;                arguments
;;;                event-list
;;;                linked-event-list)
;;;        #:mutable)
;;;   time : (>=/c 0.0)
;;;   priority : real?
;;;   process : (or/c false/c process?)
;;;   function : (or/c procedure? false/c)
;;;   arguments : list?
;;;   event-list? : (or/c false/c event-list?)
;;;   linked-event-list : (or/c false/c event-list?)
(struct event (time
               priority
               process
               function
               arguments
               event-list
               linked-event-list)
  #:mutable
  #:property prop:procedure
  (lambda (event)
    (apply (event-function event) (event-arguments event))))

;;; (make-event time priority process function arguments) -> event?
;;;   time : (>=/c 0.0)
;;;   priority : real?
;;;   process : (or/c false/c process?)
;;;   function : (or/c procedure? #f)
;;;   arguments : list?
;;; Returns a new event with the specified time, priority, process, function, and
;;; argument fields. The event-list field is initialized to #f (i.e., the event
;;; is not queued in any event list) and the linked-event-list-field is initial-
;;; ized to #f (there are no other events linked to the event).
(define (make-event time priority process function arguments)
  (event time priority process function arguments #f #f))

;;; (event<=? event-1 event-2 [#:priority-only? priority-only?]) -> boolean?
;;;   event-1 : event?
;;;   event-2 : event?
;;;   priority-only? : boolean? = #f
;;; Returns #t if event-1 occurs before event-2. If prioirity-only? is #t, only
;;; the event priorities are used - events with higher priority occur before
;;; events with lower priorities. Otherwise, the event time and priority are
;;; used.
(define (event<=? event-1 event-2 #:priority-only? (priority-only? #f))
  (if priority-only?
      (> (event-priority event-1)
         (event-priority event-2))
      (or (< (event-time event-1)
             (event-time event-2))
          (and (= (event-time event-1)
                  (event-time event-2))
               (> (event-priority event-1)
                  (event-priority event-2))))))

;;; 1.2 Event Lists

;;; An event list is an ordered list of queued events. Generally, an event list
;;; is maintained in in order by ascending time fields (i.e., earlier events
;;; occur before later ones) and, for events with equal time fields, by
;;; decreasing priority fields (i.e., higher priority events occur before lower
;;; priority ones). [This is implemented by the event<=? function.) However, if
;;; the priority-only? flag is #t, only the priority field is used.
;;;
;;; If the event-list is associated with an environment - meaning that timing
;;; information is available, the length of the queue is instrumented by the
;;; variable-n field. This allows automatic data collection - statistics and
;;; history - on the length of the queue.
;;;
;;; Currently, the event list just encapsulates a simple mutable list of events.
;;; This is very inefficient, i.e., O(N) for all operations. We should look at a
;;; skip list implementation at some point.

;;; (struct event-list (environment
;;;                     events))
;;;   environment : (or/c simulation-environment? false/c)
;;;   variable-n : (or/c variable? false/c)
;;;   events : (mlistof event?)
(struct event-list
  (priority-only?
   environment
   variable-n
   events)
  #:mutable)

;;; (make-event-list [environment]) -> event-list?
;;;   environment : (or/c simulation-environment? false/c)
;;; Returns a new, empty event list. If environment is not #f, the event list is
;;; associated with the environment and the queue length is maintained and
;;; instrumented. [Since event lists are used to implement the queues for inter-
;;; process communications, this can be very useful.]
(define (make-event-list (environment #f) #:priority-only? (priority-only? #f))
  (event-list priority-only?
              environment
              (if environment
                  (make-variable 0 #:environment environment)
                  #f)
              '()))

;;; (event-list-empty? event-list) -> boolean?
;;;   event-list : event-list?
;;; Returns #t if event-list is empty.
(define (event-list-empty? event-list)
  (null? (event-list-events event-list)))

;;; (event-list-add! event-list event) -> void?
;;;   event-list : event-list?
;;;   event : event?
;;; Adds event to event-list.
(define (event-list-add! event-list event)
  (let ((events (event-list-events event-list))
        (previous #f))
    (let loop ()
      (unless (or (null? events)
                  (event<=? event (mcar events)
                            #:priority-only?
                            (event-list-priority-only? event-list)))
        (set! previous events)
        (set! events (mcdr events))
        (loop)))
    (if previous
        (set-mcdr! previous (mcons event events))
        (set-event-list-events! event-list (mcons event events)))
    (let ((variable-n (event-list-variable-n event-list)))
      (when variable-n
        (set-variable-value! variable-n (+ (variable-value variable-n) 1))))
    (set-event-event-list! event event-list)))

;;; (event-list-remove! event-list event) -> void?
;;;   event-list : event-list?
;;;   event : event?
;;; (event-list-remove! event) -> void?
;;;   event : event?
;;; Removes event from event-list.
(define event-list-remove!
  (case-lambda
    ((event-list event)
     (let loop ((previous #f)
                (events (event-list-events event-list)))
       (when (not (null? events))
         (if (eq? event (mcar events))
             (begin
               (if previous
                   (set-mcdr! previous (mcdr events))
                   (set-event-list-events!
                    event-list (mcdr events)))     
               (let ((variable-n (event-list-variable-n event-list)))
                 (when variable-n
                   (set-variable-value! variable-n (- (variable-value variable-n) 1))))
               (set-event-event-list! event #f))
             (loop events (mcdr events))))))
    ((event)
     (when (event-event-list event)
       (event-list-remove! (event-event-list event) event)))))

;;; (event-list-pop! event-list) -> event?
;;;   event-list : event-list?
;;; Remove and return the next event from event-list.
(define (event-list-pop! event-list)
  (let* ((events (event-list-events event-list))
         (event (mcar events)))
    (set-event-list-events! event-list (mcdr events))
    (let ((variable-n (event-list-variable-n event-list)))
      (when variable-n
        (set-variable-value! variable-n (- (variable-value variable-n) 1))))
    (set-event-event-list! event #f)
    event))

;;; -----------------------------------------------------------------------------

;;; 2. Processes and Process Types

;;; A process is a simulation entity that has state, exists through simulated
;;; time, and can interact (in a controlled way) with other processes (or other
;;; simulation elements). A process sits atop an underlying event. The event
;;; maintains the computational state of the process (via a continuation). The
;;; process itself maintains the simulation state and information requires to
;;; interact with other simulation elements.

;;; 2.1 Process State

;;; The simulation state of a process captures the state of the process from the
;;; perspective of the simulation engine. The simulation states are:

;;;  Index  State
;;;   -1    terminated - the process computation has completed.
;;;    0    created - the process has been created, but has not begun its
;;;                   computation.
;;;    1    active - the process computation is running.
;;;    2    waiting/working - the process computation is waiting or working.
;;;    3    working/continuously - the process is working as a continuous
;;;                                simulation model.
;;;    4    delayed - the process is delayed.
;;;    5    interrupted - the process has been interrupted by another process.
;;;    6    suspended - the process has suspended itself.
(define PROCESS-TERMINATED -1)
(define PROCESS-CREATED 0)
(define PROCESS-ACTIVE 1)
(define PROCESS-WAITING/WORKING 2)
(define PROCESS-WORKING-CONTINUOUSLY 3)
(define PROCESS-DELAYED 4)
(define PROCESS-INTERRUPTED 5)
(define PROCESS-SUSPENDED 6)

;;; 2.2 Process Types

;;; (struct process-type-info (name
;;;                            super-info
;;;                            parameters
;;;                            inits
;;;                            make)
;;; Contains the information needed to create process instances of the corres-
;;; ponding process type.
(struct process-type-info (name
                           super-info
                           parameters
                           inits
                           make))

;;; (struct process-info (name
;;;                       type
;;;                       body))
;;;   name : symbol?
;;;   type : process-type-info?
;;;   body : procedure?
;;; Contains the information needed to instantiate a process instance.
(struct process-info (name
                      type
                      body))

;;; (process-info-make process-info) -> procedure?
;;;   process-info : (or/c process-info? false/c)
;;; Returns the make procedure for the process-type structure type of process-
;;; info. The make procedure for the process structure type is returned if
;;; process-type is #f.
(define (process-info-make process-info)
  (if (not (process-info-type process-info))
      process
      (process-type-info-make (process-info-type process-info))))

;;; (process-info-inits process-info) -> list?
;;;   process-info : (or/c process-info? false/c)
;;; Returns the initial values for the fields of the process-type structure type
;;; of process-info. The empty list is returned if process-type is #f.
(define (process-info-inits process-info)
  (if (not (process-info-type process-info))
      '()
      (process-type-info-inits (process-info-type process-info))))

;;; 2.3 Processes

;;; (struct process (process-info
;;;                  event
;;;                  state
;;;                  monitor
;;;                  continuous-variables
;;;                  terminating-condition
;;;                  differentiation-function
;;;                  queue
;;;                  acceptors)
;;;   #:mutable)
;;;   process-info : (or/c process-info? false/c)
;;;   event : event?
;;;   state : exact-integer?
;;;   monitor : (or/c procedure? false/c)
;;;   continuous-variables : (list-of variable?)
;;;   differentiation-function : (or/c procedure? false/c)
;;;   queue : event-list?
;;;   acceptors : list?
;;; Represents a process instance. Process is the root of the process type tree.
(struct process (process-info
                 event
                 state
                 monitor
                 continuous-variables
                 terminating-condition
                 differentiation-function
                 queue
                 acceptors)
  #:mutable)

;;; (process-name process) -> string?
;;;   process : process?
;;; Shortcut function to return the process name of a process instance from
;;; the process definition.
(define (process-name process)
  (process-info-name (process-info process)))

;;; (process-time process) -> (>=/c 0.0)
;;; Shortcut function to return the time the process will be reactivated.  This
;;; is only valid if the process is in the PROCESS-WAITING/WORKING state.
(define (process-time process)
  (event-time (process-event process)))

;;; (set-process-time! process time) -> void?
;;;   process : process?
;;;   time : (>=/c 0.0)
;;; Shortcut function to set the time the process will be reactivated.  This
;;; is only valid if the process is in the PROCESS-WAITING/WORKING state.
(define (set-process-time! process time)
  (set-event-time! (process-event process) time))

;;; make-process: symbol x list -> process
;;; Create and return a process instance.
(define (make-process process-info arguments)
  (let* ((event (make-event
                 +inf.0
                 0
                 #f
                 (process-info-body process-info)
                 arguments))
         (process (apply
                   (process-info-make process-info)
                   process-info         ; process information structure
                   event                ; event
                   PROCESS-CREATED      ; state - created
                   #f                   ; monitor
                   '()                  ; continuous-variables
                   #f                   ; terminating-condition
                   #f                   ; differentiation-function
                   (make-event-list (current-simulation-environment)
                                    #:priority-only? #t)
                                        ; queue
                   '()                  ; acceptors
                   (process-info-inits process-info))))
    ;; Set the event process.
    (set-event-process! event process)
    ;; Return the process info.
    process))

(define (process-queue-variable-n process)
  (event-list-variable-n (process-queue process)))

;;; -----------------------------------------------------------------------------
;;; 3. Variables

;;; A variable stores a numeric value or vector of values. It automatically
;;; collects statistics or a history of the values of the variable as requested.

;;; (struct variable (initial-value
;;;                   current-value
;;;                   time-last-synchronized
;;;                   statistics
;;;                   history
;;;                   continuous?
;;;                   state-index
;;;                   get-monitors
;;;                   set-monitors)
;;;         #:mutable)
;;;   initial-value : (or/c real? 'uninitialized)
;;;   value : (or/c real? 'uninitialized)
;;;   time-last-synchronized : real?
;;;   statistics : (or/c statistics? false/c)
;;;   history : (or/c history? false/c)
;;;   continuous : boolean?
;;;   state-index : exact-integer?
;;;   get-monitors : list?
;;;   set-monitors : list?
(struct variable (environment
                  initial-value
                  current-value
                  time-last-synchronized
                  statistics
                  history
                  continuous?
                  state-index
                  get-monitors
                  set-monitors)
  #:mutable)

;;; (make-variable [initial-value]) -> variable?
;;;   initial-value : (or/c real? 'uninitialized) = 'uninitialized
;;; Returns a new variable with the apecified initial-value. If no initial-value
;;; is specified, the variable is uninitialized. The variable automatically
;;; collects statistics on its values.
(define (make-variable (initial-value 'uninitialized)
                       #:environment (environment (current-simulation-environment)))
  (variable environment
            initial-value
            initial-value
            (simulation-environment-time environment)
            (make-statistics #t (simulation-environment-time environment))
            #f
            #f
            -1
            '()
            '()))

;;; (make-continuous-variable [initial-value]) -> variable?
;;;   initial-value : (or/c real? 'uninitialized) = 'uninitialized
;;; (make-continuous-variable) -> variable?
;;; Returns a new continuous variable with the specified initial-value. Of no
;;; initial-value is specified, the variable is uninitialized. The continuous
;;; variable does not automatically collect statistics on its values.
(define (make-continuous-variable (initial-value 'uninitialized)
                                  #:environment (environment (current-simulation-environment)))
  (let ((process (current-simulation-process))
        (cv (variable environment
                      initial-value
                      initial-value
                      (simulation-environment-time environment)
                      #f
                      #f
                      #t
                      -1
                      '()
                      '())))
    ;; Add variable to list of process continuous variables
    (set-process-continuous-variables!
     process
     (cons cv (process-continuous-variables process)))
    cv))

;;; (variable-value variable) -> (or/c 'uninitialized real? (vector-of real?))
;;;   variable : variable?
;;; Return the value of variable. An error is raised is the variable is
;;; uninitialized. If the variable is a continuous variable, the value is
;;; retrieved from the state vector.
(define (variable-value variable)
  (let ((environment (variable-environment variable))
        (value #f))
    ;; Run before monitors.
    (for-each
     (lambda (monitor)
       (when (eq? (car monitor) 'before)
         ((cdr monitor) variable value)))
     (variable-get-monitors variable))
    ;; Get the variable value.
    (when (eq? (variable-current-value variable) 'uninitialized)
      (error 'variable-value "Attempt to reference an uninitialized variable"))
    (if (and (not (= (variable-state-index variable) -1))
             (simulation-environment-y environment))
        ;; Get the value from the state vector.
        (set! value (vector-ref
                    (simulation-environment-y environment)
                    (variable-state-index variable)))
        ;; Use the stored value.
        (set! value (variable-current-value variable)))
    ;; Run after monitors.
    (for-each
     (lambda (monitor)
       (when (eq? (car monitor) 'after)
         ((cdr monitor variable value))))
     (variable-get-monitors variable))
    ;; Return the value.
    value))

;;; (set-variable-value! variable value) -> void?
;;;   variable : variable?
;;;   value : (or/c 'uninitialized real? (vector-of real?))
;;; Set the value of variable to value. If the variable is a continuous variable,
;;; the value is stored in the state vector. This is a synchronization point for
;;; the variable.
(define (set-variable-value! variable value)
  ;; Run before monitors.
  (for-each
   (lambda (monitor)
     (when (eq? (car monitor) 'before)
       ((cdr monitor) variable value)))
   (variable-set-monitors variable))
  ;; Accumulate previous value (synchronize).
  (variable-synchronize! variable)
  ;; Set the new value.
  (set-variable-current-value! variable value)
  ;; Tally new value (statistics and history).
  (when (and (variable-statistics variable)
             (not (statistics-time-dependant?
                   (variable-statistics variable))))
    (statistics-tally! (variable-statistics variable) value))
  (when (and (variable-history variable)
             (not (history-time-dependant?
                   (variable-history variable))))
    (history-tally! (variable-history variable) value))
  ;; Run after monitors.
  (for-each
   (lambda (monitor)
     (when (eq? (car monitor) 'after)
       ((cdr monitor) variable value)))
   (variable-set-monitors variable))
  (void))

;;; (variable-dt variable) -> real?
;;;   variable : variable?
;;; Returns the derivative of variable. An error is raised if there is no current
;;; work/continuous using the variable.
(define (variable-dt variable)
  (let ((environment (variable-environment variable)))
    (if (and (not (= (variable-state-index variable) -1))
             (simulation-environment-dydt environment))
        (vector-ref
         (simulation-environment-dydt environment)
         (variable-state-index variable))
        (error 'variable-dt
               "There is no active work/continuously using the variable"))))

;;; (set-variable-dt! variable value) -> void?
;;;   variable : variable?
;;;   value : real?
;;; Sets the derivative of variable to value. An error is raised if there is no
;;; current work/continuous using the variable.
(define (set-variable-dt! variable value)
  (let ((environment (variable-environment variable)))
    (if (and (not (= (variable-state-index variable) -1))
             (simulation-environment-dydt environment))
        (vector-set!
         (simulation-environment-dydt environment)
         (variable-state-index variable)
         value)
        (error 'set-variable-dt!
               "There is no active work/continuously using the variable"))))

;;; (variable-initialized? variable) -> boolean?
;;;   variable : variable?
;;; Returns #t if variable is currently uninitilized.
(define (variable-initialized? variable)
  (not (eq? (variable-current-value variable) 'uninitialized)))

;;; Variable Synchronization

;;; (variable-synchronize! variable) -> void?
;;;   variable : variable?
;;; Update the statistics or history for variable. This implements a
;;; synchronization point.
(define (variable-synchronize! variable)
  (let* ((environment (variable-environment variable))
         (duration (- (simulation-environment-time environment)
                      (variable-time-last-synchronized variable))))
    ;; Don't accumulate if duration is zero or if the value is
    ;; uninitialized.
    (when (and (> duration 0.0)
               (not (eq? (variable-current-value variable) 'uninitialized)))
      ;; Accumulate statistics.
      (when (and (variable-statistics variable)
                 (statistics-time-dependant?
                  (variable-statistics variable)))
        (statistics-accumulate!
         (variable-statistics variable)
         (variable-value variable) duration))
      ;; Accumulate history.
      (when (and (variable-history variable)
                 (history-time-dependant?
                  (variable-history variable)))
        (history-accumulate!
         (variable-history variable)
         (variable-value variable) duration))
      ;; Save synchronization time.
      (set-variable-time-last-synchronized!
       variable (simulation-environment-time environment)))))

;;; Statistics shortcuts for variables

;;; (variable-minimum variable) -> real?
;;;   variable : variable?
(define (variable-minimum variable)
  (statistics-minimum (variable-statistics variable)))

;;; (variable-maximum variable) -> real?
;;;   variable : variable?
(define (variable-maximum variable)
  (statistics-maximum (variable-statistics variable)))

;;; (variable-n variable) -> (>=/c 0)
;;;   variable : variable?
(define (variable-n variable)
  (statistics-n (variable-statistics variable)))

;;; (variable-sum variable) -> real?
;;;   variable : variable?
(define (variable-sum variable)
  (statistics-sum (variable-statistics variable)))

;;; (variable-mean variable) -> real?
;;;   variable : variable?
(define (variable-mean variable)
  (statistics-mean (variable-statistics variable)))

;;; (variable-variance variable) -> real
;;;   variable : variable?
(define (variable-variance variable)
  (statistics-variance (variable-statistics variable)))

;;; (variable-standard-deviation variable) -> real?
;;;   variable : variable?
(define (variable-standard-deviation variable)
  (statistics-standard-deviation (variable-statistics variable)))

;;; (variable-add-get-monitor! variable when proc) -> (cons/c symbol? procedure?)
;;;   variable : variable?
;;;   when : (symbols 'before 'after)
;;;   proc : procedure?
(define (variable-add-get-monitor! variable when proc)
  (let ((mon (cons when proc)))
    (set-variable-get-monitors!
     variable
     (cons mon (variable-get-monitors variable)))
    mon))

;;; (variable-remove-get-monitor! variable mon) -> void?
;;;  variable : variable?
;;;  mon : (cons/c symbol? procedure?)
(define (variable-remove-get-monitor! variable mon)
  (set-variable-get-monitors!
   variable
   (remq mon (variable-get-monitors variable))))

;;; (variable-add-set-monitor! variable when proc) -> (cons/c symbol? procedure?)
;;;   variable : variable?
;;;   when : (symbols 'before 'after)
;;;   proc : procedure?
(define (variable-add-set-monitor! variable when proc)
  (let ((mon (cons when proc)))
    (set-variable-set-monitors!
     variable
     (cons mon (variable-set-monitors variable)))
    mon))

;;; (variable-remove-set-monitor! variable mon) -> void?
;;;  variable : variable?
;;;  mon : (cons/c symbol? procedure?)
(define (variable-remove-set-monitor! variable mon)
  (set-variable-set-monitors!
   variable
   (remq mon (variable-set-monitors variable))))

;;; (make-variable-vector n) -> (vectorof variable?)
(define (make-variable-vector n)
  (build-vector 
   n
   (lambda (i)
     (make-variable))))

;;; (set-variable-vector-values! variable-vector value-vector) -> void?
(define (set-variable-vector-values! variable-vector value-vector)
  (for ((var (in-vector variable-vector))
        (val (in-vector value-vector)))
    (set-variable-value! var val)))

;;; -----------------------------------------------------------------------------
;;; 4. Simulation Environments

;;; (struct simulation-environment (running?
;;;                                 time
;;;                                 now-event-list
;;;                                 future-event-list
;;;                                 loop-next
;;;                                 loop-exit
;;;                                 event
;;;                                 process
;;;                                 root
;;;                                 parent
;;;                                 continuous-event-list
;;;                                 evolve
;;;                                 control
;;;                                 step-type
;;;                                 step
;;;                                 system
;;;                                 step-size
;;;                                 dimension
;;;                                 y
;;;                                 dydt
;;;                                 state-changed?
;;;                                 max-step-size
;;;                                 monitor
;;;                                 requeue-cont)
;;;   #:mutable)
;;;   running : boolean?
;;;   time : (>=/c 0.0)
;;;   now-event-list : event-list?
;;;   future-event-list : event-list?
;;;   loop-next : (or/c false/c continuation?)
;;;   loop-exit : (or/c false/c continuation?)
;;;   event : (or/c false/c event?)
;;;   process : (or/c false/c process?)
;;;   root : process?
;;;   parent : (or/c false/c simulation-environment?)
;;;   continuous-event-list : event-list?
;;;   evolve :
;;;   control :
;;;   step-type :
;;;   step :
;;;   system :
;;;   step-size :
;;;   dimension :
;;;   y :
;;;   dydt :
;;;   start-changed? : boolean?
;;;   max-step-size :
;;;   monitor :
;;;   requeue-cont : (or/c continuation? false/c)
(struct simulation-environment (running?
                                time
                                now-event-list
                                future-event-list
                                loop-next
                                loop-exit
                                event
                                process
                                root
                                parent
                                children
                                continuous-event-list
                                evolve
                                control
                                step-type
                                step
                                system
                                step-size
                                dimension
                                y
                                dydt
                                state-changed?
                                max-step-size
                                monitor
                                requeue-cont)
  #:mutable)

;;; (make-simulation-environment parent) -> simulation-environment?
;;;   parent : simulation-environment?
;;; (make-simulation-environment) -> simulation-environment?
;;; Create and return a new simulation environment
(define (make-simulation-environment (parent #f))
  (let ((environment
         (simulation-environment
          #f                         ; running?
          0.0                        ; time
          #f ;(make-event-list)          ; now-event-list
          #f ;(make-event-list)          ; future-event-list
          #f                         ; loop-next
          #f                         ; loop exit
          #f                         ; event
          #f                         ; process
          #f                         ; root
          parent                     ; parent
          '()                        ; children
          #f ;(make-event-list)      ; continuous-event-list
          #f                         ; evolve
          (control-y-new 1.0e-6 0.0) ; control
          rkf45-ode-type             ; step-type
          #f                         ; step
          #f                         ; system
          1.0e-6                     ; step-size
          0                          ; dimension
          #f                         ; y
          #f                         ; dydt
          #t                         ; state-changed?
          +inf.0                     ; max-step-size
          #f                         ; monitor
          #f                         ; requeue-cont
          )))
    ;; Create the event lists associated with this environment.
    (set-simulation-environment-now-event-list!
     environment (make-event-list environment))
    (set-simulation-environment-future-event-list!
     environment (make-event-list environment))
    (set-simulation-environment-continuous-event-list!
     environment (make-event-list environment))
    ;; If there is a parent environment, inherit the appropriate fields.
    (when parent
      (set-simulation-environment-running?!
       environment (simulation-environment-running? parent))
      (set-simulation-environment-time!
       environment (simulation-environment-time parent)))
    ;; Set the root environment.
    (if parent
        (set-simulation-environment-root!
           environment (simulation-environment-root parent))
        (set-simulation-environment-root!
         environment simulation-environment))
    environment))

;;; default-simulation-environment : simulation-environment?
;;; The default simulation environment.
(define default-simulation-environment
  (make-simulation-environment))

;;; current-simulation-environment : (parameter/c simulation-environment?)
;; Sets or returns the current simulation environment.
(define current-simulation-environment
  (make-parameter default-simulation-environment
                  (lambda (x)
                    (when (not (simulation-environment? x))
                      (raise-type-error 'current-simulation-environment
                                        "simulation-environment" x))
                    x)))

;;; current-simulation-running
(define current-simulation-running?
  (case-lambda
    (()
     (simulation-environment-running?
      (current-simulation-environment)))
    ((running?)
     (set-simulation-environment-running?!
      (current-simulation-environment) running?))))

;;; current-simulation-time
(define current-simulation-time
  (case-lambda
    (()
     (simulation-environment-time
      (current-simulation-environment)))
    ((time)
     (set-simulation-environment-time!
      (current-simulation-environment) time))))

;;; current-simulation-now-event-list
(define current-simulation-now-event-list
  (case-lambda
    (()
     (simulation-environment-now-event-list
      (current-simulation-environment)))
    ((now-event-list)
     (set-simulation-environment-now-event-list!
      (current-simulation-environment) now-event-list))))

;;; future-simulation-future-event-list
(define current-simulation-future-event-list
  (case-lambda
    (()
     (simulation-environment-future-event-list
      (current-simulation-environment)))
    ((future-event-list)
     (set-simulation-environment-future-event-list!
      (current-simulation-environment) future-event-list))))

;;; current-simulation-loop-next
(define current-simulation-loop-next
  (case-lambda
    (()
     (simulation-environment-loop-next
      (current-simulation-environment)))
    ((loop-next)
     (set-simulation-environment-loop-next!
      (current-simulation-environment) loop-next))))

;;; current-simulation-loop-exit
(define current-simulation-loop-exit
  (case-lambda
    (()
     (simulation-environment-loop-exit
      (current-simulation-environment)))
    ((loop-exit)
     (set-simulation-environment-loop-exit!
      (current-simulation-environment) loop-exit))))

;;; current-simulation-event
(define current-simulation-event
  (case-lambda
    (()
     (simulation-environment-event
      (current-simulation-environment)))
    ((event)
     (set-simulation-environment-event!
      (current-simulation-environment) event))))

;;; current-simulation-process
(define current-simulation-process
  (case-lambda
    (()
     (simulation-environment-process
      (current-simulation-environment)))
    ((process)
     (set-simulation-environment-process!
      (current-simulation-environment) process))))

;;; current-simulation-parent
(define current-simulation-parent
  (case-lambda
    (()
     (simulation-environment-parent
      (current-simulation-environment)))
    ((parent)
     (set-simulation-environment-parent!
      (current-simulation-environment) parent))))

;;; current-simulation-continuous-event-list
(define current-simulation-continuous-event-list
  (case-lambda
    (()
     (simulation-environment-continuous-event-list
      (current-simulation-environment)))
    ((variables)
     (set-simulation-environment-continuous-event-list!
      (current-simulation-environment) variables))))

;;; current-simulation-evolve
(define current-simulation-evolve
  (case-lambda
    (()
     (simulation-environment-evolve
      (current-simulation-environment)))
    ((evolve)
     (set-simulation-environment-evolve!
      (current-simulation-environment) evolve))))

;;; current-simulation-control
(define current-simulation-control
  (case-lambda
    (()
     (simulation-environment-control
      (current-simulation-environment)))
    ((control)
     (set-simulation-environment-control!
      (current-simulation-environment) control))))

;;; current-simulation-step-type
(define current-simulation-step-type
  (case-lambda
    (()
     (simulation-environment-step-type
      (current-simulation-environment)))
    ((step-type)
     (set-simulation-environment-step-type!
      (current-simulation-environment) step-type))))

;;; current-simulation-step
(define current-simulation-step
  (case-lambda
    (()
     (simulation-environment-step
      (current-simulation-environment)))
    ((step)
     (set-simulation-environment-step!
      (current-simulation-environment) step))))

;;; current-simulation-system
(define current-simulation-system
  (case-lambda
    (()
     (simulation-environment-system
      (current-simulation-environment)))
    ((system)
     (set-simulation-environment-system!
      (current-simulation-environment) system))))

;;; current-simulation-step-size
(define current-simulation-step-size
  (case-lambda
    (()
     (simulation-environment-step-size
      (current-simulation-environment)))
    ((step-size)
     (set-simulation-environment-step-size!
      (current-simulation-environment) step-size))))

;;; current-simulation-dimension
(define current-simulation-dimension
  (case-lambda
    (()
     (simulation-environment-dimension
      (current-simulation-environment)))
    ((dimension)
     (set-simulation-environment-dimension!
      (current-simulation-environment) dimension))))

;;; current-simulation-y
(define current-simulation-y
  (case-lambda
    (()
     (simulation-environment-y
      (current-simulation-environment)))
    ((y)
     (set-simulation-environment-y!
      (current-simulation-environment) y))))

;;; current-simulation-dydt
(define current-simulation-dydt
  (case-lambda
    (()
     (simulation-environment-dydt
      (current-simulation-environment)))
    ((dydt)
     (set-simulation-environment-dydt!
      (current-simulation-environment) dydt))))

;;; current-simulation-state-changed?
(define current-simulation-state-changed?
  (case-lambda
    (()
     (simulation-environment-state-changed?
      (current-simulation-environment)))
    ((state-changed?)
     (set-simulation-environment-state-changed?!
      (current-simulation-environment) state-changed?))))

;;; current-simulation-max-step-size
(define current-simulation-max-step-size
  (case-lambda
    (()
     (simulation-environment-max-step-size
      (current-simulation-environment)))
    ((max-step-size)
     (set-simulation-environment-max-step-size!
      (current-simulation-environment) max-step-size))))

;;; current-simulation-monitor
(define current-simulation-monitor
  (case-lambda
    (()
     (simulation-environment-monitor
      (current-simulation-environment)))
    ((monitor)
     (set-simulation-environment-monitor!
      (current-simulation-environment) monitor))))

;;; current-simulation-requeue-cont
(define current-simulation-requeue-cont
  (case-lambda
    (()
     (simulation-environment-requeue-cont
      (current-simulation-environment)))
    ((requeue-cont)
     (set-simulation-environment-requeue-cont!
      (current-simulation-environment) requeue-cont))))

;;; Module Contracts

(provide (all-defined-out))