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

Last change on this file since 30940 was 30940, checked in by Ivan Raikov, 6 years ago

signal-diagram: support for variable timestep integration

File size: 45.3 KB
Line 
1 
2;;
3;;  This module implements combinators that are used to build signal
4;;  flow functions out of pure functions.
5;;
6;;  Based on ideas from:
7;;  1) Opis - Reliable Distributed Systems in OCaml
8;;  (Copyright (C) 2008-2009 Pierre-Evariste DAGAND)
9;;
10;;  2) Yampa: Functional Reactive Programming with Arrows
11;;  Developed by the Yale Haskell Group.
12;;
13;; Copyright 2010-2014 Ivan Raikov and the Okinawa Institute of
14;; Science and Technology.
15;;
16;; This program is free software: you can redistribute it and/or
17;; modify it under the terms of the GNU General Public License as
18;; published by the Free Software Foundation, either version 3 of the
19;; License, or (at your option) any later version.
20;;
21;; This program is distributed in the hope that it will be useful, but
22;; WITHOUT ANY WARRANTY; without even the implied warranty of
23;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
24;; General Public License for more details.
25;;
26;; A full copy of the GPL license can be found at
27;; <http://www.gnu.org/licenses/>.
28;;
29
30
31(module signal-diagram 
32
33        (PURE PRIM RELATION IDENTITY 
34         SENSE ACTUATE SEQUENCE UNION REDUCE
35         INTEGRAL TRANSITION RTRANSITION TRANSIENT ON
36
37         function? make-function function-formals function-body
38         prim? make-prim prim-states prim-formals prim-body prim-init
39
40         signal? signal-name signal-value
41
42         symbolic-constants enum-freevars
43
44         construct dataflow events codegen/Octave codegen/scheme codegen/ML
45         )
46
47        (import scheme chicken)
48
49        (require-extension extras data-structures srfi-1 datatype flsim dyn-vector)
50        (require-library lolevel srfi-13)
51        (import (only srfi-13 string-concatenate string<)
52                (only lolevel extended-procedure? procedure-data extend-procedure )
53                )
54
55(include "expr-utils")
56
57(define nl "\n")
58(define (s+ . rst) (string-concatenate (map ->string rst)))
59
60;; based on SRV:send-reply by Oleg Kiselyov
61(define (print-fragments b)
62  (let loop ((fragments b) (result #f))
63    (cond
64      ((null? fragments) result)
65      ((not (car fragments)) (loop (cdr fragments) result))
66      ((null? (car fragments)) (loop (cdr fragments) result))
67      ((eq? #t (car fragments)) (loop (cdr fragments) #t))
68      ((pair? (car fragments))
69        (loop (cdr fragments) (loop (car fragments) result)))
70      ((procedure? (car fragments))
71        ((car fragments))
72        (loop (cdr fragments) #t))
73      (else
74       (display (car fragments))
75       (loop (cdr fragments) #t)))))
76
77
78(define (symbol-pair? x)
79  (and (pair? x) 
80       (and (symbol? (car x)) 
81            (or (null? (cdr x)) 
82                (symbol-pair? (cdr x))))))
83
84
85(define (symbol-list? x)
86  (and (list? x) (every symbol? x)))
87
88
89
90;;
91;; A signal function is expected to be built upon pure functions only:
92;; side-effects should not be used. Although this requirement is not
93;; of prime importance in normal use, this is a hardship if one wants
94;; to debug a signal function.
95;;
96
97(define make-signal cons)
98(define signal-name car)
99(define signal-value cdr)
100(define signal? pair?)
101
102
103(define-values (cgenenv-empty cgenenv-add cgenenv-find cgenenv-union )
104  (letrec (
105           (empty      '())
106           (add        (lambda (s v env) 
107                         (if (and (symbol? s) (symbol? v))
108                             (cons (cons s v) env)
109                             (error 'cgenenv-add "invalid arguments to add" s v))))
110           (find       (lambda (loc s env)
111                         (let ((v (alist-ref s env)))
112                           (if (not v) (error loc "label not found" s))
113                           v)))
114           (union      (lambda (x y) (lset-union (lambda (x y) (eq? (first x) (first y))) x y)))
115           )
116    (values empty add find union )))
117
118
119(define (list->cgenenv loc slst source-cgenenv)
120  (fold (lambda (s env) (cgenenv-add s (cgenenv-find loc s source-cgenenv) env))
121        cgenenv-empty slst))
122
123
124
125
126;;
127;;   An arrow is an object with:
128;;
129;;   * dfe method, which produces dataflow information
130;;   * codegen method, which generates pseudo-imperative code
131;;
132
133(define-record-type sfarrow
134  (make-sfarrow  dfe codegen sig children relations)
135  sfarrow?
136  (dfe         sfarrow-dfe)
137  (codegen     sfarrow-codegen)
138  (sig         sfarrow-sig)
139  (children    sfarrow-children)
140  (relations   sfarrow-relations)
141  )
142
143
144(define-record-type dfe
145  (make-dfe gen kill in out)
146  dfe?
147  (gen       dfe-gen )
148  (kill      dfe-kill )
149  (in        dfe-in )
150  (out       dfe-out )
151  )
152
153
154(define-record-type function
155  (make-function formals body)
156  function?
157  (formals function-formals)
158  (body    function-body))
159
160
161(define-record-type prim
162  (make-prim states formals outputs events body init-outputs init)
163  prim?
164  (states  prim-states)
165  (formals prim-formals)
166  (outputs prim-outputs)
167  (events  prim-events)
168  (body    prim-body)
169  (init    prim-init)
170  (init-outputs prim-init-outputs)
171  )
172
173
174(define (function-list? x)
175  (and (list? x) (every function? x)))
176
177
178(define (relation? r)
179  (and (pair? r) (symbol? (car r)) 
180       (symbol-list? (cadr r))
181       (function? (caddr r))))
182
183
184(define-datatype diagram diagram?
185  (IDENTITY     (f diagram?))
186  (PURE         (f function?))
187  (PRIM         (f prim?) (name symbol?))
188  (RELATION     (r relation?) (f diagram?))
189  (UNION        (f diagram?) (g diagram?))
190  (SEQUENCE     (f diagram?) (g diagram?))
191  (SENSE        (s symbol-pair?) (f diagram?))
192  (ACTUATE      (s symbol-pair?) (f diagram?))
193  (REDUCE       (f function?) (name symbol?) (init symbol?))
194  (RTRANSITION  (f diagram?) (g diagram?) 
195                (ef symbol?)
196                (eg (lambda (x) (or (symbol? x) (boolean? x))))
197                (s  symbol?)
198                )
199  (TRANSITION   (f diagram?) (g diagram?) (ef symbol?) (s symbol?))
200  (TRANSIENT    (f diagram?) (g diagram?) (e symbol?) )
201  (ON           (f diagram?) (e symbol?) )
202  (INTEGRAL     (i symbol?) (d symbol-list?) (h (lambda (x) (or (symbol? x) (number? x)))) 
203                (f function-list?))
204  )
205
206
207
208(define (select-signal loc s env)
209  (let ((v (cgenenv-find loc s env)))
210    (if (eq? s v) (V:Var s) (V:Sel s (V:Var v)))))
211
212
213(define-record-type codegen
214  (make-codegen0 rv renv expr)
215  codegen?
216  (rv          codegen-rv)
217  (renv        codegen-renv)
218  (expr        codegen-expr)
219  )
220
221(define (make-codegen rv renv expr)
222  (if (not (symbol? rv)) (error 'make-codegen "invalid return variable"))
223  (make-codegen0 rv renv expr))
224
225
226(define codegen-state (make-parameter '()))
227   
228                                           
229;;
230;;  The arrow combinators are used to build signal functions upon pure
231;;  functions.
232;; 
233
234;;  [sf f] encapsulates a pure function into a signal function.
235
236
237(define (sf f . rest)
238  (let-optionals rest ((name (gensym 'sf)))
239   (let* (
240          (fd (and (extended-procedure? f) (procedure-data f)))
241          (formals (or (and (prim? fd) (prim-outputs fd)) 
242                       (and (function? fd) (function-formals fd))
243                       '()))
244          (outputs (or (and (prim? fd) (prim-outputs fd)) '()))
245          (states (or (and (prim? fd) (prim-states fd)) '()))
246          (events (or (and (prim? fd) (prim-events fd)) '()))
247          )
248
249     (make-sfarrow 
250      ;; dataflow equations
251      (make-dfe
252       ;; gen
253       (lambda (s) (if (prim? fd) outputs (list name)))
254       ;; kill
255       (lambda (s) (if (prim? fd) outputs (list name)))
256       ;; in
257       (lambda (s) s)
258       ;; out
259       (lambda (s) (if (prim? fd) outputs (list name))))
260      ;; codegen
261      (lambda (s env dfe) 
262        (let ((in   ((dfe-in dfe) s))
263              (out  ((dfe-out dfe) s))
264              (rv1  (gensym 'rv))
265              (rv2  (gensym 'rv))
266              (init-name (and (prim? fd) (gensym (string->symbol (string-append (->string name) "init")))))
267              )
268
269          (make-codegen
270           rv2
271           (fold (lambda (name env) (cgenenv-add name rv2 env)) cgenenv-empty out)
272           (append
273           
274            (cond ((function? fd)
275                   (list (function->expr name fd)))
276                  ((prim? fd)
277                   (list (prim->expr name fd) ))
278                  (else (error 'sf "unknown function object" fd)))
279
280            (cond ((function? fd)
281                   (if (null? (function-formals fd))
282                       (list (B:Val rv2 (V:Rec `((,name ,(V:Var name))))))
283                       (list (B:Val rv1 (V:Op name (map (lambda (s) (select-signal 'sf s env)) in)))
284                             (B:Val rv2 (V:Rec `((,name ,(V:Var rv1))))))))
285
286                  ((prim? fd)
287
288                     (codegen-state
289                      (append
290                       (list (prim->init init-name fd))
291                       (codegen-state)))
292
293                     (list (B:Val rv1 (V:Op name (append
294                                                  (map (lambda (s) (select-signal 'sf s env)) in)
295                                                  (map (lambda (x) (V:Sel x (V:Var init-name))) 
296                                                       (lset-difference eq? states in)))))
297                           (B:Val rv2 (V:Rec (map (lambda (s) `(,s ,(V:Sel s (V:Var rv1)))) outputs)))
298                           )
299                     )
300                 
301                  (else (error 'sf "unknown function object" fd))
302                  )
303            ))
304          ))
305      ;; signature
306      `(SF ,name ,states ,outputs ,events)
307      ;; children
308      `(SF)
309      ;; relations
310      `()
311      ))
312     ))
313 
314
315
316
317(define (sf-pure  f . rest)
318  (let-optionals rest ((name (gensym 'sf)))
319    (let* ((f0   (cond ((function? f)  (lambda () `(,name ,(function-formals f) ,(function-body f))))
320                       ((procedure? f) f)
321                       (else (error 'sf-pure "invalid function" f))))
322           (f1 (if (function? f) (extend-procedure f0 f) f0)))
323      (sf f1 name))))
324
325
326(define (sf-prim f name)
327  (let* ((f0   (cond ((prim? f)  (lambda () `(,name ,(append (prim-formals f) (prim-states f)) ,(prim-body f))))
328                     (else (error 'sf-prim "invalid primitive" f))))
329         (f1 (if (prim? f) (extend-procedure f0 f) f0)))
330    (sf f1 name)))
331
332
333(define (sf-relation r sf)
334
335  (define (relation-vars r) (function-formals (caddr r)))
336
337  (define (relations-inputs sf)
338    (let recur ((sf sf) (inputs '()))
339      (let ((inputs (append
340                     (concatenate (map relation-vars (sfarrow-relations sf))) 
341                     inputs)))
342        (let ((sf-children (filter-map sfarrow? (sfarrow-sig sf))))
343          (if (null? sf-children) inputs
344              (fold recur inputs sf-children)
345              )))))
346
347  (if (relation? r)
348
349      (let* ((dfe (sfarrow-dfe sf))
350             (dfe1 (make-dfe (dfe-gen dfe) (dfe-kill dfe)
351                             (lambda (s) (delete-duplicates
352                                          (append ((dfe-in dfe) s) 
353                                                  (relations-inputs sf))))
354                             (dfe-out dfe))))
355        (make-sfarrow dfe1 
356                      (sfarrow-codegen sf) 
357                      (sfarrow-sig sf) (sfarrow-children sf)
358                      (cons r (sfarrow-relations sf))))
359
360      (error 'sf-relation "invalid relation" r)))
361
362
363(define (relations-codegen sf env)
364
365  (let ((kons (map (lambda (x) (car x)) (sfarrow-relations sf))))
366
367    (codegen-state
368     (append (codegen-state)
369             (reverse
370              (map
371               (lambda (r k)
372                 (let ((name (car r)) 
373                       (fd (caddr r)))
374                   (function->expr k fd)))
375               (sfarrow-relations sf) kons))
376             ))
377    '()
378    ))
379
380
381
382
383;; We now define the rest of the basic signal functions:
384(define (sf-identity f)
385   (let* ((fe       (sfarrow-dfe f))
386          (fe-in    (dfe-in fe))         
387          (fe-out   (dfe-out fe))
388          (fe-gen   (dfe-gen fe))
389          (fe-kill  (dfe-kill fe))
390          )
391
392     (make-sfarrow
393
394      ;; dataflow equations
395      (make-dfe
396       ;; gen
397       (lambda (s) (fe-gen s))
398       
399       ;; kill
400       (lambda (s) (fe-kill s))
401       
402       ;; in
403       (lambda (s) (fe-in s))
404       
405       ;; out
406       (lambda (s) (fe-out s)))
407
408      ;; codegen
409      (lambda (s env dfe) 
410        (let* (
411               (rv (gensym 'identity))
412               (fenv (list->cgenenv 'identity (fe-in s) env))
413               (fcodegen ((sfarrow-codegen f) (fe-in s) fenv fe))
414               )
415          (make-codegen rv 
416                        (fold (lambda (name env) (cgenenv-add name rv env)) cgenenv-empty (fe-out s))
417                        (append (relations-codegen f env) 
418                                (codegen-expr fcodegen)
419                                (list (B:Val rv (V:Rec (map (lambda (s) `(,s ,(select-signal 'identity s (codegen-renv fcodegen)))) (fe-out s)))))
420                                ))
421                               
422          ))
423      ;; signature
424      `(IDENTITY ,(sfarrow-sig f))
425      ;; children
426      `(IDENTITY ,f)
427      ;; relations
428      (sfarrow-relations f))
429     ))
430
431
432
433;; [union f g], applies [f] and [g] to the input signal in parallel.
434
435(define (sf-union f g)
436
437  (define (flatten-union u)
438    (let ((uc (sfarrow-children u)))
439      (case (car uc)
440        ((UNION)  (append (flatten-union (cadr uc))
441                          (flatten-union (caddr uc))))
442        (else     (list u)))))
443   
444
445   (let* ((fe      (sfarrow-dfe f))
446          (ge      (sfarrow-dfe g))
447
448          (fe-in   (dfe-in fe))   
449          (fe-out  (compose (dfe-out fe) fe-in))
450          (fe-gen  (compose (dfe-gen fe) fe-in))
451          (fe-kill (compose (dfe-kill fe) fe-in))
452
453          (ge-in   (dfe-in ge))
454          (ge-out  (compose (dfe-out ge) ge-in))
455          (ge-gen  (compose (dfe-gen ge) ge-in))
456          (ge-kill (compose (dfe-gen ge) ge-in))
457         
458          (flst (flatten-union f))
459          (glst (flatten-union g))
460          )
461
462     (make-sfarrow
463
464      ;; dataflow equations
465      (make-dfe
466       ;; gen
467       (lambda (s) (lset-union eq? (ge-gen s) (fe-gen s)))
468       
469       ;; kill
470       (lambda (s) (lset-union eq? (fe-kill s) (ge-kill s)))
471       
472       ;; in
473       (lambda (s) (lset-union eq? (ge-in s) (fe-in s)))
474       
475       ;; out
476       (lambda (s) (lset-union eq? (ge-out s) (fe-out s)))
477       
478       )
479
480      ;; codegen
481      (lambda (s env dfe) 
482
483        (let* (
484               (fgx      (lset-intersection eq? (fe-gen s) (ge-gen s)))
485               
486               (codegen (lambda (sf)
487                          (let ((codegen (sfarrow-codegen sf))
488                                (dfe (sfarrow-dfe sf)))
489                            (let ((env (list->cgenenv 'union1 ((dfe-in dfe) s) env)))
490                              (codegen ((dfe-in dfe) s) env dfe)))))
491
492               (fld  (lambda (codegen dfe)
493                       (let ((renv (codegen-renv codegen)))
494                         (map (lambda (x) (list x (select-signal 'union2 x renv)))
495                              ((dfe-out dfe) s)))))
496               
497               )
498
499          (if (not (null? fgx)) (error 'sf-union "union arguments output overlapping signals" fgx))
500
501          (let ((rv (gensym 'union))
502                (fcodegen-lst (map codegen flst))
503                (gcodegen-lst (map codegen glst))
504                )
505
506              (let* ((renv-lst (map codegen-renv (append fcodegen-lst gcodegen-lst)))
507                     (expr-lst (map codegen-expr (append fcodegen-lst gcodegen-lst)))
508                     (renv (list->cgenenv 'union3 ((dfe-out dfe) s)
509                                (let recur ((renv-lst renv-lst) (env '()))
510                                  (if (null? renv-lst) env
511                                      (recur (cdr renv-lst) (cgenenv-union (car renv-lst) env)))))))
512
513                (make-codegen 
514
515                 rv
516                 
517                 (fold (lambda (name env) (cgenenv-add name rv env)) cgenenv-empty (map car renv))
518                 
519                 (let ((fflds  (map fld fcodegen-lst (map sfarrow-dfe flst)))
520                       (gflds  (map fld gcodegen-lst (map sfarrow-dfe glst))))
521                   (append
522                    (concatenate (map (lambda (f) (relations-codegen f env)) (append flst glst)))
523                    (concatenate expr-lst)
524                    (list (B:Val rv (V:Rec (map (lambda (s) `(,s ,(select-signal 'union4 s renv))) (map car renv)))))
525                    ))
526               
527               )))
528            ))
529      ;; signature
530      `(UNION ,(sfarrow-sig f) ,(sfarrow-sig g))
531      ;; children
532      `(UNION  ,f ,g)
533      ;; relations
534      (append (sfarrow-relations f) (sfarrow-relations g))
535      ))
536)
537
538
539;; The [sequence] combinator composes two signal functions:
540
541(define (sf-sequence f g)
542   (let* ((fe      (sfarrow-dfe f))
543          (ge      (sfarrow-dfe g))
544
545          (fe-in   (dfe-in fe))   
546          (fe-out  (compose (dfe-out fe) fe-in))
547          (fe-gen  (compose (dfe-gen fe) fe-in))
548          (fe-kill (compose (dfe-kill fe) fe-in))
549
550          (ge-in   (compose (dfe-in ge) (lambda (s) (lset-union eq? (fe-out s) s))))
551          (ge-out  (compose (dfe-out ge) ge-in))
552          (ge-gen  (compose (dfe-gen ge) ge-in))
553          (ge-kill (compose (dfe-gen ge) ge-in))
554
555          )
556
557     (make-sfarrow
558     
559      ;; dataflow equations
560      (make-dfe
561       ;; gen
562       (lambda (s) (lset-union eq? (fe-gen s) (ge-gen s)))
563       
564       ;; kill
565       (lambda (s) (lset-union eq? ((dfe-kill fe) s) ((dfe-kill ge) s)))
566       
567       ;; in
568       (lambda (s) 
569         (lset-union eq? (fe-in s) 
570                     (lset-difference eq? (ge-in s)
571                                      (fe-out s))))
572       
573       ;; out
574       (lambda (s) 
575         (lset-union eq? (fe-out s) (ge-out s)))
576       
577       )
578
579      ;; codegen
580      (lambda (s env dfe) 
581        (let* (
582               
583               (fenv (list->cgenenv 'sequence11 (fe-in s) env))
584               (fcodegen ((sfarrow-codegen f) (fe-in s) fenv fe))
585
586               (genv (list->cgenenv 'sequence12 (lset-difference eq? (ge-in s) (fe-out s)) env))
587               (genv (fold (lambda (s env) 
588                             (let ((v (cgenenv-find 'sequence1 s (codegen-renv fcodegen))))
589                               (cgenenv-add s v env)))
590                           genv (fe-out s)))
591               (gcodegen ((sfarrow-codegen g) (ge-in s) genv ge))
592               
593               (fld  (lambda (codegen)
594                       (let ((renv (codegen-renv codegen)))
595                         (lambda (x) 
596                           (list x (select-signal 'sequence2 x renv))))))
597               
598               (rv  (gensym 'sequence))
599               )
600
601          (make-codegen
602           rv
603           (fold (lambda (name env) (cgenenv-add name rv env)) cgenenv-empty ((dfe-out dfe) s))
604           (append
605            (relations-codegen f env)
606            (relations-codegen g env)
607            (codegen-expr fcodegen)
608            (codegen-expr gcodegen)
609            (list (B:Val rv (V:Rec (append (map (fld fcodegen) (lset-difference eq? (fe-out s) (ge-out s)))
610                                           (map (fld gcodegen) (ge-out s))))))))
611          ))
612      ;; signature
613      `(SEQUENCE ,(sfarrow-sig f) ,(sfarrow-sig g))
614      ;; children
615      `(SEQUENCE ,f ,g)
616      ;; relations
617      (append (sfarrow-relations f) (sfarrow-relations g))
618      )))
619
620
621;; The [on] combinator takes the value of f when b is true, otherwise
622;; it is equivalent to identity
623
624(define (sf-on f e)
625
626   (let* ((fe      (sfarrow-dfe f))
627
628          (fe-in   (dfe-in fe))   
629          (fe-out  (compose (dfe-out fe) fe-in))
630          (fe-gen  (compose (dfe-gen fe) fe-in))
631          (fe-kill (compose (dfe-kill fe) fe-in))
632
633          )
634
635     (make-sfarrow
636     
637      ;; dataflow equations
638      (make-dfe
639       ;; gen
640       (lambda (s) (fe-gen s))
641       
642       ;; kill
643       (lambda (s) ((dfe-kill fe) s))
644       
645       ;; in
646       (lambda (s)  (lset-union eq? (fe-in s) 
647                                (lset-union eq? (fe-out s) (list e))))
648       
649       ;; out
650       (lambda (s) (lset-union eq? (fe-out s) (list e)))
651       
652       )
653
654      ;; codegen
655      (lambda (s env dfe) 
656        (let* (
657               
658               (fenv (list->cgenenv 'on1 (fe-in s) env))
659               (fcodegen ((sfarrow-codegen f) (fe-in s) fenv fe))
660
661               (fld  (lambda (codegen)
662                       (let ((renv (codegen-renv codegen)))
663                         (lambda (x) 
664                           (list x (select-signal 'on2 x renv))))))
665               
666               (ev (select-signal 'on3 e env))
667
668               (rv  (gensym 'onrv))
669               (onf (gensym 'onf))
670               )
671
672          (make-codegen
673           rv
674           (fold (lambda (name env) (cgenenv-add name rv env)) cgenenv-empty ((dfe-out dfe) s))
675           (list
676            (B:Val onf (V:Fn (fe-in s) 
677                             (E:Let (append
678                                     (relations-codegen f env)
679                                     (codegen-expr fcodegen))
680                                    (E:Ret (V:Rec (delete-duplicates 
681                                                   (cons (list e ev) (map (fld fcodegen) (fe-out s)))))))))
682            (B:Val rv  (V:Ifv ev
683                              (V:Op onf (map (lambda (x) (select-signal 'on4 x env)) (fe-in s)))
684                              (V:Rec (delete-duplicates
685                                      (cons (list e ev) (map (lambda (x) (list x (select-signal 'on5 x env)))
686                                                             ((dfe-out dfe) s)))))))
687            ))
688          ))
689      ;; signature
690      `(ON ,(sfarrow-sig f) ,e)
691      ;; children
692      `(ON ,f)
693      ;; relations
694      (sfarrow-relations f)
695      )))
696
697
698;; [sense s f], applies [f] to the signal named [sn] sent to the
699;; resulting signal function:
700
701(define (sf-sense sns f)
702
703  (let* ((pred    (lambda (s) (member (signal-name s) sns)))
704         (fe      (sfarrow-dfe f)))
705
706    (make-sfarrow
707
708     ;; dataflow equations
709     (make-dfe
710      ;; gen
711      (lambda (s) ((dfe-gen fe) s))
712     
713      ;; kill
714      (lambda (s) ((dfe-kill fe) s))
715     
716      ;; in
717      (lambda (s) sns)
718     
719      ;; out
720      (lambda (s) ((dfe-out fe) s))
721      )
722
723     ;; codegen
724     (lambda (s env dfe) 
725       (let* (
726              (fenv      (list->cgenenv 'sense11 ((dfe-in dfe) s) env))
727              (fcodegen  ((sfarrow-codegen f) ((dfe-in dfe) s) fenv (sfarrow-dfe f)))
728              )
729         (make-codegen 
730          (codegen-rv fcodegen)
731          (codegen-renv fcodegen)
732          (append (relations-codegen f env) (codegen-expr fcodegen))
733          )))
734     ;; signature
735     `(SENSE ,sns ,(sfarrow-sig f))
736     ;; children
737     `(SENSE ,f)
738     ;; relations
739     (sfarrow-relations f)
740  )))
741
742;; [actuate s f]
743
744(define (sf-actuate sns f)
745
746  (let* ((fe (sfarrow-dfe f))
747         
748         (fe-in   (dfe-in fe))   
749         (fe-out  (compose (dfe-out fe) fe-in))
750         (fe-gen  (compose (dfe-gen fe) fe-in))
751         (fe-kill (compose (dfe-kill fe) fe-in)))
752
753    (make-sfarrow
754     
755     ;; dataflow equations
756     (make-dfe
757      ;; gen
758      (lambda (s) (lset-union eq? sns (fe-gen s)))
759     
760      ;; kill
761      (lambda (s) (lset-union eq? (fe-kill s)
762                              (lset-intersection eq? s sns)))
763     
764      ;; in
765      (lambda (s) (fe-in s))
766     
767      ;; out
768      (lambda (s) sns)
769      )
770
771     ;; codegen
772     (lambda (s env dfe) 
773
774       (let* (
775              (fenv      (list->cgenenv 'actuate11 (fe-in s) env))
776              (fcodegen  ((sfarrow-codegen f) (fe-in s) fenv (sfarrow-dfe f)))
777              (rv        (gensym 'actuate))
778              (renv      (codegen-renv fcodegen))
779              (fldr      (lambda (n n1) (list n (select-signal 'actuate n1 renv))))
780              )
781
782         (let ((r 
783                (make-codegen
784                 rv
785                 (cgenenv-union (codegen-renv fcodegen)
786                                (map (lambda (s) (cons s rv)) sns))
787                 (append
788                  (relations-codegen f env)
789                  (codegen-expr fcodegen)
790                         (list (B:Val rv (V:Rec (map fldr sns (fe-out s)))))))))
791           r)
792         ))
793     ;; signature
794     `(ACTUATE ,sns ,(sfarrow-sig f))
795     ;; children
796     `(ACTUATE ,f)
797     ;; relations
798     (sfarrow-relations f)
799     )))
800
801
802;; [reduce f init]
803
804(define (sf-reduce f name init)
805
806  (define (step name input inax outax env)
807    (B:Val outax (V:Op name (list (select-signal 'reduce input env)
808                                  (V:Var inax)))))
809
810  (if (not (function? f))
811      (error 'sf-reduce "argument f not a pure function: " f))
812
813     (make-sfarrow 
814      ;; dataflow equations
815      (make-dfe
816       ;; gen
817       (lambda (s) (list name))
818       ;; kill
819       (lambda (s) s)
820       ;; in
821       (lambda (s) s)
822       ;; out
823       (lambda (s) (list name)))
824
825      ;; codegen
826      (lambda (s env dfe) 
827
828        (let ((in   (lset-difference eq? ((dfe-in dfe) s) (list init ))))
829
830          (if (null? in) (error 'sf-reduce "empty input: " in))
831
832            (let recur ((inax    init)
833                        (rv      (gensym 'ax))
834                        (inputs  in)
835                        (decls   '()))
836
837
838              (if (null? inputs)
839
840                  (let ((rvf (gensym 'reduce)))
841                    (make-codegen
842                     rvf
843                     (cgenenv-add name rvf cgenenv-empty)
844                     (append
845                      (list (function->expr name f)) 
846                      (reverse decls)
847                      (list (B:Val rvf (V:Rec `((,name ,(V:Var inax)))))))
848                     ))
849
850                  (recur rv (gensym 'ax) 
851                         (cdr inputs)
852                         (cons (step name (car inputs) inax rv env) decls))
853                  ))
854            ))
855
856      ;; signature
857      `(REDUCE ,f ,init ,name)
858      ;; children
859      `(REDUCE)
860      ;; relations
861      `()
862
863      ))
864
865
866
867;; Recurring state transitions
868
869(define (sf-rtransition0 f fk e ek state)
870
871  (let* ((fe      (sfarrow-dfe f))
872         (fke     (sfarrow-dfe fk))
873         
874         (fe-in   (dfe-in fe))
875         (fe-out  (compose (dfe-out fe)  fe-in))
876         (fe-gen  (compose (dfe-gen fe)  fe-in))
877         (fe-kill (compose (dfe-kill fe) fe-in))
878         
879         (fke-in   (dfe-in fke))
880         (fke-out  (compose (dfe-out fke) fke-in))
881         (fke-gen  (compose (dfe-gen fke) fke-in))
882         (fke-kill (compose (dfe-gen fke) fke-in))
883
884         (fintegrals (integrals f))
885         (fkintegrals (integrals fk))
886         )
887   
888    (for-each (lambda (x) (let ((evs (dynvector-ref integral-events x)))
889                            (dynvector-set! integral-events x (cons e evs))))
890              (map car fintegrals))
891    (for-each (lambda (x) (let ((evs (dynvector-ref integral-events x)))
892                            (dynvector-set! integral-events x (cons ek evs))))
893              (map car fkintegrals))
894
895    (make-sfarrow
896     
897     ;; dataflow equations
898     (make-dfe
899     
900      ;; gen
901      (lambda (s) (lset-union eq? (list state)
902                              (lset-union eq? (fe-gen s) (fke-gen s))))
903     
904      ;; kill
905      (lambda (s) (lset-union eq? (list state)
906                              (lset-union eq? (fe-kill s) (fke-kill s))))
907     
908      ;; in
909      (lambda (s) (lset-union eq? (list state)
910                              (lset-union eq? (fe-in s) (fke-in s)
911                                          (cond ((symbol? ek) (list e ek))
912                                                (else (list e))))))
913     
914      ;; out
915      (lambda (s) (lset-union eq? (list state)
916                              (lset-union eq? (fe-out s) (fke-out s))))
917      )
918     
919     ;; codegen
920     (lambda (s env dfe) 
921       (let* (
922              (stm        (gensym 'trstm))
923              (rv         (gensym 'trv))
924              (blender    (gensym 'blender))
925             
926              (blender-inputs     ((dfe-in dfe) s))
927              (blender-env        (map (lambda (s) (cons s s)) blender-inputs))
928
929              (blender-outputs    (lset-intersection eq? (fe-out s) (fke-out s)))
930              (blender-return     (lambda (kons codegen)
931                                    (let ((renv (codegen-renv codegen)))
932                                      (E:Ret (V:Op kons 
933                                                   (list (V:Rec (map (lambda (p) 
934                                                                       (list (car p) (V:Sel (car p) (V:Var (cdr p))))) 
935                                                                     renv))))))))
936
937             
938              (fenv   (list->cgenenv 'rtransition11 (fe-in s) blender-env))
939              (fkenv  (list->cgenenv 'rtransition12 (fke-in s) blender-env))
940             
941              (fcodegen  ((sfarrow-codegen f) 
942                          (lset-union eq? (fe-in s)
943                                      (cond ((symbol? ek) (list e ek))
944                                            (else (list e))))
945                          fenv (sfarrow-dfe f)))
946              (fkcodegen ((sfarrow-codegen fk) 
947                          (lset-union eq? (fke-in s)
948                                      (cond ((symbol? ek) (list e ek))
949                                            (else (list e))))
950                          fkenv (sfarrow-dfe fk)))
951             
952              (ftrans  (lset-union eq? (lset-intersection eq? (fe-out s) (fke-in s))
953                                   (list e)))
954              (fktrans (lset-union eq? (lset-intersection eq? (fke-out s) (fe-in s))
955                                   (cond ((symbol? ek) (list ek))
956                                         (else (list)))))
957             
958              (fblend   (lambda (state x)
959                          (V:Op 'tsCase 
960                                  (list (V:Fn '(x) 
961                                              (E:Ret (V:Rec (cons
962                                                             (list state (V:Var state))
963                                                             (append
964                                                              (map (lambda (s) (list s (V:Sel s (V:Var 'x))))
965                                                                   blender-outputs)
966                                                              (map (lambda (s) (list s (V:Var s)))
967                                                                   (lset-difference eq? 
968                                                                                    (lset-union eq? ftrans fktrans)
969                                                                                    blender-outputs)))))))
970                                       
971                                        (V:Fn '(x) 
972                                              (E:Ret (V:Rec (cons
973                                                             (list state (V:Var state))
974                                                             (append
975                                                              (map (lambda (s) (list s (V:Sel s (V:Var 'x))))
976                                                                   blender-outputs)
977                                                              (map (lambda (s) (list s (V:Var s)))
978                                                                   (lset-difference eq?
979                                                                                    (lset-union eq? ftrans fktrans)
980                                                                                    blender-outputs)))))))
981                                       
982                                       
983                                        (V:Var x)))))
984             
985              (fkblend    (lambda (state x) 
986                            (V:Op 'tsCase 
987                                    (list (V:Fn '(x) 
988                                                (E:Ret (V:Rec (cons
989                                                               (list state (V:Var state))
990                                                               (append
991                                                                (map (lambda (s) (list s (V:Sel s (V:Var 'x))))
992                                                                    blender-outputs)
993                                                                (map (lambda (s) (list s (V:Sel s (V:Var 'x))))
994                                                                     (lset-difference eq? 
995                                                                                      ftrans 
996                                                                                      blender-outputs))
997                                                                (map (lambda (s) (list s (V:Var s)))
998                                                                     (lset-difference eq? 
999                                                                                      fktrans
1000                                                                                      blender-outputs)))))))
1001                                         
1002                                          (V:Fn '(x) 
1003                                                (E:Ret (V:Rec (cons
1004                                                               (list state (V:Var state))
1005                                                               (append
1006                                                                (map (lambda (s) (list s (V:Sel s (V:Var 'x))))
1007                                                                     blender-outputs)
1008                                                                (map (lambda (s) (list s (V:Sel s (V:Var 'x))))
1009                                                                     (lset-difference eq? 
1010                                                                                      fktrans 
1011                                                                                      blender-outputs))
1012                                                                (map (lambda (s) (list s (V:Var s)))
1013                                                                     (lset-difference eq? 
1014                                                                                      ftrans
1015                                                                                      blender-outputs)))))))
1016                                         
1017                                         
1018                                          (V:Var x)))))
1019             
1020              )
1021         
1022         (if (null? (lset-intersection eq? (fe-out s) (fke-out s)))
1023             (error 'sf-rtransition "the outputs of argument functions f and fk must have a non-empty intersection"
1024                    (sfarrow-sig f) 
1025                    (sfarrow-sig fk)))
1026         
1027         (codegen-state
1028          (append
1029           (reverse
1030            (list
1031
1032             (B:Val stm
1033                    (V:Op 'TRC
1034                          (list
1035                            (V:Fn blender-inputs
1036                                  (E:Let (append
1037                                          (relations-codegen f env)
1038                                          (codegen-expr fcodegen))
1039                                         (blender-return 'TRSA fcodegen)))
1040                            (V:Fn blender-inputs
1041                                  (E:Let (append
1042                                          (relations-codegen fk env)
1043                                          (codegen-expr fkcodegen))
1044                                         (blender-return 'TRSB fkcodegen)))
1045                            (V:Fn (list 'x) (E:Ret (V:Op 'tsCase 
1046                                                         (list (V:Fn '(x) 
1047                                                                     (E:Ret (V:Sel e (V:Var 'x))
1048                                                                            ))
1049                                                               (cond ((symbol? ek) 
1050                                                                      (V:Fn '(x) (E:Ret (V:Sel ek (V:Var 'x)))))
1051                                                                     (ek    (V:Fn '(x) (E:Ret (V:C 'true))))
1052                                                                     (else  (V:Fn '(x) (E:Ret (V:C 'false)))))
1053                                                               (V:Var 'x)))))
1054                           )))
1055             
1056             (B:Val blender
1057                    (V:Fn (cons stm blender-inputs)
1058                          (E:Let `(
1059                                   ,(B:Val 'f     (V:Op 'trfOf (list (V:Var stm))))
1060                                   ,(B:Val 'fk    (V:Op 'trfkOf (list (V:Var stm))))
1061                                   ,(B:Val 'e     (V:Op 'treOf (list (V:Var stm))))
1062                                   ,(B:Val 'fv    (V:Ifv (V:Var state) (V:Op 'fk (map V:Var blender-inputs)) (V:Op 'f (map V:Var blender-inputs))))
1063                                   ,(B:Val 'trp   (V:Op 'e (list (V:Var 'fv))))
1064                                   ,(B:Val state  (V:Ifv (V:Var 'trp) (V:Op 'not (list (V:Var state))) (V:Var state)))
1065                                   )
1066                                 (E:Ife (V:Op 'not (list (V:Var 'trp)))
1067                                        (E:Ret
1068                                         (V:Ifv (V:Var state) (fkblend state 'fv) (fblend state 'fv)))
1069                                        (E:Ife (V:Var state)
1070                                               (E:Ret (fkblend state 'fv))
1071                                               (E:Ret (fblend state 'fv)))
1072                                        )
1073                                 ))
1074                    ))
1075            )
1076           (codegen-state)))
1077         
1078         (make-codegen
1079          rv
1080
1081          (fold (lambda (s ax) (cgenenv-add s rv ax))
1082                cgenenv-empty (cons state blender-outputs))
1083
1084          (list
1085           (B:Val rv
1086                  (V:Op blender (cons (V:Var stm)
1087                                      (map (lambda (s) (V:Sel s (V:Var (cgenenv-find 'rtransition22 s env)))) 
1088                                           blender-inputs))))
1089           ))
1090         ))
1091
1092     ;; signature
1093     `(RTRANSITION ,(sfarrow-sig f) ,(sfarrow-sig fk) ,e ,ek ,state)
1094
1095     ;; children
1096     `(RTRANSITION ,f ,fk)
1097
1098     ;; relations
1099     (append (sfarrow-relations f) (sfarrow-relations fk))
1100
1101     ))
1102)
1103
1104(define (sf-rtransition f fk e ek s)
1105  (sf-rtransition0 f fk e ek s))
1106
1107;; One-time state transition
1108
1109(define (sf-transition f fk ev s)
1110  (sf-rtransition0 f fk ev #f s))
1111
1112
1113;; Transient events
1114(define (sf-transient f g e)
1115
1116  (let* ((fe      (sfarrow-dfe f))
1117         (ge      (sfarrow-dfe g))
1118         
1119         (fe-in   (dfe-in fe))
1120         (fe-out  (compose (dfe-out fe) fe-in))
1121         (fe-gen  (compose (dfe-gen fe) fe-in))
1122         (fe-kill (compose (dfe-kill fe) fe-in))
1123         
1124         (ge-in   (dfe-in ge))
1125         (ge-out  (compose (dfe-out ge) ge-in))
1126         (ge-gen  (compose (dfe-gen ge) ge-in))
1127         (ge-kill (compose (dfe-gen ge) ge-in))
1128
1129         (fintegrals (integrals f))
1130         (gintegrals (integrals g))
1131         )
1132
1133    (for-each (lambda (x)
1134                (let ((evs (dynvector-ref integral-events x)))
1135                  (dynvector-set! integral-events x (cons e evs))))
1136              (map car fintegrals))
1137
1138    (make-sfarrow
1139     
1140     ;; dataflow equations
1141     (make-dfe
1142      ;; gen
1143      (lambda (s) (lset-union eq? (fe-gen s) (ge-gen s)))
1144     
1145      ;; kill
1146      (lambda (s) (lset-union eq? (fe-kill s) (fe-kill s)))
1147               
1148      ;; in
1149      (lambda (s)  (lset-union eq?
1150                               (lset-union eq? (fe-in s) (ge-in s))
1151                               (list e)))
1152      ;; out
1153      (lambda (s) 
1154        (lset-intersection eq? (fe-out s) (ge-out s)))
1155     
1156      )
1157     
1158     ;; codegen
1159     (lambda (s env dfe) 
1160
1161       (if (null? (lset-intersection eq? (fe-out s) (ge-out s)))
1162           (error 'sf-transient "the outputs of argument functions f and g must have a non-empty intersection"
1163                  (sfarrow-sig f) 
1164                  (sfarrow-sig g)))
1165         
1166       
1167       (let* (
1168
1169              (rv  (gensym 'transient))
1170
1171              (fcompute  (gensym 'transientf))
1172              (gcompute  (gensym 'transientg))
1173
1174              (fenv      (map (lambda (s) (cons s s)) (fe-in s)))
1175              (fcodegen ((sfarrow-codegen f) 
1176                         (lset-union eq? (fe-in s) (list e))
1177                         fenv fe))
1178
1179              (genv      (map (lambda (s) (cons s s)) (ge-in s)))
1180              (gcodegen ((sfarrow-codegen g) 
1181                         (lset-union eq? (ge-in s) (list e))
1182                         genv ge))
1183
1184              )
1185
1186         (codegen-state
1187          (append
1188           (list
1189           
1190            (B:Val fcompute
1191                   (V:Fn (fe-in s) 
1192                         (E:Let
1193                          (append (relations-codegen f env)
1194                                  (codegen-expr fcodegen))
1195                          (E:Ret (V:Rec (map (lambda (x) (list x (select-signal '(transient fcompute) x (codegen-renv fcodegen))))
1196                                             ((dfe-out dfe) s))))
1197                          )))
1198                   
1199            (B:Val gcompute
1200                   (V:Fn (ge-in s) 
1201                         (E:Let
1202                          (append (relations-codegen g env)
1203                                  (codegen-expr gcodegen))
1204                          (E:Ret (V:Rec (map (lambda (x) (list x (select-signal '(transient gcompute) x (codegen-renv gcodegen))))
1205                                             ((dfe-out dfe) s))))
1206                          )))
1207                   
1208            )
1209           
1210           (codegen-state)))
1211         
1212         (make-codegen
1213          rv
1214
1215          (list->cgenenv '(transient renv)
1216                         ((dfe-out dfe) s)
1217                         (fold (lambda (s env) (cgenenv-add s rv env)) cgenenv-empty ((dfe-out dfe) s)))
1218         
1219           (list
1220            (B:Val rv
1221                   (V:Ifv (select-signal '(transient rv) e env)
1222                          (V:Op gcompute (map (lambda (x) (select-signal '(transient state-compute) x env)) 
1223                                              (ge-in s)))
1224                          (V:Op fcompute (map (lambda (x) (select-signal '(transient state-compute) x env)) 
1225                                              (fe-in s)))
1226                          ))
1227           ))
1228         ))
1229
1230     ;; signature
1231     `(TRANSIENT ,(sfarrow-sig f) ,(sfarrow-sig g) ,e)
1232
1233     ;; children
1234     `(TRANSIENT ,f ,g)
1235
1236     ;; relations
1237     (append (sfarrow-relations f) (sfarrow-relations g))
1238
1239     ))
1240)
1241
1242
1243
1244(define integral-index (make-parameter 0))
1245(define integral-events (make-dynvector 0 '()))
1246
1247
1248(define (sf-integral0 x ys h fs method)
1249
1250  (let* ((xn     (gensym (string->symbol (s+ x "+h"))))
1251         (yis    (if (and (adaptive-integral) (symbol? h))
1252                     (list-tabulate (length ys) (lambda (i) (+ 1 i)))
1253                     (list-tabulate (length ys) (lambda (i) i))))
1254         (yns    (map (lambda (y) (gensym (string->symbol (s+ y "(" xn ")")))) ys))
1255         (ynvs   (map (lambda (yn) (gensym (string->symbol (s+ yn "v")))) yns))
1256         (yps    (map (lambda (y) (gensym (string->symbol (s+ y "prime")))) ys))
1257         (idx    (let ((v (integral-index)))
1258                   (integral-index (+ 1 (integral-index)))
1259                   v))
1260         )
1261
1262    (let ((fs-formals (map function-formals fs)))
1263
1264      (make-sfarrow
1265       
1266       ;; dataflow equations
1267       (make-dfe
1268
1269        ;; gen
1270        (lambda (s) (if (and (adaptive-integral) (symbol? h))
1271                        (cons h yns) yns))
1272       
1273        ;; kill
1274        (lambda (s) (lset-union eq? s (list xn)))
1275       
1276        ;; in
1277        (lambda (s) 
1278          (let ((x (lset-union eq?
1279                               (dynvector-ref integral-events idx)
1280                               (lset-union eq? 
1281                                           (concatenate fs-formals)
1282                                           (append (if (symbol? h) (list h) '())
1283                                                   (cons x ys))))))
1284            x))
1285       
1286        ;; out
1287        (lambda (s) (if (and (adaptive-integral) (symbol? h))
1288                        (cons h yns) yns))
1289        )
1290       
1291       ;; codegen
1292       (let (
1293             (rv1 (gensym 'integral))
1294             (rv2 (gensym 'integral))
1295             (dfn (gensym 'dfn))
1296             )
1297             
1298         (lambda (s env dfe)
1299
1300           (let* (
1301                  (events    (dynvector-ref integral-events idx))
1302                 
1303                  (idxv      (V:C idx))
1304
1305                  (tstep     (if (symbol? h) 
1306                                 (select-signal 'integral1 h env)
1307                                 (V:C h)))
1308                 
1309                  (fenv      (list->cgenenv 'integral2 (concatenate fs-formals)
1310                                            (cgenenv-add x x (fold (lambda (y env) (cgenenv-add y y env)) env ys))))
1311
1312                  (fargs     (map (lambda (ss) (map (lambda (s) (select-signal 'integral3 s fenv)) ss)) fs-formals))
1313                  )
1314
1315             (make-codegen
1316
1317              rv2
1318
1319              ((lambda (env) (if (and (adaptive-integral) (symbol? h))
1320                                 (cons (cons h rv2) env) env))
1321               (map (lambda (s) (cons s rv2)) yns))
1322
1323              (append
1324
1325               (map function->expr yps fs)
1326
1327               (list
1328
1329                (B:Val dfn 
1330                       (V:Fn `(,x yvec) 
1331                             (E:Let (map (lambda (y i) (B:Val y (V:Sub i (V:Var 'yvec)))) ys yis)
1332                                    (E:Ret (V:Vec (map (lambda (yprime farg) (V:Op yprime farg)) yps fargs)))
1333                                    )))
1334
1335                (B:Val rv1 
1336                       (V:Op 'integrate
1337                             (list (V:Var dfn) 
1338                                   (select-signal 'integral4 x env) 
1339                                   (V:Vec (map (lambda (y) (select-signal 'integral5 y env)) ys))
1340                                   tstep
1341                                   idxv
1342                                   )))
1343
1344
1345                (B:Val rv2
1346                       (V:Rec ((lambda (flds) 
1347                                 (if (and (adaptive-integral) (symbol? h))
1348                                     (cons `(,h ,(V:Sub 0 (V:Var rv1))) flds) 
1349                                     flds))
1350                               (map (lambda (yn yi) `(,yn ,(V:Sub yi (V:Var rv1)) )) yns yis)) ))
1351                )
1352               ))
1353             ))
1354         )
1355
1356       ;; signature
1357       `(INTEGRAL ,idx ,h ,x ,ys)
1358
1359       ;; children
1360       `(INTEGRAL)
1361
1362       ;; relations
1363       `()
1364
1365       ))
1366      ))
1367 
1368
1369
1370(define (sf-integralh x y h f)
1371  (sf-integral0 x y h f))
1372
1373
1374(define (construct d #!key (method 'rk3))
1375  (integral-index 0)
1376  (dynvector-clear! integral-events 0)
1377  (construct1 d method))
1378
1379
1380(define (construct1 d method)
1381  (let recur ((d d))
1382    (cases diagram d
1383           (IDENTITY (f)               (sf-identity (recur f)))
1384           (PURE (f)                   (sf-pure f))
1385           (PRIM (f name)              (sf-prim f name))
1386           (RELATION (r f)             (sf-relation r (recur f)))
1387           (SEQUENCE (f g)             (sf-sequence (recur f) (recur g)))
1388           (UNION (f g)                (sf-union (recur f) (recur g)))
1389           (SENSE (s f)                (sf-sense s (recur f)))
1390           (ACTUATE (s f)              (sf-actuate s (recur f)))
1391           (REDUCE (f n i)             (sf-reduce f n i))
1392           (RTRANSITION (f g ef eg s)  (sf-rtransition (recur f) (recur g) ef eg s))
1393           (TRANSITION (f g ef s)      (sf-transition (recur f) (recur g) ef s))
1394           (TRANSIENT (f g e)          (sf-transient (recur f) (recur g) e))
1395           (ON (f e)                   (sf-on (recur f) e))
1396           (INTEGRAL  (x ys h fs)      (sf-integralh method x ys h fs))
1397           )))
1398
1399
1400(define (dataflow f input)
1401  (let ((dfe (sfarrow-dfe f)))
1402    `((gen  . ,((dfe-gen dfe) input))
1403      (kill . ,((dfe-kill dfe) input))
1404      (in   . ,((dfe-in dfe) input))
1405      (out  . ,((dfe-out dfe) input)))))
1406
1407
1408(define (events f)
1409  (let recur ((f f) (ax '()))
1410    (let ((sig (sfarrow-sig f)))
1411      (case (car sig)
1412        ((RTRANSITION)
1413         (let ((ef (fourth sig)) (eg (fifth sig)))
1414           (let* ((ax1 (cons ef ax))
1415                  (ax2 (if (symbol? eg)  (cons eg ax1) ax1)))
1416             (fold recur ax2 (cdr (sfarrow-children f)))
1417             )))
1418        ((TRANSIENT)
1419         (let ((e (fourth sig)))
1420           (let* ((ax1 (cons e ax)))
1421             (fold recur ax1 (cdr (sfarrow-children f)))
1422             )))
1423        ((ON)
1424         (let ((e (third sig)))
1425           (let* ((ax1 (cons e ax)))
1426             (fold recur ax1 (cdr (sfarrow-children f)))
1427             )))
1428        ((SF)
1429         (let ((evs (fifth sig)))
1430           (if (null? evs) ax (append evs ax))))
1431        (else (fold recur ax (cdr (sfarrow-children f))))
1432        ))
1433    ))
1434
1435
1436(define (integrals f)
1437  (let recur ((f f) (ax '()))
1438    (let ((sig (sfarrow-sig f)))
1439      (case (car sig)
1440        ((INTEGRAL)
1441           (let ((ax1 (cons (cdr sig) ax)))
1442             (fold recur ax1 (cdr (sfarrow-children f)))
1443             ))
1444        (else (fold recur ax (cdr (sfarrow-children f))))
1445        ))
1446    ))
1447
1448
1449(define (codegen/Octave name f #!key (initial #f) (pre #t) (solver #f))
1450
1451  (if (and solver (not (member solver '(lsode rkfe rk3 rk4a rk4b rkhe rkbs rkf45))))
1452      (error 'codegen/Octave "unknown solver" solver))
1453 
1454  (let ((dfe (sfarrow-dfe f)))
1455
1456    (codegen-state '())
1457
1458    (let* ((input    (or (and initial (map car initial)) ((dfe-in dfe) '())))
1459           (fenv     (map (lambda (s) (cons s 'input)) input))
1460           (fcodegen ((sfarrow-codegen f) input fenv dfe ))
1461           (relations-expr (relations-codegen f input))
1462           (globals   (filter-map
1463                       (lambda (x) 
1464                         (cases binding x
1465                                (B:Val  (name v) (name/Octave name))
1466                                (else  #f)))
1467                       (codegen-state))))
1468
1469      (if pre (print-fragments (prelude/Octave solver: solver)))
1470      (print-fragments (list "global " (intersperse globals " ") ";" nl))
1471
1472      (print-fragments (list (map (lambda (x) 
1473                                    (if (binding? x)
1474                                        (cases binding x
1475                                               (B:Val  (name v) (list (name/Octave name) " = " (value->Octave v) ";" nl)))
1476                                        (expr->Octave x)))
1477                                  (reverse (codegen-state))) nl))
1478
1479      (print-fragments
1480       (list
1481        "function " (name/Octave (codegen-rv fcodegen)) " = " (name/Octave name) " (input)" nl
1482        (list "global " (intersperse globals " ") ";" nl)
1483        (map (lambda (x) (list (name/Octave x) " = " (value->Octave (V:Sel x (V:Var 'input))) "; " nl)) input)
1484        nl
1485        (map binding->Octave (append relations-expr (codegen-expr fcodegen))) nl 
1486        "endfunction" nl))
1487
1488     
1489      (if initial
1490              (print-fragments
1491               (list (name/Octave name) "_initial = " 
1492                     (value->Octave
1493                      (V:Rec (map (lambda (x) (let ((n (car x)) (v (cadr x)))
1494                                                (let ((v (cond ((and (or (number? v) (symbol? v))) v)
1495                                                               ((boolean? v) (if v 'true 'false))
1496                                                               (else v))))
1497                                                  (list n (V:C v)))))
1498                                  initial)))
1499                     nl))
1500              )
1501
1502
1503      )))
1504
1505(define (codegen/scheme name f #!key (initial #f) (pre #t) (solver 'rk4b))
1506
1507  (if (and solver (not (member solver '(cvode rkfe rk3 rk4a rk4b rkhe rkbs rkf45 rkck rkdp rkf78 rkv65))))
1508      (error 'codegen/scheme "unknown solver" solver))
1509
1510  (let ((dfe (sfarrow-dfe f)))
1511
1512    (codegen-state '())
1513
1514    (let* ((input    (or (and initial (map car initial)) ((dfe-in dfe) '())))
1515           (fenv     (map (lambda (s) (cons s 'input)) input))
1516           (fcodegen ((sfarrow-codegen f) input fenv dfe ))
1517           (relations-expr (relations-codegen f input)))
1518
1519      (if pre (print-fragments (prelude/scheme solver: solver integral-index: (integral-index))))
1520
1521      (print-fragments (list (map (lambda (x) 
1522                                    (if (binding? x)
1523                                        (cases binding x
1524                                               (B:Val  (name v)
1525                                                       (list "(define " (name/scheme name) " " (value->scheme v) ")" nl)))
1526                                        (expr->scheme x)))
1527                                  (reverse (codegen-state))) nl))
1528
1529      (print-fragments
1530       (list
1531        "(define (" (name/scheme name) " input)" nl
1532        "(let (" (intersperse (map (lambda (x) (binding->scheme (B:Val x (V:Sel x (V:Var 'input))))) input) " ")  ")"  nl
1533        "(let* (" (map binding->scheme (append relations-expr (codegen-expr fcodegen))) nl ")" nl
1534        (codegen-rv fcodegen) nl
1535        ")))" nl))
1536
1537      (if initial
1538          (print-fragments
1539           (list "(define " (name/scheme name) "_initial " 
1540                 (value->scheme
1541                  (V:Rec (map (lambda (x) (let ((n (car x)) (v (cadr x)))
1542                                            (let ((v (cond ((and (or (number? v) (symbol? v))) v)
1543                                                           ((boolean? v) (if v 'true 'false))
1544                                                           (else v))))
1545                                              (list n (V:C v)))))
1546                              initial))) ")" nl)))
1547
1548
1549      )))
1550
1551(define (codegen/ML name f #!key (initial #f) (pre #t) (post #t) (solver 'rk4b))
1552
1553  (if (and solver (not (member solver '(rkfe rk3 rk4a rk4b rkhe rkbs rkf45 rkck rkdp rkf78 rkv65))))
1554      (error 'codegen/ML "unknown solver" solver))
1555
1556  (let ((dfe (sfarrow-dfe f)))
1557
1558    (codegen-state '())
1559
1560    (let* ((input    (or (and initial ((dfe-in dfe) (map car initial)))
1561                         ((dfe-in dfe) '())))
1562           (fenv     (map (lambda (s) (cons s 'input)) input))
1563           (fcodegen ((sfarrow-codegen f) input fenv dfe ))
1564           (relations-expr (relations-codegen f input))
1565           )
1566
1567      (if pre (print-fragments (prelude/ML solver: solver)))
1568
1569      (print-fragments (list (map (lambda (x) 
1570                                    (if (binding? x)
1571                                        (cases binding x
1572                                               (B:Val  (name v)
1573                                                       (list "val " (name/ML name) " = " (value->ML v) nl)))
1574                                        (expr->ML x)))
1575                                  (reverse (codegen-state))) nl))
1576
1577
1578      (print-fragments
1579       (list
1580        "fun " (name/ML name) "(input as {" (intersperse (map name/ML input) ",")  "})" " = " nl
1581        "let" nl
1582        (map binding->ML (append relations-expr (codegen-expr fcodegen))) nl
1583        "in" nl
1584        (codegen-rv fcodegen)   nl
1585        "end" nl))
1586
1587      (if initial
1588          (print-fragments
1589           (list "val " (name/ML name) "_initial = " 
1590                 (value->ML (V:Rec (map (lambda (x) 
1591                                          (let ((n x) (v (car (alist-ref x initial))))
1592                                            (list n 
1593                                                  (cond ((and (or (number? v) (symbol? v))) 
1594                                                         (V:C v))
1595                                                        ((boolean? v) 
1596                                                         (V:C (if v 'true 'false)))
1597                                                        (else (V:C v))))
1598                                                    ))
1599                                        input))) nl)))
1600
1601      (if post (print-fragments (list "end" nl)))
1602     
1603      )))
1604
1605
1606
1607
1608)
1609
Note: See TracBrowser for help on using the repository browser.