Changeset 20836 in project


Ignore:
Timestamp:
10/14/10 04:00:13 (11 years ago)
Author:
Ivan Raikov
Message:

9ML-toolkit: diagram generator rewrite

Location:
release/4/9ML-toolkit/trunk
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • release/4/9ML-toolkit/trunk/9ML-toolkit.meta

    r20828 r20836  
    2525
    2626 (needs datatype static-modules miniML getopt-long
    27         ssax sxml-transforms sxpath object-graph signal-diagram
     27        ssax sxml-transforms sxpath object-graph format-graph
     28        signal-diagram interval-digraph
    2829        setup-helper)
    2930
  • release/4/9ML-toolkit/trunk/9ML-toolkit.setup

    r20764 r20836  
    4040
    4141(copy-file-to-9ML-dir "examples/LeakyIAF.9ML" )
     42(copy-file-to-9ML-dir "examples/LeakyIAF_tests.9ML" )
    4243
    4344
  • release/4/9ML-toolkit/trunk/examples/LeakyIAF.9ML

    r20828 r20836  
    2828
    2929
    30 val make_diagram V t gL vL Isyn C theta tspike spike Vreset trefractory refractory_end =
     30val make_diagram V t gL vL Isyn C theta tspike spike Vreset trefractory refractory_end tstep =
    3131
    32   val subthreshold_eq  = D.ODE `V `t (S.div (S.add (S.mul (S.neg gL) (S.sub V vL)) Isyn) C)
    33   val threshold_detect  = D.ASSIGN `spike (S.gte V theta)
    34   val tspike_assignment  = D.ASSIGN `tspike (S.cond spike t tspike)
    35   val subthreshold_regime  = D.SEQUENCE subthreshold_eq
    36                                           (D.SEQUENCE threshold_detect
    37                                                       (D.DUP D.IDENTITY tspike_assignment))
    38   val refractory_eq  = D.ASSIGN `V Vreset
    39   val check_refractory_time  = D.ASSIGN `refractory_end (S.gte t (S.add tspike trefractory))
    40   val refractory_regime  = D.UNION refractory_eq check_refractory_time
     32  val subthreshold_eq           = D.ODE `t `V (S.div (S.add (S.mul (S.neg gL) (S.sub V vL)) Isyn) C)
     33  val threshold_detect          = D.ASSIGN `spike (S.gte V theta)
     34  val tspike_assignment         = D.ASSIGN `tspike (S.cond spike t tspike)
     35  val subthreshold_regime       = D.DUP subthreshold_eq (D.DUP threshold_detect tspike_assignment)
     36  val refractory_eq             = D.ASSIGN `V Vreset
     37  val check_refractory_time     = D.ASSIGN `refractory_end (S.gte t (S.add tspike trefractory))
     38  val increment_refractory_time = D.ASSIGN `t (S.add t tstep)
     39  val refractory_regime         = D.UNION (D.UNION refractory_eq check_refractory_time )
     40                                          increment_refractory_time
    4141 
    4242  return D.RTRANSITION subthreshold_regime refractory_regime spike refractory_end
     43
    4344
    4445
     
    5556                                        ( S.realsig `trefractory 5.0 )
    5657                                        ( S.boolsig `refractory_end false )
     58                                        ( S.realsig `tstep  0.001 )
    5759
    5860(* a graph to represent the excitatory population *)
  • release/4/9ML-toolkit/trunk/report.scm

    r20828 r20836  
    2222(require-extension setup-api srfi-13 datatype static-modules miniML miniMLsyntax miniMLparse miniMLeval )
    2323(require-extension getopt-long ssax sxml-transforms sxpath sxpath-lolevel object-graph)
    24 (require-extension signal-diagram)
     24(require-extension signal-diagram interval-digraph format-graph)
    2525
    2626(include "SXML.scm")
     
    419419  (define (generate-diagram diagram-id tree)
    420420
    421     (print "diagram-id = " diagram-id)
    422 
    423421    (let ((sexpr (sxml-value->sexpr tree)))
    424422
    425     (print "sexpr = " sexpr)
    426 
    427423      (reset-graph)
    428       (let recur ((sexpr sexpr) (cluster #f))
     424      (let recur ((sexpr sexpr))
    429425        (or (and (pair? sexpr)
    430426                 (case (car sexpr)
    431427                        ((diagram)
    432428                         (let ((sexpr (cdr sexpr)))
     429
    433430                            (case (car sexpr)
     431
    434432                              ((RTRANSITION) 
    435433                                (let ((f (cadr sexpr)) (fk (caddr sexpr))
    436434                                      (e (recur (cadddr sexpr))) (ek (recur (car (cddddr sexpr)))))
    437                                   (let ((fnode (register-node f))
    438                                         (fknode (register-node fk)))
    439                                     (if cluster (add-to-cluster cluster fnode))
    440                                     (if cluster (add-to-cluster cluster fknode))
    441                                     (let ((fcluster (new-cluster (node-name fnode)))
    442                                           (fkcluster (new-cluster (node-name fknode))))
    443                                       (add-to-cluster fcluster fnode)
    444                                       (add-to-cluster fkcluster fknode)
    445                                       (recur f fcluster)
    446                                       (recur fk fkcluster)
    447                                       (let ((edge1  (register-edge f fk))
    448                                             (edge2  (register-edge fk f)))
    449                                         (set-label edge1 e)
    450                                         (set-label edge2 ek)
    451                                         )))))
     435                                  (let ((node (register-node (gensym 'rtransition)))
     436                                        (fnode (recur f))
     437                                        (fknode (recur fk)))
     438                                    (print "node= " node)
     439                                    (print "fnode= " fnode)
     440                                    (print "fknode= " fknode)
     441                                    (set-label node "RTRANSITION")
     442                                    (let ((edge1  (register-edge node fnode))
     443                                          (edge2  (register-edge node fknode)))
     444                                      (set-label edge1 e)
     445                                      (set-label edge2 ek)
     446                                      node
     447                                      ))))
    452448                               
    453                                ((IDENTITY)       (void))
     449                               ((IDENTITY)       (let ((node (register-node (gensym 'IDENTITY))))
     450                                                   (set-label node "IDENTITY")
     451                                                   node))
    454452                               ((PURE)           (let ((f (sexpr->function (cadr sexpr))))
    455                                                    (let ((node (register-node sexpr)))
     453                                                   (let ((node (register-node (gensym 'function))))
    456454                                                     (set-label node (sprintf "fn ~A => ~A"
    457455                                                                              (function-formals f)
    458                                                                               (function-body f))))))
    459                                ((SEQUENCE)       (let ((e1 (cadr sexpr)) (e2 (caddr sexpr)))
    460                                                    (sprintf "fn ~A | ~A" e1 e1)
    461                                                    ))
    462                                ((UNION)          (UNION (recur (cadr sexpr)) (recur (caddr sexpr))))
    463                                ((DUP)            (DUP (recur (cadr sexpr)) (recur (caddr sexpr))))
    464                                ((SENSE)          (SENSE (cadr sexpr) (recur (caddr sexpr))))
    465                                ((ACTUATE)        (ACTUATE (cadr sexpr) (recur (caddr sexpr))))
    466                                ((LOOP)           (LOOP (cadr sexpr) (recur (caddr sexpr))))
    467                                ((ODE)            (ODE (cadr sexpr) (caddr sexpr) (recur (cadddr sexpr))))
    468                                ((ASSIGN)         (ASSIGN (cadr sexpr) (recur (caddr sexpr))))
     456                                                                              (function-body f)))
     457                                                     node)))
     458                               ((SEQUENCE)       (let ((n1 (recur (cadr sexpr)))
     459                                                       (n2 (recur (caddr sexpr))))
     460                                                   (let ((node (register-node (gensym 'sequence))))
     461                                                     (set-label node "SEQUENCE")
     462                                                     (let ((edge1 (register-edge node n1))
     463                                                           (edge2 (register-edge node n2)))
     464                                                       (set-label edge1 "n1")
     465                                                       (set-label edge1 "n2")
     466                                                       node
     467                                                       ))))
     468                               ((UNION)          (let ((n1 (recur (cadr sexpr)))
     469                                                       (n2 (recur (caddr sexpr))))
     470                                                   (let ((node (register-node (gensym 'UNION))))
     471                                                     (set-label node "UNION")
     472                                                     (let ((edge1 (register-edge node n1))
     473                                                           (edge2 (register-edge node n2)))
     474                                                       (set-label edge1 "n1")
     475                                                       (set-label edge1 "n2")
     476                                                       node
     477                                                       ))))
     478                               ((DUP)            (let ((n1 (recur (cadr sexpr)))
     479                                                       (n2 (recur (caddr sexpr))))
     480                                                   (let ((node (register-node (gensym 'DUP))))
     481                                                     (set-label node "DUP")
     482                                                     (let ((edge1 (register-edge node n1))
     483                                                           (edge2 (register-edge node n2)))
     484                                                       (set-label edge1 "n1")
     485                                                       (set-label edge1 "n2")
     486                                                       node
     487                                                       ))))
     488                               ((SENSE)          (let ((sns (cadr sexpr)) (n (recur (caddr sexpr))))
     489                                                   (let ((node (register-node (gensym 'SENSE))))
     490                                                     (set-label node (sprintf "SENSE ~A" sns))
     491                                                     (let ((edge (register-edge node n)))
     492                                                       node
     493                                                       ))))
     494                                                   
     495                               ((ACTUATE)        (let ((sns (cadr sexpr)) (n (recur (caddr sexpr))))
     496                                                   (let ((node (register-node (gensym 'ACTUATE))))
     497                                                     (set-label node (sprintf "ACTUATE ~A" sns))
     498                                                     (let ((edge (register-edge node n)))
     499                                                       node
     500                                                       ))))
     501                               ((LOOP)           (let ((sns (cadr sexpr)) (n (recur (caddr sexpr))))
     502                                                   (let ((node (register-node (gensym 'LOOP))))
     503                                                     (set-label node (sprintf "LOOP ~A" sns))
     504                                                     (let ((edge (register-edge node n)))
     505                                                       node
     506                                                       ))))
     507                               ((ODE)            (let ((ivar (cadr sexpr)) (dvar (caddr sexpr))
     508                                                       (rhs (recur (cadddr sexpr))))
     509                                                   (let ((node (register-node (gensym 'ODE))))
     510                                                     (set-label node (sprintf "D (~A ~A) = ~A" dvar ivar rhs))
     511                                                     node
     512                                                     )))
     513                               ((ASSIGN)         (let ((var (cadr sexpr))
     514                                                       (rhs (recur (caddr sexpr))))
     515                                                   (let ((node (register-node (gensym 'ASSGIN))))
     516                                                     (set-label node (sprintf "~A = ~A" var rhs))
     517                                                     node
     518                                                     )))
    469519
    470520                               (else (error 'generate-diagram "invalid diagram constructor" sexpr)))))
     
    472522                        ((realsig)   (let ((name (cadr sexpr))
    473523                                           (value (caddr sexpr)))
    474                                        (initenv (cons (cons name value) (initenv)))
    475524                                       name))
    476525
    477526                        ((boolsig)   (let ((name (cadr sexpr))
    478527                                           (value (caddr sexpr)))
    479                                        (initenv (cons (cons name value) (initenv)))
    480528                                       name))
     529
     530                        (else (map recur sexpr))
    481531                        ))
    482              (register-node sexpr)))
     532             sexpr))
    483533
    484534      (let* ((dir (pathname-directory prefix))
     
    495545      ))
    496546
     547  (define (generate-graph graph-id tree)
     548
     549    (let ((sexpr (sxml-value->sexpr tree)))
     550
     551      (let recur ((sexpr sexpr) (g  (make-digraph  'graph  "NineML graph")))
     552        (or (and (pair? sexpr)
     553                 (case (car sexpr)
     554                        ((graph)
     555                         (let ((sexpr (cdr sexpr)))
     556
     557                            (case (car sexpr)
     558
     559                               ((IDENTITY)       (let ((node (register-node (gensym 'IDENTITY))))
     560                                                   (set-label node "IDENTITY")
     561                                                   node))
     562
     563                               (else (error 'generate-graph "invalid graph constructor" sexpr)))))
     564
     565
     566                        (else (map recur sexpr))
     567                        ))
     568             sexpr))
     569
     570      (let* ((dir (pathname-directory prefix))
     571             (dot-path (make-pathname dir (string-append (->string graph-id) ".dot")))
     572             (png-path (make-pathname dir (string-append (->string graph-id) ".png"))))
     573
     574        (with-output-to-file  dot-path
     575          (lambda ()
     576            ((make-format-graph 'dot) (current-output-port) g)
     577            ))
     578       
     579        (run (dot -Tpng ,dot-path > ,png-path))
     580        )
     581       
     582      ))
     583
    497584  (let-syntax
    498585      (
     
    693780                            (value (sxml:kidn-cadr 'value node))
    694781                            (tuple-label ((sxpath '(tuple left const label *text*)) `(*TOP* ,value))))
     782
    695783                       (if (not name) (error 'type-env-report "binding element requires name attribute"))
     784
    696785                       (cond ((and (pair? tuple-label) (equal? (car tuple-label) "diagram")) ;; value is a diagram
    697786                              (let* ((diagram-id (gensym 'diagram))
     
    699788                                (generate-diagram diagram-id value)
    700789                                `(,(line "binding " (b ,name) " = ") ,diagram-link)))
     790
     791                              ((and (pair? tuple-label) (equal? (car tuple-label) "graph")) ;; value is a graph
     792                              (let* ((graph-id (gensym 'graph))
     793                                     (graph-link `(img (@ (src ,(string-append (->string graph-id) ".png"))) (alt "NineML graph"))))
     794                                (generate-graph graph-id value)
     795                                `(,(line "binding " (b ,name) " = ") ,graph-link)))
    701796
    702797                             ((and (pair? tuple-label) (equal? (car tuple-label) "ivp")) ;; value is an IVP
Note: See TracChangeset for help on using the changeset viewer.