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

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

signal-diagram: fix to algebraic system

File size: 42.1 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) 
1080        (lset-intersection eq? (fe-out s) (ge-out s)))
1081     
1082      )
1083     
1084     ;; codegen
1085     (lambda (s env dfe) 
1086
1087       (if (null? (lset-intersection eq? (fe-out s) (ge-out s)))
1088           (error 'sf-transient "the outputs of argument functions f and g must have a non-empty intersection"
1089                  (sfarrow-sig f) 
1090                  (sfarrow-sig g)))
1091         
1092       
1093       (let* (
1094
1095              (rv  (gensym 'transient))
1096
1097              (fcompute  (gensym 'transientf))
1098              (gcompute  (gensym 'transientg))
1099
1100              (fenv      (map (lambda (s) (cons s s)) (fe-in s)))
1101              (fcodegen ((sfarrow-codegen f) 
1102                         (lset-union eq? (fe-in s) (list e))
1103                         fenv fe))
1104
1105              (genv      (map (lambda (s) (cons s s)) (ge-in s)))
1106              (gcodegen ((sfarrow-codegen g) 
1107                         (lset-union eq? (ge-in s) (list e))
1108                         genv ge))
1109
1110              )
1111
1112         (codegen-state
1113          (append
1114           (list
1115           
1116            (B:Val fcompute
1117                   (V:Fn (fe-in s) 
1118                         (E:Let
1119                          (append (relations-codegen f env)
1120                                  (codegen-expr fcodegen))
1121                          (E:Ret (V:Rec (map (lambda (x) (list x (select-signal '(transient fcompute) x (codegen-renv fcodegen))))
1122                                             ((dfe-out dfe) s))))
1123                          )))
1124                   
1125            (B:Val gcompute
1126                   (V:Fn (ge-in s) 
1127                         (E:Let
1128                          (append (relations-codegen g env)
1129                                  (codegen-expr gcodegen))
1130                          (E:Ret (V:Rec (map (lambda (x) (list x (select-signal '(transient gcompute) x (codegen-renv gcodegen))))
1131                                             ((dfe-out dfe) s))))
1132                          )))
1133                   
1134            )
1135           
1136           (codegen-state)))
1137         
1138         (make-codegen
1139          rv
1140
1141          (list->cgenenv '(transient renv)
1142                         ((dfe-out dfe) s)
1143                         (fold (lambda (s env) (cgenenv-add s rv env)) cgenenv-empty ((dfe-out dfe) s)))
1144         
1145           (list
1146            (B:Val rv
1147                   (V:Ifv (select-signal '(transient rv) e env)
1148                          (V:Op gcompute (map (lambda (x) (select-signal '(transient state-compute) x env)) 
1149                                              (ge-in s)))
1150                          (V:Op fcompute (map (lambda (x) (select-signal '(transient state-compute) x env)) 
1151                                              (fe-in s)))
1152                          ))
1153           ))
1154         ))
1155
1156     ;; signature
1157     `(TRANSIENT ,(sfarrow-sig f) ,(sfarrow-sig g) ,e)
1158
1159     ;; children
1160     `(TRANSIENT ,f ,g)
1161
1162     ;; relations
1163     (append (sfarrow-relations f) (sfarrow-relations g))
1164
1165     ))
1166)
1167
1168
1169
1170(define integral-index (make-parameter 0))
1171(define integral-events (make-dynvector 0 '()))
1172
1173
1174(define (sf-integral0 x ys h fs)
1175
1176  (let* ((xn     (gensym (string->symbol (s+ x "+h"))))
1177         (yis    (list-tabulate (length ys)  (lambda (i) i)))
1178         (yns    (map (lambda (y) (gensym (string->symbol (s+ y "(" xn ")")))) ys))
1179         (ynvs   (map (lambda (yn) (gensym (string->symbol (s+ yn "v")))) yns))
1180         (yps    (map (lambda (y) (gensym (string->symbol (s+ y "prime")))) ys))
1181         (idx    (let ((v (integral-index)))
1182                   (integral-index (+ 1 (integral-index)))
1183                   v))
1184         )
1185
1186    (let (
1187          (fs-formals (map function-formals fs))
1188          )
1189
1190      (make-sfarrow
1191       
1192       ;; dataflow equations
1193       (make-dfe
1194
1195        ;; gen
1196        (lambda (s) yns)
1197       
1198        ;; kill
1199        (lambda (s) (lset-union eq? s (list xn)))
1200       
1201        ;; in
1202        (lambda (s) (lset-union eq?
1203                      (dynvector-ref integral-events idx)
1204                      (lset-union eq? 
1205                        (concatenate fs-formals)
1206                        (append (if (symbol? h) (list h) '())
1207                                (cons x ys)))))
1208       
1209        ;; out
1210        (lambda (s) yns)
1211        )
1212       
1213       ;; codegen
1214       (let (
1215             (rv1 (gensym 'integral))
1216             (rv2 (gensym 'integral))
1217             (dfn (gensym 'dfn))
1218             )
1219             
1220         (lambda (s env dfe)
1221
1222           (let* (
1223                  (events    (dynvector-ref integral-events idx))
1224                 
1225                  (idxv      (V:C idx))
1226
1227                  (tstep     (if (symbol? h) 
1228                                 (select-signal 'integral1 h env)
1229                                 (V:C h)))
1230                 
1231                  (fenv      (list->cgenenv 'integral2 (concatenate fs-formals)
1232                                            (cgenenv-add x x (fold (lambda (y env) (cgenenv-add y y env)) env ys))))
1233
1234                  (fargs     (map (lambda (ss) (map (lambda (s) (select-signal 'integral3 s fenv)) ss)) fs-formals))
1235                  )
1236
1237             (make-codegen
1238
1239              rv2
1240             
1241              (map (lambda (s) (cons s rv2)) yns)
1242
1243              (append
1244
1245               (map function->expr yps fs)
1246
1247               (list
1248
1249                (B:Val dfn 
1250                       (V:Fn `(,x yvec) 
1251                             (E:Let (map (lambda (y i) (B:Val y (V:Sub i (V:Var 'yvec)))) ys yis)
1252                                    (E:Ret (V:Vec (map (lambda (yprime farg) (V:Op yprime farg)) yps fargs)))
1253                                    )))
1254
1255                (B:Val rv1 
1256                       (V:Op 'integrate
1257                             (list (V:Var dfn) 
1258                                   (select-signal 'integral4 x env) 
1259                                   (V:Vec (map (lambda (y) (select-signal 'integral5 y env)) ys))
1260                                   tstep
1261                                   idxv
1262                                   )))
1263
1264
1265                (B:Val rv2     (V:Rec (map (lambda (yn yi) `(,yn ,(V:Sub yi (V:Var rv1)) )) yns yis)) )
1266                )
1267               ))
1268             ))
1269         )
1270
1271       ;; signature
1272       `(INTEGRAL ,idx ,x ,ys)
1273
1274       ;; children
1275       `(INTEGRAL)
1276
1277       ;; relations
1278       `()
1279
1280       ))
1281      ))
1282 
1283
1284
1285(define (sf-integralh x y h f)
1286  (sf-integral0 x y h f))
1287
1288(define (sf-integral x y f)
1289  (sf-integral0 x y 1e-3 f))
1290
1291
1292(define (construct d)
1293  (integral-index 0)
1294  (dynvector-clear! integral-events 0)
1295  (construct1 d))
1296
1297(define (construct1 d)
1298  (cases diagram d
1299         (IDENTITY (f)             (sf-identity (construct1 f)))
1300         (PURE (f)                 (sf-pure f))
1301         (PRIM (f name)            (sf-prim f name))
1302         (RELATION (r f)           (sf-relation r (construct1 f)))
1303         (SEQUENCE (f g)           (sf-sequence (construct1 f) (construct1 g)))
1304         (UNION (f g)              (sf-union (construct1 f) (construct1 g)))
1305         (SENSE (s f)              (sf-sense s (construct1 f)))
1306         (ACTUATE (s f)            (sf-actuate s (construct1 f)))
1307         (REDUCE (f n i)           (sf-reduce f n i))
1308         (RTRANSITION (f g ef eg s)  (sf-rtransition (construct1 f) (construct1 g) ef eg s))
1309         (TRANSITION (f g ef s)      (sf-transition (construct1 f) (construct1 g) ef s))
1310         (TRANSIENT (f g e)          (sf-transient (construct1 f) (construct1 g) e))
1311         (INTEGRAL  (x ys fs)        (sf-integral x ys fs))
1312         (INTEGRALH (x ys h fs)      (sf-integralh x ys h fs))
1313         ))
1314
1315
1316(define (dataflow f input)
1317  (let ((dfe (sfarrow-dfe f)))
1318    `((gen  . ,((dfe-gen dfe) input))
1319      (kill . ,((dfe-kill dfe) input))
1320      (in   . ,((dfe-in dfe) input))
1321      (out  . ,((dfe-out dfe) input)))))
1322
1323
1324(define (events f)
1325  (let recur ((f f) (ax '()))
1326    (let ((sig (sfarrow-sig f)))
1327      (case (car sig)
1328        ((RTRANSITION)
1329         (let ((ef (fourth sig)) (eg (fifth sig)))
1330           (let* ((ax1 (cons ef ax))
1331                  (ax2 (if (symbol? eg)  (cons eg ax1) ax1)))
1332             (fold recur ax2 (cdr (sfarrow-children f)))
1333             )))
1334        ((TRANSIENT)
1335         (let ((e (fourth sig)))
1336           (let* ((ax1 (cons e ax)))
1337             (fold recur ax1 (cdr (sfarrow-children f)))
1338             )))
1339        ((SF)
1340         (let ((evs (fifth sig)))
1341           (append evs ax)))
1342        (else (fold recur ax (cdr (sfarrow-children f))))
1343        ))
1344    ))
1345
1346
1347(define (integrals f)
1348  (let recur ((f f) (ax '()))
1349    (let ((sig (sfarrow-sig f)))
1350      (case (car sig)
1351        ((INTEGRAL)
1352           (let ((ax1 (cons (cdr sig) ax)))
1353             (fold recur ax1 (cdr (sfarrow-children f)))
1354             ))
1355        (else (fold recur ax (cdr (sfarrow-children f))))
1356        ))
1357    ))
1358
1359
1360(define (codegen/Octave name f #!key (initial #f) (pre #t) (solver #f))
1361
1362  (if (and solver (not (member solver '(lsode rkfe rk3 rk4a rk4b rkhe rkbs rkf45))))
1363      (error 'codegen/Octave "unknown solver" solver))
1364 
1365  (let ((dfe (sfarrow-dfe f)))
1366
1367    (codegen-state '())
1368
1369    (let* ((input    (or (and initial (map car initial)) ((dfe-in dfe) '())))
1370           (fenv     (map (lambda (s) (cons s 'input)) input))
1371           (fcodegen ((sfarrow-codegen f) input fenv dfe ))
1372           (relations-expr (relations-codegen f input))
1373           (globals   (filter-map
1374                       (lambda (x) 
1375                         (cases binding x
1376                                (B:Val  (name v) (name/Octave name))
1377                                (else  #f)))
1378                       (codegen-state))))
1379
1380      (if pre (print-fragments (prelude/Octave solver: solver)))
1381      (print-fragments (list "global " (intersperse globals " ") ";" nl))
1382
1383      (print-fragments (list (map (lambda (x) 
1384                                    (if (binding? x)
1385                                        (cases binding x
1386                                               (B:Val  (name v) (list (name/Octave name) " = " (value->Octave v) ";" nl)))
1387                                        (expr->Octave x)))
1388                                  (reverse (codegen-state))) nl))
1389
1390      (print-fragments
1391       (list
1392        "function " (name/Octave (codegen-rv fcodegen)) " = " (name/Octave name) " (input)" nl
1393        (list "global " (intersperse globals " ") ";" nl)
1394        (map (lambda (x) (list (name/Octave x) " = " (value->Octave (V:Sel x (V:Var 'input))) "; " nl)) input)
1395        nl
1396        (map binding->Octave (append relations-expr (codegen-expr fcodegen))) nl 
1397        "endfunction" nl))
1398
1399     
1400      (if initial
1401              (print-fragments
1402               (list (name/Octave name) "_initial = " 
1403                     (value->Octave
1404                      (V:Rec (map (lambda (x) (let ((n (car x)) (v (cadr x)))
1405                                                (let ((v (cond ((and (or (number? v) (symbol? v))) v)
1406                                                               ((boolean? v) (if v 'true 'false))
1407                                                               (else v))))
1408                                                  (list n (V:C v)))))
1409                                  initial)))
1410                     nl))
1411              )
1412
1413
1414      )))
1415
1416(define (codegen/scheme name f #!key (initial #f) (pre #t) (solver 'rk4b))
1417
1418  (if (and solver (not (member solver '(cvode rkfe rk3 rk4a rk4b rkhe rkbs rkf45))))
1419      (error 'codegen/scheme "unknown solver" solver))
1420
1421  (let ((dfe (sfarrow-dfe f)))
1422
1423    (codegen-state '())
1424
1425    (let* ((input    (or (and initial (map car initial)) ((dfe-in dfe) '())))
1426           (fenv     (map (lambda (s) (cons s 'input)) input))
1427           (fcodegen ((sfarrow-codegen f) input fenv dfe ))
1428           (relations-expr (relations-codegen f input)))
1429
1430      (if pre (print-fragments (prelude/scheme solver: solver integral-index: (integral-index))))
1431
1432      (print-fragments (list (map (lambda (x) 
1433                                    (if (binding? x)
1434                                        (cases binding x
1435                                               (B:Val  (name v)
1436                                                       (list "(define " (name/scheme name) " " (value->scheme v) ")" nl)))
1437                                        (expr->scheme x)))
1438                                  (reverse (codegen-state))) nl))
1439
1440      (print-fragments
1441       (list
1442        "(define (" (name/scheme name) " input)" nl
1443        "(let (" (intersperse (map (lambda (x) (binding->scheme (B:Val x (V:Sel x (V:Var 'input))))) input) " ")  ")"  nl
1444        "(let* (" (map binding->scheme (append relations-expr (codegen-expr fcodegen))) nl ")" nl
1445        (codegen-rv fcodegen) nl
1446        ")))" nl))
1447
1448      (if initial
1449          (print-fragments
1450           (list "(define " (name/scheme name) "_initial " 
1451                 (value->scheme
1452                  (V:Rec (map (lambda (x) (let ((n (car x)) (v (cadr x)))
1453                                            (let ((v (cond ((and (or (number? v) (symbol? v))) v)
1454                                                           ((boolean? v) (if v 'true 'false))
1455                                                           (else v))))
1456                                              (list n (V:C v)))))
1457                              initial))) ")" nl)))
1458
1459
1460      )))
1461
1462(define (codegen/ML name f #!key (initial #f) (pre #t) (post #t) (solver 'rk4b))
1463
1464  (if (and solver (not (member solver '(rkfe rk3 rk4a rk4b rkhe rkbs rkf45))))
1465      (error 'codegen/ML "unknown solver" solver))
1466
1467  (let ((dfe (sfarrow-dfe f)))
1468
1469    (codegen-state '())
1470
1471    (let* ((input    (or (and initial (lset-intersection eq? (map car initial) ((dfe-in dfe) '())))
1472                         ((dfe-in dfe) '())))
1473           (fenv     (map (lambda (s) (cons s 'input)) input))
1474           (fcodegen ((sfarrow-codegen f) input fenv dfe ))
1475           (relations-expr (relations-codegen f input)))
1476
1477
1478      (if pre (print-fragments (prelude/ML solver: solver)))
1479
1480      (print-fragments (list (map (lambda (x) 
1481                                    (if (binding? x)
1482                                        (cases binding x
1483                                               (B:Val  (name v)
1484                                                       (list "val " (name/ML name) " = " (value->ML v) nl)))
1485                                        (expr->ML x)))
1486                                  (reverse (codegen-state))) nl))
1487
1488
1489      (print-fragments
1490       (list
1491        "fun " (name/ML name) "(input as {" (intersperse (map name/ML input) ",")  "})" " = " nl
1492        "let" nl
1493        (map binding->ML (append relations-expr (codegen-expr fcodegen))) nl
1494        "in" nl
1495        (codegen-rv fcodegen)   nl
1496        "end" nl))
1497
1498      (if initial
1499          (print-fragments
1500           (list "val " (name/ML name) "_initial = " 
1501                 (value->ML (V:Rec (map (lambda (x) 
1502                                          (let ((n x) (v (car (alist-ref x initial))))
1503                                            (list n 
1504                                                  (cond ((and (or (number? v) (symbol? v))) 
1505                                                         (V:C v))
1506                                                        ((boolean? v) 
1507                                                         (V:C (if v 'true 'false)))
1508                                                        (else (V:C v))))
1509                                                    ))
1510                                        input))) nl)))
1511
1512      (if post (print-fragments (list "end" nl)))
1513     
1514      )))
1515
1516
1517
1518
1519)
1520
Note: See TracBrowser for help on using the repository browser.