;;
;;  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
;;
;; 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 RTRANSITION TRANSIENT ON

	 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
         prelude/Octave prelude/scheme prelude/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 (hspec? h)
  (and (list? h)
       (case (car h)
         ((variable fixed var fix) #t)
         (else #f))
       (symbol? (cadr h))))


(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?) (efd diagram?) 
                (eg symbol?) (egd diagram?)
		(s  symbol?)
		)
  (TRANSIENT    (f diagram?) (g diagram?) (e symbol?) (ef diagram?) )
  (ON           (f diagram?) (e symbol?) )
  (INTEGRAL     (i symbol?) 
                (d symbol-list?) (h hspec?)
		(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) (if (function? fd) 
                       (lset-intersection eq? (function-formals fd) 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 (error 'sf "unknown function object" fd)))

	    (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 (error 'sf "unknown function object" fd))
                  )
	    ))
          ))
      ;; 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
                                          (append ((dfe-in dfe) s) 
                                                  (relations-inputs sf))))
			     (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))
      )))


;; The [on] combinator takes the value of f when e is true, otherwise
;; it is equivalent to identity

(define (sf-on f e)

   (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) (fe-gen s))
       
       ;; kill
       (lambda (s) ((dfe-kill fe) s))
       
       ;; in
       (lambda (s)  (lset-union eq? (fe-in s) 
                                (lset-union eq? (fe-out s) (list e))))
       
       ;; out
       (lambda (s) (fe-out s))
       
       )

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

	       (fld  (lambda (codegen)
		       (let ((renv (codegen-renv codegen)))
			 (lambda (x) 
			   (list x (select-signal 'on2 x renv))))))
	       
	       (ev (select-signal 'on3 e env))

	       (rv  (gensym 'onrv))
	       (onf (gensym 'onf))
	       )

	  (make-codegen
	   rv
           (fold (lambda (name env) (cgenenv-add name rv env)) cgenenv-empty ((dfe-out dfe) s))
           (list 
            (B:Val onf (V:Fn (fe-in s) 
                             (E:Let (append
                                     (relations-codegen f env)
                                     (codegen-expr fcodegen))
                                    (E:Ret (V:Rec (delete-duplicates 
                                                   (cons (list e ev) (map (fld fcodegen) (fe-out s)))))))))
            (B:Val rv  (V:Ifv (V:Op '>= (list (select-signal 'on3 e env) (V:C 0.0)))
                              (V:Op onf (map (lambda (x) (select-signal 'on4 x env)) (fe-in s)))
                              (V:Rec (delete-duplicates
                                      (cons (list e ev) (map (lambda (x) (list x (select-signal 'on5 x env)))
                                                             ((dfe-out dfe) s)))))))
            ))
	  ))
      ;; signature
      `(ON ,(sfarrow-sig f) ,e)
      ;; children
      `(ON ,f)
      ;; relations
      (sfarrow-relations f)
      )))


;; [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-rtransition f fk e ef ek ekf 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))

	 (ee      (sfarrow-dfe ef))
	 (ee-in   (dfe-in ee))
	 (ee-out  (compose (dfe-out ee) ee-in))
	 (ee-gen  (compose (dfe-gen ee) ee-in))
	 (ee-kill (compose (dfe-gen ee) ee-in))

	 (eke      (sfarrow-dfe ekf))
	 (eke-in   (dfe-in eke))
	 (eke-out  (compose (dfe-out eke) eke-in))
	 (eke-gen  (compose (dfe-gen eke) eke-in))
	 (eke-kill (compose (dfe-gen eke) eke-in))

	 )

    (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) (delete-duplicates
                   (lset-union eq? 
                               (lset-union eq? (eke-in s) (ee-in 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 e ek)
                              (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-union eq? 
                                              (lset-union eq? (ee-out s) (eke-out s))
                                              (lset-intersection eq? 
                                                                 (lset-union eq? (fe-out s) )
                                                                 (lset-union eq? (fke-out s) ))))

	      (blender-return     (lambda (kons codegen e etest ee-in eother)
				    (let ((renv (codegen-renv codegen)))
				      (E:Ret (V:Op kons 
						   (list (V:Rec (append 
                                                                 (list (list eother (V:C -1.0))
                                                                       (list e (V:Op etest
                                                                                     (map (lambda (v) 
                                                                                            (if (assoc v renv) 
                                                                                                (select-signal '(etest blender) v renv)
                                                                                                (select-signal '(etest blender) v blender-env)))
                                                                                          (ee-in s)))))
                                                                 (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)))

	      (eenv      (map (lambda (s) (cons s s)) (ee-in s)))
              (ecodegen  ((sfarrow-codegen ef) (ee-in s) eenv ee))
	      (etest     (gensym 'etest))

	      (ekenv      (map (lambda (s) (cons s s)) (eke-in s)))

              (ekcodegen  ((sfarrow-codegen ekf) (eke-in s) ekenv eke))
	      (ektest     (gensym 'ektest))

	      (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)
                                          (list
                                           (B:Val etest
                                                  (V:Fn (ee-in s)
                                                        (E:Let
                                                         (codegen-expr ecodegen)
                                                         (E:Ret (V:Sel (car (ee-out s)) (V:Var (codegen-rv ecodegen)))))
                                                        ))
                                           ))
					 (blender-return 'TRSA fcodegen e etest ee-in ek)))
			    (V:Fn blender-inputs
				  (E:Let (append 
					  (relations-codegen fk env)
					  (codegen-expr fkcodegen)
                                          (list
                                           (B:Val ektest
                                                  (V:Fn (eke-in s)
                                                        (E:Let
                                                         (codegen-expr ekcodegen)
                                                         (E:Ret (V:Sel (car (eke-out s)) (V:Var (codegen-rv ekcodegen)))))
                                                        ))))
					 (blender-return 'TRSB fkcodegen ek ektest eke-in e)))
			    (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 '>= (list (V:Op 'e (list (V:Var 'fv))) (V:C 0.0))))
				   ,(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 ,(sfarrow-sig ef) ,ek ,(sfarrow-sig ekf) ,state)

     ;; children
     `(RTRANSITION ,f ,fk ,ef ,ekf)

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

     ))
)


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

  (let* (
         (fe      (sfarrow-dfe f))
	 (ge      (sfarrow-dfe g))
	 (ee      (sfarrow-dfe ef))
	 
	 (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))

	 (ee-in   (dfe-in ee))
	 (ee-out  (compose (dfe-out ee) ee-in))
	 (ee-gen  (compose (dfe-gen ee) ee-in))
	 (ee-kill (compose (dfe-gen ee) ee-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? (fe-kill s) (fe-kill s)))
    	       
      ;; in
      (lambda (s)  (lset-union eq?
			       (lset-union eq? (fe-in s) (ge-in s))
                               (lset-union eq? (ee-in s) (list e))))
      ;; out
      (lambda (s) (lset-union eq?
                              (list e)
                              (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* (

	      (rv1  (gensym 'transient))
	      (rv2  (gensym 'transient))
	      (rv3  (gensym 'transient))

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

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

	      (genv      (map (lambda (s) (cons s s)) (ge-in s)))
	      (gcodegen  ((sfarrow-codegen g) (ge-in s) genv ge))

	      (eenv      (map (lambda (s) (cons s s)) (ee-in s)))
              (ecodegen  ((sfarrow-codegen ef) (ee-in s) eenv ee))

	      )

	 (codegen-state
	  (append
	   (list

            (B:Val evtest
                   (V:Fn (ee-in s)
                         (E:Let
                          (codegen-expr ecodegen)
                          (E:Ret 
                           (V:Rec
                            `((,e ,(V:Sel (car (ee-out s)) (V:Var (codegen-rv ecodegen)) )) )) ))
                         ))
	    
	    (B:Val fcompute
		   (V:Fn (cons rv1 (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 
                                                                                (cgenenv-add e rv1 (codegen-renv fcodegen)))))
					     ((dfe-out dfe) s))))
			  )))
		   
	    (B:Val gcompute
		   (V:Fn (cons rv1 (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 
                                                                                (cgenenv-add e rv1 (codegen-renv gcodegen)))))
					     ((dfe-out dfe) s))))
			  )))
		   
	    )
	   
	   (codegen-state)))
    	 
	 (make-codegen

	  rv3

	  (list->cgenenv '(transient renv)
			 ((dfe-out dfe) s)
                         (cgenenv-add e rv2
                                      (fold (lambda (s env) (cgenenv-add s rv3 env)) cgenenv-empty ((dfe-out dfe) s))))
	  
	   (list

            (B:Val rv1 (V:Op evtest 
                             (map (lambda (v) (select-signal 'evtest v env))
                                  (ee-in s))))

	    (B:Val rv2 (V:Op fcompute
                             (cons (V:Var rv1)
                                   (map (lambda (x) (select-signal '(transient state-compute) x env)) 
                                        (fe-in s)))))


	    (B:Val rv3
		   (V:Ifv (V:Op '>= (list (V:Sel e (V:Var rv1)) (V:C 0.0))) 
			  (V:Op gcompute (cons (V:Var rv1)
                                               (map (lambda (x) (select-signal '(transient state-compute) x env)) 
                                                    (ge-in s))))
                          (V:Var rv2)
			  ))
            ))
         
         ))

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

     ;; children
     `(TRANSIENT ,f ,g ,ef)

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

     ))
)



(define integral-index (make-parameter 0))

(define (sf-integral x ys h fs ev)

  (let* ((varh   (case (car h) 
                   ((variable) #t)
                   (else #f)))
         (hname  (cadr h))
         (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))
         (e      (and ev (car ev)))
         (ef     (and ev (cadr ev)))

	 (ee      (and ef (sfarrow-dfe ef)))
	 (ee-in   (and ee (dfe-in ee)))
	 (ee-out  (and ee (compose (dfe-out ee) ee-in)))
	 (ee-gen  (and ee (compose (dfe-gen ee) ee-in)))
	 (ee-kill (and ee (compose (dfe-gen ee) ee-in)))

         )

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

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

	;; gen
	(lambda (s) (lset-union eq?
                               (or (and ee (ee-gen s)) '())
                               (if varh (cons hname (cons x yns))
                                   (cons x yns))))
	
	;; kill
	(lambda (s) (lset-union eq?
                               (or (and ee (ee-kill s)) '())
                               (lset-union eq? s (list xn))))
	
	;; in
	(lambda (s) 
          (let ((x (lset-union eq?
                               (or (and ee (ee-in s)) '())
                               (lset-union eq? 
                                           (concatenate fs-formals)
                                           (append (list hname) 
                                                   (cons x ys))))))
            x))
	
	;; out
	(lambda (s) (append (cons x yns)
                            (or (and varh (list hname)) '())
                            (or (and ee (ee-out s)) '())
                            ))
	)
       
       ;; codegen
       (let (
	     (rv1 (gensym 'integral))
	     (rv2 (gensym 'integral))
	     (dfn (gensym 'dfn))
	     )

	     
	 (lambda (s env dfe)

	   (let* ((evtest     (and ev (gensym 'evtest)))
                  (evcompute  (and ev (gensym 'evcompute)))
                  (evcodegen  (and ev ((sfarrow-codegen (cadr ev)) s env ee)))

		  (idxv      (V:C idx))

		  (tstep     (select-signal 'integral1 hname env))
		  
		  (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

	      ((lambda (env) (if varh (cons (cons hname rv2) env) env))
               (cons (cons x rv2) (map (lambda (s) (cons s rv2)) yns)))

	      (append

               (map function->expr* yps fs)
		   
               (if ev
                   (let ((evselect
                          (lambda (x) 
                            (let ((yi (list-index (lambda (y) (equal? x y)) ys)))
                              (if yi
                                  (V:Sub (list-ref yis yi) (V:Var 'yvec))
                                  (select-signal 'evselect x env))))))
                     
                     
                     (list
                      (B:Val evcompute
                             (V:Fn (ee-in s) 
                                   (E:Let
                                    (codegen-expr evcodegen)
                                    (E:Ret (V:Rec (map (lambda (x) 
                                                         (let ((v (select-signal '(integral evcompute) x (codegen-renv evcodegen)))) 
                                                           (list x v)))
                                                       (ee-out s))))
                                    )))
                      (B:Val evtest 
                             (V:Fn `(yvec) 
                                   (E:Ret (V:Sel e (V:Op evcompute (map evselect (ee-in s)))))
                                   ))
                      ))
                '())

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

               (if ev
                   
                   (list 
                    (B:Val rv1 
                           (V:Op 'eintegral
                                 (list (V:Var dfn) 
                                       (select-signal 'eintegral1 x env) 
                                       (V:Vec (map (lambda (y) (select-signal 'eintegral2 y env)) ys))
                                       (V:Var evtest)
                                       tstep
                                       idxv
                                       )))
                    )
                   
                   (list
                    (B:Val rv1 
                           (V:Op 'integral
                                 (list (V:Var dfn) 
                                       (select-signal 'integral4 x env) 
                                       (V:Vec (map (lambda (y) (select-signal 'integral5 y env)) ys))
                                       tstep
                                       idxv
                                       ))))
                   )
                

                (if varh

                    (let* ((ysn (gensym 'ysn))
                           (xn  (gensym 'xn))
                           (retflds (cons `(,hname ,(V:Sel 'h (V:Var rv1)))
                                          (cons `(,x ,(V:Var xn))
                                                (map (lambda (yn yi) `(,yn ,(V:Sub yi (V:Var ysn)))) 
                                                     yns yis)))))
                      (list
                       (B:Val ysn (V:Sel 'ysn (V:Var rv1)))
                       (B:Val xn  (V:Sel 'xn (V:Var rv1)))
                       (B:Val rv2 (V:Rec retflds))))

                    (let* ((ysn (gensym 'ysn))
                           (xn  (gensym 'xn))
                           (retflds (cons `(,x ,(V:Var xn))
                                          (map (lambda (yn yi) `(,yn ,(V:Sub yi (V:Var ysn)) )) yns yis))))

                      (list
                       (B:Val ysn (V:Sel 'ysn (V:Var rv1)))
                       (B:Val xn  (V:Sel 'xn  (V:Var rv1)))
                       (B:Val rv2 (V:Rec retflds)))))
                ))
             ))
         )

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

       ;; children
       `(INTEGRAL)

       ;; relations
       `()

       ))
      ))
  



(define (construct d)
  (integral-index 0)
  (construct1 d))


(define (construct1 d)
  (let recur ((d d) (ev #f))
    (cases diagram d
           (IDENTITY (f)               (sf-identity (recur f ev)))
           (PURE (f)                   (sf-pure f))
           (PRIM (f name)              (sf-prim f name))
           (RELATION (r f)             (sf-relation r (recur f ev)))
           (SEQUENCE (f g)             (sf-sequence (recur f ev) (recur g ev)))
           (UNION (f g)                (sf-union (recur f ev) (recur g ev)))
           (SENSE (s f)                (sf-sense s (recur f ev)))
           (ACTUATE (s f)              (sf-actuate s (recur f ev)))
           (REDUCE (f n i)             (sf-reduce f n i))
           (RTRANSITION (f g ef efd eg egd s)  
                                       (let ((efv (recur efd #f))
                                             (egv (recur egd #f)))
                                         (sf-rtransition (recur f (list ef efv)) (recur g (list eg egv))
                                                         ef (recur efd #f) eg (recur egd #f) s)))
           (TRANSIENT (f g e ef)       (let ((ee (recur ef #f)))
                                         (sf-transient (recur f (list e ee)) (recur g ev) e ee)))
           (ON (f e)                   (sf-on (recur f ev) e))
           (INTEGRAL (x ys h fs)       (sf-integral x ys h fs ev))
           )))


(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)))
	     )))
	((ON)
	 (let ((e (third sig)))
	   (let* ((ax1 (cons e ax)))
	     (fold recur ax1 (cdr (sfarrow-children f)))
	     )))
	((SF)
	 (let ((evs (fifth sig)))
           (if (null? evs) ax (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 (prelude/scheme #!key (solver 'rk4b) (random #f) (integral-index 0))

`(
  ,(case solver
     ((cvode) `("(use sundials random-mtzig mathh)" ,nl))
     (else    `("(use runge-kutta random-mtzig mathh)" ,nl)))
 #<<EOF

;; Variant types 

(define-syntax define-datatype
  (syntax-rules ()
    [(_ type (name field ...) ...)
     (begin
       (define-constructors type ((name field ...) ...)))]))


(define-syntax define-constructors
  (syntax-rules ()
    [(define-constructors type ((name field ...) ...))
     (define-constructors type ((name field ...) ...) (name ...))]
    [(define-constructors type ((name field ...) ...) names)
     (begin
       (define-constructor type (name field ...) names)
       ...)]))


(define-syntax define-constructor
  (syntax-rules ()
    [(_ type (name field ...) names)
     (define (name field ...)
       (cons 'type
             (lambda names
               (name field ...))))]))


(define-syntax cases
  (syntax-rules ()
    [(_ type x [(name field ...) exp]
          ...)
     ((cdr x) (lambda (field ...) exp)
              ...)]))

(define-datatype trs (TRSA a) (TRSB b))
(define-datatype trc (TRC f fk e))

(define (tsCase fa fb x) (cases trs x ((TRSA a) (fa a)) ((TRSB b) (fb b))))
(define (trfOf x)  (cases trc x ((TRC f fk e) f)))
(define (trfkOf x) (cases trc x ((TRC f fk e) fk)))
(define (treOf x)  (cases trc x ((TRC f fk e) e)))

(define-datatype option (NONE) (SOME a))
(define (swap x v) (cases option v ((NONE) x) ((SOME v) v)))

(define false #f)
(define true  #t)

(define equal equal?)

(define (signalOf v) (if (not v) (error 'signalOf "empty signal" v) v))

(define (heaviside x) (if (negative? x) 0 1))

EOF

,(if (positive? integral-index)
     (case solver
       ((cvode)
	(list "(define integral-solvers (make-vector " integral-index " #f))" nl))
       (else '())
       ) '())

,(if (not solver)
     `((";; dummy solver; returns only the computed derivatives")
       ("(define (integral f x y h i) (f x y))" ,nl)
       )
     (case solver
       ((cvode) 
	`(
          ("(define (integral f x y h i) (f x y))" ,nl)
          ))

       (else
	`(("(define (scaler x a) (map (lambda (k) (fp* x k)) a))" ,nl)
	  ("(define (summer a b) (map fp+ a b))" ,nl)
	  ("(define " ,solver " (make-" ,solver "))" ,nl)
	  ("(define (make_stepper deriv) (" ,solver " scaler summer deriv))" ,nl)
	  ("(define (integral f x y h i) (((make_stepper f) h) x y))" ,nl)
          ))
       ))
))



(define (prelude/ML  #!key (solver 'rk4b) (random #f))
`(
 #<<EOF
structure Model = 
struct

open Real
open Math
open RungeKutta

datatype ('b,'c) trs = TRSA of 'b | TRSB of 'c
datatype ('a,'b,'c) trc = TRC of ((('a -> (('b,'c) trs))) * 
                                  (('a -> (('b,'c) trs))) * 
                                  ((('b,'c) trs) -> real))
	 
fun tsCase (fa,fb,x) = case x of TRSA a => (fa a) | TRSB b => (fb b)
fun trfOf x = case x of TRC (f,fk,e) => f
fun trfkOf x = case x of TRC (f,fk,e) => fk
fun treOf x = case x of TRC (f,fk,e) => e

fun putStrLn str = 
  (TextIO.output (TextIO.stdOut, str);
   TextIO.output (TextIO.stdOut, "\n"))

fun putStr str = (TextIO.output (TextIO.stdOut, str))

fun showReal n = 
let open StringCvt
in
(if n < 0.0 then "-" else "") ^ (fmt (FIX (SOME 12)) (abs n))
end

fun vmap2 f (v1,v2) = 
    let 
        val n = Vector.length v1
    in
        Vector.tabulate (n, fn (i) => f (Unsafe.Vector.sub (v1,i),
                                        Unsafe.Vector.sub (v2,i)))
    end

exception EmptySignal

val neg = (op ~)
val swap = fn (x,v) => (case v of NONE => x | SOME v => v) 
val equal = fn (x,y) => (x = y) 
val signalOf = fn (v) => (case v of NONE => raise EmptySignal | SOME v => v) 
val heaviside = fn (v) => (if Real.< (v, 0.0) then 0.0 else 1.0)

EOF

,(if random
#<<EOF

fun RandomInit () = RandomMTZig.fromEntropy()

val RandomState = RandomInit ()
val RandomZT = RandomMTZig.ztnew()

fun random_uniform () = RandomMTZig.randUniform RandomState
fun random_exponential (mu) = mu * RandomMTZig.randExp (RandomState, RandomZT)


EOF
"")

,(if (not solver)
     `(("(* dummy solver; returns only the computed derivatives *)")
       ("fun integral (f,x: real,y: real vector,h,i) = (f (x,y))" ,nl)
       )
     `(("val summer = fn (a,b) => (vmap2 (fn (x,y) => x+y) (a,b))" ,nl)
       ("val scaler = fn(a,lst) => (Vector.map (fn (x) => a*x) lst)" ,nl)
       . ,(case solver  
            ;; adaptive solvers
            ((rkoz rkdp)
             (let ((esolver (sprintf "ce~A" solver)))
             `(
               ("val " ,solver ": (real vector) stepper2 = make_" ,solver "()" ,nl)
               ("fun make_stepper (deriv) = " ,solver " (scaler,summer,deriv)" ,nl)
               ("val " ,esolver ": (real vector) stepper3 = make_" ,esolver "()" ,nl)
               ("fun make_estepper (deriv) = " ,esolver " (scaler,summer,deriv)" ,nl)
#<<EOF

val tol = Real.Math.pow (10.0, ~7.0)
val lb = 0.5 * tol
val ub = 0.9 * tol

datatype ('a, 'b) either = Left of 'a | Right of 'b


fun predictor tol (h,ys) =
  let open Real
      val e = Vector.foldl (fn (y,ax) => Real.+ ((abs y),ax)) 0.0 ys
  in 
      if e < lb 
      then Right (1.414*h)	(* step too small, accept but grow *)
      else (if e < ub 
            then Right h	(* step just right *)
            else Left (0.5*h))	(* step too large, reject and shrink *)
  end


exception ConvergenceError


fun secant tol f fg0 guess1 guess0 = 
    let open Real
        val fg1 = f guess1
        val newGuess = guess1 - fg1 * (guess1 - guess0) / (fg1 - fg0)
        val err =  abs (newGuess - guess1)
    in 
        if (err < tol)
        then newGuess
        else secant tol f fg1 newGuess guess1 
    end


datatype 'a result = Next of 'a | Root of 'a


fun esolver (stepper,evtest) (x,ys,h) =
    let open Real
        val (ys',e,finterp) = stepper h (x,ys)
    in
        case predictor tol (h,e) of
            Right h' => 
            if (evtest (ys') >= 0.0)
            then (let
                     val theta   = secant tol (evtest o finterp) (evtest ys) 1.0 0.0
                     val ys''    = finterp (theta+tol)
                 in
                     Root (x+(theta+tol)*h,ys'',h')
                 end)
            else Next (x+h,ys',h')
          | Left h'  => 
            esolver (stepper,evtest) (x,ys,h')
    end


fun eintegral (f,x,ys,evtest,h,i) =
    case esolver (make_estepper f,evtest) (x,ys,h) of
        Next (xn,ysn,h') =>
        ({xn=xn,h=h',ysn=ysn})
      | Root (xn,ysn,h') =>
        ({xn=xn,ysn=ysn,h=h'})

fun solver stepper (x,ys,h) =
    let open Real
        val (ys',e) = stepper h (x,ys)
    in
        case predictor tol (h,e) of
            Right h' => 
            (x+h,ys',h')
          | Left h'  => 
            solver (stepper) (x,ys,h')
    end

fun integral (f,x,ys,h,i) =
    let 
        val (xn,ysn,h') = solver (make_stepper f) (x,ys,h) 
    in
        {xn=xn,ysn=ysn,h=h'}
    end



EOF

               )))
            (else
             `(
               ("val " ,solver ": (real vector) stepper1 = make_" ,solver "()" ,nl)
               ("fun make_stepper (deriv) = " ,solver " (scaler,summer,deriv)" ,nl)
               ("fun integral (f,x: real,y: real vector,h,i) = ((make_stepper f) h) (x,y)" ,nl)
(#<<EOF

fun eintegral (f,x,ys,evtest,h,i) =
    let val ysn = ((make_stepper f) h) (x,ys) 
    in
        ({xn=x+h,h=h,ysn=ysn})
    end


EOF
)
               ))
            ))
       )
))
  
(define (prelude/Octave #!key (solver 'lsode))
`(
#<<EOF

function res = TRSA(v)
  res = struct ("TRSA",v);  
end

function res = TRSB(v)
  res = struct ("TRSB",v);  
end

function res = tsCase(fa,fb,v)
   if (isfield (v, "TRSA"))
     res = fa(getfield(v,"TRSA"));
   else
     res = fb(getfield(v,"TRSB"));
   endif
end

function res = TRSC(f,fk,e)
  res = struct ("TRSC",[f,fk,e]);  
end

function res = trfOf(x)
   res = getfield(x,"TRC")(1);
end

function res = trfkOf(x)
   res = getfield(x,"TRC")(2);
end

function res = treOf(x)
   res = getfield(x,"TRC")(3);
end

function res = NONE()
  res = struct ();  
end

function res = SOME(v)
  res = struct ("SOME",v);  
end

function res = swap (x,v)
   if (isfield (v, "SOME"))
     res = getfield(v,"SOME");
   else
     res = x;
   endif
end

function res = equal (x, y)
   res = (x==y);
end

function res = signalOf (v)
  if (not(v))
   error ("empty signal")
 else
   res = v;
 endif
end

function res = neg (x)
  res = -x;
end

function res = ifv (b,x,y)
  if (b) 
    res = x;
  else
    res = y;
  endif
end

EOF
,(if (not solver)
     `("function res = integral (f,x,y,h,i)" ,nl 
       "  res = f(x,y); " ,nl end ,nl
       ,nl)
     `((
#<<EOF

EOF
)
       ("global " ,solver #\; ,nl)
       (,solver = #\@ ,(case solver
			 ((rk3) 'ode23) ((rk4b rk4a) 'ode45) ((rkf45) 'ode54) 
			 (else 'lsode)) #\; ,nl)

       ,(cond

	 ((member solver '(rk3 rk4b rk4a rkf45))

	       `(
#<<EOF
global reltol abstol dt;
reltol = 0.1;
abstol = 0.01;
dt = 0.001;

global P;
P = odeset ("RelTol" , reltol , "AbsTol" , abstol , "MaxStep" , 1 , "InitialStep" , dt) ;

EOF
       "function res = integral (f,x,y,h,i)" ,nl 
       "  global P " ,solver ";" ,nl
       "  [t,y] = " ,solver "(f,[x,x+h],y,P); " ,nl 
       "  res = y(2);" ,nl end ,nl
       ))
	      (else

	       `(
#<<EOF
lsode_options("relative tolerance",1e-4);
lsode_options("absolute tolerance",1e-4);


EOF
       "function res = integral (f,x,y0,h,i)" ,nl 
       "  global " ,solver ";" ,nl
       "  y = " ,solver "(@(yvec,t) f(t,yvec),y0,[x,x+h]); " ,nl 
       "  res = y(2);" ,nl end ,nl
       )
   ))
 ))
))


(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 '(rkfe rk3 rk4a rk4b rkoz rkdp))))
      (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) (random #f) (pre #t) (post #t) (solver 'rk4b))

  (if (and solver (not (member solver '(rkfe rk3 rk4a rk4b rkoz rkdp))))
      (error 'codegen/ML "unknown solver" solver))

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

    (codegen-state '())

    (let* ((input    (or (and initial ((dfe-in dfe) (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/ML solver: solver random: random)))

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




)