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

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

picnic: working support for swc morphologies

File size: 50.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-swc-section-comps
340             (map (lambda (forest)
341                    (let ((subcomponents (subcomps sys (cid forest))))
342                      (cons forest
343                            (filter-map 
344                             (match-lambda 
345                              (('swc-section name id) (list name id))
346                              (else #f))
347                             subcomponents))))
348                  cell-forests))
349
350            (cell-layout-comps
351             (map (lambda (forest)
352                    (let ((subcomponents (subcomps sys (cid forest))))
353                      (cons forest
354                            (filter-map 
355                             (match-lambda 
356                              (('layout name id) (list name id))
357                              (else #f))
358                             subcomponents))))
359                  cell-forests))
360
361            (forest-pointset-comps
362             (map (lambda (forest)
363                    (let ((subcomponents (subcomps sys (cid forest))))
364                      (cons forest
365                            (filter-map 
366                             (match-lambda 
367                              (('pointset name id) (list name id))
368                              (else #f))
369                             subcomponents))))
370                  cell-forests))
371
372            (projection-comps
373             (filter-map (match-lambda 
374                          ((name 'projection id) (list name id))
375                          (else #f))
376                         components))
377
378            (cell-layouts 
379             (map (lambda (forest+layouts)
380                    (let ((forest  (first forest+layouts))
381                          (layouts (cdr forest+layouts)))
382                      (cons forest
383                            (map (lambda (layout)
384                                   (let ((exports (component-exports sys (cid layout))))
385                                     (let* (
386                                            (pointset-name (first exports))
387                                            (poset ((dis 'depgraph->bfs-dist-poset) g 
388                                                    root-labels: (list pointset-name)))
389                                            )
390                                       (d "poset = ~A~%" poset)
391                                       (d "pointset in ~A = ~A~%" layout pointset-name)
392                                       (vector->list poset)
393                                       ))
394                                   ) layouts))
395                      ))
396                    cell-layout-comps))
397
398            (forest-pointsets 
399             (filter-map
400              (lambda (forest+pointsets)
401                (let ((forest    (first forest+pointsets))
402                      (pointsets (cdr forest+pointsets)))
403                  (if (null? pointsets) #f
404                      (cons forest
405                            (map (lambda (pointset)
406                                   (let ((exports (component-exports sys (cid pointset))))
407                                     (let* (
408                                            (pointset-name (first exports))
409                                            (poset ((dis 'depgraph->bfs-dist-poset) g 
410                                                    root-labels: (list pointset-name)))
411                                            )
412                                       (d "poset = ~A~%" poset)
413                                       (d "pointset in ~A = ~A~%" forest pointset-name)
414                                       (list (cn pointset) (vector->list poset))
415                                       ))
416                                   ) pointsets)))
417                  ))
418              forest-pointset-comps))
419
420
421            (cell-sections 
422             (map
423              (lambda (sections)
424                (let ((forest (first sections)))
425                  (cons forest
426                        (reverse
427                         (second
428                          (fold
429                           (match-lambda* ((section (start-index lst))
430                             (let* (
431                                   (label    (cn section))
432                                   (exports  (component-exports sys (cid section)))
433                                   (imports  (component-imports sys (cid section)))
434                                   (perturbs (filter-map (lambda (x) 
435                                                           (let ((comp (and (eq? (car x) 'perturbation) (second x))))
436                                                             (component-exports sys comp)
437                                                             ))
438                                                         (subcomps sys (cid section))))
439                                   (processes (map (lambda (prs)
440                                                     (let* ((process-name (first prs))
441                                                            (n (second prs))
442                                                            (n-value ((dis 'eval-const) sys n process-name))
443                                                            (generator (gfun (hash-table-ref sys process-name)))
444                                                            (init (qinit (hash-table-ref sys process-name)))
445                                                            )
446                                                       (d "process in ~A = ~A~%" section process-name)
447                                                       (d "process generator function = ~A~%" generator)
448                                                       (list process-name n n-value)))
449                                                   (let recur ((prs '()) (exports exports))
450                                                     (if (null? exports) 
451                                                         (reverse prs)
452                                                         (recur (cons (take exports 2) prs) 
453                                                                (drop exports 2))))
454                                                   ))
455                                   )
456                               (d "label of ~A = ~A~%" (cid section) label)
457                               (d "exports in ~A = ~A~%" section exports)
458                               (d "imports in ~A = ~A~%" section imports)
459                               (d "processes in ~A = ~A~%" section processes)
460                               (d "perturbations in ~A = ~A~%" section perturbs)
461                               (list
462                                (fold (lambda (x ax) (+ (third x) ax)) start-index processes)
463                                (cons (cons label (make-section-descriptor label start-index processes perturbs)) lst))
464                               )))
465                           (list 0 '())
466                           (rest sections)))
467                         ))
468                  ))
469              cell-section-comps))
470
471            (cell-swc-sections 
472              (map
473               (lambda (sections)
474                 (let ((forest (first sections)))
475                   (cons forest
476                         (reverse
477                          (second
478                           (fold
479                            (match-lambda* ((section (start-index lst))
480                             (let* (
481                                    (label    (cn section))
482                                    (exports  (component-exports sys (cid section)))
483                                    (imports  (component-imports sys (cid section)))
484                                    (swcs     (let recur ((swcs '()) (exports exports))
485                                                (if (null? exports) 
486                                                    (reverse swcs)
487                                                    (recur (cons (car exports) swcs) 
488                                                           (cdr exports))))
489                                              )
490                                   )
491                               (d "label of ~A = ~A~%" (cid section) label)
492                               (d "exports in ~A = ~A~%" section exports)
493                               (d "imports in ~A = ~A~%" section imports)
494                               (d "swcs in ~A = ~A~%" section swcs)
495                               (list
496                                (fold (lambda (x ax) (+ 1 ax)) start-index swcs)
497                                (cons (cons label (make-section-descriptor label start-index swcs '())) lst))
498                               )))
499                            (list 0 '())
500                            (rest sections)))
501                          ))
502                   ))
503               cell-swc-section-comps)
504              )
505
506            ;; TODO: check that source/target populations are either:
507            ;; local/global
508            ;; global/global
509            (projections 
510             (fold-right
511              (lambda (projection-comp ax)
512                (d "projection-comp = ~A~%" projection-comp)
513                (let ((exports (component-exports sys (cid projection-comp)))
514                      (imports (component-imports sys (cid projection-comp))))
515                  (d "projection exports = ~A~%" exports)
516                  (d "projection imports = ~A~%" imports)
517                  (append
518                   (map
519                    (lambda (name)
520                      (let* (
521                             (label (string->symbol (last (string-split (->string name) "."))))
522                             (poset ((dis 'depgraph->bfs-dist-poset) g 
523                                     root-labels: (list name)))
524                             (poset (vector->list poset))
525                             )
526                        (d "projection poset = ~A~%" poset)
527                        (make-projection-descriptor label poset imports)))
528                    exports) ax)
529                  ))
530              '()
531              projection-comps))
532
533            )
534
535       (with-output-to-file scm-fname 
536         (lambda () 
537           (begin
538             (for-each (lambda (b) (printf "~A~%" b)) prelude/scheme)
539
540             (for-each pp (map (lambda (x) `(define . ,x)) consts))
541             (for-each pp (map (lambda (x) `(define . ,x)) configs))
542             
543             (for-each pp (filter-map (lambda (x) (defun-codegen/scheme x)) defuns))
544             
545             
546             (d "cell sections = ~A~%" cell-sections)
547       
548             (for-each
549              (match-lambda
550               ((forest layout . rest)
551                (let ((sections (map cdr (alist-ref forest cell-sections)))
552                      (swc-sections (map cdr (alist-ref forest cell-swc-sections))))
553                  (pp (forest-codegen/scheme sys forest layout sections swc-sections))
554                  )))
555              cell-layouts)
556             
557             (for-each
558              (match-lambda
559               ((forest . pointsets)
560                (for-each pp (forest-pointset-codegen/scheme sys forest pointsets))))
561              forest-pointsets)
562             
563             (d "projections = ~A~%" projections)
564             
565             (for-each
566              (lambda (projection)
567                (pp (projection-codegen/scheme sys cell-forests cell-sections projection)))
568              projections)
569             
570             (for-each pp `((MPI:finalize)))
571             
572             ))
573         )
574       
575       (if (opt 'compile)
576           (compile -O3 ,scm-fname))
577       )
578     ))
579
580
581(define prelude/scheme
582  `(#<<EOF
583(use srfi-1 mathh matchable kd-tree mpi getopt-long picnic-utils)
584(include "mathh-constants")
585
586(define (choose lst n) (list-ref lst (random n)))
587
588(define picnic-write-pointsets (make-parameter #f))
589(define picnic-write-layouts (make-parameter #f))
590(define picnic-write-sections (make-parameter #f))
591(define local-config (make-parameter '()))
592
593
594(MPI:init)
595
596(define opt-grammar
597  `(
598
599    (write-pointsets "write generated or loaded pointsets to files"
600                     (single-char #\p))
601   
602    (write-layouts "write layouts to files"
603                   (single-char #\l))
604   
605    (write-sections "write generated sections to files"
606                    (single-char #\s))
607
608    (random-seeds "Use the given seeds for random number generation"
609                  (value (required SEED-LIST)
610                         (transformer ,(lambda (x) (map string->number
611                                                        (string-split x ","))))))
612   
613    (verbose "print additional debugging information" 
614             (single-char #\v))
615   
616    (help         (single-char #\h))
617    ))
618
619;; Process arguments and collate options and arguments into OPTIONS
620;; alist, and operands (filenames) into OPERANDS.  You can handle
621;; options as they are processed, or afterwards.
622
623(define opts    (getopt-long (command-line-arguments) opt-grammar))
624(define opt     (make-option-dispatch opts opt-grammar))
625
626;; Use usage to generate a formatted list of options (from OPTS),
627;; suitable for embedding into help text.
628(define (my-usage)
629  (print "Usage: " (car (argv)) " [options...] ")
630  (newline)
631  (print "The following options are recognized: ")
632  (newline)
633  (print (parameterize ((indent 5)) (usage opt-grammar)))
634  (exit 1))
635
636(if (opt 'help)
637    (my-usage))
638
639(if (opt 'verbose)
640    (picnic-verbose 1))
641
642(if (opt 'write-pointsets)
643    (picnic-write-pointsets #t))
644
645(if (opt 'write-layouts)
646    (picnic-write-layouts #t))
647
648(if (opt 'write-sections)
649    (picnic-write-sections #t))
650
651(if (picnic-verbose)
652    (pp (local-config) (current-error-port)))
653
654(define my-comm (MPI:get-comm-world))
655(define myrank  (MPI:comm-rank my-comm))
656(define mysize  (MPI:comm-size my-comm))
657
658(define-syntax
659  SetExpr
660  (syntax-rules
661      (population section union)
662    ((SetExpr (population p))
663     (lambda (repr) 
664       (case repr 
665             ((list) (map (lambda (cell)
666                            (list (cell-index cell)
667                                  (cell-origin cell)))
668                          p))
669             ((tree) (let ((pts (map (lambda (cell)
670                                       (list (cell-index cell)
671                                             (cell-origin cell)))
672                                     p)))
673                       (list->kd-tree pts
674                                      make-point: (lambda (v) (second v))
675                                      make-value: (lambda (i v) (list (first v) 0.0)))
676
677                       ))
678             )))
679    ((SetExpr (section p t))
680     (lambda (repr)
681       (case repr
682         ((list)
683          (map (lambda (cell) 
684                 (list (cell-index cell) 
685                       (cell-section-ref (quote t) cell)))
686               p))
687         ((tree)
688          (cells-sections->kd-tree p (quote t)))
689         )))
690    ((SetExpr (union x y))
691     (lambda (repr) (append ((SetExpr x) repr) ((SetExpr y) repr))))
692    ))
693
694(define neg -)
695
696(define random-seeds (make-parameter (apply circular-list (or (opt 'random-seeds) (list 13 17 19 23 29 37)))))
697
698(define (randomSeed)
699  (let ((v (car (random-seeds))))
700     (random-seeds (cdr (random-seeds)))
701     v))
702(define randomInit random-init)
703
704(define randomNormal random-normal)
705(define randomUniform random-uniform)
706
707(define PointsFromFile load-points-from-file)
708(define LineSegment make-line-segment)
709(define Harmonic make-harmonic)
710
711
712(define (SegmentProjection label r source target) 
713  (segment-projection label
714                      (source 'tree) (target 'list) 
715                      r my-comm myrank mysize))
716(define (Projection label r source target) 
717  (projection label
718              (source 'tree) (target 'list) 
719              r my-comm myrank mysize))
720
721
722EOF
723    ))
724
725
726
727(define (expr-codegen/scheme x)
728  (cond
729   ((or (symbol? x) (number? x) (string? x)) x)
730   (else
731    (match x 
732           (('let bnds body) 
733            `(let* ,(map (lambda (x) (list (car x) (expr-codegen/scheme (cadr x)))) bnds) 
734               ,(expr-codegen/scheme body)))
735           (((? symbol?) . rest) 
736            (cons (car x) (map expr-codegen/scheme (cdr x))))
737           (else #f))))
738  )
739
740
741(define (defun-codegen/scheme en)
742  (let ((data (procedure-data (second en))))
743    (and data
744         (let ((name (lookup-def 'name data))
745               (eval-body (lookup-def 'eval-body data))
746               (rt (lookup-def 'rt data))
747               (formals (lookup-def 'formals data)))
748           `(define ,name ,(expr-codegen/scheme eval-body))))
749    ))
750
751                               
752(define (invoke-generator/scheme sys section-name section-start-index
753                                 section-processes section-perturbations
754                                 layout-name forest-name forest-type)
755  (let* ((origin (gensym 'p))
756
757         (make-section (cases picnic:quantity 
758                              (hash-table-ref sys (first (car section-processes)))
759                              (PS (name gfun sfun init npts)   
760                                  'make-section)
761                              (SEGPS (name gfun sfun init npts)   
762                                     'make-segmented-section)))
763
764         (perturbation-exprs (map
765                              (match-lambda
766                               ((process-name process-n)
767                                (cases picnic:quantity (hash-table-ref sys process-name)
768                                       (PS (name gfun sfun init npts)   
769                                           (let ((init-var (and init (gensym 'v))))
770                                             (list
771                                              (if init 
772                                                  `(,gfun gid ,origin ,init-var) 
773                                                  `(,gfun gid ,origin))
774                                              init
775                                              init-var
776                                              process-n)))
777                                       
778                                       (SEGPS (name gfun sfun init nsegs nsegpts)   
779                                              (error 'invoke-generator/scheme
780                                                     "perturbation process cannot be segmented"
781                                                     process-name))
782                                       )))
783                              section-perturbations))
784
785         (make-perturbations (lambda (expr)
786                               (fold (match-lambda*
787                                      (((pexpr init init-var n) ax)
788                                        (let ((pvar (gensym 'p)))
789                                          (if init
790                                              `(let* ((,init-var ,init)
791                                                      (,pvar (list-tabulate (inexact->exact ,n) (lambda (i) ,pexpr))))
792                                                 (fold (lambda (p ax) (compose-curves p ax)) ,ax ,pvar))
793                                              `(let* ((,pvar (list-tabulate (inexact->exact ,n) (lambda (i) ,pexpr))))
794                                                 (fold (lambda (p ax) (compose-curves p ax)) ,ax ,pvar))
795                                              ))
796                                        ))
797                                     expr
798                                     perturbation-exprs)))
799                             
800
801         (exprs  (map
802
803                  (match-lambda
804                   ((process-name process-n . _)
805                   
806                    (cases picnic:quantity (hash-table-ref sys process-name)
807                           (PS (name gfun sfun init npts)   
808                               (let ((init-var (and init (gensym 'v))))
809                                 (list
810                                  `(make-process
811                                    ,(make-perturbations
812                                      (if init 
813                                          `(,gfun gid ,origin ,init-var) 
814                                          `(,gfun gid ,origin) ))
815                                    ,(case (car sfun)
816                                       ((uniform) `(sample-uniform))
817                                       ((polynomial) `(sample-polynomial . ,(cdr sfun)))
818                                       (else (error 'picnic "unknown sampling method" sfun)))
819                                    (inexact->exact ,npts))
820                                  init
821                                  init-var
822                                  process-n)))
823                           
824                           (SEGPS (name gfun sfun init nsegs nsegpts)   
825                                  (let ((init-var (and init (gensym 'v))))
826                                    (list
827                                     `(make-segmented-process
828                                       ,(make-perturbations
829                                         (if init 
830                                             `(,gfun gid ,origin ,init-var) 
831                                             `(,gfun gid ,origin) ))
832                                       ,(case (car sfun)
833                                          ((uniform) `(sample-uniform))
834                                          ((polynomial) `(sample-polynomial . ,(cdr sfun)))
835                                          (else (error 'picnic "unknown sampling method" sfun)))
836                                       (inexact->exact ,nsegs)
837                                       (inexact->exact ,nsegpts))
838                                     init
839                                     init-var
840                                     process-n)))
841                           )))
842                  section-processes))
843         )
844
845     ((lambda (x) (fold (match-lambda*
846                         (((expr init init-var n) ax) 
847                          (if init `(let ((,init-var ,init)) ,ax) ax)))
848                        x exprs))
849      `(let ((result
850              (fold-right 
851               (match-lambda* 
852                (((gid ,origin) lst)
853                 (match-let (((i pts)
854                              (fold (match-lambda*
855                                (((f n) (i lst))
856                                 (list (+ i n)
857                                       (append
858                                        (list-tabulate 
859                                         n (lambda (j) (list (+ i j 1) (f)))) lst))))
860                               (list (inexact->exact ,section-start-index) '())
861                               (list . ,(map (match-lambda
862                                              ((expr init init-var n)
863                                               `(list (lambda () ,expr) 
864                                                      (inexact->exact ,n))))
865                                             exprs))
866                               )))
867
868                            (cons (,make-section gid ,origin (quote ,section-name) pts)
869                                  lst))
870                 ))
871                '()
872                ,layout-name)))
873         (if (picnic-write-sections)
874             ,(case forest-type
875                ((local)
876                 `(write-sections (quote ,forest-name) (quote ,section-name) ,layout-name result myrank))
877                ((global)
878                 `(write-sections (quote ,forest-name) (quote ,section-name) ,layout-name result))))
879         result
880         ))
881
882     ))
883 
884                               
885(define (invoke-swc-loader/scheme sys section-name section-start-index
886                                 section-swcs layout-name forest-name forest-type)
887  (d "invoke-swc-loader: sections-swcs = ~A~%" section-swcs)
888  (let* (
889         (origin (gensym 'p))
890
891         (make-section 'make-segmented-section)
892
893         (swc-exprs
894          (map
895           
896           (match-lambda*
897            ((swc-name)
898             (d "invoke-swc-loader: swc quantity = ~A~%" 
899                (hash-table-ref sys swc-name))
900             
901             (cases picnic:quantity (hash-table-ref sys swc-name)
902                   
903                    (SWC (name path type nsegs)   
904                         `(load-swcdir ,path (quote ,name) ,type (inexact->exact ,nsegs)) )
905                    )))
906
907           section-swcs))
908
909         ;;
910         )
911
912      `(let*
913           (
914            (swc-pools (list . ,swc-exprs))
915
916
917            (result
918             (fold-right 
919              (match-lambda* 
920               (((gid ,origin) lst)
921                (match-let
922                 (((i pts)
923                   (fold 
924
925                    (match-lambda*
926                     ((f (i lst))
927                      (list (+ i 1)
928                            (append
929                             (list-tabulate 
930                              1 (lambda (j) (list (+ i j 1) (f gid ,origin))))
931                             lst))))
932
933                    (list (inexact->exact ,section-start-index) '())
934                    (map (lambda (swc-pool)
935                           (let ((swc-pool-n (length swc-pool)))
936                             (lambda (cell-index cell-origin) 
937                               (match-let (((type g gdistv gsegv) (choose swc-pool swc-pool-n)))
938                                          (tree-graph->section-points cell-index cell-origin type g gdistv gsegv)))))
939                         swc-pools)
940                    )))
941                 
942                 (cons (,make-section gid ,origin (quote ,section-name) pts)
943                       lst))
944                ))
945              '()
946              ,layout-name))
947            )
948
949         (if (picnic-write-sections)
950             ,(case forest-type
951                ((local)
952                 `(write-sections (quote ,forest-name) (quote ,section-name) ,layout-name result myrank))
953                ((global)
954                 `(write-sections (quote ,forest-name) (quote ,section-name) ,layout-name result))))
955         result
956         ))
957
958     )
959 
960
961
962(define (forest-pointset-codegen/scheme sys forest pointsets)
963
964  (define (forest-type x)  (third x))
965  (define (cid x)  (second x))
966  (define (cn x)   (first x))
967               
968
969  (d "forest = ~A~%" forest)
970
971  (map (lambda (name+poset)
972         (d "pointset = ~A~%" name+poset)
973         (let (
974               (pointset-name (first name+poset))
975               (poset (second name+poset))
976               )
977           
978           `(define  
979             
980              ,pointset-name
981             
982              (let* ((pts (kd-tree->list*
983                           (car ,(fold-right 
984                                  (lambda (xs ax)
985                                    (fold (match-lambda*
986                                           (((id . sym) ax)
987                                            (let ((rhs (qrhs (hash-table-ref sys sym))))
988                                              `(let ((,sym ,rhs)) ,ax))))
989                                          ax xs))
990                                  (cdr (last (last poset)))
991                                  poset))
992                           )))
993               
994                (if (picnic-write-pointsets)
995                    (write-pointset (quote ,pointset-name) pts))
996
997                pts))
998           ))
999
1000       pointsets))
1001
1002
1003
1004(define (forest-codegen/scheme sys forest layout sections swc-sections)
1005
1006  (define (forest-type x)  (third x))
1007  (define (cid x)  (second x))
1008  (define (cn x)   (first x))
1009               
1010
1011  (d "forest = ~A~%" forest)
1012  (d "layout = ~A~%" layout)
1013  (d "sections = ~A~%" sections)
1014  (d "swc-sections = ~A~%" swc-sections)
1015
1016
1017  (let (
1018        (layout-name
1019         (gensym
1020          (string->symbol
1021           (string-append
1022            (->string (cn forest))
1023            "_layout"))))
1024                 
1025        (section-names
1026         (map (lambda (section)
1027                (gensym
1028                 (string->symbol
1029                  (string-append
1030                   (->string (cn forest))
1031                   (->string (section-descriptor-label section))))))
1032              sections))
1033
1034        (swc-section-names
1035         (map (lambda (section)
1036                (gensym
1037                 (string->symbol
1038                  (string-append
1039                   (->string (cn forest))
1040                   (->string (section-descriptor-label section))))))
1041              swc-sections))
1042        )
1043
1044    `(define  
1045
1046       ,(cid forest)
1047
1048       (let*
1049           
1050           (
1051            (,layout-name 
1052             (let* ((pts (kd-tree->list*
1053                          (car ,(fold-right 
1054                                 (lambda (xs ax)
1055                                   (fold (match-lambda*
1056                                          (((id . sym) ax)
1057                                           (let ((rhs (qrhs (hash-table-ref sys sym))))
1058                                             `(let ((,sym ,rhs)) ,ax))))
1059                                         ax xs))
1060                                 (cdr (last (last layout)))
1061                                 layout))
1062                          ))
1063                    (layout
1064                     ,(case (forest-type forest)
1065                        ((local)
1066                         `(let recur ((pts pts) (myindex 0) (ax '()))
1067                            (if (null? pts) ax
1068                                (let ((ax1 (if (= (modulo myindex mysize) myrank)
1069                                               (cons (car pts) ax) ax)))
1070                                  (recur (cdr pts) (+ 1 myindex) ax1)))
1071                            ))
1072                        ((global)
1073                         'pts)))
1074                    )
1075               (if (picnic-write-pointsets)
1076                   (write-pointset (quote ,(cn forest)) pts))
1077               (if (picnic-write-layouts)
1078                   ,(case (forest-type forest)
1079                      ((local)
1080                       `(write-layout (quote ,(cn forest)) layout myrank))
1081                      ((global)
1082                       `(write-layout (quote ,(cn forest)) layout))))
1083               layout
1084               ))
1085           
1086            ,@(map
1087               (lambda (section section-name)
1088                 (let ((section-perturbations (section-descriptor-perturbations section))
1089                       (section-processes (section-descriptor-processes section))
1090                       (section-label (section-descriptor-label section))
1091                       (section-start-index (section-descriptor-start-index section)))
1092                   `(,section-name 
1093                     ,(invoke-generator/scheme sys section-label section-start-index
1094                                               section-processes section-perturbations
1095                                               layout-name (cn forest) (forest-type forest)))
1096                   ))
1097              sections 
1098              section-names)
1099           
1100            ,@(map
1101               (lambda (section section-name)
1102                 (let (
1103                       (section-swcs  (section-descriptor-processes section))
1104                       (section-label (section-descriptor-label section))
1105                       (section-start-index (section-descriptor-start-index section))
1106                       )
1107                   `(,section-name 
1108                     ,(invoke-swc-loader/scheme sys section-label section-start-index
1109                                                section-swcs layout-name
1110                                                (cn forest) (forest-type forest)))
1111                   ))
1112              swc-sections 
1113              swc-section-names)
1114           
1115            )
1116         
1117          (fold-right
1118           (match-lambda*
1119            (((gid p) ,@section-names lst)
1120             (cons (make-cell (quote ,(cn forest)) gid p 
1121                              (list . ,(append section-names swc-section-names)))
1122                   lst)
1123             ))
1124           '()
1125           ,layout-name . ,section-names)
1126         
1127         ))
1128    ))
1129
1130
1131
1132(define (projection-codegen/scheme sys cell-forests cell-sections projection)
1133
1134  (define (resolve-forest-imports sym imports)
1135    (let ((x (member sym imports)))
1136      (d "resolve-forest-imports: sym = ~A imports = ~A cell-forests = ~A x = ~A~%" 
1137         sym imports cell-forests x)
1138      (and x (lookup-def (second sym) cell-forests))))
1139         
1140  (define (rewrite-projection expr label)
1141    (cond
1142     ((or (symbol? expr) (number? expr) (string? expr)) expr)
1143     (else
1144      (match expr
1145             (('let bnds body) 
1146              `(let* ,(map (lambda (x) (list (car x) (rewrite-projection (cadr x) label))) bnds) 
1147                 ,(rewrite-projection body label)))
1148             (((or 'SegmentProjection 'Projection) . rest)
1149              (cons (car expr) (cons `(quote ,label) rest)))
1150             (((? symbol?) . rest) 
1151              (cons (car expr) (map (lambda (x) (rewrite-projection x label)) (cdr expr))))
1152             (else expr)))
1153    ))
1154 
1155
1156  (let* (
1157         (label   (projection-descriptor-label projection))
1158         (poset   (projection-descriptor-poset projection))
1159         (imports (projection-descriptor-imports projection))
1160
1161         (dd (d "projection label = ~A~%" label))
1162         (dd (d "projection imports = ~A~%" imports))
1163         (dd (d "projection poset = ~A~%" poset))
1164         (dd (d "cell-sections = ~A~%" cell-sections))
1165         (dd (d "cell-forests = ~A~%" cell-forests))
1166
1167         (projection-name
1168          (gensym
1169           (string->symbol
1170            (string-append (->string label) "_projection"))))
1171         )
1172
1173    `(define  
1174
1175       ,projection-name
1176
1177       
1178       ,((lambda (body) 
1179           (if (not (null? imports))
1180               `(let ,(map (lambda (x)
1181                             (let ((sym (first x))
1182                                   (ns  (third x)))
1183                               (case ns 
1184                                 ((cell-forests)
1185                                  `(,sym ,(first (resolve-forest-imports x imports))))
1186                                 (else (error 'projection-codegen "unknown import namespace" ns)))
1187                               ))
1188                           imports)
1189                  ,body)
1190               body))
1191         (fold-right 
1192          (lambda (xs ax)
1193            (fold (match-lambda*
1194                   (((id . sym) ax)
1195                    (let ((rhs (qrhs (hash-table-ref sys sym))))
1196                      (d "projection poset sym = ~A rhs = ~A~%" sym rhs)
1197                      (let ((rhs1 (rewrite-projection rhs label)))
1198                        (if rhs1 `(let ((,sym ,rhs1)) ,ax) ax))
1199                    ))
1200                   )
1201                  ax xs))
1202          (cdr (last (last poset)))
1203          poset))
1204       )
1205    ))
1206
1207 
1208(define (main opt operands)
1209
1210  (if (opt 'version)
1211      (begin
1212        (print (picnic:version-string))
1213        (exit 0)))
1214
1215  (if (null? operands)
1216
1217      (picnic:usage)
1218
1219      (let* (
1220            (model-sources
1221             (map
1222              (lambda (operand)
1223                (let* (
1224                       (read-sexp 
1225                        (lambda (name) 
1226                          (call-with-input-file name read)))
1227
1228                       (read-iexpr
1229                        (lambda (name) 
1230                          (call-with-input-file name 
1231                            (lambda (port) 
1232                              (let ((content
1233                                     (iexpr:tree->list
1234                                      (iexpr:parse operand port))))
1235                                (car content))))))
1236                       
1237                       (in-format
1238                        (cond ((opt 'input-format) =>
1239                               (lambda (x) 
1240                                 (case ($ x)
1241                                   ((picnic)      'picnic)
1242                                   ((s-exp sexp)  'sexp)
1243                                   (else          (error 'picnic "unknown input format" x)))))
1244                              (else
1245                               (case ((lambda (x) (or (not x) ($ x)))
1246                                      (pathname-extension operand))
1247                                 ((s-exp sexp)  'sexp)
1248                                 (else 'picnic)))))
1249
1250                       (doc.iexpr
1251                        (case in-format
1252                          ((picnic) 
1253                           (let ((content (read-sexp operand)))
1254                             (if (eq? content 'picnic-model)
1255                                 (cons (read-iexpr operand) #t)
1256                                 (cons content #f))))
1257                          ((sexp) 
1258                           (cons (read-sexp operand) #f))
1259                          (else    (error 'picnic "unknown input format" in-format))))
1260                       
1261                       (dd          (if (opt 'debug)
1262                                        (begin
1263                                          (pp (car doc.iexpr))
1264                                          (picnic-verbose 1))))
1265                           
1266                       (parse-expr
1267                        (case in-format
1268                          ((sexp)         identity)
1269                          ((picnic)              (if (cdr doc.iexpr) 
1270                                                   (lambda (x #!optional loc) 
1271                                                     (if (string? x) (picnic:parse-string-expr x loc)
1272                                                         (picnic:parse-sym-expr x loc)))
1273                                                   picnic:parse-sym-expr))
1274                          (else    (error 'picnic "unknown input format" in-format))))
1275
1276                       
1277                       (model-name.model-decls
1278                        (case in-format
1279                          ((sexp picnic)         (sexp->model-decls (car doc.iexpr)))
1280                          (else    (error 'picnic "unknown input format" in-format))))
1281                       
1282                       )
1283
1284                  (ModelSource
1285                   operand in-format
1286                   (car model-name.model-decls)
1287                   (filter (lambda (x) (not (null? x))) (cadr model-name.model-decls))
1288                   (match model-name.model-decls 
1289                          ((_ _ user-templates)
1290                           user-templates)
1291                          (else '()))
1292                   (cdr doc.iexpr) 
1293                   parse-expr)
1294                  ))
1295              operands))
1296
1297            (models
1298             (map (lambda (x) 
1299                    (cases picnic:model x
1300                           
1301                           (ModelSource (source-path in-format model-name model-decls user-templates iexpr parse-expr)
1302                                        (model-source->model source-path in-format model-name 
1303                                                             model-decls user-templates iexpr parse-expr))
1304                           
1305                           
1306                           (else (error 'name "invalid model source" x))))
1307                 
1308                  model-sources))
1309            )
1310       
1311        (let ((template-insts (opt 'template)))
1312
1313          (for-each
1314           
1315           (lambda (model)
1316             
1317             (cases picnic:model model
1318                   
1319                    (SingleModel (source-path in-format model-name sys model-decls user-templates iexpr? parse-expr)
1320                                 
1321                                 (process-model opt source-path in-format #f sys model-decls iexpr? parse-expr)
1322                                 
1323                                 (if template-insts
1324                                     (for-each
1325                                      (lambda (template-inst)
1326                                        (match-let (((template-name . template-args)
1327                                                     (string-split template-inst ":")))
1328                                                   (let ((output-file-suffix (or (opt 'template-prefix) template-name)))
1329                                                     (process-template model-name template-name template-args 
1330                                                                       output-file-suffix user-templates source-path))
1331                                                   ))
1332                                      template-insts))
1333                                 )
1334
1335                 
1336                  (else (error 'picnic "invalid model" model))))
1337
1338           models))
1339        )
1340      ))
1341
1342
1343(main opt (opt '@))
1344
Note: See TracBrowser for help on using the repository browser.