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.