Changeset 31144 in project


Ignore:
Timestamp:
07/23/14 11:58:27 (6 years ago)
Author:
Ivan Raikov
Message:

picnic: working support for swc morphologies

Location:
release/4/picnic/trunk
Files:
1 added
4 edited

Legend:

Unmodified
Added
Removed
  • release/4/picnic/trunk/picnic-core.scm

    r31066 r31144  
    2626         picnic:math-constants
    2727         picnic-intern picnic-scoped eval-picnic-system-decls
    28          CONST CONFIG ASGN INITIAL PS SEGPS SET EXTERNAL PRIM LABEL
     28         CONST CONFIG ASGN INITIAL PS SEGPS SET SWC EXTERNAL PRIM LABEL
    2929
    3030         )
     
    197197                      (initial  (lambda (x) (or (not x) (rhs? x))))
    198198                      (npts     integer?)
     199                      )
     200          (SWC        (name     symbol?)
     201                      (path     string?)
     202                      (type     integer?)
     203                      (nsegs    integer?)
    199204                      )
    200205          (SET        (name symbol?)
     
    814819                             
    815820                              ))
     821
     822                           (('swc-directory) 
     823                            (let* (
     824                                   (alst    (filter identity alst))
     825                                   (path    (lookup-def 'path alst))
     826                                   (type    (lookup-def 'type alst))
     827                                   (nsegs   (lookup-def 'nsegs alst))
     828                                   )
     829                              (hash-table-set! picnic-env sym (SWC name path type nsegs))
     830                              ))
     831
    816832
    817833                           (('set) 
     
    14231439                                           (SET  (name rhs)
    14241440                                                 (list 'set sym rhs))
     1441                                           (SWC  (name path type nsegs)
     1442                                                 (list 'swc sym path type nsegs))
    14251443                                           (else picnic:error 'make-eval-poset
    14261444                                                 "invalid quantity in equation poset: " sym)))))
     
    14371455                   (('union x y)       (lset-union equal? x y))
    14381456                   (else #f))))
     1457
    14391458
    14401459          (define (eval-expr env)
     
    17141733                                                       ))
    17151734                                          (list (cons qid qs) scope-subst1)))
     1735
     1736
     1737                                       ;; directory of SWC files
     1738                                       (((or 'swcdir 'swc-directory 'SWC-DIRECTORY)
     1739                                         ((and id (? symbol?))) '= . rest)
     1740
     1741                                        (let* (
     1742                                               (qid     (compute-qid id scope scope-subst))
     1743                                               (scope-subst1 (update-subst id qid scope-subst))
     1744                                               (alst    (filter identity rest))
     1745                                               (type    (lookup-def 'type alst))
     1746                                               (nsegs   ((lambda (x) (and x (subst-expr (parse-expr x `(swcdir ,id)) scope-subst)))
     1747                                                         (lookup-def 'nsegs alst)))
     1748                                               (path    (lookup-def 'path alst))
     1749                                               )
     1750
     1751                                          (apply env-extend!
     1752                                                 (list qid '(swc-directory) #f
     1753                                                       (and nsegs `(nsegs ,(eval-const nsegs (sprintf "~A.nsegs" id)) ))
     1754                                                       (and type `(type ,type))
     1755                                                       (and path `(path ,path))
     1756                                                       ))
     1757
     1758                                          (list (cons qid qs) scope-subst1)))
     1759
    17161760
    17171761                                       ;; population set
  • release/4/picnic/trunk/picnic-utils.scm

    r31143 r31144  
    2626
    2727       
    28         (require-extension srfi-69 datatype matchable vector-lib
     28        (require-extension srfi-69 datatype matchable vector-lib regex
    2929                           mpi mathh typeclass kd-tree random-mtzig
    3030                           lalr-driver digraph graph-dfs)
     
    4545                (only irregex string->irregex irregex-match)
    4646                (only files make-pathname)
    47                 (only posix glob)
     47                (only posix glob find-files)
    4848                (only extras read-lines pp fprintf )
    4949                (only ports with-output-to-port )
     
    534534                     ax sections)
    535535                    ))
    536                 '() cells ))
     536                '() (filter cadr cells)
     537                ))
    537538
    538539
     
    881882                  (let ((point (car lst)))
    882883                   
     884
    883885                    (let ((node-id (swcpoint-id point))
    884886                          (pre-id  (swcpoint-pre point)))
    885                      
    886                       (let* ((pre-point   (node-info pre-id))
    887                              (pre-coords  (swcpoint-coords pre-point))
    888                              (node-coords (swcpoint-coords point))
    889                              (distance    (sqrt (dist2 node-coords pre-coords))))
     887
     888                      (if (> pre-id 0)
     889
     890                          (let* ((pre-point   (node-info pre-id))
     891                                 (pre-coords  (and pre-point (swcpoint-coords pre-point)))
     892                                 (node-coords (swcpoint-coords point))
     893                                 (distance    (sqrt (dist2 node-coords pre-coords))))
     894                           
     895                            (add-edge! (list pre-id node-id distance))))
    890896                       
    891                         (add-edge! (list node-id pre-id distance))
    892                        
    893                         (recur (cdr lst))
    894                         ))
    895                     ))
    896               )
     897                      (recur (cdr lst))
     898                      ))
     899                  ))
    897900            g
    898901            ))
     
    900903
    901904        (define (tree-graph-distances+segments g nseg)
     905
    902906
    903907          (define n        ((g 'capacity)))
     
    940944                  (let* ((dist  (f64vector-ref distv n))
    941945                         (rdist (f64vector-ref rdistv n))
    942                          (len   (+ dist rdist))
    943                          (delta (round (/ len nseg)))
    944                          (seg   (round (/ dist delta))))
    945                     (s32vector-set! segv n (exact->inexact seg))
     946                         (len   (and (positive? dist) (positive? rdist) (+ dist rdist)))
     947                         (delta (and len (round (/ len nseg))))
     948                         (seg   (and delta (round (/ dist delta)))))
     949                    (if seg (s32vector-set! segv n (exact->inexact seg)))
    946950                    (recur (- n 1))
    947951                    ))
    948952              ))
    949953         
    950           (let ((root 1)
    951                 (in-edges (g 'in-edges))
    952                 (terminals ((g 'terminals))))
    953             (f64vector-set! distv root 0.0)
    954             (for-each (lambda (x) (f64vector-set! distv x 0.0)) terminals)
    955             (s32vector-set! segv root 0)
    956             (traverse-dist ((g 'out-edges) root))
     954          (let ((in-edges (g 'in-edges))
     955                (out-edges (g 'out-edges))
     956                (terminals ((g 'terminals)))
     957                (roots ((g 'roots))))
     958            (for-each (lambda (x) (f64vector-set! distv x 0.0)) roots)
     959            (for-each (lambda (x) (s32vector-set! segv x 0)) roots)
     960            (for-each (lambda (x) (f64vector-set! rdistv x 0.0)) terminals)
     961            (traverse-dist (concatenate (map (lambda (x) (out-edges x)) roots)))
    957962            (traverse-rdist (concatenate (map (lambda (x) (in-edges x)) terminals)))
    958963            (compute-segv distv rdistv)
     
    961966
    962967
    963         (define (tree-graph->genpoints g gdistv gsegv type cell-index)
     968        (define (tree-graph->section-points cell-index cell-origin type g gdistv gsegv)
    964969         
    965           (let ((node-info (g 'node-info))
    966                 (out-edges (g 'out-edges)))
     970          (let* ((node-info (g 'node-info))
     971                 (succ      (g 'succ))
     972                 (offset    (let ((cell-loc (point->list cell-origin))
     973                                  (root-loc (point->list (swcpoint-coords (node-info 1)))))
     974                              (map - cell-loc root-loc))))
    967975
    968976            (let recur ((n 1) (lst '()))
     
    974982                     (proceed? (or (= point-type type)
    975983                                   (case (swcpoint-type point)
    976                                      ((0 1 5 6) #t)
     984                                     ((0 1 2 5 6) #t)
    977985                                     (else #f))))
    978986                     )
     987
     988                (d "tree-graph->section-points: n = ~A point-type = ~A proceed? = ~A~%"
     989                   n point-type proceed?)
     990
     991                (d "tree-graph->section-points: succ n = ~A~%" (succ n))
    979992                 
    980993                (if proceed?
    981994
    982995                    (let (
    983                           (point1 (make-genpoint
    984                                    (swcpoint-coords point)
    985                                    cell-index
    986                                    (f64vector-ref gdistv n)
    987                                    (s32vector-ref gsegv n)))
     996                          (point1 (list
     997                                   (s32vector-ref gsegv n)
     998                                   (apply make-point (map + offset (point->list (swcpoint-coords point))))))
    988999                          )
    9891000
    990                       (fold (lambda (x ax) (recur x ax)) (cons point1 lst) (out-edges n)))
     1001                      (fold (lambda (x ax) (recur x ax))
     1002                            (cons point1 lst)
     1003                            (succ n)))
    9911004
    9921005                    lst)
     
    9961009
    9971010 
    998         (define (load-swc filename label type nseg cell-index)
     1011        (define (load-swc filename label type nseg)
    9991012         
    10001013          (let ((in (open-input-file filename)))
     
    10041017            (let* (
    10051018                   (lines
    1006                     (filter (lambda (line) (not (irregex-match comment-pat line)))
    1007                             (read-lines in)))
     1019                    (let ((lines (read-lines in)))
     1020                      (close-input-port in)
     1021                      (filter (lambda (line) (not (irregex-match comment-pat line)))
     1022                              lines)))
    10081023
    10091024                   (swc-data
     
    10131028                         (and (not (null? lst))
    10141029                              (match-let (((id my-type x y z radius pre) lst))
    1015                                          (make-swcpoint id type (make-point x y z)
     1030                                         (make-swcpoint id my-type (make-point x y z)
    10161031                                                        radius pre)))
    10171032                         ))
     
    10211036
    10221037                   (dist+segs  (tree-graph-distances+segments swc-graph nseg))
    1023                    (point-data (tree-graph->genpoints
    1024                                 swc-graph (car dist+segs) (cadr dist+segs)
    1025                                 type cell-index))
    10261038
    10271039                   )
    10281040
    1029               (list point-data))
     1041              (cons type (cons swc-graph dist+segs)))
    10301042          ))
    10311043
    10321044
    1033 
     1045        (define (load-swcdir path label type nseg)
     1046         
     1047          (let ((pat ".*.swc"))
     1048
     1049            (let ((flst (find-files path
     1050                                    test: (regexp pat)
     1051                                    action: cons
     1052                                    seed: (list)
     1053                                    limit: 0)))
     1054
     1055              (d "load-swcdir: flst = ~A~%" flst)
     1056
     1057              (map (lambda (fn) (load-swc fn label type nseg)) (sort flst string<?))
     1058              ))
     1059          )
     1060         
    10341061
    10351062        (define (segment-projection label source-tree target-sections zone my-comm myrank size)
  • release/4/picnic/trunk/picnic.meta

    r31143 r31144  
    2121 ; A list of eggs picnic depends on.
    2222
    23  (needs make matchable (iexpr 1.8)
     23 (needs make matchable (iexpr 1.8) regex
    2424        datatype vector-lib digraph graph-bfs graph-dfs graph-cycles
    2525        mathh (varsubst 1.3) (lalr 2.4.2) ersatz getopt-long
  • release/4/picnic/trunk/picnic.scm

    r31049 r31144  
    333333                             (match-lambda
    334334                              (('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))
    335346                              (else #f))
    336347                             subcomponents))))
     
    458469              cell-section-comps))
    459470
     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
    460506            ;; TODO: check that source/target populations are either:
    461507            ;; local/global
     
    503549              (match-lambda
    504550               ((forest layout . rest)
    505                 (let ((sections (map cdr (alist-ref forest cell-sections))))
    506                   (pp (forest-codegen/scheme sys forest layout sections))
     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))
    507554                  )))
    508555              cell-layouts)
     
    536583(use srfi-1 mathh matchable kd-tree mpi getopt-long picnic-utils)
    537584(include "mathh-constants")
     585
     586(define (choose lst n) (list-ref lst (random n)))
    538587
    539588(define picnic-write-pointsets (make-parameter #f))
     
    833882     ))
    834883 
     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 
    835960
    836961
     
    8771002
    8781003
    879 (define (forest-codegen/scheme sys forest layout sections)
     1004(define (forest-codegen/scheme sys forest layout sections swc-sections)
    8801005
    8811006  (define (forest-type x)  (third x))
     
    8871012  (d "layout = ~A~%" layout)
    8881013  (d "sections = ~A~%" sections)
     1014  (d "swc-sections = ~A~%" swc-sections)
    8891015
    8901016
     
    9051031                   (->string (section-descriptor-label section))))))
    9061032              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))
    9071042        )
    9081043
     
    9481083               layout
    9491084               ))
    950             .
    951             ,(map
    952               (lambda (section section-name)
    953                 (let ((section-perturbations (section-descriptor-perturbations section))
    954                       (section-processes (section-descriptor-processes section))
    955                       (section-label (section-descriptor-label section))
    956                       (section-start-index (section-descriptor-start-index section)))
    957                   `(,section-name
    958                     ,(invoke-generator/scheme sys section-label section-start-index
    959                                               section-processes section-perturbations
    960                                               layout-name (cn forest) (forest-type forest)))
    961                   ))
     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                   ))
    9621097              sections
    9631098              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)
    9641114           
    9651115            )
     
    9691119            (((gid p) ,@section-names lst)
    9701120             (cons (make-cell (quote ,(cn forest)) gid p
    971                               (list . ,section-names)) lst)
     1121                              (list . ,(append section-names swc-section-names)))
     1122                   lst)
    9721123             ))
    9731124           '()
Note: See TracChangeset for help on using the changeset viewer.