;;
;;  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-2012 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 RELATION IDENTITY 
         SENSE ACTUATE SEQUENCE UNION REDUCE
         INTEGRAL INTEGRALH
	 TRANSITION RTRANSITION TRANSIENT

	 function? make-function function-formals function-body
	 
	 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)
	(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 (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?))
  (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?) (f function?))
  (INTEGRALH    (i symbol?) (d symbol?) (h (lambda (x) (or (symbol? x) (number? x)))) 
		(f function?))
  )



(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)))
     (make-sfarrow 
      ;; dataflow equations
      (make-dfe
       ;; gen
       (lambda (s) (list name))
       ;; kill
       (lambda (s) (list name))
       ;; in
       (lambda (s) s)
       ;; out
       (lambda (s) (list name)))
      ;; codegen
      (lambda (s env dfe) 
	(let ((in   ((dfe-in dfe) s))
	      (rv1  (gensym 'rv))
	      (rv2  (gensym 'rv))
	      (fd   (and (extended-procedure? f) (procedure-data f))))



	  (make-codegen
	   rv2
	   (cgenenv-add name rv2 cgenenv-empty)
	   (append

	    (if (function? fd)
		(list (function->expr name fd)) '())

	    (if (and (function? fd) (null? (function-formals fd)))
		(list (E:Val rv2 (V:Rec `((,name ,(V:Var name))))))
		(list (E:Val rv1 (V:Op name (map (lambda (s) (select-signal 'sf s env)) in)))
		      (E:Val rv2 (V:Rec `((,name ,(V:Var rv1)))))))
	    )
	   )))
      ;; signature
      `(SF ,name)
      ;; 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-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) 
						  (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 (E: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))
	  )

     (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 'union x renv)))
			      ((dfe-gen dfe) s)))))
	       
	       )

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

	  (let ((rv (gensym 'union))
		(flst (flatten-union f))
		(glst (flatten-union g)))

	    (let ((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 (E:Val rv (V:Rec (map (lambda (s) `(,s ,(select-signal 'union s renv))) (map car renv)))))
		    ))
	       
	       )))
	    )))
      ;; signature
      `(UNION ,(sfarrow-sig f) ,(sfarrow-sig g))
      ;; children
      `(UNION ,f ,g)
      ;; relations
      `()
      )))


;; 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
	   (list->cgenenv 'sequence13 
			  ((dfe-out dfe) s)
			  (cgenenv-union (codegen-renv fcodegen) 
					 (codegen-renv gcodegen))
			  )
	   (append 
	    (relations-codegen f env)
	    (relations-codegen g env)
	    (codegen-expr fcodegen)
	    (codegen-expr gcodegen)
	    (list (E: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
      `()
      )))


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

;; [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) (lset-union eq? (fe-out 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 (E:Val rv (V:Rec (map fldr sns (fe-out s)))))))))
	   r)
	 ))
     ;; signature
     `(ACTUATE ,sns ,(sfarrow-sig f))
     ;; children
     `(ACTUATE ,f)
     ;; relations
     `()
     )))


;; [reduce f init]

(define (sf-reduce f name init)

  (define (step name input inax outax env)
    (E: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 (E: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))
	 )
    
    (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)  (fe-in s)  fenv  (sfarrow-dfe f)))
	      (fkcodegen ((sfarrow-codegen fk) (fke-in s) 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? blender-outputs)
	     (error 'sf-rtransition "empty intersection of recurrent transition arguments" 
		    (sfarrow-sig f) (sfarrow-sig fk)))
	 
	 (codegen-state
	  (append
	   (reverse
	    (list

	     (E: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)))))
			   )))
	     
	     (E:Val blender
		    (V:Fn (cons stm blender-inputs)
			  (E:Let `(
				   ,(E:Val 'f     (V:Op 'trfOf (list (V:Var stm))))
				   ,(E:Val 'fk    (V:Op 'trfkOf (list (V:Var stm))))
				   ,(E:Val 'e     (V:Op 'treOf (list (V:Var stm))))
				   ,(E:Val 'fv    (V:Op 'f (map V:Var blender-inputs)))
				   ,(E:Val 'trp   (V:Op 'e (list (V:Var 'fv))))
				   ,(E:Val state  (V:Ifv (V:Var 'trp) (V:Op 'not (list (V:Var state))) (V:Var state)))
				   )
				   
				   (E:Ret
				    (V:Ifv (V:Var state) (fkblend state 'fv) (fblend state 'fv)))
				   
				   )))
	     ))
	   
	   (codegen-state)))
	 
	 (make-codegen
	  rv

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

	  (list
	   (E: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
     `()

     )))

(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))
	 
	 )
    	
    (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) (fe-in s) fenv fe))

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

	      )

	 (codegen-state
	  (append
	   (list
	    
	    (E: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))))
			  )))
		   
	    (E: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)))
	  
	  (append
	   (list
	    (E: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
     `()
     )))



(define (sf-integral0 x y h f)

  (let* ((xn     (gensym (string->symbol (s+ x "+h"))))
	 (yn     (gensym (string->symbol (s+ y "(" xn ")"))))
	 (ynv    (gensym (string->symbol (s+ yn "v"))))
	 (yprime (gensym (string->symbol (s+ y "prime")))))
      
      (make-sfarrow
       
       ;; dataflow equations
       (make-dfe

	;; gen
	(lambda (s) (list yn))
	
	;; kill
	(lambda (s) (lset-union eq? s (list xn)))
	
	;; in
	(lambda (s) (lset-union eq? (function-formals f) 
				(append (if (symbol? h) (list h) '())
					(list x y))))
	
	;; out
	(lambda (s) (list yn))
	)
       
       ;; codegen
       (let ((rv1       (gensym 'integral))
	     (dfn       (gensym 'dfn)))
	     
	 (lambda (s env dfe)
	   
	   (let* (
		  (tstep     (if (symbol? h) 
				 (select-signal 'integral1 h env)
				 (V:C h)))
		  
		  (fenv      (list->cgenenv 'integral2 (function-formals f) 
					    (cgenenv-add x x (cgenenv-add y y env))))

		  (fargs     (map (lambda (s) (select-signal 'integral3 s fenv)) (function-formals f)))
		  )

	     (make-codegen

	      rv1
	      
	      (map (lambda (s) (cons s rv1)) (list yn))

	      (append

	       (list 

		(function->expr yprime f)

		(E:Val dfn 
		       (V:Fn `(,x yvec) 
			     (E:Let (list (E:Val y (V:Sub 0 (V:Var 'yvec))))
				    (E:Ret (V:Vec (list (V:Op yprime fargs))))
				    )))

		(E:Val rv1     (V:Rec `((,yn ,(V:Sub 0 (V:Op 'integrate1d 
							       (list (V:Var dfn) 
								     (select-signal 'integral4 x env) 
								     (V:Vec (list (select-signal 'integral5 y env)))
								     tstep
								     )))
					     ))
				      ))

		)))
	   )))

       ;; signature
       `(INTEGRAL ,f)

       ;; children
       `(INTEGRAL ,f)

       ;; 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-4 f))


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


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


(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 expr x
				(E: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) 
				    (cases expr x
					   (E:Val  (name v) (list (name/Octave name) " = " (value->Octave v) ";" nl))
					   (else (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 expr->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)))

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

      (print-fragments
       (list
	"(define (" (name/scheme name) " input)" nl
	"(let (" (intersperse (map (lambda (x) (expr->scheme (E:Val x (V:Sel x (V:Var 'input))))) input) " ")  ")"  nl
	"(let* (" (map expr->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 expr->ML (reverse (codegen-state))) nl))

      (print-fragments
       (list
	"fun " (name/ML name) "(input as {" (intersperse (map name/ML input) ",")  "})" " = " nl
	"let" nl
	(map expr->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)))
      
      )))




)