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

Last change on this file since 7357 was 7357, checked in by Ivan Raikov, 12 years ago

Miscelanneous egg updates.

File size: 7.4 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
42
43(define (sstr s)
44  (if (symbol? s) (symbol->string s) s))
45 
46(define ($ p n) (string->symbol (string-append (sstr p) "_" (sstr n))))
47
48
49(define (lookup-field k lst . rest)
50  (let-optionals rest ((default #f))
51   (let ((v (alist-ref k lst)))
52     (if v (first v) default))))
53
54
55(define (rrhs1 suf expr alst vv)
56  (match expr 
57         ((s . es)   (or (and (symbol? s) (cons s (map (lambda (x) (rrhs1 suf x alst vv)) es))) expr))
58         (id  (or (and (symbol? id) 
59                       (let ((id1 (alist-ref id alst)))
60                         (or (and id1 (first id1))
61                             (if (member id vv) (ode:error 'rrhs "duplicate variable name during renaming: " id)
62                                 id))))  id))))
63                                                           
64
65(define (rrhs suf expr)
66  (let* ((ss '(g gbar m h gamma delta eps minf hinf sinf taum tauh taus))
67         (vv (map (lambda (x) ($ x suf)) ss)))
68    (let ((expr1 (rrhs1 suf expr (zip ss vv) vv)))
69      expr1)))
70
71(define (check-names ion env . names)
72  (for-each (lambda (name)
73              (if (environment-includes? env name)
74                  (ode:error 'ode:hhs-transformer "quantity " name " in ionic conductance declaration " ion
75                             "is already declared elsewhere")))
76            names))
77
78(define (check-decls ion names alst)
79  (for-each (lambda (name)
80              (if (not (alist-ref name alst))
81                  (ode:error 'ode:hhs-transformer "required quantity " name 
82                             " is not present in ionic conductance declaration " ion)))
83            names))
84 
85
86(define (ode:hhs-transformer sys . rest)
87  (let-optionals rest ((q? #f))
88   (let ((ode        (match (environment-ref sys (ode-intern 'odecore))
89                            (($ ode:quantity 'ODECORE value)  value)))
90         (new-env    (ode:env-copy sys #t)))
91    (let ((env-extend! ((ode 'env-extend!) new-env))
92          (eqdef!      ((ode 'eqdef!) new-env))
93          (dt          (match (environment-ref sys (ode-intern 'timestep))
94                             (($ ode:quantity 'TIMESTEP name value)  name))))
95      (environment-for-each sys 
96       (lambda (sym en)
97         (match en
98                ((or (('ionic 'conductance) ('name ion) . alst)
99                     (('ionic-conductance)  ('name ion) . alst))
100                 (check-decls ion '(gbar gamma delta minf taum) alst)
101                 (let ((suffix (sstr ion)))
102                   (let ((g        ($ "g" suffix))
103                         (gbar     ($ "gbar" suffix))
104                         (m        ($ "m" suffix))
105                         (h        ($ "h" suffix))
106                         (s        ($ "s" suffix))
107                         (gamma    ($ "gamma" suffix))
108                         (delta    ($ "delta" suffix))
109                         (eps      ($ "eps" suffix))
110                         (minf     ($ "minf" suffix))
111                         (hinf     ($ "hinf" suffix))
112                         (sinf     ($ "sinf" suffix))
113                         (taum     ($ "taum" suffix))
114                         (tauh     ($ "tauh" suffix))
115                         (taus     ($ "taus" suffix)))
116                     (check-names ion new-env g gbar m h s gamma delta eps minf hinf sinf taum tauh taus)
117                     (let ((q?        (lookup-field 'q? alst))
118                           (gamma-val ((ode 'eval-const) new-env (lookup-field 'gamma alst)))
119                           (delta-val ((ode 'eval-const) new-env (lookup-field 'delta alst 0)))
120                           (eps-val   ((ode 'eval-const) new-env (lookup-field 'eps alst 0)))
121                           (gbar-val  ((ode 'eval-const) new-env (lookup-field 'gbar alst))))
122                       (if (positive? delta-val) (check-decls ion '(hinf tauh initial-h) alst))
123                       (if (positive? eps-val) (check-decls ion '(sinf taus initial-s) alst))
124                       (if (not (and (integer? gamma-val) (positive? gamma-val)))
125                           (ode:error 'ode:hhs-transformer 
126                                      "gamma value in ionic conductance declaration " ion
127                                      " must be a positive integer"))
128                       (if (not (and (integer? delta-val) (or (positive? delta-val) (zero? delta-val))))
129                           (ode:error 'ode:hhs-transformer 
130                                      "delta value in ionic conductance declaration " ion
131                                      " must be a positive integer or zero"))
132                       (if (not (and (integer? eps-val) (or (positive? eps-val) (zero? eps-val))))
133                           (ode:error 'ode:hhs-transformer 
134                                      "eps value in ionic conductance declaration " ion
135                                      " must be a positive integer or zero"))
136                       (let ((g-rhs      (append `(* ,gbar (pow ,m ,gamma))
137                                               (if (positive? delta-val) `((pow ,h ,delta)) (list))
138                                               (if (positive? eps-val)   `((pow ,s ,eps)) (list))))
139                             (m-rhs      (if q?
140                                             `(+ ,m (* (- 1 (exp (neg (/ ,dt ,taum)))) (- ,minf ,m)))
141                                             `(/ (- ,minf ,m) ,taum)))
142                             (h-rhs      (and (positive? delta-val) 
143                                              (if q?
144                                                  `(+ ,h (* (- 1 (exp (neg (/ ,dt ,tauh)))) (- ,hinf ,h)))
145                                                  `(/ (- ,hinf ,h) ,tauh))))
146                             (s-rhs      (and (positive? eps-val)   
147                                              (if q?
148                                                  `(+ ,s (* (- 1 (exp (neg (/ ,dt ,taus)))) (- ,sinf ,s)))
149                                                  `(/ (- ,sinf ,s) ,taus))))
150                             (minf-rhs   (rrhs suffix (lookup-field 'minf alst)))
151                             (hinf-rhs   (and (positive? delta-val) (rrhs suffix (lookup-field  'hinf alst))))
152                             (sinf-rhs   (and (positive? eps-val) (rrhs suffix (lookup-field  'sinf alst))))
153                             (taum-rhs   (rrhs suffix (lookup-field 'taum alst)))
154                             (tauh-rhs   (and (positive? delta-val) (rrhs suffix (lookup-field  'tauh alst))))
155                             (taus-rhs   (and (positive? eps-val) (rrhs suffix (lookup-field  'taus alst))))
156                             (initial-m  (lookup-field 'initial-m alst))
157                             (initial-h  (and (positive? delta-val) (lookup-field 'initial-h alst)))
158                             (initial-s  (and (positive? eps-val) (lookup-field 'initial-s alst))))
159                         (env-extend! g '(asgn) 'none g-rhs)
160                         (env-extend! gbar  '(const)  gbar-val)
161                         (env-extend! gamma '(const)  gamma-val)
162                         (env-extend! delta '(const)  delta-val)
163                         (env-extend! eps   '(const)  eps-val)
164                         (env-extend! minf '(asgn) 'none minf-rhs)
165                         (if (positive? delta-val) 
166                             (env-extend! hinf '(asgn) 'none hinf-rhs))
167                         (if (positive? eps-val) 
168                             (env-extend! sinf '(asgn) 'none sinf-rhs))
169                         (env-extend! taum '(asgn) 'none taum-rhs)
170                         (if (positive? delta-val)
171                               (env-extend! tauh '(asgn) 'none tauh-rhs))
172                         (if (positive? eps-val)
173                               (env-extend! taus '(asgn) 'none taus-rhs))
174                         (env-extend! m '(state) initial-m)
175                         (eqdef! m m-rhs (if q? 'q 'd))
176                         (if (positive? delta-val)
177                             (begin
178                               (env-extend! h '(state) initial-h)
179                               (eqdef! h h-rhs (if q? 'q 'd))))
180                         (if (positive? eps-val)
181                             (begin
182                               (env-extend! s '(state) initial-s)
183                               (eqdef! s s-rhs (if q? 'q 'd)))))))))
184                (else (void))))))
185      new-env)))
Note: See TracBrowser for help on using the repository browser.