splitting things up
This commit is contained in:
nek0
parent
3a1d7e990a
commit
a503b2cb75
5 changed files with 372 additions and 326 deletions
|
|
@ -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
192
src/Commons.hs
Normal 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
108
src/InGame.hs
Normal 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 ()
|
||||
336
src/Main.hs
336
src/Main.hs
|
|
@ -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
58
src/Types.hs
Normal 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
|
||||
Loading…
Reference in a new issue