DIAG: filter valid points earlier

This saves us some code duplication.
This commit is contained in:
hasufell 2014-11-16 16:44:26 +01:00
parent 8c1d54d97a
commit 562fdbe26f
No known key found for this signature in database
GPG Key ID: 220CD1C5BDEED020
3 changed files with 29 additions and 29 deletions

View File

@ -34,4 +34,4 @@ gifDiag p xs =
-- |Same as gifDiag, except that it takes a string containing the -- |Same as gifDiag, except that it takes a string containing the
-- mesh file content instead of the the points. -- mesh file content instead of the the points.
gifDiagS :: DiagProp -> MeshString -> [(Diagram Cairo R2, GifDelay)] gifDiagS :: DiagProp -> MeshString -> [(Diagram Cairo R2, GifDelay)]
gifDiagS p = gifDiag p . meshToArr gifDiagS p = gifDiag p . filterValidPT p . meshToArr

View File

@ -38,13 +38,21 @@ diag p objs@(Objects _)
-- of an obj file. -- of an obj file.
diagS :: DiagProp -> MeshString -> Diagram Cairo R2 diagS :: DiagProp -> MeshString -> Diagram Cairo R2
diagS p mesh diagS p mesh
| algo p == 2 || algo p == 3 = diag p. Objects . facesToArr $ mesh | algo p == 2 || algo p == 3 =
| otherwise = (diag p . Object . meshToArr $ mesh) # bg white diag p
. Objects
. fmap (filterValidPT p)
. facesToArr
$ mesh
| otherwise = (diag p . Object . filterValidPT p . meshToArr $ mesh) # bg white
-- |Create the tree diagram from a String which is supposed to be the contents -- |Create the tree diagram from a String which is supposed to be the contents
-- of an obj file. -- of an obj file.
diagTreeS :: DiagProp -> MeshString -> Diagram Cairo R2 diagTreeS :: DiagProp -> MeshString -> Diagram Cairo R2
diagTreeS p mesh diagTreeS p mesh
| algo p == 4 = mkDiag treePretty p (Object . meshToArr $mesh) | algo p == 4 = mkDiag treePretty p (Object
. filterValidPT p
. meshToArr
$ mesh)
| otherwise = mempty | otherwise = mempty

View File

@ -26,8 +26,7 @@ coordPoints = Diag cp
cp p (Objects vts) = drawP (concat vts) p cp p (Objects vts) = drawP (concat vts) p
drawP [] _ = mempty drawP [] _ = mempty
drawP vt p = drawP vt p =
position (zip (filterValidPT p vt) position (zip vt (repeat dot))
(repeat dot))
where where
dot = (circle $ dotSize p :: Diagram Cairo R2) # fc black dot = (circle $ dotSize p :: Diagram Cairo R2) # fc black
@ -54,11 +53,9 @@ coordPointsText = Diag cpt
drawT vt p drawT vt p
| showCoordText p = | showCoordText p =
position position
$ zip vtf (pointToTextCoord <$> vtf) $ zip vt (pointToTextCoord <$> vt)
# translate (r2 (0, 10)) # translate (r2 (0, 10))
| otherwise = mempty | otherwise = mempty
where
vtf = filterValidPT p vt
-- |Draw the lines of the polygon. -- |Draw the lines of the polygon.
@ -66,15 +63,14 @@ polyLines :: Diag
polyLines = Diag pp polyLines = Diag pp
where where
pp _ (Objects []) = mempty pp _ (Objects []) = mempty
pp p (Objects (x:y:_)) = pp _ (Objects (x:y:_)) =
strokePoly x <> strokePoly y strokePoly x <> strokePoly y
where where
strokePoly x' = strokePoly x' =
(strokeTrail (strokeTrail
. fromVertices . fromVertices
$ vtf x' ++ [head . vtf $ x']) $ x' ++ [head x'])
# moveTo (head x') # lc black # moveTo (head x') # lc black
vtf = filterValidPT p
pp _ _ = mempty pp _ _ = mempty
@ -87,8 +83,8 @@ polyIntersection = Diag pi'
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 . filterValidPT p $ x, $ (sortLexPoly x,
sortLexPoly . filterValidPT p $ y) sortLexPoly y)
pi' _ _ = mempty pi' _ _ = mempty
@ -106,8 +102,8 @@ polyIntersectionText = Diag pit'
where where
vtpi = intersectionPoints vtpi = intersectionPoints
. sortLexPolys . sortLexPolys
$ (sortLexPoly . filterValidPT p $ x, $ (sortLexPoly x,
sortLexPoly . filterValidPT p $ y) sortLexPoly y)
pit' _ _ = mempty pit' _ _ = mempty
@ -120,7 +116,7 @@ convexHP = Diag chp
(repeat dot)) (repeat dot))
where where
dot = (circle $ dotSize p :: Diagram Cairo R2) # fc red # lc red dot = (circle $ dotSize p :: Diagram Cairo R2) # fc red # lc red
vtch = grahamCH $ filterValidPT p vt vtch = grahamCH vt
chp _ _ = mempty chp _ _ = mempty
@ -135,7 +131,7 @@ convexHPText = Diag chpt
(pointToTextCoord <$> vtchf) # translate (r2 (0, 10)) (pointToTextCoord <$> vtchf) # translate (r2 (0, 10))
| otherwise = mempty | otherwise = mempty
where where
vtchf = grahamCH . filterValidPT p $ vt vtchf = grahamCH vt
chpt _ _ = mempty chpt _ _ = mempty
@ -145,15 +141,13 @@ convexHLs :: Diag
convexHLs = Diag chl convexHLs = Diag chl
where where
chl _ (Object []) = mempty chl _ (Object []) = mempty
chl p (Object vt) = chl _ (Object vt) =
(strokeTrail (strokeTrail
. fromVertices . fromVertices
. flip (++) [head $ grahamCH vtf] . flip (++) [head $ grahamCH vt]
. grahamCH . grahamCH
$ vtf) $ vt)
# moveTo (head $ grahamCH vtf) # lc red # moveTo (head $ grahamCH vt) # lc red
where
vtf = filterValidPT p vt
chl _ _ = mempty chl _ _ = mempty
@ -164,7 +158,7 @@ convexHStepsLs :: Diag
convexHStepsLs = GifDiag chs convexHStepsLs = GifDiag chs
where where
chs p col f vt = chs p col f vt =
fmap mkChDiag (f . filterValidPT p $ vt) fmap mkChDiag (f vt)
where where
mkChDiag vt' = mkChDiag vt' =
(strokeTrail . fromVertices $ vt') # moveTo (head vt') # lc col (strokeTrail . fromVertices $ vt') # moveTo (head vt') # lc col
@ -181,17 +175,15 @@ squares = Diag f
$ (\((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) <$> (quadTreeSquares (xDimension p, yDimension p)
. quadTree vtf . quadTree vt
$ (xDimension p, yDimension p)) $ (xDimension p, yDimension p))
where
vtf = filterValidPT p vt
f _ _ = mempty f _ _ = mempty
-- |Get the quad tree corresponding to the given points and diagram properties. -- |Get the quad tree corresponding to the given points and diagram properties.
qt :: [PT] -> DiagProp -> QuadTree PT qt :: [PT] -> DiagProp -> QuadTree PT
qt vt p = quadTree (filterValidPT p vt) (xDimension p, yDimension p) qt vt p = quadTree vt (xDimension p, yDimension p)
-- |Create a diagram that shows a single square of the RangeSearch algorithm -- |Create a diagram that shows a single square of the RangeSearch algorithm