Context Navigation

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

Last change on this file since 30881 was 30881, checked in by Ivan Raikov, 7 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.

Download in other formats: