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

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

signal-diagram: beginning refactoring to allow event detection in variable-step integrators

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