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 && | ay == by &&
ax > bx = lowestYC (b:vs) ax > bx = lowestYC (b:vs)
| otherwise = lowestYC (a:vs) | otherwise = lowestYC (a:vs)
where where
(ax, ay) = unp2 a (ax, ay) = unp2 a
(bx, by) = unp2 b (bx, by) = unp2 b
-- |Sort the points in increasing order of their degree between -- |Sort the points in increasing order of their degree between
@ -31,34 +31,33 @@ lowestYC (a:b:vs)
grahamSort :: [PT] -- ^ the points to sort grahamSort :: [PT] -- ^ the points to sort
-> [PT] -- ^ sorted points -> [PT] -- ^ sorted points
grahamSort [] = [] grahamSort [] = []
grahamSort xs = p0 : sortBy (\a b grahamSort xs =
-> noEqual a b . p0 : sortBy (\a b -> noEqual a b .
compare compare (getAngle xv . (-) (pt2Vec a) $ pt2Vec p0) $
(getAngle (pt2Vec a - pt2Vec p0) xv) $ (getAngle xv . (-) (pt2Vec b) $ pt2Vec p0))
(getAngle (pt2Vec b - pt2Vec p0) xv)) (removeItem p0 xs)
(removeItem p0 xs) where
where xv = unitX
xv = unitX p0 = lowestYC xs
p0 = lowestYC xs -- Have to account for corner cases when points are in
-- Have to account for corner cases when points are in -- a straight line or have the same y coordinates. Eq is
-- a straight line or have the same y coordinates. Eq is -- not an option anyhow.
-- not an option anyhow. noEqual :: PT -> PT -> Ordering -> Ordering
noEqual :: PT -> PT -> Ordering -> Ordering noEqual a b EQ
noEqual a b EQ | ay == by &&
| ay == by && ax < bx = LT
ax < bx = LT | otherwise = GT
| otherwise = GT where
where (ax, ay) = unp2 a
(ax, ay) = unp2 a (bx, by) = unp2 b
(bx, by) = unp2 b noEqual _ _ x = x
noEqual _ _ LT = LT
noEqual _ _ GT = GT
-- |Get all points on a convex hull by using the graham scan -- |Get all points on a convex hull by using the graham scan
-- algorithm. -- algorithm.
grahamGetCH :: [PT] -> [PT] grahamGetCH :: [PT] -> [PT]
grahamGetCH vs = f . grahamSort $ vs grahamGetCH vs =
f . grahamSort $ vs
where where
f (x:y:z:xs) f (x:y:z:xs)
| ccw x y z = x : f (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 -- |Compute all steps of the graham scan algorithm to allow
-- visualizing it. -- visualizing it.
grahamGetCHSteps :: [PT] -> [[PT]] grahamGetCHSteps :: [PT] -> [[PT]]
grahamGetCHSteps vs = reverse . g $ (length vs - 2) grahamGetCHSteps vs =
reverse . g $ (length vs - 2)
where where
vs' = grahamSort vs vs' = grahamSort vs
g c 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. -- |Used to create a common interface for default settings of data types.
class Def a where class Def a where
def :: a def :: a

200
Diagram.hs
View File

@ -48,7 +48,7 @@ data DiagProp = MkProp {
instance Def DiagProp where instance Def DiagProp where
def = defaultProp def = defaultProp
instance Monoid Diag where instance Monoid Diag where
@ -90,25 +90,23 @@ yuD = snd . dY
coordPoints :: Diag coordPoints :: Diag
coordPoints = Diag f coordPoints = Diag f
where where
f p vt f p vt =
= position (zip (filter (inRange (dX p) (dY p)) $ vt) position (zip (filter (inRange (dX p) (dY p)) $ vt)
(repeat dot)) (repeat dot))
where where
-- a dot itself is a diagram dot = (circle $ t p :: Diagram Cairo R2) # fc black
dot = (circle $ t p :: Diagram Cairo R2) # fc black
-- |Create a diagram which shows the points of the convex hull. -- |Create a diagram which shows the points of the convex hull.
convexHullPoints :: Diag convexHullPoints :: Diag
convexHullPoints = Diag f convexHullPoints = Diag f
where where
f p vt f p vt =
= position (zip (filter (inRange (dX p) (dY p)) $ vtch) position (zip (filter (inRange (dX p) (dY p)) $ vtch)
(repeat dot)) (repeat dot))
where where
-- a dot itself is a diagram dot = (circle $ t p :: Diagram Cairo R2) # fc red # lc red
dot = (circle $ t p :: Diagram Cairo R2) # fc red # lc red vtch = grahamGetCH vt
vtch = grahamGetCH vt
-- |Create a diagram which shows the lines along the convex hull -- |Create a diagram which shows the lines along the convex hull
@ -117,13 +115,14 @@ convexHullLines :: Diag
convexHullLines = Diag f convexHullLines = Diag f
where where
f _ [] = mempty f _ [] = mempty
f p vt f p vt =
= (strokeTrail . (strokeTrail .
fromVertices . fromVertices .
flip (++) [head $ grahamGetCH vtf] . flip (++) [head $ grahamGetCH vtf] .
grahamGetCH $ grahamGetCH $
vtf vtf) #
) # moveTo (head $ grahamGetCH vtf) # lc red moveTo (head $ grahamGetCH vtf) #
lc red
where where
vtf = filter (inRange (dX p) (dY p)) vt vtf = filter (inRange (dX p) (dY p)) vt
@ -134,54 +133,63 @@ convexHullLines = Diag f
convexHullLinesInterval :: DiagProp -> [PT] -> [Diagram Cairo R2] convexHullLinesInterval :: DiagProp -> [PT] -> [Diagram Cairo R2]
convexHullLinesInterval p xs = convexHullLinesInterval p xs =
fmap g (grahamGetCHSteps xs) fmap g (grahamGetCHSteps xs)
where where
g vt g vt =
= (strokeTrail . (strokeTrail .
fromVertices $ fromVertices $
vtf vtf) #
) # moveTo (head vtf) # lc red moveTo (head vtf) #
where lc red
vtf = filter (inRange (dX p) (dY p)) vt where
vtf = filter (inRange (dX p) (dY p)) vt
-- |Creates a Diagram that shows an XAxis which is bound -- |Creates a Diagram that shows an XAxis which is bound
-- by the dimensions given in xD from DiagProp. -- by the dimensions given in xD from DiagProp.
xAxis :: Diag xAxis :: Diag
xAxis = (Diag hRule) `mappend` xAxis =
(Diag segments) `mappend` (Diag hRule) `mappend`
(Diag labels) (Diag segments) `mappend`
(Diag labels)
where where
hRule p _ = arrowAt (p2 (xlD p,0)) (r2 (xuD p, 0)) # hRule p _ =
moveTo (p2 (xlD p,0)) arrowAt (p2 (xlD p,0)) (r2 (xuD p, 0)) # moveTo (p2 (xlD p,0))
segments p _ = hcat' (with & sep .~ 50) segments p _ =
(take (floor . (/) (xuD p - xlD p) $ 50) . hcat' (with & sep .~ 50)
repeat $ (vrule 10)) # moveTo (p2 (xlD p,0)) (take (floor . (/) (xuD p - xlD p) $ 50) . repeat $ (vrule 10)) #
moveTo (p2 (xlD p,0))
labels p _ = labels p _ =
position $ zip (mkPoint <$> xs) position $
((\x -> (flip (<>) (square 1 # lw none) . zip (mkPoint <$> xs)
text . show $ x) # scale 10) <$> xs) ((\x -> (flip (<>) (square 1 # lw none) .
where text . show $ x) # scale 10) <$> xs)
xs :: [Int] where
xs = take (floor . (/) (xuD p - xlD p) $ 50) (iterate (+50) 0) xs :: [Int]
mkPoint x = p2 (fromIntegral x, -15) 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 -- |Creates a Diagram that shows an YAxis which is bound
-- by the dimensions given in yD from DiagProp. -- by the dimensions given in yD from DiagProp.
yAxis :: Diag yAxis :: Diag
yAxis = (Diag vRule) `mappend` yAxis =
(Diag segments) `mappend` (Diag vRule) `mappend`
(Diag labels) (Diag segments) `mappend`
(Diag labels)
where where
vRule p _ = arrowAt (p2 (0, ylD p)) (r2 (0, yuD p)) # vRule p _ =
moveTo (p2 (0, ylD p)) arrowAt (p2 (0, ylD p)) (r2 (0, yuD p)) # moveTo (p2 (0, ylD p))
segments p _ = vcat' (with & sep .~ 50) segments p _ =
(take (floor . (/) (yuD p - ylD p) $ 50) . vcat' (with & sep .~ 50)
repeat $ (hrule 10)) # alignB # moveTo (p2 (0, (ylD p))) (take (floor . (/) (yuD p - ylD p) $ 50) .
repeat $ (hrule 10)) #
alignB #
moveTo (p2 (0, (ylD p)))
labels p _ = labels p _ =
position $ zip (mkPoint <$> ys) position $
((\x -> (flip (<>) (square 1 # lw none) . zip (mkPoint <$> ys)
text . show $ x) # scale 10) <$> ys) ((\x -> (flip (<>) (square 1 # lw none) .
text . show $ x) # scale 10) <$> ys)
where where
ys :: [Int] ys :: [Int]
ys = take (floor . (/) (yuD p - ylD p) $ 50) (iterate (+50) 0) ys = take (floor . (/) (yuD p - ylD p) $ 50) (iterate (+50) 0)
@ -202,49 +210,53 @@ whiteRectB = Diag f
-- |Create the Diagram from the points. -- |Create the Diagram from the points.
diag :: DiagProp -> [PT] -> Diagram Cairo R2 diag :: DiagProp -> [PT] -> Diagram Cairo R2
diag p = case alg p of diag p = case alg p of
0 -> mkDiag 0 ->
(mconcat [coordPoints, xAxis, yAxis, mkDiag
(if gd p then grid else mempty), whiteRectB]) (mconcat [coordPoints, xAxis, yAxis,
p (if gd p then grid else mempty), whiteRectB])
1 -> mkDiag p
(mconcat $ 1 ->
[convexHullPoints, convexHullLines, coordPoints, mkDiag
xAxis, yAxis, (if gd p then grid else mempty), whiteRectB]) (mconcat
p [convexHullPoints, convexHullLines, coordPoints,
xAxis, yAxis, (if gd p then grid else mempty), whiteRectB])
p
_ -> mempty _ -> mempty
-- |Create the Diagram from a String which is supposed to be the contents -- |Create the Diagram from a String which is supposed to be the contents
-- of an obj file. -- of an obj file.
diagS :: DiagProp -> String -> Diagram Cairo R2 diagS :: DiagProp -> String -> Diagram Cairo R2
diagS p mesh diagS p mesh =
= (diag p . (diag p .
meshToArr $ meshToArr $
mesh) # bg white mesh) #
bg white
-- |Return a list of tuples used by 'gifMain' to generate an animated gif. -- |Return a list of tuples used by 'gifMain' to generate an animated gif.
gifDiag :: DiagProp -> [PT] -> [(Diagram Cairo R2, GifDelay)] gifDiag :: DiagProp -> [PT] -> [(Diagram Cairo R2, GifDelay)]
gifDiag p xs = fmap (\x -> (x, 100)) . gifDiag p xs =
fmap (\x -> x <> g) . fmap (\x -> (x, 100)) .
flip (++) fmap (\x -> x <> g) .
[mkDiag (convexHullLines `mappend` flip (++)
convexHullPoints) p xs] $ [mkDiag (convexHullLines `mappend`
(convexHullLinesInterval p xs) convexHullPoints) p xs] $
where (convexHullLinesInterval p xs)
g = mconcat . where
fmap (\x -> mkDiag x p xs) $ g =
[coordPoints, mconcat .
xAxis, fmap (\x -> mkDiag x p xs) $
yAxis, [coordPoints,
whiteRectB] xAxis,
yAxis,
whiteRectB]
-- |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 -> String -> [(Diagram Cairo R2, GifDelay)] gifDiagS :: DiagProp -> String -> [(Diagram Cairo R2, GifDelay)]
gifDiagS p = gifDiag p . gifDiagS p = gifDiag p . meshToArr
meshToArr
-- |Create a white rectangle with the given width and height. -- |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
grid = Diag f `mappend` Diag g grid = Diag f `mappend` Diag g
where where
f p _ = hcat' (with & sep .~ 50) f p _ =
(take (floor . (/) (xuD p - xlD p) $ 50) . hcat' (with & sep .~ 50)
repeat $ (vrule $ xuD p - xlD p)) # (take (floor . (/) (xuD p - xlD p) $ 50) .
moveTo (p2 (xlD p, (yuD p - ylD p) / 2)) # repeat $ (vrule $ xuD p - xlD p)) #
lw ultraThin moveTo (p2 (xlD p, (yuD p - ylD p) / 2)) #
g p _ = vcat' (with & sep .~ 50) lw ultraThin
(take (floor . (/) (yuD p - ylD p) $ 50) . g p _ =
repeat $ (hrule $ yuD p - ylD p)) # vcat' (with & sep .~ 50)
alignB # (take (floor . (/) (yuD p - ylD p) $ 50) .
moveTo (p2 ((xuD p - xlD p) / 2, ylD p)) # repeat $ (hrule $ yuD p - ylD p)) #
lw ultraThin 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" cB' <- xmlGetWidget xml castToComboBox "comboalgo"
gC' <- xmlGetWidget xml castToCheckButton "gridcheckbutton" 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 :: FilePath -> IO ()
gifCLI startFile = do gifCLI startFile = do
mesh <- readFile "UB1_sonderfaelle.obj" mesh <- readFile "UB1_sonderfaelle.obj"
gifMain (gifDiagS def mesh) gifMain (gifDiagS def mesh)
@ -118,21 +119,21 @@ makeGUI startFile = do
-- hotkeys -- hotkeys
_ <- win mygui `on` keyPressEvent $ tryEvent $ do _ <- win mygui `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier [Control] <- eventModifier
"q" <- eventKeyName "q" <- eventKeyName
liftIO mainQuit liftIO mainQuit
_ <- win mygui `on` keyPressEvent $ tryEvent $ do _ <- win mygui `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier [Control] <- eventModifier
"s" <- eventKeyName "s" <- eventKeyName
liftIO $ onClickedSaveButton mygui liftIO $ onClickedSaveButton mygui
_ <- win mygui `on` keyPressEvent $ tryEvent $ do _ <- win mygui `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier [Control] <- eventModifier
"d" <- eventKeyName "d" <- eventKeyName
liftIO $ onClickedDrawButton mygui liftIO $ onClickedDrawButton mygui
_ <- win mygui `on` keyPressEvent $ tryEvent $ do _ <- win mygui `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier [Control] <- eventModifier
"a" <- eventKeyName "a" <- eventKeyName
liftIO $ widgetShowAll (aD mygui) liftIO $ widgetShowAll (aD mygui)
-- draw widgets and start main loop -- draw widgets and start main loop
widgetShowAll (win mygui) widgetShowAll (win mygui)
@ -206,22 +207,27 @@ drawDiag' fp mygui =
(daW, daH) <- widgetGetSize (da mygui) (daW, daH) <- widgetGetSize (da mygui)
gd' <- toggleButtonGetActive (gC mygui) gd' <- toggleButtonGetActive (gC mygui)
let xD = (,) <$> readMaybe xlD' <*> readMaybe xuD' :: Maybe (Double, let
Double) xD = (,) <$>
yD = (,) <$> readMaybe ylD' <*> readMaybe yuD' :: Maybe (Double, readMaybe xlD' <*>
Double) readMaybe xuD' :: Maybe (Double, Double)
yD = (,) <$>
readMaybe ylD' <*>
readMaybe yuD' :: Maybe (Double, Double)
case (xD, yD) of case (xD, yD) of
(Just xD', Just yD') -> do (Just xD', Just yD') -> do
let (_, r) = renderDia Cairo let (_, r) = renderDia Cairo
(CairoOptions "" (CairoOptions ""
(Dims (fromIntegral daW) (fromIntegral daH)) (Dims (fromIntegral daW) (fromIntegral daH))
SVG False) SVG False)
(diagS (def{t = scaleVal, (diagS (def{
dX = xD', t = scaleVal,
dY = yD', dX = xD',
alg = alg', dY = yD',
gd = gd'}) alg = alg',
mesh) gd = gd'})
mesh)
renderWithDrawable dw r renderWithDrawable dw r
return 0 return 0
_ -> return 1 _ -> return 1
@ -247,19 +253,23 @@ saveDiag' fp mygui =
(daW, daH) <- widgetGetSize (da mygui) (daW, daH) <- widgetGetSize (da mygui)
gd' <- toggleButtonGetActive (gC mygui) gd' <- toggleButtonGetActive (gC mygui)
let xD = (,) <$> readMaybe xlD' <*> readMaybe xuD' :: Maybe (Double, let
Double) xD = (,) <$>
yD = (,) <$> readMaybe ylD' <*> readMaybe yuD' :: Maybe (Double, readMaybe xlD' <*>
Double) readMaybe xuD' :: Maybe (Double, Double)
yD = (,) <$>
readMaybe ylD' <*>
readMaybe yuD' :: Maybe (Double, Double)
case (xD, yD) of case (xD, yD) of
(Just xD', Just yD') -> do (Just xD', Just yD') -> do
renderCairo "out.svg" renderCairo "out.svg"
(Dims (fromIntegral daW) (fromIntegral daH)) (Dims (fromIntegral daW) (fromIntegral daH))
(diagS (def{t = scaleVal, (diagS (def{
dX = xD', t = scaleVal,
dY = yD', dX = xD',
alg = alg', dY = yD',
gd = gd'}) alg = alg',
gd = gd'})
mesh) mesh)
return 0 return 0
_ -> return 1 _ -> return 1

25
LinearAlgebra/Vector.hs
View File

@ -14,18 +14,18 @@ inRange :: Coord -- ^ X dimension
-> Coord -- ^ Y dimension -> Coord -- ^ Y dimension
-> PT -- ^ Coordinates -> PT -- ^ Coordinates
-> Bool -- ^ result -> Bool -- ^ result
inRange (xlD, xuD) (ylD, yuD) p inRange (xlD, xuD) (ylD, yuD) p = x <= xuD && x >= xlD && y <= yuD && y >= ylD
= x <= xuD && x >= xlD && y <= yuD && y >= ylD where
where (x, y) = unp2 p
(x, y) = unp2 p
-- |Get the angle between two vectors. -- |Get the angle between two vectors.
getAngle :: Vec -> Vec -> Double getAngle :: Vec -> Vec -> Double
getAngle a b = acos . getAngle a b =
flip (/) (vecLength a * vecLength b) . acos .
scalarProd a $ flip (/) (vecLength a * vecLength b) .
b scalarProd a $
b
-- |Get the length of a vector. -- |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 -- connecting a-b-c. This is done by computing the determinant and
-- checking the algebraic sign. -- checking the algebraic sign.
ccw :: PT -> PT -> PT -> Bool ccw :: PT -> PT -> PT -> Bool
ccw a b c = (bx - ax) * ccw a b c =
(cy - ay) - (bx - ax) *
(by - ay) * (cy - ay) -
(cx - ax) >= 0 (by - ay) *
(cx - ax) >= 0
where where
(ax, ay) = unp2 a (ax, ay) = unp2 a
(bx, by) = unp2 b (bx, by) = unp2 b

10
OS/FileExt.hs
View File

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

30
Parser/Core.hs
View File

@ -13,27 +13,32 @@ module Parser.Core (Parser,
import Control.Applicative import Control.Applicative
import Data.Char import Data.Char
-- |The parser type. It allows us to create specific parsers, -- |The parser type. It allows us to create specific parsers,
-- combine them and run them via 'runParser' to get a result. -- combine them and run them via 'runParser' to get a result.
newtype Parser a = MkParser { runParser :: String -> Maybe (a, String) } newtype Parser a = MkParser { runParser :: String -> Maybe (a, String) }
-- |Functor instance. -- |Functor instance.
instance Functor Parser where instance Functor Parser where
fmap = inParser . fmap . fmap . first fmap = inParser . fmap . fmap . first
-- |Applicative functor instance. -- |Applicative functor instance.
instance Applicative Parser where instance Applicative Parser where
pure a = MkParser (\s -> Just (a, s)) pure a = MkParser (\s -> Just (a, s))
(MkParser fp) <*> xp = MkParser $ \s -> (MkParser fp) <*> xp = MkParser $ \s ->
case fp s of case fp s of
Nothing -> Nothing Nothing -> Nothing
Just (f,x) -> runParser (f <$> xp) x Just (f,x) -> runParser (f <$> xp) x
-- |Alternative functor instance. -- |Alternative functor instance.
instance Alternative Parser where instance Alternative Parser where
empty = MkParser (const Nothing) empty = MkParser (const Nothing)
MkParser p1 <|> MkParser p2 = MkParser $ liftA2 (<|>) p1 p2 MkParser p1 <|> MkParser p2 = MkParser $ liftA2 (<|>) p1 p2
inParser :: ((String -> Maybe (a1, String)) inParser :: ((String -> Maybe (a1, String))
-> String -> String
-> Maybe (a, String)) -> Maybe (a, String))
@ -41,9 +46,11 @@ inParser :: ((String -> Maybe (a1, String))
-> Parser a -> Parser a
inParser f p = MkParser . f . runParser $ p inParser f p = MkParser . f . runParser $ p
first :: (a -> b) -> (a,c) -> (b,c) first :: (a -> b) -> (a,c) -> (b,c)
first f (x,y) = (f x, y) first f (x,y) = (f x, y)
-- |Creates a Parser that parses a Char depending on a given condition. -- |Creates a Parser that parses a Char depending on a given condition.
satisfy :: (Char -> Bool) -- ^ condition satisfy :: (Char -> Bool) -- ^ condition
-> Parser Char -- ^ created Parser -> Parser Char -- ^ created Parser
@ -54,10 +61,12 @@ satisfy p = MkParser f
| p x = Just (x, xs) | p x = Just (x, xs)
| otherwise = Nothing | otherwise = Nothing
-- |Creates a Parser that accepts a given Char. -- |Creates a Parser that accepts a given Char.
char :: Char -> Parser Char char :: Char -> Parser Char
char c = satisfy (== c) char c = satisfy (== c)
-- |Creates a Parser that accepts positive integers. -- |Creates a Parser that accepts positive integers.
posInt :: Parser Integer posInt :: Parser Integer
posInt = MkParser f posInt = MkParser f
@ -67,29 +76,34 @@ posInt = MkParser f
| otherwise = Just (read ns, rest) | otherwise = Just (read ns, rest)
where (ns, rest) = span isDigit xs where (ns, rest) = span isDigit xs
-- |Creates a Parser that accepts positive doubles. -- |Creates a Parser that accepts positive doubles.
-- Both 131.31 and 132 are valid. -- Both 131.31 and 132 are valid.
posDouble :: Parser Double posDouble :: Parser Double
posDouble = (read <$>) $ posDouble =
(\x y z -> x ++ [y] ++ z) <$> (read <$>) $
MkParser f <*> (\x y z -> x ++ [y] ++ z) <$>
char '.' <*> MkParser f <*>
MkParser f <|> char '.' <*>
MkParser f MkParser f <|>
MkParser f
where where
f xs f xs
| null ns = Nothing | null ns = Nothing
| otherwise = Just (ns, rest) | otherwise = Just (ns, rest)
where (ns, rest) = span isDigit xs where (ns, rest) = span isDigit xs
-- |Convert a given Parser to a Parser that accepts zero or more occurences. -- |Convert a given Parser to a Parser that accepts zero or more occurences.
zeroOrMore :: Parser a -> Parser [a] zeroOrMore :: Parser a -> Parser [a]
zeroOrMore p = oneOrMore p <|> pure [] zeroOrMore p = oneOrMore p <|> pure []
-- |Convert a given Parser to a Parser that accepts one or more occurences. -- |Convert a given Parser to a Parser that accepts one or more occurences.
oneOrMore :: Parser a -> Parser [a] oneOrMore :: Parser a -> Parser [a]
oneOrMore p = (:) <$> p <*> zeroOrMore p oneOrMore p = (:) <$> p <*> zeroOrMore p
-- |Creates a Parser that accepts spaces. -- |Creates a Parser that accepts spaces.
spaces :: Parser String spaces :: Parser String
spaces = zeroOrMore (satisfy isSpace) spaces = zeroOrMore (satisfy isSpace)

20
Parser/Meshparser.hs
View File

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

9
Util.hs
View File

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