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

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

signal-diagram/flsim: synchronizing changes related to adaptive time step solvers

File size: 6.1 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 ((varh (case (car h) 
83                ((variable) #t)
84                (else #f)))
85        (hname (cadr h))
86
87        (dqs (filter-map (lambda (x) (cond ((= 2 (length x)) (car x))
88                                            (else #f)))
89                          eqs))
90
91        (aqs (filter-map (lambda (x) (cond ((= 3 (length x)) (car x))
92                                           (else #f)))
93                         eqs))
94
95        (ads (filter-map (lambda (x) (cond ((= 3 (length x)) (cadr x))
96                                           (else #f)))
97                         eqs)))
98
99    (let* ((afs (filter-map
100                 (lambda (eq)
101                   (let ((rhs  (cond ((= 3 (length eq)) (caddr eq))
102                                     (else #f)))
103                         (args (cond ((= 3 (length eq)) (cadr eq))
104                                     (else #f))))
105                     (and rhs args
106                          (let ((vars (enum-freevars rhs (append args symbolic-constants) '())))
107                            (make-function (delete-duplicates (append args vars)) rhs)))))
108                 eqs))
109
110           (afs (filter-map
111                 (lambda (eq)
112                   (let ((rhs  (cond ((= 3 (length eq)) (caddr eq))
113                                     (else #f)))
114                         (args (cond ((= 3 (length eq)) (cadr eq))
115                                     (else #f))))
116                     (let ((rhs (and rhs (rewrite-relations rhs (zip aqs afs)))))
117                       (and rhs args
118                            (let ((vars (enum-freevars rhs (append args symbolic-constants) '())))
119                              (make-function (delete-duplicates (append args vars)) rhs))))))
120                 eqs))
121           
122           (dfs (filter-map
123                 (lambda (eq)
124                   (let* ((rhs0 (cond ((= 2 (length eq)) (cadr eq))
125                                      (else #f)))
126                          (rhs1 (and rhs0 (rewrite-relations rhs0 (zip aqs afs)))))
127                    (and rhs1
128                         (let ((vars (delete-duplicates (enum-freevars rhs1 symbolic-constants '()))))
129                           (make-function vars rhs1)))))
130                 eqs)))
131
132      (let ((du (ACTUATE (if varh (cons hname dqs) dqs)
133                         (INTEGRAL indep dqs h dfs))))
134
135        (make-relation (zip aqs ads afs) ;;(SEQUENCE du (make-assign-system `((,indep (+ ,indep ,h))))))
136                       (UNION du (ACTUATE (list indep) 
137                                          (PURE (make-function 
138                                                 (list indep hname) 
139                                                 `(+ ,indep ,hname))))))
140      ))
141    ))
142
143
144(define-syntax DAE
145  (syntax-rules ()
146    [(_ h indep eqn ...)
147     (make-dae-system (quote h) (quote indep) (quote (eqn ...)))]
148    ))
149
150 
151(define (make-ode-system h indep eqs)
152  (let ((varh (case (car h) 
153                ((variable) #t)
154                (else #f)))
155        (hname (cadr h))
156        (deps (map car eqs))
157        (rhss (map cadr eqs)))
158
159    (let ((fs (map
160               (lambda (rhs)                   
161                 (let ((vars (delete-duplicates (enum-freevars rhs symbolic-constants '()))))
162                   (make-function vars rhs)))
163               rhss)))
164
165      (let ((u (cond
166                ((or (null? fs) (null? deps)) 
167                 (error 'make-ode-system "empty list of equations"))
168
169                ((null? (cdr fs))
170                 (let ((d (car deps))) 
171                   (ACTUATE (if varh (list hname d) (list d))
172                            (INTEGRAL indep (list d) h (list (car fs))))
173                   ))
174
175                (else
176                 (ACTUATE (if varh (cons hname deps) deps) 
177                          (INTEGRAL indep deps h fs)))
178                )))
179
180        (UNION u (ACTUATE (list indep) 
181                          (PURE (make-function
182                                 (list indep hname) 
183                                 `(+ ,indep ,hname)))))
184
185        ))
186    ))
187
188
189(define-syntax ODE
190  (syntax-rules ()
191    [(_ h indep (dep rhs) ...)
192     (make-ode-system (quote h) (quote indep) (quote ((dep rhs) ...)))]
193    ))
194
195
196(define (make-assign-system eqs)
197  (let ((vars (map car eqs))
198        (rhss (map cadr eqs)))
199    (let ((fs (map
200               (lambda (x rhs)                 
201                 (let ((vars (delete-duplicates (enum-freevars rhs symbolic-constants '()))))
202                   (ACTUATE (list x)
203                            (if (pair? vars)
204                                (SENSE vars (PURE (make-function vars rhs)))
205                                (PURE (make-function vars rhs))))))
206               vars rhss)))
207      (make-union fs))))
208
209
210(define-syntax ASSIGN
211  (syntax-rules ()
212    [(_ eqn ...)
213     (make-assign-system (quote (eqn ...)))]
214    ))
215
216)
Note: See TracBrowser for help on using the repository browser.