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

Last change on this file since 29952 was 29952, checked in by Ivan Raikov, 8 years ago

9ML-toolkit: bringing octave and scheme backends up to date; changed Izhikevich FS example to use heaviside function

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