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

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

signal-diagram/flsim: synchronizing changes related to adaptive time step solvers

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