Changeset 21504 in project


Ignore:
Timestamp:
11/17/10 12:16:30 (9 years ago)
Author:
Ivan Raikov
Message:

9ML-toolkit: partial support for abbreviated equation notation

Location:
release/4/9ML-toolkit/trunk
Files:
2 added
1 deleted
8 edited

Legend:

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

    r20901 r21504  
    2525 ; A list of eggs 9ML-toolkit depends on.
    2626
    27  (needs datatype static-modules miniML (getopt-long  1.8)
     27 (needs matchable datatype static-modules miniML (getopt-long  1.8)
    2828        ssax sxml-transforms sxpath object-graph format-graph
    2929        signal-diagram silex lalr setup-helper)
  • release/4/9ML-toolkit/trunk/9ML-toolkit.setup

    r20900 r21504  
    1414                  -e "'(lex \"NineML.l\" \"NineML.l.scm\" (quote counters) (quote line))'")))
    1515
     16       ("expr.grm.scm" ("expr.grm")
     17        (run (csi -s expr.grm)))
     18
    1619       ("9ML-report"
    1720        ("NineMLcore.scm" "NineMLsignal.scm" "NineMLdiagram.scm" "NineMLinterval.scm"
    1821         "NineMLgraph.scm" "NineMLivp.scm" "NineMLparse.scm" "NineML.l.scm" "NineML.grm.scm"
     22         "expr.grm.scm" "expr-parser.scm"
    1923         "report.scm" )
    2024        (compile -O -d2 -S report.scm -o 9ML-report ))
  • release/4/9ML-toolkit/trunk/NineML.grm

    r20900 r21504  
    2727(require-extension lalr static-modules miniML)
    2828
    29 (define expr-parser
     29(define parser
    3030  (lalr-parser
    3131
     
    4040          IF IN  LET  MODULE
    4141          RPAREN SEMISEMI RETURN
    42           SIG STRUCT THEN TYPE VALUE
    43           (left: COMMA DOT FUNCTION)
    44           (left: LG LESS LEQ GREATER GEQ EQ EQUAL)
    45           (left: PLUS MINUS STAR SLASH)
     42          SIG STRUCT THEN TYPE VALUE SEXPR
     43          (left:  COMMA DOT FUNCTION)
     44          (left:  LG LESS LEQ GREATER GEQ EQEQ EQUAL)
     45          (left:  PLUS MINUS STAR SLASH)
    4646          (right: ARROW)
    4747          (right: LPAREN SEMICOLON COLON QUOTE))
     
    5959    (IDENT)            : (Pident  (token-value $1))
    6060    (path DOT IDENT)   : (Pdot $1 (ident-name (token-value $3))) )
    61 
    6261   ;; Value expressions for the core language
    6362
    6463   (valexpr
    65     (valexpr1)                          : $1
    66     (valexpr COMMA valexpr)             : (binop "pair" $1 $3 )
    67     (valexpr PLUS valexpr)              : (binop "add" $1 $3 )
    68     (valexpr MINUS valexpr)             : (binop "sub" $1 $3 )
    69     (valexpr STAR valexpr)              : (binop "mul" $1 $3 )
    70     (valexpr SLASH valexpr)             : (binop "div" $1 $3 )
    71     (valexpr EQ valexpr)                : (binop "==" $1 $3 )
    72     (valexpr LG valexpr)                : (binop "<>" $1 $3 )
    73     (valexpr LESS valexpr)              : (binop "<" $1 $3 )
    74     (valexpr LEQ valexpr)               : (binop "<=" $1 $3 )
    75     (valexpr GREATER valexpr)           : (binop ">" $1 $3 )
    76     (valexpr GEQ valexpr)               : (binop ">=" $1 $3 )
    77     (FUNCTION IDENT ARROW valexpr)      : (Function (token-value $2) $4)
    78     (LET IDENT valbind IN valexpr)      : (Let0 (token-value $2) $3 $5)
    79     (RETURN valexpr)                    : $2
    80     (VALUE IDENT valbind valexpr)       : (Let0 (token-value $2) $3 $4)
     64    (valexpr1)                             : $1
     65    (valexpr COMMA valexpr)                : (binop "pair" $1 $3 )
     66    (valexpr PLUS valexpr)                 : (binop "add" $1 $3 )
     67    (valexpr MINUS valexpr)                : (binop "sub" $1 $3 )
     68    (valexpr STAR valexpr)                 : (binop "mul" $1 $3 )
     69    (valexpr SLASH valexpr)                : (binop "div" $1 $3 )
     70    (valexpr EQEQ valexpr)                 : (binop "==" $1 $3 )
     71    (valexpr LG valexpr)                   : (binop "<>" $1 $3 )
     72    (valexpr LESS valexpr)                 : (binop "<" $1 $3 )
     73    (valexpr LEQ valexpr)                  : (binop "<=" $1 $3 )
     74    (valexpr GREATER valexpr)              : (binop ">" $1 $3 )
     75    (valexpr GEQ valexpr)                  : (binop ">=" $1 $3 )
     76    (FUNCTION IDENT ARROW valexpr)         : (Function (token-value $2) $4)
     77    (LET IDENT valbind IN valexpr)         : (Let0 (token-value $2) $3 $5)
     78    (RETURN valexpr)                       : $2
     79    (VALUE IDENT valbind valexpr)          : (Let0 (token-value $2) $3 $4)
    8180    (IF valexpr THEN valexpr ELSE valexpr) : (ternop "cond" $2 $4 $6)
     81    (SEXPR)                                : (begin
     82                                               (print "sexpr = " (list->string (reverse (token-value $1))))
     83                                               (print "read sexpr = " (read (open-input-string (list->string (reverse (token-value $1))))))
     84                                               (sexpr-parser (read (open-input-string (list->string (reverse (token-value $1)))))))
    8285    )
    8386
     
    101104
    102105   (simpletype
    103     (QUOTE IDENT)                 : (Tvar (find-type-variable (token-value $2)) )
    104     (simpletype ARROW simpletype) : (Tcon path-arrow (list $1 $3))
    105     (simpletype STAR simpletype)  : (Tcon path-star (list $1 $3))
    106     (path)                        : (Tcon $1 '())
    107     (simpletype path)             : (Tcon $2 (list $1))
    108     (LPAREN simpletypelist RPAREN path) :  (Tcon $4 (reverse $2))
     106    (QUOTE IDENT)                       : (Tvar (find-type-variable (token-value $2)))
     107    (simpletype ARROW simpletype)       : (Tcon path-arrow (list $1 $3))
     108    (simpletype STAR simpletype)        : (Tcon path-star (list $1 $3))
     109    (path)                              : (Tcon $1 '())
     110    (simpletype path)                   : (Tcon $2 (list $1))
     111    (LPAREN simpletypelist RPAREN path) : (Tcon $4 (reverse $2))
    109112    )
    110113
    111114
    112115   (simpletypelist
    113     (simpletype) : (list $1)
     116    (simpletype)                      : (list $1)
    114117    (simpletypelist COMMA simpletype) : (cons $3 $1)
    115118    )
     
    139142
    140143   (typeparams
    141     () : '()
    142     (typeparam) :  (list $1)
     144    ()                            : '()
     145    (typeparam)                   :  (list $1)
    143146    (LPAREN typeparamlist RPAREN) : (reverse $2))
    144147
  • release/4/9ML-toolkit/trunk/NineML.l

    r20900 r21504  
    3939("val"|"binding")                (tok (VALUE))
    4040
     41
    4142"function"         (tok (FUNCTION))
    4243"fun"              (tok (FUNCTION))
     
    6566-?(({decimal}+(\.{decimal}+)?)|(\.{decimal}+))([eE]([-+])?{decimal}+)?   (tok (REAL ,(string->number yytext)))
    6667
     68"["                       (let loop ((kont (lambda (x) (tok (SEXPR ,x)))) (result '(#\()))
     69                             (let ((c (yygetc)))
     70                               (cond ((eq? 'eof c)    (lexer-error "unexpected end of expression"))
     71                                     ((char=? #\] c)  (kont (cons #\) result)))
     72                                     ((char=? #\[ c)  (loop (lambda (x) (loop kont (append x result))) '(#\()))
     73                                     (else            (loop kont (cons c result)))
     74                                     )))
     75
    6776"(*"                       (let loop ((kont yycontinue))
    6877                             (let ((c (yygetc)))
     
    8695"-"                                (tok (MINUS))
    8796"/"                                (tok (SLASH))
    88 "=="                               (tok (EQ))
     97"=="                               (tok (EQEQ))
    8998"<>"                               (tok (LG))
    9099"<"                                (tok (LESS))
  • release/4/9ML-toolkit/trunk/NineMLparse.scm

    r20900 r21504  
    11;;
    2 ;;  A parser for a simple ML-like language.
     2;;  A parser for NineML + syntactic sugar.
    33;;
    44;;  Based on the code and paper by Xavier Leroy (2000): A modular
     
    3030
    3131        (import scheme chicken
    32                 (only srfi-1 fold combine every unzip2 filter-map)
    33                 (only data-structures conc)
     32                (only srfi-1 fold combine every unzip2 filter-map partition delete-duplicates)
     33                (only srfi-13 string-null?)
     34                (only data-structures conc ->string)
    3435                (only extras fprintf))
    35         (require-extension extras static-modules miniML miniMLsyntax)
     36        (require-extension extras matchable static-modules miniML miniMLsyntax)
    3637
    3738
     
    4445  (core-utils))
    4546
     47
    4648(define-record token symbol value line)
    4749
     
    5153           (token-value x) ))
    5254
     55
    5356(define (token p line)
    5457  (cons (car p)
     
    5659               [else (make-token (car p) #f line)])))
    5760
     61
    5862(define-syntax tok
    5963  (syntax-rules ()
    6064    ((tok t)   (token (quasiquote t) 0))
    6165    ((tok t l) (token (quasiquote t) l))))
     66
    6267
    6368(define (make-parse-error loc)
     
    7681(include "NineML.l.scm")
    7782(include "NineML.grm.scm")
     83(include "expr-parser.scm")
     84(include "expr.grm.scm")
     85
     86(define-record-type algebraic-eqn
     87  (make-algebraic-eqn quantity rhs)
     88  algebraic-eqn?
     89  (quantity algebraic-eqn-quantity)
     90  (rhs algebraic-eqn-rhs))
     91
     92
     93(define-record-type ode-eqn
     94  (make-ode-eqn indep dep rhs)
     95  ode-eqn?
     96  (indep ode-eqn-indep)
     97  (dep   ode-eqn-dep)
     98  (rhs   ode-eqn-rhs))
     99
     100
     101(define-record-type relation
     102  (make-relation quantity var rhs)
     103  relation?
     104  (quantity relation-quantity)
     105  (var      relation-var)
     106  (rhs      relation-rhs))
     107
     108
     109(define (ode-eqn-or-relation? x)
     110  (or (ode-eqn? x) (relation? x)))
     111
     112
     113(define diagram-union        (Longid (Pdot (Pident (ident-create "Diagram")) "UNION")))
     114(define diagram-assign       (Longid (Pdot (Pident (ident-create "Diagram")) "ASSIGN")))
     115(define diagram-ode          (Longid (Pdot (Pident (ident-create "Diagram")) "ODE")))
     116(define diagram-relation     (Longid (Pdot (Pident (ident-create "Diagram")) "RELATION")))
     117
     118(define signal-realconst     (Longid (Pdot (Pident (ident-create "Signal")) "realconst")))
     119(define signal-boolconst     (Longid (Pdot (Pident (ident-create "Signal")) "boolconst")))
     120
     121(define (make-union rhs-list)
     122  (let ((n (length rhs-list)))
     123    (cond ((= n 1)  (car rhs-list))
     124          ((= n 2)  (Apply (Apply diagram-union (car rhs-list)) (cadr rhs-list)))
     125          (else     (make-union
     126                     (list (make-union (list (car rhs-list) (cadr rhs-list)) )
     127                           (make-union (cddr rhs-list))))))))
     128
     129(define (make-list value-list)
     130  (let recur ((value-list (reverse value-list))
     131              (value (Longid (Pident (ident-create "empty")))))
     132    (if (null? value-list) value
     133        (recur (cdr value-list)
     134               (Apply (Apply (Longid (Pident (ident-create "cons"))) (car value-list))
     135                      value)))
     136    ))
     137
     138
     139(define (make-relation relation-list value)
     140  (if (null? relation-list) value
     141      (let ((relation (car relation-list)))
     142        (Apply
     143         (Apply
     144          (Apply
     145           (Apply diagram-relation (Const `(label ,(relation-quantity relation))))
     146           (Const `(label ,(relation-var relation))))
     147          (relation-rhs relation))
     148         (make-relation (cdr relation-list) value)))
     149      ))
     150
     151
     152(define (op->signal-function op)
     153  (let ((name (case op
     154                ((+)  "add")
     155                ((*)  "mul")
     156                ((/)  "div")
     157                (else (->string op)))))
     158    (Longid (Pdot (Pident (ident-create "Signal")) name))))
     159   
     160
     161(define (make-signal-expr expr)
     162  (cond ((number? expr) (Apply signal-realconst (Const `(real ,expr))))
     163        ((symbol? expr) (case expr
     164                          ((false) (Apply signal-boolconst (Const `(bool #f))))
     165                          ((true)  (Apply signal-boolconst (Const `(bool #f))))
     166                          (else (Longid (Pident (ident-create (->string expr)))))))
     167        (else
     168         (match expr
     169
     170                (('- a) 
     171                 (Apply (op->signal-function "neg") (make-signal-expr a)))
     172
     173                (('- a b) 
     174                 (Apply (Apply (op->signal-function "sub") (make-signal-expr a))
     175                        (make-signal-expr b)))
     176               
     177                (('if a b c) 
     178                 (Apply
     179                  (Apply
     180                   (Apply (Apply op->signal-function "if")
     181                          (make-signal-expr a))
     182                   (make-signal-expr b))
     183                  (make-signal-expr c)))
     184               
     185                (((and op (? symbol?)) a b)
     186                 (Apply (Apply (op->signal-function op)
     187                               (make-signal-expr a))
     188                        (make-signal-expr b)))
     189               
     190                (((and op (? symbol?)) a)
     191                 (Apply (op->signal-function op)
     192                        (make-signal-expr a)))
     193               
     194                (else (error 'make-signal-expr "invalid signal expression" expr))))
     195        ))
     196
     197
     198(define (sexpr-eqn-parser x)
     199  (match x
     200         (((or 'D 'd) (indep dep) '= . rhs)
     201          (let ((rhs   (parse-sym-expr rhs)))
     202            (make-ode-eqn indep dep (make-signal-expr rhs))))
     203
     204         (((and quantity (? symbol?)) (var) '= . rhs)
     205          (let ((rhs (parse-sym-expr rhs)))
     206            (make-relation quantity var (make-signal-expr rhs))))
     207
     208        (((and quantity (? symbol?))  '= . rhs)
     209         ;; algebraic equation: quantity = rhs
     210         (let ((rhs  (parse-sym-expr rhs)))
     211           (make-algebraic-eqn quantity (make-signal-expr rhs))))
     212
     213        (else
     214         (error 'sexpr-eqn-parser "invalid equation" x))
     215        ))
     216                   
     217
     218(define (sexpr-parser lst)
     219  (match lst
     220
     221         (((? symbol?) . rest)
     222          (let ((eqn (sexpr-eqn-parser lst)))
     223            (cond ((ode-eqn? eqn)
     224                   (let ((rhs (ode-eqn-rhs eqn))
     225                         (dep (ode-eqn-dep eqn))
     226                         (indep (ode-eqn-indep eqn)))
     227                     (Apply
     228                      (Apply
     229                       (Apply diagram-ode (Const `(label ,indep)))
     230                       (make-list (list (Const `(label ,dep)))))
     231                      rhs)
     232                     ))
     233
     234                  ((algebraic-eqn? eqn)
     235                   (let ((rhs (algebraic-eqn-rhs eqn))
     236                         (quantity (algebraic-eqn-quantity eqn)))
     237                     (Apply
     238                      (Apply
     239                       (Apply diagram-assign (make-list (list (Const `(label ,quantity)))))
     240                       rhs))
     241                      ))
     242                 
     243                  )))
     244                   
     245
     246
     247
     248         (((? pair?) . rest)
     249
     250          (let ((eqlst ((map sexpr-eqn-parser lst))))
     251
     252           (cond ((every algebraic-eqn? eqlst)
     253                  (let ((qs (map (lambda (x) (Const `(label ,(algebraic-eqn-quantity x)))) eqlst)))
     254                    (Apply (Apply diagram-assign (make-list qs))
     255                           (make-union (map algebraic-eqn-rhs eqlst)))))
     256
     257                 ((every ode-eqn? eqlst)
     258                  (let ((indeps (delete-duplicates (map ode-eqn-indep eqlst)))
     259                        (deps   (map  ode-eqn-dep eqlst)))
     260                    (match (list deps indeps)
     261                           (((dep . _) (indep))
     262                            (Apply (Apply (Apply diagram-ode (Const `(label ,indep)))
     263                                          (make-list (map (lambda (x) (Const `(label ,x))) deps)))
     264                                   (make-union (map ode-eqn-rhs eqlst))))
     265                           (else (error 'sexpr-parser "invalid system of ODE equations" eqlst)))))
     266
     267                 ((every ode-eqn-or-relation? eqlst)
     268                  (let-values (((relations ode-eqs) (partition relation? eqlst)))
     269                    (let ((indeps (delete-duplicates (map ode-eqn-indep ode-eqs)))
     270                          (deps   (map  ode-eqn-dep ode-eqs)))
     271                      (match (list deps indeps)
     272                             (((dep . _) (indep))
     273                              (Apply (Apply (Apply diagram-ode (Const `(label ,indep)))
     274                                            (make-list (map (lambda (x) (Const `(label ,x))) deps)))
     275                                     (make-relation relations (make-union (map ode-eqn-rhs ode-eqs)))))
     276                             (else (error 'sexpr-parser "invalid system of DAE equations" eqlst))))))
     277                         
     278                 (else
     279                  (error 'sexpr-parser "invalid system of equations" eqlst)))))
     280               
     281        (else (error 'sexpr-parser "invalid equational expression" lst))
     282        ))
    78283
    79284
  • release/4/9ML-toolkit/trunk/NineMLsignal.scm

    r20828 r21504  
    3333           (Value_sig (ident-create "signal")
    3434                      (make-valtype '() (arrow-type label-type sigfun-type)))
     35           
     36           (Value_sig (ident-create "realconst")
     37                      (make-valtype '() (arrow-type real-type sigfun-type)))
     38           
     39           (Value_sig (ident-create "boolconst")
     40                      (make-valtype '() (arrow-type bool-type sigfun-type)))
    3541           
    3642           (Value_sig (ident-create "realsig")
  • release/4/9ML-toolkit/trunk/examples/Diagram.9ML

    r20845 r21504  
    11
    2 component S = Signal ;;
    3 component D = Diagram ;;
    4 component G = Graph ;;
    5 
    6 component LeakyIAF =
     2component Test =
    73struct
    84
    9 binding make_diagram V t gL vL Isyn C theta =
     5binding make_diagram V t gL vL Isyn C =
    106
    11   binding subthreshold_eq =
    12     D.ODE `t `V (S.div (S.add (S.mul (S.neg gL)
    13                                      (S.sub V vL))
    14                               Isyn)
    15                         C)
     7  binding subthreshold_eq = [d (V t) = ((- gL) * (V - vL) + Isyn) / C]
     8
    169  return subthreshold_eq
    1710
  • release/4/9ML-toolkit/trunk/examples/LeakyIAF.9ML

    r20836 r21504  
    4545
    4646  val diagram = make_diagram   ( S.realsig `V      -65.0 )
    47                                         ( S.realsig `t      0.0 )
    48                                         ( S.realsig `gL     0.2 )
    49                                         ( S.realsig `vL     -70.0 )
    50                                         ( S.realsig `Isyn   20.0 )
    51                                         ( S.realsig `C      1.0 )
    52                                         ( S.realsig `theta  -25.0 )
    53                                         ( S.realsig `tspike  0.0 )
    54                                         ( S.boolsig `spike  false )
    55                                         ( S.realsig `Vreset -65.0 )
    56                                         ( S.realsig `trefractory 5.0 )
    57                                         ( S.boolsig `refractory_end false )
    58                                         ( S.realsig `tstep  0.001 )
     47                               ( S.realsig `t      0.0 )
     48                               ( S.realsig `gL     0.2 )
     49                               ( S.realsig `vL     -70.0 )
     50                               ( S.realsig `Isyn   20.0 )
     51                               ( S.realsig `C      1.0 )
     52                               ( S.realsig `theta  -25.0 )
     53                               ( S.realsig `tspike  0.0 )
     54                               ( S.boolsig `spike  false )
     55                               ( S.realsig `Vreset -65.0 )
     56                               ( S.realsig `trefractory 5.0 )
     57                               ( S.boolsig `refractory_end false )
     58                               ( S.realsig `tstep  0.001 )
    5959
    6060(* a graph to represent the excitatory population *)
Note: See TracChangeset for help on using the changeset viewer.