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

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

picnic: converted to GLHP example to iexpr format

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