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

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

picnic: added local config resolver

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