From d9a9e16fd78b36558d547027e9f670b2161c4ea5 Mon Sep 17 00:00:00 2001
From: Sam Anklesaria <sam@Tintin.local>
Date: Fri, 1 May 2009 11:06:20 -0500
Subject: [PATCH] added file-trees vocab

---
 extra/file-trees/file-trees-tests.factor |  4 ++++
 extra/file-trees/file-trees.factor       | 23 +++++++++++++++++++++++
 2 files changed, 27 insertions(+)
 create mode 100644 extra/file-trees/file-trees-tests.factor
 create mode 100644 extra/file-trees/file-trees.factor

diff --git a/extra/file-trees/file-trees-tests.factor b/extra/file-trees/file-trees-tests.factor
new file mode 100644
index 0000000000..dbb8f9f5d8
--- /dev/null
+++ b/extra/file-trees/file-trees-tests.factor
@@ -0,0 +1,4 @@
+USING: kernel file-trees ;
+IN: file-trees.tests
+{ "/sample/1" "/sample/2" "/killer/1" "/killer/2/3"
+"/killer/2/4" "/killer/2/4/6" "/megakiller" } create-tree drop
\ No newline at end of file
diff --git a/extra/file-trees/file-trees.factor b/extra/file-trees/file-trees.factor
new file mode 100644
index 0000000000..788291c0a2
--- /dev/null
+++ b/extra/file-trees/file-trees.factor
@@ -0,0 +1,23 @@
+USING: accessors delegate delegate.protocols io.pathnames
+kernel locals namespaces sequences vectors
+tools.annotations prettyprint ;
+IN: file-trees
+
+TUPLE: tree node children ;
+CONSULT: sequence-protocol tree children>> [ node>> ] map ;
+
+: <tree> ( start -- tree ) V{ } clone
+   [ tree boa dup children>> ] [ ".." swap tree boa ] bi swap push ;
+
+DEFER: (tree-insert)
+
+: tree-insert ( path tree -- ) [ unclip <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 <tree> [ [ tree-insert ] curry each ] keep ;
\ No newline at end of file