justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Apply Hlints

Browse Source
This commit is contained in:
jgk
2021-03-26 17:12:19 +01:00
parent 322855f25a
commit e1716615c0
5 changed files with 85 additions and 82 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Geometry.hs
+25 -19
View File
@@ -17,6 +17,7 @@ import Data.List
import Data.Maybe
import Control.Applicative
-- TODO add bang patterns
alongLineBy :: Float -> Point2 -> Point2 -> Point2
alongLineBy x a b = a +.+ y *.* normalizeV (b -.- a)
@@ -171,10 +172,10 @@ anyPolyssIntersect :: [[Point2]] -> [[Point2]] -> Bool
anyPolyssIntersect x y = or $ polysIntersect <$> x <*> y
nRays :: Int -> [Point2]
nRays n = take n $ iterate (rotateV (2*pi/fromIntegral n)) $ (600,0)
nRays n = take n $ iterate (rotateV (2*pi/fromIntegral n)) (600,0)
nRaysRad :: Int -> Float -> [Point2]
nRaysRad n x = take n $ iterate (rotateV (2*pi/fromIntegral n)) $ (x,0)
nRaysRad n x = take n $ iterate (rotateV (2*pi/fromIntegral n)) (x,0)
-- angles go from 0 to 2pi, need to work out what is left of another
@@ -298,22 +299,25 @@ isOnLine l1 l2 p = errorClosestPointOnLineParam 10 l1 (l1 +.+ vNormal (l2 -.- l1
-- generate an infinite list, and I don't know why
divideLine :: Float -> Point2 -> Point2 -> [Point2]
--divideLine x a b = map (\i -> a +.+ (i / (fromIntegral numPoints)) *.* (b -.- a))
divideLine x a b = take 5000 $ map (\i -> a +.+ (i / (fromIntegral numPoints) *.* (b -.- a)) )
$ map fromIntegral ns
where d = dist a b
numPoints = max 1 $ ceiling $ d / x
ns = [0 .. numPoints]
divideLine x a b = take 5000
$ map (\i -> a +.+ (fromIntegral i / fromIntegral numPoints *.* (b -.- a)) )
ns
where
d = dist a b
numPoints = max 1 $ ceiling $ d / x
ns = [0 .. numPoints]
divideLineOddNumPoints :: Float -> Point2 -> Point2 -> [Point2]
--divideLine x a b = map (\i -> a +.+ (i / (fromIntegral numPoints)) *.* (b -.- a))
divideLineOddNumPoints x a b = take 5000 $ map (\i -> a +.+ (i / (fromIntegral numPoints) *.* (b -.- a)) )
$ map fromIntegral ns
where d = dist a b
numPoints' = max 1 $ ceiling $ d / x
numPoints | even numPoints' = numPoints'
| otherwise = numPoints' + 1
ns = [0 .. numPoints]
divideLineOddNumPoints x a b = take 5000
$ map (\i -> a +.+ (fromIntegral i / fromIntegral numPoints *.* (b -.- a)) )
ns
where
d = dist a b
numPoints' = max 1 $ ceiling $ d / x
numPoints | even numPoints' = numPoints'
| otherwise = numPoints' + 1
ns = [0 .. numPoints]
-- pulled the following from the haskell wiki
-- it seems to produce an infinite loop sometimes
@@ -343,7 +347,8 @@ digitalLine (x1,y1) (x2,y2)
| x <- intervalList x1 x2 ]
| otherwise = [ ( ((x1-x2) * y + y1*x2 - y2*x1) `rdiv` (y1-y2) , y)
| y <- intervalList y1 y2 ]
where rdiv a b = round $ fromIntegral a / fromIntegral b
where
rdiv a b = round $ fromIntegral a / fromIntegral b
intervalList :: Int -> Int -> [Int]
intervalList x y
@@ -352,10 +357,11 @@ intervalList x y
divideCircle :: Float -> Point2 -> Float -> [Point2]
divideCircle x cen rad = map (cen +.+) $ nPointsOnCirc n rad
where n = ceiling $ rad * 2 * pi / x
where
n = ceiling $ rad * 2 * pi / x
nPointsOnCirc :: Int -> Float -> [Point2]
nPointsOnCirc n rad = take n $ iterate (rotateV (2*pi/fromIntegral n)) $ (rad,0)
nPointsOnCirc n rad = take n $ iterate (rotateV (2*pi/fromIntegral n)) (rad,0)
lineInPolygon :: Point2 -> Point2 -> [Point2] -> Bool
lineInPolygon a b ps = pointInPolygon a ps || pointInPolygon b ps
@@ -364,7 +370,7 @@ lineInPolygon a b ps = pointInPolygon a ps || pointInPolygon b ps
makeLoopPairs :: [Point2] -> [(Point2,Point2)]
makeLoopPairs [] = error "tried to make loop with empty list of points"
makeLoopPairs (x:[]) = error "tried to make loop with singleton list of points"
makeLoopPairs [x] = error "tried to make loop with singleton list of points"
makeLoopPairs (x:xs) = zip (x:xs) (xs ++ [x])
-- note the pair is ordered
src/Loop.hs
+2 -2
View File
@@ -90,7 +90,7 @@ applyEventsIO
-> world
-> [Event]
-> IO (Maybe world)
applyEventsIO fn w es = foldM (applyEventIO fn) (Just w) es
applyEventsIO fn w = foldM (applyEventIO fn) (Just w)
--eventCloseOrResize :: Event -> IO (Maybe Event)
--eventCloseOrResize e = case eventPayload e of
@@ -105,7 +105,7 @@ applyEventIO :: (world -> Event -> Maybe world) -> Maybe world -> Event -> IO (M
applyEventIO fn mw e = case eventPayload e of
QuitEvent -> return Nothing
WindowClosedEvent _ -> return Nothing
WindowSizeChangedEvent (WindowSizeChangedEventData {windowSizeChangedEventSize = V2 x y})
WindowSizeChangedEvent WindowSizeChangedEventData {windowSizeChangedEventSize = V2 x y}
-> GL.viewport $= (GL.Position 0 0,GL.Size x y) >> return (mw >>= \w -> fn w e)
_ -> return $ mw >>= flip fn e
src/Picture.hs
+42 -47
View File
@@ -1,5 +1,3 @@
--{-# LANGUAGE BangPatterns #-}
--{-# LANGUAGE Strict #-}
module Picture
( module Picture.Data
, polygon
@@ -46,7 +44,7 @@ module Picture
, setDepth
, setLayer
)
where
where
import Geometry
import Geometry.Data
@@ -75,33 +73,35 @@ bezierQuad :: Color -> Color -> Float -> Float -> Point2 -> Point2 -> Point2 ->
bezierQuad cola colc ra rc a b c
| a == b && b == c = blank
| a == b || b == c = bezierQuad cola colc ra rc a (0.5 *.* (a +.+ c)) c
| otherwise = BezierQuad 0 [-- ( (0,0) , cola, (0,0), (0,0) )
(aIn, cola, (fa aIn,fc aIn) , (1,0) )
,(aIn, cola, (fa aIn,fc aIn) , (1,0) )
,(cIn, colc, (fa cIn,fc cIn) , (0,1) )
,( aX, cola, (1,0) , (fa' aX,fc' aX) )
,( cX, colc, (0,1) , (fa' cX,fc' cX) )
,( bX, colb, (0,0) , (fa' bX,fc' bX) )
,( bX, colb, (0,0) , (fa' bX,fc' bX) )
]
where colb = mixColors 0.5 0.5 cola colc
b2a | isLHS a b c = a -.- b
| otherwise = b -.- a
aRadVec = 0.5 * ra *.* (normalizeV $ vNormal b2a)
aX = a -.- aRadVec
aIn = a +.+ aRadVec
b2c | isLHS a b c = b -.- c
| otherwise = c -.- b
cRadVec = 0.5 * rc *.* (normalizeV $ vNormal b2c)
cX = c -.- cRadVec
cIn = c +.+ cRadVec
bRadVec = 0.25 * (ra + rc) *.* (normalizeV $ a +.+ b -.- 2 *.* c)
bX = b +.+ bRadVec
bIn = b -.- bRadVec
fa = extrapolate aX cX bX
fc = extrapolate cX aX bX
fa' = extrapolate aIn cIn bIn
fc' = extrapolate cIn aIn bIn
| otherwise = BezierQuad 0
[-- ( (0,0) , cola, (0,0), (0,0) )
(aIn, cola, (fa aIn,fc aIn) , (1,0) )
,(aIn, cola, (fa aIn,fc aIn) , (1,0) )
,(cIn, colc, (fa cIn,fc cIn) , (0,1) )
,( aX, cola, (1,0) , (fa' aX,fc' aX) )
,( cX, colc, (0,1) , (fa' cX,fc' cX) )
,( bX, colb, (0,0) , (fa' bX,fc' bX) )
,( bX, colb, (0,0) , (fa' bX,fc' bX) )
]
where
colb = mixColors 0.5 0.5 cola colc
b2a | isLHS a b c = a -.- b
| otherwise = b -.- a
aRadVec = 0.5 * ra *.* normalizeV (vNormal b2a)
aX = a -.- aRadVec
aIn = a +.+ aRadVec
b2c | isLHS a b c = b -.- c
| otherwise = c -.- b
cRadVec = 0.5 * rc *.* normalizeV (vNormal b2c)
cX = c -.- cRadVec
cIn = c +.+ cRadVec
bRadVec = 0.25 * (ra + rc) *.* normalizeV (a +.+ b -.- 2 *.* c)
bX = b +.+ bRadVec
bIn = b -.- bRadVec
fa = extrapolate aX cX bX
fc = extrapolate cX aX bX
fa' = extrapolate aIn cIn bIn
fc' = extrapolate cIn aIn bIn
-- given a one and two zeros of a linear function over x and y,
-- determine the function
@@ -149,25 +149,23 @@ scale x y pic = OverPic (scale3 x y) (\(a,b) ->(a*x,b*y)) 0 id pic
rotate3 :: Float -> Point3 -> Point3
{-# INLINE rotate3 #-}
rotate3 a (x,y,z) = (x',y',z)
where (x',y') = rotateV a (x,y)
where
(x',y') = rotateV a (x,y)
rotate :: Float -> Picture -> Picture
{-# INLINE rotate #-}
rotate a pic = OverPic (rotate3 a) id a id pic
--rotateRad a = Rotate a
--{-# INLINE rotateRad #-}
pictures :: [Picture] -> Picture
{-# INLINE pictures #-}
pictures = Pictures
makeArc :: Float -> (Float,Float) -> [Point2]
{-# INLINE makeArc #-}
makeArc rad (a,b) = zipWith rotateV as $ repeat (0,rad)
where as = [a,a+step.. b]
step = pi * 0.2
makeArc rad (a,b) = zipWith rotateV as (repeat (0,rad))
where
as = [a,a+step.. b]
step = pi * 0.2
circleSolid :: Float -> Picture
{-# INLINE circleSolid #-}
@@ -196,16 +194,15 @@ lineCol = LineCol 0
thickLine :: [Point2] -> Float -> Picture
{-# INLINE thickLine #-}
thickLine ps t = pictures $ f ps
where f (x:y:ys)
| x == y = f (x:ys)
| otherwise
= polygon [x +.+ n x y, x -.- n x y, y -.- n x y, y +.+ n x y] : f (y:ys)
f _ = []
n a b = (t*0.5) *.* errorNormalizeV 42 (vNormal (a -.- b))
where
f (x:y:ys)
| x == y = f (x:ys)
| otherwise = polygon [x +.+ n x y, x -.- n x y, y -.- n x y, y +.+ n x y] : f (y:ys)
f _ = []
n a b = (t*0.5) *.* errorNormalizeV 42 (vNormal (a -.- b))
thickCircle :: Float -> Float -> Picture
{-# INLINE thickCircle #-}
--thickCircle rad wdth = thickLine (makeArc rad (0,2*pi)) wdth
thickCircle rad wdth = thickArc 0 (2*pi) rad wdth
arcSolid :: Float -> Float -> Float -> Picture
@@ -219,8 +216,6 @@ arc startA endA rad = thickArc startA endA rad 1
thickArc :: Float -> Float -> Float -> Float -> Picture
{-# INLINE thickArc #-}
thickArc = ThickArc 0
--thickArc startA endA rad wdth
-- = thickLine (makeArc rad (startA,endA)) wdth
withAlpha :: Float -> RGBA -> RGBA
{-# INLINE withAlpha #-}
src/Shader.hs
+12 -10
View File
@@ -19,7 +19,7 @@ module Shader
, freeShaderPointers
, module Shader.Data
)
where
where
import Shader.Data
import Foreign
@@ -27,7 +27,7 @@ import Codec.Picture
import qualified Data.Vector.Storable as V
import Control.Monad (when, forM, zipWithM_, forM_, foldM)
import Control.Monad (when, unless, forM, zipWithM_, forM_, foldM)
import Control.Lens
import Data.Maybe (fromMaybe)
@@ -51,9 +51,10 @@ pokeShaders fss = traverse pokeShader fss
pokeShader :: FullShader a -> F.FoldM IO a Int
pokeShader fs = F.FoldM (pokeRender fls (zip ptrs nAtss)) (return 0) return
where vao = _shaderVAO fs
(_,ptrs,nAtss) = unzip3 $ _vaoBufferTargets $ vao
fls = _shaderPokeStrategy fs
where
vao = _shaderVAO fs
(_,ptrs,nAtss) = unzip3 $ _vaoBufferTargets vao
fls = _shaderPokeStrategy fs
pokeRender :: (a -> [[[Float]]])
-> [(Ptr Float,Int)] -> Int -> a -> IO Int
@@ -66,7 +67,7 @@ pokePtrs :: [(Ptr Float,Int)] -> Int -> [[Float]] -> IO Int
pokePtrs ptrIs n fss = do
zipWithM_ f ptrIs fss
return $ n + 1
where f (ptr,i) fs = pokeArrayOff ptr (i*n) fs
where f (ptr,i) fs = pokeArrayOff ptr (i*n) fs
pokeArrayOff :: Storable a => Ptr a -> Int -> [a] -> IO ()
pokeArrayOff ptr i xs =
@@ -83,7 +84,8 @@ bindArrayBuffers numVs ps = do
bindShaderBuffers :: [FullShader a] -> [Int] -> IO ()
bindShaderBuffers fss is =
zipWithM_ f fss is
where f fs i = bindArrayBuffers i $ _vaoBufferTargets $ _shaderVAO fs
where
f fs i = bindArrayBuffers i $ _vaoBufferTargets $ _shaderVAO fs
drawShaders :: [FullShader a] -> [Int] -> IO ()
drawShaders fss is =
@@ -116,7 +118,7 @@ addTexture texturePath shad = do
(PixelData RGBA UnsignedByte ptr)
generateMipmap' Texture2D
textureFilter Texture2D $= ((Linear',Just Linear') , Nearest)
return $ shad & shaderTexture .~ Just (ShaderTexture {_textureObject = textureOb})
return $ shad & shaderTexture ?~ ShaderTexture {_textureObject = textureOb}
makeShader :: String -> [ShaderType] -> [(GLuint,Int)] -> PrimitiveMode -> (a -> [[[Float]]]) -> IO (FullShader a)
makeShader s shaderlist alocs pm renStrat = do
@@ -198,7 +200,7 @@ makeShaderProgram str sources = do
linkProgram shaderProgram
linkingSuccess <- linkStatus shaderProgram
when (not linkingSuccess) $ do
unless linkingSuccess $ do
infoLog <- get (programInfoLog shaderProgram)
putStrLn $ str ++ ": Program Linking" ++ infoLog
@@ -210,7 +212,7 @@ compileAndCheckShader str (shaderType,sourceCode) = do
shaderSourceBS theShader $= sourceCode
compileShader theShader
success <- compileStatus theShader
when (not success) $ do
unless success $ do
infoLog <- get (shaderInfoLog theShader)
putStrLn $ str ++ ": Shader compile: " ++ show shaderType ++ " : " ++ show infoLog
return theShader