Changeset 12685 in project for release/3/nemo/trunk/nemo-utils.scm


Ignore:
Timestamp:
12/01/08 06:47:14 (13 years ago)
Author:
Ivan Raikov
Message:

Bug fixes.

File:
1 edited

Legend:

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

    r12624 r12685  
    3838          if-convert let-enum let-elim let-lift
    3939          s+ sw+ sl\ nl spaces ppf
    40           transitions-graph
     40          transitions-graph state-lineqs
    4141          ))
    4242
     
    8282         (('if c t e)
    8383          `(if ,(k c subst) ,(k t subst) ,(k e subst)))
     84
    8485         (('let bs e)
    85           (k `(let ,(map (lambda (b) `(,(car b) ,(k (cadr b) subst))) bs) ,(k e subst)) subst))
     86          (k `(let ,(map (lambda (b) `(,(car b) ,(k (cadr b) subst))) bs) ,(k e subst))
     87             subst))
     88
    8689         ((f . es)
    8790          (cons (k f subst) (map (lambda (e) (k e subst)) es)))
     91
    8892         ((? symbol? )  (lookup-def t subst t))
     93
    8994         ((? atom? ) t)))
    9095
     
    188193    (let* ((nodes  ((g 'nodes)))
    189194           (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))))
     195           (snex   (let ((nodes/s (filter-map (lambda (s) (and (not (= (first s) (first snode))) (second s))) nodes))
     196                         (sumvar  (gensym "sum")))
     197                     `(let ((,sumvar ,(sum nodes/s))) (- 1 ,sumvar))))
    191198           (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)))))))))
     199                         (let* ((i   (car (alist-ref s0 name->id-map)))
     200                                (j   (car (alist-ref s1 name->id-map)))
     201                                (x0  (if (eq? s0 (second snode)) snex s0))
     202                                (x1  (if (eq? s1 (second snode)) snex s1))
     203                                (ij-expr  `(* ,(subst-convert x0 node-subs) ,(subst-convert rexpr1 node-subs)))
     204                                (ji-expr  (and rexpr2
     205                                               `(* ,(subst-convert x1 node-subs) ,(subst-convert rexpr2 node-subs)))))
     206                           (add-edge! (list i j ij-expr))
     207                           (if rexpr2 (add-edge! (list j i ji-expr)))))))
    200208      ;; create rate edges in the graph
    201209      (for-each (lambda (e)
     
    210218      (list g node-subs))))
    211219
     220
     221(define (state-lineqs n transitions lineqs state-name)
     222  (let* ((subst-convert  (subst-driver (lambda (x) (and (symbol? x) x)) binding? identity bind subst-term))
     223         (state-list     (let loop ((lst (list)) (tlst transitions))
     224                           (if (null? tlst)  (delete-duplicates lst eq?)
     225                               (match (car tlst)
     226                                      (('-> (and (? symbol?) s0) (and (? symbol?) s1) rate-expr)
     227                                       (loop (cons* s0 s1 lst) (cdr tlst)))
     228                                      (((and (? symbol?) s0) '-> (and (? symbol? s1)) rate-expr)
     229                                       (loop (cons* s0 s1 lst) (cdr tlst)))
     230                                      (('<-> (and (? symbol?) s0) (and (? symbol?) s1) rate-expr1 rate-expr2)
     231                                       (loop (cons* s0 s1 lst) (cdr tlst)))
     232                                      (((and (? symbol?) s0) 'M-> (and (? symbol? s1)) rate-expr1 rate-expr2)
     233                                       (loop (cons* s0 s1 lst) (cdr tlst)))
     234                                      (else
     235                                       (nemo:error 'nemo:state-lineq ": invalid transition equation "
     236                                                   (car tlst) " in state complex " n))
     237                                      (else (loop lst (cdr tlst)))))))
     238         (state-subs     (fold (lambda (s ax) (subst-extend s (state-name n s) ax)) subst-empty state-list))
     239         (lineqs1        (map (lambda (lineq) (match lineq ((i '= . expr) `(,i = . ,(subst-convert expr state-subs)))))
     240                              lineqs)))
     241    (list n lineqs1)))
Note: See TracChangeset for help on using the changeset viewer.