#lang scheme/base
;;; PLT Scheme Simulation Collection
;;; variable.ss
;;; Copyright (c) 2005-2008 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.
;;;
;;; Version  Date      Description
;;; 1.0.0    08/03/05  Removed default statistics accumulator.  (Doug Williams)
;;; 1.0.1    08/03/05  Added monitors.  (Doug Williams)
;;; 1.0.2    05/08/06  Changed define-monitor to monitor.  (Doug Williams)
;;; 2.0.0    05/17/07  Added vector variables.  (Doug Williams)
;;; 3.0.0    06/24/08  Updated for V4.0.  (Doug Williams)
;;; 3.0.1    11/27/08  Converted to a module.  (Doug Williams)
;;; 3.0.2    11/27/08  Cleaned up vector variable constructors.
;;;                    Added variable-add-get-monitor! and
;;;                    variable-add-set-monitor!.  (Doug Williams)
;;; 3.0.3    11/29/08  Added variable-initialized? function.  (Doug Williams)
;;; 3.0.4    09/14/09  Fixed error in executing after monitors. (Doug Williams)

(require "simulation-environment.ss"
         "process.ss"
         "statistics.ss"
         "history.ss")

(provide (all-defined-out))

;;; variable structure
;;;   #  slot                    description
;;;   -  ----                    -----------
;;;   0  initial-value           initial value (for reset)
;;;   1  value                   current value
;;;   2  time-last-synchronized  time variable was last synchronized
;;;   3  statistics              statistics collector or #f
;;;   4  history                 history collector or #f
;;;   -------------------------  v-- continuous variable --v
;;;   5  continuous?            
;;;   6  state-index             index into state vector or -1
;;;   -------------------------  v-- monitors -------------v
;;;   7  get-monitors            list of get monitors
;;;   8  set-monitors            list of set monitors
;;;   -------------------------  v-- vector variables -----v
;;;   9  vector-length           number of dimensions or #f

(define-values (struct:variable
                variable-constructor
                variable?
                variable-field-ref
                set-variable-field!)
  (make-struct-type 'variable #f 10 0))

;;; make-variable: real -> variable
;;; make-variable: -> variable
(define make-variable
  (case-lambda
    ((value)
     (variable-constructor value
                           value
                           (current-simulation-time)
                           (make-statistics #t (current-simulation-time))
                           #f
                           #f
                           -1
                           '()
                           '()
                           #f))
    (()
     (make-variable 'uninitialized))))

;;; make-continuous-variable: real -> variable
;;; make-continuous-variable: -> variable
(define make-continuous-variable
  (case-lambda
    ((value)
     (let ((process (current-simulation-process))
           (cv (variable-constructor value
                                     value
                                     (current-simulation-time)
                                     #f ;(make-statistics #t (current-simulation-time))
                                     #f
                                     #t
                                     -1
                                     '()
                                     '()
                                     #f)))
       ;; Add variable to list of process continuous variables
       (set-process-continuous-variables!
        process
        (cons cv (process-continuous-variables process)))
       cv))
    (()
     (make-continuous-variable 'uninitialized))))

;;; make-vector-variable: vector of reals -> variable
;;; make-vector-variable: positive integer -> variable

(define (make-vector-variable value-or-length)
  (cond ((vector? value-or-length)
         (variable-constructor value-or-length
                               value-or-length
                               (current-simulation-time)
                               #f ; (make-statistics #t (current-simulation-time))
                               #f
                               #f
                               -1
                               '()
                               '()
                               (vector-length value-or-length)))
        ((exact-positive-integer? value-or-length)
         (variable-constructor (make-vector value-or-length 'uninitialized)
                               (make-vector value-or-length 'uninitialized)
                               (current-simulation-time)
                               #f ; (make-statistics #t (current-simulation-time))
                               #f
                               #f
                               -1
                               '()
                               '()
                               value-or-length))
        (else
         (error 'make-vector-variable
                "expected vector of reals or exact positive integer, given ~a"
                value-or-length))))

;;; make-continuous-vector-variable: vector of reals -> variable
;;; make-continuous-vector-variable: positive integer -> variable

(define (make-continuous-vector-variable value-or-length)
  (cond ((vector? value-or-length)
         (let ((process (current-simulation-process))
               (cv (variable-constructor value-or-length
                                         value-or-length
                                         (current-simulation-time)
                                         #f ; (make-statistics #t (current-simulation-time))
                                         #f
                                         #t
                                         -1
                                         '()
                                         '()
                                         (vector-length value-or-length))))
           (set-process-continuous-variables!
            process
            (cons cv (process-continuous-variables process)))
           cv))
        ((exact-positive-integer? value-or-length)
         (let ((process (current-simulation-process))
               (cv (variable-constructor 'uninitialized
                                         'uninitialized
                                         (current-simulation-time)
                                         #f ; (make-statistics #t (current-simulation-time))
                                         #f
                                         #t
                                         -1
                                         '()
                                         '()
                                         value-or-length)))
           (set-process-continuous-variables!
            process
            (cons cv (process-continuous-variables process)))
           cv))
        (else
         (error 'make-continuousvector-variable
                "expected vector of reals or exact positive integer, given ~a"
                value-or-length))))
        

;;; variable structure, initial-value slot
;;; variable-initial-value: variable -> real or 'uninitialized
;;; set-variable-initial-value!: variable x real -> void
(define variable-initial-value
  (make-struct-field-accessor variable-field-ref 0 'initial-value))

(define set-variable-initial-value!
  (make-struct-field-mutator set-variable-field! 0 'initial-value))

;;; variable structure, value slot
;;; variable-value: variable -> real
;;; variable-value: variable x positive -> real
;;; set-variable-value!: variable x real -> void
;;; set-variable-value!: variable x positive x real -> void
(define (variable-value variable)
  (let ((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-field-ref variable 1) 'uninitialized)
      (error 'variable-value "Attempt to reference an uninitialized variable"))
    (if (and (not (= (variable-state-index variable) -1))
             (current-simulation-y))
        ;; Get the value from the state vector
        (set! value (vector-ref
                    (current-simulation-y)
                    (variable-state-index variable)))
        ;; Use the stored value
        (set! value (variable-field-ref variable 1)))
    ;; Run after monitors
    (for-each
     (lambda (monitor)
       (when (eq? (car monitor) 'after)
         ((cdr monitor) variable value)))
     (variable-get-monitors variable))
    ;; return the value
    value))

(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-field! variable 1 value)
  ;; Tally new value (statistics and history)
  (when (and (variable-field-ref variable 3)
             (not (statistics-time-dependant?
                   (variable-field-ref variable 3))))
    (statistics-tally! (variable-field-ref variable 3) value))
  (when (and (variable-field-ref variable 4)
             (not (history-time-dependant?
                   (variable-field-ref variable 4))))
    (history-tally! (variable-field-ref variable 4) value))
  ;; Run after monitors
  (for-each
   (lambda (monitor)
     (when (eq? (car monitor) 'after)
       ((cdr monitor) variable value)))
   (variable-set-monitors variable))
  (void))

;;; variable structure, time-last-synchronized slot
;;; variable-time-last-synchronized: variable -> real
;;; set-variable-time-last-synchronized!: variable x real -> void
(define variable-time-last-synchronized
  (make-struct-field-accessor variable-field-ref 2 'time-last-synchronized))

(define set-variable-time-last-synchronized!
  (make-struct-field-mutator set-variable-field! 2 'time-last-synchronized))

;;; variable structure, statistics slot
;;; variable-statistics: variable -> statistics or #f
;;; set-variable-statistics!: variable x statistics or #f -> void
;;; (define variable-statistics
;;;   (make-struct-field-accessor variable-field-ref 3 'statistics))
(define (variable-statistics variable)
  ;; Accumulate value (synchronize)
  (variable-synchronize! variable)
  (variable-field-ref variable 3))

(define set-variable-statistics!
  (make-struct-field-mutator set-variable-field! 3 'statistics))

;;; variable structure, history slot
;;; variable-history: variable -> history or #f
;;; set-variable-history!: variable x history or #f -> void
;;; (define variable-statistics
;;;   (make-struct-field-accessor variable-field-ref 4 'history))
(define (variable-history variable)
  ;; Accumulate value (synchronize)
  (variable-synchronize! variable)
  (variable-field-ref variable 4))

(define set-variable-history!
  (make-struct-field-mutator set-variable-field! 4 'history))

;; variable-continuous? field
(define variable-continuous?
  (make-struct-field-accessor variable-field-ref 5 'continuous?))

(define set-variable-continuous?!
  (make-struct-field-mutator set-variable-field! 5 'continuous?))

;; variable-state-index field
(define variable-state-index
  (make-struct-field-accessor variable-field-ref 6 'state-index))

(define set-variable-state-index!
  (make-struct-field-mutator set-variable-field! 6 'state-index))

;;; get-monitors field
(define variable-get-monitors
  (make-struct-field-accessor variable-field-ref 7 'get-monitors))

(define set-variable-get-monitors!
  (make-struct-field-mutator set-variable-field! 7 'get-monitors))

;;; set-monitors field
(define variable-set-monitors
  (make-struct-field-accessor variable-field-ref 8 'set-monitors))

(define set-variable-set-monitors!
  (make-struct-field-mutator set-variable-field! 8 'set-monitors))

;;; vector-length field
(define variable-vector-length
  (make-struct-field-accessor variable-field-ref 9 'vector-length))

(define set-variable-vector-length!
  (make-struct-field-mutator set-variable-field! 9 'vector-length))

;; variable-dt! pseudo-field
(define (variable-dt variable)
  (if (and (not (= (variable-state-index variable) -1))
           (current-simulation-dydt))
      (vector-ref
       (current-simulation-dydt)
       (variable-state-index variable))
      (error 'variable-dt
             "There is no active work/continuously using the variable")))

(define (set-variable-dt! variable value)
  (if (and (not (= (variable-state-index variable) -1))
           (current-simulation-dydt))
      (vector-set!
       (current-simulation-dydt)
       (variable-state-index variable)
       value)
      (error 'set-variable-dt!
             "There is no active work/continuously using the variable")))

;; variable-initialized?
(define (variable-initialized? variable)
  (not (eq? (variable-field-ref variable 1) 'uninitialized)))

;; variable-synchronize!: variable
(define (variable-synchronize! variable)
  (let ((duration (- (current-simulation-time)
                     (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-field-ref variable 1) 'uninitialized)))
      ;; Accumulate statistics
      (when (and (variable-field-ref variable 3)
                 (statistics-time-dependant?
                  (variable-field-ref variable 3)))
        (statistics-accumulate!
         (variable-field-ref variable 3)
         (variable-value variable) duration))
      ;; Accumulate history
      (when (and (variable-field-ref variable 4)
                 (history-time-dependant?
                  (variable-field-ref variable 4)))
        (history-accumulate!
         (variable-field-ref variable 4)
         (variable-value variable) duration))
      ;; Save synchronization time
      (set-variable-time-last-synchronized!
       variable (current-simulation-time)))))

;;; Statistics shortcuts for variables

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

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

;;; variable-n: variable -> real
(define (variable-n variable)
  (statistics-n (variable-statistics variable)))

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

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

(define (variable-variance variable)
  (statistics-variance (variable-statistics variable)))

(define (variable-standard-deviation variable)
  (statistics-standard-deviation (variable-statistics variable)))

;;; (accumulate (variable-statistics variable))
;;; (accumulate (variable-history variable))
(define-syntax accumulate
  (syntax-rules (variable-statistics variable-history)
    ((accumulate (variable-statistics variable))
     (let ((statistics (make-statistics #t (current-simulation-time))))
       (set-variable-statistics! variable statistics)))
    ((accumulate (variable-history variable))
     (let ((history (make-history #t (current-simulation-time))))
       (set-variable-history! variable history)))))

;;; (tally (variable-statistics variable))
;;; (tally (variable-history variable))
(define-syntax tally
  (syntax-rules (variable-statistics variable-history)
    ((tally (variable-statistics variable))
     (let ((statistics (make-statistics #f (current-simulation-time))))
       (when (not (eq? (variable-field-ref variable 1) 'uninitialized))
         (statistics-tally! statistics (variable-field-ref variable 1)))
       (set-variable-statistics! variable statistics)))
    ((tally (variable-history variable))
     (let ((history (make-history #f (current-simulation-time))))
       (when (not (eq? (variable-field-ref variable 1) 'uninitialized))
         (history-tally! history (variable-field-ref variable 1)))
       (set-variable-history! variable history)))))

(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))

(define (variable-remove-get-monitor! variable mon)
  (set-variable-get-monitors!
   variable
   (remq mon (variable-get-monitors variable))))

(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))

(define (variable-remove-set-monitor! variable mon)
  (set-variable-set-monitors!
   variable
   (remq mon (variable-set-monitors variable))))

;;; (define-monitor ...)
(define-syntax monitor
  (syntax-rules (before after variable-value set-variable-value!)
    ((monitor before (variable-value variable)
       body ...)
     (let ((mon (cons
                 'before
                 (lambda (variable)
                   body ...))))
       (set-variable-get-monitors!
        variable
        (cons mon (variable-get-monitors variable)))))
    ((monitor after (variable-value variable)
       body ...)
     (let ((mon (cons
                 'after
                 (lambda (variable)
                   body ...))))
       (set-variable-get-monitors!
        variable
        (cons mon (variable-get-monitors variable)))))
    ((monitor before (set-variable-value! variable value)
       body ...)
     (let ((mon (cons
                 'before
                 (lambda (variable value)
                   body ...))))
       (set-variable-set-monitors!
        variable
        (cons mon (variable-set-monitors variable)))))
    ((monitor after (set-variable-value! variable value)
       body ...)
     (let ((mon (cons
                 'after
                 (lambda (variable value)
                   body ...))))
       (set-variable-set-monitors!
        variable
        (cons mon (variable-set-monitors variable)))))))