hasufell
/
cga
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

DIAG: make the current node in the tree red

This commit is contained in:
hasufell 2014-11-15 15:26:43 +01:00
parent 50fc0c3d01
commit 60d7dca2c8
No known key found for this signature in database
GPG Key ID: 220CD1C5BDEED020
2 changed files with 33 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
Algorithms/QuadTree/QuadTree.hs
View File

@ -203,18 +203,23 @@ lookupByNeighbors = flip (foldlM (flip findNeighbor))
quadTreeToRoseTree :: Zipper PT -> Tree String
quadTreeToRoseTree z = case z of
(TNil, _) -> Node printOrigin []
(TLeaf a, _) -> Node (printOrigin ++ "\n" ++ (show . unp2 $ a)) []
_ -> Node printOrigin
[quadTreeToRoseTree (fromJust . goNW $ z)
, quadTreeToRoseTree (fromJust . goNE $ z)
, quadTreeToRoseTree (fromJust . goSW $ z)
, quadTreeToRoseTree (fromJust . goSE $ z)]
quadTreeToRoseTree z' = go (rootNode z')
where
printOrigin
| isNWchild z = "NW"
| isNEchild z = "NE"
| isSWchild z = "SW"
| isSEchild z = "SE"
| otherwise = "root"
go z = case z of
(TNil, _) -> Node markAndPrintOrigin []
(TLeaf a, _) -> Node (markAndPrintOrigin ++ "\n" ++ (show . unp2 $ a)) []
_ -> Node markAndPrintOrigin
[go (fromJust . goNW $ z)
, go (fromJust . goNE $ z)
, go (fromJust . goSW $ z)
, go (fromJust . goSE $ z)]
where
markAndPrintOrigin
| z' == z = "* " ++ printOrigin
| otherwise = printOrigin
printOrigin
| isNWchild z = "NW"
| isNEchild z = "NE"
| isSWchild z = "SW"
| isSEchild z = "SE"
| otherwise = "root"

17
Graphics/Diagram/Plotter.hs
View File

@ -238,13 +238,24 @@ treePretty :: Diag
treePretty = Diag f
where
f p (Object []) = mempty
f p (Object vt) = prettyRoseTree (quadTreeToRoseTree (qt, []))
f p (Object vt) =
prettyRoseTree (quadTreeToRoseTree . flip getCurQT (qt, []) . stringToQuads . pQt $ p)
where
qt = quadTree (filterValidPT p vt) (dX p, dY p)
getCurQT :: [Either Quad Orient] -> Zipper PT -> Zipper PT
getCurQT [] z = z
getCurQT (q:qs) z = case q of
Right x -> getCurQT qs (fromMaybe z (findNeighbor x z))
Left x -> getCurQT qs (fromMaybe z (goQuad x z))
prettyRoseTree :: Tree String -> Diagram Cairo R2
prettyRoseTree t =
renderTree (\n -> (text n # fontSizeL 5.0)
<> rect 50.0 20.0 # fc white)
renderTree (\n -> case head n of
'*' ->
(text n # fontSizeL 5.0)
<> rect 50.0 20.0 # fc red
_ ->
(text n # fontSizeL 5.0)
<> rect 50.0 20.0 # fc white)
(~~)
(symmLayout' (with & slHSep .~ 60 & slVSep .~ 40) t)
# scale 2 # alignT # bg white