#lang racket
;;; syntaxes.rkt

(require (for-syntax syntax/parse)
         racket/mpair
         "environment.rkt"
         "statistics.rkt"
         "history.rkt"
         "control.rkt")

;;; -----------------------------------------------------------------------------
;;; 1. Simulation Environment Syntaxes

;;; with-simulation-environment
;;; A macro to execute a body of code with a specified simulation
;;; environment as the current-simulation-environment.
(define-syntax-rule (with-simulation-environment simulation-environment
                      body ...)
  (parameterize ((current-simulation-environment simulation-environment))
    body ...))

;;; with-new-simulation-environment
;;; A macro to execute a body of code with a newly created simulation
;;; environment as the current-simulation-environment.
(define-syntax-rule (with-new-simulation-environment
                      body ...)
  (parameterize ((current-simulation-environment (make-simulation-environment)))
    body ...))

;;; with-new-child-simulation-environment
;;; A macro to execute a body of code with a newly created simulation
;;; environment that is a child of the current simulation environment as the
;;; current-simulation-environment.
(define-syntax-rule (with-new-child-simulation-environment
                      body ...)
  (parameterize ((current-simulation-environment
                  (make-simulation-environment (current-simulation-environment))))
    body ...))

;;; -----------------------------------------------------------------------------
;;; 2. Process Types and Process Syntaxes

;;; (define-process-type id super-id
;;;   (field ...))
;;; (define-process-type id
;;;   (field ...))
;;; Define a new process type that is a sub-type of super-id. If super-id is not
;;; specified, the super-type is process. Process is the root of the process type
;;; tree.
(define-syntax (define-process-type stx)
  (define-syntax-class field
    #:attributes (field-id value)
    (pattern (field-id:id value:expr))
    (pattern field-id:id #:with value #'#f))
  (syntax-parse stx
    ((define-process-type name:id super-name:id
       (f:field ...))
     (with-syntax ((id
                    (datum->syntax
                     (syntax define-process-type)
                     (string->symbol
                      (format "process-type:~a" (syntax->datum #'name)))))
                   (super-id
                    (datum->syntax
                     (syntax define-process-type)
                     (string->symbol
                      (format "process-type:~a" (syntax->datum #'super-name))))))
       #'(begin
           (struct name super-name (f.field-id ...) #:mutable)
           (define id (process-type-info 'name
                                         super-id
                                         (append
                                          (process-type-info-parameters super-id)
                                          (list 'f.field-id ...))
                                         (append
                                          (process-type-info-inits super-id)
                                          (list f.value ...))
                                         name)))))
    ((define-process-type name:id
       (f:field ...))
     (with-syntax ((id (datum->syntax
                        (syntax define-process-type)
                        (string->symbol
                         (format "process-type:~a" (syntax->datum #'name))))))
       #'(begin
           (struct name process (f.field-id ...) #:mutable)
           (define id (process-type-info 'name
                                         #f
                                         (list 'f.field-id ...)
                                         (list f.value ...)
                                         name)))))))

;;; (define-process [type-id] (name . parameters)
;;;   . body)
;;; Syntax for defining a process. It also creates a self variable that is
;;; lexically bound to the process instance withing the process body. The code
;;; follows the example in the Racket Reference to create the self variable in
;;; the calling environment.
(define-syntax (define-process stx)
  (syntax-parse stx
    ((define-process type:id (name:id . parameters)
       . body)
     (with-syntax ((type-id
                     (datum->syntax
                      (syntax define-process)
                     (string->symbol
                      (format "process-type:~a" (syntax->datum #'type)))))
                   (self
                    (datum->syntax
                     (syntax define-process)
                     'self)))
       #'(define name (process-info
                       'name
                       type-id
                       (lambda parameters
                         (let ((self (current-simulation-process)))
                           . body))))))
    ((define-process (name:id . parameters)
       . body)
     (with-syntax ((self
                    (datum->syntax
                     (syntax define-process)
                     'self)))
       #'(define name (process-info
                       'name
                       #f
                       (lambda parameters
                         (let ((self (current-simulation-process)))
                           . body))))))))

;;; (define-process* (name . parameters)
;;;   (field ...)
;;;   . body)
(define-syntax (define-process* stx)
  (define-syntax-class field
    #:attributes (field-id value)
    (pattern (field-id:id value:expr))
    (pattern field-id:id #:with value #'#f))
  (syntax-parse stx
    ((define-process* type:id (name:id . parameters)
       (f:field ...)
       . body)
     (with-syntax ((type-id
                    (datum->syntax
                     (syntax define-process-type)
                     (string->symbol
                      (format "process-type:~a" (syntax->datum #'type)))))
                   (make
                    (datum->syntax
                     (syntax define-process*)
                     (string->symbol
                      (format "make-~a" (syntax->datum #'name)))))
                   (self
                    (datum->syntax
                     (syntax define-process*)
                     'self)))
       #'(begin
           (struct name type (f.field-id ...)
             #:mutable
             #:constructor-name make
             #:omit-define-syntaxes)
           (define name (process-info
                         'name
                         (process-type-info 'name
                                            type-id
                                            (append
                                             (process-type-info-parameters type-id)
                                             (list 'f.field-id ...))
                                            (append
                                             (process-type-info-inits type-id)
                                             (list f.value ...))
                                            make)
                         (lambda parameters
                           (let ((self (current-simulation-process)))
                             . body)))))))
    ((define-process* (name:id . parameters)
       (f:field ...)
       . body)
     (with-syntax ((make
                    (datum->syntax
                     (syntax define-process*)
                     (string->symbol
                      (format "make-~a" (syntax->datum #'name)))))
                   (self
                    (datum->syntax
                     (syntax define-process*)
                     'self)))
       #'(begin
           (struct name process (f.field-id ...)
             #:mutable
             #:constructor-name make
             #:omit-define-syntaxes)
           (define name (process-info
                         'name
                         (process-type-info 'name
                                            #f
                                            (list 'f.field-id ...)
                                            (list f.value ...)
                                            make)
                         (lambda parameters
                           (let ((self (current-simulation-process)))
                             . body)))))))))

;;; -----------------------------------------------------------------------------
;;; 3. Variable Syntaxes

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

;;; (accumulate (variable-statistics variable))
;;; (accumulate (variable-history variable))
(define-syntax accumulate
  (syntax-rules (variable-statistics variable-vector-statistics
                 variable-history variable-vector-history)
    ((accumulate (variable-statistics variable))
     (let ((s (make-statistics #t (current-simulation-time))))
       (set-variable-statistics! variable s)))
    ((accumulate (variable-vector-statistics variable))
     (for ((v (in-vector variable)))
       (let ((s (make-statistics #t (current-simulation-time))))
         (set-variable-statistics! v s))))
    ((accumulate (variable-history variable))
     (let ((h (make-history #t (current-simulation-time))))
       (set-variable-history! variable h)))
    ((accumulate (variable-vector-history variable))
     (for ((v (in-vector variable)))
       (let ((h (make-history #t (current-simulation-time))))
         (set-variable-history! v h))))))

;;; (tally (variable-statistics variable))
;;; (tally (variable-history variable))
(define-syntax tally
  (syntax-rules (variable-statistics variable-vector-statistics
                 variable-history variable-vector-history)
    ((tally (variable-statistics variable))
     (let ((s (make-statistics #f (current-simulation-time))))
       (when (not (eq? (variable-current-value variable) 'uninitialized))
         (statistics-tally! s (variable-current-value variable)))
       (set-variable-statistics! variable s)))
    ((tally (variable-vector-statistics variable))
     (for ((v (in-vector variable)))
       (let ((s (make-statistics #f (current-simulation-time))))
         (unless (eq? (variable-current-value v) 'uninitialized)
           (statistics-tally! s (variable-current-value v)))
         (set-variable-statistics! v s))))
    ((tally (variable-history variable))
     (let ((h (make-history #f (current-simulation-time))))
       (unless (eq? (variable-current-value variable) 'uninitialized)
         (history-tally! h (variable-current-value variable)))
       (set-variable-history! variable h)))
    ((tally (variable-vector-history variable))
     (for ((v (in-vector variable)))
       (let ((h (make-history #f (current-simulation-time))))
         (unless (eq? (variable-current-value v) 'uninitialized)
           (history-tally! h (variable-current-value v)))
         (set-variable-history! v h))))))

;;; -----------------------------------------------------------------------------
;;; 3. Simulation Control Syntaxes

;;; schedule macro
;;; Schedule a process or event for execution in the current
;;; simulation environment.
(define-syntax (schedule stx)
  (define-splicing-syntax-class timing
    #:attributes (time)
    (pattern (~seq #:now)
             #:with time #''#:now)
    (pattern (~seq (~datum now))
             #:with time #''#:now)
    (pattern (~seq #:at time:expr))
    (pattern (~seq ((~datum at) time:expr)))
    (pattern (~seq #:in delta:expr)
             #:with time #'(+ delta (current-simulation-time)))
    (pattern (~seq ((~datum in) delta:expr))
             #:with time #'(+ delta (current-simulation-time)))
    (pattern (~seq #:when event:expr)
             #:with time #'event)
    (pattern (~seq ((~datum when) event:expr))
             #:with time #'event)
    (pattern (~seq time:expr)))
  (syntax-parse stx
    ((schedule t:timing (function:id . arguments)
               (~optional (~seq  #:priority priority:expr)
                          #:defaults ((priority #'0))))
       #'(if (process-info? function)
           (let ((process (make-process function (list . arguments))))
             (set-event-priority! (process-event process) priority)
             (schedule-event (process-event process) t.time (current-simulation-environment))
             process)
           (let ((event (make-event t.time priority #f function (list . arguments))))
             (schedule-event event t.time (current-simulation-environment))
             event)))))

;;; 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 ...))))

;;; -----------------------------------------------------------------------------
;;; 5. Rendezvous Syntaxes

;;; (call callee (type . arguments))
(define-syntax (call stx)
  (syntax-parse stx
    ((call callee:expr (type:id . arguments)
           (~optional (~seq #:priority priority:expr)
                      #:defaults ((priority #'0))))
     #'(let* ((event (current-simulation-event))
              (process (current-simulation-process)))
         (unless process
           (error 'call
                  "call only allowed inside a simulation process"))
         ;; Build the rendezvous event.
         (let ((rendezvous-event
                (make-event (current-simulation-time)
                            priority
                            process
                            'type
                            (list . arguments))))
           (let/cc continue
             ;; Save the (caller) continuation in the process's event.
             (set-event-function! event continue)
             (set-event-arguments! event '())
             ;; Check for an open acceptor.
             (rendezvous rendezvous-event callee)
             ;; If we get back here, then the rendezvous was not accepted.
             ;; Queue the rendezvous event in the callee process's queue.
             (event-list-add! (process-queue callee) rendezvous-event)
             ((current-simulation-loop-next))))))))

;;; (accept caller (type . parameters))
;;; (accept caller (type . parameters) . body)
(define-syntax (accept stx)
  (syntax-parse stx
    ((accept caller:expr (type:id . parameters))
     #'(let/cc continue
         (let ((event (current-simulation-event))
               (process (current-simulation-process)))
           (unless process
             (error 'accept
                    "accept only allowed inside a simulation process"))
           ;; Save the (callee) continuation in the process's event.
           (set-event-function! event continue)
           (set-event-arguments! event '())
           ;; Build the acceptors.
           (let ((acceptors (list (list 'type #f #f))))
             (set-process-acceptors! process acceptors)
             ;; Check the queue of waiting rendezvous events.
             (mfor-each
              (lambda (rendezvous-event)
                (rendezvous rendezvous-event process))
              (event-list-events (process-queue process))))
           ;; If we get back here, then no rendezvous was accepted.
           ((current-simulation-loop-next)))))
    ((accept caller:expr (type:id . parameters) . body)
     #'(let/cc continue
         (let ((event (current-simulation-event))
               (process (current-simulation-process)))
           (unless process
             (error 'select
                    "select only allowed inside a simulation process"))
           ;; Save the (callee) continuation in the process's event.
           (set-event-function! event continue)
           (set-event-arguments! event '())
           ;; Build the acceptors.
           (let ((acceptors (list (list 'type
                                        (lambda (caller . parameters)
                                          . body)
                                        #f))))
             (set-process-acceptors! process acceptors)
             ;; Check the queue of waiting rendezvous events.
             (mfor-each
              (lambda (rendezvous-event)
                (rendezvous rendezvous-event process))
              (event-list-events (process-queue process))))
           ;; If we get back here, then no rendezvous was accepted.
           ((current-simulation-loop-next)))))))

;;;
(define-syntax (select stx)
  (define-splicing-syntax-class timing
    #:attributes (time)
    (pattern (~seq #:now) #:with time #''#:now)
    (pattern (~seq #:at time:expr))
    (pattern (~seq #:in delta:expr) #:with time #'(+ delta (current-simulation-time)))
    (pattern (~seq #:when event:expr) #:with time #'event))
  (define-syntax-class accept-alternative
    #:literals (when accept)
    #:attributes (when-expr caller type parameters body1 body2)
    (pattern ((when when-expr:expr
                (accept caller:expr (type:id . parameters)))
                . body2)
             #:with body1 #'((void)))
    (pattern ((when when-expr:expr
                (accept caller:expr (type:id . parameters)
                  . body1))
                . body2))
    (pattern ((accept caller:expr (type:id . parameters))
              . body2)
             #:with when-expr #'#t
             #:with body1 #'((void)))
    (pattern ((accept caller:expr (type:id . parameters)
                . body1)
              . body2)
             #:with when-expr #'#t))
  (define-syntax-class call-alternative
    #:literals (call)
    #:attributes (callee type arguments priority body)
    (pattern ((call callee:expr (type:id . arguments)
                    (~optional (~seq #:priority priority:expr)
                      #:defaults ((priority #'0)))))
             #:with body #'((void)))
    (pattern ((call callee:expr (type:id . arguments)
                    (~optional (~seq #:priority priority:expr)
                      #:defaults ((priority #'0))))
              . body)))
  (define-syntax-class else-alternative
    #:literals (else)
    #:attributes (time body)
    (pattern (else t:timing
               . body)
             #:with time #'t.time))
  (syntax-parse stx
    ((select aa:accept-alternative ...)
     #'(let/cc continue
         (let ((event (current-simulation-event))
               (process (current-simulation-process)))
           ;; Save the (callee) continuation in the process's event.
           (set-event-function! event continue)
           (set-event-arguments! event '())
           (unless process
             (error 'accept
                    "accept only allowed inside a simulation process"))
           ;; build the acceptors.
           (let ((acceptors '()))
             ;; Accumulate the acceptors here.
             (when aa.when-expr
               (set!
                acceptors
                (append
                 acceptors
                 (list (list 'aa.type
                             (lambda (aa.caller . aa.parameters) . aa.body1)
                             (lambda () (begin . aa.body2) (continue)))))))
             ...
             (set-process-acceptors! process acceptors)
             ;; Check the queue of waiting rendezvous events.
             (mfor-each
              (lambda (rendezvous-event)
                (rendezvous rendezvous-event process))
              (event-list-events (process-queue process))))
           ;; If we get back here, then no rendezvous was accepted.
           ((current-simulation-loop-next)))))
    ((select aa:accept-alternative ... ea:else-alternative)
     #'(begin
         (let ((event (current-simulation-event))
               (process (current-simulation-process)))
           (let/cc continue
             ;; Save the (callee) continuation in the process's event.
             (set-event-function! event continue)
             (set-event-arguments! event '())
             (unless process
               (error 'accept
                      "accept only allowed inside a simulation process"))
             ;; build the acceptors.
             (let ((acceptors '()))
               ;; Accumulate the acceptors here.
               (when aa.when-expr
                 (set!
                  acceptors
                  (append
                   acceptors
                   (list (list 'aa.type
                               (lambda (aa.caller . aa.parameters) . aa.body1)
                               (lambda () (begin . aa.body2) (continue)))))))
               ...
               (set-process-acceptors! process acceptors)
               ;; Check the queue of waiting rendezvous events.
               (mfor-each
                (lambda (rendezvous-event)
                  (rendezvous rendezvous-event process))
                (event-list-events (process-queue process))))
             ;; If we get back here, then no rendezvous was (immediately) accepted.
             ;; Set up timeout.
             (schedule-event event ea.time)
             ((current-simulation-loop-next)))
           (unless (null? (process-acceptors process))
             (set-process-acceptors! process '())
             . ea.body)
           )))
    ((select ca:call-alternative ea:else-alternative)
     #'(let ((event (current-simulation-event))
             (process (current-simulation-process)))
         (unless process
           (error 'select
                  "select only allowed inside a simulation process"))
         ;; Build the rendezvous event.
         (let ((rendezvous-event
                (make-event (current-simulation-time)
                            ca.priority
                            process
                            'ca.type
                            (list . ca.arguments))))
           (let/cc continue
             ;; Save the (caller) continuation in the process's event.
             (set-event-function! event continue)
             (set-event-arguments! event '())
             ;; Check for an open acceptor.
             (rendezvous rendezvous-event ca.callee)
             ;; If we get back here, then the rendezvous was not accepted.
             ;; Queue the rendezvous event in the callee process's queue.
             (event-list-add! (process-queue ca.callee) rendezvous-event)
             ;; Schedule the reneg event.
             (schedule-event event ea.time)
             ((current-simulation-loop-next)))
           ;; Did we reneg (i.e., is the rendezvous event still queued)?
           (if (event-event-list rendezvous-event)
               (begin
                 (event-list-remove! rendezvous-event)
                 . ea.body)
               (begin
                 . ca.body)))))))

;;; Module Contracts

(provide (all-defined-out))