ALGO: rename QuadTree Zipper and rm Breadcrumbs type
This commit is contained in:
parent
4a0c9ff58d
commit
0f0362322e
@ -13,7 +13,7 @@ module Algorithms.QuadTree.QuadTree
|
|||||||
Orient(North,East,West,South),
|
Orient(North,East,West,South),
|
||||||
Quad(NW,NE,SW,SE),
|
Quad(NW,NE,SW,SE),
|
||||||
QuadTree,
|
QuadTree,
|
||||||
Zipper)
|
QTZipper)
|
||||||
where
|
where
|
||||||
|
|
||||||
import Algebra.VectorTypes
|
import Algebra.VectorTypes
|
||||||
@ -42,17 +42,14 @@ data Quad = NW | NE
|
|||||||
deriving (Show)
|
deriving (Show)
|
||||||
|
|
||||||
-- |A Crumb used for the QuadTree Zipper.
|
-- |A Crumb used for the QuadTree Zipper.
|
||||||
data Crumb a = NWCrumb (QuadTree a) (QuadTree a) (QuadTree a)
|
data QTCrumb a = NWCrumb (QuadTree a) (QuadTree a) (QuadTree a)
|
||||||
| NECrumb (QuadTree a) (QuadTree a) (QuadTree a)
|
| NECrumb (QuadTree a) (QuadTree a) (QuadTree a)
|
||||||
| SWCrumb (QuadTree a) (QuadTree a) (QuadTree a)
|
| SWCrumb (QuadTree a) (QuadTree a) (QuadTree a)
|
||||||
| SECrumb (QuadTree a) (QuadTree a) (QuadTree a)
|
| SECrumb (QuadTree a) (QuadTree a) (QuadTree a)
|
||||||
deriving (Show, Eq)
|
deriving (Show, Eq)
|
||||||
|
|
||||||
-- |A list of Crumbs.
|
|
||||||
type Breadcrumbs a = [Crumb a]
|
|
||||||
|
|
||||||
-- |Zipper for the QuadTree.
|
-- |Zipper for the QuadTree.
|
||||||
type Zipper a = (QuadTree a, Breadcrumbs a)
|
type QTZipper a = (QuadTree a, [QTCrumb a])
|
||||||
|
|
||||||
-- |Orientation.
|
-- |Orientation.
|
||||||
data Orient = North | South | East | West
|
data Orient = North | South | East | West
|
||||||
@ -69,7 +66,7 @@ seSq ((xl, xu), (yl, yu)) = (,) ((xl + xu) / 2, xu) (yl, (yl + yu) / 2)
|
|||||||
|
|
||||||
-- |Check whether the current Node is an nw, ne, sw or se child of it's
|
-- |Check whether the current Node is an nw, ne, sw or se child of it's
|
||||||
-- parent.
|
-- parent.
|
||||||
isNWchild, isNEchild, isSWchild, isSEchild :: Zipper a -> Bool
|
isNWchild, isNEchild, isSWchild, isSEchild :: QTZipper a -> Bool
|
||||||
isNWchild (_, NWCrumb {}:_) = True
|
isNWchild (_, NWCrumb {}:_) = True
|
||||||
isNWchild _ = False
|
isNWchild _ = False
|
||||||
isNEchild (_, NECrumb {}:_) = True
|
isNEchild (_, NECrumb {}:_) = True
|
||||||
@ -111,7 +108,7 @@ quadTreeSquares sq (TNode nw ne sw se) =
|
|||||||
|
|
||||||
-- |Get the current square of the zipper, relative to the given top
|
-- |Get the current square of the zipper, relative to the given top
|
||||||
-- square.
|
-- square.
|
||||||
getSquareByZipper :: Square -> Zipper a -> Square
|
getSquareByZipper :: Square -> QTZipper a -> Square
|
||||||
getSquareByZipper sq z = go sq (reverse . snd $ z)
|
getSquareByZipper sq z = go sq (reverse . snd $ z)
|
||||||
where
|
where
|
||||||
go sq' [] = sq'
|
go sq' [] = sq'
|
||||||
@ -135,7 +132,7 @@ qtFoldr f sv qt = qtFoldl (\g b x -> g (f b x)) id qt sv
|
|||||||
|
|
||||||
|
|
||||||
-- |Go to nw, ne, sw or se from the current node, one level deeper.
|
-- |Go to nw, ne, sw or se from the current node, one level deeper.
|
||||||
goNW, goNE, goSW, goSE :: Zipper a -> Maybe (Zipper a)
|
goNW, goNE, goSW, goSE :: QTZipper a -> Maybe (QTZipper a)
|
||||||
goNW (TNode nw ne sw se, bs) = Just (nw, NWCrumb ne sw se:bs)
|
goNW (TNode nw ne sw se, bs) = Just (nw, NWCrumb ne sw se:bs)
|
||||||
goNW _ = Nothing
|
goNW _ = Nothing
|
||||||
goNE (TNode nw ne sw se, bs) = Just (ne, NECrumb nw sw se:bs)
|
goNE (TNode nw ne sw se, bs) = Just (ne, NECrumb nw sw se:bs)
|
||||||
@ -147,7 +144,7 @@ goSE _ = Nothing
|
|||||||
|
|
||||||
|
|
||||||
-- |Go to the given Quad from the current Node, one level deeper.
|
-- |Go to the given Quad from the current Node, one level deeper.
|
||||||
goQuad :: Quad -> Zipper a -> Maybe (Zipper a)
|
goQuad :: Quad -> QTZipper a -> Maybe (QTZipper a)
|
||||||
goQuad q = case q of
|
goQuad q = case q of
|
||||||
NW -> goNW
|
NW -> goNW
|
||||||
NE -> goNE
|
NE -> goNE
|
||||||
@ -156,7 +153,7 @@ goQuad q = case q of
|
|||||||
|
|
||||||
|
|
||||||
-- |Go up to the parent node, if any.
|
-- |Go up to the parent node, if any.
|
||||||
goUp :: Zipper a -> Maybe (Zipper a)
|
goUp :: QTZipper a -> Maybe (QTZipper a)
|
||||||
goUp (qt, NWCrumb ne sw se:bs) = Just (TNode qt ne sw se, bs)
|
goUp (qt, NWCrumb ne sw se:bs) = Just (TNode qt ne sw se, bs)
|
||||||
goUp (qt, NECrumb nw sw se:bs) = Just (TNode nw qt sw se, bs)
|
goUp (qt, NECrumb nw sw se:bs) = Just (TNode nw qt sw se, bs)
|
||||||
goUp (qt, SWCrumb nw ne se:bs) = Just (TNode nw ne qt se, bs)
|
goUp (qt, SWCrumb nw ne se:bs) = Just (TNode nw ne qt se, bs)
|
||||||
@ -165,18 +162,18 @@ goUp _ = Nothing
|
|||||||
|
|
||||||
|
|
||||||
-- |Get the root node.
|
-- |Get the root node.
|
||||||
rootNode :: Zipper a -> Zipper a
|
rootNode :: QTZipper a -> QTZipper a
|
||||||
rootNode (qt, []) = (qt, [])
|
rootNode (qt, []) = (qt, [])
|
||||||
rootNode z = rootNode . fromJust . goUp $ z
|
rootNode z = rootNode . fromJust . goUp $ z
|
||||||
|
|
||||||
|
|
||||||
-- |Look up a node by a given path of Quads.
|
-- |Look up a node by a given path of Quads.
|
||||||
lookupByPath' :: [Quad] -> QuadTree a -> Maybe (Zipper a)
|
lookupByPath' :: [Quad] -> QuadTree a -> Maybe (QTZipper a)
|
||||||
lookupByPath' qs qt = foldlM (flip goQuad) (qt, []) qs
|
lookupByPath' qs qt = foldlM (flip goQuad) (qt, []) qs
|
||||||
|
|
||||||
|
|
||||||
-- |Find the north, south, east or west neighbor of a given node.
|
-- |Find the north, south, east or west neighbor of a given node.
|
||||||
findNeighbor :: Orient -> Zipper a -> Maybe (Zipper a)
|
findNeighbor :: Orient -> QTZipper a -> Maybe (QTZipper a)
|
||||||
findNeighbor ot zr = case ot of
|
findNeighbor ot zr = case ot of
|
||||||
North -> go isSWchild isSEchild isNWchild goNW goNE goSW goSE zr
|
North -> go isSWchild isSEchild isNWchild goNW goNE goSW goSE zr
|
||||||
South -> go isNWchild isNEchild isSWchild goSW goSE goNW goNE zr
|
South -> go isNWchild isNEchild isSWchild goSW goSE goNW goNE zr
|
||||||
@ -200,11 +197,11 @@ findNeighbor ot zr = case ot of
|
|||||||
checkParent _ = Nothing
|
checkParent _ = Nothing
|
||||||
|
|
||||||
|
|
||||||
lookupByNeighbors :: [Orient] -> Zipper a -> Maybe (Zipper a)
|
lookupByNeighbors :: [Orient] -> QTZipper a -> Maybe (QTZipper a)
|
||||||
lookupByNeighbors = flip (foldlM (flip findNeighbor))
|
lookupByNeighbors = flip (foldlM (flip findNeighbor))
|
||||||
|
|
||||||
|
|
||||||
quadTreeToRoseTree :: Zipper PT -> Tree String
|
quadTreeToRoseTree :: QTZipper PT -> Tree String
|
||||||
quadTreeToRoseTree z' = go (rootNode z')
|
quadTreeToRoseTree z' = go (rootNode z')
|
||||||
where
|
where
|
||||||
go z = case z of
|
go z = case z of
|
||||||
|
@ -255,7 +255,7 @@ quadPathSquare = Diag f
|
|||||||
(uncurry rectByDiagonal # lw thin # lc red)
|
(uncurry rectByDiagonal # lw thin # lc red)
|
||||||
(getSquare (stringToQuads (quadPath p)) (qt vt p, []))
|
(getSquare (stringToQuads (quadPath p)) (qt vt p, []))
|
||||||
where
|
where
|
||||||
getSquare :: [Either Quad Orient] -> Zipper PT -> Square
|
getSquare :: [Either Quad Orient] -> QTZipper PT -> Square
|
||||||
getSquare [] z = getSquareByZipper (xDimension p, yDimension p) z
|
getSquare [] z = getSquareByZipper (xDimension p, yDimension p) z
|
||||||
getSquare (q:qs) z = case q of
|
getSquare (q:qs) z = case q of
|
||||||
Right x -> getSquare qs (fromMaybe z (findNeighbor x z))
|
Right x -> getSquare qs (fromMaybe z (findNeighbor x z))
|
||||||
@ -272,7 +272,7 @@ gifQuadPath = GifDiag f
|
|||||||
(uncurry rectByDiagonal # lw thick # lc col)
|
(uncurry rectByDiagonal # lw thick # lc col)
|
||||||
<$> getSquares (stringToQuads (quadPath p)) (qt vt p, [])
|
<$> getSquares (stringToQuads (quadPath p)) (qt vt p, [])
|
||||||
where
|
where
|
||||||
getSquares :: [Either Quad Orient] -> Zipper PT -> [Square]
|
getSquares :: [Either Quad Orient] -> QTZipper PT -> [Square]
|
||||||
getSquares [] z = [getSquareByZipper (xDimension p, yDimension p) z]
|
getSquares [] z = [getSquareByZipper (xDimension p, yDimension p) z]
|
||||||
getSquares (q:qs) z = case q of
|
getSquares (q:qs) z = case q of
|
||||||
Right x -> getSquareByZipper (xDimension p, yDimension p) z :
|
Right x -> getSquareByZipper (xDimension p, yDimension p) z :
|
||||||
@ -293,7 +293,7 @@ treePretty = Diag f
|
|||||||
. quadPath
|
. quadPath
|
||||||
$ p)
|
$ p)
|
||||||
where
|
where
|
||||||
getCurQT :: [Either Quad Orient] -> Zipper PT -> Zipper PT
|
getCurQT :: [Either Quad Orient] -> QTZipper PT -> QTZipper PT
|
||||||
getCurQT [] z = z
|
getCurQT [] z = z
|
||||||
getCurQT (q:qs) z = case q of
|
getCurQT (q:qs) z = case q of
|
||||||
Right x -> getCurQT qs (fromMaybe z (findNeighbor x z))
|
Right x -> getCurQT qs (fromMaybe z (findNeighbor x z))
|
||||||
|
Loading…
Reference in New Issue
Block a user