source: project/release/4/9ML-toolkit/trunk/ivp-mlton.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: 8.0 KB
Line 
1;;
2;;  NineML IVP code generator for MLton.
3;;
4;;
5;; Copyright 2010-2014 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-mlton
24
25        (ivp-mlton ivp-mlton-codegen
26         mlton-initial mlton-state-update
27         mlton-value
28         )
29
30        (import scheme chicken )
31
32(import (only files make-pathname pathname-directory pathname-file)
33        (only data-structures conc alist-ref intersperse)
34        (only srfi-13 string-concatenate)
35        (only srfi-1 delete-duplicates))
36(require-extension make datatype signal-diagram 9ML-eval setup-api)
37
38
39(define nl "\n")
40
41
42(define (mlton-value v)
43  (cond
44   ((pair? v)
45    (case (car v)
46      ((real)      (mlton-value (caddr v)))
47      ((realsig)   (mlton-value (caddr v)))
48      ((realconst) (mlton-value (cadr v)))
49      ((generator) (sprintf "~A ()" (cadr v)))
50      ((random)    (sprintf "random_~A ()" (cadr v)))
51      ((neg)       (sprintf "Real.~~ (~A)" (mlton-value (cadr v))))
52      ((+ - * / >= <= > <) 
53       (sprintf "Real.~A (~A, ~A)"
54                (car v) (mlton-value (cadr v)) 
55                (mlton-value (caddr v))))
56      ((log ln sin cos cosh tanh exp)
57       (sprintf "Math.~A (~A)"
58                (car v) (mlton-value (cadr v)) ))
59      (else (error 'mlton-value "invalid value" v))))
60   ((and (number? v) (negative? v)) (string-append "~" (sprintf "~A" (abs v))))
61   ((boolean? v)  (if v "true" "false"))
62   (else (sprintf "~A" v))))
63 
64       
65(define (mlton-initial ic #!key (update '()))
66    (let ((ic (map (lambda (x) 
67                     (let ((n (car x)) (v (cdr x))) 
68                       (if (assoc n update)
69                           (cons n (mlton-value (alist-ref n update)))
70                           (cons n (mlton-value v))
71                           )
72                       ))
73                   ic)))
74      (string-append "{" (string-concatenate (intersperse (map (lambda (x) (sprintf "~A=(~A)" (car x) (cdr x))) ic) ",")) "}")
75      ))
76
77
78(define (mlton-state-update vars #!key (input "input") (field-input "fieldinput") (nstate "nstate") 
79                            (update '()) (states '()) (fields '()))
80  (let* (
81         (f (lambda (n) (if (assoc n update)
82                            (sprintf "~A=~A" n (alist-ref n update))
83                            (sprintf "~A=(#~A(~A))" n n 
84                                     (cond ((member n states) nstate)
85                                           ((member n fields) field-input)
86                                           (else input)))
87                            )))
88         (nstate1 (string-append "{" (string-concatenate (intersperse (map f vars) ",")) "}"))
89         )
90    nstate1
91    ))
92
93
94 
95(define mlton-run-prelude
96#<<EOF
97
98fun putStrLn str = 
99    (TextIO.output (TextIO.stdOut, str);
100     TextIO.output (TextIO.stdOut, "\n"))
101   
102fun putStr str = 
103    (TextIO.output (TextIO.stdOut, str))
104   
105fun showBoolean b = (if b then "1" else "0")
106
107fun showReal n = 
108    let open StringCvt
109        open Real
110    in
111        (if n < 0.0 then "-" else "") ^ (fmt (FIX (SOME 12)) (abs n))
112    end
113
114EOF
115)
116
117
118(define (mlton-printstate ivar dvars ic)
119  (string-append
120   (sprintf "fun printstate (input) = ~%")
121   "("
122   (sprintf "(showReal (#~A(input)))"  ivar)
123   (string-concatenate
124    (map (lambda (dvar)
125           (let ((v (alist-ref dvar ic)))
126             (let ((show (cond ((number? v) "showReal")
127                               ((boolean? v) "showBoolean")
128                               (else         "showReal"))))
129               (sprintf "^ \" \" ^ (~A (#~A(input)))" show dvar)))) dvars))
130   ")" ))
131
132
133
134(define (mlton-run-start ivar dvars ic)
135  (let ((states (cons ivar dvars)))
136    (sprintf
137#<<EOF
138
139fun start (tmax,f,initial) =
140let
141  fun run (input) =
142    let val nstate = f input
143        val nstate1 = ~A
144    in putStrLn (printstate nstate1);
145       if (#~A nstate)  > tmax
146       then (putStrLn "# All done!"; nstate1)
147       else (run nstate1)
148    end
149in
150  run (initial)
151end
152 
153EOF
154   (mlton-state-update (map car ic) states: states) ivar)))
155
156
157(define (ivp-mlton prefix ivp-id ivar dvars pvars start end ic sd solver)
158  (let* ((dir          (or (pathname-directory prefix) "."))
159         (shared-dir   (chicken-home))
160         (signal-diagram-dir (make-pathname shared-dir "signal-diagram"))
161         (solver-path  (make-pathname (pathname-directory prefix) (conc ivp-id "_solver.sml")))
162         (run-path     (make-pathname (pathname-directory prefix) (conc ivp-id "_run.sml")))
163         (mlb-path     (make-pathname (pathname-directory prefix) (conc ivp-id "_run.mlb")))
164         (exec-path    (make-pathname dir (sprintf "~A_run" ivp-id)))
165         (log-path     (make-pathname dir (sprintf "~A_~A.log" (pathname-file prefix) ivp-id)))
166         (mlton-path  "mlton"))
167   
168    (make (
169           (solver-path (prefix)
170                        (with-output-to-file solver-path (lambda () (codegen/ML ivp-id sd solver: solver))))
171           
172           (run-path (prefix)
173                     (with-output-to-file run-path 
174                       (lambda () 
175                         (print-fragments
176                          `(
177                            (,mlton-run-prelude)
178                            (,(mlton-printstate ivar dvars ic) ,nl)
179                            (,(mlton-run-start ivar dvars ic) ,nl)
180                            (,(sprintf "val initial = ~A~%" (mlton-initial ic)))
181                            ,(sprintf "val _ = (printstate initial; start (~A, Model.~A, initial))~%~%" end ivp-id)
182                            )))))
183           
184           (mlb-path ()
185                     (with-output-to-file mlb-path
186                       (lambda () 
187                         (print-fragments
188                          `(("$(SML_LIB)/basis/basis.mlb" ,nl )
189                            ("$(SML_LIB)/basis/unsafe.mlb" ,nl )
190                            ("$(RK_LIB)/rk.mlb" ,nl )
191                            ("$(RANDMTZIG_LIB)/randmtzig.mlb" ,nl )
192                            ("local " ,nl)
193                            (,(sprintf "    ~A_solver.sml" ivp-id) ,nl)
194                            ("in" ,nl)
195                            ("    structure Model" ,nl)
196                            ("end" ,nl)
197                            ,(sprintf "~A_run.sml" ivp-id) ,nl))
198                         )))
199           
200           (exec-path (solver-path run-path mlb-path)
201                      (run (,mlton-path -link-opt -s 
202                                        -mlb-path-var ,(string-append "'RK_LIB " signal-diagram-dir "/sml-lib/rk'") 
203                                        -mlb-path-var ,(string-append "'RANDMTZIG_LIB " signal-diagram-dir "/sml-lib/randmtzig'") 
204                                        ,mlb-path
205                                        ,(string-append signal-diagram-dir "/sml-lib/randmtzig/randmtziglib.c")
206                                        )))
207           
208           (log-path (exec-path)
209                     (run (,exec-path > ,log-path)))
210           )
211      (list log-path) )
212    ))
213
214
215(define (ivp-mlton-codegen prefix ivp-id ivar dvars pvars ic sd solver)
216  (let* ((dir          (or (pathname-directory prefix) "."))
217         (shared-dir   (chicken-home))
218         (solver-path  (make-pathname (pathname-directory prefix) (conc ivp-id "_solver.sml")))
219         (run-path     (make-pathname (pathname-directory prefix) (conc ivp-id "_run.sml")))
220         (mlb-path     (make-pathname (pathname-directory prefix) (conc ivp-id "_run.mlb")))
221         (mlton-path  "mlton")
222         )
223   
224    (make (
225           (solver-path (prefix)
226                        (with-output-to-file solver-path (lambda () (codegen/ML ivp-id sd solver: solver))))
227           
228           (run-path (prefix)
229                     (with-output-to-file run-path 
230                       (lambda () 
231                         (print-fragments
232                          `(
233                            (,mlton-run-prelude)
234                            (,(mlton-printstate ivar dvars ic) ,nl)
235                            (,(mlton-run-start ivar dvars ic) ,nl)
236                            (,(sprintf "val initial = ~A~%" (mlton-initial ic)))
237                            )))))
238           
239           (mlb-path ()
240                     (with-output-to-file mlb-path
241                       (lambda () 
242                         (print-fragments
243                          `(("$(SML_LIB)/basis/basis.mlb" ,nl )
244                            ("$(RK_LIB)/rk.mlb" ,nl )
245                            ("$(RANDMTZIG_LIB)/randmtzig.mlb" ,nl )
246                            ("local " ,nl)
247                            (,(sprintf "    ~A_solver.sml" ivp-id) ,nl)
248                            ("in" ,nl)
249                            ("    structure Model" ,nl)
250                            ("end" ,nl)
251                            ,(sprintf "~A_run.sml" ivp-id) ,nl))
252                         )))
253           
254           )
255      (list solver-path run-path mlb-path) )
256    ))
257
258)
Note: See TracBrowser for help on using the repository browser.