rowtype-yoga/purescript-yoga-tree
1
0
Fork 0
mirror of https://github.com/rowtype-yoga/purescript-yoga-tree.git synced 2024-08-16 11:40:38 +03:00
Code Issues Packages Projects Releases Wiki Activity

Back Trees by Arrays

Browse Source
This commit is contained in:
Mark Eibes 2022-08-29 10:54:06 +02:00
parent 8c63cbedbf
commit edbc26333e
10 changed files with 640 additions and 691 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
package.json
View File

@ -1,8 +1,8 @@
{
"name": "purescript-tree",
"name": "purescript-yoga-tree",
"version": "4.0.0",
"description": "A Tree data structure inspired by haskell's Data.Tree",
"description": "A Tree data structure inspired by Haskell's Data.Tree",
"main": "index.js",
"author": "Daniel Fortes",
"license": "MIT"
}
}

4
packages.dhall
View File

@ -1,5 +1,5 @@
let upstream =
https://github.com/purescript/package-sets/releases/download/psc-0.14.5-20220203/packages.dhall
sha256:f8905bf5d7ce9d886cf4ef1c5893ab55de0b30c82c2b4137f272d075000fbc50
https://github.com/purescript/package-sets/releases/download/psc-0.15.4-20220822/packages.dhall
sha256:908b4ffbfba37a0a4edf806513a555d0dbcdd0cde7abd621f8d018d2e8ecf828
in upstream

3
spago.dhall
View File

@ -3,7 +3,8 @@
, repository = "https://github.com/jordanmartinez/purescript-tree-rose"
, name = "tree-rose"
, dependencies =
[ "control"
[ "arrays"
, "control"
, "foldable-traversable"
, "free"
, "lists"

104
src/Data/Tree.purs
View File

@ -1,104 +0,0 @@
module Data.Tree where
import Prelude
import Control.Comonad.Cofree (Cofree, head, mkCofree, tail, (:<))
import Control.Monad.Rec.Class (Step(..), tailRec)
import Data.List (List(..), snoc, (:))
import Data.Monoid (power)
import Data.Traversable (Accum)
-- | A Rose, or multi-way tree, with values of type `a`. To access the
-- | root of the Tree's value, use `Control.Comonad.Cofree (head)`. To
-- | access the root's children, use `Control.Comonad.Cofree (tail)`
type Tree a = Cofree List a
-- | A type alias for the children of a Tree's root value.
type Forest a = List (Tree a)
-- | Create a `Tree` from a `Node` value of type `a` and a `Forest` of children.
mkTree :: forall a. a -> Forest a -> Tree a
mkTree = mkCofree
-- | Draw a 2D `String` representation of a `Tree String`.
drawTree :: Tree String -> String
drawTree = drawTree' 0
-- | Draw a 2D `String` representation of a `Tree String`,
-- | starting the indent at the given level
drawTree' :: Int -> Tree String -> String
drawTree' level t = do
let
treeRoot = (power " " level) <> "|----> " <> (head t) <> "\n"
treeChildren = drawForest' (level + 1) (tail t)
treeRoot <> treeChildren
-- | Draw a 2D `String` representation of a `Forest String`,
drawForest :: Forest String -> String
drawForest = drawForest' 0
-- | Draw a 2D `String` representation of a `Forest String`,
-- | starting the indent at the given level
drawForest' :: Int -> Forest String -> String
drawForest' level forest = tailRec goForest { level: level, drawn: "", current: forest }
where
goForest
:: { current :: Forest String, drawn :: String, level :: Int }
-> Step { current :: Forest String, drawn :: String, level :: Int } String
goForest { drawn: s, current: Nil } = Done s
goForest { level: l, drawn: s, current: c : cs } = do
let
drawnTree = drawTree' l c
Loop { level: l, drawn: s <> drawnTree, current: cs }
-- | Draw a 2D `String` representation of a `Tree` composed of `Show`able
-- | elements.
showTree :: forall a. Show a => Tree a -> String
showTree tree = drawTree (show <$> tree)
-- | Draw a 2D `String` representation of a `Forest` composed of `Show`able
-- | elements.
showForest :: forall a. Show a => Forest a -> String
showForest forest = drawForest ((\tree -> show <$> tree) <$> forest)
-- | Scan a `Tree`, accumulating values of `b` there are constant across `Node`s
-- | that have the same parent.
scanTree :: forall a b. (a -> b -> b) -> b -> Tree a -> Tree b
scanTree f b n = do
let
fb = f (head n) b
fb :< (tailRec go { b: fb, current: (tail n), final: Nil })
where
go :: { final :: Forest b, current :: Forest a, b :: b } -> Step { final :: Forest b, current :: Forest a, b :: b } (Forest b)
go { current: Nil, final: final } = Done final
go { b: b', current: c : cs, final: final } = do
let
fb' = f (head c) b'
Loop { b: b', current: cs, final: snoc final (fb' :< tailRec go { b: fb', current: (tail c), final: Nil }) }
-- | Scan a `Tree`, accumulating values of `b` there are constant across `Node`s
-- | that have the same parent, and returning a `Tree` of type `c`.
scanTreeAccum :: forall a b c. (a -> b -> Accum b c) -> b -> Tree a -> Tree c
scanTreeAccum f b n = do
let
fb = f (head n) b
fb.value :< (tailRec go { b: fb.accum, current: (tail n), final: Nil })
where
go :: { final :: Forest c, current :: Forest a, b :: b } -> Step { final :: Forest c, current :: Forest a, b :: b } (Forest c)
go { current: Nil, final: final } = Done final
go { b: b', current: c : cs, final: final } = do
let
fb' = f (head c) b'
Loop { b: b', current: cs, final: snoc final (fb'.value :< tailRec go { b: fb'.accum, current: (tail c), final: Nil }) }
-- | Set the value of a node.
setNodeValue :: forall a. a -> Tree a -> Tree a
setNodeValue a n = a :< (tail n)
-- | Modify the value of a node.
modifyNodeValue :: forall a. (a -> a) -> Tree a -> Tree a
modifyNodeValue f n = f (head n) :< tail n
-- | Append a child to a node.
appendChild :: forall a. Tree a -> Tree a -> Tree a
appendChild c n = head n :< snoc (tail n) c

297
src/Data/Tree/Zipper.purs
View File

@ -1,297 +0,0 @@
module Data.Tree.Zipper where
import Prelude
import Control.Alt ((<|>))
import Control.Comonad.Cofree (head, tail, (:<))
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
-- | we store the current `Node`, the sibling nodes that appear before the current
-- | node, the sibling nodes that appear after the current node, and a `List` of
-- | `Loc`ations that store the parent node locations up to the root of the three.
-- |
-- | So, effectively, the `parents` field records the path travelled in the
-- | tree to reach the level of the current `Node` starting from the tree's root,
-- | and the `before` and `after` fields describe its location in the current
-- | level.
newtype Loc a = Loc
{ node :: Tree a
, before :: Forest a
, after :: Forest a
, parents :: List (Loc a)
}
derive newtype instance eqLoc :: Eq a => Eq (Loc a)
-- -- Cursor movement
-- | Move the cursor to the next sibling.
next :: forall a. Loc a -> Maybe (Loc a)
next (Loc r) =
case r.after of
Nil -> Nothing
(c : cs) -> Just $ Loc r
{ node = c
, before = r.node : r.before
, after = cs
}
-- -- | Move the cursor to the previous sibling.
prev :: forall a. Loc a -> Maybe (Loc a)
prev (Loc r) =
case r.before of
Nil -> Nothing
(c : cs) -> Just $ Loc r
{ node = c
, before = cs
, after = r.node : r.after
}
-- -- | Move the cursor to the first sibling.
first :: forall a. Loc a -> Loc a
first l@(Loc r) =
case reverse r.before of
Nil -> l
c : cs -> Loc r
{ node = c
, before = Nil
, after = cs <> r.after
}
-- -- | Move the cursor to the last sibling.
last :: forall a. Loc a -> Loc a
last l@(Loc r) =
case reverse r.after of
Nil -> l
c : cs -> Loc r
{ node = c
, before = cs <> (r.node : r.before)
, after = Nil
}
-- -- | Move the cursor to the parent `Node`.
up :: forall a. Loc a -> Maybe (Loc a)
up l@(Loc r) =
case r.parents of
Nil -> Nothing
(p : ps) -> Just $ Loc
{ node: (value p) :< (siblings l)
, before: before p
, after: after p
, parents: ps
}
-- | Move the cursor to the root of the tree.
root :: forall a. Loc a -> Loc a
root l =
case up l of
Nothing -> l
Just p -> root p
-- | Move the cursor to the first child of the current `Node`.
firstChild :: forall a. Loc a -> Maybe (Loc a)
firstChild n =
case children n of
Nil -> Nothing
c : cs ->
Just $ Loc
{ node: c
, before: Nil
, after: cs
, parents: n : (parents n)
}
-- | Move the cursor to the first child of the current `Node`.
down :: forall a. Loc a -> Maybe (Loc a)
down = firstChild
-- | Move the cursor to the last child of the current `Node`.
lastChild :: forall a. Loc a -> Maybe (Loc a)
lastChild n =
case reverse (children n) of
Nil -> Nothing
c : cs ->
Just $ Loc
{ node: c
, before: cs
, after: Nil
, parents: n : (parents n)
}
-- | Move the cursor to a specific sibling by it's index.
siblingAt :: forall a. Int -> Loc a -> Maybe (Loc a)
siblingAt i l@(Loc r) = do
p <- up l
c <- (children p) !! i
let before' = reverse $ take i (children p)
let after' = drop (i + 1) (children p)
pure $ Loc
{ node: c
, before: before'
, after: after'
, parents: r.parents
}
-- | Move the cursor to a specific child of the current `Node` by it's index.
childAt :: forall a. Int -> Loc a -> Maybe (Loc a)
childAt i p = (firstChild p) >>= (siblingAt i)
-- | Retrieve the `Tree` representation, i.e., returns the root `Node` of the
-- | current tree.
toTree :: forall a. Loc a -> Tree a
toTree = node <<< root
-- | Get a `Loc`ation representation from a given `Tree`.
fromTree :: forall a. Tree a -> Loc a
fromTree n = Loc
{ node: n
, before: Nil
, after: Nil
, parents: Nil
}
-- | Set the `Node` at the current position.
setNode :: forall a. Tree a -> Loc a -> Loc a
setNode a (Loc r) = Loc r { node = a }
-- | Set the `Node` at the current position.
modifyNode :: forall a. (Tree a -> Tree a) -> Loc a -> Loc a
modifyNode f (Loc r) = Loc r { node = f r.node }
-- | Set the value of the current `Node`.
setValue :: forall a. a -> Loc a -> Loc a
setValue a l = setNode (setNodeValue a (node l)) l
-- | Modify the value of the current `Node`.
modifyValue :: forall a. (a -> a) -> Loc a -> Loc a
modifyValue f l = setNode (modifyNodeValue f (node l)) l
-- -- insert and delete nodes
-- | Insert a node after the current position, and move cursor to the new node.
insertAfter :: forall a. Tree a -> Loc a -> Loc a
insertAfter n (Loc r) = Loc r
{ node = n
, before = r.node : r.before
}
-- | Insert a node before the current position, and move cursor to the new node.
insertBefore :: forall a. Tree a -> Loc a -> Loc a
insertBefore n (Loc r) = Loc r
{ node = n
, after = r.node : r.after
}
-- | Insert a node as a child to the current node, and move cursor to the new node.
insertChild :: forall a. Tree a -> Loc a -> Loc a
insertChild n l =
case down l of
Just c -> insertAfter n c
Nothing -> Loc
{ node: n
, after: Nil
, before: Nil
, parents: l : (parents l)
}
-- | Delete the node in the current position.
delete :: forall a. Loc a -> Loc a
delete l@(Loc r) =
case r.after of
c : cs -> Loc r
{ node = c
, after = cs
}
Nil ->
case r.before of
c : cs -> Loc r
{ node = c
, before = cs
}
Nil ->
case r.parents of
Nil -> l
c : _ -> Loc
{ node: mkTree (value c) Nil
, before: before c
, after: after c
, parents: parents c
}
-- 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 = 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 = 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 = findFromRootWhere (_ == a)
-- | flattens the Tree into a List depth first.
flattenLocDepthFirst :: ∀ a. Loc a -> List (Loc a)
flattenLocDepthFirst loc = loc : (go loc)
where
go :: Loc a -> List (Loc a)
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 l -> l : go l
Nothing -> Nil
-- Setters and Getters
node :: forall a. Loc a -> Tree a
node (Loc r) = r.node
value :: forall a. Loc a -> a
value = head <<< node
before :: forall a. Loc a -> Forest a
before (Loc r) = r.before
after :: forall a. Loc a -> Forest a
after (Loc r) = r.after
parents :: forall a. Loc a -> List (Loc a)
parents (Loc r) = r.parents
children :: forall a. Loc a -> Forest a
children = tail <<< node
siblings :: forall a. Loc a -> Forest a
siblings (Loc r) = (reverse r.before) <> (r.node : r.after)

92
src/Yoga/Tree.purs Normal file
View File

@ -0,0 +1,92 @@
module Yoga.Tree where
import Prelude
import Control.Comonad.Cofree (Cofree, head, mkCofree, tail, (:<))
import Control.Monad.Rec.Class (Step(..), tailRec)
import Data.Array (snoc, uncons)
import Data.Maybe (Maybe(..))
import Data.Monoid (power)
import Data.Traversable (Accum)
-- | A Rose, or multi-way tree, with values of type `a`.
type Tree a =
Cofree Array a
type Forest a =
Array (Tree a)
-- | Create a `Tree` from a `Node` value of type `a` and a `Forest` of children.
mkTree ∷ ∀ a. a -> Forest a -> Tree a
mkTree = mkCofree
mkLeaf ∷ ∀ a. a -> Tree a
mkLeaf = flip mkTree []
leaf :: forall a. a -> Tree a
leaf = mkLeaf
-- | Draw a 2D `String` representation of a `Tree String`.
drawTree ∷ Tree String -> String
drawTree t = tailRec go { level: 0, drawn: (head t) <> "\n", current: (tail t) }
where
go ∷ { current ∷ Forest String, drawn ∷ String, level ∷ Int } -> Step { current ∷ Forest String, drawn ∷ String, level ∷ Int } String
go x = case x { current = uncons x.current } of
{ drawn: s, current: Nothing } -> Done s
{ level: l, drawn: s, current: Just { head: c, tail: cs } } ->
let
drawn = (power " " l) <> "|----> " <> (head c) <> "\n"
in
Loop { level: l, drawn: s <> drawn <> (tailRec go { level: l + 1, drawn: "", current: (tail c) }), current: cs }
-- | Draw a 2D `String` representation of a `Tree` composed of `Show`able
-- | elements.
showTree ∷ ∀ a. Show a => Tree a -> String
showTree = drawTree <<< (map show)
-- | Scan a `Tree`, accumulating values of `b` there are constant across `Node`s
-- | that have the same parent.
scanTree ∷ ∀ a b. (a -> b -> b) -> b -> Tree a -> Tree b
scanTree f b n =
let
fb = f (head n) b
in
fb :< (tailRec go { b: fb, current: (tail n), final: [] })
where
go ∷ { final ∷ Forest b, current ∷ Forest a, b ∷ b } -> Step { final ∷ Forest b, current ∷ Forest a, b ∷ b } (Forest b)
go x = case x { current = uncons x.current } of
{ current: Nothing, final } -> Done final
{ b: b', current: Just { head: c, tail: cs }, final } ->
let
fb' = f (head c) b'
in
Loop { b: b', current: cs, final: snoc final (fb' :< tailRec go { b: fb', current: (tail c), final: [] }) }
-- | Scan a `Tree`, accumulating values of `b` there are constant across `Node`s
-- | that have the same parent, and returning a `Tree` of type `c`.
scanTreeAccum ∷ ∀ a b c. (a -> b -> Accum b c) -> b -> Tree a -> Tree c
scanTreeAccum f b n =
let
fb = f (head n) b
in
fb.value :< (tailRec go { b: fb.accum, current: (tail n), final: [] })
where
go ∷ { final ∷ Forest c, current ∷ Forest a, b ∷ b } -> Step { final ∷ Forest c, current ∷ Forest a, b ∷ b } (Forest c)
go x = case (x { current = uncons x.current }) of
{ current: Nothing, final } -> Done final
{ b: b', current: Just { head: c, tail: cs }, final } ->
let
fb' = f (head c) b'
in
Loop { b: b', current: cs, final: snoc final (fb'.value :< tailRec go { b: fb'.accum, current: (tail c), final: [] }) }
-- | Set the value of a node.
setNodeValue ∷ ∀ a. a -> Tree a -> Tree a
setNodeValue a n = a :< (tail n)
-- | Modify the value of a node.
modifyNodeValue ∷ ∀ a. (a -> a) -> Tree a -> Tree a
modifyNodeValue f n = f (head n) :< tail n
-- | Append a child to a node.
appendChild ∷ ∀ a. Tree a -> Tree a -> Tree a
appendChild c n = head n :< snoc (tail n) c

333
src/Yoga/Tree/Zipper.purs Normal file
View File

@ -0,0 +1,333 @@
module Yoga.Tree.Zipper where
import Prelude
import Control.Alt ((<|>))
import Control.Comonad.Cofree (head, tail, (:<))
import Data.Array (drop, reverse, take, uncons, (!!), (:))
import Data.Maybe (Maybe(Just, Nothing))
import Yoga.Tree (Forest, Tree, mkTree, modifyNodeValue, setNodeValue)
-- | The `Loc` type describes the location of a `Node` inside a `Tree`. For this
-- | we store the current `Node`, the sibling nodes that appear before the current
-- | node, the sibling nodes that appear after the current node, and a `Array` of
-- | `Loc`ations that store the parent node locations up to the root of the three.
-- |
-- | So, effectively, the `parents` field records the path travelled in the
-- | tree to reach the level of the current `Node` starting from the tree's root,
-- | and the `before` and `after` fields describe its location in the current
-- | level.
newtype Loc a = Loc
{ node ∷ Tree a
, before ∷ Forest a
, after ∷ Forest a
, parents ∷ Array (Loc a)
}
instance eqLoc ∷ Eq a => Eq (Loc a) where
eq (Loc r1) (Loc r2) =
(r1.node == r2.node)
&& (r1.before == r2.before)
&& (r1.after == r2.after)
&& (r1.parents == r2.parents)
-- -- Cursor movement
-- | Move the cursor to the next sibling.
next ∷ ∀ a. Loc a -> Maybe (Loc a)
next (Loc r) = case uncons r.after of
Nothing -> Nothing
Just { head: c, tail: cs } ->
Just
$ Loc
{ node: c
, before: r.node : r.before
, after: cs
, parents: r.parents
}
-- -- | Move the cursor to the previous sibling.
prev ∷ ∀ a. Loc a -> Maybe (Loc a)
prev (Loc r) = case uncons r.before of
Nothing -> Nothing
Just { head: c, tail: cs } ->
Just
$ Loc
{ node: c
, before: cs
, after: r.node : r.after
, parents: r.parents
}
-- -- | Move the cursor to the first sibling.
first ∷ ∀ a. Loc a -> Loc a
first l@(Loc r) = case uncons r.before of
Nothing -> l
Just { head: c, tail: cs } ->
Loc
$
{ node: c
, before: []
, after: (reverse cs) <> r.after
, parents: r.parents
}
-- -- | Move the cursor to the last sibling.
last ∷ ∀ a. Loc a -> Loc a
last l@(Loc r) = case uncons (reverse r.after) of
Nothing -> l
Just { head: c, tail: cs } ->
Loc
$
{ node: c
, before: cs <> r.before
, after: []
, parents: r.parents
}
-- -- | Move the cursor to the parent `Node`.
up ∷ ∀ a. Loc a -> Maybe (Loc a)
up l@(Loc r) = case uncons r.parents of
Nothing -> Nothing
Just { head: p, tail: ps } ->
Just
$ Loc
{ node: (value p) :< (siblings l)
, before: before p
, after: after p
, parents: ps
}
-- | Move the cursor to the root of the tree.
root ∷ ∀ a. Loc a -> Loc a
root l = case up l of
Nothing -> l
Just p -> root p
-- | Move the cursor to the first child of the current `Node`.
firstChild ∷ ∀ a. Loc a -> Maybe (Loc a)
firstChild n = case uncons (children n) of
Nothing -> Nothing
Just { head: c, tail: cs } ->
Just
$ Loc
{ node: c
, before: []
, after: cs
, parents: n : (parents n)
}
-- | Move the cursor to the first child of the current `Node`.
down ∷ ∀ a. Loc a -> Maybe (Loc a)
down = firstChild
-- | Move the cursor to the last child of the current `Node`.
lastChild ∷ ∀ a. Loc a -> Maybe (Loc a)
lastChild p = last <$> down p
-- | Move the cursor to a specific sibling by it's index.
siblingAt ∷ ∀ a. Int -> Loc a -> Maybe (Loc a)
siblingAt i l@(Loc r) = case up l of
Nothing -> Nothing
Just p -> case (children p) !! i of
Nothing -> Nothing
Just c ->
let
before' = reverse $ take i (children p)
after' = drop (i + 1) (children p)
in
Just
$ Loc
{ node: c
, before: before'
, after: after'
, parents: r.parents
}
-- | Move the cursor to a specific child of the current `Node` by it's index.
childAt ∷ ∀ a. Int -> Loc a -> Maybe (Loc a)
childAt i p = (firstChild p) >>= (siblingAt i)
-- | Retrieve the `Tree` representation, i.e., returns the root `Node` of the
-- | current tree.
toTree ∷ ∀ a. Loc a -> Tree a
toTree = node <<< root
-- | Get a `Loc`ation representation from a given `Tree`.
fromTree ∷ ∀ a. Tree a -> Loc a
fromTree n =
Loc
{ node: n
, before: []
, after: []
, parents: []
}
-- | Set the `Node` at the current position.
setNode ∷ ∀ a. Tree a -> Loc a -> Loc a
setNode a (Loc r) =
Loc
{ node: a
, before: r.before
, after: r.after
, parents: r.parents
}
-- | Set the `Node` at the current position.
modifyNode ∷ ∀ a. (Tree a -> Tree a) -> Loc a -> Loc a
modifyNode f (Loc r) =
Loc
{ node: f r.node
, before: r.before
, after: r.after
, parents: r.parents
}
-- | Set the value of the current `Node`.
setValue ∷ ∀ a. a -> Loc a -> Loc a
setValue a l = setNode (setNodeValue a (node l)) l
-- | Modify the value of the current `Node`.
modifyValue ∷ ∀ a. (a -> a) -> Loc a -> Loc a
modifyValue f l = setNode (modifyNodeValue f (node l)) l
-- -- insert and delete nodes
-- | Insert a node after the current position, and move cursor to the new node.
insertAfter ∷ ∀ a. Tree a -> Loc a -> Loc a
insertAfter n l =
Loc
{ node: n
, after: after l
, before: (node l) : (before l)
, parents: parents l
}
-- | Insert a node before the current position, and move cursor to the new node.
insertBefore ∷ ∀ a. Tree a -> Loc a -> Loc a
insertBefore n l =
Loc
{ node: n
, after: (node l) : (after l)
, before: before l
, parents: parents l
}
-- | Insert a node as a child to the current node, and move cursor to the new node.
insertChild ∷ ∀ a. Tree a -> Loc a -> Loc a
insertChild n l = case down l of
Just c -> insertAfter n c
Nothing ->
Loc
{ node: n
, after: []
, before: []
, parents: l : (parents l)
}
-- | Delete the node in the current position.
delete ∷ ∀ a. Loc a -> Loc a
delete l@(Loc r) = case uncons r.after of
Just { head: c, tail: cs } ->
Loc
{ node: c
, before: r.before
, after: cs
, parents: r.parents
}
Nothing -> case uncons r.before of
Just { head: c, tail: cs } ->
Loc
{ node: c
, before: cs
, after: r.after
, parents: r.parents
}
Nothing -> case uncons r.parents of
Nothing -> l
Just { head: c } ->
Loc
{ node: mkTree (value c) []
, before: before c
, after: after c
, parents: parents c
}
-- 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 ∷ ∀ a. Eq a => a -> Loc a -> Maybe (Loc a)
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 ∷ ∀ a. Eq a => a -> Loc a -> Maybe (Loc a)
findUp a = findUpWhere (_ == a)
-- | Search from the root of the mkTree 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 ∷ ∀ a. Eq a => a -> Loc a -> Maybe (Loc a)
findFromRoot a = findFromRootWhere (_ == a)
-- | flattens the Tree into a Array depth first.
flattenLocDepthFirst ∷ ∀ a. Loc a -> Array (Loc a)
flattenLocDepthFirst loc = loc : (go loc)
where
go ∷ Loc a -> Array (Loc a)
go loc' =
let
downs = goDir loc' down
nexts = goDir loc' next
in
downs <> nexts
goDir ∷ Loc a -> (Loc a -> Maybe (Loc a)) -> Array (Loc a)
goDir loc' dirFn = case (dirFn loc') of
Just l -> l : go l
Nothing -> []
-- Setters and Getters
node ∷ ∀ a. Loc a -> Tree a
node (Loc r) = r.node
value ∷ ∀ a. Loc a -> a
value = head <<< node
before ∷ ∀ a. Loc a -> Forest a
before (Loc r) = r.before
after ∷ ∀ a. Loc a -> Forest a
after (Loc r) = r.after
parents ∷ ∀ a. Loc a -> Array (Loc a)
parents (Loc r) = r.parents
children ∷ ∀ a. Loc a -> Forest a
children = tail <<< node
siblings ∷ ∀ a. Loc a -> Forest a
siblings (Loc r) = (reverse r.before) <> (r.node : r.after)

22
test.dhall
View File

@ -1,4 +1,20 @@
let config = ./spago.dhall
in config // { sources = config.sources # [ "test/**/*.purs" ]
, dependencies = [ "console", "spec" ]
}
in config
// { sources = config.sources # [ "test/**/*.purs" ]
, dependencies =
[ "console"
, "spec"
, "aff"
, "arrays"
, "control"
, "effect"
, "foldable-traversable"
, "free"
, "lists"
, "maybe"
, "partial"
, "prelude"
, "tailrec"
]
}

66
test/Example.purs
View File

@ -2,15 +2,15 @@ module Test.Example where
import Prelude
import Control.Comonad.Cofree (Cofree, head, mkCofree, tail, (:<))
import Control.Comonad.Cofree (head, tail, (:<))
import Control.Monad.Rec.Class (Step(..), tailRec)
import Data.List.Types (List(..), (:))
import Data.Maybe (Maybe, maybe)
import Data.Array (uncons)
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid (power)
import Data.Tree (Tree)
import Data.Tree.Zipper (fromTree, toTree, modifyValue, down, next, root)
import Effect (Effect)
import Effect.Console (log)
import Yoga.Tree (Tree, mkLeaf)
import Yoga.Tree.Zipper (fromTree, toTree, modifyValue, down, next, root)
-- Serves only to make this file runnable
main :: Effect Unit
@ -30,45 +30,26 @@ main = do
-- These examples show how to create a Tree
rootOnly_mkCoFree :: Tree String
rootOnly_mkCoFree = mkCofree "root" Nil
rootOnly_mkCoFree = mkLeaf "root"
rootOnly_alias :: Tree String
rootOnly_alias = "root" :< Nil -- `:<` is the alias for `mkCofree`
rootOnly_alias = "root" :< [] -- `:<` is the alias for `mkCofree`
rootWithLeaves :: Tree String
rootWithLeaves =
"root" :<
( ( "leaf" :< Nil )
: ( "leaf" :< Nil )
: ( "leaf" :< Nil )
: Nil
)
[]
rootWithBranchesAndLeaves :: Tree String
rootWithBranchesAndLeaves =
"1" :<
( ( "1.1" :<
( ( "1.1.1" :< Nil )
: ( "1.1.2" :< Nil )
: Nil
)
)
: ( "1.2" :< Nil )
: ( "1.3" :<
( ( "1.3.1" :< Nil )
: ( "1.3.2" :< Nil )
: Nil
)
)
: Nil
)
"1" :< []
-- In our code, we will need to iterate through a Tree and do something
-- with each of its contents. Such a function has already been done
-- via `drawTree`, which iterates through a tree's contents
-- and converts it into a String, indenting them according to their respective
-- level:
-- https://github.com/dmbfm/purescript-tree/blob/v1.3.2/src/Data/Tree.purs#L21-L21
-- https://github.com/dmbfm/purescript-tree/blob/v1.3.2/src/Yoga/Tree.purs#L21-L21
-- The below example is a reproduction of the above code but differs from
-- it in that the names are more clearly defined to make it easier to see
@ -82,19 +63,20 @@ drawTree' tree =
in
tailRec go {level: 1, result: root <> "\n", current: children }
where
go :: { level :: Int, result :: String, current :: List (Cofree List String) }
-> Step { level :: Int, result :: String, current :: List (Cofree List String) } String
go {level: l, result: s, current: Nil } = Done s
go rec@{level: l, result: s, current: (Cons thisTree remainingTrees) } =
let
levelRoot = head thisTree
levelChildren = tail thisTree
content = (power " " l) <> levelRoot <> "\n"
in Loop
rec { current = remainingTrees
, result = rec.result <> content <>
(tailRec go { level: l + 1, result: "", current: levelChildren })
}
go :: { level :: Int, result :: String, current :: Array (Tree String) }
-> Step { level :: Int, result :: String, current :: Array (Tree String) } String
go rec@{level: l, result: s, current } =
case uncons current of
Nothing -> Done s
Just { head: thisTree, tail: remainingTrees } -> do
let levelRoot = head thisTree
let levelChildren = tail thisTree
let content = (power " " l) <> levelRoot <> "\n"
Loop
rec { current = remainingTrees
, result = rec.result <> content <>
(tailRec go { level: l + 1, result: "", current: levelChildren })
}
-- Since we'll also be using the Zipper for the Tree (the `Loc` type),

404
test/Main.purs
View File

@ -3,10 +3,7 @@ module Test.Main where
import Prelude
import Control.Comonad.Cofree (head, (:<))
import Data.List (List(Nil), (:))
import Data.Maybe (Maybe(..), fromJust)
import Data.Tree (Tree, mkTree, scanTree)
import Data.Tree.Zipper (down, findDownWhere, findFromRoot, findUp, flattenLocDepthFirst, fromTree, insertAfter, modifyValue, next, toTree, value, firstChild, lastChild)
import Effect (Effect)
import Effect.Aff (launchAff_)
import Partial.Unsafe (unsafePartial)
@ -14,58 +11,63 @@ import Test.Spec (describe, it)
import Test.Spec.Assertions (shouldEqual)
import Test.Spec.Reporter (consoleReporter)
import Test.Spec.Runner (runSpec)
import Yoga.Tree (Tree, leaf, scanTree, showTree)
import Yoga.Tree.Zipper (down, findDownWhere, findFromRoot, findUp, flattenLocDepthFirst, fromTree, modifyValue, next, toTree, value)
newtype SpecTree a = SpecTree (Tree a)
instance Show a => Show (SpecTree a) where
show (SpecTree t) = showTree t
derive instance (Eq a) => Eq (SpecTree a)
sampleTree :: Tree Int
sampleTree =
1 :<
(2 :< Nil)
: (3 :< Nil)
: (4 :<
(5 :< Nil)
: (6 :<
(7 :< Nil) : Nil)
: (8 :< Nil)
: Nil
)
: Nil
[ leaf 2
, leaf 3
, 4 :<
[ leaf 5
, 6 :< [ leaf 7 ]
, leaf 8
]
]
main :: Effect Unit
main = launchAff_ $ runSpec [consoleReporter] do
main = launchAff_ $ runSpec [ consoleReporter ] do
describe "Tree" do
it "mkTree" do
let t = mkTree 10 Nil
let t = 10 :< []
shouldEqual (head t) 10
it "Functor" do
let result =
2 :<
(3 :< Nil)
: (4 :< Nil)
: (5 :<
(6 :< Nil)
: (7 :<
(8 :< Nil) : Nil)
: (9 :< Nil)
: Nil
)
: Nil
shouldEqual (eq (((+)1) <$> sampleTree) result) true
let
result = 2 :<
[ leaf 3
, leaf 4
, 5 :<
[ leaf 6
, 7 :< [ leaf 8 ]
, leaf 9
]
]
SpecTree (((+) 1) <$> sampleTree) `shouldEqual` SpecTree result
it "scanTree" do
let result =
1 :<
(3 :< Nil)
: (4 :< Nil)
: (5 :<
(10 :< Nil)
: (11 :<
(18 :< Nil) : Nil)
: (13 :< Nil)
: Nil
)
: Nil
shouldEqual (eq (scanTree (\a b -> a + b) 0 sampleTree) result) true
let
result =
1 :<
[ leaf 3
, leaf 4
, 5 :<
[ leaf 10
, 11 :< [ leaf 18 ]
, leaf 13
]
]
SpecTree (scanTree (\a b -> a + b) 0 sampleTree) `shouldEqual` SpecTree result
describe "Zipper" do
@ -75,221 +77,145 @@ main = launchAff_ $ runSpec [consoleReporter] do
let root' = unsafePartial $ toTree $ modifyValue (\a -> 2 * a) (fromJust $ down root)
let root'' = unsafePartial $ toTree $ modifyValue (\a -> 2 * a) (fromJust $ down >=> next >=> next >=> down $ root)
let result =
1 :<
(4 :< Nil)
: (3 :< Nil)
: (4 :<
(5 :< Nil)
: (6 :<
(7 :< Nil) : Nil)
: (8 :< Nil)
: Nil
)
: Nil
let result' =
1 :<
(2 :< Nil)
: (3 :< Nil)
: (4 :<
(10 :< Nil)
: (6 :<
(7 :< Nil) : Nil)
: (8 :< Nil)
: Nil
)
: Nil
let
result =
1 :<
[ leaf 4
, leaf 3
, 4 :<
[ leaf 5
, 6 :< [ leaf 7 ]
, leaf 8
]
shouldEqual (eq root' result) true
shouldEqual (eq root'' result') true
]
it "Insert" do
let
result' =
1 :<
[ 2 :< []
, 3 :< []
, 4 :<
[ 10 :< []
, 6 :< [ 7 :< [] ]
, 8 :< []
]
]
let root1 = unsafePartial $ toTree $ insertAfter (mkTree 100 Nil) (fromJust $ down root)
let root2 = unsafePartial $ toTree $ insertAfter (mkTree 100 Nil) (fromJust $ (down root) >>= next >>= next >>= down >>= next >>= down)
let root3 = unsafePartial $ toTree $ insertAfter (mkTree 100 Nil) (fromJust $ (firstChild root))
let root4 = unsafePartial $ toTree $ insertAfter (mkTree 100 Nil) (fromJust $ (lastChild root))
SpecTree root' `shouldEqual` SpecTree result
SpecTree root'' `shouldEqual` SpecTree result'
let result1 =
1 :<
(2 :< Nil)
: (100 :< Nil)
: (3 :< Nil)
: (4 :<
(5 :< Nil)
: (6 :<
(7 :< Nil) : Nil)
: (8 :< Nil)
: Nil
)
: Nil
-- it "Insert" do
let result2 =
1 :<
(2 :< Nil)
: (3 :< Nil)
: (4 :<
(5 :< Nil)
: (6 :<
(7 :< Nil)
: (100 :< Nil)
: Nil)
: (8 :< Nil)
: Nil
)
: Nil
let result3 =
1 :<
(2 :< Nil)
: (100 :< Nil)
: (3 :< Nil)
: (4 :<
(5 :< Nil)
: (6 :<
(7 :< Nil)
: Nil
)
: (8 :< Nil)
: Nil
)
: Nil
let result4 =
1 :<
(2 :< Nil)
: (3 :< Nil)
: (4 :<
(5 :< Nil)
: (6 :<
(7 :< Nil) : Nil)
: (8 :< Nil)
: Nil
)
: (100 :< Nil)
: Nil
shouldEqual (eq root1 result1) true
shouldEqual (eq root2 result2) true
shouldEqual (eq root3 result3) true
shouldEqual (eq root4 result4) true
-- let root1 = unsafePartial $ toTree $ insertAfter (mkLeaf 100) (fromJust $ down root)
-- let root2 = unsafePartial $ toTree $ insertAfter (mkLeaf 100) (fromJust $ (down root) >>= next >>= next >>= down >>= next >>= down)
-- let root3 = unsafePartial $ toTree $ insertAfter (mkLeaf 100) (fromJust $ (firstChild root))
-- let root4 = unsafePartial $ toTree $ insertAfter (mkLeaf 100) (fromJust $ (lastChild root))
it "Should findDownWhere with single node" do
let tree = 1 :< Nil
let loc = fromTree tree
shouldEqual (Just 1) ((findDownWhere (_ == 1) loc) <#> value)
-- let result1 = 1 :< []
-- let result2 = 1 :< []
-- let result3 = 1 :< []
-- let result4 = 1 :< []
-- shouldEqual (eq root1 result1) true
-- shouldEqual (eq root2 result2) true
-- shouldEqual (eq root3 result3) true
-- shouldEqual (eq root4 result4) true
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 single node" do
let tree = 1 :< []
let loc = fromTree tree
shouldEqual (Just 1) ((findDownWhere (_ == 1) 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 2 nodes and 2 levels" do
let tree = 1 :< [ leaf 2 ]
let loc = fromTree tree
shouldEqual (Just 2) ((findDownWhere (_ == 2) 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 3 nodes and 2 levels" do
let tree = 1 :< [ leaf 2, leaf 3 ]
let loc = fromTree tree
shouldEqual (Just 3) ((findDownWhere (_ == 3) 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 4 nodes and 2 levels" do
let tree = 1 :< (leaf <$> [ 2, 3, 4 ])
let loc = fromTree tree
shouldEqual (Just 4) ((findDownWhere (_ == 4) 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 5 nodes and 3 levels" do
let
tree = 1 :<
[ leaf 2
, leaf 3
, 4 :< [ leaf 5 ]
]
-- log $ showTree tree
let loc = fromTree tree
shouldEqual (Just 5) ((findDownWhere (_ == 5) 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 6 nodes and 3 levels" do
let
tree = 1 :<
[ leaf 2
, leaf 3
, 4 :< [ leaf 5, leaf 6 ]
]
-- log $ showTree tree
let loc = fromTree tree
shouldEqual (Just 6) ((findDownWhere (_ == 6) 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 7 nodes and 4 levels" do
let
tree = 1 :<
[ leaf 2
, leaf 3
, 4 :< [ leaf 5, 6 :< [ leaf 7 ] ]
]
-- log $ showTree tree
let loc = fromTree tree
shouldEqual (Just 7) ((findDownWhere (_ == 7) 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 findDownWhere with 8 nodes and 4 levels" do
let
tree = 1 :<
[ leaf 2
, leaf 3
, 4 :< [ leaf 5, 6 :< [ leaf 7 ] ]
, leaf 8
]
-- log $ showTree tree
let loc = fromTree tree
shouldEqual (Just 8) ((findDownWhere (_ == 8) loc) <#> value)
it "Should find 7 from the sampleTree" do
shouldEqual (Just 7) (findDownWhere (_ == 7) (fromTree sampleTree) <#> value)
it "Should findDownWhere with 8 nodes and 4 levels with a step back" do
let
tree = 1 :<
[ leaf 2
, leaf 3
, 4 :< [ leaf 5, 6 :< [ leaf 7 ] ]
, leaf 8
]
-- log $ showTree tree
let loc = fromTree tree
shouldEqual (Just 7) ((findDownWhere (_ == 7) loc) <#> 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 7 from the sampleTree" do
shouldEqual (Just 7) (findDownWhere (_ == 7) (fromTree sampleTree) <#> 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 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) and then find 7 using findFromRoot" do
let eight = unsafePartial $ fromJust $ findDownWhere (_ == 8) $ fromTree sampleTree
shouldEqual (Just 7) (findFromRoot 7 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 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)
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)
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]