Context Navigation

source: project/release/3/oru/core.scm @ 11412

Last change on this file since 11412 was 11412, checked in by Ivan Raikov, 13 years ago
Repository synchronized.
File size: 30.8 KB

Line
1	;;
2	;; NeuroML substrate semantics.
3	;;
4	;; Copyright 2008 Ivan Raikov and the Okinawa Institute of Science and Technology
5	;;
6	;; This program is free software: you can redistribute it and/or
7	;; modify it under the terms of the GNU General Public License as
8	;; published by the Free Software Foundation, either version 3 of the
9	;; License, or (at your option) any later version.
10	;;
11	;; This program is distributed in the hope that it will be useful, but
12	;; WITHOUT ANY WARRANTY; without even the implied warranty of
13	;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14	;; General Public License for more details.
15	;;
16	;; A full copy of the GPL license can be found at
17	;; <http://www.gnu.org/licenses/>.
18	;;
19
20	(require-extension srfi-1)
21	(require-extension srfi-4)
22	(require-extension srfi-13)
23	(require-extension srfi-14)
24	(require-extension datatype)
25	(require-extension vector-lib)
26	(require-extension environments)
27	(require-extension digraph)
28	(require-extension graph-bfs)
29	(require-extension graph-cycles)
30	(require-extension mathh)
31	(require-extension lolevel)
32
33	(include "mathh-constants")
34
35	(define-extension oru-core)
36
37	(declare (export make-oru-core oru:error oru:warning
38	oru:env-copy oru-intern oru:quantity?
39	eval-oru-system-decls
40	TSCOMP ASGN CONST PRIM))
41
42	;--------------------
43	; Message routines
44	;
45	;
46
47	(define (oru:warning x . rest)
48	(let loop ((port (open-output-string)) (objs (cons x rest)))
49	(if (null? objs)
50	(begin
51	(newline port)
52	(print-error-message (get-output-string port)
53	(current-error-port) "oru warning"))
54	(begin (display (car objs) port)
55	(display " " port)
56	(loop port (cdr objs))))))
57
58	(define (oru:error x . rest)
59	(let ((port (open-output-string)))
60	(if (port? x)
61	(begin
62	(display "[" port)
63	(display (port-name x) port)
64	(display "] " port)))
65	(let loop ((objs (if (port? x) rest (cons x rest))))
66	(if (null? objs)
67	(begin
68	(newline port)
69	(error 'oru (get-output-string port)))
70	(let ((obj (car objs)))
71	(if (procedure? obj)
72	(with-output-to-port port obj)
73	(begin
74	(display obj port)
75	(display " " port)))
76	(loop (cdr objs)))))))
77
78	(define (rhs? x) (or (symbol? x) (number? x) (and (list? x) (every rhs? x))))
79
80	(define (transition? x)
81	(match x (('-> a b x) (and (symbol? a) (symbol? b) (rhs? x)))
82	(else #f)))
83
84	(define-datatype oru:quantity oru:quantity?
85	(SYSNAME (name symbol?))
86	(ASGN (name symbol?) (value number?) (rhs rhs?) )
87	(CONST (name symbol?) (value number?))
88	(TSCOMP (name symbol?) (initial rhs?)
89	(open (lambda (x) (or (symbol? x) (and (list? x) (every symbol? x) ))))
90	(transitions (lambda (x) (and (list? x) (every transition? x))))
91	(power integer?))
92	(PRIM (name symbol?) (value identity))
93	(EXTERNAL (local-name symbol?) (name symbol?) (namespace (lambda (x) (or (not x) (symbol? x)))))
94	(DISPATCH (value procedure?))
95	(EXPORTS (lst (lambda (x) (and (list? x) (every symbol? x)))))
96	(COMPONENT (type symbol?) (lst (lambda (x) (and (list? x) (every symbol? x)))))
97	)
98
99	(define (oru-intern sym)
100	(string->symbol (string-append "#" (symbol->string sym))))
101
102	(define (lookup-def k lst . rest)
103	(let-optionals rest ((default #f))
104	(let ((v (alist-ref k lst)))
105	(if v (first v) default))))
106
107	(define (make-oru-core . alst)
108
109	;; floating point precision (single or double; default is double)
110	(define fptype (lookup-def 'fpprec alst 'double))
111	(define fpvector-type
112	(lookup-def 'fpvector-type alst (if (equal? fptype 'single) 'f32vector 'f64vector)))
113	(define fpvector?
114	(lookup-def 'fpvector? alst (if (equal? fptype 'single) f32vector? f64vector?)))
115	(define fpvector
116	(lookup-def 'fpvector alst (if (equal? fptype 'single) f32vector f64vector)))
117	(define fpvector-ref
118	(lookup-def 'fpvector-ref alst (if (equal? fptype 'single) f32vector-ref f64vector-ref)))
119	(define fpvector-set!
120	(lookup-def 'fpvector-set! alst (if (equal? fptype 'single) f32vector-set! f64vector-set!)))
121
122
123	(define builtin-fns
124	`(+ - * / pow neg abs atan asin acos sin cos exp ln
125	sqrt tan cosh sinh tanh hypot gamma lgamma log10 log2 log1p ldexp cube
126	> < <= >= = and or round ceiling floor max min
127	fpvector-ref))
128
129	(define (add-primitives! env)
130	(for-each (lambda (n b fms rt)
131	(let ((fb (extend-procedure b `((rt ,rt) (formals ,fms)))))
132	(environment-extend! env n fb)))
133	builtin-fns
134	(list fp+ fp- fp* fp/ expt fpneg
135	abs atan asin acos sin cos exp log sqrt tan
136	cosh sinh tanh hypot gamma lgamma log10 log2 log1p ldexp
137	(lambda (x) (* x x x))
138	fp> fp< fp<= fp>= fp=
139	(lambda (x y) (and x y)) (lambda (x y) (or x y))
140	round ceiling floor fpmax fpmin
141	fpvector-ref)
142	`((,fptype ,fptype) (,fptype ,fptype) (,fptype ,fptype) (,fptype ,fptype)
143	(,fptype ,fptype) (,fptype)
144	(,fptype) (,fptype) (,fptype) (,fptype) (,fptype) (,fptype) (,fptype)
145	(,fptype) (,fptype) (,fptype)
146	(,fptype) (,fptype) (,fptype) (,fptype) (,fptype) (,fptype) (,fptype)
147	(,fptype) (,fptype) (,fptype)
148	(,fptype)
149	(bool bool) (bool bool) (bool bool) (bool bool) (bool bool) (bool bool) (bool bool)
150	(,fptype) (,fptype) (,fptype) (,fptype ,fptype) (,fptype ,fptype)
151	(,fpvector-type integer) )
152	`(,fptype ,fptype ,fptype ,fptype
153	,fptype ,fptype
154	,fptype ,fptype ,fptype ,fptype ,fptype ,fptype ,fptype
155	,fptype ,fptype ,fptype
156	,fptype ,fptype ,fptype ,fptype ,fptype ,fptype ,fptype
157	,fptype ,fptype ,fptype
158	,fptype
159	bool bool bool bool bool bool bool
160	,fptype ,fptype ,fptype ,fptype ,fptype
161	,fptype )
162	))
163
164	(define (add-constants! env)
165	(for-each (lambda (n b) (environment-extend! env n b))
166	`(E 1/E E^2 E^PI/4 LOG2E LOG10E LN2 LN3 LNPI LN10 1/LN2 1/LN10 PI PI/2
167	PI/4 1/PI 2/PI 2/SQRTPI SQRTPI PI^2 DEGREE SQRT2 1/SQRT2 SQRT3 SQRT5
168	SQRT10 CUBERT2 CUBERT3 4THRT2 GAMMA1/2 GAMMA1/3 GAMMA2/3 PHI LNPHI
169	1/LNPHI EULER E^EULER SIN1 COS1 ZETA3)
170	(list E 1/E E^2 E^PI/4 LOG2E LOG10E LN2 LN3 LNPI LN10 1/LN2 1/LN10 PI PI/2
171	PI/4 1/PI 2/PI 2/SQRTPI SQRTPI PI^2 DEGREE SQRT2 1/SQRT2 SQRT3 SQRT5
172	SQRT10 CUBERT2 CUBERT3 4THRT2 GAMMA1/2 GAMMA1/3 GAMMA2/3 PHI LNPHI
173	1/LNPHI EULER E^EULER SIN1 COS1 ZETA3)))
174
175
176	(define (enumdeps expr ax)
177	(match expr
178	((s . es) (if (symbol? s) (fold enumdeps ax es) (fold enumdeps ax (cons s es))))
179	(id (if (symbol? id) (cons id ax) ax))))
180
181
182	(define (binop-fold op lst)
183	(if (null? lst) lst
184	(match lst
185	((x) x)
186	((x y) `(,op ,x ,y))
187	((x y . rest) `(,op (,op ,x ,y) ,(binop-fold op rest)))
188	((x . rest) `(,op ,x ,(binop-fold op rest))))))
189
190
191	;; if argument is constant, return the negative of that constant,
192	;; otherwise return `(neg ,expr)
193	(define (negate expr)
194	(if (number? expr) (- expr)
195	`(neg ,expr)))
196
197	;; 1. make sure all constants in an expression are flonums
198	;; 2. fold expressions like (+ a b c d) into nested binops
199	(define (normalize-expr expr)
200	(match expr
201	(('+ . es) (binop-fold '+ (map normalize-expr es)))
202	(('- . es) (let ((es1 (map normalize-expr es)))
203	(binop-fold '+ (cons (car es1) (map negate (cdr es1))))))
204	(('* . es) (binop-fold '* (map normalize-expr es)))
205	(('/ . es) (binop-fold '/ (map normalize-expr es)))
206	(('fix n) n)
207	((s . es) (cons s (map normalize-expr es)))
208	(x (if (number? x) (exact->inexact x) x))))
209
210	(define (make-base-env)
211	(let ((env (make-environment #t)))
212	(add-primitives! env)
213	(add-constants! env)
214	env))
215
216	(define (make-const-env oru-env)
217	(let ((env (make-base-env)))
218	(environment-for-each oru-env
219	(lambda (sym en)
220	(cond ((oru:quantity? en)
221	(cases oru:quantity en
222	(CONST (name value)
223	(environment-extend! env name value))
224	(PRIM (name value)
225	(environment-extend! env name value))))
226	((procedure? en)
227	(environment-extend! env sym en)))))
228	env))
229
230	(define (system name)
231	(let ((env (make-base-env))
232	(name (if (symbol? name) name (string->symbol name))))
233	(environment-extend! env (oru-intern 'dispatch) (DISPATCH oru-dispatch))
234	(environment-extend! env (oru-intern 'name) (SYSNAME name))
235	(environment-extend! env (oru-intern 'exports) (EXPORTS (list)))
236	env))
237
238	(define (add-external! oru-env)
239	(lambda (sym typ)
240	(match typ
241	('output
242	(begin
243	(if (not (environment-has-binding? oru-env sym))
244	(oru:error 'add-external! ": exported quantity " sym " is not defined"))
245	(let* ((exports-sym (oru-intern 'exports))
246	(exports (environment-ref oru-env exports-sym)))
247	(cases oru:quantity exports
248	(EXPORTS (lst) (environment-set! oru-env exports-sym (EXPORTS (cons sym lst))))
249	(else (oru:error 'add-external! ": invalid exports entry " exports))))))
250
251	(('input sym lsym ns)
252	(let ((lsym (or lsym sym)))
253
254	(if (environment-has-binding? oru-env lsym)
255	(oru:error 'add-import! ": import symbol " lsym " is already defined"))
256
257	((env-extend! oru-env) lsym '(external) 'none `(name ,sym) `(namespace ,ns))))
258
259	)))
260
261	(define (env-extend! oru-env)
262	(lambda (name type initial . alst)
263	(let ((sym (if (symbol? name) name (string->symbol name))))
264	(if (environment-has-binding? oru-env sym)
265	(oru:error 'env-extend! ": quantity " sym " already defined")
266	(match type
267	(('external) (let ((ns (lookup-def 'namespace alst))
268	(external-name (lookup-def 'name alst)))
269	(environment-extend! oru-env sym (EXTERNAL name external-name ns ))))
270
271	(('prim) (let* ((rhs (lookup-def 'rhs alst))
272	(val (if (and rhs (procedure? initial) )
273	(extend-procedure initial rhs)
274	initial)))
275	(environment-extend! oru-env sym (PRIM name val ))))
276
277	(('const) (begin
278	(if (not (number? initial))
279	(oru:error 'env-extend! ": constant definitions require numeric value"))
280	(environment-extend! oru-env sym (CONST name initial))))
281
282	(('tscomp) (let ((power (or (lookup-def 'power alst) 1))
283	(transitions (or (alist-ref 'transitions alst) (list)))
284	(open (lookup-def 'open alst)))
285	(if (null? transitions)
286	(oru:error 'env-extend!
287	": transition state complex definitions require a transition scheme"))
288	(if (not open)
289	(oru:error 'env-extend! ": state complex definitions require open state"))
290	(if (not (integer? power))
291	(oru:error 'env-extend!
292	": definition for state " sym
293	" requires an integer power (" power " was given)"))
294	(let ((en (TSCOMP name initial open transitions power)))
295	(environment-extend! oru-env sym en))))
296
297	(('asgn) (let ((rhs (lookup-def 'rhs alst)))
298	(if (not (eq? initial 'none))
299	(oru:error 'env-extend!
300	": state function definitions must have initial value of '(none)"))
301	(if (not rhs)
302	(oru:error 'env-extend! ": state function definitions require an equation"))
303	(environment-extend! oru-env sym (ASGN name 0.0 (normalize-expr rhs)))))
304
305	(else (begin
306	(environment-extend! oru-env sym `(,type (name ,sym) . ,initial))))
307	)))))
308
309	(define (infer oru-env ftenv formals body)
310	(let recur ((expr body))
311	(match expr
312	(('if c t e)
313	(let ((ct (recur c))
314	(tt (recur t))
315	(et (recur e)))
316	(and ct tt et
317	(begin
318	(if (not (equal? ct 'bool))
319	(oru:error 'infer "if condition type must be boolean"))
320	(if (equal? tt et) tt
321	(oru:error 'infer "type mismatch in if statement: then = " tt
322	" else = " et))))))
323
324	((s . es)
325	(let* ((f (environment-ref oru-env s))
326	(lst (procedure-data f)))
327	(and lst
328	(let ((rt (lookup-def 'rt lst))
329	(fms (lookup-def 'formals lst)))
330	(and rt fms
331	(begin
332	(for-each (lambda (x ft)
333	(if (and (symbol? x) (not (environment-includes? ftenv x)))
334	(environment-extend! ftenv x ft)))
335	es fms)
336	(let ((ets (map recur es)))
337	(and (every identity ets)
338	(every (lambda (xt ft) (equal? xt ft)) ets fms)
339	rt))))))))
340
341	(id (cond ((symbol? id) (environment-ref ftenv id))
342	((number? id) fptype)
343	((boolean? id) 'bool)
344	((fpvector? id) fpvector-type)
345	(else #f))))))
346
347
348	(define (defun! oru-env)
349	(lambda (name formals body)
350	(let ((const-env (make-const-env oru-env))
351	(sym (if (symbol? name) name (string->symbol name))))
352	(letrec ((enumconsts
353	(lambda (expr ax)
354	(match expr
355	(('if . es) (fold enumconsts ax es))
356	((s . es) (if (symbol? s) (cons s (fold enumconsts ax es)) ax))
357	(s (if (and (symbol? s) (environment-includes? const-env s))
358	(cons s ax) ax))))))
359	(if (environment-has-binding? oru-env sym)
360	(oru:error 'defun! ": quantity " sym " already defined")
361	(let* ((body (normalize-expr body))
362	(consts (delete-duplicates (enumconsts body (list))))
363	(fc `(lambda (const-env)
364	(let ,(map (lambda (v) `(,v (environment-ref const-env ',v))) consts)
365	(lambda ,formals ,body))))
366	(f ((eval fc) const-env)))
367
368	(let* ((ftenv (make-environment))
369	(rt (infer oru-env ftenv formals body))
370	(ftypes (filter-map (lambda (x) (and (environment-includes? ftenv x)
371	(environment-ref ftenv x)))
372	formals))
373	(ef (extend-procedure f `((rt ,rt) (formals ,ftypes) (vars ,formals)
374	(body ,body) (consts ,consts)))))
375	(environment-extend! oru-env sym ef))))))))
376
377	(define (symbol-list? lst)
378	(and (list? lst) (every symbol? lst)))
379
380	(define (extended oru-env)
381	(filter-map (lambda (sym)
382	(let ((x (environment-ref oru-env sym)))
383	(and (not (oru:quantity? x)) (not (procedure? x))
384	(match x
385	(((? symbol-list?) ('name name) . rest) `(,sym ,x))
386	(else #f)))))
387	(environment-symbols oru-env)))
388
389
390	(define (extended-with-tag oru-env tag)
391	(filter-map (lambda (sym)
392	(let ((x (environment-ref oru-env sym)))
393	(and (not (oru:quantity? x)) (not (procedure? x))
394	(match x
395	(((? (lambda (x) (equal? x tag))) ('name name) . rest)
396	`(,sym ,x))
397	(else #f)))))
398	(environment-symbols oru-env)))
399
400
401	(define (components oru-env)
402	(filter-map (lambda (sym)
403	(let ((x (environment-ref oru-env sym)))
404	(and (oru:quantity? x)
405	(cases oru:quantity x
406	(COMPONENT (type lst) `(,type ,sym))
407	(else #f)))))
408	(environment-symbols oru-env)))
409
410
411	(define (component-symbols oru-env sym)
412	(let ((x (environment-ref oru-env sym)))
413	(and (oru:quantity? x)
414	(cases oru:quantity x
415	(COMPONENT (type lst) lst)
416	(else #f)))))
417
418
419	(define (component-exports oru-env sym)
420	(let ((all-exports (cases oru:quantity (environment-ref oru-env (oru-intern 'exports))
421	(EXPORTS (lst) lst))))
422	(let ((x (environment-ref oru-env sym)))
423	(and (oru:quantity? x)
424	(cases oru:quantity x
425	(COMPONENT (type lst)
426	(filter-map (lambda (x) ((lambda (x) (and x (car x))) (member x all-exports))) lst))
427	(else #f))))))
428
429	(define (component-subcomps oru-env sym)
430	(define (component-type x)
431	(cases oru:quantity x
432	(COMPONENT (type lst) type)
433	(else #f)))
434	(let ((x (environment-ref oru-env sym)))
435	(and (oru:quantity? x)
436	(cases oru:quantity x
437	(COMPONENT (type lst)
438	(filter-map (lambda (s) (let ((x (environment-ref oru-env s)))
439	(and (iscomp? x) `(,(component-type x) ,s)))) lst))
440	(else #f)))))
441
442	(define (component-extend! oru-env)
443	(lambda (comp sym)
444	(let ((x (environment-ref oru-env comp)))
445	(if (oru:quantity? x)
446	(cases oru:quantity x
447	(COMPONENT (type lst)
448	(let ((en1 (COMPONENT type (cons sym lst))))
449	(environment-set! oru-env comp en1)))
450	(else (oru:error 'component-extend! ": invalid component " comp)))
451	(oru:error 'component-extend! ": invalid component " comp)))))
452
453
454	(define (exports oru-env)
455	(cases oru:quantity (environment-ref oru-env (oru-intern 'exports))
456	(EXPORTS (lst) lst)))
457
458
459	(define (imports oru-env)
460	(filter-map (lambda (sym)
461	(let ((x (environment-ref oru-env sym)))
462	(and (oru:quantity? x)
463	(cases oru:quantity x
464	(EXTERNAL (local-name name namespace) (list local-name name namespace))
465	(else #f)))))
466	(environment-symbols oru-env)))
467
468
469	(define (consts oru-env)
470	(filter-map (lambda (sym)
471	(let ((x (environment-ref oru-env sym)))
472	(and (oru:quantity? x)
473	(cases oru:quantity x
474	(CONST (name value) (list name value) )
475	(else #f)))))
476	(environment-symbols oru-env)))
477
478
479	(define (states oru-env)
480	(fold (lambda (sym ax)
481	(let ((x (environment-ref oru-env sym)))
482	(if (oru:quantity? x)
483	(cases oru:quantity x
484	(TSCOMP (name initial open transitions power)
485	(let ((ss (delete-duplicates (append (map second transitions)
486	(map third transitions)))))
487	(append ss ax)))
488	(else ax))
489	ax)))
490	(list) (environment-symbols oru-env)))
491
492
493	(define (stcomps oru-env)
494	(fold (lambda (sym ax)
495	(let ((x (environment-ref oru-env sym)))
496	(if (oru:quantity? x)
497	(cases oru:quantity x
498	(TSCOMP (name initial open transitions power)
499	(cons name ax))
500	(else ax))
501	ax)))
502	(list) (environment-symbols oru-env)))
503
504
505	(define (asgns oru-env)
506	(filter-map (lambda (sym)
507	(let ((x (environment-ref oru-env sym)))
508	(and (oru:quantity? x)
509	(cases oru:quantity x
510	(ASGN (name value rhs) name)
511	(else #f)))))
512	(environment-symbols oru-env)))
513
514
515	(define (defuns oru-env)
516	(filter-map (lambda (sym)
517	(let ((x (environment-ref oru-env sym)))
518	(and (procedure? x) (not (member sym builtin-fns)) (list sym x))))
519	(environment-symbols oru-env)))
520
521
522
523	(define (exam oru-env)
524	(lambda (name)
525	(let ((sym (if (symbol? name) name (string->symbol name)))
526	(out (current-output-port)))
527	(if (not (environment-has-binding? oru-env sym))
528	(oru:error 'exam ": quantity " sym " is not defined")
529	(let ((x (environment-ref oru-env sym)))
530	(cases oru:quantity x
531	(PRIM (name value)
532	(begin
533	(fprintf out "~a: compiled coru primitive\n" name)
534	(fprintf out " value: ~a\n" value)))
535
536	(TSCOMP (name initial open transitions power)
537	(begin
538	(fprintf out "~a: transition state complex\n" name)
539	(fprintf out " initial value: ~a\n" initial)))
540
541	(CONST (name value)
542	(begin
543	(fprintf out "~a: constant\n" name)
544	(fprintf out " value: ~a\n" value)))
545
546	(ASGN (name value rhs)
547	(begin
548	(fprintf out "~a: state function\n" name)
549	(fprintf out " value: ~a\n" value)))
550
551	(else (oru:error 'exam name ": unknown type of quantity"))))))))
552
553
554	(define (eval-const oru-env expr)
555	(exact->inexact (eval (normalize-expr expr) (make-const-env oru-env))))
556
557
558	(define (iscomp? x)
559	(cond ((oru:quantity? x)
560	(cases oru:quantity x
561	(COMPONENT (type lst) #t)
562	(else #f)))
563	(else #f)))
564
565	(define (isdep? x)
566	(cond ((oru:quantity? x)
567	(cases oru:quantity x
568	(ASGN (name value rhs) #t)
569	(else #f)))
570	((and (list? x) (every pair? (cdr x))) (alist-ref 'dep? (cdr x)))
571	(else #f)))
572
573
574	(define (isstate? x)
575	(and (oru:quantity? x)
576	(cases oru:quantity x
577	(TSCOMP (name initial open transitions) #t)
578	(else #f))))
579
580
581	(define (qrhs x)
582	(and (oru:quantity? x)
583	(cases oru:quantity x
584	(TSCOMP (name initial open transitions)
585	(begin
586	(map cadddr transitions)))
587	(ASGN (name value rhs) rhs)
588	(else #f))))
589
590
591	(define (sysname oru-env)
592	(cases oru:quantity (environment-ref oru-env (oru-intern 'name))
593	(SYSNAME (name) name)))
594
595
596	;; create equation dependency graph
597	(define (make-eqng oru-env)
598	(let* ((sysname (sysname oru-env))
599	(g (make-digraph sysname (string-append (symbol->string sysname)
600	" equation dependency graph")))
601	(add-node! (g 'add-node!))
602	(add-edge! (g 'add-edge!))
603	(oru-list (filter (lambda (sym) (let ((x (environment-ref oru-env sym)))
604	(or (isstate? x) (isdep? x))))
605	(environment-symbols oru-env)))
606	(oru-ids (list-tabulate (length oru-list) identity))
607	(name->id-map (zip oru-list oru-ids)))
608	(let-values (((state-list asgn-list)
609	(partition (lambda (sym) (isstate? (environment-ref oru-env sym)))
610	oru-list)))
611
612	;; insert equations in the dependency graph
613	(for-each (lambda (i n) (add-node! i n)) oru-ids oru-list)
614	;; create dependency edges in the graph
615	(for-each (lambda (e)
616	(match e ((ni . nj) (begin
617	(let ((i (car (alist-ref ni name->id-map)))
618	(j (car (alist-ref nj name->id-map))))
619	(add-edge! (list i j (format "~A=>~A" ni nj))))))
620	(else (oru:error 'make-eqng ": invalid edge " e))))
621	(fold (lambda (qsym ax)
622	(let* ((q (environment-ref oru-env qsym))
623	(rhs (qrhs q)))
624	(if rhs
625	(let* ((deps (filter (if (isstate? q)
626	(lambda (sym)
627	(and (let ((x (environment-ref oru-env sym)))
628	(and (isdep? x) (not (eq? sym qsym))))))
629	(lambda (sym)
630	(and (let ((x (environment-ref oru-env sym)))
631	(isdep? x)))))
632	(enumdeps rhs (list))))
633	(edges (map (lambda (d) (cons d qsym)) deps)))
634	(if edges (append edges ax) ax))
635	ax)))
636	(list) oru-list))
637	(let ((cycles (graph-cycles-fold g (lambda (cycle ax) (cons cycle ax)) (list))))
638	(if (null? cycles) (list state-list asgn-list g)
639	(oru:error 'make-eqng ": equation cycle detected: " (car cycles)))))))
640
641
642	;; given a graph, create a partial ordering based on BFS distance from root
643	(define (graph->bfs-dist-poset g)
644	(define node-info (g 'node-info))
645
646	(let-values (((dists dmax) (graph-bfs-dist g ((g 'roots)))))
647	(let loop ((poset (make-vector (fx+ 1 dmax) (list)))
648	(i (fx- (s32vector-length dists) 1)))
649	(if (fx>= i 0)
650	(let* ((c (s32vector-ref dists i))
651	(info (node-info i)))
652	(vector-set! poset c (cons (cons i info) (vector-ref poset c)))
653	(loop poset (fx- i 1)))
654	(begin
655	poset)))))
656
657
658	(define (make-eval-poset oru-env eqposet)
659	(vector-map
660	(lambda (i lst)
661	(filter-map (lambda (id+sym)
662	(let* ((sym (cdr id+sym))
663	(x (environment-ref oru-env sym)))
664	(and (oru:quantity? x)
665	(cases oru:quantity x
666	(TSCOMP (name initial open transitions)
667	(let ((rs (map cadddr transitions)))
668	(list 'ts sym rs)))
669	(ASGN (name value rhs)
670	(list 'a sym rhs))
671	(else oru:error 'make-eval-poset
672	": invalid quantity in equation poset: " sym)))))
673	lst))
674	eqposet))
675
676	(define (eval-expr env)
677	(lambda (expr)
678	(let ((val (match expr
679	(('if c t f)
680	(let ((ee (eval-expr env)))
681	(condition-case
682	(if (ee c) (ee t) (ee f))
683	[var ()
684	(oru:error 'eval-expr " exception in " expr ": \n"
685	(lambda () (print-error-message var)))])))
686
687	((s . es)
688	(condition-case
689	(let ((op (environment-ref env s))
690	(args (map (eval-expr env) es)))
691	(apply op args))
692	[var ()
693	(oru:error 'eval-expr " exception in " expr ": \n"
694	(lambda () (print-error-message var)))]))
695
696	(s
697	(cond ((symbol? s) (environment-ref env s))
698	((number? s) s)
699	(else (oru:error 'eval-expr "unknown expression " s)))))))
700	val)))
701
702
703	(define (depgraph oru-env)
704	(match-let (((state-list asgn-list g) (make-eqng oru-env))) g))
705
706	(define (depgraph* oru-env)
707	(match-let (((state-list asgn-list g) (make-eqng oru-env)))
708	(list state-list asgn-list g)))
709
710
711	;; Dispatcher
712	(define (oru-dispatch selector)
713	(case selector
714	((add-external!) add-external!)
715	((defun!) defun!)
716	((depgraph) depgraph)
717	((depgraph) depgraph)
718	((depgraph->bfs-dist-poset) graph->bfs-dist-poset)
719	((eval-const) eval-const)
720	((env-extend!) env-extend!)
721	((exam) exam)
722	((make-const-env) make-const-env)
723	((system) system)
724	((sysname) sysname)
725	((asgns) asgns)
726	((states) states)
727	((stcomps) stcomps)
728	((defuns) defuns)
729	((consts) consts)
730	((exports) exports)
731	((imports) imports)
732	((components) components)
733	((component-symbols) component-symbols)
734	((component-exports) component-exports)
735	((component-subcomps) component-subcomps)
736	((component-extend!) component-extend!)
737	((extended) extended)
738	((extended-with-tag) extended-with-tag)
739	(else
740	(oru:error 'selector ": unknown message " selector " sent to an oru-core object"))))
741
742	oru-dispatch)
743
744	(define oru:env-copy environment-copy)
745
746	(define qcounter 0)
747
748	(define (qname prefix)
749	(let ((v qcounter))
750	(set! qcounter (+ 1 qcounter))
751	(string->symbol (string-append (->string prefix) (number->string v)))))
752
753	(define (eval-oru-system-decls oru-core name sys declarations)
754	(define (eval-const x) (and x ((oru-core 'eval-const) sys x)))
755	(let loop ((ds declarations) (qs (list)))
756	(if (null? ds) qs
757	(let ((decl (car ds)))
758	(let ((qs1 (match decl
759	;; imported quantities
760	(('input . lst)
761	(cond ((every (lambda (x) (or (symbol? x) (list? x))) lst)
762	(fold (lambda (x ax)
763	(match x
764	((? symbol?)
765	(((oru-core 'add-external!) sys) x `(input ,x ,x #f))
766	(cons x ax))
767	((id1 'as x1)
768	(((oru-core 'add-external!) sys) x `(input ,id1 ,x1 #f))
769	(cons x1 ax))
770	((id1 'from n1)
771	(((oru-core 'add-external!) sys) x `(input ,id1 ,id1 ,n1))
772	(cons id1 ax))
773	((id1 'as x1 'from n1)
774	(((oru-core 'add-external!) sys) x `(input ,id1 ,x1 ,n1))
775	(cons x1 ax))
776	))
777	qs lst))
778	(else (oru:error 'eval-oru-system-decls
779	"import statement must be of the form: "
780	"input id1 [as x1] ... "))))
781
782	;; exported quantities
783	(('output . lst)
784	(cond ((every symbol? lst)
785	(for-each (lambda (x) (((oru-core 'add-external!) sys) x 'output)) lst)
786	qs)
787	(else (oru:error 'eval-oru-system-decls
788	"export statement must be of the form: "
789	"output id1 ... "))))
790
791	;; constant during integration
792	(('const id '= expr)
793	(cond ((and (symbol? id) (or (number? expr) (list? expr)))
794	(let ((val (eval-const expr)))
795	(((oru-core 'env-extend!) sys) id '(const) val)
796	(cons id qs)))
797	(else (oru:error 'eval-oru-system-decls
798	"constant declarations must be of the form: "
799	"const id = expr"))))
800
801	;; state transition complex
802	(('state-complex (id . alst) )
803	(cond ((and (symbol? id) (list? alst))
804	(let ((initial (eval-const (lookup-def 'initial alst)))
805	(power (eval-const (lookup-def 'power alst))))
806	(apply ((oru-core 'env-extend!) sys)
807	(cons* id '(tscomp) initial `(power ,power) alst)))
808	(cons id qs))
809	(else (oru:error 'eval-oru-system-decls
810	"state complex declarations must be of the form: "
811	"state-complex (id ...)"))))
812
813	;; algebraic assignment
814	((id '= expr)
815	(cond ((and (symbol? id) (or (symbol? expr) (number? expr) (list? expr)))
816	(((oru-core 'env-extend!) sys) id '(asgn) 'none `(rhs ,expr))
817	(cons id qs))
818	(else (oru:error 'eval-oru-system-decls
819	"algebraic declarations must be of the form: "
820	"id = expr"))))
821
822	;; user-defined function
823	(('defun id idlist expr)
824	(cond ((and (symbol? id) (list? idlist) (every symbol? idlist) (list? expr))
825	(((oru-core 'defun!) sys) id idlist expr)
826	(cons id qs))
827	(else (oru:error 'eval-oru-system-decls
828	"function declarations must be of the form: "
829	"defun id (arg1 arg2 ...) expr"))))
830
831	;; compiled coru primitives
832	(('prim id value)
833	(cond ((symbol? id) (((oru-core 'env-extend!) sys) id '(prim) value))
834	(else (oru:error 'eval-oru-system-decls
835	"prim declarations must be of the form: "
836	"prim id value"))))
837
838	(('component ('type typ) ('name name) . lst)
839	(let* ((cqs (loop lst (list)))
840	(comp (COMPONENT typ cqs))
841	(sym (string->symbol (->string name))))
842	(environment-set! sys sym comp)
843	(cons sym qs)))
844
845
846	(('component ('type typ) . lst)
847	(let* ((cqs (loop lst (list)))
848	(comp (COMPONENT typ cqs))
849	(sym (qname "comp")))
850	(environment-set! sys sym comp)
851	(cons sym qs)))
852
853
854	(('sysname name) (if (symbol? name)
855	(environment-set! sys (oru-intern 'name) (SYSNAME name))
856	(oru:error 'eval-oru-system-decls
857	"system name must be a symbol")))
858
859	(('const . _)
860	(oru:error 'eval-oru-system-decls "constant declarations must be of the form: "
861	"const id = expr"))
862
863	((id '= . _)
864	(oru:error 'eval-oru-system-decls "algebraic equations must be of the form: "
865	"id = expr"))
866
867	(('state-complex . _)
868	(oru:error 'eval-oru-system-decls
869	"state complex declarations must be of the form: "
870	"state-complex (id ...)"))
871
872	(('defun . _)
873	(oru:error 'eval-oru-system-decls "function declarations must be of the form: "
874	"defun id (arg1 arg2 ...) expr"))
875
876	(('prim . _)
877	(oru:error 'eval-oru-system-decls "prim declarations must be of the form: "
878	"prim id value"))
879
880	(('component . _)
881	(oru:error 'eval-oru-system-decls "invalid component: " decl))
882
883	(('sysname . _)
884	(oru:error 'eval-oru-system-decls "system name must be of the form (sysname name)"))
885
886	;; anything that doesn't match is possibly
887	;; declarations recognized by the oru extension
888	;; modules
889	((tag . lst)
890	(if (symbol? tag)
891	(match-let (((typ name alst)
892	(let loop ((lst lst) (ax (list tag)))
893	(if (null? lst)
894	(list (list (car (reverse ax))) #f (cdr (reverse ax)))
895	(match lst
896	(((? symbol?) . rest)
897	(loop (cdr lst) (cons (car lst) ax)))
898	(((x . rest))
899	(if (and (symbol? x) (every list? rest))
900	(list (reverse ax) x rest)
901	(list (reverse ax) #f lst)))
902	(else (list (reverse ax) #f lst)))))))
903	(let ((name (or name (qname tag))))
904	(((oru-core 'env-extend!) sys) name typ alst)
905	(cons name qs)))
906	(oru:error 'eval-oru-system-decls "extended declarations must be of the form: "
907	"declaration (name (properties ...)"))))))
908
909
910	(loop (cdr ds) qs1)))
911	))
912	sys)

Note: See TracBrowser for help on using the repository browser.

Download in other formats: