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 | |
---|