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

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

9ML-toolkit: a round of bug fixes to synapse handling and code generation for relations

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