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

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

picnic: some bug fixes to multiple process generation

File size: 34.8 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 forest-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 
617                                         `(,gfun gid ,origin ,init-var) 
618                                         `(,gfun gid ,origin) )
619                                    (inexact->exact ,npts))
620                                  init
621                                  init-var
622                                  process-n)))
623                           
624                           (SEGPS (name gfun init nsegs nsegpts)   
625                                  (let ((init-var (and init (gensym 'v))))
626                                    (list
627                                     `(make-segmented-process
628                                       ,(if init 
629                                            `(,gfun gid ,origin ,init-var) 
630                                            `(,gfun gid ,origin) )
631                                       (inexact->exact ,nsegs)
632                                       (inexact->exact ,nsegpts))
633                                     init
634                                     init-var
635                                     process-n)))
636                           )))
637                  section-processes))
638         )
639
640     ((lambda (x) (fold (match-lambda*
641                         (((expr init init-var n) ax) 
642                          (if init `(let ((,init-var ,init)) ,ax) ax)))
643                        x exprs))
644      `(let ((result
645              (second
646               (fold 
647                (match-lambda* 
648                 ((,origin (gid lst)) 
649                  (list (+ 1 gid) 
650                        (cons (,make-section 
651                               gid ,origin (quote ,section-name) 
652                               (second
653                                (fold (match-lambda*
654                                       (((f n) (i lst))
655                                        (list (+ i n)
656                                              (append
657                                               (list-tabulate 
658                                                n (lambda (j) (list (+ i j) (f)))) lst))))
659                                      (list 0 '())
660                                      (list . ,(map (match-lambda
661                                                     ((expr init init-var n)
662                                                      `(list (lambda () ,expr) 
663                                                             (inexact->exact ,n))))
664                                                    exprs)))))
665                              lst))))
666                (list 0 (list))
667                ,layout-name))))
668         (if (picnic-write-sections)
669             (write-sections (quote ,forest-name) (quote ,section-name) result))
670         result
671         ))
672
673     ))
674 
675
676
677(define (forest-codegen/scheme sys forest layout sections)
678
679  (define (forest-type x)  (third x))
680  (define (cid x)  (second x))
681  (define (cn x)   (first x))
682               
683
684  (d "forest = ~A~%" forest)
685  (d "layout = ~A~%" layout)
686  (d "sections = ~A~%" sections)
687
688
689  (let (
690        (layout-name
691         (gensym
692          (string->symbol
693           (string-append
694            (->string (cn forest))
695            "_layout"))))
696                 
697        (section-names
698         (map (lambda (section)
699                (gensym
700                 (string->symbol
701                  (string-append
702                   (->string (cn forest))
703                   (->string (section-descriptor-label section))))))
704              sections))
705        )
706
707    `(define  
708
709       ,(cid forest)
710
711       (let*
712           
713           (
714            (,layout-name 
715             (let* ((pts (kd-tree->list 
716                          (car ,(fold-right 
717                                 (lambda (xs ax)
718                                   (fold (match-lambda*
719                                          (((id . sym) ax)
720                                           (let ((rhs (qrhs (hash-table-ref sys sym))))
721                                             `(let ((,sym ,rhs)) ,ax))))
722                                         ax xs))
723                                 (cdr (last (last layout)))
724                                 layout))
725                          ))
726                    (layout
727                     ,(case (forest-type forest)
728                        ((local)
729                         `(let recur ((pts pts) (myindex 0) (ax '()))
730                            (if (null? pts) ax
731                                (let ((ax1 (if (= (modulo myindex mysize) myrank)
732                                               (cons (car pts) ax) ax)))
733                                  (recur (cdr pts) (+ 1 myindex) ax1)))
734                            ))
735                        ((global)
736                         'pts)))
737                    )
738               (if (picnic-write-pointsets)
739                   (write-pointset (quote ,(cn forest)) layout))
740               layout
741               ))
742            .
743            ,(map
744              (lambda (section section-name)
745                (let ((section-processes (section-descriptor-processes section))
746                      (section-label (section-descriptor-label section)))
747                  `(,section-name 
748                    ,(invoke-generator/scheme sys section-label section-processes layout-name (cn forest)))
749                  ))
750              sections 
751              section-names)
752           
753            )
754         
755         (first
756          (fold-right
757           (match-lambda*
758            ((p ,@section-names (lst i)) 
759             (list (cons (make-cell (quote ,(cn forest)) i p 
760                                    (list . ,section-names)) lst)
761                   (+ i 1) )))
762           (list '() 0)
763           ,layout-name . ,section-names))
764         
765         ))
766    ))
767
768
769
770(define (projection-codegen/scheme sys cell-forests cell-sections projection)
771
772  (define (resolve-forest-imports sym imports)
773    (let ((x (member sym imports)))
774      (d "resolve-forest-imports: sym = ~A imports = ~A cell-forests = ~A x = ~A~%" 
775         sym imports cell-forests x)
776      (and x (lookup-def (second sym) cell-forests))))
777         
778  (define (rewrite-projection expr label)
779    (cond
780     ((or (symbol? expr) (number? expr) (string? expr)) expr)
781     (else
782      (match expr
783             (('let bnds body) 
784              `(let* ,(map (lambda (x) (list (car x) (rewrite-projection (cadr x) label))) bnds) 
785                 ,(rewrite-projection body label)))
786             (((or 'SegmentProjection 'Projection) . rest)
787              (cons (car expr) (cons `(quote ,label) rest)))
788             (((? symbol?) . rest) 
789              (cons (car expr) (map (lambda (x) (rewrite-projection x label)) (cdr expr))))
790             (else expr)))
791    ))
792 
793
794  (let* (
795         (label   (projection-descriptor-label projection))
796         (poset   (projection-descriptor-poset projection))
797         (imports (projection-descriptor-imports projection))
798
799         (dd (d "projection imports = ~A~%" imports))
800         (dd (d "projection label = ~A~%" label))
801         (dd (d "projection poset = ~A~%" poset))
802         (dd (d "cell-sections = ~A~%" cell-sections))
803         (dd (d "cell-forests = ~A~%" cell-forests))
804
805         (projection-name
806          (gensym
807           (string->symbol
808            (string-append (->string label) "_projection"))))
809         )
810
811    `(define  
812
813       ,projection-name
814
815       
816       ,((lambda (body) 
817           (if (not (null? imports))
818               `(let ,(map (lambda (x)
819                             (let ((sym (first x))
820                                   (ns  (third x)))
821                               (case ns 
822                                 ((cell-forests)
823                                  `(,sym ,(first (resolve-forest-imports x imports))))
824                                 (else (error 'projection-codegen "unknown import namespace" ns)))
825                               ))
826                           imports)
827                  ,body)
828               body))
829         (fold-right 
830          (lambda (xs ax)
831            (fold (match-lambda*
832                   (((id . sym) ax)
833                    (let ((rhs (qrhs (hash-table-ref sys sym))))
834                      (d "projection poset sym = ~A rhs = ~A~%" sym rhs)
835                      (let ((rhs1 (rewrite-projection rhs label)))
836                        (if rhs1 `(let ((,sym ,rhs1)) ,ax) ax))
837                    ))
838                   )
839                  ax xs))
840          (cdr (last (last poset)))
841          poset))
842       )
843    ))
844
845 
846(define (main opt operands)
847
848  (if (opt 'version)
849      (begin
850        (print (picnic:version-string))
851        (exit 0)))
852
853  (if (null? operands)
854
855      (picnic:usage)
856
857      (let* (
858            (model-sources
859             (map
860              (lambda (operand)
861                (let* (
862                       (read-sexp 
863                        (lambda (name) 
864                          (call-with-input-file name read)))
865
866                       (read-iexpr
867                        (lambda (name) 
868                          (call-with-input-file name 
869                            (lambda (port) 
870                              (let ((content
871                                     (iexpr:tree->list
872                                      (iexpr:parse operand port))))
873                                (car content))))))
874                       
875                       (in-format
876                        (cond ((opt 'input-format) =>
877                               (lambda (x) 
878                                 (case ($ x)
879                                   ((picnic)        'picnic)
880                                   ((s-exp sexp)  'sexp)
881                                   (else          (error 'picnic "unknown input format" x)))))
882                              (else
883                               (case ((lambda (x) (or (not x) ($ x)))
884                                      (pathname-extension operand))
885                                 ((s-exp sexp)  'sexp)
886                                 (else 'picnic)))))
887
888                       (doc.iexpr
889                        (case in-format
890                          ((picnic) 
891                           (let ((content (read-sexp operand)))
892                             (if (eq? content 'picnic-model)
893                                 (cons (read-iexpr operand) #t)
894                                 (cons content #f))))
895                          ((sexp) 
896                           (cons (read-sexp operand) #f))
897                          (else    (error 'picnic "unknown input format" in-format))))
898                       
899                       (dd          (if (opt 'debug)
900                                        (begin
901                                          ;;(pp (car doc.iexpr))
902                                          (picnic-verbose 1))))
903                           
904                       (parse-expr
905                        (case in-format
906                          ((sexp)         identity)
907                          ((picnic)              (if (cdr doc.iexpr) 
908                                                   (lambda (x #!optional loc) 
909                                                     (if (string? x) (picnic:parse-string-expr x loc)
910                                                         (picnic:parse-sym-expr x loc)))
911                                                   picnic:parse-sym-expr))
912                          (else    (error 'picnic "unknown input format" in-format))))
913
914                       
915                       (model-name.model-decls
916                        (case in-format
917                          ((sexp picnic)         (sexp->model-decls (car doc.iexpr)))
918                          (else    (error 'picnic "unknown input format" in-format))))
919                       
920                       )
921
922                  (ModelSource
923                   operand in-format
924                   (car model-name.model-decls)
925                   (filter (lambda (x) (not (null? x))) (cadr model-name.model-decls))
926                   (match model-name.model-decls 
927                          ((_ _ user-templates)
928                           user-templates)
929                          (else '()))
930                   (cdr doc.iexpr) 
931                   parse-expr)
932                  ))
933              operands))
934
935            (models
936             (map (lambda (x) 
937                    (cases picnic:model x
938                           
939                           (ModelSource (source-path in-format model-name model-decls user-templates iexpr parse-expr)
940                                        (model-source->model source-path in-format model-name 
941                                                             model-decls user-templates iexpr parse-expr))
942                           
943                           
944                           (else (error 'name "invalid model source" x))))
945                 
946                  model-sources))
947            )
948       
949        (let ((template-insts (opt 'template)))
950
951          (for-each
952           
953           (lambda (model)
954             
955             (cases picnic:model model
956                   
957                    (SingleModel (source-path in-format model-name sys model-decls user-templates iexpr? parse-expr)
958                                 
959                                 (process-model opt source-path in-format #f sys model-decls iexpr? parse-expr)
960                                 
961                                 (if template-insts
962                                     (for-each
963                                      (lambda (template-inst)
964                                        (match-let (((template-name . template-args)
965                                                     (string-split template-inst ":")))
966                                                   (let ((output-file-suffix (or (opt 'template-prefix) template-name)))
967                                                     (process-template model-name template-name template-args 
968                                                                       output-file-suffix user-templates source-path))
969                                                   ))
970                                      template-insts))
971                                 )
972
973                 
974                  (else (error 'picnic "invalid model" model))))
975
976           models))
977        )
978      ))
979
980
981(main opt (opt '@))
982
Note: See TracBrowser for help on using the repository browser.