Changeset 12624 in project


Ignore:
Timestamp:
11/28/08 03:04:46 (11 years ago)
Author:
Ivan Raikov
Message:

Factoring out the code for creating graph representation of the kinetic equations.

Location:
release/3/nemo/trunk
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • release/3/nemo/trunk/nemo-matlab.scm

    r12567 r12624  
    2828(require-extension lolevel)
    2929(require-extension varsubst)
    30 (require-extension digraph)
    3130(require-extension datatype)
    3231
     
    245244
    246245(define (state-eqs n initial open transitions power)
    247   (let* ((subst-convert  (subst-driver (lambda (x) (and (symbol? x) x)) binding? identity bind subst-term))
    248          (g          (make-digraph n (string-append (->string n) " transitions graph")))
    249          (add-node!  (g 'add-node!))
    250          (add-edge!  (g 'add-edge!))
    251          (out-edges  (g 'out-edges))
    252          (in-edges   (g 'in-edges))
    253          (node-info  (g 'node-info))
    254          (node-list  (let loop ((lst (list)) (tlst transitions))
    255                        (if (null? tlst)  (delete-duplicates lst eq?)
    256                            (match (car tlst)
    257                                   (('-> (and (? symbol?) s0) (and (? symbol?) s1) rate-expr)
    258                                    (loop (cons* s0 s1 lst) (cdr tlst)))
    259                                   (((and (? symbol?) s0) '-> (and (? symbol? s1)) rate-expr)
    260                                    (loop (cons* s0 s1 lst) (cdr tlst)))
    261                                   (('<-> (and (? symbol?) s0) (and (? symbol?) s1) rate-expr1 rate-expr2)
    262                                    (loop (cons* s0 s1 lst) (cdr tlst)))
    263                                   (((and (? symbol?) s0) 'M-> (and (? symbol? s1)) rate-expr1 rate-expr2)
    264                                    (loop (cons* s0 s1 lst) (cdr tlst)))
    265                                   (else
    266                                    (nemo:error 'nemo:matlab-state-eqs ": invalid transition equation "
    267                                                   (car tlst) " in state complex " n))
    268                                   (else (loop lst (cdr tlst)))))))
    269          (node-ids      (list-tabulate (length node-list) identity))
    270          (name->id-map  (zip node-list node-ids))
    271          (node-subs     (fold (lambda (s ax) (subst-extend s (matlab-state-name n s) ax)) subst-empty node-list)))
    272     ;; insert state nodes in the dependency graph
    273     (for-each (lambda (i n) (add-node! i n)) node-ids node-list)
    274     (let* ((nodes  ((g 'nodes)))
    275            (snode   (find (lambda (s) (not (eq? (second s) open))) nodes))
    276            (snex   `(- 1 ,(sum (filter-map (lambda (s) (and (not (= (first s) (first snode))) (second s))) nodes))))
    277            (add-tredge (lambda (s0 s1 rexpr1 rexpr2)
    278                          (let ((i   (car (alist-ref s0 name->id-map)))
    279                                (j   (car (alist-ref s1 name->id-map)))
    280                                (x0  (if (eq? s0 (second snode)) snex s0))
    281                                (x1  (if (eq? s1 (second snode)) snex s1)))
    282                            (add-edge! (list i j `(* ,(subst-convert x0 node-subs)
    283                                                     ,(subst-convert rexpr1 node-subs))))
    284                            (if rexpr2 (add-edge! (list j i `(* ,(subst-convert x1 node-subs)
    285                                                                ,(subst-convert rexpr2 node-subs)))))))))
    286       ;; create rate edges in the graph
    287       (for-each (lambda (e)
    288                   (match e
    289                          (('-> s0 s1 rexpr)  (add-tredge s0 s1 rexpr #f))
    290                          ((s0 '-> s1 rexpr)  (add-tredge s0 s1 rexpr #f))
    291                          (('<-> s0 s1 rexpr1 rexpr2)  (add-tredge s0 s1 rexpr1 rexpr2))
    292                          ((s0 '<-> s1 rexpr1 rexpr2)  (add-tredge s0 s1 rexpr1 rexpr2))
    293                          ))
    294                 transitions)
    295 
     246  (match-let (((g  node-subs)  (transitions-graph n open transitions matlab-state-name)))
     247     (let* ((out-edges  (g 'out-edges))
     248            (in-edges   (g 'in-edges))
     249            (nodes      ((g 'nodes)))
     250            (snode      (find (lambda (s) (not (eq? (second s) open))) nodes)))
    296251      ;; generate differential equations for each state in the transitions system
    297252      (let ((eqs    (fold (lambda (s ax)
     
    308263                                                      ((and (null? out) (not (null? in)))
    309264                                                       (sum (map third in)))))
    310                                          (fbody  (rhsexpr/MATLAB rhs1))
    311                                          (fbody1 (canonicalize-expr/MATLAB fbody)))
     265                                         (fbody0  (rhsexpr/MATLAB rhs1))
     266                                         (fbody1  (canonicalize-expr/MATLAB fbody0)))
    312267                                    (cons (list name  fbody1) ax)))))
    313268                          (list) nodes)))
    314269        eqs))))
    315            
    316        
    317270
    318271
     
    702655
    703656             (let* ((init-defs         (poset->state-init-defs poset sys)))
    704 ;;                  (init-eq-defs      (poset->state-init-eq-defs poset sys)))
    705657
    706658               (pp indent+ (y0 = zeros(,(length state-index-map) #\, 1) #\;))
     
    728680                         init-defs)
    729681
    730 #|
    731                (for-each
    732                 (lambda (x)
    733                   (let ((lineqs  (second x)))
    734                     (for-each (lambda (eq)
    735                                 (let ((val  (first eq))
    736                                       (expr (third eq)))
    737                                   (pp indent+ ,(lineq->string/NMODL expr val))))
    738                               lineqs)))
    739                 init-eq-defs)
    740 |#
    741682
    742683               )
  • release/3/nemo/trunk/nemo-nmodl.scm

    r12558 r12624  
    2828(require-extension lolevel)
    2929(require-extension varsubst)
    30 (require-extension digraph)
    3130(require-extension datatype)
    3231
     
    378377
    379378(define (state-eqs n initial open transitions power method)
    380   (let* ((subst-convert  (subst-driver (lambda (x) (and (symbol? x) x)) binding? identity bind subst-term))
    381          (g          (make-digraph n (string-append (->string n) " transitions graph")))
    382          (add-node!  (g 'add-node!))
    383          (add-edge!  (g 'add-edge!))
    384          (out-edges  (g 'out-edges))
    385          (in-edges   (g 'in-edges))
    386          (node-info  (g 'node-info))
    387          (node-list  (let loop ((lst (list)) (tlst transitions))
    388                        (if (null? tlst)  (delete-duplicates lst eq?)
    389                            (match (car tlst)
    390                                   (('-> (and (? symbol?) s0) (and (? symbol?) s1) rate-expr)
    391                                    (loop (cons* s0 s1 lst) (cdr tlst)))
    392                                   (((and (? symbol?) s0) '-> (and (? symbol? s1)) rate-expr)
    393                                    (loop (cons* s0 s1 lst) (cdr tlst)))
    394                                   (('<-> (and (? symbol?) s0) (and (? symbol?) s1) rate-expr1 rate-expr2)
    395                                    (loop (cons* s0 s1 lst) (cdr tlst)))
    396                                   (((and (? symbol?) s0) 'M-> (and (? symbol? s1)) rate-expr1 rate-expr2)
    397                                    (loop (cons* s0 s1 lst) (cdr tlst)))
    398                                   (else
    399                                    (nemo:error 'nemo:nmodl-state-eqs ": invalid transition equation "
    400                                                   (car tlst) " in state complex " n))
    401                                   (else (loop lst (cdr tlst)))))))
    402          (node-ids      (list-tabulate (length node-list) identity))
    403          (name->id-map  (zip node-list node-ids))
    404          (node-subs     (fold (lambda (s ax) (subst-extend s (nmodl-state-name n s) ax)) subst-empty node-list)))
    405     ;; insert state nodes in the dependency graph
    406     (for-each (lambda (i n) (add-node! i n)) node-ids node-list)
    407     (let* ((nodes  ((g 'nodes)))
    408            (snode   (find (lambda (s) (not (eq? (second s) open))) nodes))
    409            (snex   `(- 1 ,(sum (filter-map (lambda (s) (and (not (= (first s) (first snode))) (second s))) nodes))))
    410            (add-tredge (lambda (s0 s1 rexpr1 rexpr2)
    411                          (let ((i   (car (alist-ref s0 name->id-map)))
    412                                (j   (car (alist-ref s1 name->id-map)))
    413                                (x0  (if (eq? s0 (second snode)) snex s0))
    414                                (x1  (if (eq? s1 (second snode)) snex s1)))
    415                            (add-edge! (list i j `(* ,(subst-convert x0 node-subs)
    416                                                     ,(subst-convert rexpr1 node-subs))))
    417                            (if rexpr2 (add-edge! (list j i `(* ,(subst-convert x1 node-subs)
    418                                                                ,(subst-convert rexpr2 node-subs)))))))))
    419       ;; create rate edges in the graph
    420       (for-each (lambda (e)
    421                   (match e
    422                          (('-> s0 s1 rexpr)  (add-tredge s0 s1 rexpr #f))
    423                          ((s0 '-> s1 rexpr)  (add-tredge s0 s1 rexpr #f))
    424                          (('<-> s0 s1 rexpr1 rexpr2)  (add-tredge s0 s1 rexpr1 rexpr2))
    425                          ((s0 '<-> s1 rexpr1 rexpr2)  (add-tredge s0 s1 rexpr1 rexpr2))
    426                          ))
    427                 transitions)
    428 
    429       ;; generate differential equations for each state in the transitions system
     379  (match-let (((g  node-subs)  (transitions-graph n open transitions nmodl-state-name)))
     380     (let* ((out-edges  (g 'out-edges))
     381            (in-edges   (g 'in-edges))
     382            (nodes   ((g 'nodes)))
     383            (snode   (find (lambda (s) (not (eq? (second s) open))) nodes)))
     384       ;; generate differential equations for each state in the transitions system
    430385      (let ((eqs    (fold (lambda (s ax)
    431386                            (if (= (first snode) (first s) ) ax
  • release/3/nemo/trunk/nemo-utils.scm

    r12556 r12624  
    2626(require-extension srfi-13)
    2727(require-extension varsubst)
     28(require-extension digraph)
    2829
    2930(define-extension nemo-utils)
     
    3738          if-convert let-enum let-elim let-lift
    3839          s+ sw+ sl\ nl spaces ppf
     40          transitions-graph
    3941          ))
     42
     43
    4044
    4145(define (lookup-def k lst . rest)
     
    152156                              (else   (print sp (if (list? x) (sw+ x) x))))))
    153157              lst)))
     158
     159
     160(define (transitions-graph n open transitions state-name)
     161  (let* ((subst-convert  (subst-driver (lambda (x) (and (symbol? x) x)) binding? identity bind subst-term))
     162         (g          (make-digraph n (string-append (->string n) " transitions graph")))
     163         (add-node!  (g 'add-node!))
     164         (add-edge!  (g 'add-edge!))
     165         (out-edges  (g 'out-edges))
     166         (in-edges   (g 'in-edges))
     167         (node-info  (g 'node-info))
     168         (node-list  (let loop ((lst (list)) (tlst transitions))
     169                       (if (null? tlst)  (delete-duplicates lst eq?)
     170                           (match (car tlst)
     171                                  (('-> (and (? symbol?) s0) (and (? symbol?) s1) rate-expr)
     172                                   (loop (cons* s0 s1 lst) (cdr tlst)))
     173                                  (((and (? symbol?) s0) '-> (and (? symbol? s1)) rate-expr)
     174                                   (loop (cons* s0 s1 lst) (cdr tlst)))
     175                                  (('<-> (and (? symbol?) s0) (and (? symbol?) s1) rate-expr1 rate-expr2)
     176                                   (loop (cons* s0 s1 lst) (cdr tlst)))
     177                                  (((and (? symbol?) s0) 'M-> (and (? symbol? s1)) rate-expr1 rate-expr2)
     178                                   (loop (cons* s0 s1 lst) (cdr tlst)))
     179                                  (else
     180                                   (nemo:error 'state-eqs ": invalid transition equation "
     181                                                  (car tlst) " in state complex " n))
     182                                  (else (loop lst (cdr tlst)))))))
     183         (node-ids      (list-tabulate (length node-list) identity))
     184         (name->id-map  (zip node-list node-ids))
     185         (node-subs     (fold (lambda (s ax) (subst-extend s (state-name n s) ax)) subst-empty node-list)))
     186    ;; insert state nodes in the dependency graph
     187    (for-each (lambda (i n) (add-node! i n)) node-ids node-list)
     188    (let* ((nodes  ((g 'nodes)))
     189           (snode   (find (lambda (s) (not (eq? (second s) open))) nodes))
     190           (snex   `(- 1 ,(sum (filter-map (lambda (s) (and (not (= (first s) (first snode))) (second s))) nodes))))
     191           (add-tredge (lambda (s0 s1 rexpr1 rexpr2)
     192                         (let ((i   (car (alist-ref s0 name->id-map)))
     193                               (j   (car (alist-ref s1 name->id-map)))
     194                               (x0  (if (eq? s0 (second snode)) snex s0))
     195                               (x1  (if (eq? s1 (second snode)) snex s1)))
     196                           (add-edge! (list i j `(* ,(subst-convert x0 node-subs)
     197                                                    ,(subst-convert rexpr1 node-subs))))
     198                           (if rexpr2 (add-edge! (list j i `(* ,(subst-convert x1 node-subs)
     199                                                               ,(subst-convert rexpr2 node-subs)))))))))
     200      ;; create rate edges in the graph
     201      (for-each (lambda (e)
     202                  (match e
     203                         (('-> s0 s1 rexpr)  (add-tredge s0 s1 rexpr #f))
     204                         ((s0 '-> s1 rexpr)  (add-tredge s0 s1 rexpr #f))
     205                         (('<-> s0 s1 rexpr1 rexpr2)  (add-tredge s0 s1 rexpr1 rexpr2))
     206                         ((s0 '<-> s1 rexpr1 rexpr2)  (add-tredge s0 s1 rexpr1 rexpr2))
     207                         ))
     208                transitions)
     209
     210      (list g node-subs))))
     211
Note: See TracChangeset for help on using the changeset viewer.