source: project/release/4/signal-diagram/trunk/signal-diagram.scm @ 30882

 
;;
;;  This module implements combinators that are used to build signal
;;  flow functions out of pure functions.
;;
;;  Based on ideas from:
;;  1) Opis - Reliable Distributed Systems in OCaml
;;  (Copyright (C) 2008-2009 Pierre-Evariste DAGAND)
;;
;;  2) Yampa: Functional Reactive Programming with Arrows
;;  Developed by the Yale Haskell Group.
;;
;; Copyright 2010-2014 Ivan Raikov and the Okinawa Institute of
;; Science and Technology.
;;
;; This program is free software: you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.
;;
;; This program 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
;; General Public License for more details.
;;
;; A full copy of the GPL license can be found at
;; <http://www.gnu.org/licenses/>.
;;


(module signal-diagram 

        (PURE PRIM RELATION IDENTITY 
         SENSE ACTUATE SEQUENCE UNION REDUCE
         INTEGRAL INTEGRALH
         TRANSITION RTRANSITION TRANSIENT 

         function? make-function function-formals function-body
         prim? make-prim prim-states prim-formals prim-body prim-init

         signal? signal-name signal-value

         symbolic-constants enum-freevars

         construct dataflow events codegen/Octave codegen/scheme codegen/ML
         )

        (import scheme chicken)

        (require-extension extras data-structures srfi-1 datatype flsim dyn-vector)
        (require-library lolevel srfi-13)
        (import (only srfi-13 string-concatenate string<)
                (only lolevel extended-procedure? procedure-data extend-procedure )
                )

(include "expr-utils")

(define nl "\n")
(define (s+ . rst) (string-concatenate (map ->string rst)))

;; based on SRV:send-reply by Oleg Kiselyov
(define (print-fragments b)
  (let loop ((fragments b) (result #f))
    (cond
      ((null? fragments) result)
      ((not (car fragments)) (loop (cdr fragments) result))
      ((null? (car fragments)) (loop (cdr fragments) result))
      ((eq? #t (car fragments)) (loop (cdr fragments) #t))
      ((pair? (car fragments))
        (loop (cdr fragments) (loop (car fragments) result)))
      ((procedure? (car fragments))
        ((car fragments))
        (loop (cdr fragments) #t))
      (else
       (display (car fragments))
       (loop (cdr fragments) #t)))))


(define (symbol-pair? x)
  (and (pair? x) 
       (and (symbol? (car x)) 
            (or (null? (cdr x)) 
                (symbol-pair? (cdr x))))))


(define (symbol-list? x)
  (and (list? x) (every symbol? x)))



;;
;; A signal function is expected to be built upon pure functions only:
;; side-effects should not be used. Although this requirement is not
;; of prime importance in normal use, this is a hardship if one wants
;; to debug a signal function.
;;

(define make-signal cons)
(define signal-name car)
(define signal-value cdr)
(define signal? pair?)


(define-values (cgenenv-empty cgenenv-add cgenenv-find cgenenv-union )
  (letrec (
           (empty      '())
           (add        (lambda (s v env) 
                         (if (and (symbol? s) (symbol? v))
                             (cons (cons s v) env)
                             (error 'cgenenv-add "invalid arguments to add" s v))))
           (find       (lambda (loc s env)
                         (let ((v (alist-ref s env)))
                           (if (not v) (error loc "label not found" s))
                           v)))
           (union      (lambda (x y) (lset-union (lambda (x y) (eq? (first x) (first y))) x y)))
           )
    (values empty add find union )))


(define (list->cgenenv loc slst source-cgenenv)
  (fold (lambda (s env) (cgenenv-add s (cgenenv-find loc s source-cgenenv) env))
        cgenenv-empty slst))




;;
;;   An arrow is an object with:
;;
;;   * dfe method, which produces dataflow information
;;   * codegen method, which generates pseudo-imperative code
;;

(define-record-type sfarrow
  (make-sfarrow  dfe codegen sig children relations)
  sfarrow?
  (dfe         sfarrow-dfe)
  (codegen     sfarrow-codegen)
  (sig         sfarrow-sig)
  (children    sfarrow-children)
  (relations   sfarrow-relations)
  )


(define-record-type dfe
  (make-dfe gen kill in out)
  dfe?
  (gen       dfe-gen )
  (kill      dfe-kill )
  (in        dfe-in )
  (out       dfe-out )
  )


(define-record-type function
  (make-function formals body)
  function?
  (formals function-formals)
  (body    function-body))


(define-record-type prim
  (make-prim states formals outputs events body init-outputs init)
  prim?
  (states  prim-states)
  (formals prim-formals)
  (outputs prim-outputs)
  (events  prim-events)
  (body    prim-body)
  (init    prim-init)
  (init-outputs prim-init-outputs)
  )


(define (function-list? x)
  (and (list? x) (every function? x)))


(define (relation? r)
  (and (pair? r) (symbol? (car r)) 
       (symbol-list? (cadr r))
       (function? (caddr r))))


(define-datatype diagram diagram?
  (IDENTITY     (f diagram?))
  (PURE         (f function?))
  (PRIM         (f prim?) (name symbol?))
  (RELATION     (r relation?) (f diagram?))
  (UNION        (f diagram?) (g diagram?))
  (SEQUENCE     (f diagram?) (g diagram?))
  (SENSE        (s symbol-pair?) (f diagram?))
  (ACTUATE      (s symbol-pair?) (f diagram?))
  (REDUCE       (f function?) (name symbol?) (init symbol?))
  (RTRANSITION  (f diagram?) (g diagram?) 
                (ef symbol?)
                (eg (lambda (x) (or (symbol? x) (boolean? x))))
                (s  symbol?)
                )
  (TRANSITION   (f diagram?) (g diagram?) (ef symbol?) (s symbol?))
  (TRANSIENT    (f diagram?) (g diagram?) (e symbol?) )
  (INTEGRAL     (i symbol?) (d symbol-list?) (f function-list?))
  (INTEGRALH    (i symbol?) (d symbol-list?) (h (lambda (x) (or (symbol? x) (number? x)))) 
                (f function-list?))
  )



(define (select-signal loc s env)
  (let ((v (cgenenv-find loc s env)))
    (if (eq? s v) (V:Var s) (V:Sel s (V:Var v)))))


(define-record-type codegen
  (make-codegen0 rv renv expr)
  codegen?
  (rv          codegen-rv)
  (renv        codegen-renv)
  (expr        codegen-expr)
  )

(define (make-codegen rv renv expr)
  (if (not (symbol? rv)) (error 'make-codegen "invalid return variable"))
  (make-codegen0 rv renv expr))


(define codegen-state (make-parameter '()))
    
                                           
;;
;;  The arrow combinators are used to build signal functions upon pure
;;  functions.
;;  

;;  [sf f] encapsulates a pure function into a signal function.


(define (sf f . rest)
  (let-optionals rest ((name (gensym 'sf)))
   (let* (
          (fd (and (extended-procedure? f) (procedure-data f)))
          (formals (or (and (prim? fd) (prim-outputs fd)) 
                       (and (function? fd) (function-formals fd))
                       '()))
          (outputs (or (and (prim? fd) (prim-outputs fd)) '()))
          (states (or (and (prim? fd) (prim-states fd)) '()))
          (events (or (and (prim? fd) (prim-events fd)) '()))
          )

     (make-sfarrow 
      ;; dataflow equations
      (make-dfe
       ;; gen
       (lambda (s) (if (prim? fd) outputs (list name)))
       ;; kill
       (lambda (s) (if (prim? fd) outputs (list name)))
       ;; in
       (lambda (s) s)
       ;; out
       (lambda (s) (if (prim? fd) outputs (list name))))
      ;; codegen
      (lambda (s env dfe) 
        (let ((in   ((dfe-in dfe) s))
              (out  ((dfe-out dfe) s))
              (rv1  (gensym 'rv))
              (rv2  (gensym 'rv))
              (init-name (and (prim? fd) (gensym (string->symbol (string-append (->string name) "init")))))
              )


          (make-codegen
           rv2
           (fold (lambda (name env) (cgenenv-add name rv2 env)) cgenenv-empty out)
           (append
            
            (cond ((function? fd)
                   (list (function->expr name fd)))
                  ((prim? fd)
                   (list (prim->expr name fd) ))
                  (else '()))

            (cond ((function? fd)
                   (if (null? (function-formals fd))
                       (list (B:Val rv2 (V:Rec `((,name ,(V:Var name))))))
                       (list (B:Val rv1 (V:Op name (map (lambda (s) (select-signal 'sf s env)) in)))
                             (B:Val rv2 (V:Rec `((,name ,(V:Var rv1))))))))

                  ((prim? fd)

                     (codegen-state
                      (append
                       (list (prim->init init-name fd))
                       (codegen-state)))

                     (list (B:Val rv1 (V:Op name (append
                                                  (map (lambda (s) (select-signal 'sf s env)) in)
                                                  (map (lambda (x) (V:Sel x (V:Var init-name))) 
                                                       (lset-difference eq? states in)))))
                           (B:Val rv2 (V:Rec (map (lambda (s) `(,s ,(V:Sel s (V:Var rv1)))) outputs)))
                           )
                     )
                  
                  (else '())
                  )
            ))
          ))
      ;; signature
      `(SF ,name ,states ,outputs ,events)
      ;; children
      `(SF)
      ;; relations
      `()
      ))
     ))
  



(define (sf-pure  f . rest)
  (let-optionals rest ((name (gensym 'sf)))
    (let* ((f0   (cond ((function? f)  (lambda () `(,name ,(function-formals f) ,(function-body f))))
                       ((procedure? f) f)
                       (else (error 'sf-pure "invalid function" f))))
           (f1 (if (function? f) (extend-procedure f0 f) f0)))
      (sf f1 name))))


(define (sf-prim f name)
  (let* ((f0   (cond ((prim? f)  (lambda () `(,name ,(append (prim-formals f) (prim-states f)) ,(prim-body f))))
                     (else (error 'sf-prim "invalid primitive" f))))
         (f1 (if (prim? f) (extend-procedure f0 f) f0)))
    (sf f1 name)))


(define (sf-relation r sf)

  (define (relation-vars r) (function-formals (caddr r)))

  (define (relations-inputs sf)
    (let recur ((sf sf) (inputs '()))
      (let ((inputs (append
                     (concatenate (map relation-vars (sfarrow-relations sf))) 
                     inputs)))
        (let ((sf-children (filter-map sfarrow? (sfarrow-sig sf))))
          (if (null? sf-children) inputs
              (fold recur inputs sf-children)
              )))))

  (if (relation? r)

      (let* ((dfe (sfarrow-dfe sf))
             (dfe1 (make-dfe (dfe-gen dfe) (dfe-kill dfe)
                             (lambda (s) (delete-duplicates
                                          (lset-difference eq? 
                                              (append ((dfe-in dfe) s) 
                                                      (relations-inputs sf))
                                              (relation-vars r))))
                             (dfe-out dfe))))
        (make-sfarrow dfe1 
                      (sfarrow-codegen sf) 
                      (sfarrow-sig sf) (sfarrow-children sf)
                      (cons r (sfarrow-relations sf))))

      (error 'sf-relation "invalid relation" r)))


(define (relations-codegen sf env)

  (let ((kons (map (lambda (x) (car x)) (sfarrow-relations sf))))

    (codegen-state
     (append (codegen-state)
             (reverse 
              (map
               (lambda (r k)
                 (let ((name (car r)) 
                       (fd (caddr r)))
                   (function->expr k fd)))
               (sfarrow-relations sf) kons))
             ))
    '()
    ))




;; We now define the rest of the basic signal functions:
(define (sf-identity f)
   (let* ((fe       (sfarrow-dfe f))
          (fe-in    (dfe-in fe))          
          (fe-out   (dfe-out fe))
          (fe-gen   (dfe-gen fe))
          (fe-kill  (dfe-kill fe))
          )

     (make-sfarrow

      ;; dataflow equations
      (make-dfe
       ;; gen
       (lambda (s) (fe-gen s))
       
       ;; kill
       (lambda (s) (fe-kill s))
       
       ;; in
       (lambda (s) (fe-in s))
       
       ;; out
       (lambda (s) (fe-out s)))

      ;; codegen
      (lambda (s env dfe) 
        (let* (
               (rv (gensym 'identity))
               (fenv (list->cgenenv 'identity (fe-in s) env))
               (fcodegen ((sfarrow-codegen f) (fe-in s) fenv fe))
               )
          (make-codegen rv 
                        (fold (lambda (name env) (cgenenv-add name rv env)) cgenenv-empty (fe-out s))
                        (append (relations-codegen f env) 
                                (codegen-expr fcodegen)
                                (list (B:Val rv (V:Rec (map (lambda (s) `(,s ,(select-signal 'identity s (codegen-renv fcodegen)))) (fe-out s)))))
                                ))
                                
          ))
      ;; signature
      `(IDENTITY ,(sfarrow-sig f))
      ;; children
      `(IDENTITY ,f)
      ;; relations
      (sfarrow-relations f))
     ))



;; [union f g], applies [f] and [g] to the input signal in parallel.

(define (sf-union f g)

  (define (flatten-union u)
    (let ((uc (sfarrow-children u)))
      (case (car uc)
        ((UNION)  (append (flatten-union (cadr uc))
                          (flatten-union (caddr uc))))
        (else     (list u)))))
    

   (let* ((fe      (sfarrow-dfe f))
          (ge      (sfarrow-dfe g))

          (fe-in   (dfe-in fe))   
          (fe-out  (compose (dfe-out fe) fe-in))
          (fe-gen  (compose (dfe-gen fe) fe-in))
          (fe-kill (compose (dfe-kill fe) fe-in))

          (ge-in   (dfe-in ge))
          (ge-out  (compose (dfe-out ge) ge-in))
          (ge-gen  (compose (dfe-gen ge) ge-in))
          (ge-kill (compose (dfe-gen ge) ge-in))
          
          (flst (flatten-union f))
          (glst (flatten-union g))
          )

     (make-sfarrow

      ;; dataflow equations
      (make-dfe
       ;; gen
       (lambda (s) (lset-union eq? (ge-gen s) (fe-gen s)))
       
       ;; kill
       (lambda (s) (lset-union eq? (fe-kill s) (ge-kill s)))
       
       ;; in
       (lambda (s) (lset-union eq? (ge-in s) (fe-in s)))
       
       ;; out
       (lambda (s) (lset-union eq? (ge-out s) (fe-out s)))
       
       )

      ;; codegen
      (lambda (s env dfe) 
        (let* (
               (fgx      (lset-intersection eq? (fe-gen s) (ge-gen s)))
               
               (codegen (lambda (sf)
                          (let ((codegen (sfarrow-codegen sf))
                                (dfe (sfarrow-dfe sf)))
                            (let ((env (list->cgenenv 'union1 ((dfe-in dfe) s) env)))
                              (codegen ((dfe-in dfe) s) env dfe)))))

               (fld  (lambda (codegen dfe)
                       (let ((renv (codegen-renv codegen)))
                         (map (lambda (x) (list x (select-signal 'union2 x renv)))
                              ((dfe-out dfe) s)))))
               
               )

          (if (not (null? fgx)) (error 'sf-union "union arguments output overlapping signals" fgx))

          (let ((rv (gensym 'union))
                (fcodegen-lst (map codegen flst))
                (gcodegen-lst (map codegen glst))
                )

              (let* ((renv-lst (map codegen-renv (append fcodegen-lst gcodegen-lst)))
                     (expr-lst (map codegen-expr (append fcodegen-lst gcodegen-lst)))
                     (renv (list->cgenenv 'union3 ((dfe-out dfe) s)
                                (let recur ((renv-lst renv-lst) (env '()))
                                  (if (null? renv-lst) env
                                      (recur (cdr renv-lst) (cgenenv-union (car renv-lst) env)))))))

                (make-codegen 

                 rv
                 
                 (fold (lambda (name env) (cgenenv-add name rv env)) cgenenv-empty (map car renv))
                 
                 (let ((fflds  (map fld fcodegen-lst (map sfarrow-dfe flst)))
                       (gflds  (map fld gcodegen-lst (map sfarrow-dfe glst))))
                   (append 
                    (concatenate (map (lambda (f) (relations-codegen f env)) (append flst glst)))
                    (concatenate expr-lst)
                    (list (B:Val rv (V:Rec (map (lambda (s) `(,s ,(select-signal 'union4 s renv))) (map car renv)))))
                    ))
               
               )))
            ))
      ;; signature
      `(UNION ,(sfarrow-sig f) ,(sfarrow-sig g))
      ;; children
      `(UNION  ,f ,g)
      ;; relations
      (append (sfarrow-relations f) (sfarrow-relations g))
      ))
)


;; The [sequence] combinator composes two signal functions:

(define (sf-sequence f g)
   (let* ((fe      (sfarrow-dfe f))
          (ge      (sfarrow-dfe g))

          (fe-in   (dfe-in fe))   
          (fe-out  (compose (dfe-out fe) fe-in))
          (fe-gen  (compose (dfe-gen fe) fe-in))
          (fe-kill (compose (dfe-kill fe) fe-in))

          (ge-in   (compose (dfe-in ge) (lambda (s) (lset-union eq? (fe-out s) s))))
          (ge-out  (compose (dfe-out ge) ge-in))
          (ge-gen  (compose (dfe-gen ge) ge-in))
          (ge-kill (compose (dfe-gen ge) ge-in))

          )

     (make-sfarrow
      
      ;; dataflow equations
      (make-dfe
       ;; gen
       (lambda (s) (lset-union eq? (fe-gen s) (ge-gen s)))
       
       ;; kill
       (lambda (s) (lset-union eq? ((dfe-kill fe) s) ((dfe-kill ge) s)))
       
       ;; in
       (lambda (s)  (lset-union eq? (fe-in s) 
                                (lset-difference eq? (ge-in s)
                                                 (fe-out s))))
       
       ;; out
       (lambda (s) 
         (lset-union eq? (fe-out s) (ge-out s)))
       
       )

      ;; codegen
      (lambda (s env dfe) 
        (let* (
               
               (fenv (list->cgenenv 'sequence11 (fe-in s) env))
               (fcodegen ((sfarrow-codegen f) (fe-in s) fenv fe))

               (genv (list->cgenenv 'sequence12 (lset-difference eq? (ge-in s) (fe-out s)) env))
               (genv (fold (lambda (s env) 
                             (let ((v (cgenenv-find 'sequence1 s (codegen-renv fcodegen))))
                               (cgenenv-add s v env)))
                           genv (fe-out s)))
               (gcodegen ((sfarrow-codegen g) (ge-in s) genv ge))
               
               (fld  (lambda (codegen)
                       (let ((renv (codegen-renv codegen)))
                         (lambda (x) 
                           (list x (select-signal 'sequence2 x renv))))))
               
               (rv  (gensym 'sequence))
               )
  
          (make-codegen
           rv
           (fold (lambda (name env) (cgenenv-add name rv env)) cgenenv-empty ((dfe-out dfe) s))
           (append 
            (relations-codegen f env)
            (relations-codegen g env)
            (codegen-expr fcodegen)
            (codegen-expr gcodegen)
            (list (B:Val rv (V:Rec (append (map (fld fcodegen) (lset-difference eq? (fe-out s) (ge-out s)))
                                           (map (fld gcodegen) (ge-out s))))))))
          ))
      ;; signature
      `(SEQUENCE ,(sfarrow-sig f) ,(sfarrow-sig g))
      ;; children
      `(SEQUENCE ,f ,g)
      ;; relations
      (append (sfarrow-relations f) (sfarrow-relations g))
      )))


;; [sense s f], applies [f] to the signal named [sn] sent to the
;; resulting signal function:

(define (sf-sense sns f)

  (let* ((pred    (lambda (s) (member (signal-name s) sns)))
         (fe      (sfarrow-dfe f)))

    (make-sfarrow

     ;; dataflow equations
     (make-dfe
      ;; gen
      (lambda (s) ((dfe-gen fe) s))
      
      ;; kill
      (lambda (s) ((dfe-kill fe) s))
      
      ;; in
      (lambda (s) sns)
      
      ;; out
      (lambda (s) ((dfe-out fe) s))
      )

     ;; codegen
     (lambda (s env dfe) 
       (let* (
              (fenv      (list->cgenenv 'sense11 ((dfe-in dfe) s) env))
              (fcodegen  ((sfarrow-codegen f) ((dfe-in dfe) s) fenv (sfarrow-dfe f)))
              )
         (make-codegen 
          (codegen-rv fcodegen)
          (codegen-renv fcodegen)
          (append (relations-codegen f env) (codegen-expr fcodegen))
          )))
     ;; signature
     `(SENSE ,sns ,(sfarrow-sig f))
     ;; children
     `(SENSE ,f)
     ;; relations
     (sfarrow-relations f)
  )))

;; [actuate s f]

(define (sf-actuate sns f)

  (let* ((fe (sfarrow-dfe f))
         
         (fe-in   (dfe-in fe))    
         (fe-out  (compose (dfe-out fe) fe-in))
         (fe-gen  (compose (dfe-gen fe) fe-in))
         (fe-kill (compose (dfe-kill fe) fe-in)))

    (make-sfarrow
     
     ;; dataflow equations
     (make-dfe
      ;; gen
      (lambda (s) (lset-union eq? sns (fe-gen s)))
      
      ;; kill
      (lambda (s) (lset-union eq? (fe-kill s)
                              (lset-intersection eq? s sns)))
      
      ;; in
      (lambda (s) (fe-in s))
      
      ;; out
      (lambda (s) sns)
      )

     ;; codegen
     (lambda (s env dfe) 

       (let* (
              (fenv      (list->cgenenv 'actuate11 (fe-in s) env))
              (fcodegen  ((sfarrow-codegen f) (fe-in s) fenv (sfarrow-dfe f)))
              (rv        (gensym 'actuate))
              (renv      (codegen-renv fcodegen))
              (fldr      (lambda (n n1) 
                           (list n (select-signal 'actuate n1 renv))))
              )

         (let ((r 
                (make-codegen
                 rv
                 (cgenenv-union (codegen-renv fcodegen)
                                (map (lambda (s) (cons s rv)) sns))
                 (append 
                  (relations-codegen f env)
                  (codegen-expr fcodegen)
                         (list (B:Val rv (V:Rec (map fldr sns (fe-out s)))))))))
           r)
         ))
     ;; signature
     `(ACTUATE ,sns ,(sfarrow-sig f))
     ;; children
     `(ACTUATE ,f)
     ;; relations
     (sfarrow-relations f)
     )))


;; [reduce f init]

(define (sf-reduce f name init)

  (define (step name input inax outax env)
    (B:Val outax (V:Op name (list (select-signal 'reduce input env)
                                  (V:Var inax)))))

  (if (not (function? f))
      (error 'sf-reduce "argument f not a pure function: " f))

     (make-sfarrow 
      ;; dataflow equations
      (make-dfe
       ;; gen
       (lambda (s) (list name))
       ;; kill
       (lambda (s) s)
       ;; in
       (lambda (s) s)
       ;; out
       (lambda (s) (list name)))

      ;; codegen
      (lambda (s env dfe) 

        (let ((in   (lset-difference eq? ((dfe-in dfe) s) (list init ))))

          (if (null? in) (error 'sf-reduce "empty input: " in))

            (let recur ((inax    init)
                        (rv      (gensym 'ax))
                        (inputs  in)
                        (decls   '()))


              (if (null? inputs)

                  (let ((rvf (gensym 'reduce)))
                    (make-codegen
                     rvf
                     (cgenenv-add name rvf cgenenv-empty)
                     (append 
                      (list (function->expr name f)) 
                      (reverse decls)
                      (list (B:Val rvf (V:Rec `((,name ,(V:Var inax)))))))
                     ))

                  (recur rv (gensym 'ax) 
                         (cdr inputs)
                         (cons (step name (car inputs) inax rv env) decls))
                  ))
            ))

      ;; signature
      `(REDUCE ,f ,init ,name)
      ;; children
      `(REDUCE)
      ;; relations
      `()

      ))



;; Recurring state transitions

(define (sf-rtransition0 f fk e ek state)

  (let* ((fe      (sfarrow-dfe f))
         (fke     (sfarrow-dfe fk))
         
         (fe-in   (dfe-in fe))
         (fe-out  (compose (dfe-out fe)  fe-in))
         (fe-gen  (compose (dfe-gen fe)  fe-in))
         (fe-kill (compose (dfe-kill fe) fe-in))
         
         (fke-in   (dfe-in fke))
         (fke-out  (compose (dfe-out fke) fke-in))
         (fke-gen  (compose (dfe-gen fke) fke-in))
         (fke-kill (compose (dfe-gen fke) fke-in))

         (fintegrals (integrals f))
         (fkintegrals (integrals fk))
         )
    
    (for-each (lambda (x) (let ((evs (dynvector-ref integral-events x)))
                            (dynvector-set! integral-events x (cons e evs))))
              (map car fintegrals))
    (for-each (lambda (x) (let ((evs (dynvector-ref integral-events x)))
                            (dynvector-set! integral-events x (cons ek evs))))
              (map car fkintegrals))

    (make-sfarrow
     
     ;; dataflow equations
     (make-dfe
      
      ;; gen
      (lambda (s) (lset-union eq? (list state)
                              (lset-union eq? (fe-gen s) (fke-gen s))))
      
      ;; kill
      (lambda (s) (lset-union eq? (list state)
                              (lset-union eq? (fe-kill s) (fke-kill s))))
      
      ;; in
      (lambda (s) (lset-union eq? (list state)
                              (lset-union eq? (fe-in s) (fke-in s)
                                          (cond ((symbol? ek) (list e ek))
                                                (else (list e))))))
      
      ;; out
      (lambda (s) (lset-union eq? (list state)
                              (lset-union eq? (fe-out s) (fke-out s))))
      )
     
     ;; codegen
     (lambda (s env dfe) 
       (let* (
              (stm        (gensym 'trstm))
              (rv         (gensym 'trv))
              (blender    (gensym 'blender))
              
              (blender-inputs     ((dfe-in dfe) s))
              (blender-env        (map (lambda (s) (cons s s)) blender-inputs))

              (blender-outputs    (lset-intersection eq? (fe-out s) (fke-out s)))
              (blender-return     (lambda (kons codegen)
                                    (let ((renv (codegen-renv codegen)))
                                      (E:Ret (V:Op kons 
                                                   (list (V:Rec (map (lambda (p) 
                                                                       (list (car p) (V:Sel (car p) (V:Var (cdr p))))) 
                                                                     renv))))))))

              
              (fenv   (list->cgenenv 'rtransition11 (fe-in s) blender-env))
              (fkenv  (list->cgenenv 'rtransition12 (fke-in s) blender-env))
              
              (fcodegen  ((sfarrow-codegen f)  
                          (lset-union eq? (fe-in s)
                                      (cond ((symbol? ek) (list e ek))
                                            (else (list e))))
                          fenv (sfarrow-dfe f)))
              (fkcodegen ((sfarrow-codegen fk) 
                          (lset-union eq? (fke-in s)
                                      (cond ((symbol? ek) (list e ek))
                                            (else (list e))))
                          fkenv (sfarrow-dfe fk)))
              
              (ftrans  (lset-union eq? (lset-intersection eq? (fe-out s) (fke-in s))
                                   (list e)))
              (fktrans (lset-union eq? (lset-intersection eq? (fke-out s) (fe-in s))
                                   (cond ((symbol? ek) (list ek))
                                         (else (list)))))
              
              (fblend   (lambda (state x)
                          (V:Op 'tsCase 
                                  (list (V:Fn '(x) 
                                              (E:Ret (V:Rec (cons
                                                             (list state (V:Var state))
                                                             (append
                                                              (map (lambda (s) (list s (V:Sel s (V:Var 'x))))
                                                                   blender-outputs)
                                                              (map (lambda (s) (list s (V:Var s)))
                                                                   (lset-difference eq? 
                                                                                    (lset-union eq? ftrans fktrans)
                                                                                    blender-outputs)))))))
                                        
                                        (V:Fn '(x) 
                                              (E:Ret (V:Rec (cons
                                                             (list state (V:Var state))
                                                             (append
                                                              (map (lambda (s) (list s (V:Sel s (V:Var 'x))))
                                                                   blender-outputs)
                                                              (map (lambda (s) (list s (V:Var s)))
                                                                   (lset-difference eq?
                                                                                    (lset-union eq? ftrans fktrans)
                                                                                    blender-outputs)))))))
                                        
                                        
                                        (V:Var x)))))
              
              (fkblend    (lambda (state x) 
                            (V:Op 'tsCase 
                                    (list (V:Fn '(x) 
                                                (E:Ret (V:Rec (cons
                                                               (list state (V:Var state))
                                                               (append
                                                                (map (lambda (s) (list s (V:Sel s (V:Var 'x))))
                                                                    blender-outputs)
                                                                (map (lambda (s) (list s (V:Sel s (V:Var 'x))))
                                                                     (lset-difference eq? 
                                                                                      ftrans 
                                                                                      blender-outputs))
                                                                (map (lambda (s) (list s (V:Var s)))
                                                                     (lset-difference eq? 
                                                                                      fktrans
                                                                                      blender-outputs)))))))
                                          
                                          (V:Fn '(x) 
                                                (E:Ret (V:Rec (cons
                                                               (list state (V:Var state))
                                                               (append
                                                                (map (lambda (s) (list s (V:Sel s (V:Var 'x))))
                                                                     blender-outputs)
                                                                (map (lambda (s) (list s (V:Sel s (V:Var 'x))))
                                                                     (lset-difference eq? 
                                                                                      fktrans 
                                                                                      blender-outputs))
                                                                (map (lambda (s) (list s (V:Var s)))
                                                                     (lset-difference eq? 
                                                                                      ftrans
                                                                                      blender-outputs)))))))
                                          
                                          
                                          (V:Var x)))))
              
              )
         
         (if (null? (lset-intersection eq? (fe-out s) (fke-out s)))
             (error 'sf-rtransition "the outputs of argument functions f and fk must have a non-empty intersection"
                    (sfarrow-sig f) 
                    (sfarrow-sig fk)))
         
         (codegen-state
          (append
           (reverse
            (list

             (B:Val stm
                    (V:Op 'TRC
                          (list 
                            (V:Fn blender-inputs
                                  (E:Let (append
                                          (relations-codegen f env)
                                          (codegen-expr fcodegen))
                                         (blender-return 'TRSA fcodegen)))
                            (V:Fn blender-inputs
                                  (E:Let (append 
                                          (relations-codegen fk env)
                                          (codegen-expr fkcodegen))
                                         (blender-return 'TRSB fkcodegen)))
                            (V:Fn (list 'x) (E:Ret (V:Op 'tsCase 
                                                         (list (V:Fn '(x) 
                                                                     (E:Ret (V:Sel e (V:Var 'x))
                                                                            ))
                                                               (cond ((symbol? ek)  
                                                                      (V:Fn '(x) (E:Ret (V:Sel ek (V:Var 'x)))))
                                                                     (ek    (V:Fn '(x) (E:Ret (V:C 'true))))
                                                                     (else  (V:Fn '(x) (E:Ret (V:C 'false)))))
                                                               (V:Var 'x)))))
                           )))
             
             (B:Val blender
                    (V:Fn (cons stm blender-inputs)
                          (E:Let `(
                                   ,(B:Val 'f     (V:Op 'trfOf (list (V:Var stm))))
                                   ,(B:Val 'fk    (V:Op 'trfkOf (list (V:Var stm))))
                                   ,(B:Val 'e     (V:Op 'treOf (list (V:Var stm))))
                                   ,(B:Val 'fv    (V:Ifv (V:Var state) (V:Op 'fk (map V:Var blender-inputs)) (V:Op 'f (map V:Var blender-inputs))))
                                   ,(B:Val 'trp   (V:Op 'e (list (V:Var 'fv))))
                                   ,(B:Val state  (V:Ifv (V:Var 'trp) (V:Op 'not (list (V:Var state))) (V:Var state)))
                                   )
                                 (E:Ife (V:Op 'not (list (V:Var 'trp)))
                                        (E:Ret
                                         (V:Ifv (V:Var state) (fkblend state 'fv) (fblend state 'fv)))
                                        (E:Ife (V:Var state)
                                               (E:Ret (fkblend state 'fv))
                                               (E:Ret (fblend state 'fv)))
                                        )
                                 ))
                    ))
            )
           (codegen-state)))
         
         (make-codegen
          rv

          (fold (lambda (s ax) (cgenenv-add s rv ax))
                cgenenv-empty (cons state blender-outputs))

          (list
           (B:Val rv
                  (V:Op blender (cons (V:Var stm)
                                      (map (lambda (s) (V:Sel s (V:Var (cgenenv-find 'rtransition22 s env)))) 
                                           blender-inputs))))
           ))
         ))

     ;; signature
     `(RTRANSITION ,(sfarrow-sig f) ,(sfarrow-sig fk) ,e ,ek ,state)

     ;; children
     `(RTRANSITION ,f ,fk)

     ;; relations
     (append (sfarrow-relations f) (sfarrow-relations fk))

     ))
)

(define (sf-rtransition f fk e ek s)
  (sf-rtransition0 f fk e ek s))

;; One-time state transition

(define (sf-transition f fk ev s)
  (sf-rtransition0 f fk ev #f s))


;; Transient events
(define (sf-transient f g e)

  (let* ((fe      (sfarrow-dfe f))
         (ge      (sfarrow-dfe g))
         
         (fe-in   (dfe-in fe))
         (fe-out  (compose (dfe-out fe) fe-in))
         (fe-gen  (compose (dfe-gen fe) fe-in))
         (fe-kill (compose (dfe-kill fe) fe-in))
         
         (ge-in   (dfe-in ge))
         (ge-out  (compose (dfe-out ge) ge-in))
         (ge-gen  (compose (dfe-gen ge) ge-in))
         (ge-kill (compose (dfe-gen ge) ge-in))

         (fintegrals (integrals f))
         (gintegrals (integrals g))
         )

    (for-each (lambda (x)
                (let ((evs (dynvector-ref integral-events x)))
                  (dynvector-set! integral-events x (cons e evs))))
              (map car fintegrals))

    (make-sfarrow
     
     ;; dataflow equations
     (make-dfe
      ;; gen
      (lambda (s) (lset-union eq? (fe-gen s) (ge-gen s)))
      
      ;; kill
      (lambda (s) (lset-union eq? (fe-kill s) (fe-kill s)))
               
      ;; in
      (lambda (s)  (lset-union eq?
                               (lset-union eq? (fe-in s) (ge-in s))
                               (list e)))
      ;; out
      (lambda (s) 
        (lset-intersection eq? (fe-out s) (ge-out s)))
      
      )
     
     ;; codegen
     (lambda (s env dfe) 

       (if (null? (lset-intersection eq? (fe-out s) (ge-out s)))
           (error 'sf-transient "the outputs of argument functions f and g must have a non-empty intersection"
                  (sfarrow-sig f) 
                  (sfarrow-sig g)))
         
       
       (let* (

              (rv  (gensym 'transient))

              (fcompute  (gensym 'transientf))
              (gcompute  (gensym 'transientg))

              (fenv      (map (lambda (s) (cons s s)) (fe-in s)))
              (fcodegen ((sfarrow-codegen f) 
                         (lset-union eq? (fe-in s) (list e))
                         fenv fe))

              (genv      (map (lambda (s) (cons s s)) (ge-in s)))
              (gcodegen ((sfarrow-codegen g) 
                         (lset-union eq? (ge-in s) (list e))
                         genv ge))

              )

         (codegen-state
          (append
           (list
            
            (B:Val fcompute
                   (V:Fn (fe-in s) 
                         (E:Let
                          (append (relations-codegen f env)
                                  (codegen-expr fcodegen))
                          (E:Ret (V:Rec (map (lambda (x) (list x (select-signal '(transient fcompute) x (codegen-renv fcodegen))))
                                             ((dfe-out dfe) s))))
                          )))
                   
            (B:Val gcompute
                   (V:Fn (ge-in s) 
                         (E:Let
                          (append (relations-codegen g env)
                                  (codegen-expr gcodegen))
                          (E:Ret (V:Rec (map (lambda (x) (list x (select-signal '(transient gcompute) x (codegen-renv gcodegen))))
                                             ((dfe-out dfe) s))))
                          )))
                   
            )
           
           (codegen-state)))
         
         (make-codegen
          rv

          (list->cgenenv '(transient renv)
                         ((dfe-out dfe) s)
                         (fold (lambda (s env) (cgenenv-add s rv env)) cgenenv-empty ((dfe-out dfe) s)))
          
           (list
            (B:Val rv
                   (V:Ifv (select-signal '(transient rv) e env)
                          (V:Op gcompute (map (lambda (x) (select-signal '(transient state-compute) x env)) 
                                              (ge-in s)))
                          (V:Op fcompute (map (lambda (x) (select-signal '(transient state-compute) x env)) 
                                              (fe-in s)))
                          ))
           ))
         ))

     ;; signature
     `(TRANSIENT ,(sfarrow-sig f) ,(sfarrow-sig g) ,e)

     ;; children
     `(TRANSIENT ,f ,g)

     ;; relations
     (append (sfarrow-relations f) (sfarrow-relations g))

     ))
)



(define integral-index (make-parameter 0))
(define integral-events (make-dynvector 0 '()))


(define (sf-integral0 x ys h fs)

  (let* ((xn     (gensym (string->symbol (s+ x "+h"))))
         (yis    (list-tabulate (length ys)  (lambda (i) i)))
         (yns    (map (lambda (y) (gensym (string->symbol (s+ y "(" xn ")")))) ys))
         (ynvs   (map (lambda (yn) (gensym (string->symbol (s+ yn "v")))) yns))
         (yps    (map (lambda (y) (gensym (string->symbol (s+ y "prime")))) ys))
         (idx    (let ((v (integral-index)))
                   (integral-index (+ 1 (integral-index)))
                   v))
         )

    (let (
          (fs-formals (map function-formals fs))
          )

      (make-sfarrow
       
       ;; dataflow equations
       (make-dfe

        ;; gen
        (lambda (s) yns)
        
        ;; kill
        (lambda (s) (lset-union eq? s (list xn)))
        
        ;; in
        (lambda (s) (lset-union eq?
                      (dynvector-ref integral-events idx)
                      (lset-union eq? 
                        (concatenate fs-formals)
                        (append (if (symbol? h) (list h) '())
                                (cons x ys)))))
        
        ;; out
        (lambda (s) yns)
        )
       
       ;; codegen
       (let (
             (rv1 (gensym 'integral))
             (rv2 (gensym 'integral))
             (dfn (gensym 'dfn))
             )
             
         (lambda (s env dfe)

           (let* (
                  (events    (dynvector-ref integral-events idx))
                  
                  (idxv      (V:C idx))

                  (tstep     (if (symbol? h) 
                                 (select-signal 'integral1 h env)
                                 (V:C h)))
                  
                  (fenv      (list->cgenenv 'integral2 (concatenate fs-formals)
                                            (cgenenv-add x x (fold (lambda (y env) (cgenenv-add y y env)) env ys))))

                  (fargs     (map (lambda (ss) (map (lambda (s) (select-signal 'integral3 s fenv)) ss)) fs-formals))
                  )

             (make-codegen

              rv2
              
              (map (lambda (s) (cons s rv2)) yns)

              (append

               (map function->expr yps fs)

               (list 

                (B:Val dfn 
                       (V:Fn `(,x yvec) 
                             (E:Let (map (lambda (y i) (B:Val y (V:Sub i (V:Var 'yvec)))) ys yis)
                                    (E:Ret (V:Vec (map (lambda (yprime farg) (V:Op yprime farg)) yps fargs)))
                                    )))

                (B:Val rv1 
                       (V:Op 'integrate
                             (list (V:Var dfn) 
                                   (select-signal 'integral4 x env) 
                                   (V:Vec (map (lambda (y) (select-signal 'integral5 y env)) ys))
                                   tstep
                                   idxv
                                   )))


                (B:Val rv2     (V:Rec (map (lambda (yn yi) `(,yn ,(V:Sub yi (V:Var rv1)) )) yns yis)) )
                )
               ))
             ))
         )

       ;; signature
       `(INTEGRAL ,idx ,x ,ys)

       ;; children
       `(INTEGRAL)

       ;; relations
       `()

       ))
      ))
  


(define (sf-integralh x y h f)
  (sf-integral0 x y h f))

(define (sf-integral x y f)
  (sf-integral0 x y 1e-3 f))


(define (construct d)
  (integral-index 0)
  (dynvector-clear! integral-events 0)
  (construct1 d))

(define (construct1 d)
  (cases diagram d
         (IDENTITY (f)             (sf-identity (construct1 f)))
         (PURE (f)                 (sf-pure f))
         (PRIM (f name)            (sf-prim f name))
         (RELATION (r f)           (sf-relation r (construct1 f)))
         (SEQUENCE (f g)           (sf-sequence (construct1 f) (construct1 g)))
         (UNION (f g)              (sf-union (construct1 f) (construct1 g)))
         (SENSE (s f)              (sf-sense s (construct1 f)))
         (ACTUATE (s f)            (sf-actuate s (construct1 f)))
         (REDUCE (f n i)           (sf-reduce f n i))
         (RTRANSITION (f g ef eg s)  (sf-rtransition (construct1 f) (construct1 g) ef eg s))
         (TRANSITION (f g ef s)      (sf-transition (construct1 f) (construct1 g) ef s))
         (TRANSIENT (f g e)          (sf-transient (construct1 f) (construct1 g) e))
         (INTEGRAL  (x ys fs)        (sf-integral x ys fs))
         (INTEGRALH (x ys h fs)      (sf-integralh x ys h fs))
         ))


(define (dataflow f input)
  (let ((dfe (sfarrow-dfe f)))
    `((gen  . ,((dfe-gen dfe) input))
      (kill . ,((dfe-kill dfe) input))
      (in   . ,((dfe-in dfe) input))
      (out  . ,((dfe-out dfe) input)))))


(define (events f)
  (let recur ((f f) (ax '()))
    (let ((sig (sfarrow-sig f)))
      (case (car sig)
        ((RTRANSITION)
         (let ((ef (fourth sig)) (eg (fifth sig)))
           (let* ((ax1 (cons ef ax))
                  (ax2 (if (symbol? eg)  (cons eg ax1) ax1)))
             (fold recur ax2 (cdr (sfarrow-children f)))
             )))
        ((TRANSIENT)
         (let ((e (fourth sig)))
           (let* ((ax1 (cons e ax)))
             (fold recur ax1 (cdr (sfarrow-children f)))
             )))
        ((SF)
         (let ((evs (fifth sig)))
           (append evs ax)))
        (else (fold recur ax (cdr (sfarrow-children f))))
        ))
    ))


(define (integrals f)
  (let recur ((f f) (ax '()))
    (let ((sig (sfarrow-sig f)))
      (case (car sig)
        ((INTEGRAL)
           (let ((ax1 (cons (cdr sig) ax)))
             (fold recur ax1 (cdr (sfarrow-children f)))
             ))
        (else (fold recur ax (cdr (sfarrow-children f))))
        ))
    ))


(define (codegen/Octave name f #!key (initial #f) (pre #t) (solver #f))

  (if (and solver (not (member solver '(lsode rkfe rk3 rk4a rk4b rkhe rkbs rkf45))))
      (error 'codegen/Octave "unknown solver" solver))
  
  (let ((dfe (sfarrow-dfe f)))

    (codegen-state '())

    (let* ((input    (or (and initial (map car initial)) ((dfe-in dfe) '())))
           (fenv     (map (lambda (s) (cons s 'input)) input))
           (fcodegen ((sfarrow-codegen f) input fenv dfe ))
           (relations-expr (relations-codegen f input))
           (globals   (filter-map
                       (lambda (x) 
                         (cases binding x
                                (B:Val  (name v) (name/Octave name))
                                (else  #f)))
                       (codegen-state))))

      (if pre (print-fragments (prelude/Octave solver: solver)))
      (print-fragments (list "global " (intersperse globals " ") ";" nl))

      (print-fragments (list (map (lambda (x) 
                                    (if (binding? x)
                                        (cases binding x
                                               (B:Val  (name v) (list (name/Octave name) " = " (value->Octave v) ";" nl)))
                                        (expr->Octave x)))
                                  (reverse (codegen-state))) nl))

      (print-fragments
       (list
        "function " (name/Octave (codegen-rv fcodegen)) " = " (name/Octave name) " (input)" nl
        (list "global " (intersperse globals " ") ";" nl)
        (map (lambda (x) (list (name/Octave x) " = " (value->Octave (V:Sel x (V:Var 'input))) "; " nl)) input)
        nl
        (map binding->Octave (append relations-expr (codegen-expr fcodegen))) nl 
        "endfunction" nl))

      
      (if initial
              (print-fragments
               (list (name/Octave name) "_initial = " 
                     (value->Octave
                      (V:Rec (map (lambda (x) (let ((n (car x)) (v (cadr x)))
                                                (let ((v (cond ((and (or (number? v) (symbol? v))) v)
                                                               ((boolean? v) (if v 'true 'false))
                                                               (else v))))
                                                  (list n (V:C v)))))
                                  initial)))
                     nl))
              )


      )))

(define (codegen/scheme name f #!key (initial #f) (pre #t) (solver 'rk4b))

  (if (and solver (not (member solver '(cvode rkfe rk3 rk4a rk4b rkhe rkbs rkf45))))
      (error 'codegen/scheme "unknown solver" solver))

  (let ((dfe (sfarrow-dfe f)))

    (codegen-state '())

    (let* ((input    (or (and initial (map car initial)) ((dfe-in dfe) '())))
           (fenv     (map (lambda (s) (cons s 'input)) input))
           (fcodegen ((sfarrow-codegen f) input fenv dfe ))
           (relations-expr (relations-codegen f input)))

      (if pre (print-fragments (prelude/scheme solver: solver integral-index: (integral-index))))

      (print-fragments (list (map (lambda (x) 
                                    (if (binding? x)
                                        (cases binding x
                                               (B:Val  (name v)
                                                       (list "(define " (name/scheme name) " " (value->scheme v) ")" nl)))
                                        (expr->scheme x)))
                                  (reverse (codegen-state))) nl))

      (print-fragments
       (list
        "(define (" (name/scheme name) " input)" nl
        "(let (" (intersperse (map (lambda (x) (binding->scheme (B:Val x (V:Sel x (V:Var 'input))))) input) " ")  ")"  nl
        "(let* (" (map binding->scheme (append relations-expr (codegen-expr fcodegen))) nl ")" nl
        (codegen-rv fcodegen) nl
        ")))" nl))

      (if initial
          (print-fragments
           (list "(define " (name/scheme name) "_initial " 
                 (value->scheme
                  (V:Rec (map (lambda (x) (let ((n (car x)) (v (cadr x)))
                                            (let ((v (cond ((and (or (number? v) (symbol? v))) v)
                                                           ((boolean? v) (if v 'true 'false))
                                                           (else v))))
                                              (list n (V:C v)))))
                              initial))) ")" nl)))


      )))

(define (codegen/ML name f #!key (initial #f) (pre #t) (post #t) (solver 'rk4b))

  (if (and solver (not (member solver '(rkfe rk3 rk4a rk4b rkhe rkbs rkf45))))
      (error 'codegen/ML "unknown solver" solver))

  (let ((dfe (sfarrow-dfe f)))

    (codegen-state '())

    (let* ((input    (or (and initial (lset-intersection eq? (map car initial) ((dfe-in dfe) '())))
                         ((dfe-in dfe) '())))
           (fenv     (map (lambda (s) (cons s 'input)) input))
           (fcodegen ((sfarrow-codegen f) input fenv dfe ))
           (relations-expr (relations-codegen f input)))


      (if pre (print-fragments (prelude/ML solver: solver)))

      (print-fragments (list (map (lambda (x) 
                                    (if (binding? x)
                                        (cases binding x
                                               (B:Val  (name v)
                                                       (list "val " (name/ML name) " = " (value->ML v) nl)))
                                        (expr->ML x)))
                                  (reverse (codegen-state))) nl))


      (print-fragments
       (list
        "fun " (name/ML name) "(input as {" (intersperse (map name/ML input) ",")  "})" " = " nl
        "let" nl
        (map binding->ML (append relations-expr (codegen-expr fcodegen))) nl
        "in" nl
        (codegen-rv fcodegen)   nl
        "end" nl))

      (if initial
          (print-fragments
           (list "val " (name/ML name) "_initial = " 
                 (value->ML (V:Rec (map (lambda (x) 
                                          (let ((n x) (v (car (alist-ref x initial))))
                                            (list n 
                                                  (cond ((and (or (number? v) (symbol? v))) 
                                                         (V:C v))
                                                        ((boolean? v) 
                                                         (V:C (if v 'true 'false)))
                                                        (else (V:C v))))
                                                    ))
                                        input))) nl)))

      (if post (print-fragments (list "end" nl)))
      
      )))




)