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

Last change on this file since 29838 was 29838, checked in by Ivan Raikov, 8 years ago

9ML-toolkit: bug fixes in NineML -> signal-diagram conversion; ensure consistent results of Brunel alpha/delta variants

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