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

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

npccl renamed to picnic

File size: 31.8 KB
Line 
1;;
2;; Neural Parametric Curve Connectivity Language
3;;
4;; Copyright 2012-2014 Ivan Raikov and the Okinawa Institute of
5;; Science and Technology.
6;;
7;; This program is free software: you can redistribute it and/or
8;; modify it under the terms of the GNU General Public License as
9;; published by the Free Software Foundation, either version 3 of the
10;; License, or (at your option) any later version.
11;;
12;; This program is distributed in the hope that it will be useful, but
13;; WITHOUT ANY WARRANTY; without even the implied warranty of
14;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
15;; General Public License for more details.
16;;
17;; A full copy of the GPL license can be found at
18;; <http://www.gnu.org/licenses/>.
19;;
20;;
21
22
23(import scheme chicken)
24
25(require-extension srfi-1 picnic-core)
26(require-library iexpr ersatz-lib)
27(require-extension datatype matchable lalr-driver getopt-long)
28(import (prefix iexpr iexpr: )
29        (prefix ersatz-lib ersatz: )
30        )
31
32(define rest cdr)
33
34(define-datatype picnic:model picnic:model?
35  (ModelSource (source-path string?) (in-format symbol?) (name symbol?) 
36               (decls list?) 
37               (user-templates user-template-list?)
38               (iexpr boolean?) (parse-expr procedure?))
39  (SingleModel (source-path string?) (in-format symbol?) (name symbol?) 
40               (sys hash-table?) (decls list?) (user-templates user-template-list?)
41               (iexpr boolean?) (parse-expr procedure?))
42  )
43
44
45(define-record-type section-descriptor 
46  (make-section-descriptor label processes)
47  section-descriptor? 
48  (label section-descriptor-label)
49  (processes section-descriptor-processes)
50  )
51
52
53(define-record-type projection-descriptor 
54  (make-projection-descriptor label poset imports)
55  projection-descriptor? 
56  (label projection-descriptor-label)
57  (poset projection-descriptor-poset)
58  (imports projection-descriptor-imports)
59  )
60
61
62
63 
64(define (d fstr . args)
65  (let ([port (current-error-port)])
66    (if (positive? (picnic-verbose)) 
67        (begin (apply fprintf port fstr args)
68               (flush-output port) ) )))
69
70
71(define (user-template-list? ts)
72  (every (lambda (x) (and (string? (car x))
73                          (every string? (cadr x))
74                          (every ersatz:tstmt? (caddr x)))) ts))
75
76
77(define (lookup-def k lst . rest)
78  (let-optionals rest ((default #f))
79      (let ((kv (assoc k lst)))
80        (if (not kv) default
81            (match kv ((k v) v) (else (cdr kv)))))))
82
83
84(define ($ x)  (and x (string->symbol (->string x))))
85
86
87;;; Procedures for string concatenation and pretty-printing
88
89(define (s+ . lst)    (string-concatenate (map ->string lst)))
90(define (sw+ lst)     (string-intersperse (filter-map (lambda (x) (and x (->string x))) lst) " "))
91(define (s\ p . lst)  (string-intersperse (map ->string lst) p))
92(define (slp p lst)   (string-intersperse (map ->string lst) p))
93(define nl "\n")
94
95
96(define (warn port message . specialising-msgs)
97  (print-error-message message (current-output-port) "Warning")
98  (print (string-concatenate (map ->string specialising-msgs))))
99
100;;; Error procedure for the XML parser
101
102(define (parser-error port message . specialising-msgs)
103  (error (string-append message (string-concatenate (map ->string specialising-msgs)))))
104
105(define ssax:warn warn)
106
107(define (defopt x)
108  (lookup-def x opt-defaults))
109
110(define opt-grammar
111  `(
112    (input-format
113     "specify input format (picnic, s-exp)"
114     (single-char #\i)
115     (value (required FORMAT)
116            (transformer ,string->symbol)))
117
118    (template
119     "instantiate the given template from the model file by setting the given variables to the respective values"
120     (value (required "NAME[:VAR=VAL...]"))
121     (multiple #t)
122     )
123
124    (template-prefix 
125     "output instantiated templates to <PREFIX><template_name> (default is <model-name>_<template_name>)"
126     (value (required PREFIX) ))
127
128    (debug "print additional debugging information" 
129           (single-char #\v))
130
131    (version "print the current version and exit")
132
133    (help         (single-char #\h))
134
135
136    ))
137
138
139;; Use args:usage to generate a formatted list of options (from OPTS),
140;; suitable for embedding into help text.
141(define (picnic:usage)
142  (print "Usage: " (car (argv)) "  <list of files to be processed> [options...] ")
143  (newline)
144  (print "The following options are recognized: ")
145  (newline)
146  (print (parameterize ((indent 5) (width 30)) (usage opt-grammar)))
147  (exit 1))
148
149
150;; Process arguments and collate options and arguments into OPTIONS
151;; alist, and operands (filenames) into OPERANDS.  You can handle
152;; options as they are processed, or afterwards.
153
154(define opts    (getopt-long (command-line-arguments) opt-grammar))
155(define opt     (make-option-dispatch opts opt-grammar))
156
157
158(define (picnic-constructor name declarations parse-expr)
159  (let* ((picnic   (make-picnic-core))
160         (sys    ((picnic 'system) name))
161         (qs     (eval-picnic-system-decls picnic name sys declarations parse-expr: parse-expr)))
162    (list sys picnic qs)))
163
164
165(define (sexp->model-decls doc)
166  (match doc
167         ((or ('picnic-model model-name model-decls)
168              ('picnic-model (model-name . model-decls)))
169          (list model-name model-decls))
170         ((or ('picnic-model model-name model-decls user-templates)
171              ('picnic-model (model-name . model-decls) user-templates))
172          (list model-name model-decls 
173                (map (lambda (x) (list (->string (car x)) 
174                                       (map ->string (cadr x))
175                                       (ersatz:statements-from-string
176                                        (ersatz:template-std-env) 
177                                        (caddr x))))
178                             user-templates)))
179         (else (error 'sexp->model "unknown model format"))
180         ))
181
182
183(define (sexp-model-decls->model options model-name model-decls parse-expr)
184  (let* ((model+picnic  (picnic-constructor model-name model-decls parse-expr))
185         (model (first model+picnic))
186         (picnic  (second model+picnic)))
187      (if (assoc 'depgraph options) (print "dependency graph: " ((picnic 'depgraph*) model)))
188      (if (assoc 'exports options)  (print "exports: " ((picnic 'exports) model)))     
189      (if (assoc 'imports options)  (print "imports: " ((picnic 'imports) model)))
190      (if (assoc 'components options)
191          (for-each (lambda (x) 
192                      (print "component " x ": " ((picnic 'component-exports) model (second x)))
193                      (print "component " x " subcomponents: " ((picnic 'component-subcomps) model (second x))))
194                    ((picnic 'components) model)))
195      model))
196         
197
198
199(include "expr-parser.scm")
200
201
202(define (instantiate-template user-templates template-name template-vars)
203  (let ((tmpl (assoc (->string template-name) user-templates string=?)))
204    (if (not tmpl)
205        (error 'picnic "template not found" template-name))
206    (let ((ctx (ersatz:init-context models: template-vars )))
207      (display
208       (ersatz:eval-statements (caddr tmpl)
209                               env: (ersatz:template-std-env)
210                               models: template-vars ctx: ctx))
211      )))
212
213
214(define (process-template model-name template-name template-args template-out user-templates source-path)
215
216  (let (
217        (template-vars (cons (cons 'model_name
218                                   (ersatz:Tstr (->string model-name)) )
219                             (map (lambda (x) 
220                                    (let ((kv (string-split x "=")))
221                                      (cons ($ (car kv))
222                                            (ersatz:Tstr (cadr kv)))))
223                                  template-args)))
224        )
225
226    (let* ((dirname (pathname-directory source-path))
227           (output-name (if (string-prefix? "." template-out)
228                            (make-pathname dirname (s+ model-name template-out)) 
229                            (make-pathname dirname (s+ model-name "_" template-out)) )))
230      (with-output-to-file output-name
231        (lambda () (instantiate-template user-templates template-name template-vars))
232        ))
233    ))
234
235
236
237
238(define (model-source->model source-path in-format model-name model-decls user-templates iexpr parse-expr)
239
240  (case in-format
241   
242    ((sexp picnic)
243     (SingleModel source-path in-format model-name
244                  (sexp-model-decls->model 
245                   `() model-name model-decls parse-expr)
246                  model-decls user-templates iexpr parse-expr))
247   
248    (else (error 'picnic "invalid input format"))
249    ))
250       
251 
252(define (qrhs x)
253  (and (picnic:quantity? x)
254       (cases picnic:quantity x
255              (SET  (name rhs)  `(SetExpr . ,rhs))
256              (ASGN  (name value rhs)  rhs)
257              (INITIAL (name rhs)  rhs)
258              (else #f))))
259
260(define (qinit x)
261  (and (picnic:quantity? x)
262       (cases picnic:quantity x
263              (PS (name gfun init npts)   init)
264              (SEGPS (name gfun init nsegs nsegpts)   init)
265              (else #f))))
266
267(define (gfun x)
268  (and (picnic:quantity? x)
269       (cases picnic:quantity x
270              (PS (name gfun init npts)   gfun)
271              (SEGPS (name gfun init nsegs nsegpts)   gfun)
272              (else #f))))
273
274(define (process-model opt source-path in-format prefix sys model-decls iexpr? parse-expr)
275
276  (define (cid x)  (second x))
277  (define (cn x)   (first x))
278               
279  (match-let ((($ picnic:quantity 'DISPATCH dis) 
280               (hash-table-ref sys (picnic-intern 'dispatch))))
281                                   
282     (let* (
283            (sysname     ((lambda (x) (or (and prefix ($ (s+ prefix "_" x))) x)) ((dis 'sysname) sys)))
284            (dirname     (pathname-directory source-path))
285
286            (eval-const  (let ((eval-const (dis 'eval-const)))
287                           (lambda (x q) (eval-const sys x q))))
288            (consts      ((dis 'consts)  sys))
289            (defuns      ((dis 'defuns)  sys))
290            (asgns       ((dis 'asgns)   sys))
291            (initials    ((dis 'initials)   sys))
292            (sets        ((dis 'sets)   sys))
293            (imports     ((dis 'imports)  sys))
294            (exports     ((dis 'exports)  sys))
295            (components  ((dis 'components) sys))
296            (subcomps    (dis 'component-subcomps))
297
298            (component-exports (dis 'component-exports))
299            (component-imports (dis 'component-imports))
300
301            (g ((dis 'depgraph) sys))
302           
303
304            (cell-forests
305             (filter-map (match-lambda 
306                          ((name 'cell-forest id) (list name id 'global))
307                          ((name 'local-cell-forest id) (list name id 'local))
308                          (else #f)) 
309                         components))
310
311            (cell-section-comps
312             (map (lambda (forest)
313                    (let ((subcomponents (subcomps sys (cid forest))))
314                      (cons forest
315                            (filter-map 
316                             (match-lambda 
317                              (('section name id) (list name id))
318                              (else #f))
319                             subcomponents))))
320                  cell-forests))
321
322            (cell-layout-comps
323             (map (lambda (forest)
324                    (let ((subcomponents (subcomps sys (cid forest))))
325                      (cons forest
326                            (filter-map 
327                             (match-lambda 
328                              (('layout name id) (list name id))
329                              (else #f))
330                             subcomponents))))
331                  cell-forests))
332
333            (projection-comps
334             (filter-map (match-lambda 
335                          ((name 'projection id) (list name id))
336                          (else #f))
337                         components))
338
339            (cell-layouts 
340             (map (lambda (layouts)
341                    (let ((forest (first layouts))
342                          (layout (second layouts)))
343                      (cons forest
344                            (let ((exports (component-exports sys (cid layout))))
345                              (let* (
346                                     (pointset-name (first exports))
347                                     (poset ((dis 'depgraph->bfs-dist-poset) g 
348                                             root-labels: (list pointset-name)))
349                                     )
350                                (d "poset = ~A~%" poset)
351                                (d "pointset in ~A = ~A~%" layout pointset-name)
352                                (vector->list poset)
353                                ))
354                            ))
355                      )
356                    cell-layout-comps))
357
358            (cell-sections 
359             (map (lambda (sections)
360                    (let ((forest (first sections)))
361                      (cons forest
362                            (map
363                             (lambda (section)
364                               (let (
365                                     (label (cn section))
366                                     (exports (component-exports sys (cid section)))
367                                     (imports (component-imports sys (cid section)))
368                                     )
369                                 (d "label of ~A = ~A~%" (cid section) label)
370                                 (d "exports in ~A = ~A~%" section exports)
371                                 (d "imports in ~A = ~A~%" section imports)
372                                 (cons label
373                                       (make-section-descriptor
374                                        label
375                                        (map (lambda (prs)
376                                               (let* ((process-name (first prs))
377                                                      (n (second prs))
378                                                      (n-value ((dis 'eval-const) sys n process-name))
379                                                      (generator (gfun (hash-table-ref sys process-name)))
380                                                      (init (qinit (hash-table-ref sys process-name)))
381                                                      )
382                                                 (d "process in ~A = ~A~%" section process-name)
383                                                 (d "process generator function = ~A~%" generator)
384                                                 (list process-name n)))
385                                             (let recur ((prs '()) (exports exports))
386                                               (if (null? exports) 
387                                                   (reverse prs)
388                                                   (recur (cons (take exports 2) prs) 
389                                                          (drop exports 2))))
390                                             )))
391                                       ))
392                             (rest sections)))
393                      ))
394                  cell-section-comps))
395
396            ;; TODO: check that source/target populations are either:
397            ;; local/global
398            ;; global/global
399            (projections 
400             (fold-right
401              (lambda (projection-comp ax)
402                (d "projection-comp = ~A~%" projection-comp)
403                (let ((exports (component-exports sys (cid projection-comp)))
404                      (imports (component-imports sys (cid projection-comp))))
405                  (d "projection exports = ~A~%" exports)
406                  (d "projection imports = ~A~%" imports)
407                  (append
408                   (map
409                    (lambda (name)
410                      (let* (
411                             (label (string->symbol (last (string-split (->string name) "."))))
412                             (poset ((dis 'depgraph->bfs-dist-poset) g 
413                                     root-labels: (list name)))
414                             (poset (vector->list poset))
415                             )
416                        (make-projection-descriptor label poset imports)))
417                    exports) ax)
418                  ))
419              '()
420              projection-comps))
421
422            )
423
424       (for-each (lambda (b) (printf "~A~%" b)) prelude/scheme)
425
426       (for-each pp (map (lambda (x) `(define . ,x)) consts))
427
428       (for-each pp (filter-map (lambda (x) (defun-codegen/scheme x)) defuns))
429
430       
431       (d "cell sections = ~A~%" cell-sections)
432       
433       (for-each
434        (match-lambda
435         ((forest . layout)
436          (let ((sections (map cdr (alist-ref forest cell-sections))))
437            (pp (forest-codegen/scheme sys forest layout sections))
438            )))
439        cell-layouts)
440       
441       (d "projections = ~A~%" projections)
442
443       (for-each
444        (lambda (projection)
445          (pp (projection-codegen/scheme sys cell-forests cell-sections projection)))
446        projections)
447       
448       (for-each pp `((MPI:finalize)))
449       
450       ))
451
452  )
453
454
455(define prelude/scheme
456  `(#<<EOF
457(use srfi-1 mathh matchable kd-tree mpi picnic-utils)
458(include "mathh-constants")
459(define picnic-write-pointsets (make-parameter #f))
460(MPI:init)
461(if (member "-v" (command-line-arguments))
462    (picnic-verbose 1))
463(if (member "-w" (command-line-arguments))
464    (picnic-write-pointsets #t))
465(define my-comm (MPI:get-comm-world))
466(define myrank  (MPI:comm-rank my-comm))
467(define mysize  (MPI:comm-size my-comm))
468(define-syntax
469  SetExpr
470  (syntax-rules
471      (population section union)
472    ((SetExpr population p) 
473     (lambda (repr) p))
474    ((SetExpr section p t) 
475     (lambda (repr)
476       (case repr
477         ((list)
478          (map (lambda (cell) 
479                 (list (cell-index cell) 
480                       (cell-section-ref (quote t) cell)))
481               p))
482         ((tree)
483          (cells-sections->kd-tree p (quote t)))
484         )))
485    ((SetExpr union x y) 
486     (lambda (repr) (append (SetExpr x) (SetExpr y))))
487    ))
488(define neg -)
489(define randomNormal random-normal)
490(define randomUniform random-uniform)
491(define randomInit random-init)
492(define PointsFromFile load-points-from-file)
493(define LineSegment make-line-segment)
494(define (SegmentProjection label r source target) 
495  (segment-projection label
496                      (source 'tree) (target 'list) 
497                      r my-comm myrank mysize))
498(define (Projection label r source target) 
499  (projection label
500              (source 'tree) (target 'list) 
501              r my-comm myrank mysize))
502EOF
503    ))
504
505
506(define (expr-codegen/scheme x)
507  (cond
508   ((or (symbol? x) (number? x) (string? x)) x)
509   (else
510    (match x 
511           (('let bnds body) 
512            `(let* ,(map (lambda (x) (list (car x) (expr-codegen/scheme (cadr x)))) bnds) 
513               ,(expr-codegen/scheme body)))
514           (((? symbol?) . rest) 
515            (cons (car x) (map expr-codegen/scheme (cdr x))))
516           (else #f))))
517  )
518
519
520(define (defun-codegen/scheme en)
521  (let ((data (procedure-data (second en))))
522    (and data
523         (let ((name (lookup-def 'name data))
524               (eval-body (lookup-def 'eval-body data))
525               (rt (lookup-def 'rt data))
526               (formals (lookup-def 'formals data)))
527           `(define ,name ,(expr-codegen/scheme eval-body))))
528    ))
529
530                               
531(define (invoke-generator/scheme sys section-name section-processes layout-name)
532  (let* ((origin (gensym 'p))
533         (make-section (cases picnic:quantity 
534                              (hash-table-ref sys (first (car section-processes)))
535                              (PS (name gfun init npts)   
536                                  'make-section)
537                              (SEGPS (name gfun init npts)   
538                                     'make-segmented-section)))
539         (exprs  (map
540                  (match-lambda
541                   ((process-name process-n)
542                    (cases picnic:quantity (hash-table-ref sys process-name)
543                           (PS (name gfun init npts)   
544                               (let ((init-var (and init (gensym 'v))))
545                                 (list
546                                  `(make-process
547                                    ,(if init `(,gfun ,origin ,init-var) `(,gfun ,origin) )
548                                    (inexact->exact ,npts))
549                                  init
550                                  init-var
551                                  process-n)))
552                           
553                           (SEGPS (name gfun init nsegs nsegpts)   
554                                  (let ((init-var (and init (gensym 'v))))
555                                    (list
556                                     `(make-segmented-process
557                                       ,(if init `(,gfun ,origin ,init-var) `(,gfun ,origin) )
558                                       (inexact->exact ,nsegs)
559                                       (inexact->exact ,nsegpts))
560                                     init
561                                     init-var
562                                     process-n)))
563                           )))
564                  section-processes))
565         )
566
567     ((lambda (x) (fold (match-lambda*
568                         (((expr init init-var n) ax) 
569                          (if init `(let ((,init-var ,init)) ,ax) ax)))
570                        x exprs))
571      `(second
572        (fold 
573         (match-lambda* 
574          ((,origin (gid lst)) 
575           (list (+ 1 gid) 
576                 (cons (,make-section 
577                        gid ,origin (quote ,section-name) 
578                        (second
579                         (fold (match-lambda*
580                                (((f n) (i lst))
581                                 (list (+ i n)
582                                       (list-tabulate n
583                                                      (lambda (j) (list (+ i j) (f)))))))
584                               (list 0 '())
585                               (list . ,(map (match-lambda
586                                              ((expr init init-var n)
587                                               `(list (lambda () ,expr) 
588                                                      (inexact->exact ,n))))
589                                             exprs)))))
590                       lst))))
591         (list 0 (list))
592        ,layout-name))
593
594     ))
595  )
596
597
598(define (forest-codegen/scheme sys forest layout sections)
599
600  (define (forest-type x)  (third x))
601  (define (cid x)  (second x))
602  (define (cn x)   (first x))
603               
604
605  (d "forest = ~A~%" forest)
606  (d "layout = ~A~%" layout)
607  (d "sections = ~A~%" sections)
608
609
610  (let (
611        (layout-name
612         (gensym
613          (string->symbol
614           (string-append
615            (->string (cn forest))
616            "_layout"))))
617                 
618        (section-names
619         (map (lambda (section)
620                (gensym
621                 (string->symbol
622                  (string-append
623                   (->string (cn forest))
624                   (->string (section-descriptor-label section))))))
625              sections))
626        )
627
628    `(define  
629
630       ,(cid forest)
631
632       (let*
633           
634           (
635            (,layout-name 
636             (let* ((pts (kd-tree->list 
637                          (car ,(fold-right 
638                                 (lambda (xs ax)
639                                   (fold (match-lambda*
640                                          (((id . sym) ax)
641                                           (let ((rhs (qrhs (hash-table-ref sys sym))))
642                                             `(let ((,sym ,rhs)) ,ax))))
643                                         ax xs))
644                                 (cdr (last (last layout)))
645                                 layout))
646                          ))
647                    (layout
648                     ,(case (forest-type forest)
649                        ((local)
650                         `(let recur ((pts pts) (myindex 0) (ax '()))
651                            (if (null? pts) ax
652                                (let ((ax1 (if (= (modulo myindex mysize) myrank)
653                                               (cons (car pts) ax) ax)))
654                                  (recur (cdr pts) (+ 1 myindex) ax1)))
655                            ))
656                        ((global)
657                         'pts)))
658                    )
659               (if (picnic-write-pointsets)
660                   (write-pointset (quote ,(cn forest)) layout))
661               layout
662               ))
663            .
664            ,(map
665              (lambda (section section-name)
666                (let ((section-processes (section-descriptor-processes section))
667                      (section-label (section-descriptor-label section)))
668                  `(,section-name 
669                    ,(invoke-generator/scheme sys section-label section-processes layout-name))
670                  ))
671              sections 
672              section-names)
673            )
674         
675         (first
676          (fold-right
677           (match-lambda*
678            ((p ,@section-names (lst i)) 
679             (list (cons (make-cell (quote ,(cn forest)) i p 
680                                    (list . ,section-names)) lst)
681                   (+ i 1) )))
682           (list '() 0)
683           ,layout-name . ,section-names))
684         
685         ))
686    ))
687
688
689
690(define (projection-codegen/scheme sys cell-forests cell-sections projection)
691
692  (define (resolve-forest-imports sym imports)
693    (let ((x (alist-ref sym imports)))
694     (and x (lookup-def (first x) cell-forests))))
695         
696  (define (rewrite-projection expr label)
697    (cond
698     ((or (symbol? expr) (number? expr) (string? expr)) expr)
699     (else
700      (match expr
701             (('let bnds body) 
702              `(let* ,(map (lambda (x) (list (car x) (rewrite-projection (cadr x) label))) bnds) 
703                 ,(rewrite-projection body label)))
704             (((or 'SegmentProjection 'Projection) . rest)
705              (cons (car expr) (cons `(quote ,label) rest)))
706             (((? symbol?) . rest) 
707              (cons (car expr) (map (lambda (x) (rewrite-projection x label)) (cdr expr))))
708             (else expr)))
709    ))
710 
711
712  (let* (
713         (label   (projection-descriptor-label projection))
714         (poset   (projection-descriptor-poset projection))
715         (imports (projection-descriptor-imports projection))
716
717         (dd (d "projection label = ~A~%" label))
718         (dd (d "projection poset = ~A~%" poset))
719         (dd (d "cell-sections = ~A~%" cell-sections))
720         (dd (d "cell-forests = ~A~%" cell-forests))
721
722         (projection-name
723          (gensym
724           (string->symbol
725            (string-append (->string label) "_projection"))))
726         )
727
728    `(define  
729
730       ,projection-name
731
732       ,(fold-right 
733         (lambda (xs ax)
734           (fold (match-lambda*
735                  (((id . sym) ax)
736                   (let ((rhs (qrhs (hash-table-ref sys sym))))
737                     (let ((rhs1 (or (and rhs (rewrite-projection rhs label))
738                                     (first (resolve-forest-imports sym imports)))))
739                       `(let ((,sym ,rhs1)) ,ax)))
740                   ))
741                 ax xs))
742         (cdr (last (last poset)))
743         poset)
744       )
745    ))
746
747 
748(define (main opt operands)
749
750  (if (opt 'version)
751      (begin
752        (print (picnic:version-string))
753        (exit 0)))
754
755  (if (null? operands)
756
757      (picnic:usage)
758
759      (let* (
760            (model-sources
761             (map
762              (lambda (operand)
763                (let* (
764                       (read-sexp 
765                        (lambda (name) 
766                          (call-with-input-file name read)))
767
768                       (read-iexpr
769                        (lambda (name) 
770                          (call-with-input-file name 
771                            (lambda (port) 
772                              (let ((content
773                                     (iexpr:tree->list
774                                      (iexpr:parse operand port))))
775                                (car content))))))
776                       
777                       (in-format
778                        (cond ((opt 'input-format) =>
779                               (lambda (x) 
780                                 (case ($ x)
781                                   ((picnic)        'picnic)
782                                   ((s-exp sexp)  'sexp)
783                                   (else          (error 'picnic "unknown input format" x)))))
784                              (else
785                               (case ((lambda (x) (or (not x) ($ x)))
786                                      (pathname-extension operand))
787                                 ((s-exp sexp)  'sexp)
788                                 (else 'picnic)))))
789
790                       (doc.iexpr
791                        (case in-format
792                          ((picnic) 
793                           (let ((content (read-sexp operand)))
794                             (if (eq? content 'picnic-model)
795                                 (cons (read-iexpr operand) #t)
796                                 (cons content #f))))
797                          ((sexp) 
798                           (cons (read-sexp operand) #f))
799                          (else    (error 'picnic "unknown input format" in-format))))
800                       
801                       (dd          (if (opt 'debug)
802                                        (begin
803                                          ;;(pp (car doc.iexpr))
804                                          (picnic-verbose 1))))
805                           
806                       (parse-expr
807                        (case in-format
808                          ((sexp)         identity)
809                          ((picnic)              (if (cdr doc.iexpr) 
810                                                   (lambda (x #!optional loc) 
811                                                     (if (string? x) (picnic:parse-string-expr x loc)
812                                                         (picnic:parse-sym-expr x loc)))
813                                                   picnic:parse-sym-expr))
814                          (else    (error 'picnic "unknown input format" in-format))))
815
816                       
817                       (model-name.model-decls
818                        (case in-format
819                          ((sexp picnic)         (sexp->model-decls (car doc.iexpr)))
820                          (else    (error 'picnic "unknown input format" in-format))))
821                       
822                       )
823
824                  (ModelSource
825                   operand in-format
826                   (car model-name.model-decls)
827                   (filter (lambda (x) (not (null? x))) (cadr model-name.model-decls))
828                   (match model-name.model-decls 
829                          ((_ _ user-templates)
830                           user-templates)
831                          (else '()))
832                   (cdr doc.iexpr) 
833                   parse-expr)
834                  ))
835              operands))
836
837            (models
838             (map (lambda (x) 
839                    (cases picnic:model x
840                           
841                           (ModelSource (source-path in-format model-name model-decls user-templates iexpr parse-expr)
842                                        (model-source->model source-path in-format model-name 
843                                                             model-decls user-templates iexpr parse-expr))
844                           
845                           
846                           (else (error 'name "invalid model source" x))))
847                 
848                  model-sources))
849            )
850       
851        (let ((template-insts (opt 'template)))
852
853          (for-each
854           
855           (lambda (model)
856             
857             (cases picnic:model model
858                   
859                    (SingleModel (source-path in-format model-name sys model-decls user-templates iexpr? parse-expr)
860                                 
861                                 (process-model opt source-path in-format #f sys model-decls iexpr? parse-expr)
862                                 
863                                 (if template-insts
864                                     (for-each
865                                      (lambda (template-inst)
866                                        (match-let (((template-name . template-args)
867                                                     (string-split template-inst ":")))
868                                                   (let ((output-file-suffix (or (opt 'template-prefix) template-name)))
869                                                     (process-template model-name template-name template-args 
870                                                                       output-file-suffix user-templates source-path))
871                                                   ))
872                                      template-insts))
873                                 )
874
875                 
876                  (else (error 'picnic "invalid model" model))))
877
878           models))
879        )
880      ))
881
882
883(main opt (opt '@))
884
Note: See TracBrowser for help on using the repository browser.