Improve overall style and indenting
This commit is contained in:
parent
22482f7c49
commit
12da4040dc
@ -31,11 +31,10 @@ lowestYC (a:b:vs)
|
||||
grahamSort :: [PT] -- ^ the points to sort
|
||||
-> [PT] -- ^ sorted points
|
||||
grahamSort [] = []
|
||||
grahamSort xs = p0 : sortBy (\a b
|
||||
-> noEqual a b .
|
||||
compare
|
||||
(getAngle (pt2Vec a - pt2Vec p0) xv) $
|
||||
(getAngle (pt2Vec b - pt2Vec p0) xv))
|
||||
grahamSort xs =
|
||||
p0 : sortBy (\a b -> noEqual a b .
|
||||
compare (getAngle xv . (-) (pt2Vec a) $ pt2Vec p0) $
|
||||
(getAngle xv . (-) (pt2Vec b) $ pt2Vec p0))
|
||||
(removeItem p0 xs)
|
||||
where
|
||||
xv = unitX
|
||||
@ -51,14 +50,14 @@ grahamSort xs = p0 : sortBy (\a b
|
||||
where
|
||||
(ax, ay) = unp2 a
|
||||
(bx, by) = unp2 b
|
||||
noEqual _ _ LT = LT
|
||||
noEqual _ _ GT = GT
|
||||
noEqual _ _ x = x
|
||||
|
||||
|
||||
-- |Get all points on a convex hull by using the graham scan
|
||||
-- algorithm.
|
||||
grahamGetCH :: [PT] -> [PT]
|
||||
grahamGetCH vs = f . grahamSort $ vs
|
||||
grahamGetCH vs =
|
||||
f . grahamSort $ vs
|
||||
where
|
||||
f (x:y:z:xs)
|
||||
| ccw x y z = x : f (y:z:xs)
|
||||
@ -69,7 +68,8 @@ grahamGetCH vs = f . grahamSort $ vs
|
||||
-- |Compute all steps of the graham scan algorithm to allow
|
||||
-- visualizing it.
|
||||
grahamGetCHSteps :: [PT] -> [[PT]]
|
||||
grahamGetCHSteps vs = reverse . g $ (length vs - 2)
|
||||
grahamGetCHSteps vs =
|
||||
reverse . g $ (length vs - 2)
|
||||
where
|
||||
vs' = grahamSort vs
|
||||
g c
|
||||
|
90
Diagram.hs
90
Diagram.hs
@ -90,11 +90,10 @@ yuD = snd . dY
|
||||
coordPoints :: Diag
|
||||
coordPoints = Diag f
|
||||
where
|
||||
f p vt
|
||||
= position (zip (filter (inRange (dX p) (dY p)) $ vt)
|
||||
f p vt =
|
||||
position (zip (filter (inRange (dX p) (dY p)) $ vt)
|
||||
(repeat dot))
|
||||
where
|
||||
-- a dot itself is a diagram
|
||||
dot = (circle $ t p :: Diagram Cairo R2) # fc black
|
||||
|
||||
|
||||
@ -102,11 +101,10 @@ coordPoints = Diag f
|
||||
convexHullPoints :: Diag
|
||||
convexHullPoints = Diag f
|
||||
where
|
||||
f p vt
|
||||
= position (zip (filter (inRange (dX p) (dY p)) $ vtch)
|
||||
f p vt =
|
||||
position (zip (filter (inRange (dX p) (dY p)) $ vtch)
|
||||
(repeat dot))
|
||||
where
|
||||
-- a dot itself is a diagram
|
||||
dot = (circle $ t p :: Diagram Cairo R2) # fc red # lc red
|
||||
vtch = grahamGetCH vt
|
||||
|
||||
@ -117,13 +115,14 @@ convexHullLines :: Diag
|
||||
convexHullLines = Diag f
|
||||
where
|
||||
f _ [] = mempty
|
||||
f p vt
|
||||
= (strokeTrail .
|
||||
f p vt =
|
||||
(strokeTrail .
|
||||
fromVertices .
|
||||
flip (++) [head $ grahamGetCH vtf] .
|
||||
grahamGetCH $
|
||||
vtf
|
||||
) # moveTo (head $ grahamGetCH vtf) # lc red
|
||||
vtf) #
|
||||
moveTo (head $ grahamGetCH vtf) #
|
||||
lc red
|
||||
where
|
||||
vtf = filter (inRange (dX p) (dY p)) vt
|
||||
|
||||
@ -135,11 +134,12 @@ convexHullLinesInterval :: DiagProp -> [PT] -> [Diagram Cairo R2]
|
||||
convexHullLinesInterval p xs =
|
||||
fmap g (grahamGetCHSteps xs)
|
||||
where
|
||||
g vt
|
||||
= (strokeTrail .
|
||||
g vt =
|
||||
(strokeTrail .
|
||||
fromVertices $
|
||||
vtf
|
||||
) # moveTo (head vtf) # lc red
|
||||
vtf) #
|
||||
moveTo (head vtf) #
|
||||
lc red
|
||||
where
|
||||
vtf = filter (inRange (dX p) (dY p)) vt
|
||||
|
||||
@ -147,17 +147,20 @@ convexHullLinesInterval p xs =
|
||||
-- |Creates a Diagram that shows an XAxis which is bound
|
||||
-- by the dimensions given in xD from DiagProp.
|
||||
xAxis :: Diag
|
||||
xAxis = (Diag hRule) `mappend`
|
||||
xAxis =
|
||||
(Diag hRule) `mappend`
|
||||
(Diag segments) `mappend`
|
||||
(Diag labels)
|
||||
where
|
||||
hRule p _ = arrowAt (p2 (xlD p,0)) (r2 (xuD p, 0)) #
|
||||
hRule p _ =
|
||||
arrowAt (p2 (xlD p,0)) (r2 (xuD p, 0)) # moveTo (p2 (xlD p,0))
|
||||
segments p _ =
|
||||
hcat' (with & sep .~ 50)
|
||||
(take (floor . (/) (xuD p - xlD p) $ 50) . repeat $ (vrule 10)) #
|
||||
moveTo (p2 (xlD p,0))
|
||||
segments p _ = hcat' (with & sep .~ 50)
|
||||
(take (floor . (/) (xuD p - xlD p) $ 50) .
|
||||
repeat $ (vrule 10)) # moveTo (p2 (xlD p,0))
|
||||
labels p _ =
|
||||
position $ zip (mkPoint <$> xs)
|
||||
position $
|
||||
zip (mkPoint <$> xs)
|
||||
((\x -> (flip (<>) (square 1 # lw none) .
|
||||
text . show $ x) # scale 10) <$> xs)
|
||||
where
|
||||
@ -169,17 +172,22 @@ xAxis = (Diag hRule) `mappend`
|
||||
-- |Creates a Diagram that shows an YAxis which is bound
|
||||
-- by the dimensions given in yD from DiagProp.
|
||||
yAxis :: Diag
|
||||
yAxis = (Diag vRule) `mappend`
|
||||
yAxis =
|
||||
(Diag vRule) `mappend`
|
||||
(Diag segments) `mappend`
|
||||
(Diag labels)
|
||||
where
|
||||
vRule p _ = arrowAt (p2 (0, ylD p)) (r2 (0, yuD p)) #
|
||||
moveTo (p2 (0, ylD p))
|
||||
segments p _ = vcat' (with & sep .~ 50)
|
||||
vRule p _ =
|
||||
arrowAt (p2 (0, ylD p)) (r2 (0, yuD p)) # moveTo (p2 (0, ylD p))
|
||||
segments p _ =
|
||||
vcat' (with & sep .~ 50)
|
||||
(take (floor . (/) (yuD p - ylD p) $ 50) .
|
||||
repeat $ (hrule 10)) # alignB # moveTo (p2 (0, (ylD p)))
|
||||
repeat $ (hrule 10)) #
|
||||
alignB #
|
||||
moveTo (p2 (0, (ylD p)))
|
||||
labels p _ =
|
||||
position $ zip (mkPoint <$> ys)
|
||||
position $
|
||||
zip (mkPoint <$> ys)
|
||||
((\x -> (flip (<>) (square 1 # lw none) .
|
||||
text . show $ x) # scale 10) <$> ys)
|
||||
where
|
||||
@ -202,12 +210,14 @@ whiteRectB = Diag f
|
||||
-- |Create the Diagram from the points.
|
||||
diag :: DiagProp -> [PT] -> Diagram Cairo R2
|
||||
diag p = case alg p of
|
||||
0 -> mkDiag
|
||||
0 ->
|
||||
mkDiag
|
||||
(mconcat [coordPoints, xAxis, yAxis,
|
||||
(if gd p then grid else mempty), whiteRectB])
|
||||
p
|
||||
1 -> mkDiag
|
||||
(mconcat $
|
||||
1 ->
|
||||
mkDiag
|
||||
(mconcat
|
||||
[convexHullPoints, convexHullLines, coordPoints,
|
||||
xAxis, yAxis, (if gd p then grid else mempty), whiteRectB])
|
||||
p
|
||||
@ -217,22 +227,25 @@ diag p = case alg p of
|
||||
-- |Create the Diagram from a String which is supposed to be the contents
|
||||
-- of an obj file.
|
||||
diagS :: DiagProp -> String -> Diagram Cairo R2
|
||||
diagS p mesh
|
||||
= (diag p .
|
||||
diagS p mesh =
|
||||
(diag p .
|
||||
meshToArr $
|
||||
mesh) # bg white
|
||||
mesh) #
|
||||
bg white
|
||||
|
||||
|
||||
-- |Return a list of tuples used by 'gifMain' to generate an animated gif.
|
||||
gifDiag :: DiagProp -> [PT] -> [(Diagram Cairo R2, GifDelay)]
|
||||
gifDiag p xs = fmap (\x -> (x, 100)) .
|
||||
gifDiag p xs =
|
||||
fmap (\x -> (x, 100)) .
|
||||
fmap (\x -> x <> g) .
|
||||
flip (++)
|
||||
[mkDiag (convexHullLines `mappend`
|
||||
convexHullPoints) p xs] $
|
||||
(convexHullLinesInterval p xs)
|
||||
where
|
||||
g = mconcat .
|
||||
g =
|
||||
mconcat .
|
||||
fmap (\x -> mkDiag x p xs) $
|
||||
[coordPoints,
|
||||
xAxis,
|
||||
@ -243,8 +256,7 @@ gifDiag p xs = fmap (\x -> (x, 100)) .
|
||||
-- |Same as gifDiag, except that it takes a string containing the
|
||||
-- mesh file content instead of the the points.
|
||||
gifDiagS :: DiagProp -> String -> [(Diagram Cairo R2, GifDelay)]
|
||||
gifDiagS p = gifDiag p .
|
||||
meshToArr
|
||||
gifDiagS p = gifDiag p . meshToArr
|
||||
|
||||
|
||||
-- |Create a white rectangle with the given width and height.
|
||||
@ -256,12 +268,14 @@ whiteRect x y = rect x y # lwG 0.00 # bg white
|
||||
grid :: Diag
|
||||
grid = Diag f `mappend` Diag g
|
||||
where
|
||||
f p _ = hcat' (with & sep .~ 50)
|
||||
f p _ =
|
||||
hcat' (with & sep .~ 50)
|
||||
(take (floor . (/) (xuD p - xlD p) $ 50) .
|
||||
repeat $ (vrule $ xuD p - xlD p)) #
|
||||
moveTo (p2 (xlD p, (yuD p - ylD p) / 2)) #
|
||||
lw ultraThin
|
||||
g p _ = vcat' (with & sep .~ 50)
|
||||
g p _ =
|
||||
vcat' (with & sep .~ 50)
|
||||
(take (floor . (/) (yuD p - ylD p) $ 50) .
|
||||
repeat $ (hrule $ yuD p - ylD p)) #
|
||||
alignB #
|
||||
|
32
Gtk.hs
32
Gtk.hs
@ -77,7 +77,8 @@ makeMyGladeGUI = do
|
||||
cB' <- xmlGetWidget xml castToComboBox "comboalgo"
|
||||
gC' <- xmlGetWidget xml castToCheckButton "gridcheckbutton"
|
||||
|
||||
return $ MkMyGUI win' dB' sB' qB' fB' da' hs' xl' xu' yl' yu' aD' cB' gC'
|
||||
return $ MkMyGUI win' dB' sB' qB' fB' da' hs'
|
||||
xl' xu' yl' yu' aD' cB' gC'
|
||||
|
||||
|
||||
gifCLI :: FilePath -> IO ()
|
||||
@ -206,17 +207,22 @@ drawDiag' fp mygui =
|
||||
(daW, daH) <- widgetGetSize (da mygui)
|
||||
gd' <- toggleButtonGetActive (gC mygui)
|
||||
|
||||
let xD = (,) <$> readMaybe xlD' <*> readMaybe xuD' :: Maybe (Double,
|
||||
Double)
|
||||
yD = (,) <$> readMaybe ylD' <*> readMaybe yuD' :: Maybe (Double,
|
||||
Double)
|
||||
let
|
||||
xD = (,) <$>
|
||||
readMaybe xlD' <*>
|
||||
readMaybe xuD' :: Maybe (Double, Double)
|
||||
yD = (,) <$>
|
||||
readMaybe ylD' <*>
|
||||
readMaybe yuD' :: Maybe (Double, Double)
|
||||
|
||||
case (xD, yD) of
|
||||
(Just xD', Just yD') -> do
|
||||
let (_, r) = renderDia Cairo
|
||||
(CairoOptions ""
|
||||
(Dims (fromIntegral daW) (fromIntegral daH))
|
||||
SVG False)
|
||||
(diagS (def{t = scaleVal,
|
||||
(diagS (def{
|
||||
t = scaleVal,
|
||||
dX = xD',
|
||||
dY = yD',
|
||||
alg = alg',
|
||||
@ -247,15 +253,19 @@ saveDiag' fp mygui =
|
||||
(daW, daH) <- widgetGetSize (da mygui)
|
||||
gd' <- toggleButtonGetActive (gC mygui)
|
||||
|
||||
let xD = (,) <$> readMaybe xlD' <*> readMaybe xuD' :: Maybe (Double,
|
||||
Double)
|
||||
yD = (,) <$> readMaybe ylD' <*> readMaybe yuD' :: Maybe (Double,
|
||||
Double)
|
||||
let
|
||||
xD = (,) <$>
|
||||
readMaybe xlD' <*>
|
||||
readMaybe xuD' :: Maybe (Double, Double)
|
||||
yD = (,) <$>
|
||||
readMaybe ylD' <*>
|
||||
readMaybe yuD' :: Maybe (Double, Double)
|
||||
case (xD, yD) of
|
||||
(Just xD', Just yD') -> do
|
||||
renderCairo "out.svg"
|
||||
(Dims (fromIntegral daW) (fromIntegral daH))
|
||||
(diagS (def{t = scaleVal,
|
||||
(diagS (def{
|
||||
t = scaleVal,
|
||||
dX = xD',
|
||||
dY = yD',
|
||||
alg = alg',
|
||||
|
@ -14,15 +14,15 @@ inRange :: Coord -- ^ X dimension
|
||||
-> Coord -- ^ Y dimension
|
||||
-> PT -- ^ Coordinates
|
||||
-> Bool -- ^ result
|
||||
inRange (xlD, xuD) (ylD, yuD) p
|
||||
= x <= xuD && x >= xlD && y <= yuD && y >= ylD
|
||||
inRange (xlD, xuD) (ylD, yuD) p = x <= xuD && x >= xlD && y <= yuD && y >= ylD
|
||||
where
|
||||
(x, y) = unp2 p
|
||||
|
||||
|
||||
-- |Get the angle between two vectors.
|
||||
getAngle :: Vec -> Vec -> Double
|
||||
getAngle a b = acos .
|
||||
getAngle a b =
|
||||
acos .
|
||||
flip (/) (vecLength a * vecLength b) .
|
||||
scalarProd a $
|
||||
b
|
||||
@ -65,7 +65,8 @@ vp2 a b = (pt2Vec b) - (pt2Vec a)
|
||||
-- connecting a-b-c. This is done by computing the determinant and
|
||||
-- checking the algebraic sign.
|
||||
ccw :: PT -> PT -> PT -> Bool
|
||||
ccw a b c = (bx - ax) *
|
||||
ccw a b c =
|
||||
(bx - ax) *
|
||||
(cy - ay) -
|
||||
(by - ay) *
|
||||
(cx - ax) >= 0
|
||||
|
@ -13,14 +13,17 @@ module Parser.Core (Parser,
|
||||
import Control.Applicative
|
||||
import Data.Char
|
||||
|
||||
|
||||
-- |The parser type. It allows us to create specific parsers,
|
||||
-- combine them and run them via 'runParser' to get a result.
|
||||
newtype Parser a = MkParser { runParser :: String -> Maybe (a, String) }
|
||||
|
||||
|
||||
-- |Functor instance.
|
||||
instance Functor Parser where
|
||||
fmap = inParser . fmap . fmap . first
|
||||
|
||||
|
||||
-- |Applicative functor instance.
|
||||
instance Applicative Parser where
|
||||
pure a = MkParser (\s -> Just (a, s))
|
||||
@ -29,11 +32,13 @@ instance Applicative Parser where
|
||||
Nothing -> Nothing
|
||||
Just (f,x) -> runParser (f <$> xp) x
|
||||
|
||||
|
||||
-- |Alternative functor instance.
|
||||
instance Alternative Parser where
|
||||
empty = MkParser (const Nothing)
|
||||
MkParser p1 <|> MkParser p2 = MkParser $ liftA2 (<|>) p1 p2
|
||||
|
||||
|
||||
inParser :: ((String -> Maybe (a1, String))
|
||||
-> String
|
||||
-> Maybe (a, String))
|
||||
@ -41,9 +46,11 @@ inParser :: ((String -> Maybe (a1, String))
|
||||
-> Parser a
|
||||
inParser f p = MkParser . f . runParser $ p
|
||||
|
||||
|
||||
first :: (a -> b) -> (a,c) -> (b,c)
|
||||
first f (x,y) = (f x, y)
|
||||
|
||||
|
||||
-- |Creates a Parser that parses a Char depending on a given condition.
|
||||
satisfy :: (Char -> Bool) -- ^ condition
|
||||
-> Parser Char -- ^ created Parser
|
||||
@ -54,10 +61,12 @@ satisfy p = MkParser f
|
||||
| p x = Just (x, xs)
|
||||
| otherwise = Nothing
|
||||
|
||||
|
||||
-- |Creates a Parser that accepts a given Char.
|
||||
char :: Char -> Parser Char
|
||||
char c = satisfy (== c)
|
||||
|
||||
|
||||
-- |Creates a Parser that accepts positive integers.
|
||||
posInt :: Parser Integer
|
||||
posInt = MkParser f
|
||||
@ -67,10 +76,12 @@ posInt = MkParser f
|
||||
| otherwise = Just (read ns, rest)
|
||||
where (ns, rest) = span isDigit xs
|
||||
|
||||
|
||||
-- |Creates a Parser that accepts positive doubles.
|
||||
-- Both 131.31 and 132 are valid.
|
||||
posDouble :: Parser Double
|
||||
posDouble = (read <$>) $
|
||||
posDouble =
|
||||
(read <$>) $
|
||||
(\x y z -> x ++ [y] ++ z) <$>
|
||||
MkParser f <*>
|
||||
char '.' <*>
|
||||
@ -82,14 +93,17 @@ posDouble = (read <$>) $
|
||||
| otherwise = Just (ns, rest)
|
||||
where (ns, rest) = span isDigit xs
|
||||
|
||||
|
||||
-- |Convert a given Parser to a Parser that accepts zero or more occurences.
|
||||
zeroOrMore :: Parser a -> Parser [a]
|
||||
zeroOrMore p = oneOrMore p <|> pure []
|
||||
|
||||
|
||||
-- |Convert a given Parser to a Parser that accepts one or more occurences.
|
||||
oneOrMore :: Parser a -> Parser [a]
|
||||
oneOrMore p = (:) <$> p <*> zeroOrMore p
|
||||
|
||||
|
||||
-- |Creates a Parser that accepts spaces.
|
||||
spaces :: Parser String
|
||||
spaces = zeroOrMore (satisfy isSpace)
|
||||
|
@ -12,7 +12,8 @@ import Parser.Core
|
||||
-- an array of float tuples.
|
||||
meshToArr :: String -- ^ the string to convert
|
||||
-> [PT] -- ^ the resulting vertice table
|
||||
meshToArr xs = fmap (p2) .
|
||||
meshToArr xs =
|
||||
fmap (p2) .
|
||||
fmap (\(Just (x, _)) -> x) .
|
||||
filter (/= Nothing) .
|
||||
fmap (runParser parseVertice) .
|
||||
@ -22,6 +23,7 @@ meshToArr xs = fmap (p2) .
|
||||
|
||||
-- | Creates a Parser that accepts a single vertice, such as 'v 1.0 2.0'.
|
||||
parseVertice :: Parser (Double, Double)
|
||||
parseVertice = (,) <$>
|
||||
parseVertice =
|
||||
(,) <$>
|
||||
(char 'v' *> spaces *> posDouble) <*>
|
||||
(spaces *> posDouble)
|
||||
|
Loading…
Reference in New Issue
Block a user