From 3dc610dfa6c7af565dc85e42b6fc98d6f4baeb80 Mon Sep 17 00:00:00 2001 From: Dustin Whitney Date: Tue, 16 Jan 2018 18:54:09 -0500 Subject: [PATCH 1/4] fixed a bug finding some nodes and added some find functions that take predicates --- src/Data/Tree/Zipper.purs | 54 +++++++++------- test/Main.purs | 133 +++++++++++++++++++++++++++++++++++--- 2 files changed, 154 insertions(+), 33 deletions(-) diff --git a/src/Data/Tree/Zipper.purs b/src/Data/Tree/Zipper.purs index 70e61d0..27c9b8c 100644 --- a/src/Data/Tree/Zipper.purs +++ b/src/Data/Tree/Zipper.purs @@ -2,9 +2,10 @@ module Data.Tree.Zipper where import Prelude +import Control.Alt ((<|>)) import Control.Comonad.Cofree (head, tail, (:<)) -import Data.List (List(..), drop, reverse, take, (!!), (:)) -import Data.Maybe (Maybe(..)) +import Data.List (List(Nil), drop, reverse, take, (!!), (:)) +import Data.Maybe (Maybe(Just, Nothing)) import Data.Tree (Forest, Tree, mkTree, modifyNodeValue, setNodeValue) -- | The `Loc` type describes the location of a `Node` inside a `Tree`. For this @@ -229,36 +230,39 @@ delete l@(Loc r) = -- Searches + -- | Search down and to the right for the first occurence where the given predicate is true and return the Loc +findDownWhere :: ∀ a. (a -> Boolean) -> Loc a -> Maybe (Loc a) +findDownWhere predicate loc | predicate $ value loc = Just loc +findDownWhere predicate loc = lookNext <|> lookDown + where + lookNext = next loc >>= findDownWhere predicate + lookDown = down loc >>= findDownWhere predicate + -- | Search for the first occurence of the value `a` downwards and to the right. findDown :: forall a. Eq a => a -> Loc a -> Maybe (Loc a) -findDown a l@(Loc r) = - if a == (value l) - then (Just l) - else - case next l of - Just n -> findDown a n - Nothing -> - case down l of - Just n' -> findDown a n' - Nothing -> Nothing - --- | Search for the first occurence of the value `a` upwards and to the left. +findDown a = findDownWhere ( _ == a) + +-- | Search to the left and up for the first occurence where the given predicate is true and return the Loc +findUpWhere :: ∀ a. (a -> Boolean) -> Loc a -> Maybe (Loc a) +findUpWhere predicate loc | predicate $ value loc = Just loc +findUpWhere predicate loc = lookPrev <|> lookUp + where + lookPrev = prev loc >>= findUpWhere predicate + lookUp = up loc >>= findUpWhere predicate + +-- | Search for the first occurence of the value `a` upwards and to the left, findUp :: forall a. Eq a => a -> Loc a -> Maybe (Loc a) -findUp a l@(Loc r) = - if a == (value l) - then (Just l) - else - case prev l of - Just n -> findUp a n - Nothing -> - case up l of - Just n' -> findUp a n' - Nothing -> Nothing +findUp a = findUpWhere (_ == a) + +-- | Search from the root of the tree for the first occurrence where the given predicate is truen and return the Loc +findFromRootWhere :: ∀ a. (a -> Boolean) -> Loc a -> Maybe (Loc a) +findFromRootWhere predicate loc | predicate $ value loc = Just loc +findFromRootWhere predicate loc = findDownWhere predicate $ root loc -- | Search for the first occurence of the value `a` starting from the root of -- | the tree. findFromRoot :: forall a. Eq a => a -> Loc a -> Maybe (Loc a) -findFromRoot a = (findDown a) <<< root +findFromRoot a = findFromRootWhere (_ == a) -- Setters and Getters node :: forall a. Loc a -> Tree a diff --git a/test/Main.purs b/test/Main.purs index 42b13eb..457e085 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -2,14 +2,12 @@ module Test.Main where import Prelude -import Control.Comonad.Cofree (Cofree, head, (:<)) +import Control.Comonad.Cofree (head, (:<)) import Control.Monad.Eff (Eff) -import Control.Monad.Eff.Class (liftEff) -import Control.Monad.Eff.Console (CONSOLE, log) -import Data.List (List(..), (:)) -import Data.Maybe (fromJust) -import Data.Tree (Tree, mkTree, scanTree, showTree) -import Data.Tree.Zipper (down, fromTree, insertAfter, modifyValue, next, toTree) +import Data.List (List(Nil), (:)) +import Data.Maybe (Maybe(..), fromJust) +import Data.Tree (Tree, mkTree, scanTree) +import Data.Tree.Zipper (down, findDownWhere, findFromRoot, findUp, fromTree, insertAfter, modifyValue, next, toTree, value) import Partial.Unsafe (unsafePartial) import Test.Spec (describe, it) import Test.Spec.Assertions (shouldEqual) @@ -139,4 +137,123 @@ main = run [consoleReporter] do ) : Nil shouldEqual (eq root' result) true - shouldEqual (eq root'' result') true \ No newline at end of file + shouldEqual (eq root'' result') true + + it "Should findDownWhere with single node" do + let tree = 1 :< Nil + let loc = fromTree tree + shouldEqual (Just 1) ((findDownWhere (_ == 1) loc) <#> value) + + it "Should findDownWhere with 2 nodes and 2 levels" do + let tree = 1 :< + (2 :< Nil) + : Nil + -- log $ showTree tree + let loc = fromTree tree + shouldEqual (Just 2) ((findDownWhere (_ == 2) loc) <#> value) + + it "Should findDownWhere with 3 nodes and 2 levels" do + let tree = 1 :< + (2 :< Nil) + : (3 :< Nil) + : Nil + -- log $ showTree tree + let loc = fromTree tree + shouldEqual (Just 3) ((findDownWhere (_ == 3) loc) <#> value) + + it "Should findDownWhere with 4 nodes and 2 levels" do + let tree = 1 :< + (2 :< Nil) + : (3 :< Nil) + : (4 :< Nil) + : Nil + -- log $ showTree tree + let loc = fromTree tree + shouldEqual (Just 4) ((findDownWhere (_ == 4) loc) <#> value) + + it "Should findDownWhere with 5 nodes and 3 levels" do + let tree = 1 :< + (2 :< Nil) + : (3 :< Nil) + : (4 :< + (5 :< Nil) + : Nil) + : Nil + -- log $ showTree tree + let loc = fromTree tree + shouldEqual (Just 5) ((findDownWhere (_ == 5) loc) <#> value) + + it "Should findDownWhere with 6 nodes and 3 levels" do + let tree = 1 :< + (2 :< Nil) + : (3 :< Nil) + : (4 :< + (5 :< Nil) + : (6 :< Nil) + : Nil) + : Nil + -- log $ showTree tree + let loc = fromTree tree + shouldEqual (Just 6) ((findDownWhere (_ == 6) loc) <#> value) + + it "Should findDownWhere with 7 nodes and 4 levels" do + let tree = 1 :< + (2 :< Nil) + : (3 :< Nil) + : (4 :< + (5 :< Nil) + : (6 :< + (7 :< Nil) : Nil) + : Nil) + : Nil + -- log $ showTree tree + let loc = fromTree tree + shouldEqual (Just 7) ((findDownWhere (_ == 7) loc) <#> value) + + it "Should findDownWhere with 8 nodes and 4 levels" do + let tree = 1 :< + (2 :< Nil) + : (3 :< Nil) + : (4 :< + (5 :< Nil) + : (6 :< + (7 :< Nil) : Nil) + : (8 :< Nil) + : Nil) + : Nil + -- log $ showTree tree + let loc = fromTree tree + shouldEqual (Just 8) ((findDownWhere (_ == 8) loc) <#> value) + + it "Should findDownWhere with 8 nodes and 4 levels with a step back" do + let tree = 1 :< + (2 :< Nil) + : (3 :< Nil) + : (4 :< + (5 :< Nil) + : (6 :< + (7 :< Nil) : Nil) + : (8 :< Nil) + : Nil) + : Nil + -- log $ showTree tree + let loc = fromTree tree + shouldEqual (Just 7) ((findDownWhere (_ == 7) loc) <#> value) + + it "Should find 7 from the sampleTree" do + shouldEqual (Just 7) (findDownWhere (_ == 7) (fromTree sampleTree) <#> value) + + it "Should find 8 from the sampleTree (the bottom) and then find 1 (the top) with findUp" do + let eight = unsafePartial $ fromJust $ findDownWhere (_ == 8) $ fromTree sampleTree + shouldEqual (Just 1) (findUp 1 eight <#> value) + + it "Should find 8 from the sampleTree (the bottom) but then not find 7 because it would require a downward traversal" do + let eight = unsafePartial $ fromJust $ findDownWhere (_ == 8) $ fromTree sampleTree + shouldEqual Nothing (findUp 7 eight <#> value) + + it "Should find 8 from the sampleTree (the bottom) and then find 7 using findFromRoot" do + let eight = unsafePartial $ fromJust $ findDownWhere (_ == 8) $ fromTree sampleTree + shouldEqual (Just 7) (findFromRoot 7 eight <#> value) + + + From 591a7d4f58f74c4e5bab4750f3032e2e664565a7 Mon Sep 17 00:00:00 2001 From: Dustin Whitney Date: Mon, 21 May 2018 10:15:22 -0400 Subject: [PATCH 2/4] got rid of the warnings --- src/Data/Tree.purs | 6 +++--- src/Data/Tree/Zipper.purs | 16 ++++++++++++++++ test/Main.purs | 12 ++++++++++-- 3 files changed, 29 insertions(+), 5 deletions(-) diff --git a/src/Data/Tree.purs b/src/Data/Tree.purs index a04d304..d1c5e31 100644 --- a/src/Data/Tree.purs +++ b/src/Data/Tree.purs @@ -21,7 +21,7 @@ mkTree = mkCofree drawTree :: Tree String -> String drawTree t = tailRec go {level: 0, drawn: (head t) <> "\n", current: (tail t)} where - go :: _ -> Step _ String + go :: { current :: List (Tree String) , drawn :: String , level :: Int } -> Step { current :: List (Tree String) , drawn :: String , level :: Int } String go {level: l, drawn: s, current: Nil} = Done s go {level: l, drawn: s, current: c:cs } = let drawn = (power " " l) <> "|----> " <> (head c) <> "\n" in @@ -39,7 +39,7 @@ scanTree f b n = let fb = f (head n) b in fb :< (tailRec go {b: fb, current: (tail n), final: Nil}) where - go :: _ -> Step _ (Forest b) + go :: { final :: List (Cofree List b) , current :: List (Cofree List a) , b :: b } -> Step { final :: List (Cofree List b) , current :: List (Cofree List a) , b :: b } (Forest b) go {b: b', current: Nil, final: final} = Done final go {b: b', current: c:cs, final: final} = let fb' = f (head c) b' @@ -52,7 +52,7 @@ scanTreeAccum f b n = let fb = f (head n) b in fb.value :< (tailRec go {b: fb.accum , current: (tail n), final: Nil}) where - go :: _ -> Step _ (Forest c) + go :: { final :: List (Cofree List c) , current :: List (Cofree List a) , b :: b } -> Step { final :: List (Cofree List c) , current :: List (Cofree List a) , b :: b } (Forest c) go {b: b', current: Nil, final: final} = Done final go {b: b', current: c:cs, final: final} = let fb' = f (head c) b' diff --git a/src/Data/Tree/Zipper.purs b/src/Data/Tree/Zipper.purs index 27c9b8c..5c1b889 100644 --- a/src/Data/Tree/Zipper.purs +++ b/src/Data/Tree/Zipper.purs @@ -264,6 +264,22 @@ findFromRootWhere predicate loc = findDownWhere predicate $ root loc findFromRoot :: forall a. Eq a => a -> Loc a -> Maybe (Loc a) findFromRoot a = findFromRootWhere (_ == a) +flattenLocDepthFirst :: ∀ a. Loc a -> List (Loc a) +flattenLocDepthFirst loc = loc : (go loc) + where + go :: Loc a -> List (Loc a) + go goLoc = + let + downs = goDir goLoc down + nexts = goDir goLoc next + in + downs <> nexts + + goDir :: Loc a -> (Loc a -> Maybe (Loc a)) -> List (Loc a) + goDir loc' dirFn = case (dirFn loc') of + Just justLoc' -> loc' : go justLoc' + Nothing -> Nil + -- Setters and Getters node :: forall a. Loc a -> Tree a node (Loc r) = r.node diff --git a/test/Main.purs b/test/Main.purs index 457e085..e25cc0f 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -4,10 +4,12 @@ import Prelude import Control.Comonad.Cofree (head, (:<)) import Control.Monad.Eff (Eff) +import Control.Monad.Aff.Console (log) import Data.List (List(Nil), (:)) import Data.Maybe (Maybe(..), fromJust) -import Data.Tree (Tree, mkTree, scanTree) -import Data.Tree.Zipper (down, findDownWhere, findFromRoot, findUp, fromTree, insertAfter, modifyValue, next, toTree, value) +import Data.Tree (Tree, mkTree, scanTree, showTree) +import Data.Tree.Zipper (down, findDownWhere, findFromRoot, findUp, flattenLocDepthFirst, fromTree, insertAfter, modifyValue, next, toTree, value) +import Debug.Trace (spy) import Partial.Unsafe (unsafePartial) import Test.Spec (describe, it) import Test.Spec.Assertions (shouldEqual) @@ -255,5 +257,11 @@ main = run [consoleReporter] do let eight = unsafePartial $ fromJust $ findDownWhere (_ == 8) $ fromTree sampleTree shouldEqual (Just 7) (findFromRoot 7 eight <#> value) + it "Should flatten the Tree into a list of locations following a depth first pattern" do + let flat = map value $ flattenLocDepthFirst $ fromTree sampleTree + -- log $ showTree sampleTree + -- log $ show flat + shouldEqual flat (1 : 2 : 3 : 4 : 5 : 6 : 7 : 8 : Nil) + From c242a176e49385cd5c05b0a08811780c4492bc7c Mon Sep 17 00:00:00 2001 From: Dustin Whitney Date: Mon, 18 Jun 2018 23:26:56 -0400 Subject: [PATCH 3/4] upgraded to purescript 0.12 --- bower.json | 12 ++++++------ src/Data/Tree/Zipper.purs | 21 ++++++++++++--------- test/Main.purs | 14 ++++++-------- 3 files changed, 24 insertions(+), 23 deletions(-) diff --git a/bower.json b/bower.json index c38ccc2..1a7620f 100644 --- a/bower.json +++ b/bower.json @@ -12,13 +12,13 @@ "url": "git://github.com/dmbfm/purescript-tree.git" }, "dependencies": { - "purescript-prelude": "^3.1.0", - "purescript-console": "^3.0.0", - "purescript-lists": "^4.9.1", - "purescript-free": "^4.1.0" + "purescript-prelude": "^4.0.1", + "purescript-console": "^4.1.0", + "purescript-lists": "^5.0.0", + "purescript-free": "^5.1.0" }, "devDependencies": { - "purescript-psci-support": "^3.0.0", - "purescript-spec": "^1.0.0" + "purescript-psci-support": "^4.0.0", + "purescript-spec": "^3.0.0" } } diff --git a/src/Data/Tree/Zipper.purs b/src/Data/Tree/Zipper.purs index 5c1b889..041eae6 100644 --- a/src/Data/Tree/Zipper.purs +++ b/src/Data/Tree/Zipper.purs @@ -264,21 +264,24 @@ findFromRootWhere predicate loc = findDownWhere predicate $ root loc findFromRoot :: forall a. Eq a => a -> Loc a -> Maybe (Loc a) findFromRoot a = findFromRootWhere (_ == a) +-- | flattens the Tree into a List depth first. flattenLocDepthFirst :: ∀ a. Loc a -> List (Loc a) flattenLocDepthFirst loc = loc : (go loc) - where + where go :: Loc a -> List (Loc a) - go goLoc = - let - downs = goDir goLoc down - nexts = goDir goLoc next - in + go loc' = + let + downs = goDir loc' down + nexts = goDir loc' next + in downs <> nexts goDir :: Loc a -> (Loc a -> Maybe (Loc a)) -> List (Loc a) - goDir loc' dirFn = case (dirFn loc') of - Just justLoc' -> loc' : go justLoc' - Nothing -> Nil + goDir loc' dirFn = case (dirFn loc') of + Just l -> l : go l + Nothing -> Nil + + -- Setters and Getters node :: forall a. Loc a -> Tree a diff --git a/test/Main.purs b/test/Main.purs index e25cc0f..96641f0 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -3,18 +3,16 @@ module Test.Main where import Prelude import Control.Comonad.Cofree (head, (:<)) -import Control.Monad.Eff (Eff) -import Control.Monad.Aff.Console (log) import Data.List (List(Nil), (:)) import Data.Maybe (Maybe(..), fromJust) -import Data.Tree (Tree, mkTree, scanTree, showTree) +import Data.Tree (Tree, mkTree, scanTree) import Data.Tree.Zipper (down, findDownWhere, findFromRoot, findUp, flattenLocDepthFirst, fromTree, insertAfter, modifyValue, next, toTree, value) -import Debug.Trace (spy) +import Effect (Effect) import Partial.Unsafe (unsafePartial) import Test.Spec (describe, it) import Test.Spec.Assertions (shouldEqual) import Test.Spec.Reporter (consoleReporter) -import Test.Spec.Runner (RunnerEffects, run) +import Test.Spec.Runner (run) sampleTree :: Tree Int sampleTree = @@ -30,7 +28,7 @@ sampleTree = ) : Nil -main :: forall e. Eff (RunnerEffects e) Unit +main :: Effect Unit main = run [consoleReporter] do describe "Tree" do @@ -259,8 +257,8 @@ main = run [consoleReporter] do it "Should flatten the Tree into a list of locations following a depth first pattern" do let flat = map value $ flattenLocDepthFirst $ fromTree sampleTree - -- log $ showTree sampleTree - -- log $ show flat + --log $ showTree sampleTree + --log $ show flat shouldEqual flat (1 : 2 : 3 : 4 : 5 : 6 : 7 : 8 : Nil) From e6930590834dfb084c7a6cce591fd6543c52e80c Mon Sep 17 00:00:00 2001 From: Dustin Whitney Date: Tue, 19 Jun 2018 09:44:44 -0400 Subject: [PATCH 4/4] renamed some params using the Forest type alias instead of it's full expanded type --- src/Data/Tree.purs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Data/Tree.purs b/src/Data/Tree.purs index d1c5e31..00c321a 100644 --- a/src/Data/Tree.purs +++ b/src/Data/Tree.purs @@ -21,7 +21,7 @@ mkTree = mkCofree drawTree :: Tree String -> String drawTree t = tailRec go {level: 0, drawn: (head t) <> "\n", current: (tail t)} where - go :: { current :: List (Tree String) , drawn :: String , level :: Int } -> Step { current :: List (Tree String) , drawn :: String , level :: Int } String + go :: { current :: Forest String , drawn :: String , level :: Int } -> Step { current :: Forest String , drawn :: String , level :: Int } String go {level: l, drawn: s, current: Nil} = Done s go {level: l, drawn: s, current: c:cs } = let drawn = (power " " l) <> "|----> " <> (head c) <> "\n" in @@ -39,7 +39,7 @@ scanTree f b n = let fb = f (head n) b in fb :< (tailRec go {b: fb, current: (tail n), final: Nil}) where - go :: { final :: List (Cofree List b) , current :: List (Cofree List a) , b :: b } -> Step { final :: List (Cofree List b) , current :: List (Cofree List a) , b :: b } (Forest b) + go :: { final :: Forest b , current :: Forest a , b :: b } -> Step { final :: Forest b , current :: Forest a , b :: b } (Forest b) go {b: b', current: Nil, final: final} = Done final go {b: b', current: c:cs, final: final} = let fb' = f (head c) b' @@ -52,7 +52,7 @@ scanTreeAccum f b n = let fb = f (head n) b in fb.value :< (tailRec go {b: fb.accum , current: (tail n), final: Nil}) where - go :: { final :: List (Cofree List c) , current :: List (Cofree List a) , b :: b } -> Step { final :: List (Cofree List c) , current :: List (Cofree List a) , b :: b } (Forest c) + go :: { final :: Forest c , current :: Forest a , b :: b } -> Step { final :: Forest c , current :: Forest a , b :: b } (Forest c) go {b: b', current: Nil, final: final} = Done final go {b: b', current: c:cs, final: final} = let fb' = f (head c) b'