source: project/ode/trunk/extensions/ode-hhs.scm @ 8001

Last change on this file since 8001 was 8001, checked in by Ivan Raikov, 13 years ago

Bug fixes and changes to ode-hhsm and the solvers.

File size: 7.3 KB
Line 
1;;
2;;
3;; An extension for specifying Hodgkin-Huxley type dynamics in ODE
4;; systems; an additional variable s is introduced in the conductance
5;; equation, in to order to account for dendritic slow attenuation of
6;; sodium current.
7;;
8;;
9;; For details on the attenuation state variable, see the paper:
10;;
11;; _Role of an A-Type K+ Conductance in the Back-Propagation of Action
12;; Potentials in the Dendrites of Hippocampal Pyramidal Neurons_,
13;; Migliore M.; Hoffman D.A.; Magee J.C.; Johnston D.
14;;
15;; Journal of Computational Neuroscience, Volume 7, Number 1, 8 July
16;; 1999 , pp. 5-15(11)
17;;
18;;
19;;
20;; Copyright 2007 Ivan Raikov and the Okinawa Institute of Science and Technology
21;;
22;; This program is free software: you can redistribute it and/or
23;; modify it under the terms of the GNU General Public License as
24;; published by the Free Software Foundation, either version 3 of the
25;; License, or (at your option) any later version.
26;;
27;; This program is distributed in the hope that it will be useful, but
28;; WITHOUT ANY WARRANTY; without even the implied warranty of
29;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
30;; General Public License for more details.
31;;
32;; A full copy of the GPL license can be found at
33;; <http://www.gnu.org/licenses/>.
34;;
35
36
37(require-extension srfi-1)
38(require-extension ode)
39(require-extension environments)
40
41(define s+ string-append)
42
43(define ($ p n) (string->symbol (s+ (->string p) "_" (->string n))))
44
45
46(define (lookup-field k lst . rest)
47  (let-optionals rest ((default #f))
48   (let ((v (alist-ref k lst)))
49     (if v (first v) default))))
50
51
52(define (rrhs1 suf expr alst vv)
53  (match expr 
54         ((s . es)   (or (and (symbol? s) (cons s (map (lambda (x) (rrhs1 suf x alst vv)) es))) expr))
55         (id  (or (and (symbol? id) 
56                       (let ((id1 (alist-ref id alst)))
57                         (or (and id1 (first id1))
58                             (if (member id vv) (ode:error 'rrhs "duplicate variable name during renaming: " id)
59                                 id))))  id))))
60                                                           
61
62(define (rrhs suf expr)
63  (let* ((ss '(g gbar m h gamma delta eps minf hinf sinf taum tauh taus))
64         (vv (map (lambda (x) ($ x suf)) ss)))
65    (let ((expr1 (rrhs1 suf expr (zip ss vv) vv)))
66      expr1)))
67
68(define (check-names ion env . names)
69  (for-each (lambda (name)
70              (if (environment-includes? env name)
71                  (ode:error 'ode:hhs-transformer "quantity " name " in ionic conductance declaration " ion
72                             "is already declared elsewhere")))
73            names))
74
75(define (check-decls ion names alst)
76  (for-each (lambda (name)
77              (if (not (alist-ref name alst))
78                  (ode:error 'ode:hhs-transformer "required quantity " name 
79                             " is not present in ionic conductance declaration " ion)))
80            names))
81 
82
83(define (ode:hhs-transformer sys . rest)
84  (let-optionals rest ((q? #f))
85   (let ((ode        (match (environment-ref sys (ode-intern 'odecore))
86                            (($ ode:quantity 'ODECORE value)  value)))
87         (new-env    (ode:env-copy sys #t)))
88    (let ((env-extend! ((ode 'env-extend!) new-env))
89          (eqdef!      ((ode 'eqdef!) new-env))
90          (dt          (match (environment-ref sys (ode-intern 'timestep))
91                             (($ ode:quantity 'TIMESTEP name value)  name))))
92      (environment-for-each sys 
93       (lambda (sym en)
94         (match en
95                ((or (('ionic 'conductance) ('name ion) . alst)
96                     (('ionic-conductance)  ('name ion) . alst))
97                 (check-decls ion '(gbar gamma delta minf taum) alst)
98                 (let ((suffix (->string ion)))
99                   (let ((g        ($ "g" suffix))
100                         (gbar     ($ "gbar" suffix))
101                         (m        ($ "m" suffix))
102                         (h        ($ "h" suffix))
103                         (s        ($ "s" suffix))
104                         (gamma    ($ "gamma" suffix))
105                         (delta    ($ "delta" suffix))
106                         (eps      ($ "eps" suffix))
107                         (minf     ($ "minf" suffix))
108                         (hinf     ($ "hinf" suffix))
109                         (sinf     ($ "sinf" suffix))
110                         (taum     ($ "taum" suffix))
111                         (tauh     ($ "tauh" suffix))
112                         (taus     ($ "taus" suffix)))
113                     (check-names ion new-env g gbar m h s gamma delta eps minf hinf sinf taum tauh taus)
114                     (let ((q?        (lookup-field 'q? alst))
115                           (gamma-val ((ode 'eval-const) new-env (lookup-field 'gamma alst)))
116                           (delta-val ((ode 'eval-const) new-env (lookup-field 'delta alst 0)))
117                           (eps-val   ((ode 'eval-const) new-env (lookup-field 'eps alst 0)))
118                           (gbar-val  ((ode 'eval-const) new-env (lookup-field 'gbar alst))))
119                       (if (positive? delta-val) (check-decls ion '(hinf tauh initial-h) alst))
120                       (if (positive? eps-val) (check-decls ion '(sinf taus initial-s) alst))
121                       (if (not (and (integer? gamma-val) (positive? gamma-val)))
122                           (ode:error 'ode:hhs-transformer 
123                                      "gamma value in ionic conductance declaration " ion
124                                      " must be a positive integer"))
125                       (if (not (and (integer? delta-val) (or (positive? delta-val) (zero? delta-val))))
126                           (ode:error 'ode:hhs-transformer 
127                                      "delta value in ionic conductance declaration " ion
128                                      " must be a positive integer or zero"))
129                       (if (not (and (integer? eps-val) (or (positive? eps-val) (zero? eps-val))))
130                           (ode:error 'ode:hhs-transformer 
131                                      "eps value in ionic conductance declaration " ion
132                                      " must be a positive integer or zero"))
133                       (let ((g-rhs      (append `(* ,gbar (pow ,m ,gamma))
134                                               (if (positive? delta-val) `((pow ,h ,delta)) (list))
135                                               (if (positive? eps-val)   `((pow ,s ,eps)) (list))))
136                             (m-rhs      (if q?
137                                             `(+ ,m (* (- 1 (exp (neg (/ ,dt ,taum)))) (- ,minf ,m)))
138                                             `(/ (- ,minf ,m) ,taum)))
139                             (h-rhs      (and (positive? delta-val) 
140                                              (if q?
141                                                  `(+ ,h (* (- 1 (exp (neg (/ ,dt ,tauh)))) (- ,hinf ,h)))
142                                                  `(/ (- ,hinf ,h) ,tauh))))
143                             (s-rhs      (and (positive? eps-val)   
144                                              (if q?
145                                                  `(+ ,s (* (- 1 (exp (neg (/ ,dt ,taus)))) (- ,sinf ,s)))
146                                                  `(/ (- ,sinf ,s) ,taus))))
147                             (minf-rhs   (rrhs suffix (lookup-field 'minf alst)))
148                             (hinf-rhs   (and (positive? delta-val) (rrhs suffix (lookup-field  'hinf alst))))
149                             (sinf-rhs   (and (positive? eps-val) (rrhs suffix (lookup-field  'sinf alst))))
150                             (taum-rhs   (rrhs suffix (lookup-field 'taum alst)))
151                             (tauh-rhs   (and (positive? delta-val) (rrhs suffix (lookup-field  'tauh alst))))
152                             (taus-rhs   (and (positive? eps-val) (rrhs suffix (lookup-field  'taus alst))))
153                             (initial-m  (lookup-field 'initial-m alst))
154                             (initial-h  (and (positive? delta-val) (lookup-field 'initial-h alst)))
155                             (initial-s  (and (positive? eps-val) (lookup-field 'initial-s alst))))
156                         (env-extend! g '(asgn) 'none g-rhs)
157                         (env-extend! gbar  '(const)  gbar-val)
158                         (env-extend! gamma '(const)  gamma-val)
159                         (env-extend! delta '(const)  delta-val)
160                         (env-extend! eps   '(const)  eps-val)
161                         (env-extend! minf '(asgn) 'none minf-rhs)
162                         (if (positive? delta-val) 
163                             (env-extend! hinf '(asgn) 'none hinf-rhs))
164                         (if (positive? eps-val) 
165                             (env-extend! sinf '(asgn) 'none sinf-rhs))
166                         (env-extend! taum '(asgn) 'none taum-rhs)
167                         (if (positive? delta-val)
168                               (env-extend! tauh '(asgn) 'none tauh-rhs))
169                         (if (positive? eps-val)
170                               (env-extend! taus '(asgn) 'none taus-rhs))
171                         (env-extend! m '(state) initial-m)
172                         (eqdef! m m-rhs (if q? 'q 'd))
173                         (if (positive? delta-val)
174                             (begin
175                               (env-extend! h '(state) initial-h)
176                               (eqdef! h h-rhs (if q? 'q 'd))))
177                         (if (positive? eps-val)
178                             (begin
179                               (env-extend! s '(state) initial-s)
180                               (eqdef! s s-rhs (if q? 'q 'd)))))))))
181                (else (void))))))
182      new-env)))
Note: See TracBrowser for help on using the repository browser.