Improve overall style and indenting
This commit is contained in:
parent
22482f7c49
commit
12da4040dc
@ -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
|
||||
|
||||
@ -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
200
Diagram.hs
@ -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
82
Gtk.hs
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 = ""
|
||||
|
||||
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
9
Util.hs
@ -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.
|
||||
|
||||
Loading…
Reference in New Issue
Block a user