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

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

signal-diagram: support for variable timestep integration

File size: 5.4 KB
Line 
1 
2;;
3;;  This module implements signal diagram combinators for differential
4;;  and differential-algebraic equations.
5;;
6;; Copyright 2010-2013 Ivan Raikov and the Okinawa Institute of
7;; Science and Technology.
8;;
9;; This program is free software: you can redistribute it and/or
10;; modify it under the terms of the GNU General Public License as
11;; published by the Free Software Foundation, either version 3 of the
12;; License, or (at your option) any later version.
13;;
14;; This program is distributed in the hope that it will be useful, but
15;; WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
17;; General Public License for more details.
18;;
19;; A full copy of the GPL license can be found at
20;; <http://www.gnu.org/licenses/>.
21;;
22
23
24(module signal-diagram-dynamics
25
26        (
27         (ASSIGN make-assign-system) 
28         (ODE make-ode-system) 
29         (DAE make-dae-system) 
30         make-assign-system 
31         make-ode-system 
32         make-dae-system 
33         )
34
35        (import scheme chicken)
36
37        (require-extension extras data-structures srfi-1 signal-diagram )
38
39
40(define (make-union rhs-list)
41  (let ((n (length rhs-list)))
42    (cond ((= n 1)  (car rhs-list))
43          ((= n 2)  (UNION (car rhs-list) (cadr rhs-list)))
44          (else     (UNION (UNION (car rhs-list) (cadr rhs-list)) 
45                           (make-union (cddr rhs-list)))))))
46
47
48(define (make-relation relation-list sf)
49  (if (null? relation-list) sf
50      (RELATION (car relation-list) 
51                (make-relation (cdr relation-list) sf))))
52
53 
54(define (make-dae-system h indep eqs)
55
56  (define (rewrite-relations expr aqs)
57
58    (cond ((pair? expr)
59
60           (case (car expr)
61
62             ((if) (let ((es (cdr expr))) 
63                     (cons 'if (map (lambda (x) (rewrite-relations x aqs)) es))))
64 
65             ((let)
66              (let ((lbnds (cadr expr))
67                    (body  (caddr expr)))
68                (let ((lbnds1  (map (lambda (x) (list (car x) (rewrite-relations (cadr x) aqs))) lbnds))
69                      (body1   (rewrite-relations body aqs)))
70                  (list 'let lbnds1 body1))))
71
72             (else
73              (let ((s (car expr)) (es (cdr expr)))
74                (cond ((and (symbol? s) (assoc s aqs)) =>
75                       (lambda (x) (cons s (append es (drop (function-formals (cadr x)) (length es))))))
76                      (else (cons s (map (lambda (x) (rewrite-relations x aqs)) es))))))
77
78             ))
79
80          (else  expr)))
81
82  (let ((dqs (filter-map (lambda (x) (cond ((= 2 (length x)) (car x))
83                                            (else #f)))
84                          eqs))
85
86        (aqs (filter-map (lambda (x) (cond ((= 3 (length x)) (car x))
87                                           (else #f)))
88                         eqs))
89
90        (ads (filter-map (lambda (x) (cond ((= 3 (length x)) (cadr x))
91                                           (else #f)))
92                         eqs)))
93
94    (let* ((afs (filter-map
95                 (lambda (eq)
96                   (let ((rhs  (cond ((= 3 (length eq)) (caddr eq))
97                                     (else #f)))
98                         (args (cond ((= 3 (length eq)) (cadr eq))
99                                     (else #f))))
100                     (and rhs args
101                          (let ((vars (enum-freevars rhs (append args symbolic-constants) '())))
102                            (make-function (delete-duplicates (append args vars)) rhs)))))
103                 eqs))
104
105           (afs (filter-map
106                 (lambda (eq)
107                   (let ((rhs  (cond ((= 3 (length eq)) (caddr eq))
108                                     (else #f)))
109                         (args (cond ((= 3 (length eq)) (cadr eq))
110                                     (else #f))))
111                     (let ((rhs (and rhs (rewrite-relations rhs (zip aqs afs)))))
112                       (and rhs args
113                            (let ((vars (enum-freevars rhs (append args symbolic-constants) '())))
114                              (make-function (delete-duplicates (append args vars)) rhs))))))
115                 eqs))
116           
117           (dfs (filter-map
118                 (lambda (eq)
119                   (let* ((rhs0 (cond ((= 2 (length eq)) (cadr eq))
120                                      (else #f)))
121                          (rhs1 (and rhs0 (rewrite-relations rhs0 (zip aqs afs)))))
122                    (and rhs1
123                         (let ((vars (delete-duplicates (enum-freevars rhs1 symbolic-constants '()))))
124                           (make-function vars rhs1)))))
125                 eqs)))
126
127      (let ((du (ACTUATE dqs (INTEGRALH indep dqs h dfs))))
128
129        (make-relation (zip aqs ads afs) ;;(SEQUENCE du (make-assign-system `((,indep (+ ,indep ,h))))))
130                       (SEQUENCE du (ACTUATE (list indep h) (PURE (make-function (list indep h) `(+ ,indep ,h)))))
131                       )
132      ))
133    ))
134
135
136(define-syntax DAE
137  (syntax-rules ()
138    [(_ h indep eqn ...)
139     (make-dae-system (quote h) (quote indep) (quote (eqn ...)))]
140    ))
141
142 
143(define (make-ode-system h indep eqs)
144  (let ((deps (map car eqs))
145        (rhss (map cadr eqs)))
146    (let ((fs (map
147               (lambda (rhs)                   
148                 (let ((vars (delete-duplicates (enum-freevars rhs symbolic-constants '()))))
149                   (make-function vars rhs)))
150               rhss)))
151
152      (let ((u (cond ((or (null? fs) (null? deps)) (error 'make-ode-system "empty list of equations"))
153                     ((null? (cdr fs))
154                      (let ((d (car deps))) 
155                        (ACTUATE (list d) (INTEGRALH indep (list d) h (list (car fs))))
156                        ))
157                     (else
158                      (ACTUATE deps (INTEGRALH indep deps h fs)))
159                     )))
160
161        (SEQUENCE u (ACTUATE (list indep h) (PURE (make-function (list indep h) `(+ ,indep ,h)))))
162
163        ))
164    ))
165
166
167(define-syntax ODE
168  (syntax-rules ()
169    [(_ h indep (dep rhs) ...)
170     (make-ode-system (quote h) (quote indep) (quote ((dep rhs) ...)))]
171    ))
172
173
174(define (make-assign-system eqs)
175  (let ((vars (map car eqs))
176        (rhss (map cadr eqs)))
177    (let ((fs (map
178               (lambda (x rhs)                 
179                 (let ((vars (delete-duplicates (enum-freevars rhs symbolic-constants '()))))
180                   (ACTUATE (list x)
181                            (if (pair? vars)
182                                (SENSE vars (PURE (make-function vars rhs)))
183                                (PURE (make-function vars rhs))))))
184               vars rhss)))
185      (make-union fs))))
186
187
188(define-syntax ASSIGN
189  (syntax-rules ()
190    [(_ eqn ...)
191     (make-assign-system (quote (eqn ...)))]
192    ))
193
194)
Note: See TracBrowser for help on using the repository browser.