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

Last change on this file since 23765 was 23765, checked in by Ivan Raikov, 10 years ago

9ML-toolkit: more fixes to the examples

File size: 16.1 KB
Line 
1;;
2;;  An IVP solver for NineML.
3;;
4;;
5;; Copyright 2010-2011 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(require-extension setup-api srfi-13 datatype static-modules miniML miniMLsyntax miniMLvalue miniMLeval)
23(require-extension getopt-long ssax sxml-transforms sxpath sxpath-lolevel object-graph signal-diagram)
24(require-extension 9ML-parse 9ML-repr )
25
26
27(include "SXML.scm")
28(include "SXML-to-XML.scm")
29
30(define-values (env-binding? env-empty env-add-signature env-add-module env-add-type env-add-spec env-add-value
31                env-find-value env-find-type env-find-module env-find)
32  (make-mod-env core-syntax))
33
34(define-values (scope-typedecl scope-modtype scope-signature scope-modterm scope-moddef)
35  (make-mod-scoping core-syntax core-scoping))
36
37(define-values (check-modtype check-signature type-modterm type-moddef type-definition)
38  (make-mod-typing core-syntax core-typing))
39
40
41
42(include "NineMLcore.scm")
43(include "NineMLsignal.scm")
44(include "NineMLdiagram.scm")
45(include "NineMLinterval.scm")
46(include "NineMLgraph.scm")
47(include "NineMLivp.scm")
48
49
50(define init-scope      (make-parameter st-empty))
51(define init-type-env   (make-parameter env-empty))
52(define init-eval-env   (make-parameter env-empty))
53
54
55(define (enter-typedecl id decl)
56  (init-scope (st-enter-type id (init-scope)))
57  (init-type-env   (env-add-type id decl (init-type-env))))
58
59(define (enter-valtype name ty)
60  (let ((id (ident-create name)))
61    (init-scope (st-enter-value id (init-scope)))
62    (init-type-env   (env-add-value id ty (init-type-env)))))
63
64(define (enter-val name val)
65  (let ((id (or (and (ident? name) name) (ident-create name))))
66    (init-eval-env (ident-add id val (init-eval-env)))))
67
68(core-initialize enter-typedecl enter-valtype)
69(eval-cbv-initialize enter-val)
70
71
72(define (enter-module id mty)
73  (init-scope (st-enter-module id (init-scope)))
74  (init-type-env (env-add-module id mty (init-type-env))))
75
76
77(define lookup-def 
78  (lambda (k lst . rest)
79    (let-optionals rest ((default #f))
80      (alist-ref k lst eq? default))))
81
82
83(define opt-defaults
84  `(
85    (platform . chicken)
86    ))
87
88(define (defopt x)
89  (lookup-def x opt-defaults))
90
91                 
92(define opt-grammar
93  `(
94
95    (print-type-env  "prints the type environment of each operand"
96                     (single-char #\t)
97                     (value (optional COMPONENT-LIST)
98                            (default all)
99                            (transformer 
100                             ,(lambda (x) 
101                                (if (string=? x "all") x
102                                    (list (string-split x ",")))))))
103
104    (print-eval-env  "prints the evaluation environment of each operand"
105                     (single-char #\e)
106                     (value (optional COMPONENT-LIST)
107                            (default all)
108                            (transformer 
109                             ,(lambda (x) 
110                                (if (string=? x "all") x
111                                    (list (string-split x ",")))))))
112
113    (print-source-defs  "prints the source definitions of each operand"
114                        (single-char #\s))
115
116    (html-report        "prints out an HTML report of the unified environments of each operand")
117
118    (output-sxml        "sets output format to SXML")
119
120    (output-xml         "sets output format to XML")
121
122    (data            "save data from simulations in files ${OPERAND}_NAME.log"
123                     (single-char #\d))
124
125    (plot            "make plots of simulation data in files ${OPERAND}_NAME.png"
126                     (single-char #\p))
127
128    (platform        "simulation platform (one of chicken, mlton, octave, octave/mlton)"
129                     (value (required PLATFORM)
130                            (predicate 
131                             ,(lambda (x) 
132                                (let ((s (string->symbol (string-downcase x))))
133                                  (case s
134                                    ((chicken mlton octave octave/ml) s)
135                                    (else (error 'ivp "unrecognized platform" x))))))
136                            (transformer ,string->symbol)
137                             ))
138
139
140
141    (help         (single-char #\h))           
142
143    ))
144
145
146;; Process arguments and collate options and arguments into OPTIONS
147;; alist, and operands (filenames) into OPERANDS.  You can handle
148;; options as they are processed, or afterwards.
149
150(define opts    (getopt-long (command-line-arguments) opt-grammar))
151(define opt     (make-option-dispatch opts opt-grammar))
152
153
154(define (run:execute explist)
155  (define (smooth lst)
156    (let ((slst (map ->string lst)))
157      (string-intersperse (cons (car slst) (cdr slst)) " ")))
158  (for-each (lambda (cmd) (system (->string cmd)))
159            (map smooth explist)))
160
161(define (run:execute* explist)
162  (define (smooth lst)
163    (let ((slst (map ->string lst)))
164      (string-intersperse (cons (car slst) (cdr slst)) " ")))
165  (for-each (lambda (cmd) (system* "~a" cmd))
166            (map smooth explist)))
167
168
169(define-syntax run
170  (syntax-rules ()
171    ((_ exp ...)
172     (run:execute* (list `exp ...)))))
173
174(define-syntax run-
175  (syntax-rules ()
176    ((_ exp ...)
177     (run:execute (list `exp ...)))))
178
179
180;; Use args:usage to generate a formatted list of options (from OPTS),
181;; suitable for embedding into help text.
182(define (ivp:usage)
183  (print "Usage: " (car (argv)) " [options...] file1... ")
184  (newline)
185  (print "The following options are recognized: ")
186  (newline)
187  (print (parameterize ((indent 5)) (usage opt-grammar)))
188  (exit 1))
189
190
191(define nl "\n")
192
193(define (generate-ivp-table prefix ivp-id sxml-tuple #!key (platform 'chicken))
194
195  (define chicken-run
196#<<EOF
197
198(define-syntax run
199  (syntax-rules ()
200    ((_ f indep dep end input parameters)
201     (let ((nstate input))
202       (printf "# ~A " indep)
203       (for-each (lambda (x) (printf "~A " x)) dep)
204       (printf "~%")
205       (let recur ((nstate nstate))
206         (let ((ival (alist-ref indep nstate)))
207           (printf "~A " ival)
208           (for-each (lambda (x)
209                       (let ((v (alist-ref x nstate)))
210                         (printf "~A " (if (boolean? v) (or (and v 1) 0) v))))
211                     dep)
212           (printf "~%")
213           (if (> ival end)
214               (print "# All done!")
215               (recur (append (f nstate) parameters))))))
216     )))
217EOF
218)
219 
220  (define mlton-prelude
221#<<EOF
222
223fun putStrLn str = 
224    (TextIO.output (TextIO.stdOut, str);
225     TextIO.output (TextIO.stdOut, "\n"))
226   
227fun putStr str = 
228    (TextIO.output (TextIO.stdOut, str))
229   
230fun showBoolean b = (if b then "1" else "0")
231
232fun showReal n = 
233    let open StringCvt
234        open Real
235    in
236        (if n < 0.0 then "-" else "") ^ (fmt (FIX (SOME 12)) (abs n))
237    end
238
239EOF
240)
241
242  (define (mlton-printstate ivar dvars ic)
243    (string-append
244      (sprintf
245#<<EOF
246
247fun printstate (input) =
248    ( (showReal (#~A(input)))
249EOF
250      ivar)
251    (string-concatenate
252     (map (lambda (dvar)
253            (let ((v (alist-ref dvar ic)))
254              (let ((show (cond ((number? v) "showReal")
255                                ((boolean? v) "showBoolean")
256                                (else         ""))))
257                (sprintf "^ \" \" ^ (~A (#~A(input)))" show dvar)))) dvars))
258
259    ")" ))
260
261  (define (mlton-run ivar dvars ic)
262    (let* ((states (cons ivar dvars))
263           (f       (lambda (x) (let ((n (car x)))
264                                  (sprintf "~A=(#~A(~A))" n n (if (member n states) "nstate" "initial") ))))
265           (nstate1 (string-append "{" (string-concatenate (intersperse (map f ic) ",")) "}")))
266      (sprintf
267#<<EOF
268
269fun start (tmax,f,initial) =
270let
271  fun run (input) =
272    let val nstate = f input
273        val nstate1 = ~A
274    in putStrLn (printstate nstate1);
275       if (#~A nstate)  > tmax
276       then (putStrLn "# All done!"; nstate)
277       else (run nstate1)
278    end
279in
280  run (initial)
281end
282 
283EOF
284   nstate1 ivar)))
285
286
287    (define (mlton-initial ic)
288      (let ((mlvalue (lambda (v) 
289                       (cond ((and (number? v) (negative? v)) (string-append "~" (sprintf "~A" (abs v))))
290                             ((boolean? v)  (if v "true" "false"))
291                             (else (sprintf "~A" v))))))
292        (let ((ic (map (lambda (x) (let ((v (cdr x))) (cons (car x) (mlvalue v)))) ic)))
293          (string-append "val initial = {" (string-concatenate (intersperse (map (lambda (x) (sprintf "~A=(~A)" (car x) (cdr x))) ic) ",")) "}"))))
294
295  (let ((sexpr 
296         (let ((sexpr (sxml-value->sexpr sxml-tuple)))
297           (case (car sexpr)
298             ((ivp)
299              (and (pair? (cdr sexpr))
300                   (case (cadr sexpr)
301                     ((construct)  (cddr sexpr))
302                     (else #f))))
303             (else #f)))))
304      (and sexpr
305           (let* ((ivar    (cadr sexpr))
306                  (hvar    (caddr sexpr))
307                  (start   (cadddr sexpr))
308                  (end     (cadddr (cdr sexpr)))
309                  (diagram+initial (sexpr->diagram+initial hvar (car sexpr))))
310             (pp (car sexpr))
311             (let ((sd       (construct (car diagram+initial)))
312                   (ic       (cadr diagram+initial)))
313               (if (not (alist-ref ivar ic))
314                   (error 'generate-ivp-table "IVP independent variable is not present in given system" ivar))
315               (if (not (alist-ref hvar ic))
316                   (error 'generate-ivp-table "IVP step variable is not present in given system" hvar))
317               (let* ((dfe (dataflow sd '()))
318                      (dvars (lset-difference eq?
319                                              (lset-intersection eq? (alist-ref 'in dfe) (alist-ref 'out dfe))
320                                              (list ivar)))
321                      (pvars (lset-difference eq? (alist-ref 'in dfe) dvars)))
322
323
324                 (case platform
325
326                   ((chicken)
327                    (with-output-to-file (make-pathname (pathname-directory prefix) (conc ivp-id "_solver.scm"))
328                      (lambda () (codegen/scheme ivp-id sd solver: 'rk3)))
329                    (with-output-to-file (make-pathname (pathname-directory prefix) (conc ivp-id "_run.scm"))
330                      (lambda () 
331                        (print-fragments
332                         (list
333                          (sprintf "(include \"~A_solver.scm\")~%~%" ivp-id)
334                          chicken-run nl
335                          (sprintf "(define initial (quote ~A))~%~%" (cons (cons ivar start) ic))
336                          (sprintf "(define parameters (quote ~A))~%~%" (map (lambda (x) (assoc x ic)) pvars))
337                          (sprintf "(run ~A (quote ~A) (quote ~A) ~A initial parameters)~%~%" ivp-id ivar dvars end)
338                          ))))
339
340                    (let* ((dir (pathname-directory prefix))
341                           (src-path  (make-pathname dir (sprintf "~A_run.scm" ivp-id)))
342                           (exec-path (make-pathname dir (sprintf "~A_run" ivp-id)))
343                           (log-path  (make-pathname dir (sprintf "~A_~A.log" (pathname-file prefix) ivp-id)))
344                           (csc-path  (make-pathname (program-path) "csc")))
345                      (run (,csc-path -I ,dir -b -S -O3 -d0 -heap-initial-size 4096k ,src-path))
346                      (run (,exec-path > ,log-path))
347                      (list ivp-id ivar dvars)
348                      ))
349                   
350                   ((mlton)
351                    (with-output-to-file (make-pathname (pathname-directory prefix) (conc ivp-id "_solver.sml"))
352                      (lambda () (codegen/ML ivp-id sd solver: 'rk3)))
353
354                    (with-output-to-file (make-pathname (pathname-directory prefix) (conc ivp-id "_run.sml"))
355                      (lambda () 
356                        (print-fragments
357                         `(
358                           (,mlton-prelude)
359                           (,(mlton-printstate ivar dvars ic) ,nl)
360                           (,(mlton-run ivar dvars ic) ,nl)
361                           (,(mlton-initial ic) ,nl)
362                           ,(sprintf "val _ = (printstate initial; start (~A, Model.~A, initial))~%~%" end ivp-id)
363                          ))))
364
365                    (with-output-to-file (make-pathname (pathname-directory prefix) (conc ivp-id "_run.mlb"))
366                      (lambda () 
367                        (print-fragments
368                         `(("$(SML_LIB)/basis/basis.mlb" ,nl )
369                           ("$(RK_LIB)/rk.mlb" ,nl )
370                           ("local " ,nl)
371                           (,(sprintf "    ~A_solver.sml" ivp-id) ,nl)
372                           ("in" ,nl)
373                           ("    structure Model" ,nl)
374                           ("end" ,nl)
375                           ,(sprintf "~A_run.sml" ivp-id) ,nl))
376                        ))
377
378                    (let* ((dir (pathname-directory prefix))
379                           (shared-dir (chicken-home))
380                           (flsim-dir (make-pathname shared-dir "flsim"))
381                           (mlb-path  (make-pathname dir (sprintf "~A_run.mlb" ivp-id)))
382                           (exec-path (make-pathname dir (sprintf "~A_run" ivp-id)))
383                           (log-path  (make-pathname dir (sprintf "~A_~A.log" (pathname-file prefix) ivp-id)))
384                           (mlton-path  "mlton"))
385
386                      (run (,mlton-path -link-opt -s -mlb-path-var ,(string-append "'RK_LIB " flsim-dir "/sml-lib/rk'") ,mlb-path))
387                      (run (,exec-path > ,log-path))
388                      (list ivp-id ivar dvars)
389                      ))
390                   
391                   ))
392               ))
393)))
394
395
396(define (generate-ivp-plot prefix  ivp-info)
397  (let ((ivp-id (car ivp-info))
398        (dvars (caddr ivp-info)))
399    (let* ((n (+ 1 (length dvars)))
400           (linewidth 3)
401           (dir (pathname-directory prefix))
402           (log-path (make-pathname dir (sprintf "~A_~A.log" (pathname-file prefix) ivp-id)))
403           (png-path (make-pathname dir (sprintf "~A_~A.png" (pathname-file prefix) ivp-id)))
404           )
405      (run (octave --eval #\'log = load (,(sprintf "\"~A\"" log-path)) #\;
406                   h = plot ("log(:,1)" #\, ,(sprintf "log(:,2:~A)" n)) #\;
407                   ,@(concatenate (list-tabulate (- n 1) (lambda (i) `(set (h(,(+ 1 i)) #\, "\"linewidth\"" #\, ,linewidth) #\;))))
408                   print (,(sprintf "\"~A\"" png-path) #\, "\"-dpng\"") #\;
409                   #\'))
410      )))
411
412
413
414(define (make-ivp-hook #!key (ivp #f) (diagram #f) (ivp-plot #f))
415  (lambda (prefix name label value)
416    (cond
417     ((and diagram
418           (or (and (string? label) (string=? label "diagram")) 
419               (and (pair? label) (string=? (car label) "diagram")))) ;; value is a diagram
420      (let* ((diagram-id (gensym 'diagram))
421             (diagram-link `(img (@ (src ,(sprintf "~A.png" diagram-id))) (alt "NineML diagram"))))
422        (generate-diagram prefix diagram-id value)
423        diagram-link
424        ))
425     
426     ((and ivp (or (and (string? label) (string=? label "ivp"))
427                   (and (pair? label) (string=? (car label) "ivp")))) ;; value is an IVP
428      (let* ((ivp-id (gensym 'ivp))
429             (ivp-plot-link `(img (@ (src ,(sprintf "~A_~A.png" (pathname-file prefix) ivp-id)) (alt "NineML IVP plot"))))
430             (ivp-info (generate-ivp-table prefix ivp-id value platform: (or (opt 'platform) (defopt 'platform) ))))
431        (if ivp-plot (generate-ivp-plot prefix ivp-info))
432        (and ivp-plot ivp-plot-link)
433        ))
434     
435     (else #f))))
436           
437
438
439
440(define (interpreter operand)
441  (let ((defs (parse 'NineML (open-input-file operand))))
442    (let* ((scoped-defs      (scope-moddef (init-scope) defs))
443           (mty              (type-moddef (init-type-env) '() scoped-defs))
444           (type-env         (map (lambda (x) (cases modspec x
445                                                     (Value_sig (id vty) (cons id x))
446                                                     (Type_sig (id decl) (cons id x))
447                                                     (Module_sig (id mty) (cons id x))
448                                                     )) mty))
449           (eval-env         (mod-eval-cbv (init-eval-env) scoped-defs))
450           (unified-env      (list scoped-defs 
451                                   (filter (lambda (x) (not (assoc (car x) (init-type-env)))) type-env) 
452                                   (filter (lambda (x) (not (assoc (car x) (init-eval-env)))) eval-env) ))
453
454           )
455      unified-env
456      )))
457
458
459(define (main options operands)
460
461  (if (options 'help) (ivp:usage))
462
463
464  (let ((find-module (lambda (x) (env-find-module x (init-type-env)))))
465    (for-each (lambda (init name) (init name enter-module find-module init-eval-env))
466              (list Signal:module-initialize   
467                    Diagram:module-initialize 
468                    Interval:module-initialize 
469                    Graph:module-initialize
470                    IVP:module-initialize )
471              (list "Signal" "Diagram" "Interval" "Graph" "IVP" )) )
472
473  (if (null? operands)
474      (ivp:usage)
475      (let ((output-type (cond ((options 'output-xml)  'xml)
476                               ((options 'output-sxml) 'sxml)
477                               (else #f)))
478            (unified-envs (map interpreter operands)))
479        (for-each
480         (lambda (operand uenv)
481           (let ((source-defs (car uenv))
482                 (mty         (cadr uenv))
483                 (eval-env    (caddr uenv)))
484             
485             (let ((type-env-opt (options 'print-type-env)))
486               (if type-env-opt
487                   (if (and (string? type-env-opt) (string=?  type-env-opt "all"))
488                     (print-type-env mty output-type)
489                     (let ((fc (lambda (x) (and (member (ident-name (car x)) type-env-opt) x))))
490                       (print-type-env mty output-type fc)))
491                   ))
492
493             (let ((eval-env-opt (options 'print-eval-env)))
494               (if eval-env-opt
495                   (if (and (string? eval-env-opt) (string=? eval-env-opt "all"))
496                     (print-eval-env eval-env output-eval)
497                     (let ((fc (lambda (x) (and (member (ident-name (car x)) eval-env-opt) x))))
498                       (print-eval-env eval-env output-type fc)))
499                   ))
500
501             (if (options 'print-source-defs)
502                 (print-source-defs source-defs output-type))
503
504             (cond ((options 'html-report)
505                    (html-report operand uenv value-hook: (make-ivp-hook diagram: #t ivp: #t ivp-plot: #t)))
506
507                   ((options 'data)
508                    (traverse-definitions operand uenv value-hook: (make-ivp-hook ivp: #t)))
509
510                   ((options 'plot)
511                    (traverse-definitions operand uenv value-hook: (make-ivp-hook ivp: #t ivp-plot: #t)))
512
513                   )
514             ))
515         operands unified-envs))))
516
517(main opt (opt '@))
Note: See TracBrowser for help on using the repository browser.