nek0/pituicat
2
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

some linting

Browse source
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
Show stats Download patch file Download diff file Expand all files Collapse all files

2
examples/example00.hs
View file

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

16
examples/example01.hs
View file

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

12
examples/example02.hs
View file

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

149
examples/example03.hs
View file

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

18
src/Affection.hs
View file

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

54
src/Affection/Draw.hs
View file

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

4
src/Affection/Property.hs
View file

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