Changeset 20762 in project


Ignore:
Timestamp:
10/10/10 15:41:13 (11 years ago)
Author:
Ivan Raikov
Message:

signal-diagram: Scheme implementation of the Runge-Kutta methods and corresponding M-L testcase

Location:
release/4/signal-diagram/trunk
Files:
3 added
8 edited

Legend:

Unmodified
Added
Removed
  • release/4/signal-diagram/trunk/examples/morris-lecar.mlb

    r18280 r20762  
    55
    66local
    7         morris-lecar.sml
     7        morris-lecar_engine.sml
    88in
    99        structure Model
  • release/4/signal-diagram/trunk/examples/morris-lecar.scm

    r19067 r20762  
    8585    ))
    8686
    87 (define (M-L-graph)
     87(define (M-L-codegen #!key (language 'scheme))
    8888  (let* ((f      (alist-ref 'f morris-lecar))
    8989         (f1     (PURE dv))
     
    9494         (init   (alist-ref 'init morris-lecar))
    9595         (input  (map car init)))
    96     (print-graph (graph (construct f3) input))
     96    (let ((codegen (case language
     97                     ((scheme) codegen/scheme)
     98                     ((ML) codegen/ML))))
     99      (codegen 'morris_lecar (construct f) input
     100               `(minf ,minf)
     101               `(winf ,winf)
     102               `(ica  ,ica)
     103               `(ik   ,ik)
     104               `(lamw ,lamw)
     105               ))
    97106    ))
    98107
    99 (define (M-L-codegen)
    100   (let* ((f      (alist-ref 'f morris-lecar))
    101          (f1     (PURE dv))
    102          (f2     (SENSE '(v w Istim gl vl v1 v2 gca vca gk vk c) f1))
    103          (f3     (ACTUATE '(nt vt) (Dh 't 'v 'tstep f2)))
    104          (f4     (ACTUATE '(nt wt) (Dh 't 'w 'tstep (SENSE '(w v phi v3 v4) (PURE dw)))))
    105          (f5     (UNION f3 f4))
    106          (init   (alist-ref 'init morris-lecar))
    107          (input  (map car init)))
    108     (codegen/ML 'morris_lecar (construct f) input
    109                 `(minf ,minf)
    110                 `(winf ,winf)
    111                 `(ica  ,ica)
    112                 `(ik   ,ik)
    113                 `(lamw ,lamw)
    114                 )
    115     ))
     108(with-output-to-file "morris-lecar_engine.scm"
     109  (lambda () (M-L-codegen language: 'scheme)))
    116110
    117 ;;(M-L-codegen)
    118 (M-L-graph)
     111(with-output-to-file "morris-lecar_engine.sml"
     112  (lambda () (M-L-codegen language: 'ML)))
     113
  • release/4/signal-diagram/trunk/examples/sml-lib/rk/rk.sml

    r20748 r20762  
    6161
    6262exception InsufficientArguments
     63
     64fun putStr str =
     65    (TextIO.output (TextIO.stdOut, str))
     66
     67fun putStrLn str =
     68    (TextIO.output (TextIO.stdOut, str);
     69     TextIO.output (TextIO.stdOut, "\n"))
     70
    6371
    6472fun foldl1 f (a::b::lst) = List.foldl f (f(a,b)) lst
     
    183191          ((d,ns), ks) =
    184192    let fun m_scale (s,v) =
    185             (if Real.compare(s,0.0) = EQUAL then NONE
    186              else (if Real.compare(s,1.0) = EQUAL then SOME v
    187                    else SOME (sc_fn (s,v))))
     193             (if Real.compare(s,0.0) = EQUAL then NONE
     194              else (if Real.compare(s,1.0) = EQUAL then SOME v
     195                    else SOME (sc_fn (s,v))))
    188196        val ns_ks = ListPair.zip (ns,ks)
    189197    in
     
    239247                     (real * 'a -> 'a)) ->
    240248                    (real -> (real * 'a) -> (real * 'a))
    241                                  
     249
    242250fun core1
    243251        (cl: real list, al: RCL list, bl: RCL)
     
    254262     end)
    255263
     264
    256265(*
    257266   This is the second core routine, analogous to the previous one.
     
    401410val r2_rkf = [16//135, RAT 0, 6656//12825, 28561//56430, ~9//50, 2//55]
    402411val bs_rkf = ratToRCL r1_rkf
     412val _ = (putStrLn "rkf45: diffs r1 r2 = ";
     413         List.app (fn (r) => putStr ((Real.toString r) ^ " ")) (ratToReals (diffs (r1_rkf, r2_rkf)));
     414         putStrLn ""
     415         )
    403416val ds_rkf = ratToRCL (diffs (r1_rkf, r2_rkf))
    404417fun make_rkf45 (): 'a stepper2  = core2 (cs_rkf, as_rkf, bs_rkf, ds_rkf)
  • release/4/signal-diagram/trunk/examples/sml-lib/rk/rktest.sml

    r18280 r20762  
    88open RungeKutta
    99
     10val summer = Real.+
    1011val scaler = Real.*
    11 val summer = Real.+
     12
     13infix 7 */
     14infix 6 +/
     15infix //
    1216
    1317
     
    2529fun exact t = y0*Real.Math.exp(con*(t - t0))
    2630
     31fun putStr str =
     32    (TextIO.output (TextIO.stdOut, str))
    2733
    2834fun putStrLn str =
    2935    (TextIO.output (TextIO.stdOut, str);
    3036     TextIO.output (TextIO.stdOut, "\n"))
    31 
    32 fun putStr str =
    33     (TextIO.output (TextIO.stdOut, str))
    3437
    3538fun showReal n = Real.toString n
     
    133136  )
    134137
    135 
     138val _ = run()
    136139end
  • release/4/signal-diagram/trunk/runge-kutta.scm

    r20748 r20762  
    4646(module runge-kutta
    4747
    48         *
     48        (
     49         (core1 k-sum gen-ks )
     50         (core2 k-sum gen-ks )
     51         make-rkfe make-rk3 make-rk4a make-rk4b
     52         make-he make-he-aux
     53         make-bs make-bs-aux
     54         make-rkf45 make-rkf45-aux
     55         diffs ratlist->reals ratlist->RCL ratlists->RCLs R //
     56         )
    4957
    5058        (import scheme chicken)
    51         (require-library data-structures srfi-1)
     59        (require-library data-structures srfi-1 numbers)
    5260        (import (only srfi-1 fold filter-map)
    53                 (only data-structures compose))
     61                (only data-structures compose)
     62                (only numbers inexact->exact exact->inexact denominator numerator gcd + - * /))
     63
    5464
    5565(define (foldl1 f lst)
    56   (cond ((and (pair? lst) (pair? (cdr lst)))
    57          (fold f (f (car lst) (cadr lst)) lst))
    58         ((pair? lst) (car lst))
     66  (cond ((pair? lst)
     67         (if (pair? (cdr lst))
     68             (fold f (f (car lst) (cadr lst)) (cddr lst))
     69             (car lst)))
    5970        (else (error 'foldl1  "insufficient arguments"))))
    60 
    61 
    62 ;; Variant types
    63 
    64 (define-syntax define-datatype
    65   (syntax-rules ()
    66     [(_ type (name field ...) ...)
    67      (begin
    68        (define-constructors type ((name field ...) ...)))]))
    69 
    70 
    71 (define-syntax define-constructors
    72   (syntax-rules ()
    73     [(define-constructors type ((name field ...) ...))
    74      (define-constructors type ((name field ...) ...) (name ...))]
    75     [(define-constructors type ((name field ...) ...) names)
    76      (begin
    77        (define-constructor type (name field ...) names)
    78        ...)]))
    79 
    80 
    81 (define-syntax define-constructor
    82   (syntax-rules ()
    83     [(_ type (name field ...) names)
    84      (define (name field ...)
    85        (cons 'type
    86              (lambda names
    87                (name field ...))))]))
    88 
    89 
    90 (define-syntax cases
    91   (syntax-rules ()
    92     [(_ type x [(name field ...) exp]
    93           ...)
    94      ((cdr x) (lambda (field ...) exp)
    95               ...)]))
    96 
    97 
    98 ;; Rational number implementation.
    99 ;; Based on code by Vesa Karvonen.
    100 
    101 (define-datatype rational
    102   (RAT i)
    103   (// n d))
    104 
    105 (define (rational->fp r)
    106   (cases rational r
    107          ((RAT n)  (exact->inexact n))
    108          ((// n d) (fp/ (exact->inexact n) (exact->inexact d)))))
    109 
    110 (define (numerator r)
    111   (cases rational r
    112          ((RAT n)  n)
    113          ((// n d) n)))
    114 
    115 (define (denominator r)
    116   (cases rational r
    117          ((RAT n)  1)
    118          ((// n d) d)))
    119 
    120 (define (gcd* a b)  (if (zero? b) a (gcd* b (fxmod a b))))
    121 
    122 (define (normalize r)
    123   (cases rational r
    124          ((RAT _)  r)
    125          ((// n d) (if (zero? n) (RAT 0)
    126                        (let ((c (gcd* n d)))
    127                          (if (fx= c d)
    128                              (RAT (fx/ n c))
    129                              (// (fx/ n c) (fx/ d c))))))
    130          ))
    131 
    132 
    133 (define (+/ a b)
    134   (define (sym i n d) (// (fx+ n (fx* i d)) d))
    135   (cases rational a
    136          ((RAT l)  (cases rational b
    137                           ((RAT r) (RAT (fx+ l r)))
    138                           ((// n d) (sym l n d))))
    139          ((// n d) (cases rational b
    140                           ((RAT r)  (sym r n d))
    141                           ((// m e) (normalize (if (fx= d e)
    142                                                    (// (fx+ n m) d)
    143                                                    (// (fx+ (fx* n e) (fx* m d)) (fx* d e)))))))
    144          ))
    145 
    146 (define (*/ a b)
    147   (define (sym i n d) (normalize (// (fx* i n) d)))
    148   (cases rational a
    149          ((RAT l)  (cases rational b
    150                           ((RAT r)  (RAT (fx* l r)))
    151                           ((// n d) (sym l n d))))
    152          ((// n d) (cases rational b
    153                           ((RAT r)  (sym r n d))
    154                           ((// m e) (normalize (// (fx* n m) (fx* d e))))))
    155          ))
    15671
    15772
     
    16883  (if (null? rs)  '(1.0 ())
    16984      (let* ((ds (map denominator rs))
    170              (dp (foldl1 fx* ds))
    171              (ns (map (compose numerator (lambda (x) (*/ (RAT dp) x))) rs))
    172              (g  (fold gcd* dp ns)))
    173         `(,(exact->inexact (fx/ dp g))
    174           ,(map (compose exact->inexact (lambda (x) (fx/ x g)) ns))))))
     85             (dp (foldl1 * ds))
     86             (ns (map (compose numerator (lambda (x) (* dp x))) rs))
     87             (g  (fold gcd dp ns)))
     88        `(,(exact->inexact (/ dp g))
     89          ,(map (compose exact->inexact (lambda (x) (/ x g))) ns)))))
    17590
    17691
     
    17994
    18095;; ratToReals :: [rational] -> [real] *)
    181 (define (ratlist->reals x) (map rational->fp x))
     96(define (ratlist->reals x) (map exact->inexact x))
    18297
    18398
     
    202117(define (gen-ks ksum-fn sum-fn der-fn h tn+yn ks cs as)
    203118  (if (and (null? cs) (null? as)) ks
    204       (let* ((tn (car tn+yn))
     119      (let* (
     120             (tn (car tn+yn))
    205121             (yn (cadr tn+yn))
    206122             (yn1 (if (null? ks) yn
     
    211127              (cr (cdr cs)))
    212128          (let ((ks1 (list (der-fn (fp+ tn (fp* c h)) yn1))))
    213             (gen-ks (ksum-fn sum-fn der-fn h tn+yn (append ks ks1) cr ar))
     129            (gen-ks ksum-fn sum-fn der-fn h tn+yn (append ks ks1) cr ar)
    214130            )))))
     131
     132
    215133         
    216134;;    This is the first core routine: it does not get used directly, only
     
    256174    [(_  cl al bl)
    257175     (lambda (sc-fn sum-fn der-fn)
    258        (lambda (h old)
    259          (let* ((ksum (k-sum sc-fn sum-fn h))
    260                 (ks   (gen-ks ksum sum-fn der-fn h old '() cl al)))
    261            (list (fp+ tn h) (sum-fn yn (ksum bl ks))))
    262            ))]
     176       (lambda (h)
     177         (let ((ksum (k-sum sc-fn sum-fn h)))
     178           (lambda (tn yn)
     179             (let ((ks (gen-ks ksum sum-fn der-fn h (list tn yn) '() cl al)))
     180               (list (fp+ tn h) (sum-fn yn (ksum bl ks))))
     181             ))))]
    263182    ))
    264183
     
    277196    [(_  cl al bl dl)
    278197     (lambda (sc-fn sum-fn der-fn)
    279          (lambda (h old)
    280            (let* ((ksum (k-sum sc-fn sum-fn h))
    281                   (ks   (gen-ks ksum sum-fn der-fn h old '() cl al)))
    282              (list (fp+ tn h) (sum-fn yn (ksum bl ks)) (ksum dl ks))
    283            )))]
     198       (lambda (h)
     199         (let ((ksum (k-sum sc-fn sum-fn h)))
     200           (lambda (tn yn)
     201             (let ((ks (gen-ks ksum sum-fn der-fn h (list tn yn) '() cl al)))
     202               (list (fp+ tn h) (sum-fn yn (ksum bl ks)) (ksum dl ks))
     203               )))))]
    284204    ))
    285205
     
    288208;;   "List of Runge-Kutta methods" at Wikipedia
    289209
     210(define R (lambda (x) x))
     211(define // /)
     212
     213
     214
    290215;; forward Euler: unconditionally unstable: don't use this!
    291216
     
    293218  (syntax-rules ()
    294219    [(_)
    295      (let ((cs_fe (ratlist->reals `(,[RAT 0])))
     220     (let ((cs_fe (ratlist->reals `(,[R 0])))
    296221           (as_fe (ratlists->RCLs `(())))
    297            (bs_fe (ratlist->RCL   `(,[RAT 1]))))
     222           (bs_fe (ratlist->RCL   `(,[R 1]))))
    298223       (core1 cs_fe as_fe bs_fe))]))
    299 
    300224
    301225;; Kutta's third-order method:
     
    303227  (syntax-rules ()
    304228    [(_)
    305      (let ((cs_rk3 (ratlist->reals `(,[RAT 0] ,[// 1 2] ,[RAT 1])))
    306            (as_rk3 (ratlists->RCLs `(() (,[// 1 2]) (,[RAT -1] ,[RAT 2]))))
     229     (let ((cs_rk3 (ratlist->reals `(,[R 0] ,[// 1 2] ,[R 1])))
     230           (as_rk3 (ratlists->RCLs `(() (,[// 1 2]) (,[R -1] ,[R 2]))))
    307231           (bs_rk3 (ratlist->RCL   `(,[// 1 6] ,[// 2 3] ,[// 1 6]))))
    308232       (core1 cs_rk3 as_rk3 bs_rk3))]))
     
    312236  (syntax-rules ()
    313237    [(_)
    314      (let ((cs_rk4a (ratlist->reals `(,[RAT 0] ,[// 1 2] ,[// 1 2] ,[RAT 1])))
    315            (as_rk4a (ratlists->RCLs `(() (,[RAT 0] ,[// 1 2]) (,[RAT 0] ,[RAT 0] ,[RAT 1]))))
     238     (let ((cs_rk4a (ratlist->reals `(,[R 0] ,[// 1 2] ,[// 1 2] ,[R 1])))
     239           (as_rk4a (ratlists->RCLs `(() (,[// 1 2]) (,[R 0] ,[// 1 2]) (,[R 0] ,[R 0] ,[R 1]))))
    316240           (bs_rk4a (ratlist->RCL   `(,[// 1 6] ,[// 1 3] ,[// 1 3] ,[// 1 6]))))
    317241       (core1 cs_rk4a as_rk4a bs_rk4a))]))
     
    322246  (syntax-rules ()
    323247    [(_)
    324      (let ((cs_rk4b (ratlist->reals `(,[RAT 0] ,[// 1 3] ,[// 2 3] ,[RAT 1])))
    325            (as_rk4b (ratlists->RCLs `(() (,[// 1 3]) (,[// -1 3] ,[RAT 1]) (,[RAT 1] ,[RAT -1] ,[RAT 1]))))
     248     (let ((cs_rk4b (ratlist->reals `(,[R 0] ,[// 1 3] ,[// 2 3] ,[R 1])))
     249           (as_rk4b (ratlists->RCLs `(() (,[// 1 3]) (,[// -1 3] ,[R 1]) (,[R 1] ,[R -1] ,[R 1]))))
    326250           (bs_rk4b (ratlist->RCL   `(,[// 1 8] ,[// 3 8] ,[// 3 8] ,[// 1 8]))))
    327251       (core1 cs_rk4b as_rk4b bs_rk4b))]))
     
    339263;;   zeros at the end, as far as is necessary.
    340264
    341 (define (negate x) (*/ (RAT -1) x))
    342 
    343265(define (diffs a b)
    344266  (cond ((and (null? a) (null? b))  '())
    345267        ((and (pair? a) (null? b))  a)
    346         ((and (null? a) (pair? b))  (map negate b))
    347         (else (cons (+/ (car a) (negate (car b))) (diffs (cdr a) (cdr b))))))
     268        ((and (null? a) (pair? b))  (map - b))
     269        (else (cons (+ (car a) (- (car b))) (diffs (cdr a) (cdr b))))))
    348270       
    349271;; Heun-Euler, order 2/1
    350272
    351 (define-syntax cs_he (syntax-rules () [(_) (ratlist->reals `(,[RAT 0] ,[RAT 1]))]))
    352 (define-syntax as_he (syntax-rules () [(_) (ratlists->RCLs `(() (,[RAT 1])))]))
     273(define-syntax cs_he (syntax-rules () [(_) (ratlist->reals `(,[R 0] ,[R 1]))]))
     274(define-syntax as_he (syntax-rules () [(_) (ratlists->RCLs `(() (,[R 1])))]))
    353275
    354276(define-syntax make-he
     
    356278    [(_)
    357279     (let ((cs (cs_he))
    358            (as (cs_he))
     280           (as (as_he))
    359281           ;; second order coefficients
    360282           (r1_he `(,[// 1 2] ,[// 1 2]))
    361283           ;; first-order coefficients
    362            (r2_he `(,[RAT 1])))
     284           (r2_he `(,[R 1])))
    363285       (let ((bs (ratlist->RCL r1_he))
    364              (ds (ratlist->RCL (diffs (r1_he r2_he)))))
     286             (ds (ratlist->RCL (diffs r1_he r2_he))))
    365287         (core2 cs as bs ds)))]
    366288    ))
     
    370292  (syntax-rules ()
    371293    [(_)
    372      (let ((r2_he `(,[RAT 1])))
     294     (let ((r2_he `(,[R 1])))
    373295       (let ((cs (cs_he))
    374296             (as (as_he))
     
    381303;; Bogacki-Shampine, order 3/2
    382304
    383 (define-syntax cs_bs (syntax-rules () [(_) (ratlist->reals  `(,[RAT 0] ,[// 1 2] ,[// 3 4] ,[RAT 1]))]))
    384 (define-syntax as_bs (syntax-rules () [(_) (ratlists->RCLs `(() (,[// 1 2])
    385                                                              (,[RAT 0]  ,[// 3 4])
     305(define-syntax cs_bs (syntax-rules () [(_) (ratlist->reals  `(,[R 0] ,[// 1 2] ,[// 3 4] ,[R 1]))]))
     306(define-syntax as_bs (syntax-rules () [(_) (ratlists->RCLs `(()
     307                                                             (,[// 1 2])
     308                                                             (,[R 0]  ,[// 3 4])
    386309                                                             (,[// 2 9] ,[// 1 3] ,[// 4 9])))]))
    387310
     
    393316           ;; third-order coefficients
    394317           (r1_bs  `(,[// 2 9] ,[// 1 3] ,[// 4 9]))
    395            ;; second-order coeffs
     318           ;; second-order coefficients
    396319           (r2_bs `(,[// 7 24] ,[// 1 4] ,[// 1 3] ,[// 1 8])))
    397320       (let ((bs (ratlist->RCL r1_bs))
     
    405328     (let ((cs (cs_bs))
    406329           (as (as_bs))
    407            ;; second-order coeffs
    408330           (r2_bs `(,[// 7 24] ,[// 1 4] ,[// 1 3] ,[// 1 8])))
    409331       (let ((bs (ratlist->RCL r2_bs)))
     
    412334
    413335;; Runge-Kutta-Fehlberg, order 4/5
    414 (define-syntax cs_rkf 
    415   (syntax-rules () [(_)  (ratlist->reals  `(,[RAT 0] ,[// 1 4] ,[// 3 8] ,[// 12 13] ,[RAT 1] ,[// 1 2]))]))
    416 (define-syntax as_rkf
     336(define-syntax cs_rkf45
     337  (syntax-rules () [(_)  (ratlist->reals  `(,[R 0] ,[// 1 4] ,[// 3 8] ,[// 12 13] ,[R 1] ,[// 1 2]))]))
     338(define-syntax as_rkf45
    417339   (syntax-rules () [(_)
    418340                     (ratlists->RCLs `(()
     
    420342                                       (,[// 3 32]      ,[// 9 32])
    421343                                       (,[// 1932 2197] ,[// -7200 2197] ,[// 7296 2197])
    422                                        (,[// 439 216]   ,[RAT -8]        ,[// 3680 513] ,[// -845 4104])
    423                                        (,[// -8 27]     ,[RAT 2]         ,[// -3544 2565] ,[// 1859 4104] ,[// -11 40])))]))
    424 
    425 (define-syntax make-rkf
    426   (syntax-rules ()
    427     [(_)
    428      (let ((cs (cs_rkf))
    429            (as (as_rkf))
     344                                       (,[// 439 216]   ,[R -8]        ,[// 3680 513]   ,[// -845 4104])
     345                                       (,[// -8 27]     ,[R 2]         ,[// -3544 2565] ,[// 1859 4104] ,[// -11 40])))]))
     346
     347
     348
     349(define-syntax make-rkf45
     350  (syntax-rules ()
     351    [(_)
     352     (let ((cs (cs_rkf45))
     353           (as (as_rkf45))
    430354           ;; fourth-order coefficients
    431            (r1_rkf  `(,[// 25 216] ,[RAT 0] ,[// 1408 2565] ,[// 2197 4104] ,[// -1 5]))
     355           (r1_rkf  `(,[// 25 216] ,[R 0] ,[// 1408 2565] ,[// 2197 4104] ,[// -1 5]))
    432356           ;; fifth-order coefficients
    433            (r2_rkf  `(,[// 16 135] ,[RAT 0] ,[// 6656 12825] ,[// 28561 56430] ,[// -9 50] ,[// 2 55])))
    434        (let ((bs_rkf (ratlist->RCL r1_rkf))
    435              (ds_rkf (ratlist->RCL (diffs r1_rkf r2_rkf))))
    436          (core2 cs_rkf as_rkf bs_rkf ds_rkf)))]
    437     ))
    438 
    439 (define-syntax make-rkf-aux
    440   (syntax-rules ()
    441     [(_)
    442      (let ((cs (cs_rkf))
    443            (as (as_rkf))
    444            ;; fifth-order coefficients
    445            (r2_rkf  `(,[// 16 135] ,[RAT 0] ,[// 6656 12825] ,[// 28561 56430] ,[// -9 50] ,[// 2 55])))
     357           (r2_rkf  `(,[// 16 135] ,[R 0] ,[// 6656 12825] ,[// 28561 56430] ,[// -9 50] ,[// 2 55])))
     358       (let ((bs (ratlist->RCL r1_rkf))
     359             (ds (ratlist->RCL (diffs r1_rkf r2_rkf))))
     360         (core2 cs as bs ds)))]
     361    ))
     362
     363(define-syntax make-rkf45-aux
     364  (syntax-rules ()
     365    [(_)
     366     (let ((cs (cs_rkf45))
     367           (as (as_rkf45))
     368           (r2_rkf  `(,[// 16 135] ,[R 0] ,[// 6656 12825] ,[// 28561 56430] ,[// -9 50] ,[// 2 55])))
    446369       (let ((bs (ratlist->RCL r2_rkf)))
    447370         (core1 cs as bs)))]
  • release/4/signal-diagram/trunk/signal-diagram.meta

    r20748 r20762  
    1818 ; A list of eggs signal-diagram depends on.
    1919
    20  (needs datatype mathh)
     20 (needs datatype numbers mathh)
    2121
    2222 (author "Ivan Raikov")
  • release/4/signal-diagram/trunk/signal-diagram.scm

    r20450 r20762  
    3838         signal? signal-name signal-value
    3939
    40          construct dataflow  codegen/ML
     40         construct dataflow  codegen/ML codegen/scheme
    4141         )
    4242        (import scheme chicken)
     
    4444        (require-extension extras data-structures srfi-1 datatype)
    4545        (require-library srfi-13 lolevel)
    46         (import (only srfi-13 string-concatenate)
     46        (import (only srfi-13 string-concatenate string<)
    4747                (only lolevel extended-procedure? procedure-data extend-procedure ))
    4848
     
    984984
    985985
     986
     987(define (name/scheme s)
     988  (let ((cs (string->list (->string s))))
     989    (let loop ((lst (list)) (cs cs))
     990      (if (null? cs) (string->symbol (list->string (reverse lst)))
     991          (let* ((c (car cs))
     992                 (c1 (cond ((or (char-alphabetic? c) (char-numeric? c)
     993                                (char=? c #\_) (char=? c #\-)) c)
     994                           (else #\-))))
     995            (loop (cons c1 lst) (cdr cs)))))))
     996
     997
     998(define (expr->scheme x)
     999    (cases expr x
     1000         (E:Val     (name v)
     1001                    (list "(" (name/scheme name) " " (value->scheme v) ")" nl))
     1002
     1003         (E:Ife     (test ift iff)
     1004                    (list "(cond " (value->scheme test) " " nl
     1005                          "(#t " (expr->scheme ift ) ")" nl
     1006                          "(else " (expr->scheme iff) "))" nl))
     1007
     1008         (E:Let     (bnds body)
     1009                    (list "(let* (" nl
     1010                          (map expr->scheme bnds) nl
     1011                          ") " nl
     1012                          (expr->scheme body) nl
     1013                          ")" nl))
     1014                         
     1015         (E:Set     (loc v)
     1016                    (list "(" (value->scheme loc) " " (value->scheme v) ")"))
     1017
     1018         (E:Ret     (v)  (value->scheme v))
     1019                   
     1020         (E:Seq     (exprs)
     1021                    (list "(begin " (intersperse (map expr->scheme exprs) " ") ")"))
     1022
     1023         (E:Noop    () (list "(void)"))
     1024         ))
     1025
     1026
     1027(define (value->scheme v)
     1028  (cases value v
     1029         (V:C       (v) v)
     1030         (V:Var     (name) (name/scheme name))
     1031         (V:Rec     (lst)
     1032                    (list "`(" (intersperse (map (lambda (nv) (list "(" (name/scheme (car nv)) " . ," 
     1033                                                                    (value->scheme (cadr nv)) ")")) lst) " ") ")"))
     1034         (V:Sel     (field v)
     1035                    (if (number? field)
     1036                        (list "(list-ref " (value->scheme v) " " (- field 1) ")")
     1037                        (list "(alist-ref '" (name/scheme field) " " (value->scheme v) ")")))
     1038         (V:Ldv     (v)
     1039                    (list "(" (value->scheme v) ")"))
     1040         (V:Stv     (v)
     1041                    (list "(make-parameter " (value->scheme v) ")" ))
     1042         (V:Fn      (args body)
     1043                    (list "(lambda (" (intersperse (map name/scheme args) " ") ") "
     1044                          (expr->scheme body) ")"))
     1045         (V:Prim    (name args)
     1046                    (let* ((fp? (case name
     1047                                     ((+ - * / >= > < <=)  #t)
     1048                                     (else #f)))
     1049                           (op (if fp? (conc "fp" name) name)))
     1050                      (cond ((null? args)
     1051                             (case name
     1052                               ((NONE)  (list "#f"))
     1053                               (else    (list "(" name ")"))))
     1054                           
     1055                            (fp?
     1056                             (fold-right (lambda (x ax) (list "(" op " " (value->scheme x) " " ax ")"))
     1057                                         (list "(" op " " (value->scheme (car args)) " " (value->scheme (cadr args)) ")")
     1058                                         (cddr args)))
     1059
     1060                            (else
     1061                             (list "(" op " " (intersperse (map value->scheme args) " ") ")")))))
     1062         (V:Ifv     (test ift iff)
     1063                    (list "(if " (value->scheme test) " "
     1064                          (value->scheme ift) " "
     1065                          (value->scheme iff) ")"))
     1066
     1067         ))
     1068
     1069(define (prelude/scheme)
     1070  (print #<<EOF
     1071(use runge-kutta mathh)
     1072
     1073;; Variant types
     1074
     1075(define-syntax define-datatype
     1076  (syntax-rules ()
     1077    [(_ type (name field ...) ...)
     1078     (begin
     1079       (define-constructors type ((name field ...) ...)))]))
     1080
     1081
     1082(define-syntax define-constructors
     1083  (syntax-rules ()
     1084    [(define-constructors type ((name field ...) ...))
     1085     (define-constructors type ((name field ...) ...) (name ...))]
     1086    [(define-constructors type ((name field ...) ...) names)
     1087     (begin
     1088       (define-constructor type (name field ...) names)
     1089       ...)]))
     1090
     1091
     1092(define-syntax define-constructor
     1093  (syntax-rules ()
     1094    [(_ type (name field ...) names)
     1095     (define (name field ...)
     1096       (cons 'type
     1097             (lambda names
     1098               (name field ...))))]))
     1099
     1100
     1101(define-syntax cases
     1102  (syntax-rules ()
     1103    [(_ type x [(name field ...) exp]
     1104          ...)
     1105     ((cdr x) (lambda (field ...) exp)
     1106              ...)]))
     1107
     1108(define-datatype trs (TRSA a) (TRSA b))
     1109(define-datatype trc (TRC x))
     1110
     1111(define (tsCase fa fb x) (cases trs x ((TRSA a) (fa a)) ((TRSB b) (fb b))))
     1112(define (trfOf x) (cases trc ((TRC f fk e) f)))
     1113(define (trfkOf x) (cases trc ((TRC f fk e) fk)))
     1114(define (treOf x) (cases trc ((TRC f fk e) e)))
     1115
     1116(define (trfSet x f1) (cases trc ((TRC f fk e) (f f1))))
     1117(define (trfkSet x fk1) (cases trc ((TRC f fk e) (fk fk1))))
     1118
     1119(define NONE #f)
     1120(define SOME identity)
     1121(define equal equal?)
     1122(define (swap x v) (or v x))
     1123(define (signalOf v) (if (not v) (error 'signalOf "empty signal" v) v))
     1124
     1125(define scaler fp*)
     1126(define summer fp+)
     1127
     1128(define rk4b (make-rk4b))
     1129
     1130(define (make_stepper deriv) (rk4b scaler summer deriv))
     1131
     1132EOF
     1133))
     1134
     1135
     1136(define (codegen/scheme name f input . fundecls)
     1137
     1138  (let ((dfe (sfarrow-dfe f)))
     1139
     1140    (let* ((fenv     (map (lambda (s) (cons s 'input)) input))
     1141           (fcodegen ((sfarrow-codegen f) input fenv dfe )))
     1142
     1143      (prelude/scheme)
     1144
     1145      (if (pair? fundecls)
     1146          (print-fragments (list (map (lambda (fundecl)
     1147                                        (let ((x (apply function->expr fundecl)))
     1148                                          (cases expr x
     1149                                                 (E:Val  (name v)
     1150                                                         (list "(define " (name/scheme name) " " (value->scheme v) ")" nl))
     1151                                                 (else (expr->scheme x)))
     1152                                          ))
     1153                                      fundecls)
     1154                                 nl)))
     1155
     1156      (print-fragments (list (map (lambda (x)
     1157                                    (cases expr x
     1158                                           (E:Val  (name v)
     1159                                                   (list "(define " (name/scheme name) " " (value->scheme v) ")" nl))
     1160                                           (else (expr->scheme x))))
     1161                                  (reverse (codegen-state))) nl))
     1162
     1163      (print-fragments
     1164       (list
     1165        "(define (" name " input)" nl
     1166        "(let (" (intersperse (map (lambda (x) (expr->scheme (E:Val x (V:Sel x (V:Var 'input))))) input) " ")  ")"  nl
     1167        "(let* (" (map expr->scheme (codegen-expr fcodegen)) nl ")" nl
     1168        (codegen-rv fcodegen) nl
     1169        "))" nl))
     1170
     1171      (print-fragments
     1172       (list ")" nl))
     1173     
     1174      )))
     1175
     1176
     1177                           
     1178
    9861179(define (name/ML s)
    9871180  (let ((cs (string->list (->string s))))
     
    11101303))
    11111304
     1305
    11121306(define (codegen/ML name f input . fundecls)
    11131307  (let ((dfe (sfarrow-dfe f)))
     1308
    11141309    (let* ((fenv     (map (lambda (s) (cons s 'input)) input))
    11151310           (fcodegen ((sfarrow-codegen f) input fenv dfe )))
     
    11371332     
    11381333      )))
    1139 
    11401334)
    11411335
     
    12101404     )))
    12111405
    1212 ;; Numerical integration
    1213 (define (midpoint x xn y yn h f c)
    1214 
    1215   (let* ((ff (sfarrow-arrow f))
    1216          (s  (container-sigenv c))
    1217          (xs (first s))
    1218          (ys (second s))
    1219          (hs (if (symbol? h) (third s) h))
    1220          (feval (lambda v
    1221                   (let ((c1 (ff (if (null? v) c
    1222                                     (copy-container c 
    1223                                                     (sigenv-add (make-signal y (first v)) s))))))
    1224                         (signal-value (first (container-sigenv c1))))))
    1225          )
    1226 
    1227     (if (not (eq? x (signal-name xs)))
    1228         (error 'midpoint "independent variable mismatch: " (signal-name xs)))
    1229     (if (not (eq? y (signal-name ys)))
    1230         (error 'midpoint "dependent variable mismatch: " (signal-name ys)))
    1231 
    1232     (let ((xv (signal-value xs))
    1233           (yv (signal-value ys))
    1234           (hv (if (signal? h) (signal-value h) h)))
    1235 
    1236       (let ((xv1 (+ xv (/ hv 2)))
    1237             (yv1 (+ yv (* hv (feval (+ yv (/ (* hv (feval)) 2)))))))
    1238        
    1239         (copy-container c 
    1240                         (sigenv-add (make-signal xn xv1)
    1241                                     (sigenv-add (make-signal yn yv1)
    1242                                                 sigenv-empty)))
    1243         ))))
    12441406
    12451407(define (sf-transition0 f fk ev . rest)
  • release/4/signal-diagram/trunk/signal-diagram.setup

    r20748 r20762  
    44  (make-pathname #f fn ##sys#load-dynamic-extension))   
    55
    6 (compile -O2 -s runge-kutta.scm -j runge-kutta)
     6(compile -O3 -d0 -S -s runge-kutta.scm -j runge-kutta)
    77(compile -O2 -s runge-kutta.import.scm)
    88
Note: See TracChangeset for help on using the changeset viewer.