Changeset 12554 in project for release/3/nemo/trunk/nemomatlab.scm
 Timestamp:
 11/18/08 08:31:57 (11 years ago)
 File:

 1 edited
Legend:
 Unmodified
 Added
 Removed

release/3/nemo/trunk/nemomatlab.scm
r12353 r12554 99 99 (define (s+ . lst) (stringconcatenate (map >string lst))) 100 100 (define (sw+ lst) (stringintersperse (filtermap (lambda (x) (and x (>string x))) lst) " ")) 101 (define (s\ p . lst) (stringintersperse (map >string lst) p))102 101 (define (sl\ p lst) (stringintersperse (map >string lst) p)) 103 102 (define nl "\n") … … 337 336 (sdoc>string (doc:format width (formatexpr/MATLAB 2 x rv))))) 338 337 339 340 (define (formatlineq/MATLAB indent expr . rest) 341 (letoptionals rest ((rv #f)) 342 (let ((indent+ (+ 2 indent))) 343 (match expr 344 (('let bindings body) 345 (letblk/MATLAB 346 (foldright 347 (lambda (x ax) 348 (letblk/MATLAB 349 (match (second x) 350 (('if c t e) 351 (ifthen/MATLAB 352 (group/MATLAB (formatlineq/MATLAB indent c)) 353 (block/MATLAB (formatlineq/MATLAB indent t (first x))) 354 (block/MATLAB (formatlineq/MATLAB indent e (first x))))) 355 (else 356 (formatop/MATLAB indent+ " = " 357 (list (formatlineq/MATLAB indent (first x) ) 358 (formatlineq/MATLAB indent (second x)))))) 359 ax)) 360 (doc:empty) bindings) 361 (let ((body1 (doc:nest indent (formatlineq/MATLAB indent body)))) 362 (if rv (formatop/MATLAB indent " = " (list (formatlineq/MATLAB indent+ rv ) body1)) 363 body1)))) 364 365 (('if . rest) (error 'formatlineq/MATLAB "invalid if statement " expr)) 366 367 ((op . rest) 368 (let ((op (case op ((pow) '^) ((abs) 'fabs) (else op)))) 369 (let ((fe 370 (if (member op matlabops) 371 (let ((mdiv? (any (lambda (x) (match x (('* . _) #t) (('/ . _) #t) (else #f))) rest)) 372 (mul? (any (lambda (x) (match x (('* . _) #t) (else #f))) rest)) 373 (plmin? (any (lambda (x) (match x (('+ . _) #t) ((' . _) #t) (else #f))) rest))) 374 (case op 375 ((/) 376 (formatop/MATLAB indent op 377 (map (lambda (x) 378 (let ((fx (formatlineq/MATLAB indent+ x))) 379 (if (or (symbol? x) (number? x)) fx 380 (if (or mul? plmin?) (group/MATLAB fx) fx)))) rest))) 381 ((*) 382 (formatop/MATLAB indent op 383 (map (lambda (x) 384 (let ((fx (formatlineq/MATLAB indent+ x))) 385 (if (or (symbol? x) (number? x)) fx 386 (if plmin? (group/MATLAB fx) fx)))) rest))) 387 388 ((^) 389 (formatop/MATLAB indent op 390 (map (lambda (x) 391 (let ((fx (formatlineq/MATLAB indent+ x))) 392 (if (or (symbol? x) (number? x)) fx 393 (if (or mdiv? plmin?) (group/MATLAB fx) fx)))) rest))) 394 395 (else 396 (formatop/MATLAB indent op 397 (map (lambda (x) 398 (let ((fx (formatlineq/MATLAB indent+ x))) fx)) rest))))) 399 400 (case op 401 ((neg) (formatop/MATLAB indent '* (map (lambda (x) (formatlineq/MATLAB indent+ x)) 402 (cons "(1)" rest)))) 403 (else (formatfncall/MATLAB indent op (map (lambda (x) (formatlineq/MATLAB indent+ x)) 404 rest))))))) 405 406 (if rv (formatop/MATLAB indent " = " (list (formatlineq/MATLAB indent+ rv ) fe)) fe)))) 407 408 (else (let ((fe (doc:text (>string expr)))) 409 (if rv 410 (formatop/MATLAB indent " = " (list (formatlineq/MATLAB indent+ rv ) fe)) 411 fe))))))) 412 413 414 415 (define (lineq>string/MATLAB x val . rest) 416 (letoptionals rest ((width 72)) 417 (s+ "~ " (sdoc>string (doc:format width (formatlineq/MATLAB 2 x #f))) 418 " = " (number>string val)))) 419 420 421 (define (makedefinefn table? minv maxv with depend) 338 (define (makedefinefn table? minv maxv with) 422 339 (lambda (indent n proc) 423 340 (let ((lst (proceduredata proc)) … … 431 348 (let* ((body1 (canonicalizeexpr/MATLAB (rhsexpr body))) 432 349 (lbs (enumbnds body1 (list)))) 433 ; (if (and table? minv maxv with)434 ; (match vars435 ; (('v) (pp indent+ (TABLE ,@(if depend `(DEPEND ,depend) `(""))436 ; FROM ,minv TO ,maxv WITH ,with)))437 ; (else (void))))438 350 (pp indent+ ,(expr>string/MATLAB body1 retval)) 439 351 (pp indent endfunction)) … … 510 422 (fbody (rhsexpr rhs1)) 511 423 (fbody1 (canonicalizeexpr/MATLAB fbody))) 512 (cons (list (s+ name "'")fbody1) ax)))))424 (cons (list name fbody1) ax))))) 513 425 (list) nodes))) 514 426 eqs)))) … … 516 428 517 429 518 (define (kstateeqs n initial open transitions power)519 (let* ((substconvert (substdriver (lambda (x) (and (symbol? x) x)) binding? identity bind substterm))520 (statelist (let loop ((lst (list)) (tlst transitions))521 (if (null? tlst) (deleteduplicates lst eq?)522 (match (car tlst)523 (('> (and (? symbol?) s0) (and (? symbol?) s1) rateexpr)524 (loop (cons* s0 s1 lst) (cdr tlst)))525 (((and (? symbol?) s0) '> (and (? symbol? s1)) rateexpr)526 (loop (cons* s0 s1 lst) (cdr tlst)))527 (('<> (and (? symbol?) s0) (and (? symbol?) s1) rateexpr1 rateexpr2)528 (loop (cons* s0 s1 lst) (cdr tlst)))529 (((and (? symbol?) s0) 'M> (and (? symbol? s1)) rateexpr1 rateexpr2)530 (loop (cons* s0 s1 lst) (cdr tlst)))531 (else532 (nemo:error 'nemo:matlabkstateeqs ": invalid transition equation "533 (car tlst) " in state complex " n))534 (else (loop lst (cdr tlst)))))))535 (statesubs (fold (lambda (s ax) (substextend s (matlabstatename n s) ax)) substempty statelist)))536 ;; generate kinetic equations for each edge in the transitions system537 (map538 (lambda (e)539 (match e540 (('> s0 s1 rexpr)541 (let ((i (lookupdef s0 statesubs))542 (j (lookupdef s1 statesubs)))543 `(> ,i ,j ,(substconvert rexpr statesubs))))544 545 ((s0 '> s1 rexpr)546 (let ((i (lookupdef s0 statesubs))547 (j (lookupdef s1 statesubs)))548 `(> ,i ,j ,(substconvert rexpr statesubs))))549 550 (('<> s0 s1 rexpr1 rexpr2)551 (let ((i (lookupdef s0 statesubs))552 (j (lookupdef s1 statesubs)))553 `(<> ,i ,j ,(substconvert rexpr1 statesubs) ,(substconvert rexpr2 statesubs))))554 555 ((s0 '<> s1 rexpr1 rexpr2)556 (let ((i (lookupdef s0 statesubs))557 (j (lookupdef s1 statesubs)))558 `(<> ,i ,j ,(substconvert rexpr1 statesubs) ,(substconvert rexpr2 statesubs))))559 560 561 (else (nemo:error 'nemo:matlabkstateeqs ": invalid transition equation "562 e " in state complex " n))))563 transitions)))564 565 566 430 567 431 (define (stateinit n init) … … 570 434 (list (matlabname n) init1))) 571 435 572 573 (define (stateiniteq n transitions init)574 (let* ((substconvert (substdriver (lambda (x) (and (symbol? x) x)) binding? identity bind substterm))575 (statelist (let loop ((lst (list)) (tlst transitions))576 (if (null? tlst) (deleteduplicates lst eq?)577 (match (car tlst)578 (('> (and (? symbol?) s0) (and (? symbol?) s1) rateexpr)579 (loop (cons* s0 s1 lst) (cdr tlst)))580 (((and (? symbol?) s0) '> (and (? symbol? s1)) rateexpr)581 (loop (cons* s0 s1 lst) (cdr tlst)))582 (('<> (and (? symbol?) s0) (and (? symbol?) s1) rateexpr1 rateexpr2)583 (loop (cons* s0 s1 lst) (cdr tlst)))584 (((and (? symbol?) s0) 'M> (and (? symbol? s1)) rateexpr1 rateexpr2)585 (loop (cons* s0 s1 lst) (cdr tlst)))586 (else587 (nemo:error 'nemo:stateiniteq ": invalid transition equation "588 (car tlst) " in state complex " n))589 (else (loop lst (cdr tlst)))))))590 (statesubs (fold (lambda (s ax) (substextend s (matlabstatename n s) ax)) substempty statelist))591 (init1 (map (lambda (lineq) (match lineq ((i '= . expr) `(,i = . ,(substconvert expr statesubs)))))592 init)))593 (list (matlabname n) init1)))594 436 595 437 … … 619 461 620 462 621 (define (poset>stateeqdefs poset sys kinetic)463 (define (poset>stateeqdefs poset sys) 622 464 (foldright 623 465 (lambda (lst ax) … … 625 467 (matchlet (((i . n) x)) 626 468 (let ((en (environmentref sys n))) 627 (if ( and (not (member n kinetic)) (nemo:quantity? en))469 (if (nemo:quantity? en) 628 470 (cases nemo:quantity en 629 (TSCOMP (name initial open transitions power)471 (TSCOMP (name initial open transitions conserve power) 630 472 (append (stateeqs name initial open transitions power) ax)) 631 473 (else ax)) … … 635 477 636 478 637 (define (poset>kstateeqdefs poset sys kinetic)638 (foldright639 (lambda (lst ax)640 (fold (lambda (x ax)641 (matchlet (((i . n) x))642 (let ((en (environmentref sys n)))643 (if (and (member n kinetic) (nemo:quantity? en))644 (cases nemo:quantity en645 (TSCOMP (name initial open transitions power)646 (append (kstateeqs name initial open transitions power) ax))647 (else ax))648 ax))))649 ax lst))650 (list) poset))651 479 652 480 … … 659 487 (if (nemo:quantity? en) 660 488 (cases nemo:quantity en 661 (TSCOMP (name initial open transitions power)489 (TSCOMP (name initial open transitions conserve power) 662 490 (cons (stcompeq name open transitions) ax)) 663 491 (else ax)) … … 675 503 (if (nemo:quantity? en) 676 504 (cases nemo:quantity en 677 (TSCOMP (name initial open transitions power)505 (TSCOMP (name initial open transitions conserve power) 678 506 (if (nemo:rhs? initial) 679 507 (cons* (stateinit name initial) … … 686 514 687 515 688 (define (poset>stateiniteqdefs poset sys)689 (foldright690 (lambda (lst ax)691 (fold (lambda (x ax)692 (matchlet (((i . n) x))693 (let ((en (environmentref sys n)))694 (if (nemo:quantity? en)695 (cases nemo:quantity en696 (TSCOMP (name initial open transitions power)697 (if (and (list? initial) (every nemo:lineq? initial))698 (cons (stateiniteq name transitions initial) ax)699 ax))700 (else ax))701 ax))))702 ax lst))703 (list) poset))704 705 706 516 (define (findlocals defs) 707 517 (concatenate (map (lambda (def) (match def (('let bnds _) (map first bnds)) (else (list)))) defs))) … … 712 522 (if (nemo:quantity? en) 713 523 (cases nemo:quantity en 714 (TSCOMP (name initial open transitions power) power)524 (TSCOMP (name initial open transitions conserve power) power) 715 525 (else #f)) #f))) 716 526 … … 746 556 (define (cid x) (second x)) 747 557 (define (cn x) (first x)) 748 (letoptionals rest ((method 'cnexp) (table? #f) (minv 100) (maxv 100) (step 0.5) 749 (depend #f) (kinetic (list)) ) 558 (letoptionals rest ((method 'cnexp) (table? #f) (minv 100) (maxv 100) (step 0.5) ) 750 559 (matchlet ((($ nemo:quantity 'DISPATCH dis) (environmentref sys (nemointern 'dispatch)))) 751 560 (let ((imports ((dis 'imports) sys)) … … 767 576 768 577 (matchlet (((statelist asgnlist g) deps*)) 769 (let* ((poset (vector>list ((dis 'depgraph>bfsdistposet) g)))770 (asgneqdefs (poset>asgneqdefs poset sys))578 (let* ((poset (vector>list ((dis 'depgraph>bfsdistposet) g))) 579 (asgneqdefs (poset>asgneqdefs poset sys)) 771 580 (permions (fold (lambda (ionch ax) 772 581 (let* ((subcomps ((dis 'componentsubcomps) sys (cid ionch))) … … 796 605 (let ((ion (car ep))) 797 606 `(,(matlabname ion) ,(matlabname (s+ 'i ion)) ,(matlabname (s+ ion 'i))))) 798 epools)) 799 (haskinetic? (or (not (null? (filter (lambda (x) (member (car x) kinetic)) states))))) 800 (hasode? (or (not (null? (filter (lambda (x) (not (member (car x) kinetic))) states))) 801 (not (null? poolions))))) 802 607 epools))) 803 608 804 609 (foreach … … 819 624 820 625 (let* ((with (inexact>exact (round (/ (abs ( maxv minv)) step)))) 821 (definefn (makedefinefn table? minv maxv with depend)))626 (definefn (makedefinefn table? minv maxv with))) 822 627 (foreach (lambda (fndef) 823 628 (if (not (member (car fndef) builtinfns)) … … 825 630 defuns)) 826 631 827 (pp indent ,nl ( dy = ,sysname (,(sl\ ", " `(dy t)))))632 (pp indent ,nl (function dy = ,sysname (,(sl\ ", " `(dy t))))) 828 633 829 634 (if (not (null? exports)) (pp indent+ (global ,(sl\ ", " exports)))) … … 871 676 (pp indent+ ,(expr>string/MATLAB b n)))) asgneqdefs)) 872 677 873 #874 678 (let* ((ieqs (filtermap 875 679 (lambda (ionch) … … 924 728 ))) 925 729 ionchs)) 730 926 731 (ibkts (bucketpartition (lambda (x y) (eq? (car x) (car y))) ieqs)) 732 927 733 (ieqs (fold (lambda (b ax) 928 734 (match b … … 942 748 (else ax))) 943 749 (list) ibkts)) 944 (locals (findlocals (map second ieqs)))) 945 (if (not (null? locals)) (pp indent+ (LOCAL ,(sl\ ", " locals)))) 946 (if (not (null? asgns)) (pp indent+ (rates ()))) 947 (if hasode? 948 (if (not method) (pp indent+ (SOLVE states)) 949 (pp indent+ (SOLVE states METHOD ,method)))) 950 (if haskinetic? (pp indent+ (SOLVE kstates METHOD sparse))) 951 (if (not (null? stcomps)) (pp indent+ (stcomps ()))) 952 (if (not (null? poolions)) (pp indent+ (pools ()))) 953 (foreach (lambda (p) (pp indent+ ,(expr>string/MATLAB (second p) (first p)))) ieqs) 954 (pp indent "}")) 955 956 (if hasode? 957 (begin 958 (pp indent ,nl (DERIVATIVE states "{")) 959 (let* ((stateeqdefs (reverse (poset>stateeqdefs poset sys kinetic))) 960 (pooleqdefs 961 (map (lambda (ep) 962 (let* ((epname (first ep)) 963 (poolion (assoc epname poolions)) 964 (iname (second poolion)) 965 (initname (matlabname (s+ epname 'init))) 966 (tempname (matlabname (s+ epname 'tempadj))) 967 (betaname (matlabname (s+ epname 'beta))) 968 (depthname (matlabname (s+ epname 'depth))) 969 (rhs `(let ((F 96485.0)) 970 ( (/ (neg ,iname) (* 2 F ,initname ,depthname)) 971 (* ,betaname ,epname . 972 ,(if tempname (list tempname) (list))))))) 973 `(,(s+ epname "'") ,rhs))) 974 epools)) 975 (eqdefs (append pooleqdefs stateeqdefs)) 976 (locals (findlocals (map second eqdefs)))) 977 (if (not (null? locals)) (pp indent+ (LOCAL ,(sl\ ", " locals)))) 978 (foreach (lambda (def) 979 (let ((n (first def)) (b (second def))) 980 (pp indent+ ,(expr>string/MATLAB b n)))) eqdefs)) 981 982 (pp indent "}"))) 983 984 # 985 986 ))))))) 750 751 (stateeqdefs (reverse (poset>stateeqdefs poset sys))) 752 753 (stcompeqdefs (poset>stcompeqdefs poset sys)) 754 755 (pooleqdefs 756 (map (lambda (ep) 757 (let* ((epname (first ep)) 758 (poolion (assoc epname poolions)) 759 (iname (second poolion)) 760 (initname (matlabname (s+ epname 'init))) 761 (tempname (matlabname (s+ epname 'tempadj))) 762 (betaname (matlabname (s+ epname 'beta))) 763 (depthname (matlabname (s+ epname 'depth))) 764 (rhs `(let ((F 96485.0)) 765 ( (/ (neg ,iname) (* 2 F ,initname ,depthname)) 766 (* ,betaname ,epname . 767 ,(if tempname (list tempname) (list))))))) 768 `(,(s+ epname) ,rhs))) 769 epools)) 770 771 (rateeqdefs (append pooleqdefs stateeqdefs)) 772 773 (stateindexmap (let ((acc (fold (lambda (def ax) 774 (let ((stname (first def))) 775 (list (+ 1 (first ax)) 776 (cons `(,stname ,(first ax)) (second ax))))) 777 (list 0 (list)) rateeqdefs))) 778 (second acc))) 779 ) 780 781 782 (pp indent+ (dy = zeros(length(y),1))) 783 784 (foreach (lambda (def) 785 (let ((n (first def)) ) 786 (pp indent+ (,n = ,(s+ "y(" (lookupdef n stateindexmap) ")"))))) rateeqdefs) 787 788 (foreach (lambda (def) 789 (let ((n (first def)) (b (second def))) 790 (pp indent+ ,(expr>string/MATLAB b n)))) stcompeqdefs) 791 792 (foreach (lambda (def) 793 (let ((n (s+ "dy(" (lookupdef (first def) stateindexmap) ")")) (b (second def))) 794 (pp indent+ ,(expr>string/MATLAB b n)))) rateeqdefs) 795 796 (foreach (lambda (poolion) 797 (pp indent+ (,(third poolion) = ,(first poolion)))) poolions) 798 799 (foreach (lambda (def) 800 (pp indent+ ,(expr>string/MATLAB (second def) (first def)))) ieqs) 801 802 ))))))))
Note: See TracChangeset
for help on using the changeset viewer.