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

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

nemo: bug fixes in hh and vclamp extension modules

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