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

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

54
Algorithms/ConvexHull.hs
View File

@ -21,9 +21,9 @@ lowestYC (a:b:vs)
| ay == by &&
ax > bx = lowestYC (b:vs)
| otherwise = lowestYC (a:vs)
where
(ax, ay) = unp2 a
(bx, by) = unp2 b
where
(ax, ay) = unp2 a
(bx, by) = unp2 b
-- |Sort the points in increasing order of their degree between
@ -31,34 +31,33 @@ 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))
(removeItem p0 xs)
where
xv = unitX
p0 = lowestYC xs
-- Have to account for corner cases when points are in
-- a straight line or have the same y coordinates. Eq is
-- not an option anyhow.
noEqual :: PT -> PT -> Ordering -> Ordering
noEqual a b EQ
| ay == by &&
ax < bx = LT
| otherwise = GT
where
(ax, ay) = unp2 a
(bx, by) = unp2 b
noEqual _ _ LT = LT
noEqual _ _ GT = GT
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
p0 = lowestYC xs
-- Have to account for corner cases when points are in
-- a straight line or have the same y coordinates. Eq is
-- not an option anyhow.
noEqual :: PT -> PT -> Ordering -> Ordering
noEqual a b EQ
| ay == by &&
ax < bx = LT
| otherwise = GT
where
(ax, ay) = unp2 a
(bx, by) = unp2 b
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

2
Class/Defaults.hs
View File

@ -5,4 +5,4 @@ module Class.Defaults where
-- |Used to create a common interface for default settings of data types.
class Def a where
def :: a
def :: a

200
Diagram.hs
View File

@ -48,7 +48,7 @@ data DiagProp = MkProp {
instance Def DiagProp where
def = defaultProp
def = defaultProp
instance Monoid Diag where
@ -90,25 +90,23 @@ yuD = snd . dY
coordPoints :: Diag
coordPoints = Diag f
where
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
f p vt =
position (zip (filter (inRange (dX p) (dY p)) $ vt)
(repeat dot))
where
dot = (circle $ t p :: Diagram Cairo R2) # fc black
-- |Create a diagram which shows the points of the convex hull.
convexHullPoints :: Diag
convexHullPoints = Diag f
where
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
f p vt =
position (zip (filter (inRange (dX p) (dY p)) $ vtch)
(repeat dot))
where
dot = (circle $ t p :: Diagram Cairo R2) # fc red # lc red
vtch = grahamGetCH vt
-- |Create a diagram which shows the lines along the convex hull
@ -117,13 +115,14 @@ convexHullLines :: Diag
convexHullLines = Diag f
where
f _ [] = mempty
f p vt
= (strokeTrail .
fromVertices .
flip (++) [head $ grahamGetCH vtf] .
grahamGetCH $
vtf
) # moveTo (head $ grahamGetCH vtf) # lc red
f p vt =
(strokeTrail .
fromVertices .
flip (++) [head $ grahamGetCH vtf] .
grahamGetCH $
vtf) #
moveTo (head $ grahamGetCH vtf) #
lc red
where
vtf = filter (inRange (dX p) (dY p)) vt
@ -134,54 +133,63 @@ convexHullLines = Diag f
convexHullLinesInterval :: DiagProp -> [PT] -> [Diagram Cairo R2]
convexHullLinesInterval p xs =
fmap g (grahamGetCHSteps xs)
where
g vt
= (strokeTrail .
fromVertices $
vtf
) # moveTo (head vtf) # lc red
where
vtf = filter (inRange (dX p) (dY p)) vt
where
g vt =
(strokeTrail .
fromVertices $
vtf) #
moveTo (head vtf) #
lc red
where
vtf = filter (inRange (dX p) (dY p)) vt
-- |Creates a Diagram that shows an XAxis which is bound
-- by the dimensions given in xD from DiagProp.
xAxis :: Diag
xAxis = (Diag hRule) `mappend`
(Diag segments) `mappend`
(Diag labels)
xAxis =
(Diag hRule) `mappend`
(Diag segments) `mappend`
(Diag labels)
where
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))
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))
labels p _ =
position $ zip (mkPoint <$> xs)
((\x -> (flip (<>) (square 1 # lw none) .
text . show $ x) # scale 10) <$> xs)
where
xs :: [Int]
xs = take (floor . (/) (xuD p - xlD p) $ 50) (iterate (+50) 0)
mkPoint x = p2 (fromIntegral x, -15)
position $
zip (mkPoint <$> xs)
((\x -> (flip (<>) (square 1 # lw none) .
text . show $ x) # scale 10) <$> xs)
where
xs :: [Int]
xs = take (floor . (/) (xuD p - xlD p) $ 50) (iterate (+50) 0)
mkPoint x = p2 (fromIntegral x, -15)
-- |Creates a Diagram that shows an YAxis which is bound
-- by the dimensions given in yD from DiagProp.
yAxis :: Diag
yAxis = (Diag vRule) `mappend`
(Diag segments) `mappend`
(Diag labels)
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)
(take (floor . (/) (yuD p - ylD p) $ 50) .
repeat $ (hrule 10)) # alignB # moveTo (p2 (0, (ylD p)))
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)))
labels p _ =
position $ zip (mkPoint <$> ys)
((\x -> (flip (<>) (square 1 # lw none) .
text . show $ x) # scale 10) <$> ys)
position $
zip (mkPoint <$> ys)
((\x -> (flip (<>) (square 1 # lw none) .
text . show $ x) # scale 10) <$> ys)
where
ys :: [Int]
ys = take (floor . (/) (yuD p - ylD p) $ 50) (iterate (+50) 0)
@ -202,49 +210,53 @@ whiteRectB = Diag f
-- |Create the Diagram from the points.
diag :: DiagProp -> [PT] -> Diagram Cairo R2
diag p = case alg p of
0 -> mkDiag
(mconcat [coordPoints, xAxis, yAxis,
(if gd p then grid else mempty), whiteRectB])
p
1 -> mkDiag
(mconcat $
[convexHullPoints, convexHullLines, coordPoints,
xAxis, yAxis, (if gd p then grid else mempty), whiteRectB])
p
0 ->
mkDiag
(mconcat [coordPoints, xAxis, yAxis,
(if gd p then grid else mempty), whiteRectB])
p
1 ->
mkDiag
(mconcat
[convexHullPoints, convexHullLines, coordPoints,
xAxis, yAxis, (if gd p then grid else mempty), whiteRectB])
p
_ -> mempty
-- |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)) .
fmap (\x -> x <> g) .
flip (++)
[mkDiag (convexHullLines `mappend`
convexHullPoints) p xs] $
(convexHullLinesInterval p xs)
where
g = mconcat .
fmap (\x -> mkDiag x p xs) $
[coordPoints,
xAxis,
yAxis,
whiteRectB]
gifDiag p xs =
fmap (\x -> (x, 100)) .
fmap (\x -> x <> g) .
flip (++)
[mkDiag (convexHullLines `mappend`
convexHullPoints) p xs] $
(convexHullLinesInterval p xs)
where
g =
mconcat .
fmap (\x -> mkDiag x p xs) $
[coordPoints,
xAxis,
yAxis,
whiteRectB]
-- |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,14 +268,16 @@ 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)
(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)
(take (floor . (/) (yuD p - ylD p) $ 50) .
repeat $ (hrule $ yuD p - ylD p)) #
alignB #
moveTo (p2 ((xuD p - xlD p) / 2, ylD p)) #
lw ultraThin
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)
(take (floor . (/) (yuD p - ylD p) $ 50) .
repeat $ (hrule $ yuD p - ylD p)) #
alignB #
moveTo (p2 ((xuD p - xlD p) / 2, ylD p)) #
lw ultraThin

82
Gtk.hs
View File

@ -77,12 +77,13 @@ 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 ()
gifCLI startFile = do
mesh <- readFile "UB1_sonderfaelle.obj"
mesh <- readFile "UB1_sonderfaelle.obj"
gifMain (gifDiagS def mesh)
@ -118,21 +119,21 @@ makeGUI startFile = do
-- hotkeys
_ <- win mygui `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"q" <- eventKeyName
liftIO mainQuit
[Control] <- eventModifier
"q" <- eventKeyName
liftIO mainQuit
_ <- win mygui `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"s" <- eventKeyName
liftIO $ onClickedSaveButton mygui
[Control] <- eventModifier
"s" <- eventKeyName
liftIO $ onClickedSaveButton mygui
_ <- win mygui `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"d" <- eventKeyName
liftIO $ onClickedDrawButton mygui
[Control] <- eventModifier
"d" <- eventKeyName
liftIO $ onClickedDrawButton mygui
_ <- win mygui `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"a" <- eventKeyName
liftIO $ widgetShowAll (aD mygui)
[Control] <- eventModifier
"a" <- eventKeyName
liftIO $ widgetShowAll (aD mygui)
-- draw widgets and start main loop
widgetShowAll (win mygui)
@ -206,22 +207,27 @@ 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,
dX = xD',
dY = yD',
alg = alg',
gd = gd'})
mesh)
(CairoOptions ""
(Dims (fromIntegral daW) (fromIntegral daH))
SVG False)
(diagS (def{
t = scaleVal,
dX = xD',
dY = yD',
alg = alg',
gd = gd'})
mesh)
renderWithDrawable dw r
return 0
_ -> return 1
@ -247,19 +253,23 @@ 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,
dX = xD',
dY = yD',
alg = alg',
gd = gd'})
(diagS (def{
t = scaleVal,
dX = xD',
dY = yD',
alg = alg',
gd = gd'})
mesh)
return 0
_ -> return 1

25
LinearAlgebra/Vector.hs
View File

@ -14,18 +14,18 @@ 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
where
(x, y) = unp2 p
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 .
flip (/) (vecLength a * vecLength b) .
scalarProd a $
b
getAngle a b =
acos .
flip (/) (vecLength a * vecLength b) .
scalarProd a $
b
-- |Get the length of a vector.
@ -65,10 +65,11 @@ 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) *
(cy - ay) -
(by - ay) *
(cx - ax) >= 0
ccw a b c =
(bx - ax) *
(cy - ay) -
(by - ay) *
(cx - ax) >= 0
where
(ax, ay) = unp2 a
(bx, by) = unp2 b

10
OS/FileExt.hs
View File

@ -13,11 +13,11 @@ cmpExt checkExt = (==) checkExt . getExt
-- |Get the extension of a file.
getExt :: FilePath -> String
getExt fp
| hasExt fp = last .
splitBy (== '.') .
last .
splitBy (== '/') $
fp
| hasExt fp = last .
splitBy (== '.') .
last .
splitBy (== '/') $
fp
| otherwise = ""

30
Parser/Core.hs
View File

@ -13,27 +13,32 @@ 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))
pure a = MkParser (\s -> Just (a, s))
(MkParser fp) <*> xp = MkParser $ \s ->
case fp s of
Nothing -> Nothing
Just (f,x) -> runParser (f <$> xp) x
-- |Alternative functor instance.
instance Alternative Parser where
empty = MkParser (const Nothing)
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,29 +76,34 @@ 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 <$>) $
(\x y z -> x ++ [y] ++ z) <$>
MkParser f <*>
char '.' <*>
MkParser f <|>
MkParser f
posDouble =
(read <$>) $
(\x y z -> x ++ [y] ++ z) <$>
MkParser f <*>
char '.' <*>
MkParser f <|>
MkParser f
where
f xs
| null ns = Nothing
| 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)

20
Parser/Meshparser.hs
View File

@ -12,16 +12,18 @@ import Parser.Core
-- an array of float tuples.
meshToArr :: String -- ^ the string to convert
-> [PT] -- ^ the resulting vertice table
meshToArr xs = fmap (p2) .
fmap (\(Just (x, _)) -> x) .
filter (/= Nothing) .
fmap (runParser parseVertice) .
lines $
xs
meshToArr xs =
fmap (p2) .
fmap (\(Just (x, _)) -> x) .
filter (/= Nothing) .
fmap (runParser parseVertice) .
lines $
xs
-- | Creates a Parser that accepts a single vertice, such as 'v 1.0 2.0'.
parseVertice :: Parser (Double, Double)
parseVertice = (,) <$>
(char 'v' *> spaces *> posDouble) <*>
(spaces *> posDouble)
parseVertice =
(,) <$>
(char 'v' *> spaces *> posDouble) <*>
(spaces *> posDouble)

9
Util.hs
View File

@ -7,10 +7,11 @@ module Util where
splitBy :: (a -> Bool) -- ^ condition
-> [a] -- ^ array to split
-> [[a]] -- ^ splitted array
splitBy f s = case dropWhile f s of
[] -> []
s' -> w : splitBy f s''
where (w, s'') = break f s'
splitBy f s =
case dropWhile f s of
[] -> []
s' -> w : splitBy f s''
where (w, s'') = break f s'
-- |Remove a given item from a list.