rys ostrovid
GitHub
commit
7634be434b
14 changed files with 807 additions and 541 deletions
5
.gitignore
vendored
5
.gitignore
vendored
|
|
@ -1,3 +1,8 @@
|
|||
.cabal-sandbox/
|
||||
cabal.sandbox.config
|
||||
dist/
|
||||
*.prof
|
||||
*.aux
|
||||
*.hp
|
||||
*.ps
|
||||
*.swp
|
||||
|
|
|
|||
BIN
assets/Modulo.ttf
Normal file
BIN
assets/Modulo.ttf
Normal file
Binary file not shown.
BIN
assets/haskelloid.png
Normal file
BIN
assets/haskelloid.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 6.6 KiB |
|
|
@ -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
BIN
assets/ship.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 4.6 KiB |
1
cabal.config
Normal file
1
cabal.config
Normal file
|
|
@ -0,0 +1 @@
|
|||
constraints: affection +debug
|
||||
|
|
@ -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
|
||||
|
|
|
|||
276
src/Commons.hs
276
src/Commons.hs
|
|
@ -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))
|
||||
|
|
|
|||
344
src/InGame.hs
344
src/InGame.hs
|
|
@ -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
79
src/Init.hs
Normal 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
|
||||
}
|
||||
276
src/Main.hs
276
src/Main.hs
|
|
@ -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
86
src/Menu.hs
Normal 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
34
src/StateMachine.hs
Normal 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 [] []
|
||||
}
|
||||
131
src/Types.hs
131
src/Types.hs
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue