file trees start common path

core/sequences/sequences.factor

@@ -920,6 +920,8 @@ PRIVATE>
         ] [ generic-flip ] if
     ] unless ;
 
+: reduce1 ( seq quot -- result ) [ unclip ] dip reduce ; inline
+
 :: reduce-r
     ( list identity quot: ( obj1 obj2 -- obj ) -- result )
     list empty?

extra/file-trees/file-trees.factor

@@ -1,6 +1,6 @@
 USING: accessors arrays delegate delegate.protocols
 io.pathnames kernel locals sequences
-ui.frp vectors make ;
+ui.frp vectors make strings ;
 IN: file-trees
 
 TUPLE: walkable-vector vector father ;
@@ -31,8 +31,16 @@ DEFER: (tree-insert)
 : add-paths ( pathseq -- {{name,path}} )
    "" [ [ "/" glue dup ] keep swap 2array , ] [ reduce drop ] f make ;
 
-: create-tree ( file-list -- tree ) [ path-components add-paths ] map
-   { "/" "/" } <dir-tree> [ [ tree-insert ] curry each ] keep ;
+: go-to-path ( path tree -- tree' ) over empty? [ nip ]
+   [ [ unclip ] [ children>> ] bi* swap [ swap node>> = ] curry find nip go-to-path ] if ;
+
+: find-root ( pathseq -- root ) dup flip
+   [ [ dupd = [ ] [ drop f ] if ] reduce1 ] find-last drop
+      [ first ] dip head-slice >string path-components ;
+
+: create-tree ( file-list -- tree ) [ find-root ]
+   [ [ path-components add-paths ] map { "/" "/" } <dir-tree> [ [ tree-insert ] curry each ] keep ] bi
+   go-to-path ;
 
 : <dir-table> ( tree-model -- table )
    <frp-list*> [ node>> 1array ] >>quot

extra/file-trees/file-trees.factor copy

@@ -1,34 +0,0 @@
-USING: accessors arrays delegate delegate.protocols
-io.pathnames kernel locals namespaces prettyprint sequences
-ui.frp vectors ;
-IN: file-trees
-
-! There should be optional extra information you can provide
-TUPLE: tree node children ;
-CONSULT: sequence-protocol tree children>> ;
-
-: <dir-tree> ( start -- tree ) V{ } clone
-   [ tree boa dup children>> ] [ ".." swap tree boa ] bi swap push ;
-
-DEFER: (tree-insert)
-
-: tree-insert ( path tree -- ) [ unclip <dir-tree> ] [ children>> ] bi* (tree-insert) ;
-:: (tree-insert) ( path-rest path-head tree-children -- )
-   tree-children [ node>> path-head node>> = ] find nip
-   [ path-rest swap tree-insert ]
-   [ 
-      path-head tree-children push
-      path-rest [ path-head tree-insert ] unless-empty
-   ] if* ;
-
-: create-tree ( file-list -- tree ) [ path-components ] map
-   t <dir-tree> [ [ tree-insert ] curry each ] keep ;
-
-: find-path ( tree -- string ) dup node>> tuck t =
-   [ 2drop f ] [ children>> first find-path "/" glue ] if ;
-
-: <dir-table> ( tree-model -- table )
-   <frp-list*> [ node>> 1array ] >>quot
-   [ selected-value>> <switch> ]
-   [ swap >>model ] bi
-   [ find-path ] >>val-quot ;