Merge pull request #1 from nek0/v2

V2 rewrite now merged to master
This commit is contained in:
rys ostrovid 2017-12-21 05:25:16 +01:00 committed by GitHub
commit 7634be434b
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
14 changed files with 807 additions and 541 deletions

5
.gitignore vendored
View file

@ -1,3 +1,8 @@
.cabal-sandbox/
cabal.sandbox.config
dist/
*.prof
*.aux
*.hp
*.ps
*.swp

BIN
assets/Modulo.ttf Normal file

Binary file not shown.

BIN
assets/haskelloid.png Normal file

Binary file not shown.

After

Width:  |  Height:  |  Size: 6.6 KiB

View file

@ -1,16 +1,80 @@
<?xml version="1.0" encoding="UTF-8"?>
<svg xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" width="481.8897pt" height="340.1574pt" viewBox="0 0 481.8897 340.1574" version="1.1">
<defs>
<clipPath id="clip1">
<path d="M 0 340.15625 L 481.890625 340.15625 L 481.890625 0 L 0 0 L 0 340.15625 Z M 0 340.15625 "/>
</clipPath>
</defs>
<g id="surface0">
<g clip-path="url(#clip1)" clip-rule="nonzero">
<path style=" stroke:none;fill-rule: nonzero; fill: rgb(40%,40%,40%); fill-opacity: 1;" d="M 0 340.15625 L 113.386719 170.078125 L 0 0 L 85.039062 0 L 198.425781 170.078125 L 85.039062 340.15625 L 0 340.15625 Z M 0 340.15625 "/>
<path style=" stroke:none;fill-rule: nonzero; fill: rgb(60%,60%,60%); fill-opacity: 1;" d="M 113.386719 340.15625 L 226.773438 170.078125 L 113.386719 0 L 198.425781 0 L 425.195312 340.15625 L 340.15625 340.15625 L 269.292969 233.859375 L 198.425781 340.15625 L 113.386719 340.15625 Z M 113.386719 340.15625 "/>
<path style=" stroke:none;fill-rule: nonzero; fill: rgb(40%,40%,40%); fill-opacity: 1;" d="M 387.402344 240.945312 L 349.609375 184.253906 L 481.890625 184.25 L 481.890625 240.945312 L 387.402344 240.945312 Z M 387.402344 240.945312 "/>
<path style=" stroke:none;fill-rule: nonzero; fill: rgb(40%,40%,40%); fill-opacity: 1;" d="M 330.710938 155.90625 L 292.914062 99.214844 L 481.890625 99.210938 L 481.890625 155.90625 L 330.710938 155.90625 Z M 330.710938 155.90625 "/>
</g>
</g>
</svg>
<?xml version="1.0" encoding="UTF-8" standalone="no"?>
<svg
xmlns:dc="http://purl.org/dc/elements/1.1/"
xmlns:cc="http://creativecommons.org/ns#"
xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
xmlns:svg="http://www.w3.org/2000/svg"
xmlns="http://www.w3.org/2000/svg"
xmlns:sodipodi="http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd"
xmlns:inkscape="http://www.inkscape.org/namespaces/inkscape"
width="481.8897pt"
height="340.1574pt"
viewBox="0 0 481.8897 340.1574"
version="1.1"
id="svg18"
sodipodi:docname="haskelloid.svg"
inkscape:export-filename="/home/nek0/workspace/Haskell/haskelloids/assets/haskelloid.png"
inkscape:export-xdpi="62"
inkscape:export-ydpi="62"
inkscape:version="0.92.2 (5c3e80d, 2017-08-06)">
<metadata
id="metadata22">
<rdf:RDF>
<cc:Work
rdf:about="">
<dc:format>image/svg+xml</dc:format>
<dc:type
rdf:resource="http://purl.org/dc/dcmitype/StillImage" />
</cc:Work>
</rdf:RDF>
</metadata>
<sodipodi:namedview
pagecolor="#ffffff"
bordercolor="#666666"
borderopacity="1"
objecttolerance="10"
gridtolerance="10"
guidetolerance="10"
inkscape:pageopacity="0"
inkscape:pageshadow="2"
inkscape:window-width="1598"
inkscape:window-height="820"
id="namedview20"
showgrid="false"
inkscape:zoom="0.52034733"
inkscape:cx="234.77911"
inkscape:cy="226.77161"
inkscape:window-x="0"
inkscape:window-y="26"
inkscape:window-maximized="1"
inkscape:current-layer="svg18" />
<defs
id="defs5">
<clipPath
id="clip1">
<path
d="M 0 340.15625 L 481.890625 340.15625 L 481.890625 0 L 0 0 L 0 340.15625 Z M 0 340.15625 "
id="path2" />
</clipPath>
</defs>
<path
style="clip-rule:nonzero;fill:#9e4e2e;fill-opacity:1;fill-rule:nonzero;stroke:none"
d="M 0,340.15625 113.38672,170.07812 0,0 H 85.039062 L 198.42578,170.07812 85.039062,340.15625 Z m 0,0"
id="path7"
inkscape:connector-curvature="0" />
<path
style="clip-rule:nonzero;fill:#d18161;fill-opacity:1;fill-rule:nonzero;stroke:none"
d="M 113.38672,340.15625 226.77344,170.07812 113.38672,0 h 85.03906 L 425.19531,340.15625 H 340.15625 L 269.29297,233.85937 198.42578,340.15625 Z m 0,0"
id="path9"
inkscape:connector-curvature="0" />
<path
style="clip-rule:nonzero;fill:#9e4e2e;fill-opacity:1;fill-rule:nonzero;stroke:none"
d="m 387.40234,240.94531 -37.79297,-56.6914 132.28125,-0.004 v 56.69531 z m 0,0"
id="path11"
inkscape:connector-curvature="0" />
<path
style="clip-rule:nonzero;fill:#9e4e2e;fill-opacity:1;fill-rule:nonzero;stroke:none"
d="m 330.71094,155.90625 -37.79688,-56.691406 188.97656,-0.0039 v 56.695316 z m 0,0"
id="path13"
inkscape:connector-curvature="0" />
</svg>

Before

Width:  |  Height:  |  Size: 1.4 KiB

After

Width:  |  Height:  |  Size: 2.8 KiB

BIN
assets/ship.png Normal file

Binary file not shown.

After

Width:  |  Height:  |  Size: 4.6 KiB

1
cabal.config Normal file
View file

@ -0,0 +1 @@
constraints: affection +debug

View file

@ -51,23 +51,31 @@ executable haskelloids
-- .hs or .lhs file containing the Main module.
main-is: Main.hs
ghc-options: -Wall
extra-libraries: GLEW
-- Modules included in this executable, other than Main.
other-modules: InGame
, Types
other-modules: Types
, Commons
, StateMachine
, Menu
, InGame
, Init
default-extensions: OverloadedStrings
-- LANGUAGE extensions used by modules in this package.
-- other-extensions:
-- Other library packages from which modules are imported.
build-depends: base >=4.9 && <4.11
, affection
, gegl
, babl
, sdl2
, affection <= 0.0.0.7
, sdl2 >= 2.1.3.1
, OpenGL
, containers
, random
, linear
, stm
, nanovg
-- Directories containing source files.
hs-source-dirs: src

View file

@ -1,192 +1,122 @@
{-# LANGUAGE RecordWildCards #-}
module Commons where
import Affection
import qualified SDL
import GEGL
import BABL
import qualified Data.Map as M
import Data.Maybe (catMaybes)
import Data.List (delete)
import Data.Maybe (catMaybes, isJust)
import Control.Monad (foldM)
import Control.Monad (foldM, unless, when)
import Control.Monad.IO.Class (liftIO)
import System.Random (randomRIO)
import Debug.Trace
import NanoVG as N hiding (V2(..))
import Linear as L hiding (rotate)
import Foreign.C.Types (CFloat(..))
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
wrapAround :: (Fractional t, Ord t, Num t) => V2 t -> t -> V2 t
wrapAround (V2 nx ny) width = (V2 nnx nny)
where
nnx
| nx > 800 + half = nx - (800 + width)
| nx < -half = nx + 800 + width
| otherwise = nx
nny
| ny > 600 + half = ny - (600 + width)
| ny < -half = ny + 600 + width
| otherwise = ny
half = width / 2
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
]
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
newHaskelloids :: Affection UserData [Haskelloid]
newHaskelloids = do
img <- haskImage <$> getAffection
liftIO $ mapM (\_ -> do
posx <- randomRIO (0, 800)
posy <- randomRIO (0, 600)
velx <- randomRIO (-10, 10)
vely <- randomRIO (-10, 10)
rot <- randomRIO (-180, 180)
pitch <- randomRIO (-pi, pi)
div <- randomRIO (1, 2)
return $ Haskelloid
(V2 posx posy)
(V2 velx vely)
rot
pitch
div
img
) [1..10]
updateHaskelloid :: Double -> Haskelloid -> Haskelloid
updateHaskelloid dsec has =
has
{ hPos = wrapAround
(hPos has + hVel has * V2 sec sec)
(100 / fromIntegral (hDiv has))
, hRot = hRot has + hPitch has * sec
}
where
sec = realToFrac dsec
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
clamp :: Ord a => a -> a -> a -> a
clamp a' low up
| a' < low = low
| a' > up = up
| otherwise = a'
drawImage :: Context -> Image -> V2 Float -> V2 Float -> Float -> Float -> IO ()
drawImage ctx img pos dim rot alpha = do
let (V2 x y) = fmap CFloat pos
(V2 w h) = fmap CFloat dim
save ctx
translate ctx (x + (w/2)) (y + (h/2))
rotate ctx (degToRad $ CFloat rot)
translate ctx (-(w/2)) (-(h/2))
sPaint <- imagePattern ctx 0 0 w h 0 img (CFloat alpha)
beginPath ctx
rect ctx 0 0 w h
fillPaint ctx sPaint
fill ctx
resetTransform ctx
restore ctx
drawSpinner :: Context -> Float -> Float -> Float -> Float -> IO ()
drawSpinner ctx x y cr ct = do
let a0 = 0+t*6
a1 = pi + t*6
r0 = r
r1 = r*0.75
(cx, cy) = (CFloat x, CFloat y)
r = CFloat cr
t = CFloat ct
save ctx
beginPath ctx
arc ctx cx cy r0 a0 a1 CW
arc ctx cx cy r1 a1 a0 CCW
closePath ctx
let ax = cx+cos a0 * (r0+r1)*0.5
ay = cy+sin a0 * (r0+r1)*0.5
bx = cx+cos a1 * (r0+r1)*0.5
by = cy+sin a1 * (r0+r1)*0.5
paint <- linearGradient ctx ax ay bx by (rgba 255 255 255 0) (rgba 255 255 255 128)
fillPaint ctx paint
fill ctx
restore ctx
drawHaskelloid :: Haskelloid -> Affection UserData ()
drawHaskelloid (Haskelloid pos _ rot _ div img) = do
ctx <- nano <$> getAffection
liftIO $ drawImage ctx img (pos - fmap (/2) dim) dim rot 255
where
dim = (fmap (/ fromIntegral div) (V2 100 100))

View file

@ -1,109 +1,257 @@
{-# LANGUAGE RecordWildCards #-}
module InGame where
import Affection
import Affection as A
import qualified SDL
import GEGL
import qualified Data.Map as M
import qualified Data.Set as S
import Data.Maybe (isNothing, catMaybes)
import Control.Monad (when)
import Control.Monad (when, unless)
import Control.Monad.IO.Class (liftIO)
import Debug.Trace
import System.Random (randomRIO)
import Linear
import NanoVG hiding (V2(..))
import Foreign.C.Types (CFloat(..))
import Types
import Commons
handleGameEvent :: SDL.EventPayload -> Affection UserData ()
handleGameEvent e = do
ad <- get
wd <- getAffection
sec <- getDelta
case 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 = 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 = 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
putAffection nd
_ -> return ()
SDL.WindowClosedEvent _ -> do
traceM "seeya!"
put ad
{ quitEvent = True
}
dVel :: Float
dVel = 100
pewVel :: Float
pewVel = 200
pewTTL :: Double
pewTTL = 10
dRot :: Float
dRot = 150
loadGame :: Affection UserData () -> Affection UserData () -> Affection UserData ()
loadGame stateChange clean = do
liftIO $ logIO A.Debug "loading game"
ud <- getAffection
nhs <- newHaskelloids
kid <- partSubscribe (subKeyboard $ subsystems ud) (handleGameKeys stateChange clean)
putAffection ud
{ stateUUIDs = UUIDClean [] [kid]
, haskelloids = nhs
, ship = (ship ud)
{ sPos = V2 400 300
, sVel = V2 0 0
, sRot = 0
}
, shots = []
, state = InGame
, wonlost = Nothing
}
handleGameKeys :: Affection UserData () -> Affection UserData () -> KeyboardMessage -> Affection UserData ()
handleGameKeys stateChange clean kbdev = when (msgKbdKeyMotion kbdev == SDL.Pressed) $
case SDL.keysymKeycode (msgKbdKeysym kbdev) of
SDL.KeycodeSpace -> unless (msgKbdKeyRepeat kbdev) $ do
liftIO $ logIO A.Debug "PEW!"
shoot
SDL.KeycodeR -> unless (msgKbdKeyRepeat kbdev) $ do
ud <- getAffection
unless (isNothing $ wonlost ud) $ do
liftIO $ logIO A.Debug "Reloading"
clean
SDL.KeycodeEscape -> do
liftIO $ logIO A.Debug "Leave to Menu"
stateChange
SDL.KeycodeW -> accelShip dVel
SDL.KeycodeS -> accelShip (-dVel)
SDL.KeycodeA -> rotateShip dRot
SDL.KeycodeD -> rotateShip (-dRot)
_ -> return ()
shoot :: Affection UserData ()
shoot = do
ud <- getAffection
let Ship{..} = ship ud
npew = Pew ppos pVel pewTTL
ppos = sPos + ((V2 0 25) `rotVec` sRot)
pVel = sVel + ((V2 0 pewVel) `rotVec` sRot)
putAffection ud
{ shots = npew : shots ud
}
accelShip :: Float -> Affection UserData ()
accelShip vel = do
ud <- getAffection
dt <- getDelta
let s = ship ud
nVel = sVel s + fmap (realToFrac dt *) ((V2 0 vel) `rotVec` sRot s)
putAffection ud
{ ship = s
{ sVel = nVel
}
}
rotateShip :: Float -> Affection UserData ()
rotateShip deg = do
ud <- getAffection
dt <- getDelta
putAffection ud
{ ship = (ship ud)
{ sRot = (sRot $ ship ud) - deg * realToFrac dt
}
}
rotVec :: (Num a, Floating a) => V2 a -> a -> V2 a
rotVec (V2 x y) deg = V2 nx ny
where
nx = x * (cos $ dtor deg) + y * (sin $ dtor deg)
ny = x * (sin $ dtor deg) - y * (cos $ dtor deg)
dtor = (pi / 180 *)
updateGame :: Double -> Affection UserData ()
updateGame sec = do
ud <- getAffection
let nhs = map (updateHaskelloid sec) (haskelloids ud)
npews = filter (\p -> pTTL p > 0) $ map (updatePew sec) (shots ud)
putAffection ud
{ haskelloids = nhs
, shots = npews
, ship = updateShip sec (ship ud)
}
checkShotDown
ud2 <- getAffection
when
( ( any (checkCollision (ship ud2)) (haskelloids ud2)
|| any (checkFriendlyFire (ship ud2)) (shots ud2)
)
&& isNothing (wonlost ud2)
)
(putAffection ud2
{ wonlost = Just Lost
}
)
when (isNothing (wonlost ud2) && null (haskelloids ud2))
(putAffection ud2
{ wonlost = Just Won
}
)
checkShotDown :: Affection UserData ()
checkShotDown =
do
ud <- getAffection
let shoots = shots ud
hasks = haskelloids ud
pairs = catMaybes $ concatMap (crossOut hasks) shoots
deadHasks = map fst pairs
nhask = foldl (\acc a -> filter (\x -> a /= x) acc) hasks deadHasks
npews = foldl (\acc a -> filter (\x -> a /= x) acc) shoots (map snd pairs)
children <- liftIO $ concat <$> mapM (\Haskelloid{..} -> do
n1velx <- randomRIO (-10, 10)
n1vely <- randomRIO (-10, 10)
n1rot <- randomRIO (-180, 180)
n1pitch <- randomRIO (-pi, pi)
n2velx <- randomRIO (-10, 10)
n2vely <- randomRIO (-10, 10)
n2rot <- randomRIO (-180, 180)
n2pitch <- randomRIO (-pi, pi)
let ndiv = hDiv + 1
if ndiv > 5
then return []
else return $
[ Haskelloid hPos (V2 n1velx n1vely) n1rot n1pitch ndiv hImg
, Haskelloid hPos (V2 n2velx n2vely) n2rot n2pitch ndiv hImg
]
) deadHasks
putAffection ud
{ shots = npews
, haskelloids = nhask ++ children
}
where
crossOut :: [Haskelloid] -> Pew -> [Maybe (Haskelloid, Pew)]
crossOut hs p =
foldl (\acc h ->
if distance (pPos p) (hPos h) < (50 / fromIntegral (hDiv h))
then Just (h, p) : acc
else Nothing : acc
) [] hs
checkCollision :: Ship -> Haskelloid -> Bool
checkCollision s h =
distance (sPos s) (hPos h) < minDist
where
minDist = 20 + (50 / fromIntegral (hDiv h))
checkFriendlyFire :: Ship -> Pew -> Bool
checkFriendlyFire s p =
distance (sPos s) (pPos p) < 20
updateShip :: Double -> Ship -> Ship
updateShip ddt s@Ship{..} = s
{ sPos = wrapAround (sPos + fmap (dt *) sVel) 40
}
where
dt = realToFrac ddt
updatePew :: Double -> Pew -> Pew
updatePew ddt p@Pew{..} = p
{ pPos = wrapAround (pPos + fmap (dt *) pVel) 0
, pTTL = pTTL - ddt
}
where
dt = realToFrac ddt
drawGame :: Affection UserData ()
drawGame = do
ud <- getAffection
mapM_ drawHaskelloid (haskelloids ud)
mapM_ drawPew (shots ud)
case wonlost ud of
Just Lost -> liftIO $ do
let ctx = nano ud
save ctx
fontSize ctx 120
fontFace ctx "modulo"
textAlign ctx (S.fromList [AlignCenter,AlignTop])
fillColor ctx (rgba 255 255 255 255)
textBox ctx 0 200 800 "YOU LOST!"
fillColor ctx (rgba 255 128 0 255)
fontSize ctx 40
textBox ctx 0 350 800 "Press [Esc] to exit\nPress [R] to try again"
restore ctx
Just Won -> liftIO $ do
let ctx = nano ud
save ctx
fontSize ctx 120
fontFace ctx "modulo"
textAlign ctx (S.fromList [AlignCenter,AlignTop])
fillColor ctx (rgba 255 255 255 255)
textBox ctx 0 200 800 "YOU WON!"
fillColor ctx (rgba 128 255 0 255)
fontSize ctx 40
textBox ctx 0 350 800 "Press [Esc] to exit\nPress [R] to try again"
restore ctx
Nothing -> drawShip (ship ud)
drawShip :: Ship -> Affection UserData ()
drawShip Ship{..} = do
ctx <- nano <$> getAffection
liftIO $ drawImage ctx (sImg) (sPos - fmap (/2) dim) dim sRot 255
where
dim = V2 40 40
drawPew :: Pew -> Affection UserData ()
drawPew Pew{..} = do
ctx <- nano <$> getAffection
liftIO $ do
let (V2 x y) = fmap CFloat pPos
save ctx
beginPath ctx
fillColor ctx (rgba 255 128 0 255)
circle ctx x y 2
fill ctx
restore ctx

79
src/Init.hs Normal file
View file

@ -0,0 +1,79 @@
{-# LANGUAGE ForeignFunctionInterface #-}
module Init where
import Affection as A
import SDL (($=))
import qualified SDL
import qualified Graphics.Rendering.OpenGL as GL
import qualified Data.Set as S
import Data.Maybe
import Control.Monad (when)
import Control.Monad.IO.Class (liftIO)
import Control.Concurrent.STM
import System.Random
import System.Exit (exitFailure)
import Linear
import NanoVG hiding (V2)
import Foreign.C.Types (CInt(..))
-- Internal imports
import Types
foreign import ccall unsafe "glewInit"
glewInit :: IO CInt
load :: IO UserData
load = do
-- liftIO $ logIO A.Debug "Let's drop some Hints for SDL"
-- SDL.HintRenderDriver $= SDL.OpenGL
liftIO $ logIO A.Debug "init GLEW"
_ <- glewInit
liftIO $ logIO A.Debug "loading state"
liftIO $ logIO A.Debug "create context"
nvgCtx <- createGL3 (S.fromList [Antialias, StencilStrokes, NanoVG.Debug])
liftIO $ logIO A.Debug "load ship image"
mshipImage <- createImage nvgCtx (FileName "assets/ship.png") 0
when (isNothing mshipImage) $ do
logIO Error "Failed to load asset ship"
exitFailure
mhaskImage <- liftIO $
createImage nvgCtx (FileName "assets/haskelloid.png") 0
when (isNothing mhaskImage) $
liftIO $ logIO Error "Failed to load asset haskelloid"
mfont <- createFont nvgCtx "modulo" (FileName "assets/Modulo.ttf")
when (isNothing mfont) $ do
logIO Error "Failed to load font"
exitFailure
liftIO $ logIO A.Debug "Initializing subsystems"
subs <- Subsystems
<$> (return . Window =<< newTVarIO [])
<*> (return . Keyboard =<< newTVarIO [])
liftIO $ logIO A.Debug "Setting viewport"
GL.viewport $= (GL.Position 0 0, GL.Size 800 600)
liftIO $ logIO A.Debug "Returning UserData"
return UserData
{ ship = Ship
{ sPos = V2 400 300
, sVel = V2 0 0
, sRot = 0
, sImg = fromJust mshipImage
}
, haskelloids = []
, shots = []
, wonlost = Nothing
, state = Menu
, fade = FadeIn 1
, nano = nvgCtx
, font = fromJust mfont
, subsystems = subs
, haskImage = fromJust mhaskImage
}

View file

@ -1,233 +1,87 @@
{-# LANGUAGE OverloadedStrings, RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Affection
import Affection as A
import SDL (($=))
import qualified SDL
import GEGL
import qualified Graphics.Rendering.OpenGL as GL
import Data.List (delete)
import qualified Data.Map as M
import Data.Maybe (catMaybes)
import Control.Monad (when, foldM)
import Linear as L
import Debug.Trace
import NanoVG hiding (V2(..), V4(..))
import Control.Monad (when)
import Control.Monad.IO.Class (liftIO)
-- internal imports
import Types
import InGame
import Commons
import StateMachine ()
import Init
main :: IO ()
main = withAffection $ AffectionConfig
{ initComponents = All
, windowTitle = "Haskelloids"
, windowConfig = defaultWindow
, preLoop = return ()
, drawLoop = draw
, updateLoop = update
, loadState = load
, cleanUp = clean
, canvasSize = Nothing
, initScreenMode = SDL.Windowed
, eventLoop = handleGameEvent
}
main = do
logIO A.Debug "Starting"
withAffection AffectionConfig
{ initComponents = All
, windowTitle = "Haskelloids"
, windowConfig = SDL.defaultWindow
{ SDL.windowOpenGL = Just SDL.defaultOpenGL
{ SDL.glProfile = SDL.Core SDL.Normal 3 2
, SDL.glColorPrecision = V4 8 8 8 1
}
}
, initScreenMode = SDL.Windowed
, canvasSize = Nothing
, loadState = load
, preLoop = pre >> smLoad Menu
, eventLoop = handle
, updateLoop = update
, drawLoop = draw
, cleanUp = (\_ -> return ())
}
pre :: Affection UserData ()
pre = do
subs <- subsystems <$> getAffection
liftIO $ logIO A.Debug "Setting global resize event listener"
_ <- partSubscribe (subWindow subs) $ \msg -> case msg of
MsgWindowResize _ _ (V2 w h) -> do
liftIO $ logIO A.Debug "Window has been resized"
let nw = floor $ fromIntegral h * (800/600)
dw = floor $ (fromIntegral w - fromIntegral nw) / 2
GL.viewport $= (GL.Position dw 0, GL.Size nw h)
_ -> return ()
_ <- partSubscribe (subKeyboard subs) $ \kbdev ->
when (msgKbdKeyMotion kbdev == SDL.Pressed) $
case SDL.keysymKeycode (msgKbdKeysym kbdev) of
SDL.KeycodeF -> do
dt <- getDelta
liftIO $ logIO A.Debug $ "FPS: " ++ show (1/dt)
SDL.KeycodeO -> toggleScreen
_ -> return ()
return ()
update :: Double -> Affection UserData ()
update sec = do
-- traceM $ (show $ 1 / sec) ++ " FPS"
ad <- get
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"
[ Property "size-x" $ PropertyInt $ pixelSize wd - 1
, Property "size-y" $ PropertyInt $ pixelSize wd - 1
]
pd <- getAffection
putAffection pd
{ pixelSize = pixelSize wd -1
}
-- evs <- SDL.pollEvents
-- mapM_ (\e ->
-- case state wd of
-- InGame ->
-- handleGameEvent e
-- _ -> error "not yet implemented"
-- ) evs
ud2 <- getAffection
nhs <- mapM (updateHaskelloid sec) (haskelloids ud2)
-- liftIO $ traceIO $ show $ length nhs
putAffection ud2
{ haskelloids = nhs
}
ud3 <- getAffection
let nx = fst (sPos $ ship ud3) + (fst (sVel $ ship ud3)) * sec
ny = snd (sPos $ ship ud3) + (snd (sVel $ ship ud3)) * sec
(nnx, nny) = wrapAround (nx, ny) 50
liftIO $ gegl_node_set (nodeGraph ud3 M.! KeyTranslate) $ Operation "gegl:translate"
[ Property "x" $ PropertyDouble $ nnx
, Property "y" $ PropertyDouble $ nny
]
liftIO $ gegl_node_set (nodeGraph ud3 M.! KeyRotate) $ Operation "gegl:rotate"
[ Property "degrees" $ PropertyDouble $ sRot $ ship ud3
]
ups <- updateParticleSystem (shots ud3) sec shotsUpd
ud4 <- getAffection
putAffection ud4
{ ship = (ship ud3)
{ sPos = (nnx, nny)
}
, shots = ups
}
ud <- getAffection
smUpdate (state ud) sec
wrapAround :: (Ord t, Num t) => (t, t) -> t -> (t, t)
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
handle :: [SDL.EventPayload] -> Affection UserData ()
handle e = do
(Subsystems w k) <- subsystems <$> getAffection
_ <- consumeSDLEvents w =<< consumeSDLEvents k e
return ()
draw :: Affection UserData ()
draw = do
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)
True
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)
when (not $ 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 ()) (\_ ->
lose
) lost
return part
{ particlePosition = (nnx, nny)
, particleTimeToLive = if (not $ null inters) then 0 else particleTimeToLive
}
haskelloidShotDown :: Haskelloid -> Affection UserData ()
haskelloidShotDown h = do
liftIO $ gegl_node_drop $ hNodeGraph h M.! "root"
ud <- getAffection
let redHaskelloids = delete h (haskelloids ud)
liftIO $ gegl_node_drop $ hNodeGraph h M.! "root"
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_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.! KeyFGNop)
putAffection ud
{ wonlost = True
}
putAffection ud
{ haskelloids = newHaskelloids
}
shotsDraw :: GeglBuffer -> GeglNode -> Particle -> Affection UserData ()
shotsDraw _ _ _ = return ()
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 $ 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 <- 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
)
maybe (return ()) (\_ ->
lose
) lost
return h
{ hPos = (nnx, nny)
, hRot = newRot
}
lose :: Affection UserData ()
lose = do
ud <- getAffection
liftIO $ traceIO "YOU LOST!"
_ <- liftIO $ gegl_node_link
(nodeGraph ud M.! KeyLost)
(nodeGraph ud M.! KeyFGNop)
putAffection ud
{ wonlost = True
}
_ <- liftIO $ gegl_node_disconnect (nodeGraph ud M.! KeyShipOver) "aux"
return ()
-- window <- drawWindow <$> get
-- pf <- liftIO $ SDL.getWindowPixelFormat window
-- liftIO $ logIO A.Debug $ "Window pixel format: " ++ show pf
liftIO $ beginFrame (nano ud) 800 600 1
smDraw (state ud)
liftIO $ endFrame (nano ud)

86
src/Menu.hs Normal file
View file

@ -0,0 +1,86 @@
module Menu where
import Affection as A
import qualified SDL
import Debug.Trace
import Data.Maybe
import qualified Data.Set as S
import Control.Monad (when)
import Control.Monad.IO.Class (liftIO)
import qualified Data.Map as M
import NanoVG hiding (V2(..), V4(..))
import Linear
import Foreign.C.Types
-- internal imports
import Types
import Commons
loadMenu :: (Affection UserData ()) -> Affection UserData ()
loadMenu stateChange = do
liftIO $ logIO A.Debug "Loading Menu"
ud <- getAffection
hs <- newHaskelloids
kbdUUID <- partSubscribe (subKeyboard $ subsystems ud)
(\kbdev -> when (msgKbdKeyMotion kbdev == SDL.Pressed) $
case SDL.keysymKeycode (msgKbdKeysym kbdev) of
SDL.KeycodeEscape -> do
liftIO $ logIO A.Debug "seeya"
quit
SDL.KeycodeSpace -> do
liftIO $ logIO A.Debug "Leaving Menu to Game"
stateChange
_ -> return ()
)
putAffection ud
{ haskelloids = hs
, fade = FadeIn 1
, state = Menu
, stateUUIDs = UUIDClean [] [kbdUUID]
-- , shots = (shots ud)
-- { partSysParts = ParticleStorage Nothing [] }
}
updateMenu :: Double -> Affection UserData ()
updateMenu sec = do
ud <- getAffection
let nhs = map (updateHaskelloid sec) (haskelloids ud)
case fade ud of
FadeIn ttl -> do
putAffection ud
{ fade = if (ttl - sec) > 0 then FadeIn (ttl - sec) else FadeOut 1
, haskelloids = nhs
}
FadeOut ttl -> do
putAffection ud
{ fade = if (ttl - sec) > 0 then FadeOut (ttl - sec) else FadeIn 1
, haskelloids = nhs
}
drawMenu :: Affection UserData ()
drawMenu = do
ud <- getAffection
mapM_ drawHaskelloid (haskelloids ud)
liftIO $ do
let ctx = nano ud
alpha fio = case fio of
FadeIn d -> (floor (255 * (1 - d)))
FadeOut d -> (floor (255 * d))
save ctx
fontSize ctx 120
fontFace ctx "modulo"
textAlign ctx (S.fromList [AlignCenter,AlignTop])
fillColor ctx (rgba 255 255 255 255)
textBox ctx 0 200 800 "HASKELLOIDS"
fillColor ctx (rgba 0 128 255 (alpha $ fade ud))
fontSize ctx 40
textBox ctx 0 350 800 "Press [Space] to Play\nPress [Esc] to exit"
restore ctx

34
src/StateMachine.hs Normal file
View file

@ -0,0 +1,34 @@
{-# LANGUAGE MultiParamTypeClasses #-}
module StateMachine where
import Affection
import Types
import InGame
import Menu
instance StateMachine State UserData where
smLoad Menu = loadMenu (smClean Menu >> smLoad InGame)
smLoad InGame = loadGame (smClean InGame >> smLoad Menu) (smClean InGame >> smLoad InGame)
smUpdate Menu = updateMenu
smUpdate InGame = updateGame
smDraw Menu = drawMenu
smDraw InGame = drawGame
smEvent _ _ = return ()
smClean _ = do
ud <- getAffection
let (UUIDClean uuwin uukbd) = stateUUIDs ud
(Subsystems win kbd) = subsystems ud
mapM_ (partUnSubscribe win) uuwin
mapM_ (partUnSubscribe kbd) uukbd
putAffection ud
{ stateUUIDs = UUIDClean [] []
}

View file

@ -1,58 +1,115 @@
{-# LANGUAGE MultiParamTypeClasses #-}
module Types where
import Affection
import qualified SDL
import GEGL
import BABL
import qualified Data.Map as M
import NanoVG hiding (V2(..))
import Linear
import Control.Concurrent.STM
import Control.Monad.IO.Class (liftIO)
data UserData = UserData
{ nodeGraph :: M.Map NodeKey GeglNode
, ship :: Ship
, buffer :: GeglBuffer
{ ship :: Ship
, haskelloids :: [Haskelloid]
, shots :: ParticleSystem
, shots :: [Pew]
-- , debris :: ParticleSystem
, wonlost :: Bool
, wonlost :: Maybe WonLost
, pixelSize :: Int
, state :: State
, fade :: MenuFade
, nano :: Context
, font :: Font
, subsystems :: Subsystems
, haskImage :: Image
, stateUUIDs :: UUIDClean
}
data Ship = Ship
{ sPos :: (Double, Double)
, sVel :: (Double, Double)
, sRot :: Double
, sFlange :: GeglNode
{ sPos :: V2 Float
, sVel :: V2 Float
, sRot :: Float
, sImg :: Image
}
data Haskelloid = Haskelloid
{ hPos :: (Double, Double)
, hVel :: (Double, Double)
, hRot :: Double
, hPitch :: Double
, hDiv :: Int
, hFlange :: GeglNode
, hNodeGraph :: M.Map String GeglNode
data Pew = Pew
{ pPos :: V2 Float
, pVel :: V2 Float
, pTTL :: Double
} deriving (Eq)
data NodeKey
= KeyRoot
| KeyTranslate
| KeyRotate
| KeyShip
| KeyPNop
| KeyHNop
| KeyCrop
| KeyShipOver
| KeySink
| KeyWon
| KeyLost
| KeyPixelize
| KeyFGOver
| KeyFGNop
deriving (Ord, Eq)
data Haskelloid = Haskelloid
{ hPos :: V2 Float
, hVel :: V2 Float
, hRot :: Float
, hPitch :: Float
, hDiv :: Int
, hImg :: Image
} deriving (Eq)
data State
= Menu
| HighScore
-- | HighScore
| InGame
data MenuFade
= FadeIn Double
| FadeOut Double
data WonLost
= Won
| Lost
deriving (Eq)
data Subsystems = Subsystems
{ subWindow :: Window
, subKeyboard :: Keyboard
}
data UUIDClean = UUIDClean
{ uuWindow :: [MsgId WindowMessage]
, uuKeyboard :: [MsgId KeyboardMessage]
}
newtype Window = Window (TVar [(UUID, WindowMessage -> Affection UserData ())])
instance Participant Window WindowMessage UserData where
partSubscribers (Window t) = do
subTups <- liftIO $ readTVarIO t
return $ map snd subTups
partSubscribe (Window t) funct = do
uuid <- genUUID
liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
return $ MsgId uuid MsgWindowEmptyEvent
partUnSubscribe (Window t) (MsgId uuid _) =
liftIO $ atomically $ modifyTVar' t (filter (flip filterMsg uuid))
where
filterMsg :: (UUID, WindowMessage -> Affection UserData ()) -> UUID -> Bool
filterMsg (u, _) p = u /= p
instance SDLSubsystem Window UserData where
consumeSDLEvents = consumeSDLWindowEvents
newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection UserData ())])
instance Participant Keyboard KeyboardMessage UserData where
partSubscribers (Keyboard t) = do
subTups <- liftIO $ readTVarIO t
return $ map snd subTups
partSubscribe (Keyboard t) funct = do
uuid <- genUUID
liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
return $ MsgId uuid MsgKeyboardEmptyEvent
partUnSubscribe (Keyboard t) (MsgId uuid _) =
liftIO $ atomically $ modifyTVar' t (filter (flip filterMsg uuid))
where
filterMsg :: (UUID, KeyboardMessage -> Affection UserData ()) -> UUID -> Bool
filterMsg (u, _) p = u /= p
instance SDLSubsystem Keyboard UserData where
consumeSDLEvents = consumeSDLKeyboardEvents