Changeset 30964 in project


Ignore:
Timestamp:
06/05/14 14:42:35 (6 years ago)
Author:
Ivan Raikov
Message:

signal-diagram/flsim: adaptive integration refactoring of transients; moving supporting numerical libraries to signal-diagram

Location:
release/4
Files:
5 edited
3 moved

Legend:

Unmodified
Added
Removed
  • release/4/flsim/trunk/flsim.scm

    r30959 r30964  
    634634
    635635
    636 fun esolver (stepper,evtest) (t,st,tstep) =
     636fun esolver (stepper,evtest) (x,ys,h) =
    637637    let open Real
    638         val (st',e,finterp) = stepper tstep (t,st)
     638        val (ys',e,finterp) = stepper h (x,ys)
    639639    in
    640         case predictor tol (tstep,e) of
    641             Right tstep' =>
    642             if (evtest (st') >= 0.0)
     640        case predictor tol (h,e) of
     641            Right h' =>
     642            if (evtest (ys') >= 0.0)
    643643            then (let
    644                      val theta   = secant tol (evtest o finterp) (evtest st) 1.0 0.0
    645                      val st''    = finterp (theta+tol)
     644                     val theta   = secant tol (evtest o finterp) (evtest ys) 1.0 0.0
     645                     val ys''    = finterp (theta+tol)
    646646                 in
    647                      Root (t+(theta+tol)*tstep,st'',tstep')
     647                     Root (x+(theta+tol)*h,ys'',h')
    648648                 end)
    649             else Next (t+tstep,st',tstep')
    650           | Left tstep'  =>
    651             esolver (stepper,evtest) (t,st,tstep')
     649            else Next (x+h,ys',h')
     650          | Left h'  =>
     651            esolver (stepper,evtest) (x,ys,h')
    652652    end
    653653
    654654
    655655fun eintegral (f,x,ys,evtest,h,i) =
    656     case esolver (stepper,evtest) (t,st,tstep) of
    657         Next (tn,stn,tstep') =>
    658         ({tn=tn,tstep=tstep',stn=stn})
    659       | Root (tn,stn,tstep') =>
    660         ({tn=tn,stn=stn,tstep=tstep'))
    661 
    662 fun solver stepper (t,st,tstep) =
     656    case esolver (make_stepper f,evtest) (x,ys,h) of
     657        Next (xn,ysn,h') =>
     658        ({xn=xn,h=h',ysn=ysn})
     659      | Root (xn,ysn,h') =>
     660        ({xn=xn,ysn=ysn,h=h'})
     661
     662fun solver stepper (x,ys,h) =
    663663    let open Real
    664         val (st',e,finterp) = stepper tstep (t,st)
     664        val (ys',e,finterp) = stepper h (x,ys)
    665665    in
    666         case predictor tol (tstep,e) of
    667             Right tstep' =>
    668             (t+tstep,st',tstep')
    669           | Left tstep'  =>
    670             solver (stepper) (t,st,tstep')
     666        case predictor tol (h,e) of
     667            Right h' =>
     668            (x+h,ys',h')
     669          | Left h'  =>
     670            solver (stepper) (x,ys,h')
    671671    end
    672672
    673673fun integral (f,x,ys,evtest,h,i) =
    674674    let
    675         val (tn,stn,tstep') = solver stepper (t,st,tstep)
     675        val (xn,ysn,h') = solver (make_stepper f) (x,ys,h)
    676676    in
    677         {tn=tn,tstep=tstep',stn=stn}
     677        {xn=xn,ysn=ysn,h=h'}
    678678    end
    679679
  • release/4/signal-diagram/trunk/examples/Izhikevich03.scm

    r30959 r30964  
    88(use signal-diagram signal-diagram-dynamics mathh srfi-1 )
    99
    10 (define (Izhikevich03:construct t V U k1 k2 k3 theta a b c d spike tspike Isyn )
     10(define (Izhikevich03:construct t V U k1 k2 k3 theta a b c d Isyn )
    1111
    1212  `((f . ,(let* ((subthreshold-eq         (ODE (variable h) t
     
    1414                                               (U  (* a (- (* b V) U)))))
    1515
    16                  (threshold-detect        (ASSIGN (spike (> V theta))))
     16                 (threshold-detect        (ASSIGN (spike (- V theta))))
    1717
    1818                 (refractory-eq           (ASSIGN (t (+ t h) )
    19                                                   (tspike (if spike t tspike))
    20                                                   (spike false)
    21                                                   (tspike tspike)
     19                                                  (h h)
    2220                                                  (V c)
    2321                                                  (U (+ U d))))
     
    4139             (c               ,c)
    4240             (d               ,d)
    43              (spike           ,spike)
    44              (tspike          ,tspike)
    4541             (Isyn            ,Isyn)
    4642             ))
     
    8682        (d 8.0))
    8783    (Izhikevich03:construct
    88      ;; t V U k1 k2 k3 theta a b c d spike tspike Isyn
    89      t V (* b V) k1 k2 k3 theta a b c d #f t Isyn)))
    90 
     84     ;; t V U k1 k2 k3 theta a b c d Isyn
     85     t V (* b V) k1 k2 k3 theta a b c d Isyn)))
    9186
    9287;; Intrinsically bursting (IB) parameters
     
    9792        (d 4.0))
    9893    (Izhikevich03:construct
    99      ;; t V U k1 k2 k3 theta a b c d spike tspike Isyn
    100      t V (* b V) k1 k2 k3 theta a b c d #f t Isyn)))
     94     ;; t V U k1 k2 k3 theta a b c d Isyn
     95     t V (* b V) k1 k2 k3 theta a b c d Isyn)))
    10196
    10297
     
    108103        (d 2.0))
    109104    (Izhikevich03:construct
    110      ;; t V U k1 k2 k3 theta a b c d spike tspike Isyn
    111      t V (* b V) k1 k2 k3 theta a b c d #f t Isyn)))
     105     ;; t V U k1 k2 k3 theta a b c d Isyn
     106     t V (* b V) k1 k2 k3 theta a b c d Isyn)))
    112107
    113108
     
    119114        (d 2.0))
    120115    (Izhikevich03:construct
    121      ;; t V U k1 k2 k3 theta a b c d spike tspike Isyn
    122      t V (* b V) k1 k2 k3 theta a b c d #f t Isyn)))
     116     ;; t V U k1 k2 k3 theta a b c d Isyn
     117     t V (* b V) k1 k2 k3 theta a b c d Isyn)))
    123118
    124119
     
    131126        (d 0.05))
    132127    (Izhikevich03:construct
    133      ;; t V U k1 k2 k3 theta a b c d spike tspike Isyn
    134      t V (* b V) k1 k2 k3 theta a b c d #f t Isyn)))
     128     ;; t V U k1 k2 k3 theta a b c d Isyn
     129     t V (* b V) k1 k2 k3 theta a b c d Isyn)))
    135130
    136131
     
    142137        (d 2.0))
    143138    (Izhikevich03:construct
    144      ;; t V U k1 k2 k3 theta a b c d spike tspike Isyn
    145      t V (* b V) k1 k2 k3 theta a b c d #f t Isyn)))
     139     ;; t V U k1 k2 k3 theta a b c d Isyn
     140     t V (* b V) k1 k2 k3 theta a b c d Isyn)))
    146141
    147142
     
    154149        (d 2.0))
    155150    (Izhikevich03:construct
    156      ;; t V U k1 k2 k3 theta a b c d spike tspike Isyn
    157      t V (* b V) k1 k2 k3 theta a b c d #f t Isyn)))
     151     ;; t V U k1 k2 k3 theta a b c d Isyn
     152     t V (* b V) k1 k2 k3 theta a b c d Isyn)))
    158153
    159154
    160 (define models `((RS  . ,RS) (IB . ,IB) (CH . ,CH) (FS . ,FS)  (RZ . ,RZ) (LTS . ,LTS) ))
     155(define models `((RS  . ,RS))) ; (IB . ,IB) (CH . ,CH) (FS . ,FS)  (RZ . ,RZ) (LTS . ,LTS) ))
    161156
    162157 
  • release/4/signal-diagram/trunk/examples/Izhikevich03_run.sml

    r30942 r30964  
    1919
    2020
    21 fun start (initial,tmax,f,m) =
     21fun start (initial,tmax,f) =
    2222    let
    2323        fun run (input) =
    2424            let val nstate = f input
    25                 val nstate1 = {spike=(#spike(nstate)),d=(#d(initial)),U=(#U(nstate)),V=(#V(nstate)),b=(#b(initial)),c=(#c(initial)),tspike=(#tspike(nstate)),t=(#t(nstate)),theta=(#theta(initial)),a=(#a(initial)),Isyn=(#Isyn(initial)),k3=(#k3(initial)),k2=(#k2(initial)),k1=(#k1(initial)),h=(#h(initial))}
     25                val nstate1 = {d=(#d(initial)),U=(#U(nstate)),V=(#V(nstate)),b=(#b(initial)),c=(#c(initial)),t=(#t(nstate)),theta=(#theta(initial)),a=(#a(initial)),Isyn=(#Isyn(initial)),k3=(#k3(initial)),k2=(#k2(initial)),k1=(#k1(initial)),h=(#h(nstate))}
    2626            in putStrLn (printstate nstate1);
    2727               if (#t nstate)  > tmax
     
    3535
    3636
    37 fun make_pulse (lodur,hidur,lo, hi) =
    38     (fn (nstate as {h,t,V,U,k1,k2,k3,theta,a,b,c,d,spike,tspike,Isyn}) =>
    39         (let val t = #t(nstate)
    40              val Isyn = (if (Real.> (t,lodur))
    41                          then hi
    42                          else (if (Real.> (t,Real.+(lodur,hidur)))
    43                                then lo else lo))
    44          in
    45              {h=h,t=t,V=V,U=U,k1=k1,k2=k1,k3=k3,theta=theta,a=a,b=b,c=c,d=d,spike=spike,tspike=tspike,Isyn=Isyn}
    46          end))
    47 
    48 
    49 val _ = (start (Model.RS_initial,240.0,Model.RS,make_pulse (40.0,200.0,0.0,10.0)))
     37val _ = start (Model.RS_initial,240.0,Model.RS)
    5038(*
    5139val _ = (start (Model.IB_initial,240.0,Model.IB,make_pulse (40.0,200.0,0.0,10.0)))
  • release/4/signal-diagram/trunk/expr-utils.scm

    r30916 r30964  
    8484           (if (and (symbol? id) (not (member id bnds)))  (cons id ax) ax)))))
    8585
    86 
    87 #|
    88 
    89 
    90 (define (enum-bnds expr ax)
    91   (match expr
    92          (('if . es)        (fold enum-bnds ax es))
    93          (('let bnds body)  (enum-bnds body (append (map car bnds) (fold enum-bnds ax (map cadr bnds)))))
    94          ((s . es)          (if (symbol? s)  (fold enum-bnds ax es) ax))
    95          (else ax)))
    96 
    97 
    98 (define (enum-freevars expr bnds ax)
    99   (match expr
    100          (('if . es) 
    101           (fold (lambda (x ax) (enum-freevars x bnds ax)) ax es))
    102          (('let lbnds body) 
    103           (let ((bnds1 (append (map first lbnds) bnds)))
    104             (enum-freevars body bnds1
    105              (fold (lambda (x ax) (enum-freevars x bnds ax)) ax
    106                    (map second lbnds)))))
    107          ((s . es)    (if (symbol? s)  (fold (lambda (x ax) (enum-freevars x bnds ax)) ax es) ax))
    108          (id          (if (and (symbol? id) (not (member id bnds)))  (cons id ax) ax))))
    109 
    110 
    111 (define (if-convert expr)
    112   (match expr
    113          (('if c t e)
    114           (let ((r (gensym "if")))
    115             `(let ((,r (if ,(if-convert c) ,(if-convert t) ,(if-convert e)))) 
    116                ,r)))
    117          (('let bs e)
    118           `(let ,(map (lambda (b) `(,(car b) ,(if-convert (cadr b)))) bs) ,(if-convert e)))
    119          ((f . es)
    120           (cons f (map if-convert es)))
    121          ((? atom? ) expr)))
    122 
    123          
    124 (define (let-enum expr ax)
    125   (match expr
    126          (('let ((x ('if c t e))) y)
    127           (let ((ax (fold let-enum ax (list c ))))
    128             (if (eq? x y)  (append ax (list (list x `(if ,c ,t ,e)))) ax)))
    129 
    130          (('let bnds body)  (append ax bnds))
    131 
    132          (('if c t e)  (let-enum c ax))
    133 
    134          ((f . es)  (fold let-enum ax es))
    135 
    136          (else ax)))
    137 
    138 
    139 (define (let-elim expr)
    140   (match expr
    141          (('let ((x ('if c t e))) y)
    142           (if (eq? x y)  y expr))
    143 
    144          (('let bnds body) body)
    145 
    146          (('if c t e)  `(if ,(let-elim c) ,(let-lift t) ,(let-lift e)))
    147 
    148          ((f . es)  `(,f . ,(map let-elim es)))
    149 
    150          (else expr)))
    151  
    152 
    153 (define (let-lift expr)
    154   (define (fbnds bnds)
    155     (let ((bnds0
    156            (fold (lambda (b ax)
    157                    (let ((bexpr  (cadr b)))
    158                      (match bexpr
    159                             (('let bnds expr) (append bnds ax))
    160                             (else (append (let-enum bexpr (list)) ax)))))
    161                  '() bnds)))
    162       bnds0))
    163   (let ((expr1
    164          (match expr
    165                 (('let bnds expr)
    166                  (let ((bnds0 (fbnds bnds))
    167                        (expr1
    168                         `(let  ,(map (lambda (b) (list (car b) (let-elim (cadr b)))) bnds)
    169                            ,(let-lift expr))))
    170                      (if (null? bnds0) expr1 `(let ,bnds0 ,expr1))))
    171 
    172                 (else
    173                  (let ((bnds (let-enum expr (list))))
    174                    (if (null? bnds)
    175                        (let-elim expr)
    176                        (let ((bnds0 (fbnds bnds))
    177                              (expr1 `(let ,(map (lambda (b) (list (car b) (let-elim (cadr b)))) bnds)
    178                                        ,(let-elim expr))))
    179                          (if (null? bnds0) expr1 `(let ,bnds0 ,expr1))))))
    180                 )))
    181     (if (equal? expr expr1) expr1
    182         (let-lift expr1))))
    183 
    184 
    185 (define (lookup-def k lst . rest)
    186   (let-optionals rest ((default #f))
    187     (let ((k (->string k)))
    188      (let recur ((kv #f) (lst lst))
    189        (if (or kv (null? lst))
    190         (if (not kv) default
    191             (match kv ((k v) v) (else (cdr kv))))
    192         (let ((kv (car lst)))
    193           (recur (and (string=? (->string (car kv)) k) kv)
    194                  (cdr lst)) ))))))
    195 
    196 
    197 (define (subst-term t subst k)
    198   (assert (every symbol? (map car subst)))
    199   (match t
    200          (('if c t e)
    201           `(if ,(k c subst) ,(k t subst) ,(k e subst)))
    202                  
    203          (('let bs e)
    204           (let ((r `(let ,(map (lambda (b) `(,(car b) ,(k (cadr b) subst))) bs) ,(k e subst))))
    205             (k r subst)))
    206                  
    207          ((f . es)
    208           (cons (k f subst) (map (lambda (e) (k e subst)) es)))
    209          
    210          ((? symbol? )  (lookup-def t subst t))
    211          
    212          ((? atom? ) t)))
    213    
    214 
    215 (define (binding? t)
    216   (and (list? t) (eq? 'let (car t)) (cdr t)))
    217 
    218 (define (bind ks vs e) `(let ,(zip ks vs) ,e))
    219 
    220 (define (canonicalize-expr expr)
    221   (let ((subst-convert  (subst-driver (lambda (x) (and (symbol? x) x)) binding? identity bind subst-term)))
    222     (let* ((expr1 (if-convert expr))
    223            (expr2 (subst-convert expr1 subst-empty))
    224            (expr3 (let-lift expr2)))
    225       expr3)))
    226 
    227 |#
  • release/4/signal-diagram/trunk/signal-diagram.scm

    r30959 r30964  
    255255          )
    256256
    257      (print "fd = " fd)
    258 
    259257     (make-sfarrow
    260258      ;; dataflow equations
     
    265263       (lambda (s) (if (prim? fd) outputs (list name)))
    266264       ;; in
    267        (lambda (s) (begin
    268                      (print "s = " s)
    269                      (print "fd formals = " (function-formals fd))
    270                      (if (function? fd)
     265       (lambda (s) (if (function? fd)
    271266                       (lset-intersection eq? (function-formals fd) s)
    272                        s)))
     267                       s))
    273268       ;; out
    274269       (lambda (s) (if (prim? fd) outputs (list name))))
    275270      ;; codegen
    276       (lambda (s ev env dfe)
     271      (lambda (s env dfe)
    277272        (let ((in   ((dfe-in dfe) s))
    278273              (out  ((dfe-out dfe) s))
     
    422417
    423418      ;; codegen
    424       (lambda (s ev env dfe)
     419      (lambda (s env dfe)
    425420        (let* (
    426421               (rv (gensym 'identity))
    427422               (fenv (list->cgenenv 'identity (fe-in s) env))
    428                (fcodegen ((sfarrow-codegen f) (fe-in s) ev fenv fe))
     423               (fcodegen ((sfarrow-codegen f) (fe-in s) fenv fe))
    429424               )
    430425          (make-codegen rv
     
    494489
    495490      ;; codegen
    496       (lambda (s ev env dfe)
     491      (lambda (s env dfe)
    497492
    498493        (let* (
     
    503498                                (dfe (sfarrow-dfe sf)))
    504499                            (let ((env (list->cgenenv 'union1 ((dfe-in dfe) s) env)))
    505                               (codegen ((dfe-in dfe) s) ev env dfe)))))
     500                              (codegen ((dfe-in dfe) s) env dfe)))))
    506501
    507502               (fld  (lambda (codegen dfe)
     
    593588
    594589      ;; codegen
    595       (lambda (s ev env dfe)
     590      (lambda (s env dfe)
    596591        (let* (
    597592               
    598593               (fenv (list->cgenenv 'sequence11 (fe-in s) env))
    599                (fcodegen ((sfarrow-codegen f) (fe-in s) ev fenv fe))
     594               (fcodegen ((sfarrow-codegen f) (fe-in s) fenv fe))
    600595
    601596               (genv (list->cgenenv 'sequence12 (lset-difference eq? (ge-in s) (fe-out s)) env))
     
    604599                               (cgenenv-add s v env)))
    605600                           genv (fe-out s)))
    606                (gcodegen ((sfarrow-codegen g) (ge-in s) ev genv ge))
     601               (gcodegen ((sfarrow-codegen g) (ge-in s) genv ge))
    607602               
    608603               (fld  (lambda (codegen)
     
    670665
    671666      ;; codegen
    672       (lambda (s ev env dfe)
     667      (lambda (s env dfe)
    673668        (let* (
    674669               
    675670               (fenv (list->cgenenv 'on1 (fe-in s) env))
    676                (fcodegen ((sfarrow-codegen f) (fe-in s) ev fenv fe))
     671               (fcodegen ((sfarrow-codegen f) (fe-in s) fenv fe))
    677672
    678673               (fld  (lambda (codegen)
     
    739734
    740735     ;; codegen
    741      (lambda (s ev env dfe)
     736     (lambda (s env dfe)
    742737       (let* (
    743738              (fenv      (list->cgenenv 'sense11 ((dfe-in dfe) s) env))
    744               (fcodegen  ((sfarrow-codegen f) ((dfe-in dfe) s) ev fenv (sfarrow-dfe f)))
     739              (fcodegen  ((sfarrow-codegen f) ((dfe-in dfe) s) fenv (sfarrow-dfe f)))
    745740              )
    746741         (make-codegen
     
    780775     
    781776      ;; in
    782       (lambda (s) (print "sf-actuate in: s = " s) (fe-in s))
     777      (lambda (s) (fe-in s))
    783778     
    784779      ;; out
     
    787782
    788783     ;; codegen
    789      (lambda (s ev env dfe)
     784     (lambda (s env dfe)
    790785
    791786       (let* (
    792787              (fenv      (list->cgenenv 'actuate11 (fe-in s) env))
    793               (fcodegen  ((sfarrow-codegen f) (fe-in s) ev fenv (sfarrow-dfe f)))
     788              (fcodegen  ((sfarrow-codegen f) (fe-in s) fenv (sfarrow-dfe f)))
    794789              (rv        (gensym 'actuate))
    795790              (renv      (codegen-renv fcodegen))
     
    841836
    842837      ;; codegen
    843       (lambda (s ev env dfe)
     838      (lambda (s env dfe)
    844839
    845840        (let ((in   (lset-difference eq? ((dfe-in dfe) s) (list init ))))
     
    926921     
    927922     ;; codegen
    928      (lambda (s ev env dfe)
     923     (lambda (s env dfe)
    929924       (let* (
    930925              (stm        (gensym 'trstm))
     
    11231118(define (sf-transient f g e ef)
    11241119
    1125   (let* ((fe      (sfarrow-dfe f))
     1120  (let* (
     1121         (fe      (sfarrow-dfe f))
    11261122         (ge      (sfarrow-dfe g))
    11271123         (ee      (sfarrow-dfe ef))
     
    11591155                               (ee-in s)))
    11601156      ;; out
    1161       (lambda (s)
    1162         (lset-intersection eq? (fe-out s) (ge-out s)))
     1157      (lambda (s) (lset-intersection eq? (fe-out s) (ge-out s)))
    11631158     
    11641159      )
    11651160     
    11661161     ;; codegen
    1167      (lambda (s ev env dfe)
     1162     (lambda (s env dfe)
    11681163
    11691164       (if (null? (lset-intersection eq? (fe-out s) (ge-out s)))
     
    11711166                  (sfarrow-sig f)
    11721167                  (sfarrow-sig g)))
    1173          
    11741168       
    11751169       (let* (
    11761170
    1177               (rv  (gensym 'transient))
     1171              (rv1  (gensym 'transient))
     1172              (rv2  (gensym 'transient))
     1173              (rv3  (gensym 'transient))
    11781174
    11791175              (fcompute  (gensym 'transientf))
    11801176              (gcompute  (gensym 'transientg))
    1181               (ecompute  (gensym 'transiente))
    1182 
    1183               (eenv      (map (lambda (s) (cons s s)) (ee-in s)))
    1184               (ecodegen ((sfarrow-codegen f) (ee-in s) #f eenv ee))
    1185 
    1186               (fenv      (map (lambda (s) (cons s s)) (fe-in s)))
    1187               (fcodegen ((sfarrow-codegen f) (fe-in s) (list e ecompute (ee-in s))  fenv fe))
     1177              (evtest    (gensym 'evtest))
     1178
     1179              (fenv      (map (lambda (s) (cons s s)) (lset-union eq? (ee-in s) (fe-in s))))
     1180              (fcodegen  ((sfarrow-codegen f) (lset-union eq? (ee-in s) (fe-in s)) fenv fe))
    11881181
    11891182              (genv      (map (lambda (s) (cons s s)) (ge-in s)))
    1190               (gcodegen ((sfarrow-codegen g) (ge-in s) ev genv ge))
     1183              (gcodegen  ((sfarrow-codegen g) (ge-in s) genv ge))
     1184
     1185              (eenv      (map (lambda (s) (cons s s)) (fe-in s)))
     1186              (ecodegen  ((sfarrow-codegen ef) (ee-in s) eenv ee))
    11911187
    11921188              )
     
    11951191          (append
    11961192           (list
     1193
     1194            (B:Val evtest
     1195                   (V:Fn (ee-in s)
     1196                         (E:Let
     1197                          (codegen-expr ecodegen)
     1198                          (E:Ret (V:Op '>= (list (V:Sel (car (ee-out s)) (V:Var (codegen-rv ecodegen))) (V:C 0.0)))))
     1199                         ))
    11971200           
    11981201            (B:Val fcompute
     
    12141217                          )))
    12151218                   
    1216             (B:Val ecompute
    1217                    (V:Fn (ee-in s)
    1218                          (E:Let
    1219                           (append (relations-codegen e env)
    1220                                   (codegen-expr ecodegen))
    1221                           (E:Ret (V:Rec (map (lambda (x) (list x (select-signal '(transient ecompute) x (codegen-renv ecodegen))))
    1222                                              ((ee-out dfe) s))))
    1223                           )))
    1224                    
    12251219            )
    12261220           
     
    12281222         
    12291223         (make-codegen
    1230           rv
     1224
     1225          rv3
    12311226
    12321227          (list->cgenenv '(transient renv)
    12331228                         ((dfe-out dfe) s)
    1234                          (fold (lambda (s env) (cgenenv-add s rv env)) cgenenv-empty ((dfe-out dfe) s)))
     1229                         (cgenenv-add e rv2
     1230                                      (fold (lambda (s env) (cgenenv-add s rv3 env)) cgenenv-empty ((dfe-out dfe) s))))
    12351231         
    12361232           (list
    1237             (B:Val rv
    1238                    (V:Ifv (select-signal '(transient rv) e env)
     1233
     1234            (B:Val rv1 (V:Op fcompute (map (lambda (x) (select-signal '(transient state-compute) x env))
     1235                                           (fe-in s))))
     1236
     1237            (B:Val rv2 (V:Op evtest (map (lambda (v)
     1238                                           (if (member v (fe-out s))
     1239                                               (V:Sel v (V:Var rv1))
     1240                                               (select-signal 'evtest v env)))
     1241                                         (ee-in s))))
     1242
     1243            (B:Val rv3
     1244                   (V:Ifv (V:Var rv2)
    12391245                          (V:Op gcompute (map (lambda (x) (select-signal '(transient state-compute) x env))
    12401246                                              (ge-in s)))
    1241                           (V:Op fcompute (map (lambda (x) (select-signal '(transient state-compute) x env))
    1242                                               (fe-in s)))
     1247                          (V:Var rv1)
    12431248                          ))
    1244            ))
    1245          ))
     1249            ))
     1250         
     1251         ))
    12461252
    12471253     ;; signature
     
    12611267(define integral-index (make-parameter 0))
    12621268
    1263 (define (sf-integral x ys h fs)
     1269(define (sf-integral x ys h fs ev)
    12641270
    12651271  (let* ((varh   (case (car h)
     
    12751281                   (integral-index (+ 1 (integral-index)))
    12761282                   v))
     1283         (e      (and ev (car ev)))
     1284         (ef     (and ev (cadr ev)))
     1285
     1286         (ee      (and ef (sfarrow-dfe ef)))
     1287         (ee-in   (and ee (dfe-in ee)))
     1288         (ee-out  (and ee (compose (dfe-out ee) ee-in)))
     1289         (ee-gen  (and ee (compose (dfe-gen ee) ee-in)))
     1290         (ee-kill (and ee (compose (dfe-gen ee) ee-in)))
     1291
    12771292         )
    12781293
     
    12851300
    12861301        ;; gen
    1287         (lambda (s) (if varh (cons hname yns) yns))
     1302        (lambda (s) (lset-union eq?
     1303                               (or (and ee (ee-gen s)) '())
     1304                               (if varh (cons hname yns) yns)))
    12881305       
    12891306        ;; kill
    1290         (lambda (s) (lset-union eq? s (list xn)))
     1307        (lambda (s) (lset-union eq?
     1308                               (or (and ee (ee-kill s)) '())
     1309                               (lset-union eq? s (list xn))))
    12911310       
    12921311        ;; in
    12931312        (lambda (s)
    1294           (let ((x (lset-union eq?
    1295                                (concatenate fs-formals)
    1296                                (append (list hname)
    1297                                        (cons x ys)))))
     1313          (let ((x (lset-union eq?
     1314                               (or (and ee (ee-in s)) '())
     1315                               (lset-union eq?
     1316                                           (concatenate fs-formals)
     1317                                           (append (list hname)
     1318                                                   (cons x ys))))))
    12981319            x))
    12991320       
    13001321        ;; out
    1301         (lambda (s) (if varh (cons hname yns) yns))
     1322        (lambda (s) (lset-union eq?
     1323                               (or (and ee (ee-out s)) '())
     1324                               (if varh (cons hname yns) yns)))
    13021325        )
    13031326       
     
    13101333
    13111334             
    1312          (lambda (s ev env dfe)
    1313 
    1314            (let* ((evtest (and ev (gensym 'evtest)))
     1335         (lambda (s env dfe)
     1336
     1337           (let* ((evtest     (and ev (gensym 'evtest)))
     1338                  (evcompute  (and ev (gensym 'evcompute)))
     1339                  (evcodegen  (and ev ((sfarrow-codegen (cadr ev)) s env ee)))
    13151340
    13161341                  (idxv      (V:C idx))
     
    13351360
    13361361               (map function->expr yps fs)
     1362                   
     1363               (if ev
     1364                   (let ((evselect
     1365                          (lambda (x)
     1366                            (let ((yi (list-index (lambda (y) (equal? x y)) ys)))
     1367                              (if yi
     1368                                  (V:Sub (list-ref yis yi) (V:Var 'yvec))
     1369                                  (select-signal 'evselect x env))))))
     1370                     
     1371                     
     1372                     (list
     1373                      (B:Val evcompute
     1374                             (V:Fn (ee-in s)
     1375                                   (E:Let
     1376                                    (codegen-expr evcodegen)
     1377                                    (E:Ret (V:Rec (map (lambda (x)
     1378                                                         (let ((v (select-signal '(integral evcompute) x (codegen-renv evcodegen))))
     1379                                                           (list x v)))
     1380                                                       (ee-out s))))
     1381                                    )))
     1382                      (B:Val evtest
     1383                             (V:Fn `(yvec)
     1384                                   (E:Ret (V:Sel e (V:Op evcompute (map evselect (ee-in s)))))
     1385                                   ))
     1386                      ))
     1387                '())
    13371388
    13381389               (list
     
    13431394                                    ))))
    13441395
    1345                (if (and varh ev)
     1396               (if ev
    13461397                   
    1347                    (let ((ev-select
    1348                           (lambda (x)
    1349                             (let ((yi (find (lambda (y) (equal? x y)) ys)))
    1350                               (if yi
    1351                                   (V:Sub (list-ref yis yi) (V:Var 'yvec))
    1352                                   (select-signal 'ev-select x env))))))
    1353                      
    1354                          (list
    1355                            (B:Val evtest
    1356                                   (V:Fn `(yvec)
    1357                                         (E:Ret (V:Op (cadr ev) (list (V:Rec (map (lambda (s) `(,s ,(ev-select s))) (caddr ev))))))
    1358                                         ))
    1359 
    1360                            (B:Val rv1
    1361                                   (V:Op 'eintegral
    1362                                         (list (V:Var dfn)
    1363                                               (select-signal 'eintegral1 x env)
    1364                                               (V:Vec (map (lambda (y) (select-signal 'eintegral2 y env)) ys))
    1365                                               (V:Var evtest)
    1366                                               tstep
    1367                                               idxv
    1368                                               )))
    1369                            ))
     1398                   (list
     1399                    (B:Val rv1
     1400                           (V:Op 'eintegral
     1401                                 (list (V:Var dfn)
     1402                                       (select-signal 'eintegral1 x env)
     1403                                       (V:Vec (map (lambda (y) (select-signal 'eintegral2 y env)) ys))
     1404                                       (V:Var evtest)
     1405                                       tstep
     1406                                       idxv
     1407                                       )))
     1408                    )
    13701409                   
    13711410                   (list
     
    13821421
    13831422                (if varh
    1384                     (let ((stn1 (gensym 'stn)))
     1423                    (let* ((ysn (gensym 'ysn))
     1424                           (retflds (cons `(,hname ,(V:Sel 'h (V:Var rv1)))
     1425                                          (map (lambda (yn yi) `(,yn ,(V:Sub yi (V:Var ysn)))) yns yis))))
    13851426                      (list
    1386                        (B:Val stn1 (V:Sel 'stn (V:Var rv1)))
    1387                        (B:Val rv2
    1388                               (V:Rec
    1389                                (cons `(,hname ,(V:Sel 'tstep (V:Var rv1)))
    1390                                      (map (lambda (yn yi) `(,yn ,(V:Sub yi (V:Var stn1)))) yns yis))))))
    1391                      (list (B:Val rv2
    1392                                   (V:Rec (map (lambda (yn yi) `(,yn ,(V:Sub yi (V:Var rv1)) )) yns yis)) )))
    1393                ))
     1427                       (B:Val ysn (V:Sel 'ysn (V:Var rv1)))
     1428                       (B:Val rv2 (V:Rec retflds))))
     1429                    (let* ((ysn (gensym 'ysn))
     1430                           (retflds (map (lambda (yn yi) `(,yn ,(V:Sub yi (V:Var rv1)) )) yns yis)))
     1431                      (list (B:Val rv2 (V:Rec retflds)))))
     1432                ))
    13941433             ))
    13951434         )
    13961435
    13971436       ;; signature
    1398        `(INTEGRAL ,idx ,h ,x ,ys)
     1437       `(INTEGRAL ,idx ,h ,x ,ys ,ev)
    13991438
    14001439       ;; children
     
    14161455
    14171456(define (construct1 d)
    1418   (let recur ((d d))
     1457  (let recur ((d d) (ev #f))
    14191458    (cases diagram d
    1420            (IDENTITY (f)               (sf-identity (recur f)))
     1459           (IDENTITY (f)               (sf-identity (recur f ev)))
    14211460           (PURE (f)                   (sf-pure f))
    14221461           (PRIM (f name)              (sf-prim f name))
    1423            (RELATION (r f)             (sf-relation r (recur f)))
    1424            (SEQUENCE (f g)             (sf-sequence (recur f) (recur g)))
    1425            (UNION (f g)                (sf-union (recur f) (recur g)))
    1426            (SENSE (s f)                (sf-sense s (recur f)))
    1427            (ACTUATE (s f)              (sf-actuate s (recur f)))
     1462           (RELATION (r f)             (sf-relation r (recur f ev)))
     1463           (SEQUENCE (f g)             (sf-sequence (recur f ev) (recur g ev)))
     1464           (UNION (f g)                (sf-union (recur f ev) (recur g ev)))
     1465           (SENSE (s f)                (sf-sense s (recur f ev)))
     1466           (ACTUATE (s f)              (sf-actuate s (recur f ev)))
    14281467           (REDUCE (f n i)             (sf-reduce f n i))
    1429            (RTRANSITION (f g ef eg s)  (sf-rtransition (recur f) (recur g) ef eg s))
    1430            (TRANSITION (f g ef s)      (sf-transition (recur f) (recur g) ef s))
    1431            (TRANSIENT (f g e ef)       (sf-transient (recur f) (recur g) e (recur ef)))
    1432            (ON (f e)                   (sf-on (recur f) e))
    1433            (INTEGRAL (x ys h fs)       (sf-integral x ys h fs))
     1468           (RTRANSITION (f g ef eg s)  (sf-rtransition (recur f ev) (recur g ev) ef eg s))
     1469           (TRANSITION (f g ef s)      (sf-transition (recur f ev) (recur g ev) ef s))
     1470           (TRANSIENT (f g e ef)       (let ((ee (recur ef #f)))
     1471                                         (sf-transient (recur f (list e ee)) (recur g ev) e ee)))
     1472           (ON (f e)                   (sf-on (recur f ev) e))
     1473           (INTEGRAL (x ys h fs)       (sf-integral x ys h fs ev))
    14341474           )))
    14351475
     
    14951535    (let* ((input    (or (and initial (map car initial)) ((dfe-in dfe) '())))
    14961536           (fenv     (map (lambda (s) (cons s 'input)) input))
    1497            (fcodegen ((sfarrow-codegen f) input #f fenv dfe ))
     1537           (fcodegen ((sfarrow-codegen f) input fenv dfe ))
    14981538           (relations-expr (relations-codegen f input))
    14991539           (globals   (filter-map
     
    15511591    (let* ((input    (or (and initial (map car initial)) ((dfe-in dfe) '())))
    15521592           (fenv     (map (lambda (s) (cons s 'input)) input))
    1553            (fcodegen ((sfarrow-codegen f) input #f fenv dfe ))
     1593           (fcodegen ((sfarrow-codegen f) input fenv dfe ))
    15541594           (relations-expr (relations-codegen f input)))
    15551595
     
    16001640                         ((dfe-in dfe) '())))
    16011641           (fenv     (map (lambda (s) (cons s 'input)) input))
    1602            (fcodegen ((sfarrow-codegen f) input #f fenv dfe ))
     1642           (fcodegen ((sfarrow-codegen f) input fenv dfe ))
    16031643           (relations-expr (relations-codegen f input))
    16041644           )
Note: See TracChangeset for help on using the changeset viewer.