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)))) |
---|