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

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

9ML-toolit: commit octave/mlton platform

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