trees, add height

extra/trees/trees-docs.factor

@@ -1,4 +1,4 @@
-USING: help.syntax help.markup assocs ;
+USING: assocs help.markup help.syntax math ;
 IN: trees
 
 HELP: TREE{
@@ -17,6 +17,13 @@ HELP: >tree
 HELP: tree
 { $class-description "This is the class for unbalanced binary search trees. It is not usually intended to be used directly but rather as a basis for other trees." } ;
 
+HELP: height
+{ $values
+    { "tree" tree }
+    { "n" integer }
+}
+{ $description "Returns the height of " { $snippet "tree" } "." } ;
+
 ARTICLE: "trees" "Binary search trees"
 "This is a library for unbalanced binary search trees. It is not intended to be used directly in most situations but rather as a base class for new trees, because performance can degrade to linear time storage/retrieval by the number of keys. These binary search trees conform to the assoc protocol."
 { $subsections
@@ -24,6 +31,7 @@ ARTICLE: "trees" "Binary search trees"
     <tree>
     >tree
     POSTPONE: TREE{
+    height
 } ;
 
 ABOUT: "trees"

extra/trees/trees-tests.factor

@@ -36,3 +36,18 @@ IN: trees.tests
     { 9 "nine" }
     { 4 "four" }
 } clone ] unit-test
+
+! test height
+{ 0 } [ TREE{ } height ] unit-test
+
+{ 2 } [ TREE{
+    { 7 "seven" }
+    { 9 "nine" }
+    { 4 "four" }
+} height ] unit-test
+
+{ 3 } [ TREE{
+    { 9 "seven" }
+    { 7 "nine" }
+    { 4 "four" }
+} height ] unit-test

extra/trees/trees.factor

@@ -227,3 +227,16 @@ M: tree assoc-size count>> ;
 M: tree pprint-delims drop \ TREE{ \ } ;
 M: tree >pprint-sequence >alist ;
 M: tree pprint-narrow? drop t ;
+
+<PRIVATE
+
+: node-height ( node -- n )
+    [
+        [ left>> ] [ right>> ] bi
+        [ node-height ] bi@ max 1 +
+    ] [ 0 ] if* ;
+
+PRIVATE>
+
+: height ( tree -- n )
+    root>> node-height ;