Changeset 7939 in project


Ignore:
Timestamp:
01/26/08 13:17:22 (12 years ago)
Author:
Ivan Raikov
Message:

Some additions to the hhsm extension.

File:
1 edited

Legend:

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

    r7909 r7939  
    111111         (loop (cons b rest) (cons* `(-> ,a ,b ,in-rate) `(-> ,b ,a ,out-rate) lst)))
    112112        (else  lst)))))
    113                
    114113     
    115114 
     
    295294                ))))))))
    296295
     296
     297(define (fold-couplings couplings chains)
     298  (fold (lambda (x ax)
     299          (match x  ((chain-names state in out)
     300             (let ((coupling (make-coupling chain-names state in out)))
     301               (cons coupling ax)))))
     302        couplings chains))
     303
     304
    297305(define (ode:hhsm-transformer pr-transformer sys . rest)
    298306 (let-optionals rest ((debug #f))
     
    314322            ((or (('coupled 'ionic 'conductance) ('name ion) . lst)
    315323                 (('coupled-ionic-conductance)   ('name ion) . lst))
    316              (let ((chains
     324
     325             (let* ((chains
    317326                    (filter-map
    318                      (lambda (x)
    319                        (match x
    320                          (('species (species . alst))
     327                     (lambda (x)
     328                       (match x (('species (species . alst))
    321329                          (let ((ion-species ($ ion species)))
    322330                            (cons ion-species (ion-transformer new-sys env-extend! eqdef! eval-const ion-species alst))))
    323331                          (else #f)))
    324332                     lst))
    325                    (coupling-factor (lookup-field 'coupling-factor lst))
    326                    (coupling-scheme (lookup-field 'coupling-scheme lst)))
     333                    (chain-names (map car chains))
     334                    (coupling-factor (lookup-field 'coupling-factor lst))
     335                    (coupling-scheme (lookup-field 'coupling-scheme lst)))
     336
    327337               (cond ((and coupling-factor coupling-scheme)
    328338                      (ode:error 'ode:hhsm-transformer "coupled conductance declaration " ion
     
    330340                     
    331341                     (coupling-factor
    332                       (let ((coupling-factor-val (eval-const new-sys coupling-factor)))
    333                         (if (not (number? coupling-factor-val))
    334                             (ode:error 'ode:hhsm-transformer "coupling factor in "
    335                                        "coupled conductance declaration " ion
    336                                        " must be a numeric constant"))))
     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)))
     348                          (if (not (number? prob-val))
     349                              (ode:error 'ode:hhsm-transformer "coupling probability in "
     350                                         "coupled conductance declaration " lst
     351                                         " 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                            (randomize)
     358                            (let* ((couplings
     359                                    (filter-map (lambda (x)
     360                                                  (and (<= (random 100) k) (list chain-names (car x) in-val out-val)))
     361                                                chains))
     362                                   (chains1 (fold-couplings couplings chains)))
     363                              (env-extend! (gensym 'rate) '(rate) (c+ chains1)))))))
     364
     365                       
    337366                     
    338367                     (coupling-scheme
    339                       (let* ((chain-names (map car chains))
    340                              (chains1
     368                      (let* ((couplings
    341369                              (fold (lambda (x ax)
    342370                                      (match x
    343371                                       (('coupling . alst)
    344                                         (let ((state  (lookup-field 'state alst))
     372                                        (let (
     373                                              (state  (lookup-field 'state alst))
    345374                                              (in     (lookup-field 'in alst))
    346375                                              (out    (lookup-field 'out alst)))
     
    354383                                                           "rates in coupling declaration " x " must be "
    355384                                                           "numeric constants "))
    356                                             (let ((coupling (make-coupling chain-names state in-val out-val)))
     385                                            (let ((coupling (list chain-names state in-val out-val)))
    357386                                              (cons coupling ax)))))
    358387                                       
    359388                                       (else (ode:error 'ode:hhsm-transformer
    360389                                                        "unknown coupling declaration " x))))
    361                                     (map cdr chains) coupling-scheme)))
     390                                    coupling-scheme (list)))
     391                             (chains1 (fold-couplings couplings chains)))
    362392                        (env-extend! (gensym 'rate) '(rate) (c+ chains1))))
    363393
Note: See TracChangeset for help on using the changeset viewer.