source: project/release/4/9ML-toolkit/trunk/ivp-lib.scm @ 30976

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

signal-diagram / 9ML-toolkit: refactoring transients

File size: 10.7 KB
Line 
1;;
2;;  An IVP solver for NineML.
3;;
4;;
5;; Copyright 2010-2013 Ivan Raikov and the Okinawa Institute of
6;; Science and Technology.
7;;
8;; This program is free software: you can redistribute it and/or
9;; modify it under the terms of the GNU General Public License as
10;; published by the Free Software Foundation, either version 3 of the
11;; License, or (at your option) any later version.
12;;
13;; This program is distributed in the hope that it will be useful, but
14;; WITHOUT ANY WARRANTY; without even the implied warranty of
15;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
16;; General Public License for more details.
17;;
18;; A full copy of the GPL license can be found at
19;; <http://www.gnu.org/licenses/>.
20;;
21
22
23(module 9ML-ivp-lib
24
25        (
26         ivp-verbose  ivp-simulation-platform ivp-simulation-method
27         make-ivp-cgen-hook make-ivp-data-hook make-ivp-plot-hook
28         )
29
30(import scheme chicken)
31
32(require-extension datatype matchable static-modules miniML miniMLsyntax miniMLvalue miniMLeval)
33(require-extension object-graph signal-diagram)
34(require-extension 9ML-parse 9ML-eval 9ML-plot)
35(require-extension 9ML-ivp-octave 9ML-ivp-chicken 9ML-ivp-mlton 9ML-ivp-octave-mlton )
36
37(import (only files pathname-file)
38        (only utils system*)
39        (only extras fprintf)
40        (only posix process-fork)
41        (only data-structures string-intersperse ->string alist-ref)
42        (only srfi-1 lset-intersection lset-difference)
43        )
44
45(define lookup-def 
46  (lambda (k lst . rest)
47    (let-optionals rest ((default #f))
48      (alist-ref k lst eq? default))))
49
50
51(define ivp-simulation-platform (make-parameter #f))
52(define ivp-simulation-method (make-parameter 'rk3))
53(define ivp-verbose (make-parameter 0))
54
55(define (d fstr . args)
56  (let ([port (current-error-port)])
57    (if (positive? (ivp-verbose)) 
58        (begin (apply fprintf port fstr args)
59               (flush-output port) ) )))
60
61
62(define (run:execute explist)
63  (define (smooth lst)
64    (let ((slst (map ->string lst)))
65      (string-intersperse (cons (car slst) (cdr slst)) " ")))
66  (for-each (lambda (cmd) (system (->string cmd)))
67            (map smooth explist)))
68
69
70(define (run:execute* explist)
71  (define (smooth lst)
72    (let ((slst (map ->string lst)))
73      (string-intersperse (cons (car slst) (cdr slst)) " ")))
74  (for-each (lambda (cmd) (system* "~a" cmd))
75            (map smooth explist)))
76
77
78(define-syntax run
79  (syntax-rules ()
80    ((_ exp ...)
81     (begin
82       (d "running ~A ...~%" (list `exp ...))
83       (run:execute* (list `exp ...))))))
84
85
86(define-syntax run-
87  (syntax-rules ()
88    ((_ exp ...)
89     (begin
90       (d "running ~A ...~%" (list `exp ...))
91       (run:execute (list `exp ...))))))
92
93
94;; Use args:usage to generate a formatted list of options (from OPTS),
95;; suitable for embedding into help text.
96
97(define nl "\n")
98
99
100(define (construct-ivp prefix name sxml-tuple htype)
101
102  (let ((sexpr 
103         (let ((sexpr (sxml-value->sexpr sxml-tuple)))
104           (case (car sexpr)
105             ((ivp)
106              (and (pair? (cdr sexpr))
107                   (case (cadr sexpr)
108                     ((initial)  (cddr sexpr))
109                     (else #f))))
110             (else #f)))))
111
112      (and sexpr
113           (match-let (((ivar hvar) (cdr sexpr)))
114
115             (let* (
116                    (diagram+initial (sexpr->diagram+initial `(,htype ,hvar) (car sexpr) ))
117                    (sd (construct (car diagram+initial)))
118                    (ic (cadr diagram+initial))
119                    (fields (caddr diagram+initial))
120                    )
121
122               (if (not (alist-ref ivar ic))
123                   (error 'construct-ivp "IVP independent variable is not present in given system" name ivar))
124               (if (not (alist-ref hvar ic))
125                   (error 'construct-ivp "IVP step variable is not present in given system" name hvar))
126
127               (let* ((dfe (dataflow sd '()))
128                      (dvars (lset-difference eq?
129                                              (lset-intersection eq? (alist-ref 'in dfe) (alist-ref 'out dfe))
130                                              (list ivar)))
131                      (pvars (lset-difference eq? (alist-ref 'in dfe) (cons ivar dvars)))
132                      (events (reverse (events sd)))
133                      )
134
135                 `(
136                   (signal-diagram . ,sd)
137                   (initial-conditions . ,ic)
138                   (dfe    . ,dfe)
139                   (ivar   . ,ivar)
140                   (hvar   . ,hvar)
141                   (dvars  . ,dvars)
142                   (pvars  . ,pvars)
143                   (events . ,events)
144                   (fields . ,fields)
145                   )
146                 ))
147             ))
148      ))
149                   
150                 
151
152(define (generate-ivp-code prefix ivp-id sxml-tuple
153                           #!key (platform 'chicken) (method 'rk3))
154
155  (let* ((htype (case method 
156                  ((rkfe rk3 rk4a rk4b) 'fixed)
157                  ((rkhe rkbs rkf45 rkck rkdp rkf78 rkv65) 'variable)))
158         (sdinfo (construct-ivp prefix ivp-id sxml-tuple htype)))
159
160    (d "generate-ivp-code: sdinfo = ~A~%" sdinfo)
161
162
163    (if (not sdinfo)
164
165        (error 'generate-ivp-code "invalid network node")
166       
167        (let (
168              (sd      (lookup-def 'signal-diagram sdinfo))
169              (ic      (lookup-def 'initial-conditions sdinfo))
170              (ivar    (lookup-def 'ivar sdinfo))
171              (hvar    (lookup-def 'hvar sdinfo))
172              (dvars   (lookup-def 'dvars sdinfo))
173              (pvars   (lookup-def 'pvars sdinfo))
174              (events  (lookup-def 'events sdinfo))
175              )
176         
177          (d "generate-ivp-code: ic = ~A~%" ic)
178         
179          (case platform
180           
181            ((octave)
182             (begin
183               (ivp-octave-codegen prefix ivp-id hvar ivar dvars pvars events ic sd)
184               `((ivp-id . ,ivp-id) . ,sdinfo)))
185           
186            ((octave/mlton octave-mlton)
187             (begin
188               (ivp-octave-mlton-codegen prefix ivp-id hvar ivar dvars pvars ic sd)
189               `((ivp-id . ,ivp-id) . ,sdinfo)))
190           
191            ((mlton)
192             (begin
193               (ivp-mlton-codegen prefix ivp-id ivar dvars pvars ic sd method)
194               `((ivp-id . ,ivp-id) . ,sdinfo)))
195           
196            ((chicken)
197             (begin
198               (ivp-chicken-codegen prefix ivp-id ivar dvars pvars events ic sd method)
199               `((ivp-id . ,ivp-id) . ,sdinfo)))
200           
201            (else (error 'generate-ivp-code "unknown platform"  platform))
202           
203            ))
204        ))
205 
206  )               
207
208(define (generate-ivp-table prefix ivp-id sxml-tuple #!key (platform 'chicken) (method 'rk3))
209
210               
211  (let ((htype (case method 
212                 ((rkfe rk3 rk4a rk4b) 'fixed)
213                 ((rkhe rkbs rkf45 rkck rkdp rkf78 rkv65) 'variable)))
214        (sexpr 
215         (let ((sexpr (sxml-value->sexpr sxml-tuple)))
216           (case (car sexpr)
217             ((ivp)
218              (and (pair? (cdr sexpr))
219                   (case (cadr sexpr)
220                     ((run)  (cddr sexpr))
221                     (else #f))))
222             (else #f)))))
223
224    (d "generate-ivp-table: sexpr = ~A~%" (sxml-value->sexpr sxml-tuple))
225
226      (and sexpr
227           (match-let (((ivar hvar start end) (cdr sexpr)))
228
229             (let* ((diagram+initial (sexpr->diagram+initial `(,htype ,hvar) (car sexpr)))
230                    (sd (construct (car diagram+initial)))
231                    (ic (cadr diagram+initial)))
232
233               (d "generate-ivp-table: ic = ~A~%" ic)
234
235               (if (not (alist-ref ivar ic))
236                   (error 'generate-ivp-table "IVP independent variable is not present in given system" ivar))
237               (if (not (alist-ref hvar ic))
238                   (error 'generate-ivp-table "IVP step variable is not present in given system" hvar))
239               (let* ((dfe (dataflow sd '()))
240                      (dvars (lset-difference eq?
241                                              (lset-intersection eq? (alist-ref 'in dfe) (alist-ref 'out dfe))
242                                              (list ivar)))
243                      (pvars (lset-difference eq? (alist-ref 'in dfe) (cons ivar dvars)))
244                      (events (events sd))
245                      )
246
247
248                 (case platform
249                   
250                   ((octave)
251                    (process-fork
252                     (lambda () (ivp-octave prefix ivp-id hvar ivar dvars pvars events start end ic sd)))
253                    (list ivp-id ivar dvars) )
254
255                   ((octave/mlton octave-mlton)
256                    (process-fork
257                     (lambda () (ivp-octave-mlton prefix ivp-id hvar ivar dvars pvars start end ic sd)))
258                    (list ivp-id ivar dvars) )
259                   
260                   ((mlton)
261                    (process-fork
262                     (lambda () (ivp-mlton  prefix ivp-id ivar dvars pvars start end ic sd method)))
263                    (list ivp-id ivar dvars) )
264
265                   ((chicken)
266                    (process-fork
267                     (lambda () (ivp-chicken prefix ivp-id ivar dvars pvars events start end ic sd)))
268                    (list ivp-id ivar dvars) )
269
270                   (else (error 'generate-ivp-table "unknown platform"  platform))
271                   
272                   )))
273             )))
274  )
275
276
277
278(define (make-ivp-cgen-hook ivp-env)
279  (lambda (prefix name label value)
280
281    (cond
282
283     ((or (and (string? label) (string=? label "ivp"))
284          (and (pair? label) (string=? (car label) "ivp"))) ;; value is an IVP
285
286      (d "make-ivp-cgen-hook: value = ~A~%" value)
287
288      (let ((ivp-info (generate-ivp-code prefix name value 
289                                         method: 'rkfe 
290                                         platform: (ivp-simulation-platform))))
291        (ivp-env (cons `(,(string->symbol name) . ,ivp-info) (ivp-env)))
292        ivp-info
293        ))
294     
295     (else #f)
296     ))
297  )
298           
299
300(define (make-ivp-data-hook #!key (ivp #f) (diagram #f))
301  (lambda (prefix name label value)
302
303    (cond
304     ((and diagram
305           (or (and (string? label) (string=? label "diagram")) 
306               (and (pair? label) (string=? (car label) "diagram")))) ;; value is a diagram
307      (let* ((diagram-id (gensym 'diagram))
308             (diagram-link `(img (@ (src ,(sprintf "~A.png" diagram-id))) (alt "NineML diagram"))))
309        (plot-diagram prefix diagram-id value)
310        diagram-link
311        ))
312     
313     ((and ivp (or (and (string? label) (string=? label "ivp"))
314                   (and (pair? label) (string=? (car label) "ivp")))) ;; value is an IVP
315      (let ((ivp-id (gensym (string->symbol (string-append (->string name) "ivp")))))
316        (let ((ivp-info (generate-ivp-table prefix ivp-id value 
317                                            method: (ivp-simulation-method)
318                                            platform: (ivp-simulation-platform))))
319          ivp-info
320        ))
321      )
322     
323     (else #f))))
324           
325
326(define (make-ivp-plot-hook #!key (ivp #f) (plot-format 'png) (plot-index #f))
327  (lambda (prefix name label value)
328    (cond
329
330     ((and ivp (or (and (string? label) (string=? label "ivp"))
331                   (and (pair? label) (string=? (car label) "ivp")))) ;; value is an IVP
332      (let* ((ivp-id (gensym 'ivp))
333             (ivp-plot-link `(img (@ (src ,(sprintf "~A_~A.png" (pathname-file prefix) ivp-id)) (alt "NineML IVP plot")))))
334
335        (let ((ivp-info (generate-ivp-table prefix ivp-id value 
336                                            platform: (ivp-simulation-platform)
337                                            method: (ivp-simulation-method))))
338          (plot-ivp prefix ivp-info format: plot-format index: plot-index)
339          ivp-plot-link)
340        ))
341     
342     (else #f))))
343           
344
345
346)
Note: See TracBrowser for help on using the repository browser.