intricacy-0.9.0.0: SDL2UI.hs
-- This file is part of Intricacy
-- Copyright (C) 2013-2025 Martin Bays <mbays@sdf.org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of version 3 of the GNU General Public License as
-- published by the Free Software Foundation, or any later version.
--
-- You should have received a copy of the GNU General Public License
-- along with this program. If not, see http://www.gnu.org/licenses/.
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module SDL2UI where
import Control.Applicative
import Control.Monad
import Control.Monad.Catch (handleAll)
import Control.Monad.State
import Control.Monad.Trans.Maybe
import Data.List
import Data.Map (Map, (!?))
import qualified Data.Map as Map
import Data.Maybe
import Data.Ratio
import Data.Time.Clock (getCurrentTime)
import Data.Word
import qualified SDL
import SDL hiding (get, rotate, zero, (*^))
import qualified SDL.Font as TTF
import SDL.Primitive (Color)
import System.FilePath
--import Debug.Trace (traceShow)
import Foreign.C.Types (CInt)
import Foreign.Ptr (nullPtr)
#ifdef SOUND
import SDL.Mixer
import System.Random (randomRIO)
#endif
import qualified SimpleCache as SC
import BoardColouring
import Command
import Font
import GameState
import GameStateTypes
import Hex
import InputMode
import KeyBindings
import Lock
import Maxlocksize
import Metagame
import Mundanities
import Physics
import SDL2Glyph
import SDL2Render
import SDL2RenderCache
import Util
data UIState = UIState
{ scrDimen :: V2 CInt
, sdlWindow :: Maybe Window
, vidRenderer :: Maybe Renderer
, backbuffer :: Maybe Texture
, unblockEventType :: Maybe (RegisteredEventType ())
, bgTexture :: Maybe Texture
, rCache :: RenderCache
, lastDrawArgs :: Maybe DrawArgs
, miniLocks :: SC.SimpleCache Lock Texture
, registeredSelectables :: Map HexVec Selectable
, contextButtons :: [ButtonGroup]
, uiOptions :: UIOptions
, settingBinding :: Maybe Command
, uiKeyBindings :: Map InputMode KeyBindings
, dispFont :: Maybe TTF.Font
, dispFontSmall :: Maybe TTF.Font
, lastFrameTicks :: Word32
, paintTileIndex :: Int
, leftButtonDown :: Maybe HexVec
, middleButtonDown :: Maybe HexVec
, rightButtonDown :: Maybe HexVec
, mousePos :: (HexVec,Bool)
, message :: Maybe (Color, String)
, hoverStr :: Maybe String
, dispCentre :: HexPos
, dispLastCol :: PieceColouring
, animFrame :: Int
, nextAnimFrameAt :: Maybe Word32
, fps :: Int
#ifdef SOUND
, sounds :: Map String [Chunk]
#endif
}
emptyMiniLocks :: SC.SimpleCache Lock Texture
emptyMiniLocks = SC.empty 50 destroyTexture
type UIM = StateT UIState IO
nullUIState = UIState (V2 0 0) Nothing Nothing Nothing Nothing Nothing emptyRenderCache Nothing emptyMiniLocks Map.empty []
defaultUIOptions Nothing Map.empty Nothing Nothing 0 0 Nothing Nothing Nothing
(zero,False) Nothing Nothing (PHS zero) Map.empty 0 Nothing 50
#ifdef SOUND
Map.empty
#endif
data UIOptions = UIOptions
{ useFiveColouring :: Bool
, showBlocks :: ShowBlocks
, jiggleBlocked :: Bool
, whsButtons :: Map InputMode WrHoSel
, useBackground :: Bool
, fullscreen :: Bool
, showButtonText :: Bool
, soundVolume :: Int
, uiAnimTime :: Word32
, shortUiAnimTime :: Word32
}
deriving (Eq, Ord, Show, Read)
defaultUIOptions = UIOptions False ShowBlocksNone True Map.empty True False True 64 50 20
modifyUIOptions :: (UIOptions -> UIOptions) -> UIM ()
modifyUIOptions f = modify $ \s -> s { uiOptions = f $ uiOptions s }
renderToMain :: RenderM a -> UIM a
renderToMain m = do
Just rend <- gets vidRenderer
cache <- gets rCache
(a,cache') <- renderToMainWithRenderer rend cache m
modify $ \s -> s { rCache = cache' }
pure a
renderToMainWithRenderer :: Renderer -> RenderCache -> RenderM a -> UIM (a, RenderCache)
renderToMainWithRenderer rend cache m = do
(scrCentre, size) <- getGeom
centre <- gets dispCentre
mfont <- gets dispFont
bgt <- gets bgTexture
V2 w _ <- gets scrDimen
liftIO $ runRenderM m cache $ RenderContext rend bgt centre scrCentre zero size mfont w
refresh :: UIM ()
refresh = do
-- We use our own backbuffer, so we can update parts of the screen between
-- presentations without the rest of the screen being invalidated.
Just rend <- gets vidRenderer
Just bb <- gets backbuffer
rendererRenderTarget rend $= Nothing
copy rend bb Nothing Nothing
present rend
clear rend
rendererRenderTarget rend $= Just bb
clearFrame :: UIM ()
clearFrame = do
Just rend <- gets vidRenderer
rendererDrawColor rend $= black
SDL.clear rend
waitFrame :: UIM ()
waitFrame = do
next <- gets $ (+ 1000 `div` 30) . lastFrameTicks
now <- ticks
when (now < next) $
liftIO $ delay (next - now)
now' <- ticks
modify $ \ds -> ds { lastFrameTicks = now' }
data Button = Button { buttonPos :: HexVec, buttonCmd :: Command, buttonHelp :: [ButtonHelp] }
deriving (Eq, Ord, Show)
type ButtonGroup = ([Button],(Int,Int))
type ButtonHelp = (String, HexVec)
singleButton :: HexVec -> Command -> Int -> [ButtonHelp] -> ButtonGroup
singleButton pos cmd col helps = ([Button pos cmd helps], (col,0))
getButtons :: InputMode -> UIM [ ButtonGroup ]
getButtons mode = do
mwhs <- gets $ (!? mode) . whsButtons . uiOptions
cntxtButtons <- gets contextButtons
return $ cntxtButtons ++ global ++ case mode of
IMEdit -> [
singleButton (tl+^hv+^neg hw) CmdTest 1 [("test", hu+^neg hw)]
, singleButton (tl+^neg hw) CmdPlay 2 [("play", hu+^neg hw)]
, markButtonGroup
, singleButton (br+^2*^hu) CmdWriteState 2 [("save", hu+^neg hw)] ]
++ whsBGs mwhs
++ [ ([Button (paintButtonStart +^ hu +^ i*^hv) (paintTileCmds!!i) []
| i <- take (length paintTiles) [0..] ],(5,0)) ]
IMPlay -> whsBGs mwhs
IMReplay -> [ markButtonGroup ]
IMMeta ->
[ singleButton serverPos CmdSetServer 0 [("server",7*^neg hu)]
, singleButton (serverPos+^hw) CmdToggleCacheOnly 0 [("offline",hv+^7*^neg hu),("mode",hw+^5*^neg hu)]
, singleButton (codenamePos +^ 2*^neg hu) (CmdSelCodename Nothing) 2 [("code",hv+^5*^neg hu),("name",hw+^5*^neg hu)]
, singleButton (serverPos +^ 2*^neg hv +^ 2*^hw) CmdInitiation 3 [("initi",hu+^neg hw),("ation",hu+^neg hv)]
]
_ -> []
where
global = if mode `elem` [IMTextInput,IMImpatience] then [] else
[ singleButton br CmdQuit 0 [("quit",hu+^neg hw)]
, singleButton (tr +^ 3*^hv +^ 3*^hu) CmdHelp 3 [("help",hu+^neg hw)] ]
whsBGs :: Maybe WrHoSel -> [ ButtonGroup ]
whsBGs Nothing = []
whsBGs (Just whs) =
let edit = mode == IMEdit
in [ ( [ Button bl (if edit then CmdSelect else CmdWait) [] ], (0,0))
, ( [ Button (bl+^dir) (CmdDir whs dir)
(if dir==hu then [("move",hu+^neg hw),(if edit then "piece" else whsStr whs,hu+^neg hv)] else [])
| dir <- hexDirs ], (5,0) )
] ++
([( [ Button (bl+^((-2)*^hv))
(CmdRotate whs (-1))
[("turn",hu+^neg hw),("cw",hu+^neg hv)]
, Button (bl+^((-2)*^hw))
(CmdRotate whs 1)
[("turn",hu+^neg hw),("ccw",hu+^neg hv)]
], (5,0) ) | whs /= WHSWrench]) ++
([( [ Button (bl+^(2*^hv)+^hw+^neg hu) CmdToggle [("swap",hu+^neg hw),("tool",hu+^neg hv)]
], (2,0) ) | whs == WHSSelected && mode /= IMEdit])
tr = periphery 0
tl = periphery 2
bl = periphery 3
br = periphery 5
markButtonGroup = ([Button (tl+^hw) CmdMark [("set",hu+^neg hw),("mark",hu+^neg hv)]
, Button (tl+^hw+^hv) CmdJumpMark [("jump",hu+^neg hw),("mark",hu+^neg hv)]
, Button (tl+^hw+^2*^hv) CmdReset [("jump",hu+^neg hw),("start",hu+^neg hv)]],(0,1))
where
tl = periphery 2
data AccessedInfo = AccessedSolved | AccessedPublic | AccessedReadNotes | AccessedUndeclared
deriving (Eq, Ord, Show)
data Selectable
= SelOurLock
| SelTut Bool
| SelInitLock HexVec Bool
| SelLock ActiveLock
| SelLockUnset Bool ActiveLock
| SelSelectedCodeName Codename
| SelRelScore
| SelRelScoreComponent
| SelScoreLock (Maybe Codename) (Maybe AccessedReason) ActiveLock
| SelUndeclared Undeclared
| SelReadNote NoteInfo
| SelReadNoteSlot
| SelSolution NoteInfo
| SelAccessed Codename
| SelRandom Codename
| SelSecured NoteInfo
| SelOldLock LockSpec
| SelPublicLock
| SelAccessedInfo AccessedInfo
| SelLockPath
| SelPrivyHeader
| SelNotesHeader
| SelToolHook
| SelToolWrench Bool
deriving (Eq, Ord, Show)
registerSelectable :: HexVec -> Int -> Selectable -> UIM ()
registerSelectable v r s =
modify $ \ds -> ds {registeredSelectables = foldr (
(`Map.insert` s) . (v+^)) (registeredSelectables ds) (hexDisc r)}
registerButtonGroup :: ButtonGroup -> UIM ()
registerButtonGroup g = modify $ \ds -> ds {contextButtons = g:contextButtons ds}
registerButton :: HexVec -> Command -> Int -> [ButtonHelp] -> UIM ()
registerButton pos cmd col helps = registerButtonGroup $ singleButton pos cmd col helps
clearSelectables,clearButtons :: UIM ()
clearSelectables = modify $ \ds -> ds {registeredSelectables = Map.empty}
clearButtons = modify $ \ds -> ds {contextButtons = []}
registerUndoButtons :: Bool -> UIM ()
registerUndoButtons noRedo = do
registerButton (periphery 2+^hu) CmdUndo 0 [("undo",hu+^neg hw)]
unless noRedo $ registerButton (periphery 2+^hu+^neg hv) CmdRedo 2 [("redo",hu+^neg hw)]
commandOfSelectable IMInit (SelTut _) _ = Just . CmdSolveInit $ Just zero
commandOfSelectable IMInit (SelInitLock v _) _ = Just . CmdSolveInit $ Just v
commandOfSelectable IMMeta SelOurLock _ = Just CmdEdit
commandOfSelectable IMMeta (SelLock (ActiveLock _ i)) False = Just $ CmdSolve (Just i)
commandOfSelectable IMMeta (SelLock (ActiveLock _ i)) True = Just $ CmdPlaceLock (Just i)
commandOfSelectable IMMeta (SelScoreLock Nothing _ (ActiveLock _ i)) False = Just $ CmdSolve (Just i)
commandOfSelectable IMMeta (SelScoreLock Nothing _ (ActiveLock _ i)) True = Just $ CmdPlaceLock (Just i)
commandOfSelectable IMMeta (SelScoreLock (Just _) _ _) _ = Just CmdHome
commandOfSelectable IMMeta (SelLockUnset True (ActiveLock _ i)) _ = Just $ CmdPlaceLock (Just i)
commandOfSelectable IMMeta (SelSelectedCodeName _) False = Just $ CmdSelCodename Nothing
commandOfSelectable IMMeta (SelSelectedCodeName _) True = Just CmdHome
commandOfSelectable IMMeta (SelUndeclared undecl) _ = Just $ CmdDeclare $ Just undecl
commandOfSelectable IMMeta (SelReadNote note) False = Just $ CmdSelCodename $ Just $ noteAuthor note
commandOfSelectable IMMeta (SelReadNote note) True = Just $ CmdViewSolution $ Just note
commandOfSelectable IMMeta (SelSolution note) False = Just $ CmdSelCodename $ Just $ noteAuthor note
commandOfSelectable IMMeta (SelSolution note) True = Just $ CmdViewSolution $ Just note
commandOfSelectable IMMeta (SelAccessed name) _ = Just $ CmdSelCodename $ Just name
commandOfSelectable IMMeta (SelRandom name) _ = Just $ CmdSelCodename $ Just name
commandOfSelectable IMMeta (SelSecured note) False = Just $ CmdSelCodename $ Just $ lockOwner $ noteOn note
commandOfSelectable IMMeta (SelSecured note) True = Just $ CmdViewSolution $ Just note
commandOfSelectable IMMeta (SelOldLock ls) _ = Just $ CmdPlayLockSpec $ Just ls
commandOfSelectable IMMeta SelLockPath _ = Just CmdSelectLock
commandOfSelectable IMTextInput (SelLock (ActiveLock _ i)) _ = Just $ CmdInputSelLock i
commandOfSelectable IMTextInput (SelScoreLock _ _ (ActiveLock _ i)) _ = Just $ CmdInputSelLock i
commandOfSelectable IMTextInput (SelLockUnset _ (ActiveLock _ i)) _ = Just $ CmdInputSelLock i
commandOfSelectable IMTextInput (SelReadNote note) _ = Just $ CmdInputCodename $ noteAuthor note
commandOfSelectable IMTextInput (SelSolution note) _ = Just $ CmdInputCodename $ noteAuthor note
commandOfSelectable IMTextInput (SelSecured note) _ = Just $ CmdInputCodename $ lockOwner $ noteOn note
commandOfSelectable IMTextInput (SelRandom name) _ = Just $ CmdInputCodename name
commandOfSelectable IMTextInput (SelUndeclared undecl) _ = Just $ CmdInputSelUndecl undecl
commandOfSelectable _ _ _ = Nothing
helpOfSelectable (SelTut False) = Just "Enter tutorials"
helpOfSelectable (SelTut True) = Just "Revisit tutorials"
helpOfSelectable (SelInitLock _ False) = Just "Attempt lock"
helpOfSelectable (SelInitLock _ True) = Just "Revisit solved lock"
helpOfSelectable SelOurLock = Just
"Design a lock."
helpOfSelectable (SelSelectedCodeName name) = Just $
"Currently viewing player "++name++"."
helpOfSelectable SelRelScore = Just
"The extent to which you are held in higher esteem than this player."
helpOfSelectable SelRelScoreComponent = Just
"Contribution to total relative esteem."
helpOfSelectable (SelLock (ActiveLock name i)) = Just $
name++"'s lock "++[lockIndexChar i]++"."
helpOfSelectable (SelLockUnset True _) = Just
"Place a lock."
helpOfSelectable (SelLockUnset False _) = Just
"An empty lock slot."
helpOfSelectable (SelUndeclared _) = Just
"Declare your solution to a lock by securing a note on it behind a lock of your own."
helpOfSelectable (SelRandom _) = Just
"Random set of players. Colours show relative esteem, bright red (-3) to bright green (+3)."
helpOfSelectable (SelScoreLock (Just name) Nothing _) = Just $
"Your lock. "++name++" can not not unlock it."
helpOfSelectable (SelScoreLock (Just name) (Just AccessedPrivy) _) = Just $
"Your lock. "++name++" can unlock it: -1 to relative esteem."
helpOfSelectable (SelScoreLock (Just _) (Just AccessedPub) _) = Just
"Your lock. Its secrets have been publically revealed: -1 to relative esteem."
helpOfSelectable (SelScoreLock (Just name) (Just AccessedEmpty) _) = Just $
"Your empty lock slot. "++name++" can unlock all your locks: -1 to relative esteem."
helpOfSelectable (SelScoreLock Nothing Nothing (ActiveLock name _)) = Just $
name++"'s lock. You can not unlock it."
helpOfSelectable (SelScoreLock Nothing (Just AccessedPrivy) (ActiveLock name _)) = Just $
name++"'s lock. You can unlock it: +1 to relative esteem."
helpOfSelectable (SelScoreLock Nothing (Just AccessedPub) (ActiveLock name _)) = Just $
name++"'s lock. Its secrets have been publically revealed: +1 to relative esteem."
helpOfSelectable (SelScoreLock Nothing (Just AccessedEmpty) (ActiveLock name _)) = Just $
name++"'s empty lock slot. You can unlock all "++name++"'s locks: +1 to relative esteem."
helpOfSelectable (SelReadNote note) = Just $
"You have read "++noteAuthor note++"'s note on this lock."
helpOfSelectable SelReadNoteSlot = Just
"Reading three notes on this lock would suffice to reveal its secrets."
helpOfSelectable (SelSecured note) = let ActiveLock owner idx = noteOn note in
Just $ "Secured note on "++owner++"'s lock "++[lockIndexChar idx]++"."
helpOfSelectable (SelSolution note) = Just $ case noteBehind note of
Just (ActiveLock owner idx) -> owner ++
" has secured their note on this lock behind their lock " ++ [lockIndexChar idx] ++ "."
Nothing -> noteAuthor note ++ "'s note on this lock is public knowledge."
helpOfSelectable (SelAccessed name) = Just $
name ++ " did not pick this lock, but learnt how to unlock it by reading three notes on it."
helpOfSelectable SelPublicLock = Just
"Notes behind retired or public locks are public; a lock with three public notes on it is public."
helpOfSelectable (SelAccessedInfo meth) = Just $ case meth of
AccessedSolved -> "You picked this lock and declared your solution, so may read any notes it secures."
AccessedPublic -> "The secrets of this lock have been publically revealed."
AccessedUndeclared -> "You have picked this lock, but are yet to declare your solution."
AccessedReadNotes ->
"Having read three notes on others' solutions to this lock, you have unravelled its secrets."
helpOfSelectable (SelOldLock ls) = Just $
"Retired lock #"++show ls++". Any notes which were secured by the lock are now public knowledge."
helpOfSelectable SelLockPath = Just
"Select a lock by its name. The names you give your locks are not revealed to others."
helpOfSelectable SelPrivyHeader = Just
"Notes on this lock declared by players who picked the lock."
helpOfSelectable SelNotesHeader = Just
"Notes secured by this lock. These notes are read by everyone who can unlock the lock."
helpOfSelectable (SelToolWrench False) = Just "The wrench, one of your lockpicking tools. Click and drag to move."
helpOfSelectable (SelToolWrench True) = Just "The wrench, currently in motion. It will keep moving until it is blocked."
helpOfSelectable SelToolHook = Just "The hook, one of your lockpicking tools. Click and drag to move, use mousewheel to turn."
cmdAtMousePos (mPos,central) im selMode = do
buttons <- concatMap fst <$> getButtons im
sels <- gets registeredSelectables
return $ listToMaybe $
[ buttonCmd button
| button <- buttons, mPos == buttonPos button, central]
++ maybe [] (\isRight ->
[ cmd
| Just sel <- [Map.lookup mPos sels]
, Just cmd <- [ commandOfSelectable im sel isRight ] ])
selMode
helpAtMousePos :: (HexVec, Bool) -> InputMode -> UIM (Maybe [Char])
helpAtMousePos (mPos,_) _ = do
lb <- gets $ isJust . leftButtonDown
gets $ (helpOfSelectableFiltered lb <=< Map.lookup mPos) . registeredSelectables
where
-- Don't show tool help while dragging
helpOfSelectableFiltered True SelToolHook = Nothing
helpOfSelectableFiltered True (SelToolWrench _) = Nothing
helpOfSelectableFiltered _ s = helpOfSelectable s
data UIOptButton a = UIOptButton { getUIOpt :: UIOptions->a, setUIOpt :: a->UIOptions->UIOptions,
uiOptVals :: [a], uiOptPos :: HexVec, uiOptGlyph :: a->Glyph, uiOptDescr :: a->String,
uiOptModes :: [InputMode], onSet :: Maybe (a -> UIM ()) }
-- non-uniform type, so can't use a list...
uiOB1 = UIOptButton useFiveColouring (\v o -> o {useFiveColouring=v}) [True,False]
(periphery 0 +^ 3 *^ hu +^ neg hv) UseFiveColourButton
(\v -> if v then "Adjacent pieces get different colours" else
"Pieces are coloured according to type")
[] -- disabled
Nothing
uiOB2 = UIOptButton showBlocks (\v o -> o {showBlocks=v}) [ShowBlocksBlocking,ShowBlocksAll,ShowBlocksNone]
(periphery 0 +^ 2 *^ hu +^ 2 *^ neg hv) ShowBlocksButton
(\case
ShowBlocksBlocking -> "Showing conflicting forces"
ShowBlocksAll -> "Showing conflicting forces and movements they prevent"
ShowBlocksNone -> "Not showing conflicts")
[IMPlay, IMReplay] Nothing
uiOB3P = UIOptButton ((!? IMPlay) . whsButtons) (\v o -> o { whsButtons = Map.alter (const v) IMPlay $ whsButtons o })
[Nothing, Just WHSSelected, Just WHSHook, Just WHSWrench]
(periphery 3 +^ 3 *^ hv) WhsButtonsButton
(\case
Nothing -> "Click to show (and rebind) keyboard control buttons."
Just whs -> "Showing buttons for controlling " ++ case whs of
WHSSelected -> "selected piece; right-click on buttons to rebind"
WHSWrench -> "wrench; right-click on buttons to rebind"
WHSHook -> "hook; right-click on buttons to rebind")
[IMPlay] Nothing
uiOB3E = UIOptButton ((!? IMEdit) . whsButtons) (\v o -> o { whsButtons = Map.alter (const v) IMEdit $ whsButtons o })
[Nothing, Just WHSSelected]
(periphery 3 +^ 3 *^ hv) WhsEditButtonsButton
(\case
Nothing -> "Click to show (and rebind) keyboard control buttons."
Just _ -> "Showing buttons for controlling cursor / selected piece; right-click on buttons to rebind")
[IMEdit] Nothing
uiOB4 = UIOptButton showButtonText (\v o -> o {showButtonText=v}) [True,False]
(periphery 0 +^ 2 *^ hu +^ 3 *^ hv) ShowButtonTextButton
(\v -> if v then "Help text enabled" else
"Help text disabled")
[IMPlay, IMEdit, IMReplay, IMMeta, IMInit] Nothing
uiOB5 = UIOptButton fullscreen (\v o -> o {fullscreen=v}) [True,False]
(periphery 0 +^ 4 *^ hu +^ 2 *^ hv) FullscreenButton
(\v -> if v then "Fullscreen mode active" else "Windowed mode active")
[IMPlay, IMEdit, IMReplay, IMMeta, IMInit] (Just onFullScreenChange)
uiOB6 = UIOptButton soundVolume (\v o -> o {soundVolume=v}) [64,0,16,32]
(periphery 0 +^ 4 *^ hu +^ hv) VolumeButton
(\case
v | v >= 64 -> "Sound effects at full volume"
v | v >= 32 -> "Sound effects at medium volume"
0 -> "Sound effects disabled"
_ -> "Sound effects at low volume")
[IMPlay, IMEdit, IMReplay] $ Just (`setVolume` AllChannels)
drawUIOptionButtons :: InputMode -> UIM ()
drawUIOptionButtons mode = do
drawUIOptionButton mode uiOB1
drawUIOptionButton mode uiOB2
drawUIOptionButton mode uiOB3P
drawUIOptionButton mode uiOB3E
drawUIOptionButton mode uiOB4
drawUIOptionButton mode uiOB5
#ifdef SOUND
drawUIOptionButton mode uiOB6
#endif
drawUIOptionButton im b = when (im `elem` uiOptModes b) $ do
value <- gets $ getUIOpt b . uiOptions
renderToMain $ mapM_ (\g -> drawAtRel g (uiOptPos b))
[HollowGlyph $ obscure purple, uiOptGlyph b value]
describeUIOptionButton :: UIOptButton a -> MaybeT UIM String
describeUIOptionButton b = do
value <- gets $ getUIOpt b . uiOptions
return $ uiOptDescr b value
-- XXX: hand-hacking lenses...
toggleUIOption (UIOptButton getopt setopt vals _ _ _ _ monSet) = do
value <- gets $ getopt . uiOptions
let value' = cycle vals !! max 0 (1 + fromMaybe 0 (elemIndex value vals))
modifyUIOptions $ setopt value'
maybe (pure ()) ($ value') monSet
readUIConfigFile :: UIM ()
readUIConfigFile = do
path <- liftIO $ confFilePath "SDLUI.conf"
mOpts <- liftIO $ readReadFile path
case mOpts of
Just opts -> modify $ \s -> s {uiOptions = opts}
Nothing -> return ()
writeUIConfigFile :: UIM ()
writeUIConfigFile = do
path <- liftIO $ confFilePath "SDLUI.conf"
opts <- gets uiOptions
liftIO makeConfDir
liftIO $ writeFile path $ show opts
readBindings :: UIM ()
readBindings = do
path <- liftIO $ confFilePath "bindings"
mbdgs <- liftIO $ readReadFile path
case mbdgs of
Just bdgs -> modify $ \s -> s {uiKeyBindings = bdgs}
Nothing -> return ()
writeBindings :: UIM ()
writeBindings = do
path <- liftIO $ confFilePath "bindings"
bdgs <- gets uiKeyBindings
liftIO makeConfDir
liftIO $ writeFile path $ show bdgs
getBindings :: InputMode -> UIM [(Char, Command)]
getBindings mode = do
uibdgs <- gets (Map.findWithDefault [] mode . uiKeyBindings)
return $ uibdgs ++ bindings mode
paintTiles :: [ Maybe Tile ]
paintTiles =
[ Just BallTile
, Just $ ArmTile zero False
, Just $ PivotTile zero
, Just $ SpringTile Relaxed zero
, Just $ BlockTile []
, Nothing
]
paintTileCmds = map (maybe CmdDelete CmdTile) paintTiles
getEffPaintTileIndex :: UIM Int
getEffPaintTileIndex = do
mods <- liftIO getModState
if keyModifierLeftCtrl mods || keyModifierRightCtrl mods
then return $ length paintTiles - 1
else gets paintTileIndex
paintButtonStart :: HexVec
paintButtonStart = periphery 0 +^ (- length paintTiles `div` 2)*^hv
drawPaintButtons :: UIM ()
drawPaintButtons = do
pti <- getEffPaintTileIndex
renderToMain $ sequence_ [
do
let gl = case paintTiles!!i of
Nothing -> HollowInnerGlyph $ dim purple
Just t -> TileGlyph t $ dim purple
drawAtRel gl pos
when selected $ drawAtRel cursorGlyph pos
| i <- take (length paintTiles) [0..]
, let pos = paintButtonStart +^ i*^hv
, let selected = i == pti
]
periphery 0 = ((3*maxlocksize)`div`2)*^hu +^ ((3*maxlocksize)`div`4)*^hv
periphery n = rotate n $ periphery 0
-- ^ XXX only peripheries 0,2,3,5 are guaranteed to be on-screen!
--messageLineStart = (maxlocksize+1)*^hw
messageLineCentre = ((maxlocksize+1)`div`2)*^hw +^ ((maxlocksize+1+1)`div`2)*^neg hv
-- XXX HACK: the n=8 line is crowded
titlePos n = titlePos' $ if n == 8 then 9 else n
where titlePos' l = l*^hv +^ (l`div`2)*^hu
screenWidthHexes,screenHeightHexes :: CInt
screenWidthHexes = 32
screenHeightHexes = 26
getGeom :: UIM (SVec, CInt)
getGeom = do
V2 w h <- gets scrDimen
let scrCentre = SVec (w`div`2) (h`div`2)
-- |size is the greatest integer such that
-- and [2*size*screenWidthHexes < width
-- , 3*ysize size*screenHeightHexes < height]
-- where ysize size = round $ fi size / sqrt 3
-- Minimum allowed size is 2 (get segfaults on SDL_FreeSurface with 1).
let size = max 2 $ min ((w-1)`div`(2*screenWidthHexes))
(floor $ sqrt 3 * (0.5 + fi ((h-1)`div`(3*screenHeightHexes))))
return (scrCentre, size)
clearAnim :: UIM ()
clearAnim = modify $ \ds -> ds { animFrame = 0, nextAnimFrameAt = Nothing }
data DrawArgs = DrawArgs [PieceIdx] Bool [Alert] GameState UIOptions
deriving (Eq, Ord, Show)
drawMainGameState :: [PieceIdx] -> Bool -> [Alert] -> GameState -> UIM ()
drawMainGameState highlight colourFixed alerts st = do
uiopts <- gets uiOptions
drawMainGameState' $ DrawArgs highlight colourFixed alerts st uiopts
data AnimFrameInfo = AnimFrameInfo
{ animFrameAlerts :: [Alert]
, animFrameState :: GameState
, animFrameIsIntermediate :: Bool
} deriving Eq
drawMainGameState' :: DrawArgs -> UIM ()
drawMainGameState' args@(DrawArgs highlight colourFixed alerts st uiopts) = do
lastArgs <- gets lastDrawArgs
when (case lastArgs of
Nothing -> True
Just (DrawArgs _ _ lastAlerts lastSt _) ->
lastAlerts /= alerts || lastSt /= st)
clearAnim
modify $ \ds -> ds { lastDrawArgs = Just args }
lastAnimFrame <- gets animFrame
now <- ticks
anim <- gets (maybe False (<now) . nextAnimFrameAt)
when anim $
modify $ \ds -> ds { animFrame = lastAnimFrame+1, nextAnimFrameAt = Nothing }
animFrameToDraw <- gets animFrame
noJiggle <- gets $ not . jiggleBlocked . uiOptions
-- split the alerts at intermediate states, and associate alerts
-- to the right states:
let (globalAlerts,transitoryAlerts) = partition isGlobalAlert alerts
splitAlerts :: [Alert] -> [Alert] -> [AnimFrameInfo]
splitAlerts frameAs (AlertIntermediateState st' : as) =
AnimFrameInfo frameAs st' True : splitAlerts [] as
splitAlerts frameAs (a:as) =
splitAlerts (a:frameAs) as
splitAlerts frameAs [] = [AnimFrameInfo frameAs st False]
jiggleLast :: [AnimFrameInfo] -> [AnimFrameInfo]
jiggleLast afis | noJiggle = afis
jiggleLast [AnimFrameInfo as st' False]
| jiggles <- nub $ mapMaybe blockedToForce globalAlerts
, not (null jiggles)
= [ AnimFrameInfo jiggles st' True
, AnimFrameInfo as st' False]
jiggleLast (af:afs) = af : jiggleLast afs
jiggleLast [] = []
isGlobalAlert (AlertAppliedForce _) = False
isGlobalAlert (AlertIntermediateState _) = False
isGlobalAlert _ = True
blockedToForce (AlertBlockedForce (Push idx dir)) = Just $ AlertAppliedForce (Push idx $ neg dir)
blockedToForce (AlertBlockedForce (Torque idx tdir)) = Just $ AlertAppliedForce (Torque idx $ -tdir)
blockedToForce _ = Nothing
let animAlertedStates = jiggleLast $ nub $
let ass = splitAlerts [] transitoryAlerts
in if last ass == AnimFrameInfo [] st False then ass else ass ++ [AnimFrameInfo [] st False]
let frames = length animAlertedStates
let AnimFrameInfo drawAlerts' drawSt isIntermediate = animAlertedStates !! animFrameToDraw
let drawAlerts = nub $ drawAlerts' ++ globalAlerts
-- let drawAlerts = takeWhile (/= AlertIntermediateState drawSt) alerts
nextIsSet <- gets (isJust . nextAnimFrameAt)
when (not nextIsSet && frames > animFrameToDraw+1) $ do
t <- gets ((if isIntermediate then uiAnimTime else shortUiAnimTime) . uiOptions)
modify $ \ds -> ds { nextAnimFrameAt = Just $ now + t }
let board = stateBoard drawSt
lastCol <- gets dispLastCol
let coloured = colouredPieces colourFixed drawSt
let colouring = if useFiveColouring uiopts
then boardColouring drawSt coloured lastCol
else pieceTypeColouring drawSt coloured
modify $ \ds -> ds { dispLastCol = colouring }
renderToMain $ do
let tileGlyphs = ownedTileGlyph colouring highlight <$> board
applyAlert (AlertAppliedForce (Torque idx tdir)) =
let poss = case getpp drawSt idx of
PlacedPiece pos (Pivot arms) -> pos : map (+^pos) arms
PlacedPiece pos (Hook arm _) -> [arm+^pos]
_ -> []
rotateGlyph (TileGlyph (ArmTile dir _) col) =
ArmGlyph (-tdir) dir col
rotateGlyph (TileGlyph (PivotTile dir) col) =
PivotGlyph (-tdir) dir col
rotateGlyph gl = gl
in flip (foldr . Map.adjust $ rotateGlyph) poss
applyAlert (AlertAppliedForce (Push idx dir)) =
displaceFootprint . displaceSprings
where
displace = DisplacedGlyph $ neg dir
displaceSpringGlyph isRoot (TileGlyph (SpringTile extn sdir) col) =
displaceSpringGlyph isRoot $ SpringGlyph zero zero extn sdir col
displaceSpringGlyph isRoot (SpringGlyph rdisp edisp extn sdir col)
| isRoot = SpringGlyph (neg dir) edisp extn sdir col
| otherwise = SpringGlyph rdisp (neg dir) extn sdir col
displaceSpringGlyph _ glyph = glyph
displaceFootprint =
flip (foldr . Map.adjust $ displace) $
plPieceFootprint $ getpp drawSt idx
displaceSpring isRoot c@(Connection root end (Spring sdir _))
| dir `elem` [sdir,neg sdir] =
Map.adjust (displaceSpringGlyph isRoot) $
if isRoot
then sdir +^ locusPos drawSt root
else neg sdir +^ locusPos drawSt end
| isRoot =
flip (foldr . Map.adjust $ displace) $
connectionFootPrint drawSt c
| otherwise = id
displaceSpring _ _ = id
displaceSprings =
flip (foldr $ displaceSpring True) (springsRootAtIdx drawSt idx) .
flip (foldr $ displaceSpring False) (springsEndAtIdx drawSt idx)
applyAlert _ = id
applyAlerts = flip (foldr applyAlert) drawAlerts
erase
sequence_ [ drawAt glyph pos |
(pos,glyph) <- Map.toList $ applyAlerts tileGlyphs
]
when (showBlocks uiopts /= ShowBlocksNone) $ sequence_ $
[ drawBlocked drawSt colouring False force
| showBlocks uiopts == ShowBlocksAll
, AlertBlockedForce force <- drawAlerts] ++
[ drawBlocked drawSt colouring True force
| AlertBlockingForce force <- drawAlerts ] ++
-- [ drawBlocked drawSt colouring True force
-- | AlertResistedForce force <- drawAlerts ] ++
[ drawAt CollisionMarker pos
| AlertCollision pos <- drawAlerts ]
-- [ drawApplied drawSt colouring force
-- | AlertAppliedForce force <- drawAlerts ] ++
playAlertSounds :: GameState -> [Alert] -> UIM ()
#ifdef SOUND
playAlertSounds st alerts = do
use <- gets $ (> 0) . soundVolume . uiOptions
when use $ mapM_ (maybe (return ()) playSound . alertSound) alerts
where
alertSound (AlertBlockedForce force) = alertPreventedForce force
alertSound (AlertResistedForce force) = alertPreventedForce force
alertSound (AlertDivertedWrench _) = Just "wrenchscrape"
alertSound (AlertAppliedForce (Torque idx _))
| isPivot.placedPiece.getpp st $ idx = Just "pivot"
| isTool.placedPiece.getpp st $ idx = Just "toolmove"
alertSound (AlertAppliedForce (Push idx dir))
| isBall.placedPiece.getpp st $ idx = Just "ballmove"
| isTool.placedPiece.getpp st $ idx = Just "toolmove"
| otherwise = do
(align,newLen) <- listToMaybe [(align,newLen)
| c@(Connection (startIdx,_) (endIdx,_) (Spring outDir _)) <- connections st
, let align = (if outDir == dir then 1 else if outDir == neg dir then -1 else 0)
* (if idx == startIdx then 1 else if idx == endIdx then -1 else 0)
, align /= 0
, let newLen = connectionLength st c ]
return $ "spring" ++ (if align == 1 then "contract" else "extend")
++ show (min newLen 12)
alertSound AlertUnlocked = Just "unlocked"
alertSound _ = Nothing
alertPreventedForce force =
let PlacedPiece _ piece = getpp st $ forceIdx force
in case piece of
Wrench _ -> Just "wrenchblocked"
Hook _ _ -> if isPush force then Just "hookblocked" else Just "hookarmblocked"
_ -> Nothing
playSound :: String -> UIM ()
playSound sound = void.runMaybeT $ do
ss <- MaybeT $ Map.lookup sound <$> gets sounds
guard.not.null $ ss
liftIO $ randFromList ss >>= \(Just s) -> handleAll (const $ pure ()) $ play s
randFromList :: [a] -> IO (Maybe a)
randFromList [] = return Nothing
randFromList as = (Just.(as!!)) <$> randomRIO (0,length as - 1)
#else
playAlertSounds _ _ = return ()
#endif
drawMiniLock :: Lock -> HexVec -> UIM ()
drawMiniLock lock v = do
texture <- maybe new return =<< gets ((SC.!? lock) . miniLocks)
renderToMain $ blitAt texture v
where
miniLocksize = 3
new = do
(_, size) <- getGeom
let minisize = size `div` ceiling (lockSize lock % miniLocksize)
let width, height :: CInt
width = size*2*(fi miniLocksize*2+1)
height = ceiling $ fi size * sqrt 3 * fi (miniLocksize*2+1+1)
surf <- createRGBSurface (V2 width height) =<< masksToPixelFormat 16 (V4 0 0 0 0)
surfaceColorKey surf $= Just (V4 0 0 0 0)
rend <- createSoftwareRenderer surf
uiopts <- gets uiOptions
let st = snd $ reframe lock
coloured = colouredPieces False st
colouring = if useFiveColouring uiopts
then boardColouring st coloured Map.empty
else pieceTypeColouring st coloured
draw = sequence_ [ drawAt glyph pos |
(pos,glyph) <- Map.toList $ ownedTileGlyph colouring [] <$> stateBoard st ]
liftIO $ do
(_,cache) <- runRenderM draw emptyRenderCache $
RenderContext rend Nothing (PHS zero) (SVec (width`div`2) (height`div`2)) zero minisize Nothing width
deallocRenderCache cache
destroyRenderer rend
Just vidRend <- gets vidRenderer
texture <- createTextureFromSurface vidRend surf
minis <- liftIO . SC.insert lock texture =<< gets miniLocks
modify $ \ds -> ds { miniLocks = minis }
return texture
clearMiniLocks = do
liftIO . SC.deallocAll =<< gets miniLocks
modify $ \ds -> ds { miniLocks = emptyMiniLocks }
drawEmptyMiniLock v =
renderToMain $ recentreAt v $ rescaleRender 6 $ drawAtRel (HollowInnerGlyph $ dim white) zero
getBindingStr :: InputMode -> UIM (Command -> String)
getBindingStr mode = do
setting <- gets settingBinding
uibdgs <- gets (Map.findWithDefault [] mode . uiKeyBindings)
return (\cmd ->
if Just cmd == setting then "??"
else maybe "" showKeyFriendlyShort $ findBinding (uibdgs ++ bindings mode) cmd)
drawButtons :: InputMode -> UIM ()
drawButtons mode = do
buttons <- getButtons mode
bindingStr <- getBindingStr mode
showBT <- gets (showButtonText . uiOptions)
smallFont <- gets dispFontSmall
renderToMain $ sequence_ $ concat [ [ do
drawAtRel (ButtonGlyph col) v
let drawBdg = renderStrColAt buttonTextCol bdg v
case length bdg of
0 -> drawAtRel UnboundButtonGlyph v
l | l < 3 -> drawBdg
_ -> withFont smallFont drawBdg
when showBT $
withFont smallFont $ recentreAt v $ rescaleRender (1/4) $
sequence_ [ renderStrColAtLeft white s dv | (s,dv) <- helps ]
| (i,(v,bdg,helps)) <- enumerate $ map (\b->(buttonPos b, bindingStr $ buttonCmd b, buttonHelp b)) buttonGroup
, let col = dim $ colourWheel (base+inc*i) ]
| (buttonGroup,(base,inc)) <- buttons
]
where enumerate = zip [0..]
initMisc :: UIM ()
initMisc = do
mevType <- registerEvent (const . const . pure $ Just ()) (const . pure $ RegisteredEventData Nothing 0 nullPtr nullPtr)
modify $ \s -> s { unblockEventType = mevType }
onFullScreenChange :: Bool -> UIM ()
onFullScreenChange fs = do
Just win <- gets sdlWindow
setWindowMode win $ wModeOfFS fs
initVideo 0 0
wModeOfFS :: Bool -> WindowMode
wModeOfFS True = FullscreenDesktop
wModeOfFS False = Windowed
initVideo :: CInt -> CInt -> UIM ()
initVideo w h = do
winUninitialised <- gets $ isNothing . sdlWindow
when winUninitialised $ do
wMode <- gets $ wModeOfFS . fullscreen . uiOptions
let winConf = defaultWindow
{ windowMode = wMode
, windowResizable = True
, windowInitialSize = if (w,h) == (0,0) then V2 800 600 else V2 w h
}
win <- createWindow "Intricacy" winConf
rend <- createRenderer win (-1) defaultRenderer
modify $ \ds -> ds { sdlWindow = Just win, vidRenderer = Just rend }
Just win <- gets sdlWindow
Just vidRend <- gets vidRenderer
dimen <- SDL.get (windowSize win)
modify $ \ds -> ds { scrDimen = dimen }
maybe (pure ()) destroyTexture =<< gets backbuffer
bb <- createTexture vidRend RGB888 TextureAccessTarget dimen
rendererRenderTarget vidRend $= Just bb
modify $ \ds -> ds { backbuffer = Just bb }
clearFrame >> refresh
(_,size) <- getGeom
#ifdef EMBED
font <- warnIOErrAlt $ Just <$> TTF.decode veraMoBd (fi size)
smallFont <- warnIOErrAlt $ Just <$> TTF.decode veraMoBd (2 * fi size `div` 3)
#else
fontpath <- liftIO $ getDataPath "VeraMoBd.ttf"
font <- warnIOErrAlt $ Just <$> TTF.load fontpath (fi size)
smallFont <- warnIOErrAlt $ Just <$> TTF.load fontpath (2 * fi size `div` 3)
#endif
modify $ \ds -> ds { dispFont = font, dispFontSmall = smallFont }
maybe (pure ()) destroyTexture =<< gets bgTexture
useBG <- gets $ useBackground . uiOptions
mbg <- if useBG then do
bgsurf <- createRGBSurface dimen =<< masksToPixelFormat 16 (V4 0 0 0 0)
bgrend <- createSoftwareRenderer bgsurf
(_,cache) <- renderToMainWithRenderer bgrend emptyRenderCache . drawBasicBG . fi $ 2*max screenWidthHexes screenHeightHexes`div`3
liftIO $ deallocRenderCache cache -- XXX: have to destroy textures before renderer
destroyRenderer bgrend
bgtexture <- createTextureFromSurface vidRend bgsurf
freeSurface bgsurf
pure $ Just bgtexture
else return Nothing
modify $ \ds -> ds { bgTexture = mbg }
clearMiniLocks
liftIO . deallocRenderCache =<< gets rCache
modify $ \s -> s { rCache = emptyRenderCache }
when (isNothing font) $ liftIO $ do
now <- getCurrentTime
#ifdef EMBED
let text = show now ++ ": Warning: embedded font failed to load.\n"
#else
let text = show now ++ ": Warning: font file not found at "++fontpath++".\n"
#endif
putStr text
appendFile "intricacy-warnings.log" text
initAudio :: UIM ()
#ifdef SOUND
initAudio = do
initialised <- (isJust <$>) . nothingOnIOErr $ openAudio (defaultAudio { audioOutput = SDL.Mixer.Mono }) 1024
unless initialised $ liftIO $ do
now <- getCurrentTime
let text = show now ++ ": Warning: audio failed to initialise.\n"
putStr text
appendFile "intricacy-warnings.log" text
-- liftIO $ querySpec >>= print
setChannels 32
let seqWhileJust (m:ms) = m >>= \ret -> case ret of
Nothing -> return []
Just a -> (a:) <$> seqWhileJust ms
seqWhileJust [] = pure []
soundsdir <- liftIO $ getDataPath "sounds"
globalVolume <- gets $ soundVolume . uiOptions
snds <- sequence [ do
chunks <- seqWhileJust
[ runMaybeT $ do
chunk <- msum $ map (MaybeT . nothingOnIOErr . load) paths
setVolume vol chunk
return chunk
| n <- [1..]
, let paths = [soundsdir ++ [pathSeparator] ++ sound ++
"-" ++ (if n < 10 then ('0':) else id) (show n) ++ ext
| ext <- [".ogg", ".wav"] ]
, let vol = case sound of
"pivot" -> 64
"wrenchscrape" -> 64
"wrenchblocked" -> 64
"hookarmblocked" -> 64
"hookblocked" -> 64
"toolmove" -> 64
_ -> 128
]
setVolume globalVolume AllChannels
return (sound,chunks)
| sound <- ["hookblocked","hookarmblocked","wrenchblocked","wrenchscrape","pivot","unlocked","ballmove","toolmove"]
++ ["spring" ++ d ++ show l | d <- ["extend","contract"], l <- [1..12]] ]
modify $ \s -> s { sounds = Map.fromList snds }
#else
initAudio = return ()
#endif
drawMsgLine = void.runMaybeT $ do
(col,str) <- msum
[ MaybeT $ gets message
, (dimWhiteCol,) <$> MaybeT (gets hoverStr)
]
lift $ do
renderToMain $ blankRow messageLineCentre
smallFont <- gets dispFontSmall
renderToMain $
(if length str > fi screenWidthHexes * 3 then withFont smallFont else id) $
renderStrColAtCentre col str messageLineCentre
setMsgLineNoRefresh col str = do
modify $ \s -> s { message = Just (col,str) }
drawMsgLine
setMsgLine col str = setMsgLineNoRefresh col str >> refresh
clearMsg :: UIM ()
clearMsg = modify $ \s -> s { message = Nothing }
drawTitle (Just (title,n)) = renderToMain $ renderStrColAtCentre messageCol title (titlePos n)
drawTitle Nothing = return ()
say = setMsgLine messageCol
sayError = setMsgLine errorCol
miniLockPos = (-9)*^hw +^ hu
lockLinePos = 4*^hu +^ miniLockPos
serverPos = 12*^hv +^ 7*^neg hu
serverWaitPos = serverPos +^ hw +^ hu
randomNamesPos = 9*^hv +^ 2*^ neg hu
codenamePos = (-6)*^hw +^ 6*^hv
undeclsPos = 13*^neg hu
accessedOursPos = 2*^hw +^ codenamePos
locksPos = hw+^neg hv
retiredPos = locksPos +^ 11*^hu +^ neg hv
interactButtonsPos = 9*^neg hu +^ 8*^hw
scoresPos = codenamePos +^ 5*^hu +^ 2*^neg hv