Changeset 7940 in project


Ignore:
Timestamp:
01/26/08 15:38:14 (12 years ago)
Author:
Ivan Raikov
Message:

Fixes to the coupling scheme code.

Location:
ode/trunk
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • ode/trunk/extensions/ode-bpr.scm

    r7909 r7940  
    128128                                                              (rt double))))
    129129    (environment-for-each sys 
    130        (lambda (sym en)
    131          (let-values (((name seedv alst)
    132                        (match en
    133                               (('rate . alst)
    134                                (values (lookup-field 'name alst)
    135                                        (lookup-field 'seed alst)
    136                                        alst)))))
     130     (lambda (sym en)
     131       (let-values (((name seedv alst)
     132                     (match en
     133                            (('rate . alst)
     134                             (values (lookup-field 'name alst)
     135                                     (lookup-field 'seed alst)
     136                                     alst))
     137                            (else (values #f #f #f)))))
     138             
    137139            (if name
    138140                (let* ((g  (make-digraph name (string-append (symbol->string name) " probability rate graph")))
  • ode/trunk/extensions/ode-hhsm.scm

    r7939 r7940  
    3636(define ($ p n) (string->symbol (s+ (sstr p) "_" (sstr n))))
    3737
    38 (define (lookup-field k lst . rest)
     38(define (lookup-car k lst . rest)
    3939  (let-optionals rest ((default #f))
    4040   (let ((v (alist-ref k lst)))
    4141     (if v (first v) default))))
     42
     43
     44(define (lookup-cdr k lst . rest)
     45  (let-optionals rest ((default #f))
     46   (let ((v (alist-ref k lst)))
     47     (or v default))))
    4248
    4349                                                           
     
    102108
    103109(define (make-coupling chain-names state in-rate out-rate)
    104   (let ((si (map cdr state))
    105         (stname (cond ((= 3 (length state)) mhssym)
    106                       ((= 2 (length state)) mhsym)
    107                       ((= 1 (length state)) msym))))
    108     (let loop ((sts (map (lambda (cn) ($ (apply (stname cn) si))) chain-names)) (lst (list)))
     110  (let* ((si (map second state))
     111         (stname (cond ((= 3 (length si)) mhssym)
     112                       ((= 2 (length si)) mhsym)
     113                       ((= 1 (length si)) msym))))
     114    (let loop ((sts (map (lambda (cn) (apply (stname cn) si)) chain-names)) (lst (list)))
    109115      (match sts
    110         ((a b . rest)
    111          (loop (cons b rest) (cons* `(-> ,a ,b ,in-rate) `(-> ,b ,a ,out-rate) lst)))
    112         (else  lst)))))
     116             ((a b . rest)
     117              (loop (cons b rest) (cons* `(-> ,a ,b ,in-rate) `(-> ,b ,a ,out-rate) lst)))
     118             (else  lst)))))
    113119     
    114120 
     
    214220                   alpham betam alphah betah alphas betas
    215221                   density total area phi)
    216       (let ((seed-val  (lookup-field 'rng-seed alst))
    217             (gamma-val (eval-const new-sys (lookup-field 'gamma alst)))
    218             (delta-val (eval-const new-sys (lookup-field 'delta alst 0)))
    219             (eps-val   (eval-const new-sys (lookup-field 'eps alst 0)))
    220             (density-val (eval-const new-sys (lookup-field 'density alst)))
    221             (area-val  (eval-const new-sys (lookup-field 'area alst)))
    222             (phi-val   (eval-const new-sys (lookup-field 'phi alst))))
     222      (let ((seed-val  (lookup-car 'rng-seed alst))
     223            (gamma-val (eval-const new-sys (lookup-car 'gamma alst)))
     224            (delta-val (eval-const new-sys (lookup-car 'delta alst 0)))
     225            (eps-val   (eval-const new-sys (lookup-car 'eps alst 0)))
     226            (density-val (eval-const new-sys (lookup-car 'density alst)))
     227            (area-val  (eval-const new-sys (lookup-car 'area alst)))
     228            (phi-val   (eval-const new-sys (lookup-car 'phi alst))))
    223229        (if (positive? delta-val) (check-decls ion '(hinf tauh) alst))
    224230        (if (positive? eps-val) (check-decls ion '(sinf taus) alst))
     
    247253                (alphas-rhs  (and (positive? eps-val) `(/ ,sinf ,taus)))
    248254                (betas-rhs   (and (positive? eps-val) `(/ (- 1 ,sinf) ,taus)))
    249                 (minf-rhs    (rrhs suffix (lookup-field 'minf alst)))
    250                 (hinf-rhs    (and (positive? delta-val) (rrhs suffix (lookup-field  'hinf alst))))
    251                 (sinf-rhs    (and (positive? eps-val) (rrhs suffix (lookup-field  'sinf alst))))
    252                 (taum-rhs    (rrhs suffix (lookup-field 'taum alst)))
    253                 (tauh-rhs    (and (positive? delta-val) (rrhs suffix (lookup-field  'tauh alst))))
    254                 (taus-rhs    (and (positive? eps-val) (rrhs suffix (lookup-field  'taus alst))))
    255                 (initial-m   (eval-const new-sys (lookup-field 'initial-m alst)))
     255                (minf-rhs    (rrhs suffix (lookup-car 'minf alst)))
     256                (hinf-rhs    (and (positive? delta-val) (rrhs suffix (lookup-car  'hinf alst))))
     257                (sinf-rhs    (and (positive? eps-val) (rrhs suffix (lookup-car  'sinf alst))))
     258                (taum-rhs    (rrhs suffix (lookup-car 'taum alst)))
     259                (tauh-rhs    (and (positive? delta-val) (rrhs suffix (lookup-car  'tauh alst))))
     260                (taus-rhs    (and (positive? eps-val) (rrhs suffix (lookup-car  'taus alst))))
     261                (initial-m   (eval-const new-sys (lookup-car 'initial-m alst)))
    256262                (initial-h   (and (positive? delta-val)
    257                                   (eval-const new-sys (lookup-field 'initial-h alst))))
     263                                  (eval-const new-sys (lookup-car 'initial-h alst))))
    258264                (initial-s   (and (positive? eps-val)
    259                                   (eval-const new-sys (lookup-field 'initial-s alst)))))
     265                                  (eval-const new-sys (lookup-car 'initial-s alst)))))
    260266            (env-extend! gamma   '(const)  gamma-val)
    261267            (env-extend! delta   '(const)  delta-val)
     
    298304  (fold (lambda (x ax)
    299305          (match x  ((chain-names state in out)
    300              (let ((coupling (make-coupling chain-names state in out)))
    301                (cons coupling ax)))))
    302         couplings chains))
     306                     (let ((coupling (make-coupling chain-names state in out)))
     307                       (cons coupling ax)))))
     308        chains couplings))
    303309
    304310
     
    323329                 (('coupled-ionic-conductance)   ('name ion) . lst))
    324330
    325              (let* ((chains
     331             (let* ((suffix (sstr ion))
     332                    (chains
    326333                    (filter-map
    327334                     (lambda (x)
     
    332339                     lst))
    333340                    (chain-names (map car chains))
    334                     (coupling-factor (lookup-field 'coupling-factor lst))
    335                     (coupling-scheme (lookup-field 'coupling-scheme lst)))
    336 
     341                    (coupling-factor (lookup-car 'coupling-factor lst))
     342                    (coupling-scheme (lookup-cdr 'coupling-scheme lst)))
     343               
    337344               (cond ((and coupling-factor coupling-scheme)
    338345                      (ode:error 'ode:hhsm-transformer "coupled conductance declaration " ion
     
    340347                     
    341348                     (coupling-factor
    342                       (let ((prob  (lookup-field 'prob lst))
    343                             (in     (lookup-field 'in  lst))
    344                             (out    (lookup-field 'out lst)))
    345                         (let ((prob-val (eval-const new-sys prob))
    346                               (in-val   (eval-const new-sys in))
    347                               (out-val  (eval-const new-sys out)))
     349                      (let ((prob  (lookup-car 'prob lst))
     350                            (in     (lookup-car 'in  lst))
     351                            (out    (lookup-car 'out lst)))
     352                        (let ((prob-val (eval-const new-sys prob)))
    348353                          (if (not (number? prob-val))
    349354                              (ode:error 'ode:hhsm-transformer "coupling probability in "
    350355                                         "coupled conductance declaration " lst
    351356                                         " must be a numeric constant"))
    352                           (if (not (and (number? in-val) (number? out-val)))
    353                               (ode:error 'ode:hhsm-transformer
    354                                          "rates in coupling declaration " lst " must be "
    355                                          "numeric constants "))
    356                           (let ((k  (min 100 (abs (round (* 100 prob-val))))))
     357                          (let ((k     (min 100 (abs (round (* 100 prob-val)))))
     358                                (inq   ($ "in" (sstr ion)))
     359                                (outq  ($ "out" (sstr ion))))
     360                               
    357361                            (randomize)
    358362                            (let* ((couplings
    359363                                    (filter-map (lambda (x)
    360                                                   (and (<= (random 100) k) (list chain-names (car x) in-val out-val)))
     364                                                  (and (<= (random 100) k) (list chain-names (car x) inq outq)))
    361365                                                chains))
    362                                    (chains1 (fold-couplings couplings chains)))
     366                                   (chains1 (fold-couplings couplings (map cdr chains))))
     367                              (if debug (print "ode-hhsm:transformer: chains1 = " chains1))
     368                              (env-extend! inq  '(asgn)   'none in)
     369                              (env-extend! outq '(asgn)   'none out)
    363370                              (env-extend! (gensym 'rate) '(rate) (c+ chains1)))))))
    364371
     
    366373                     
    367374                     (coupling-scheme
    368                       (let* ((couplings
    369                               (fold (lambda (x ax)
    370                                       (match x
    371                                        (('coupling . alst)
    372                                         (let (
    373                                               (state  (lookup-field 'state alst))
    374                                               (in     (lookup-field 'in alst))
    375                                               (out    (lookup-field 'out alst)))
    376                                           (if (not state)
    377                                               (ode:error 'ode:hhsm-transformer
    378                                                          "coupling declaration " x " lacks state name"))
    379                                           (let ((in-val  (eval-const new-sys in))
    380                                                 (out-val (eval-const new-sys out)))
    381                                             (if (not (and (number? in-val) (number? out-val)))
    382                                                 (ode:error 'ode:hhsm-transformer
    383                                                            "rates in coupling declaration " x " must be "
    384                                                            "numeric constants "))
    385                                             (let ((coupling (list chain-names state in-val out-val)))
    386                                               (cons coupling ax)))))
    387                                        
    388                                        (else (ode:error 'ode:hhsm-transformer
    389                                                         "unknown coupling declaration " x))))
    390                                     coupling-scheme (list)))
    391                              (chains1 (fold-couplings couplings chains)))
    392                         (env-extend! (gensym 'rate) '(rate) (c+ chains1))))
     375                      (let-values
     376                       (((couplings coupling-rates)
     377                         (let loop ((coupling-scheme coupling-scheme) (couplings (list))
     378                                    (cpl-rates (list)) (i 0))
     379                           (if (null? coupling-scheme) (values couplings cpl-rates)
     380                               (let ((x (car coupling-scheme)))
     381                                 (match x
     382                                        (('coupling . alst)
     383                                         (let ((inq    ($ (s+ "inq" (->string i)) suffix))
     384                                               (outq   ($ (s+ "outq" (->string i)) suffix))
     385                                               (state  (lookup-cdr 'state alst))
     386                                               (in     (lookup-car 'in alst))
     387                                               (out    (lookup-car 'out alst)))
     388                                           (if (not state)
     389                                               (ode:error 'ode:hhsm-transformer
     390                                                          "coupling declaration " x " lacks state name"))
     391                                           
     392                                           (let ((coupling (list chain-names state in out)))
     393                                             (loop (cdr coupling-scheme) (cons coupling couplings)
     394                                                   (cons* `(,inq ,in) `(,outq ,out) cpl-rates)
     395                                                   (+ i 1)))))
     396                                       
     397                                        (else (ode:error 'ode:hhsm-transformer
     398                                                         "unknown coupling declaration " x))))))))
     399                       (let ((chains1 (fold-couplings couplings (map cdr chains))))
     400                         (if debug (print "ode-hhsm:transformer: chains1 = " chains1))
     401                         (for-each (lambda (x) (env-extend! (first x)  '(asgn)   'none (second x)))
     402                                   coupling-rates)
     403                         (env-extend! (gensym 'rate) '(rate) (c+ chains1)))))
    393404
    394405                     (else
  • ode/trunk/ode.scm

    r7203 r7940  
    507507                  (else #f)))
    508508          ((list? x)
    509            (alist-ref 'dep?  (cdr x)))
     509           (begin
     510             (print "isdep? x = " x)
     511             (alist-ref 'dep?  (cdr x))))
    510512          (else #f)))
    511513       
     
    565567                           (let* ((q   (environment-ref ode-env qsym))
    566568                                  (rhs (qrhs q)))
     569                             (print "q = " q)
    567570                             (if rhs
    568571                                 (let* ((deps (filter (if (isstate? q)
Note: See TracChangeset for help on using the changeset viewer.