;;
;;  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-2011 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 PIPE
         INTEGRAL INTEGRALH
	 LOOP TRANSITION RTRANSITION TRANSIENT

	 function? make-function function-formals function-body
	 
	 signal? signal-name signal-value

	 symbolic-constants enum-freevars

	 construct dataflow 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)
  (PURE         (f function?))
  (RELATION     (r relation?) (f diagram?))
  (UNION        (f diagram?) (g diagram?))
  (SEQUENCE     (f diagram?) (g diagram?))
  (PIPE         (f diagram?) (g diagram?))
  (SENSE        (s symbol-pair?) (f diagram?))
  (ACTUATE      (s symbol-pair?) (f diagram?))
  (RTRANSITION  (f diagram?) (g diagram?) 
		(ef symbol?)
		(eg (lambda (x) (or (symbol? x) (boolean? x)))))
  (TRANSITION   (f diagram?) (g diagram?) (ef symbol?) )
  (TRANSIENT    (f diagram?) (g diagram?) (e symbol?) )
  (LOOP         (s (lambda (lst) (every symbol-pair? lst))) (f diagram?))
  (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-codegen rv renv expr)
  codegen?
  (rv          codegen-rv)
  (renv        codegen-renv)
  (expr        codegen-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:Prim 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) (gensym 'relation)) (sfarrow-relations sf))))
  (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)
  (make-sfarrow 
   ;; dataflow equations
   (make-dfe
    ;; gen
    (lambda (s) '())
    ;; kill
    (lambda (s) '())
    ;; in
    (lambda (s) s)
    ;; out
    (lambda (s) s))
   ;; codegen
   (lambda (s env dfe) (make-codegen #f env (list)))
   ;; signature
   `(IDENTITY)
   ;; children
   `(IDENTITY)
   ;; relations
   `()
   ))


;; The [pipe] combinator feeds the output of the first signal function
;; into the input of the second:

(define (sf-pipe 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) 
						    (lset-difference eq? s (fe-kill 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? (ge-gen s)
		     (lset-difference eq? (fe-gen s) (ge-kill s))))
      ;; kill
      (lambda (s) (lset-union eq? (ge-kill s)
		     (lset-difference eq? (fe-kill s) (ge-gen s))))
      ;; in
      (lambda (s) (lset-union eq? (fe-in s) 
			      (lset-difference eq? (ge-in s) (fe-kill s))))

      ;; out
      (lambda (s) (ge-out s))
      )

   ;; codegen
   (lambda (s env dfe)

     (let* (
	    (fenv     (list->cgenenv 'pipe1 (fe-in s) env))
	    (fcodegen ((sfarrow-codegen f) (fe-in s) fenv fe))

	    (genv     (fold (lambda (s genv) (cgenenv-add s (cgenenv-find 'pipe2 s env) genv))
			    cgenenv-empty (ge-in (lset-difference eq? s (fe-kill s)))))
	    (genv     (fold (lambda (s genv) 
			      (let ((v (cgenenv-find 'pipe3 s (codegen-renv fcodegen))))
				(cgenenv-add s v genv)) )
			    genv (fe-out s)))
			    
	    (gcodegen ((sfarrow-codegen g) (ge-in (lset-difference eq? s (fe-kill s))) genv ge))

	    )
		       
       (make-codegen
	(codegen-rv gcodegen)
	(list->cgenenv 'pipe4 (ge-out s) (codegen-renv gcodegen))
	(append (relations-codegen f env)
		(relations-codegen g env)
		(codegen-expr fcodegen)
		(codegen-expr gcodegen)))))
   ;; signature
   `(PIPE ,(sfarrow-sig f) ,(sfarrow-sig g))
   ;; children
   `(PIPE ,f ,g)
   ;; relations
   `()
   )))

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

		(make-codegen 

		 #f
		 
		 (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)))))
		 
	       (let ((fflds  (map fld fcodegen-lst (map sfarrow-dfe flst)))
		     (gflds  (map fld gcodegen-lst (map sfarrow-dfe glst))))
		 (append 
		  (relations-codegen f env)
		  (relations-codegen g env)
		  (concatenate expr-lst)))
	       
	       )))
	    )))
      ;; 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) (fe-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
     `()
     )))

;; Recurring state transitions

(define (sf-rtransition0 f fk e ek)

  (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? (fe-gen s) (fke-gen s)))
      
      ;; kill
      (lambda (s) (lset-union eq? (fe-kill s) (fke-kill s)))
      
      ;; in
      (lambda (s) (lset-union eq? (fe-in s) (fke-in s) 
			      (cond ((symbol? ek) (list e ek))
				    (else (list e)))))
      
      ;; out
      (lambda (s) (lset-union eq? (fe-out s) (fke-out s))))
     
     ;; codegen
     (lambda (s env dfe) 
       (let* (
	      (rv         (gensym 'trv))
	      (blender    (gensym 'blender))
	      (state      (gensym 'trst))
	      
	      (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:Prim 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 (x)
			  (V:Prim 'tsCase 
				  (list (V:Fn '(x) (E:Ret (V:Rec (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 (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 (x) 
			    (V:Prim 'tsCase 
				    (list (V:Fn '(x) (E:Ret (V:Rec (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 (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 state
		    (V:Prim 'TRC
			    (list 
			     (V:Stv
			      (V:Fn blender-inputs
				    (E:Let (append
					    (relations-codegen f env)
					    (codegen-expr fcodegen))
					   (blender-return 'TRSA fcodegen))))
			     (V:Stv
			      (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:Prim '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 state blender-inputs)
			  (E:Let `(
				   ,(E:Val 'f     (V:Ldv (V:Prim 'trfOf (list (V:Var state)))))
				   ,(E:Val 'e     (V:Prim 'treOf (list (V:Var state))))
				   ,(E:Val 'fv    (V:Prim 'f (map V:Var blender-inputs)))
				   ,(E:Val 'trp   (V:Prim 'e (list (V:Var 'fv))))
				   )
				 (E:Seq
				  (list
				   (E:Ife (V:Var 'trp)
					  (E:Let `(
						   ,(E:Val 'fk (V:Ldv (V:Prim 'trfkOf (list (V:Var state)))))
						   )
						 (E:Seq
						  (list
						   (E:Ret (V:Prim 'trfSet  (list (V:Var state) (V:Var 'fk))))
						   (E:Ret (V:Prim 'trfkSet (list (V:Var state) (V:Var 'f))))
						   )))
					  (E:Noop))
				   
				   (E:Ret
				    (V:Ifv (V:Var 'trp) (fkblend 'fv) (fblend 'fv)))
				   
				   )))
			  ))
	     ))
	   
	   (codegen-state)))
	 
	 (make-codegen
	  rv

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

	  (list
	   (E:Val rv
		  (V:Prim blender (cons (V:Var state) 
					(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)
     ;; children
     `(RTRANSITION ,f ,fk)
     ;; relations
     `()
     )))

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

;; One-time state transition

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


;; 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:Prim gcompute (map (lambda (x) (select-signal '(transient state-compute) x env)) 
						(ge-in s)))
			  (V:Prim 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
     `()
     )))

;; Recursive signal functions

(define (sf-loop p 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)))

    (let ((feedback (map cadr p))
	  (p (map (lambda (x) (cons (first x) (second x))) p)))
      (make-sfarrow
       
       ;; dataflow equations
       (make-dfe
	;; gen
	(lambda (s) feedback)
	
	;; kill
	(lambda (s) (fe-kill s))
	
	;; in
	(lambda (s) (fe-in s))
	
	;; out
	(lambda (s) (lset-union eq? (fe-out s) feedback)))
       
       ;; codegen
       (lambda (s env dfe) 
	 (let* (
		(fenv     (list->cgenenv 'loop11 (fe-in s) env))
		(fcodegen ((sfarrow-codegen f) (fe-in s) fenv (sfarrow-dfe f)))

		(state        (gensym 'loopst))
		(state-update (gensym 'updloop))
		(rv           (gensym 'looprv))
		
		(fldinit  (lambda (s) (list (cdr s) (V:C 'NONE))))
		
		(fldupd   (lambda (s) 
			    (let* ((n (cdr s)))
			      (list n (V:Prim 'SOME (list (V:Var n))))))) 
		
		(fldexch (lambda (n) 
			   (let* ((pn (alist-ref n p))
				  (nv (select-signal 'loop n env))
				  (fv (and pn (V:Sel pn (V:Ldv (V:Var state))))))
			     (list n (if pn (V:Prim 'swap (list nv fv)) nv)))))
		
		)
	   
	   (codegen-state
	    (append
	      (list
	       (E:Val state-update
		      (V:Fn (cons state (map cdr p))
			    (E:Ret (V:Rec (map fldupd p)))))
	       (E:Val state (V:Stv (V:Rec (map fldinit p))))
	       )
	   (codegen-state)))
	   
	   (make-codegen
	    rv
	    (codegen-renv fcodegen)
	    (append (relations-codegen f env)
		    (codegen-expr fcodegen)
		    (list (E:Set (V:Var state)
				 (V:Prim state-update
					 (cons (V:Var state) 
					       (map (lambda (p) (select-signal 'loop (cdr p) (codegen-renv fcodegen))) p)))))
		    (list (E:Val rv (V:Rec (map fldexch s))))
		  ))
	   ))

       ;; signature
       `(LOOP ,p ,(sfarrow-sig f))
       ;; children
       `(LOOP ,f)
       ;; 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:Prim yprime fargs))))
				    )))

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

		)))
	   )))

       ;; 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 ()              (sf-identity))
	 (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)))
	 (PIPE  (f g)              (sf-pipe (construct f) (construct g)))
	 (SENSE (s f)              (sf-sense s (construct f)))
	 (ACTUATE (s f)            (sf-actuate s (construct f)))
	 (LOOP (s f)               (sf-loop s (construct f)))
	 (RTRANSITION (f g ef eg)  (sf-rtransition (construct f) (construct g) ef eg))
	 (TRANSITION (f g ef)      (sf-transition (construct f) (construct g) ef))
	 (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 (codegen/Octave name f #!key (initial #f) (pre #t) (solver 'rk4b))

  (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 ))
	   (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-codegen f input) (codegen-expr fcodegen))) nl 
	"end" 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))

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

      (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-codegen f input) (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))

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

      (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-codegen f input) (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)))
      
      )))


)


;; Discrete events: hold, edge, merge
#|
(define (sf-hold e)
  (let ((v (make-parameter (make-undefined-signal))))
    
    (make-sfarrow

     ;; arrow
     (lambda (c) 
       (let* ((r  ((sfarrow-arrow e) c))
	      (s1 (container-sigenv r)))
	 (if (undefined-signal? (signal-value (first s1))) 
	     (copy-container c  (v))
	     (begin (v s1)
		    (copy-container c  s1)))))

     ;; signature 
     `(HOLD ,(sfarrow-signature e) )
     
     ;; state
     (lambda ()
       (cons `(HOLD . ,v) ((sfarrow-state e)) ))

     ;; dataflow equations
     (let ((ee (sfarrow-dfe e)))
       
       (make-dfe
	;; gen
	(lambda (s) ((dfe-gen ee) s))
	
	;; kill
	(lambda (s) ((dfe-kill ee) s))
	
	;; in
	(lambda (s) s)
	
	;; out
	(lambda (s) ((dfe-out ee) s))))

     ;; codegen
     (lambda (s env dfe) 
       (let* ((rv1       (gensym 'hold))
	      (rv2       (gensym 'hold))
	      (ev        (gensym 'ev))
	      (testv     (gensym 'testv))
	      (state     (gensym 'holdst)))
	 
	 (begin
	   (codegen-state
	    (cons 
	     (E:Val state (V:Rec (list (first s) (V:Stv (V:C 'NONE)))))
	     (codegen-state)))
	   
	   (make-codegen
	    rv1
	    (list (E:Val ev    (V:Sel (first s) (V:Var x)))

		  (E:Val testv (V:Prim 'equal (list (V:Var ev) (V:C 'NONE))))
		  
		  (E:Val rv1 (E:Ife (V:Var testv)
				    (E:Ret (V:Ldv (V:Sel (first s) (V:Var state))))
				    (E:Let `(,(E:Val rv2 (V:Prim 'Num (list (V:Prim 'signalOf (list (V:Var ev)))))))
					   (E:Seq (list (E:Set (V:Sel (first s) (V:Var state)) (V:Var rv2))
							(E:Ret (V:Var rv2)))))))))
							 
							 
	   )))

     )))


(define-record-type event
  (make-event type  arguments)
  event?
  (type       event-type )
  (arguments  event-arguments )
  )


(define (single-event type . rest)
  (make-event type rest))

(define (co-event . rest)
  (make-event '|| rest))

(define (co-event? x)
  (and (event? x) (equal? '|| (event-type x))))

|#