source: project/release/4/nemo/trunk/extensions/nemo-hh.scm @ 27021

Last change on this file since 27021 was 27021, checked in by Ivan Raikov, 9 years ago

nemo: bug fixes in hh and vclamp extension modules

File size: 9.3 KB
Line 
1;;
2;;
3;; An extension for specifying Hodgkin-Huxley type dynamics in NEMO
4;; systems.
5;;
6;; Copyright 2008-2011 Ivan Raikov and the Okinawa Institute of Science and Technology
7;;
8;; This program is free software: you can redistribute it and/or
9;; modify it under the terms of the GNU General Public License as
10;; published by the Free Software Foundation, either version 3 of the
11;; License, or (at your option) any later version.
12;;
13;; This program is distributed in the hope that it will be useful, but
14;; WITHOUT ANY WARRANTY; without even the implied warranty of
15;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
16;; General Public License for more details.
17;;
18;; A full copy of the GPL license can be found at
19;; <http://www.gnu.org/licenses/>.
20;;
21
22(module nemo-hh
23
24        (nemo:hh-transformer)
25
26        (import scheme chicken data-structures srfi-1 srfi-13)
27       
28        (require-extension matchable environments varsubst nemo-core)
29
30(define (s+ . lst)    (string-concatenate (map ->string lst)))
31
32(define (p$ p n) (string->symbol (s+ (->string p) "_" (->string n))))
33
34
35(define (lookup-field k lst . rest)
36  (let-optionals rest ((default #f))
37   (let ((v (alist-ref k lst)))
38     (if v (first v) default))))
39
40
41(define (check-names ion env . names)
42  (for-each (lambda (name)
43              (if (environment-includes? env name)
44                  (nemo:error 'nemo:hh-transformer "quantity " name " in ionic conductance declaration " ion
45                             "is already declared elsewhere")))
46            names))
47
48(define (check-decls ion names alst . rest)
49  (let-optionals rest ((raise-exception? #t))
50    (if raise-exception?
51        (for-each (lambda (name) 
52                    (if (not (alist-ref name alst))
53                        (nemo:error 'nemo:hh-transformer "required quantity " name 
54                                   " is not present in ionic conductance declaration " ion)))
55                  names)
56        (every (lambda (name) (alist-ref name alst)) names))))
57
58
59(define (handle thunk dflt)
60  (condition-case (thunk)
61                  [(exn) dflt]))
62
63(define (hh-ionic-gate-transform sys parse-expr subst-expr scope-subst scope eval-const env-extend! add-external! component-extend! comp en markov?)
64  (define (and-parse-expr scope-subst x . rest) 
65    (and x (subst-expr (apply parse-expr (cons x rest)) scope-subst)))
66  (match en
67         ((or (('hh 'ionic 'conductance)  ('name (? symbol? ion)) . alst)
68              (('hh-ionic-gate)    ('name (? symbol? ion)) . alst))
69
70          (check-decls ion '(m-power h-power) alst)
71
72          (let* ((suffix (->string ion))
73                 
74                 (m-inf-sym   (p$ ion 'm-inf))
75                 (m-tau-sym   (p$ ion 'm-tau))
76                 
77                 (h-inf-sym   (p$ ion 'h-inf))
78                 (h-tau-sym   (p$ ion 'h-tau))
79                 (h-reaction-sym  (p$ ion 'h))
80
81                 )
82
83            (let ((m-power (eval-const sys (subst-expr
84                                            (parse-expr (lookup-field 'm-power alst) 
85                                                        `(hh-ionic-gate ,ion (m-power))
86                                                        )
87                                            scope-subst)))
88                  (h-power (eval-const sys (subst-expr
89                                            (parse-expr (lookup-field 'h-power alst 0)
90                                                        `(hh-ionic-gate ,ion (h-power))
91                                                        )
92                                          scope-subst))))
93
94
95            (if (not (and (integer? m-power) (positive? m-power)))
96                (nemo:error 'nemo:hh-transformer 
97                           "m-power value in ionic conductance declaration " ion
98                           " must be a positive integer"))
99           
100            ;; check for required decls in m
101            (check-decls ion '(initial-m) alst)
102            (if (not (check-decls ion '(m-inf m-tau) alst #f))
103                (check-decls ion '(m-alpha m-beta) alst))
104           
105            ;; check for required decls in h
106            (if (positive? h-power) 
107                (begin (check-decls ion '(initial-h) alst)
108                       (if (not (check-decls ion '(h-inf h-tau) alst #f))
109                           (check-decls ion '(h-alpha h-beta) alst))))
110           
111            (if (not (and (integer? h-power) (or (zero? h-power) (positive? m-power))))
112                (nemo:error 'nemo:hh-transformer 
113                           "h-power value in ionic conductance declaration " ion
114                                                        " must be a positive integer"))
115
116            (let* ((initial-m  ((lambda (x) 
117                                  (let ((expr (subst-expr
118                                               (parse-expr x `(hh-ionic-gate ,ion (initial-m))) 
119                                               scope-subst)))
120                                    (handle (lambda () (eval-const sys expr)) expr)))
121                                (lookup-field 'initial-m alst)))
122                   (m-inf      (and-parse-expr scope-subst
123                                               (lookup-field 'm-inf alst)
124                                               `(hh-ionic-gate ,ion (m-inf))))
125                   (m-tau      (and-parse-expr scope-subst
126                                               (lookup-field 'm-tau alst)
127                                               `(hh-ionic-gate ,ion (m-tau))))
128                   (m-alpha    (and-parse-expr scope-subst
129                                               (lookup-field 'm-alpha alst)
130                                               `(hh-ionic-gate ,ion (m-alpha))))
131                   (m-beta     (and-parse-expr scope-subst
132                                               (lookup-field 'm-beta alst)
133                                               `(hh-ionic-gate ,ion (m-beta))))
134                   (open       'O)
135                   (closed     'C)
136                   )
137
138              (if m-inf (env-extend! m-inf-sym '(asgn) 'none `(rhs ,m-inf)))
139              (if m-tau (env-extend! m-tau-sym '(asgn) 'none `(rhs ,m-tau)))
140              (if m-inf (component-extend! comp m-inf-sym))
141              (if m-tau (component-extend! comp m-tau-sym))
142
143
144              (cond ((or (and m-alpha m-beta) (and markov? m-tau m-inf))
145                     (let* ((m-reaction-sym  (p$ ion 'm))
146                            (m-alpha    (or m-alpha
147                                            (subst-expr 
148                                             `(let ((x (/ ,m-inf-sym ,m-tau-sym))) x)
149                                             scope-subst)))
150                            (m-beta     (or m-beta
151                                            (subst-expr 
152                                             `(let ((x (/ (- 1 ,m-inf-sym) ,m-tau-sym))) x)
153                                             scope-subst)))
154                            (mst        `((power ,m-power)  (open  ,open)
155                                          (transitions (<-> ,closed ,open ,m-alpha ,m-beta))
156                                          (conserve (1 = (+ ,closed ,open))))))
157                       (apply env-extend! (cons* m-reaction-sym '(reaction) initial-m mst))
158                       (add-external! m-reaction-sym 'output)
159                       (component-extend! comp m-reaction-sym)))
160                    ((and m-tau m-inf)
161                     (let* ((m-rate-sym  (p$ ion 'm))
162                            (rate-rhs    `((power ,m-power)
163                                           (rhs  (/ (- ,m-inf-sym ,m-rate-sym) ,m-tau-sym))
164                                           )))
165                       (apply env-extend! (cons* m-rate-sym '(rate) initial-m rate-rhs))
166                       (add-external! m-rate-sym 'output)
167                       (component-extend! comp m-rate-sym)
168                       ))
169                    (else
170                     (nemo:error 'nemo:hh-transformer 
171                                 "invalid activation and inactivation rate specification in ionic conductance declaration " 
172                                 ion)))
173              )
174           
175            (if (positive? h-power)
176                (let* ((initial-h  ((lambda (x)
177                                      (let ((expr (subst-expr 
178                                                   (parse-expr x `(hh-ionic-gate ,ion (initial-h)))
179                                                   scope-subst)))
180                                        (handle (lambda () (eval-const sys expr)) expr)))
181                                    (lookup-field 'initial-h alst)))
182                       (h-inf      (and-parse-expr scope-subst
183                                                   (lookup-field 'h-inf alst)
184                                                   `(hh-ionic-gate ,ion (h-inf))))
185                       (h-tau      (and-parse-expr scope-subst
186                                                   (lookup-field 'h-tau alst)
187                                                   `(hh-ionic-gate ,ion (h-tau))))
188                       (h-alpha    (and-parse-expr scope-subst
189                                                   (lookup-field 'h-alpha alst)
190                                                   `(hh-ionic-gate ,ion (h-alpha))))
191                       (h-beta     (and-parse-expr scope-subst
192                                                   (lookup-field 'h-beta alst)
193                                                   `(hh-ionic-gate ,ion (h-beta))))
194                       (open       'O)
195                       (closed     'C))
196
197                  (if h-inf (env-extend! h-inf-sym '(asgn) 'none `(rhs ,h-inf)))
198                  (if h-tau (env-extend! h-tau-sym '(asgn) 'none `(rhs ,h-tau)))
199                  (if h-inf (component-extend! comp h-inf-sym))
200                  (if h-tau (component-extend! comp h-tau-sym))
201
202                  (cond ((or (and h-alpha h-beta) (and markov? h-tau h-inf))
203                         (let* ((h-reaction-sym  (p$ ion 'h))
204                                (h-alpha    (or h-alpha
205                                                (subst-expr 
206                                                 `(let ((x (/ ,h-inf-sym ,h-tau-sym))) x)
207                                                 scope-subst)))
208                                (h-beta     (or h-beta
209                                                (subst-expr
210                                                 `(let ((x (/ (- 1 ,h-inf-sym) ,h-tau-sym))) x)
211                                                 scope-subst)))
212                                (hst        `((power ,h-power)  (open  ,open)
213                                              (transitions (<-> ,closed ,open ,h-alpha ,h-beta))
214                                              (conserve (1 = (+ ,closed ,open))))))
215                           (apply env-extend! (cons* h-reaction-sym '(reaction) initial-h hst))
216                           (add-external! h-reaction-sym 'output)
217                           (component-extend! comp h-reaction-sym)))
218                        ((and h-tau h-inf)
219                         (let* ((h-rate-sym  (p$ ion 'h))
220                                (rate-rhs    `((power ,h-power)
221                                               (rhs (/ (- ,h-inf-sym ,h-rate-sym) ,h-tau-sym)))))
222                           (apply env-extend! (cons* h-rate-sym '(rate) initial-h rate-rhs))
223                           (add-external! h-rate-sym 'output)
224                           (component-extend! comp h-rate-sym)
225                           ))
226                        (else
227                         (nemo:error 'nemo:hh-transformer 
228                                     "invalid activation and inactivation rate specification in ionic conductance declaration " 
229                                     ion)))
230
231                  )))))
232
233         (else (list))))
234
235(define (nemo:hh-transformer sys markov? . rest)
236  (let-optionals rest ((parse-expr (lambda (x . rest) (identity x))))
237   (let ((new-sys  (nemo:env-copy sys)))
238     (match-let ((($ nemo:quantity 'DISPATCH  dis) (environment-ref new-sys (nemo-intern 'dispatch))))
239      (let* ((eval-const         (dis 'eval-const))
240             (subst-expr         (dis 'subst-expr))
241             (env-extend!        ((dis 'env-extend!) new-sys))
242             (add-external!      ((dis 'add-external!) new-sys))
243             (component-extend!  ((dis 'component-extend!) new-sys))
244             (indent  0)
245             (indent+ (+ 2 indent )))
246        (let recur ((comp-name (nemo-intern 'toplevel)) (scope #f))
247          (let* ((comp-symbols   ((dis 'component-symbols) new-sys comp-name))
248                 (subcomps       ((dis 'component-subcomps) new-sys comp-name))
249                 (scope-subst    ((dis 'component-scope-subst) new-sys comp-name)))
250            (for-each (lambda (sym)
251                        (hh-ionic-gate-transform 
252                         new-sys parse-expr subst-expr scope-subst scope
253                         (dis 'eval-const) env-extend! add-external! component-extend!
254                         comp-name (environment-ref new-sys sym) markov?))
255                      comp-symbols)
256            (for-each (lambda (subcomp) (recur subcomp (or scope subcomp))) (map third subcomps))))
257        new-sys)))))
258)
Note: See TracBrowser for help on using the repository browser.