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

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

picnic: reformulated gid assignment based on layout; added mpi-aware write-layouts procedure

File size: 35.4 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-layouts (make-parameter #f))
473(define picnic-write-sections (make-parameter #f))
474(define local-config (make-parameter '()))
475
476
477(MPI:init)
478
479(define opt-grammar
480  `(
481
482    (write-pointsets "write generated or loaded pointsets to files"
483                     (single-char #\p))
484   
485    (write-layouts "write layouts to files"
486                   (single-char #\l))
487   
488    (write-sections "write generated sections to files"
489                    (single-char #\s))
490   
491    (verbose "print additional debugging information" 
492             (single-char #\v))
493   
494    (help         (single-char #\h))
495    ))
496
497;; Process arguments and collate options and arguments into OPTIONS
498;; alist, and operands (filenames) into OPERANDS.  You can handle
499;; options as they are processed, or afterwards.
500
501(define opts    (getopt-long (command-line-arguments) opt-grammar))
502(define opt     (make-option-dispatch opts opt-grammar))
503
504;; Use usage to generate a formatted list of options (from OPTS),
505;; suitable for embedding into help text.
506(define (my-usage)
507  (print "Usage: " (car (argv)) " [options...] ")
508  (newline)
509  (print "The following options are recognized: ")
510  (newline)
511  (print (parameterize ((indent 5)) (usage opt-grammar)))
512  (exit 1))
513
514(if (opt 'help)
515    (my-usage))
516
517(if (opt 'verbose)
518    (picnic-verbose 1))
519
520(if (opt 'write-pointsets)
521    (picnic-write-pointsets #t))
522
523(if (opt 'write-layouts)
524    (picnic-write-layouts #t))
525
526(if (opt 'write-sections)
527    (picnic-write-sections #t))
528
529(if (picnic-verbose)
530    (pp (local-config) (current-error-port)))
531
532(define my-comm (MPI:get-comm-world))
533(define myrank  (MPI:comm-rank my-comm))
534(define mysize  (MPI:comm-size my-comm))
535
536(define-syntax
537  SetExpr
538  (syntax-rules
539      (population section union)
540    ((SetExpr (population p))
541     (lambda (repr) p))
542    ((SetExpr (section p t))
543     (lambda (repr)
544       (case repr
545         ((list)
546          (map (lambda (cell) 
547                 (list (cell-index cell) 
548                       (cell-section-ref (quote t) cell)))
549               p))
550         ((tree)
551          (cells-sections->kd-tree p (quote t)))
552         )))
553    ((SetExpr (union x y))
554     (lambda (repr) (append ((SetExpr x) repr) ((SetExpr y) repr))))
555    ))
556
557(define neg -)
558(define randomNormal random-normal)
559(define randomUniform random-uniform)
560(define randomInit random-init)
561
562
563(define PointsFromFile load-points-from-file)
564(define LineSegment make-line-segment)
565
566
567(define (SegmentProjection label r source target) 
568  (segment-projection label
569                      (source 'tree) (target 'list) 
570                      r my-comm myrank mysize))
571(define (Projection label r source target) 
572  (projection label
573              (source 'tree) (target 'list) 
574              r my-comm myrank mysize))
575
576
577EOF
578    ))
579
580
581
582(define (expr-codegen/scheme x)
583  (cond
584   ((or (symbol? x) (number? x) (string? x)) x)
585   (else
586    (match x 
587           (('let bnds body) 
588            `(let* ,(map (lambda (x) (list (car x) (expr-codegen/scheme (cadr x)))) bnds) 
589               ,(expr-codegen/scheme body)))
590           (((? symbol?) . rest) 
591            (cons (car x) (map expr-codegen/scheme (cdr x))))
592           (else #f))))
593  )
594
595
596(define (defun-codegen/scheme en)
597  (let ((data (procedure-data (second en))))
598    (and data
599         (let ((name (lookup-def 'name data))
600               (eval-body (lookup-def 'eval-body data))
601               (rt (lookup-def 'rt data))
602               (formals (lookup-def 'formals data)))
603           `(define ,name ,(expr-codegen/scheme eval-body))))
604    ))
605
606                               
607(define (invoke-generator/scheme sys section-name section-processes layout-name forest-name forest-type)
608  (let* ((origin (gensym 'p))
609         (make-section (cases picnic:quantity 
610                              (hash-table-ref sys (first (car section-processes)))
611                              (PS (name gfun init npts)   
612                                  'make-section)
613                              (SEGPS (name gfun init npts)   
614                                     'make-segmented-section)))
615         (exprs  (map
616                  (match-lambda
617                   ((process-name process-n)
618                    (cases picnic:quantity (hash-table-ref sys process-name)
619                           (PS (name gfun init npts)   
620                               (let ((init-var (and init (gensym 'v))))
621                                 (list
622                                  `(make-process
623                                    ,(if init 
624                                         `(,gfun gid ,origin ,init-var) 
625                                         `(,gfun gid ,origin) )
626                                    (inexact->exact ,npts))
627                                  init
628                                  init-var
629                                  process-n)))
630                           
631                           (SEGPS (name gfun init nsegs nsegpts)   
632                                  (let ((init-var (and init (gensym 'v))))
633                                    (list
634                                     `(make-segmented-process
635                                       ,(if init 
636                                            `(,gfun gid ,origin ,init-var) 
637                                            `(,gfun gid ,origin) )
638                                       (inexact->exact ,nsegs)
639                                       (inexact->exact ,nsegpts))
640                                     init
641                                     init-var
642                                     process-n)))
643                           )))
644                  section-processes))
645         )
646
647     ((lambda (x) (fold (match-lambda*
648                         (((expr init init-var n) ax) 
649                          (if init `(let ((,init-var ,init)) ,ax) ax)))
650                        x exprs))
651      `(let ((result
652              (fold 
653               (match-lambda* 
654                (((gid ,origin) lst)
655                 (cons (,make-section 
656                        gid ,origin (quote ,section-name) 
657                        (second
658                         (fold (match-lambda*
659                                (((f n) (i lst))
660                                 (list (+ i n)
661                                       (append
662                                        (list-tabulate 
663                                         n (lambda (j) (list (+ i j) (f)))) lst))))
664                               (list 0 '())
665                               (list . ,(map (match-lambda
666                                              ((expr init init-var n)
667                                               `(list (lambda () ,expr) 
668                                                      (inexact->exact ,n))))
669                                             exprs)))))
670                       lst)))
671                (list)
672                ,layout-name)))
673         (if (picnic-write-sections)
674             ,(case forest-type
675                ((local)
676                 `(write-sections (quote ,forest-name) (quote ,section-name) ,layout-name result myrank))
677                ((global)
678                 `(write-sections (quote ,forest-name) (quote ,section-name) ,layout-name result))))
679         result
680         ))
681
682     ))
683 
684
685
686(define (forest-codegen/scheme sys forest layout sections)
687
688  (define (forest-type x)  (third x))
689  (define (cid x)  (second x))
690  (define (cn x)   (first x))
691               
692
693  (d "forest = ~A~%" forest)
694  (d "layout = ~A~%" layout)
695  (d "sections = ~A~%" sections)
696
697
698  (let (
699        (layout-name
700         (gensym
701          (string->symbol
702           (string-append
703            (->string (cn forest))
704            "_layout"))))
705                 
706        (section-names
707         (map (lambda (section)
708                (gensym
709                 (string->symbol
710                  (string-append
711                   (->string (cn forest))
712                   (->string (section-descriptor-label section))))))
713              sections))
714        )
715
716    `(define  
717
718       ,(cid forest)
719
720       (let*
721           
722           (
723            (,layout-name 
724             (let* ((pts (kd-tree->list*
725                          (car ,(fold-right 
726                                 (lambda (xs ax)
727                                   (fold (match-lambda*
728                                          (((id . sym) ax)
729                                           (let ((rhs (qrhs (hash-table-ref sys sym))))
730                                             `(let ((,sym ,rhs)) ,ax))))
731                                         ax xs))
732                                 (cdr (last (last layout)))
733                                 layout))
734                          ))
735                    (layout
736                     ,(case (forest-type forest)
737                        ((local)
738                         `(let recur ((pts pts) (myindex 0) (ax '()))
739                            (if (null? pts) ax
740                                (let ((ax1 (if (= (modulo myindex mysize) myrank)
741                                               (cons (car pts) ax) ax)))
742                                  (recur (cdr pts) (+ 1 myindex) ax1)))
743                            ))
744                        ((global)
745                         'pts)))
746                    )
747               (if (picnic-write-pointsets)
748                   (write-pointset (quote ,(cn forest)) pts))
749               (if (picnic-write-layouts)
750                   ,(case (forest-type forest)
751                      ((local)
752                       `(write-layout (quote ,(cn forest)) layout myrank))
753                      ((global)
754                       `(write-layout (quote ,(cn forest)) layout))))
755               layout
756               ))
757            .
758            ,(map
759              (lambda (section section-name)
760                (let ((section-processes (section-descriptor-processes section))
761                      (section-label (section-descriptor-label section)))
762                  `(,section-name 
763                    ,(invoke-generator/scheme sys section-label section-processes layout-name 
764                                              (cn forest) (forest-type forest)))
765                  ))
766              sections 
767              section-names)
768           
769            )
770         
771          (fold-right
772           (match-lambda*
773            (((gid p) ,@section-names lst)
774             (cons (make-cell (quote ,(cn forest)) gid p 
775                              (list . ,section-names)) lst)
776             ))
777           '()
778           ,layout-name . ,section-names)
779         
780         ))
781    ))
782
783
784
785(define (projection-codegen/scheme sys cell-forests cell-sections projection)
786
787  (define (resolve-forest-imports sym imports)
788    (let ((x (member sym imports)))
789      (d "resolve-forest-imports: sym = ~A imports = ~A cell-forests = ~A x = ~A~%" 
790         sym imports cell-forests x)
791      (and x (lookup-def (second sym) cell-forests))))
792         
793  (define (rewrite-projection expr label)
794    (cond
795     ((or (symbol? expr) (number? expr) (string? expr)) expr)
796     (else
797      (match expr
798             (('let bnds body) 
799              `(let* ,(map (lambda (x) (list (car x) (rewrite-projection (cadr x) label))) bnds) 
800                 ,(rewrite-projection body label)))
801             (((or 'SegmentProjection 'Projection) . rest)
802              (cons (car expr) (cons `(quote ,label) rest)))
803             (((? symbol?) . rest) 
804              (cons (car expr) (map (lambda (x) (rewrite-projection x label)) (cdr expr))))
805             (else expr)))
806    ))
807 
808
809  (let* (
810         (label   (projection-descriptor-label projection))
811         (poset   (projection-descriptor-poset projection))
812         (imports (projection-descriptor-imports projection))
813
814         (dd (d "projection imports = ~A~%" imports))
815         (dd (d "projection label = ~A~%" label))
816         (dd (d "projection poset = ~A~%" poset))
817         (dd (d "cell-sections = ~A~%" cell-sections))
818         (dd (d "cell-forests = ~A~%" cell-forests))
819
820         (projection-name
821          (gensym
822           (string->symbol
823            (string-append (->string label) "_projection"))))
824         )
825
826    `(define  
827
828       ,projection-name
829
830       
831       ,((lambda (body) 
832           (if (not (null? imports))
833               `(let ,(map (lambda (x)
834                             (let ((sym (first x))
835                                   (ns  (third x)))
836                               (case ns 
837                                 ((cell-forests)
838                                  `(,sym ,(first (resolve-forest-imports x imports))))
839                                 (else (error 'projection-codegen "unknown import namespace" ns)))
840                               ))
841                           imports)
842                  ,body)
843               body))
844         (fold-right 
845          (lambda (xs ax)
846            (fold (match-lambda*
847                   (((id . sym) ax)
848                    (let ((rhs (qrhs (hash-table-ref sys sym))))
849                      (d "projection poset sym = ~A rhs = ~A~%" sym rhs)
850                      (let ((rhs1 (rewrite-projection rhs label)))
851                        (if rhs1 `(let ((,sym ,rhs1)) ,ax) ax))
852                    ))
853                   )
854                  ax xs))
855          (cdr (last (last poset)))
856          poset))
857       )
858    ))
859
860 
861(define (main opt operands)
862
863  (if (opt 'version)
864      (begin
865        (print (picnic:version-string))
866        (exit 0)))
867
868  (if (null? operands)
869
870      (picnic:usage)
871
872      (let* (
873            (model-sources
874             (map
875              (lambda (operand)
876                (let* (
877                       (read-sexp 
878                        (lambda (name) 
879                          (call-with-input-file name read)))
880
881                       (read-iexpr
882                        (lambda (name) 
883                          (call-with-input-file name 
884                            (lambda (port) 
885                              (let ((content
886                                     (iexpr:tree->list
887                                      (iexpr:parse operand port))))
888                                (car content))))))
889                       
890                       (in-format
891                        (cond ((opt 'input-format) =>
892                               (lambda (x) 
893                                 (case ($ x)
894                                   ((picnic)        'picnic)
895                                   ((s-exp sexp)  'sexp)
896                                   (else          (error 'picnic "unknown input format" x)))))
897                              (else
898                               (case ((lambda (x) (or (not x) ($ x)))
899                                      (pathname-extension operand))
900                                 ((s-exp sexp)  'sexp)
901                                 (else 'picnic)))))
902
903                       (doc.iexpr
904                        (case in-format
905                          ((picnic) 
906                           (let ((content (read-sexp operand)))
907                             (if (eq? content 'picnic-model)
908                                 (cons (read-iexpr operand) #t)
909                                 (cons content #f))))
910                          ((sexp) 
911                           (cons (read-sexp operand) #f))
912                          (else    (error 'picnic "unknown input format" in-format))))
913                       
914                       (dd          (if (opt 'debug)
915                                        (begin
916                                          ;;(pp (car doc.iexpr))
917                                          (picnic-verbose 1))))
918                           
919                       (parse-expr
920                        (case in-format
921                          ((sexp)         identity)
922                          ((picnic)              (if (cdr doc.iexpr) 
923                                                   (lambda (x #!optional loc) 
924                                                     (if (string? x) (picnic:parse-string-expr x loc)
925                                                         (picnic:parse-sym-expr x loc)))
926                                                   picnic:parse-sym-expr))
927                          (else    (error 'picnic "unknown input format" in-format))))
928
929                       
930                       (model-name.model-decls
931                        (case in-format
932                          ((sexp picnic)         (sexp->model-decls (car doc.iexpr)))
933                          (else    (error 'picnic "unknown input format" in-format))))
934                       
935                       )
936
937                  (ModelSource
938                   operand in-format
939                   (car model-name.model-decls)
940                   (filter (lambda (x) (not (null? x))) (cadr model-name.model-decls))
941                   (match model-name.model-decls 
942                          ((_ _ user-templates)
943                           user-templates)
944                          (else '()))
945                   (cdr doc.iexpr) 
946                   parse-expr)
947                  ))
948              operands))
949
950            (models
951             (map (lambda (x) 
952                    (cases picnic:model x
953                           
954                           (ModelSource (source-path in-format model-name model-decls user-templates iexpr parse-expr)
955                                        (model-source->model source-path in-format model-name 
956                                                             model-decls user-templates iexpr parse-expr))
957                           
958                           
959                           (else (error 'name "invalid model source" x))))
960                 
961                  model-sources))
962            )
963       
964        (let ((template-insts (opt 'template)))
965
966          (for-each
967           
968           (lambda (model)
969             
970             (cases picnic:model model
971                   
972                    (SingleModel (source-path in-format model-name sys model-decls user-templates iexpr? parse-expr)
973                                 
974                                 (process-model opt source-path in-format #f sys model-decls iexpr? parse-expr)
975                                 
976                                 (if template-insts
977                                     (for-each
978                                      (lambda (template-inst)
979                                        (match-let (((template-name . template-args)
980                                                     (string-split template-inst ":")))
981                                                   (let ((output-file-suffix (or (opt 'template-prefix) template-name)))
982                                                     (process-template model-name template-name template-args 
983                                                                       output-file-suffix user-templates source-path))
984                                                   ))
985                                      template-insts))
986                                 )
987
988                 
989                  (else (error 'picnic "invalid model" model))))
990
991           models))
992        )
993      ))
994
995
996(main opt (opt '@))
997
Note: See TracBrowser for help on using the repository browser.