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/
cabal.sandbox.config cabal.sandbox.config
dist/ 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"?> <?xml version="1.0" encoding="UTF-8" standalone="no"?>
<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"> <svg
<defs> xmlns:dc="http://purl.org/dc/elements/1.1/"
<clipPath id="clip1"> xmlns:cc="http://creativecommons.org/ns#"
<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 "/> xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
</clipPath> xmlns:svg="http://www.w3.org/2000/svg"
</defs> xmlns="http://www.w3.org/2000/svg"
<g id="surface0"> xmlns:sodipodi="http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd"
<g clip-path="url(#clip1)" clip-rule="nonzero"> xmlns:inkscape="http://www.inkscape.org/namespaces/inkscape"
<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 "/> width="481.8897pt"
<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 "/> height="340.1574pt"
<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 "/> viewBox="0 0 481.8897 340.1574"
<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 "/> version="1.1"
</g> id="svg18"
</g> sodipodi:docname="haskelloid.svg"
</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. -- .hs or .lhs file containing the Main module.
main-is: Main.hs main-is: Main.hs
ghc-options: -Wall ghc-options: -Wall
extra-libraries: GLEW
-- Modules included in this executable, other than Main. -- Modules included in this executable, other than Main.
other-modules: InGame other-modules: Types
, Types
, Commons , Commons
, StateMachine
, Menu
, InGame
, Init
default-extensions: OverloadedStrings
-- LANGUAGE extensions used by modules in this package. -- LANGUAGE extensions used by modules in this package.
-- other-extensions: -- other-extensions:
-- Other library packages from which modules are imported. -- Other library packages from which modules are imported.
build-depends: base >=4.9 && <4.11 build-depends: base >=4.9 && <4.11
, affection , affection <= 0.0.0.7
, gegl , sdl2 >= 2.1.3.1
, babl , OpenGL
, sdl2
, containers , containers
, random , random
, linear
, stm
, nanovg
-- Directories containing source files. -- Directories containing source files.
hs-source-dirs: src hs-source-dirs: src

View file

@ -1,192 +1,122 @@
{-# LANGUAGE RecordWildCards #-}
module Commons where module Commons where
import Affection import Affection
import qualified SDL import qualified SDL
import GEGL
import BABL
import qualified Data.Map as M 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 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 import Types
toR :: Double -> Double toR :: Double -> Double
toR deg = deg * pi / 180 toR deg = deg * pi / 180
clean :: UserData -> IO () wrapAround :: (Fractional t, Ord t, Num t) => V2 t -> t -> V2 t
clean ud = do wrapAround (V2 nx ny) width = (V2 nnx nny)
mapM_ gegl_node_drop $ map (\h -> hNodeGraph h M.! "root") (haskelloids ud) where
gegl_node_drop $ nodeGraph ud M.! KeyRoot 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 newHaskelloids :: Affection UserData [Haskelloid]
load = do newHaskelloids = do
traceM "loading" img <- haskImage <$> getAffection
root <- gegl_node_new liftIO $ mapM (\_ -> do
traceM "root node" posx <- randomRIO (0, 800)
bg <- gegl_node_new_child root $ Operation "gegl:rectangle" posy <- randomRIO (0, 600)
[ Property "x" $ PropertyDouble 0 velx <- randomRIO (-10, 10)
, Property "y" $ PropertyDouble 0 vely <- randomRIO (-10, 10)
, Property "width" $ PropertyDouble 800 rot <- randomRIO (-180, 180)
, Property "height" $ PropertyDouble 600 pitch <- randomRIO (-pi, pi)
, Property "color" $ PropertyColor $ GEGL.RGBA 0 0 0.1 1 div <- randomRIO (1, 2)
] return $ Haskelloid
ship <- gegl_node_new_child root $ Operation "gegl:svg-load" (V2 posx posy)
[ Property "path" $ PropertyString "assets/ship.svg" (V2 velx vely)
, Property "width" $ PropertyInt 50 rot
, Property "height" $ PropertyInt 50 pitch
] div
pnop <- gegl_node_new_child root $ Operation "gegl:nop" [] img
hnop <- gegl_node_new_child root $ Operation "gegl:nop" [] ) [1..10]
fgnop <- gegl_node_new_child root $ Operation "gegl:nop" []
sover <- gegl_node_new_child root $ defaultOverOperation updateHaskelloid :: Double -> Haskelloid -> Haskelloid
hover <- gegl_node_new_child root $ defaultOverOperation updateHaskelloid dsec has =
pover <- gegl_node_new_child root $ defaultOverOperation has
bgover <- gegl_node_new_child root $ defaultOverOperation { hPos = wrapAround
fgover <- gegl_node_new_child root $ defaultOverOperation (hPos has + hVel has * V2 sec sec)
translate <- gegl_node_new_child root $ Operation "gegl:translate" (100 / fromIntegral (hDiv has))
[ Property "x" $ PropertyDouble 375 , hRot = hRot has + hPitch has * sec
, 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
} }
where
sec = realToFrac dsec
insertHaskelloid :: [Maybe Haskelloid] -> Maybe Int -> (Double, Double) -> IO [Maybe Haskelloid] clamp :: Ord a => a -> a -> a -> a
insertHaskelloid hasks split (px, py) = do clamp a' low up
-- liftIO $ traceIO "inserting haskelloid" | a' < low = low
vx <- liftIO $ randomRIO (-10, 10) | a' > up = up
vy <- liftIO $ randomRIO (-10, 10) | otherwise = a'
rdiv <- case split of
Nothing -> liftIO $ randomRIO (1, 2) drawImage :: Context -> Image -> V2 Float -> V2 Float -> Float -> Float -> IO ()
Just x -> return $ x + 1 drawImage ctx img pos dim rot alpha = do
rot <- liftIO $ randomRIO (0, 360) let (V2 x y) = fmap CFloat pos
pitch <- liftIO $ randomRIO (-45, 45) (V2 w h) = fmap CFloat dim
tempRoot <- liftIO $ gegl_node_new save ctx
tempOver <- liftIO $ gegl_node_new_child tempRoot $ defaultOverOperation translate ctx (x + (w/2)) (y + (h/2))
tempSvg <- gegl_node_new_child tempRoot $ Operation "gegl:svg-load" rotate ctx (degToRad $ CFloat rot)
[ Property "path" $ PropertyString "assets/haskelloid.svg" translate ctx (-(w/2)) (-(h/2))
, Property "width" $ PropertyInt (100 `div` rdiv) sPaint <- imagePattern ctx 0 0 w h 0 img (CFloat alpha)
, Property "height" $ PropertyInt (100 `div` rdiv) beginPath ctx
] rect ctx 0 0 w h
tempTrans <- liftIO $ gegl_node_new_child tempRoot $ Operation "gegl:translate" fillPaint ctx sPaint
[ Property "x" $ PropertyDouble $ px + (100 / fromIntegral rdiv / 2) fill ctx
, Property "y" $ PropertyDouble $ py + (100 / fromIntegral rdiv / 2) resetTransform ctx
, Property "sampler" $ PropertyInt $ fromEnum GeglSamplerCubic restore ctx
]
tempRot <- liftIO $ gegl_node_new_child tempRoot $ Operation "gegl:rotate" drawSpinner :: Context -> Float -> Float -> Float -> Float -> IO ()
[ Property "origin-x" $ PropertyDouble (100 / 2 / fromIntegral rdiv) drawSpinner ctx x y cr ct = do
, Property "origin-y" $ PropertyDouble (100 / 2 / fromIntegral rdiv) let a0 = 0+t*6
, Property "degrees" $ PropertyDouble rot a1 = pi + t*6
, Property "sampler" $ PropertyInt $ fromEnum GeglSamplerCubic r0 = r
] r1 = r*0.75
liftIO $ gegl_node_link_many [tempSvg, tempRot, tempTrans] (cx, cy) = (CFloat x, CFloat y)
_ <- liftIO $ gegl_node_connect_to tempTrans "output" tempOver "aux" r = CFloat cr
return $ Just Haskelloid t = CFloat ct
{ hPos = save ctx
( px + (100 / 2 / fromIntegral rdiv) beginPath ctx
, py + (100 / 2 / fromIntegral rdiv) arc ctx cx cy r0 a0 a1 CW
) arc ctx cx cy r1 a1 a0 CCW
, hVel = (vx, vy) closePath ctx
, hRot = rot let ax = cx+cos a0 * (r0+r1)*0.5
, hPitch = pitch ay = cy+sin a0 * (r0+r1)*0.5
, hDiv = rdiv bx = cx+cos a1 * (r0+r1)*0.5
, hFlange = tempOver by = cy+sin a1 * (r0+r1)*0.5
, hNodeGraph = M.fromList paint <- linearGradient ctx ax ay bx by (rgba 255 255 255 0) (rgba 255 255 255 128)
[ ("root", tempRoot) fillPaint ctx paint
, ("over", tempOver) fill ctx
, ("svg", tempSvg) restore ctx
, ("trans", tempTrans)
, ("rot", tempRot) drawHaskelloid :: Haskelloid -> Affection UserData ()
] drawHaskelloid (Haskelloid pos _ rot _ div img) = do
} : hasks 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 module InGame where
import Affection import Affection as A
import qualified SDL 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 Types
import Commons import Commons
handleGameEvent :: SDL.EventPayload -> Affection UserData () dVel :: Float
handleGameEvent e = do dVel = 100
ad <- get
wd <- getAffection pewVel :: Float
sec <- getDelta pewVel = 200
case e of
SDL.KeyboardEvent dat -> pewTTL :: Double
case (SDL.keysymKeycode $ SDL.keyboardEventKeysym dat) of pewTTL = 10
SDL.KeycodeLeft -> do
ud <- getAffection dRot :: Float
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed && not (wonlost ud)) $ dRot = 150
putAffection ud
{ ship = (ship ud) loadGame :: Affection UserData () -> Affection UserData () -> Affection UserData ()
{ sRot = (sRot $ ship ud) + 270 * sec loadGame stateChange clean = do
} liftIO $ logIO A.Debug "loading game"
} ud <- getAffection
SDL.KeycodeRight -> do nhs <- newHaskelloids
ud <- getAffection kid <- partSubscribe (subKeyboard $ subsystems ud) (handleGameKeys stateChange clean)
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $ putAffection ud
putAffection ud { stateUUIDs = UUIDClean [] [kid]
{ ship = (ship ud) , haskelloids = nhs
{ sRot = (sRot $ ship ud) - 270 * sec , ship = (ship ud)
} { sPos = V2 400 300
} , sVel = V2 0 0
SDL.KeycodeUp -> , sRot = 0
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed && not (wonlost wd)) $ do }
ud <- getAffection , shots = []
let vx = -10 * (sin (toR $ (sRot $ ship ud))) + fst (sVel $ ship ud) , state = InGame
vy = -10 * (cos (toR $ (sRot $ ship ud))) + snd (sVel $ ship ud) , wonlost = Nothing
putAffection ud }
{ ship = (ship ud)
{ sVel = (vx, vy) handleGameKeys :: Affection UserData () -> Affection UserData () -> KeyboardMessage -> Affection UserData ()
} handleGameKeys stateChange clean kbdev = when (msgKbdKeyMotion kbdev == SDL.Pressed) $
} case SDL.keysymKeycode (msgKbdKeysym kbdev) of
-- traceM $ show (vx, vy) ++ " " ++ show (sRot $ ship ud) SDL.KeycodeSpace -> unless (msgKbdKeyRepeat kbdev) $ do
SDL.KeycodeSpace -> liftIO $ logIO A.Debug "PEW!"
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed && not (wonlost wd)) $ do shoot
ud <- getAffection SDL.KeycodeR -> unless (msgKbdKeyRepeat kbdev) $ do
liftIO $ gegl_node_set (nodeGraph ud M.! KeyPixelize) $ Operation "gegl:pixelize" ud <- getAffection
[ Property "size-x" $ PropertyInt 8 unless (isNothing $ wonlost ud) $ do
, Property "size-y" $ PropertyInt 8 liftIO $ logIO A.Debug "Reloading"
] clean
-- ad <- get SDL.KeycodeEscape -> do
let posX = (fst $ sPos $ ship ud) + 23 - 35 * sin (toR $ sRot $ ship ud) liftIO $ logIO A.Debug "Leave to Menu"
posY = (snd $ sPos $ ship ud) + 23 - 35 * cos (toR $ sRot $ ship ud) stateChange
tempRoot <- liftIO $ gegl_node_new SDL.KeycodeW -> accelShip dVel
tempRect <- liftIO $ gegl_node_new_child tempRoot $ Operation "gegl:rectangle" SDL.KeycodeS -> accelShip (-dVel)
[ Property "x" $ PropertyDouble $ posX SDL.KeycodeA -> rotateShip dRot
, Property "y" $ PropertyDouble $ posY SDL.KeycodeD -> rotateShip (-dRot)
, 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
}
_ -> return () _ -> 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 module Main where
import Affection import Affection as A
import SDL (($=))
import qualified SDL import qualified SDL
import GEGL import qualified Graphics.Rendering.OpenGL as GL
import Data.List (delete)
import qualified Data.Map as M 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 -- internal imports
import Types import Types
import InGame
import Commons import Commons
import StateMachine ()
import Init
main :: IO () main :: IO ()
main = withAffection $ AffectionConfig main = do
{ initComponents = All logIO A.Debug "Starting"
, windowTitle = "Haskelloids" withAffection AffectionConfig
, windowConfig = defaultWindow { initComponents = All
, preLoop = return () , windowTitle = "Haskelloids"
, drawLoop = draw , windowConfig = SDL.defaultWindow
, updateLoop = update { SDL.windowOpenGL = Just SDL.defaultOpenGL
, loadState = load { SDL.glProfile = SDL.Core SDL.Normal 3 2
, cleanUp = clean , SDL.glColorPrecision = V4 8 8 8 1
, canvasSize = Nothing }
, initScreenMode = SDL.Windowed }
, eventLoop = handleGameEvent , 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 :: Double -> Affection UserData ()
update sec = do update sec = do
-- traceM $ (show $ 1 / sec) ++ " FPS" ud <- getAffection
ad <- get smUpdate (state ud) sec
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
}
wrapAround :: (Ord t, Num t) => (t, t) -> t -> (t, t) handle :: [SDL.EventPayload] -> Affection UserData ()
wrapAround (nx, ny) width = (nnx, nny) handle e = do
where (Subsystems w k) <- subsystems <$> getAffection
nnx = _ <- consumeSDLEvents w =<< consumeSDLEvents k e
if nx > 800 return ()
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 :: Affection UserData ()
draw = do draw = do
ud <- getAffection ud <- getAffection
liftIO $ gegl_node_process $ nodeGraph ud M.! KeySink -- window <- drawWindow <$> get
-- mintr <- liftIO $ gegl_rectangle_intersect -- pf <- liftIO $ SDL.getWindowPixelFormat window
-- (GeglRectangle 0 0 800 600) -- liftIO $ logIO A.Debug $ "Window pixel format: " ++ show pf
-- (GeglRectangle (floor $ fst $ sPos $ ship ud) (floor $ snd $ sPos $ ship ud) 50 50) liftIO $ beginFrame (nano ud) 800 600 1
-- maybe (return ()) (\intr -> smDraw (state ud)
-- present liftIO $ endFrame (nano ud)
-- (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 ()

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 module Types where
import Affection import Affection
import qualified SDL import qualified SDL
import GEGL import NanoVG hiding (V2(..))
import BABL import Linear
import qualified Data.Map as M
import Control.Concurrent.STM
import Control.Monad.IO.Class (liftIO)
data UserData = UserData data UserData = UserData
{ nodeGraph :: M.Map NodeKey GeglNode { ship :: Ship
, ship :: Ship
, buffer :: GeglBuffer
, haskelloids :: [Haskelloid] , haskelloids :: [Haskelloid]
, shots :: ParticleSystem , shots :: [Pew]
-- , debris :: ParticleSystem -- , debris :: ParticleSystem
, wonlost :: Bool , wonlost :: Maybe WonLost
, pixelSize :: Int , pixelSize :: Int
, state :: State , state :: State
, fade :: MenuFade
, nano :: Context
, font :: Font
, subsystems :: Subsystems
, haskImage :: Image
, stateUUIDs :: UUIDClean
} }
data Ship = Ship data Ship = Ship
{ sPos :: (Double, Double) { sPos :: V2 Float
, sVel :: (Double, Double) , sVel :: V2 Float
, sRot :: Double , sRot :: Float
, sFlange :: GeglNode , sImg :: Image
} }
data Haskelloid = Haskelloid data Pew = Pew
{ hPos :: (Double, Double) { pPos :: V2 Float
, hVel :: (Double, Double) , pVel :: V2 Float
, hRot :: Double , pTTL :: Double
, hPitch :: Double
, hDiv :: Int
, hFlange :: GeglNode
, hNodeGraph :: M.Map String GeglNode
} deriving (Eq) } deriving (Eq)
data NodeKey data Haskelloid = Haskelloid
= KeyRoot { hPos :: V2 Float
| KeyTranslate , hVel :: V2 Float
| KeyRotate , hRot :: Float
| KeyShip , hPitch :: Float
| KeyPNop , hDiv :: Int
| KeyHNop , hImg :: Image
| KeyCrop } deriving (Eq)
| KeyShipOver
| KeySink
| KeyWon
| KeyLost
| KeyPixelize
| KeyFGOver
| KeyFGNop
deriving (Ord, Eq)
data State data State
= Menu = Menu
| HighScore -- | HighScore
| InGame | 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