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

Last change on this file since 29979 was 29979, checked in by Ivan Raikov, 7 years ago

9ML-toolkit: updates to support proper NineML schema

File size: 33.2 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)
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 
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-transient     (Longid (Pdot (Pident (ident-create "Diagram")) "TRANSIENT")))
180(define diagram-transition    (Longid (Pdot (Pident (ident-create "Diagram")) "TRANSITION")))
181(define diagram-rtransition   (Longid (Pdot (Pident (ident-create "Diagram")) "RTRANSITION")))
182(define diagram-relation      (Longid (Pdot (Pident (ident-create "Diagram")) "RELATION")))
183(define diagram-identity      (Longid (Pdot (Pident (ident-create "Diagram")) "IDENTITY")))
184
185(define signal-realconst     (Longid (Pdot (Pident (ident-create "Signal")) "realconst")))
186(define signal-boolconst     (Longid (Pdot (Pident (ident-create "Signal")) "boolconst")))
187(define signal-boolsig       (Longid (Pdot (Pident (ident-create "Signal")) "boolsig")))
188
189(define (make-group rhs-list)
190  (let ((n (length rhs-list)))
191    (cond ((= n 1)  (car rhs-list))
192          ((= n 2)  (Apply (Apply diagram-group (car rhs-list)) (cadr rhs-list)))
193          (else     (make-group
194                     (list (make-group (list (car rhs-list) (cadr rhs-list)) )
195                           (make-group (cddr rhs-list))))))))
196
197(define (make-list value-list)
198  (let recur ((value-list (reverse value-list)) 
199              (value (Longid (Pident (ident-create "null")))))
200    (if (null? value-list) value
201        (recur (cdr value-list) 
202               (Apply (Apply (Longid (Pident (ident-create "cons"))) (car value-list)) 
203                      value)))
204    ))
205
206
207(define (make-relations relation-list value)
208  (if (null? relation-list) value
209      (let ((relation (car relation-list)))
210        (Apply
211         (Apply
212          (Apply
213           (Apply diagram-relation (Const `(label ,(relation-quantity relation))))
214           (Const `(label ,(relation-var relation))))
215          (relation-rhs relation))
216         (make-relations (cdr relation-list) value)))
217      ))
218
219
220(define (op->signal-function op)
221  (let ((name (case op
222                ((+)   "add")
223                ((*)   "mul")
224                ((/)   "div")
225                ((>)   "gt")
226                ((<)   "lt")
227                ((>=)  "gte")
228                ((<=)  "lte")
229                (else (->string op)))))
230    (Longid (Pdot (Pident (ident-create "Signal")) name))))
231   
232
233(define (op->random-function op)
234  (let ((name (->string op)))
235    (Longid (Pdot (Pident (ident-create "Random")) name))))
236   
237
238(define (op->relation op)
239  (Apply
240   (Longid (Pdot (Pident (ident-create "Signal")) "relation"))
241   (Const `(label ,op))))
242
243(define (signal-operation? op)
244  (case op
245    ((add mul div gt gte lte neg cosh tanh log ln exp) #t)
246    (else #f)))
247
248(define (random-operation? op)
249  (case op
250    ((randomNormal randomUniform) #t)
251    (else #f)))
252
253   
254(define (make-pure sf) (Apply diagram-pure sf))
255
256(define (make-signal-expr expr)
257  (cond ((number? expr) (Apply signal-realconst (Const `(real ,expr))))
258        ((symbol? expr) (case expr 
259                          ((false) (Apply signal-boolconst (Const `(bool #f))))
260                          ((true)  (Apply signal-boolconst (Const `(bool #t))))
261                          (else (Longid (Pident (ident-create (->string expr)))))))
262        (else
263         (match expr
264
265                (('- a) 
266                 (Apply (op->signal-function "neg") (make-signal-expr a)))
267
268                (('- a b) 
269                 (Apply (Apply (op->signal-function "sub") (make-signal-expr a))
270                        (make-signal-expr b)))
271               
272                (('if a b c) 
273                 (Apply
274                  (Apply (Apply (op->signal-function "if")
275                                (make-signal-expr a))
276                         (make-signal-expr b))
277                  (make-signal-expr c)))
278               
279                (((and op (? symbol?)) a b)
280                 (Apply
281                  (Apply (op->signal-function op) 
282                         (make-signal-expr a))
283                  (make-signal-expr b)))
284               
285                (((and op (? symbol?)) a)
286                 (cond ((signal-operation? op)
287                        (Apply (op->signal-function op) 
288                               (make-signal-expr a)))
289                       ((random-operation? op)
290                        (Apply (op->random-function op) 
291                               (make-signal-expr a)))
292                       (else
293                        (Apply (op->relation op) 
294                               (make-signal-expr a)))))
295
296                (((and op (? symbol?)))
297                 (cond
298                  ((random-operation? op)
299                   (Apply (op->random-function op) (Longid empty)))
300                  (else
301                   (error 'make-signal-expr "invalid signal expression" expr))))
302               
303                (else (error 'make-signal-expr "invalid signal expression" expr))))
304        ))
305
306
307(define (parse-sexpr-eqn x)
308  (match x
309         (((or 'D 'd) (dep indep tstep) '= . rhs)
310          (let ((rhs   (parse-string-expr (->string rhs))))
311            (make-ode-eqn indep dep tstep (make-signal-expr rhs))))
312
313         (((and quantity (? symbol?)) (var) '= . rhs)
314          (let ((rhs (parse-string-expr (->string rhs))))
315            (make-relation quantity var (make-signal-expr rhs))))
316
317        (((and quantity (? symbol?))  '= . rhs)
318         (let ((rhs  (parse-string-expr (->string rhs))))
319           (make-algebraic-eqn quantity (make-signal-expr rhs))))
320
321        (else
322         (error 'parse-sexpr-eqn "invalid equation" x))
323        ))
324                   
325
326(define (make-ode-eqn-expr eqn)
327  (and (ode-eqn? eqn) 
328       (let ((rhs (ode-eqn-rhs eqn))
329             (dep (ode-eqn-dep eqn))
330             (indep (ode-eqn-indep eqn))
331             (tstep (ode-eqn-tstep eqn)))
332         (Apply
333          (Apply
334           (Apply
335            (Apply diagram-ode (make-list (list (Longid (Pident (ident-create (->string dep)))))))
336            (Longid (Pident (ident-create (->string indep)))))
337           (Longid (Pident (ident-create (->string tstep)))))
338          (make-pure rhs))
339         )))
340
341
342(define (make-relation-expr eqn)
343  (let ((rhs (relation-rhs eqn))
344        (var (relation-var eqn))
345        (quantity (relation-quantity eqn)))
346    (Apply
347     (Apply
348      (Apply diagram-relation (Const `(label ,quantity)))
349      (Const `(label ,var)))
350     (make-pure rhs))
351    ))
352
353
354(define (make-algebraic-eqn-expr eqn)
355  (let ((rhs (algebraic-eqn-rhs eqn))
356        (quantity (algebraic-eqn-quantity eqn)))
357    (Apply
358     (Apply diagram-assign (make-list (list (Const `(label ,quantity)))))
359     (make-pure rhs))
360    ))
361
362
363(define (make-algebraic-eqn-lst-expr eqlst)
364  (and (not (null? eqlst))
365      (let ((qs (map (lambda (x) (Const `(label ,(algebraic-eqn-quantity x)))) eqlst)))
366        (Apply (Apply diagram-assign (make-list qs))
367               (make-group (map make-pure (map algebraic-eqn-rhs eqlst)))))))
368
369
370(define (make-ode-eqn-lst-expr eqlst)
371  (let ((tsteps (delete-duplicates (map ode-eqn-tstep eqlst)))
372        (indeps (delete-duplicates (map ode-eqn-indep eqlst)))
373        (deps   (map  ode-eqn-dep eqlst)))
374    (match (list deps indeps tsteps)
375           (((dep . _) (indep) (tstep))
376            (Apply
377             (Apply
378              (Apply 
379               (Apply diagram-ode (make-list (map (lambda (x) (Longid (Pident (ident-create (->string x))))) deps)))
380               (Longid (Pident (ident-create (->string indep)))))
381              (Longid (Pident (ident-create (->string tstep)))))
382             (make-group (map make-pure (map ode-eqn-rhs eqlst)))))
383           (else (error 'parse-NineML-equation-sexpr-macro "invalid system of ODE equations" eqlst)))))
384
385
386(define (make-dae-eqn-lst-expr eqlst)
387  (let-values (((relations ode-eqs) (partition relation? eqlst)))
388    (let ((tsteps (delete-duplicates (map ode-eqn-tstep ode-eqs)))
389          (indeps (delete-duplicates (map ode-eqn-indep ode-eqs)))
390          (deps   (map ode-eqn-dep ode-eqs)))
391      (match (list deps indeps tsteps)
392             (((dep . _) (indep) (tstep))
393              (Apply
394               (Apply
395                (Apply
396                 (Apply diagram-ode (make-list (map (lambda (x) (Longid (Pident (ident-create (->string x))))) deps)))
397                 (Longid (Pident (ident-create (->string indep)))) )
398                (Longid (Pident (ident-create (->string tstep)))))
399               (make-relations relations (make-group (map make-pure (map ode-eqn-rhs ode-eqs))))))
400             
401             (else (error 'parse-NineML-equation-sexpr-macro "invalid system of DAE equations" eqlst))
402             ))))
403
404
405
406(define (make-rtransition state-name relations
407                          ode-variables1 ode-rhss1 trigger-name1 trigger-rhs1 assign-variables1 assign-rhss1
408                          ode-variables2 ode-rhss2 trigger-name2 trigger-rhs2 assign-variables2 assign-rhss2)
409
410  (let (
411        (assignments1
412         (make-algebraic-eqn-lst-expr
413          (append
414           (map (lambda (var rhs) (make-algebraic-eqn var (make-signal-expr rhs))  )
415                assign-variables1 assign-rhss1)
416           (list (make-algebraic-eqn trigger-name1 (make-signal-expr trigger-rhs1))
417                 (make-algebraic-eqn trigger-name2 (make-signal-expr 'false)))
418           )))
419       
420        (assignments2
421         (make-algebraic-eqn-lst-expr
422          (append
423           (map (lambda (var rhs) (make-algebraic-eqn var (make-signal-expr rhs))  )
424                assign-variables2 assign-rhss2)
425           (list (make-algebraic-eqn trigger-name1 (make-signal-expr 'false))
426                 (make-algebraic-eqn trigger-name2 (make-signal-expr trigger-rhs2)))
427           )))
428
429        (odes1 
430         (if (null? relations)
431                         
432             (make-ode-eqn-lst-expr
433              (map (lambda (var rhs) (make-ode-eqn 't var 'h (make-signal-expr rhs)))
434                   ode-variables1 ode-rhss1))
435             
436             (make-dae-eqn-lst-expr
437              (append relations
438                      (map (lambda (var rhs) (make-ode-eqn 't var 'h (make-signal-expr rhs)))
439                           ode-variables1 ode-rhss1)))
440             ))
441
442        (odes2
443         (and (not (null? ode-variables2))
444              (if (null? relations)
445                 
446                  (make-ode-eqn-lst-expr
447                   (map (lambda (var rhs) (make-ode-eqn 't var 'h (make-signal-expr rhs)))
448                        ode-variables2 ode-rhss2))
449                 
450                  (make-dae-eqn-lst-expr
451                   (append relations
452                           (map (lambda (var rhs) (make-ode-eqn 't var 'h (make-signal-expr rhs)))
453                                ode-variables2 ode-rhss2)))
454                  )))
455         
456
457        )
458                     
459  (Apply
460   
461   (Apply
462   
463    (Apply
464     
465     (Apply
466     
467      (Apply diagram-rtransition
468             
469              (if assignments1
470                  (Apply
471                   (Apply diagram-sequence odes1)
472                   assignments1)
473                  odes1))
474     
475      (if (null? ode-variables2)
476         
477          (if (null? relations) 
478             
479              assignments2
480             
481              (make-relations relations assignments2))
482         
483          (if assignments2
484              (Apply 
485               (Apply diagram-sequence odes2)
486               assignments2)
487              odes2)))
488     
489     (Apply
490      (Apply signal-boolsig (Const `(label ,trigger-name1)))
491      (Apply signal-boolconst (Const `(bool #f)))))
492
493    (Apply
494     (Apply signal-boolsig (Const `(label ,trigger-name2)))
495     (Apply signal-boolconst (Const `(bool #f)))))
496           
497   (Apply
498    (Apply signal-boolsig (Const `(label ,state-name)))
499    (Apply signal-boolconst (Const `(bool #f)))))
500
501  ))
502
503
504(define (make-transient 
505         relations 
506         ode-variables ode-rhss assign-variables assign-rhss
507         trigger-name trigger-rhs 
508         ode-variables1 ode-rhss1 assign-variables1 assign-rhss1)
509
510    (let ((assignments
511           (make-algebraic-eqn-lst-expr
512            (map (lambda (var rhs) (make-algebraic-eqn var (make-signal-expr rhs))  )
513                 assign-variables assign-rhss)))
514
515          (assignments1
516           (make-algebraic-eqn-lst-expr
517            ((lambda (x) (if (null? ode-variables1)
518                             (cons (make-algebraic-eqn 't (make-signal-expr 't)) x) x))
519             (cons (make-algebraic-eqn trigger-name (make-signal-expr 'false))
520                   (map (lambda (var rhs) (make-algebraic-eqn var (make-signal-expr rhs))  )
521                        assign-variables1 assign-rhss1)))))
522               
523
524
525          (odes 
526
527           (Apply
528
529            (Apply diagram-union 
530                   (Apply (Apply diagram-assign (make-list (list (Const `(label ,trigger-name)))))
531                          (make-pure (make-signal-expr trigger-rhs))))
532
533            (if (null? relations)
534               
535                (make-ode-eqn-lst-expr
536                 (map (lambda (var rhs) (make-ode-eqn 't var 'h (make-signal-expr rhs))) 
537                      ode-variables ode-rhss))
538               
539                (make-dae-eqn-lst-expr
540                 (append relations
541                         (map (lambda (var rhs) (make-ode-eqn 't var 'h (make-signal-expr rhs))) 
542                              ode-variables ode-rhss)))
543                )))
544
545          (odes1 
546           (and (not (null? ode-variables1))
547            (if (null? relations)
548
549                (make-ode-eqn-lst-expr
550                 (map (lambda (var rhs) 
551                        (make-ode-eqn 't var 'h (make-signal-expr rhs))) 
552                      ode-variables1 ode-rhss1))
553
554                (make-dae-eqn-lst-expr
555                 (append relations
556                         (map (lambda (var rhs) 
557                                (make-ode-eqn 't var 'h (make-signal-expr rhs))) 
558                              ode-variables1 ode-rhss1)))
559                )))
560          )
561     
562
563      (Apply
564
565       (Apply
566       
567        (Apply diagram-transient
568
569               (if assignments
570                   (Apply
571                    (Apply diagram-sequence odes)
572                    assignments)
573                   odes))
574       
575         (if (null? ode-variables1)
576             
577             assignments1
578             
579             (Apply
580              (Apply
581               diagram-sequence odes1)
582              assignments1)
583             
584            ))
585
586        (Apply
587         (Apply signal-boolsig (Const `(label ,trigger-name)))
588         (Apply signal-boolconst (Const `(bool #f)))))
589
590       ))
591
592
593(define (parse-NineML-equation-sexpr-macro mac)
594  (if (not (sexpr-macro? mac))
595      (error 'parse-NineML-equation-sexpr-macro "invalid macro expression" mac))
596 
597  (let ((lst (sexpr-macro-text mac)))
598    (match lst
599
600         (((? symbol?) . rest)
601
602          (let ((eqn (parse-sexpr-eqn lst)))
603
604            (cond ((ode-eqn? eqn)   (make-ode-eqn-expr eqn))
605
606                  ((relation? eqn) (make-relation-expr eqn))
607
608                  ((algebraic-eqn? eqn) (make-algebraic-eqn-expr eqn))
609                 
610                  )))
611
612
613         (((? pair?) . rest)
614
615          (let ((eqlst (map parse-sexpr-eqn lst)))
616
617            (cond ((every algebraic-eqn-or-relation? eqlst) 
618                   (make-algebraic-eqn-lst-expr eqlst))
619
620                 ((every ode-eqn? eqlst)
621                  (make-ode-eqn-lst-expr eqlst))
622
623                 ((every ode-eqn-or-relation? eqlst)
624                  (make-dae-eqn-lst-expr eqlst))
625                         
626                 (else
627                  (error 'parse-NineML-equation-sexpr-macro "invalid system of equations" eqlst)))))
628               
629        (else (error 'parse-NineML-equation-sexpr-macro "invalid equational expression" lst))
630        ))
631  )
632
633
634(define (parse-list-sexpr-macro text)
635  (let recur ((text (reverse text)) 
636              (lst list-null))
637    (if (null? text) lst
638        (recur (cdr lst) (Apply list-cons (parse (->string (car text))) lst)))
639    ))
640
641
642
643
644(define nineml-xmlns-base "http://nineml.incf.org/9ML/")
645
646(define (parse-al-sxml-dynamics sxml)
647  (let (
648        (state-variables  ((sxpath `(// nml:StateVariable)) sxml))
649        (regimes          ((sxpath `(// nml:Regime)) sxml))
650        (relations        ((sxpath `(// (*or* nml:Relation nml:Alias))) sxml))
651        )
652
653;; TODO: ensure that parameters and state variables are consistent in the equations
654
655    (if (pair? regimes)
656        (cond
657
658         ((= (length regimes) 1)
659          (let ((r (car regimes)))
660            (let (
661                  (time-derivatives   ((sxpath `(nml:TimeDerivative)) r))
662                  (on-conditions      ((sxpath `(nml:OnCondition)) r))
663                  (state-assignments  ((sxpath `(nml:StateAssignment)) r))
664                  )
665             
666              (if (> (length on-conditions) 1)
667                  (error 'parse-al-sxml-dynamics "multiple on-conditions blocks in regime" r))
668             
669              (if (null? time-derivatives)
670                  (error 'parse-al-sxml-dynamics "regime does not contain time derivative blocks" r))
671             
672              (let
673                  (
674                    (ode-variables    (map (lambda (x) 
675                                             (string->symbol (sxml:attr x 'variable )))
676                                           time-derivatives))
677                   
678                    (ode-rhss         (map (lambda (x)
679                                             (parse-string-expr 
680                                              (sxml:kidn-cadr 'nml:MathInline x )
681                                              'parse-al-sxml-dynamics))
682                                           time-derivatives))
683
684                    (assign-variables (map (lambda (x) 
685                                             (string->symbol (sxml:attr  x 'variable))) 
686                                           state-assignments))
687
688                    (assign-rhss      (map (lambda (x)
689                                             (parse-string-expr 
690                                              (sxml:kidn-cadr 'nml:MathInline x) 
691                                              'parse-al-sxml-dynamics))
692                                           state-assignments))
693                   
694
695                    (relations        (map (lambda (x)
696                                             (let ((quantity (sxml:attr x 'name))
697                                                   (var      (sxml:attr x 'argument))
698                                                   (rhs      (parse-string-expr 
699                                                              (sxml:kidn-cadr 'nml:MathInline x )
700                                                              'parse-al-sxml-dynamics)))
701                                               (make-relation (string->symbol quantity)
702                                                              (string->symbol var)
703                                                              (make-signal-expr rhs))
704                                            ))
705                                           relations))
706
707                    )
708               
709               
710                (if (null? on-conditions)
711
712                    (let ((odes 
713                           (map (lambda (var rhs) (make-ode-eqn 't var 'h (make-signal-expr rhs))) 
714                                ode-variables ode-rhss))
715                         
716                          (assignments
717                           (and (not (null? assign-variables))
718                                (make-algebraic-eqn-lst-expr
719                                 (map (lambda (var rhs) (make-algebraic-eqn var (make-signal-expr rhs))  )
720                                      assign-variables assign-rhss))))
721                          )
722
723                      (if assignments
724
725                          (Apply
726                           (Apply
727                            diagram-sequence
728                            (if (null? relations)
729                                (make-ode-eqn-lst-expr odes)
730                                (make-dae-eqn-lst-expr (append relations odes))
731                                ))
732                           assignments)
733
734                          (if (null? relations)
735                            (make-ode-eqn-lst-expr odes)
736                            (make-dae-eqn-lst-expr (append relations odes))
737                            )
738                         
739                          ))
740                   
741                    (let ((c (car on-conditions)))
742
743                      (let (
744                            ( trigger (sxml:kidn-cadr 'nml:Trigger c))
745                            ( event-out (sxml:kidn 'nml:EventOut c))
746                            ( state-assignments1 ((sxpath `(nml:StateAssignment)) c))
747                            ( time-derivatives1 ((sxpath `(nml:TimeDerivative)) c))
748                            )
749                       
750                        (let ((ode-variables1 (map (lambda (x) 
751                                                     (string->symbol (sxml:attr x 'variable )))
752                                                   time-derivatives1))
753                             
754                              (ode-rhss1      (map (lambda (x)
755                                                     (parse-string-expr 
756                                                      (sxml:kidn-cadr 'nml:MathInline x )
757                                                      'parse-al-sxml-dynamics))
758                                                   time-derivatives1))
759                              )
760                         
761                          (if (not trigger) (error 'parse-al-sxml-dynamics "on-condition without trigger" c))
762                          (if (not event-out) (error 'parse-al-sxml-dynamics "on-condition without event-out" c))
763                         
764                          (let ((trigger-rhs (parse-string-expr 
765                                              (sxml:text trigger) 
766                                              'parse-al-sxml-dynamics))
767                                (trigger-name (string->symbol (sxml:attr event-out 'port )))
768                                (assign-variables1 (map (lambda (x) 
769                                                         (string->symbol (sxml:attr  x 'variable))) 
770                                                       state-assignments1))
771                                (assign-rhss1      (map (lambda (x)
772                                                          (parse-string-expr 
773                                                           (sxml:kidn-cadr 'nml:MathInline x) 
774                                                           'parse-al-sxml-dynamics))
775                                                        state-assignments1)))
776                           
777                            (make-transient relations 
778                                            ode-variables ode-rhss assign-variables assign-rhss
779                                            trigger-name trigger-rhs 
780                                            ode-variables1 ode-rhss1 assign-variables1 assign-rhss1)
781                           
782                            ))
783                        ))
784                    ))
785              ))
786          )
787
788         ((= (length regimes) 2)
789
790          (let ((rs regimes)
791                (state-name (gensym 'st)))
792
793            (let (
794                  (time-derivatives  (map (sxpath `(nml:TimeDerivative)) rs))
795                  (on-conditions     (map (sxpath `(nml:OnCondition)) rs))
796                  )
797             
798              (for-each
799               (lambda (r cs)
800                 (cond
801                  ((null? cs)
802                   (error 'parse-al-sxml-dynamics "regime does not contain on-conditions blocks" rs))
803                  ((> (length cs) 1)
804                   (error 'parse-al-sxml-dynamics "multiple on-conditions blocks in regime" r))
805                  ))
806               rs on-conditions)
807             
808
809              (if (every (lambda (x) (null? x)) time-derivatives)
810                  (error 'parse-al-sxml-dynamics "regime list does not contain time derivative blocks" rs))
811
812              (let (
813                    (relations
814                     (map (lambda (x)
815                            (let ((quantity (sxml:attr x 'name))
816                                  (var      (sxml:attr x 'argument))
817                                  (rhs      (parse-string-expr 
818                                             (sxml:kidn-cadr 'nml:MathInline x )
819                                             'parse-al-sxml-dynamics)))
820                              (make-relation (string->symbol quantity)
821                                             (string->symbol var)
822                                             (make-signal-expr rhs))
823                              ))
824                          relations))
825
826                    (regimes
827                     (map
828                      (lambda (r time-derivatives on-conditions)
829
830                        (let ((ode-variables (map (lambda (x) 
831                                                    (string->symbol (sxml:attr x 'variable )))
832                                                  time-derivatives))
833                                 
834                              (ode-rhss      (map (lambda (x)
835                                                    (parse-string-expr 
836                                                     (sxml:kidn-cadr 'nml:MathInline x )
837                                                     'parse-al-sxml-dynamics))
838                                                  time-derivatives))
839
840                              ( state-assignments ((sxpath `(nml:StateAssignment)) r))
841                             
842                              (c (car on-conditions)))
843                           
844                          (let (
845                                ( trigger (sxml:kidn-cadr 'nml:Trigger c))
846                                ( event-out (sxml:kidn 'nml:EventOut c))
847                                )
848                           
849                            (if (not trigger) 
850                                (error 'parse-al-sxml-dynamics "on-condition without trigger" c))
851
852                            (if (not event-out) 
853                                (error 'parse-al-sxml-dynamics "on-condition without event-out" c))
854                           
855                            (let* ((trigger-name (string->symbol (sxml:attr event-out 'port )))
856                                   
857                                   (trigger-rhs (parse-string-expr 
858                                                 (sxml:text trigger) 
859                                                 'parse-al-sxml-dynamics))
860                                   
861                                   ( c-state-assignments ((sxpath `(nml:StateAssignment)) c))
862                                   
863                                   (assign-variables (map (lambda (x) 
864                                                            (string->symbol (sxml:attr  x 'variable))) 
865                                                          (append state-assignments 
866                                                                  c-state-assignments)))
867                                   
868                                   (assign-rhss      (map (lambda (x)
869                                                            (parse-string-expr 
870                                                             (sxml:kidn-cadr 'nml:MathInline x) 
871                                                             'parse-al-sxml-dynamics))
872                                                          (append state-assignments
873                                                                  c-state-assignments)))
874                                   )
875                              (list ode-variables ode-rhss trigger-name trigger-rhs assign-variables assign-rhss))
876                             
877                              ))
878                        )
879                      regimes time-derivatives on-conditions))
880
881                    )
882
883                (match-let ((((ode-variables1 ode-rhss1 trigger-name1 trigger-rhs1 assign-variables1 assign-rhss1)
884                              (ode-variables2 ode-rhss2 trigger-name2 trigger-rhs2 assign-variables2 assign-rhss2))
885                             regimes))
886
887                      (make-rtransition state-name relations
888                                        ode-variables1 ode-rhss1 trigger-name1 trigger-rhs1 assign-variables1 assign-rhss1
889                                        ode-variables2 ode-rhss2 trigger-name2 trigger-rhs2 assign-variables2 assign-rhss2))
890               
891                ))
892            ))
893
894
895         ((> (length regimes) 2)
896          (error 'parse-al-sxml-dynamics "maximum of two regimes is supported" sxml))
897         
898         )
899       
900        (error 'parse-al-sxml-dynamics "no regimes found in component" )
901
902        )
903    ))
904 
905 
906
907
908(define (parse-al-sxml-component sxml)
909 
910  (let ((dynamics    (safe-car ((sxpath `(// nml:Dynamics)) sxml)))
911        (parameters  ((sxpath `(// nml:Parameter))  sxml))
912        (ports       ((sxpath `(// (*or* nml:AnalogPort nml:EventPort)))  sxml))
913        (name        (sxml:attr sxml 'name)))
914
915   (let ((dynamics-body 
916           (cond (dynamics => parse-al-sxml-dynamics)
917                 (else '())))
918
919         (dynamics-args
920          (cons* "h" "t" (map (lambda (x) (sxml:attr x 'name)) 
921                              (append (reverse ports)
922                                      (reverse parameters)))))
923         )
924
925     (Value_def (ident-create name) 
926                (let recur ((args dynamics-args) (ax dynamics-body))
927                  (if (null? args) ax
928                      (recur (cdr args) (Function (ident-create (car args)) ax)))))
929     )))
930
931
932
933(define (parse-al-sxml al-sxml)
934  (let ((al-sxml-defs ((sxpath `(// nml:ComponentClass))  al-sxml)) )
935
936    (map parse-al-sxml-component al-sxml-defs)
937
938    ))
939
940(register-macro-hook 'default parse-NineML-equation-sexpr-macro)
941(register-macro-hook 'list parse-list-sexpr-macro)
942
943)
Note: See TracBrowser for help on using the repository browser.