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

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

signal-diagram / 9ML-toolkit: refactoring transients

File size: 58.3 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 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?) (eg symbol?)
203                (s  symbol?)
204                )
205  (TRANSIENT    (f diagram?) (g diagram?) (e symbol?) (ef diagram?) )
206  (ON           (f diagram?) (e symbol?) )
207  (INTEGRAL     (i symbol?) 
208                (d symbol-list?) (h hspec?)
209                (f function-list?) )
210  )
211
212
213
214(define (select-signal loc s env)
215  (let ((v (cgenenv-find loc s env)))
216    (if (eq? s v) (V:Var s) (V:Sel s (V:Var v)))))
217
218
219(define-record-type codegen
220  (make-codegen0 rv renv expr)
221  codegen?
222  (rv          codegen-rv)
223  (renv        codegen-renv)
224  (expr        codegen-expr)
225  )
226
227(define (make-codegen rv renv expr)
228  (if (not (symbol? rv)) (error 'make-codegen "invalid return variable"))
229  (make-codegen0 rv renv expr))
230
231
232(define codegen-state (make-parameter '()))
233   
234                                           
235;;
236;;  The arrow combinators are used to build signal functions upon pure
237;;  functions.
238;; 
239
240;;  [sf f] encapsulates a pure function into a signal function.
241
242
243(define (sf f . rest)
244  (let-optionals rest ((name (gensym 'sf)))
245   (let* (
246          (fd (and (extended-procedure? f) (procedure-data f)))
247          (formals (or (and (prim? fd) (prim-outputs fd)) 
248                       (and (function? fd) (function-formals fd))
249                       '()))
250          (outputs (or (and (prim? fd) (prim-outputs fd)) '()))
251          (states (or (and (prim? fd) (prim-states fd)) '()))
252          (events (or (and (prim? fd) (prim-events fd)) '()))
253          )
254
255     (make-sfarrow 
256      ;; dataflow equations
257      (make-dfe
258       ;; gen
259       (lambda (s) (if (prim? fd) outputs (list name)))
260       ;; kill
261       (lambda (s) (if (prim? fd) outputs (list name)))
262       ;; in
263       (lambda (s) (if (function? fd) 
264                       (lset-intersection eq? (function-formals fd) s)
265                       s))
266       ;; out
267       (lambda (s) (if (prim? fd) outputs (list name))))
268      ;; codegen
269      (lambda (s env dfe) 
270        (let ((in   ((dfe-in dfe) s))
271              (out  ((dfe-out dfe) s))
272              (rv1  (gensym 'rv))
273              (rv2  (gensym 'rv))
274              (init-name (and (prim? fd) (gensym (string->symbol (string-append (->string name) "init")))))
275              )
276
277          (make-codegen
278           rv2
279           (fold (lambda (name env) (cgenenv-add name rv2 env)) cgenenv-empty out)
280           (append
281           
282            (cond ((function? fd)
283                   (list (function->expr name fd)))
284                  ((prim? fd)
285                   (list (prim->expr name fd) ))
286                  (else (error 'sf "unknown function object" fd)))
287
288            (cond ((function? fd)
289                   (if (null? (function-formals fd))
290                       (list (B:Val rv2 (V:Rec `((,name ,(V:Var name))))))
291                       (list (B:Val rv1 (V:Op name (map (lambda (s) (select-signal 'sf s env)) in)))
292                             (B:Val rv2 (V:Rec `((,name ,(V:Var rv1))))))))
293
294                  ((prim? fd)
295
296                     (codegen-state
297                      (append
298                       (list (prim->init init-name fd))
299                       (codegen-state)))
300
301                     (list (B:Val rv1 (V:Op name (append
302                                                  (map (lambda (s) (select-signal 'sf s env)) in)
303                                                  (map (lambda (x) (V:Sel x (V:Var init-name))) 
304                                                       (lset-difference eq? states in)))))
305                           (B:Val rv2 (V:Rec (map (lambda (s) `(,s ,(V:Sel s (V:Var rv1)))) outputs)))
306                           )
307                     )
308                 
309                  (else (error 'sf "unknown function object" fd))
310                  )
311            ))
312          ))
313      ;; signature
314      `(SF ,name ,states ,outputs ,events)
315      ;; children
316      `(SF)
317      ;; relations
318      `()
319      ))
320     ))
321 
322
323
324
325(define (sf-pure  f . rest)
326  (let-optionals rest ((name (gensym 'sf)))
327    (let* ((f0   (cond ((function? f)  (lambda () `(,name ,(function-formals f) ,(function-body f))))
328                       ((procedure? f) f)
329                       (else (error 'sf-pure "invalid function" f))))
330           (f1 (if (function? f) (extend-procedure f0 f) f0)))
331      (sf f1 name))))
332
333
334(define (sf-prim f name)
335  (let* ((f0   (cond ((prim? f)  (lambda () `(,name ,(append (prim-formals f) (prim-states f)) ,(prim-body f))))
336                     (else (error 'sf-prim "invalid primitive" f))))
337         (f1 (if (prim? f) (extend-procedure f0 f) f0)))
338    (sf f1 name)))
339
340
341(define (sf-relation r sf)
342
343  (define (relation-vars r) (function-formals (caddr r)))
344
345  (define (relations-inputs sf)
346    (let recur ((sf sf) (inputs '()))
347      (let ((inputs (append
348                     (concatenate (map relation-vars (sfarrow-relations sf))) 
349                     inputs)))
350        (let ((sf-children (filter-map sfarrow? (sfarrow-sig sf))))
351          (if (null? sf-children) inputs
352              (fold recur inputs sf-children)
353              )))))
354
355  (if (relation? r)
356
357      (let* ((dfe (sfarrow-dfe sf))
358             (dfe1 (make-dfe (dfe-gen dfe) (dfe-kill dfe)
359                             (lambda (s) (delete-duplicates
360                                          (append ((dfe-in dfe) s) 
361                                                  (relations-inputs sf))))
362                             (dfe-out dfe))))
363        (make-sfarrow dfe1 
364                      (sfarrow-codegen sf) 
365                      (sfarrow-sig sf) (sfarrow-children sf)
366                      (cons r (sfarrow-relations sf))))
367
368      (error 'sf-relation "invalid relation" r)))
369
370
371(define (relations-codegen sf env)
372
373  (let ((kons (map (lambda (x) (car x)) (sfarrow-relations sf))))
374
375    (codegen-state
376     (append (codegen-state)
377             (reverse
378              (map
379               (lambda (r k)
380                 (let ((name (car r)) 
381                       (fd (caddr r)))
382                   (function->expr k fd)))
383               (sfarrow-relations sf) kons))
384             ))
385    '()
386    ))
387
388
389
390
391;; We now define the rest of the basic signal functions:
392(define (sf-identity f)
393   (let* ((fe       (sfarrow-dfe f))
394          (fe-in    (dfe-in fe))         
395          (fe-out   (dfe-out fe))
396          (fe-gen   (dfe-gen fe))
397          (fe-kill  (dfe-kill fe))
398          )
399
400     (make-sfarrow
401
402      ;; dataflow equations
403      (make-dfe
404       ;; gen
405       (lambda (s) (fe-gen s))
406       
407       ;; kill
408       (lambda (s) (fe-kill s))
409       
410       ;; in
411       (lambda (s) (fe-in s))
412       
413       ;; out
414       (lambda (s) (fe-out s)))
415
416      ;; codegen
417      (lambda (s env dfe) 
418        (let* (
419               (rv (gensym 'identity))
420               (fenv (list->cgenenv 'identity (fe-in s) env))
421               (fcodegen ((sfarrow-codegen f) (fe-in s) fenv fe))
422               )
423          (make-codegen rv 
424                        (fold (lambda (name env) (cgenenv-add name rv env)) cgenenv-empty (fe-out s))
425                        (append (relations-codegen f env) 
426                                (codegen-expr fcodegen)
427                                (list (B:Val rv (V:Rec (map (lambda (s) `(,s ,(select-signal 'identity s (codegen-renv fcodegen)))) (fe-out s)))))
428                                ))
429                               
430          ))
431      ;; signature
432      `(IDENTITY ,(sfarrow-sig f))
433      ;; children
434      `(IDENTITY ,f)
435      ;; relations
436      (sfarrow-relations f))
437     ))
438
439
440
441;; [union f g], applies [f] and [g] to the input signal in parallel.
442
443(define (sf-union f g)
444
445  (define (flatten-union u)
446    (let ((uc (sfarrow-children u)))
447      (case (car uc)
448        ((UNION)  (append (flatten-union (cadr uc))
449                          (flatten-union (caddr uc))))
450        (else     (list u)))))
451   
452
453   (let* ((fe      (sfarrow-dfe f))
454          (ge      (sfarrow-dfe g))
455
456          (fe-in   (dfe-in fe))   
457          (fe-out  (compose (dfe-out fe) fe-in))
458          (fe-gen  (compose (dfe-gen fe) fe-in))
459          (fe-kill (compose (dfe-kill fe) fe-in))
460
461          (ge-in   (dfe-in ge))
462          (ge-out  (compose (dfe-out ge) ge-in))
463          (ge-gen  (compose (dfe-gen ge) ge-in))
464          (ge-kill (compose (dfe-gen ge) ge-in))
465         
466          (flst (flatten-union f))
467          (glst (flatten-union g))
468          )
469
470     (make-sfarrow
471
472      ;; dataflow equations
473      (make-dfe
474       ;; gen
475       (lambda (s) (lset-union eq? (ge-gen s) (fe-gen s)))
476       
477       ;; kill
478       (lambda (s) (lset-union eq? (fe-kill s) (ge-kill s)))
479       
480       ;; in
481       (lambda (s) (lset-union eq? (ge-in s) (fe-in s)))
482       
483       ;; out
484       (lambda (s) (lset-union eq? (ge-out s) (fe-out s)))
485       
486       )
487
488      ;; codegen
489      (lambda (s env dfe) 
490
491        (let* (
492               (fgx      (lset-intersection eq? (fe-gen s) (ge-gen s)))
493               
494               (codegen (lambda (sf)
495                          (let ((codegen (sfarrow-codegen sf))
496                                (dfe (sfarrow-dfe sf)))
497                            (let ((env (list->cgenenv 'union1 ((dfe-in dfe) s) env)))
498                              (codegen ((dfe-in dfe) s) env dfe)))))
499
500               (fld  (lambda (codegen dfe)
501                       (let ((renv (codegen-renv codegen)))
502                         (map (lambda (x) (list x (select-signal 'union2 x renv)))
503                              ((dfe-out dfe) s)))))
504               
505               )
506
507          (if (not (null? fgx)) (error 'sf-union "union arguments output overlapping signals" fgx))
508
509          (let ((rv (gensym 'union))
510                (fcodegen-lst (map codegen flst))
511                (gcodegen-lst (map codegen glst))
512                )
513
514              (let* ((renv-lst (map codegen-renv (append fcodegen-lst gcodegen-lst)))
515                     (expr-lst (map codegen-expr (append fcodegen-lst gcodegen-lst)))
516                     (renv (list->cgenenv 'union3 ((dfe-out dfe) s)
517                                (let recur ((renv-lst renv-lst) (env '()))
518                                  (if (null? renv-lst) env
519                                      (recur (cdr renv-lst) (cgenenv-union (car renv-lst) env)))))))
520
521                (make-codegen 
522
523                 rv
524                 
525                 (fold (lambda (name env) (cgenenv-add name rv env)) cgenenv-empty (map car renv))
526                 
527                 (let ((fflds  (map fld fcodegen-lst (map sfarrow-dfe flst)))
528                       (gflds  (map fld gcodegen-lst (map sfarrow-dfe glst))))
529                   (append
530                    (concatenate (map (lambda (f) (relations-codegen f env)) (append flst glst)))
531                    (concatenate expr-lst)
532                    (list (B:Val rv (V:Rec (map (lambda (s) `(,s ,(select-signal 'union4 s renv))) (map car renv)))))
533                    ))
534               
535               )))
536            ))
537      ;; signature
538      `(UNION ,(sfarrow-sig f) ,(sfarrow-sig g))
539      ;; children
540      `(UNION  ,f ,g)
541      ;; relations
542      (append (sfarrow-relations f) (sfarrow-relations g))
543      ))
544)
545
546
547;; The [sequence] combinator composes two signal functions:
548
549(define (sf-sequence f g)
550   (let* ((fe      (sfarrow-dfe f))
551          (ge      (sfarrow-dfe g))
552
553          (fe-in   (dfe-in fe))   
554          (fe-out  (compose (dfe-out fe) fe-in))
555          (fe-gen  (compose (dfe-gen fe) fe-in))
556          (fe-kill (compose (dfe-kill fe) fe-in))
557
558          (ge-in   (compose (dfe-in ge) (lambda (s) (lset-union eq? (fe-out s) s))))
559          (ge-out  (compose (dfe-out ge) ge-in))
560          (ge-gen  (compose (dfe-gen ge) ge-in))
561          (ge-kill (compose (dfe-gen ge) ge-in))
562
563          )
564
565     (make-sfarrow
566     
567      ;; dataflow equations
568      (make-dfe
569       ;; gen
570       (lambda (s) (lset-union eq? (fe-gen s) (ge-gen s)))
571       
572       ;; kill
573       (lambda (s) (lset-union eq? ((dfe-kill fe) s) ((dfe-kill ge) s)))
574       
575       ;; in
576       (lambda (s) 
577         (lset-union eq? (fe-in s) 
578                     (lset-difference eq? (ge-in s)
579                                      (fe-out s))))
580       
581       ;; out
582       (lambda (s) 
583         (lset-union eq? (fe-out s) (ge-out s)))
584       
585       )
586
587      ;; codegen
588      (lambda (s env dfe) 
589        (let* (
590               
591               (fenv (list->cgenenv 'sequence11 (fe-in s) env))
592               (fcodegen ((sfarrow-codegen f) (fe-in s) fenv fe))
593
594               (genv (list->cgenenv 'sequence12 (lset-difference eq? (ge-in s) (fe-out s)) env))
595               (genv (fold (lambda (s env) 
596                             (let ((v (cgenenv-find 'sequence1 s (codegen-renv fcodegen))))
597                               (cgenenv-add s v env)))
598                           genv (fe-out s)))
599               (gcodegen ((sfarrow-codegen g) (ge-in s) genv ge))
600               
601               (fld  (lambda (codegen)
602                       (let ((renv (codegen-renv codegen)))
603                         (lambda (x) 
604                           (list x (select-signal 'sequence2 x renv))))))
605               
606               (rv  (gensym 'sequence))
607               )
608
609
610
611          (make-codegen
612           rv
613           (fold (lambda (name env) (cgenenv-add name rv env)) cgenenv-empty ((dfe-out dfe) s))
614           (append
615            (relations-codegen f env)
616            (relations-codegen g env)
617            (codegen-expr fcodegen)
618            (codegen-expr gcodegen)
619            (list (B:Val rv (V:Rec (append (map (fld fcodegen) (lset-difference eq? (fe-out s) (ge-out s)))
620                                           (map (fld gcodegen) (ge-out s))))))))
621          ))
622      ;; signature
623      `(SEQUENCE ,(sfarrow-sig f) ,(sfarrow-sig g))
624      ;; children
625      `(SEQUENCE ,f ,g)
626      ;; relations
627      (append (sfarrow-relations f) (sfarrow-relations g))
628      )))
629
630
631;; The [on] combinator takes the value of f when e is true, otherwise
632;; it is equivalent to identity
633
634(define (sf-on f e)
635
636   (let* ((fe      (sfarrow-dfe f))
637
638          (fe-in   (dfe-in fe))   
639          (fe-out  (compose (dfe-out fe) fe-in))
640          (fe-gen  (compose (dfe-gen fe) fe-in))
641          (fe-kill (compose (dfe-kill fe) fe-in))
642
643          )
644
645     (make-sfarrow
646     
647      ;; dataflow equations
648      (make-dfe
649       ;; gen
650       (lambda (s) (fe-gen s))
651       
652       ;; kill
653       (lambda (s) ((dfe-kill fe) s))
654       
655       ;; in
656       (lambda (s)  (lset-union eq? (fe-in s) 
657                                (lset-union eq? (fe-out s) (list e))))
658       
659       ;; out
660       (lambda (s) (lset-union eq? (fe-out s) (list e)))
661       
662       )
663
664      ;; codegen
665      (lambda (s env dfe) 
666        (let* (
667               
668               (fenv (list->cgenenv 'on1 (fe-in s) env))
669               (fcodegen ((sfarrow-codegen f) (fe-in s) fenv fe))
670
671               (fld  (lambda (codegen)
672                       (let ((renv (codegen-renv codegen)))
673                         (lambda (x) 
674                           (list x (select-signal 'on2 x renv))))))
675               
676               (ev (select-signal 'on3 e env))
677
678               (rv  (gensym 'onrv))
679               (onf (gensym 'onf))
680               )
681
682          (make-codegen
683           rv
684           (fold (lambda (name env) (cgenenv-add name rv env)) cgenenv-empty ((dfe-out dfe) s))
685           (list
686            (B:Val onf (V:Fn (fe-in s) 
687                             (E:Let (append
688                                     (relations-codegen f env)
689                                     (codegen-expr fcodegen))
690                                    (E:Ret (V:Rec (delete-duplicates 
691                                                   (cons (list e ev) (map (fld fcodegen) (fe-out s)))))))))
692            (B:Val rv  (V:Ifv ev
693                              (V:Op onf (map (lambda (x) (select-signal 'on4 x env)) (fe-in s)))
694                              (V:Rec (delete-duplicates
695                                      (cons (list e ev) (map (lambda (x) (list x (select-signal 'on5 x env)))
696                                                             ((dfe-out dfe) s)))))))
697            ))
698          ))
699      ;; signature
700      `(ON ,(sfarrow-sig f) ,e)
701      ;; children
702      `(ON ,f)
703      ;; relations
704      (sfarrow-relations f)
705      )))
706
707
708;; [sense s f], applies [f] to the signal named [sn] sent to the
709;; resulting signal function:
710
711(define (sf-sense sns f)
712
713  (let* ((pred    (lambda (s) (member (signal-name s) sns)))
714         (fe      (sfarrow-dfe f)))
715
716    (make-sfarrow
717
718     ;; dataflow equations
719     (make-dfe
720      ;; gen
721      (lambda (s) ((dfe-gen fe) s))
722     
723      ;; kill
724      (lambda (s) ((dfe-kill fe) s))
725     
726      ;; in
727      (lambda (s) sns)
728     
729      ;; out
730      (lambda (s) ((dfe-out fe) s))
731      )
732
733     ;; codegen
734     (lambda (s env dfe) 
735       (let* (
736              (fenv      (list->cgenenv 'sense11 ((dfe-in dfe) s) env))
737              (fcodegen  ((sfarrow-codegen f) ((dfe-in dfe) s) fenv (sfarrow-dfe f)))
738              )
739         (make-codegen 
740          (codegen-rv fcodegen)
741          (codegen-renv fcodegen)
742          (append (relations-codegen f env) (codegen-expr fcodegen))
743          )))
744     ;; signature
745     `(SENSE ,sns ,(sfarrow-sig f))
746     ;; children
747     `(SENSE ,f)
748     ;; relations
749     (sfarrow-relations f)
750  )))
751
752;; [actuate s f]
753
754(define (sf-actuate sns f)
755
756  (let* ((fe (sfarrow-dfe f))
757         
758         (fe-in   (dfe-in fe))   
759         (fe-out  (compose (dfe-out fe) fe-in))
760         (fe-gen  (compose (dfe-gen fe) fe-in))
761         (fe-kill (compose (dfe-kill fe) fe-in)))
762
763    (make-sfarrow
764     
765     ;; dataflow equations
766     (make-dfe
767      ;; gen
768      (lambda (s) (lset-union eq? sns (fe-gen s)))
769     
770      ;; kill
771      (lambda (s) (lset-union eq? (fe-kill s)
772                              (lset-intersection eq? s sns)))
773     
774      ;; in
775      (lambda (s) (fe-in s))
776     
777      ;; out
778      (lambda (s) sns)
779      )
780
781     ;; codegen
782     (lambda (s env dfe) 
783
784       (let* (
785              (fenv      (list->cgenenv 'actuate11 (fe-in s) env))
786              (fcodegen  ((sfarrow-codegen f) (fe-in s) fenv (sfarrow-dfe f)))
787              (rv        (gensym 'actuate))
788              (renv      (codegen-renv fcodegen))
789              (fldr      (lambda (n n1) (list n (select-signal 'actuate n1 renv))))
790              )
791
792         (let ((r 
793                (make-codegen
794                 rv
795                 (cgenenv-union (codegen-renv fcodegen)
796                                (map (lambda (s) (cons s rv)) sns))
797                 (append
798                  (relations-codegen f env)
799                  (codegen-expr fcodegen)
800                         (list (B:Val rv (V:Rec (map fldr sns (fe-out s)))))))))
801           r)
802         ))
803     ;; signature
804     `(ACTUATE ,sns ,(sfarrow-sig f))
805     ;; children
806     `(ACTUATE ,f)
807     ;; relations
808     (sfarrow-relations f)
809     )))
810
811
812;; [reduce f init]
813
814(define (sf-reduce f name init)
815
816  (define (step name input inax outax env)
817    (B:Val outax (V:Op name (list (select-signal 'reduce input env)
818                                  (V:Var inax)))))
819
820  (if (not (function? f))
821      (error 'sf-reduce "argument f not a pure function: " f))
822
823     (make-sfarrow 
824      ;; dataflow equations
825      (make-dfe
826       ;; gen
827       (lambda (s) (list name))
828       ;; kill
829       (lambda (s) s)
830       ;; in
831       (lambda (s) s)
832       ;; out
833       (lambda (s) (list name)))
834
835      ;; codegen
836      (lambda (s env dfe) 
837
838        (let ((in   (lset-difference eq? ((dfe-in dfe) s) (list init ))))
839
840          (if (null? in) (error 'sf-reduce "empty input: " in))
841
842            (let recur ((inax    init)
843                        (rv      (gensym 'ax))
844                        (inputs  in)
845                        (decls   '()))
846
847
848              (if (null? inputs)
849
850                  (let ((rvf (gensym 'reduce)))
851                    (make-codegen
852                     rvf
853                     (cgenenv-add name rvf cgenenv-empty)
854                     (append
855                      (list (function->expr name f)) 
856                      (reverse decls)
857                      (list (B:Val rvf (V:Rec `((,name ,(V:Var inax)))))))
858                     ))
859
860                  (recur rv (gensym 'ax) 
861                         (cdr inputs)
862                         (cons (step name (car inputs) inax rv env) decls))
863                  ))
864            ))
865
866      ;; signature
867      `(REDUCE ,f ,init ,name)
868      ;; children
869      `(REDUCE)
870      ;; relations
871      `()
872
873      ))
874
875
876
877;; Recurring state transitions
878
879(define (sf-rtransition0 f fk e ek state)
880
881  (let* ((fe      (sfarrow-dfe f))
882         (fke     (sfarrow-dfe fk))
883         
884         (fe-in   (dfe-in fe))
885         (fe-out  (compose (dfe-out fe)  fe-in))
886         (fe-gen  (compose (dfe-gen fe)  fe-in))
887         (fe-kill (compose (dfe-kill fe) fe-in))
888         
889         (fke-in   (dfe-in fke))
890         (fke-out  (compose (dfe-out fke) fke-in))
891         (fke-gen  (compose (dfe-gen fke) fke-in))
892         (fke-kill (compose (dfe-gen fke) fke-in))
893
894         )
895
896    (make-sfarrow
897     
898     ;; dataflow equations
899     (make-dfe
900     
901      ;; gen
902      (lambda (s) (lset-union eq? (list state)
903                              (lset-union eq? (fe-gen s) (fke-gen s))))
904     
905      ;; kill
906      (lambda (s) (lset-union eq? (list state)
907                              (lset-union eq? (fe-kill s) (fke-kill s))))
908     
909      ;; in
910      (lambda (s) (lset-union eq? (list state)
911                              (lset-union eq? (fe-in s) (fke-in s)
912                                          (cond ((symbol? ek) (list e ek))
913                                                (else (list e))))))
914     
915      ;; out
916      (lambda (s) (lset-union eq? (list state)
917                              (lset-union eq? (fe-out s) (fke-out s))))
918      )
919     
920     ;; codegen
921     (lambda (s env dfe) 
922       (let* (
923              (stm        (gensym 'trstm))
924              (rv         (gensym 'trv))
925              (blender    (gensym 'blender))
926             
927              (blender-inputs     ((dfe-in dfe) s))
928              (blender-env        (map (lambda (s) (cons s s)) blender-inputs))
929
930              (blender-outputs    (lset-intersection eq? (fe-out s) (fke-out s)))
931              (blender-return     (lambda (kons codegen)
932                                    (let ((renv (codegen-renv codegen)))
933                                      (E:Ret (V:Op kons 
934                                                   (list (V:Rec (map (lambda (p) 
935                                                                       (list (car p) (V:Sel (car p) (V:Var (cdr p))))) 
936                                                                     renv))))))))
937
938             
939              (fenv   (list->cgenenv 'rtransition11 (fe-in s) blender-env))
940              (fkenv  (list->cgenenv 'rtransition12 (fke-in s) blender-env))
941             
942              (fcodegen  ((sfarrow-codegen f) 
943                          (lset-union eq? (fe-in s)
944                                      (cond ((symbol? ek) (list e ek))
945                                            (else (list e))))
946                          e
947                          fenv (sfarrow-dfe f)))
948              (fkcodegen ((sfarrow-codegen fk) 
949                          (lset-union eq? (fke-in s)
950                                      (cond ((symbol? ek) (list e ek))
951                                            (else (list e))))
952                          ek
953                          fkenv (sfarrow-dfe fk)))
954             
955              (ftrans  (lset-union eq? (lset-intersection eq? (fe-out s) (fke-in s))
956                                   (list e)))
957              (fktrans (lset-union eq? (lset-intersection eq? (fke-out s) (fe-in s))
958                                   (cond ((symbol? ek) (list ek))
959                                         (else (list)))))
960             
961              (fblend   (lambda (state x)
962                          (V:Op 'tsCase 
963                                  (list (V:Fn '(x) 
964                                              (E:Ret (V:Rec (cons
965                                                             (list state (V:Var state))
966                                                             (append
967                                                              (map (lambda (s) (list s (V:Sel s (V:Var 'x))))
968                                                                   blender-outputs)
969                                                              (map (lambda (s) (list s (V:Var s)))
970                                                                   (lset-difference eq? 
971                                                                                    (lset-union eq? ftrans fktrans)
972                                                                                    blender-outputs)))))))
973                                       
974                                        (V:Fn '(x) 
975                                              (E:Ret (V:Rec (cons
976                                                             (list state (V:Var state))
977                                                             (append
978                                                              (map (lambda (s) (list s (V:Sel s (V:Var 'x))))
979                                                                   blender-outputs)
980                                                              (map (lambda (s) (list s (V:Var s)))
981                                                                   (lset-difference eq?
982                                                                                    (lset-union eq? ftrans fktrans)
983                                                                                    blender-outputs)))))))
984                                       
985                                       
986                                        (V:Var x)))))
987             
988              (fkblend    (lambda (state x) 
989                            (V:Op 'tsCase 
990                                    (list (V:Fn '(x) 
991                                                (E:Ret (V:Rec (cons
992                                                               (list state (V:Var state))
993                                                               (append
994                                                                (map (lambda (s) (list s (V:Sel s (V:Var 'x))))
995                                                                    blender-outputs)
996                                                                (map (lambda (s) (list s (V:Sel s (V:Var 'x))))
997                                                                     (lset-difference eq? 
998                                                                                      ftrans 
999                                                                                      blender-outputs))
1000                                                                (map (lambda (s) (list s (V:Var s)))
1001                                                                     (lset-difference eq? 
1002                                                                                      fktrans
1003                                                                                      blender-outputs)))))))
1004                                         
1005                                          (V:Fn '(x) 
1006                                                (E:Ret (V:Rec (cons
1007                                                               (list state (V:Var state))
1008                                                               (append
1009                                                                (map (lambda (s) (list s (V:Sel s (V:Var 'x))))
1010                                                                     blender-outputs)
1011                                                                (map (lambda (s) (list s (V:Sel s (V:Var 'x))))
1012                                                                     (lset-difference eq? 
1013                                                                                      fktrans 
1014                                                                                      blender-outputs))
1015                                                                (map (lambda (s) (list s (V:Var s)))
1016                                                                     (lset-difference eq? 
1017                                                                                      ftrans
1018                                                                                      blender-outputs)))))))
1019                                         
1020                                         
1021                                          (V:Var x)))))
1022             
1023              )
1024         
1025         (if (null? (lset-intersection eq? (fe-out s) (fke-out s)))
1026             (error 'sf-rtransition "the outputs of argument functions f and fk must have a non-empty intersection"
1027                    (sfarrow-sig f) 
1028                    (sfarrow-sig fk)))
1029         
1030         (codegen-state
1031          (append
1032           (reverse
1033            (list
1034
1035             (B:Val stm
1036                    (V:Op 'TRC
1037                          (list
1038                            (V:Fn blender-inputs
1039                                  (E:Let (append
1040                                          (relations-codegen f env)
1041                                          (codegen-expr fcodegen))
1042                                         (blender-return 'TRSA fcodegen)))
1043                            (V:Fn blender-inputs
1044                                  (E:Let (append
1045                                          (relations-codegen fk env)
1046                                          (codegen-expr fkcodegen))
1047                                         (blender-return 'TRSB fkcodegen)))
1048                            (V:Fn (list 'x) (E:Ret (V:Op 'tsCase 
1049                                                         (list (V:Fn '(x) 
1050                                                                     (E:Ret (V:Sel e (V:Var 'x))
1051                                                                            ))
1052                                                               (cond ((symbol? ek) 
1053                                                                      (V:Fn '(x) (E:Ret (V:Sel ek (V:Var 'x)))))
1054                                                                     (ek    (V:Fn '(x) (E:Ret (V:C 'true))))
1055                                                                     (else  (V:Fn '(x) (E:Ret (V:C 'false)))))
1056                                                               (V:Var 'x)))))
1057                           )))
1058             
1059             (B:Val blender
1060                    (V:Fn (cons stm blender-inputs)
1061                          (E:Let `(
1062                                   ,(B:Val 'f     (V:Op 'trfOf (list (V:Var stm))))
1063                                   ,(B:Val 'fk    (V:Op 'trfkOf (list (V:Var stm))))
1064                                   ,(B:Val 'e     (V:Op 'treOf (list (V:Var stm))))
1065                                   ,(B:Val 'fv    (V:Ifv (V:Var state) (V:Op 'fk (map V:Var blender-inputs)) (V:Op 'f (map V:Var blender-inputs))))
1066                                   ,(B:Val 'trp   (V:Op 'e (list (V:Var 'fv))))
1067                                   ,(B:Val state  (V:Ifv (V:Var 'trp) (V:Op 'not (list (V:Var state))) (V:Var state)))
1068                                   )
1069                                 (E:Ife (V:Op 'not (list (V:Var 'trp)))
1070                                        (E:Ret (V:Ifv (V:Var state) (fkblend state 'fv) (fblend state 'fv)))
1071                                        (E:Ife (V:Var state)
1072                                               (E:Ret (fkblend state 'fv))
1073                                               (E:Ret (fblend state 'fv)))
1074                                        )
1075                                 ))
1076                    ))
1077            )
1078           (codegen-state)))
1079         
1080         (make-codegen
1081          rv
1082
1083          (fold (lambda (s ax) (cgenenv-add s rv ax))
1084                cgenenv-empty (cons state blender-outputs))
1085
1086          (list
1087           (B:Val rv
1088                  (V:Op blender (cons (V:Var stm)
1089                                      (map (lambda (s) (V:Sel s (V:Var (cgenenv-find 'rtransition22 s env)))) 
1090                                           blender-inputs))))
1091           ))
1092         ))
1093
1094     ;; signature
1095     `(RTRANSITION ,(sfarrow-sig f) ,(sfarrow-sig fk) ,e ,ek ,state)
1096
1097     ;; children
1098     `(RTRANSITION ,f ,fk)
1099
1100     ;; relations
1101     (append (sfarrow-relations f) (sfarrow-relations fk))
1102
1103     ))
1104)
1105
1106(define (sf-rtransition f fk e ek s)
1107  (sf-rtransition0 f fk e ek s))
1108
1109
1110;; Transient events
1111(define (sf-transient f g e ef)
1112
1113  (let* (
1114         (fe      (sfarrow-dfe f))
1115         (ge      (sfarrow-dfe g))
1116         (ee      (sfarrow-dfe ef))
1117         
1118         (fe-in   (dfe-in fe))
1119         (fe-out  (compose (dfe-out fe) fe-in))
1120         (fe-gen  (compose (dfe-gen fe) fe-in))
1121         (fe-kill (compose (dfe-kill fe) fe-in))
1122         
1123         (ge-in   (dfe-in ge))
1124         (ge-out  (compose (dfe-out ge) ge-in))
1125         (ge-gen  (compose (dfe-gen ge) ge-in))
1126         (ge-kill (compose (dfe-gen ge) ge-in))
1127
1128         (ee-in   (dfe-in ee))
1129         (ee-out  (compose (dfe-out ee) ee-in))
1130         (ee-gen  (compose (dfe-gen ee) ee-in))
1131         (ee-kill (compose (dfe-gen ee) ee-in))
1132
1133         )
1134
1135    (make-sfarrow
1136     
1137     ;; dataflow equations
1138     (make-dfe
1139      ;; gen
1140      (lambda (s) (lset-union eq? (fe-gen s) (ge-gen s)))
1141     
1142      ;; kill
1143      (lambda (s) (lset-union eq? (fe-kill s) (fe-kill s)))
1144               
1145      ;; in
1146      (lambda (s)  (lset-union eq?
1147                               (lset-union eq? (fe-in s) (ge-in s))
1148                               (ee-in s)))
1149      ;; out
1150      (lambda (s) (lset-intersection eq? (fe-out s) (ge-out s)))
1151     
1152      )
1153     
1154     ;; codegen
1155     (lambda (s env dfe) 
1156
1157       (if (null? (lset-intersection eq? (fe-out s) (ge-out s)))
1158           (error 'sf-transient "the outputs of argument functions f and g must have a non-empty intersection"
1159                  (sfarrow-sig f) 
1160                  (sfarrow-sig g)))
1161       
1162       (let* (
1163
1164              (rv1  (gensym 'transient))
1165              (rv2  (gensym 'transient))
1166              (rv3  (gensym 'transient))
1167
1168              (fcompute  (gensym 'transientf))
1169              (gcompute  (gensym 'transientg))
1170              (evtest    (gensym 'evtest))
1171
1172              (fenv      (map (lambda (s) (cons s s)) (lset-union eq? (ee-in s) (fe-in s))))
1173              (fcodegen  ((sfarrow-codegen f) (lset-union eq? (ee-in s) (fe-in s)) fenv fe))
1174
1175              (genv      (map (lambda (s) (cons s s)) (ge-in s)))
1176              (gcodegen  ((sfarrow-codegen g) (ge-in s) genv ge))
1177
1178              (eenv      (map (lambda (s) (cons s s)) (fe-in s)))
1179              (ecodegen  ((sfarrow-codegen ef) (ee-in s) eenv ee))
1180
1181              )
1182
1183         (codegen-state
1184          (append
1185           (list
1186
1187            (B:Val evtest
1188                   (V:Fn (ee-in s)
1189                         (E:Let
1190                          (codegen-expr ecodegen)
1191                          (E:Ret (V:Op '>= (list (V:Sel (car (ee-out s)) (V:Var (codegen-rv ecodegen))) (V:C 0.0)))))
1192                         ))
1193           
1194            (B:Val fcompute
1195                   (V:Fn (fe-in s) 
1196                         (E:Let
1197                          (append (relations-codegen f env)
1198                                  (codegen-expr fcodegen))
1199                          (E:Ret (V:Rec (map (lambda (x) (list x (select-signal '(transient fcompute) x (codegen-renv fcodegen))))
1200                                             ((dfe-out dfe) s))))
1201                          )))
1202                   
1203            (B:Val gcompute
1204                   (V:Fn (ge-in s) 
1205                         (E:Let
1206                          (append (relations-codegen g env)
1207                                  (codegen-expr gcodegen))
1208                          (E:Ret (V:Rec (map (lambda (x) (list x (select-signal '(transient gcompute) x (codegen-renv gcodegen))))
1209                                             ((dfe-out dfe) s))))
1210                          )))
1211                   
1212            )
1213           
1214           (codegen-state)))
1215         
1216         (make-codegen
1217
1218          rv3
1219
1220          (list->cgenenv '(transient renv)
1221                         ((dfe-out dfe) s)
1222                         (cgenenv-add e rv2
1223                                      (fold (lambda (s env) (cgenenv-add s rv3 env)) cgenenv-empty ((dfe-out dfe) s))))
1224         
1225           (list
1226
1227            (B:Val rv1 (V:Op fcompute (map (lambda (x) (select-signal '(transient state-compute) x env)) 
1228                                           (fe-in s))))
1229
1230            (B:Val rv2 (V:Op evtest (map (lambda (v) 
1231                                           (if (member v (fe-out s)) 
1232                                               (V:Sel v (V:Var rv1))
1233                                               (select-signal 'evtest v env)))
1234                                         (ee-in s))))
1235
1236            (B:Val rv3
1237                   (V:Ifv (V:Var rv2) 
1238                          (V:Op gcompute (map (lambda (x) (select-signal '(transient state-compute) x env)) 
1239                                              (ge-in s)))
1240                          (V:Var rv1)
1241                          ))
1242            ))
1243         
1244         ))
1245
1246     ;; signature
1247     `(TRANSIENT ,(sfarrow-sig f) ,(sfarrow-sig g) ,e ,(sfarrow-sig ef))
1248
1249     ;; children
1250     `(TRANSIENT ,f ,g ,ef)
1251
1252     ;; relations
1253     (append (sfarrow-relations f) (sfarrow-relations g))
1254
1255     ))
1256)
1257
1258
1259
1260(define integral-index (make-parameter 0))
1261
1262(define (sf-integral x ys h fs ev)
1263
1264  (let* ((varh   (case (car h) 
1265                   ((variable) #t)
1266                   (else #f)))
1267         (hname  (cadr h))
1268         (xn     (gensym (string->symbol (s+ x "+h"))))
1269         (yis    (list-tabulate (length ys) (lambda (i) i)))
1270         (yns    (map (lambda (y) (gensym (string->symbol (s+ y "(" xn ")")))) ys))
1271         (ynvs   (map (lambda (yn) (gensym (string->symbol (s+ yn "v")))) yns))
1272         (yps    (map (lambda (y) (gensym (string->symbol (s+ y "prime")))) ys))
1273         (idx    (let ((v (integral-index)))
1274                   (integral-index (+ 1 (integral-index)))
1275                   v))
1276         (e      (and ev (car ev)))
1277         (ef     (and ev (cadr ev)))
1278
1279         (ee      (and ef (sfarrow-dfe ef)))
1280         (ee-in   (and ee (dfe-in ee)))
1281         (ee-out  (and ee (compose (dfe-out ee) ee-in)))
1282         (ee-gen  (and ee (compose (dfe-gen ee) ee-in)))
1283         (ee-kill (and ee (compose (dfe-gen ee) ee-in)))
1284
1285         )
1286
1287    (let ((fs-formals (map function-formals fs)))
1288
1289      (make-sfarrow
1290       
1291       ;; dataflow equations
1292       (make-dfe
1293
1294        ;; gen
1295        (lambda (s) (lset-union eq?
1296                               (or (and ee (ee-gen s)) '())
1297                               (if varh (cons hname (cons x yns))
1298                                   (cons x yns))))
1299       
1300        ;; kill
1301        (lambda (s) (lset-union eq?
1302                               (or (and ee (ee-kill s)) '())
1303                               (lset-union eq? s (list xn))))
1304       
1305        ;; in
1306        (lambda (s) 
1307          (let ((x (lset-union eq?
1308                               (or (and ee (ee-in s)) '())
1309                               (lset-union eq? 
1310                                           (concatenate fs-formals)
1311                                           (append (list hname) 
1312                                                   (cons x ys))))))
1313            x))
1314       
1315        ;; out
1316        (lambda (s) (append (cons x yns)
1317                            (or (and varh (list hname)) '())
1318                            (or (and ee (ee-out s)) '())
1319                            ))
1320        )
1321       
1322       ;; codegen
1323       (let (
1324             (rv1 (gensym 'integral))
1325             (rv2 (gensym 'integral))
1326             (dfn (gensym 'dfn))
1327             )
1328
1329             
1330         (lambda (s env dfe)
1331
1332           (let* ((evtest     (and ev (gensym 'evtest)))
1333                  (evcompute  (and ev (gensym 'evcompute)))
1334                  (evcodegen  (and ev ((sfarrow-codegen (cadr ev)) s env ee)))
1335
1336                  (idxv      (V:C idx))
1337
1338                  (tstep     (select-signal 'integral1 hname env))
1339                 
1340                  (fenv      (list->cgenenv 'integral2 (concatenate fs-formals)
1341                                            (cgenenv-add x x (fold (lambda (y env) (cgenenv-add y y env)) env ys))))
1342
1343                  (fargs     (map (lambda (ss) (map (lambda (s) (select-signal 'integral3 s fenv)) ss)) fs-formals))
1344                  )
1345
1346
1347             (make-codegen
1348
1349              rv2
1350
1351              ((lambda (env) (if varh (cons (cons hname rv2) env) env))
1352               (cons (cons x rv2) (map (lambda (s) (cons s rv2)) yns)))
1353
1354              (append
1355
1356               (map function->expr yps fs)
1357                   
1358               (if ev
1359                   (let ((evselect
1360                          (lambda (x) 
1361                            (let ((yi (list-index (lambda (y) (equal? x y)) ys)))
1362                              (if yi
1363                                  (V:Sub (list-ref yis yi) (V:Var 'yvec))
1364                                  (select-signal 'evselect x env))))))
1365                     
1366                     
1367                     (list
1368                      (B:Val evcompute
1369                             (V:Fn (ee-in s) 
1370                                   (E:Let
1371                                    (codegen-expr evcodegen)
1372                                    (E:Ret (V:Rec (map (lambda (x) 
1373                                                         (let ((v (select-signal '(integral evcompute) x (codegen-renv evcodegen)))) 
1374                                                           (list x v)))
1375                                                       (ee-out s))))
1376                                    )))
1377                      (B:Val evtest 
1378                             (V:Fn `(yvec) 
1379                                   (E:Ret (V:Sel e (V:Op evcompute (map evselect (ee-in s)))))
1380                                   ))
1381                      ))
1382                '())
1383
1384               (list
1385                (B:Val dfn 
1386                       (V:Fn `(,x yvec) 
1387                             (E:Let (map (lambda (y i) (B:Val y (V:Sub i (V:Var 'yvec)))) ys yis)
1388                                    (E:Ret (V:Vec (map (lambda (yprime farg) (V:Op yprime farg)) yps fargs)))
1389                                    ))))
1390
1391               (if ev
1392                   
1393                   (list
1394                    (B:Val rv1 
1395                           (V:Op 'eintegral
1396                                 (list (V:Var dfn) 
1397                                       (select-signal 'eintegral1 x env) 
1398                                       (V:Vec (map (lambda (y) (select-signal 'eintegral2 y env)) ys))
1399                                       (V:Var evtest)
1400                                       tstep
1401                                       idxv
1402                                       )))
1403                    )
1404                   
1405                   (list
1406                    (B:Val rv1 
1407                           (V:Op 'integral
1408                                 (list (V:Var dfn) 
1409                                       (select-signal 'integral4 x env) 
1410                                       (V:Vec (map (lambda (y) (select-signal 'integral5 y env)) ys))
1411                                       tstep
1412                                       idxv
1413                                       ))))
1414                   )
1415               
1416
1417                (if varh
1418
1419                    (let* ((ysn (gensym 'ysn))
1420                           (xn  (gensym 'xn))
1421                           (retflds (cons `(,hname ,(V:Sel 'h (V:Var rv1)))
1422                                          (cons `(,x ,(V:Var xn))
1423                                                (map (lambda (yn yi) `(,yn ,(V:Sub yi (V:Var ysn)))) 
1424                                                     yns yis)))))
1425                      (list
1426                       (B:Val ysn (V:Sel 'ysn (V:Var rv1)))
1427                       (B:Val xn  (V:Sel 'xn (V:Var rv1)))
1428                       (B:Val rv2 (V:Rec retflds))))
1429
1430                    (let* ((ysn (gensym 'ysn))
1431                           (xn  (gensym 'xn))
1432                           (retflds (cons `(,x ,(V:Var xn))
1433                                          (map (lambda (yn yi) `(,yn ,(V:Sub yi (V:Var rv1)) )) yns yis))))
1434
1435                      (list
1436                       (B:Val ysn (V:Sel 'ysn (V:Var rv1)))
1437                       (B:Val xn  (V:Sel 'xn  (V:Var rv1)))
1438                       (B:Val rv2 (V:Rec retflds)))))
1439                ))
1440             ))
1441         )
1442
1443       ;; signature
1444       `(INTEGRAL ,idx ,h ,x ,ys ,ev)
1445
1446       ;; children
1447       `(INTEGRAL)
1448
1449       ;; relations
1450       `()
1451
1452       ))
1453      ))
1454 
1455
1456
1457
1458(define (construct d)
1459  (integral-index 0)
1460  (construct1 d))
1461
1462
1463(define (construct1 d)
1464  (let recur ((d d) (ev #f))
1465    (cases diagram d
1466           (IDENTITY (f)               (sf-identity (recur f ev)))
1467           (PURE (f)                   (sf-pure f))
1468           (PRIM (f name)              (sf-prim f name))
1469           (RELATION (r f)             (sf-relation r (recur f ev)))
1470           (SEQUENCE (f g)             (sf-sequence (recur f ev) (recur g ev)))
1471           (UNION (f g)                (sf-union (recur f ev) (recur g ev)))
1472           (SENSE (s f)                (sf-sense s (recur f ev)))
1473           (ACTUATE (s f)              (sf-actuate s (recur f ev)))
1474           (REDUCE (f n i)             (sf-reduce f n i))
1475           (RTRANSITION (f g ef eg s)  (sf-rtransition (recur f ev) (recur g ev) ef eg s))
1476           (TRANSIENT (f g e ef)       (let ((ee (recur ef #f)))
1477                                         (sf-transient (recur f (list e ee)) (recur g ev) e ee)))
1478           (ON (f e)                   (sf-on (recur f ev) e))
1479           (INTEGRAL (x ys h fs)       (sf-integral x ys h fs ev))
1480           )))
1481
1482
1483(define (dataflow f input)
1484  (let ((dfe (sfarrow-dfe f)))
1485    `((gen  . ,((dfe-gen dfe) input))
1486      (kill . ,((dfe-kill dfe) input))
1487      (in   . ,((dfe-in dfe) input))
1488      (out  . ,((dfe-out dfe) input)))))
1489
1490
1491(define (events f)
1492  (let recur ((f f) (ax '()))
1493    (let ((sig (sfarrow-sig f)))
1494      (case (car sig)
1495        ((RTRANSITION)
1496         (let ((ef (fourth sig)) (eg (fifth sig)))
1497           (let* ((ax1 (cons ef ax))
1498                  (ax2 (if (symbol? eg)  (cons eg ax1) ax1)))
1499             (fold recur ax2 (cdr (sfarrow-children f)))
1500             )))
1501        ((TRANSIENT)
1502         (let ((e (fourth sig)))
1503           (let* ((ax1 (cons e ax)))
1504             (fold recur ax1 (cdr (sfarrow-children f)))
1505             )))
1506        ((ON)
1507         (let ((e (third sig)))
1508           (let* ((ax1 (cons e ax)))
1509             (fold recur ax1 (cdr (sfarrow-children f)))
1510             )))
1511        ((SF)
1512         (let ((evs (fifth sig)))
1513           (if (null? evs) ax (append evs ax))))
1514        (else (fold recur ax (cdr (sfarrow-children f))))
1515        ))
1516    ))
1517
1518
1519(define (integrals f)
1520  (let recur ((f f) (ax '()))
1521    (let ((sig (sfarrow-sig f)))
1522      (case (car sig)
1523        ((INTEGRAL)
1524           (let ((ax1 (cons (cdr sig) ax)))
1525             (fold recur ax1 (cdr (sfarrow-children f)))
1526             ))
1527        (else (fold recur ax (cdr (sfarrow-children f))))
1528        ))
1529    ))
1530
1531 
1532(define (prelude/scheme #!key (solver 'rk4b) (random #f) (integral-index 0))
1533
1534`(
1535  ,(case solver
1536     ((cvode) `("(use sundials random-mtzig mathh)" ,nl))
1537     (else    `("(use runge-kutta random-mtzig mathh)" ,nl)))
1538 #<<EOF
1539
1540;; Variant types
1541
1542(define-syntax define-datatype
1543  (syntax-rules ()
1544    [(_ type (name field ...) ...)
1545     (begin
1546       (define-constructors type ((name field ...) ...)))]))
1547
1548
1549(define-syntax define-constructors
1550  (syntax-rules ()
1551    [(define-constructors type ((name field ...) ...))
1552     (define-constructors type ((name field ...) ...) (name ...))]
1553    [(define-constructors type ((name field ...) ...) names)
1554     (begin
1555       (define-constructor type (name field ...) names)
1556       ...)]))
1557
1558
1559(define-syntax define-constructor
1560  (syntax-rules ()
1561    [(_ type (name field ...) names)
1562     (define (name field ...)
1563       (cons 'type
1564             (lambda names
1565               (name field ...))))]))
1566
1567
1568(define-syntax cases
1569  (syntax-rules ()
1570    [(_ type x [(name field ...) exp]
1571          ...)
1572     ((cdr x) (lambda (field ...) exp)
1573              ...)]))
1574
1575(define-datatype trs (TRSA a) (TRSB b))
1576(define-datatype trc (TRC f fk e))
1577
1578(define (tsCase fa fb x) (cases trs x ((TRSA a) (fa a)) ((TRSB b) (fb b))))
1579(define (trfOf x)  (cases trc x ((TRC f fk e) f)))
1580(define (trfkOf x) (cases trc x ((TRC f fk e) fk)))
1581(define (treOf x)  (cases trc x ((TRC f fk e) e)))
1582
1583(define-datatype option (NONE) (SOME a))
1584(define (swap x v) (cases option v ((NONE) x) ((SOME v) v)))
1585
1586(define false #f)
1587(define true  #t)
1588
1589(define equal equal?)
1590
1591(define (signalOf v) (if (not v) (error 'signalOf "empty signal" v) v))
1592
1593(define (heaviside x) (if (negative? x) 0 1))
1594
1595EOF
1596
1597,(if (positive? integral-index)
1598     (case solver
1599       ((cvode)
1600        (list "(define integral-solvers (make-vector " integral-index " #f))" nl))
1601       (else '())
1602       ) '())
1603
1604,(if (not solver)
1605     `((";; dummy solver; returns only the computed derivatives")
1606       ("(define (integral f x y h i) (f x y))" ,nl)
1607       )
1608     (case solver
1609       ((cvode) 
1610        `(
1611          ("(define (integral f x y h i) (f x y))" ,nl)
1612          ))
1613
1614       (else
1615        `(("(define (scaler x a) (map (lambda (k) (fp* x k)) a))" ,nl)
1616          ("(define (summer a b) (map fp+ a b))" ,nl)
1617          ("(define " ,solver " (make-" ,solver "))" ,nl)
1618          ("(define (make_stepper deriv) (" ,solver " scaler summer deriv))" ,nl)
1619          ("(define (integral f x y h i) (((make_stepper f) h) x y))" ,nl)
1620          ))
1621       ))
1622))
1623
1624
1625
1626(define (prelude/ML  #!key (solver 'rk4b) (random #f))
1627`(
1628 #<<EOF
1629structure Model = 
1630struct
1631
1632open Real
1633open Math
1634open RungeKutta
1635
1636datatype ('b,'c) trs = TRSA of 'b | TRSB of 'c
1637datatype ('a,'b,'c) trc = TRC of ((('a -> (('b,'c) trs))) * 
1638                                  (('a -> (('b,'c) trs))) * 
1639                                  ((('b,'c) trs) -> bool))
1640         
1641fun tsCase (fa,fb,x) = case x of TRSA a => (fa a) | TRSB b => (fb b)
1642fun trfOf x = case x of TRC (f,fk,e) => f
1643fun trfkOf x = case x of TRC (f,fk,e) => fk
1644fun treOf x = case x of TRC (f,fk,e) => e
1645
1646fun putStrLn str = 
1647  (TextIO.output (TextIO.stdOut, str);
1648   TextIO.output (TextIO.stdOut, "\n"))
1649
1650fun putStr str = (TextIO.output (TextIO.stdOut, str))
1651
1652fun showReal n = 
1653let open StringCvt
1654in
1655(if n < 0.0 then "-" else "") ^ (fmt (FIX (SOME 12)) (abs n))
1656end
1657
1658fun vmap2 f (v1,v2) = 
1659    let
1660        val n = Vector.length v1
1661    in
1662        Vector.tabulate (n, fn (i) => f (Unsafe.Vector.sub (v1,i),
1663                                        Unsafe.Vector.sub (v2,i)))
1664    end
1665
1666exception EmptySignal
1667
1668val neg = (op ~)
1669val swap = fn (x,v) => (case v of NONE => x | SOME v => v) 
1670val equal = fn (x,y) => (x = y) 
1671val signalOf = fn (v) => (case v of NONE => raise EmptySignal | SOME v => v) 
1672val heaviside = fn (v) => (if Real.< (v, 0.0) then 0.0 else 1.0)
1673EOF
1674
1675,(if random
1676#<<EOF
1677
1678fun RandomInit () = RandomMTZig.fromEntropy()
1679
1680val RandomState = RandomInit ()
1681
1682fun random_uniform () = RandomMTZig.randUniform RandomState
1683
1684
1685fun PoissonInit () =
1686 let
1687     val zt = RandomMTZig.ztnew()
1688     val st = RandomMTZig.fromEntropy()
1689 in
1690     {st=st,zt=zt}
1691 end
1692
1693fun PoissonStep (rate,t,h,st,zt) =
1694 let
1695    val rv     = RandomMTZig.randPoisson (rate*0.001*h,st,zt) 
1696    val spike' = Real.> (rv,0.0)
1697    val spikeCount' = if spike' then rv else 0.0
1698  in
1699     {t=t+h,spike=spike',spikeCount=spikeCount',st=st,zt=zt}
1700  end
1701
1702
1703EOF
1704"")
1705
1706,(if (not solver)
1707     `(("(* dummy solver; returns only the computed derivatives *)")
1708       ("fun integral (f,x: real,y: real vector,h,i) = (f (x,y))" ,nl)
1709       )
1710     `(("val summer = fn (a,b) => (vmap2 (fn (x,y) => x+y) (a,b))" ,nl)
1711       ("val scaler = fn(a,lst) => (Vector.map (fn (x) => a*x) lst)" ,nl)
1712       . ,(case solver 
1713            ;; adaptive solvers
1714            ((rkhe rkbs rkf45 rkck rkdp rkf78 rkv65)
1715             `(
1716               ("val " ,solver ": (real vector) stepper2 = make_" ,solver "()" ,nl)
1717               ("fun make_stepper (deriv) = " ,solver " (scaler,summer,deriv)" ,nl)
1718               ("val cerkdp: (real vector) stepper3 = make_cerkdp()" ,nl)
1719               ("fun make_estepper (deriv) = cerkdp (scaler,summer,deriv)" ,nl)
1720#<<EOF
1721
1722val tol = Real.Math.pow (10.0, ~7.0)
1723val lb = 0.5 * tol
1724val ub = 0.9 * tol
1725
1726datatype ('a, 'b) either = Left of 'a | Right of 'b
1727
1728
1729fun predictor tol (h,ys) =
1730  let open Real
1731      val e = Vector.foldl (fn (y,ax) => Real.+ ((abs y),ax)) 0.0 ys
1732  in 
1733      if e < lb 
1734      then Right (1.414*h)      (* step too small, accept but grow *)
1735      else (if e < ub 
1736            then Right h        (* step just right *)
1737            else Left (0.5*h))  (* step too large, reject and shrink *)
1738  end
1739
1740
1741exception ConvergenceError
1742
1743
1744fun secant tol f fg0 guess1 guess0 = 
1745    let open Real
1746        val fg1 = f guess1
1747        val newGuess = guess1 - fg1 * (guess1 - guess0) / (fg1 - fg0)
1748        val err =  abs (newGuess - guess1)
1749    in 
1750        if (err < tol)
1751        then newGuess
1752        else secant tol f fg1 newGuess guess1 
1753    end
1754
1755
1756datatype 'a result = Next of 'a | Root of 'a
1757
1758
1759fun esolver (stepper,evtest) (x,ys,h) =
1760    let open Real
1761        val (ys',e,finterp) = stepper h (x,ys)
1762    in
1763        case predictor tol (h,e) of
1764            Right h' =>
1765            if (evtest (ys') >= 0.0)
1766            then (let
1767                     val theta   = secant tol (evtest o finterp) (evtest ys) 1.0 0.0
1768                     val ys''    = finterp (theta)
1769                 in
1770                     Root (x+(theta)*h,ys'',h')
1771                 end)
1772            else Next (x+h,ys',h')
1773          | Left h'  =>
1774            esolver (stepper,evtest) (x,ys,h')
1775    end
1776
1777
1778fun eintegral (f,x,ys,evtest,h,i) =
1779    case esolver (make_estepper f,evtest) (x,ys,h) of
1780        Next (xn,ysn,h') =>
1781        ({xn=xn,h=h',ysn=ysn})
1782      | Root (xn,ysn,h') =>
1783        ({xn=xn,ysn=ysn,h=h'})
1784
1785fun solver stepper (x,ys,h) =
1786    let open Real
1787        val (ys',e) = stepper h (x,ys)
1788    in
1789        case predictor tol (h,e) of
1790            Right h' =>
1791            (x+h,ys',h')
1792          | Left h'  =>
1793            solver (stepper) (x,ys,h')
1794    end
1795
1796fun integral (f,x,ys,evtest,h,i) =
1797    let
1798        val (xn,ysn,h') = solver (make_stepper f) (x,ys,h) 
1799    in
1800        {xn=xn,ysn=ysn,h=h'}
1801    end
1802
1803
1804
1805EOF
1806
1807               ))
1808            (else
1809             `(
1810               ("val " ,solver ": (real vector) stepper1 = make_" ,solver "()" ,nl)
1811               ("fun make_stepper (deriv) = " ,solver " (scaler,summer,deriv)" ,nl)
1812               ("fun integral (f,x: real,y: real vector,h,i) = ((make_stepper f) h) (x,y)" ,nl)
1813               ))
1814            ))
1815       )
1816))
1817 
1818(define (prelude/Octave #!key (solver 'lsode))
1819`(
1820#<<EOF
1821
1822function res = TRSA(v)
1823  res = struct ("TRSA",v)
1824end
1825
1826function res = TRSB(v)
1827  res = struct ("TRSB",v)
1828end
1829
1830function res = tsCase(fa,fb,v)
1831   if (isfield (v, "TRSA"))
1832     res = fa(getfield(v,"TRSA"));
1833   else
1834     res = fb(getfield(v,"TRSB"));
1835   endif
1836end
1837
1838function res = TRSC(f,fk,e)
1839  res = struct ("TRSC",[f,fk,e])
1840end
1841
1842function res = trfOf(x)
1843   res = getfield(x,"TRC")(1);
1844end
1845
1846function res = trfkOf(x)
1847   res = getfield(x,"TRC")(2);
1848end
1849
1850function res = treOf(x)
1851   res = getfield(x,"TRC")(3);
1852end
1853
1854function res = NONE()
1855  res = struct ()
1856end
1857
1858function res = SOME(v)
1859  res = struct ("SOME",v)
1860end
1861
1862function res = swap (x,v)
1863   if (isfield (v, "SOME"))
1864     res = getfield(v,"SOME");
1865   else
1866     res = x;
1867   endif
1868end
1869
1870function res = equal (x, y)
1871   res = (x==y);
1872end
1873
1874function res = signalOf (v)
1875  if (not(v))
1876   error ("empty signal")
1877 else
1878   res = v;
1879 endif
1880end
1881
1882function res = neg (x)
1883  res = -x;
1884end
1885
1886function res = ifv (b,x,y)
1887  if (b) 
1888    res = x;
1889  else
1890    res = y;
1891  endif
1892end
1893
1894EOF
1895,(if (not solver)
1896     `("function res = integral (f,x,y,h,i)" ,nl 
1897       "  res = f(x,y); " ,nl end ,nl
1898       ,nl)
1899     `((
1900#<<EOF
1901
1902EOF
1903)
1904       ("global " ,solver #\; ,nl)
1905       (,solver = #\@ ,(case solver
1906                         ((rk3) 'ode23) ((rk4b rk4a) 'ode45) ((rkf45) 'ode54) 
1907                         (else 'lsode)) #\; ,nl)
1908
1909       ,(cond
1910
1911         ((member solver '(rk3 rk4b rk4a rkf45))
1912
1913               `(
1914#<<EOF
1915global reltol abstol dt;
1916reltol = 0.1;
1917abstol = 0.01;
1918dt = 0.001;
1919
1920global P;
1921P = odeset ("RelTol" , reltol , "AbsTol" , abstol , "MaxStep" , 1 , "InitialStep" , dt) ;
1922
1923EOF
1924       "function res = integral (f,x,y,h,i)" ,nl 
1925       "  global P " ,solver ";" ,nl
1926       "  [t,y] = " ,solver "(f,[x,x+h],y,P); " ,nl 
1927       "  res = y(2);" ,nl end ,nl
1928       ))
1929              (else
1930
1931               `(
1932#<<EOF
1933lsode_options("relative tolerance",1e-4);
1934lsode_options("absolute tolerance",1e-4);
1935
1936
1937EOF
1938       "function res = integral (f,x,y0,h,i)" ,nl 
1939       "  global " ,solver ";" ,nl
1940       "  y = " ,solver "(@(yvec,t) f(t,yvec),y0,[x,x+h]); " ,nl 
1941       "  res = y(2);" ,nl end ,nl
1942       )
1943   ))
1944 ))
1945))
1946
1947
1948(define (codegen/Octave name f #!key (initial #f) (pre #t) (solver #f))
1949
1950  (if (and solver (not (member solver '(lsode rkfe rk3 rk4a rk4b rkhe rkbs rkf45))))
1951      (error 'codegen/Octave "unknown solver" solver))
1952 
1953  (let ((dfe (sfarrow-dfe f)))
1954
1955    (codegen-state '())
1956
1957    (let* ((input    (or (and initial (map car initial)) ((dfe-in dfe) '())))
1958           (fenv     (map (lambda (s) (cons s 'input)) input))
1959           (fcodegen ((sfarrow-codegen f) input fenv dfe ))
1960           (relations-expr (relations-codegen f input))
1961           (globals   (filter-map
1962                       (lambda (x) 
1963                         (cases binding x
1964                                (B:Val  (name v) (name/Octave name))
1965                                (else  #f)))
1966                       (codegen-state))))
1967
1968      (if pre (print-fragments (prelude/Octave solver: solver)))
1969      (print-fragments (list "global " (intersperse globals " ") ";" nl))
1970
1971      (print-fragments (list (map (lambda (x) 
1972                                    (if (binding? x)
1973                                        (cases binding x
1974                                               (B:Val  (name v) (list (name/Octave name) " = " (value->Octave v) ";" nl)))
1975                                        (expr->Octave x)))
1976                                  (reverse (codegen-state))) nl))
1977
1978      (print-fragments
1979       (list
1980        "function " (name/Octave (codegen-rv fcodegen)) " = " (name/Octave name) " (input)" nl
1981        (list "global " (intersperse globals " ") ";" nl)
1982        (map (lambda (x) (list (name/Octave x) " = " (value->Octave (V:Sel x (V:Var 'input))) "; " nl)) input)
1983        nl
1984        (map binding->Octave (append relations-expr (codegen-expr fcodegen))) nl 
1985        "endfunction" nl))
1986
1987     
1988      (if initial
1989              (print-fragments
1990               (list (name/Octave name) "_initial = " 
1991                     (value->Octave
1992                      (V:Rec (map (lambda (x) (let ((n (car x)) (v (cadr x)))
1993                                                (let ((v (cond ((and (or (number? v) (symbol? v))) v)
1994                                                               ((boolean? v) (if v 'true 'false))
1995                                                               (else v))))
1996                                                  (list n (V:C v)))))
1997                                  initial)))
1998                     nl))
1999              )
2000
2001
2002      )))
2003
2004(define (codegen/scheme name f #!key (initial #f) (pre #t) (solver 'rk4b))
2005
2006  (if (and solver (not (member solver '(cvode rkfe rk3 rk4a rk4b rkhe rkbs rkf45 rkck rkdp rkf78 rkv65))))
2007      (error 'codegen/scheme "unknown solver" solver))
2008
2009  (let ((dfe (sfarrow-dfe f)))
2010
2011    (codegen-state '())
2012
2013    (let* ((input    (or (and initial (map car initial)) ((dfe-in dfe) '())))
2014           (fenv     (map (lambda (s) (cons s 'input)) input))
2015           (fcodegen ((sfarrow-codegen f) input fenv dfe ))
2016           (relations-expr (relations-codegen f input)))
2017
2018      (if pre (print-fragments (prelude/scheme solver: solver 
2019                                               integral-index: (integral-index))))
2020
2021      (print-fragments (list (map (lambda (x) 
2022                                    (if (binding? x)
2023                                        (cases binding x
2024                                               (B:Val  (name v)
2025                                                       (list "(define " (name/scheme name) " " (value->scheme v) ")" nl)))
2026                                        (expr->scheme x)))
2027                                  (reverse (codegen-state))) nl))
2028
2029      (print-fragments
2030       (list
2031        "(define (" (name/scheme name) " input)" nl
2032        "(let (" (intersperse (map (lambda (x) (binding->scheme (B:Val x (V:Sel x (V:Var 'input))))) input) " ")  ")"  nl
2033        "(let* (" (map binding->scheme (append relations-expr (codegen-expr fcodegen))) nl ")" nl
2034        (codegen-rv fcodegen) nl
2035        ")))" nl))
2036
2037      (if initial
2038          (print-fragments
2039           (list "(define " (name/scheme name) "_initial " 
2040                 (value->scheme
2041                  (V:Rec (map (lambda (x) (let ((n (car x)) (v (cadr x)))
2042                                            (let ((v (cond ((and (or (number? v) (symbol? v))) v)
2043                                                           ((boolean? v) (if v 'true 'false))
2044                                                           (else v))))
2045                                              (list n (V:C v)))))
2046                              initial))) ")" nl)))
2047
2048
2049      )))
2050
2051(define (codegen/ML name f #!key (initial #f) (random #f) (pre #t) (post #t) (solver 'rk4b))
2052
2053  (if (and solver (not (member solver '(rkfe rk3 rk4a rk4b rkhe rkbs rkf45 rkck rkdp rkf78 rkv65))))
2054      (error 'codegen/ML "unknown solver" solver))
2055
2056
2057  (let ((dfe (sfarrow-dfe f)))
2058
2059    (codegen-state '())
2060
2061    (let* ((input    (or (and initial ((dfe-in dfe) (map car initial)))
2062                         ((dfe-in dfe) '())))
2063           (fenv     (map (lambda (s) (cons s 'input)) input))
2064           (fcodegen ((sfarrow-codegen f) input fenv dfe ))
2065           (relations-expr (relations-codegen f input))
2066           )
2067
2068      (if pre (print-fragments (prelude/ML solver: solver random: random)))
2069
2070      (print-fragments (list (map (lambda (x) 
2071                                    (if (binding? x)
2072                                        (cases binding x
2073                                               (B:Val  (name v)
2074                                                       (list "val " (name/ML name) " = " (value->ML v) nl)))
2075                                        (expr->ML x)))
2076                                  (reverse (codegen-state))) nl))
2077
2078
2079      (print-fragments
2080       (list
2081        "fun " (name/ML name) "(input as {" (intersperse (map name/ML input) ",")  "})" " = " nl
2082        "let" nl
2083        (map binding->ML (append relations-expr (codegen-expr fcodegen))) nl
2084        "in" nl
2085        (codegen-rv fcodegen)   nl
2086        "end" nl))
2087
2088      (if initial
2089          (print-fragments
2090           (list "val " (name/ML name) "_initial = " 
2091                 (value->ML (V:Rec (map (lambda (x) 
2092                                          (let ((n x) (v (car (alist-ref x initial))))
2093                                            (list n 
2094                                                  (cond ((and (or (number? v) (symbol? v))) 
2095                                                         (V:C v))
2096                                                        ((boolean? v) 
2097                                                         (V:C (if v 'true 'false)))
2098                                                        (else (V:C v))))
2099                                                    ))
2100                                        input))) nl)))
2101
2102      (if post (print-fragments (list "end" nl)))
2103     
2104      )))
2105
2106
2107
2108
2109)
2110
Note: See TracBrowser for help on using the repository browser.