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

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

signal-diagram: bug fixes in integral variable propagation

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