Changeset 13012 in project
 Timestamp:
 01/15/09 09:14:55 (11 years ago)
 Location:
 release/3/nemo/trunk
 Files:

 4 edited
Legend:
 Unmodified
 Added
 Removed

release/3/nemo/trunk/nemomacros.scm
r12710 r13012 2 2 ;; NEMO macros 3 3 ;; 4 ;; Copyright 2008 Ivan Raikov and the Okinawa Institute of Science and Technology4 ;; Copyright 20082009 Ivan Raikov and the Okinawa Institute of Science and Technology 5 5 ;; 6 6 ;; This program is free software: you can redistribute it and/or 
release/3/nemo/trunk/nemomatlab.scm
r12960 r13012 32 32 (requireextension nemocore) 33 33 (requireextension nemoutils) 34 (requireextension nemoionch) 34 35 35 36 (defineextension nemomatlab) … … 218 219 (letoptionals rest ((rv #f) (width 72)) 219 220 (sdoc>string (doc:format width (formatexpr/MATLAB 2 x rv))))) 221 222 223 (define (expeuler dt name rhs) 224 (define (isname? x) (equal? x name)) 225 (let ((res 226 (match rhs 227 ((or (' A ('* B (and x (? isname?)))) 228 ('+ ('neg ('* B (and x (? isname?)))) A)) 229 (let ((xexp (string>symbol (s+ x 'exp)))) 230 `(let ((,xexp (exp (* (neg ,B) ,dt)))) 231 (+ (* ,x ,xexp) (* ( 1 ,xexp) (/ ,A ,B)))))) 232 233 ((or (' A ('* (and x (? isname?)) . B)) 234 ('+ ('neg ('* (and x (? isname?)) . B)) A)) 235 (let ((xexp (string>symbol (s+ x 'exp))) 236 (B1 (if (null? (cdr B)) (car B) `(* ,@B)))) 237 `(let ((,xexp (exp (* (neg ,B1) ,dt)))) 238 (+ (* ,x ,xexp) (* ( 1 ,xexp) (/ ,A ,B1)))))) 239 240 (('+ ('neg ('* (and x1 (? isname?)) Alpha)) 241 ('* (' 1 (and x2 (? isname?))) Beta)) 242 (let ((A Alpha) 243 (B `(+ ,Alpha ,Beta))) 244 (let ((xexp (string>symbol (s+ x1 'exp)))) 245 `(let ((,xexp (exp (* (neg ,B) ,dt)))) 246 (+ (* ,x1 ,xexp) (* ( 1 ,xexp) (/ ,A ,B))))))) 247 248 (('let bnds body) 249 `(let ,bnds ,(expeuler dt name body))) 250 251 (else (nemo:error 'nemo:expeuler ": unable to rewrite equation " rhs 252 "in exponential Euler form"))))) 253 254 res)) 220 255 221 256 (define (makedefinefn table? minv maxv with) … … 236 271 237 272 238 (define (stateeqs n initial open transitions power) 273 274 (define (stateinit n init) 275 (let* ((init (rhsexpr/MATLAB init)) 276 (init1 (canonicalizeexpr/MATLAB init))) 277 (list (matlabname n) init1))) 278 279 280 (define (asgneq n rhs) 281 (let* ((fbody (rhsexpr/MATLAB rhs)) 282 (fbody1 (canonicalizeexpr/MATLAB fbody))) 283 (list (matlabname n) fbody1))) 284 285 286 (define (reactioneq n open transitions) 287 (list (matlabname n) (matlabname (matlabstatename n open)))) 288 289 290 (define (reactiontransitioneqs n initial open transitions power method) 239 291 (matchlet (((g nodesubs) (transitionsgraph n open transitions matlabstatename))) 240 292 (let* ((outedges (g 'outedges)) 241 293 (inedges (g 'inedges)) 242 (nodes 243 (snode 244 ;; generateequations for each state in the transitions system294 (nodes ((g 'nodes))) 295 (snode (find (lambda (s) (not (eq? (second s) open))) nodes))) 296 ;; generate differential equations for each state in the transitions system 245 297 (let ((eqs (fold (lambda (s ax) 246 298 (if (= (first snode) (first s) ) ax … … 256 308 ((and (null? out) (not (null? in))) 257 309 (sum (map third in))))) 258 (fbody0 (rhsexpr/MATLAB rhs1)) 259 (fbody1 (canonicalizeexpr/MATLAB fbody0))) 260 (cons (list name fbody1) ax))))) 310 (fbody0 (rhsexpr/MATLAB rhs1))) 311 (case method 312 ((expeuler) (cons (list name (canonicalizeexpr/MATLAB 313 (expeuler 'dt name fbody0))) 314 ax)) 315 (else (cons (list name (canonicalizeexpr/MATLAB fbody0)) 316 ax)) 317 ))))) 261 318 (list) nodes))) 262 319 eqs)))) 263 264 265 (define (stateinit n init) 266 (let* ((init (rhsexpr/MATLAB init)) 267 (init1 (canonicalizeexpr/MATLAB init))) 268 (list (matlabname n) init1))) 269 270 271 (define (asgneq n rhs) 272 (let* ((fbody (rhsexpr/MATLAB rhs)) 273 (fbody1 (canonicalizeexpr/MATLAB fbody))) 274 (list (matlabname n) fbody1))) 275 276 277 (define (reactioneq n open transitions) 278 (list (matlabname n) (matlabname (matlabstatename n open)))) 279 320 321 280 322 281 323 (define (poset>asgneqdefs poset sys) … … 288 330 (cases nemo:quantity en 289 331 (ASGN (name value rhs) (cons (asgneq name rhs) ax)) 332 (else ax)) 333 ax)))) 334 ax lst)) 335 (list) poset)) 336 337 (define (poset>rateeqdefs poset sys method) 338 (foldright 339 (lambda (lst ax) 340 (fold (lambda (x ax) 341 (matchlet (((i . n) x)) 342 (let ((en (environmentref sys n))) 343 (if (nemo:quantity? en) 344 (cases nemo:quantity en 345 346 (REACTION (name initial open transitions conserve power) 347 (append (reactiontransitioneqs name initial open transitions 348 power method) ax)) 349 350 (RATE (name initial rhs) 351 (let ((fbody0 (rhsexpr/MATLAB rhs)) 352 (dy name )) 353 (case method 354 ((expeuler) 355 (cons (list dy (canonicalizeexpr/MATLAB (expeuler 'dt name fbody0))) 356 ax)) 357 (else 358 (cons (list dy (canonicalizeexpr/MATLAB fbody0)) ax))))) 359 290 360 (else ax)) 291 361 ax)))) … … 323 393 (stateinit (matlabstatename name open) name) ax) 324 394 ax)) 395 396 (RATE (name initial rhs) 397 (if (nemo:rhs? initial) 398 (cons (stateinit name initial) ax) 399 ax)) 400 325 401 (else ax)) 326 402 ax)))) … … 365 441 (loop (cdr lst) (append (cdr oldbkts) (cons (cons x (car oldbkts)) newbkts))) 366 442 (bktloop (cdr oldbkts) (cons (car oldbkts) newbkts))))))))) 367 368 369 (define (collectepools sys)370 (matchlet ((($ nemo:quantity 'DISPATCH dis) (environmentref sys (nemointern 'dispatch))))371 (let recur ((compname (nemointern 'toplevel)) (ax (list)))372 (let* ((compsymbols ((dis 'componentsymbols) sys compname))373 (subcomps ((dis 'componentsubcomps) sys compname)))374 (fold recur375 (fold (lambda (sym ax)376 (let ((en (environmentref sys sym)))377 (match en378 ((or (('decaying 'pool) ('name (? symbol? ion)) . alst)379 (('decayingpool) ('name (? symbol? ion)) . alst))380 (cons (list ion alst) ax))381 (else ax)))) ax compsymbols)382 (map third subcomps))))))383 443 384 444 … … 401 461 (defuns ((dis 'defuns) sys)) 402 462 (components ((dis 'components) sys)) 403 (ionchs (filtermap (matchlambda ((name 'ionchannel id) (list name id)) (else #f)) components)) 404 (capcomp (any (matchlambda ((name 'membranecapacitance id) (list name id)) (else #f)) components)) 405 (epools (collectepools sys))) 406 407 (matchlet (((statelist asgnlist g) deps*)) 408 (let* ( 409 (constdefs (filtermap 410 (lambda (nv) 411 (and (not (member (first nv) matlabbuiltinconsts)) 412 (let ((v1 (canonicalizeexpr/MATLAB (second nv)))) 413 (list (matlabname (first nv)) v1)))) 414 consts)) 415 (poset (vector>list ((dis 'depgraph>bfsdistposet) g))) 416 (asgneqdefs (poset>asgneqdefs poset sys)) 417 (mcap (and capcomp (car ((dis 'componentexports) sys (cid capcomp))))) 418 (permions (fold (lambda (ionch ax) 419 (let* ((subcomps ((dis 'componentsubcomps) sys (cid ionch))) 420 (perm (lookupdef 'permeatingsubstance subcomps))) 421 (if perm 422 (case (cn perm) 423 ((nonspecific) 424 (let* ((erev (car ((dis 'componentexports) sys (cid perm)))) 425 (i (matlabname 'i)) 426 (e (matlabname 'e))) 427 (cons `(,(cn perm) ,i ,e ,erev) ax))) 428 (else (let* ((erev (car ((dis 'componentexports) sys (cid perm)))) 429 (i (matlabname (s+ 'i (cn perm)))) 430 (e (matlabname (s+ 'e (cn perm))))) 431 (cons `(,(cn perm) ,i ,e ,erev) ax)))) 432 ax))) 433 (list) ionchs)) 434 (accions (fold (lambda (ionch ax) 435 (let* ((subcomps ((dis 'componentsubcomps) sys (cid ionch))) 436 (acc (lookupdef 'accumulatingsubstance subcomps)) 437 (i (and acc (matlabname (s+ 'i (cn acc))))) 438 (in (and acc (matlabname (s+ (cn acc) 'i)))) 439 (out (and acc (matlabname (s+ (cn acc) 'o))))) 440 (if acc (cons `(,(cn acc) ,i ,in ,out) ax) ax))) 441 (list) ionchs)) 442 (poolions (map (lambda (ep) 443 (let ((ion (car ep))) 444 `(,(matlabname ion) ,(matlabname (s+ 'i ion)) ,(matlabname (s+ ion 'i))))) 445 epools)) 446 447 (poolioni (map (lambda (ep) (let ((ion (car ep))) (matlabname (s+ 'i ion)))) 448 epools)) 449 450 451 (ieqs (filtermap 452 (lambda (ionch) 453 454 (let* ((label (first ionch)) 455 (n (second ionch)) 456 (subcomps ((dis 'componentsubcomps) sys n)) 457 (acc (lookupdef 'accumulatingsubstance subcomps)) 458 (perm (lookupdef 'permeatingsubstance subcomps)) 459 (permqs (and perm ((dis 'componentexports) sys (cid perm)))) 460 (pore (lookupdef 'pore subcomps)) 461 (gate (lookupdef 'gate subcomps)) 462 (sts (and gate ((dis 'componentexports) sys (cid gate))))) 463 464 (cond ((and perm pore gate) 465 (case (cn perm) 466 ((nonspecific) 467 (let* ((i (matlabname 'i)) 468 (e (car permqs)) 469 (gmax (car ((dis 'componentexports) sys (cid pore)))) 470 (pwrs (map (lambda (n) (reactionpower sys n)) sts)) 471 (sptms (map (lambda (st pwr) `(pow ,st ,pwr)) sts pwrs)) 472 (gion `(* ,gmax ,@sptms))) 473 (list i e gion))) 474 (else 475 (let* ((i (matlabname (s+ 'i (cn perm)))) 476 (e (car permqs)) 477 (gmax (car ((dis 'componentexports) sys (cid pore)))) 478 (pwrs (map (lambda (n) (reactionpower sys n)) sts)) 479 (sptms (map (lambda (st pwr) `(pow ,st ,pwr)) sts pwrs)) 480 (gion `(* ,gmax ,@sptms))) 481 (list i e gion))))) 463 464 (g (matchlet (((statelist asgnlist g) ((dis 'depgraph*) sys))) g)) 465 (poset (vector>list ((dis 'depgraph>bfsdistposet) g))) 466 467 (constdefs (filtermap 468 (lambda (nv) 469 (and (not (member (first nv) matlabbuiltinconsts)) 470 (let ((v1 (canonicalizeexpr/MATLAB (second nv)))) 471 (list (matlabname (first nv)) v1)))) 472 consts)) 473 474 (ionchinfo (nemo:ionchquery sys)) 475 (ionchs (lookupdef 'ionchannels ionchinfo)) 476 (permions (map (matchlambda ((comp i e erev) `(,comp ,(matlabname i) ,(matlabname e) ,erev))) 477 (lookupdef 'permions ionchinfo))) 478 (accions (map (matchlambda ((comp i in out) `(,comp ,@(map matlabname (list i in out))))) 479 (lookupdef 'accions ionchinfo))) 480 (epools (lookupdef 'poolions ionchinfo)) 481 (poolions (map (lambda (lst) (map matlabname lst)) epools)) 482 483 (igates (lookupdef 'igates ionchinfo)) 484 485 (capcomp (any (matchlambda ((name 'membranecapacitance id) (list name id)) (else #f)) components)) 486 (mcap (and capcomp (car ((dis 'componentexports) sys (cid capcomp))))) 487 488 489 (ieqs0 (filtermap 490 (lambda (ionch) 491 492 (let* ((label (first ionch)) 493 (n (second ionch)) 494 (subcomps ((dis 'componentsubcomps) sys n)) 495 (acc (lookupdef 'accumulatingsubstance subcomps)) 496 (perm (lookupdef 'permeatingsubstance subcomps)) 497 (permqs (and perm ((dis 'componentexports) sys (cid perm)))) 498 (pore (lookupdef 'pore subcomps)) 499 (gate (lookupdef 'gate subcomps)) 500 (sts (and gate ((dis 'componentexports) sys (cid gate))))) 501 502 (cond ((and perm pore gate) 503 (case (cn perm) 504 ((nonspecific) 505 (let* ((i (matlabname 'i)) 506 (e (car permqs)) 507 (gmax (car ((dis 'componentexports) sys (cid pore)))) 508 (pwrs (map (lambda (n) (reactionpower sys n)) sts)) 509 (sptms (map (lambda (st pwr) `(pow ,st ,pwr)) sts pwrs)) 510 (gion `(* ,gmax ,@sptms))) 511 (list i e gion))) 512 (else 513 (let* ((i (matlabname (s+ 'i (cn perm)))) 514 (e (car permqs)) 515 (gmax (car ((dis 'componentexports) sys (cid pore)))) 516 (pwrs (map (lambda (n) (reactionpower sys n)) sts)) 517 (sptms (map (lambda (st pwr) `(pow ,st ,pwr)) sts pwrs)) 518 (gion `(* ,gmax ,@sptms))) 519 (list i e gion))))) 520 521 ((and perm pore) 522 (case (cn perm) 523 ((nonspecific) 524 (let* ((i (matlabname 'i)) 525 (e (car permqs)) 526 (gmax (car ((dis 'componentexports) sys (cid pore))))) 527 (list i e gmax))) 528 (else 529 (nemo:error 'nemo:matlabtranslator ": invalid ion channel definition " label)))) 530 531 ((and acc pore gate) 532 (let* ((i (matlabname (s+ 'i (cn acc)))) 533 (gmax (car ((dis 'componentexports) sys (cid pore)))) 534 (pwrs (map (lambda (n) (reactionpower sys n)) sts)) 535 (sptms (map (lambda (st pwr) `(pow ,st ,pwr)) sts pwrs)) 536 (gion `(* ,gmax ,@sptms))) 537 (list i #f gion))) 538 (else (nemo:error 'nemo:matlabtranslator ": invalid ion channel definition " label)) 539 ))) 540 ionchs)) 541 542 (ibkts (bucketpartition (lambda (x y) (eq? (car x) (car y))) ieqs0)) 543 544 (ieqs (fold (lambda (b ax) 545 (match b 546 ((and ps ((i e gion) . rst)) 547 (let* ((sum (if e (sum (map (lambda (b) `(* ,(third b) ( v ,(second b)))) 548 ps)) 549 (sum (map third ps)))) 550 (sum0 (rhsexpr/MATLAB sum)) 551 (sum1 (canonicalizeexpr/MATLAB sum0))) 552 (cons (list i sum1) ax))) 482 553 483 ((and perm pore) 484 (case (cn perm) 485 ((nonspecific) 486 (let* ((i (matlabname 'i)) 487 (e (car permqs)) 488 (gmax (car ((dis 'componentexports) sys (cid pore))))) 489 (list i e gmax))) 490 (else 491 (nemo:error 'nemo:matlabtranslator ": invalid ion channel definition " label)))) 554 ((i e gion) 555 (let* ((expr0 (rhsexpr/MATLAB (if e `(* ,gion ( v ,e)) gion))) 556 (expr1 (canonicalizeexpr/MATLAB expr0))) 557 (cons (list i expr1) ax))) 492 558 493 ((and acc pore gate) 494 (let* ((i (matlabname (s+ 'i (cn acc)))) 495 (gmax (car ((dis 'componentexports) sys (cid pore)))) 496 (pwrs (map (lambda (n) (reactionpower sys n)) sts)) 497 (sptms (map (lambda (st pwr) `(pow ,st ,pwr)) sts pwrs)) 498 (gion `(* ,gmax ,@sptms))) 499 (list i #f gion))) 500 (else (nemo:error 'nemo:matlabtranslator ": invalid ion channel definition " label)) 501 ))) 502 ionchs)) 503 504 (ibkts (bucketpartition (lambda (x y) (eq? (car x) (car y))) ieqs)) 505 506 (ieqs (fold (lambda (b ax) 507 (match b 508 ((and ps ((i e gion) . rst)) 509 (let* ((sum (if e (sum (map (lambda (b) `(* ,(third b) ( v ,(second b)))) 510 ps)) 511 (sum (map third ps)))) 512 (sum0 (rhsexpr/MATLAB sum)) 513 (sum1 (canonicalizeexpr/MATLAB sum0))) 514 (cons (list i sum1) ax))) 515 516 ((i e gion) 517 (let* ((expr0 (rhsexpr/MATLAB (if e `(* ,gion ( v ,e)) gion))) 518 (expr1 (canonicalizeexpr/MATLAB expr0))) 519 (cons (list i expr1) ax))) 520 521 (else ax))) 522 (list) ibkts)) 523 524 (stateeqdefs (reverse (poset>stateeqdefs poset sys))) 525 526 (reactioneqdefs (poset>reactioneqdefs poset sys)) 527 528 (conserveeqdefs (map (lambda (eq) (list 0 `( ,(second eq) ,(first eq)))) 529 (poset>stateconserveeqdefs poset sys))) 530 531 (poolconsts (concatenate 532 (map (lambda (ep) 533 (let* ((epname (first ep)) 534 (poolion (assoc epname poolions)) 535 (iname (second poolion)) 536 (initname (matlabname (s+ epname 'init))) 537 (tempname (matlabname (s+ epname 'tempadj))) 538 (betaname (matlabname (s+ epname 'beta))) 539 (depthname (matlabname (s+ epname 'depth)))) 540 (list initname tempname betaname depthname))) 541 epools))) 542 543 (pooleqdefs 544 (map (lambda (ep) 545 (let* ((epname (first ep)) 546 (poolion (assoc epname poolions)) 547 (iname (second poolion)) 548 (initname (matlabname (s+ epname 'init))) 549 (tempname (matlabname (s+ epname 'tempadj))) 550 (betaname (matlabname (s+ epname 'beta))) 551 (depthname (matlabname (s+ epname 'depth))) 552 (rhs `(let ((F 96485.0)) 553 ( (/ (neg ,iname) (* 2 F ,initname ,depthname)) 554 (* ,betaname ,epname . 555 ,(if tempname (list tempname) (list))))))) 556 `(,(s+ epname) ,rhs))) 557 epools)) 558 559 (rateeqdefs (append pooleqdefs stateeqdefs)) 560 561 (initeqdefs (poset>stateinitdefs poset sys)) 562 563 (stateindexmap (let ((acc (fold (lambda (def ax) 564 (let ((stname (first def))) 565 (list (+ 1 (first ax)) 566 (cons `(,stname ,(first ax)) (second ax))))) 567 (list 1 (list)) 568 (cons (list 'v) rateeqdefs)))) 569 570 (second acc))) 571 572 (steadystateindexmap (let ((acc (fold (lambda (def ax) 573 (let ((stname (first def))) 574 (if (not (alistref stname initeqdefs)) 575 (list (+ 1 (first ax)) 576 (cons `(,stname ,(first ax)) (second ax))) 577 ax))) 578 (list 1 (list)) 579 rateeqdefs))) 580 (second acc))) 581 582 (globals (map matlabname 583 (deleteduplicates (append 584 exports 585 poolconsts 586 (map second permions) 587 (map third permions) 588 (map second accions) 589 (map third accions) 590 (map fourth accions) 591 (map second poolions) 592 (map third poolions) 593 (map first imports) 594 (map first constdefs))))) 559 (else ax))) 560 (list) ibkts)) 561 562 (asgneqdefs (poset>asgneqdefs poset sys)) 563 564 565 (rateeqdefs (reverse (poset>rateeqdefs poset sys method))) 566 567 (reactioneqdefs (poset>reactioneqdefs poset sys)) 568 569 (initeqdefs (poset>stateinitdefs poset sys)) 570 571 (conserveeqdefs (map (lambda (eq) (list 0 `( ,(second eq) ,(first eq)))) 572 (poset>stateconserveeqdefs poset sys))) 573 574 (poolioni (map second poolions)) 575 576 577 (stateindexmap (let ((acc (fold (lambda (def ax) 578 (let ((stname (first def))) 579 (list (+ 1 (first ax)) 580 (cons `(,stname ,(first ax)) (second ax))))) 581 (list 1 (list)) 582 (cons (list 'v) rateeqdefs)))) 583 584 (second acc))) 585 586 (steadystateindexmap (let ((acc (fold (lambda (def ax) 587 (let ((stname (first def))) 588 (if (not (alistref stname initeqdefs)) 589 (list (+ 1 (first ax)) 590 (cons `(,stname ,(first ax)) (second ax))) 591 ax))) 592 (list 1 (list)) 593 rateeqdefs))) 594 (second acc))) 595 596 (globals (map matlabname 597 (deleteduplicates (append 598 exports 599 (map second permions) 600 (map third permions) 601 (map second accions) 602 (map third accions) 603 (map fourth accions) 604 (map second poolions) 605 (map third poolions) 606 (map first imports) 607 (map first constdefs))))) 595 608 596 609 ) … … 612 625 poolions) 613 626 614 (if (not (null? globals)) (pp indent +(global ,(sl\ " " globals))))627 (if (not (null? globals)) (pp indent (global ,(sl\ " " globals)))) 615 628 616 629 (pp indent ,nl (function dy = ,sysname (,(sl\ ", " (case method … … 701 714 (pp indent ,nl (endfunction)))) 702 715 716 717 (pp indent ,nl (function ,(s+ sysname "_print_state") (y))) 718 719 (let ((lst (sort (map (lambda (x) (cons (>string (car x)) (cdr x))) stateindexmap) 720 (lambda (x y) (string<? (car x) (car y)))))) 721 (foreach (lambda (p) 722 (let ((n (first p)) (i (second p))) 723 (pp indent+ (,n " = " "y(" ,i ")")))) 724 lst)) 725 726 (pp indent ,nl (endfunction)) 727 703 728 704 729 (pp indent ,nl (function y0 = ,(s+ sysname "_init") (Vinit))) … … 708 733 (pp indent+ ,(expr>string/MATLAB `(zeros ,(length stateindexmap) 1) 'y0)) 709 734 710 (foreach (lambda (ep)711 (let* ((epname (first ep))712 (epprops (second ep))713 (initexpr (lookupdef 'initial epprops))714 (tempexpr (lookupdef 'tempadj epprops))715 (betaexpr (lookupdef 'beta epprops))716 (depthexpr (lookupdef 'depth epprops))717 (initname (matlabname (s+ epname 'init)))718 (tempname (matlabname (s+ epname 'tempadj)))719 (betaname (matlabname (s+ epname 'beta)))720 (depthname (matlabname (s+ epname 'depth))))721 (if (or (not betaexpr) (not depthexpr) (not initexpr))722 (nemo:error 'nemo:matlabtranslator723 ": ion pool " epname " requires initial value, depth and beta parameters"))724 (let ((tempval (and tempexpr (evalconst sys tempexpr)))725 (initval (evalconst sys initexpr))726 (betaval (evalconst sys betaexpr))727 (depthval (evalconst sys depthexpr)))728 (pp indent+729 ,(expr>string/MATLAB initval initname)730 ,(expr>string/MATLAB tempval tempname)731 ,(expr>string/MATLAB betaval betaname)732 ,(expr>string/MATLAB depthval depthname)))))733 epools)734 735 736 735 (if (member 'v globals) 737 736 (let ((vi (lookupdef 'v stateindexmap))) … … 796 795 (apply definefn (cons indent fndef)))) 797 796 defuns)) 798 ))))) ))797 ))))) 
release/3/nemo/trunk/nemonmodl.scm
r13004 r13012 57 57 (enumfreevars rhs (list) (list))) 58 58 59 (define (rhsexpr expr)59 (define (rhsexpr/NMODL expr) 60 60 (match expr 61 (('if . es) `(if . ,(map (lambda (x) (rhsexpr x)) es)))61 (('if . es) `(if . ,(map (lambda (x) (rhsexpr/NMODL x)) es))) 62 62 (('pow x y) (if (and (integer? y) (positive? y)) 63 63 (if (> y 1) (let ((tmp (gensym "x"))) … … 65 65 x) 66 66 expr)) 67 ((s . es) (if (symbol? s) (cons s (map (lambda (x) (rhsexpr x)) es)) expr))67 ((s . es) (if (symbol? s) (cons s (map (lambda (x) (rhsexpr/NMODL x)) es)) expr)) 68 68 (id (if (symbol? id) (nmodlname id) id)))) 69 69 … … 322 322 (body (lookupdef 'body lst))) 323 323 (pp indent ,nl (FUNCTION ,n (,(sl\ ", " vars)) "{" )) 324 (let* ((body1 (canonicalizeexpr/NMODL (rhsexpr body)))324 (let* ((body1 (canonicalizeexpr/NMODL (rhsexpr/NMODL body))) 325 325 (lbs (enumbnds body1 (list)))) 326 326 (if (not (null? lbs)) (pp indent+ (LOCAL ,(sl\ ", " lbs)))) … … 368 368 369 369 370 (define (reaction eqs n initial open transitions power method)370 (define (reactiontransitioneqs n initial open transitions power method) 371 371 (matchlet (((g nodesubs) (transitionsgraph n open transitions nmodlstatename))) 372 372 (let* ((outedges (g 'outedges)) … … 388 388 ((and (null? out) (not (null? in))) 389 389 (sum (map third in))))) 390 (fbody0 (rhsexpr rhs1)))390 (fbody0 (rhsexpr/NMODL rhs1))) 391 391 (case method 392 392 ((expeuler) (cons (list name (canonicalizeexpr/NMODL (expeuler 'dt name fbody0))) … … 452 452 453 453 (define (stateinit n init) 454 (let* ((init (rhsexpr init))454 (let* ((init (rhsexpr/NMODL init)) 455 455 (init1 (canonicalizeexpr/NMODL init))) 456 456 (list (nmodlname n) init1))) … … 458 458 459 459 (define (asgneq n rhs) 460 (let* ((fbody (rhsexpr rhs))460 (let* ((fbody (rhsexpr/NMODL rhs)) 461 461 (fbody1 (canonicalizeexpr/NMODL fbody))) 462 462 (list (nmodlname n) fbody1))) … … 498 498 499 499 500 (define (poset> stateeqdefs poset sys kinetic method)500 (define (poset>rateeqdefs poset sys kinetic method) 501 501 (foldright 502 502 (lambda (lst ax) … … 507 507 (cases nemo:quantity en 508 508 (REACTION (name initial open transitions conserve power) 509 (append (reactioneqs name initial open transitions power method) ax)) 509 (append (reactiontransitioneqs name initial open transitions 510 power method) ax)) 510 511 511 512 (RATE (name initial rhs) 512 (let ((fbody0 (rhsexpr rhs))513 (let ((fbody0 (rhsexpr/NMODL rhs)) 513 514 (dy name )) 514 515 (case method … … 525 526 526 527 527 (define (poset>k stateeqdefs poset sys kinetic)528 (define (poset>kineticeqdefs poset sys kinetic) 528 529 (foldright 529 530 (lambda (lst ax) … … 631 632 (g (matchlet (((statelist asgnlist g) ((dis 'depgraph*) sys))) g)) 632 633 (poset (vector>list ((dis 'depgraph>bfsdistposet) g))) 633 (asgneqdefs (poset>asgneqdefs poset sys))634 634 (ionchinfo (nemo:ionchquery sys)) 635 635 (ionchs (lookupdef 'ionchannels ionchinfo)) … … 645 645 (haskinetic? (or (not (null? (filter (lambda (x) (member (car x) kinetic)) states))))) 646 646 (hasode? (or (not (null? (filter (lambda (x) (not (member (car x) kinetic))) states))) 647 (not (null? poolions))))) 647 (not (null? poolions)))) 648 649 (asgneqdefs (poset>asgneqdefs poset sys)) 650 (reactioneqdefs (poset>reactioneqdefs poset sys kinetic)) 651 (rateeqdefs (reverse (poset>rateeqdefs poset sys kinetic method))) 652 (kstateeqdefs (poset>kineticeqdefs poset sys kinetic)) 653 (conserveeqdefs (poset>stateconserveeqdefs poset sys)) 654 (stateinitdefs (poset>stateinitdefs poset sys)) 655 656 ) 648 657 649 658 … … 762 771 (begin 763 772 (pp indent ,nl (PROCEDURE reactions () "{")) 764 (let* ((eqdefs (poset>reactioneqdefs poset sys kinetic)) 765 (locals (findlocals (map second eqdefs))) ) 773 (let ((locals (findlocals (map second reactioneqdefs))) ) 766 774 (if (not (null? locals)) (pp indent+ (LOCAL ,(sl\ ", " locals)))) 767 775 (foreach (lambda (def) 768 776 (let ((n (nmodlname (first def))) (b (second def))) 769 (pp indent+ ,(expr>string/NMODL b n)))) eqdefs))777 (pp indent+ ,(expr>string/NMODL b n)))) reactioneqdefs)) 770 778 771 779 (pp indent "}"))) … … 852 860 (if (null? ps) 853 861 (let* ((sum0 (sum summands)) 854 (sum1 (rhsexpr sum0))862 (sum1 (rhsexpr/NMODL sum0)) 855 863 (sum2 (canonicalizeexpr/NMODL sum1))) 856 864 (cons (list i sum2) ax)) … … 859 867 860 868 ((i e gion) 861 (let* ((expr0 (rhsexpr (if e `(* ,gion ( v ,e)) gion)))869 (let* ((expr0 (rhsexpr/NMODL (if e `(* ,gion ( v ,e)) gion))) 862 870 (expr1 (canonicalizeexpr/NMODL expr0))) 863 871 (cons (list i expr1) ax))) … … 879 887 880 888 (if hasode? 881 (let* ((eqdefs (reverse (poset>stateeqdefs poset sys kinetic method))) 882 (locals (findlocals (map second eqdefs)))) 889 (let ((locals (findlocals (map second rateeqdefs)))) 883 890 (case method 884 891 ((expeuler) (pp indent ,nl (PROCEDURE states () "{"))) … … 892 899 (b (second def))) 893 900 (pp indent+ ,(expr>string/NMODL b n)))) 894 eqdefs))901 rateeqdefs)) 895 902 (pp indent "}"))) 896 903 … … 898 905 (begin 899 906 (pp indent ,nl (KINETIC kstates "{")) 900 (let* ((keqdefs (poset>kstateeqdefs poset sys kinetic)) 901 (locals (concatenate (findlocals (map third (map second keqdefs))))) 902 (conserveeqdefs (poset>stateconserveeqdefs poset sys))) 907 (let ((locals (concatenate (findlocals (map third (map second kstateeqdefs)))))) 903 908 (if (not (null? locals)) (pp indent+ (LOCAL ,(sl\ ", " locals)))) 904 909 (foreach … … 907 912 (eqs (second def)) 908 913 (conserveeqs (lookupdef n conserveeqdefs))) 909 910 914 (foreach 911 915 (lambda (eq) … … 926 930 conserveeqs)) 927 931 )) 928 k eqdefs))932 kstateeqdefs)) 929 933 (pp indent "}"))) 930 934 931 935 932 (let* ((initdefs (poset>stateinitdefs poset sys)) 933 (locals (concatenate (findlocals (map second initdefs)))) ) 936 (let ((locals (concatenate (findlocals (map second stateinitdefs)))) ) 934 937 (pp indent ,nl (INITIAL "{")) 935 938 (if (not (null? locals)) (pp indent+ (LOCAL ,(sl\ ", " locals)))) … … 937 940 (foreach (lambda (def) 938 941 (let ((n (first def)) (b (second def))) 939 (pp indent+ ,(expr>string/NMODL b n)))) initdefs)942 (pp indent+ ,(expr>string/NMODL b n)))) stateinitdefs) 940 943 941 944 (if haskinetic? … … 944 947 (pp indent "}") 945 948 949 (pp indent ,nl (PROCEDURE print_state () "{")) 950 951 (let ((lst (sort (map (compose >string first) rateeqdefs) string<?))) 952 (foreach (lambda (x) 953 (pp indent+ (printf (,(s+ #\" x " = %g\\n" #\") ", " ,x )))) 954 lst)) 955 956 (pp indent "}") 957 946 958 )))))) 
release/3/nemo/trunk/nemoutils.scm
r12784 r13012 3 3 ;; Utility procedures for NEMO code generators. 4 4 ;; 5 ;; Copyright 2008 Ivan Raikov and the Okinawa Institute of Science and Technology5 ;; Copyright 20082009 Ivan Raikov and the Okinawa Institute of Science and Technology 6 6 ;; 7 7 ;; This program is free software: you can redistribute it and/or
Note: See TracChangeset
for help on using the changeset viewer.