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

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

nemo: eliminated dependency on environments

File size: 50.8 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      (let ((op (hash-table-ref nemo-env s)))
382        (if (extended-procedure? op)
383            (let* ((fd   (procedure-data op))
384                   (fms   (lookup-def 'formals fd)))
385
386              (if (not (= (length fms) (length args)))
387                  (nemo:error 'eval-expr "procedure " s 
388                              " called with incorrect number of arguments: "
389                              args)))))))
390
391  (define (env-extend! nemo-env)
392    (lambda (name type initial . alst)
393
394       (let* ((sym (if (symbol? name) name (string->symbol name)))
395              (arity-check (make-arity-check nemo-env))
396              (normalize-expr (make-normalize-expr arity-check)))
397        (if (hash-table-exists? nemo-env sym)
398            (nemo:error 'env-extend! ": quantity " sym " already defined")
399            (match type
400              (('label)   (begin
401                            (if (not (symbol? initial)) 
402                                (nemo:error 'env-extend! ": label definitions require symbolic value"))
403                            (hash-table-set! nemo-env sym (LABEL initial))))
404
405              (('external)  (begin
406                              (let* ((ns             (lookup-def 'namespace alst))
407                                     (external-name  (lookup-def 'name alst))
408                                     (x              (EXTERNAL name external-name ns )))
409                                (hash-table-set! nemo-env sym x)
410                                )))
411                             
412              (('prim)    (let* ((rhs (lookup-def 'rhs alst))
413                                 (val (if (and rhs (procedure? initial) )
414                                          (extend-procedure initial rhs)
415                                          initial)))
416                            (hash-table-set! nemo-env sym (PRIM name val ))))
417
418              (('const)   (begin
419                            (if (not (number? initial)) 
420                                (nemo:error 'env-extend! ": constant definitions require numeric value"))
421                            (hash-table-set! nemo-env sym (CONST name initial))))
422
423              (('asgn)    (let ((rhs (lookup-def 'rhs alst)))
424                            (if (not (eq? initial 'none))
425                                (nemo:error 'env-extend! 
426                                                    ": state function definitions must have initial value of '(none)"))
427                            (if (not rhs) 
428                                (nemo:error 'env-extend! ": state function definitions require an equation"))
429                            (hash-table-set! nemo-env sym (ASGN  name 0.0 (normalize-expr rhs)))))
430
431              (('rate)    (let ((rhs (lookup-def 'rhs alst))
432                                (power (lookup-def 'power alst)))
433                            (if (not (rhs? rhs))
434                                (nemo:error 'env-extend! ": rate law definitions require an equation"))
435
436                            (hash-table-set! nemo-env sym (RATE name (and initial (normalize-expr initial))
437                                                                (normalize-expr rhs) power))))
438
439              (('reaction)  (begin
440                            (let ((power         (or (lookup-def 'power alst) 1))
441                                  (transitions   
442                                   (map (lambda (t) 
443                                          (match t
444                                                 (( '<-> (and src (? symbol?)) (and dst (? symbol?)) r1 r2) 
445                                                  `( <-> ,src ,dst ,(normalize-expr r1) ,(normalize-expr r2)))
446
447                                                 (( '-> (and src (? symbol?)) (and dst (? symbol?)) r1) 
448                                                  `( -> ,src ,dst ,(normalize-expr r1) ))
449
450                                                 (else
451                                                  (nemo:error 'env-extend! ": invalid transition " t))))
452                                        (or (alist-ref 'transitions alst) (list))))
453                                  (conserve      (lookup-def 'conserve alst))
454                                  (open          (lookup-def 'open alst)))
455                              (if (null? transitions)
456                                  (nemo:error 'env-extend! 
457                                              ": transition state complex definitions require a transition scheme"))
458                              (if (not open) 
459                                  (nemo:error 'env-extend! ": state complex definitions require open state"))
460                              (if (not (integer? power))
461                                  (nemo:error 'env-extend!
462                                              ": definition for state " sym
463                                              " requires an integer power (" power  " was given)"))
464                             
465                              (let ((en (REACTION name (and initial (normalize-expr initial))
466                                                  open transitions 
467                                                  (and conserve (list conserve)) power)))
468                                (hash-table-set! nemo-env sym en)))))
469
470
471              (else       (begin
472                            (hash-table-set! nemo-env sym `(,type (name ,sym) . ,initial))))
473              )))))
474
475  (define (infer nemo-env ftenv body)
476    (let recur ((expr body) (lb (list)))
477      (match expr 
478             (('if c t e)
479              (let ((ct (recur c lb))
480                    (tt (recur t lb))
481                    (et (recur e lb)))
482                (and ct tt et 
483                     (begin
484                       (if (not (equal? ct 'bool)) 
485                           (nemo:error 'infer "if condition type must be boolean"))
486                       (if (equal? tt et) tt
487                           (nemo:error 'infer "type mismatch in if statement: then = " tt
488                                      " else = " et))))))
489             (('let bs e)
490              (let* ((rlb (lambda (x) (recur x lb)))
491                     (tbs (map rlb (map second bs)))
492                     (lb1 (append (zip (map first bs) tbs) lb)))
493                (recur e lb1)))
494             
495             ((s . es)   
496              (let* ((f    (hash-table-ref nemo-env s))
497                     (lst  (procedure-data f)))
498                (and lst 
499                     (let ((rt   (lookup-def 'rt   lst))
500                           (fms  (lookup-def 'formals lst)))
501                       (and rt fms
502                            (begin
503                              (for-each (lambda (x ft)
504                                          (if (and (symbol? x) (not (hash-table-exists? ftenv x)))
505                                              (hash-table-set! ftenv x ft)))
506                                        es fms)
507                              (let* ((rlb (lambda (x) (recur x lb)))
508                                     (ets (map rlb es)))
509                                (and (every identity ets)
510                                     (every (lambda (xt ft) (equal? xt ft)) ets fms)
511                                     rt))))))))
512             
513             (id    (cond ((symbol? id)     (or (lookup-def id lb) (hash-table-ref ftenv id)))
514                          ((number? id)     fptype)
515                          ((boolean? id)    'bool)
516                          ((fpvector? id)   fpvector-type)
517                          (else #f))))))
518   
519
520  (define (defun! nemo-env)
521    (define arity-check (make-arity-check nemo-env))
522    (define normalize-expr (make-normalize-expr arity-check))
523
524    (lambda (name formals body)
525        (let ((const-env (make-const-env nemo-env))
526              (sym (if (symbol? name) name (string->symbol name))))
527          (letrec ((enumconsts
528                    (lambda (lb)
529                      (lambda (expr ax)
530                        (match expr 
531                               (('let bs e)  (let ((ec (enumconsts (append (map first bs) lb))))
532                                               (ec e (fold ec ax (map second bs)))))
533                               (('if . es)   (fold (enumconsts lb) ax es))
534                               ((s . es)     (if (symbol? s) 
535                                                 (let ((v (const-env-entry->value (hash-table-ref const-env s))))
536                                                   (cons (cons s v) (fold (enumconsts lb) ax es)))
537                                                 ax))
538                               (s            (cond
539                                               ((and (symbol? s) (not (member s lb)) 
540                                                     (hash-table-exists? const-env s))
541                                                (let ((v (const-env-entry->value (hash-table-ref const-env s))))
542                                                  (cons (cons s v) ax) ))
543                                               ((and (symbol? s) (not (member s lb)))
544                                                (nemo:error 'defun ": quantity " s " not defined"))
545                                               (else ax)))))))
546                   
547                   )
548            (if (hash-table-exists? nemo-env sym)
549                (nemo:error 'defun! ": quantity " sym " already defined")
550                (let* (
551                       (body    (normalize-expr body))
552                       (consts  (delete-duplicates ((enumconsts formals) body (list)) 
553                                                   (lambda (x y) (equal? (car x) (car y)))))
554                       (eval-body `(let ,(map (lambda (sv)
555                                                `(,(car sv) ,(cdr sv))) consts)
556                                     (lambda ,formals ,body)))
557                       (f      (eval eval-body))
558                       )
559                  (let* ((ftenv  (make-hash-table))
560                         (rt     (infer nemo-env ftenv body))
561                         (ftypes (filter-map (lambda (x) 
562                                               (or (and (hash-table-exists? ftenv x)
563                                                        (hash-table-ref ftenv x)) 'double))
564                                             formals))
565                         (ef     (extend-procedure f 
566                                   `((name ,sym) (body ,body) (eval-body ,eval-body) 
567                                     (rt ,rt) (formals ,ftypes) (vars ,formals)
568                                     (consts ,(filter (lambda (x) (not (member x builtin-fns))) consts)))))
569                         )
570                  (hash-table-set! nemo-env sym ef))))))))
571
572  (define (symbol-list? lst)
573    (and (list? lst) (every symbol? lst)))
574
575  (define (extended nemo-env)
576      (filter-map (lambda (sym) 
577                    (let ((x (hash-table-ref nemo-env sym)))
578                      (and (not (nemo:quantity? x)) (not (procedure? x)) 
579                           (match x 
580                                  (((? symbol-list?) ('name name) . rest)  `(,sym ,x))
581                                  (else #f)))))
582           (hash-table-keys nemo-env)))
583                       
584
585  (define (extended-with-tag nemo-env tag)
586      (filter-map (lambda (sym) 
587                    (let ((x (hash-table-ref nemo-env sym)))
588                      (and (not (nemo:quantity? x)) (not (procedure? x)) 
589                           (match x 
590                                  (((? (lambda (x) (equal? x tag))) ('name name) . rest) 
591                                   `(,sym ,x))
592                                  (else #f)))))
593           (hash-table-keys nemo-env)))
594                       
595
596  (define (components nemo-env)
597      (filter-map (lambda (sym) 
598                    (let ((x (hash-table-ref nemo-env sym)))
599                      (and (nemo:quantity? x)
600                           (cases nemo:quantity x
601                                  (COMPONENT (name type lst _)  `(,name ,type ,sym))
602                                  (else #f)))))
603           (hash-table-keys nemo-env)))
604
605
606  (define (component-name nemo-env sym)
607    (let ((x (hash-table-ref nemo-env sym)))
608      (and (nemo:quantity? x)
609           (cases nemo:quantity x
610                  (COMPONENT (name type lst _)  name)
611                  (else #f)))))
612
613
614  (define (component-symbols nemo-env sym)
615    (let ((x (hash-table-ref nemo-env sym)))
616      (and (nemo:quantity? x)
617           (cases nemo:quantity x
618                  (COMPONENT (name type lst _)  lst)
619                  (else #f)))))
620
621
622  (define (component-scope-subst nemo-env sym)
623    (let ((x (hash-table-ref nemo-env sym)))
624      (and (nemo:quantity? x)
625           (cases nemo:quantity x
626                  (COMPONENT (name type lst scope-subst)  scope-subst)
627                  (else #f)))))
628
629
630  (define (component-exports nemo-env sym)
631    (let ((all-exports (cases nemo:quantity (hash-table-ref nemo-env (nemo-intern 'exports))
632                              (EXPORTS (lst)  lst))))
633      (let ((x  (hash-table-ref nemo-env sym)))
634        (and (nemo:quantity? x)
635             (cases nemo:quantity x
636                    (COMPONENT (name type lst _) 
637                      (filter-map (lambda (x) ((lambda (x) (and x (car x))) (member x all-exports))) lst))
638                    (else #f))))))
639
640  (define (component-subcomps nemo-env sym)
641
642    (define (component-type x)
643      (cases nemo:quantity x
644             (COMPONENT (name type lst _) type)
645             (else #f)))
646    (define (component-name x)
647      (cases nemo:quantity x
648             (COMPONENT (name type lst _) name)
649             (else #f)))
650    (let ((en (hash-table-ref nemo-env sym)))
651      (and (nemo:quantity? en)
652           (cases nemo:quantity en
653                  (COMPONENT (name type lst _) 
654                             (filter-map 
655                              (lambda (s) 
656                                (let ((x (hash-table-ref nemo-env s)))
657                                  (and (iscomp? x) `(,(component-type x) ,(component-name x) ,s)))) lst))
658                  (else #f)))))
659
660  (define (component-extend! nemo-env)
661    (lambda (comp-name sym)
662      (let ((x (hash-table-ref nemo-env comp-name)))
663        (if (nemo:quantity? x)
664            (cases nemo:quantity x
665                   (COMPONENT (name type lst scope-subst) 
666                              (let ((en1 (COMPONENT name type (delete-duplicates (append lst (list sym))) scope-subst)))
667                                (hash-table-set! nemo-env comp-name en1)))
668                   (else (nemo:error 'component-extend! ": invalid component " comp-name)))
669            (nemo:error 'component-extend! ": invalid component " comp-name)))))
670
671  (define (component-enumdeps nemo-env sym)
672    (let ((x (hash-table-ref nemo-env sym)))
673      (and (nemo:quantity? x)
674           (cases nemo:quantity x
675                  (COMPONENT 
676                   (name type lst scope-subst) 
677                   (delete-duplicates
678                    (append
679                     (fold (lambda (qsym ax)
680                             (let* ((q   (hash-table-ref nemo-env qsym))
681                                    (rhs (qrhs q)))
682                               (or (and rhs (append (enumdeps rhs) ax)) ax)))
683                           '()
684                           lst)
685                     (map (lambda (x) (component-enumdeps  nemo-env x))
686                          (component-subcomps nemo-env sym)))))
687                  (else #f)))))
688
689  (define (component-env nemo-env sym . syms)
690    (fold 
691     (lambda (sym env)
692       (let ((comp (hash-table-ref nemo-env sym)))
693         (and (nemo:quantity? comp)
694              (cases nemo:quantity comp
695                     (COMPONENT 
696                      (name type lst scope-subst) 
697                      (let* ((depnames (component-enumdeps nemo-env sym))
698                             (subnames (map third (component-subcomps nemo-env sym)))
699                             (cnames   lst))
700
701                        (let* ((syms (delete-duplicates (append depnames subnames cnames)))
702                               (vals (map (lambda (x) (hash-table-ref nemo-env x)) syms)))
703                          (for-each (lambda (s v) (hash-table-set! env s v)) 
704                                    syms vals)
705                          env
706                          )))
707                     (else env)))))
708     (make-base-env)
709     (cons sym syms)))
710
711
712  (define (exports nemo-env)
713    (cases nemo:quantity (hash-table-ref nemo-env (nemo-intern 'exports))
714           (EXPORTS (lst)  lst)))
715
716
717  (define (imports nemo-env)
718      (filter-map (lambda (sym) 
719                    (let ((x (hash-table-ref nemo-env sym)))
720                      (and (nemo:quantity? x)
721                           (cases nemo:quantity x
722                                  (EXTERNAL (local-name name namespace)  (list local-name name namespace))
723                                  (else #f)))))
724           (hash-table-keys nemo-env)))
725
726
727  (define (consts nemo-env)
728      (filter-map (lambda (sym) 
729                    (let ((x (hash-table-ref nemo-env sym)))
730                      (and (nemo:quantity? x)
731                           (cases nemo:quantity x
732                                  (CONST (name value)  (list name value) )
733                                  (else #f)))))
734           (hash-table-keys nemo-env)))
735
736
737
738  (define (states nemo-env)
739      (fold (lambda (sym ax) 
740                    (let ((x (hash-table-ref nemo-env sym)))
741                      (if (nemo:quantity? x)
742                           (cases nemo:quantity x
743                                  (REACTION (name initial open transitions conserve power)
744                                          (let* ((ss1 (delete-duplicates (append (map second transitions) 
745                                                                                 (map third transitions))))
746                                                 (ss2 (map (lambda (x) (list name x))  ss1)))
747                                            (append ss2 ax)))
748                                  (RATE (name initial rhs _) (cons (list #f name) ax))
749                                  (else ax))
750                           ax)))
751           (list) (hash-table-keys nemo-env)))
752
753
754  (define (reactions nemo-env)
755      (fold (lambda (sym ax) 
756                    (let ((x (hash-table-ref nemo-env sym)))
757                      (if (nemo:quantity? x)
758                           (cases nemo:quantity x
759                                  (REACTION (name initial open transitions conserve power)
760                                          (cons name ax))
761                                  (else ax))
762                           ax)))
763           (list) (hash-table-keys nemo-env)))
764
765
766  (define (rates nemo-env)
767      (filter-map (lambda (sym) 
768                    (let ((x (hash-table-ref nemo-env sym)))
769                      (and (nemo:quantity? x)
770                           (cases nemo:quantity x
771                                  (RATE (name value rhs _) name)
772                                  (else #f)))))
773           (hash-table-keys nemo-env)))
774
775  (define (asgns nemo-env)
776      (filter-map (lambda (sym) 
777                    (let ((x (hash-table-ref nemo-env sym)))
778                      (and (nemo:quantity? x)
779                           (cases nemo:quantity x
780                                  (ASGN (name value rhs) name)
781                                  (else #f)))))
782           (hash-table-keys nemo-env)))
783
784
785  (define (defuns nemo-env)
786      (filter-map (lambda (sym) 
787                    (let ((x (hash-table-ref nemo-env sym)))
788                      (and (procedure? x) (not (member sym builtin-fns)) (list sym x))))
789           (hash-table-keys nemo-env)))
790
791
792  (define (toplevel nemo-env)
793    (cases nemo:quantity (hash-table-ref nemo-env (nemo-intern 'toplevel))
794           (COMPONENT (name type lst _) `(,type ,lst))))
795
796                                       
797  (define (exam nemo-env)
798    (lambda (name)
799      (let ((sym (if (symbol? name) name (string->symbol name)))
800            (out (current-output-port)))
801        (if (not (hash-table-exists? nemo-env sym))
802            (nemo:error 'exam ": quantity " sym " is not defined")
803            (let ((x (hash-table-ref nemo-env sym)))
804              (cases nemo:quantity x
805                     (LABEL  (v)
806                            (begin
807                              (fprintf out "~a: label\n" name)
808                              (fprintf out "    value: ~a\n" v)))
809
810                     (PRIM  (name value)
811                            (begin
812                              (fprintf out "~a: compiled nemo primitive\n" name)
813                              (fprintf out "    value: ~a\n" value)))
814
815                     (CONST    (name value)
816                               (begin
817                                 (fprintf out "~a: constant\n" name)
818                                 (fprintf out "    value: ~a\n" value)))
819                     
820                     (ASGN     (name value rhs)
821                               (begin
822                                 (fprintf out "~a: state function\n" name)
823                                 (fprintf out "    value: ~a\n" value)))
824
825                     (REACTION (name initial open transitions conserve power)
826                             (begin
827                               (fprintf out "~a: transition state complex\n" name)
828                               (fprintf out "    initial value: ~a\n" initial)))
829                     
830                     (RATE     (name initial rhs power)
831                               (begin
832                                 (fprintf out "~a: rate law\n" name)
833                                 (fprintf out "    rhs: ~a\n" rhs)
834                                 (if power (fprintf out "    power: ~a\n" power))
835                                 ))
836
837                     (else (nemo:error 'exam name ": unknown type of quantity"))))))))
838 
839  (define (eval-simple-expr env expr)
840    (cond ((number? expr) expr)
841          ((symbol? expr) (hash-table-ref env expr))
842          ((pair? expr)   (let ((expr1 (map (lambda (x) (eval-simple-expr env x)) expr)))
843                            (apply (car expr1) (cdr expr1))))))
844
845  (define (eval-const nemo-env expr)
846    (let* ((arity-check (make-arity-check nemo-env))
847           (normalize-expr (make-normalize-expr arity-check)))
848      (let ((expr1 (normalize-expr expr))
849            (const-env (make-const-env nemo-env)))
850        (condition-case
851         (exact->inexact (eval-simple-expr const-env expr1))
852         [var () expr1])
853        )))
854
855
856  (define (iscomp? x)
857    (cond ((nemo:quantity? x)
858           (cases nemo:quantity x
859                  (COMPONENT  (name type lst _)  #t)
860                  (else #f)))
861          (else #f)))
862
863  (define (isdep? x)
864    (cond ((nemo:quantity? x)
865           (cases nemo:quantity x
866                  (ASGN  (name value rhs)  #t)
867                  (else #f)))
868          ((and (list? x) (every pair? (cdr x)))  (alist-ref 'dep?  (cdr x)))
869          (else #f)))
870
871
872  (define (isstate? x)
873    (and (nemo:quantity? x)
874         (cases nemo:quantity x
875                (REACTION (name initial open transitions)  #t)
876                (RATE     (name initial rhs _) #t)
877                (else #f))))
878
879
880  (define (qrhs x)
881    (and (nemo:quantity? x)
882         (cases nemo:quantity x
883                (REACTION (name initial open transitions) 
884                        (begin
885                          (map cadddr transitions)))
886                (RATE  (name initial rhs _)  rhs)
887                (ASGN  (name value rhs)  rhs)
888                (else #f))))
889
890           
891  (define (sysname nemo-env)
892    (cases nemo:quantity (hash-table-ref nemo-env (nemo-intern 'name))
893           (SYSNAME (name)  name)))
894
895
896  ;; create equation dependency graph
897  (define (make-eqng nemo-env)
898    (let* ((sysname    (sysname nemo-env))
899           (g          (make-digraph sysname (string-append (symbol->string sysname) 
900                                                            " equation dependency graph")))
901           (add-node!  (g 'add-node!))
902           (add-edge!  (g 'add-edge!))
903           (nemo-list  (filter (lambda (sym) (let ((x (hash-table-ref nemo-env sym)))
904                                               (or (isstate? x) (isdep? x))))
905                               (hash-table-keys nemo-env)))
906           (nemo-ids      (list-tabulate (length nemo-list) identity))
907           (name->id-map  (zip nemo-list nemo-ids)))
908      (let-values (((state-list asgn-list) 
909                    (partition (lambda (sym) (isstate? (hash-table-ref nemo-env sym)))
910                               nemo-list)))
911                 
912         ;; insert equations in the dependency graph
913         (for-each (lambda (i n) (add-node! i n)) nemo-ids nemo-list)
914         ;; create dependency edges in the graph
915         (for-each (lambda (e) 
916                     (match e ((ni . nj) (begin
917                                           (let ((i (car (alist-ref ni name->id-map)))
918                                                 (j (car (alist-ref nj name->id-map))))
919                                             (add-edge! (list i j (format "~A=>~A" ni nj))))))
920                            (else (nemo:error 'make-eqng ": invalid edge " e))))
921                   (fold (lambda (qsym ax) 
922                           (let* ((q   (hash-table-ref nemo-env qsym))
923                                  (rhs (qrhs q)))
924                             (if rhs 
925                                 (let* ((deps (filter (if (isstate? q)
926                                                          (lambda (sym) 
927                                                            (if (not (hash-table-exists? nemo-env sym))
928                                                                (nemo:error 'make-eqng ": undefined symbol " sym 
929                                                                            " in definition of quantity " qsym))
930                                                            (and (let ((x (hash-table-ref nemo-env sym)))
931                                                                   (and (isdep? x) (not (eq? sym qsym))))))
932                                                          (lambda (sym) 
933                                                            (if (not (hash-table-exists? nemo-env sym))
934                                                                (nemo:error 'make-eqng ": undefined symbol " sym 
935                                                                            " in definition of quantity " qsym))
936                                                            (and (let ((x (hash-table-ref nemo-env sym)))
937                                                                   (isdep? x)))))
938                                                      (enumdeps rhs)))
939                                          (edges (map (lambda (d) (cons d qsym)) deps)))
940                                   (if edges (append edges ax) ax))
941                                 ax)))
942                         (list) nemo-list))
943         (let ((cycles (graph-cycles-fold g (lambda (cycle ax) (cons cycle ax)) (list))))
944           (if (null? cycles) (list state-list asgn-list g)
945               (nemo:error 'make-eqng ": equation cycle detected: " (car cycles)))))))
946
947
948  ;; given a graph, create a partial ordering based on BFS distance from root
949  (define (graph->bfs-dist-poset g)
950    (define node-info (g 'node-info))
951
952    (let-values (((dists dmax) (graph-bfs-dist g ((g 'roots)))))
953      (let loop ((poset  (make-vector (fx+ 1 dmax) (list)))
954                 (i      (fx- (s32vector-length dists) 1)))
955        (if (fx>= i 0)
956            (let* ((c     (s32vector-ref dists i))
957                   (info  (node-info i)))
958              (vector-set! poset c (cons (cons i info) (vector-ref poset c)))
959              (loop poset (fx- i 1)))
960            (begin
961              poset)))))
962
963
964  (define (make-eval-poset nemo-env eqposet)
965    (vector-map 
966       (lambda (i lst) 
967         (filter-map (lambda (id+sym)
968                       (let* ((sym  (cdr id+sym))
969                              (x    (hash-table-ref nemo-env sym)))
970                         (and (nemo:quantity? x)
971                              (cases nemo:quantity x
972                                     (REACTION (name initial open transitions) 
973                                             (let ((rs (map cadddr transitions)))
974                                               (list 're sym rs)))
975                                     (RATE  (name initial rhs _)
976                                            (list 'r sym rhs))
977                                     (ASGN  (name value rhs)
978                                            (list 'a sym rhs))
979                                     (else nemo:error 'make-eval-poset
980                                           ": invalid quantity in equation poset: " sym)))))
981                     lst))
982       eqposet))
983
984  (define (eval-expr env)
985    (lambda (expr)
986      (let ((val (match expr
987                        (('if c t f) 
988                         (let ((ee (eval-expr env)))
989                           (condition-case
990                            (if (ee c) (ee t) (ee f))
991                            [var () 
992                               (nemo:error 'eval-expr " exception in " expr ": \n"
993                                          (lambda () (print-error-message var)))])))
994
995                        ((s . es)   
996                         (condition-case 
997                          (let ((op   (hash-table-ref env s))
998                                (args (map (eval-expr env) es)))
999                            (if (extended-procedure? op)
1000                                (let* ((fd   (procedure-data op))
1001                                       (vs  (lookup-def 'vars fd)))
1002
1003                                  (if (not (= (length vs) (length args)))
1004                                      (nemo:error 'eval-expr "procedure " s 
1005                                                  " called with incorrect number of arguments"))))
1006                            (apply op args))
1007                          [var () 
1008                               (nemo:error 'eval-expr " exception in " expr ": \n"
1009                                          (lambda () (print-error-message var)))]))
1010                       
1011                        (s                 
1012                         (cond ((symbol? s) (hash-table-ref env s))
1013                               ((number? s) s)
1014                               (else (nemo:error 'eval-expr "unknown expression " s)))))))
1015        val)))
1016
1017
1018  (define (depgraph nemo-env)
1019    (match-let (((state-list asgn-list g)  (make-eqng nemo-env))) g))
1020
1021  (define (depgraph* nemo-env)
1022    (match-let (((state-list asgn-list g)  (make-eqng nemo-env))) 
1023               (list state-list asgn-list g)))
1024
1025
1026  ;; Dispatcher
1027  (define (nemo-dispatch selector)
1028    (case selector
1029      ((add-external!)     add-external!)
1030      ((defun!)            defun!)
1031      ((depgraph)          depgraph)
1032      ((depgraph*)         depgraph*)
1033      ((depgraph->bfs-dist-poset)  graph->bfs-dist-poset)
1034      ((eval-const)          eval-const)
1035      ((env-extend!)         env-extend!)
1036      ((subst-expr)        (subst-driver (lambda (x) (and (symbol? x) x)) 
1037                                         nemo:binding? 
1038                                         identity 
1039                                         nemo:bind 
1040                                         nemo:subst-term))
1041      ((exam)                exam)
1042      ((make-const-env)      make-const-env)
1043      ((system)              system)
1044      ((sysname)             sysname)
1045      ((asgns)               asgns)
1046      ((states)              states)
1047      ((reactions)           reactions)
1048      ((rates)               rates)
1049      ((defuns)              defuns)
1050      ((consts)              consts)
1051      ((exports)             exports)
1052      ((imports)             imports)
1053      ((toplevel)            toplevel)
1054      ((components)          components)
1055      ((component-env)       component-env)
1056      ((component-name)      component-name)
1057      ((component-symbols)   component-symbols)
1058      ((component-exports)   component-exports)
1059      ((component-subcomps)  component-subcomps)
1060      ((component-scope-subst)  component-scope-subst)
1061      ((component-extend!)   component-extend!)
1062      ((extended)            extended)
1063      ((extended-with-tag)   extended-with-tag)
1064      (else
1065       (nemo:error 'selector ": unknown message " selector " sent to an nemo-core object"))))
1066
1067  nemo-dispatch)
1068
1069(define (eval-nemo-system-decls nemo-core name sys declarations . rest)
1070  (let-optionals rest ((parse-expr (lambda (x . rest) x)))
1071   (define (eval-const x) (and x ((nemo-core 'eval-const) sys x)))
1072   (define env-extend!  ((nemo-core 'env-extend!) sys))
1073   (define (compute-qid id scope scope-subst) (or (and scope scope-subst (nemo-scoped scope id)) id))
1074   (define (update-subst id qid subst) (if (equal? id qid) subst
1075                                           (subst-extend id qid subst) ))
1076   (define subst-expr  (subst-driver (lambda (x) (and (symbol? x) x)) 
1077                                     nemo:binding? 
1078                                     identity 
1079                                     nemo:bind 
1080                                     nemo:subst-term))
1081   (let ((res
1082          (let loop ((ds declarations) (qs (list)) (scope #f) (scope-subst '()))
1083
1084            (if (null? ds) 
1085                (let ((qs (reverse qs)))
1086                  (if (not scope)
1087                      (let* ((top-syms   ((nemo-core 'component-symbols ) sys (nemo-intern 'toplevel)))
1088                             (top-syms1  (append qs top-syms)))
1089                        (hash-table-set! sys (nemo-intern 'toplevel) (COMPONENT 'toplevel 'toplevel top-syms1 '()))))
1090                  (list qs scope-subst))
1091                (let ((decl (car ds)))
1092                  (if (null? decl)
1093                      (loop (cdr ds) qs scope scope-subst)
1094                  (match-let 
1095                   (((qs1 scope-subst1)
1096                     (match decl
1097
1098                            ;; labels
1099                            (((or 'label 'LABEL) (and id (? symbol?)) '= (and v (? symbol?)))
1100                             (let* ((qid  (compute-qid id scope scope-subst)))
1101                               (env-extend! qid '(label) v)
1102                               (list (cons qid qs) (update-subst id qid scope-subst))))
1103                           
1104                            ;; imported quantities
1105                            (((or 'input 'INPUT) . lst) 
1106                             (cond ((every (lambda (x) (or (symbol? x) (list? x))) lst)
1107                                    (fold
1108                                     (lambda (x ax) 
1109                                       (match-let (((qs scope-subst) ax))
1110                                                  (match x
1111                                                         ((? symbol?) 
1112                                                          (let ((qid (compute-qid x scope scope-subst)))
1113                                                            (((nemo-core 'add-external!) sys) x `(input ,x ,qid #f))
1114                                                            (list (cons qid qs) (update-subst x qid scope-subst))))
1115                                                         ((id1 (or 'as 'AS) x1) 
1116                                                          (let ((qid (compute-qid x1 scope scope-subst)))
1117                                                            (((nemo-core 'add-external!) sys) x `(input ,id1 ,qid #f))
1118                                                            (list (cons qid qs) (update-subst x1 qid scope-subst))))
1119                                                         ((id1 (or 'from 'FROM) n1) 
1120                                                          (let ((qid (compute-qid id1 scope scope-subst)))
1121                                                            (((nemo-core 'add-external!) sys) x `(input ,id1 ,qid ,n1))
1122                                                            (list (cons qid qs) (update-subst id1 qid scope-subst))))
1123                                                         ((id1 (or 'as 'AS) x1 (or 'from 'FROM) n1) 
1124                                                          (let ((qid (compute-qid x1 scope scope-subst)))
1125                                                            (((nemo-core 'add-external!) sys) x `(input ,id1 ,qid ,n1))
1126                                                            (list (cons qid qs) (update-subst x1 qid scope-subst))))
1127                                                         )))
1128                                     (list qs scope-subst) lst))
1129                                   (else (nemo:error 'eval-nemo-system-decls 
1130                                                     "import statement must be of the form: "
1131                                                     "input id1 [as x1] ... "))))
1132                           
1133                            ;; exported quantities
1134                            (((or 'output 'OUTPUT) . (and lst (? (lambda (x) (every symbol? x)))))
1135                             (let ((lst1 (map (lambda (x) (compute-qid x scope scope-subst)) lst)))
1136                               (for-each (lambda (x) (((nemo-core 'add-external!) sys) x 'output)) lst1)
1137                               (list qs scope-subst)))
1138                           
1139                            ;; constant during integration
1140                            (((or 'const 'CONST) (and id (? symbol?)) '= (and expr (? expr? )))
1141                             (let* ((qid    (compute-qid id scope scope-subst))
1142                                    (qexpr  (subst-expr (parse-expr expr `(const ,qid)) scope-subst))
1143                                    (qval   (eval-const qexpr)))
1144                               (env-extend! qid '(const) qval)
1145                               (list (cons qid qs) (update-subst id qid scope-subst))
1146                               ))
1147
1148                            ;; state transition complex
1149                            (((or 'reaction 'REACTION) ((and id (? symbol?)) . alst) )
1150                             (let* ((loc          `(reaction ,id))
1151                                    (alst         (filter identity alst))
1152                                    (initial      (lookup-def 'initial alst))
1153                                    (conserve-eq  (alist-ref 'conserve alst))
1154                                    (power        (lookup-def 'power alst))
1155                                    (power-val    (if (expr? power) 
1156                                                      (eval-const (subst-expr (parse-expr power loc) scope-subst))
1157                                                      (nemo:error 'eval-nemo-system-decls 
1158                                                                  "invalid power expression" power
1159                                                                  " in definition of state complex" id)))
1160                                    (transitions
1161                                     (map (lambda (t) 
1162                                            (match-let
1163                                             (((src dst rate1 rate2)
1164                                               (match t
1165                                                      (('-> a b r) (list a b r #f))
1166                                                      ((a '-> b r) (list a b r #f))
1167                                                      (('<-> a b r1 r2) (list a b r1 r2))
1168                                                      ((a '<-> b r1 r2) (list a b r1 r2))
1169                                                      (else (nemo:error "invalid transition " t
1170                                                                        " in definition of state complex " id))
1171                                                      )))
1172                                             (if (and rate1 rate2)
1173                                                 (let ((loc `(,@loc (eq. ,src <-> ,dst))))
1174                                                   `( <-> ,(subst-expr src scope-subst) 
1175                                                          ,(subst-expr dst scope-subst)
1176                                                          ,(subst-expr (parse-expr rate1 loc) scope-subst)
1177                                                          ,(subst-expr (parse-expr rate2 loc) scope-subst)))
1178                                                 (let ((loc `(,@loc (eq. ,src -> ,dst))))
1179                                                   `( -> ,(subst-expr src scope-subst)
1180                                                         ,(subst-expr dst scope-subst)
1181                                                         ,(subst-expr (parse-expr rate1 loc) scope-subst))))))
1182                                          (or (alist-ref 'transitions alst) (list)))))
1183
1184                               (let ((conserve-eq 
1185                                      (and conserve-eq
1186                                           (let ((loc `(,@loc (cons. eqs.))))
1187                                             (map (lambda (eq) 
1188                                                    (if (expr? (third eq))
1189                                                        `(,(first eq) = 
1190                                                          ,(subst-expr (parse-expr (third eq) loc) scope-subst))
1191                                                        (nemo:error 'eval-nemo-system-decls 
1192                                                                    "invalid equation " eq)))
1193                                                  conserve-eq)))))
1194                                 
1195                                 (if (and (list? conserve-eq) (not (every conseq? conserve-eq)))
1196                                     (nemo:error 'env-extend!
1197                                                 ": conservation equation for " id
1198                                                 " must be a linear equation: " conserve-eq))
1199                                 
1200                                 (let* ((qid          (compute-qid id scope scope-subst))
1201                                        (initial-expr (and initial 
1202                                                           (let ((loc `(,@loc (init. eq.))))
1203                                                             (subst-expr (parse-expr initial loc) scope-subst))))
1204                                        (initial-val  (and initial-expr (eval-const initial-expr))))
1205                                   (let ((lst (cons* qid '(reaction) initial-val 
1206                                                     `(power ,power-val) 
1207                                                     (if conserve-eq `(conserve ,@conserve-eq)
1208                                                         `(conserve #f))
1209                                                     `(transitions ,@transitions) alst)))
1210                                     (apply env-extend! lst))
1211                                   (list (cons qid qs) (update-subst id qid scope-subst))))))
1212                           
1213                           
1214                            ;; rate law
1215                            (((or 'd 'D) ((and id (? symbol?))) '= (and expr (? expr?) ) 
1216                              . rest)
1217
1218                             (let* ((qid     (compute-qid id scope scope-subst))
1219                                    (scope-subst1 (update-subst id qid scope-subst))
1220                                    (qexpr   (subst-expr (parse-expr expr `(rate ,id)) scope-subst1))
1221                                    (rest    (filter identity rest))
1222                                    (initial ((lambda (x) (and x (subst-expr (parse-expr x `(rate ,id)) scope-subst)))
1223                                              (lookup-def 'initial rest))))
1224
1225                               (env-extend! qid '(rate) 
1226                                            (and initial (eval-const initial)) 
1227                                            `(rhs ,qexpr))
1228                                           
1229                               (list (cons qid qs) scope-subst1)))
1230                           
1231                            ;; algebraic assignment
1232                            (((and id (? symbol?)) '= (and expr (? expr?) ))
1233                             (let* ((qid    (compute-qid id scope scope-subst))
1234                                    (qexpr  (subst-expr (parse-expr expr `(asgn ,id)) scope-subst)))
1235                               (env-extend! qid '(asgn) 'none `(rhs ,qexpr))
1236                               (list (cons qid qs) (update-subst id qid scope-subst))))
1237                           
1238                            ;; user-defined function
1239                            (((or 'fun 'FUN 'rel 'REL 'defun 'DEFUN) (and id (? symbol?)) 
1240                              (and idlist (? (lambda (x) (every symbol? x)))) 
1241                              (and expr (? expr?)))
1242
1243                             (let* ((qid          (compute-qid id scope scope-subst))
1244                                    (scope-subst1 (fold (lambda (x ax) (subst-remove x ax))
1245                                                        scope-subst
1246                                                        idlist))
1247                                    (qexpr         (subst-expr (parse-expr expr `(defun ,qid)) 
1248                                                               scope-subst1))
1249                                    )
1250                               (((nemo-core 'defun!) sys) qid idlist qexpr)
1251                               (list (cons qid qs) (update-subst id qid scope-subst))))
1252                           
1253                            ;; compiled primitives
1254                            (((or 'prim 'PRIM) id value) 
1255                             (cond ((symbol? id)  (env-extend! id '(prim) value))
1256                                   (else (nemo:error 'eval-nemo-system-decls 
1257                                                        "prim declarations must be of the form: "
1258                                                        "prim id value"))))
1259
1260                            (((or 'sysname 'SYSNAME) name) 
1261                             (if (symbol? name)
1262                                 (hash-table-set! sys (nemo-intern 'name) (SYSNAME name))
1263                                 (nemo:error 'eval-nemo-system-decls
1264                                             "system name must be a symbol")))
1265                           
1266                            (((or 'component 'COMPONENT)
1267                              ((or 'type 'TYPE) typ) 
1268                              ((or 'name 'NAME) name) . lst)
1269
1270                             (let ((name1 (let ((x (and (hash-table-exists? 
1271                                                         sys (or (lookup-def name scope-subst) name))
1272                                                        (hash-table-ref 
1273                                                         sys (or (lookup-def name scope-subst) name)))))
1274                                            (or (and x (nemo:quantity? x)
1275                                                     (cases nemo:quantity x
1276                                                            (LABEL (v)  v)
1277                                                            (else name)))
1278                                                name))))
1279
1280                               (let* ((sym   (fresh "comp"))
1281                                      (scope (or scope sym)))
1282                                 (match-let (((cqs scope-subst1)   (loop lst (list) scope scope-subst)))
1283                                            (let ((comp  (COMPONENT name1 typ cqs scope-subst1)))
1284                                              (hash-table-set! sys sym comp)
1285                                              (list (cons sym qs) scope-subst1))))))
1286
1287                            (((or 'component 'COMPONENT) ((or 'type 'TYPE) typ)  . lst) 
1288                             (let* ((sym   (fresh "comp"))
1289                                    (scope (or scope sym)))
1290                                   (match-let (((cqs scope-subst1)   (loop lst (list) scope scope-subst)))
1291                                      (let ((comp  (COMPONENT sym typ cqs scope-subst1)))
1292                                        (hash-table-set! sys sym comp)
1293                                        (list (cons sym qs) scope-subst1)))))
1294
1295                            (((or 'component 'COMPONENT)  ((or 'name 'NAME) name) '= 
1296                              (and functor-name (? symbol?)) 
1297                              (and args (? list?)))
1298
1299                             (if (and scope scope-subst) 
1300                                 (nemo:error 'eval-nemo-system-decls
1301                                             "functor instantiation is not permitted in nested scope"))
1302
1303                             (match-let
1304                              (((functor-args functor-type functor-lst)
1305                                (let ((x (hash-table-ref sys functor-name)))
1306                                  (or (and (nemo:quantity? x)
1307                                           (cases nemo:quantity x
1308                                                  (FUNCTOR (sym args typ lst)  (list args typ lst))
1309                                                  (else #f)))
1310                                      (nemo:error 'eval-nemo-system-decls! functor-name 
1311                                                  " is not a functor" )))))
1312
1313                              (if (not (<= (length functor-args)  (length args)))
1314                                  (let ((n (length args)))
1315                                    (nemo:error 'eval-nemo-system-decls! "functor " functor-name 
1316                                                " requires at least " (length functor-args) " arguments; "
1317                                                args  " (total " n ") "
1318                                                (if (= n 1) "was" "were") " given" )))
1319
1320                              (match-let
1321                               (((cqs1 scope-subst1)   (loop args (list) name subst-empty)))
1322                                 (let ((cqs1-names (sort (map ->string cqs1) string< ))
1323                                       (args-names (let ((qs (map (lambda (x) 
1324                                                                    (->string (compute-qid x name scope-subst1)) )
1325                                                                    functor-args)))
1326                                                     (sort qs string<))))
1327
1328                                   (if (not (every (lambda (x) (member x cqs1-names string=)) args-names))
1329                                       (nemo:error 'eval-nemo-system-decls! "functor " functor-name 
1330                                              " instantiation did not include required arguments " 
1331                                              (filter (lambda (x) (not (member x cqs1-names string=))) args-names)))
1332                               
1333                                   (match-let
1334                                    (((cqs2 scope-subst2)   (loop functor-lst (list) name scope-subst1)))
1335                                    (let* ((sym    (fresh "comp"))
1336                                           (comp   (COMPONENT name functor-type (append cqs1 cqs2) scope-subst2)))
1337                                      (hash-table-set! sys sym comp)
1338                                     
1339                                      (list (cons sym qs) '())))))))
1340                             
1341                            (((or 'functor 'FUNCTOR) ((or 'name 'NAME) name) ((or 'type 'TYPE) typ)
1342                              (and args (? list?))  '= . lst)
1343
1344                             (if (and scope scope-subst) 
1345                                 (nemo:error 'eval-nemo-system-decls
1346                                             "functor declaration is not permitted in nested scope"))
1347                             (let* ((sym      (string->symbol (->string name)))
1348                                    (functor  (FUNCTOR sym args typ lst)))
1349                               (if (hash-table-exists? sys sym)
1350                                   (nemo:error 'eval-nemo-system-decls! ": functor " sym " already defined"))
1351                               (hash-table-set! sys sym functor)
1352                               (list (cons sym qs) '())))
1353                           
1354                            (((or 'const 'CONST) . _)
1355                             (nemo:error 'eval-nemo-system-decls "declaration: " decl
1356                                         ": constant declarations must be of the form: "
1357                                            "const id = expr"))
1358                           
1359                            ((id '= . _) 
1360                             (nemo:error 'eval-nemo-system-decls 
1361                                         "declaration " decl
1362                                         ": algebraic equations must be of the form: "
1363                                         "id = expr")) 
1364                           
1365                            (((or 'reaction 'REACTION) . _)
1366                             (nemo:error 'eval-nemo-system-decls 
1367                                         "declaration " decl 
1368                                         ": reaction declarations must be of the form: "
1369                                         "reaction (id ...)"))
1370                           
1371                            (((or 'fun 'FUN 'rel 'REL 'defun 'DEFUN) . _) 
1372                             (nemo:error 'eval-nemo-system-decls "function declarations must be of the form: "
1373                                            "fun id (arg1 arg2 ...) expr"))
1374                           
1375                            (((or 'prim 'PRIM) . _) 
1376                             (nemo:error 'eval-nemo-system-decls "prim declarations must be of the form: "
1377                                            "prim id value"))
1378                           
1379                            (((or 'component 'COMPONENT) . _) 
1380                             (nemo:error 'eval-nemo-system-decls "invalid component: " decl))
1381                           
1382                            (((or 'sysname 'SYSNAME) . _) 
1383                             (nemo:error 'eval-nemo-system-decls "system name must be of the form (sysname name)"))
1384                           
1385                            ;; anything that doesn't match is possibly
1386                            ;; declarations recognized by the nemo extension
1387                            ;; modules
1388                            (((and tag (? symbol?))  . lst)
1389                             (match-let (((typ name alst) 
1390                                          (let loop ((lst lst) (ax (list tag)))
1391                                            (if (null? lst)
1392                                                (list (list (car (reverse ax))) #f (cdr (reverse ax)))
1393                                                (match lst
1394                                                       (((? symbol?) . rest) 
1395                                                        (loop (cdr lst) (cons (car lst) ax) ))
1396                                                       (((x . rest)) 
1397                                                          (if (and (symbol? x) (every list? rest))
1398                                                              (list (reverse ax) x rest)
1399                                                              (list (reverse ax) #f lst)))
1400                                                       (else  (list (reverse ax) #f lst)))))))
1401                                       
1402                                        (let* ((name (or name (fresh tag)))
1403                                               (qid  name))
1404                                          (env-extend! qid  typ (if scope (append alst `((scope ,scope))) alst))
1405                                          (list (cons qid qs) (update-subst name qid scope-subst)))))
1406
1407                            (else
1408                             (nemo:error 'eval-nemo-system-decls 
1409                                         "declaration " decl ": "
1410                                         "extended declarations must be of the form: "
1411                                         "declaration (name (properties ...)"
1412                                         ))
1413                            )))
1414           (loop (cdr ds) qs1 scope scope-subst1))))
1415        ))))
1416     res
1417     )))
1418)
Note: See TracBrowser for help on using the repository browser.