source: project/release/3/nemo/trunk/extensions/nemo-hh.scm @ 11977

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

Bug fixes.

File size: 5.7 KB
Line 
1;;
2;;
3;; An extension for specifying Hodgkin-Huxley type dynamics in NeuroML
4;; systems
5;;
6;; Copyright 2008 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
23(require-extension syntax-case)
24(require-extension matchable)
25(require-extension srfi-1)
26(require-extension srfi-13)
27(require-extension nemo-core)
28(require-extension environments)
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-conductance-transform sys eval-const env-extend! add-external! component-extend! comp en)
64  (match en
65         ((or (('hh 'ionic 'conductance)  ('name (? symbol? ion)) . alst)
66              (('hh-ionic-conductance)    ('name (? symbol? ion)) . alst))
67          (check-decls ion '(m-power h-power) alst)
68          (let ((suffix (->string ion))
69                (m-power (eval-const sys (lookup-field 'm-power alst)))
70                (h-power (eval-const sys (lookup-field 'h-power alst 0))))
71           
72            (if (not (and (integer? m-power) (positive? m-power)))
73                (nemo:error 'nemo:hh-transformer 
74                           "m-power value in ionic conductance declaration " ion
75                           " must be a positive integer"))
76           
77            ;; check for required decls in m
78            (check-decls ion '(initial-m) alst)
79            (if (not (check-decls ion '(m-inf m-tau) alst #f))
80                (check-decls ion '(m-alpha m-beta) alst))
81           
82            ;; check for required decls in h
83            (if (positive? h-power) 
84                (begin (check-decls ion '(initial-h) alst)
85                       (if (not (check-decls ion '(h-inf h-tau) alst #f))
86                           (check-decls ion '(h-alpha h-beta) alst))))
87           
88            (if (not (and (integer? h-power) (or (zero? h-power) (positive? m-power))))
89                (nemo:error 'nemo:hh-transformer 
90                           "h-power value in ionic conductance declaration " ion
91                                                        " must be a positive integer"))
92                                         
93            (let* ((initial-m  ((lambda (x) (handle (lambda () (eval-const sys x)) x))
94                                (lookup-field 'initial-m alst)))
95                   (m-inf      (lookup-field 'm-inf alst))
96                   (m-tau      (lookup-field 'm-tau alst))
97                   (m-alpha    (or (lookup-field 'm-alpha alst)  `(/ ,m-inf ,m-tau)))
98                   (m-beta     (or (lookup-field 'm-beta alst)   `(/ (- 1 ,m-inf) ,m-tau)))
99                   (open       (p$ ion 'mO))
100                   (closed     (p$ ion 'mC))
101                   (mst        `((power ,m-power)  (open  ,open)
102                                 (transitions (-> ,closed ,open ,m-alpha) 
103                                              (-> ,open ,closed ,m-beta)))))
104              (apply env-extend! (cons* (p$ ion 'm) '(tscomp) initial-m mst))
105              (add-external! (p$ ion 'm) 'output)
106              (component-extend! comp (p$ ion 'm))
107              )
108           
109            (if (positive? h-power)
110                (let* ((initial-h  ((lambda (x) (handle (lambda () (eval-const sys x)) x))
111                                    (lookup-field 'initial-h alst)))
112                       (h-inf      (lookup-field 'h-inf alst))
113                       (h-tau      (lookup-field 'h-tau alst))
114                       (h-alpha    (or (lookup-field 'h-alpha alst)
115                                       `(/ ,h-inf ,h-tau)))
116                       (h-beta     (or (lookup-field 'h-beta alst)
117                                       `(/ (- 1 ,h-inf) ,h-tau)))
118
119                       (open       (p$ ion 'hO))
120                       (closed     (p$ ion 'hC))
121                       (hst        `((power ,h-power)
122                                     (open  ,open)
123                                     (transitions (-> ,closed ,open ,h-alpha) 
124                                                  (-> ,open ,closed ,h-beta)))))
125                  (apply env-extend! (cons* (p$ ion 'h) '(tscomp) initial-h hst))
126                  (add-external! (p$ ion 'h) 'output)
127                  (component-extend! comp (p$ ion 'h))
128                  ))))
129         (else (list))))
130
131(define (nemo:hh-transformer sys . rest)
132  (let ((new-sys  (nemo:env-copy sys)))
133   (match-let ((($ nemo:quantity 'DISPATCH  dis) (environment-ref new-sys (nemo-intern 'dispatch))))
134     (let* ((eval-const         (dis 'eval-const))
135            (env-extend!        ((dis 'env-extend!) new-sys))
136            (add-external!      ((dis 'add-external!) new-sys))
137            (component-extend!  ((dis 'component-extend!) new-sys))
138            (indent  0)
139            (indent+ (+ 2 indent )))
140       (let recur ((comp-name (nemo-intern 'toplevel)))
141         (let* ((comp-symbols   ((dis 'component-symbols) new-sys comp-name))
142                (subcomps       ((dis 'component-subcomps) new-sys comp-name)))
143           (print "comp-name: " comp-name)
144           (print "comp-symbols: " comp-symbols)
145            (for-each (lambda (sym)
146                        (hh-ionic-conductance-transform 
147                         new-sys (dis 'eval-const) env-extend! add-external! component-extend!
148                         comp-name (environment-ref new-sys sym)))
149                      comp-symbols)
150            (for-each recur (map second subcomps))))
151       new-sys))))
Note: See TracBrowser for help on using the repository browser.