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

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

Bug fixes.

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