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

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

signal-diagram: correction to the data flow equations of relations

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