ALGO: rename QuadTree Zipper and rm Breadcrumbs type

This commit is contained in:
hasufell 2014-12-03 21:18:15 +01:00
parent 4a0c9ff58d
commit 0f0362322e
No known key found for this signature in database
GPG Key ID: 220CD1C5BDEED020
2 changed files with 16 additions and 19 deletions

View File

@ -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

View File

@ -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))