some linting

This commit is contained in:
nek0 2017-03-20 05:24:30 +01:00
parent f4a96f03c4
commit 7bf2962d07
7 changed files with 112 additions and 143 deletions

View File

@ -106,7 +106,7 @@ update = do
ad <- get
ud@UserData{..} <- getAffection
sec <- getTick
sec <- getDelta
traceM $ (show $ 1 / sec) ++ " FPS"
when (elapsedTime ad > 5) $
put $ ad

View File

@ -40,7 +40,7 @@ main = do
data UserData = UserData
{ nodeGraph :: M.Map String G.GeglNode
, foreground :: G.GeglBuffer
, lastTick :: Double
-- , lastTick :: Double
}
load :: SDL.Surface -> IO UserData
@ -82,7 +82,7 @@ load _ = do
return $ UserData
{ nodeGraph = myMap
, foreground = buffer
, lastTick = 0
-- , lastTick = 0
}
draw :: Affection UserData ()
@ -96,13 +96,13 @@ update :: Affection UserData ()
update = do
traceM "updating"
ud <- getAffection
let last = lastTick ud
tick <- getTick
putAffection $ ud { lastTick = tick }
let dt = tick - last
-- let last = lastTick ud
-- tick <- getTick
-- putAffection $ ud { lastTick = tick }
dt <- getDelta
traceM $ (show $ 1 / dt) ++ " FPS"
when (tick > 20) $
elapsed <- getElapsedTime
when (elapsed > 20) $
quit
clean :: UserData -> IO ()

View File

@ -10,7 +10,7 @@ import Debug.Trace
main :: IO ()
main = do
conf <- return $ AffectionConfig
conf <- return AffectionConfig
{ initComponents = All
, windowTitle = "Affection: example00"
, windowConfig = SDL.defaultWindow
@ -77,7 +77,7 @@ load _ = do
actorMap <- return $ M.fromList
[ ("rect", rectActor)
]
return $ UserData
return UserData
{ nodeGraph = myMap
, actors = actorMap
, foreground = buffer
@ -100,13 +100,13 @@ update :: Affection UserData ()
update = do
traceM "updating"
tick <- getTick
tick <- getElapsedTime
ud <- getAffection
putAffection $ ud { lastTick = tick }
let dt = tick - lastTick ud
return ()
traceM $ (show $ 1 / dt) ++ " FPS"
traceM $ show (1 / dt) ++ " FPS"
handle :: SDL.EventPayload -> Affection UserData ()
handle (SDL.MouseMotionEvent dat) = do
@ -114,11 +114,11 @@ handle (SDL.MouseMotionEvent dat) = do
ud <- getAffection
nmap <- return $ M.adjust
(\a -> Actor (props $ do
(Actor (props $ do
prop "y" (fromIntegral (y - 10) :: Double)
prop "x" (fromIntegral (x - 10) :: Double)
)
(actorNode a)
. actorNode
)
"rect"
(actors ud)

View File

@ -42,10 +42,14 @@ load _ = do
traceM "loading"
root <- G.gegl_node_new
traceM "new root node"
checkerboard <- G.gegl_node_new_child root $ G.checkerboardOperation
[ G.Property "color1" $ G.PropertyColor $ G.RGBA 0.4 0.4 0.4 1
, G.Property "color2" $ G.PropertyColor $ G.RGBA 0.6 0.6 0.6 1
]
rect <- G.gegl_node_new_child root $ G.Operation "gegl:rectangle" $
props $ do
prop "x" (0 :: Double)
prop "y" (0 :: Double)
prop "width" (800 :: Double)
prop "height" (600 :: Double)
prop "color" $ G.RGB 0 0 0
traceM "rect"
traceM "checkerboard"
over <- G.gegl_node_new_child root G.defaultOverOperation
traceM "over"
@ -62,13 +66,12 @@ load _ = do
, G.Property "height" $ G.PropertyDouble 600
]
traceM "crop"
G.gegl_node_link_many [checkerboard, over, crop, sink]
G.gegl_node_link_many [rect, over, crop, sink]
G.gegl_node_connect_to nop "output" over "aux"
traceM "connections made"
myMap <- return $ M.fromList
[ ("root" , root)
, ("over" , over)
, ("background" , checkerboard)
, ("sink" , sink)
, ("nop" , nop)
, ("crop" , crop)
@ -81,29 +84,21 @@ load _ = do
}
drawInit :: Affection UserData ()
drawInit = do
UserData{..} <- getAffection
present (GeglRectangle 0 0 800 600) foreground True
drawInit = return ()
-- drawInit = do
-- UserData{..} <- getAffection
-- present (GeglRectangle 0 0 800 600) foreground True
draw :: Affection UserData ()
draw = do
traceM "drawing"
UserData{..} <- getAffection
drawParticleSystem partsys partDraw
process $ nodeGraph M.! "sink"
-- ad <- get
-- ud <- getAffection
-- drawParticles partDraw $ particles ud
-- SDL.V2 (CInt rw) (CInt rh) <- SDL.surfaceDimensions $ drawSurface ad
-- let (w, h) = (fromIntegral rw, fromIntegral rh)
-- liftIO $ clearArea (foreground ud) (GeglRectangle 0 0 w h)
-- maybe (return ()) (\(x, y) ->
-- drawRect
-- (foreground ud)
-- (nodeGraph ud M.! "over")
-- (G.RGBA 1 0 0 0.5)
-- (Line 7)
-- (G.GeglRectangle (x - 10) (y - 10) 20 20)
-- ) $ coordinates ud
present
(G.GeglRectangle 0 0 800 600)
foreground
True
update :: Affection UserData ()
update = do
@ -111,66 +106,61 @@ update = do
ad <- get
ud <- getAffection
delta <- getDelta
-- let newPart = updateParticles delta partUpd $ particles ud
-- putAffection $ ud { particles = newPart }
traceM $ (show $ 1 / delta) ++ " FPS"
-- ev <- liftIO $ SDL.pollEvents
ud2 <- getAffection
!nps <- updateParticleSystem (partsys ud2) delta partUpd partDraw
!nps <- updateParticleSystem (partsys ud2) delta partUpd
putAffection $ ud2 { partsys = nps }
handle (SDL.MouseMotionEvent dat) =
if SDL.ButtonLeft `elem` SDL.mouseMotionEventState dat
then do
ad <- get
ud <- getAffection
let (SDL.P (SDL.V2 x y)) = SDL.mouseMotionEventPos dat
vx <- liftIO $ randomRIO (-20, 20)
vy <- liftIO $ randomRIO (-20, 20)
life <- liftIO $ randomRIO (1, 5)
r <- liftIO $ randomRIO (0,1)
g <- liftIO $ randomRIO (0,1)
b <- liftIO $ randomRIO (0,1)
tempRoot <- liftIO $ G.gegl_node_new
tempOver <- liftIO $ G.gegl_node_new_child tempRoot
G.defaultOverOperation
tempRect <- liftIO $ G.gegl_node_new_child tempRoot $ G.Operation
"gegl:rectangle"
[ G.Property "x" $ G.PropertyDouble $ fromIntegral x - 10
, G.Property "y" $ G.PropertyDouble $ fromIntegral y - 10
, G.Property "width" $ G.PropertyDouble 20
, G.Property "height" $ G.PropertyDouble 20
, G.Property "color" $ G.PropertyColor $ (G.RGBA r g b 0.5)
]
liftIO $ G.gegl_node_connect_to tempRect "output" tempOver "aux"
-- traceM $ "position is: " ++ show x ++ " " ++ show y
-- traceM $ "velocity is: " ++ show vx ++ " " ++ show vy
ips <- insertParticle (partsys ud) $
Particle
{ particleTimeToLive = life
, particleCreation = elapsedTime ad
, particlePosition = (fromIntegral x, fromIntegral y)
, particleRotation = Rad 0
, particleVelocity = (vx, vy)
, particlePitchRate = Rad 0
, particleRootNode = tempRoot
, particleNodeGraph = M.fromList
[ ("root", tempRoot)
, ("over", tempOver)
, ("rect", tempRect)
]
, particleStackCont = tempOver
, particleDrawFlange = tempOver
}
putAffection $ ud
{ partsys = ips
}
-- when (not $ null $ psParts $ partsys ud) $
-- liftIO $ G.gegl_node_link
-- tempOver
-- (particleStackCont $ head $ psParts $ partsys ud)
else
return ()
when (SDL.ButtonLeft `elem` SDL.mouseMotionEventState dat)
$ do
ad <- get
ud <- getAffection
let (SDL.P (SDL.V2 x y)) = SDL.mouseMotionEventPos dat
vx <- liftIO $ randomRIO (-20, 20)
vy <- liftIO $ randomRIO (-20, 20)
life <- liftIO $ randomRIO (1, 5)
r <- liftIO $ randomRIO (0,1)
g <- liftIO $ randomRIO (0,1)
b <- liftIO $ randomRIO (0,1)
tempRoot <- liftIO $ G.gegl_node_new
tempOver <- liftIO $ G.gegl_node_new_child tempRoot
G.defaultOverOperation
tempRect <- liftIO $ G.gegl_node_new_child tempRoot $ G.Operation
"gegl:rectangle"
[ G.Property "x" $ G.PropertyDouble $ fromIntegral x - 10
, G.Property "y" $ G.PropertyDouble $ fromIntegral y - 10
, G.Property "width" $ G.PropertyDouble 20
, G.Property "height" $ G.PropertyDouble 20
, G.Property "color" $ G.PropertyColor $ (G.RGBA r g b 0.5)
]
liftIO $ G.gegl_node_connect_to tempRect "output" tempOver "aux"
-- traceM $ "position is: " ++ show x ++ " " ++ show y
-- traceM $ "velocity is: " ++ show vx ++ " " ++ show vy
ips <- insertParticle (partsys ud) $
Particle
{ particleTimeToLive = life
, particleCreation = elapsedTime ad
, particlePosition = (fromIntegral x, fromIntegral y)
, particleRotation = Rad 0
, particleVelocity = (vx, vy)
, particlePitchRate = Rad 0
, particleRootNode = tempRoot
, particleNodeGraph = M.fromList
[ ("root", tempRoot)
, ("over", tempOver)
, ("rect", tempRect)
]
, particleStackCont = tempOver
, particleDrawFlange = tempOver
}
putAffection $ ud
{ partsys = ips
}
-- when (not $ null $ psParts $ partsys ud) $
-- liftIO $ G.gegl_node_link
-- tempOver
-- (particleStackCont $ head $ psParts $ partsys ud)
handle (SDL.WindowClosedEvent _) = do
traceM "seeya!"
@ -180,7 +170,8 @@ handle _ =
return ()
clean :: UserData -> IO ()
clean _ = return ()
clean ud = do
G.gegl_node_drop (nodeGraph ud M.! "root")
partUpd :: Double -> Particle -> Affection UserData Particle
partUpd sec p = do

View File

@ -9,7 +9,7 @@ module Affection
, delaySec
, get
, put
, getTick
, getElapsedTime
, getDelta
, quit
, module A
@ -81,8 +81,8 @@ withAffection AffectionConfig{..} = do
pixelFormat <- liftIO $ peek . Raw.surfaceFormat =<< peek ptr
SDL.V2 (CInt rw) (CInt rh) <- liftIO $ SDL.surfaceDimensions surface
let (w, h) = (fromIntegral rw, fromIntegral rh)
stride = (fromIntegral $ Raw.pixelFormatBytesPerPixel pixelFormat) * w
pixels <- SDL.surfacePixels $ surface
stride = fromIntegral (Raw.pixelFormatBytesPerPixel pixelFormat) * w
pixels <- SDL.surfacePixels surface
let bablFormat = B.PixelFormat B.RGBA B.CFu8
cpp = B.babl_components_per_pixel bablFormat
format <- B.babl_format bablFormat
@ -116,9 +116,9 @@ withAffection AffectionConfig{..} = do
-- clean draw requests from last run
mapM_ (invalidateDrawRequest (drawPixels ad) (drawStride ad) (drawCPP ad)) (drawStack ad)
-- clean the renderer form last time
SDL.clear renderer
-- SDL.clear renderer
-- compute dt and update elapsedTime
let !dt = (fromIntegral $ toNanoSecs $ diffTimeSpec lastTime now) / (fromIntegral 10 ^ 9)
let !dt = fromIntegral (toNanoSecs $ diffTimeSpec lastTime now) / (10 ^ 9)
!ne = elapsedTime ad + dt
put $ ad
{ drawStack = []
@ -147,7 +147,7 @@ withAffection AffectionConfig{..} = do
-- clean the texture
SDL.destroyTexture texture
-- save new time
liftIO $ writeIORef execTime $ now
liftIO $ writeIORef execTime now
)
) initContainer
G.gegl_exit
@ -159,7 +159,7 @@ getSurfaces :: SDL.Window -> IO (SDL.Surface, SDL.Surface)
getSurfaces window = do
oldSurf@(SDL.Surface ptr _) <- SDL.getWindowSurface window
rawSurfacePtr <- Raw.convertSurfaceFormat ptr (SDL.toNumber SDL.ABGR8888) 0
let surface = (flip SDL.Surface Nothing) rawSurfacePtr
let surface = SDL.Surface rawSurfacePtr Nothing
return (oldSurf, surface)
-- Prehandle SDL events in case any window events occur
@ -198,8 +198,8 @@ delaySec
delaySec dur = SDL.delay (fromIntegral $ dur * 1000)
-- | Get time since start but always the same in the current tick.
getTick :: Affection us Double
getTick =
getElapsedTime :: Affection us Double
getElapsedTime =
elapsedTime <$> get
getDelta :: Affection us Double

View File

@ -1,4 +1,4 @@
{-# LANGUAGE RecordWildCards, BangPatterns #-}
{-# LANGUAGE RecordWildCards #-}
-- | Module for drawing primitives
module Affection.Draw
@ -40,7 +40,7 @@ drawRect
-> Affection us ()
drawRect node color Fill rect@GeglRectangle{..} buf = do
ad <- get
tempRoot <- liftIO $ G.gegl_node_new
tempRoot <- liftIO G.gegl_node_new
opNode <- liftIO $ G.gegl_node_new_child tempRoot $ G.Operation "gegl:rectangle"
[ G.Property "x" $ G.PropertyDouble $ fromIntegral rectangleX
, G.Property "y" $ G.PropertyDouble $ fromIntegral rectangleY
@ -51,7 +51,7 @@ drawRect node color Fill rect@GeglRectangle{..} buf = do
diw <- liftIO $ G.gegl_node_connect_to opNode "output" node "input"
unless diw $ error "Affection.Draw.drawRect: connect failed"
put $ ad
{ drawStack = (DrawRequest rect buf (Kill (Just tempRoot))) : drawStack ad
{ drawStack = DrawRequest rect buf (Kill (Just tempRoot)) : drawStack ad
}
-- | Force update of a specific region on screen
@ -64,7 +64,7 @@ present rect buf kill = do
ad <- get
let k = if not kill then Kill Nothing else Persist
put ad
{ drawStack = (DrawRequest rect buf k) : drawStack ad
{ drawStack = DrawRequest rect buf k : drawStack ad
}
process
@ -106,20 +106,9 @@ handleDrawRequest pixels stride cpp dr@DrawRequest{..} = do
let surf = drawSurface ad
mrealRect <- liftIO $ G.gegl_rectangle_intersect
requestArea
(G.GeglRectangle 0 0 (fst $ drawDimensions ad) (snd $ drawDimensions ad))
maybe (return()) (\realRect -> do
liftIO $ SDL.lockSurface surf
liftIO $ G.gegl_buffer_get
requestBuffer
(Just realRect)
1
(Just $ drawFormat ad)
(pixels `plusPtr`
(rectangleX realRect * cpp + rectangleY realRect * stride))
stride
G.GeglAbyssNone
liftIO $ SDL.unlockSurface surf
-- liftIO $ SDL.updateWindowSurface $ drawWindow ad
(uncurry (G.GeglRectangle 0 0) (drawDimensions ad))
maybe (return()) (\realRect ->
putToSurface pixels realRect stride cpp dr
) mrealRect
case requestPersist of
Persist ->
@ -139,21 +128,10 @@ invalidateDrawRequest pixels stride cpp dr@DrawRequest{..} = do
ad <- get
mrealRect <- liftIO $ G.gegl_rectangle_intersect
requestArea
(G.GeglRectangle 0 0 (fst $ drawDimensions ad) (snd $ drawDimensions ad))
(uncurry (G.GeglRectangle 0 0) (drawDimensions ad))
maybe (return()) (\realRect -> do
let surf = drawSurface ad
liftIO $ clearArea requestBuffer realRect
liftIO $ SDL.lockSurface surf
liftIO $ G.gegl_buffer_get
requestBuffer
(Just realRect)
1
(Just $ drawFormat ad)
(pixels `plusPtr`
(rectangleX realRect * cpp + rectangleY realRect * stride))
stride
G.GeglAbyssNone
liftIO $ SDL.unlockSurface surf
putToSurface pixels realRect stride cpp dr
) mrealRect
case requestPersist of
Kill (Just victim) ->
@ -177,7 +155,7 @@ colorize (rr, rg, rb, ra) col =
G.RGB r g b -> (r, g, b)
ca = case col of
G.RGBA _ _ _ a -> a
G.RGB _ _ _ -> 1
G.RGB{} -> 1
alpha = ca
dst_a = ba
da = alpha + dst_a * (1 - alpha)
@ -189,7 +167,7 @@ colorize (rr, rg, rb, ra) col =
( G.CVdouble $ CDouble $ red / da
, G.CVdouble $ CDouble $ gre / da
, G.CVdouble $ CDouble $ blu / da
, G.CVdouble $ CDouble $ ca
, G.CVdouble $ CDouble ca
)
unsafeColorize col =
@ -199,12 +177,12 @@ unsafeColorize col =
G.RGB cr cg cb -> (cr, cg, cb)
a = case col of
G.RGBA _ _ _ ca -> ca
G.RGB _ _ _ -> 1
G.RGB{} -> 1
in
( G.CVdouble $ CDouble $ r
, G.CVdouble $ CDouble $ g
, G.CVdouble $ CDouble $ b
, G.CVdouble $ CDouble $ a
( G.CVdouble $ CDouble r
, G.CVdouble $ CDouble g
, G.CVdouble $ CDouble b
, G.CVdouble $ CDouble a
)
-- | Clear a specified area of a buffer from all data

View File

@ -1,7 +1,7 @@
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
module Affection.Property
( Props(..)
( Props
, prop
, props
) where
@ -20,7 +20,7 @@ props = flip execState []
prop :: IsPropertyValue v => String -> v -> Props ()
prop k v = do
ps <- get
put $ (G.Property k (toPropertyValue v)) : ps
put $ G.Property k (toPropertyValue v) : ps
class IsPropertyValue v where
toPropertyValue :: v -> G.PropertyValue