Changeset 31143 in project


Ignore:
Timestamp:
07/23/14 05:31:00 (6 years ago)
Author:
Ivan Raikov
Message:

picnic: additional imports in utils module

Location:
release/4/picnic/trunk
Files:
2 edited

Legend:

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

    r31142 r31143  
    3838                (only srfi-1
    3939                      fold fold-right filter-map filter every zip list-tabulate delete-duplicates partition
    40                       first second third take)
     40                      first second third take concatenate)
    4141                (only srfi-4
    42                       s32vector s32vector-length s32vector-ref
    43                       f64vector f64vector? f64vector-ref f64vector-length f64vector->list list->f64vector)
     42                      s32vector s32vector-length s32vector-ref s32vector-set! make-s32vector
     43                      f64vector f64vector? f64vector-ref f64vector-set! f64vector-length f64vector->list list->f64vector make-f64vector)
    4444                (only srfi-13 string= string< string-null? string-prefix? string-trim-both)
    4545                (only irregex string->irregex irregex-match)
     
    874874                      (recur (cdr lst))))))
    875875
    876               (let recur ((lst lst))
    877                
    878                 (if (not (null? lst))
     876            ;; insert edges
     877            (let recur ((lst lst))
     878             
     879              (if (not (null? lst))
     880                 
     881                  (let ((point (car lst)))
    879882                   
    880                     (let ((point (car lst)))
     883                    (let ((node-id (swcpoint-id point))
     884                          (pre-id  (swcpoint-pre point)))
    881885                     
    882                       (let ((node-id (swcpoint-id point))
    883                             (pre-id  (swcpoint-pre point)))
     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))))
    884890                       
    885                         (let* ((pre-point  (node-info pre-id))
    886                                (pre-coords (swcpoint-coords pre-point))
    887                                (distance   (sqrt (dist2 node-coords pre-coords))))
    888                          
    889                           (add-edge! (list node-id pre-id distance))
    890                          
    891                           (recur (cdr lst))
    892                           ))
    893                       ))
    894                 ))
     891                        (add-edge! (list node-id pre-id distance))
     892                       
     893                        (recur (cdr lst))
     894                        ))
     895                    ))
     896              )
    895897            g
    896             )
     898            ))
     899
    897900
    898901        (define (tree-graph-distances+segments g nseg)
     
    900903          (define n        ((g 'capacity)))
    901904          (define distv    (make-f64vector (+ 1 n) -1.0))
     905          (define rdistv   (make-f64vector (+ 1 n) -1.0))
    902906          (define segv     (make-s32vector (+ 1 n) -1))
    903          
    904           (define (traverse es)
     907
     908
     909          ;; determine distances from root
     910          (define (traverse-dist es)
    905911            (if (null? es) distv
    906912                (match-let (((i j dist) (car es)))
    907913                  (if (>= (f64vector-ref distv j) 0.0)
    908                       (traverse (cdr es))
     914                      (traverse-dist (cdr es))
    909915                      (let ((idist (f64vector-ref distv i)))
    910916                        (f64vector-set! distv j (+ idist dist))
    911                         (let ((distv1 (traverse ((g 'out-edges) j))))
    912                           (traverse es)))
     917                        (let ((distv1 (traverse-dist ((g 'out-edges) j))))
     918                          (traverse-dist es)))
    913919                      ))
    914920                ))
    915921         
    916           (let ((root 1))
     922         
     923          ;; determine distances from end (reverse distance)
     924          (define (traverse-rdist es)
     925            (if (null? es) rdistv
     926                (match-let (((i j dist) (car es)))
     927                  (if (>= (f64vector-ref rdistv i) 0.0)
     928                      (traverse-rdist (cdr es))
     929                      (let ((jdist (f64vector-ref distv j)))
     930                        (f64vector-set! rdistv i (+ jdist dist))
     931                        (let ((rdistv1 (traverse-rdist ((g 'in-edges) i))))
     932                          (traverse-rdist es)))
     933                      ))
     934                ))
     935
     936
     937          (define (compute-segv distv rdistv)
     938            (let recur ((n n))
     939              (if (>= n 1)
     940                  (let* ((dist  (f64vector-ref distv n))
     941                         (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                    (recur (- n 1))
     947                    ))
     948              ))
     949         
     950          (let ((root 1)
     951                (in-edges (g 'in-edges))
     952                (terminals ((g 'terminals))))
    917953            (f64vector-set! distv root 0.0)
     954            (for-each (lambda (x) (f64vector-set! distv x 0.0)) terminals)
    918955            (s32vector-set! segv root 0)
    919             (traverse ((g 'out-edges) root))
     956            (traverse-dist ((g 'out-edges) root))
     957            (traverse-rdist (concatenate (map (lambda (x) (in-edges x)) terminals)))
     958            (compute-segv distv rdistv)
    920959            (list distv segv)
    921960          ))
     
    930969
    931970              (let* (
    932                      (point (node-info root))
     971                     (point (node-info n))
    933972                     (point-type (swcpoint-type point))
    934973                     (point-pre (swcpoint-pre point))
     
    949988                          )
    950989
    951                       (fold (lambda (x ax) (recur x ax)) (cons point1 lst) (out-edges root)))
     990                      (fold (lambda (x ax) (recur x ax)) (cons point1 lst) (out-edges n)))
    952991
    953992                    lst)
     
    957996
    958997 
    959         (define (load-swc filename label type nseg index)
     998        (define (load-swc filename label type nseg cell-index)
    960999         
    9611000          (let ((in (open-input-file filename)))
     
    9731012                       (let ((lst (map string->number (string-split line " \t"))))
    9741013                         (and (not (null? lst))
    975                               (match-let (((id my-type x y z radius parent) lst))
     1014                              (match-let (((id my-type x y z radius pre) lst))
    9761015                                         (make-swcpoint id type (make-point x y z)
    977                                                         radius parent-index)))
     1016                                                        radius pre)))
    9781017                         ))
    9791018                     lines))
     
    9841023                   (point-data (tree-graph->genpoints
    9851024                                swc-graph (car dist+segs) (cadr dist+segs)
    986                                 type index))
     1025                                type cell-index))
    9871026
    9881027                   )
  • release/4/picnic/trunk/picnic.meta

    r30746 r31143  
    2222
    2323 (needs make matchable (iexpr 1.8)
    24         datatype vector-lib digraph graph-bfs graph-cycles
     24        datatype vector-lib digraph graph-bfs graph-dfs graph-cycles
    2525        mathh (varsubst 1.3) (lalr 2.4.2) ersatz getopt-long
    2626        typeclass kd-tree (parametric-curve 1.11) bvsp-spline
Note: See TracChangeset for help on using the changeset viewer.