grid-proto-0.1.0.0: src/GridProto/Internal/Core.hs
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TupleSections #-}
module GridProto.Internal.Core where
import Prelude hiding (lookup)
import GHC.Generics (Generic)
import Control.Applicative ((<|>))
import Data.Traversable (forM)
import Data.Aeson (FromJSON, ToJSON)
import Data.Aeson.Types (FromJSONKey, ToJSONKey)
import Data.Function (fix)
import Data.Foldable (forM_)
import Data.IORef (IORef, newIORef, readIORef, modifyIORef)
import Data.Map (Map, fromList, (!), delete, alter, insert, filterWithKey, member, notMember, toList)
import Data.Maybe (catMaybes, fromMaybe)
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
import Data.Text (pack)
import Data.Word (Word8)
import Data.Int (Int16)
import Linear.V2 (V2(..))
import Linear.V4 (V4(..))
import SDL.Input.Keyboard.Codes
import SDL.Input.GameController (ControllerButton(..), ControllerButtonState(..), ControllerDeviceConnection(..))
import GridProto.Internal.Font
import qualified Data.Map as Map
import qualified Data.Vector.Storable as VS
import qualified SDL
import qualified SDL.Raw.Event as Raw
import qualified SDL.Font as Font
import qualified SDL.Primitive as Gfx
import qualified SDL.Mixer as Mixer
data Color
= Red0
| Red1
| Red2
| Orange0
| Orange1
| Orange2
| Yellow0
| Yellow1
| Yellow2
| Chartreuse0
| Chartreuse1
| Chartreuse2
| Green0
| Green1
| Green2
| Spring0
| Spring1
| Spring2
| Cyan0
| Cyan1
| Cyan2
| Azure0
| Azure1
| Azure2
| Blue0
| Blue1
| Blue2
| Violet0
| Violet1
| Violet2
| Magenta0
| Magenta1
| Magenta2
| Rose0
| Rose1
| Rose2
| Brown0
| Brown1
| Brown2
| Gray0
| Gray1
| Gray2
| White0
| White1
| White2
| Black0
| Black1
| Black2
deriving (Enum, Eq, Bounded, Ord, Show, Generic)
instance ToJSON Color
instance FromJSON Color
data Shape
= Circle
| FillCircle
| Triangle
| FillTriangle
| Square
| FillSquare
| Plus
| Dash
| Bar
| Cross
deriving (Enum, Eq, Bounded, Show, Generic)
instance ToJSON Shape
instance FromJSON Shape
data Mouse = Mouse
{ mousePosition :: (Int, Int)
, mouseButton :: KeyState
} deriving (Show, Eq, Generic)
instance ToJSON Mouse
instance FromJSON Mouse
data Key
= Char Char
| UpArrow
| DownArrow
| LeftArrow
| RightArrow
| Enter
| Escape
| LeftShift
| RightShift
| LeftControl
| RightControl
| LeftAlt
| RightAlt
| Tab
| Backspace
| Meta
deriving (Eq, Show, Ord, Generic)
instance ToJSON Key
instance FromJSON Key
instance ToJSONKey Key
instance FromJSONKey Key
data KeyState
= Pressed
| Held
| Released
| Untouched
deriving (Enum, Eq, Bounded, Show, Generic)
instance ToJSON KeyState
instance FromJSON KeyState
newtype Keys = Keys { unKeys :: Map Key KeyState }
deriving (Show, Eq, Generic)
instance ToJSON Keys
instance FromJSON Keys
data Axis = Axis
{ xAxis :: Float
, yAxis :: Float
} deriving (Show, Eq, Generic)
instance ToJSON Axis
instance FromJSON Axis
data Controller = Controller
{ isConnected :: Bool
, startButton :: KeyState
, backButton :: KeyState
, dpadUp :: KeyState
, dpadDown :: KeyState
, dpadLeft :: KeyState
, dpadRight :: KeyState
, aButton :: KeyState
, bButton :: KeyState
, xButton :: KeyState
, yButton :: KeyState
, leftStick :: KeyState
, rightStick :: KeyState
, leftShoulder :: KeyState
, rightShoulder :: KeyState
, leftAxis :: Axis
, rightAxis :: Axis
} deriving (Show, Eq, Generic)
initController :: Controller
initController = Controller
False
Untouched
Untouched
Untouched
Untouched
Untouched
Untouched
Untouched
Untouched
Untouched
Untouched
Untouched
Untouched
Untouched
Untouched
(Axis 0 0)
(Axis 0 0)
instance ToJSON Controller
instance FromJSON Controller
data Input = Input
{ mouse :: Mouse
, keys :: Keys
, controller1 :: Controller
, controller2 :: Controller
, controller3 :: Controller
, controller4 :: Controller
} deriving (Show, Eq, Generic)
instance ToJSON Input
instance FromJSON Input
data Tile = Tile
{ symbol :: Maybe (Char, Color)
, shape :: Maybe (Shape, Color)
, fill :: Maybe Color
} deriving (Show, Eq, Generic)
instance ToJSON Tile
instance FromJSON Tile
instance Semigroup Tile where
(<>) (Tile aSymbol aShape aFill) (Tile bSymbol bShape bFill) = case bFill of
Nothing -> Tile (bSymbol <|> aSymbol) (bShape <|> aShape) aFill
Just _ -> Tile bSymbol bShape bFill
instance Monoid Tile where
mempty = Tile Nothing Nothing Nothing
data Sfx
= Achievement
| Gong
deriving (Show, Eq)
lookupMap :: Ord k => k -> Map k a -> Maybe a
lookupMap = Map.lookup
num :: (Integral a, Num b) => a -> b
num = fromIntegral
lookupKey :: Keys -> Key -> KeyState
lookupKey (Keys m) k = fromMaybe Untouched (Map.lookup k m)
makeInput :: Input -> Maybe (Int, Int) -> Bool -> [SDL.EventPayload] -> Input
makeInput Input{mouse,keys,controller1,controller2,controller3,controller4} mpos' mclick eventPayloads = Input m (Keys $ nextKeys $ unKeys keys) controller1' controller2' controller3' controller4'
where
mpos = fromMaybe (mousePosition mouse) mpos'
mbutton
| mclick && mouseButton mouse == Untouched = Pressed
| mclick && mouseButton mouse == Pressed = Held
| mclick && mouseButton mouse == Held = Held
| not mclick && mouseButton mouse == Held = Released
| otherwise = Untouched
m = Mouse mpos mbutton
keyChanges = Map.fromList . catMaybes $ map keyChange eventPayloads
removeReleased = Map.filter (/= Released)
pressedToHeld = Map.map stepKeyState
nextKeys = Map.union keyChanges . pressedToHeld . removeReleased
controller1' = foldr (applyControllerChange 0) (stepController controller1) eventPayloads
controller2' = foldr (applyControllerChange 1) (stepController controller2) eventPayloads
controller3' = foldr (applyControllerChange 2) (stepController controller3) eventPayloads
controller4' = foldr (applyControllerChange 3) (stepController controller4) eventPayloads
normalizeInt16 :: Int16 -> Float
normalizeInt16 w = let
f = fromIntegral w / (fromIntegral (maxBound :: Int16))
deadzone x = if x < 0.05 && x > -0.05 then 0 else x
clamp x = if x > 1 then 1 else (if x < -1 then -1 else x)
in clamp $ deadzone f
applyControllerChange :: Int -> SDL.EventPayload -> Controller -> Controller
applyControllerChange idx event c = case event of
SDL.ControllerDeviceEvent (SDL.ControllerDeviceEventData ControllerDeviceRemoved j) -> if j == jId then c { isConnected = False } else c
SDL.ControllerButtonEvent (SDL.ControllerButtonEventData 0 button buttonState) -> fromMaybe c (update button <$> toKeyState buttonState)
SDL.ControllerAxisEvent (SDL.ControllerAxisEventData j 0 i) -> if j == jId then c { leftAxis = (leftAxis c) { xAxis = normalizeInt16 i } } else c
SDL.ControllerAxisEvent (SDL.ControllerAxisEventData j 1 i) -> if j == jId then c { leftAxis = (leftAxis c) { yAxis = normalizeInt16 i } } else c
SDL.ControllerAxisEvent (SDL.ControllerAxisEventData j 2 i) -> if j == jId then c { rightAxis = (rightAxis c) { xAxis = normalizeInt16 i } } else c
SDL.ControllerAxisEvent (SDL.ControllerAxisEventData j 3 i) -> if j == jId then c { rightAxis = (rightAxis c) { yAxis = normalizeInt16 i } } else c
--
SDL.JoyAxisEvent (SDL.JoyAxisEventData j 0 i) -> if j == jId then c { leftAxis = (leftAxis c) { xAxis = normalizeInt16 i } } else c
SDL.JoyAxisEvent (SDL.JoyAxisEventData j 1 i) -> if j == jId then c { leftAxis = (leftAxis c) { yAxis = normalizeInt16 i } } else c
SDL.JoyAxisEvent (SDL.JoyAxisEventData j 2 i) -> if j == jId then c { rightAxis = (rightAxis c) { xAxis = normalizeInt16 i } } else c
SDL.JoyAxisEvent (SDL.JoyAxisEventData j 3 i) -> if j == jId then c { rightAxis = (rightAxis c) { yAxis = normalizeInt16 i } } else c
_ -> c
where
toKeyState buttonState = case buttonState of
ControllerButtonPressed -> Just Pressed
ControllerButtonReleased -> Just Released
_ -> Nothing
update button v = case button of
ControllerButtonStart -> c { startButton = v }
ControllerButtonBack -> c { backButton = v }
ControllerButtonDpadUp -> c { dpadUp = v }
ControllerButtonDpadDown -> c { dpadDown = v }
ControllerButtonDpadLeft -> c { dpadLeft = v }
ControllerButtonDpadRight -> c { dpadRight = v }
ControllerButtonA -> c { aButton = v }
ControllerButtonB -> c { bButton = v }
ControllerButtonX -> c { xButton = v }
ControllerButtonY -> c { yButton = v }
ControllerButtonLeftStick -> c { leftStick = v }
ControllerButtonRightStick -> c { rightStick = v }
ControllerButtonLeftShoulder -> c { leftShoulder = v }
ControllerButtonRightShoulder -> c { rightShoulder = v }
_ -> c
jId = fromIntegral idx
stepController :: Controller -> Controller
stepController c = c
{ startButton = stepKeyState $ startButton c
, backButton = stepKeyState $ backButton c
, dpadUp = stepKeyState $ dpadUp c
, dpadDown = stepKeyState $ dpadDown c
, dpadLeft = stepKeyState $ dpadLeft c
, dpadRight = stepKeyState $ dpadRight c
, aButton = stepKeyState $ aButton c
, bButton = stepKeyState $ bButton c
, xButton = stepKeyState $ xButton c
, yButton = stepKeyState $ yButton c
, leftStick = stepKeyState $ leftStick c
, rightStick = stepKeyState $ rightStick c
, leftShoulder = stepKeyState $ leftShoulder c
, rightShoulder = stepKeyState $ rightShoulder c
}
stepKeyState :: KeyState -> KeyState
stepKeyState ks = case ks of
Pressed -> Held
Held -> Held
Released -> Untouched
Untouched -> Untouched
keyFromKeyCode :: SDL.Keycode -> Maybe Key
keyFromKeyCode = \case
KeycodeLeft -> Just LeftArrow
KeycodeDown -> Just DownArrow
KeycodeUp -> Just UpArrow
KeycodeRight -> Just RightArrow
KeycodeReturn -> Just Enter
KeycodeEscape -> Just Escape
KeycodeLShift -> Just LeftShift
KeycodeRShift -> Just RightShift
KeycodeLCtrl -> Just LeftControl
KeycodeRCtrl -> Just RightControl
KeycodeLAlt -> Just LeftAlt
KeycodeRAlt -> Just RightAlt
KeycodeTab -> Just Tab
KeycodeBackspace -> Just Backspace
KeycodeLGUI -> Just Meta
KeycodeRGUI -> Just Meta
--
KeycodeA -> Just $ Char 'a'
KeycodeB -> Just $ Char 'b'
KeycodeC -> Just $ Char 'c'
KeycodeD -> Just $ Char 'd'
KeycodeE -> Just $ Char 'e'
KeycodeF -> Just $ Char 'f'
KeycodeG -> Just $ Char 'g'
KeycodeH -> Just $ Char 'h'
KeycodeI -> Just $ Char 'i'
KeycodeJ -> Just $ Char 'j'
KeycodeK -> Just $ Char 'k'
KeycodeL -> Just $ Char 'l'
KeycodeM -> Just $ Char 'm'
KeycodeN -> Just $ Char 'n'
KeycodeO -> Just $ Char 'o'
KeycodeP -> Just $ Char 'p'
KeycodeQ -> Just $ Char 'q'
KeycodeR -> Just $ Char 'r'
KeycodeS -> Just $ Char 's'
KeycodeT -> Just $ Char 't'
KeycodeU -> Just $ Char 'u'
KeycodeV -> Just $ Char 'v'
KeycodeW -> Just $ Char 'w'
KeycodeX -> Just $ Char 'x'
KeycodeY -> Just $ Char 'y'
KeycodeZ -> Just $ Char 'z'
--
Keycode0 -> Just $ Char '0'
Keycode1 -> Just $ Char '1'
Keycode2 -> Just $ Char '2'
Keycode3 -> Just $ Char '3'
Keycode4 -> Just $ Char '4'
Keycode5 -> Just $ Char '5'
Keycode6 -> Just $ Char '6'
Keycode7 -> Just $ Char '7'
Keycode8 -> Just $ Char '8'
Keycode9 -> Just $ Char '9'
--
KeycodeBackquote -> Just $ Char '`'
KeycodeMinus -> Just $ Char '-'
KeycodeEquals -> Just $ Char '='
KeycodeLeftBracket -> Just $ Char '['
KeycodeRightBracket -> Just $ Char ']'
KeycodeBackslash -> Just $ Char '\\'
KeycodeSemicolon -> Just $ Char ';'
KeycodeQuote -> Just $ Char '\''
KeycodeComma -> Just $ Char ','
KeycodePeriod -> Just $ Char '.'
KeycodeSlash -> Just $ Char '/'
--
_ -> Nothing
keyChange :: SDL.EventPayload -> Maybe (Key, KeyState)
keyChange event = case event of
SDL.KeyboardEvent SDL.KeyboardEventData{SDL.keyboardEventKeysym = SDL.Keysym{SDL.keysymKeycode = code}, SDL.keyboardEventKeyMotion = motion, SDL.keyboardEventRepeat } -> if not keyboardEventRepeat
then case motion of
SDL.Released -> (\k -> (k, Released)) <$> keyFromKeyCode code
SDL.Pressed -> (\k -> (k, Pressed)) <$> keyFromKeyCode code
else Nothing
_ -> Nothing
drawTileMap :: Color -> SDL.Renderer -> Int -> (Color -> Char -> IO (Maybe (SDL.Texture, Int, Int))) -> Map (Int, Int) Tile -> IO ()
drawTileMap bgColor renderer tileSize fontMap m = forM_ (toList m) $ \((x,y), Tile{symbol,shape,fill}) -> do
drawFill renderer tileSize (x,y) fill
case shape of
Nothing -> return ()
Just shape' -> drawShape (fromMaybe bgColor fill) renderer tileSize (x,y) shape'
case symbol of
Nothing -> return ()
Just (symbol', color) -> drawSymbol renderer fontMap symbol' color tileSize (x,y)
drawFill :: SDL.Renderer -> Int -> (Int, Int) -> Maybe Color -> IO ()
drawFill _ _ _ Nothing = return ()
drawFill renderer tileSize (x,y) (Just color) = do
let fx0 = x * tileSize
fx1 = (x + 1) * tileSize
fy0 = y * tileSize
fy1 = (y + 1) * tileSize
Gfx.fillRectangle
renderer
(V2 (num fx0) (num fy0))
(V2 (num fx1) (num fy1))
(colorPixel color)
drawShape :: Color -> SDL.Renderer -> Int -> (Int, Int) -> (Shape, Color) -> IO ()
drawShape bgColor renderer tileSize (x,y) (shape,color) = case shape of
--
Circle -> do
Gfx.fillCircle renderer center radius color'
Gfx.fillCircle renderer center (radius - thickness') (colorPixel bgColor)
--
FillCircle -> Gfx.fillCircle renderer center radius color'
--
Triangle -> do
let (dax, day) = triDA
(dbx, dby) = triDB
(dcx, dcy) = triDC
ax = x * tileSize + dax
ay = y * tileSize + day
bx = x * tileSize + dbx
by = y * tileSize + dby
cx = x * tileSize + dcx
cy = y * tileSize + dcy
a = num <$> V2 ax ay
b = num <$> V2 bx by
c = num <$> V2 cx cy
Gfx.thickLine renderer a b thickness' color'
Gfx.thickLine renderer b c thickness' color'
Gfx.thickLine renderer c a thickness' color'
--
FillTriangle -> do
let (dax, day) = triDA
(dbx, dby) = triDB
(dcx, dcy) = triDC
ax = x * tileSize + dax
ay = y * tileSize + day
bx = x * tileSize + dbx
by = y * tileSize + dby
cx = x * tileSize + dcx
cy = y * tileSize + dcy
Gfx.fillTriangle
renderer
(V2 (num ax) (num ay))
(V2 (num bx) (num by))
(V2 (num cx) (num cy))
(colorPixel color)
--
Square -> do
let fx0 = x * tileSize + thickness
fx1 = (x + 1) * tileSize - thickness
fy0 = y * tileSize + thickness
fy1 = (y + 1) * tileSize - thickness
Gfx.rectangle
renderer
(V2 (num fx0) (num fy0))
(V2 (num fx1) (num fy1))
(colorPixel color)
--
FillSquare -> do
let fx0 = x * tileSize + thickness
fx1 = (x + 1) * tileSize - thickness
fy0 = y * tileSize + thickness
fy1 = (y + 1) * tileSize - thickness
Gfx.fillRectangle
renderer
(V2 (num fx0) (num fy0))
(V2 (num fx1) (num fy1))
(colorPixel color)
--
Plus -> do
let x' = x * tileSize + halfTile'
y' = y * tileSize + halfTile'
a = num <$> V2 x' (y * tileSize + thickness')
b = num <$> V2 x' ((y + 1) * tileSize - thickness')
c = num <$> V2 (x * tileSize + thickness') y'
d = num <$> V2 ((x + 1) * tileSize - thickness') y'
Gfx.thickLine renderer a b thickness' color'
Gfx.thickLine renderer c d thickness' color'
--
Dash -> do
let y' = y * tileSize + halfTile'
a = num <$> V2 (x * tileSize + thickness') y'
b = num <$> V2 ((x + 1) * tileSize - thickness') y'
Gfx.thickLine renderer a b thickness' color'
Bar -> do
let x' = x * tileSize + halfTile'
a = num <$> V2 x' (y * tileSize + thickness')
b = num <$> V2 x' ((y + 1) * tileSize - thickness')
Gfx.thickLine renderer a b thickness' color'
--
Cross -> do
let diff = halfTile' - thickness
left = x * tileSize + halfTile' - diff
right = x * tileSize + halfTile' + diff
top = y * tileSize + halfTile' - diff
bottom = y * tileSize + halfTile' + diff
a = num <$> V2 left top
b = num <$> V2 right bottom
c = num <$> V2 right top
d = num <$> V2 left bottom
Gfx.thickLine renderer a b thickness' color'
Gfx.thickLine renderer c d thickness' color'
where
thickness' :: Num a => a
thickness' = num thickness
thickness :: Int
thickness = max (tileSize `div` 8) 1
triAAngle = pi / 2
triBAngle = 2 * pi / 3 + pi / 2
triCAngle = 2 * 2 * pi / 3 + pi / 2
halfTile = fromIntegral tileSize / 2
halfTile' = tileSize `div` 2
triCorner angle =
( floor $ (halfTile * cos angle) + halfTile
, floor $ negate (halfTile * sin angle) + halfTile + fromIntegral tileSize * 0.1
)
triDA = triCorner triAAngle
triDB = triCorner triBAngle
triDC = triCorner triCAngle
center = (\n -> floor (num (n * tileSize) + halfTile)) <$> V2 x y
radius = floor $ halfTile * 0.8
color' = colorPixel color
drawSymbol :: SDL.Renderer -> (Color -> Char -> IO (Maybe (SDL.Texture, Int, Int))) -> Char -> Color -> Int -> (Int, Int) -> IO ()
drawSymbol renderer fontMap ch color tileSize (x,y) = do
m <- fontMap color ch
case m of
Nothing -> return ()
Just (tex, offsetX, offsetWidth) -> do
SDL.TextureInfo{SDL.textureWidth=_texWidth,SDL.textureHeight=texHeight} <- SDL.queryTexture tex
let wh = V2 (fromIntegral offsetWidth) texHeight
let wh2 = V2 (div (fromIntegral offsetWidth) 2) (div texHeight 2)
let xy' = xy + center - wh2
SDL.copy
renderer
tex
(Just $ SDL.Rectangle (SDL.P (fromIntegral <$> V2 offsetX 0)) (V2 (fromIntegral offsetWidth) texHeight))
(Just $ SDL.Rectangle (SDL.P xy') wh)
where
xy = fromIntegral <$> V2 (tileSize * x) (tileSize * y)
center = fromIntegral <$> V2 (tileSize `div` 2) (tileSize `div` 2)
colorPixel :: Color -> Gfx.Color
colorPixel c = bgr (colorValue c)
sdlColor :: Color -> Gfx.Color
sdlColor = bgr . colorValue
bgr :: (Word8, Word8, Word8) -> Gfx.Color
bgr (r,g,b) = V4 (num r) (num g) (num b) 0xff
colorValue :: Integral a => Color -> (a, a, a)
colorValue Red0 = (0xff, 0x44, 0x44)
colorValue Red1 = (0xff, 0x00, 0x00)
colorValue Red2 = (0xaa, 0x00, 0x00)
colorValue Orange0 = (0xff, 0xaf, 0x33)
colorValue Orange1 = (0xff, 0x7f, 0x00)
colorValue Orange2 = (0xcf, 0x4f, 0x00)
colorValue Yellow0 = (0xff, 0xff, 0x44)
colorValue Yellow1 = (0xff, 0xff, 0x00)
colorValue Yellow2 = (0xaa, 0xaa, 0x00)
colorValue Chartreuse0 = (0xb2, 0xff, 0x66)
colorValue Chartreuse1 = (0x7f, 0xff, 0x00)
colorValue Chartreuse2 = (0x58, 0xb2, 0x00)
colorValue Green0 = (0x44, 0xff, 0x44)
colorValue Green1 = (0x00, 0xff, 0x00)
colorValue Green2 = (0x00, 0xaa, 0x00)
colorValue Spring0 = (0x66, 0xff, 0xb2)
colorValue Spring1 = (0x00, 0xff, 0x7f)
colorValue Spring2 = (0x00, 0x99, 0x4c)
colorValue Cyan0 = (0xa0, 0xff, 0xff)
colorValue Cyan1 = (0x00, 0xff, 0xff)
colorValue Cyan2 = (0x00, 0x8b, 0x8b)
colorValue Azure0 = (0x00, 0x7f, 0xff)
colorValue Azure1 = (0x33, 0x66, 0x99)
colorValue Azure2 = (0x00, 0x33, 0x66)
colorValue Blue0 = (0x44, 0x44, 0xff)
colorValue Blue1 = (0x00, 0x00, 0xff)
colorValue Blue2 = (0x00, 0x00, 0xaa)
colorValue Violet0 = (0x93, 0x70, 0xdb)
colorValue Violet1 = (0x94, 0x00, 0xd3)
colorValue Violet2 = (0x80, 0x00, 0x80)
colorValue Magenta0 = (0xff, 0x9e, 0xff)
colorValue Magenta1 = (0xff, 0x00, 0xff)
colorValue Magenta2 = (0x8b, 0x00, 0x8b)
colorValue Rose0 = (0xff, 0x99, 0xcc)
colorValue Rose1 = (0xff, 0x66, 0x99)
colorValue Rose2 = (0xaa, 0x22, 0x44)
colorValue Brown0 = (0xaa, 0x77, 0x44)
colorValue Brown1 = (0x88, 0x44, 0x00)
colorValue Brown2 = (0x55, 0x22, 0x00)
colorValue Gray0 = (0xd3, 0xd3, 0xd3)
colorValue Gray1 = (0x80, 0x80, 0x80)
colorValue Gray2 = (0xa9, 0xa9, 0xa9)
colorValue White0 = (0xff, 0xff, 0xf0)
colorValue White1 = (0xff, 0xff, 0xff)
colorValue White2 = (0xf0, 0xff, 0xff)
colorValue Black0 = (0x10, 0x00, 0x00)
colorValue Black1 = (0x00, 0x00, 0x00)
colorValue Black2 = (0x00, 0x10, 0x10)
rd0, rd1, rd2,
or0, or1, or2,
yw0, yw1, yw2,
ch0, ch1, ch2,
gn0, gn1, gn2,
sp0, sp1, sp2,
cn0, cn1, cn2,
az0, az1, az2,
bu0, bu1, bu2,
vt0, vt1, vt2,
mg0, mg1, mg2,
rs0, rs1, rs2,
br0, br1, br2,
gy0, gy1, gy2,
wh0, wh1, wh2,
bk0, bk1, bk2 :: Color
(rd0, rd1, rd2) = (Red0, Red1, Red2)
(or0, or1, or2) = (Orange0, Orange1, Orange2)
(yw0, yw1, yw2) = (Yellow0, Yellow1, Yellow2)
(ch0, ch1, ch2) = (Chartreuse0, Chartreuse1, Chartreuse2)
(gn0, gn1, gn2) = (Green0, Green1, Green2)
(sp0, sp1, sp2) = (Spring0, Spring1, Spring2)
(cn0, cn1, cn2) = (Cyan0, Cyan1, Cyan2)
(az0, az1, az2) = (Azure0, Azure1, Azure2)
(bu0, bu1, bu2) = (Blue0, Blue1, Blue2)
(vt0, vt1, vt2) = (Violet0, Violet1, Violet2)
(mg0, mg1, mg2) = (Magenta0, Magenta1, Magenta2)
(rs0, rs1, rs2) = (Rose0, Rose1, Rose2)
(br0, br1, br2) = (Brown0, Brown1, Brown2)
(gy0, gy1, gy2) = (Gray0, Gray1, Gray2)
(wh0, wh1, wh2) = (White0, White1, White2)
(bk0, bk1, bk2) = (Black0, Black1, Black2)
rainbow :: [Color]
rainbow = [rd1, or1, yw1, ch1, gn1, sp1, cn1, az1, bu1, vt1, mg1, rs1]
tileByMousePosition :: Int -> (Int, Int) -> (Int, Int) -> Maybe (Int, Int)
tileByMousePosition tileSize (mx,my) (r,c)
| mx < 0 || my < 0 || mx >= tileSize * c || my >= tileSize * r = Nothing
| otherwise = Just (mx `div` tileSize, my `div` tileSize)
symbolList :: [Char]
symbolList = "`1234567890-=~!@#$%^&*()_+qwertyuiop[]\\QWERTYUIOP{}|asdfghjkl;'ASDFGHJKL:\"zxcvbnm,./ZXCVBNM<>?"
toTexture :: SDL.Renderer -> SDL.Surface -> IO SDL.Texture
toTexture renderer surface = do
texture <- SDL.createTextureFromSurface renderer surface
SDL.freeSurface surface
return texture
placeTile :: (Int, Int) -> Tile -> Map (Int, Int) Tile -> Map (Int, Int) Tile
placeTile xy tile m = Map.insertWith (<>) xy tile m
placeTilesAt
:: Map (Int, Int) Tile -- | Base tiles
-> (Int, Int) -- | Offset
-> Map (Int, Int) Tile -- | Tiles to be placed
-> Map (Int, Int) Tile
placeTilesAt old (x,y) new = foldr (\((x',y'), tile) m' -> placeTile (x+x', y+y') tile m') old (Map.toList new)
mergeTiles
:: Map (Int, Int) Tile -- | Base tiles
-> Map (Int, Int) Tile -- | Tiles to be placed
-> Map (Int, Int) Tile
mergeTiles old new = placeTilesAt old (0,0) new
loadFont :: SDL.Renderer -> Int -> IO (Font.Font, Int)
loadFont renderer tileSize = (,) <$> Font.decode fontData size <*> pure size
where
size = tileSize `div` 2
newFontColorMap :: IO (IORef (Map Color SDL.Texture))
newFontColorMap = newIORef Map.empty
loadSymbols :: SDL.Renderer -> Font.Font -> Color -> IO SDL.Texture
loadSymbols renderer font color = do
symSurface <- Font.solid font (colorPixel color) (pack symbolList)
toTexture renderer symSurface
findSymbols
:: SDL.Renderer
-> Font.Font
-> Int
-> IORef (Map Color SDL.Texture)
-> Color
-> Char
-> IO (Maybe (SDL.Texture, Int, Int))
findSymbols renderer font width ref color ch = do
let width' = width `div` 2
fontMap <- readIORef ref
case lookupMap color fontMap of
Just tex -> case lookupMap ch offsets of
Nothing -> return Nothing
Just off -> return $ Just (tex, off * width', width')
Nothing -> case lookupMap ch offsets of
Nothing -> return Nothing
Just off -> do
sym <- loadSymbols renderer font color
modifyIORef ref (insert color sym)
return $ Just (sym, off * width', width')
where
offsets = Map.fromList $ zip symbolList [0..]
playSfxs :: Mixer.Chunk -> Mixer.Chunk -> [Sfx] -> IO ()
playSfxs achievement gong sfxs = flip mapM_ sfxs $ \sfx -> case sfx of
Achievement -> Mixer.playOn 0 1 achievement
Gong -> Mixer.playOn 0 2 gong