SDLUI.hs

   1 -- This file is part of Intricacy
   2 -- Copyright (C) 2013 Martin Bays <mbays@sdf.org>
   3 --
   4 -- This program is free software: you can redistribute it and/or modify
   5 -- it under the terms of version 3 of the GNU General Public License as
   6 -- published by the Free Software Foundation, or any later version.
   7 --
   8 -- You should have received a copy of the GNU General Public License
   9 -- along with this program.  If not, see http://www.gnu.org/licenses/.
  10
  11 {-# LANGUAGE CPP           #-}
  12 {-# LANGUAGE LambdaCase    #-}
  13 {-# LANGUAGE TupleSections #-}
  14
  15 module SDLUI where
  16
  17 import           Control.Applicative
  18 import           Control.Arrow
  19 import           Control.Concurrent.STM
  20 import           Control.Monad              ((<=<))
  21 import           Control.Monad.State
  22 import           Control.Monad.Trans.Maybe
  23 import           Control.Monad.Trans.Reader
  24 import           Data.Array
  25 import           Data.Function              (on)
  26 import           Data.List
  27 import           Data.Map                   (Map)
  28 import qualified Data.Map                   as Map
  29 import           Data.Maybe
  30 import           Data.Ratio
  31 import           Data.Time.Clock            (getCurrentTime)
  32 import           Data.Word
  33 import           Graphics.UI.SDL            hiding (flip)
  34 import qualified Graphics.UI.SDL            as SDL
  35 import qualified Graphics.UI.SDL.TTF        as TTF
  36 import           System.FilePath
  37 --import Debug.Trace (traceShow)
  38
  39 #ifdef SOUND
  40 import           Graphics.UI.SDL.Mixer
  41 import           System.Random              (randomRIO)
  42 #endif
  43
  44 import           BoardColouring
  45 import           Command
  46 import           GameState
  47 import           GameStateTypes
  48 import           Hex
  49 import           InputMode
  50 import           KeyBindings
  51 import           Lock
  52 import           Maxlocksize
  53 import           Metagame
  54 import           Mundanities
  55 import           Physics
  56 import           SDLGlyph
  57 import           SDLRender
  58 import           Util
  59
  60 data UIState = UIState
  61     { scrHeight             :: Int
  62     , scrWidth              :: Int
  63     , gsSurface             :: Maybe Surface
  64     , bgSurface             :: Maybe Surface
  65     , cachedGlyphs          :: CachedGlyphs
  66     , lastDrawArgs          :: Maybe DrawArgs
  67     , miniLocks             :: Map Lock Surface
  68     , registeredSelectables :: Map HexVec Selectable
  69     , contextButtons        :: [ButtonGroup]
  70     , uiOptions             :: UIOptions
  71     , settingBinding        :: Maybe Command
  72     , uiKeyBindings         :: Map InputMode KeyBindings
  73     , dispFont              :: Maybe TTF.Font
  74     , dispFontSmall         :: Maybe TTF.Font
  75     , lastFrameTicks        :: Word32
  76     , paintTileIndex        :: Int
  77     , leftButtonDown        :: Maybe HexVec
  78     , middleButtonDown      :: Maybe HexVec
  79     , rightButtonDown       :: Maybe HexVec
  80     , mousePos              :: (HexVec,Bool)
  81     , message               :: Maybe (Pixel, String)
  82     , hoverStr              :: Maybe String
  83     , dispCentre            :: HexPos
  84     , dispLastCol           :: PieceColouring
  85     , animFrame             :: Int
  86     , nextAnimFrameAt       :: Maybe Word32
  87     , fps                   :: Int
  88 #ifdef SOUND
  89     , sounds                :: Map String [Chunk]
  90 #endif
  91     }
  92     deriving (Eq, Ord, Show)
  93 type UIM = StateT UIState IO
  94 nullUIState = UIState 0 0 Nothing Nothing emptyCachedGlyphs Nothing Map.empty Map.empty []
  95     defaultUIOptions Nothing Map.empty Nothing Nothing 0 0 Nothing Nothing Nothing
  96     (zero,False) Nothing Nothing (PHS zero) Map.empty 0 Nothing 50
  97 #ifdef SOUND
  98     Map.empty
  99 #endif
 100
 101 data UIOptions = UIOptions
 102     { useFiveColouring :: Bool
 103     , showBlocks       :: ShowBlocks
 104     , whsButtons       :: Maybe WrHoSel
 105     , useBackground    :: Bool
 106     , fullscreen       :: Bool
 107     , showButtonText   :: Bool
 108     , useSounds        :: Bool
 109     , uiAnimTime       :: Word32
 110     , shortUiAnimTime  :: Word32
 111     }
 112     deriving (Eq, Ord, Show, Read)
 113 defaultUIOptions = UIOptions False ShowBlocksBlocking Nothing True False True True 100 20
 114
 115 modifyUIOptions :: (UIOptions -> UIOptions) -> UIM ()
 116 modifyUIOptions f = modify $ \s -> s { uiOptions = f $ uiOptions s }
 117
 118 renderToMain :: RenderM a -> UIM a
 119 renderToMain m = do
 120     surf <- liftIO getVideoSurface
 121     renderToMainWithSurf surf m
 122 renderToMainWithSurf :: Surface -> RenderM a -> UIM a
 123 renderToMainWithSurf surf m = do
 124     (scrCentre, size) <- getGeom
 125     centre <- gets dispCentre
 126     mfont <- gets dispFont
 127     bgsurf <- gets bgSurface
 128     cgs <- gets cachedGlyphs
 129     (a,cgs') <- liftIO $ runRenderM m cgs $ RenderContext surf bgsurf centre scrCentre zero size mfont
 130     modify $ \s -> s { cachedGlyphs = cgs' }
 131     return a
 132
 133 refresh :: UIM ()
 134 refresh = do
 135     surface <- liftIO getVideoSurface
 136     liftIO $ SDL.flip surface
 137
 138 waitFrame :: UIM ()
 139 waitFrame = do
 140     last <- gets lastFrameTicks
 141     let next = last + 1000 `div` 30
 142     now <- liftIO getTicks
 143     -- liftIO $ print now
 144     when (now < next) $
 145         liftIO $ delay (next - now)
 146     modify $ \ds -> ds { lastFrameTicks = now }
 147
 148
 149 data Button = Button { buttonPos :: HexVec, buttonCmd :: Command, buttonHelp :: [ButtonHelp] }
 150     deriving (Eq, Ord, Show)
 151 type ButtonGroup = ([Button],(Int,Int))
 152 type ButtonHelp = (String, HexVec)
 153 singleButton :: HexVec -> Command -> Int -> [ButtonHelp] -> ButtonGroup
 154 singleButton pos cmd col helps = ([Button pos cmd helps], (col,0))
 155 getButtons :: InputMode -> UIM [ ButtonGroup ]
 156 getButtons mode = do
 157     mwhs <- gets $ whsButtons . uiOptions
 158     cntxtButtons <- gets contextButtons
 159     return $ cntxtButtons ++ global ++ case mode of
 160         IMEdit -> [
 161             singleButton (tl+^hv+^neg hw) CmdTest 1 [("test", hu+^neg hw)]
 162             , singleButton (tl+^neg hw) CmdPlay 2 [("play", hu+^neg hw)]
 163             , markButtonGroup
 164             , singleButton (br+^2*^hu) CmdWriteState 2 [("save", hu+^neg hw)] ]
 165             ++ whsBGs mwhs mode
 166             ++ [ ([Button (paintButtonStart +^ hu +^ i*^hv) (paintTileCmds!!i) []
 167                 | i <- take (length paintTiles) [0..] ],(5,0)) ]
 168         IMPlay -> whsBGs mwhs mode
 169         IMReplay -> [ markButtonGroup ]
 170         IMMeta ->
 171             [ singleButton serverPos CmdSetServer 0 [("server",7*^neg hu)]
 172             , singleButton (serverPos+^hw) CmdToggleCacheOnly 0 [("offline",hv+^7*^neg hu),("mode",hw+^5*^neg hu)]
 173             , singleButton (codenamePos +^ 2*^neg hu) (CmdSelCodename Nothing) 2 [("code",hv+^5*^neg hu),("name",hw+^5*^neg hu)]
 174             , singleButton (serverPos +^ 2*^neg hv +^ 2*^hw) CmdInitiation 3 [("initi",hu+^neg hw),("ation",hu+^neg hv)]
 175             ]
 176
 177         _ -> []
 178         where
 179             global = if mode `elem` [IMTextInput,IMImpatience] then [] else
 180                 [ singleButton br CmdQuit 0 [("quit",hu+^neg hw)]
 181                 , singleButton (tr +^ 3*^hv +^ 3*^hu) CmdHelp 3 [("help",hu+^neg hw)] ]
 182             whsBGs :: Maybe WrHoSel -> InputMode -> [ ButtonGroup ]
 183             whsBGs Nothing _ = []
 184             whsBGs (Just whs) mode =
 185                 let edit = mode == IMEdit
 186                 in [ ( [ Button bl (if edit then CmdSelect else CmdWait) [] ], (0,0))
 187                     , ( [ Button (bl+^dir) (CmdDir whs dir)
 188                         (if dir==hu then [("move",hu+^neg hw),(if edit then "piece" else whsStr whs,hu+^neg hv)] else [])
 189                         | dir <- hexDirs ], (5,0) )
 190                 ] ++
 191                 ([( [ Button (bl+^((-2)*^hv))
 192                            (CmdRotate whs (-1))
 193                            [("turn",hu+^neg hw),("cw",hu+^neg hv)]
 194                        , Button (bl+^((-2)*^hw))
 195                            (CmdRotate whs 1)
 196                            [("turn",hu+^neg hw),("ccw",hu+^neg hv)]
 197                        ], (5,0) ) | whs /= WHSWrench]) ++
 198                 ([( [ Button (bl+^(2*^hv)+^hw+^neg hu) (CmdTile HookTile) [("select",hu+^neg hw),("hook",hu+^neg hv)]
 199                        , Button (bl+^(2*^hv)+^neg hu) (CmdTile $ WrenchTile zero) [("select",hu+^neg hw),("wrench",hu+^neg hv)]
 200                        ], (2,0) ) | whs == WHSSelected && mode /= IMEdit])
 201             tr = periphery 0
 202             tl = periphery 2
 203             bl = periphery 3
 204             br = periphery 5
 205
 206 markButtonGroup = ([Button (tl+^hw) CmdMark [("set",hu+^neg hw),("mark",hu+^neg hv)]
 207     , Button (tl+^hw+^hv) CmdJumpMark [("jump",hu+^neg hw),("mark",hu+^neg hv)]
 208     , Button (tl+^hw+^2*^hv) CmdReset [("jump",hu+^neg hw),("start",hu+^neg hv)]],(0,1))
 209     where
 210     tl = periphery 2
 211
 212 data AccessedInfo = AccessedSolved | AccessedPublic | AccessedReadNotes | AccessedUndeclared
 213     deriving (Eq, Ord, Show)
 214 data Selectable
 215     = SelOurLock
 216     | SelTut Bool
 217     | SelInitLock HexVec Bool
 218     | SelLock ActiveLock
 219     | SelLockUnset Bool ActiveLock
 220     | SelSelectedCodeName Codename
 221     | SelRelScore
 222     | SelRelScoreComponent
 223     | SelScoreLock (Maybe Codename) (Maybe AccessedReason) ActiveLock
 224     | SelUndeclared Undeclared
 225     | SelReadNote NoteInfo
 226     | SelReadNoteSlot
 227     | SelSolution NoteInfo
 228     | SelAccessed Codename
 229     | SelRandom Codename
 230     | SelSecured NoteInfo
 231     | SelOldLock LockSpec
 232     | SelPublicLock
 233     | SelAccessedInfo AccessedInfo
 234     | SelLockPath
 235     | SelPrivyHeader
 236     | SelNotesHeader
 237     | SelToolHook
 238     | SelToolWrench Bool
 239     deriving (Eq, Ord, Show)
 240
 241 registerSelectable :: HexVec -> Int -> Selectable -> UIM ()
 242 registerSelectable v r s =
 243     modify $ \ds -> ds {registeredSelectables = foldr (
 244         (`Map.insert` s) . (v+^)) (registeredSelectables ds) (hexDisc r)}
 245 registerButtonGroup :: ButtonGroup -> UIM ()
 246 registerButtonGroup g = modify $ \ds -> ds {contextButtons = g:contextButtons ds}
 247 registerButton :: HexVec -> Command -> Int -> [ButtonHelp] -> UIM ()
 248 registerButton pos cmd col helps = registerButtonGroup $ singleButton pos cmd col helps
 249 clearSelectables,clearButtons :: UIM ()
 250 clearSelectables = modify $ \ds -> ds {registeredSelectables = Map.empty}
 251 clearButtons = modify $ \ds -> ds {contextButtons = []}
 252
 253 registerUndoButtons :: Bool -> UIM ()
 254 registerUndoButtons noRedo = do
 255     registerButton (periphery 2+^hu) CmdUndo 0 [("undo",hu+^neg hw)]
 256     unless noRedo $ registerButton (periphery 2+^hu+^neg hv) CmdRedo 2 [("redo",hu+^neg hw)]
 257
 258 commandOfSelectable IMInit (SelTut _) _ = Just . CmdSolveInit $ Just zero
 259 commandOfSelectable IMInit (SelInitLock v _) _ = Just . CmdSolveInit $ Just v
 260 commandOfSelectable IMMeta SelOurLock _ = Just CmdEdit
 261 commandOfSelectable IMMeta (SelLock (ActiveLock _ i)) False = Just $ CmdSolve (Just i)
 262 commandOfSelectable IMMeta (SelLock (ActiveLock _ i)) True = Just $ CmdPlaceLock (Just i)
 263 commandOfSelectable IMMeta (SelScoreLock Nothing _ (ActiveLock _ i)) False = Just $ CmdSolve (Just i)
 264 commandOfSelectable IMMeta (SelScoreLock Nothing _ (ActiveLock _ i)) True = Just $ CmdPlaceLock (Just i)
 265 commandOfSelectable IMMeta (SelScoreLock (Just _) _ _) _ = Just CmdHome
 266 commandOfSelectable IMMeta (SelLockUnset True (ActiveLock _ i)) _ = Just $ CmdPlaceLock (Just i)
 267 commandOfSelectable IMMeta (SelSelectedCodeName _) False = Just $ CmdSelCodename Nothing
 268 commandOfSelectable IMMeta (SelSelectedCodeName _) True = Just CmdHome
 269 commandOfSelectable IMMeta (SelUndeclared undecl) _ = Just $ CmdDeclare $ Just undecl
 270 commandOfSelectable IMMeta (SelReadNote note) False = Just $ CmdSelCodename $ Just $ noteAuthor note
 271 commandOfSelectable IMMeta (SelReadNote note) True = Just $ CmdViewSolution $ Just note
 272 commandOfSelectable IMMeta (SelSolution note) False = Just $ CmdSelCodename $ Just $ noteAuthor note
 273 commandOfSelectable IMMeta (SelSolution note) True = Just $ CmdViewSolution $ Just note
 274 commandOfSelectable IMMeta (SelAccessed name) _ = Just $ CmdSelCodename $ Just name
 275 commandOfSelectable IMMeta (SelRandom name) _ = Just $ CmdSelCodename $ Just name
 276 commandOfSelectable IMMeta (SelSecured note) False = Just $ CmdSelCodename $ Just $ lockOwner $ noteOn note
 277 commandOfSelectable IMMeta (SelSecured note) True = Just $ CmdViewSolution $ Just note
 278 commandOfSelectable IMMeta (SelOldLock ls) _ = Just $ CmdPlayLockSpec $ Just ls
 279 commandOfSelectable IMMeta SelLockPath _ = Just CmdSelectLock
 280 commandOfSelectable IMTextInput (SelLock (ActiveLock _ i)) _ = Just $ CmdInputSelLock i
 281 commandOfSelectable IMTextInput (SelScoreLock _ _ (ActiveLock _ i)) _ = Just $ CmdInputSelLock i
 282 commandOfSelectable IMTextInput (SelLockUnset _ (ActiveLock _ i)) _ = Just $ CmdInputSelLock i
 283 commandOfSelectable IMTextInput (SelReadNote note) _ = Just $ CmdInputCodename $ noteAuthor note
 284 commandOfSelectable IMTextInput (SelSolution note) _ = Just $ CmdInputCodename $ noteAuthor note
 285 commandOfSelectable IMTextInput (SelSecured note) _ = Just $ CmdInputCodename $ lockOwner $ noteOn note
 286 commandOfSelectable IMTextInput (SelRandom name) _ = Just $ CmdInputCodename name
 287 commandOfSelectable IMTextInput (SelUndeclared undecl) _ = Just $ CmdInputSelUndecl undecl
 288 commandOfSelectable _ _ _ = Nothing
 289
 290 helpOfSelectable (SelTut False) = Just "Enter tutorials"
 291 helpOfSelectable (SelTut True) = Just "Revisit tutorials"
 292 helpOfSelectable (SelInitLock _ False) = Just "Attempt lock"
 293 helpOfSelectable (SelInitLock _ True) = Just "Revisit solved lock"
 294 helpOfSelectable SelOurLock = Just
 295     "Design a lock."
 296 helpOfSelectable (SelSelectedCodeName name) = Just $
 297     "Currently viewing player "++name++"."
 298 helpOfSelectable SelRelScore = Just
 299     "The extent to which you are held in higher esteem than this player."
 300 helpOfSelectable SelRelScoreComponent = Just
 301     "Contribution to total relative esteem."
 302 helpOfSelectable (SelLock (ActiveLock name i)) = Just $
 303     name++"'s lock "++[lockIndexChar i]++"."
 304 helpOfSelectable (SelLockUnset True _) = Just
 305     "Place a lock."
 306 helpOfSelectable (SelLockUnset False _) = Just
 307     "An empty lock slot."
 308 helpOfSelectable (SelUndeclared _) = Just
 309     "Declare your solution to a lock by securing a note on it behind a lock of your own."
 310 helpOfSelectable (SelRandom _) = Just
 311     "Random set of players. Colours show relative esteem, bright red (-3) to bright green (+3)."
 312 helpOfSelectable (SelScoreLock (Just name) Nothing _) = Just $
 313     "Your lock. "++name++" can not not unlock it."
 314 helpOfSelectable (SelScoreLock (Just name) (Just AccessedPrivy) _) = Just $
 315     "Your lock. "++name++" can unlock it: -1 to relative esteem."
 316 helpOfSelectable (SelScoreLock (Just name) (Just AccessedPub) _) = Just
 317     "Your lock. Its secrets have been publically revealed: -1 to relative esteem."
 318 helpOfSelectable (SelScoreLock (Just name) (Just AccessedEmpty) _) = Just $
 319     "Your empty lock slot. "++name++" can unlock all your locks: -1 to relative esteem."
 320 helpOfSelectable (SelScoreLock Nothing Nothing (ActiveLock name _)) = Just $
 321     name++"'s lock. You can not unlock it."
 322 helpOfSelectable (SelScoreLock Nothing (Just AccessedPrivy) (ActiveLock name _)) = Just $
 323     name++"'s lock. You can unlock it: +1 to relative esteem."
 324 helpOfSelectable (SelScoreLock Nothing (Just AccessedPub) (ActiveLock name _)) = Just $
 325     name++"'s lock. Its secrets have been publically revealed: +1 to relative esteem."
 326 helpOfSelectable (SelScoreLock Nothing (Just AccessedEmpty) (ActiveLock name _)) = Just $
 327     name++"'s empty lock slot. You can unlock all "++name++"'s locks: +1 to relative esteem."
 328 helpOfSelectable (SelReadNote note) = Just $
 329     "You have read "++noteAuthor note++"'s note on this lock."
 330 helpOfSelectable SelReadNoteSlot = Just
 331     "Reading three notes on this lock would suffice to reveal its secrets."
 332 helpOfSelectable (SelSecured note) = let ActiveLock owner idx = noteOn note in
 333     Just $ "Secured note on "++owner++"'s lock "++[lockIndexChar idx]++"."
 334 helpOfSelectable (SelSolution note) = Just $ case noteBehind note of
 335     Just (ActiveLock owner idx) -> owner ++
 336         " has secured their note on this lock behind their lock " ++ [lockIndexChar idx] ++ "."
 337     Nothing -> noteAuthor note ++ "'s note on this lock is public knowledge."
 338 helpOfSelectable (SelAccessed name) = Just $
 339     name ++ " did not pick this lock, but learnt how to unlock it by reading three notes on it."
 340 helpOfSelectable SelPublicLock = Just
 341     "Notes behind retired or public locks are public; a lock with three public notes on it is public."
 342 helpOfSelectable (SelAccessedInfo meth) = Just $ case meth of
 343     AccessedSolved -> "You picked this lock and declared your solution, so may read any notes it secures."
 344     AccessedPublic -> "The secrets of this lock have been publically revealed."
 345     AccessedUndeclared -> "You have picked this lock, but are yet to declare your solution."
 346     AccessedReadNotes ->
 347         "Having read three notes on others' solutions to this lock, you have unravelled its secrets."
 348 helpOfSelectable (SelOldLock ls) = Just $
 349     "Retired lock #"++show ls++". Any notes which were secured by the lock are now public knowledge."
 350 helpOfSelectable SelLockPath = Just
 351     "Select a lock by its name. The names you give your locks are not revealed to others."
 352 helpOfSelectable SelPrivyHeader = Just
 353     "Notes on this lock declared by players who picked the lock."
 354 helpOfSelectable SelNotesHeader = Just
 355     "Notes secured by this lock. These notes are read by everyone who can unlock the lock."
 356 helpOfSelectable (SelToolWrench False) = Just "The wrench, one of your lockpicking tools. Click and drag to move."
 357 helpOfSelectable (SelToolWrench True) = Just "The wrench, currently in motion. It will keep moving until it is blocked."
 358 helpOfSelectable SelToolHook = Just "The hook, one of your lockpicking tools. Click and drag to move, use mousewheel to turn."
 359
 360 cmdAtMousePos pos@(mPos,central) im selMode = do
 361     buttons <- concatMap fst <$> getButtons im
 362     sels <- gets registeredSelectables
 363     return $ listToMaybe $
 364         [ buttonCmd button
 365             | button <- buttons, mPos == buttonPos button, central]
 366         ++ maybe [] (\isRight ->
 367                 [ cmd
 368                 | Just sel <- [Map.lookup mPos sels]
 369                 , Just cmd <- [ commandOfSelectable im sel isRight ] ])
 370             selMode
 371
 372 helpAtMousePos :: (HexVec, Bool) -> InputMode -> UIM (Maybe [Char])
 373 helpAtMousePos (mPos,_) _ =
 374     gets $ (helpOfSelectable <=< Map.lookup mPos) . registeredSelectables
 375
 376
 377 data UIOptButton a = UIOptButton { getUIOpt :: UIOptions->a, setUIOpt :: a->UIOptions->UIOptions,
 378     uiOptVals :: [a], uiOptPos :: HexVec, uiOptGlyph :: a->Glyph, uiOptDescr :: a->String,
 379     uiOptModes :: [InputMode], onSet :: Maybe (a -> UIM ()) }
 380
 381 -- non-uniform type, so can't use a list...
 382 uiOB1 = UIOptButton useFiveColouring (\v o -> o {useFiveColouring=v}) [True,False]
 383         (periphery 0 +^ 3 *^ hu +^ neg hv) UseFiveColourButton
 384         (\v -> if v then "Adjacent pieces get different colours" else
 385         "Pieces are coloured according to type")
 386         [IMPlay, IMReplay, IMEdit] Nothing
 387 uiOB2 = UIOptButton showBlocks (\v o -> o {showBlocks=v}) [ShowBlocksBlocking,ShowBlocksAll,ShowBlocksNone]
 388         (periphery 0 +^ 2 *^ hu +^ 2 *^ neg hv) ShowBlocksButton
 389         (\case
 390             ShowBlocksBlocking -> "Blocking forces are annotated"
 391             ShowBlocksAll      -> "Blocked and blocking forces are annotated"
 392             ShowBlocksNone     -> "Blockage annotations disabled")
 393         [IMPlay, IMReplay] Nothing
 394 uiOB3 = UIOptButton whsButtons (\v o -> o {whsButtons=v}) [Nothing, Just WHSSelected, Just WHSWrench, Just WHSHook]
 395         (periphery 3 +^ 3 *^ hv) WhsButtonsButton
 396         (\case
 397             Nothing -> "Click to show (and rebind) keyboard control buttons."
 398             Just whs -> "Showing buttons for controlling " ++ case whs of
 399                 WHSSelected -> "selected piece; right-click to rebind"
 400                 WHSWrench   -> "wrench; right-click to rebind"
 401                 WHSHook     -> "hook; right-click to rebind")
 402         [IMPlay, IMEdit] Nothing
 403 uiOB4 = UIOptButton showButtonText (\v o -> o {showButtonText=v}) [True,False]
 404         (periphery 0 +^ 2 *^ hu +^ 3 *^ hv) ShowButtonTextButton
 405         (\v -> if v then "Help text enabled" else
 406         "Help text disabled")
 407         [IMPlay, IMEdit, IMReplay, IMMeta, IMInit] Nothing
 408 uiOB5 = UIOptButton fullscreen (\v o -> o {fullscreen=v}) [True,False]
 409         (periphery 0 +^ 4 *^ hu +^ 2 *^ hv) FullscreenButton
 410         (\v -> if v then "Fullscreen mode active" else "Windowed mode active")
 411         [IMPlay, IMEdit, IMReplay, IMMeta, IMInit] (Just $ const $ initVideo 0 0)
 412 uiOB6 = UIOptButton useSounds (\v o -> o {useSounds=v}) [True,False]
 413         (periphery 0 +^ 4 *^ hu +^ hv) UseSoundsButton
 414         (\v -> if v then "Sound effects enabled" else
 415         "Sound effects disabled")
 416         [IMPlay, IMEdit, IMReplay] Nothing
 417
 418 drawUIOptionButtons :: InputMode -> UIM ()
 419 drawUIOptionButtons mode = do
 420     drawUIOptionButton mode uiOB1
 421     drawUIOptionButton mode uiOB2
 422     drawUIOptionButton mode uiOB3
 423     drawUIOptionButton mode uiOB4
 424     drawUIOptionButton mode uiOB5
 425 #ifdef SOUND
 426     drawUIOptionButton mode uiOB6
 427 #endif
 428 drawUIOptionButton im b = when (im `elem` uiOptModes b) $ do
 429     value <- gets $ getUIOpt b . uiOptions
 430     renderToMain $ mapM_ (\g -> drawAtRel g (uiOptPos b))
 431         [HollowGlyph $ obscure purple, uiOptGlyph b value]
 432 describeUIOptionButton :: UIOptButton a -> MaybeT UIM String
 433 describeUIOptionButton b = do
 434     value <- gets $ getUIOpt b . uiOptions
 435     return $ uiOptDescr b value
 436 -- XXX: hand-hacking lenses...
 437 toggleUIOption (UIOptButton getopt setopt vals _ _ _ _ monSet) = do
 438     value <- gets $ getopt . uiOptions
 439     let value' = cycle vals !! max 0 (1 + fromMaybe 0 (elemIndex value vals))
 440     modifyUIOptions $ setopt value'
 441     case monSet of
 442         Nothing    -> return ()
 443         Just onSet -> onSet value'
 444
 445 readUIConfigFile :: UIM ()
 446 readUIConfigFile = do
 447     path <- liftIO $ confFilePath "SDLUI.conf"
 448     mOpts <- liftIO $ readReadFile path
 449     case mOpts of
 450         Just opts -> modify $ \s -> s {uiOptions = opts}
 451         Nothing   -> return ()
 452 writeUIConfigFile :: UIM ()
 453 writeUIConfigFile = do
 454     path <- liftIO $ confFilePath "SDLUI.conf"
 455     opts <- gets uiOptions
 456     liftIO makeConfDir
 457     liftIO $ writeFile path $ show opts
 458
 459 readBindings :: UIM ()
 460 readBindings = do
 461     path <- liftIO $ confFilePath "bindings"
 462     mbdgs <- liftIO $ readReadFile path
 463     case mbdgs of
 464         Just bdgs -> modify $ \s -> s {uiKeyBindings = bdgs}
 465         Nothing   -> return ()
 466 writeBindings :: UIM ()
 467 writeBindings = do
 468     path <- liftIO $ confFilePath "bindings"
 469     bdgs <- gets uiKeyBindings
 470     liftIO makeConfDir
 471     liftIO $ writeFile path $ show bdgs
 472
 473 getBindings :: InputMode -> UIM [(Char, Command)]
 474 getBindings mode = do
 475     uibdgs <- gets (Map.findWithDefault [] mode . uiKeyBindings)
 476     return $ uibdgs ++ bindings mode
 477
 478 paintTiles :: [ Maybe Tile ]
 479 paintTiles =
 480     [ Just BallTile
 481     , Just $ ArmTile zero False
 482     , Just $ PivotTile zero
 483     , Just $ SpringTile Relaxed zero
 484     , Just $ BlockTile []
 485     , Nothing
 486     ]
 487
 488 paintTileCmds = map (maybe CmdDelete CmdTile) paintTiles
 489
 490 getEffPaintTileIndex :: UIM Int
 491 getEffPaintTileIndex = do
 492     mods <- liftIO getModState
 493     if any (`elem` mods) [KeyModLeftCtrl, KeyModRightCtrl]
 494     then return $ length paintTiles - 1
 495     else gets paintTileIndex
 496
 497 paintButtonStart :: HexVec
 498 paintButtonStart = periphery 0 +^ (- length paintTiles `div` 2)*^hv
 499
 500 drawPaintButtons :: UIM ()
 501 drawPaintButtons = do
 502     pti <- getEffPaintTileIndex
 503     renderToMain $ sequence_ [
 504         do
 505             let gl = case paintTiles!!i of
 506                     Nothing -> HollowInnerGlyph $ dim purple
 507                     Just t  -> TileGlyph t $ dim purple
 508             drawAtRel gl pos
 509             when selected $ drawAtRel cursorGlyph pos
 510         | i <- take (length paintTiles) [0..]
 511         , let pos = paintButtonStart +^ i*^hv
 512         , let selected = i == pti
 513         ]
 514
 515 periphery 0 = ((3*maxlocksize)`div`2)*^hu +^ ((3*maxlocksize)`div`4)*^hv
 516 periphery n = rotate n $ periphery 0
 517 -- ^ XXX only peripheries 0,2,3,5 are guaranteed to be on-screen!
 518 --messageLineStart = (maxlocksize+1)*^hw
 519 messageLineCentre = ((maxlocksize+1)`div`2)*^hw +^ ((maxlocksize+1+1)`div`2)*^neg hv
 520
 521 -- XXX HACK: the n=8 line is crowded
 522 titlePos n = titlePos' $ if n == 8 then 9 else n
 523     where titlePos' n = n*^hv +^ (n`div`2)*^hu
 524
 525 screenWidthHexes,screenHeightHexes :: Int
 526 screenWidthHexes = 32
 527 screenHeightHexes = 26
 528 getGeom :: UIM (SVec, Int)
 529 getGeom = do
 530     h <- gets scrHeight
 531     w <- gets scrWidth
 532     let scrCentre = SVec (w`div`2) (h`div`2)
 533     -- |size is the greatest integer such that
 534     -- and [2*size*screenWidthHexes < width
 535     --        , 3*ysize size*screenHeightHexes < height]
 536     --        where ysize size = round $ fi size / sqrt 3
 537     -- Minimum allowed size is 2 (get segfaults on SDL_FreeSurface with 1).
 538     let size = max 2 $ minimum [ (w-1)`div`(2*screenWidthHexes)
 539             , floor $ sqrt 3 * (0.5 + fi ((h-1)`div`(3*screenHeightHexes)))]
 540     return (scrCentre, size)
 541
 542 data DrawArgs = DrawArgs [PieceIdx] Bool [Alert] GameState UIOptions
 543     deriving (Eq, Ord, Show)
 544
 545 drawMainGameState :: [PieceIdx] -> Bool -> [Alert] -> GameState -> UIM ()
 546 drawMainGameState highlight colourFixed alerts st = do
 547     uiopts <- gets uiOptions
 548     drawMainGameState' $ DrawArgs highlight colourFixed alerts st uiopts
 549
 550 drawMainGameState' :: DrawArgs -> UIM ()
 551 drawMainGameState' args@(DrawArgs highlight colourFixed alerts st uiopts) = do
 552     lastArgs <- gets lastDrawArgs
 553     when (case lastArgs of
 554             Nothing -> True
 555             Just (DrawArgs _ _ lastAlerts lastSt _) ->
 556                 lastAlerts /= alerts || lastSt /= st) $
 557         modify $ \ds -> ds { animFrame = 0, nextAnimFrameAt = Nothing }
 558
 559     lastAnimFrame <- gets animFrame
 560     now <- liftIO getTicks
 561     anim <- gets (maybe False (<now) . nextAnimFrameAt)
 562     when anim $
 563         modify $ \ds -> ds { animFrame = lastAnimFrame+1, nextAnimFrameAt = Nothing }
 564     animFrameToDraw <- gets animFrame
 565     void $ if lastArgs == Just args && lastAnimFrame == animFrameToDraw
 566         then do
 567             vidSurf <- liftIO getVideoSurface
 568             gsSurf <- gets (fromJust . gsSurface)
 569             liftIO $ blitSurface gsSurf Nothing vidSurf Nothing
 570         else do
 571             modify $ \ds -> ds { lastDrawArgs = Just args }
 572
 573             -- split the alerts at intermediate states, and associate alerts
 574             -- to the right states:
 575             let (globalAlerts,transitoryAlerts) = partition isGlobalAlert alerts
 576                 splitAlerts frameAs (AlertIntermediateState st' : as) =
 577                     (frameAs,st',True) : splitAlerts [] as
 578                 splitAlerts frameAs (a:as) =
 579                     splitAlerts (a:frameAs) as
 580                 splitAlerts frameAs [] = [(frameAs,st,False)]
 581                 isGlobalAlert (AlertAppliedForce _)      = False
 582                 isGlobalAlert (AlertIntermediateState _) = False
 583                 isGlobalAlert _                          = True
 584             let animAlertedStates = nub $
 585                     let ass = splitAlerts [] transitoryAlerts
 586                     in if last ass == ([],st,False) then ass else ass ++ [([],st,False)]
 587             let frames = length animAlertedStates
 588             let (drawAlerts',drawSt,isIntermediate) = animAlertedStates !! animFrameToDraw
 589             let drawAlerts = drawAlerts' ++ globalAlerts
 590             -- let drawAlerts = takeWhile (/= AlertIntermediateState drawSt) alerts
 591             nextIsSet <- gets (isJust . nextAnimFrameAt)
 592             when (not nextIsSet && frames > animFrameToDraw+1) $ do
 593                 time <- gets ((if isIntermediate then uiAnimTime else shortUiAnimTime) . uiOptions)
 594                 modify $ \ds -> ds { nextAnimFrameAt = Just $ now + time }
 595
 596             let board = stateBoard drawSt
 597             lastCol <- gets dispLastCol
 598             let coloured = colouredPieces colourFixed drawSt
 599             let colouring = if useFiveColouring uiopts
 600                 then boardColouring drawSt coloured lastCol
 601                 else pieceTypeColouring drawSt coloured
 602             modify $ \ds -> ds { dispLastCol = colouring }
 603             gsSurf <- gets (fromJust . gsSurface)
 604             renderToMainWithSurf gsSurf $ do
 605                 let tileGlyphs = ownedTileGlyph colouring highlight <$> board
 606
 607                     applyAlert (AlertAppliedForce f@(Torque idx tdir)) =
 608                         let poss = case getpp drawSt idx of
 609                                 PlacedPiece pos (Pivot arms) -> pos : map (+^pos) arms
 610                                 PlacedPiece pos (Hook arm _) -> [arm+^pos]
 611                                 _ -> []
 612                             rotateGlyph (TileGlyph (ArmTile dir _) col) =
 613                                 ArmGlyph (-tdir) dir col
 614                             rotateGlyph (TileGlyph (PivotTile dir) col) =
 615                                 PivotGlyph (-tdir) dir col
 616                         in flip (foldr . Map.adjust $ rotateGlyph) poss
 617                     applyAlert (AlertAppliedForce f@(Push idx dir)) =
 618                         displaceFootprint . displaceSprings
 619                         where
 620                             displace = DisplacedGlyph $ neg dir
 621                             displaceSpringGlyph isRoot (TileGlyph (SpringTile extn sdir) col) =
 622                                 displaceSpringGlyph isRoot $ SpringGlyph zero zero extn sdir col
 623                             displaceSpringGlyph isRoot (SpringGlyph rdisp edisp extn sdir col)
 624                                 | isRoot = SpringGlyph (neg dir) edisp extn sdir col
 625                                 | otherwise = SpringGlyph rdisp (neg dir) extn sdir col
 626                             displaceSpringGlyph _ glyph = glyph
 627                             displaceFootprint =
 628                                 flip (foldr . Map.adjust $ displace) $
 629                                     plPieceFootprint $ getpp drawSt idx
 630
 631                             displaceSpring isRoot c@(Connection root end (Spring sdir _))
 632                                 | dir `elem` [sdir,neg sdir] =
 633                                     Map.adjust (displaceSpringGlyph isRoot) $
 634                                         if isRoot
 635                                             then sdir +^ locusPos drawSt root
 636                                             else neg sdir +^ locusPos drawSt end
 637                                 | isRoot =
 638                                     flip (foldr . Map.adjust $ displace) $
 639                                         connectionFootPrint drawSt c
 640                                 | otherwise = id
 641                             displaceSpring _ _ = id
 642
 643                             displaceSprings =
 644                                 flip (foldr $ displaceSpring True) (springsRootAtIdx drawSt idx) .
 645                                 flip (foldr $ displaceSpring False) (springsEndAtIdx drawSt idx)
 646                     applyAlert _ = id
 647
 648                     applyAlerts = flip (foldr applyAlert) drawAlerts
 649
 650                 erase
 651                 sequence_ [ drawAt glyph pos |
 652                     (pos,glyph) <- Map.toList $ applyAlerts tileGlyphs
 653                     ]
 654
 655                 when (showBlocks uiopts /= ShowBlocksNone) $ sequence_
 656                     $ [drawBlocked drawSt colouring False force |
 657                    showBlocks uiopts == ShowBlocksAll,
 658                    AlertBlockedForce force <- drawAlerts]
 659                     ++ [ drawBlocked drawSt colouring True force
 660                         | AlertBlockingForce force <- drawAlerts ]
 661                     -- ++ [ drawBlocked drawSt colouring True force |
 662                     -- AlertResistedForce force <- drawAlerts ]
 663                     ++ [ drawAt CollisionMarker pos
 664                         | AlertCollision pos <- drawAlerts ]
 665                     -- ++ [ drawApplied drawSt colouring force
 666                     --    | AlertAppliedForce force <- drawAlerts ]
 667             vidSurf <- liftIO getVideoSurface
 668             liftIO $ blitSurface gsSurf Nothing vidSurf Nothing
 669
 670 playAlertSounds :: GameState -> [Alert] -> UIM ()
 671 #ifdef SOUND
 672 playAlertSounds st alerts = do
 673     use <- useSounds <$> gets uiOptions
 674     when use $ mapM_ (maybe (return ()) playSound . alertSound) alerts
 675     where
 676         alertSound (AlertBlockedForce force) =
 677             let PlacedPiece _ piece = getpp st $ forceIdx force
 678             in case piece of
 679                 Wrench _ -> Just "wrenchblocked"
 680                 Hook _ _ -> if isPush force then Just "hookblocked" else Just "hookarmblocked"
 681                 _ -> Nothing
 682         alertSound (AlertDivertedWrench _) = Just "wrenchscrape"
 683         alertSound (AlertAppliedForce (Torque idx _))
 684             | isPivot.placedPiece.getpp st $ idx = Just "pivot"
 685             | isTool.placedPiece.getpp st $ idx = Just "toolmove"
 686         alertSound (AlertAppliedForce (Push idx dir))
 687             | isBall.placedPiece.getpp st $ idx = Just "ballmove"
 688             | isTool.placedPiece.getpp st $ idx = Just "toolmove"
 689             | otherwise = do
 690             (align,newLen) <- listToMaybe [(align,newLen)
 691                 | c@(Connection (startIdx,_) (endIdx,_) (Spring outDir natLen)) <- connections st
 692                 , let align = (if outDir == dir then 1 else if outDir == neg dir then -1 else 0)
 693                         * (if idx == startIdx then 1 else if idx == endIdx then -1 else 0)
 694                 , align /= 0
 695                 , let newLen = connectionLength st c ]
 696             return $ "spring" ++ (if align == 1 then "contract" else "extend")
 697                 ++ show (min newLen 12)
 698         alertSound AlertUnlocked = Just "unlocked"
 699         alertSound _ = Nothing
 700         playSound :: String -> UIM ()
 701         playSound sound = void.runMaybeT $ do
 702             ss <- MaybeT $ Map.lookup sound <$> gets sounds
 703             guard.not.null $ ss
 704             liftIO $ randFromList ss >>= \(Just s) -> void $ tryPlayChannel (-1) s 0
 705         randFromList :: [a] -> IO (Maybe a)
 706         randFromList [] = return Nothing
 707         randFromList as = (Just.(as!!)) <$> randomRIO (0,length as - 1)
 708 #else
 709 playAlertSounds _ _ = return ()
 710 #endif
 711
 712
 713 drawMiniLock :: Lock -> HexVec -> UIM ()
 714 drawMiniLock lock v = do
 715     surface <- gets miniLocks >>= maybe new return . Map.lookup lock
 716     renderToMain $ blitAt surface v
 717     where
 718         miniLocksize = 3
 719         new = do
 720             (_, size) <- getGeom
 721             let minisize = size `div` ceiling (lockSize lock % miniLocksize)
 722             let width = size*2*(miniLocksize*2+1)
 723             let height = ceiling $ fi size * sqrt 3 * fi (miniLocksize*2+1+1)
 724             surf <- liftIO $ createRGBSurface [] width height 16 0 0 0 0
 725             liftIO $ setColorKey surf [SrcColorKey,RLEAccel] $ Pixel 0
 726             uiopts <- gets uiOptions
 727             let st = snd $ reframe lock
 728                 coloured = colouredPieces False st
 729                 colouring = if useFiveColouring uiopts
 730                     then boardColouring st coloured Map.empty
 731                     else pieceTypeColouring st coloured
 732                 draw = sequence_ [ drawAt glyph pos |
 733                     (pos,glyph) <- Map.toList $ ownedTileGlyph colouring [] <$> stateBoard st ]
 734             liftIO $ runRenderM draw emptyCachedGlyphs $
 735                 RenderContext surf Nothing (PHS zero) (SVec (width`div`2) (height`div`2)) zero minisize Nothing
 736             clearOldMiniLocks
 737             modify $ \ds -> ds { miniLocks = Map.insert lock surf $ miniLocks ds }
 738             return surf
 739
 740 -- | TODO: do this more cleverly
 741 clearOldMiniLocks =
 742     (>=50).Map.size <$> gets miniLocks >>? clearMiniLocks
 743 clearMiniLocks = modify $ \ds -> ds { miniLocks = Map.empty}
 744
 745 drawEmptyMiniLock v =
 746     renderToMain $ recentreAt v $ rescaleRender 6 $ drawAtRel (HollowInnerGlyph $ dim white) zero
 747
 748 getBindingStr :: InputMode -> UIM (Command -> String)
 749 getBindingStr mode = do
 750     setting <- gets settingBinding
 751     uibdgs <- gets (Map.findWithDefault [] mode . uiKeyBindings)
 752     return (\cmd ->
 753         if Just cmd == setting then "??"
 754         else maybe "" showKey $ findBinding (uibdgs ++ bindings mode) cmd)
 755
 756 drawButtons :: InputMode -> UIM ()
 757 drawButtons mode = do
 758     buttons <- getButtons mode
 759     bindingStr <- getBindingStr mode
 760     showBT <- gets (showButtonText . uiOptions)
 761     smallFont <- gets dispFontSmall
 762     renderToMain $ sequence_ $ concat [ [ do
 763                 drawAtRel (ButtonGlyph col) v
 764                 (if length bdg > 2 then withFont smallFont else id) $
 765                     renderStrColAt buttonTextCol bdg v
 766                 when showBT $
 767                     withFont smallFont $ recentreAt v $ rescaleRender (1/4) $
 768                     sequence_ [ renderStrColAtLeft white s dv | (s,dv) <- helps ]
 769             | (i,(v,bdg,helps)) <- enumerate $ map (\b->(buttonPos b, bindingStr $ buttonCmd b, buttonHelp b)) buttonGroup
 770                 , let col = dim $ colourWheel (base+inc*i) ]
 771         | (buttonGroup,(base,inc)) <- buttons
 772         ]
 773     where enumerate = zip [0..]
 774
 775 initMisc :: IO ()
 776 initMisc = void $ enableUnicode True >> enableKeyRepeat 250 30 >> setCaption "intricacy" "intricacy"
 777
 778 initVideo :: Int -> Int -> UIM ()
 779 initVideo w h = do
 780     liftIO $ (((w,h)==(0,0) &&) . (InitVideo `elem`) <$> wasInit [InitVideo]) >>?
 781         -- reset video so that passing (0,0) to setVideoMode sets to
 782         -- current screen res rather than current window size
 783         (quitSubSystem [InitVideo] >> initSubSystem [InitVideo] >> initMisc)
 784
 785     fs <- gets (fullscreen . uiOptions)
 786     liftIO $ do
 787         (w',h') <- if fs || (w,h)/=(0,0) then return (w,h) else
 788 #ifdef APPLE
 789             -- use smaller dimensions than the screen's, to work around a bug
 790             -- seen on mac, whereby a resizable window created with
 791             -- (w,h)=(0,0), or even with the (w,h) given by getHardwareDimensions
 792             -- after creating such a window, is reported to be larger than it
 793             -- is.
 794             do
 795                 (w',h') <- getHardwareDimensions
 796                 return (4*w'`div`5,4*h'`div`5)
 797 #else
 798             getHardwareDimensions
 799 #endif
 800         setVideoMode w' h' 0 $ if fs then [Fullscreen] else [Resizable]
 801
 802     (w',h') <- liftIO getSurfaceDimensions
 803
 804     modify $ \ds -> ds { scrWidth = w' }
 805     modify $ \ds -> ds { scrHeight = h' }
 806     gssurf <- liftIO $ createRGBSurface [] w' h' 16 0 0 0 0
 807     modify $ \ds -> ds { gsSurface = Just gssurf, lastDrawArgs = Nothing }
 808
 809     (_,size) <- getGeom
 810     let fontfn = "VeraMoBd.ttf"
 811     fontpath <- liftIO $ getDataPath fontfn
 812     font <- liftIO $ TTF.tryOpenFont fontpath size
 813     smallFont <- liftIO $ TTF.tryOpenFont fontpath (2*size`div`3)
 814     modify $ \ds -> ds { dispFont = font, dispFontSmall = smallFont }
 815
 816     useBG <- gets $ useBackground . uiOptions
 817     mbg <- if useBG then do
 818             bgsurf <- liftIO $ createRGBSurface [] w' h' 16 0 0 0 0
 819             renderToMainWithSurf bgsurf $ drawBasicBG $ 2*max screenWidthHexes screenHeightHexes`div`3
 820             return $ Just bgsurf
 821         else return Nothing
 822     modify $ \ds -> ds { bgSurface = mbg }
 823
 824     clearMiniLocks
 825
 826     when (isNothing font) $ liftIO $ do
 827         now <- getCurrentTime
 828         let text = show now ++ ": Warning: font file not found at "++fontpath++".\n"
 829         putStr text
 830         appendFile "intricacy-warnings.log" text
 831
 832     where
 833         getHardwareDimensions = (videoInfoWidth &&& videoInfoHeight) <$> getVideoInfo
 834         getSurfaceDimensions = (surfaceGetWidth &&& surfaceGetHeight) <$> getVideoSurface
 835
 836
 837 initAudio :: UIM ()
 838 #ifdef SOUND
 839 initAudio = do
 840     initialised <- liftIO $ tryOpenAudio defaultFrequency AudioS16Sys 1 1024
 841     unless initialised $ liftIO $ do
 842         now <- getCurrentTime
 843         let text = show now ++ ": Warning: audio failed to initialise.\n"
 844         putStr text
 845         appendFile "intricacy-warnings.log" text
 846     -- liftIO $ querySpec >>= print
 847     liftIO $ allocateChannels 16
 848     let seqWhileJust (m:ms) = m >>= \ret -> case ret of
 849             Nothing -> return []
 850             Just a  -> (a:) <$> seqWhileJust ms
 851     soundsdir <- liftIO $ getDataPath "sounds"
 852     sounds <- sequence [ do
 853             chunks <- liftIO $ seqWhileJust
 854                 [ runMaybeT $ do
 855                     chunk <- msum $ map (MaybeT . tryLoadWAV) paths
 856                     liftIO $ volumeChunk chunk vol
 857                     return chunk
 858                 | n <- [1..]
 859                 , let paths = [soundsdir ++ [pathSeparator] ++ sound ++
 860                         "-" ++ (if n < 10 then ('0':) else id) (show n) ++ ext
 861                         | ext <- [".ogg", ".wav"] ]
 862                 , let vol = case sound of
 863                         "pivot"        -> 64
 864                         "wrenchscrape" -> 64
 865                         "toolmove"     -> 64
 866                         _              -> 128
 867                 ]
 868             return (sound,chunks)
 869         | sound <- ["hookblocked","hookarmblocked","wrenchblocked","wrenchscrape","pivot","unlocked","ballmove","toolmove"]
 870                 ++ ["spring" ++ d ++ show l | d <- ["extend","contract"], l <- [1..12]] ]
 871     -- liftIO $ print sounds
 872     modify $ \s -> s { sounds = Map.fromList sounds }
 873 #else
 874 initAudio = return ()
 875 #endif
 876
 877 pollEvents = do
 878     e <- pollEvent
 879     case e of
 880         NoEvent -> return []
 881         _ -> do
 882             es <- pollEvents
 883             return $ e:es
 884
 885 drawMsgLine = void.runMaybeT $ do
 886     (col,str) <- msum
 887         [ MaybeT $ gets message
 888         , (dimWhiteCol,) <$> MaybeT (gets hoverStr)
 889         ]
 890     lift $ do
 891         renderToMain $ blankRow messageLineCentre
 892         smallFont <- gets dispFontSmall
 893         renderToMain $
 894             (if length str > screenWidthHexes * 3 then withFont smallFont else id) $
 895                 renderStrColAtCentre col str messageLineCentre
 896
 897 setMsgLineNoRefresh col str = do
 898     modify $ \s -> s { message = Just (col,str) }
 899     drawMsgLine
 900 setMsgLine col str = setMsgLineNoRefresh col str >> refresh
 901
 902 clearMsg :: UIM ()
 903 clearMsg = modify $ \s -> s { message = Nothing }
 904
 905 drawTitle (Just (title,n)) = renderToMain $ renderStrColAtCentre messageCol title (titlePos n)
 906 drawTitle Nothing      = return ()
 907
 908 say = setMsgLine messageCol
 909 sayError = setMsgLine errorCol
 910
 911 miniLockPos = (-9)*^hw +^ hu
 912 lockLinePos = 4*^hu +^ miniLockPos
 913 serverPos = 12*^hv +^ 7*^neg hu
 914 serverWaitPos = serverPos +^ hw +^ neg hu
 915 randomNamesPos = 9*^hv +^ 2*^ neg hu
 916 codenamePos = (-6)*^hw +^ 6*^hv
 917 undeclsPos = 13*^neg hu
 918 accessedOursPos = 2*^hw +^ codenamePos
 919 locksPos = hw+^neg hv
 920 retiredPos = locksPos +^ 11*^hu +^ neg hv
 921 interactButtonsPos = 9*^neg hu +^ 8*^hw
 922 scoresPos = codenamePos +^ 5*^hu +^ 2*^neg hv