source: project/release/4/signal-diagram/tags/3.4/signal-diagram.scm @ 30918

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

signal-diagram release 3.4

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