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

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

signal-diagram/flsim: adaptive integration refactoring of transients; moving supporting numerical libraries to signal-diagram

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