source: project/release/4/9ML-toolkit/trunk/eval.scm @ 30917

Last change on this file since 30917 was 30917, checked in by Ivan Raikov, 6 years ago

9ML-toolkit: reformulation of regimes to use ON signal combinator; added LIF UL xml file; fixes to AEIF example

File size: 48.1 KB
Line 
1
2;;
3;; Support for evaluation of NineML.
4;;
5;; Copyright 2010-2012 Ivan Raikov and the Okinawa Institute of
6;; Science and Technology.
7;;
8;; This program is free software: you can redistribute it and/or
9;; modify it under the terms of the GNU General Public License as
10;; published by the Free Software Foundation, either version 3 of the
11;; License, or (at your option) any later version.
12;;
13;; This program is distributed in the hope that it will be useful, but
14;; WITHOUT ANY WARRANTY; without even the implied warranty of
15;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
16;; General Public License for more details.
17;;
18;; A full copy of the GPL license can be found at
19;; <http://www.gnu.org/licenses/>.
20;;
21
22
23(module 9ML-eval
24
25        (eval-verbose 
26         print-eval-env print-type-env print-source-defs 
27         traverse-definitions definition-apply
28         sxml-value->sexpr sexpr->function 
29         sexpr->diagram+initial sexpr->alsys+initial 
30         sigfun-transform sigfun-eval real-eval random-eval
31         print-fragments 
32         html-report 
33         )
34
35        (import scheme chicken )
36
37        (require-library srfi-1 srfi-13 data-structures extras utils files irregex mathh)
38        (import (only srfi-1 fold combine every zip unzip2 filter-map partition delete-duplicates)
39                (only srfi-13 string-downcase string-concatenate)
40                (only data-structures conc compose identity atom? intersperse string-intersperse ->string )
41                (only extras fprintf pp)
42                (only utils system*)
43                (only files make-pathname pathname-directory)
44                (only mathh cosh tanh log10 exp)
45                (only irregex irregex-search irregex-match-num-submatches irregex-match-start-index irregex-match-end-index)
46                )
47
48        (require-library sxml-transforms)
49        (import (prefix sxml-transforms sxml:))
50        (require-library signal-diagram signal-diagram-dynamics)
51        (import (prefix signal-diagram diagram:)
52                (prefix signal-diagram-dynamics diagram:))
53        (require-library algebraic-system)
54        (import (prefix algebraic-system alsys:))
55
56        (require-extension datatype sxpath sxpath-lolevel)
57        (require-extension static-modules miniML miniMLvalue miniMLeval)
58        (require-extension object-graph)
59        (require-extension random-mtzig)
60
61(include "SXML.scm")
62(include "SXML-to-XML.scm")
63
64
65(define random-state (random-mtzig:init))
66
67(define eval-verbose (make-parameter 0))
68
69(define (d fstr . args)
70  (let ([port (current-error-port)])
71    (if (positive? (eval-verbose)) 
72        (begin (apply fprintf port fstr args)
73               (flush-output port) ) )))
74
75(define (random-transform sexpr)
76  (case (car sexpr)
77    ((random)
78     (case (cadr sexpr)
79       ((uniform exponential poisson)
80        (list (string->symbol (sprintf "~A.~A" (car sexpr) (cadr sexpr)))))
81       (else sexpr)))
82    ))
83
84
85(define (sigfun-transform sexpr)
86  (let recur ((sexpr sexpr))
87    (if (pair? sexpr)
88        (case (car sexpr)
89          ((random)   (random-transform sexpr))
90          (else       (cons (car sexpr) (map sigfun-transform (cdr sexpr))))
91          )
92        sexpr)))
93
94
95(define (sexpr->function sexpr) 
96  (let ((sexpr1 (sigfun-transform sexpr)))
97    (diagram:make-function 
98     (diagram:enum-freevars sexpr1 diagram:symbolic-constants '()) 
99     sexpr1)))
100
101
102(define (sxml-path->symbol p)
103  (let recur ((p p) (ax '()))
104    (case (car p)
105      ((path) (recur (cadr p) ax))
106      ((Pident)
107       (let ((id (sxml:text (cdr p))))
108         (let ((ax1 (cons id ax)))
109           (string->symbol (string-concatenate (intersperse  ax1 ".")))
110           )))
111      ((Pdot)
112       (let ((name (sxml:attr p 'name)))
113         (recur (sxml:kid p) (cons (sxml:text name) ax))))
114      (else (error 'sxml-path->symbol "invalid path" p))
115      )))
116   
117
118   
119
120
121(define (sxml-term->sexpr term)
122  (let ((tree
123         (sxml:pre-post-order* 
124          term
125          `(
126            (Const 
127             (
128              (label *preorder* . ,(lambda (tag elems) (string->symbol (sxml:text elems))))
129             
130              (string *preorder* . ,(lambda (tag elems) (sxml:text elems)))
131             
132              (real *preorder* . ,(lambda (tag elems) 
133                                    (let ((v (sxml:text elems)))
134                                      (if (number? v) v (string->number v)))))
135             
136              (nat  *preorder* . ,(lambda (tag elems) 
137                                    (let ((v (sxml:text elems)))
138                                      (if (number? v) v (string->number v)))))
139             
140              (bool *preorder* . ,(lambda (tag elems) (if (string=? (sxml:text elems) "true") #t #f)))
141             
142              (null *preorder* . ,(lambda (tag elems) '()))
143             
144              (*text* . ,(lambda (trigger str) str))
145             
146              (*default* . ,(lambda (tag elems) (cons tag elems)))
147              )
148             
149             . ,(lambda (tag elems)  (car elems)))
150
151            (Longid *preorder* . ,(lambda (tag elems) (sxml-path->symbol (car elems))))
152            (Function *preorder* . ,(lambda (tag elems) 
153                                      (let ((formal (string->symbol (sxml:attr (cons tag elems) 'formal)))
154                                            (body (sxml:kid elems)))
155                                        `(lambda (,formal) ,(sxml-term->sexpr body)))))
156            (Let0 *preorder* . ,(lambda (tag elems)
157                                  (let ((name (string->symbol (sxml:attr (cons tag elems) 'name)))
158                                        (value (sxml:kidn-cadr 'value (cons tag elems)))
159                                        (body (sxml:kidn-cadr 'body (cons tag elems))))
160                                    `(let ((,name ,(sxml-term->sexpr value)))
161                                       ,(sxml-term->sexpr body)))))
162            (Apply *macro* . ,(lambda (tag elems) 
163                                (let ((left (sxml:kidn-cadr 'left (cons tag elems)))
164                                      (right (sxml:kidn-cadr 'right (cons tag elems))))
165                                  `(,left ,right))))
166            (*text* . ,(lambda (trigger str) str))
167            (*default* . ,(lambda (tag elems) (cons tag elems)))
168            ))))
169    tree))
170
171
172(define (sxml-eval-env->sexpr env fin)
173  (let recur ((env env) (ax '()))
174    (if (null? env) 
175        `(let (,ax) ,fin)
176        (let ((en (car env)))
177          (let ((name (string->symbol (sxml:attr en 'name)))
178                (value (sxml-value->sexpr (sxml:kid en))))
179            (let ((en (list name value)))
180              (recur (cdr env) (if value (cons en ax) ax))
181              )))
182        )))
183
184                                         
185(define (sxml-value->sexpr tree)
186    (let* ((tree 
187            (sxml:pre-post-order* 
188            tree
189            `(
190              (Tuple *macro*  .
191                      ,(lambda (tag elems) 
192                         (let ((node (cons tag elems)))
193                           (let ((left (sxml:kidn-cadr 'left node))
194                                 (right (sxml:kidn-cadr 'right node)))
195
196                             (list left right)))
197                         ))
198
199              (Const (
200                      (label . ,(lambda (tag elems) (string->symbol (car elems))))
201                     
202                      (string . ,(lambda (tag elems) (car elems)))
203                     
204                      (real . ,(lambda (tag elems) 
205                                 (let ((v (car elems)))
206                                   (exact->inexact
207                                    (if (number? v) v 
208                                        (string->number v))))))
209                     
210                      (nat  . ,(lambda (tag elems) 
211                                 (let ((v (car elems)))
212                                   (if (number? v) v (string->number v)))))
213                     
214                      (bool . ,(lambda (tag elems) (if (string=? (car elems) "true") #t #f)))
215                     
216                      (null . ,(lambda (tag elems) '()))
217                     
218                      (*text* . ,(lambda (trigger str) str))
219
220                      (*default* . ,(lambda (tag elems) (cons tag elems)))
221
222                      ) . ,(lambda (tag elems) 
223                             (car elems)))
224
225              (Closure .
226                       ,(lambda (tag elems) 
227                          (let ((node (cons tag elems)))
228                            (let ((body (sxml:kidn-cadr 'body node))
229                                  (env  (sxml:kidn-cdr 'env node)))
230                              (let ((term (sxml-term->sexpr body)))
231                                (list (sxml-eval-env->sexpr env term))
232                                ;;                              (list term)
233                                )))
234                          ))
235
236              (null . ,(lambda (tag elems) '()))
237
238              (*text* . ,(lambda (trigger str) str))
239
240              (*default* . ,(lambda (tag elems) (cons tag elems)))
241
242              )))
243
244           (tree
245            (sxml:pre-post-order* 
246             tree
247             `(
248               (signal . ,(lambda (tag elems) (caar elems)))
249               
250               (sigfun . ,(lambda (tag elems) (car elems)))
251
252               (*text* . ,(lambda (trigger str) str))
253
254               (*default* . ,(lambda (tag elems) (cons tag elems)))
255               )))
256
257           (tree
258            (let flatten ((tree tree))
259              (cond ((or (atom? tree) (null? tree) (null? (cdr tree))) tree)
260                    (else (cons (flatten (car tree)) 
261                                (flatten (cadr tree)))))))
262
263             )
264      tree))
265
266
267;; based on SRV:send-reply by Oleg Kiselyov
268(define (print-fragments b)
269  (let loop ((fragments b) (result #f))
270    (cond
271      ((null? fragments) result)
272      ((not (car fragments)) (loop (cdr fragments) result))
273      ((null? (car fragments)) (loop (cdr fragments) result))
274      ((eq? #t (car fragments)) (loop (cdr fragments) #t))
275      ((pair? (car fragments))
276        (loop (cdr fragments) (loop (car fragments) result)))
277      ((procedure? (car fragments))
278        ((car fragments))
279        (loop (cdr fragments) #t))
280      (else
281       (display (car fragments))
282       (loop (cdr fragments) #t)))))
283
284     
285(define (print-eval-env env . rest)
286  (let-optionals rest ((output-type #f)  (component-filter identity))
287          (let ((env (filter-map component-filter env)))
288
289                 (case output-type
290                   ((sxml )
291                    (pp (eval-env->sxml env)))
292
293
294                   ((xml )
295                    (let* ((doc1   `(Toplevel ,@(eval-env->sxml env)))
296                           (doc2  (ensure-xmlns  doc1))
297                           (doc3  (ensure-xmlver doc2)))
298                      (print-fragments (generate-XML `(begin ,doc3)))))
299                       
300                   
301                   (else
302                    (for-each
303                     (lambda (x) 
304                       (let ((id (car x))
305                             (v  (cdr x)))
306                         (pp `(,id ,v))
307                         ))
308                     env))
309                   ))))
310
311
312     
313(define (print-type-env env . rest)
314  (let-optionals rest ((output-type #f) (component-filter identity))
315          (let ((env (filter-map component-filter env)))
316            (case output-type
317              ((sxml )
318               (pp (map (compose modspec->sxml cdr) env)))
319             
320              ((xml )
321               (let* ((doc1   `(Toplevel ,@(map (compose modspec->sxml cdr) env)))
322                      (doc2  (ensure-xmlns doc1))
323                      (doc3  (ensure-xmlver doc2)))
324                 (print-fragments (generate-XML `(begin ,doc3)))))
325             
326              (else  (pp env))
327             
328              ))))
329     
330(define (print-source-defs defs . rest)
331  (let-optionals rest ((output-type #f))
332
333                 (case output-type
334                   ((sxml )
335                    (pp (map moddef->sxml defs)))
336
337                   ((xml )
338                    (let* ((doc1   `(Toplevel ,@(map moddef->sxml defs)))
339                           (doc2  (ensure-xmlns doc1))
340                           (doc3  (ensure-xmlver doc2)))
341                      (print-fragments (generate-XML `(begin ,doc3)))))
342                       
343                   (else  (pp defs))
344
345                   )))
346
347(define (signal-op->mathml op)
348  (case op
349    ((add) 'plus)
350    ((sub) 'minus)
351    ((mul) 'multiply)
352    ((div) 'divide)
353    (else op)))
354
355
356(define (function->nxml f)
357  `(lambda ,(map (lambda (x) `(bvar ,x)) (diagram:function-formals f))
358     ,(signal->nxml (diagram:function-body f))))
359
360
361(define (signal->nxml tree)
362    (let recur ((sexpr tree))
363      (or (and (pair? sexpr)
364               (case (car sexpr)
365
366                 ((signal) 
367                  (let ((sexpr (cdr sexpr)))
368                   
369                    (case (car sexpr)
370                     
371                      ((signal)   
372                       (let ((name (cadr sexpr)))
373                         `(ci ,name)))
374                     
375                      ((realsig)   
376                       (let ((name (cadr sexpr))
377                             (value (caddr sexpr)))
378                         `(ci (@ (type real)) ,name)))
379                     
380                      ((boolsig)   
381                       (let ((name (cadr sexpr))
382                             (value (caddr sexpr)))
383                         `(ci (@ (type real)) ,name)))
384
385                      ((if)
386                       `(if ,(recur (cadr sexpr)) 
387                            ,(recur (caddr sexpr))
388                            ,(recur (cadddr sexpr))))
389                     
390                      ((add sub mul div gte lte gt lt)
391                       (let ((name (signal-op->mathml (car sexpr))))
392                         `(apply (,name) ,(recur (cadr sexpr)) 
393                                 ,(recur (caddr sexpr)))))
394                       
395                      ((neg log ln sin cos cosh tanh exp)
396                       (let ((name (signal-op->mathml (car sexpr))))
397                         `(apply (,name) ,(recur (cadr sexpr)) )))
398
399                      (else (error 'signal->nxml "invalid signal function constructor" sexpr))
400
401                      )))
402
403                 (else (map recur sexpr))
404                 )))
405
406             sexpr))
407
408
409(define (diagram->nxml sexpr)
410
411    (let recur ((sexpr sexpr))
412      (or (and (pair? sexpr)
413               (case (car sexpr)
414                 ((diagram) 
415                  (let ((sexpr (cdr sexpr)))
416                   
417                    (case (car sexpr)
418                     
419                      ((RTRANSITION) 
420                       (let ((f (cadr sexpr)) (fk (caddr sexpr))
421                             (e (cadddr sexpr)) (ek (car (cddddr sexpr))))
422                         `(DiagramLib:Rtransition 
423                           (@ (e ,e) (e ,ek) ,(recur f) ,(recur fk)))
424                         ))
425                     
426                      ((TRANSITION) 
427                       (let ((f (cadr sexpr)) (fk (caddr sexpr))
428                             (e (cadddr sexpr))) 
429                         `(DiagramLib:Transition 
430                           (@ (e ,e) ,(recur f) ,(recur fk)))
431                         ))
432                     
433                      ((TRANSIENT) 
434                       (let ((f (cadr sexpr)) (fk (caddr sexpr))
435                             (e (cadddr sexpr))) 
436                         `(DiagramLib:Transient 
437                           (@ (e ,e) ,(recur f) ,(recur fk)))
438                         ))
439
440                      ((ON) 
441                       (let ((f (cadr sexpr)) 
442                             (e (caddr sexpr))) 
443                         `(DiagramLib:On 
444                           (@ (e ,e) ,(recur f)))
445                         ))
446
447                      ((IDENTITY)       
448                       (let ((f (cadr sexpr)))
449                         `(DiagramLib:Identity ,(recur f))))
450
451                      ((RELATION)           
452                       (let ((n (cadr sexpr)) (x (caddr sexpr))
453                             (f (sexpr->function (cadddr sexpr)))
454                             (d (car (cddddr sexpr))))
455                         `(DiagramLib:Relation (@ (name ,n) (arg ,x))
456                                               ,(function->nxml f)
457                                               ,(recur d))))
458                         
459                      ((PURE)           
460                       (let ((f (sexpr->function (cadr sexpr))))
461                         `(DiagramLib:Function
462                           ,(function->nxml f))))
463
464                      ((GROUP)           
465                       (let ((n1 (cadr sexpr)) (n2 (caddr sexpr)))
466                         `(DiagramLib:Group
467                           ,(recur n1) ,(recur n2))))
468
469                      ((SEQUENCE)       
470                       (let ((n1  (cadr sexpr))
471                             (n2  (caddr sexpr)))
472                         `(DiagramLib:Sequence ,(recur n1) ,(recur n2))
473                         ))
474
475                      ((UNION)         
476                       (let ((n1 (cadr sexpr))
477                             (n2 (caddr sexpr)))
478                         `(DiagramLib:Regime ,(recur n1) ,(recur n2))
479                         ))
480
481                      ((SENSE)         
482                       (let ((sns (cadr sexpr)) (n (caddr sexpr)))
483                         `(DiagramLib:Sense ,(map (lambda (s) `(signal ,s)) sns) 
484                                            ,(recur n))
485                         ))
486                                                   
487                      ((ACTUATE)       
488                       (let ((sns (cadr sexpr)) (n (caddr sexpr)))
489                         `(DiagramLib:Actuate ,(map (lambda (s) `(signal ,s)) sns) 
490                                              ,(recur n))))
491                     
492                      ((ODE)           
493                       (let ((ivar (cadr sexpr)) (dvar (caddr sexpr))
494                             (rhs (cadddr sexpr)))
495                         `(DiagramLib:ODE `(independent_variable ,ivar)
496                                          `(dependent_variable ,dvar)
497                                           ,(recur rhs))))
498
499                      ((ASSIGN)         
500                       (let ((var (cadr sexpr)) 
501                             (rhs (recur (caddr sexpr))))
502                         `(DiagramLib:Assign `(variable ,var)
503                                             ,(recur rhs))))
504
505                     
506                      (else (error 'diagram->nxml "invalid diagram constructor" sexpr))
507                      )))
508
509                 (else (map recur sexpr))
510                 ))
511
512             sexpr)))
513
514
515(define (print-nxml prefix uenv)
516
517    (let (
518          (path-ss
519           `(
520             (path
521              *macro*
522              . ,(lambda (tag elems) elems))
523             
524            (Pident
525             *macro*
526             . ,(lambda (tag elems)
527                  (let ((node (cons tag elems)))
528                    (let ((name (sxml:text node)))
529                      (if (not name) (error 'print-nxml "Pident element requires text content" node))
530                      name))))
531             
532             (Pdot
533              *macro*
534              . ,(lambda (tag elems)
535                   (let ((node (cons tag elems)))
536                     (let ((name (sxml:attr node 'name)))
537                       (if (not name) (error 'print-nxml "Pdot element requires name attribute"))
538                       `(,(sxml:kids node) "." ,name)))))
539
540             
541             ,@sxml:alist-conv-rules*
542             ))
543
544
545          (moddef-ss
546           
547           `(
548             (Type_def
549              *macro*
550              . ,(lambda (tag elems)
551                   (let ((node (cons tag elems)))
552                     (let ((name (sxml:attr node 'name))
553                           (deftype (sxml:kidn* 'deftype node)))
554                       `(Type (@ (name ,name)) ,deftype)))
555                   ))
556
557             (Component
558              *macro*
559              . ,(lambda (tag elems)
560                   (let ((node (cons tag elems)))
561                       (let ((name (sxml:attr node 'name))
562                             (members ((sxpath '(Component (*or* Val Component))) `(*TOP* ,node))))
563                         `(Namespace (@ (name ,name)) . ,members)
564                         ))
565                   ))
566
567             (Val
568              *macro*
569              . ,(lambda (tag elems)
570                   (let ((node (cons tag elems)))
571                     (let* ((name (sxml:attr node 'name))
572                            (value (sxml:kid node))
573                            (tuple-label ((sxpath '(Tuple left Const label *text*)) `(*TOP* ,value))))
574
575                       (if (not name) (error 'type-env-report "binding element requires name attribute"))
576
577                       (cond ((and (pair? tuple-label) (equal? (car tuple-label) "diagram")) ;; value is a diagram
578                              (let* ((diagram-id (gensym 'diagram)))
579                                `(Binding (@ (name ,name)) ,(diagram->nxml (sxml-value->sexpr value)))))
580
581                             (else
582                              `(Binding (@ (name ,name))  ,value)))
583                       ))))
584             
585          ,@sxml:alist-conv-rules*
586
587          ))
588
589
590          (term-ss
591           `(
592
593             (Longid 
594              *macro*
595              . ,(lambda (tag elems)
596                   (let ((node (cons tag elems)))
597                     (sxml:kids node)
598                     )))
599
600             (Function
601              *macro*
602              . ,(lambda (tag elems)
603                   (let ((node (cons tag elems)))
604                     (let ((formal (sxml:attr node 'formal))
605                           (body   (sxml:kid node)))
606                       `(Term:Function (@ (x ,formal)) ,body)
607                       ))))
608
609
610             (Let0 
611              *macro*
612              . ,(lambda (tag elems)
613                   (let ((node (cons tag elems)))
614                     (let ((name (sxml:attr node 'name))
615                           (value (sxml:kidn-cadr 'value node))
616                           (body (sxml:kidn-cadr 'body node)))
617                       `(Term:Let (@ (name ,name)) (value ,value) (body ,body))
618                       ))))
619
620             (Apply 
621              *macro*
622              . ,(lambda (tag elems)
623                   (let ((node (cons tag elems)))
624                     (let ((left (sxml:kidn-cdr 'left node))
625                           (right (sxml:kidn-cdr 'right node)))
626                       `(Term:Apply (left ,left) (right ,right))
627                       ))))
628             
629             ,@sxml:alist-conv-rules*
630             ))
631
632
633          )
634
635  (let ( 
636        (filename    (string-append prefix ".xml"))
637        (source-defs (car uenv))
638        (type-env    (cadr uenv))
639        (eval-env    (caddr uenv)))
640
641    (let ((eval-env-sxml (eval-env->sxml eval-env))
642          (eval-env-rulesets `(,moddef-ss
643                               ,term-ss
644                               ,path-ss
645                               )))
646     
647      (let* (
648             (eval-env-sxml  (sxml-transform eval-env-sxml eval-env-rulesets))
649             (content        `(Toplevel ,eval-env-sxml))
650             )
651       
652        (with-output-to-file filename
653          (lambda () (print-fragments (generate-XML content))))
654           
655        )))
656  ))
657
658
659(define (realsig-value x)
660  (cond ((number? x) x)
661        ((equal? 'realsig (car x)) (caddr x))
662        (else (error 'realsig-value "invalid real signal" x))))
663
664(define (realsig-name x)
665  (if (and (pair? x) (equal? 'realsig (car x))) (cadr x)
666      (error 'realsig-name "invalid real signal" x)))
667
668(define (boolsig-value x)
669  (cond ((boolean? x) x)
670        ((equal? 'boolsig (car x)) (caddr x))
671        (else (error 'boolsig-value "invalid boolean signal" x))))
672
673(define (boolsig-name x)
674  (if (and (pair? x) (equal? 'boolsig (car x))) (cadr x)
675      (error 'boolsig-value "invalid boolean signal" x)))
676
677
678
679(define (sigfun-eval sexpr)
680  (let recur ((sexpr sexpr))
681    (if (pair? sexpr)
682        (case (car sexpr)
683          ((realconst)   (let ((value (cadr sexpr))) (real-eval value)))
684          ((boolconst)   (let ((value (cadr sexpr))) value))
685          ((realsig)     (let ((name (cadr sexpr))
686                               (value (recur (caddr sexpr))))
687                           (if (not (number? value)) (error 'realsig "real signal value is not a real" name value))
688                           `(realsig ,name ,value)))
689          ((boolsig)   (let ((name (cadr sexpr))
690                             (value0 (recur (caddr sexpr))))
691                         (let ((value (if (boolean? value0) value0
692                                          (else (error 'boolsig "boolean signal value is not a boolean" name value0)))))
693                           `(boolsig ,name ,value))))
694          ((neg)       (let ((x (recur (cadr sexpr))))
695                         (- (realsig-value x))))
696          ((log)       (let ((x (recur (cadr sexpr))))
697                         (log10 (realsig-value x))))
698          ((ln)        (let ((x (recur (cadr sexpr))))
699                         (log (realsig-value x))))
700          ((cosh)      (let ((x (recur (cadr sexpr))))
701                         (cosh (realsig-value x))))
702          ((tanh)      (let ((x (recur (cadr sexpr))))
703                             (tanh (realsig-value x))))
704          ((exp)       (let ((x (recur (cadr sexpr))))
705                         (exp (realsig-value x))))
706          ((+)       (let ((x (recur (cadr sexpr)))
707                           (y (recur (caddr sexpr))))
708                       (+ (realsig-value x) (realsig-value y))))
709          ((-)       (let ((x (recur (cadr sexpr))) 
710                           (y (recur (caddr sexpr))))
711                       (- (realsig-value x) (realsig-value y))))
712          ((*)       (let ((x (recur (cadr sexpr))) 
713                           (y (recur (caddr sexpr))))
714                       (* (realsig-value x) (realsig-value y))))
715          ((/)       (let ((x (recur (cadr sexpr))) 
716                           (y (recur (caddr sexpr))))
717                       (/ (realsig-value x) (realsig-value y))))
718          ((>=)       (let ((x (recur (cadr sexpr))) 
719                            (y (recur (caddr sexpr))))
720                        (>= (realsig-value x) (realsig-value y))))
721          ((<=)       (let ((x (recur (cadr sexpr))) 
722                            (y (recur (caddr sexpr))))
723                        (<= (realsig-value x) (realsig-value y))))
724          ((>)        (let ((x (recur (cadr sexpr))) 
725                            (y (recur (caddr sexpr))))
726                        (> (realsig-value x) (realsig-value y))))
727          ((<)        (let ((x (recur (cadr sexpr))) 
728                            (y (recur (caddr sexpr))))
729                        (< (realsig-value x) (realsig-value y))))
730          (else (map recur sexpr))
731          ) 
732        sexpr)))
733
734
735
736(define (real-eval sexpr)
737  (let recur ((sexpr sexpr))
738    (if (number? sexpr) sexpr
739        (case (car sexpr)
740          ((real)      (recur (cdr sexpr)))
741          ((random)    (random-eval (cdr sexpr)))
742          ((neg)       (let ((x (recur (cadr sexpr))))
743                         (- (real-eval x))))
744          ((log)       (let ((x (recur (cadr sexpr))))
745                         (log10 (real-eval x))))
746          ((ln)        (let ((x (recur (cadr sexpr))))
747                         (log (real-eval x))))
748          ((cosh)      (let ((x (recur (cadr sexpr))))
749                         (cosh (real-eval x))))
750          ((tanh)      (let ((x (recur (cadr sexpr))))
751                         (tanh (real-eval x))))
752          ((exp)       (let ((x (recur (cadr sexpr))))
753                         (exp (realsig-value x))))
754          ((+)       (let ((x (recur (cadr sexpr)))
755                           (y (recur (caddr sexpr))))
756                       (+ (real-eval x) (real-eval y))))
757          ((-)       (let ((x (recur (cadr sexpr))) 
758                           (y (recur (caddr sexpr))))
759                           (- (real-eval x) (real-eval y))))
760          ((*)       (let ((x (recur (cadr sexpr))) 
761                           (y (recur (caddr sexpr))))
762                           (* (real-eval x) (real-eval y))))
763          ((/)       (let ((x (recur (cadr sexpr))) 
764                               (y (recur (caddr sexpr))))
765                       (/ (real-eval x) (real-eval y))))
766          ((>=)       (let ((x (recur (cadr sexpr))) 
767                            (y (recur (caddr sexpr))))
768                        (>= (real-eval x) (real-eval y))))
769          ((<=)       (let ((x (recur (cadr sexpr))) 
770                            (y (recur (caddr sexpr))))
771                        (<= (real-eval x) (real-eval y))))
772          ((>)        (let ((x (recur (cadr sexpr))) 
773                            (y (recur (caddr sexpr))))
774                        (> (real-eval x) (real-eval y))))
775          ((<)        (let ((x (recur (cadr sexpr))) 
776                            (y (recur (caddr sexpr))))
777                        (< (real-eval x) (real-eval y))))
778          ((toNat)    (let ((v (recur (cadr sexpr))))
779                        (inexact->exact (abs (round v)))))
780          (else (map recur sexpr))
781          ))
782    ))
783
784
785(define (random-eval sexpr)
786  (let recur ((sexpr sexpr))
787    (if (number? sexpr) sexpr
788        (case (car sexpr)
789
790          ((random)     
791           (recur (cdr sexpr)))
792
793          ((uniform)     
794           (let ((low   (real-eval (cadr sexpr)))
795                 (high  (real-eval (caddr sexpr))))
796             (let ((rlo (if (< low high) low high))
797                   (rhi (if (< low high) high low))) 
798               (let ((delta (+ 1 (- rhi rlo)))
799                     (v (random-mtzig:randu! random-state)))
800                 (+ rlo (floor (* delta v)))
801                 ))
802             ))
803
804          ((normal)     
805           (let ((mean   (real-eval (cadr sexpr)))
806                 (stddev (sqrt (real-eval (caddr sexpr)))))
807             (let ((v (random-mtzig:randn! random-state)))
808               (+ (* v stddev) mean))))
809
810          ((exponential) 
811           (let ((mean   (real-eval (cadr sexpr))))
812             (let ((v (random-mtzig:rande! random-state)))
813               (* v mean))))
814
815          (else (error 'random-eval "unknown random constructor" sexpr))
816          ))
817    ))
818
819
820(define (sexpr->diagram+initial h sexpr)
821
822    (define initenv  (make-parameter '()))
823    (define fieldenv  (make-parameter '()))
824
825    (let ((diagram
826           (let recur ((sexpr sexpr))
827
828             (if (pair? sexpr)
829                 (case (car sexpr)
830
831                   ((generator)
832                    (let ((sexpr (cdr sexpr)))
833                      (case (car sexpr)
834                        ((poisson)
835                         (let ((rate (recur (cadr sexpr)))
836                               (t (recur (caddr sexpr)))
837                               (h (recur (cadddr sexpr))))
838                           (initenv (append `( (spike . #f) (spikeCount . 0.0) 
839                                               (st . (generator RandomInit))
840                                               (zt . (generator ZigInit)) )
841                                            (initenv)))
842                           (diagram:SENSE `(,t ,h spike spikeCount rate st zt)
843                                          (diagram:PRIM (diagram:make-prim 
844                                                         `(,t st zt)
845                                                         `(,t ,h spike spikeCount rate st zt)
846                                                         `(,t spike spikeCount st zt)
847                                                         `(spike)
848                                                         `(PoissonStep ,rate ,t ,h st zt)
849                                                         '(st zt)
850                                                         '(PoissonInit)
851                                                         )
852                                                        'poisson))
853                           ))
854                        (else
855                         (error 'sexpr->diagram "invalid generator" sexpr))
856
857                        )))
858
859                   ((diagram) 
860                    (let ((sexpr (cdr sexpr)))
861
862                      (case (car sexpr)
863                       
864                        ((PURE)           (let ((f (sexpr->function (cadr sexpr)))) (diagram:PURE f)))
865                        ((GROUP)          (diagram:UNION (recur (cadr sexpr)) (recur (caddr sexpr))))
866                        ((IDENTITY)       (diagram:IDENTITY (recur (cadr sexpr))))
867                        ((SEQUENCE)       (diagram:SEQUENCE (recur (cadr sexpr)) (recur (caddr sexpr))))
868                        ((UNION)          (diagram:UNION (recur (cadr sexpr)) (recur (caddr sexpr))))
869                        ((SENSE)          (diagram:SENSE (cadr sexpr) (recur (caddr sexpr))))
870                        ((ACTUATE)        (diagram:ACTUATE (cadr sexpr) (recur (caddr sexpr))))
871                        ((ON)             (let ((e1 (recur (cadr sexpr)))
872                                                (e2 (recur (caddr sexpr))))
873                                            (diagram:ON e1 e2)))
874                        ((TRANSIENT)      (diagram:TRANSIENT (recur (cadr sexpr)) (recur (caddr sexpr))
875                                                             (recur (cadddr sexpr))))
876                        ((TRANSITION)     (diagram:TRANSITION (recur (cadr sexpr)) (recur (caddr sexpr))
877                                                              (recur (cadddr sexpr))))
878                        ((RTRANSITION)    (diagram:RTRANSITION (recur (cadr sexpr)) 
879                                                               (recur (caddr sexpr))
880                                                               (recur (cadddr sexpr))
881                                                               (recur (cadddr (cdr sexpr)))
882                                                               (recur (cadddr (cddr sexpr)))
883                                                               ))
884                       
885                        ((ODE)            (let ((deps  (map recur (cadr sexpr)))
886                                                (indep (recur (caddr sexpr)))
887                                                (tstep (recur (cadddr sexpr)))
888                                                (rhs   (cadddr (cdr sexpr))))
889                                           
890                                            (if (not (equal? tstep h))
891                                                (error 'sexpr->diagram "mismatch between independent variable step of ODE and IVP" h tstep))
892                                           
893                                            (let-values (((rhs-list relation-list)
894                                                          (let rhs-recur ((rhs-list '()) (relation-list '()) (rhs rhs))
895                                                            (case (car rhs)
896                                                              ((pure)
897                                                               (let ((d (cdr rhs)))
898                                                                 (case (car d)
899                                                                   ((GROUP) 
900                                                                    (let-values (((rhs-list1 relation-list1) 
901                                                                                  (rhs-recur rhs-list relation-list (cadr d))))
902                                                                      (rhs-recur rhs-list1 relation-list1 (caddr d))))
903                                                                   ((PURE)     
904                                                                    (let ((expr (recur (cadr d))))
905                                                                      (values (cons expr rhs-list) relation-list)))
906                                                                   ((RELATION) 
907                                                                    (let ((r (cdr d)))
908                                                                      (rhs-recur rhs-list 
909                                                                                 (cons (list (car r) (list (cadr r)) (recur (caddr r))) 
910                                                                                       relation-list) 
911                                                                                 (cadddr r))))
912                                                                   (else (error 'sexpr->diagram "invalid ODE subelement" d)))))
913                                                              (else
914                                                               (error 'sexpr->diagram "invalid ODE subelement" rhs))))))
915                                              (diagram:make-dae-system h indep (append (reverse relation-list) (zip deps (reverse rhs-list))))
916                                              )))
917                       
918                        ((ASSIGN)         (let ((vars  (cadr sexpr))
919                                                (rhs   (caddr sexpr)))
920                                            (let ((rhs-list
921                                                   (let rhs-recur ((rhs-list '()) (rhs rhs))
922                                                     (case (car rhs)
923                                                       ((pure)
924                                                        (let ((d (cdr rhs)))
925                                                          (case (car d)
926                                                            ((GROUP)  (rhs-recur (rhs-recur rhs-list  (cadr d)) (caddr d)))
927                                                            ((PURE)   (cons (recur (cadr d)) rhs-list))
928                                                            (else (error 'sexpr->diagram "invalid ASSIGN subelement" d)))))
929                                                       (else (error 'sexpr->diagram "invalid ASSIGN subelement" rhs))))))
930                                             
931                                              (diagram:make-assign-system (zip vars (reverse rhs-list))))))
932                       
933                        ((RELATION)      (let ((n (cadr sexpr)) (x (caddr sexpr))
934                                               (f (sexpr->function (recur (cadddr sexpr)))))
935                                           (diagram:RELATION (list n x f) (recur (cadddr (cdr sexpr))))))
936                       
937                        (else             (error 'sexpr->diagram "invalid diagram constructor" sexpr))
938                        )))
939                   
940                   ((relation)    (let ((op (cadr sexpr))) (cons op (map recur (cddr sexpr)))))
941                   
942                   ((realfield)   (let ((name (cadr sexpr))
943                                        (value (caddr sexpr)))
944                                    (initenv (cons (cons name value) (initenv)))
945                                    (fieldenv (cons (cons name value) (fieldenv)))
946                                    name))
947
948                   ((realsig)     (let ((name (cadr sexpr))
949                                        (value (caddr sexpr)))
950                                    (initenv (cons (cons name value) (initenv)))
951                                    name))
952
953                   ((realconst)   (cadr sexpr))
954                   
955                   ((boolsig)   (let ((name (cadr sexpr))
956                                      (value0 (caddr sexpr)))
957                                  (let ((value (if (boolean? value0) value0
958                                                   (case (car value0) 
959                                                     ((boolconst) (cadr value0))
960                                                     (else (error 'boolsig "boolean signal value is not a boolean" name value0))))))
961                                    (initenv (cons (cons name value) (initenv)))
962                                    name)))
963
964                   ((boolconst)   (if (cadr sexpr) 'true 'false))
965                   
966                   (else (map recur sexpr)))
967
968                 sexpr)
969          )))
970    (initenv (delete-duplicates (initenv) (lambda (x y) (equal? (car x) (car y)))))
971    (fieldenv (delete-duplicates (fieldenv) (lambda (x y) (equal? (car x) (car y)))))
972    (list diagram (initenv) (fieldenv))
973
974    ))
975
976
977(define (sexpr->alsys+initial sexpr)
978
979    (define initenv  (make-parameter '()))
980    (define fieldenv  (make-parameter '()))
981
982    (let ((alsys
983           (let recur ((sexpr sexpr))
984             (if (pair? sexpr)
985                 (case (car sexpr)
986
987                   ((alsys) 
988                    (let ((sexpr (cdr sexpr)))
989
990                      (case (car sexpr)
991                       
992                        ((EQUATION)         (let ((var  (cadr sexpr))
993                                                  (rhs  (sexpr->function (recur (caddr sexpr)))))
994                                              (alsys:EQUATION var rhs)))
995                       
996                        ((UNION)          (alsys:UNION (recur (cadr sexpr)) (recur (caddr sexpr))))
997                       
998                        ((RELATION)      (let ((n (cadr sexpr)) (x (caddr sexpr))
999                                               (f (sexpr->function (recur (cadddr sexpr)))))
1000                                           (alsys:RELATION (list n x f) (recur (cadddr (cdr sexpr))))))
1001                       
1002                        (else             (error 'sexpr->alsys "invalid algebraic system constructor" sexpr))
1003                        )))
1004                   
1005                   ((relation)    (let ((op (cadr sexpr))) (cons op (map recur (cddr sexpr)))))
1006                   
1007                   ((realfield)   (let ((name (cadr sexpr))
1008                                        (value (caddr sexpr)))
1009                                    (initenv (cons (cons name value) (initenv)))
1010                                    (fieldenv (cons (cons name value) (fieldenv)))
1011                                    name))
1012
1013                   ((realsig)     (let ((name (cadr sexpr))
1014                                        (value (caddr sexpr)))
1015                                    (initenv (cons (cons name value) (initenv)))
1016                                    name))
1017
1018                   ((realconst)   (cadr sexpr))
1019                   
1020                   ((boolsig)   (let ((name (cadr sexpr))
1021                                      (value0 (caddr sexpr)))
1022                                  (let ((value (if (boolean? value0) value0
1023                                                   (case (car value0) 
1024                                                     ((boolconst) (cadr value0))
1025                                                     (else (error 'boolsig "boolean signal value is not a boolean" name value0))))))
1026                                    (initenv (cons (cons name value) (initenv)))
1027                                    name)))
1028
1029                   ((boolconst)   (if (cadr sexpr) 'true 'false))
1030                   
1031                   (else (map recur sexpr)))
1032                 sexpr)
1033          )))
1034    (initenv (delete-duplicates (initenv) (lambda (x y) (equal? (car x) (car y)))))
1035    (fieldenv (delete-duplicates (fieldenv) (lambda (x y) (equal? (car x) (car y)))))
1036    (list alsys (initenv) (fieldenv))
1037
1038    ))
1039
1040   
1041 
1042
1043(define variable-names (make-parameter '()))
1044
1045
1046(define (html-report prefix uenv #!key (value-hook #f))
1047
1048  (let-syntax
1049      (
1050       (line (syntax-rules ()
1051               ((_ x ...) (list (list 'span '(@ (class "hl_line")) `x ...) nl))))
1052       (code (syntax-rules ()
1053               ((_ x ...) (list 'code '(@ (class "hl_code")) `x ...))))
1054       )
1055
1056    (let (
1057          (path-ss
1058           `(
1059             (path
1060              *macro*
1061              . ,(lambda (tag elems) elems))
1062             
1063            (Pident
1064             *macro*
1065             . ,(lambda (tag elems)
1066                  (let ((node (cons tag elems)))
1067                    (let ((name (sxml:text node)))
1068                      (if (not name) (error 'html-report "Pident element requires text content" node))
1069                      name))))
1070             
1071             (Pdot
1072              *macro*
1073              . ,(lambda (tag elems)
1074                   (let ((node (cons tag elems)))
1075                     (let ((name (sxml:attr node 'name)))
1076                       (if (not name) (error 'html-report "Pdot element requires name attribute"))
1077                       `(,(sxml:kids node) "." ,name)))))
1078
1079             
1080             ,@sxml:alist-conv-rules*
1081             ))
1082
1083          (simple-type-ss
1084           `(
1085             (Tcon
1086              *macro*
1087              . ,(lambda (tag elems)
1088                   (let ((node (cons tag elems)))
1089                     (let ((path (sxml:kidn-cadr 'path node))
1090                           (ts (map cdr (sxml:kidsn 't node))))
1091                       (cond
1092                        ((equal? path `(pident (@ (name "->"))))
1093                         `(,(car ts) " -> " ,(cadr ts)))
1094                        ((pair? ts)
1095                         `("(" ,@(intersperse ts " ") ") " ,path))
1096                        (else path))))))
1097             
1098             
1099             (Tvar
1100              *macro*
1101              . ,(lambda (tag elems)
1102                   (let ((node (cons tag elems)))
1103                     (let ((repres (sxml:kidn 'repres node)))
1104                       (cond
1105                        (repres (cdr repres))
1106                        (else (let* ((name (or (assq elems (variable-names))))
1107                                     (name (if (not name)
1108                                               (let* ((n  (+ 1 (length (variable-names))))
1109                                                     (s  (string-append "'t" (number->string n))))
1110                                                 (variable-names (cons (list n s) (variable-names)))
1111                                                 s))))
1112                                name)))))))
1113             
1114             ,@sxml:alist-conv-rules*
1115             ))
1116
1117          (const-ss
1118           `(
1119
1120             (Const
1121              *macro*
1122              . ,(lambda (tag elems) 
1123                   (let ((node (cons tag elems)))
1124                     (sxml:kids node))))
1125
1126             (label 
1127              *macro*
1128              . ,(lambda (tag elems)
1129                   (let ((node (cons tag elems)))
1130                     (code ,(sxml:text node)))))
1131                   
1132             ,@sxml:alist-conv-rules*
1133             ))
1134           
1135          (typedef-ss
1136           `(
1137             (Valtype
1138              *macro* 
1139              . ,(lambda (tag elems)
1140                   (let ((body (sxml:kidn-cdr 'body elems)))
1141                     body)
1142                   ))
1143
1144             (Deftype 
1145               *macro*
1146               . ,(lambda (tag elems)
1147                    (let ((node (cons tag elems)))
1148                      (let ((b (sxml:kidn-cdr 'body node)))
1149                        b)
1150                      )))
1151
1152             ,@sxml:alist-conv-rules*
1153
1154             ))
1155         
1156          (modspec-ss
1157           `(
1158             (Value_sig 
1159              *macro*
1160              . ,(lambda (tag elems)
1161                   (let ((node (cons tag elems)))
1162                     (let ((name (sxml:attr node 'name)))
1163                       (if (not name) (error 'type-env-report "value_sig element requires name attribute"))
1164                       (line "Value " (b ,name) " : " ,(sxml:kids node))))))
1165             
1166             
1167             (Type_sig 
1168              *macro*
1169              . ,(lambda (tag elems)
1170                   (let ((node (cons tag elems)))
1171                     (let ((name (sxml:attr node 'name)))
1172                       (if (not name) (error 'type-env-report "type_sig element requires name attribute"))
1173                       (line "Type " (b ,name) " = " ,(sxml:kids node))))))
1174             
1175             (Typedecl
1176              *macro* 
1177              . ,(lambda (tag elems)
1178                   (let ((node (cons tag elems)))
1179                     (let ((m (sxml:kidn* 'manifest node)))
1180                       m)
1181                     )))
1182             
1183             (manifest 
1184              *macro*
1185              . ,(lambda (tag elems)
1186                   (let ((node (cons tag elems)))
1187                     (let ((dt (sxml:kidn* 'deftype node)))
1188                       dt)
1189                     )))
1190             
1191             (Module_sig 
1192              *macro*
1193              . ,(lambda (tag elems)
1194                   (let ((node (cons tag elems)))
1195                     (let ((name (sxml:attr node 'name)))
1196                       (if (not name) (error 'type-env-report "module_sig element requires name attribute"))
1197                       `(,(line "Component signature " (b ,name) " : ") 
1198                         ,(sxml:kids node))))))
1199             
1200             (Signature
1201              *macro* 
1202              . ,(lambda (tag elems)
1203                   (let ((node (cons tag elems)))
1204                     `(ul . ,(map (lambda (x) `(li ,x)) (sxml:kids node ))))))
1205             
1206             
1207             (Functorty
1208              *macro* 
1209              . ,(lambda (tag elems)
1210                   (let ((node (cons tag elems)))
1211                     (let ((name (sxml:attr node 'name)))
1212                       (if (not name) (error 'type-env-report "functorty elements requires name attribute"))
1213                       `("Functor " (b ,name)
1214                         (ul . ,(map (lambda (x) `(li ,x)) (sxml:kids node ))))))))
1215             
1216             
1217             ,@sxml:alist-conv-rules*
1218             ))
1219
1220          (moddef-ss
1221           
1222           `(
1223             (Type_def
1224              *macro*
1225              . ,(lambda (tag elems)
1226                   (let ((node (cons tag elems)))
1227                     (let ((name (sxml:attr node 'name))
1228                           (deftype (sxml:kidn* 'deftype node)))
1229                       (code  "type " ,name " = " ,deftype)
1230                   ))))
1231
1232             (Component
1233              *macro*
1234              . ,(lambda (tag elems)
1235                   (let ((node (cons tag elems)))
1236                     (let ((name (sxml:attr node 'name)))
1237                       (if (not name) (error 'type-env-report "component element requires name attribute"))
1238                       `(,(line "Component " (b ,name) " = ") (ul . ,(map (lambda (x) `(li ,x)) (sxml:kids node))))))))
1239
1240             (Val
1241              *macro*
1242              . ,(lambda (tag elems)
1243                   (let ((node (cons tag elems)))
1244                     (let* ((name (sxml:attr node 'name))
1245                            (value (sxml:kid node))
1246                            (tuple-label ((sxpath '(Tuple left Const label *text*)) `(*TOP* ,value))))
1247
1248                       (if (not name) (error 'type-env-report "binding element requires name attribute"))
1249
1250                       (cond ((and value-hook (pair? tuple-label) (value-hook prefix name (car tuple-label) value)) =>
1251                              (lambda (x) `(,(line "binding " (b ,name) " = ") (p ,x))))
1252
1253                             (else
1254                              `(,(line "binding " (b ,name) " = ") ,value)))
1255                       ))))
1256
1257             (Prim
1258              *macro*
1259              . ,(lambda (tag elems) 
1260                  (code "primitive procedure")))
1261             
1262             (null
1263              *macro*
1264              . ,(lambda (tag elems) 
1265                  (code "null")))
1266             
1267             (Tuple
1268              *macro*
1269              . ,(lambda (tag elems)
1270                   (let ((node (cons tag elems)))
1271                     (let ((left (sxml:kidn-cadr 'left node))
1272                           (right (sxml:kidn-cdr 'right node)))
1273                        `( " ( "  ,left " " ,@right " ) " )
1274                        ))))
1275             
1276             (Closure
1277              *macro*
1278              . ,(lambda (tag elems)
1279                   (let ((node (cons tag elems)))
1280                     (let ((body (sxml:kidn-cdr 'body node))
1281                           (env (sxml:kidn-cdr 'env node)))
1282                       `(,(line "Closure: ") ,@body ,(line "where ") ,env)))))
1283
1284             
1285             
1286          ,@sxml:alist-conv-rules*
1287
1288          ))
1289
1290
1291          (term-ss
1292           `(
1293
1294             (Longid 
1295              *macro*
1296              . ,(lambda (tag elems)
1297                   (let ((node (cons tag elems)))
1298                     (sxml:kids node))))
1299
1300             (Function
1301              *macro*
1302              . ,(lambda (tag elems)
1303                   (let ((node (cons tag elems)))
1304                     (let ((formal (sxml:attr node 'formal)))
1305                       (let-values (((formals body)
1306                                     (let recur ((formals (list formal)) 
1307                                                 (body (sxml:kid node)))
1308                                       (case (car body) 
1309                                         ((function)
1310                                          (recur 
1311                                           (cons (sxml:attr body 'formal) formals)
1312                                           (sxml:kid body)))
1313                                         (else (values (reverse formals) body))))))
1314                         `(,(line (code "Function " ,(intersperse formals " ") " => ")) 
1315                           ,body))
1316                       ))))
1317
1318
1319             (Let0 
1320              *macro*
1321              . ,(lambda (tag elems)
1322                   (let ((node (cons tag elems)))
1323                     (let ((name (sxml:attr node 'name))
1324                           (value (sxml:kidn-cadr 'value node))
1325                           (body (sxml:kidn-cadr 'body node)))
1326                       `(,(line (code "binding " (b ,name) " = ") ,value)
1327                         ,body)))))
1328             
1329             (Apply 
1330              *macro*
1331              . ,(lambda (tag elems)
1332                   (let ((node (cons tag elems)))
1333                     (let ((left (sxml:kidn-cdr 'left node))
1334                           (right (sxml:kidn-cdr 'right node)))
1335                       (code ,left " (" ,right ") ")))))
1336             
1337             ,@sxml:alist-conv-rules*
1338             ))
1339
1340
1341          )
1342
1343  (let ((filename (string-append prefix ".html"))
1344        (source-defs (car uenv))
1345        (type-env    (cadr uenv))
1346        (eval-env    (caddr uenv)))
1347
1348
1349    (let ((type-env-sxml (map (compose modspec->sxml cdr) type-env))
1350          (eval-env-sxml (eval-env->sxml eval-env))
1351          (type-env-rulesets `(,modspec-ss
1352                               ,typedef-ss
1353                               ,simple-type-ss
1354                               ,path-ss
1355                               ))
1356          (eval-env-rulesets `(,moddef-ss
1357                               ,modspec-ss
1358                               ,typedef-ss
1359                               ,term-ss
1360                               ,const-ss
1361                               ,simple-type-ss
1362                               ,path-ss
1363                               )))
1364     
1365      (with-output-to-file filename
1366        (lambda ()
1367          (let* ((type-env-shtml (sxml-transform type-env-sxml type-env-rulesets))
1368                 (eval-env-shtml (sxml-transform eval-env-sxml eval-env-rulesets))
1369                 (content        `(html:begin ,prefix (body (section* 1 ,prefix)
1370                                                            (toc)
1371                                                            (section 2 "Type environment") 
1372                                                            ,type-env-shtml 
1373                                                            (section 2 "Value environment")
1374                                                            ,eval-env-shtml
1375                                                            )))
1376                 (internal-link
1377                  (lambda (r)
1378                    (sxml:post-order 
1379                     r
1380                     `(
1381                       (*default* . ,(lambda (tag elems) (cons tag elems)))
1382                       
1383                       (*text* . ,(lambda (trigger str) 
1384                                    (string-substitute* (string-downcase str) 
1385                                                        '(("[^A-Za-z0-9_ \t-]" . "")
1386                                                         ("[ \t]+" . "-"))))))
1387                     )))
1388                 )
1389
1390            (print-fragments
1391             (generate-XML content
1392                           rulesets:
1393                           `(((html:begin . ,(lambda (tag elems)
1394                                               (let ((title (car elems))
1395                                                     (elems (cdr elems)))
1396                                                 (list "<HTML><HEAD><TITLE>" title "</TITLE></HEAD>"
1397                                                       "<meta http-equiv=\"Content-Style-Type\" content=\"text/css\" />"
1398                                                       "<meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\" />"
1399
1400                                                       "<link rel=\"stylesheet\" type=\"text/css\" href=\"highlight.css\" />"
1401                                                       elems
1402                                                       "</HTML>"))))
1403                              (section
1404                               *macro*
1405                               . ,(lambda (tag elems)
1406                                    (let ((level (car elems))
1407                                          (head-word (cadr elems))
1408                                          (contents (cddr elems)))
1409                                      (cond ((and (integer? level) head-word)
1410                                             `((,(string->symbol (string-append "h" (number->string level)))
1411                                                (@ (id ,(internal-link head-word)))
1412                                                ,head-word ) . ,contents))
1413                                            (else
1414                                             (error 'html-transformation-rules
1415                                                    (conc "section elements must be of the form (section level head-word . contents), got " elems))))
1416                                           )))
1417
1418                              (section*
1419                               *macro*
1420                               . ,(lambda (tag elems)
1421                                    (let ((level (car elems))
1422                                          (head-word (cadr elems))
1423                                          (contents (cddr elems)))
1424                                      (cond ((and (integer? level) head-word)
1425                                             `((,(string->symbol (string-append "h" (number->string level)))
1426                                                ,head-word ) . ,contents))
1427                                            (else
1428                                             (error 'html-transformation-rules
1429                                                    (conc "section elements must be of the form (section level head-word . contents), got " elems))))
1430                                      )))
1431
1432
1433                              (toc ;; Re-scan the content for "section" tags and generate
1434                               *macro*
1435                               . ,(lambda (tag rest) ;; the table of contents
1436                                    `(div (@ (id "toc"))
1437                                          ,rest
1438                                          (ol ,(let find-sections ((content content))
1439                                                 (cond
1440                                                  ((not (pair? content)) '())
1441                                                  ((pair? (car content))
1442                                                   (append (find-sections (car content))
1443                                                           (find-sections (cdr content))))
1444                                                  ((eq? (car content) 'section)
1445                                                   (let* ((level (cadr content))
1446                                                          (head-word (caddr content))
1447                                                          (href (conc "#" (internal-link head-word)))
1448                                                          (subsections (find-sections (cdddr content))))
1449                                                     (cond ((and (integer? level) head-word)
1450                                                            `((li (a (@ (href ,href)) ,head-word)
1451                                                                  ,@(if (null? subsections)
1452                                                                        '()
1453                                                                        `((ol ,subsections))))))
1454                                                           (else
1455                                                            (error 'html-transformation-rules
1456                                                                   "section elements must be of the form (section level head-word . contents)")))))
1457                                                  (else (find-sections (cdr content)))))))))
1458
1459
1460                              ,@sxml:alist-conv-rules*
1461                              ))
1462                           protect: #t
1463                           ))
1464           
1465            )))
1466
1467          ;;eval-env-sxml
1468      )))))
1469
1470
1471
1472(define (traverse-definitions prefix uenv #!key (type-hook #f) (component-hook #f) (value-hook #f) (filter (lambda (x) x)))
1473 
1474  (let ((source-defs (car uenv))
1475        (type-env    (cadr uenv))
1476        (eval-env    (caddr uenv)))
1477
1478    (let recur ((eval-env eval-env))
1479      (if (pair? eval-env)
1480          (let ((entry (car eval-env)))
1481            (if (filter entry)
1482                (let ((v (cdr entry))
1483                      (name (ident-name (car entry))))
1484                  (cond ((MLvalue? v) 
1485                         (let ((sxml-value (MLvalue->sxml v)))
1486                           (let* ((value (sxml:kid* sxml-value))
1487                                  (tuple-label (and value ((sxpath '(Tuple left Const label *text*)) `(*TOP* ,sxml-value)))))
1488                             (if (pair? tuple-label)
1489                                 (value-hook prefix name (car tuple-label) sxml-value)))))
1490                        (else
1491                         (if (modval? v)
1492                             (cases modval v
1493                                    (Structure_v (env) (recur env))))))))
1494            (recur (cdr eval-env))
1495            ))
1496      ))
1497  )
1498
1499
1500(define (definition-apply prefix name uenv #!key (type-hook #f) (component-hook #f) (value-hook #f))
1501
1502  (let ((name (if (or (string? name) (symbol? name)) (ident-create (->string name)) name))
1503        (source-defs (car uenv))
1504        (type-env    (cadr uenv))
1505        (eval-env    (caddr uenv)))
1506
1507    (let ((v (ident-find name eval-env)))
1508
1509      (and v
1510             
1511             (cond ((MLvalue? v) 
1512                    (let ((sxml-value (MLvalue->sxml v)))
1513                      (let* ((value (sxml:kid* sxml-value))
1514                             (tuple-label (and value ((sxpath '(Tuple left Const label *text*)) `(*TOP* ,sxml-value)))))
1515                        (if (pair? tuple-label)
1516                            (value-hook prefix (ident-name name) (car tuple-label) sxml-value)
1517                            (value-hook prefix (ident-name name) #f sxml-value))
1518                        )))
1519                           
1520                   (else #f))
1521             ))
1522      ))
1523
1524
1525
1526;; Taken from regex.scm:
1527
1528;;; Substitute matching strings:
1529
1530(define (string-search-positions rx str #!optional (start 0) (range (string-length str)))
1531  (let ((n (string-length str)))
1532    (and-let* ((m (irregex-search rx str start (min n (fx+ start range)))))
1533      (let loop ((i (irregex-match-num-submatches m))
1534                 (res '()))
1535        (if (fx< i 0)
1536            res
1537            (loop (fx- i 1) (cons (list (irregex-match-start-index m i)
1538                                        (irregex-match-end-index m i))
1539                                  res)))))))
1540
1541(define string-substitute
1542  (let ([substring substring]
1543        [reverse reverse]
1544        [make-string make-string]
1545        [string-search-positions string-search-positions] )
1546    (lambda (rx subst string . flag)
1547      (##sys#check-string subst 'string-substitute)
1548      (##sys#check-string string 'string-substitute)
1549      (let* ([which (if (pair? flag) (car flag) 1)]
1550             [substlen (##sys#size subst)]
1551             (strlen (##sys#size string))
1552             [substlen-1 (fx- substlen 1)]
1553             [result '()]
1554             [total 0] )
1555        (define (push x)
1556          (set! result (cons x result))
1557          (set! total (fx+ total (##sys#size x))) )
1558        (define (substitute matches)
1559          (let loop ([start 0] [index 0])
1560
1561
1562                 (if (fx>= index substlen-1)
1563                (push (if (fx= start 0) subst (substring subst start substlen)))
1564                (let ([c (##core#inline "C_subchar" subst index)]
1565                      [index+1 (fx+ index 1)] )
1566                  (if (char=? c #\\)
1567                      (let ([c2 (##core#inline "C_subchar" subst index+1)])
1568                        (if (and (not (char=? #\\ c2)) (char-numeric? c2))
1569                            (let ([mi (list-ref matches (fx- (char->integer c2) 48))])
1570                              (push (substring subst start index))
1571                              (push (substring string (car mi) (cadr mi)))
1572                              (loop (fx+ index 2) index+1) )
1573                            (loop start (fx+ index+1 1)) ) )
1574                      (loop start index+1) ) ) ) ) )
1575        (let loop ([index 0] [count 1])
1576          (let ((matches (and (fx< index strlen) 
1577                              (string-search-positions rx string index))))
1578            (cond [matches
1579                   (let* ([range (car matches)]
1580                          [upto (cadr range)] )
1581                     (cond ((fx= 0 (fx- (cadr range) (car range)))
1582                            (##sys#error
1583                             'string-substitute "empty substitution match"
1584                             rx) )
1585                           ((or (not (fixnum? which)) (fx= count which))
1586                            (push (substring string index (car range)))
1587                            (substitute matches)
1588                            (loop upto #f) )
1589                           (else
1590                            (push (substring string index upto))
1591                            (loop upto (fx+ count 1)) ) ) ) ]
1592                  [else
1593                   (push (substring string index (##sys#size string)))
1594                   (##sys#fragments->string total (reverse result)) ] ) ) ) ) ) ) )
1595
1596(define string-substitute*
1597  (let ([string-substitute string-substitute])
1598    (lambda (str smap . mode)
1599      (##sys#check-string str 'string-substitute*)
1600      (##sys#check-list smap 'string-substitute*)
1601      (let ((mode (and (pair? mode) (car mode))))
1602        (let loop ((str str) (smap smap))
1603          (if (null? smap)
1604              str
1605              (let ((sm (car smap)))
1606                (loop (string-substitute (car sm) (cdr sm) str mode)
1607                      (cdr smap) ) ) ) ) ) ) ) )
1608
1609
1610
1611)
Note: See TracBrowser for help on using the repository browser.