source: project/release/4/nemo/trunk/nemo-core.scm @ 27113

Last change on this file since 27113 was 27113, checked in by Ivan Raikov, 9 years ago

nemo: bug fixes and error handling

File size: 51.6 KB
Line 
1;;
2;; NEMO substrate semantics.
3;;
4;; Copyright 2008-2012 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 reactions are valid
20;;       * check that reactions do not specify more than
21;;         one transition between any two states
22;;
23
24(module nemo-core
25
26 (make-nemo-core nemo:error nemo:warning 
27  nemo:env-copy nemo-intern nemo-scoped nemo:quantity?
28  nemo:rhs? nemo:conseq? nemo:subst-term nemo:binding? nemo:bind
29  eval-nemo-system-decls
30  CONST ASGN REACTION RATE PRIM LABEL)
31
32 (import scheme chicken data-structures ports lolevel extras
33         srfi-1 srfi-4 srfi-13 srfi-14 srfi-69)
34
35 (require-extension lolevel datatype matchable vector-lib
36                    varsubst digraph graph-bfs graph-cycles mathh)
37
38 (include "mathh-constants")
39
40
41;--------------------
42;  Message routines
43;
44;
45
46(define (nemo:warning x . rest)
47  (let loop ((port (open-output-string)) (objs (cons x rest)))
48    (if (null? objs)
49        (begin
50          (newline port)
51          (print-error-message (get-output-string port) 
52                               (current-error-port) "nemo warning"))
53        (begin (display (car objs) port)
54               (display " " port)
55               (loop port (cdr objs))))))
56
57(define (nemo:error x . rest)
58  (let ((port (open-output-string)))
59    (if (port? x)
60        (begin
61          (display "[" port)
62          (display (port-name x) port)
63          (display "] " port)))
64    (let loop ((objs (if (port? x) rest (cons x rest))))
65      (if (null? objs)
66          (begin
67            (newline port)
68            (error 'nemo (get-output-string port)))
69          (let ((obj (car objs)))
70            (if (procedure? obj) 
71                (with-output-to-port port obj)
72                (begin
73                  (display obj port)
74                  (display " " port)))
75            (loop (cdr objs)))))))
76
77(define (make-opt pred?) (lambda (x) 
78                           (or (not x) (pred? x))))
79
80(define (eval-math x . rest)
81  (if (null? rest)
82      (let ((ex `(begin (import mathh) ,x)))
83        (eval ex))
84      (let ((ex `(begin (import mathh) (list ,x . ,rest))))
85        (eval ex))
86      ))
87     
88
89(define (expr? x) 
90  (or (symbol? x) (number? x) 
91      (match x (((? symbol?) . rest)  (every expr? rest)) 
92             (((and hd (? expr?)) . rest)  (every expr? rest)) 
93             (else #f))))
94
95(define (rhs? x) 
96  (or (symbol? x) (number? x) 
97      (match x 
98             (('let bnds body) (and (rhs? body)
99                                    (every (lambda (b) 
100                                             (and (symbol? (car b)) (rhs? (cadr b)))) bnds)))
101             (((? symbol?) . rest)  (every rhs? rest)) 
102             (else #f))))
103
104(define (conseq? x)  (match x (((? number?) '= ('+ . rest))  #t) (else #f)))
105
106(define nemo:rhs?    rhs?)
107(define nemo:conseq?  conseq?)
108
109(define (transition? x)
110  (match x
111         (('-> a b r)       (and (symbol? a) (symbol? b) (rhs? r)))
112         ((a '-> b r)       (and (symbol? a) (symbol? b) (rhs? r)))
113         (('<-> a b r1 r2)  (and (symbol? a) (symbol? b) (rhs? r1) (rhs? r2)))
114         ((a '<-> b r1 r2)  (and (symbol? a) (symbol? b) (rhs? r1) (rhs? r2)))
115         (else #f)))
116
117(define-datatype nemo:quantity nemo:quantity?
118  (SYSNAME    (name symbol?))
119  (LABEL      (v symbol?))
120  (CONST      (name symbol?) (value number?))
121  (ASGN       (name symbol?) (value number?) (rhs rhs?) )
122  (REACTION   (name symbol?) 
123              (initial      (lambda (x) (or (rhs? x) (not x))))
124              (open         (lambda (x) (or (symbol? x) (and (list? x) (every symbol? x) ))))
125              (transitions  (lambda (x) (and (list? x) (every transition? x)))) 
126              (conserve     (lambda (x) (or (not x) (and (list? x) (every conseq? x)))))
127              (power        integer?))
128  (RATE       (name symbol?) 
129              (initial      (lambda (x) (or (rhs? x) (not x))))
130              (rhs          rhs?)
131              (power       (lambda (x) (or (integer? x) (not x)))))
132  (PRIM       (name symbol?) (value identity))
133  (EXTERNAL   (local-name symbol?) (name symbol?) (namespace (make-opt symbol?)))
134  (EXPORTS    (lst (lambda (x) (and (list? x) (every symbol? x)))))
135  (COMPONENT  (name symbol?) (type symbol?) (lst (lambda (x) (and (list? x) (every symbol? x)))) (scope-subst list?))
136  (FUNCTOR    (name symbol?) (args (lambda (x) (and (list? x) (every symbol? x)))) (type symbol?)  (decls list?))
137  (DISPATCH   (value procedure?))
138  )
139
140(define (nemo-intern sym)
141  (string->symbol (string-append "#" (symbol->string sym))))
142
143(define (nemo-scoped scope sym)
144  (string->symbol (string-append (->string scope) ":" (->string sym))))
145
146(define fresh gensym)
147
148(define (alist? x)
149  (every (lambda (x) (and (pair? x) (symbol? (car x)))) x))
150
151(define (lookup-def k lst . rest)
152  (let-optionals rest ((default #f))
153    (let ((k (->string k))) 
154     (let recur ((kv #f) (lst lst))
155       (if (or kv (null? lst))
156        (if (not kv) default
157            (match kv ((k v) v) (else (cdr kv))))
158        (let ((kv (car lst)))
159          (recur (and (string=? (->string (car kv)) k) kv)
160                 (cdr lst)) ))))))
161
162
163(define (nemo:subst-term t subst k)
164  (assert (every symbol? (map car subst)))
165  (match t
166         (('if c t e)
167          `(if ,(k c subst) ,(k t subst) ,(k e subst)))
168                 
169         (('let bs e)
170          (let ((r `(let ,(map (lambda (b) `(,(car b) ,(k (cadr b) subst))) bs) ,(k e subst))))
171            (k r subst)))
172                 
173         ((f . es)
174          (cons (k f subst) (map (lambda (e) (k e subst)) es)))
175         
176         ((? symbol? )  (lookup-def t subst t))
177         
178         ((? atom? ) t)))
179   
180
181(define (nemo:binding? t) 
182  (and (list? t) (eq? 'let (car t)) (cdr t)))
183
184(define (nemo:bind ks vs e) `(let ,(zip ks vs) ,e))
185
186(define nemo:env-copy hash-table-copy)
187
188
189(define (make-nemo-core . alst)
190
191  ;; floating point precision (single or double; default is double)
192  (define  fptype (lookup-def 'fpprec alst 'double))
193  (define  fpvector-type
194    (lookup-def 'fpvector-type alst (if (equal? fptype 'single) 'f32vector 'f64vector)))
195  (define  fpvector? 
196    (lookup-def 'fpvector? alst (if (equal? fptype 'single) f32vector? f64vector?)))
197  (define  fpvector 
198    (lookup-def 'fpvector alst (if (equal? fptype 'single) f32vector f64vector)))
199  (define  fpvector-ref
200    (lookup-def 'fpvector-ref alst (if (equal? fptype 'single) f32vector-ref f64vector-ref)))
201  (define  fpvector-set!
202    (lookup-def 'fpvector-set! alst (if (equal? fptype 'single) f32vector-set! f64vector-set!)))
203
204
205  (define builtin-fns
206    `(+ - * / pow neg abs atan asin acos sin cos exp ln
207        sqrt tan cosh sinh tanh hypot gamma lgamma log10 log2 log1p ldexp cube
208        > < <= >= = and or round ceiling floor max min
209        ))
210
211
212  (define (add-primitives! env)
213    (let ((prim-exprs
214           '(fp+ fp- fp* fp/ expt fpneg
215                 abs atan asin acos sin cos exp log sqrt tan 
216                 cosh sinh tanh hypot gamma lgamma log10 log2 log1p ldexp
217                 (lambda (x) (* x x x))
218                 fp> fp< fp<= fp>= fp=
219                 (lambda (x y) (and x y)) (lambda (x y) (or x y)) 
220                 round ceiling floor fpmax fpmin
221                 )))
222      (for-each (lambda (n v qb fms rt) 
223                  (let ((fb (extend-procedure 
224                             v `((name ,n) (eval-body ,qb)
225                                 (rt ,rt) (formals ,fms)))))
226                    (hash-table-set! env n fb)))
227                builtin-fns
228                (apply eval-math prim-exprs)
229                prim-exprs
230                `((,fptype ,fptype) (,fptype ,fptype) (,fptype ,fptype) (,fptype ,fptype) 
231                  (,fptype ,fptype) (,fptype)
232                  (,fptype) (,fptype) (,fptype) (,fptype) (,fptype) (,fptype) (,fptype)
233                  (,fptype) (,fptype) (,fptype)
234                  (,fptype) (,fptype) (,fptype) (,fptype) (,fptype) (,fptype) (,fptype)
235                  (,fptype) (,fptype) (,fptype)
236                  (,fptype) 
237                  (bool bool) (bool bool) (bool bool) (bool bool) (bool bool) (bool bool) (bool bool) 
238                  (,fptype) (,fptype) (,fptype) (,fptype ,fptype) (,fptype ,fptype) 
239                  (,fpvector-type integer) )
240                `(,fptype ,fptype ,fptype ,fptype 
241                          ,fptype ,fptype
242                          ,fptype ,fptype ,fptype ,fptype ,fptype ,fptype ,fptype
243                          ,fptype ,fptype ,fptype
244                          ,fptype ,fptype ,fptype ,fptype ,fptype ,fptype ,fptype
245                          ,fptype ,fptype ,fptype
246                          ,fptype 
247                          bool bool bool bool bool bool bool 
248                          ,fptype ,fptype ,fptype ,fptype ,fptype 
249                          ,fptype )
250                )))
251
252  (define (add-constants! env)
253    (for-each (lambda (n b) (hash-table-set! env n b))
254              `(E 1/E E^2 E^PI/4 LOG2E LOG10E LN2 LN3 LNPI LN10 1/LN2 1/LN10 PI PI/2
255                  PI/4 1/PI 2/PI 2/SQRTPI SQRTPI PI^2 DEGREE SQRT2 1/SQRT2 SQRT3 SQRT5
256                  SQRT10 CUBERT2 CUBERT3 4THRT2 GAMMA1/2 GAMMA1/3 GAMMA2/3 PHI LNPHI
257                  1/LNPHI EULER E^EULER SIN1 COS1 ZETA3)
258              (list E 1/E E^2 E^PI/4 LOG2E LOG10E LN2 LN3 LNPI LN10 1/LN2 1/LN10 PI PI/2
259                 PI/4 1/PI 2/PI 2/SQRTPI SQRTPI PI^2 DEGREE SQRT2 1/SQRT2 SQRT3 SQRT5
260                 SQRT10 CUBERT2 CUBERT3 4THRT2 GAMMA1/2 GAMMA1/3 GAMMA2/3 PHI LNPHI
261                 1/LNPHI EULER E^EULER SIN1 COS1 ZETA3)))
262
263
264  (define (enumdeps expr)
265    (let loop ((expr expr) (ax (list)) (lbs (list)))
266      (match expr 
267             (('let bs e)  (let let-loop ((bs bs) (ax ax) (lbs lbs))
268                             (if (null? bs) (loop e ax lbs)
269                                 (let ((x   (first  (car bs)))
270                                       (ex  (second (car bs))))
271                                   (let* ((lbs1  (cons x lbs))
272                                          (ax1   (loop ex ax lbs)))
273                                     (let-loop (cdr bs) ax1 lbs1))))))
274
275             ((s . es)     (if (symbol? s) (fold (lambda (e ax) (loop e ax lbs)) ax es) 
276                               (fold (lambda (e ax) (loop e ax lbs)) ax (cons s es))))
277             (id           (if (and (symbol? id) (not (member id lbs))) (cons id ax) ax)))))
278
279
280  (define (binop-fold op lst)
281    (if (null? lst) lst
282        (match lst
283               ((x)   x)
284               ((x y) `(,op ,x ,y))
285               ((x y . rest) `(,op (,op ,x ,y) ,(binop-fold op rest)))
286               ((x . rest) `(,op ,x ,(binop-fold op rest))))))
287
288
289  ;; if argument is constant, return the negative of that constant,
290  ;; otherwise return `(neg ,expr)
291  (define (negate expr)
292    (if (number? expr) (- expr)
293        `(neg ,expr)))
294
295  ;; 1. make sure all constants in an expression are flonums
296  ;; 2. fold expressions like (+ a b c d) into nested binops
297  (define (make-normalize-expr arity-check)
298    (lambda (expr)
299      (let recur ((expr expr))
300        (match expr 
301               (('let bs e)         (let ((normalize-bnd  (lambda (x) `(,(first x) ,(recur (second x))))))
302                                      `(let ,(map normalize-bnd bs) ,(recur e))))
303               (('if c t e)         `(if ,(recur c) ,(recur t) ,(recur e))) 
304               (('+ . es)           (binop-fold '+ (map recur es)))
305               (('- . es)           (let ((es1 (map recur es)))
306                                      (binop-fold '+ (cons (car es1) (map negate (cdr es1))))))
307               (('* . es)           (binop-fold '* (map recur es)))
308               (('/ . es)           (binop-fold '/ (map recur es)))
309               (('fix n)            n)
310               ((s . es)            (begin
311                                      (arity-check s es)
312                                      (cons s (map recur es))))
313               (x                   (if (number? x) (exact->inexact x) x))))))
314
315  (define (make-base-env)
316    (let ((env (make-hash-table hash: symbol-hash)))
317      (add-primitives! env)
318      (add-constants! env)
319      env))
320   
321  (define (make-const-env nemo-env)
322    (let ((env (make-base-env)))
323      (hash-table-for-each nemo-env
324        (lambda (sym en)
325          (cond  ((nemo:quantity? en) 
326                  (cases nemo:quantity en
327                         (CONST (name value) 
328                                (hash-table-set! env name value))
329                         (PRIM (name value) 
330                               (hash-table-set! env name value))))
331                 ((procedure? en)
332                  (hash-table-set! env sym en)))))
333        env))
334
335
336  (define (const-env-entry->value en)
337    (cond  ((nemo:quantity? en) 
338            (cases nemo:quantity en
339                   (CONST (name value)  value)
340                   (PRIM (name value)  value)
341                   ))
342           ((procedure? en) (lookup-def 'eval-body (procedure-data en)))
343           ((or (number? en) (symbol? en))   en)
344           (else #f)))
345
346  (define (system name)
347    (let ((env  (make-base-env))
348          (name (if (symbol? name) name (string->symbol name))))
349      (hash-table-set! env (nemo-intern 'dispatch)  (DISPATCH nemo-dispatch))
350      (hash-table-set! env (nemo-intern 'name)      (SYSNAME name))
351      (hash-table-set! env (nemo-intern 'exports)   (EXPORTS (list)))
352      (hash-table-set! env (nemo-intern 'toplevel)  (COMPONENT 'toplevel 'toplevel (list) (list)))
353      env))
354
355  (define (add-external! nemo-env)
356    (lambda (sym typ)
357      (match typ
358             ('output
359              (begin
360                (if (not (hash-table-exists? nemo-env sym))
361                    (nemo:error 'add-external! ": exported quantity " sym " is not defined"))
362                (let* ((exports-sym   (nemo-intern 'exports))
363                       (exports       (hash-table-ref nemo-env exports-sym)))
364                  (cases nemo:quantity exports
365                         (EXPORTS (lst) (hash-table-set! nemo-env exports-sym (EXPORTS (cons sym lst))))
366                         (else  (nemo:error 'add-external! ": invalid exports entry " exports))))))
367             
368             (('input sym lsym ns)
369              (let ((lsym (or lsym sym)))
370               
371                (if (hash-table-exists? nemo-env lsym)
372                    (nemo:error 'add-import! ": import symbol " lsym " is already defined"))
373               
374                ((env-extend! nemo-env) lsym '(external) 'none `(name ,sym) `(namespace ,ns))))
375             
376             )))
377
378
379  (define (make-arity-check nemo-env)
380    (lambda (s args)
381      (if (hash-table-exists? nemo-env s)
382          (let ((op (hash-table-ref nemo-env s)))
383            (if (extended-procedure? op)
384                (let* ((fd   (procedure-data op))
385                       (fms   (lookup-def 'formals fd)))
386                 
387                  (if (not (= (length fms) (length args)))
388                      (nemo:error 'eval-expr "procedure " s 
389                                  " called with incorrect number of arguments: "
390                                  args)))))
391          (nemo:error 'eval-expr "symbol " s " is not defined")
392          )))
393
394  (define (env-extend! nemo-env)
395    (lambda (name type initial . alst)
396
397       (let* ((sym (if (symbol? name) name (string->symbol name)))
398              (arity-check (make-arity-check nemo-env))
399              (normalize-expr (make-normalize-expr arity-check)))
400
401        (if (hash-table-exists? nemo-env sym)
402            (nemo:error 'env-extend! ": quantity " sym " already defined")
403            (match type
404              (('label)   (begin
405                            (if (not (symbol? initial)) 
406                                (nemo:error 'env-extend! ": label definitions require symbolic value"))
407                            (hash-table-set! nemo-env sym (LABEL initial))))
408
409              (('external)  (begin
410                              (let* ((ns             (lookup-def 'namespace alst))
411                                     (external-name  (lookup-def 'name alst))
412                                     (x              (EXTERNAL name external-name ns )))
413                                (hash-table-set! nemo-env sym x)
414                                )))
415                             
416              (('prim)    (let* ((rhs (lookup-def 'rhs alst))
417                                 (val (if (and rhs (procedure? initial) )
418                                          (extend-procedure initial rhs)
419                                          initial)))
420                            (hash-table-set! nemo-env sym (PRIM name val ))))
421
422              (('const)   (begin
423                            (if (not (number? initial)) 
424                                (nemo:error 'env-extend! ": constant definitions require numeric value" name initial))
425                            (hash-table-set! nemo-env sym (CONST name initial))
426                            ))
427
428              (('asgn)    (let ((rhs (lookup-def 'rhs alst)))
429
430                            (if (not (eq? initial 'none))
431                                (nemo:error 'env-extend! 
432                                                    ": state function definitions must have initial value of '(none)"))
433                            (if (not rhs) 
434                                (nemo:error 'env-extend! ": state function definitions require an equation"))
435                            (let ((expr1 (normalize-expr rhs)))
436                              (hash-table-set! nemo-env sym (ASGN name 0.0 expr1)))
437                            ))
438
439              (('rate)    (let ((rhs (lookup-def 'rhs alst))
440                                (power (lookup-def 'power alst)))
441                            (if (not (rhs? rhs))
442                                (nemo:error 'env-extend! ": rate law definitions require an equation"))
443
444                            (hash-table-set! nemo-env sym (RATE name (and initial (normalize-expr initial))
445                                                                (normalize-expr rhs) power))))
446
447              (('reaction)  (begin
448                            (let ((power         (or (lookup-def 'power alst) 1))
449                                  (transitions   
450                                   (map (lambda (t) 
451                                          (match t
452                                                 (( '<-> (and src (? symbol?)) (and dst (? symbol?)) r1 r2) 
453                                                  `( <-> ,src ,dst ,(normalize-expr r1) ,(normalize-expr r2)))
454
455                                                 (( '-> (and src (? symbol?)) (and dst (? symbol?)) r1) 
456                                                  `( -> ,src ,dst ,(normalize-expr r1) ))
457
458                                                 (else
459                                                  (nemo:error 'env-extend! ": invalid transition " t))))
460                                        (or (alist-ref 'transitions alst) (list))))
461                                  (conserve      (lookup-def 'conserve alst))
462                                  (open          (lookup-def 'open alst)))
463                              (if (null? transitions)
464                                  (nemo:error 'env-extend! 
465                                              ": transition state complex definitions require a transition scheme"))
466                              (if (not open) 
467                                  (nemo:error 'env-extend! ": state complex definitions require open state"))
468                              (if (not (integer? power))
469                                  (nemo:error 'env-extend!
470                                              ": definition for state " sym
471                                              " requires an integer power (" power  " was given)"))
472                             
473                              (let ((en (REACTION name (and initial (normalize-expr initial))
474                                                  open transitions 
475                                                  (and conserve (list conserve)) power)))
476                                (hash-table-set! nemo-env sym en)))))
477
478
479              (else       (begin
480                            (hash-table-set! nemo-env sym `(,type (name ,sym) . ,initial))))
481              )))))
482
483  (define (infer nemo-env ftenv body)
484    (let recur ((expr body) (lb (list)))
485      (match expr 
486             (('if c t e)
487              (let ((ct (recur c lb))
488                    (tt (recur t lb))
489                    (et (recur e lb)))
490                (and ct tt et 
491                     (begin
492                       (if (not (equal? ct 'bool)) 
493                           (nemo:error 'infer "if condition type must be boolean"))
494                       (if (equal? tt et) tt
495                           (nemo:error 'infer "type mismatch in if statement: then = " tt
496                                      " else = " et))))))
497             (('let bs e)
498              (let* ((rlb (lambda (x) (recur x lb)))
499                     (tbs (map rlb (map second bs)))
500                     (lb1 (append (zip (map first bs) tbs) lb)))
501                (recur e lb1)))
502             
503             ((s . es)   
504              (let* ((f    (hash-table-ref nemo-env s))
505                     (lst  (procedure-data f)))
506                (and lst 
507                     (let ((rt   (lookup-def 'rt   lst))
508                           (fms  (lookup-def 'formals lst)))
509                       (and rt fms
510                            (begin
511                              (for-each (lambda (x ft)
512                                          (if (and (symbol? x) (not (hash-table-exists? ftenv x)))
513                                              (hash-table-set! ftenv x ft)))
514                                        es fms)
515                              (let* ((rlb (lambda (x) (recur x lb)))
516                                     (ets (map rlb es)))
517                                (and (every identity ets)
518                                     (every (lambda (xt ft) (equal? xt ft)) ets fms)
519                                     rt))))))))
520             
521             (id    (cond ((symbol? id)     (or (lookup-def id lb) (hash-table-ref ftenv id)))
522                          ((number? id)     fptype)
523                          ((boolean? id)    'bool)
524                          ((fpvector? id)   fpvector-type)
525                          (else #f))))))
526   
527
528  (define (defun! nemo-env)
529    (define arity-check (make-arity-check nemo-env))
530    (define normalize-expr (make-normalize-expr arity-check))
531
532    (lambda (name formals body)
533        (let ((const-env (make-const-env nemo-env))
534              (sym (if (symbol? name) name (string->symbol name))))
535          (letrec ((enumconsts
536                    (lambda (lb)
537                      (lambda (expr ax)
538                        (match expr 
539                               (('let bs e)  (let ((ec (enumconsts (append (map first bs) lb))))
540                                               (ec e (fold ec ax (map second bs)))))
541                               (('if . es)   (fold (enumconsts lb) ax es))
542                               ((s . es)     (cond ((and (symbol? s) (hash-table-exists? const-env s))
543                                                    (let ((v (const-env-entry->value (hash-table-ref const-env s))))
544                                                      (cons (cons s v) (fold (enumconsts lb) ax es)))
545                                                    ax)
546                                                   ((and (symbol? s) (not (member s lb)))
547                                                    (nemo:error 'defun ": quantity " s " not defined"))
548                                                   (else ax)
549                                                   ))
550                               (s            (cond
551                                               ((and (symbol? s) (not (member s lb)) 
552                                                     (hash-table-exists? const-env s))
553                                                (let ((v (const-env-entry->value (hash-table-ref const-env s))))
554                                                  (cons (cons s v) ax) ))
555                                               ((and (symbol? s) (not (member s lb)))
556                                                (nemo:error 'defun ": quantity " s " not defined"))
557                                               (else ax)))
558                               ))
559                      ))
560                   
561                   )
562            (if (hash-table-exists? nemo-env sym)
563                (nemo:error 'defun! ": quantity " sym " already defined")
564                (let* (
565                       (body    (normalize-expr body))
566                       (consts  (delete-duplicates ((enumconsts formals) body (list)) 
567                                                   (lambda (x y) (equal? (car x) (car y)))))
568                       (eval-body `(let ,(map (lambda (sv)
569                                                `(,(car sv) ,(cdr sv))) consts)
570                                     (lambda ,formals ,body)))
571                       (f      (eval eval-body))
572                       )
573                  (let* ((ftenv  (make-hash-table))
574                         (rt     (infer nemo-env ftenv body))
575                         (ftypes (filter-map (lambda (x) 
576                                               (or (and (hash-table-exists? ftenv x)
577                                                        (hash-table-ref ftenv x)) 'double))
578                                             formals))
579                         (ef     (extend-procedure f 
580                                   `((name ,sym) (body ,body) (eval-body ,eval-body) 
581                                     (rt ,rt) (formals ,ftypes) (vars ,formals)
582                                     (consts ,(filter (lambda (x) (not (member x builtin-fns))) consts)))))
583                         )
584                  (hash-table-set! nemo-env sym ef))))))))
585
586  (define (symbol-list? lst)
587    (and (list? lst) (every symbol? lst)))
588
589  (define (extended nemo-env)
590      (filter-map (lambda (sym) 
591                    (let ((x (hash-table-ref nemo-env sym)))
592                      (and (not (nemo:quantity? x)) (not (procedure? x)) 
593                           (match x 
594                                  (((? symbol-list?) ('name name) . rest)  `(,sym ,x))
595                                  (else #f)))))
596           (hash-table-keys nemo-env)))
597                       
598
599  (define (extended-with-tag nemo-env tag)
600      (filter-map (lambda (sym) 
601                    (let ((x (hash-table-ref nemo-env sym)))
602                      (and (not (nemo:quantity? x)) (not (procedure? x)) 
603                           (match x 
604                                  (((? (lambda (x) (equal? x tag))) ('name name) . rest) 
605                                   `(,sym ,x))
606                                  (else #f)))))
607           (hash-table-keys nemo-env)))
608                       
609
610  (define (components nemo-env)
611      (filter-map (lambda (sym) 
612                    (let ((x (hash-table-ref nemo-env sym)))
613                      (and (nemo:quantity? x)
614                           (cases nemo:quantity x
615                                  (COMPONENT (name type lst _)  `(,name ,type ,sym))
616                                  (else #f)))))
617           (hash-table-keys nemo-env)))
618
619
620  (define (component-name nemo-env sym)
621    (let ((x (hash-table-ref nemo-env sym)))
622      (and (nemo:quantity? x)
623           (cases nemo:quantity x
624                  (COMPONENT (name type lst _)  name)
625                  (else #f)))))
626
627
628  (define (component-symbols nemo-env sym)
629    (let ((x (hash-table-ref nemo-env sym)))
630      (and (nemo:quantity? x)
631           (cases nemo:quantity x
632                  (COMPONENT (name type lst _)  lst)
633                  (else #f)))))
634
635
636  (define (component-scope-subst nemo-env sym)
637    (let ((x (hash-table-ref nemo-env sym)))
638      (and (nemo:quantity? x)
639           (cases nemo:quantity x
640                  (COMPONENT (name type lst scope-subst)  scope-subst)
641                  (else #f)))))
642
643
644  (define (component-exports nemo-env sym)
645    (let ((all-exports (cases nemo:quantity (hash-table-ref nemo-env (nemo-intern 'exports))
646                              (EXPORTS (lst)  lst))))
647      (let ((x  (hash-table-ref nemo-env sym)))
648        (and (nemo:quantity? x)
649             (cases nemo:quantity x
650                    (COMPONENT (name type lst _) 
651                      (filter-map (lambda (x) ((lambda (x) (and x (car x))) (member x all-exports))) lst))
652                    (else #f))))))
653
654  (define (component-subcomps nemo-env sym)
655
656    (define (component-type x)
657      (cases nemo:quantity x
658             (COMPONENT (name type lst _) type)
659             (else #f)))
660    (define (component-name x)
661      (cases nemo:quantity x
662             (COMPONENT (name type lst _) name)
663             (else #f)))
664    (let ((en (hash-table-ref nemo-env sym)))
665      (and (nemo:quantity? en)
666           (cases nemo:quantity en
667                  (COMPONENT (name type lst _) 
668                             (filter-map 
669                              (lambda (s) 
670                                (let ((x (hash-table-ref nemo-env s)))
671                                  (and (iscomp? x) `(,(component-type x) ,(component-name x) ,s)))) lst))
672                  (else #f)))))
673
674  (define (component-extend! nemo-env)
675    (lambda (comp-name sym)
676      (let ((x (hash-table-ref nemo-env comp-name)))
677        (if (nemo:quantity? x)
678            (cases nemo:quantity x
679                   (COMPONENT (name type lst scope-subst) 
680                              (let ((en1 (COMPONENT name type (delete-duplicates (append lst (list sym))) scope-subst)))
681                                (hash-table-set! nemo-env comp-name en1)))
682                   (else (nemo:error 'component-extend! ": invalid component " comp-name)))
683            (nemo:error 'component-extend! ": invalid component " comp-name)))))
684
685  (define (component-enumdeps nemo-env sym)
686    (let ((x (hash-table-ref nemo-env sym)))
687      (and (nemo:quantity? x)
688           (cases nemo:quantity x
689                  (COMPONENT 
690                   (name type lst scope-subst) 
691                   (delete-duplicates
692                    (append
693                     (fold (lambda (qsym ax)
694                             (let* ((q   (hash-table-ref nemo-env qsym))
695                                    (rhs (qrhs q)))
696                               (or (and rhs (append (enumdeps rhs) ax)) ax)))
697                           '()
698                           lst)
699                     (map (lambda (x) (component-enumdeps  nemo-env x))
700                          (component-subcomps nemo-env sym)))))
701                  (else #f)))))
702
703  (define (component-env nemo-env sym . syms)
704    (fold 
705     (lambda (sym env)
706       (let ((comp (hash-table-ref nemo-env sym)))
707         (and (nemo:quantity? comp)
708              (cases nemo:quantity comp
709                     (COMPONENT 
710                      (name type lst scope-subst) 
711                      (let* ((depnames (component-enumdeps nemo-env sym))
712                             (subnames (map third (component-subcomps nemo-env sym)))
713                             (cnames   lst))
714
715                        (let* ((syms (delete-duplicates (append depnames subnames cnames)))
716                               (vals (map (lambda (x) (hash-table-ref nemo-env x)) syms)))
717                          (for-each (lambda (s v) (hash-table-set! env s v)) 
718                                    syms vals)
719                          env
720                          )))
721                     (else env)))))
722     (make-base-env)
723     (cons sym syms)))
724
725
726  (define (exports nemo-env)
727    (cases nemo:quantity (hash-table-ref nemo-env (nemo-intern 'exports))
728           (EXPORTS (lst)  lst)))
729
730
731  (define (imports nemo-env)
732      (filter-map (lambda (sym) 
733                    (let ((x (hash-table-ref nemo-env sym)))
734                      (and (nemo:quantity? x)
735                           (cases nemo:quantity x
736                                  (EXTERNAL (local-name name namespace)  (list local-name name namespace))
737                                  (else #f)))))
738           (hash-table-keys nemo-env)))
739
740
741  (define (consts nemo-env)
742      (filter-map (lambda (sym) 
743                    (let ((x (hash-table-ref nemo-env sym)))
744                      (and (nemo:quantity? x)
745                           (cases nemo:quantity x
746                                  (CONST (name value)  (list name value) )
747                                  (else #f)))))
748           (hash-table-keys nemo-env)))
749
750
751
752  (define (states nemo-env)
753      (fold (lambda (sym ax) 
754                    (let ((x (hash-table-ref nemo-env sym)))
755                      (if (nemo:quantity? x)
756                           (cases nemo:quantity x
757                                  (REACTION (name initial open transitions conserve power)
758                                          (let* ((ss1 (delete-duplicates (append (map second transitions) 
759                                                                                 (map third transitions))))
760                                                 (ss2 (map (lambda (x) (list name x))  ss1)))
761                                            (append ss2 ax)))
762                                  (RATE (name initial rhs _) (cons (list #f name) ax))
763                                  (else ax))
764                           ax)))
765           (list) (hash-table-keys nemo-env)))
766
767
768  (define (reactions nemo-env)
769      (fold (lambda (sym ax) 
770                    (let ((x (hash-table-ref nemo-env sym)))
771                      (if (nemo:quantity? x)
772                           (cases nemo:quantity x
773                                  (REACTION (name initial open transitions conserve power)
774                                          (cons name ax))
775                                  (else ax))
776                           ax)))
777           (list) (hash-table-keys nemo-env)))
778
779
780  (define (rates nemo-env)
781      (filter-map (lambda (sym) 
782                    (let ((x (hash-table-ref nemo-env sym)))
783                      (and (nemo:quantity? x)
784                           (cases nemo:quantity x
785                                  (RATE (name value rhs _) name)
786                                  (else #f)))))
787           (hash-table-keys nemo-env)))
788
789  (define (asgns nemo-env)
790      (filter-map (lambda (sym) 
791                    (let ((x (hash-table-ref nemo-env sym)))
792                      (and (nemo:quantity? x)
793                           (cases nemo:quantity x
794                                  (ASGN (name value rhs) name)
795                                  (else #f)))))
796           (hash-table-keys nemo-env)))
797
798
799  (define (defuns nemo-env)
800      (filter-map (lambda (sym) 
801                    (let ((x (hash-table-ref nemo-env sym)))
802                      (and (procedure? x) (not (member sym builtin-fns)) (list sym x))))
803           (hash-table-keys nemo-env)))
804
805
806  (define (toplevel nemo-env)
807    (cases nemo:quantity (hash-table-ref nemo-env (nemo-intern 'toplevel))
808           (COMPONENT (name type lst _) `(,type ,lst))))
809
810                                       
811  (define (exam nemo-env)
812    (lambda (name)
813      (let ((sym (if (symbol? name) name (string->symbol name)))
814            (out (current-output-port)))
815        (if (not (hash-table-exists? nemo-env sym))
816            (nemo:error 'exam ": quantity " sym " is not defined")
817            (let ((x (hash-table-ref nemo-env sym)))
818              (cases nemo:quantity x
819                     (LABEL  (v)
820                            (begin
821                              (fprintf out "~a: label\n" name)
822                              (fprintf out "    value: ~a\n" v)))
823
824                     (PRIM  (name value)
825                            (begin
826                              (fprintf out "~a: compiled nemo primitive\n" name)
827                              (fprintf out "    value: ~a\n" value)))
828
829                     (CONST    (name value)
830                               (begin
831                                 (fprintf out "~a: constant\n" name)
832                                 (fprintf out "    value: ~a\n" value)))
833                     
834                     (ASGN     (name value rhs)
835                               (begin
836                                 (fprintf out "~a: state function\n" name)
837                                 (fprintf out "    value: ~a\n" value)))
838
839                     (REACTION (name initial open transitions conserve power)
840                             (begin
841                               (fprintf out "~a: transition state complex\n" name)
842                               (fprintf out "    initial value: ~a\n" initial)))
843                     
844                     (RATE     (name initial rhs power)
845                               (begin
846                                 (fprintf out "~a: rate law\n" name)
847                                 (fprintf out "    rhs: ~a\n" rhs)
848                                 (if power (fprintf out "    power: ~a\n" power))
849                                 ))
850
851                     (else (nemo:error 'exam name ": unknown type of quantity"))))))))
852 
853  (define (eval-simple-expr env expr)
854    (cond ((number? expr) expr)
855          ((symbol? expr) (hash-table-ref env expr))
856          ((pair? expr)   (let ((expr1 (map (lambda (x) (eval-simple-expr env x)) expr)))
857                            (apply (car expr1) (cdr expr1))))))
858
859  (define (eval-const nemo-env expr)
860    (let* ((arity-check (make-arity-check nemo-env))
861           (normalize-expr (make-normalize-expr arity-check)))
862      (let ((expr1 (normalize-expr expr))
863            (const-env (make-const-env nemo-env)))
864        (condition-case
865         (exact->inexact (eval-simple-expr const-env expr1))
866         [var () expr1])
867        )))
868
869
870  (define (iscomp? x)
871    (cond ((nemo:quantity? x)
872           (cases nemo:quantity x
873                  (COMPONENT  (name type lst _)  #t)
874                  (else #f)))
875          (else #f)))
876
877  (define (isdep? x)
878    (cond ((nemo:quantity? x)
879           (cases nemo:quantity x
880                  (ASGN  (name value rhs)  #t)
881                  (else #f)))
882          ((and (list? x) (every pair? (cdr x)))  (alist-ref 'dep?  (cdr x)))
883          (else #f)))
884
885
886  (define (isstate? x)
887    (and (nemo:quantity? x)
888         (cases nemo:quantity x
889                (REACTION (name initial open transitions)  #t)
890                (RATE     (name initial rhs _) #t)
891                (else #f))))
892
893
894  (define (qrhs x)
895    (and (nemo:quantity? x)
896         (cases nemo:quantity x
897                (REACTION (name initial open transitions) 
898                        (begin
899                          (map cadddr transitions)))
900                (RATE  (name initial rhs _)  rhs)
901                (ASGN  (name value rhs)  rhs)
902                (else #f))))
903
904           
905  (define (sysname nemo-env)
906    (cases nemo:quantity (hash-table-ref nemo-env (nemo-intern 'name))
907           (SYSNAME (name)  name)))
908
909
910  ;; create equation dependency graph
911  (define (make-eqng nemo-env)
912    (let* ((sysname    (sysname nemo-env))
913           (g          (make-digraph sysname (string-append (symbol->string sysname) 
914                                                            " equation dependency graph")))
915           (add-node!  (g 'add-node!))
916           (add-edge!  (g 'add-edge!))
917           (nemo-list  (filter (lambda (sym) (let ((x (hash-table-ref nemo-env sym)))
918                                               (or (isstate? x) (isdep? x))))
919                               (hash-table-keys nemo-env)))
920           (nemo-ids      (list-tabulate (length nemo-list) identity))
921           (name->id-map  (zip nemo-list nemo-ids)))
922      (let-values (((state-list asgn-list) 
923                    (partition (lambda (sym) (isstate? (hash-table-ref nemo-env sym)))
924                               nemo-list)))
925                 
926         ;; insert equations in the dependency graph
927         (for-each (lambda (i n) (add-node! i n)) nemo-ids nemo-list)
928         ;; create dependency edges in the graph
929         (for-each (lambda (e) 
930                     (match e ((ni . nj) (begin
931                                           (let ((i (car (alist-ref ni name->id-map)))
932                                                 (j (car (alist-ref nj name->id-map))))
933                                             (add-edge! (list i j (format "~A=>~A" ni nj))))))
934                            (else (nemo:error 'make-eqng ": invalid edge " e))))
935                   (fold (lambda (qsym ax) 
936                           (let* ((q   (hash-table-ref nemo-env qsym))
937                                  (rhs (qrhs q)))
938                             (if rhs 
939                                 (let* ((deps (filter (if (isstate? q)
940                                                          (lambda (sym) 
941                                                            (if (not (hash-table-exists? nemo-env sym))
942                                                                (nemo:error 'make-eqng ": undefined symbol " sym 
943                                                                            " in definition of quantity " qsym))
944                                                            (and (let ((x (hash-table-ref nemo-env sym)))
945                                                                   (and (isdep? x) (not (eq? sym qsym))))))
946                                                          (lambda (sym) 
947                                                            (if (not (hash-table-exists? nemo-env sym))
948                                                                (nemo:error 'make-eqng ": undefined symbol " sym 
949                                                                            " in definition of quantity " qsym))
950                                                            (and (let ((x (hash-table-ref nemo-env sym)))
951                                                                   (isdep? x)))))
952                                                      (enumdeps rhs)))
953                                          (edges (map (lambda (d) (cons d qsym)) deps)))
954                                   (if edges (append edges ax) ax))
955                                 ax)))
956                         (list) nemo-list))
957         (let ((cycles (graph-cycles-fold g (lambda (cycle ax) (cons cycle ax)) (list))))
958           (if (null? cycles) (list state-list asgn-list g)
959               (nemo:error 'make-eqng ": equation cycle detected: " (car cycles)))))))
960
961
962  ;; given a graph, create a partial ordering based on BFS distance from root
963  (define (graph->bfs-dist-poset g)
964    (define node-info (g 'node-info))
965
966    (let-values (((dists dmax) (graph-bfs-dist g ((g 'roots)))))
967      (let loop ((poset  (make-vector (fx+ 1 dmax) (list)))
968                 (i      (fx- (s32vector-length dists) 1)))
969        (if (fx>= i 0)
970            (let* ((c     (s32vector-ref dists i))
971                   (info  (node-info i)))
972              (vector-set! poset c (cons (cons i info) (vector-ref poset c)))
973              (loop poset (fx- i 1)))
974            (begin
975              poset)))))
976
977
978  (define (make-eval-poset nemo-env eqposet)
979    (vector-map 
980       (lambda (i lst) 
981         (filter-map (lambda (id+sym)
982                       (let* ((sym  (cdr id+sym))
983                              (x    (hash-table-ref nemo-env sym)))
984                         (and (nemo:quantity? x)
985                              (cases nemo:quantity x
986                                     (REACTION (name initial open transitions) 
987                                             (let ((rs (map cadddr transitions)))
988                                               (list 're sym rs)))
989                                     (RATE  (name initial rhs _)
990                                            (list 'r sym rhs))
991                                     (ASGN  (name value rhs)
992                                            (list 'a sym rhs))
993                                     (else nemo:error 'make-eval-poset
994                                           ": invalid quantity in equation poset: " sym)))))
995                     lst))
996       eqposet))
997
998  (define (eval-expr env)
999    (lambda (expr)
1000      (let ((val (match expr
1001                        (('if c t f) 
1002                         (let ((ee (eval-expr env)))
1003                           (condition-case
1004                            (if (ee c) (ee t) (ee f))
1005                            [var () 
1006                               (nemo:error 'eval-expr " exception in " expr ": \n"
1007                                          (lambda () (print-error-message var)))])))
1008
1009                        ((s . es)   
1010                         (condition-case 
1011                          (let ((op   (hash-table-ref env s))
1012                                (args (map (eval-expr env) es)))
1013                            (if (extended-procedure? op)
1014                                (let* ((fd   (procedure-data op))
1015                                       (vs  (lookup-def 'vars fd)))
1016
1017                                  (if (not (= (length vs) (length args)))
1018                                      (nemo:error 'eval-expr "procedure " s 
1019                                                  " called with incorrect number of arguments"))))
1020                            (apply op args))
1021                          [var () 
1022                               (nemo:error 'eval-expr " exception in " expr ": \n"
1023                                          (lambda () (print-error-message var)))]))
1024                       
1025                        (s                 
1026                         (cond ((symbol? s) (hash-table-ref env s))
1027                               ((number? s) s)
1028                               (else (nemo:error 'eval-expr "unknown expression " s)))))))
1029        val)))
1030
1031
1032  (define (depgraph nemo-env)
1033    (match-let (((state-list asgn-list g)  (make-eqng nemo-env))) g))
1034
1035  (define (depgraph* nemo-env)
1036    (match-let (((state-list asgn-list g)  (make-eqng nemo-env))) 
1037               (list state-list asgn-list g)))
1038
1039
1040  ;; Dispatcher
1041  (define (nemo-dispatch selector)
1042    (case selector
1043      ((add-external!)     add-external!)
1044      ((defun!)            defun!)
1045      ((depgraph)          depgraph)
1046      ((depgraph*)         depgraph*)
1047      ((depgraph->bfs-dist-poset)  graph->bfs-dist-poset)
1048      ((eval-const)          eval-const)
1049      ((env-extend!)         env-extend!)
1050      ((subst-expr)        (subst-driver (lambda (x) (and (symbol? x) x)) 
1051                                         nemo:binding? 
1052                                         identity 
1053                                         nemo:bind 
1054                                         nemo:subst-term))
1055      ((exam)                exam)
1056      ((make-const-env)      make-const-env)
1057      ((system)              system)
1058      ((sysname)             sysname)
1059      ((asgns)               asgns)
1060      ((states)              states)
1061      ((reactions)           reactions)
1062      ((rates)               rates)
1063      ((defuns)              defuns)
1064      ((consts)              consts)
1065      ((exports)             exports)
1066      ((imports)             imports)
1067      ((toplevel)            toplevel)
1068      ((components)          components)
1069      ((component-env)       component-env)
1070      ((component-name)      component-name)
1071      ((component-symbols)   component-symbols)
1072      ((component-exports)   component-exports)
1073      ((component-subcomps)  component-subcomps)
1074      ((component-scope-subst)  component-scope-subst)
1075      ((component-extend!)   component-extend!)
1076      ((extended)            extended)
1077      ((extended-with-tag)   extended-with-tag)
1078      (else
1079       (nemo:error 'selector ": unknown message " selector " sent to an nemo-core object"))))
1080
1081  nemo-dispatch)
1082
1083(define (eval-nemo-system-decls nemo-core name sys declarations . rest)
1084  (let-optionals rest ((parse-expr (lambda (x . rest) x)))
1085   (define (eval-const x) (and x ((nemo-core 'eval-const) sys x)))
1086   (define env-extend!  ((nemo-core 'env-extend!) sys))
1087   (define (compute-qid id scope scope-subst) (or (and scope scope-subst (nemo-scoped scope id)) id))
1088   (define (update-subst id qid subst) (if (equal? id qid) subst
1089                                           (subst-extend id qid subst) ))
1090   (define subst-expr  (subst-driver (lambda (x) (and (symbol? x) x)) 
1091                                     nemo:binding? 
1092                                     identity 
1093                                     nemo:bind 
1094                                     nemo:subst-term))
1095   (let ((res
1096          (let loop ((ds declarations) (qs (list)) (scope #f) (scope-subst '()))
1097
1098            (if (null? ds) 
1099                (let ((qs (reverse qs)))
1100                  (if (not scope)
1101                      (let* ((top-syms   ((nemo-core 'component-symbols ) sys (nemo-intern 'toplevel)))
1102                             (top-syms1  (append qs top-syms)))
1103                        (hash-table-set! sys (nemo-intern 'toplevel) (COMPONENT 'toplevel 'toplevel top-syms1 '()))))
1104                  (list qs scope-subst))
1105                (let ((decl (car ds)))
1106                  (if (null? decl)
1107                      (loop (cdr ds) qs scope scope-subst)
1108                  (match-let 
1109                   (((qs1 scope-subst1)
1110                     (match decl
1111
1112                            ;; labels
1113                            (((or 'label 'LABEL) (and id (? symbol?)) '= (and v (? symbol?)))
1114                             (let* ((qid  (compute-qid id scope scope-subst)))
1115                               (env-extend! qid '(label) v)
1116                               (list (cons qid qs) (update-subst id qid scope-subst))))
1117                           
1118                            ;; imported quantities
1119                            (((or 'input 'INPUT) . lst) 
1120                             (cond ((every (lambda (x) (or (symbol? x) (list? x))) lst)
1121                                    (fold
1122                                     (lambda (x ax) 
1123                                       (match-let (((qs scope-subst) ax))
1124                                                  (match x
1125                                                         ((? symbol?) 
1126                                                          (let ((qid (compute-qid x scope scope-subst)))
1127                                                            (((nemo-core 'add-external!) sys) x `(input ,x ,qid #f))
1128                                                            (list (cons qid qs) (update-subst x qid scope-subst))))
1129                                                         ((id1 (or 'as 'AS) x1) 
1130                                                          (let ((qid (compute-qid x1 scope scope-subst)))
1131                                                            (((nemo-core 'add-external!) sys) x `(input ,id1 ,qid #f))
1132                                                            (list (cons qid qs) (update-subst x1 qid scope-subst))))
1133                                                         ((id1 (or 'from 'FROM) n1) 
1134                                                          (let ((qid (compute-qid id1 scope scope-subst)))
1135                                                            (((nemo-core 'add-external!) sys) x `(input ,id1 ,qid ,n1))
1136                                                            (list (cons qid qs) (update-subst id1 qid scope-subst))))
1137                                                         ((id1 (or 'as 'AS) x1 (or 'from 'FROM) n1) 
1138                                                          (let ((qid (compute-qid x1 scope scope-subst)))
1139                                                            (((nemo-core 'add-external!) sys) x `(input ,id1 ,qid ,n1))
1140                                                            (list (cons qid qs) (update-subst x1 qid scope-subst))))
1141                                                         )))
1142                                     (list qs scope-subst) lst))
1143                                   (else (nemo:error 'eval-nemo-system-decls 
1144                                                     "import statement must be of the form: "
1145                                                     "input id1 [as x1] ... "))))
1146                           
1147                            ;; exported quantities
1148                            (((or 'output 'OUTPUT) . (and lst (? (lambda (x) (every symbol? x)))))
1149                             (let ((lst1 (map (lambda (x) (compute-qid x scope scope-subst)) lst)))
1150                               (for-each (lambda (x) (((nemo-core 'add-external!) sys) x 'output)) lst1)
1151                               (list qs scope-subst)))
1152                           
1153                            ;; constant during integration
1154                            (((or 'const 'CONST) (and id (? symbol?)) '= (and expr (? expr? )))
1155                             (let* ((qid    (compute-qid id scope scope-subst))
1156                                    (qexpr  (subst-expr (parse-expr expr `(const ,qid)) scope-subst))
1157                                    (qval   (eval-const qexpr)))
1158                               (env-extend! qid '(const) qval)
1159                               (list (cons qid qs) (update-subst id qid scope-subst))
1160                               ))
1161
1162                            ;; state transition complex
1163                            (((or 'reaction 'REACTION) ((and id (? symbol?)) . alst) )
1164                             (let* ((loc          `(reaction ,id))
1165                                    (alst         (filter identity alst))
1166                                    (initial      (lookup-def 'initial alst))
1167                                    (conserve-eq  (alist-ref 'conserve alst))
1168                                    (power        (lookup-def 'power alst))
1169                                    (power-val    (if (expr? power) 
1170                                                      (eval-const (subst-expr (parse-expr power loc) scope-subst))
1171                                                      (nemo:error 'eval-nemo-system-decls 
1172                                                                  "invalid power expression" power
1173                                                                  " in definition of state complex" id)))
1174                                    (transitions
1175                                     (map (lambda (t) 
1176                                            (match-let
1177                                             (((src dst rate1 rate2)
1178                                               (match t
1179                                                      (('-> a b r) (list a b r #f))
1180                                                      ((a '-> b r) (list a b r #f))
1181                                                      (('<-> a b r1 r2) (list a b r1 r2))
1182                                                      ((a '<-> b r1 r2) (list a b r1 r2))
1183                                                      (else (nemo:error "invalid transition " t
1184                                                                        " in definition of state complex " id))
1185                                                      )))
1186                                             (if (and rate1 rate2)
1187                                                 (let ((loc `(,@loc (eq. ,src <-> ,dst))))
1188                                                   `( <-> ,(subst-expr src scope-subst) 
1189                                                          ,(subst-expr dst scope-subst)
1190                                                          ,(subst-expr (parse-expr rate1 loc) scope-subst)
1191                                                          ,(subst-expr (parse-expr rate2 loc) scope-subst)))
1192                                                 (let ((loc `(,@loc (eq. ,src -> ,dst))))
1193                                                   `( -> ,(subst-expr src scope-subst)
1194                                                         ,(subst-expr dst scope-subst)
1195                                                         ,(subst-expr (parse-expr rate1 loc) scope-subst))))))
1196                                          (or (alist-ref 'transitions alst) (list)))))
1197
1198                               (let ((conserve-eq 
1199                                      (and conserve-eq
1200                                           (let ((loc `(,@loc (cons. eqs.))))
1201                                             (map (lambda (eq) 
1202                                                    (if (expr? (third eq))
1203                                                        `(,(first eq) = 
1204                                                          ,(subst-expr (parse-expr (third eq) loc) scope-subst))
1205                                                        (nemo:error 'eval-nemo-system-decls 
1206                                                                    "invalid equation " eq)))
1207                                                  conserve-eq)))))
1208                                 
1209                                 (if (and (list? conserve-eq) (not (every conseq? conserve-eq)))
1210                                     (nemo:error 'env-extend!
1211                                                 ": conservation equation for " id
1212                                                 " must be a linear equation: " conserve-eq))
1213                                 
1214                                 (let* ((qid          (compute-qid id scope scope-subst))
1215                                        (initial-expr (and initial 
1216                                                           (let ((loc `(,@loc (init. eq.))))
1217                                                             (subst-expr (parse-expr initial loc) scope-subst))))
1218                                        (initial-val  (and initial-expr (eval-const initial-expr))))
1219                                   (let ((lst (cons* qid '(reaction) initial-val 
1220                                                     `(power ,power-val) 
1221                                                     (if conserve-eq `(conserve ,@conserve-eq)
1222                                                         `(conserve #f))
1223                                                     `(transitions ,@transitions) alst)))
1224                                     (apply env-extend! lst))
1225                                   (list (cons qid qs) (update-subst id qid scope-subst))))))
1226                           
1227                           
1228                            ;; rate law
1229                            (((or 'd 'D) ((and id (? symbol?))) '= (and expr (? expr?) ) 
1230                              . rest)
1231
1232                             (let* ((qid     (compute-qid id scope scope-subst))
1233                                    (scope-subst1 (update-subst id qid scope-subst))
1234                                    (qexpr   (subst-expr (parse-expr expr `(rate ,id)) scope-subst1))
1235                                    (rest    (filter identity rest))
1236                                    (initial ((lambda (x) (and x (subst-expr (parse-expr x `(rate ,id)) scope-subst)))
1237                                              (lookup-def 'initial rest))))
1238
1239                               (env-extend! qid '(rate) 
1240                                            (and initial (eval-const initial)) 
1241                                            `(rhs ,qexpr))
1242                                           
1243                               (list (cons qid qs) scope-subst1)))
1244                           
1245                            ;; algebraic assignment
1246                            (((and id (? symbol?)) '= (and expr (? expr?) ))
1247                             (let* ((qid    (compute-qid id scope scope-subst))
1248                                    (qexpr  (subst-expr (parse-expr expr `(asgn ,id)) scope-subst)))
1249                               (env-extend! qid '(asgn) 'none `(rhs ,qexpr))
1250                               (list (cons qid qs) (update-subst id qid scope-subst))))
1251                           
1252                            ;; user-defined function
1253                            (((or 'fun 'FUN 'rel 'REL 'defun 'DEFUN) (and id (? symbol?)) 
1254                              (and idlist (? (lambda (x) (every symbol? x)))) 
1255                              (and expr (? expr?)))
1256
1257                             (let* ((qid          (compute-qid id scope scope-subst))
1258                                    (scope-subst1 (fold (lambda (x ax) (subst-remove x ax))
1259                                                        scope-subst
1260                                                        idlist))
1261                                    (qexpr         (subst-expr (parse-expr expr `(defun ,qid)) 
1262                                                               scope-subst1))
1263                                    )
1264                               (((nemo-core 'defun!) sys) qid idlist qexpr)
1265                               (list (cons qid qs) (update-subst id qid scope-subst))))
1266                           
1267                            ;; compiled primitives
1268                            (((or 'prim 'PRIM) id value) 
1269                             (cond ((symbol? id)  (env-extend! id '(prim) value))
1270                                   (else (nemo:error 'eval-nemo-system-decls 
1271                                                        "prim declarations must be of the form: "
1272                                                        "prim id value"))))
1273
1274                            (((or 'sysname 'SYSNAME) name) 
1275                             (if (symbol? name)
1276                                 (hash-table-set! sys (nemo-intern 'name) (SYSNAME name))
1277                                 (nemo:error 'eval-nemo-system-decls
1278                                             "system name must be a symbol")))
1279                           
1280                            (((or 'component 'COMPONENT)
1281                              ((or 'type 'TYPE) typ) 
1282                              ((or 'name 'NAME) name) . lst)
1283
1284                             (let ((name1 (let ((x (and (hash-table-exists? 
1285                                                         sys (or (lookup-def name scope-subst) name))
1286                                                        (hash-table-ref 
1287                                                         sys (or (lookup-def name scope-subst) name)))))
1288                                            (or (and x (nemo:quantity? x)
1289                                                     (cases nemo:quantity x
1290                                                            (LABEL (v)  v)
1291                                                            (else name)))
1292                                                name))))
1293
1294                               (let* ((sym   (fresh "comp"))
1295                                      (scope (or scope sym)))
1296                                 (match-let (((cqs scope-subst1)   (loop lst (list) scope scope-subst)))
1297                                            (let ((comp  (COMPONENT name1 typ cqs scope-subst1)))
1298                                              (hash-table-set! sys sym comp)
1299                                              (list (cons sym qs) scope-subst1))))))
1300
1301                            (((or 'component 'COMPONENT) ((or 'type 'TYPE) typ)  . lst) 
1302                             (let* ((sym   (fresh "comp"))
1303                                    (scope (or scope sym)))
1304                                   (match-let (((cqs scope-subst1)   (loop lst (list) scope scope-subst)))
1305                                      (let ((comp  (COMPONENT sym typ cqs scope-subst1)))
1306                                        (hash-table-set! sys sym comp)
1307                                        (list (cons sym qs) scope-subst1)))))
1308
1309                            (((or 'component 'COMPONENT)  ((or 'name 'NAME) name) '= 
1310                              (and functor-name (? symbol?)) 
1311                              (and args (? list?)))
1312
1313                             (if (and scope scope-subst) 
1314                                 (nemo:error 'eval-nemo-system-decls
1315                                             "functor instantiation is not permitted in nested scope"))
1316
1317                             (match-let
1318                              (((functor-args functor-type functor-lst)
1319                                (let ((x (hash-table-ref sys functor-name)))
1320                                  (or (and (nemo:quantity? x)
1321                                           (cases nemo:quantity x
1322                                                  (FUNCTOR (sym args typ lst)  (list args typ lst))
1323                                                  (else #f)))
1324                                      (nemo:error 'eval-nemo-system-decls! functor-name 
1325                                                  " is not a functor" )))))
1326
1327                              (if (not (<= (length functor-args)  (length args)))
1328                                  (let ((n (length args)))
1329                                    (nemo:error 'eval-nemo-system-decls! "functor " functor-name 
1330                                                " requires at least " (length functor-args) " arguments; "
1331                                                args  " (total " n ") "
1332                                                (if (= n 1) "was" "were") " given" )))
1333
1334                              (match-let
1335                               (((cqs1 scope-subst1)   (loop args (list) name subst-empty)))
1336                                 (let ((cqs1-names (sort (map ->string cqs1) string< ))
1337                                       (args-names (let ((qs (map (lambda (x) 
1338                                                                    (->string (compute-qid x name scope-subst1)) )
1339                                                                    functor-args)))
1340                                                     (sort qs string<))))
1341
1342                                   (if (not (every (lambda (x) (member x cqs1-names string=)) args-names))
1343                                       (nemo:error 'eval-nemo-system-decls! "functor " functor-name 
1344                                              " instantiation did not include required arguments " 
1345                                              (filter (lambda (x) (not (member x cqs1-names string=))) args-names)))
1346                               
1347                                   (match-let
1348                                    (((cqs2 scope-subst2)   (loop functor-lst (list) name scope-subst1)))
1349                                    (let* ((sym    (fresh "comp"))
1350                                           (comp   (COMPONENT name functor-type (append cqs1 cqs2) scope-subst2)))
1351                                      (hash-table-set! sys sym comp)
1352                                     
1353                                      (list (cons sym qs) '())))))))
1354                             
1355                            (((or 'functor 'FUNCTOR) ((or 'name 'NAME) name) ((or 'type 'TYPE) typ)
1356                              (and args (? list?))  '= . lst)
1357
1358                             (if (and scope scope-subst) 
1359                                 (nemo:error 'eval-nemo-system-decls
1360                                             "functor declaration is not permitted in nested scope"))
1361                             (let* ((sym      (string->symbol (->string name)))
1362                                    (functor  (FUNCTOR sym args typ lst)))
1363                               (if (hash-table-exists? sys sym)
1364                                   (nemo:error 'eval-nemo-system-decls! ": functor " sym " already defined"))
1365                               (hash-table-set! sys sym functor)
1366                               (list (cons sym qs) '())))
1367                           
1368                            (((or 'const 'CONST) . _)
1369                             (nemo:error 'eval-nemo-system-decls "declaration: " decl
1370                                         ": constant declarations must be of the form: "
1371                                            "const id = expr"))
1372                           
1373                            ((id '= . _) 
1374                             (nemo:error 'eval-nemo-system-decls 
1375                                         "declaration " decl
1376                                         ": algebraic equations must be of the form: "
1377                                         "id = expr")) 
1378                           
1379                            (((or 'reaction 'REACTION) . _)
1380                             (nemo:error 'eval-nemo-system-decls 
1381                                         "declaration " decl 
1382                                         ": reaction declarations must be of the form: "
1383                                         "reaction (id ...)"))
1384                           
1385                            (((or 'fun 'FUN 'rel 'REL 'defun 'DEFUN) . _) 
1386                             (nemo:error 'eval-nemo-system-decls "function declarations must be of the form: "
1387                                            "fun id (arg1 arg2 ...) expr"))
1388                           
1389                            (((or 'prim 'PRIM) . _) 
1390                             (nemo:error 'eval-nemo-system-decls "prim declarations must be of the form: "
1391                                            "prim id value"))
1392                           
1393                            (((or 'component 'COMPONENT) . _) 
1394                             (nemo:error 'eval-nemo-system-decls "invalid component: " decl))
1395                           
1396                            (((or 'sysname 'SYSNAME) . _) 
1397                             (nemo:error 'eval-nemo-system-decls "system name must be of the form (sysname name)"))
1398                           
1399                            ;; anything that doesn't match is possibly
1400                            ;; declarations recognized by the nemo extension
1401                            ;; modules
1402                            (((and tag (? symbol?))  . lst)
1403                             (match-let (((typ name alst) 
1404                                          (let loop ((lst lst) (ax (list tag)))
1405                                            (if (null? lst)
1406                                                (list (list (car (reverse ax))) #f (cdr (reverse ax)))
1407                                                (match lst
1408                                                       (((? symbol?) . rest) 
1409                                                        (loop (cdr lst) (cons (car lst) ax) ))
1410                                                       (((x . rest)) 
1411                                                          (if (and (symbol? x) (every list? rest))
1412                                                              (list (reverse ax) x rest)
1413                                                              (list (reverse ax) #f lst)))
1414                                                       (else  (list (reverse ax) #f lst)))))))
1415                                       
1416                                        (let* ((name (or name (fresh tag)))
1417                                               (qid  name))
1418                                          (env-extend! qid  typ (if scope (append alst `((scope ,scope))) alst))
1419                                          (list (cons qid qs) (update-subst name qid scope-subst)))))
1420
1421                            (else
1422                             (nemo:error 'eval-nemo-system-decls 
1423                                         "declaration " decl ": "
1424                                         "extended declarations must be of the form: "
1425                                         "declaration (name (properties ...)"
1426                                         ))
1427                            )))
1428           (loop (cdr ds) qs1 scope scope-subst1))))
1429        ))))
1430     res
1431     )))
1432)
Note: See TracBrowser for help on using the repository browser.