source: project/release/4/picnic/trunk/picnic.scm @ 30658

Last change on this file since 30658 was 30658, checked in by Ivan Raikov, 7 years ago

picnic: reworking config imports

File size: 34.5 KB
Line 
1;;
2;; Neural Parametric Curve Connectivity Language
3;;
4;; Copyright 2012-2014 Ivan Raikov and the Okinawa Institute of
5;; Science and Technology.
6;;
7;; This program is free software: you can redistribute it and/or
8;; modify it under the terms of the GNU General Public License as
9;; published by the Free Software Foundation, either version 3 of the
10;; License, or (at your option) any later version.
11;;
12;; This program is distributed in the hope that it will be useful, but
13;; WITHOUT ANY WARRANTY; without even the implied warranty of
14;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
15;; General Public License for more details.
16;;
17;; A full copy of the GPL license can be found at
18;; <http://www.gnu.org/licenses/>.
19;;
20;;
21
22
23(import scheme chicken)
24
25(require-extension srfi-1 picnic-core)
26(require-library iexpr ersatz-lib picnic-utils)
27(require-extension datatype matchable lalr-driver getopt-long)
28(import (prefix iexpr iexpr: )
29        (prefix ersatz-lib ersatz: )
30        (only picnic-utils load-config-file)
31        )
32
33(define rest cdr)
34
35(define-datatype picnic:model picnic:model?
36  (ModelSource (source-path string?) (in-format symbol?) (name symbol?) 
37               (decls list?) 
38               (user-templates user-template-list?)
39               (iexpr boolean?) (parse-expr procedure?))
40  (SingleModel (source-path string?) (in-format symbol?) (name symbol?) 
41               (sys hash-table?) (decls list?) (user-templates user-template-list?)
42               (iexpr boolean?) (parse-expr procedure?))
43  )
44
45
46(define-record-type section-descriptor 
47  (make-section-descriptor label processes)
48  section-descriptor? 
49  (label section-descriptor-label)
50  (processes section-descriptor-processes)
51  )
52
53
54(define-record-type projection-descriptor 
55  (make-projection-descriptor label poset imports)
56  projection-descriptor? 
57  (label projection-descriptor-label)
58  (poset projection-descriptor-poset)
59  (imports projection-descriptor-imports)
60  )
61
62
63
64 
65(define (d fstr . args)
66  (let ([port (current-error-port)])
67    (if (positive? (picnic-verbose)) 
68        (begin (apply fprintf port fstr args)
69               (flush-output port) ) )))
70
71
72(define (user-template-list? ts)
73  (every (lambda (x) (and (string? (car x))
74                          (every string? (cadr x))
75                          (every ersatz:tstmt? (caddr x)))) ts))
76
77
78(define (lookup-def k lst . rest)
79  (let-optionals rest ((default #f))
80      (let ((kv (assoc k lst)))
81        (if (not kv) default
82            (match kv ((k v) v) (else (cdr kv)))))))
83
84
85(define ($ x)  (and x (string->symbol (->string x))))
86
87
88;;; Procedures for string concatenation and pretty-printing
89
90(define (s+ . lst)    (string-concatenate (map ->string lst)))
91(define (sw+ lst)     (string-intersperse (filter-map (lambda (x) (and x (->string x))) lst) " "))
92(define (s\ p . lst)  (string-intersperse (map ->string lst) p))
93(define (slp p lst)   (string-intersperse (map ->string lst) p))
94(define nl "\n")
95
96
97(define (warn port message . specialising-msgs)
98  (print-error-message message (current-output-port) "Warning")
99  (print (string-concatenate (map ->string specialising-msgs))))
100
101;;; Error procedure for the XML parser
102
103(define (parser-error port message . specialising-msgs)
104  (error (string-append message (string-concatenate (map ->string specialising-msgs)))))
105
106(define ssax:warn warn)
107
108(define (defopt x)
109  (lookup-def x opt-defaults))
110
111(define opt-grammar
112  `(
113    (input-format
114     "specify input format (picnic, s-exp)"
115     (single-char #\i)
116     (value (required FORMAT)
117            (transformer ,string->symbol)))
118
119    (config-file "use the given hoc configuration file to obtain parameter values"
120                 (value (required FILENAME)))
121
122    (template
123     "instantiate the given template from the model file by setting the given variables to the respective values"
124     (value (required "NAME[:VAR=VAL...]"))
125     (multiple #t)
126     )
127
128    (template-prefix 
129     "output instantiated templates to <PREFIX><template_name> (default is <model-name>_<template_name>)"
130     (value (required PREFIX) ))
131
132    (debug "print additional debugging information" 
133           (single-char #\v))
134
135    (version "print the current version and exit")
136
137    (help         (single-char #\h))
138
139
140    ))
141
142
143;; Use args:usage to generate a formatted list of options (from OPTS),
144;; suitable for embedding into help text.
145(define (picnic:usage)
146  (print "Usage: " (car (argv)) "  <list of files to be processed> [options...] ")
147  (newline)
148  (print "The following options are recognized: ")
149  (newline)
150  (print (parameterize ((indent 5) (width 30)) (usage opt-grammar)))
151  (exit 1))
152
153
154;; Process arguments and collate options and arguments into OPTIONS
155;; alist, and operands (filenames) into OPERANDS.  You can handle
156;; options as they are processed, or afterwards.
157
158(define opts    (getopt-long (command-line-arguments) opt-grammar))
159(define opt     (make-option-dispatch opts opt-grammar))
160
161
162(define picnic-config (make-parameter '()))
163(if (opt 'config-file)
164    (picnic-config (load-config-file (opt 'config-file))))
165
166
167(define (picnic-constructor name config declarations parse-expr)
168  (let* ((picnic   (make-picnic-core `(config . ,config)))
169         (sys      ((picnic 'system) name))
170         (qs       (eval-picnic-system-decls picnic name sys declarations parse-expr: parse-expr)))
171    (list sys picnic qs)))
172
173
174(define (sexp->model-decls doc)
175  (match doc
176         ((or ('picnic-model model-name model-decls)
177              ('picnic-model (model-name . model-decls)))
178          (list model-name model-decls))
179         ((or ('picnic-model model-name model-decls user-templates)
180              ('picnic-model (model-name . model-decls) user-templates))
181          (list model-name model-decls 
182                (map (lambda (x) (list (->string (car x)) 
183                                       (map ->string (cadr x))
184                                       (ersatz:statements-from-string
185                                        (ersatz:template-std-env) 
186                                        (caddr x))))
187                             user-templates)))
188         (else (error 'sexp->model "unknown model format"))
189         ))
190
191
192(define (sexp-model-decls->model options model-name model-decls parse-expr)
193  (let* ((model+picnic  (picnic-constructor model-name (picnic-config) model-decls parse-expr))
194         (model (first model+picnic))
195         (picnic  (second model+picnic)))
196      (if (assoc 'depgraph options) (print "dependency graph: " ((picnic 'depgraph*) model)))
197      (if (assoc 'exports options)  (print "exports: " ((picnic 'exports) model)))     
198      (if (assoc 'imports options)  (print "imports: " ((picnic 'imports) model)))
199      (if (assoc 'components options)
200          (for-each (lambda (x) 
201                      (print "component " x ": " ((picnic 'component-exports) model (second x)))
202                      (print "component " x " subcomponents: " ((picnic 'component-subcomps) model (second x))))
203                    ((picnic 'components) model)))
204      model))
205         
206
207
208(include "expr-parser.scm")
209
210
211(define (instantiate-template user-templates template-name template-vars)
212  (let ((tmpl (assoc (->string template-name) user-templates string=?)))
213    (if (not tmpl)
214        (error 'picnic "template not found" template-name))
215    (let ((ctx (ersatz:init-context models: template-vars )))
216      (display
217       (ersatz:eval-statements (caddr tmpl)
218                               env: (ersatz:template-std-env)
219                               models: template-vars ctx: ctx))
220      )))
221
222
223(define (process-template model-name template-name template-args template-out user-templates source-path)
224
225  (let (
226        (template-vars (cons (cons 'model_name
227                                   (ersatz:Tstr (->string model-name)) )
228                             (map (lambda (x) 
229                                    (let ((kv (string-split x "=")))
230                                      (cons ($ (car kv))
231                                            (ersatz:Tstr (cadr kv)))))
232                                  template-args)))
233        )
234
235    (let* ((dirname (pathname-directory source-path))
236           (output-name (if (string-prefix? "." template-out)
237                            (make-pathname dirname (s+ model-name template-out)) 
238                            (make-pathname dirname (s+ model-name "_" template-out)) )))
239      (with-output-to-file output-name
240        (lambda () (instantiate-template user-templates template-name template-vars))
241        ))
242    ))
243
244
245
246
247(define (model-source->model source-path in-format model-name model-decls user-templates iexpr parse-expr)
248
249  (case in-format
250   
251    ((sexp picnic)
252     (SingleModel source-path in-format model-name
253                  (sexp-model-decls->model 
254                   `() model-name model-decls parse-expr)
255                  model-decls user-templates iexpr parse-expr))
256   
257    (else (error 'picnic "invalid input format"))
258    ))
259       
260 
261(define (qrhs x)
262  (and (picnic:quantity? x)
263       (cases picnic:quantity x
264              (SET  (name rhs)  `(SetExpr ,rhs))
265              (ASGN  (name value rhs)  rhs)
266              (INITIAL (name rhs)  rhs)
267              (else #f))))
268
269(define (qinit x)
270  (and (picnic:quantity? x)
271       (cases picnic:quantity x
272              (PS (name gfun init npts)   init)
273              (SEGPS (name gfun init nsegs nsegpts)   init)
274              (else #f))))
275
276(define (gfun x)
277  (and (picnic:quantity? x)
278       (cases picnic:quantity x
279              (PS (name gfun init npts)   gfun)
280              (SEGPS (name gfun init nsegs nsegpts)   gfun)
281              (else #f))))
282
283(define (process-model opt source-path in-format prefix sys model-decls iexpr? parse-expr)
284
285  (define (cid x)  (second x))
286  (define (cn x)   (first x))
287               
288  (match-let ((($ picnic:quantity 'DISPATCH dis) 
289               (hash-table-ref sys (picnic-intern 'dispatch))))
290                                   
291     (let* (
292            (sysname     ((lambda (x) (or (and prefix ($ (s+ prefix "_" x))) x)) ((dis 'sysname) sys)))
293            (dirname     (pathname-directory source-path))
294
295            (eval-const  (let ((eval-const (dis 'eval-const)))
296                           (lambda (x q) (eval-const sys x q))))
297            (consts      ((dis 'consts)  sys))
298            (defuns      ((dis 'defuns)  sys))
299            (asgns       ((dis 'asgns)   sys))
300            (initials    ((dis 'initials)   sys))
301            (sets        ((dis 'sets)   sys))
302            (configs     ((dis 'configs)  sys))
303            (imports     ((dis 'imports)  sys))
304            (exports     ((dis 'exports)  sys))
305            (components  ((dis 'components) sys))
306            (subcomps    (dis 'component-subcomps))
307
308            (component-exports (dis 'component-exports))
309            (component-imports (dis 'component-imports))
310
311            (g ((dis 'depgraph) sys))
312           
313
314            (cell-forests
315             (filter-map (match-lambda 
316                          ((name 'cell-forest id) (list name id 'global))
317                          ((name 'local-cell-forest id) (list name id 'local))
318                          (else #f)) 
319                         components))
320
321            (cell-section-comps
322             (map (lambda (forest)
323                    (let ((subcomponents (subcomps sys (cid forest))))
324                      (cons forest
325                            (filter-map 
326                             (match-lambda 
327                              (('section name id) (list name id))
328                              (else #f))
329                             subcomponents))))
330                  cell-forests))
331
332            (cell-layout-comps
333             (map (lambda (forest)
334                    (let ((subcomponents (subcomps sys (cid forest))))
335                      (cons forest
336                            (filter-map 
337                             (match-lambda 
338                              (('layout name id) (list name id))
339                              (else #f))
340                             subcomponents))))
341                  cell-forests))
342
343            (projection-comps
344             (filter-map (match-lambda 
345                          ((name 'projection id) (list name id))
346                          (else #f))
347                         components))
348
349            (cell-layouts 
350             (map (lambda (layouts)
351                    (let ((forest (first layouts))
352                          (layout (second layouts)))
353                      (cons forest
354                            (let ((exports (component-exports sys (cid layout))))
355                              (let* (
356                                     (pointset-name (first exports))
357                                     (poset ((dis 'depgraph->bfs-dist-poset) g 
358                                             root-labels: (list pointset-name)))
359                                     )
360                                (d "poset = ~A~%" poset)
361                                (d "pointset in ~A = ~A~%" layout pointset-name)
362                                (vector->list poset)
363                                ))
364                            ))
365                      )
366                    cell-layout-comps))
367
368            (cell-sections 
369             (map (lambda (sections)
370                    (let ((forest (first sections)))
371                      (cons forest
372                            (map
373                             (lambda (section)
374                               (let (
375                                     (label (cn section))
376                                     (exports (component-exports sys (cid section)))
377                                     (imports (component-imports sys (cid section)))
378                                     )
379                                 (d "label of ~A = ~A~%" (cid section) label)
380                                 (d "exports in ~A = ~A~%" section exports)
381                                 (d "imports in ~A = ~A~%" section imports)
382                                 (cons label
383                                       (make-section-descriptor
384                                        label
385                                        (map (lambda (prs)
386                                               (let* ((process-name (first prs))
387                                                      (n (second prs))
388                                                      (n-value ((dis 'eval-const) sys n process-name))
389                                                      (generator (gfun (hash-table-ref sys process-name)))
390                                                      (init (qinit (hash-table-ref sys process-name)))
391                                                      )
392                                                 (d "process in ~A = ~A~%" section process-name)
393                                                 (d "process generator function = ~A~%" generator)
394                                                 (list process-name n)))
395                                             (let recur ((prs '()) (exports exports))
396                                               (if (null? exports) 
397                                                   (reverse prs)
398                                                   (recur (cons (take exports 2) prs) 
399                                                          (drop exports 2))))
400                                             )))
401                                       ))
402                             (rest sections)))
403                      ))
404                  cell-section-comps))
405
406            ;; TODO: check that source/target populations are either:
407            ;; local/global
408            ;; global/global
409            (projections 
410             (fold-right
411              (lambda (projection-comp ax)
412                (d "projection-comp = ~A~%" projection-comp)
413                (let ((exports (component-exports sys (cid projection-comp)))
414                      (imports (component-imports sys (cid projection-comp))))
415                  (d "projection exports = ~A~%" exports)
416                  (d "projection imports = ~A~%" imports)
417                  (append
418                   (map
419                    (lambda (name)
420                      (let* (
421                             (label (string->symbol (last (string-split (->string name) "."))))
422                             (poset ((dis 'depgraph->bfs-dist-poset) g 
423                                     root-labels: (list name)))
424                             (poset (vector->list poset))
425                             )
426                        (make-projection-descriptor label poset imports)))
427                    exports) ax)
428                  ))
429              '()
430              projection-comps))
431
432            )
433
434       (for-each (lambda (b) (printf "~A~%" b)) prelude/scheme)
435
436       (for-each pp (map (lambda (x) `(define . ,x)) consts))
437       (for-each pp (map (lambda (x) `(define . ,x)) configs))
438
439       (for-each pp (filter-map (lambda (x) (defun-codegen/scheme x)) defuns))
440
441       
442       (d "cell sections = ~A~%" cell-sections)
443       
444       (for-each
445        (match-lambda
446         ((forest . layout)
447          (let ((sections (map cdr (alist-ref forest cell-sections))))
448            (pp (forest-codegen/scheme sys forest layout sections))
449            )))
450        cell-layouts)
451       
452       (d "projections = ~A~%" projections)
453
454       (for-each
455        (lambda (projection)
456          (pp (projection-codegen/scheme sys cell-forests cell-sections projection)))
457        projections)
458       
459       (for-each pp `((MPI:finalize)))
460       
461       ))
462
463  )
464
465
466(define prelude/scheme
467  `(#<<EOF
468(use srfi-1 mathh matchable kd-tree mpi getopt-long picnic-utils)
469(include "mathh-constants")
470
471(define picnic-write-pointsets (make-parameter #f))
472(define picnic-write-sections (make-parameter #f))
473(define local-config (make-parameter '()))
474
475
476(MPI:init)
477
478(define opt-grammar
479  `(
480
481    (write-pointsets "write generated pointsets to files"
482                     (single-char #\p))
483   
484    (write-sections "write generated sections to files"
485                    (single-char #\s))
486   
487    (verbose "print additional debugging information" 
488             (single-char #\v))
489   
490    (help         (single-char #\h))
491    ))
492
493;; Process arguments and collate options and arguments into OPTIONS
494;; alist, and operands (filenames) into OPERANDS.  You can handle
495;; options as they are processed, or afterwards.
496
497(define opts    (getopt-long (command-line-arguments) opt-grammar))
498(define opt     (make-option-dispatch opts opt-grammar))
499
500;; Use usage to generate a formatted list of options (from OPTS),
501;; suitable for embedding into help text.
502(define (my-usage)
503  (print "Usage: " (car (argv)) " [options...] ")
504  (newline)
505  (print "The following options are recognized: ")
506  (newline)
507  (print (parameterize ((indent 5)) (usage opt-grammar)))
508  (exit 1))
509
510(if (opt 'help)
511    (my-usage))
512
513(if (opt 'verbose)
514    (picnic-verbose 1))
515
516(if (opt 'write-pointsets)
517    (picnic-write-pointsets #t))
518
519(if (opt 'write-sections)
520    (picnic-write-sections #t))
521
522(if (picnic-verbose)
523    (pp (local-config) (current-error-port)))
524
525(define my-comm (MPI:get-comm-world))
526(define myrank  (MPI:comm-rank my-comm))
527(define mysize  (MPI:comm-size my-comm))
528
529(define-syntax
530  SetExpr
531  (syntax-rules
532      (population section union)
533    ((SetExpr (population p))
534     (lambda (repr) p))
535    ((SetExpr (section p t))
536     (lambda (repr)
537       (case repr
538         ((list)
539          (map (lambda (cell) 
540                 (list (cell-index cell) 
541                       (cell-section-ref (quote t) cell)))
542               p))
543         ((tree)
544          (cells-sections->kd-tree p (quote t)))
545         )))
546    ((SetExpr (union x y))
547     (lambda (repr) (append ((SetExpr x) repr) ((SetExpr y) repr))))
548    ))
549
550(define neg -)
551(define randomNormal random-normal)
552(define randomUniform random-uniform)
553(define randomInit random-init)
554
555
556(define PointsFromFile load-points-from-file)
557(define LineSegment make-line-segment)
558
559
560(define (SegmentProjection label r source target) 
561  (segment-projection label
562                      (source 'tree) (target 'list) 
563                      r my-comm myrank mysize))
564(define (Projection label r source target) 
565  (projection label
566              (source 'tree) (target 'list) 
567              r my-comm myrank mysize))
568
569
570EOF
571    ))
572
573
574
575(define (expr-codegen/scheme x)
576  (cond
577   ((or (symbol? x) (number? x) (string? x)) x)
578   (else
579    (match x 
580           (('let bnds body) 
581            `(let* ,(map (lambda (x) (list (car x) (expr-codegen/scheme (cadr x)))) bnds) 
582               ,(expr-codegen/scheme body)))
583           (((? symbol?) . rest) 
584            (cons (car x) (map expr-codegen/scheme (cdr x))))
585           (else #f))))
586  )
587
588
589(define (defun-codegen/scheme en)
590  (let ((data (procedure-data (second en))))
591    (and data
592         (let ((name (lookup-def 'name data))
593               (eval-body (lookup-def 'eval-body data))
594               (rt (lookup-def 'rt data))
595               (formals (lookup-def 'formals data)))
596           `(define ,name ,(expr-codegen/scheme eval-body))))
597    ))
598
599                               
600(define (invoke-generator/scheme sys section-name section-processes layout-name)
601  (let* ((origin (gensym 'p))
602         (make-section (cases picnic:quantity 
603                              (hash-table-ref sys (first (car section-processes)))
604                              (PS (name gfun init npts)   
605                                  'make-section)
606                              (SEGPS (name gfun init npts)   
607                                     'make-segmented-section)))
608         (exprs  (map
609                  (match-lambda
610                   ((process-name process-n)
611                    (cases picnic:quantity (hash-table-ref sys process-name)
612                           (PS (name gfun init npts)   
613                               (let ((init-var (and init (gensym 'v))))
614                                 (list
615                                  `(make-process
616                                    ,(if init `(,gfun ,origin ,init-var) `(,gfun ,origin) )
617                                    (inexact->exact ,npts))
618                                  init
619                                  init-var
620                                  process-n)))
621                           
622                           (SEGPS (name gfun init nsegs nsegpts)   
623                                  (let ((init-var (and init (gensym 'v))))
624                                    (list
625                                     `(make-segmented-process
626                                       ,(if init `(,gfun ,origin ,init-var) `(,gfun ,origin) )
627                                       (inexact->exact ,nsegs)
628                                       (inexact->exact ,nsegpts))
629                                     init
630                                     init-var
631                                     process-n)))
632                           )))
633                  section-processes))
634         )
635
636     ((lambda (x) (fold (match-lambda*
637                         (((expr init init-var n) ax) 
638                          (if init `(let ((,init-var ,init)) ,ax) ax)))
639                        x exprs))
640      `(let ((result
641              (second
642               (fold 
643                (match-lambda* 
644                 ((,origin (gid lst)) 
645                  (list (+ 1 gid) 
646                        (cons (,make-section 
647                               gid ,origin (quote ,section-name) 
648                               (second
649                                (fold (match-lambda*
650                                       (((f n) (i lst))
651                                        (list (+ i n)
652                                              (list-tabulate n
653                                                             (lambda (j) (list (+ i j) (f)))))))
654                                      (list 0 '())
655                                      (list . ,(map (match-lambda
656                                                     ((expr init init-var n)
657                                                      `(list (lambda () ,expr) 
658                                                             (inexact->exact ,n))))
659                                                    exprs)))))
660                              lst))))
661                (list 0 (list))
662                ,layout-name))))
663         (if (picnic-write-sections)
664             (write-sections (quote ,section-name) result))
665         result
666         ))
667
668     ))
669 
670
671
672(define (forest-codegen/scheme sys forest layout sections)
673
674  (define (forest-type x)  (third x))
675  (define (cid x)  (second x))
676  (define (cn x)   (first x))
677               
678
679  (d "forest = ~A~%" forest)
680  (d "layout = ~A~%" layout)
681  (d "sections = ~A~%" sections)
682
683
684  (let (
685        (layout-name
686         (gensym
687          (string->symbol
688           (string-append
689            (->string (cn forest))
690            "_layout"))))
691                 
692        (section-names
693         (map (lambda (section)
694                (gensym
695                 (string->symbol
696                  (string-append
697                   (->string (cn forest))
698                   (->string (section-descriptor-label section))))))
699              sections))
700        )
701
702    `(define  
703
704       ,(cid forest)
705
706       (let*
707           
708           (
709            (,layout-name 
710             (let* ((pts (kd-tree->list 
711                          (car ,(fold-right 
712                                 (lambda (xs ax)
713                                   (fold (match-lambda*
714                                          (((id . sym) ax)
715                                           (let ((rhs (qrhs (hash-table-ref sys sym))))
716                                             `(let ((,sym ,rhs)) ,ax))))
717                                         ax xs))
718                                 (cdr (last (last layout)))
719                                 layout))
720                          ))
721                    (layout
722                     ,(case (forest-type forest)
723                        ((local)
724                         `(let recur ((pts pts) (myindex 0) (ax '()))
725                            (if (null? pts) ax
726                                (let ((ax1 (if (= (modulo myindex mysize) myrank)
727                                               (cons (car pts) ax) ax)))
728                                  (recur (cdr pts) (+ 1 myindex) ax1)))
729                            ))
730                        ((global)
731                         'pts)))
732                    )
733               (if (picnic-write-pointsets)
734                   (write-pointset (quote ,(cn forest)) layout))
735               layout
736               ))
737            .
738            ,(map
739              (lambda (section section-name)
740                (let ((section-processes (section-descriptor-processes section))
741                      (section-label (section-descriptor-label section)))
742                  `(,section-name 
743                    ,(invoke-generator/scheme sys section-label section-processes layout-name))
744                  ))
745              sections 
746              section-names)
747           
748            )
749         
750         (first
751          (fold-right
752           (match-lambda*
753            ((p ,@section-names (lst i)) 
754             (list (cons (make-cell (quote ,(cn forest)) i p 
755                                    (list . ,section-names)) lst)
756                   (+ i 1) )))
757           (list '() 0)
758           ,layout-name . ,section-names))
759         
760         ))
761    ))
762
763
764
765(define (projection-codegen/scheme sys cell-forests cell-sections projection)
766
767  (define (resolve-forest-imports sym imports)
768    (let ((x (member sym imports)))
769      (d "resolve-forest-imports: sym = ~A imports = ~A cell-forests = ~A x = ~A~%" 
770         sym imports cell-forests x)
771      (and x (lookup-def (second sym) cell-forests))))
772         
773  (define (rewrite-projection expr label)
774    (cond
775     ((or (symbol? expr) (number? expr) (string? expr)) expr)
776     (else
777      (match expr
778             (('let bnds body) 
779              `(let* ,(map (lambda (x) (list (car x) (rewrite-projection (cadr x) label))) bnds) 
780                 ,(rewrite-projection body label)))
781             (((or 'SegmentProjection 'Projection) . rest)
782              (cons (car expr) (cons `(quote ,label) rest)))
783             (((? symbol?) . rest) 
784              (cons (car expr) (map (lambda (x) (rewrite-projection x label)) (cdr expr))))
785             (else expr)))
786    ))
787 
788
789  (let* (
790         (label   (projection-descriptor-label projection))
791         (poset   (projection-descriptor-poset projection))
792         (imports (projection-descriptor-imports projection))
793
794         (dd (d "projection imports = ~A~%" imports))
795         (dd (d "projection label = ~A~%" label))
796         (dd (d "projection poset = ~A~%" poset))
797         (dd (d "cell-sections = ~A~%" cell-sections))
798         (dd (d "cell-forests = ~A~%" cell-forests))
799
800         (projection-name
801          (gensym
802           (string->symbol
803            (string-append (->string label) "_projection"))))
804         )
805
806    `(define  
807
808       ,projection-name
809
810       
811       ,((lambda (body) 
812           (if (not (null? imports))
813               `(let ,(map (lambda (x)
814                             (let ((sym (first x))
815                                   (ns  (third x)))
816                               (case ns 
817                                 ((cell-forests)
818                                  `(,sym ,(first (resolve-forest-imports x imports))))
819                                 (else (error 'projection-codegen "unknown import namespace" ns)))
820                               ))
821                           imports)
822                  ,body)
823               body))
824         (fold-right 
825          (lambda (xs ax)
826            (fold (match-lambda*
827                   (((id . sym) ax)
828                    (let ((rhs (qrhs (hash-table-ref sys sym))))
829                      (d "projection poset sym = ~A rhs = ~A~%" sym rhs)
830                      (let ((rhs1 (rewrite-projection rhs label)))
831                        (if rhs1 `(let ((,sym ,rhs1)) ,ax) ax))
832                    ))
833                   )
834                  ax xs))
835          (cdr (last (last poset)))
836          poset))
837       )
838    ))
839
840 
841(define (main opt operands)
842
843  (if (opt 'version)
844      (begin
845        (print (picnic:version-string))
846        (exit 0)))
847
848  (if (null? operands)
849
850      (picnic:usage)
851
852      (let* (
853            (model-sources
854             (map
855              (lambda (operand)
856                (let* (
857                       (read-sexp 
858                        (lambda (name) 
859                          (call-with-input-file name read)))
860
861                       (read-iexpr
862                        (lambda (name) 
863                          (call-with-input-file name 
864                            (lambda (port) 
865                              (let ((content
866                                     (iexpr:tree->list
867                                      (iexpr:parse operand port))))
868                                (car content))))))
869                       
870                       (in-format
871                        (cond ((opt 'input-format) =>
872                               (lambda (x) 
873                                 (case ($ x)
874                                   ((picnic)        'picnic)
875                                   ((s-exp sexp)  'sexp)
876                                   (else          (error 'picnic "unknown input format" x)))))
877                              (else
878                               (case ((lambda (x) (or (not x) ($ x)))
879                                      (pathname-extension operand))
880                                 ((s-exp sexp)  'sexp)
881                                 (else 'picnic)))))
882
883                       (doc.iexpr
884                        (case in-format
885                          ((picnic) 
886                           (let ((content (read-sexp operand)))
887                             (if (eq? content 'picnic-model)
888                                 (cons (read-iexpr operand) #t)
889                                 (cons content #f))))
890                          ((sexp) 
891                           (cons (read-sexp operand) #f))
892                          (else    (error 'picnic "unknown input format" in-format))))
893                       
894                       (dd          (if (opt 'debug)
895                                        (begin
896                                          ;;(pp (car doc.iexpr))
897                                          (picnic-verbose 1))))
898                           
899                       (parse-expr
900                        (case in-format
901                          ((sexp)         identity)
902                          ((picnic)              (if (cdr doc.iexpr) 
903                                                   (lambda (x #!optional loc) 
904                                                     (if (string? x) (picnic:parse-string-expr x loc)
905                                                         (picnic:parse-sym-expr x loc)))
906                                                   picnic:parse-sym-expr))
907                          (else    (error 'picnic "unknown input format" in-format))))
908
909                       
910                       (model-name.model-decls
911                        (case in-format
912                          ((sexp picnic)         (sexp->model-decls (car doc.iexpr)))
913                          (else    (error 'picnic "unknown input format" in-format))))
914                       
915                       )
916
917                  (ModelSource
918                   operand in-format
919                   (car model-name.model-decls)
920                   (filter (lambda (x) (not (null? x))) (cadr model-name.model-decls))
921                   (match model-name.model-decls 
922                          ((_ _ user-templates)
923                           user-templates)
924                          (else '()))
925                   (cdr doc.iexpr) 
926                   parse-expr)
927                  ))
928              operands))
929
930            (models
931             (map (lambda (x) 
932                    (cases picnic:model x
933                           
934                           (ModelSource (source-path in-format model-name model-decls user-templates iexpr parse-expr)
935                                        (model-source->model source-path in-format model-name 
936                                                             model-decls user-templates iexpr parse-expr))
937                           
938                           
939                           (else (error 'name "invalid model source" x))))
940                 
941                  model-sources))
942            )
943       
944        (let ((template-insts (opt 'template)))
945
946          (for-each
947           
948           (lambda (model)
949             
950             (cases picnic:model model
951                   
952                    (SingleModel (source-path in-format model-name sys model-decls user-templates iexpr? parse-expr)
953                                 
954                                 (process-model opt source-path in-format #f sys model-decls iexpr? parse-expr)
955                                 
956                                 (if template-insts
957                                     (for-each
958                                      (lambda (template-inst)
959                                        (match-let (((template-name . template-args)
960                                                     (string-split template-inst ":")))
961                                                   (let ((output-file-suffix (or (opt 'template-prefix) template-name)))
962                                                     (process-template model-name template-name template-args 
963                                                                       output-file-suffix user-templates source-path))
964                                                   ))
965                                      template-insts))
966                                 )
967
968                 
969                  (else (error 'picnic "invalid model" model))))
970
971           models))
972        )
973      ))
974
975
976(main opt (opt '@))
977
Note: See TracBrowser for help on using the repository browser.