haskelloids/src/Commons.hs

385 lines
13 KiB
Haskell

{-# LANGUAGE RecordWildCards #-}
module Commons where
import Affection
import qualified SDL
import GEGL
import BABL
import qualified Data.Map as M
import Data.List (delete)
import Data.Maybe (catMaybes)
import Control.Monad (foldM, unless)
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 . (\h -> hNodeGraph h M.! "root")) (haskelloids ud)
gegl_node_drop $ nodeGraph ud M.! KeyRoot
load :: 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
]
shipNode <- 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
]
nbuffer <- 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 nbuffer
]
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"
[ Property "size-x" $ PropertyInt 3
, Property "size-y" $ PropertyInt 3
]
-- vdeg <- gegl_node_new_child root $ Operation "gegl:video-degradation"
-- [ Property "pattern" $ PropertyInt 8
-- ]
menuHeading <- gegl_node_new_child root $ textOperation
[ Property "string" $ PropertyString "Haskelloids"
, Property "font" $ PropertyString "Modulo"
, Property "size" $ PropertyDouble 100
, Property "color" $ PropertyColor $ GEGL.RGBA 1 1 1 1
]
menuText <- gegl_node_new_child root $ textOperation
[ Property "string" $ PropertyString "Press [Space] to start"
, Property "font" $ PropertyString "Modulo"
, Property "size" $ PropertyDouble 50
, Property "alignment" $ PropertyInt 1
, Property "color" $ PropertyColor $ GEGL.RGBA 1 1 1 1
]
menuTranslateHeading <- gegl_node_new_child root $ Operation "gegl:translate"
[ Property "x" $ PropertyDouble 150
, Property "y" $ PropertyDouble 100
, Property "sampler" $ PropertyInt $ fromEnum GeglSamplerCubic
]
menuTranslateText <- gegl_node_new_child root $ Operation "gegl:translate"
[ Property "x" $ PropertyDouble 130
, Property "y" $ PropertyDouble 300
, Property "sampler" $ PropertyInt $ fromEnum GeglSamplerCubic
]
menuOver <- gegl_node_new_child root defaultOverOperation
gegl_node_link menuHeading menuTranslateHeading
gegl_node_link_many [menuText, menuTranslateText, menuOver]
_ <- gegl_node_connect_to menuTranslateHeading "output" menuOver "aux"
gegl_node_link_many [shipNode, 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"
_ <- gegl_node_connect_to fgnop "output" fgover "aux"
traceM "nodes complete"
myMap <- return $ M.fromList
[ (KeyRoot, root)
, (KeyShip, shipNode)
, (KeyShipTranslate, translate)
, (KeyShipRotate, rotate)
, (KeyPNop, pnop)
, (KeyHNop, hnop)
, (KeyCrop, crop)
, (KeyShipOver, sover)
, (KeySink, sink)
, (KeyWon, won)
, (KeyLost, lost)
, (KeyPixelize, pixelize)
, (KeyFGOver, fgover)
, (KeyFGNop, fgnop)
, (KeyFGTrans, fgtranslate)
, (KeyMenuHeading, menuTranslateHeading)
, (KeyMenuText, menuText)
, (KeyMenuOver, menuOver)
]
traceM "built map"
hs <- catMaybes <$> foldM (\acc _ -> do
px <- liftIO $ randomRIO (0, 800)
py <- liftIO $ randomRIO (0, 600)
insertHaskelloid acc Nothing (px, py)
) [] ([0..9] :: [Int])
traceM "built haskelloids"
liftIO $ gegl_node_link_many $ map hFlange hs
liftIO $ gegl_node_link (last $ map hFlange hs) hnop
traceM "linking haskelloids and returning UserData"
return $ UserData
{ nodeGraph = myMap
, ship = Ship
{ sPos = (375, 275)
, sVel = (0, 0)
, sRot = 0
, sFlange = rotate
}
, buffer = nbuffer
, shots = ParticleSystem (ParticleStorage Nothing []) pnop nbuffer
-- , haskelloids = hs
, haskelloids = []
, wonlost = False
, pixelSize = 3
, state = Menu
, fade = FadeIn 1
}
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 ((-180) , 180)
pitch <- liftIO $ randomRIO ((-(pi/2)), pi/2)
tempRoot <- liftIO $ gegl_node_new
tempOver <- liftIO $ gegl_node_new_child tempRoot $ defaultOverOperation
tempSvg <- gegl_node_new_child tempRoot $ Operation "gegl:png-load"
[ Property "path" $ PropertyString "assets/haskelloid.png"
]
liftIO $ traceIO "svg loaded"
tempScale <- gegl_node_new_child tempRoot $ Operation "gegl:scale-size"
[ Property "sampler" $ PropertyInt $ fromEnum GeglSamplerCubic
, Property "x" $ PropertyDouble (100 / (fromIntegral rdiv) :: Double)
, Property "y" $ PropertyDouble (100 / (fromIntegral rdiv) :: Double)
]
liftIO $ traceIO "scaled"
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
]
liftIO $ traceIO "translated"
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 $ traceIO $ "rotated: " ++ show rot
liftIO $ gegl_node_link_many [tempSvg, tempScale, 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
haskelloidShotDown :: Haskelloid -> Affection UserData ()
haskelloidShotDown h = do
ud <- getAffection
-- liftIO $ traceIO $ show $ length $ haskelloids ud
let redHaskelloids = delete h (haskelloids ud)
newHaskelloids <- catMaybes <$> foldM
(\acc _ ->
if hDiv h < 4
then
liftIO $ insertHaskelloid acc (Just $ hDiv h) $ hPos h
else
return $ Nothing : acc
)
(map Just redHaskelloids) ([0..1] :: [Int])
liftIO $ gegl_node_drop $ hNodeGraph h M.! "root"
liftIO $ gegl_node_link_many $ map hFlange newHaskelloids
if not $ null newHaskelloids
then
liftIO $ gegl_node_link
(last $ map hFlange newHaskelloids)
(nodeGraph ud M.! KeyHNop)
else do
liftIO $ traceIO "YOU WON!"
_ <- liftIO $ gegl_node_link
(nodeGraph ud M.! KeyWon)
(nodeGraph ud M.! KeyFGTrans)
_ <- liftIO $ gegl_node_connect_to
(nodeGraph ud M.! KeyFGTrans)
"output"
(nodeGraph ud M.! KeyFGOver)
"aux"
_ <- liftIO $ gegl_node_disconnect (nodeGraph ud M.! KeyShipOver) "aux"
putAffection ud
{ wonlost = True
}
ud2 <- getAffection
putAffection ud2
{ haskelloids = newHaskelloids
}
updateHaskelloid :: Double -> Haskelloid -> Affection UserData Haskelloid
updateHaskelloid sec h@Haskelloid{..} = do
let newX = fst hPos + sec * fst hVel
newY = snd hPos + sec * snd hVel
newRot = hRot + hPitch * sec
(nnx, nny) = wrapAround (newX, newY) (100 / fromIntegral hDiv)
-- liftIO $ traceIO $ "moving to: " ++ show nnx ++ " " ++ show nny
liftIO $ gegl_node_set (hNodeGraph M.! "trans") $ Operation "gegl:translate"
[ Property "x" $ PropertyDouble nnx
, Property "y" $ PropertyDouble nny
]
liftIO $ gegl_node_set (hNodeGraph M.! "rot") $ Operation "gegl:rotate"
[ Property "degrees" $ PropertyDouble newRot
]
ud <- getAffection
lost <-
case state ud of
InGame -> liftIO $ gegl_rectangle_intersect
(GeglRectangle (floor nnx) (floor nny) (100 `div` hDiv) (100 `div` hDiv))
(GeglRectangle
(floor $ fst $ sPos $ ship ud)
(floor $ snd $ sPos $ ship ud)
50
50
)
_ -> return Nothing
maybe (return ()) (const $ do
lose
putAffection ud {wonlost = True}
) lost
return h
{ hPos = (nnx, nny)
, hRot = newRot
}
wrapAround :: (Ord t, Num t) => (t, t) -> t -> (t, t)
wrapAround (nx, ny) width = (nnx, nny)
where
nnx
| nx > 800 = nx - (800 + width)
| nx < -width = nx + 800 + width
| otherwise = nx
nny
| ny > 600 = ny - (600 + width)
| ny < -width = ny + 600 + width
| otherwise = ny
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) 4
liftIO $ gegl_node_set (particleNodeGraph M.! "rect") $ Operation "gegl:rectangle"
[ Property "x" $ PropertyDouble nnx
, Property "y" $ PropertyDouble nny
]
ud <- getAffection
inters <- catMaybes <$> mapM (\h -> do
col <- liftIO $ gegl_rectangle_intersect
(GeglRectangle (floor nnx) (floor nny) 4 4)
(GeglRectangle
(floor $ fst $ hPos h)
(floor $ snd $ hPos h)
(100 `div` hDiv h)
(100 `div` hDiv h)
)
case col of
Just _ -> return $ Just h
Nothing -> return Nothing
) (haskelloids ud)
unless (null inters) $
haskelloidShotDown $ head inters
lost <- liftIO $ gegl_rectangle_intersect
(GeglRectangle (floor nnx) (floor nny) 4 4)
(GeglRectangle
(floor $ fst $ sPos $ ship ud)
(floor $ snd $ sPos $ ship ud)
50
50
)
maybe (return ()) (const lose) lost
return part
{ particlePosition = (nnx, nny)
, particleTimeToLive = if not $ null inters then 0 else particleTimeToLive
}
shotsDraw :: GeglBuffer -> GeglNode -> Particle -> Affection UserData ()
shotsDraw _ _ _ = return ()
lose :: Affection UserData ()
lose = do
ud <- getAffection
liftIO $ traceIO "YOU LOST!"
_ <- liftIO $ gegl_node_link
(nodeGraph ud M.! KeyLost)
(nodeGraph ud M.! KeyFGTrans)
_ <- liftIO $ gegl_node_connect_to
(nodeGraph ud M.! KeyFGTrans)
"output"
(nodeGraph ud M.! KeyFGOver)
"aux"
_ <- liftIO $ gegl_node_disconnect (nodeGraph ud M.! KeyShipOver) "aux"
putAffection ud
{ wonlost = True
}