source: project/release/3/oru/trunk/oru.scm @ 11701

Last change on this file since 11701 was 11701, checked in by Ivan Raikov, 13 years ago

moved everything to trunk

File size: 31.9 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)
177    (let loop ((expr expr) (ax (list)) (lbs (list)))
178      (match expr 
179             (('let bs e)  (let let-loop ((bs bs) (ax ax) (lbs lbs))
180                             (if (null? bs) (loop e ax lbs)
181                                 (let ((x   (first  (car bs)))
182                                       (ex  (second (car bs))))
183                                   (let* ((lbs1  (cons x lbs))
184                                          (ax1   (loop ex ax lbs)))
185                                     (let-loop (cdr bs) ax1 lbs1))))))
186
187             ((s . es)     (if (symbol? s) (fold (lambda (e ax) (loop e ax lbs)) ax es) 
188                               (fold (lambda (e ax) (loop e ax lbs)) ax (cons s es))))
189             (id           (if (and (symbol? id) (not (member id lbs))) (cons id ax) ax)))))
190
191
192  (define (binop-fold op lst)
193    (if (null? lst) lst
194        (match lst
195               ((x)   x)
196               ((x y) `(,op ,x ,y))
197               ((x y . rest) `(,op (,op ,x ,y) ,(binop-fold op rest)))
198               ((x . rest) `(,op ,x ,(binop-fold op rest))))))
199
200
201  ;; if argument is constant, return the negative of that constant,
202  ;; otherwise return `(neg ,expr)
203  (define (negate expr)
204    (if (number? expr) (- expr)
205        `(neg ,expr)))
206
207  ;; 1. make sure all constants in an expression are flonums
208  ;; 2. fold expressions like (+ a b c d) into nested binops
209  (define (normalize-expr expr)
210    (define (normalize-bnd x)
211      `(,(first x) ,(normalize-expr (second x))))
212    (match expr 
213           (('let bs e)         `(let ,(map normalize-bnd bs) ,(normalize-expr e)))
214           (('if c t e)         `(if ,(normalize-expr c) ,(normalize-expr t) ,(normalize-expr e))) 
215           (('+ . es)           (binop-fold '+ (map normalize-expr es)))
216           (('- . es)           (let ((es1 (map normalize-expr es)))
217                                  (binop-fold '+ (cons (car es1) (map negate (cdr es1))))))
218           (('* . es)           (binop-fold '* (map normalize-expr es)))
219           (('/ . es)           (binop-fold '/ (map normalize-expr es)))
220           (('fix n)            n)
221           ((s . es)            (cons s (map normalize-expr es)))
222           (x                   (if (number? x) (exact->inexact x) x))))
223
224  (define (make-base-env)
225    (let ((env (make-environment #t)))
226      (add-primitives! env)
227      (add-constants! env)
228      env))
229   
230  (define (make-const-env oru-env)
231    (let ((env (make-base-env)))
232      (environment-for-each oru-env
233        (lambda (sym en)
234          (cond  ((oru:quantity? en) 
235                  (cases oru:quantity en
236                         (CONST (name value) 
237                                (environment-extend! env name value))
238                         (PRIM (name value) 
239                               (environment-extend! env name value))))
240                 ((procedure? en)
241                  (environment-extend! env sym en)))))
242        env))
243
244  (define (system name)
245    (let ((env  (make-base-env))
246          (name (if (symbol? name) name (string->symbol name))))
247      (environment-extend! env (oru-intern 'dispatch)  (DISPATCH oru-dispatch))
248      (environment-extend! env (oru-intern 'name)      (SYSNAME name))
249      (environment-extend! env (oru-intern 'exports)   (EXPORTS (list)))
250      env))
251
252  (define (add-external! oru-env)
253    (lambda (sym typ)
254      (match typ
255             ('output
256              (begin
257                (if (not (environment-has-binding? oru-env sym))
258                    (oru:error 'add-external! ": exported quantity " sym " is not defined"))
259                (let* ((exports-sym   (oru-intern 'exports))
260                       (exports       (environment-ref oru-env exports-sym)))
261                  (cases oru:quantity exports
262                         (EXPORTS (lst) (environment-set! oru-env exports-sym (EXPORTS (cons sym lst))))
263                         (else  (oru:error 'add-external! ": invalid exports entry " exports))))))
264             
265             (('input sym lsym ns)
266              (let ((lsym (or lsym sym)))
267               
268                (if (environment-has-binding? oru-env lsym)
269                    (oru:error 'add-import! ": import symbol " lsym " is already defined"))
270               
271                ((env-extend! oru-env) lsym '(external) 'none `(name ,sym) `(namespace ,ns))))
272             
273             )))
274
275  (define (env-extend! oru-env)
276    (lambda (name type initial . alst)
277       (let ((sym (if (symbol? name) name (string->symbol name))))
278        (if (environment-has-binding? oru-env sym)
279            (oru:error 'env-extend! ": quantity " sym " already defined")
280            (match type
281              (('external)  (let ((ns  (lookup-def 'namespace alst))
282                                  (external-name  (lookup-def 'name alst)))
283                              (environment-extend! oru-env sym (EXTERNAL name external-name ns ))))
284                             
285              (('prim)    (let* ((rhs (lookup-def 'rhs alst))
286                                 (val (if (and rhs (procedure? initial) )
287                                          (extend-procedure initial rhs)
288                                          initial)))
289                            (environment-extend! oru-env sym (PRIM name val ))))
290
291              (('const)   (begin
292                            (if (not (number? initial)) 
293                                (oru:error 'env-extend! ": constant definitions require numeric value"))
294                            (environment-extend! oru-env sym (CONST name initial))))
295
296              (('tscomp)  (let ((power        (or (lookup-def 'power alst) 1))
297                                (transitions  (or (alist-ref 'transitions alst) (list)))
298                                (open         (lookup-def 'open alst)))
299                            (if (null? transitions)
300                                (oru:error 'env-extend! 
301                                               ": transition state complex definitions require a transition scheme"))
302                            (if (not open) 
303                                (oru:error 'env-extend! ": state complex definitions require open state"))
304                            (if (not (integer? power))
305                                (oru:error 'env-extend!
306                                               ": definition for state " sym
307                                               " requires an integer power (" power  " was given)"))
308                            (let ((en (TSCOMP name initial open transitions power)))
309                              (environment-extend! oru-env sym en))))
310
311              (('asgn)    (let ((rhs (lookup-def 'rhs alst)))
312                            (if (not (eq? initial 'none))
313                                (oru:error 'env-extend! 
314                                                    ": state function definitions must have initial value of '(none)"))
315                            (if (not rhs) 
316                                (oru:error 'env-extend! ": state function definitions require an equation"))
317                            (environment-extend! oru-env sym (ASGN  name 0.0 (normalize-expr rhs)))))
318
319              (else       (begin
320                            (environment-extend! oru-env sym `(,type (name ,sym) . ,initial))))
321              )))))
322
323  (define (infer oru-env ftenv body)
324    (let recur ((expr body) (lb (list)))
325      (match expr 
326             (('if c t e)
327              (let ((ct (recur c lb))
328                    (tt (recur t lb))
329                    (et (recur e lb)))
330                (and ct tt et 
331                     (begin
332                       (if (not (equal? ct 'bool)) 
333                           (oru:error 'infer "if condition type must be boolean"))
334                       (if (equal? tt et) tt
335                           (oru:error 'infer "type mismatch in if statement: then = " tt
336                                      " else = " et))))))
337             (('let bs e)
338              (let* ((rlb (lambda (x) (recur x lb)))
339                     (tbs (map rlb (map second bs)))
340                     (lb1 (append (zip (map first bs) tbs) lb)))
341                (recur e lb1)))
342             
343             ((s . es)   
344              (let* ((f    (environment-ref oru-env s))
345                     (lst  (procedure-data f)))
346                (and lst 
347                     (let ((rt   (lookup-def 'rt lst))
348                           (fms  (lookup-def 'formals lst)))
349                       (and rt fms
350                            (begin
351                              (for-each (lambda (x ft)
352                                          (if (and (symbol? x) (not (environment-includes? ftenv x)))
353                                              (environment-extend! ftenv x ft)))
354                                        es fms)
355                              (let* ((rlb (lambda (x) (recur x lb)))
356                                     (ets (map rlb es)))
357                                (and (every identity ets)
358                                     (every (lambda (xt ft) (equal? xt ft)) ets fms)
359                                     rt))))))))
360             
361             (id    (cond ((symbol? id)     (or (lookup-def id lb) (environment-ref ftenv id)))
362                          ((number? id)     fptype)
363                          ((boolean? id)    'bool)
364                          ((fpvector? id)   fpvector-type)
365                          (else #f))))))
366   
367
368  (define (defun! oru-env)
369    (lambda (name formals body)
370        (let ((const-env (make-const-env oru-env))
371              (sym (if (symbol? name) name (string->symbol name))))
372          (letrec ((enumconsts
373                    (lambda (lb)
374                      (lambda (expr ax)
375                        (match expr 
376                               (('let bs e)  (let ((ec (enumconsts (append (map first bs) lb))))
377                                               (ec e (fold ec ax (map second bs)))))
378                               (('if . es)   (fold (enumconsts lb) ax es))
379                               ((s . es)     (if (symbol? s)  (cons s (fold (enumconsts lb) ax es)) ax))
380                               (s            (if (and (symbol? s) (not (member s lb)) 
381                                                      (environment-includes? const-env s))
382                                                 (cons s ax) ax)))))))
383            (if (environment-has-binding? oru-env sym)
384                (oru:error 'defun! ": quantity " sym " already defined")
385                (let* ((body    (normalize-expr body))
386                       (consts  (delete-duplicates ((enumconsts formals) body (list))))
387                       (fc     `(lambda (const-env)
388                                  (let ,(map (lambda (v) `(,v (environment-ref const-env ',v))) consts)
389                                    (lambda ,formals ,body))))
390                       (f      ((eval fc) const-env)))
391                 
392                  (let* ((ftenv  (make-environment))
393                         (rt     (infer oru-env ftenv body))
394                         (ftypes (filter-map (lambda (x) (and (environment-includes? ftenv x)
395                                                              (environment-ref ftenv x))) 
396                                             formals))
397                         (ef     (extend-procedure f `((rt ,rt) (formals ,ftypes) (vars ,formals)
398                                                       (body ,body) (consts ,consts)))))
399                  (environment-extend! oru-env sym ef))))))))
400
401  (define (symbol-list? lst)
402    (and (list? lst) (every symbol? lst)))
403
404  (define (extended oru-env)
405      (filter-map (lambda (sym) 
406                    (let ((x (environment-ref oru-env sym)))
407                      (and (not (oru:quantity? x)) (not (procedure? x)) 
408                           (match x 
409                                  (((? symbol-list?) ('name name) . rest)  `(,sym ,x))
410                                  (else #f)))))
411           (environment-symbols oru-env)))
412                       
413
414  (define (extended-with-tag oru-env tag)
415      (filter-map (lambda (sym) 
416                    (let ((x (environment-ref oru-env sym)))
417                      (and (not (oru:quantity? x)) (not (procedure? x)) 
418                           (match x 
419                                  (((? (lambda (x) (equal? x tag))) ('name name) . rest) 
420                                   `(,sym ,x))
421                                  (else #f)))))
422           (environment-symbols oru-env)))
423                       
424
425  (define (components oru-env)
426      (filter-map (lambda (sym) 
427                    (let ((x (environment-ref oru-env sym)))
428                      (and (oru:quantity? x)
429                           (cases oru:quantity x
430                                  (COMPONENT (type lst)  `(,type ,sym))
431                                  (else #f)))))
432           (environment-symbols oru-env)))
433
434
435  (define (component-symbols oru-env sym)
436    (let ((x (environment-ref oru-env sym)))
437      (and (oru:quantity? x)
438           (cases oru:quantity x
439                  (COMPONENT (type lst)  lst)
440                  (else #f)))))
441
442
443  (define (component-exports oru-env sym)
444    (let ((all-exports (cases oru:quantity (environment-ref oru-env (oru-intern 'exports))
445                              (EXPORTS (lst)  lst))))
446      (let ((x (environment-ref oru-env sym)))
447        (and (oru:quantity? x)
448             (cases oru:quantity x
449                    (COMPONENT (type lst) 
450                      (filter-map (lambda (x) ((lambda (x) (and x (car x))) (member x all-exports))) lst))
451                    (else #f))))))
452
453  (define (component-subcomps oru-env sym)
454    (define (component-type x)
455      (cases oru:quantity x
456             (COMPONENT (type lst) type)
457             (else #f)))
458    (let ((x (environment-ref oru-env sym)))
459      (and (oru:quantity? x)
460           (cases oru:quantity x
461                  (COMPONENT (type lst) 
462                             (filter-map (lambda (s) (let ((x (environment-ref oru-env s)))
463                                                       (and (iscomp? x) `(,(component-type x) ,s)))) lst))
464                  (else #f)))))
465
466  (define (component-extend! oru-env)
467    (lambda (comp sym)
468      (let ((x (environment-ref oru-env comp)))
469        (if (oru:quantity? x)
470            (cases oru:quantity x
471                   (COMPONENT (type lst) 
472                              (let ((en1 (COMPONENT type (cons sym lst))))
473                                (environment-set! oru-env comp en1)))
474                   (else (oru:error 'component-extend! ": invalid component " comp)))
475            (oru:error 'component-extend! ": invalid component " comp)))))
476
477
478  (define (exports oru-env)
479    (cases oru:quantity (environment-ref oru-env (oru-intern 'exports))
480           (EXPORTS (lst)  lst)))
481
482
483  (define (imports oru-env)
484      (filter-map (lambda (sym) 
485                    (let ((x (environment-ref oru-env sym)))
486                      (and (oru:quantity? x)
487                           (cases oru:quantity x
488                                  (EXTERNAL (local-name name namespace)  (list local-name name namespace))
489                                  (else #f)))))
490           (environment-symbols oru-env)))
491
492
493  (define (consts oru-env)
494      (filter-map (lambda (sym) 
495                    (let ((x (environment-ref oru-env sym)))
496                      (and (oru:quantity? x)
497                           (cases oru:quantity x
498                                  (CONST (name value)  (list name value) )
499                                  (else #f)))))
500           (environment-symbols oru-env)))
501
502
503  (define (states oru-env)
504      (fold (lambda (sym ax) 
505                    (let ((x (environment-ref oru-env sym)))
506                      (if (oru:quantity? x)
507                           (cases oru:quantity x
508                                  (TSCOMP (name initial open transitions power)
509                                          (let ((ss (delete-duplicates (append (map second transitions) 
510                                                                               (map third transitions)))))
511                                            (append ss ax)))
512                                  (else ax))
513                           ax)))
514           (list) (environment-symbols oru-env)))
515
516
517  (define (stcomps oru-env)
518      (fold (lambda (sym ax) 
519                    (let ((x (environment-ref oru-env sym)))
520                      (if (oru:quantity? x)
521                           (cases oru:quantity x
522                                  (TSCOMP (name initial open transitions power)
523                                          (cons name ax))
524                                  (else ax))
525                           ax)))
526           (list) (environment-symbols oru-env)))
527
528
529  (define (asgns oru-env)
530      (filter-map (lambda (sym) 
531                    (let ((x (environment-ref oru-env sym)))
532                      (and (oru:quantity? x)
533                           (cases oru:quantity x
534                                  (ASGN (name value rhs) name)
535                                  (else #f)))))
536           (environment-symbols oru-env)))
537
538
539  (define (defuns oru-env)
540      (filter-map (lambda (sym) 
541                    (let ((x (environment-ref oru-env sym)))
542                      (and (procedure? x) (not (member sym builtin-fns)) (list sym x))))
543           (environment-symbols oru-env)))
544
545
546                                       
547  (define (exam oru-env)
548    (lambda (name)
549      (let ((sym (if (symbol? name) name (string->symbol name)))
550            (out (current-output-port)))
551        (if (not (environment-has-binding? oru-env sym))
552            (oru:error 'exam ": quantity " sym " is not defined")
553            (let ((x (environment-ref oru-env sym)))
554              (cases oru:quantity x
555                     (PRIM  (name value)
556                            (begin
557                              (fprintf out "~a: compiled coru primitive\n" name)
558                              (fprintf out "    value: ~a\n" value)))
559
560                     (TSCOMP (name initial open transitions power)
561                             (begin
562                               (fprintf out "~a: transition state complex\n" name)
563                               (fprintf out "    initial value: ~a\n" initial)))
564                     
565                     (CONST    (name value)
566                               (begin
567                                 (fprintf out "~a: constant\n" name)
568                                 (fprintf out "    value: ~a\n" value)))
569                     
570                     (ASGN     (name value rhs)
571                               (begin
572                                 (fprintf out "~a: state function\n" name)
573                                 (fprintf out "    value: ~a\n" value)))
574
575                     (else (oru:error 'exam name ": unknown type of quantity"))))))))
576 
577
578  (define (eval-const oru-env expr)
579    (let ((expr1 (normalize-expr expr)))
580      (exact->inexact (eval expr1  (make-const-env oru-env)))))
581
582
583  (define (iscomp? x)
584    (cond ((oru:quantity? x)
585           (cases oru:quantity x
586                  (COMPONENT  (type lst)  #t)
587                  (else #f)))
588          (else #f)))
589
590  (define (isdep? x)
591    (cond ((oru:quantity? x)
592           (cases oru:quantity x
593                  (ASGN  (name value rhs)  #t)
594                  (else #f)))
595          ((and (list? x) (every pair? (cdr x)))  (alist-ref 'dep?  (cdr x)))
596          (else #f)))
597
598
599  (define (isstate? x)
600    (and (oru:quantity? x)
601         (cases oru:quantity x
602                (TSCOMP (name initial open transitions)  #t)
603                (else #f))))
604
605
606  (define (qrhs x)
607    (and (oru:quantity? x)
608         (cases oru:quantity x
609                (TSCOMP (name initial open transitions) 
610                        (begin
611                          (map cadddr transitions)))
612                (ASGN  (name value rhs)  rhs)
613                (else #f))))
614
615           
616  (define (sysname oru-env)
617    (cases oru:quantity (environment-ref oru-env (oru-intern 'name))
618           (SYSNAME (name)  name)))
619
620
621  ;; create equation dependency graph
622  (define (make-eqng oru-env)
623    (let* ((sysname    (sysname oru-env))
624           (g          (make-digraph sysname (string-append (symbol->string sysname) 
625                                                            " equation dependency graph")))
626           (add-node!  (g 'add-node!))
627           (add-edge!  (g 'add-edge!))
628           (oru-list  (filter (lambda (sym) (let ((x (environment-ref oru-env sym)))
629                                               (or (isstate? x) (isdep? x))))
630                               (environment-symbols oru-env)))
631           (oru-ids      (list-tabulate (length oru-list) identity))
632           (name->id-map  (zip oru-list oru-ids)))
633      (let-values (((state-list asgn-list) 
634                    (partition (lambda (sym) (isstate? (environment-ref oru-env sym)))
635                               oru-list)))
636                 
637         ;; insert equations in the dependency graph
638         (for-each (lambda (i n) (add-node! i n)) oru-ids oru-list)
639         ;; create dependency edges in the graph
640         (for-each (lambda (e) 
641                     (match e ((ni . nj) (begin
642                                           (let ((i (car (alist-ref ni name->id-map)))
643                                                 (j (car (alist-ref nj name->id-map))))
644                                             (add-edge! (list i j (format "~A=>~A" ni nj))))))
645                            (else (oru:error 'make-eqng ": invalid edge " e))))
646                   (fold (lambda (qsym ax) 
647                           (let* ((q   (environment-ref oru-env qsym))
648                                  (rhs (qrhs q)))
649                             (if rhs 
650                                 (let* ((deps (filter (if (isstate? q)
651                                                          (lambda (sym) 
652                                                            (and (let ((x (environment-ref oru-env sym)))
653                                                                   (and (isdep? x) (not (eq? sym qsym))))))
654                                                          (lambda (sym) 
655                                                            (and (let ((x (environment-ref oru-env sym)))
656                                                                   (isdep? x)))))
657                                                      (enumdeps rhs)))
658                                          (edges (map (lambda (d) (cons d qsym)) deps)))
659                                   (if edges (append edges ax) ax))
660                                 ax)))
661                         (list) oru-list))
662         (let ((cycles (graph-cycles-fold g (lambda (cycle ax) (cons cycle ax)) (list))))
663           (if (null? cycles) (list state-list asgn-list g)
664               (oru:error 'make-eqng ": equation cycle detected: " (car cycles)))))))
665
666
667  ;; given a graph, create a partial ordering based on BFS distance from root
668  (define (graph->bfs-dist-poset g)
669    (define node-info (g 'node-info))
670
671    (let-values (((dists dmax) (graph-bfs-dist g ((g 'roots)))))
672      (let loop ((poset  (make-vector (fx+ 1 dmax) (list)))
673                 (i      (fx- (s32vector-length dists) 1)))
674        (if (fx>= i 0)
675            (let* ((c     (s32vector-ref dists i))
676                   (info  (node-info i)))
677              (vector-set! poset c (cons (cons i info) (vector-ref poset c)))
678              (loop poset (fx- i 1)))
679            (begin
680              poset)))))
681
682
683  (define (make-eval-poset oru-env eqposet)
684    (vector-map 
685       (lambda (i lst) 
686         (filter-map (lambda (id+sym)
687                       (let* ((sym  (cdr id+sym))
688                              (x    (environment-ref oru-env sym)))
689                         (and (oru:quantity? x)
690                              (cases oru:quantity x
691                                     (TSCOMP (name initial open transitions) 
692                                             (let ((rs (map cadddr transitions)))
693                                               (list 'ts sym rs)))
694                                     (ASGN  (name value rhs)
695                                            (list 'a sym rhs))
696                                     (else oru:error 'make-eval-poset
697                                           ": invalid quantity in equation poset: " sym)))))
698                     lst))
699       eqposet))
700
701  (define (eval-expr env)
702    (lambda (expr)
703      (let ((val (match expr
704                        (('if c t f) 
705                         (let ((ee (eval-expr env)))
706                           (condition-case
707                            (if (ee c) (ee t) (ee f))
708                            [var () 
709                               (oru:error 'eval-expr " exception in " expr ": \n"
710                                          (lambda () (print-error-message var)))])))
711
712                        ((s . es)   
713                         (condition-case 
714                          (let ((op   (environment-ref env s))
715                                (args (map (eval-expr env) es)))
716                            (apply op args))
717                          [var () 
718                               (oru:error 'eval-expr " exception in " expr ": \n"
719                                          (lambda () (print-error-message var)))]))
720                       
721                        (s                 
722                         (cond ((symbol? s) (environment-ref env s))
723                               ((number? s) s)
724                               (else (oru:error 'eval-expr "unknown expression " s)))))))
725        val)))
726
727
728  (define (depgraph oru-env)
729    (match-let (((state-list asgn-list g)  (make-eqng oru-env))) g))
730
731  (define (depgraph* oru-env)
732    (match-let (((state-list asgn-list g)  (make-eqng oru-env))) 
733               (list state-list asgn-list g)))
734
735
736  ;; Dispatcher
737  (define (oru-dispatch selector)
738    (case selector
739      ((add-external!)     add-external!)
740      ((defun!)            defun!)
741      ((depgraph)          depgraph)
742      ((depgraph*)         depgraph*)
743      ((depgraph->bfs-dist-poset)  graph->bfs-dist-poset)
744      ((eval-const)          eval-const)
745      ((env-extend!)         env-extend!)
746      ((exam)                exam)
747      ((make-const-env)      make-const-env)
748      ((system)              system)
749      ((sysname)             sysname)
750      ((asgns)               asgns)
751      ((states)              states)
752      ((stcomps)             stcomps)
753      ((defuns)              defuns)
754      ((consts)              consts)
755      ((exports)             exports)
756      ((imports)             imports)
757      ((components)          components)
758      ((component-symbols)   component-symbols)
759      ((component-exports)   component-exports)
760      ((component-subcomps)  component-subcomps)
761      ((component-extend!)   component-extend!)
762      ((extended)            extended)
763      ((extended-with-tag)   extended-with-tag)
764      (else
765       (oru:error 'selector ": unknown message " selector " sent to an oru-core object")))) 
766
767  oru-dispatch)
768
769(define oru:env-copy environment-copy)
770
771(define qcounter 0)
772
773(define (qname prefix)
774  (let ((v qcounter))
775    (set! qcounter (+ 1 qcounter))
776    (string->symbol (string-append (->string prefix) (number->string v)))))
777
778(define (eval-oru-system-decls oru-core name sys declarations)
779  (define (eval-const x) (and x ((oru-core 'eval-const) sys x)))
780  (let loop ((ds declarations) (qs (list)))
781    (if (null? ds) qs
782        (let ((decl (car ds)))
783          (let ((qs1  (match decl
784                            ;; imported quantities
785                            (('input . lst) 
786                             (cond ((every (lambda (x) (or (symbol? x) (list? x))) lst)
787                                    (fold (lambda (x ax) 
788                                            (match x
789                                                   ((? symbol?) 
790                                                    (((oru-core 'add-external!) sys) x `(input ,x ,x #f))
791                                                    (cons x ax))
792                                                   ((id1 'as x1) 
793                                                    (((oru-core 'add-external!) sys) x `(input ,id1 ,x1 #f))
794                                                    (cons x1 ax))
795                                                   ((id1 'from n1) 
796                                                    (((oru-core 'add-external!) sys) x `(input ,id1 ,id1 ,n1))
797                                                    (cons id1 ax))
798                                                   ((id1 'as x1 'from n1) 
799                                                    (((oru-core 'add-external!) sys) x `(input ,id1 ,x1 ,n1))
800                                                    (cons x1 ax))
801                                                   ))
802                                          qs lst))
803                                   (else (oru:error 'eval-oru-system-decls 
804                                                        "import statement must be of the form: "
805                                                        "input id1 [as x1] ... "))))
806
807                            ;; exported quantities
808                            (('output . lst) 
809                             (cond ((every symbol? lst) 
810                                    (for-each (lambda (x) (((oru-core 'add-external!) sys) x 'output)) lst)
811                                    qs)
812                                   (else (oru:error 'eval-oru-system-decls 
813                                                        "export statement must be of the form: "
814                                                        "output id1 ... "))))
815
816                            ;; constant during integration
817                            (('const id '= expr)
818                             (cond ((and (symbol? id) (or (number? expr) (list? expr)))
819                                    (let ((val (eval-const expr)))
820                                      (((oru-core 'env-extend!) sys) id '(const) val)
821                                      (cons id qs)))
822                                   (else (oru:error 'eval-oru-system-decls 
823                                                        "constant declarations must be of the form: "
824                                                        "const id = expr")))) 
825
826                            ;; state transition complex
827                            (('state-complex (id . alst) )
828                             (cond ((and (symbol? id) (list? alst))
829                                    (let ((initial (eval-const (lookup-def 'initial alst)))
830                                          (power   (eval-const (lookup-def 'power alst))))
831                                      (apply ((oru-core 'env-extend!) sys) 
832                                             (cons* id '(tscomp) initial `(power ,power) alst)))
833                                    (cons id qs))
834                                   (else (oru:error 'eval-oru-system-decls 
835                                                        "state complex declarations must be of the form: "
836                                                        "state-complex (id ...)"))))
837                           
838                            ;; algebraic assignment
839                            ((id '= expr) 
840                             (cond ((and (symbol? id) (or (symbol? expr) (number? expr) (list? expr)))
841                                    (((oru-core 'env-extend!) sys) id '(asgn) 'none `(rhs ,expr))
842                                    (cons id qs))
843                                   (else (oru:error 'eval-oru-system-decls 
844                                                        "algebraic declarations must be of the form: "
845                                                        "id = expr"))))
846                           
847                            ;; user-defined function
848                            (('defun id idlist expr) 
849                             (cond ((and (symbol? id) (list? idlist) (every symbol? idlist) (list? expr))
850                                    (((oru-core 'defun!) sys) id idlist expr)
851                                    (cons id qs))
852                                   (else (oru:error 'eval-oru-system-decls
853                                                        "function declarations must be of the form: "
854                                                        "defun id (arg1 arg2 ...) expr"))))
855                           
856                            ;; compiled coru primitives
857                            (('prim id value) 
858                             (cond ((symbol? id)  (((oru-core 'env-extend!) sys) id '(prim) value))
859                                   (else (oru:error 'eval-oru-system-decls 
860                                                        "prim declarations must be of the form: "
861                                                        "prim id value"))))
862                           
863                            (('component ('type typ) ('name name) . lst) 
864                             (let* ((cqs   (loop lst (list)))
865                                    (comp  (COMPONENT typ cqs))
866                                    (sym   (string->symbol (->string name))))
867                               (environment-set! sys sym comp)
868                               (cons sym qs)))
869
870                             
871                            (('component ('type typ)  . lst) 
872                             (let* ((cqs   (loop lst (list)))
873                                    (comp  (COMPONENT typ cqs))
874                                    (sym   (qname "comp")))
875                               (environment-set! sys sym comp)
876                               (cons sym qs)))
877                             
878                           
879                            (('sysname name)  (if (symbol? name)
880                                                  (environment-set! sys (oru-intern 'name)      (SYSNAME name))
881                                                  (oru:error 'eval-oru-system-decls
882                                                                 "system name must be a symbol")))
883                           
884                            (('const . _)
885                             (oru:error 'eval-oru-system-decls "constant declarations must be of the form: "
886                                            "const id = expr"))
887                           
888                            ((id '= . _) 
889                             (oru:error 'eval-oru-system-decls "algebraic equations must be of the form: "
890                                            "id = expr")) 
891                           
892                            (('state-complex . _)
893                             (oru:error 'eval-oru-system-decls 
894                                            "state complex declarations must be of the form: "
895                                            "state-complex (id ...)"))
896                           
897                            (('defun . _) 
898                             (oru:error 'eval-oru-system-decls "function declarations must be of the form: "
899                                            "defun id (arg1 arg2 ...) expr"))
900                           
901                            (('prim . _) 
902                             (oru:error 'eval-oru-system-decls "prim declarations must be of the form: "
903                                            "prim id value"))
904                           
905                            (('component . _) 
906                             (oru:error 'eval-oru-system-decls "invalid component: " decl))
907                           
908                            (('sysname . _) 
909                             (oru:error 'eval-oru-system-decls "system name must be of the form (sysname name)"))
910                           
911                            ;; anything that doesn't match is possibly
912                            ;; declarations recognized by the oru extension
913                            ;; modules
914                            ((tag  . lst)
915                             (if (symbol? tag)
916                                 (match-let (((typ name alst) 
917                                              (let loop ((lst lst) (ax (list tag)))
918                                                (if (null? lst)
919                                                    (list (list (car (reverse ax))) #f (cdr (reverse ax)))
920                                                    (match lst
921                                                           (((? symbol?) . rest) 
922                                                            (loop (cdr lst) (cons (car lst) ax)))
923                                                           (((x . rest)) 
924                                                            (if (and (symbol? x) (every list? rest))
925                                                                (list (reverse ax) x rest)
926                                                                (list (reverse ax) #f lst)))
927                                                           (else  (list (reverse ax) #f lst)))))))
928                                             (let ((name (or name (qname tag))))
929                                               (((oru-core 'env-extend!) sys) name  typ alst)
930                                               (cons name qs)))
931                                 (oru:error 'eval-oru-system-decls "extended declarations must be of the form: "
932                                                "declaration (name (properties ...)"))))))
933                           
934                           
935                     (loop (cdr ds) qs1)))
936        ))
937  sys)
Note: See TracBrowser for help on using the repository browser.