haskelloids/src/Main.hs
2016-12-28 14:17:37 +01:00

336 lines
11 KiB
Haskell

{-# LANGUAGE OverloadedStrings, RecordWildCards #-}
module Main where
import Affection
import qualified SDL
import GEGL
import BABL
import qualified Data.Map as M
import Control.Monad (when)
import System.Random (randomRIO)
import Debug.Trace
main :: IO ()
main = withAffection $ AffectionConfig
{ initComponents = All
, windowTitle = "Haskelloids"
, windowConfig = defaultWindow
, preLoop = return ()
, drawLoop = draw
, updateLoop = update
, loadState = load
, cleanUp = clean
}
load :: SDL.Surface -> IO UserData
load _ = do
traceM "loading"
root <- gegl_node_new
traceM "root node"
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" []
sover <- gegl_node_new_child root $ defaultOverOperation
hover <- gegl_node_new_child root $ defaultOverOperation
pover <- gegl_node_new_child root $ defaultOverOperation
translate <- gegl_node_new_child root $ Operation "gegl:translate"
[ Property "origin-x" $ PropertyDouble 25
, Property "origin-y" $ PropertyDouble 25
, Property "x" $ PropertyDouble 400
, Property "y" $ PropertyDouble 300
, 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
]
gegl_node_link_many [ship, rotate, translate]
gegl_node_link_many [pover, hover, sover, crop, 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"
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)
]
hs <- mapM (\_ -> do
px <- liftIO $ randomRIO (0, 800)
py <- liftIO $ randomRIO (0, 600)
vx <- liftIO $ randomRIO (0, 5)
vy <- liftIO $ randomRIO (0, 5)
div <- liftIO $ randomRIO (1, 2)
tempRoot <- liftIO $ gegl_node_new
tempOver <- liftIO $ gegl_node_new_child tempRoot $ defaultOverOperation
tempText <- liftIO $ gegl_node_new_child tempRoot $ textOperation
[ Property "string" $ PropertyString "λ"
, Property "color" $ PropertyColor $ GEGL.RGBA 1 1 1 1
, Property "size" $ PropertyDouble 40
]
liftIO $ gegl_node_connect_to tempText "output" tempOver "aux"
return Haskelloid
{ hPos = (px, py)
, hVel = (vx, vy)
, hDiv = div
, hFlange = tempOver
, hNodeGraph = M.fromList
[ ("root", tempRoot)
, ("over", tempOver)
, ("text", tempText)
]
}
) [1..5]
liftIO $ gegl_node_link_many $ map hFlange hs
liftIO $ gegl_node_link (last $ map hFlange hs) hnop
return $ UserData
{ nodeGraph = myMap
, ship = Ship
{ sPos = (400, 300)
, sVel = (0, 0)
, sRot = 0
, sFlange = rotate
}
, buffer = buffer
, shots = ParticleSystem (ParticleStorage Nothing []) pnop buffer
, haskelloids = hs
}
data UserData = UserData
{ nodeGraph :: M.Map NodeKey GeglNode
, ship :: Ship
, buffer :: GeglBuffer
, haskelloids :: [Haskelloid]
, shots :: ParticleSystem
-- , debris :: ParticleSystem
}
data Ship = Ship
{ sPos :: (Double, Double)
, sVel :: (Double, Double)
, sRot :: Double
, sFlange :: GeglNode
}
data Haskelloid = Haskelloid
{ hPos :: (Double, Double)
, hVel :: (Double, Double)
, hDiv :: Int
, hFlange :: GeglNode
, hNodeGraph :: M.Map String GeglNode
}
data NodeKey
= KeyRoot
| KeyTranslate
| KeyRotate
| KeyShip
| KeyPNop
| KeyHNop
| KeyCrop
| KeyShipOver
| KeySink
deriving (Ord, Eq)
update :: Double -> Affection UserData ()
update sec = do
-- traceM $ (show $ 1 / sec) ++ " FPS"
ad <- get
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) $
putAffection ud
{ ship = (ship ud)
{ sRot = (sRot $ ship ud) + 180 * sec
}
}
SDL.KeycodeRight -> do
ud <- getAffection
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $
putAffection ud
{ ship = (ship ud)
{ sRot = (sRot $ ship ud) - 180 * sec
}
}
SDL.KeycodeUp ->
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $ do
ud <- getAffection
-- let vx = -10 * (sin (toR $ 2 * (sRot $ ship ud))) + fst (sVel $ ship ud)
-- vy = -10 * (cos (toR $ 2 * (sRot $ ship ud))) + snd (sVel $ ship ud)
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 ((*) 2 $ sRot $ ship ud)
SDL.KeycodeSpace ->
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $ do
ud <- getAffection
ad <- get
tempRoot <- liftIO $ gegl_node_new
tempRect <- liftIO $ gegl_node_new_child tempRoot $ Operation "gegl:rectangle"
[ Property "x" $ (PropertyDouble $ (fst $ sPos $ ship ud) + 23)
, Property "y" $ (PropertyDouble $ (snd $ sPos $ ship ud) + 23)
, 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 = 10
, particleCreation = elapsedTime ad
, particlePosition =
( (fst $ sPos $ ship ud) + 23
, (snd $ sPos $ ship ud) + 23
)
, 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
}
-- XXX: Continue here
_ -> return ()
SDL.WindowClosedEvent _ -> do
traceM "seeya!"
put ad
{ quitEvent = True
}
_ -> return ()
) evs
ud2 <- getAffection
let nx = fst (sPos $ ship ud2) + (fst (sVel $ ship ud2)) * sec
ny = snd (sPos $ ship ud2) + (snd (sVel $ ship ud2)) * sec
-- nnx =
-- if nx > 800
-- then nx - 850
-- else if nx < -50 then nx + 850 else nx
-- nny =
-- if ny > 600
-- then ny - 650
-- else if ny < -50 then ny + 650 else ny
(nnx, nny) = wrapAround (nx, ny) 50
liftIO $ gegl_node_set (nodeGraph ud2 M.! KeyTranslate) $ Operation "gegl:translate"
[ Property "x" $ PropertyDouble $ nnx
, Property "y" $ PropertyDouble $ nny
]
liftIO $ gegl_node_set (nodeGraph ud2 M.! KeyRotate) $ Operation "gegl:rotate"
[ Property "degrees" $ PropertyDouble $ sRot $ ship ud2
]
ups <- updateParticleSystem (shots ud2) sec shotsUpd shotsDraw
nhs <- mapM (updateHaskelloid sec) (haskelloids ud2)
putAffection ud2
{ ship = (ship ud2)
{ sPos = (nnx, nny)
}
, shots = ups
, haskelloids = nhs
}
wrapAround (nx, ny) width = (nnx, nny)
where
nnx =
if nx > 800
then nx - (800 + width)
else if nx < -width then nx + 800 + width else nx
nny =
if ny > 600
then ny - (600 + width)
else if ny < -width then ny + 600 + width else ny
draw :: Affection UserData ()
draw = do
traceM "drawing"
ud <- getAffection
liftIO $ gegl_node_process $ nodeGraph ud M.! KeySink
-- mintr <- liftIO $ gegl_rectangle_intersect
-- (GeglRectangle 0 0 800 600)
-- (GeglRectangle (floor $ fst $ sPos $ ship ud) (floor $ snd $ sPos $ ship ud) 50 50)
-- maybe (return ()) (\intr ->
-- present
-- (GeglRectangle (floor $ fst $ sPos $ ship ud) (floor $ snd $ sPos $ ship ud) 50 50)
-- (buffer ud)
-- False
-- ) mintr
-- XXX: above part crashes regularly for no apparent reason
present
(GeglRectangle 0 0 800 600)
(buffer ud)
False
clean :: UserData -> IO ()
clean ud = return ()
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)
newY = (snd particlePosition) + sec * (fromIntegral $ snd particleVelocity)
(nnx, nny) = wrapAround (newX, newY) 2
liftIO $ gegl_node_set (particleNodeGraph M.! "rect") $ Operation "gegl:rectangle"
[ Property "x" $ (PropertyDouble $ nnx - 2)
, Property "y" $ (PropertyDouble $ nny - 2)
]
return part
{ particlePosition = (nnx, nny)
}
shotsDraw :: GeglBuffer -> GeglNode -> Particle -> Affection UserData ()
shotsDraw buf node Particle{..} = do
-- present
-- (GeglRectangle (floor $ fst particlePosition - 2) (floor $ snd particlePosition - 2) 4 4)
-- buf
-- False
return ()
updateHaskelloid :: Double -> Haskelloid -> Affection UserData Haskelloid
updateHaskelloid sec h@Haskelloid{..} = return h