source: project/release/4/9ML-toolkit/trunk/parse.scm @ 30917

Last change on this file since 30917 was 30917, checked in by Ivan Raikov, 6 years ago

9ML-toolkit: reformulation of regimes to use ON signal combinator; added LIF UL xml file; fixes to AEIF example

File size: 43.7 KB
Line 
1;;
2;;  A parser for NineML + syntactic sugar.
3;;
4;;  Based on the code and paper by Xavier Leroy (2000): A modular
5;;  module system. Journal of Functional Programming, 10, pp 269-303
6;;  doi:10.1017/S0956796800003683
7;;
8;;
9;; Copyright 2010-2012 Ivan Raikov and the Okinawa Institute of
10;; Science and Technology.
11;;
12;; This program is free software: you can redistribute it and/or
13;; modify it under the terms of the GNU General Public License as
14;; published by the Free Software Foundation, either version 3 of the
15;; License, or (at your option) any later version.
16;;
17;; This program is distributed in the hope that it will be useful, but
18;; WITHOUT ANY WARRANTY; without even the implied warranty of
19;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
20;; General Public License for more details.
21;;
22;; A full copy of the GPL license can be found at
23;; <http://www.gnu.org/licenses/>.
24;;
25
26
27(module 9ML-parse
28
29        (parse parse-sexpr-macro parse-string-expr parse-sym-expr make-signal-expr
30         nineml-xmlns-base parse-al-sxml-component parse-al-sxml)
31
32        (import scheme chicken)
33        (require-library srfi-1 srfi-13 data-structures extras)
34        (import
35         (only srfi-1 concatenate fold combine any every unzip2 filter-map partition delete-duplicates cons*)
36         (only srfi-13 string-null?)
37         (only data-structures conc ->string alist-ref)
38         (only extras fprintf pp))
39
40        (require-extension matchable)
41        (require-extension sxpath sxpath-lolevel)
42        (require-extension static-modules miniML miniMLsyntax)
43
44       
45        (require-library sxml-transforms)
46        (import (prefix sxml-transforms sxml:))
47
48        (include "SXML.scm")
49
50
51  (define-values (type-variables reset-type-variables
52                                 find-type-variable instance typerepr
53                                 begin-def end-def newvar generalize
54                                 make-deftype make-valtype make-kind
55                                 binop ternop path-star path-list path-arrow
56                                 star-type list-type arrow-type label-type string-type bot-type
57                                 )
58    (core-utils))
59
60
61(define (safe-car x) (and (pair? x) (car x)))
62
63
64(define-syntax tok
65  (syntax-rules ()
66    ((tok loc t) (make-lexical-token (quasiquote t) loc #f))
67    ((tok loc t l) (make-lexical-token (quasiquote t) loc l))))
68
69
70
71(define-record-type sexpr-macro
72  (make-sexpr-macro label text)
73  sexpr-macro? 
74  (label sexpr-macro-label)
75  (text sexpr-macro-text))
76
77
78
79(define-record-type algebraic-eqn
80  (make-algebraic-eqn quantity rhs)
81  algebraic-eqn? 
82  (quantity algebraic-eqn-quantity)
83  (rhs algebraic-eqn-rhs))
84
85
86(define-record-type ode-eqn
87  (make-ode-eqn indep dep tstep rhs)
88  ode-eqn? 
89  (indep ode-eqn-indep)
90  (dep   ode-eqn-dep)
91  (tstep ode-eqn-tstep)
92  (rhs   ode-eqn-rhs))
93
94
95(define-record-type relation
96  (make-relation quantity var rhs)
97  relation? 
98  (quantity relation-quantity)
99  (var      relation-var)
100  (rhs      relation-rhs))
101
102
103(define (ode-eqn-or-relation? x)
104  (or (ode-eqn? x) (relation? x)))
105
106(define (algebraic-eqn-or-relation? x)
107  (or (algebraic-eqn? x) (relation? x)))
108
109
110
111(define sexpr-macro-hooks (make-parameter '()))
112
113
114(define (register-macro-hook label hook)
115  (assert (procedure? hook))
116  (if (not (symbol? label))
117      (error 'register-macro-hook "hook label must be a symbol" label))
118  (if (assoc label (sexpr-macro-hooks))
119      (error 'register-macro-hook "hook already exists" label))
120  (sexpr-macro-hooks (cons (cons label hook) (sexpr-macro-hooks)))
121  )
122
123
124(define (parse-sexpr-macro x)
125  (if (sexpr-macro? x)
126      (let ((label (sexpr-macro-label x)))
127        (if (not label)
128            (let ((default-handler (cdr (assoc 'default (sexpr-macro-hooks)))))
129              (default-handler x))
130            (cond ((assoc label (sexpr-macro-hooks)) =>
131                   (lambda (v) ((cdr v) (sexpr-macro-text x))))
132                  (else
133                   (error 'parse-sexpr-macro "cannot find handler for macro" label))
134                  )))
135        ))
136
137
138
139(include "NineML.grm.scm")
140(include "NineML.l.scm")
141(include "expr-parser.scm")
142
143
144(define (make-parse-error loc)
145  (lambda (msg #!optional arg)
146    (let ((loc-str (or (and loc (if (list? loc) (conc " " loc " ") (conc " (" loc ") "))) "")))
147      (cond  [(not arg) (error loc-str msg)]
148             [(lexical-token? arg)
149              (error (conc "line " (let ((src (lexical-token-source arg)))
150                                     (if (source-location? src) 
151                                         (source-location-line (lexical-token-source arg))
152                                         src)) ": " msg)
153                     loc-str
154                     (conc (lexical-token-category arg) 
155                           (if (lexical-token-value arg) (conc " " (lexical-token-value arg)) "")))]
156             [else (error loc-str (conc msg arg))]
157             ))))
158
159(define lexer-error error)
160
161
162(define (parse loc s)
163  (cond ((port? s)   (lexer-init 'port s))
164        ((string? s) (lexer-init 'string s))
165        (else (error 'parse "bad argument type; not a string or port" s)) )
166   (parser lexer (make-parse-error loc)))
167
168(define empty             (Pident (ident-create "empty")))
169
170(define list-cons         (Pident (ident-create "cons")))
171(define list-null         (Pident (ident-create "null")))
172
173(define diagram-pure         (Longid (Pdot (Pident (ident-create "Diagram")) "PURE")))
174(define diagram-group        (Longid (Pdot (Pident (ident-create "Diagram")) "GROUP")))
175(define diagram-assign       (Longid (Pdot (Pident (ident-create "Diagram")) "ASSIGN")))
176(define diagram-ode          (Longid (Pdot (Pident (ident-create "Diagram")) "ODE")))
177(define diagram-sequence     (Longid (Pdot (Pident (ident-create "Diagram")) "SEQUENCE")))
178(define diagram-union         (Longid (Pdot (Pident (ident-create "Diagram")) "UNION")))
179(define diagram-on            (Longid (Pdot (Pident (ident-create "Diagram")) "ON")))
180(define diagram-transient     (Longid (Pdot (Pident (ident-create "Diagram")) "TRANSIENT")))
181(define diagram-transition    (Longid (Pdot (Pident (ident-create "Diagram")) "TRANSITION")))
182(define diagram-rtransition   (Longid (Pdot (Pident (ident-create "Diagram")) "RTRANSITION")))
183(define diagram-relation      (Longid (Pdot (Pident (ident-create "Diagram")) "RELATION")))
184(define diagram-identity      (Longid (Pdot (Pident (ident-create "Diagram")) "IDENTITY")))
185
186(define alsys-relation      (Longid (Pdot (Pident (ident-create "AlgebraicSystem")) "RELATION")))
187(define alsys-equation      (Longid (Pdot (Pident (ident-create "AlgebraicSystem")) "EQUATION")))
188(define alsys-union         (Longid (Pdot (Pident (ident-create "AlgebraicSystem")) "UNION")))
189
190(define signal-realconst     (Longid (Pdot (Pident (ident-create "Signal")) "realconst")))
191(define signal-boolconst     (Longid (Pdot (Pident (ident-create "Signal")) "boolconst")))
192(define signal-boolsig       (Longid (Pdot (Pident (ident-create "Signal")) "boolsig")))
193(define signal-realsig       (Longid (Pdot (Pident (ident-create "Signal")) "realsig")))
194(define signal-signal        (Longid (Pdot (Pident (ident-create "Signal")) "signal")))
195
196(define (make-group rhs-list)
197  (let ((n (length rhs-list)))
198    (cond ((= n 1)  (car rhs-list))
199          ((= n 2)  (Apply (Apply diagram-group (car rhs-list)) (cadr rhs-list)))
200          (else     (make-group
201                     (list (make-group (list (car rhs-list) (cadr rhs-list)) )
202                           (make-group (cddr rhs-list))))))))
203
204(define (make-list value-list)
205  (let recur ((value-list (reverse value-list)) 
206              (value (Longid (Pident (ident-create "null")))))
207    (if (null? value-list) value
208        (recur (cdr value-list) 
209               (Apply (Apply (Longid (Pident (ident-create "cons"))) (car value-list)) 
210                      value)))
211    ))
212
213
214(define (make-relations relation-list value)
215  (if (null? relation-list) value
216      (let ((relation (car relation-list)))
217        (Apply
218         (Apply
219          (Apply
220           (Apply diagram-relation (Const `(label ,(relation-quantity relation))))
221           (Const `(label ,(relation-var relation))))
222          (relation-rhs relation))
223         (make-relations (cdr relation-list) value)))
224      ))
225
226(define (make-alsys-relations relation-list value)
227  (if (null? relation-list) value
228      (let ((relation (car relation-list)))
229        (Apply
230         (Apply
231          (Apply
232           (Apply alsys-relation (Const `(label ,(relation-quantity relation))))
233           (Const `(label ,(relation-var relation))))
234          (relation-rhs relation))
235         (make-relations (cdr relation-list) value)))
236      ))
237
238
239(define (op->signal-function op)
240  (let ((name (case op
241                ((+)   "add")
242                ((*)   "mul")
243                ((/)   "div")
244                ((>)   "gt")
245                ((<)   "lt")
246                ((>=)  "gte")
247                ((<=)  "lte")
248                (else (->string op)))))
249    (Longid (Pdot (Pident (ident-create "Signal")) name))))
250   
251
252(define (op->random-function op)
253  (define opmap '((randomUniform . "uniform")
254                  (randomNormal  . "normal")
255                  (randomPoisson . "poisson")))
256  (let ((name op))
257    (Longid (Pdot (Pident (ident-create "Random")) 
258                  (alist-ref name opmap)))))
259   
260
261
262(define (op->relation op)
263  (Apply
264   (Longid (Pdot (Pident (ident-create "Signal")) "relation"))
265   (Const `(label ,op))))
266
267(define (signal-operation? op)
268  (case op
269    ((add mul div gt gte lte neg cosh tanh log ln exp) #t)
270    (else #f)))
271
272(define (random-operation? op)
273  (case op
274    ((randomNormal randomUniform) #t)
275    (else #f)))
276
277   
278(define (make-pure sf) (Apply diagram-pure sf))
279
280
281(define (make-signal-expr expr #!key (subst '()) (argument #f))
282
283  (let recur ((expr expr))
284
285    (cond ((number? expr) 
286           (Apply signal-realconst (Const `(real ,expr))))
287
288          ((symbol? expr) 
289           (case expr 
290             ((false) (Apply signal-boolconst (Const `(bool #f))))
291             ((true)  (Apply signal-boolconst (Const `(bool #t))))
292             (else
293              (let ((v (alist-ref expr subst)))
294                (cond (v 
295                       (make-signal-expr v subst: '() argument: argument))
296                     
297                      ((equal? argument expr)
298                       (Apply signal-signal (Const `(label ,expr))))
299                     
300                      (else (Longid (Pident (ident-create (->string expr))))))))
301             ))
302
303        (else
304         (match expr
305
306                (('- a) 
307                 (Apply (op->signal-function "neg") (recur a)))
308
309                (('- a b) 
310                 (Apply (Apply (op->signal-function "sub") 
311                               (recur a))
312                        (recur b)))
313               
314                (('if a b c) 
315                 (Apply
316                  (Apply (Apply (op->signal-function "if")
317                                (recur a))
318                         (recur b))
319                  (recur c)))
320               
321                (((and op (? symbol?)) a b)
322                 (Apply
323                  (Apply (op->signal-function op) 
324                         (recur a))
325                  (recur b)))
326               
327                (((and op (? symbol?)) a)
328                 (cond ((signal-operation? op)
329                        (Apply (op->signal-function op) 
330                               (recur a)))
331                       ((random-operation? op)
332                        (Apply (op->random-function op) 
333                               (recur a)))
334                       (else
335                        (Apply (op->relation op) 
336                               (recur a)))))
337
338                (((and op (? symbol?)))
339                 (cond
340                  ((random-operation? op)
341                   (Apply (op->random-function op) (Longid empty)))
342                  (else
343                   (error 'make-signal-expr "invalid signal expression" expr))))
344               
345                (else (error 'make-signal-expr "invalid signal expression" expr))))
346        ))
347)
348
349(define (parse-sexpr-eqn x)
350  (match x
351         (((or 'D 'd) (dep indep tstep) '= . rhs)
352          (let ((rhs   (parse-string-expr (->string rhs))))
353            (make-ode-eqn indep dep tstep (make-signal-expr rhs))))
354
355         (((and quantity (? symbol?)) (var) '= . rhs)
356          (let ((rhs (parse-string-expr (->string rhs))))
357            (make-relation quantity var (make-signal-expr rhs))))
358
359        (((and quantity (? symbol?))  '= . rhs)
360         (let ((rhs  (parse-string-expr (->string rhs))))
361           (make-algebraic-eqn quantity (make-signal-expr rhs))))
362
363        (else
364         (error 'parse-sexpr-eqn "invalid equation" x))
365        ))
366                   
367
368(define (make-ode-eqn-expr eqn)
369  (and (ode-eqn? eqn) 
370       (let ((rhs (ode-eqn-rhs eqn))
371             (dep (ode-eqn-dep eqn))
372             (indep (ode-eqn-indep eqn))
373             (tstep (ode-eqn-tstep eqn)))
374         (Apply
375          (Apply
376           (Apply
377            (Apply diagram-ode (make-list (list (Longid (Pident (ident-create (->string dep)))))))
378            (Longid (Pident (ident-create (->string indep)))))
379           (Longid (Pident (ident-create (->string tstep)))))
380          (make-pure rhs))
381         )))
382
383
384(define (make-relation-expr eqn)
385  (let ((rhs (relation-rhs eqn))
386        (var (relation-var eqn))
387        (quantity (relation-quantity eqn)))
388    (Apply
389     (Apply
390      (Apply diagram-relation (Const `(label ,quantity)))
391      (Const `(label ,var)))
392     (make-pure rhs))
393    ))
394
395
396(define (make-algebraic-eqn-expr eqn)
397  (let ((rhs (algebraic-eqn-rhs eqn))
398        (quantity (algebraic-eqn-quantity eqn)))
399    (Apply
400     (Apply diagram-assign (make-list (list (Const `(label ,quantity)))))
401     (make-pure rhs))
402    ))
403
404
405(define (make-algebraic-eqn-lst-expr eqlst)
406  (and (not (null? eqlst))
407      (let ((qs (map (lambda (x) (Const `(label ,(algebraic-eqn-quantity x)))) eqlst)))
408        (Apply (Apply diagram-assign (make-list qs))
409               (make-group (map make-pure (map algebraic-eqn-rhs eqlst)))))))
410
411
412(define (make-ode-eqn-lst-expr eqlst)
413  (let ((tsteps (delete-duplicates (map ode-eqn-tstep eqlst)))
414        (indeps (delete-duplicates (map ode-eqn-indep eqlst)))
415        (deps   (map  ode-eqn-dep eqlst)))
416    (match (list deps indeps tsteps)
417           (((dep . _) (indep) (tstep))
418            (Apply
419             (Apply
420              (Apply 
421               (Apply diagram-ode (make-list (map (lambda (x) (Longid (Pident (ident-create (->string x))))) deps)))
422               (Longid (Pident (ident-create (->string indep)))))
423              (Longid (Pident (ident-create (->string tstep)))))
424             (make-group (map make-pure (map ode-eqn-rhs eqlst)))))
425           (else (error 'parse-NineML-equation-sexpr-macro "invalid system of ODE equations" eqlst)))))
426
427
428(define (make-dae-eqn-lst-expr eqlst)
429  (let-values (((relations ode-eqs) (partition relation? eqlst)))
430    (let ((tsteps (delete-duplicates (map ode-eqn-tstep ode-eqs)))
431          (indeps (delete-duplicates (map ode-eqn-indep ode-eqs)))
432          (deps   (map ode-eqn-dep ode-eqs)))
433      (match (list deps indeps tsteps)
434             (((dep . _) (indep) (tstep))
435              (Apply
436               (Apply
437                (Apply
438                 (Apply diagram-ode (make-list (map (lambda (x) (Longid (Pident (ident-create (->string x))))) deps)))
439                 (Longid (Pident (ident-create (->string indep)))) )
440                (Longid (Pident (ident-create (->string tstep)))))
441               (make-relations relations (make-group (map make-pure (map ode-eqn-rhs ode-eqs))))))
442             
443             (else (error 'parse-NineML-equation-sexpr-macro "invalid system of DAE equations" eqlst))
444             ))))
445
446
447
448(define (make-rtransition state-name relations aliases
449                          ode-variables1 ode-rhss1 trigger-name1 trigger-rhs1 assign-variables1 assign-rhss1 
450                          c-assign-variables1 c-assign-rhss1 e1
451                          ode-variables2 ode-rhss2 trigger-name2 trigger-rhs2 assign-variables2 assign-rhss2 
452                          c-assign-variables2 c-assign-rhss2 e2)
453
454  (let (
455        (assignments1
456         (make-algebraic-eqn-lst-expr
457          (append
458           (map (lambda (var rhs) (make-algebraic-eqn var (make-signal-expr rhs subst: aliases))  )
459                assign-variables1 assign-rhss1)
460           (list (make-algebraic-eqn trigger-name1 (make-signal-expr trigger-rhs1 subst: aliases))
461                 (make-algebraic-eqn trigger-name2 (make-signal-expr 'false)))
462           )))
463       
464        (assignments2
465         (make-algebraic-eqn-lst-expr
466          (append
467           (map (lambda (var rhs) (make-algebraic-eqn var (make-signal-expr rhs subst: aliases))  )
468                assign-variables2 assign-rhss2)
469           (list (make-algebraic-eqn trigger-name1 (make-signal-expr 'false))
470                 (make-algebraic-eqn trigger-name2 (make-signal-expr trigger-rhs2 subst: aliases)))
471           )))
472
473        (c-assignments1
474         (make-algebraic-eqn-lst-expr
475          (map (lambda (var rhs) (make-algebraic-eqn var (make-signal-expr rhs subst: aliases))  )
476               c-assign-variables1 c-assign-rhss1)
477           ))
478       
479
480        (c-assignments2
481         (make-algebraic-eqn-lst-expr
482          (map (lambda (var rhs) (make-algebraic-eqn var (make-signal-expr rhs subst: aliases))  )
483               c-assign-variables2 c-assign-rhss2)
484           ))
485
486        (odes1 
487         (if (null? relations)
488                         
489             (make-ode-eqn-lst-expr
490              (map (lambda (var rhs) (make-ode-eqn 't var 'h (make-signal-expr rhs subst: aliases)))
491                   ode-variables1 ode-rhss1))
492             
493             (make-dae-eqn-lst-expr
494              (append relations
495                      (map (lambda (var rhs) (make-ode-eqn 't var 'h (make-signal-expr rhs subst: aliases)))
496                           ode-variables1 ode-rhss1)))
497             ))
498
499        (odes2
500         (and (not (null? ode-variables2))
501              (if (null? relations)
502                 
503                  (make-ode-eqn-lst-expr
504                   (map (lambda (var rhs) (make-ode-eqn 't var 'h (make-signal-expr rhs subst: aliases)))
505                        ode-variables2 ode-rhss2))
506                 
507                  (make-dae-eqn-lst-expr
508                   (append relations
509                           (map (lambda (var rhs) (make-ode-eqn 't var 'h (make-signal-expr rhs subst: aliases)))
510                                ode-variables2 ode-rhss2)))
511                  )))
512         
513
514        )
515                     
516  (Apply
517   
518   (Apply
519   
520    (Apply
521     
522     (Apply
523     
524      (Apply diagram-rtransition
525             
526             ((lambda (sys)
527                (if e1
528                    (make-event e1 sys aliases)
529                    sys))
530
531              ((lambda (sys)
532                 (if c-assignments1
533                     (Apply
534                      (Apply diagram-sequence sys)
535                      (Apply (Apply diagram-on c-assignments1) 
536                             (Apply
537                              (Apply signal-boolsig (Const `(label ,trigger-name1)))
538                              (Apply signal-boolconst (Const `(bool #f))))))
539                      sys))
540
541               (if assignments1
542                   (Apply
543                    (Apply diagram-sequence odes1)
544                    assignments1)
545                   odes1))))
546     
547      ((lambda (sys)
548         (if e2
549             (make-event e2 sys aliases)
550             sys))
551
552       ((lambda (sys)
553          (if c-assignments2
554              (Apply
555               (Apply diagram-sequence sys)
556               (Apply (Apply diagram-on c-assignments2) 
557                      (Apply
558                       (Apply signal-boolsig (Const `(label ,trigger-name2)))
559                       (Apply signal-boolconst (Const `(bool #f))))))
560              sys))
561       
562        (if (null? ode-variables2)
563           
564            (if (null? relations) 
565               
566                assignments2
567               
568                (make-relations relations assignments2))
569           
570            (if assignments2
571                (Apply 
572                 (Apply diagram-sequence odes2)
573                 assignments2)
574                odes2)))
575       ))
576     
577     (Apply
578      (Apply signal-boolsig (Const `(label ,trigger-name1)))
579      (Apply signal-boolconst (Const `(bool #f)))))
580
581    (Apply
582     (Apply signal-boolsig (Const `(label ,trigger-name2)))
583     (Apply signal-boolconst (Const `(bool #f)))))
584           
585   (Apply
586    (Apply signal-boolsig (Const `(label ,state-name)))
587    (Apply signal-boolconst (Const `(bool #f)))))
588
589  ))
590
591
592(define (make-transient 
593         relations aliases
594         ode-variables ode-rhss assign-variables assign-rhss
595         trigger-name trigger-rhs 
596         ode-variables1 ode-rhss1 assign-variables1 assign-rhss1)
597
598    (let ((assignments
599           (make-algebraic-eqn-lst-expr
600            (map (lambda (var rhs) (make-algebraic-eqn var (make-signal-expr rhs subst: aliases))  )
601                 assign-variables assign-rhss)))
602
603          (assignments1
604           (make-algebraic-eqn-lst-expr
605            ((lambda (x) (if (null? ode-variables1)
606                             (cons (make-algebraic-eqn 't (make-signal-expr 't)) x) x))
607             (cons (make-algebraic-eqn trigger-name (make-signal-expr 'false))
608                   (map (lambda (var rhs) (make-algebraic-eqn var (make-signal-expr rhs subst: aliases))  )
609                        assign-variables1 assign-rhss1)))))
610               
611
612
613          (odes 
614
615           (Apply
616
617            (Apply diagram-union 
618                   (Apply (Apply diagram-assign (make-list (list (Const `(label ,trigger-name)))))
619                          (make-pure (make-signal-expr trigger-rhs subst: aliases))))
620
621            (if (null? relations)
622               
623                (make-ode-eqn-lst-expr
624                 (map (lambda (var rhs) (make-ode-eqn 't var 'h (make-signal-expr rhs subst: aliases))) 
625                      ode-variables ode-rhss))
626               
627                (make-dae-eqn-lst-expr
628                 (append relations
629                         (map (lambda (var rhs) (make-ode-eqn 't var 'h (make-signal-expr rhs subst: aliases))) 
630                              ode-variables ode-rhss)))
631                )))
632
633          (odes1 
634           (and (not (null? ode-variables1))
635            (if (null? relations)
636
637                (make-ode-eqn-lst-expr
638                 (map (lambda (var rhs) 
639                        (make-ode-eqn 't var 'h (make-signal-expr rhs subst: aliases))) 
640                      ode-variables1 ode-rhss1))
641
642                (make-dae-eqn-lst-expr
643                 (append relations
644                         (map (lambda (var rhs) 
645                                (make-ode-eqn 't var 'h (make-signal-expr rhs subst: aliases))) 
646                              ode-variables1 ode-rhss1)))
647                )))
648          )
649     
650
651      (Apply
652
653       (Apply
654       
655        (Apply diagram-transient
656
657               (if assignments
658                   (Apply
659                    (Apply diagram-sequence odes)
660                    assignments)
661                   odes))
662       
663         (if (null? ode-variables1)
664             
665             assignments1
666             
667             (Apply
668              (Apply
669               diagram-sequence odes1)
670              assignments1)
671             
672            ))
673
674        (Apply
675         (Apply signal-boolsig (Const `(label ,trigger-name)))
676         (Apply signal-boolconst (Const `(bool #f)))))
677
678       ))
679
680
681(define (make-event e r aliases)
682  (let* (
683         (e-state-assignments ((sxpath `(nml:StateAssignment)) e))
684         (e-assign-variables (map (lambda (x) 
685                                    (string->symbol (sxml:attr  x 'variable))) 
686                                  e-state-assignments))
687         (e-assign-rhss      (map (lambda (x)
688                                    (parse-string-expr 
689                                     (sxml:kidn-cadr 'nml:MathInline x) 
690                                     'parse-al-sxml-dynamics))
691                                  e-state-assignments))
692         (e-port             (string->symbol (sxml:attr e 'src_port)))
693         )
694
695    (Apply
696     (Apply
697      (Apply diagram-transient r)
698      (make-algebraic-eqn-lst-expr
699       (map (lambda (var rhs) (make-algebraic-eqn var (make-signal-expr rhs subst: aliases))  )
700            e-assign-variables e-assign-rhss)))
701     (Apply
702      (Apply signal-boolsig (Const `(label ,e-port)))
703      (Apply signal-boolconst (Const `(bool #f)))))
704    ))
705
706
707(define (make-alsys-union eq-list)
708  (let ((n (length eq-list)))
709    (cond ((= n 1)  (car eq-list))
710          ((= n 2)  (Apply (Apply alsys-union (car eq-list)) (cadr eq-list)))
711          (else     (make-alsys-union
712                     (list (make-alsys-union (list (car eq-list) (cadr eq-list)) )
713                           (make-alsys-union (cddr eq-list))
714                           ))
715                    )
716          ))
717    )
718
719
720(define (make-alsys-eqn-lst-expr eqlst)
721  (and (not (null? eqlst))
722       (let ((qs (map (lambda (x) (Const `(label ,(algebraic-eqn-quantity x)))) eqlst))
723             (rhss (map algebraic-eqn-rhs eqlst)))
724         (make-alsys-union
725          (map (lambda (q rhs) (Apply (Apply alsys-equation q) rhs)) qs rhss)
726          ))
727       ))
728
729
730(define (parse-NineML-equation-sexpr-macro mac)
731  (if (not (sexpr-macro? mac))
732      (error 'parse-NineML-equation-sexpr-macro "invalid macro expression" mac))
733 
734  (let ((lst (sexpr-macro-text mac)))
735
736    (match lst
737
738         (((? symbol?) . rest)
739
740          (let ((eqn (parse-sexpr-eqn lst)))
741
742            (cond ((ode-eqn? eqn)   (make-ode-eqn-expr eqn))
743
744                  ((relation? eqn) (make-relation-expr eqn))
745
746                  ((algebraic-eqn? eqn) (make-algebraic-eqn-expr eqn))
747                 
748                  )))
749
750
751         (((? pair?) . rest)
752
753          (let ((eqlst (map parse-sexpr-eqn lst)))
754
755            (cond ((every algebraic-eqn-or-relation? eqlst) 
756                   (make-algebraic-eqn-lst-expr eqlst))
757
758                 ((every ode-eqn? eqlst)
759                  (make-ode-eqn-lst-expr eqlst))
760
761                 ((every ode-eqn-or-relation? eqlst)
762                  (make-dae-eqn-lst-expr eqlst))
763                         
764                 (else
765                  (error 'parse-NineML-equation-sexpr-macro "invalid system of equations" eqlst)))))
766               
767        (else (error 'parse-NineML-equation-sexpr-macro "invalid equational expression" lst))
768        ))
769  )
770
771
772(define (parse-list-sexpr-macro text)
773  (let recur ((text (reverse text)) 
774              (lst list-null))
775    (if (null? text) lst
776        (recur (cdr lst) (Apply list-cons (parse (->string (car text))) lst)))
777    ))
778
779
780
781
782(define nineml-xmlns-base "http://nineml.incf.org/9ML/")
783
784(define (parse-al-sxml-dynamics sxml)
785  (let (
786        (state-variables  ((sxpath `(// nml:StateVariable)) sxml))
787        (regimes          ((sxpath `(// nml:Regime)) sxml))
788        (relations        ((sxpath `(// nml:Relation)) sxml))
789        (aliases          ((sxpath `(// nml:Alias)) sxml))
790        )
791
792
793;; TODO: ensure that parameters and state variables are consistent in the equations
794
795    (if (pair? regimes)
796        (cond
797
798         ((= (length regimes) 1)
799          (let ((r (car regimes)))
800            (let (
801                  (time-derivatives   ((sxpath `(nml:TimeDerivative)) r))
802                  (on-conditions      ((sxpath `(nml:OnCondition)) r))
803                  (on-events          ((sxpath `(nml:OnEvent)) r))
804                  (state-assignments  ((sxpath `(nml:StateAssignment)) r))
805                  )
806
807              (if (> (length on-conditions) 1)
808                  (error 'parse-al-sxml-dynamics "multiple on-conditions blocks in regime are not supported" r))
809
810              (if (> (length on-events) 1)
811                  (error 'parse-al-sxml-dynamics "multiple on-events in regime are not supported" r))
812             
813              (if (null? time-derivatives) 
814                  (error 'parse-al-sxml-dynamics "regime does not contain time derivative blocks or assignments" r))
815             
816              (let*
817                  (
818                    (ode-variables    (map (lambda (x) 
819                                             (string->symbol (sxml:attr x 'variable )))
820                                           time-derivatives))
821                   
822                    (ode-rhss         (map (lambda (x)
823                                             (parse-string-expr 
824                                              (sxml:kidn-cadr 'nml:MathInline x )
825                                              'parse-al-sxml-dynamics))
826                                           time-derivatives))
827
828                    (assign-variables (map (lambda (x) 
829                                             (string->symbol (sxml:attr  x 'variable))) 
830                                           state-assignments))
831
832                    (assign-rhss      (map (lambda (x)
833                                             (parse-string-expr 
834                                              (sxml:kidn-cadr 'nml:MathInline x) 
835                                              'parse-al-sxml-dynamics))
836                                           state-assignments))
837                   
838
839                    (relations        (map (lambda (x)
840                                             (let ((quantity (sxml:attr x 'name))
841                                                   (var      (sxml:attr x 'argument))
842                                                   (rhs      (parse-string-expr 
843                                                              (sxml:kidn-cadr 'nml:MathInline x )
844                                                              'parse-al-sxml-dynamics)))
845                                               (make-relation (string->symbol quantity)
846                                                              (string->symbol var)
847                                                              (make-signal-expr  rhs argument: (string->symbol var)))
848                                            ))
849                                           relations))
850
851                    (aliases        (map (lambda (x)
852                                             (let ((quantity (sxml:attr x 'name))
853                                                   (rhs      (parse-string-expr 
854                                                              (sxml:kidn-cadr 'nml:MathInline x )
855                                                              'parse-al-sxml-dynamics)))
856                                               `(,(string->symbol quantity) .
857                                                 ,rhs)
858                                               ))
859                                         aliases))
860
861                    (on-event (and (not (null? on-events))
862                                   (car on-events)))
863                    )
864               
865               
866
867                (if (null? on-conditions)
868
869                    (let ((odes 
870                           (map (lambda (var rhs) (make-ode-eqn 't var 'h (make-signal-expr rhs subst: aliases))) 
871                                ode-variables ode-rhss))
872                         
873                          (assignments
874                           (and (not (null? assign-variables))
875                                (make-algebraic-eqn-lst-expr
876                                 (map (lambda (var rhs) (make-algebraic-eqn var (make-signal-expr rhs subst: aliases))  )
877                                      assign-variables assign-rhss))))
878
879                          )
880
881                      ((lambda (sys)
882                         (if on-event
883                             (make-event on-event sys aliases)
884                             sys))
885
886                       ((lambda (rels+odes)
887                          (if assignments
888                             
889                              (Apply
890                               (Apply diagram-sequence rels+odes)
891                               assignments)
892                             
893                              rels+odes))
894                       
895                        (if (null? relations)
896                            (make-ode-eqn-lst-expr odes)
897                            (make-dae-eqn-lst-expr (append relations odes))
898                            ))
899                       
900                       ))
901                   
902                    (let ((c (car on-conditions)))
903
904                      (let (
905                            ( trigger (sxml:kidn-cadr 'nml:Trigger c))
906                            ( event-out (sxml:kidn 'nml:EventOut c))
907                            ( state-assignments1 ((sxpath `(nml:StateAssignment)) c))
908                            ( time-derivatives1 ((sxpath `(nml:TimeDerivative)) c))
909                            )
910                       
911                        (let ((ode-variables1 (map (lambda (x) 
912                                                     (string->symbol (sxml:attr x 'variable )))
913                                                   time-derivatives1))
914                             
915                              (ode-rhss1      (map (lambda (x)
916                                                     (parse-string-expr 
917                                                      (sxml:kidn-cadr 'nml:MathInline x )
918                                                      'parse-al-sxml-dynamics))
919                                                   time-derivatives1))
920                              )
921                         
922                          (if (not trigger) (error 'parse-al-sxml-dynamics "on-condition without trigger" c))
923                          (if (not event-out) (error 'parse-al-sxml-dynamics "on-condition without event-out" c))
924                         
925                          (let ((trigger-rhs (parse-string-expr 
926                                              (sxml:text trigger) 
927                                              'parse-al-sxml-dynamics))
928                                (trigger-name (string->symbol (sxml:attr event-out 'port )))
929                                (assign-variables1 (map (lambda (x) 
930                                                         (string->symbol (sxml:attr  x 'variable))) 
931                                                       state-assignments1))
932                                (assign-rhss1      (map (lambda (x)
933                                                          (parse-string-expr 
934                                                           (sxml:kidn-cadr 'nml:MathInline x) 
935                                                           'parse-al-sxml-dynamics))
936                                                        state-assignments1)))
937                           
938                            ((lambda (sys)
939                               (if on-event 
940                                   (make-event on-event sys aliases)
941                                   sys))
942                                   
943                             (make-transient relations aliases 
944                                             ode-variables ode-rhss assign-variables assign-rhss
945                                             trigger-name trigger-rhs 
946                                             ode-variables1 ode-rhss1 assign-variables1 assign-rhss1))
947                           
948                            ))
949                        ))
950                    ))
951              ))
952          )
953
954         ((= (length regimes) 2)
955
956          (let ((rs regimes)
957                (state-name (gensym 'st)))
958
959            (let (
960                  (time-derivatives  (map (sxpath `(nml:TimeDerivative)) rs))
961                  (on-conditions     (map (sxpath `(nml:OnCondition)) rs))
962                  (on-events         (map (sxpath `(nml:OnEvent)) rs))
963                  )
964             
965              (for-each
966               (lambda (r cs evs)
967                 (cond
968                  ((null? cs)
969                   (error 'parse-al-sxml-dynamics "regime does not contain on-conditions blocks" rs))
970                  ((> (length cs) 1)
971                   (error 'parse-al-sxml-dynamics "multiple on-conditions blocks in regime are not supported" r))
972                  ((> (length evs) 1)
973                   (error 'parse-al-sxml-dynamics "multiple on-events in regime are not supported" r))
974                  ))
975               rs on-conditions on-events)
976             
977
978              (if (every (lambda (x) (null? x)) time-derivatives)
979                  (error 'parse-al-sxml-dynamics "regime list does not contain time derivative blocks" rs))
980
981              (let (
982                    (relations
983                     (map (lambda (x)
984                            (let ((quantity (sxml:attr x 'name))
985                                  (var      (sxml:attr x 'argument))
986                                  (rhs      (parse-string-expr 
987                                             (sxml:kidn-cadr 'nml:MathInline x )
988                                             'parse-al-sxml-dynamics)))
989                              (make-relation (string->symbol quantity)
990                                             (string->symbol var)
991                                             (make-signal-expr rhs argument: (string->symbol var) rhs))
992                              ))
993                          relations))
994
995                    (regimes
996                     (map
997                      (lambda (r time-derivatives on-conditions on-events)
998
999                        (let ((ode-variables (map (lambda (x) 
1000                                                    (string->symbol (sxml:attr x 'variable )))
1001                                                  time-derivatives))
1002                                 
1003                              (ode-rhss      (map (lambda (x)
1004                                                    (parse-string-expr 
1005                                                     (sxml:kidn-cadr 'nml:MathInline x )
1006                                                     'parse-al-sxml-dynamics))
1007                                                  time-derivatives))
1008
1009                              (state-assignments ((sxpath `(nml:StateAssignment)) r))
1010                             
1011                              (c (and (not (null? on-conditions)) (car on-conditions)))
1012                              )
1013                           
1014                          (let (
1015                                ( trigger (sxml:kidn-cadr 'nml:Trigger c))
1016                                ( event-out (sxml:kidn 'nml:EventOut c))
1017                                )
1018                           
1019                            (if (not trigger) 
1020                                (error 'parse-al-sxml-dynamics "on-condition without trigger" c))
1021
1022                            (if (not event-out) 
1023                                (error 'parse-al-sxml-dynamics "on-condition without event-out" c))
1024                           
1025                            (let* ((trigger-name (string->symbol (sxml:attr event-out 'port )))
1026                                   
1027                                   (trigger-rhs (parse-string-expr 
1028                                                 (sxml:text trigger) 
1029                                                 'parse-al-sxml-dynamics))
1030                                   
1031                                   (c-state-assignments ((sxpath `(nml:StateAssignment)) c))
1032                                   
1033                                   (assign-variables (map (lambda (x) 
1034                                                            (string->symbol (sxml:attr  x 'variable)))
1035                                                          state-assignments))
1036
1037                                   (c-assign-variables (map (lambda (x) 
1038                                                              (string->symbol (sxml:attr  x 'variable)))
1039                                                            c-state-assignments))
1040                                   
1041                                   (assign-rhss      (map (lambda (x)
1042                                                            (parse-string-expr 
1043                                                             (sxml:kidn-cadr 'nml:MathInline x) 
1044                                                             'parse-al-sxml-dynamics))
1045                                                          state-assignments))
1046
1047                                   (c-assign-rhss      (map (lambda (x)
1048                                                              (parse-string-expr 
1049                                                               (sxml:kidn-cadr 'nml:MathInline x) 
1050                                                               'parse-al-sxml-dynamics))
1051                                                            c-state-assignments))
1052
1053                                   )
1054                              (list ode-variables ode-rhss trigger-name trigger-rhs assign-variables assign-rhss
1055                                    c-assign-variables c-assign-rhss
1056                                    (and (not (null? on-events)) (car on-events)))
1057                             
1058                              ))
1059                        ))
1060                      regimes time-derivatives on-conditions on-events))
1061
1062                    )
1063
1064                (match-let ((((ode-variables1 ode-rhss1 trigger-name1 trigger-rhs1 assign-variables1 assign-rhss1 
1065                                              c-assign-variables1 c-assign-rhss1 e1)
1066                              (ode-variables2 ode-rhss2 trigger-name2 trigger-rhs2 assign-variables2 assign-rhss2 
1067                                              c-assign-variables2 c-assign-rhss2 e2))
1068                             regimes))
1069
1070                      (make-rtransition state-name relations aliases
1071                                        ode-variables1 ode-rhss1 trigger-name1 trigger-rhs1 assign-variables1 assign-rhss1 
1072                                        c-assign-variables1 c-assign-rhss1 e1
1073                                        ode-variables2 ode-rhss2 trigger-name2 trigger-rhs2 assign-variables2 assign-rhss2 
1074                                        c-assign-variables2 c-assign-rhss2 e2))
1075               
1076                ))
1077            ))
1078
1079
1080         ((> (length regimes) 2)
1081          (error 'parse-al-sxml-dynamics "maximum of two regimes is supported" sxml))
1082         
1083         )
1084       
1085        (error 'parse-al-sxml-dynamics "no regimes found in component" )
1086
1087        )
1088    ))
1089 
1090 
1091
1092(define (parse-al-sxml-alsys sxml)
1093  (let (
1094        (state-variables   ((sxpath `(// nml:StateVariable)) sxml))
1095        (state-assignments ((sxpath `(// nml:Equation)) sxml))
1096        (relations         ((sxpath `(// nml:Relation)) sxml))
1097        )
1098
1099    (let*
1100        (
1101         (assign-variables (map (lambda (x) 
1102                                  (string->symbol (sxml:attr x 'variable)))
1103                                state-assignments))
1104         
1105         (assign-rhss      (map (lambda (x)
1106                                  (parse-string-expr 
1107                                   (sxml:kidn-cadr 'nml:MathInline x) 
1108                                   'parse-al-sxml-alsys))
1109                                state-assignments))
1110                   
1111
1112         (relations        (map (lambda (x)
1113                                   (let ((quantity (sxml:attr x 'name))
1114                                         (var      (sxml:attr x 'argument))
1115                                         (rhs      (parse-string-expr 
1116                                                   (sxml:kidn-cadr 'nml:MathInline x )
1117                                                   'parse-al-sxml-alsys)))
1118                                     (make-relation (string->symbol quantity)
1119                                                    (string->symbol var)
1120                                                    (make-signal-expr rhs argument: (string->symbol var)))
1121                                     ))
1122                                 relations))
1123
1124         (assignments
1125          (and (not (null? assign-variables))
1126               (make-alsys-eqn-lst-expr
1127                (map (lambda (var rhs) (make-algebraic-eqn var (make-signal-expr rhs))  )
1128                     assign-variables assign-rhss))))
1129         )
1130 
1131      (make-alsys-relations relations assignments)
1132
1133      ))
1134  )
1135
1136
1137(define (parse-al-sxml-component sxml)
1138 
1139  (let ((dynamics    (safe-car ((sxpath `(// nml:Dynamics)) sxml)))
1140        (alsys      (safe-car ((sxpath `(// nml:AlgebraicSystem)) sxml)))
1141        (parameters  ((sxpath `(// nml:Parameter))  sxml))
1142        (ports       ((sxpath `(// (*or* nml:AnalogPort nml:EventPort)))  sxml))
1143        (name        (sxml:attr sxml 'name)))
1144
1145    (cond
1146     (dynamics 
1147
1148      (let ((dynamics-body (parse-al-sxml-dynamics dynamics))
1149           
1150            (dynamics-args
1151             (cons* "h" "t" (map (lambda (x) (sxml:attr x 'name)) 
1152                                 (append (reverse ports)
1153                                         (reverse parameters)))))
1154            )
1155       
1156        (Value_def (ident-create name) 
1157                   (let recur ((args dynamics-args) (ax dynamics-body))
1158                     (if (null? args) ax
1159                         (recur (cdr args) (Function (ident-create (car args)) ax)))))
1160        ))
1161     
1162     (alsys
1163     
1164      (let ((alsys-body (parse-al-sxml-alsys alsys))
1165           
1166            (alsys-args
1167             (map (lambda (x) (sxml:attr x 'name)) 
1168                  (append (reverse ports)
1169                          (reverse parameters))))
1170                 )
1171       
1172             (Value_def (ident-create name) 
1173                        (let recur ((args alsys-args) (ax alsys-body))
1174                          (if (null? args) ax
1175                              (recur (cdr args) (Function (ident-create (car args)) ax)))))
1176             ))
1177     
1178     (else
1179      (error 'parse-al-sxml-component "component class does not contain dynamics or a linear system"))
1180
1181     )
1182    ))
1183           
1184
1185
1186(define (parse-al-sxml al-sxml)
1187  (let ((al-sxml-defs ((sxpath `(// nml:ComponentClass))  al-sxml)) )
1188
1189    (map parse-al-sxml-component al-sxml-defs)
1190
1191    ))
1192
1193(register-macro-hook 'default parse-NineML-equation-sexpr-macro)
1194(register-macro-hook 'list parse-list-sexpr-macro)
1195
1196)
Note: See TracBrowser for help on using the repository browser.