| 1 | ;; |
|---|
| 2 | ;; |
|---|
| 3 | ;; Procedures for querying ion channel descriptions in NEMO models. |
|---|
| 4 | ;; |
|---|
| 5 | ;; Copyright 2008-2012 Ivan Raikov and the Okinawa Institute of Science and Technology |
|---|
| 6 | ;; |
|---|
| 7 | ;; This program is free software: you can redistribute it and/or |
|---|
| 8 | ;; modify it under the terms of the GNU General Public License as |
|---|
| 9 | ;; published by the Free Software Foundation, either version 3 of the |
|---|
| 10 | ;; License, or (at your option) any later version. |
|---|
| 11 | ;; |
|---|
| 12 | ;; This program is distributed in the hope that it will be useful, but |
|---|
| 13 | ;; WITHOUT ANY WARRANTY; without even the implied warranty of |
|---|
| 14 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
|---|
| 15 | ;; General Public License for more details. |
|---|
| 16 | ;; |
|---|
| 17 | ;; A full copy of the GPL license can be found at |
|---|
| 18 | ;; <http://www.gnu.org/licenses/>. |
|---|
| 19 | ;; |
|---|
| 20 | |
|---|
| 21 | (module nemo-gate-complex |
|---|
| 22 | |
|---|
| 23 | (nemo:ion-pool-query |
|---|
| 24 | nemo:gate-complex-query) |
|---|
| 25 | |
|---|
| 26 | (import scheme chicken srfi-1 srfi-13) |
|---|
| 27 | |
|---|
| 28 | (require-extension environments matchable nemo-core nemo-utils) |
|---|
| 29 | |
|---|
| 30 | (define (cid x) (second x)) |
|---|
| 31 | (define (cn x) (first x)) |
|---|
| 32 | |
|---|
| 33 | |
|---|
| 34 | (define (ispool? x) |
|---|
| 35 | (match x (('decaying-pool name id) id) (('decaying 'pool name id) id) |
|---|
| 36 | (else #f))) |
|---|
| 37 | |
|---|
| 38 | (define (nemo:ion-pool-query sys) |
|---|
| 39 | (match-let ((($ nemo:quantity 'DISPATCH dis) (environment-ref sys (nemo-intern 'dispatch)))) |
|---|
| 40 | (let recur ((comp-name (nemo-intern 'toplevel)) (ax (list))) |
|---|
| 41 | (let ((subcomps ((dis 'component-subcomps) sys comp-name))) |
|---|
| 42 | (let-values (((epool-comps other-comps) (partition ispool? subcomps))) |
|---|
| 43 | (let ((epools (map (lambda (x) |
|---|
| 44 | (let ((exports ((dis 'component-exports) sys (third x)))) |
|---|
| 45 | (if (null? exports) |
|---|
| 46 | (nemo:error 'nemo:epool-query |
|---|
| 47 | ": ion pool component " (third x) |
|---|
| 48 | " must export a state")) |
|---|
| 49 | `(,@(cdr x) ,(car exports)))) |
|---|
| 50 | epool-comps))) |
|---|
| 51 | (fold recur (append epools ax) (map third other-comps)))))))) |
|---|
| 52 | |
|---|
| 53 | (define (nemo:gate-complex-query sys . rest) |
|---|
| 54 | (let-optionals rest ((ionic-current-name (lambda (ion-name) (s+ 'i ion-name))) |
|---|
| 55 | (rev-potential-name (lambda (ion-name) (s+ 'e ion-name ))) |
|---|
| 56 | (in-concentration-name (lambda (ion-name) (s+ ion-name 'i))) |
|---|
| 57 | (out-concentration-name (lambda (ion-name) (s+ ion-name 'o)))) |
|---|
| 58 | |
|---|
| 59 | (match-let ((($ nemo:quantity 'DISPATCH dis) (environment-ref sys (nemo-intern 'dispatch)))) |
|---|
| 60 | (let ((imports ((dis 'imports) sys)) |
|---|
| 61 | (exports ((dis 'exports) sys))) |
|---|
| 62 | (let* ((consts ((dis 'consts) sys)) |
|---|
| 63 | (asgns ((dis 'asgns) sys)) |
|---|
| 64 | (states ((dis 'states) sys)) |
|---|
| 65 | (reactions ((dis 'reactions) sys)) |
|---|
| 66 | (rates ((dis 'rates) sys)) |
|---|
| 67 | (defuns ((dis 'defuns) sys)) |
|---|
| 68 | (components ((dis 'components) sys)) |
|---|
| 69 | (gate-complexes (filter-map (match-lambda |
|---|
| 70 | ((name 'gate-complex id) (list name id)) |
|---|
| 71 | ((name 'ion-channel id) (list name id)) |
|---|
| 72 | (else #f)) components)) |
|---|
| 73 | (ion-pools (nemo:ion-pool-query sys)) |
|---|
| 74 | |
|---|
| 75 | (perm-ions (fold (lambda (gate-complex ax) |
|---|
| 76 | (let* ((subcomps ((dis 'component-subcomps) sys (cid gate-complex))) |
|---|
| 77 | (perm (lookup-def 'permeating-ion subcomps))) |
|---|
| 78 | (cond (perm |
|---|
| 79 | (case (cn perm) |
|---|
| 80 | ((non-specific) |
|---|
| 81 | (let* ((erev (car ((dis 'component-exports) sys (cid perm)))) |
|---|
| 82 | (i 'i) (e 'e)) |
|---|
| 83 | (cons `(,(cn perm) ,i ,e ,erev) ax))) |
|---|
| 84 | (else (let* ((erev ((lambda (x) (and (pair? x) (car x))) ((dis 'component-exports) sys (cid perm)))) |
|---|
| 85 | (i (ionic-current-name (cn perm))) |
|---|
| 86 | (e (rev-potential-name (cn perm)))) |
|---|
| 87 | (cons `(,(cn perm) ,i ,e ,erev) ax))))) |
|---|
| 88 | (else ax)))) |
|---|
| 89 | (list) gate-complexes)) |
|---|
| 90 | |
|---|
| 91 | (perm-ions (fold (lambda (gate-complex ax) |
|---|
| 92 | (let* ((subcomps ((dis 'component-subcomps) sys (cid gate-complex))) |
|---|
| 93 | (bingate (lookup-def 'binary-gate subcomps))) |
|---|
| 94 | (cond |
|---|
| 95 | (bingate |
|---|
| 96 | (cons `(non-specific i e #f) ax)) |
|---|
| 97 | (else ax)))) |
|---|
| 98 | perm-ions gate-complexes)) |
|---|
| 99 | |
|---|
| 100 | (acc-ions (fold (lambda (gate-complex ax) |
|---|
| 101 | (let* ((subcomps ((dis 'component-subcomps) sys (cid gate-complex))) |
|---|
| 102 | (acc (lookup-def 'accumulating-substance subcomps)) |
|---|
| 103 | (i (and acc (ionic-current-name (cn acc)))) |
|---|
| 104 | (in (and acc (in-concentration-name (cn acc)))) |
|---|
| 105 | (out (and acc (out-concentration-name (cn acc))))) |
|---|
| 106 | (if acc (cons `(,(cn acc) ,i ,in ,out) ax) ax))) |
|---|
| 107 | (list) gate-complexes)) |
|---|
| 108 | |
|---|
| 109 | (pool-ions (map (lambda (ep) |
|---|
| 110 | (let* ((ion (first ep)) |
|---|
| 111 | (state (third ep)) |
|---|
| 112 | (i (ionic-current-name ion)) |
|---|
| 113 | (in (in-concentration-name ion))) |
|---|
| 114 | `(,state ,i ,in ,ion))) |
|---|
| 115 | ion-pools)) |
|---|
| 116 | |
|---|
| 117 | (i-gates (fold (lambda (gate-complex ax) |
|---|
| 118 | (let* ((subcomps ((dis 'component-subcomps) sys (cid gate-complex))) |
|---|
| 119 | (i-gate-comp (lookup-def 'binary-gate subcomps))) |
|---|
| 120 | (if i-gate-comp |
|---|
| 121 | (let* ((i-gate-exps ((dis 'component-exports) sys (cid i-gate-comp))) |
|---|
| 122 | (asgn-names asgns) |
|---|
| 123 | (i-gate-var (find (lambda (x) (member x asgn-names)) |
|---|
| 124 | i-gate-exps))) |
|---|
| 125 | (if (not i-gate-var) |
|---|
| 126 | (nemo:error 'nemo:gate-complex-query |
|---|
| 127 | ": binary gate in gate complex " (cn gate-complex) |
|---|
| 128 | " must export an assignment")) |
|---|
| 129 | (cons (list i-gate-var (cn i-gate-comp) ) ax)) |
|---|
| 130 | ax))) |
|---|
| 131 | (list) gate-complexes))) |
|---|
| 132 | |
|---|
| 133 | (for-each |
|---|
| 134 | (lambda (a) |
|---|
| 135 | (let ((acc-ion (car a))) |
|---|
| 136 | (if (assoc acc-ion perm-ions) |
|---|
| 137 | (nemo:error 'nemo:gate-complex-query |
|---|
| 138 | ": ion species " acc-ion " cannot be declared as both accumulating and permeating")))) |
|---|
| 139 | acc-ions) |
|---|
| 140 | |
|---|
| 141 | (for-each |
|---|
| 142 | (lambda (p) |
|---|
| 143 | (let ((pool-ion (car p))) |
|---|
| 144 | (if (assoc pool-ion perm-ions) |
|---|
| 145 | (nemo:error 'nemo:gate-complex-query |
|---|
| 146 | ": ion species " pool-ion " cannot be declared as both pool and permeating")))) |
|---|
| 147 | pool-ions) |
|---|
| 148 | |
|---|
| 149 | `((gate-complexes ,gate-complexes) |
|---|
| 150 | (perm-ions ,perm-ions) |
|---|
| 151 | (acc-ions ,acc-ions) |
|---|
| 152 | (pool-ions ,pool-ions) |
|---|
| 153 | (i-gates ,i-gates) |
|---|
| 154 | )))))) |
|---|
| 155 | |
|---|
| 156 | ) |
|---|
