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