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

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

9ML-toolkit: making ivp and ivp-lib consistent with changes to parsing interface

File size: 47.7 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                      ((IDENTITY)       
441                       (let ((f (cadr sexpr)))
442                         `(DiagramLib:Identity ,(recur f))))
443
444                      ((RELATION)           
445                       (let ((n (cadr sexpr)) (x (caddr sexpr))
446                             (f (sexpr->function (cadddr sexpr)))
447                             (d (car (cddddr sexpr))))
448                         `(DiagramLib:Relation (@ (name ,n) (arg ,x))
449                                               ,(function->nxml f)
450                                               ,(recur d))))
451                         
452                      ((PURE)           
453                       (let ((f (sexpr->function (cadr sexpr))))
454                         `(DiagramLib:Function
455                           ,(function->nxml f))))
456
457                      ((GROUP)           
458                       (let ((n1 (cadr sexpr)) (n2 (caddr sexpr)))
459                         `(DiagramLib:Group
460                           ,(recur n1) ,(recur n2))))
461
462                      ((SEQUENCE)       
463                       (let ((n1  (cadr sexpr))
464                             (n2  (caddr sexpr)))
465                         `(DiagramLib:Sequence ,(recur n1) ,(recur n2))
466                         ))
467
468                      ((UNION)         
469                       (let ((n1 (cadr sexpr))
470                             (n2 (caddr sexpr)))
471                         `(DiagramLib:Regime ,(recur n1) ,(recur n2))
472                         ))
473
474                      ((SENSE)         
475                       (let ((sns (cadr sexpr)) (n (caddr sexpr)))
476                         `(DiagramLib:Sense ,(map (lambda (s) `(signal ,s)) sns) 
477                                            ,(recur n))
478                         ))
479                                                   
480                      ((ACTUATE)       
481                       (let ((sns (cadr sexpr)) (n (caddr sexpr)))
482                         `(DiagramLib:Actuate ,(map (lambda (s) `(signal ,s)) sns) 
483                                              ,(recur n))))
484                     
485                      ((ODE)           
486                       (let ((ivar (cadr sexpr)) (dvar (caddr sexpr))
487                             (rhs (cadddr sexpr)))
488                         `(DiagramLib:ODE `(independent_variable ,ivar)
489                                          `(dependent_variable ,dvar)
490                                           ,(recur rhs))))
491
492                      ((ASSIGN)         
493                       (let ((var (cadr sexpr)) 
494                             (rhs (recur (caddr sexpr))))
495                         `(DiagramLib:Assign `(variable ,var)
496                                             ,(recur rhs))))
497
498                     
499                      (else (error 'diagram->nxml "invalid diagram constructor" sexpr))
500                      )))
501
502                 (else (map recur sexpr))
503                 ))
504
505             sexpr)))
506
507
508(define (print-nxml prefix uenv)
509
510    (let (
511          (path-ss
512           `(
513             (path
514              *macro*
515              . ,(lambda (tag elems) elems))
516             
517            (Pident
518             *macro*
519             . ,(lambda (tag elems)
520                  (let ((node (cons tag elems)))
521                    (let ((name (sxml:text node)))
522                      (if (not name) (error 'print-nxml "Pident element requires text content" node))
523                      name))))
524             
525             (Pdot
526              *macro*
527              . ,(lambda (tag elems)
528                   (let ((node (cons tag elems)))
529                     (let ((name (sxml:attr node 'name)))
530                       (if (not name) (error 'print-nxml "Pdot element requires name attribute"))
531                       `(,(sxml:kids node) "." ,name)))))
532
533             
534             ,@sxml:alist-conv-rules*
535             ))
536
537
538          (moddef-ss
539           
540           `(
541             (Type_def
542              *macro*
543              . ,(lambda (tag elems)
544                   (let ((node (cons tag elems)))
545                     (let ((name (sxml:attr node 'name))
546                           (deftype (sxml:kidn* 'deftype node)))
547                       `(Type (@ (name ,name)) ,deftype)))
548                   ))
549
550             (Component
551              *macro*
552              . ,(lambda (tag elems)
553                   (let ((node (cons tag elems)))
554                       (let ((name (sxml:attr node 'name))
555                             (members ((sxpath '(Component (*or* Val Component))) `(*TOP* ,node))))
556                         `(Namespace (@ (name ,name)) . ,members)
557                         ))
558                   ))
559
560             (Val
561              *macro*
562              . ,(lambda (tag elems)
563                   (let ((node (cons tag elems)))
564                     (let* ((name (sxml:attr node 'name))
565                            (value (sxml:kid node))
566                            (tuple-label ((sxpath '(Tuple left Const label *text*)) `(*TOP* ,value))))
567
568                       (if (not name) (error 'type-env-report "binding element requires name attribute"))
569
570                       (cond ((and (pair? tuple-label) (equal? (car tuple-label) "diagram")) ;; value is a diagram
571                              (let* ((diagram-id (gensym 'diagram)))
572                                `(Binding (@ (name ,name)) ,(diagram->nxml (sxml-value->sexpr value)))))
573
574                             (else
575                              `(Binding (@ (name ,name))  ,value)))
576                       ))))
577             
578          ,@sxml:alist-conv-rules*
579
580          ))
581
582
583          (term-ss
584           `(
585
586             (Longid 
587              *macro*
588              . ,(lambda (tag elems)
589                   (let ((node (cons tag elems)))
590                     (sxml:kids node)
591                     )))
592
593             (Function
594              *macro*
595              . ,(lambda (tag elems)
596                   (let ((node (cons tag elems)))
597                     (let ((formal (sxml:attr node 'formal))
598                           (body   (sxml:kid node)))
599                       `(Term:Function (@ (x ,formal)) ,body)
600                       ))))
601
602
603             (Let0 
604              *macro*
605              . ,(lambda (tag elems)
606                   (let ((node (cons tag elems)))
607                     (let ((name (sxml:attr node 'name))
608                           (value (sxml:kidn-cadr 'value node))
609                           (body (sxml:kidn-cadr 'body node)))
610                       `(Term:Let (@ (name ,name)) (value ,value) (body ,body))
611                       ))))
612
613             (Apply 
614              *macro*
615              . ,(lambda (tag elems)
616                   (let ((node (cons tag elems)))
617                     (let ((left (sxml:kidn-cdr 'left node))
618                           (right (sxml:kidn-cdr 'right node)))
619                       `(Term:Apply (left ,left) (right ,right))
620                       ))))
621             
622             ,@sxml:alist-conv-rules*
623             ))
624
625
626          )
627
628  (let ( 
629        (filename    (string-append prefix ".xml"))
630        (source-defs (car uenv))
631        (type-env    (cadr uenv))
632        (eval-env    (caddr uenv)))
633
634    (let ((eval-env-sxml (eval-env->sxml eval-env))
635          (eval-env-rulesets `(,moddef-ss
636                               ,term-ss
637                               ,path-ss
638                               )))
639     
640      (let* (
641             (eval-env-sxml  (sxml-transform eval-env-sxml eval-env-rulesets))
642             (content        `(Toplevel ,eval-env-sxml))
643             )
644       
645        (with-output-to-file filename
646          (lambda () (print-fragments (generate-XML content))))
647           
648        )))
649  ))
650
651
652(define (realsig-value x)
653  (cond ((number? x) x)
654        ((equal? 'realsig (car x)) (caddr x))
655        (else (error 'realsig-value "invalid real signal" x))))
656
657(define (realsig-name x)
658  (if (and (pair? x) (equal? 'realsig (car x))) (cadr x)
659      (error 'realsig-name "invalid real signal" x)))
660
661(define (boolsig-value x)
662  (cond ((boolean? x) x)
663        ((equal? 'boolsig (car x)) (caddr x))
664        (else (error 'boolsig-value "invalid boolean signal" x))))
665
666(define (boolsig-name x)
667  (if (and (pair? x) (equal? 'boolsig (car x))) (cadr x)
668      (error 'boolsig-value "invalid boolean signal" x)))
669
670
671
672(define (sigfun-eval sexpr)
673  (let recur ((sexpr sexpr))
674    (if (pair? sexpr)
675        (case (car sexpr)
676          ((realconst)   (let ((value (cadr sexpr))) (real-eval value)))
677          ((boolconst)   (let ((value (cadr sexpr))) value))
678          ((realsig)     (let ((name (cadr sexpr))
679                               (value (recur (caddr sexpr))))
680                           (if (not (number? value)) (error 'realsig "real signal value is not a real" name value))
681                           `(realsig ,name ,value)))
682          ((boolsig)   (let ((name (cadr sexpr))
683                             (value0 (recur (caddr sexpr))))
684                         (let ((value (if (boolean? value0) value0
685                                          (else (error 'boolsig "boolean signal value is not a boolean" name value0)))))
686                           `(boolsig ,name ,value))))
687          ((neg)       (let ((x (recur (cadr sexpr))))
688                         (- (realsig-value x))))
689          ((log)       (let ((x (recur (cadr sexpr))))
690                         (log10 (realsig-value x))))
691          ((ln)        (let ((x (recur (cadr sexpr))))
692                         (log (realsig-value x))))
693          ((cosh)      (let ((x (recur (cadr sexpr))))
694                         (cosh (realsig-value x))))
695          ((tanh)      (let ((x (recur (cadr sexpr))))
696                             (tanh (realsig-value x))))
697          ((exp)       (let ((x (recur (cadr sexpr))))
698                         (exp (realsig-value x))))
699          ((+)       (let ((x (recur (cadr sexpr)))
700                           (y (recur (caddr sexpr))))
701                       (+ (realsig-value x) (realsig-value y))))
702          ((-)       (let ((x (recur (cadr sexpr))) 
703                           (y (recur (caddr sexpr))))
704                       (- (realsig-value x) (realsig-value y))))
705          ((*)       (let ((x (recur (cadr sexpr))) 
706                           (y (recur (caddr sexpr))))
707                       (* (realsig-value x) (realsig-value y))))
708          ((/)       (let ((x (recur (cadr sexpr))) 
709                           (y (recur (caddr sexpr))))
710                       (/ (realsig-value x) (realsig-value y))))
711          ((>=)       (let ((x (recur (cadr sexpr))) 
712                            (y (recur (caddr sexpr))))
713                        (>= (realsig-value x) (realsig-value y))))
714          ((<=)       (let ((x (recur (cadr sexpr))) 
715                            (y (recur (caddr sexpr))))
716                        (<= (realsig-value x) (realsig-value y))))
717          ((>)        (let ((x (recur (cadr sexpr))) 
718                            (y (recur (caddr sexpr))))
719                        (> (realsig-value x) (realsig-value y))))
720          ((<)        (let ((x (recur (cadr sexpr))) 
721                            (y (recur (caddr sexpr))))
722                        (< (realsig-value x) (realsig-value y))))
723          (else (map recur sexpr))
724          ) 
725        sexpr)))
726
727
728
729(define (real-eval sexpr)
730  (let recur ((sexpr sexpr))
731    (if (number? sexpr) sexpr
732        (case (car sexpr)
733          ((real)      (recur (cdr sexpr)))
734          ((random)    (random-eval (cdr sexpr)))
735          ((neg)       (let ((x (recur (cadr sexpr))))
736                         (- (real-eval x))))
737          ((log)       (let ((x (recur (cadr sexpr))))
738                         (log10 (real-eval x))))
739          ((ln)        (let ((x (recur (cadr sexpr))))
740                         (log (real-eval x))))
741          ((cosh)      (let ((x (recur (cadr sexpr))))
742                         (cosh (real-eval x))))
743          ((tanh)      (let ((x (recur (cadr sexpr))))
744                         (tanh (real-eval x))))
745          ((exp)       (let ((x (recur (cadr sexpr))))
746                         (exp (realsig-value x))))
747          ((+)       (let ((x (recur (cadr sexpr)))
748                           (y (recur (caddr sexpr))))
749                       (+ (real-eval x) (real-eval y))))
750          ((-)       (let ((x (recur (cadr sexpr))) 
751                           (y (recur (caddr sexpr))))
752                           (- (real-eval x) (real-eval y))))
753          ((*)       (let ((x (recur (cadr sexpr))) 
754                           (y (recur (caddr sexpr))))
755                           (* (real-eval x) (real-eval y))))
756          ((/)       (let ((x (recur (cadr sexpr))) 
757                               (y (recur (caddr sexpr))))
758                       (/ (real-eval x) (real-eval y))))
759          ((>=)       (let ((x (recur (cadr sexpr))) 
760                            (y (recur (caddr sexpr))))
761                        (>= (real-eval x) (real-eval y))))
762          ((<=)       (let ((x (recur (cadr sexpr))) 
763                            (y (recur (caddr sexpr))))
764                        (<= (real-eval x) (real-eval y))))
765          ((>)        (let ((x (recur (cadr sexpr))) 
766                            (y (recur (caddr sexpr))))
767                        (> (real-eval x) (real-eval y))))
768          ((<)        (let ((x (recur (cadr sexpr))) 
769                            (y (recur (caddr sexpr))))
770                        (< (real-eval x) (real-eval y))))
771          ((toNat)    (let ((v (recur (cadr sexpr))))
772                        (inexact->exact (abs (round v)))))
773          (else (map recur sexpr))
774          ))
775    ))
776
777
778(define (random-eval sexpr)
779  (let recur ((sexpr sexpr))
780    (if (number? sexpr) sexpr
781        (case (car sexpr)
782
783          ((random)     
784           (recur (cdr sexpr)))
785
786          ((uniform)     
787           (let ((low   (real-eval (cadr sexpr)))
788                 (high  (real-eval (caddr sexpr))))
789             (let ((rlo (if (< low high) low high))
790                   (rhi (if (< low high) high low))) 
791               (let ((delta (+ 1 (- rhi rlo)))
792                     (v (random-mtzig:randu! random-state)))
793                 (+ rlo (floor (* delta v)))
794                 ))
795             ))
796
797          ((normal)     
798           (let ((mean   (real-eval (cadr sexpr)))
799                 (stddev (sqrt (real-eval (caddr sexpr)))))
800             (let ((v (random-mtzig:randn! random-state)))
801               (+ (* v stddev) mean))))
802
803          ((exponential) 
804           (let ((mean   (real-eval (cadr sexpr))))
805             (let ((v (random-mtzig:rande! random-state)))
806               (* v mean))))
807
808          (else (error 'random-eval "unknown random constructor" sexpr))
809          ))
810    ))
811
812
813(define (sexpr->diagram+initial h sexpr)
814
815    (define initenv  (make-parameter '()))
816    (define fieldenv  (make-parameter '()))
817
818    (let ((diagram
819           (let recur ((sexpr sexpr))
820             (if (pair? sexpr)
821                 (case (car sexpr)
822
823                   ((generator)
824                    (let ((sexpr (cdr sexpr)))
825                      (case (car sexpr)
826                        ((poisson)
827                         (let ((rate (recur (cadr sexpr)))
828                               (t (recur (caddr sexpr)))
829                               (h (recur (cadddr sexpr))))
830                           (initenv (append `( (spike . #f) (spikeCount . 0.0) 
831                                               (st . (generator RandomInit))
832                                               (zt . (generator ZigInit)) )
833                                            (initenv)))
834                           (diagram:SENSE `(,t ,h spike spikeCount rate st zt)
835                                          (diagram:PRIM (diagram:make-prim 
836                                                         `(,t st zt)
837                                                         `(,t ,h spike spikeCount rate st zt)
838                                                         `(,t spike spikeCount st zt)
839                                                         `(spike)
840                                                         `(PoissonStep ,rate ,t ,h st zt)
841                                                         '(st zt)
842                                                         '(PoissonInit)
843                                                         )
844                                                        'poisson))
845                           ))
846                        (else
847                         (error 'sexpr->diagram "invalid generator" sexpr))
848
849                        )))
850
851                   ((diagram) 
852                    (let ((sexpr (cdr sexpr)))
853
854                      (case (car sexpr)
855                       
856                        ((PURE)           (let ((f  (sexpr->function (cadr sexpr))))  (diagram:PURE f)))
857                        ((GROUP)          (diagram:UNION (recur (cadr sexpr)) (recur (caddr sexpr))))
858                        ((IDENTITY)       (diagram:IDENTITY (recur (cadr sexpr))))
859                        ((SEQUENCE)       (diagram:SEQUENCE (recur (cadr sexpr)) (recur (caddr sexpr))))
860                        ((UNION)          (diagram:UNION (recur (cadr sexpr)) (recur (caddr sexpr))))
861                        ((SENSE)          (diagram:SENSE (cadr sexpr) (recur (caddr sexpr))))
862                        ((ACTUATE)        (diagram:ACTUATE (cadr sexpr) (recur (caddr sexpr))))
863                        ((TRANSIENT)      (diagram:TRANSIENT (recur (cadr sexpr)) (recur (caddr sexpr))
864                                                             (recur (cadddr sexpr))))
865                        ((TRANSITION)     (diagram:TRANSITION (recur (cadr sexpr)) (recur (caddr sexpr))
866                                                              (recur (cadddr sexpr))))
867                        ((RTRANSITION)    (diagram:RTRANSITION (recur (cadr sexpr)) 
868                                                               (recur (caddr sexpr))
869                                                               (recur (cadddr sexpr))
870                                                               (recur (cadddr (cdr sexpr)))
871                                                               (recur (cadddr (cddr sexpr)))
872                                                               ))
873                       
874                        ((ODE)            (let ((deps  (map recur (cadr sexpr)))
875                                                (indep (recur (caddr sexpr)))
876                                                (tstep (recur (cadddr sexpr)))
877                                                (rhs   (cadddr (cdr sexpr))))
878                                           
879                                            (if (not (equal? tstep h))
880                                                (error 'sexpr->diagram "mismatch between independent variable step of ODE and IVP" h tstep))
881                                           
882                                            (let-values (((rhs-list relation-list)
883                                                          (let rhs-recur ((rhs-list '()) (relation-list '()) (rhs rhs))
884                                                            (case (car rhs)
885                                                              ((pure)
886                                                               (let ((d (cdr rhs)))
887                                                                 (case (car d)
888                                                                   ((GROUP) 
889                                                                    (let-values (((rhs-list1 relation-list1) 
890                                                                                  (rhs-recur rhs-list relation-list (cadr d))))
891                                                                      (rhs-recur rhs-list1 relation-list1 (caddr d))))
892                                                                   ((PURE)     
893                                                                    (let ((expr (recur (cadr d))))
894                                                                      (values (cons expr rhs-list) relation-list)))
895                                                                   ((RELATION) 
896                                                                    (let ((r (cdr d)))
897                                                                      (rhs-recur rhs-list 
898                                                                                 (cons (list (car r) (list (cadr r)) (recur (caddr r))) 
899                                                                                       relation-list) 
900                                                                                 (cadddr r))))
901                                                                   (else (error 'sexpr->diagram "invalid ODE subelement" d)))))
902                                                              (else
903                                                               (error 'sexpr->diagram "invalid ODE subelement" rhs))))))
904                                              (diagram:make-dae-system h indep (append (reverse relation-list) (zip deps (reverse rhs-list))))
905                                              )))
906                       
907                        ((ASSIGN)         (let ((vars  (cadr sexpr))
908                                                (rhs   (caddr sexpr)))
909                                            (let ((rhs-list
910                                                   (let rhs-recur ((rhs-list '()) (rhs rhs))
911                                                     (case (car rhs)
912                                                       ((pure)
913                                                        (let ((d (cdr rhs)))
914                                                          (case (car d)
915                                                            ((GROUP)  (rhs-recur (rhs-recur rhs-list  (cadr d)) (caddr d)))
916                                                            ((PURE)   (cons (recur (cadr d)) rhs-list))
917                                                            (else (error 'sexpr->diagram "invalid ASSIGN subelement" d)))))
918                                                       (else (error 'sexpr->diagram "invalid ASSIGN subelement" rhs))))))
919                                             
920                                              (diagram:make-assign-system (zip vars (reverse rhs-list))))))
921                       
922                        ((RELATION)      (let ((n (cadr sexpr)) (x (caddr sexpr))
923                                               (f (sexpr->function (recur (cadddr sexpr)))))
924                                           (diagram:RELATION (list n x f) (recur (cadddr (cdr sexpr))))))
925                       
926                        (else             (error 'sexpr->diagram "invalid diagram constructor" sexpr))
927                        )))
928                   
929                   ((relation)    (let ((op (cadr sexpr))) (cons op (map recur (cddr sexpr)))))
930                   
931                   ((realfield)   (let ((name (cadr sexpr))
932                                        (value (caddr sexpr)))
933                                    (initenv (cons (cons name value) (initenv)))
934                                    (fieldenv (cons (cons name value) (fieldenv)))
935                                    name))
936
937                   ((realsig)     (let ((name (cadr sexpr))
938                                        (value (caddr sexpr)))
939                                    (initenv (cons (cons name value) (initenv)))
940                                    name))
941
942                   ((realconst)   (cadr sexpr))
943                   
944                   ((boolsig)   (let ((name (cadr sexpr))
945                                      (value0 (caddr sexpr)))
946                                  (let ((value (if (boolean? value0) value0
947                                                   (case (car value0) 
948                                                     ((boolconst) (cadr value0))
949                                                     (else (error 'boolsig "boolean signal value is not a boolean" name value0))))))
950                                    (initenv (cons (cons name value) (initenv)))
951                                    name)))
952
953                   ((boolconst)   (if (cadr sexpr) 'true 'false))
954                   
955                   (else (map recur sexpr)))
956                 sexpr)
957          )))
958    (initenv (delete-duplicates (initenv) (lambda (x y) (equal? (car x) (car y)))))
959    (fieldenv (delete-duplicates (fieldenv) (lambda (x y) (equal? (car x) (car y)))))
960    (list diagram (initenv) (fieldenv))
961
962    ))
963
964
965(define (sexpr->alsys+initial sexpr)
966
967    (define initenv  (make-parameter '()))
968    (define fieldenv  (make-parameter '()))
969
970    (let ((alsys
971           (let recur ((sexpr sexpr))
972             (if (pair? sexpr)
973                 (case (car sexpr)
974
975                   ((alsys) 
976                    (let ((sexpr (cdr sexpr)))
977
978                      (case (car sexpr)
979                       
980                        ((EQUATION)         (let ((var  (cadr sexpr))
981                                                  (rhs  (sexpr->function (recur (caddr sexpr)))))
982                                              (alsys:EQUATION var rhs)))
983                       
984                        ((UNION)          (alsys:UNION (recur (cadr sexpr)) (recur (caddr sexpr))))
985                       
986                        ((RELATION)      (let ((n (cadr sexpr)) (x (caddr sexpr))
987                                               (f (sexpr->function (recur (cadddr sexpr)))))
988                                           (alsys:RELATION (list n x f) (recur (cadddr (cdr sexpr))))))
989                       
990                        (else             (error 'sexpr->alsys "invalid algebraic system constructor" sexpr))
991                        )))
992                   
993                   ((relation)    (let ((op (cadr sexpr))) (cons op (map recur (cddr sexpr)))))
994                   
995                   ((realfield)   (let ((name (cadr sexpr))
996                                        (value (caddr sexpr)))
997                                    (initenv (cons (cons name value) (initenv)))
998                                    (fieldenv (cons (cons name value) (fieldenv)))
999                                    name))
1000
1001                   ((realsig)     (let ((name (cadr sexpr))
1002                                        (value (caddr sexpr)))
1003                                    (initenv (cons (cons name value) (initenv)))
1004                                    name))
1005
1006                   ((realconst)   (cadr sexpr))
1007                   
1008                   ((boolsig)   (let ((name (cadr sexpr))
1009                                      (value0 (caddr sexpr)))
1010                                  (let ((value (if (boolean? value0) value0
1011                                                   (case (car value0) 
1012                                                     ((boolconst) (cadr value0))
1013                                                     (else (error 'boolsig "boolean signal value is not a boolean" name value0))))))
1014                                    (initenv (cons (cons name value) (initenv)))
1015                                    name)))
1016
1017                   ((boolconst)   (if (cadr sexpr) 'true 'false))
1018                   
1019                   (else (map recur sexpr)))
1020                 sexpr)
1021          )))
1022    (initenv (delete-duplicates (initenv) (lambda (x y) (equal? (car x) (car y)))))
1023    (fieldenv (delete-duplicates (fieldenv) (lambda (x y) (equal? (car x) (car y)))))
1024    (list alsys (initenv) (fieldenv))
1025
1026    ))
1027
1028   
1029 
1030
1031(define variable-names (make-parameter '()))
1032
1033
1034(define (html-report prefix uenv #!key (value-hook #f))
1035
1036  (let-syntax
1037      (
1038       (line (syntax-rules ()
1039               ((_ x ...) (list (list 'span '(@ (class "hl_line")) `x ...) nl))))
1040       (code (syntax-rules ()
1041               ((_ x ...) (list 'code '(@ (class "hl_code")) `x ...))))
1042       )
1043
1044    (let (
1045          (path-ss
1046           `(
1047             (path
1048              *macro*
1049              . ,(lambda (tag elems) elems))
1050             
1051            (Pident
1052             *macro*
1053             . ,(lambda (tag elems)
1054                  (let ((node (cons tag elems)))
1055                    (let ((name (sxml:text node)))
1056                      (if (not name) (error 'html-report "Pident element requires text content" node))
1057                      name))))
1058             
1059             (Pdot
1060              *macro*
1061              . ,(lambda (tag elems)
1062                   (let ((node (cons tag elems)))
1063                     (let ((name (sxml:attr node 'name)))
1064                       (if (not name) (error 'html-report "Pdot element requires name attribute"))
1065                       `(,(sxml:kids node) "." ,name)))))
1066
1067             
1068             ,@sxml:alist-conv-rules*
1069             ))
1070
1071          (simple-type-ss
1072           `(
1073             (Tcon
1074              *macro*
1075              . ,(lambda (tag elems)
1076                   (let ((node (cons tag elems)))
1077                     (let ((path (sxml:kidn-cadr 'path node))
1078                           (ts (map cdr (sxml:kidsn 't node))))
1079                       (cond
1080                        ((equal? path `(pident (@ (name "->"))))
1081                         `(,(car ts) " -> " ,(cadr ts)))
1082                        ((pair? ts)
1083                         `("(" ,@(intersperse ts " ") ") " ,path))
1084                        (else path))))))
1085             
1086             
1087             (Tvar
1088              *macro*
1089              . ,(lambda (tag elems)
1090                   (let ((node (cons tag elems)))
1091                     (let ((repres (sxml:kidn 'repres node)))
1092                       (cond
1093                        (repres (cdr repres))
1094                        (else (let* ((name (or (assq elems (variable-names))))
1095                                     (name (if (not name)
1096                                               (let* ((n  (+ 1 (length (variable-names))))
1097                                                     (s  (string-append "'t" (number->string n))))
1098                                                 (variable-names (cons (list n s) (variable-names)))
1099                                                 s))))
1100                                name)))))))
1101             
1102             ,@sxml:alist-conv-rules*
1103             ))
1104
1105          (const-ss
1106           `(
1107
1108             (Const
1109              *macro*
1110              . ,(lambda (tag elems) 
1111                   (let ((node (cons tag elems)))
1112                     (sxml:kids node))))
1113
1114             (label 
1115              *macro*
1116              . ,(lambda (tag elems)
1117                   (let ((node (cons tag elems)))
1118                     (code ,(sxml:text node)))))
1119                   
1120             ,@sxml:alist-conv-rules*
1121             ))
1122           
1123          (typedef-ss
1124           `(
1125             (Valtype
1126              *macro* 
1127              . ,(lambda (tag elems)
1128                   (let ((body (sxml:kidn-cdr 'body elems)))
1129                     body)
1130                   ))
1131
1132             (Deftype 
1133               *macro*
1134               . ,(lambda (tag elems)
1135                    (let ((node (cons tag elems)))
1136                      (let ((b (sxml:kidn-cdr 'body node)))
1137                        b)
1138                      )))
1139
1140             ,@sxml:alist-conv-rules*
1141
1142             ))
1143         
1144          (modspec-ss
1145           `(
1146             (Value_sig 
1147              *macro*
1148              . ,(lambda (tag elems)
1149                   (let ((node (cons tag elems)))
1150                     (let ((name (sxml:attr node 'name)))
1151                       (if (not name) (error 'type-env-report "value_sig element requires name attribute"))
1152                       (line "Value " (b ,name) " : " ,(sxml:kids node))))))
1153             
1154             
1155             (Type_sig 
1156              *macro*
1157              . ,(lambda (tag elems)
1158                   (let ((node (cons tag elems)))
1159                     (let ((name (sxml:attr node 'name)))
1160                       (if (not name) (error 'type-env-report "type_sig element requires name attribute"))
1161                       (line "Type " (b ,name) " = " ,(sxml:kids node))))))
1162             
1163             (Typedecl
1164              *macro* 
1165              . ,(lambda (tag elems)
1166                   (let ((node (cons tag elems)))
1167                     (let ((m (sxml:kidn* 'manifest node)))
1168                       m)
1169                     )))
1170             
1171             (manifest 
1172              *macro*
1173              . ,(lambda (tag elems)
1174                   (let ((node (cons tag elems)))
1175                     (let ((dt (sxml:kidn* 'deftype node)))
1176                       dt)
1177                     )))
1178             
1179             (Module_sig 
1180              *macro*
1181              . ,(lambda (tag elems)
1182                   (let ((node (cons tag elems)))
1183                     (let ((name (sxml:attr node 'name)))
1184                       (if (not name) (error 'type-env-report "module_sig element requires name attribute"))
1185                       `(,(line "Component signature " (b ,name) " : ") 
1186                         ,(sxml:kids node))))))
1187             
1188             (Signature
1189              *macro* 
1190              . ,(lambda (tag elems)
1191                   (let ((node (cons tag elems)))
1192                     `(ul . ,(map (lambda (x) `(li ,x)) (sxml:kids node ))))))
1193             
1194             
1195             (Functorty
1196              *macro* 
1197              . ,(lambda (tag elems)
1198                   (let ((node (cons tag elems)))
1199                     (let ((name (sxml:attr node 'name)))
1200                       (if (not name) (error 'type-env-report "functorty elements requires name attribute"))
1201                       `("Functor " (b ,name)
1202                         (ul . ,(map (lambda (x) `(li ,x)) (sxml:kids node ))))))))
1203             
1204             
1205             ,@sxml:alist-conv-rules*
1206             ))
1207
1208          (moddef-ss
1209           
1210           `(
1211             (Type_def
1212              *macro*
1213              . ,(lambda (tag elems)
1214                   (let ((node (cons tag elems)))
1215                     (let ((name (sxml:attr node 'name))
1216                           (deftype (sxml:kidn* 'deftype node)))
1217                       (code  "type " ,name " = " ,deftype)
1218                   ))))
1219
1220             (Component
1221              *macro*
1222              . ,(lambda (tag elems)
1223                   (let ((node (cons tag elems)))
1224                     (let ((name (sxml:attr node 'name)))
1225                       (if (not name) (error 'type-env-report "component element requires name attribute"))
1226                       `(,(line "Component " (b ,name) " = ") (ul . ,(map (lambda (x) `(li ,x)) (sxml:kids node))))))))
1227
1228             (Val
1229              *macro*
1230              . ,(lambda (tag elems)
1231                   (let ((node (cons tag elems)))
1232                     (let* ((name (sxml:attr node 'name))
1233                            (value (sxml:kid node))
1234                            (tuple-label ((sxpath '(Tuple left Const label *text*)) `(*TOP* ,value))))
1235
1236                       (if (not name) (error 'type-env-report "binding element requires name attribute"))
1237
1238                       (cond ((and value-hook (pair? tuple-label) (value-hook prefix name (car tuple-label) value)) =>
1239                              (lambda (x) `(,(line "binding " (b ,name) " = ") (p ,x))))
1240
1241                             (else
1242                              `(,(line "binding " (b ,name) " = ") ,value)))
1243                       ))))
1244
1245             (Prim
1246              *macro*
1247              . ,(lambda (tag elems) 
1248                  (code "primitive procedure")))
1249             
1250             (null
1251              *macro*
1252              . ,(lambda (tag elems) 
1253                  (code "null")))
1254             
1255             (Tuple
1256              *macro*
1257              . ,(lambda (tag elems)
1258                   (let ((node (cons tag elems)))
1259                     (let ((left (sxml:kidn-cadr 'left node))
1260                           (right (sxml:kidn-cdr 'right node)))
1261                        `( " ( "  ,left " " ,@right " ) " )
1262                        ))))
1263             
1264             (Closure
1265              *macro*
1266              . ,(lambda (tag elems)
1267                   (let ((node (cons tag elems)))
1268                     (let ((body (sxml:kidn-cdr 'body node))
1269                           (env (sxml:kidn-cdr 'env node)))
1270                       `(,(line "Closure: ") ,@body ,(line "where ") ,env)))))
1271
1272             
1273             
1274          ,@sxml:alist-conv-rules*
1275
1276          ))
1277
1278
1279          (term-ss
1280           `(
1281
1282             (Longid 
1283              *macro*
1284              . ,(lambda (tag elems)
1285                   (let ((node (cons tag elems)))
1286                     (sxml:kids node))))
1287
1288             (Function
1289              *macro*
1290              . ,(lambda (tag elems)
1291                   (let ((node (cons tag elems)))
1292                     (let ((formal (sxml:attr node 'formal)))
1293                       (let-values (((formals body)
1294                                     (let recur ((formals (list formal)) 
1295                                                 (body (sxml:kid node)))
1296                                       (case (car body) 
1297                                         ((function)
1298                                          (recur 
1299                                           (cons (sxml:attr body 'formal) formals)
1300                                           (sxml:kid body)))
1301                                         (else (values (reverse formals) body))))))
1302                         `(,(line (code "Function " ,(intersperse formals " ") " => ")) 
1303                           ,body))
1304                       ))))
1305
1306
1307             (Let0 
1308              *macro*
1309              . ,(lambda (tag elems)
1310                   (let ((node (cons tag elems)))
1311                     (let ((name (sxml:attr node 'name))
1312                           (value (sxml:kidn-cadr 'value node))
1313                           (body (sxml:kidn-cadr 'body node)))
1314                       `(,(line (code "binding " (b ,name) " = ") ,value)
1315                         ,body)))))
1316             
1317             (Apply 
1318              *macro*
1319              . ,(lambda (tag elems)
1320                   (let ((node (cons tag elems)))
1321                     (let ((left (sxml:kidn-cdr 'left node))
1322                           (right (sxml:kidn-cdr 'right node)))
1323                       (code ,left " (" ,right ") ")))))
1324             
1325             ,@sxml:alist-conv-rules*
1326             ))
1327
1328
1329          )
1330
1331  (let ((filename (string-append prefix ".html"))
1332        (source-defs (car uenv))
1333        (type-env    (cadr uenv))
1334        (eval-env    (caddr uenv)))
1335
1336
1337    (let ((type-env-sxml (map (compose modspec->sxml cdr) type-env))
1338          (eval-env-sxml (eval-env->sxml eval-env))
1339          (type-env-rulesets `(,modspec-ss
1340                               ,typedef-ss
1341                               ,simple-type-ss
1342                               ,path-ss
1343                               ))
1344          (eval-env-rulesets `(,moddef-ss
1345                               ,modspec-ss
1346                               ,typedef-ss
1347                               ,term-ss
1348                               ,const-ss
1349                               ,simple-type-ss
1350                               ,path-ss
1351                               )))
1352     
1353      (with-output-to-file filename
1354        (lambda ()
1355          (let* ((type-env-shtml (sxml-transform type-env-sxml type-env-rulesets))
1356                 (eval-env-shtml (sxml-transform eval-env-sxml eval-env-rulesets))
1357                 (content        `(html:begin ,prefix (body (section* 1 ,prefix)
1358                                                            (toc)
1359                                                            (section 2 "Type environment") 
1360                                                            ,type-env-shtml 
1361                                                            (section 2 "Value environment")
1362                                                            ,eval-env-shtml
1363                                                            )))
1364                 (internal-link
1365                  (lambda (r)
1366                    (sxml:post-order 
1367                     r
1368                     `(
1369                       (*default* . ,(lambda (tag elems) (cons tag elems)))
1370                       
1371                       (*text* . ,(lambda (trigger str) 
1372                                    (string-substitute* (string-downcase str) 
1373                                                        '(("[^A-Za-z0-9_ \t-]" . "")
1374                                                         ("[ \t]+" . "-"))))))
1375                     )))
1376                 )
1377
1378            (print-fragments
1379             (generate-XML content
1380                           rulesets:
1381                           `(((html:begin . ,(lambda (tag elems)
1382                                               (let ((title (car elems))
1383                                                     (elems (cdr elems)))
1384                                                 (list "<HTML><HEAD><TITLE>" title "</TITLE></HEAD>"
1385                                                       "<meta http-equiv=\"Content-Style-Type\" content=\"text/css\" />"
1386                                                       "<meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\" />"
1387
1388                                                       "<link rel=\"stylesheet\" type=\"text/css\" href=\"highlight.css\" />"
1389                                                       elems
1390                                                       "</HTML>"))))
1391                              (section
1392                               *macro*
1393                               . ,(lambda (tag elems)
1394                                    (let ((level (car elems))
1395                                          (head-word (cadr elems))
1396                                          (contents (cddr elems)))
1397                                      (cond ((and (integer? level) head-word)
1398                                             `((,(string->symbol (string-append "h" (number->string level)))
1399                                                (@ (id ,(internal-link head-word)))
1400                                                ,head-word ) . ,contents))
1401                                            (else
1402                                             (error 'html-transformation-rules
1403                                                    (conc "section elements must be of the form (section level head-word . contents), got " elems))))
1404                                           )))
1405
1406                              (section*
1407                               *macro*
1408                               . ,(lambda (tag elems)
1409                                    (let ((level (car elems))
1410                                          (head-word (cadr elems))
1411                                          (contents (cddr elems)))
1412                                      (cond ((and (integer? level) head-word)
1413                                             `((,(string->symbol (string-append "h" (number->string level)))
1414                                                ,head-word ) . ,contents))
1415                                            (else
1416                                             (error 'html-transformation-rules
1417                                                    (conc "section elements must be of the form (section level head-word . contents), got " elems))))
1418                                      )))
1419
1420
1421                              (toc ;; Re-scan the content for "section" tags and generate
1422                               *macro*
1423                               . ,(lambda (tag rest) ;; the table of contents
1424                                    `(div (@ (id "toc"))
1425                                          ,rest
1426                                          (ol ,(let find-sections ((content content))
1427                                                 (cond
1428                                                  ((not (pair? content)) '())
1429                                                  ((pair? (car content))
1430                                                   (append (find-sections (car content))
1431                                                           (find-sections (cdr content))))
1432                                                  ((eq? (car content) 'section)
1433                                                   (let* ((level (cadr content))
1434                                                          (head-word (caddr content))
1435                                                          (href (conc "#" (internal-link head-word)))
1436                                                          (subsections (find-sections (cdddr content))))
1437                                                     (cond ((and (integer? level) head-word)
1438                                                            `((li (a (@ (href ,href)) ,head-word)
1439                                                                  ,@(if (null? subsections)
1440                                                                        '()
1441                                                                        `((ol ,subsections))))))
1442                                                           (else
1443                                                            (error 'html-transformation-rules
1444                                                                   "section elements must be of the form (section level head-word . contents)")))))
1445                                                  (else (find-sections (cdr content)))))))))
1446
1447
1448                              ,@sxml:alist-conv-rules*
1449                              ))
1450                           protect: #t
1451                           ))
1452           
1453            )))
1454
1455          ;;eval-env-sxml
1456      )))))
1457
1458
1459
1460(define (traverse-definitions prefix uenv #!key (type-hook #f) (component-hook #f) (value-hook #f) (filter (lambda (x) x)))
1461 
1462  (let ((source-defs (car uenv))
1463        (type-env    (cadr uenv))
1464        (eval-env    (caddr uenv)))
1465
1466    (let recur ((eval-env eval-env))
1467      (if (pair? eval-env)
1468          (let ((entry (car eval-env)))
1469            (if (filter entry)
1470                (let ((v (cdr entry))
1471                      (name (ident-name (car entry))))
1472                  (cond ((MLvalue? v) 
1473                         (let ((sxml-value (MLvalue->sxml v)))
1474                           (let* ((value (sxml:kid* sxml-value))
1475                                  (tuple-label (and value ((sxpath '(Tuple left Const label *text*)) `(*TOP* ,sxml-value)))))
1476                             (if (pair? tuple-label)
1477                                 (value-hook prefix name (car tuple-label) sxml-value)))))
1478                        (else
1479                         (if (modval? v)
1480                             (cases modval v
1481                                    (Structure_v (env) (recur env))))))))
1482            (recur (cdr eval-env))
1483            ))
1484      ))
1485  )
1486
1487
1488(define (definition-apply prefix name uenv #!key (type-hook #f) (component-hook #f) (value-hook #f))
1489
1490  (let ((name (if (or (string? name) (symbol? name)) (ident-create (->string name)) name))
1491        (source-defs (car uenv))
1492        (type-env    (cadr uenv))
1493        (eval-env    (caddr uenv)))
1494
1495    (let ((v (ident-find name eval-env)))
1496
1497      (and v
1498             
1499             (cond ((MLvalue? v) 
1500                    (let ((sxml-value (MLvalue->sxml v)))
1501                      (let* ((value (sxml:kid* sxml-value))
1502                             (tuple-label (and value ((sxpath '(Tuple left Const label *text*)) `(*TOP* ,sxml-value)))))
1503                        (if (pair? tuple-label)
1504                            (value-hook prefix (ident-name name) (car tuple-label) sxml-value)
1505                            (value-hook prefix (ident-name name) #f sxml-value))
1506                        )))
1507                           
1508                   (else #f))
1509             ))
1510      ))
1511
1512
1513
1514;; Taken from regex.scm:
1515
1516;;; Substitute matching strings:
1517
1518(define (string-search-positions rx str #!optional (start 0) (range (string-length str)))
1519  (let ((n (string-length str)))
1520    (and-let* ((m (irregex-search rx str start (min n (fx+ start range)))))
1521      (let loop ((i (irregex-match-num-submatches m))
1522                 (res '()))
1523        (if (fx< i 0)
1524            res
1525            (loop (fx- i 1) (cons (list (irregex-match-start-index m i)
1526                                        (irregex-match-end-index m i))
1527                                  res)))))))
1528
1529(define string-substitute
1530  (let ([substring substring]
1531        [reverse reverse]
1532        [make-string make-string]
1533        [string-search-positions string-search-positions] )
1534    (lambda (rx subst string . flag)
1535      (##sys#check-string subst 'string-substitute)
1536      (##sys#check-string string 'string-substitute)
1537      (let* ([which (if (pair? flag) (car flag) 1)]
1538             [substlen (##sys#size subst)]
1539             (strlen (##sys#size string))
1540             [substlen-1 (fx- substlen 1)]
1541             [result '()]
1542             [total 0] )
1543        (define (push x)
1544          (set! result (cons x result))
1545          (set! total (fx+ total (##sys#size x))) )
1546        (define (substitute matches)
1547          (let loop ([start 0] [index 0])
1548
1549
1550                 (if (fx>= index substlen-1)
1551                (push (if (fx= start 0) subst (substring subst start substlen)))
1552                (let ([c (##core#inline "C_subchar" subst index)]
1553                      [index+1 (fx+ index 1)] )
1554                  (if (char=? c #\\)
1555                      (let ([c2 (##core#inline "C_subchar" subst index+1)])
1556                        (if (and (not (char=? #\\ c2)) (char-numeric? c2))
1557                            (let ([mi (list-ref matches (fx- (char->integer c2) 48))])
1558                              (push (substring subst start index))
1559                              (push (substring string (car mi) (cadr mi)))
1560                              (loop (fx+ index 2) index+1) )
1561                            (loop start (fx+ index+1 1)) ) )
1562                      (loop start index+1) ) ) ) ) )
1563        (let loop ([index 0] [count 1])
1564          (let ((matches (and (fx< index strlen) 
1565                              (string-search-positions rx string index))))
1566            (cond [matches
1567                   (let* ([range (car matches)]
1568                          [upto (cadr range)] )
1569                     (cond ((fx= 0 (fx- (cadr range) (car range)))
1570                            (##sys#error
1571                             'string-substitute "empty substitution match"
1572                             rx) )
1573                           ((or (not (fixnum? which)) (fx= count which))
1574                            (push (substring string index (car range)))
1575                            (substitute matches)
1576                            (loop upto #f) )
1577                           (else
1578                            (push (substring string index upto))
1579                            (loop upto (fx+ count 1)) ) ) ) ]
1580                  [else
1581                   (push (substring string index (##sys#size string)))
1582                   (##sys#fragments->string total (reverse result)) ] ) ) ) ) ) ) )
1583
1584(define string-substitute*
1585  (let ([string-substitute string-substitute])
1586    (lambda (str smap . mode)
1587      (##sys#check-string str 'string-substitute*)
1588      (##sys#check-list smap 'string-substitute*)
1589      (let ((mode (and (pair? mode) (car mode))))
1590        (let loop ((str str) (smap smap))
1591          (if (null? smap)
1592              str
1593              (let ((sm (car smap)))
1594                (loop (string-substitute (car sm) (cdr sm) str mode)
1595                      (cdr smap) ) ) ) ) ) ) ) )
1596
1597
1598
1599)
Note: See TracBrowser for help on using the repository browser.