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

Last change on this file since 31049 was 31049, checked in by Ivan Raikov, 6 years ago

picnic: added command-line option to supply lists of random number seeds

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