Improve overall style and indenting

This commit is contained in:
hasufell 2014-10-10 00:19:05 +02:00
parent 22482f7c49
commit 12da4040dc
No known key found for this signature in database
GPG Key ID: 220CD1C5BDEED020
9 changed files with 237 additions and 195 deletions

View File

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

View File

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

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

View File

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

View File

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

View File

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

View File

@ -7,7 +7,8 @@ module Util where
splitBy :: (a -> Bool) -- ^ condition
-> [a] -- ^ array to split
-> [[a]] -- ^ splitted array
splitBy f s = case dropWhile f s of
splitBy f s =
case dropWhile f s of
[] -> []
s' -> w : splitBy f s''
where (w, s'') = break f s'