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

DIAG: improve code prettiness

Browse Source
This commit is contained in:
hasufell 2014-11-16 04:37:34 +01:00
parent dd9bfc530d
commit 9c7acc6dce
No known key found for this signature in database
GPG Key ID: 220CD1C5BDEED020
1 changed files with 49 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

98
Graphics/Diagram/Plotter.hs
View File

@ -53,8 +53,9 @@ coordPointsText = Diag cpt
drawT [] _ = mempty drawT [] _ = mempty
drawT vt p drawT vt p
| showCoordText p = | showCoordText p =
position $ position
zip vtf (pointToTextCoord <$> vtf) # translate (r2 (0, 10)) $ zip vtf (pointToTextCoord <$> vtf)
# translate (r2 (0, 10))
| otherwise = mempty | otherwise = mempty
where where
vtf = filterValidPT p vt vtf = filterValidPT p vt
@ -69,11 +70,10 @@ polyLines = Diag pp
strokePoly x <> strokePoly y strokePoly x <> strokePoly y
where where
strokePoly x' = strokePoly x' =
(strokeTrail . (strokeTrail
fromVertices $ . fromVertices
vtf x' ++ [head . vtf $ x']) # $ vtf x' ++ [head . vtf $ x'])
moveTo (head x') # # moveTo (head x') # lc black
lc black
vtf = filterValidPT p vtf = filterValidPT p
pp _ _ = mempty pp _ _ = mempty
@ -84,31 +84,30 @@ polyIntersection = Diag pi'
where where
pi' p (Objects (x:y:_)) = position (zip vtpi (repeat dot)) pi' p (Objects (x:y:_)) = position (zip vtpi (repeat dot))
where where
paF = filterValidPT p x
pbF = filterValidPT p y
dot = (circle $ dotSize p :: Diagram Cairo R2) # fc red # lc red dot = (circle $ dotSize p :: Diagram Cairo R2) # fc red # lc red
vtpi = intersectionPoints vtpi = intersectionPoints
. sortLexPolys . sortLexPolys
$ (sortLexPoly paF, sortLexPoly pbF) $ (sortLexPoly . filterValidPT p $ x,
sortLexPoly . filterValidPT p $ y)
pi' _ _ = mempty pi' _ _ = mempty
-- |Show the intersection points of two polygons as red dots. -- |Show the coordinate text of the intersection points of two polygons.
polyIntersectionText :: Diag polyIntersectionText :: Diag
polyIntersectionText = Diag pit' polyIntersectionText = Diag pit'
where where
pit' p (Objects (x:y:_)) pit' p (Objects (x:y:_))
| showCoordText p = | showCoordText p =
position $ position
zip vtpi . zip vtpi
(pointToTextCoord # fc red <$> vtpi) # translate (r2 (0, 10)) $ (pointToTextCoord # fc red <$> vtpi)
# translate (r2 (0, 10))
| otherwise = mempty | otherwise = mempty
where where
paF = filterValidPT p x
pbF = filterValidPT p y
vtpi = intersectionPoints vtpi = intersectionPoints
. sortLexPolys . sortLexPolys
$ (sortLexPoly paF, sortLexPoly pbF) $ (sortLexPoly . filterValidPT p $ x,
sortLexPoly . filterValidPT p $ y)
pit' _ _ = mempty pit' _ _ = mempty
@ -147,13 +146,12 @@ convexHLs = Diag chl
where where
chl _ (Object []) = mempty chl _ (Object []) = mempty
chl p (Object vt) = chl p (Object vt) =
(strokeTrail . (strokeTrail
fromVertices . . fromVertices
flip (++) [head $ grahamCH vtf] . . flip (++) [head $ grahamCH vtf]
grahamCH $ . grahamCH
vtf) # $ vtf)
moveTo (head $ grahamCH vtf) # # moveTo (head $ grahamCH vtf) # lc red
lc red
where where
vtf = filterValidPT p vt vtf = filterValidPT p vt
chl _ _ = mempty chl _ _ = mempty
@ -182,7 +180,9 @@ squares = Diag f
mconcat mconcat
$ (\((xmin, xmax), (ymin, ymax)) -> rect (xmax - xmin) (ymax - ymin) $ (\((xmin, xmax), (ymin, ymax)) -> rect (xmax - xmin) (ymax - ymin)
# moveTo (p2 ((xmax + xmin) / 2, (ymax + ymin) / 2)) # lw ultraThin) # moveTo (p2 ((xmax + xmin) / 2, (ymax + ymin) / 2)) # lw ultraThin)
<$> (quadTreeSquares (xDimension p, yDimension p) . quadTree vtf $ (xDimension p, yDimension p)) <$> (quadTreeSquares (xDimension p, yDimension p)
. quadTree vtf
$ (xDimension p, yDimension p))
where where
vtf = filterValidPT p vt vtf = filterValidPT p vt
f _ _ = mempty f _ _ = mempty
@ -203,7 +203,7 @@ quadPathSquare = Diag f
f p (Object vt) = f p (Object vt) =
(\((xmin, xmax), (ymin, ymax)) -> rect (xmax - xmin) (ymax - ymin) (\((xmin, xmax), (ymin, ymax)) -> rect (xmax - xmin) (ymax - ymin)
# moveTo (p2 ((xmax + xmin) / 2,(ymax + ymin) / 2)) # lw thin # lc red) # moveTo (p2 ((xmax + xmin) / 2,(ymax + ymin) / 2)) # 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] -> Zipper PT -> Square
getSquare [] z = getSquareByZipper (xDimension p, yDimension p) z getSquare [] z = getSquareByZipper (xDimension p, yDimension p) z
@ -221,7 +221,7 @@ gifQuadPath = GifDiag f
f p col _ vt = f p col _ vt =
(\((xmin, xmax), (ymin, ymax)) -> rect (xmax - xmin) (ymax - ymin) (\((xmin, xmax), (ymin, ymax)) -> rect (xmax - xmin) (ymax - ymin)
# moveTo (p2 ((xmax + xmin) / 2,(ymax + ymin) / 2)) # lw thick # lc col) # moveTo (p2 ((xmax + xmin) / 2,(ymax + ymin) / 2)) # 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] -> Zipper PT -> [Square]
getSquares [] z = [getSquareByZipper (xDimension p, yDimension p) z] getSquares [] z = [getSquareByZipper (xDimension p, yDimension p) z]
@ -238,7 +238,11 @@ treePretty = Diag f
where where
f _ (Object []) = mempty f _ (Object []) = mempty
f p (Object vt) = f p (Object vt) =
prettyRoseTree (quadTreeToRoseTree . flip getCurQT (qt vt p, []) . stringToQuads . quadPath $ p) prettyRoseTree (quadTreeToRoseTree
. flip getCurQT (qt vt p, [])
. stringToQuads
. quadPath
$ p)
where where
getCurQT :: [Either Quad Orient] -> Zipper PT -> Zipper PT getCurQT :: [Either Quad Orient] -> Zipper PT -> Zipper PT
getCurQT [] z = z getCurQT [] z = z
@ -248,12 +252,10 @@ treePretty = Diag f
prettyRoseTree :: Tree String -> Diagram Cairo R2 prettyRoseTree :: Tree String -> Diagram Cairo R2
prettyRoseTree tree = prettyRoseTree tree =
renderTree (\n -> case head n of renderTree (\n -> case head n of
'*' -> '*' -> (text n # fontSizeL 5.0)
(text n # fontSizeL 5.0) <> rect 50.0 20.0 # fc red
<> rect 50.0 20.0 # fc red _ -> (text n # fontSizeL 5.0)
_ -> <> rect 50.0 20.0 # fc white)
(text n # fontSizeL 5.0)
<> rect 50.0 20.0 # fc white)
(~~) (~~)
(symmLayout' (with & slHSep .~ 60 & slVSep .~ 40) tree) (symmLayout' (with & slHSep .~ 60 & slVSep .~ 40) tree)
# scale 2 # alignT # bg white # scale 2 # alignT # bg white
@ -274,8 +276,8 @@ xAxis =
segments p _ = segments p _ =
hcat' (with & sep .~ squareSize p) hcat' (with & sep .~ squareSize p)
(replicate (floor . (/) (diagWidth p) $ squareSize p) (replicate (floor . (/) (diagWidth p) $ squareSize p)
(vrule 10)) # (vrule 10))
moveTo (p2 (diagXmin p, if diagYmin p <= 0 then 0 else diagYmin p)) # moveTo (p2 (diagXmin p, if diagYmin p <= 0 then 0 else diagYmin p))
labels p _ = labels p _ =
position $ position $
zip (mkPoint <$> xs) zip (mkPoint <$> xs)
@ -302,9 +304,9 @@ yAxis =
segments p _ = segments p _ =
vcat' (with & sep .~ squareSize p) vcat' (with & sep .~ squareSize p)
(replicate (floor . (/) (diagHeight p) $ squareSize p) (replicate (floor . (/) (diagHeight p) $ squareSize p)
(hrule 10)) # (hrule 10))
alignB # # alignB
moveTo (p2 (if diagXmin p <= 0 then 0 else diagXmin p, diagYmin p)) # moveTo (p2 (if diagXmin p <= 0 then 0 else diagXmin p, diagYmin p))
labels p _ = labels p _ =
position $ position $
zip (mkPoint <$> ys) zip (mkPoint <$> ys)
@ -323,8 +325,9 @@ whiteRectB :: Diag
whiteRectB = Diag rect' whiteRectB = Diag rect'
where where
rect' p _ = rect' p _ =
whiteRect (diagWidth p + (diagWidth p / 10)) (diagHeight p + (diagHeight p / 10)) # whiteRect (diagWidth p + (diagWidth p / 10))
moveTo (p2 (diagWidthOffset p, diagHeightOffset p)) (diagHeight p + (diagHeight p / 10))
# moveTo (p2 (diagWidthOffset p, diagHeightOffset p))
where where
@ -342,18 +345,15 @@ grid = Diag xGrid <> Diag yGrid
| haveGrid p = | haveGrid p =
hcat' (with & sep .~ squareSize p) hcat' (with & sep .~ squareSize p)
(replicate (floor . (/) (diagWidth p) $ squareSize p) (replicate (floor . (/) (diagWidth p) $ squareSize p)
(vrule $ diagHeight p)) # (vrule $ diagHeight p))
moveTo (p2 (diagXmin p, diagHeightOffset p)) # # moveTo (p2 (diagXmin p, diagHeightOffset p)) # lw ultraThin
lw ultraThin
| otherwise = mempty | otherwise = mempty
xGrid p _ xGrid p _
| haveGrid p = | haveGrid p =
vcat' (with & sep .~ squareSize p) vcat' (with & sep .~ squareSize p)
(replicate (floor . (/) (diagHeight p) $ squareSize p) (replicate (floor . (/) (diagHeight p) $ squareSize p)
(hrule $ diagWidth p)) # (hrule $ diagWidth p))
alignB # # alignB # moveTo (p2 (diagWidthOffset p, diagYmin p)) # lw ultraThin
moveTo (p2 (diagWidthOffset p, diagYmin p)) #
lw ultraThin
| otherwise = mempty | otherwise = mempty