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

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

9ML-toolkit: bringing octave and scheme backends up to date; changed Izhikevich FS example to use heaviside function

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