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

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

flsim/signal-diagram: adaptive integration refactoring

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