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

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

nemo: updated copyright year

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