splitting things up

This commit is contained in:
nek0 2016-12-31 17:01:24 +01:00
parent 3a1d7e990a
commit a503b2cb75
5 changed files with 372 additions and 326 deletions

View file

@ -53,7 +53,9 @@ executable haskelloids
ghc-options: -Wall
-- Modules included in this executable, other than Main.
-- other-modules:
other-modules: InGame
, Types
, Commons
-- LANGUAGE extensions used by modules in this package.
-- other-extensions:

192
src/Commons.hs Normal file
View file

@ -0,0 +1,192 @@
module Commons where
import Affection
import qualified SDL
import GEGL
import BABL
import qualified Data.Map as M
import Data.Maybe (catMaybes)
import Control.Monad (foldM)
import System.Random (randomRIO)
import Debug.Trace
import Types
toR :: Double -> Double
toR deg = deg * pi / 180
clean :: UserData -> IO ()
clean ud = do
mapM_ gegl_node_drop $ map (\h -> hNodeGraph h M.! "root") (haskelloids ud)
gegl_node_drop $ nodeGraph ud M.! KeyRoot
load :: SDL.Surface -> IO UserData
load _ = do
traceM "loading"
root <- gegl_node_new
traceM "root node"
bg <- gegl_node_new_child root $ Operation "gegl:rectangle"
[ Property "x" $ PropertyDouble 0
, Property "y" $ PropertyDouble 0
, Property "width" $ PropertyDouble 800
, Property "height" $ PropertyDouble 600
, Property "color" $ PropertyColor $ GEGL.RGBA 0 0 0.1 1
]
ship <- gegl_node_new_child root $ Operation "gegl:svg-load"
[ Property "path" $ PropertyString "assets/ship.svg"
, Property "width" $ PropertyInt 50
, Property "height" $ PropertyInt 50
]
pnop <- gegl_node_new_child root $ Operation "gegl:nop" []
hnop <- gegl_node_new_child root $ Operation "gegl:nop" []
fgnop <- gegl_node_new_child root $ Operation "gegl:nop" []
sover <- gegl_node_new_child root $ defaultOverOperation
hover <- gegl_node_new_child root $ defaultOverOperation
pover <- gegl_node_new_child root $ defaultOverOperation
bgover <- gegl_node_new_child root $ defaultOverOperation
fgover <- gegl_node_new_child root $ defaultOverOperation
translate <- gegl_node_new_child root $ Operation "gegl:translate"
[ Property "x" $ PropertyDouble 375
, Property "y" $ PropertyDouble 275
, Property "sampler" $ PropertyInt $ fromEnum GeglSamplerCubic
]
fgtranslate <- gegl_node_new_child root $ Operation "gegl:translate"
[ Property "x" $ PropertyDouble 150
, Property "y" $ PropertyDouble 250
, Property "sampler" $ PropertyInt $ fromEnum GeglSamplerCubic
]
rotate <- gegl_node_new_child root $ Operation "gegl:rotate"
[ Property "origin-x" $ PropertyDouble 25
, Property "origin-y" $ PropertyDouble 25
, Property "sampler" $ PropertyInt $ fromEnum GeglSamplerCubic
]
crop <- gegl_node_new_child root $ Operation "gegl:crop"
[ Property "width" $ PropertyDouble 800
, Property "height" $ PropertyDouble 600
]
buffer <- gegl_buffer_new (Just $ GeglRectangle 0 0 800 600) =<<
babl_format (PixelFormat BABL.RGBA CFfloat)
sink <- gegl_node_new_child root $ Operation "gegl:copy-buffer"
[ Property "buffer" $ PropertyBuffer buffer
]
won <- gegl_node_new_child root $ textOperation
[ Property "string" $ PropertyString "YOU WON!"
, Property "font" $ PropertyString "Modulo"
, Property "size" $ PropertyDouble 100
, Property "color" $ PropertyColor $ GEGL.RGBA 1 1 1 1
]
lost <- gegl_node_new_child root $ textOperation
[ Property "string" $ PropertyString "YOU LOST!"
, Property "font" $ PropertyString "Modulo"
, Property "size" $ PropertyDouble 100
, Property "color" $ PropertyColor $ GEGL.RGBA 1 1 1 1
]
vignette <- gegl_node_new_child root $ Operation "gegl:vignette" []
-- pixelize <- gegl_node_new_child root $ Operation "gegl:pixelize"
pixelize <- gegl_node_new_child root $ Operation "gegl:pixelize"
[ Property "size-x" $ PropertyInt 3
, Property "size-y" $ PropertyInt 3
]
-- vdeg <- gegl_node_new_child root $ Operation "gegl:video-degradation"
-- [ Property "pattern" $ PropertyInt 8
-- ]
gegl_node_link_many [ship, rotate, translate]
gegl_node_link_many [bgover, pover, hover, sover, crop, fgover, pixelize, vignette, sink]
_ <- gegl_node_connect_to translate "output" sover "aux"
_ <- gegl_node_connect_to pnop "output" pover "aux"
_ <- gegl_node_connect_to hnop "output" hover "aux"
_ <- gegl_node_connect_to bg "output" bgover "aux"
liftIO $ gegl_node_link fgnop fgtranslate
_ <- gegl_node_connect_to fgtranslate "output" fgover "aux"
traceM "nodes complete"
myMap <- return $ M.fromList
[ (KeyRoot, root)
, (KeyTranslate, translate)
, (KeyRotate, rotate)
, (KeyShip, ship)
, (KeyPNop, pnop)
, (KeyHNop, hnop)
, (KeyCrop, crop)
, (KeyShipOver, sover)
, (KeySink, sink)
, (KeyWon, won)
, (KeyLost, lost)
, (KeyPixelize, pixelize)
, (KeyFGOver, fgover)
, (KeyFGNop, fgnop)
]
hs <- catMaybes <$> foldM (\acc _ -> do
px <- liftIO $ randomRIO (0, 800)
py <- liftIO $ randomRIO (0, 600)
insertHaskelloid acc Nothing (px, py)
) [] ([0..9] :: [Int])
liftIO $ gegl_node_link_many $ map hFlange hs
liftIO $ gegl_node_link (last $ map hFlange hs) hnop
return $ UserData
{ nodeGraph = myMap
, ship = Ship
{ sPos = (375, 275)
, sVel = (0, 0)
, sRot = 0
, sFlange = rotate
}
, buffer = buffer
, shots = ParticleSystem (ParticleStorage Nothing []) pnop buffer
, haskelloids = hs
, wonlost = False
, pixelSize = 3
, state = InGame
}
insertHaskelloid :: [Maybe Haskelloid] -> Maybe Int -> (Double, Double) -> IO [Maybe Haskelloid]
insertHaskelloid hasks split (px, py) = do
-- liftIO $ traceIO "inserting haskelloid"
vx <- liftIO $ randomRIO (-10, 10)
vy <- liftIO $ randomRIO (-10, 10)
rdiv <- case split of
Nothing -> liftIO $ randomRIO (1, 2)
Just x -> return $ x + 1
rot <- liftIO $ randomRIO (0, 360)
pitch <- liftIO $ randomRIO (-45, 45)
tempRoot <- liftIO $ gegl_node_new
tempOver <- liftIO $ gegl_node_new_child tempRoot $ defaultOverOperation
tempSvg <- gegl_node_new_child tempRoot $ Operation "gegl:svg-load"
[ Property "path" $ PropertyString "assets/haskelloid.svg"
, Property "width" $ PropertyInt (100 `div` rdiv)
, Property "height" $ PropertyInt (100 `div` rdiv)
]
tempTrans <- liftIO $ gegl_node_new_child tempRoot $ Operation "gegl:translate"
[ Property "x" $ PropertyDouble $ px + (100 / fromIntegral rdiv / 2)
, Property "y" $ PropertyDouble $ py + (100 / fromIntegral rdiv / 2)
, Property "sampler" $ PropertyInt $ fromEnum GeglSamplerCubic
]
tempRot <- liftIO $ gegl_node_new_child tempRoot $ Operation "gegl:rotate"
[ Property "origin-x" $ PropertyDouble (100 / 2 / fromIntegral rdiv)
, Property "origin-y" $ PropertyDouble (100 / 2 / fromIntegral rdiv)
, Property "degrees" $ PropertyDouble rot
, Property "sampler" $ PropertyInt $ fromEnum GeglSamplerCubic
]
liftIO $ gegl_node_link_many [tempSvg, tempRot, tempTrans]
_ <- liftIO $ gegl_node_connect_to tempTrans "output" tempOver "aux"
return $ Just Haskelloid
{ hPos =
( px + (100 / 2 / fromIntegral rdiv)
, py + (100 / 2 / fromIntegral rdiv)
)
, hVel = (vx, vy)
, hRot = rot
, hPitch = pitch
, hDiv = rdiv
, hFlange = tempOver
, hNodeGraph = M.fromList
[ ("root", tempRoot)
, ("over", tempOver)
, ("svg", tempSvg)
, ("trans", tempTrans)
, ("rot", tempRot)
]
} : hasks

108
src/InGame.hs Normal file
View file

@ -0,0 +1,108 @@
module InGame where
import Affection
import qualified SDL
import GEGL
import qualified Data.Map as M
import Control.Monad (when)
import Debug.Trace
import Types
import Commons
handleGameEvent :: Double -> SDL.Event -> Affection UserData ()
handleGameEvent sec e = do
ad <- get
wd <- getAffection
case SDL.eventPayload e of
SDL.KeyboardEvent dat ->
case (SDL.keysymKeycode $ SDL.keyboardEventKeysym dat) of
SDL.KeycodeLeft -> do
ud <- getAffection
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed && not (wonlost ud)) $
putAffection ud
{ ship = (ship ud)
{ sRot = (sRot $ ship ud) + 270 * sec
}
}
SDL.KeycodeRight -> do
ud <- getAffection
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $
putAffection ud
{ ship = (ship ud)
{ sRot = (sRot $ ship ud) - 270 * sec
}
}
SDL.KeycodeUp ->
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed && not (wonlost wd)) $ do
ud <- getAffection
let vx = -10 * (sin (toR $ (sRot $ ship ud))) + fst (sVel $ ship ud)
vy = -10 * (cos (toR $ (sRot $ ship ud))) + snd (sVel $ ship ud)
putAffection ud
{ ship = (ship ud)
{ sVel = (vx, vy)
}
}
-- traceM $ show (vx, vy) ++ " " ++ show (sRot $ ship ud)
SDL.KeycodeSpace ->
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed && not (wonlost wd)) $ do
ud <- getAffection
liftIO $ gegl_node_set (nodeGraph ud M.! KeyPixelize) $ Operation "gegl:pixelize"
[ Property "size-x" $ PropertyInt 8
, Property "size-y" $ PropertyInt 8
]
-- ad <- get
let posX = (fst $ sPos $ ship ud) + 23 - 35 * sin (toR $ sRot $ ship ud)
posY = (snd $ sPos $ ship ud) + 23 - 35 * cos (toR $ sRot $ ship ud)
tempRoot <- liftIO $ gegl_node_new
tempRect <- liftIO $ gegl_node_new_child tempRoot $ Operation "gegl:rectangle"
[ Property "x" $ PropertyDouble $ posX
, Property "y" $ PropertyDouble $ posY
, Property "width" $ PropertyDouble 4
, Property "height" $ PropertyDouble 4
, Property "color" $ PropertyColor $ (GEGL.RGBA 1 1 1 1)
]
tempOver <- liftIO $ gegl_node_new_child tempRoot $ defaultOverOperation
_ <- liftIO $ gegl_node_connect_to tempRect "output" tempOver "aux"
ips <- insertParticle (shots ud) $
Particle
{ particleTimeToLive = 5
, particleCreation = elapsedTime ad
, particlePosition = (posX, posY)
, particleRotation = Rad 0
, particleVelocity =
-- ( (floor $ -200 * (sin $ toR $ (sRot $ ship ud) + (fst $ sVel $ ship ud)))
-- , (floor $ -200 * (cos $ toR $ (sRot $ ship ud) + (snd $ sVel $ ship ud)))
( (floor $ -200 * (sin $ toR $ sRot $ ship ud))
, (floor $ -200 * (cos $ toR $ sRot $ ship ud))
)
, particlePitchRate = Rad 0
, particleRootNode = tempRoot
, particleNodeGraph = M.fromList
[ ("root", tempRoot)
, ("over", tempOver)
, ("rect", tempRect)
]
, particleStackCont = tempOver
, particleDrawFlange = tempOver
}
putAffection $ ud
{ shots = ips
, pixelSize = 8
}
SDL.KeycodeR ->
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $ do
liftIO $ traceIO "reloading"
liftIO $ clean wd
nd <- liftIO $ load $ drawSurface ad
putAffection nd
_ -> return ()
SDL.WindowClosedEvent _ -> do
traceM "seeya!"
put ad
{ quitEvent = True
}
_ -> return ()

View file

@ -4,7 +4,6 @@ module Main where
import Affection
import qualified SDL
import GEGL
import BABL
import Data.List (delete)
import qualified Data.Map as M
@ -12,10 +11,14 @@ import Data.Maybe (catMaybes)
import Control.Monad (when, foldM)
import System.Random (randomRIO)
import Debug.Trace
-- internal imports
import Types
import InGame
import Commons
main :: IO ()
main = withAffection $ AffectionConfig
{ initComponents = All
@ -28,173 +31,10 @@ main = withAffection $ AffectionConfig
, cleanUp = clean
}
load :: SDL.Surface -> IO UserData
load _ = do
traceM "loading"
root <- gegl_node_new
traceM "root node"
bg <- gegl_node_new_child root $ Operation "gegl:rectangle"
[ Property "x" $ PropertyDouble 0
, Property "y" $ PropertyDouble 0
, Property "width" $ PropertyDouble 800
, Property "height" $ PropertyDouble 600
, Property "color" $ PropertyColor $ GEGL.RGBA 0 0 0.1 1
]
ship <- gegl_node_new_child root $ Operation "gegl:svg-load"
[ Property "path" $ PropertyString "assets/ship.svg"
, Property "width" $ PropertyInt 50
, Property "height" $ PropertyInt 50
]
pnop <- gegl_node_new_child root $ Operation "gegl:nop" []
hnop <- gegl_node_new_child root $ Operation "gegl:nop" []
fgnop <- gegl_node_new_child root $ Operation "gegl:nop" []
sover <- gegl_node_new_child root $ defaultOverOperation
hover <- gegl_node_new_child root $ defaultOverOperation
pover <- gegl_node_new_child root $ defaultOverOperation
bgover <- gegl_node_new_child root $ defaultOverOperation
fgover <- gegl_node_new_child root $ defaultOverOperation
translate <- gegl_node_new_child root $ Operation "gegl:translate"
[ Property "x" $ PropertyDouble 375
, Property "y" $ PropertyDouble 275
, Property "sampler" $ PropertyInt $ fromEnum GeglSamplerCubic
]
fgtranslate <- gegl_node_new_child root $ Operation "gegl:translate"
[ Property "x" $ PropertyDouble 150
, Property "y" $ PropertyDouble 250
, Property "sampler" $ PropertyInt $ fromEnum GeglSamplerCubic
]
rotate <- gegl_node_new_child root $ Operation "gegl:rotate"
[ Property "origin-x" $ PropertyDouble 25
, Property "origin-y" $ PropertyDouble 25
, Property "sampler" $ PropertyInt $ fromEnum GeglSamplerCubic
]
crop <- gegl_node_new_child root $ Operation "gegl:crop"
[ Property "width" $ PropertyDouble 800
, Property "height" $ PropertyDouble 600
]
buffer <- gegl_buffer_new (Just $ GeglRectangle 0 0 800 600) =<<
babl_format (PixelFormat BABL.RGBA CFfloat)
sink <- gegl_node_new_child root $ Operation "gegl:copy-buffer"
[ Property "buffer" $ PropertyBuffer buffer
]
won <- gegl_node_new_child root $ textOperation
[ Property "string" $ PropertyString "YOU WON!"
, Property "font" $ PropertyString "Modulo"
, Property "size" $ PropertyDouble 100
, Property "color" $ PropertyColor $ GEGL.RGBA 1 1 1 1
]
lost <- gegl_node_new_child root $ textOperation
[ Property "string" $ PropertyString "YOU LOST!"
, Property "font" $ PropertyString "Modulo"
, Property "size" $ PropertyDouble 100
, Property "color" $ PropertyColor $ GEGL.RGBA 1 1 1 1
]
vignette <- gegl_node_new_child root $ Operation "gegl:vignette" []
-- pixelize <- gegl_node_new_child root $ Operation "gegl:pixelize"
pixelize <- gegl_node_new_child root $ Operation "gegl:pixelize"
[ Property "size-x" $ PropertyInt 3
, Property "size-y" $ PropertyInt 3
]
-- vdeg <- gegl_node_new_child root $ Operation "gegl:video-degradation"
-- [ Property "pattern" $ PropertyInt 8
-- ]
gegl_node_link_many [ship, rotate, translate]
gegl_node_link_many [bgover, pover, hover, sover, crop, fgover, pixelize, vignette, sink]
_ <- gegl_node_connect_to translate "output" sover "aux"
_ <- gegl_node_connect_to pnop "output" pover "aux"
_ <- gegl_node_connect_to hnop "output" hover "aux"
_ <- gegl_node_connect_to bg "output" bgover "aux"
liftIO $ gegl_node_link fgnop fgtranslate
_ <- gegl_node_connect_to fgtranslate "output" fgover "aux"
traceM "nodes complete"
myMap <- return $ M.fromList
[ (KeyRoot, root)
, (KeyTranslate, translate)
, (KeyRotate, rotate)
, (KeyShip, ship)
, (KeyPNop, pnop)
, (KeyHNop, hnop)
, (KeyCrop, crop)
, (KeyShipOver, sover)
, (KeySink, sink)
, (KeyWon, won)
, (KeyLost, lost)
, (KeyPixelize, pixelize)
, (KeyFGOver, fgover)
, (KeyFGNop, fgnop)
]
hs <- catMaybes <$> foldM (\acc _ -> do
px <- liftIO $ randomRIO (0, 800)
py <- liftIO $ randomRIO (0, 600)
insertHaskelloid acc Nothing (px, py)
) [] ([0..9] :: [Int])
liftIO $ gegl_node_link_many $ map hFlange hs
liftIO $ gegl_node_link (last $ map hFlange hs) hnop
return $ UserData
{ nodeGraph = myMap
, ship = Ship
{ sPos = (375, 275)
, sVel = (0, 0)
, sRot = 0
, sFlange = rotate
}
, buffer = buffer
, shots = ParticleSystem (ParticleStorage Nothing []) pnop buffer
, haskelloids = hs
, wonlost = False
, pixelSize = 3
}
data UserData = UserData
{ nodeGraph :: M.Map NodeKey GeglNode
, ship :: Ship
, buffer :: GeglBuffer
, haskelloids :: [Haskelloid]
, shots :: ParticleSystem
-- , debris :: ParticleSystem
, wonlost :: Bool
, pixelSize :: Int
}
data Ship = Ship
{ sPos :: (Double, Double)
, sVel :: (Double, Double)
, sRot :: Double
, sFlange :: GeglNode
}
data Haskelloid = Haskelloid
{ hPos :: (Double, Double)
, hVel :: (Double, Double)
, hRot :: Double
, hPitch :: Double
, hDiv :: Int
, hFlange :: GeglNode
, hNodeGraph :: M.Map String GeglNode
} deriving (Eq)
data NodeKey
= KeyRoot
| KeyTranslate
| KeyRotate
| KeyShip
| KeyPNop
| KeyHNop
| KeyCrop
| KeyShipOver
| KeySink
| KeyWon
| KeyLost
| KeyPixelize
| KeyFGOver
| KeyFGNop
deriving (Ord, Eq)
update :: Double -> Affection UserData ()
update sec = do
-- traceM $ (show $ 1 / sec) ++ " FPS"
ad <- get
evs <- SDL.pollEvents
wd <- getAffection
when (((floor $ elapsedTime ad :: Int) * 100) `mod` 10 < 2 && pixelSize wd > 3) $ do
liftIO $ gegl_node_set (nodeGraph wd M.! KeyPixelize) $ Operation "gegl:pixelize"
@ -205,90 +45,12 @@ update sec = do
putAffection pd
{ pixelSize = pixelSize wd -1
}
evs <- SDL.pollEvents
mapM_ (\e ->
case SDL.eventPayload e of
SDL.KeyboardEvent dat ->
case (SDL.keysymKeycode $ SDL.keyboardEventKeysym dat) of
SDL.KeycodeLeft -> do
ud <- getAffection
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed && not (wonlost wd)) $
putAffection ud
{ ship = (ship ud)
{ sRot = (sRot $ ship ud) + 270 * sec
}
}
SDL.KeycodeRight -> do
ud <- getAffection
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $
putAffection ud
{ ship = (ship ud)
{ sRot = (sRot $ ship ud) - 270 * sec
}
}
SDL.KeycodeUp ->
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed && not (wonlost wd)) $ do
ud <- getAffection
let vx = -10 * (sin (toR $ (sRot $ ship ud))) + fst (sVel $ ship ud)
vy = -10 * (cos (toR $ (sRot $ ship ud))) + snd (sVel $ ship ud)
putAffection ud
{ ship = (ship ud)
{ sVel = (vx, vy)
}
}
-- traceM $ show (vx, vy) ++ " " ++ show (sRot $ ship ud)
SDL.KeycodeSpace ->
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed && not (wonlost wd)) $ do
ud <- getAffection
liftIO $ gegl_node_set (nodeGraph ud M.! KeyPixelize) $ Operation "gegl:pixelize"
[ Property "size-x" $ PropertyInt 8
, Property "size-y" $ PropertyInt 8
]
-- ad <- get
let posX = (fst $ sPos $ ship ud) + 23 - 35 * sin (toR $ sRot $ ship ud)
posY = (snd $ sPos $ ship ud) + 23 - 35 * cos (toR $ sRot $ ship ud)
tempRoot <- liftIO $ gegl_node_new
tempRect <- liftIO $ gegl_node_new_child tempRoot $ Operation "gegl:rectangle"
[ Property "x" $ PropertyDouble $ posX
, Property "y" $ PropertyDouble $ posY
, Property "width" $ PropertyDouble 4
, Property "height" $ PropertyDouble 4
, Property "color" $ PropertyColor $ (GEGL.RGBA 1 1 1 1)
]
tempOver <- liftIO $ gegl_node_new_child tempRoot $ defaultOverOperation
_ <- liftIO $ gegl_node_connect_to tempRect "output" tempOver "aux"
ips <- insertParticle (shots ud) $
Particle
{ particleTimeToLive = 5
, particleCreation = elapsedTime ad
, particlePosition = (posX, posY)
, particleRotation = Rad 0
, particleVelocity =
-- ( (floor $ -200 * (sin $ toR $ (sRot $ ship ud) + (fst $ sVel $ ship ud)))
-- , (floor $ -200 * (cos $ toR $ (sRot $ ship ud) + (snd $ sVel $ ship ud)))
( (floor $ -200 * (sin $ toR $ sRot $ ship ud))
, (floor $ -200 * (cos $ toR $ sRot $ ship ud))
)
, particlePitchRate = Rad 0
, particleRootNode = tempRoot
, particleNodeGraph = M.fromList
[ ("root", tempRoot)
, ("over", tempOver)
, ("rect", tempRect)
]
, particleStackCont = tempOver
, particleDrawFlange = tempOver
}
putAffection $ ud
{ shots = ips
, pixelSize = 8
}
_ -> return ()
SDL.WindowClosedEvent _ -> do
traceM "seeya!"
put ad
{ quitEvent = True
}
_ -> return ()
case state wd of
InGame ->
handleGameEvent sec e
_ -> error "not yet implemented"
) evs
ud2 <- getAffection
nhs <- mapM (updateHaskelloid sec) (haskelloids ud2)
@ -330,7 +92,6 @@ wrapAround (nx, ny) width = (nnx, nny)
draw :: Affection UserData ()
draw = do
-- traceM "drawing"
ud <- getAffection
liftIO $ gegl_node_process $ nodeGraph ud M.! KeySink
-- mintr <- liftIO $ gegl_rectangle_intersect
@ -346,15 +107,8 @@ draw = do
present
(GeglRectangle 0 0 800 600)
(buffer ud)
-- (not $ wonlost ud)
True
clean :: UserData -> IO ()
clean ud = gegl_node_drop $ nodeGraph ud M.! KeyRoot
toR :: Double -> Double
toR deg = deg * pi / 180
shotsUpd :: Double -> Particle -> Affection UserData Particle
shotsUpd sec part@Particle{..} = do
let newX = (fst particlePosition) + sec * (fromIntegral $ fst particleVelocity)
@ -398,27 +152,9 @@ shotsUpd sec part@Particle{..} = do
haskelloidShotDown :: Haskelloid -> Affection UserData ()
haskelloidShotDown h = do
-- liftIO $ traceIO "Haskelloid shot down"
liftIO $ gegl_node_drop $ hNodeGraph h M.! "root"
ud <- getAffection
let redHaskelloids = delete h (haskelloids ud)
-- mproducer <- liftIO $ gegl_node_get_producer
-- (hFlange h)
-- "input"
-- case mproducer of
-- Just (prod, padname) -> do
-- consumers <- liftIO $ gegl_node_get_consumers
-- (hFlange h)
-- "output"
-- liftIO $ mapM_ (\(node, inpad) -> do
-- traceIO "klink"
-- gegl_node_connect_to
-- prod
-- padname
-- node
-- inpad
-- ) consumers
-- Nothing -> return ()
liftIO $ gegl_node_drop $ hNodeGraph h M.! "root"
newHaskelloids <- catMaybes <$> foldM
(\acc _ ->
@ -429,7 +165,6 @@ haskelloidShotDown h = do
return $ Nothing : acc
)
(map Just redHaskelloids) ([0..1] :: [Int])
-- liftIO $ traceIO $ show $ length newHaskelloids
liftIO $ gegl_node_link_many $ map hFlange newHaskelloids
if not $ null newHaskelloids
then
@ -481,55 +216,6 @@ updateHaskelloid sec h@Haskelloid{..} = do
, hRot = newRot
}
insertHaskelloid :: [Maybe Haskelloid] -> Maybe Int -> (Double, Double) -> IO [Maybe Haskelloid]
insertHaskelloid hasks split (px, py) = do
-- liftIO $ traceIO "inserting haskelloid"
vx <- liftIO $ randomRIO (-10, 10)
vy <- liftIO $ randomRIO (-10, 10)
rdiv <- case split of
Nothing -> liftIO $ randomRIO (1, 2)
Just x -> return $ x + 1
rot <- liftIO $ randomRIO (0, 360)
pitch <- liftIO $ randomRIO (-45, 45)
tempRoot <- liftIO $ gegl_node_new
tempOver <- liftIO $ gegl_node_new_child tempRoot $ defaultOverOperation
tempSvg <- gegl_node_new_child tempRoot $ Operation "gegl:svg-load"
[ Property "path" $ PropertyString "assets/haskelloid.svg"
, Property "width" $ PropertyInt (100 `div` rdiv)
, Property "height" $ PropertyInt (100 `div` rdiv)
]
tempTrans <- liftIO $ gegl_node_new_child tempRoot $ Operation "gegl:translate"
[ Property "x" $ PropertyDouble $ px + (100 / fromIntegral rdiv / 2)
, Property "y" $ PropertyDouble $ py + (100 / fromIntegral rdiv / 2)
, Property "sampler" $ PropertyInt $ fromEnum GeglSamplerCubic
]
tempRot <- liftIO $ gegl_node_new_child tempRoot $ Operation "gegl:rotate"
[ Property "origin-x" $ PropertyDouble (100 / 2 / fromIntegral rdiv)
, Property "origin-y" $ PropertyDouble (100 / 2 / fromIntegral rdiv)
, Property "degrees" $ PropertyDouble rot
, Property "sampler" $ PropertyInt $ fromEnum GeglSamplerCubic
]
liftIO $ gegl_node_link_many [tempSvg, tempRot, tempTrans]
_ <- liftIO $ gegl_node_connect_to tempTrans "output" tempOver "aux"
return $ Just Haskelloid
{ hPos =
( px + (100 / 2 / fromIntegral rdiv)
, py + (100 / 2 / fromIntegral rdiv)
)
, hVel = (vx, vy)
, hRot = rot
, hPitch = pitch
, hDiv = rdiv
, hFlange = tempOver
, hNodeGraph = M.fromList
[ ("root", tempRoot)
, ("over", tempOver)
, ("svg", tempSvg)
, ("trans", tempTrans)
, ("rot", tempRot)
]
} : hasks
lose :: Affection UserData ()
lose = do
ud <- getAffection

58
src/Types.hs Normal file
View file

@ -0,0 +1,58 @@
module Types where
import Affection
import qualified SDL
import GEGL
import BABL
import qualified Data.Map as M
data UserData = UserData
{ nodeGraph :: M.Map NodeKey GeglNode
, ship :: Ship
, buffer :: GeglBuffer
, haskelloids :: [Haskelloid]
, shots :: ParticleSystem
-- , debris :: ParticleSystem
, wonlost :: Bool
, pixelSize :: Int
, state :: StateMachine
}
data Ship = Ship
{ sPos :: (Double, Double)
, sVel :: (Double, Double)
, sRot :: Double
, sFlange :: GeglNode
}
data Haskelloid = Haskelloid
{ hPos :: (Double, Double)
, hVel :: (Double, Double)
, hRot :: Double
, hPitch :: Double
, hDiv :: Int
, hFlange :: GeglNode
, hNodeGraph :: M.Map String GeglNode
} deriving (Eq)
data NodeKey
= KeyRoot
| KeyTranslate
| KeyRotate
| KeyShip
| KeyPNop
| KeyHNop
| KeyCrop
| KeyShipOver
| KeySink
| KeyWon
| KeyLost
| KeyPixelize
| KeyFGOver
| KeyFGNop
deriving (Ord, Eq)
data StateMachine
= Menu
| HighScore
| InGame