source: project/release/3/nemo/trunk/nemo-core.scm @ 12113

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

Include support for complex prefixes in the names of transition states.

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