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

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

signal-diagram: fix to algebraic system

File size: 17.9 KB
Line 
1 
2;;
3;;  This module implements combinators that are used to build
4;;  algebraic system 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 2013 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 algebraic-system 
32
33        (PRIM EQUATION RELATION UNION
34
35         function? make-function function-formals function-body
36         prim? make-prim prim-states prim-formals prim-body prim-init
37
38         signal? signal-name signal-value
39
40         enum-freevars
41         
42         construct dataflow codegen/Octave codegen/scheme codegen/ML
43         )
44
45        (import scheme chicken)
46
47        (require-extension extras data-structures srfi-1 datatype flsim)
48        (require-library lolevel srfi-13)
49        (import (only srfi-13 string-concatenate string<)
50                (only lolevel extended-procedure? procedure-data extend-procedure )
51                )
52
53(include "expr-utils")
54
55(define nl "\n")
56(define (s+ . rst) (string-concatenate (map ->string rst)))
57
58;; based on SRV:send-reply by Oleg Kiselyov
59(define (print-fragments b)
60  (let loop ((fragments b) (result #f))
61    (cond
62      ((null? fragments) result)
63      ((not (car fragments)) (loop (cdr fragments) result))
64      ((null? (car fragments)) (loop (cdr fragments) result))
65      ((eq? #t (car fragments)) (loop (cdr fragments) #t))
66      ((pair? (car fragments))
67        (loop (cdr fragments) (loop (car fragments) result)))
68      ((procedure? (car fragments))
69        ((car fragments))
70        (loop (cdr fragments) #t))
71      (else
72       (display (car fragments))
73       (loop (cdr fragments) #t)))))
74
75
76(define (symbol-pair? x)
77  (and (pair? x) 
78       (and (symbol? (car x)) 
79            (or (null? (cdr x)) 
80                (symbol-pair? (cdr x))))))
81
82
83(define (symbol-list? x)
84  (and (list? x) (every symbol? x)))
85
86
87
88(define make-signal cons)
89(define signal-name car)
90(define signal-value cdr)
91(define signal? pair?)
92
93
94(define-values (cgenenv-empty cgenenv-add cgenenv-find cgenenv-union )
95  (letrec (
96           (empty      '())
97           (add        (lambda (s v env) 
98                         (if (and (symbol? s) (symbol? v))
99                             (cons (cons s v) env)
100                             (error 'cgenenv-add "invalid arguments to add" s v))))
101           (find       (lambda (loc s env)
102                         (let ((v (alist-ref s env)))
103                           (if (not v) (error loc "label not found" s))
104                           v)))
105           (union      (lambda (x y) (lset-union (lambda (x y) (eq? (first x) (first y))) x y)))
106           )
107    (values empty add find union )))
108
109
110(define (list->cgenenv loc slst source-cgenenv)
111  (fold (lambda (s env) (cgenenv-add s (cgenenv-find loc s source-cgenenv) env))
112        cgenenv-empty slst))
113
114
115
116
117;;
118;;   An arrow is an object with:
119;;
120;;   * dfe method, which produces dataflow information
121;;   * codegen method, which generates pseudo-imperative code
122;;
123
124(define-record-type larrow
125  (make-larrow  dfe codegen sig children relations)
126  larrow?
127  (dfe         larrow-dfe)
128  (codegen     larrow-codegen)
129  (sig         larrow-sig)
130  (children    larrow-children)
131  (relations   larrow-relations)
132  )
133
134
135(define-record-type dfe
136  (make-dfe gen kill in out)
137  dfe?
138  (gen       dfe-gen )
139  (kill      dfe-kill )
140  (in        dfe-in )
141  (out       dfe-out )
142  )
143
144
145(define-record-type function
146  (make-function formals body)
147  function?
148  (formals function-formals)
149  (body    function-body))
150
151
152(define-record-type prim
153  (make-prim states formals outputs body init-outputs init)
154  prim?
155  (states  prim-states)
156  (formals prim-formals)
157  (outputs prim-outputs)
158  (body    prim-body)
159  (init    prim-init)
160  (init-outputs prim-init-outputs)
161  )
162
163
164(define (function-list? x)
165  (and (list? x) (every function? x)))
166
167
168(define (relation? r)
169  (and (pair? r) (symbol? (car r)) 
170       (symbol-list? (cadr r))
171       (function? (caddr r))))
172
173
174(define-datatype alsys alsys?
175  (PRIM         (f prim?) (name symbol?))
176  (RELATION     (r relation?) (f alsys?))
177  (UNION        (f alsys?) (g alsys?))
178  (EQUATION     (s symbol?) (f function?))
179  )
180
181(define (select-signal loc s env)
182  (let ((v (cgenenv-find loc s env)))
183    (if (eq? s v) (V:Var s) (V:Sel s (V:Var v)))))
184
185
186(define-record-type codegen
187  (make-codegen0 rv renv expr)
188  codegen?
189  (rv          codegen-rv)
190  (renv        codegen-renv)
191  (expr        codegen-expr)
192  )
193
194(define (make-codegen rv renv expr)
195  (if (not (symbol? rv)) (error 'make-codegen "invalid return variable"))
196  (make-codegen0 rv renv expr))
197
198
199(define codegen-state (make-parameter '()))
200   
201                                           
202;;
203;;  The arrow combinators are used to build signal functions upon pure
204;;  functions.
205;; 
206
207;;  [ls f] encapsulates a pure function into a signal function.
208
209
210(define (ls f name)
211   (let* (
212          (fd (and (extended-procedure? f) (procedure-data f)))
213          (formals (or (and (prim? fd) (prim-outputs fd)) 
214                       (and (function? fd) (function-formals fd))
215                       '()))
216          (outputs (or (and (prim? fd) (prim-outputs fd)) '()))
217          (states (or (and (prim? fd) (prim-states fd)) '()))
218          )
219
220     (make-larrow 
221
222      ;; dataflow equations
223      (make-dfe
224       ;; gen
225       (lambda (s) (if (prim? fd) outputs (list name)))
226       ;; kill
227       (lambda (s) (if (prim? fd) outputs (list name)))
228       ;; in
229       (lambda (s) formals)
230       ;; out
231       (lambda (s) (if (prim? fd) outputs (list name))))
232
233      ;; codegen
234      (lambda (s env dfe) 
235        (let ((in   ((dfe-in dfe) s))
236              (out  ((dfe-out dfe) s))
237              (rv1  (gensym 'rv))
238              (rv2  (gensym 'rv))
239              (init-name (and (prim? fd) (gensym (string->symbol (string-append (->string name) "init")))))
240              )
241
242          (make-codegen
243           rv2
244           (fold (lambda (name env) (cgenenv-add name rv2 env)) cgenenv-empty out)
245           (append
246           
247            (cond ((function? fd)
248                   (list (function->expr name fd)))
249                  ((prim? fd)
250                   (list (prim->expr name fd) ))
251                  (else '()))
252
253            (cond ((function? fd)
254                   (if (null? (function-formals fd))
255                       (list (B:Val rv2 (V:Rec `((,name ,(V:Var name))))))
256                       (list (B:Val rv1 (V:Op name (map (lambda (s) (select-signal 'ls s env)) in)))
257                             (B:Val rv2 (V:Rec `((,name ,(V:Var rv1))))))))
258
259                  ((prim? fd)
260
261                     (codegen-state
262                      (append
263                       (list (prim->init init-name fd))
264                       (codegen-state)))
265
266                     (list (B:Val rv1 (V:Op name (append
267                                                  (map (lambda (s) (select-signal 'ls s env)) in)
268                                                  (map (lambda (x) (V:Sel x (V:Var init-name))) 
269                                                       (lset-difference eq? states in)))))
270                           (B:Val rv2 (V:Rec (map (lambda (s) `(,s ,(V:Sel s (V:Var rv1)))) outputs)))
271                           )
272                     )
273                 
274                  (else '())
275                  )
276            ))
277          ))
278      ;; signature
279      `(EQUATION ,name ,states ,outputs)
280      ;; children
281      `(EQUATION)
282      ;; relations
283      `()
284      ))
285     )
286 
287
288
289
290(define (ls-equation name f)
291  (let* ((f0   (cond ((function? f)  (lambda () `(,name ,(function-formals f) ,(function-body f))))
292                     ((procedure? f) f)
293                     (else (error 'ls-equation "invalid function" f))))
294         (f1 (if (function? f) (extend-procedure f0 f) f0)))
295    (ls f1 name)))
296
297
298(define (ls-prim f name)
299  (let* ((f0   (cond ((prim? f)  (lambda () `(,name ,(append (prim-formals f) (prim-states f)) ,(prim-body f))))
300                     (else (error 'ls-prim "invalid primitive" f))))
301         (f1 (if (prim? f) (extend-procedure f0 f) f0)))
302    (ls f1 name)))
303
304
305(define (ls-relation r ls)
306
307  (define (relation-vars r) (function-formals (caddr r)))
308
309  (define (relations-inputs ls)
310    (let recur ((ls ls) (inputs '()))
311      (let ((inputs (append
312                     (concatenate (map relation-vars (larrow-relations ls)))
313                     inputs)))
314        (let ((ls-children (filter-map larrow? (larrow-sig ls))))
315          (if (null? ls-children) inputs
316              (fold recur inputs ls-children)
317              )))
318      ))
319
320  (if (relation? r)
321      (let* ((dfe (larrow-dfe ls))
322             (dfe1 (make-dfe (dfe-gen dfe) (dfe-kill dfe)
323                             (lambda (s) (delete-duplicates
324                                          (lset-difference eq? 
325                                              (append ((dfe-in dfe) s) 
326                                                      (relations-inputs ls))
327                                              (relation-vars r))))
328                             (dfe-out dfe))))
329        (make-larrow dfe1 
330                      (larrow-codegen ls) 
331                      (larrow-sig ls) (larrow-children ls)
332                      (cons r (larrow-relations ls))))
333      (error 'ls-relation "invalid relation" r)))
334
335
336(define (relations-codegen ls env)
337
338  (let ((kons (map (lambda (x) (car x)) (larrow-relations ls))))
339
340    (codegen-state
341     (append (codegen-state)
342             (reverse
343              (map
344               (lambda (r k)
345                 (let ((name (car r)) 
346                       (fd (caddr r)))
347                   (function->expr k fd)))
348               (larrow-relations ls) kons))
349             ))
350    '()
351    ))
352
353
354
355
356
357
358;; [union f g], applies [f] and [g] to the input signal in parallel.
359
360(define (ls-union f g)
361
362  (define (flatten-union u)
363    (let ((uc (larrow-children u)))
364      (case (car uc)
365        ((UNION)  (append (flatten-union (cadr uc))
366                          (flatten-union (caddr uc))))
367        (else     (list u)))))
368   
369
370   (let* ((fe      (larrow-dfe f))
371          (ge      (larrow-dfe g))
372
373          (fe-in   (dfe-in fe))   
374          (fe-out  (compose (dfe-out fe) fe-in))
375          (fe-gen  (compose (dfe-gen fe) fe-in))
376          (fe-kill (compose (dfe-kill fe) fe-in))
377
378          (ge-in   (dfe-in ge))
379          (ge-out  (compose (dfe-out ge) ge-in))
380          (ge-gen  (compose (dfe-gen ge) ge-in))
381          (ge-kill (compose (dfe-gen ge) ge-in))
382         
383          (flst (flatten-union f))
384          (glst (flatten-union g))
385          )
386
387     (make-larrow
388
389      ;; dataflow equations
390      (make-dfe
391       ;; gen
392       (lambda (s) (lset-union eq? (ge-gen s) (fe-gen s)))
393       
394       ;; kill
395       (lambda (s) (lset-union eq? (fe-kill s) (ge-kill s)))
396       
397       ;; in
398       (lambda (s) (lset-union eq? (ge-in s) (fe-in s)))
399       
400       ;; out
401       (lambda (s) (lset-union eq? (ge-out s) (fe-out s)))
402       
403       )
404
405      ;; codegen
406      (lambda (s env dfe) 
407        (let* (
408               (fgx      (lset-intersection eq? (fe-gen s) (ge-gen s)))
409               
410               (codegen (lambda (ls)
411                          (let ((codegen (larrow-codegen ls))
412                                (dfe (larrow-dfe ls)))
413                            (let ((env (list->cgenenv 'union1 ((dfe-in dfe) s) env)))
414                              (codegen ((dfe-in dfe) s) env dfe)))))
415
416               (fld  (lambda (codegen dfe)
417                       (let ((renv (codegen-renv codegen)))
418                         (map (lambda (x) (list x (select-signal 'union2 x renv)))
419                              ((dfe-out dfe) s)))))
420               
421               )
422
423          (if (not (null? fgx)) (error 'ls-union "union arguments output overlapping signals" fgx))
424
425          (let ((rv (gensym 'union))
426                (fcodegen-lst (map codegen flst))
427                (gcodegen-lst (map codegen glst))
428                )
429
430              (let* ((renv-lst (map codegen-renv (append fcodegen-lst gcodegen-lst)))
431                     (expr-lst (map codegen-expr (append fcodegen-lst gcodegen-lst)))
432                     (renv (list->cgenenv 'union3 ((dfe-out dfe) s)
433                                (let recur ((renv-lst renv-lst) (env '()))
434                                  (if (null? renv-lst) env
435                                      (recur (cdr renv-lst) (cgenenv-union (car renv-lst) env)))))))
436
437                (make-codegen 
438
439                 rv
440                 
441                 (fold (lambda (name env) (cgenenv-add name rv env)) cgenenv-empty (map car renv))
442                 
443                 (let ((fflds  (map fld fcodegen-lst (map larrow-dfe flst)))
444                       (gflds  (map fld gcodegen-lst (map larrow-dfe glst))))
445                   (append
446                    (concatenate (map (lambda (f) (relations-codegen f env)) (append flst glst)))
447                    (concatenate expr-lst)
448                    (list (B:Val rv (V:Rec (map (lambda (s) `(,s ,(select-signal 'union4 s renv))) (map car renv)))))
449                    ))
450               
451               )))
452            ))
453      ;; signature
454      `(UNION ,(larrow-sig f) ,(larrow-sig g))
455      ;; children
456      `(UNION  ,f ,g)
457      ;; relations
458      (append (larrow-relations f) (larrow-relations g))
459      ))
460)
461
462
463
464(define (construct l)
465  (cases alsys l
466         (EQUATION (x f)           (ls-equation x f))
467         (PRIM (f name)            (ls-prim f name))
468         (RELATION (r f)           (ls-relation r (construct f)))
469         (UNION (f g)              (ls-union (construct f) (construct g)))
470         ))
471
472
473(define (dataflow f input)
474  (let ((dfe (larrow-dfe f)))
475    `((gen  . ,((dfe-gen dfe) input))
476      (kill . ,((dfe-kill dfe) input))
477      (in   . ,((dfe-in dfe) input))
478      (out  . ,((dfe-out dfe) input)))))
479
480
481(define (codegen/Octave name f #!key (initial #f) (pre #t))
482
483  (let ((dfe (larrow-dfe f)))
484
485    (codegen-state '())
486
487    (let* ((input    (or (and initial (map car initial)) ((dfe-in dfe) '())))
488           (fenv     (map (lambda (s) (cons s 'input)) input))
489           (fcodegen ((larrow-codegen f) input fenv dfe ))
490           (relations-expr (relations-codegen f input))
491           (globals   (filter-map
492                       (lambda (x) 
493                         (cases binding x
494                                (B:Val  (name v) (name/Octave name))
495                                (else  #f)))
496                       (codegen-state))))
497
498      (if pre (print-fragments (prelude/Octave)))
499      (print-fragments (list "global " (intersperse globals " ") ";" nl))
500
501      (print-fragments (list (map (lambda (x) 
502                                    (if (binding? x)
503                                        (cases binding x
504                                               (B:Val  (name v) (list (name/Octave name) " = " (value->Octave v) ";" nl)))
505                                        (expr->Octave x)))
506                                  (reverse (codegen-state))) nl))
507
508      (print-fragments
509       (list
510        "function " (name/Octave (codegen-rv fcodegen)) " = " (name/Octave name) " (input)" nl
511        (list "global " (intersperse globals " ") ";" nl)
512        (map (lambda (x) (list (name/Octave x) " = " (value->Octave (V:Sel x (V:Var 'input))) "; " nl)) input)
513        nl
514        (map binding->Octave (append relations-expr (codegen-expr fcodegen))) nl 
515        "endfunction" nl))
516
517     
518      (if initial
519              (print-fragments
520               (list (name/Octave name) "_initial = " 
521                     (value->Octave
522                      (V:Rec (map (lambda (x) (let ((n (car x)) (v (cadr x)))
523                                                (let ((v (cond ((and (or (number? v) (symbol? v))) v)
524                                                               ((boolean? v) (if v 'true 'false))
525                                                               (else v))))
526                                                  (list n (V:C v)))))
527                                  initial)))
528                     nl))
529              )
530
531
532      ))
533  )
534
535
536(define (codegen/scheme name f #!key (initial #f) (pre #t))
537
538  (let ((dfe (larrow-dfe f)))
539
540    (codegen-state '())
541
542    (let* ((input    (or (and initial (map car initial)) ((dfe-in dfe) '())))
543           (fenv     (map (lambda (s) (cons s 'input)) input))
544           (fcodegen ((larrow-codegen f) input fenv dfe ))
545           (relations-expr (relations-codegen f input)))
546
547      (if pre (print-fragments (prelude/scheme)))
548
549      (print-fragments (list (map (lambda (x) 
550                                    (if (binding? x)
551                                        (cases binding x
552                                               (B:Val  (name v)
553                                                       (list "(define " (name/scheme name) " " (value->scheme v) ")" nl)))
554                                        (expr->scheme x)))
555                                  (reverse (codegen-state))) nl))
556
557      (print-fragments
558       (list
559        "(define (" (name/scheme name) " input)" nl
560        "(let (" (intersperse (map (lambda (x) (binding->scheme (B:Val x (V:Sel x (V:Var 'input))))) input) " ")  ")"  nl
561        "(let* (" (map binding->scheme (append relations-expr (codegen-expr fcodegen))) nl ")" nl
562        (codegen-rv fcodegen) nl
563        ")))" nl))
564
565      (if initial
566          (print-fragments
567           (list "(define " (name/scheme name) "_initial " 
568                 (value->scheme
569                  (V:Rec (map (lambda (x) (let ((n (car x)) (v (cadr x)))
570                                            (let ((v (cond ((and (or (number? v) (symbol? v))) v)
571                                                           ((boolean? v) (if v 'true 'false))
572                                                           (else v))))
573                                              (list n (V:C v)))))
574                              initial))) ")" nl)))
575
576
577      )))
578
579(define (codegen/ML name f #!key (initial #f) (pre #t) (post #t))
580
581  (let ((dfe (larrow-dfe f)))
582
583    (codegen-state '())
584
585    (let* ((input    (or (and initial (lset-intersection eq? (map car initial) ((dfe-in dfe) '())))
586                         ((dfe-in dfe) '())))
587           (fenv     (map (lambda (s) (cons s 'input)) input))
588           (fcodegen ((larrow-codegen f) input fenv dfe ))
589           (relations-expr (relations-codegen f input)))
590
591
592      (if pre (print-fragments (prelude/ML)))
593
594      (print-fragments (list (map (lambda (x) 
595                                    (if (binding? x)
596                                        (cases binding x
597                                               (B:Val  (name v)
598                                                       (list "val " (name/ML name) " = " (value->ML v) nl)))
599                                        (expr->ML x)))
600                                  (reverse (codegen-state))) nl))
601
602
603      (print-fragments
604       (list
605        "fun " (name/ML name) "(input as {" (intersperse (map name/ML input) ",")  "})" " = " nl
606        "let" nl
607        (map binding->ML (append relations-expr (codegen-expr fcodegen))) nl
608        "in" nl
609        (codegen-rv fcodegen)   nl
610        "end" nl))
611
612      (if initial
613          (print-fragments
614           (list "val " (name/ML name) "_initial = " 
615                 (value->ML (V:Rec (map (lambda (x) 
616                                          (let ((n x) (v (car (alist-ref x initial))))
617                                            (list n 
618                                                  (cond ((and (or (number? v) (symbol? v))) 
619                                                         (V:C v))
620                                                        ((boolean? v) 
621                                                         (V:C (if v 'true 'false)))
622                                                        (else (V:C v))))
623                                                    ))
624                                        input))) nl)))
625
626      (if post (print-fragments (list "end" nl)))
627     
628      )))
629
630
631
632
633)
634
Note: See TracBrowser for help on using the repository browser.