SDLUIMInstance.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 FlexibleInstances, FlexibleContexts #-}
  12 {-# OPTIONS_GHC -cpp #-}
  13 module SDLUIMInstance () where
  14
  15 import Graphics.UI.SDL hiding (flip, name)
  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 System.Timeout
  21 import qualified Data.Map as Map
  22 import Data.Map (Map)
  23 import qualified Data.Vector as Vector
  24 import Data.Maybe
  25 import Control.Concurrent (threadDelay)
  26 import Control.Monad.State
  27 import Control.Monad.Trans.Maybe
  28 import Control.Monad.Trans.Reader
  29 import Data.Word
  30 import Data.Array
  31 import Data.List
  32 import Data.Function (on)
  33 import Data.Foldable (for_)
  34 --import Debug.Trace (traceShow)
  35
  36 import MainState
  37 import Hex
  38 import Command
  39 import GameStateTypes
  40 import Lock
  41 import KeyBindings
  42 import Mundanities
  43 import Metagame
  44 import Protocol
  45 import Cache
  46 import Database
  47 import ServerAddr
  48 import Util
  49 import InputMode
  50 import SDLRender
  51 import SDLUI
  52
  53 instance UIMonad (StateT UIState IO) where
  54     runUI m = evalStateT m nullUIState
  55     drawMainState = do
  56         lift $ clearButtons >> clearSelectables
  57         s <- get
  58         let mode = ms2im s
  59         lift $ waitFrame
  60         drawMainState' s
  61         lift . drawTitle =<< getTitle
  62         lift $ do
  63             drawButtons mode
  64             drawUIOptionButtons mode
  65             gets needHoverUpdate >>? do
  66                 updateHoverStr mode
  67                 modify (\ds -> ds {needHoverUpdate=False})
  68             drawMsgLine
  69             drawShortMouseHelp mode
  70             refresh
  71         where
  72         drawMainState' (PlayState { psCurrentState=st, psLastAlerts=alerts, wrenchSelected=wsel, psIsTut=isTut }) = do
  73             canUndo <- null <$> gets psGameStateMoveStack
  74             canRedo <- null <$> gets psUndoneStack
  75             lift $ do
  76                 let selTools = [ idx |
  77                         (idx, PlacedPiece pos p) <- enumVec $ placedPieces st
  78                         , or [wsel && isWrench p, not wsel && isHook p] ]
  79                 drawMainGameState selTools False alerts st
  80                 lb <- isJust <$> gets leftButtonDown
  81                 rb <- isJust <$> gets leftButtonDown
  82                 when isTut $ do
  83                     centre <- gets dispCentre
  84                     sequence_
  85                         [ registerSelectable (pos -^ centre) 0 $
  86                             if isWrench p then SelToolWrench else SelToolHook
  87                         | PlacedPiece pos p <- Vector.toList $ placedPieces st
  88                         , not $ lb || rb
  89                         , isTool p
  90                         ]
  91                 registerUndoButtons canUndo canRedo
  92         drawMainState' (ReplayState { rsCurrentState=st, rsLastAlerts=alerts } ) = do
  93             canUndo <- null <$> gets rsGameStateMoveStack
  94             canRedo <- null <$> gets rsMoveStack
  95             lift $ do
  96                 drawMainGameState [] False alerts st
  97                 registerUndoButtons canUndo canRedo
  98                 renderToMain $ drawCursorAt Nothing
  99         drawMainState' (EditState { esGameStateStack=(st:sts), esUndoneStack=undostack,
 100                 selectedPiece=selPiece, selectedPos=selPos }) = lift $ do
 101             drawMainGameState (maybeToList selPiece) True [] st
 102             renderToMain $ drawCursorAt $ if isNothing selPiece then Just selPos else Nothing
 103             registerUndoButtons (null sts) (null undostack)
 104             when (isJust selPiece) $ mapM_ registerButtonGroup
 105                 [ singleButton (periphery 2 +^ 3*^hw+^hv) CmdDelete 0 [("delete",hu+^neg hw)]
 106                 , singleButton (periphery 2 +^ 3*^hw) CmdMerge 1 [("merge",hu+^neg hw)]
 107                 ]
 108             sequence_
 109                 [ when (null . filter (pred . placedPiece) . Vector.toList $ placedPieces st)
 110                     $ registerButton (periphery 0 +^ d) cmd 2 [("place",hu+^neg hw),(tool,hu+^neg hv)]
 111                 | (pred,tool,cmd,d) <- [
 112                     (isWrench, "wrench", CmdTile $ WrenchTile zero, (-4)*^hv +^ hw),
 113                     (isHook, "hook", CmdTile $ HookTile, (-3)*^hv +^ hw) ] ]
 114             drawPaintButtons
 115         drawMainState' (MetaState {curServer=saddr, undeclareds=undecls,
 116                 cacheOnly=cOnly, curAuth=auth, codenameStack=names,
 117                 randomCodenames=rnamestvar, retiredLocks=mretired, curLockPath=path,
 118                 curLock=mlock, listOffset=offset, asyncCount=count}) = do
 119             let ourName = authUser <$> auth
 120             let selName = listToMaybe names
 121             let home = isJust ourName && ourName == selName
 122             lift $ renderToMain $ (erase >> drawCursorAt Nothing)
 123             lift $ do
 124                 smallFont <- gets dispFontSmall
 125                 renderToMain $ withFont smallFont $ renderStrColAtLeft purple
 126                         (saddrStr saddr ++ if cOnly then " (cache only)" else "")
 127                     $ serverPos +^ hu
 128
 129             when (length names > 1) $ lift $ registerButton
 130                 (codenamePos +^ neg hu +^ 2*^hw) CmdBackCodename 0 [("back",3*^hw)]
 131
 132             runMaybeT $ do
 133                 name <- MaybeT (return selName)
 134                 FetchedRecord fresh err muirc <- lift $ getUInfoFetched 300 name
 135                 pending <- ((>0) <$>) $ liftIO $ atomically $ readTVar count
 136                 lift $ do
 137                     lift $ do
 138                         unless ((fresh && not pending) || cOnly) $ do
 139                             smallFont <- gets dispFontSmall
 140                             let str = if pending then "(response pending)" else "(updating)"
 141                             renderToMain $ withFont smallFont $
 142                                 renderStrColBelow (opaquify $ dim errorCol) str $ codenamePos
 143                         maybe (return ()) (setMsgLineNoRefresh errorCol) err
 144                         when (fresh && (isNothing ourName || isNothing muirc || home)) $
 145                             let reg = isNothing muirc || isJust ourName
 146                             in registerButton (codenamePos +^ 2*^hu)
 147                                 (if reg then CmdRegister $ isJust ourName else CmdAuth)
 148                                 (if isNothing ourName then 2 else 0)
 149                                 [(if reg then "reg" else "auth", 3*^hw)]
 150                     (if isJust muirc then drawName else drawNullName) name codenamePos
 151                     lift $ registerSelectable codenamePos 0 (SelSelectedCodeName name)
 152                     drawRelScore name (codenamePos+^hu)
 153                     when (isJust muirc) $ lift $
 154                         registerButton retiredPos CmdShowRetired 5 [("retired",hu+^neg hw)]
 155                     for_ muirc $ \(RCUserInfo (_,uinfo)) -> case mretired of
 156                             Just retired -> do
 157                                 fillArea locksPos
 158                                     (map (locksPos+^) $ zero:[rotate n $ 4*^hu-^4*^hw | n <- [0,2,3,5]])
 159                                     [ \pos -> (lift $ registerSelectable pos 1 (SelOldLock ls)) >> drawOldLock ls pos
 160                                     | ls <- retired ]
 161                                 lift $ registerButton (retiredPos +^ hv) (CmdPlayLockSpec Nothing) 1 [("play",hu+^neg hw),("no.",hu+^neg hv)]
 162                             Nothing -> do
 163                                 sequence_ [ drawLockInfo (ActiveLock (codename uinfo) i) mlockinfo |
 164                                     (i,mlockinfo) <- assocs $ userLocks uinfo ]
 165                                 when (isJust $ msum $ elems $ userLocks uinfo) $ lift $ do
 166                                     registerButton interactButtonsPos (CmdSolve Nothing) 2 [("solve",hu+^neg hw),("lock",hu+^neg hv)]
 167                                     registerButton (interactButtonsPos+^hw) (CmdViewSolution Nothing) 1 [("view",hu+^neg hw),("soln",hu+^neg hv)]
 168
 169             when home $ do
 170                 lift.renderToMain $ renderStrColAt messageCol
 171                     "Home" (codenamePos+^hw+^neg hv)
 172                 unless (null undecls) $ do
 173                     lift.renderToMain $ renderStrColAtLeft messageCol "Undeclared:" (undeclsPos+^2*^hv+^neg hu)
 174                     lift $ registerButton (undeclsPos+^hw+^neg hu) (CmdDeclare Nothing) 2 [("decl",hv+^4*^neg hu),("soln",hw+^4*^neg hu)]
 175                     fillArea (undeclsPos+^hv)
 176                         (map (undeclsPos+^) $ hexDisc 1 ++ [hu+^neg hw, neg hu+^hv])
 177                         [ \pos -> (lift $ registerSelectable pos 0 (SelUndeclared undecl)) >> drawActiveLock al pos
 178                         | undecl@(Undeclared _ _ al) <- undecls ]
 179                 lift $ do
 180                     maybe (drawEmptyMiniLock miniLockPos)
 181                         (\lock -> drawMiniLock lock miniLockPos)
 182                         (fst<$>mlock)
 183                     registerSelectable miniLockPos 1 SelOurLock
 184                     registerButton (miniLockPos+^3*^neg hw+^2*^hu) CmdEdit 2
 185                         [("edit",hu+^neg hw),("lock",hu+^neg hv)]
 186                     registerButton lockLinePos CmdSelectLock 1 []
 187                 lift $ when (not $ null path) $ do
 188                     renderToMain $ renderStrColAtLeft messageCol (take 16 path) $ lockLinePos +^ hu
 189                     registerSelectable (lockLinePos +^ 2*^hu) 1 SelLockPath
 190                     sequence_
 191                         [ registerButton (miniLockPos +^ 2*^neg hv +^ 2*^hu +^ dv) cmd 1
 192                             [(dirText,hu+^neg hw),("lock",hu+^neg hv)]
 193                         | (dv,cmd,dirText) <- [(zero,CmdPrevLock,"prev"),(neg hw,CmdNextLock,"next")] ]
 194                 let tested = maybe False (isJust.snd) mlock
 195                 when (isJust mlock && home) $ lift $ registerButton
 196                     (miniLockPos+^2*^neg hw+^3*^hu) (CmdPlaceLock Nothing)
 197                         (if tested then 2 else 1)
 198                         [("place",hu+^neg hw),("lock",hu+^neg hv)]
 199             rnames <- liftIO $ atomically $ readTVar rnamestvar
 200             unless (null rnames) $
 201                 fillArea randomNamesPos
 202                     (map (randomNamesPos+^) $ hexDisc 2)
 203                     [ \pos -> (lift $ registerSelectable pos 0 (SelRandom name)) >> drawName name pos
 204                     | name <- rnames ]
 205
 206             when (ourName /= selName) $ void $ runMaybeT $ do
 207                 when (isJust ourName) $
 208                     lift.lift $ registerButton (codenamePos +^ hw +^ neg hv) CmdHome 1 [("home",3*^hw)]
 209                 sel <- liftMaybe selName
 210                 us <- liftMaybe ourName
 211                 ourUInfo <- mgetUInfo us
 212                 selUInfo <- mgetUInfo sel
 213                 let accesses = map (uncurry getAccessInfo) [(ourUInfo,selUInfo),(selUInfo,ourUInfo)]
 214                 let posLeft = scoresPos +^ hw +^ neg hu
 215                 let posRight = posLeft +^ 3*^hu
 216                 size <- snd <$> (lift.lift) getGeom
 217                 lift $ do
 218                     lift.renderToMain $ renderStrColAbove (brightish white) "ESTEEM" $ scoresPos
 219                     lift $ sequence_ [ registerSelectable (scoresPos+^v) 0 SelRelScore | v <- [hv, hv+^hu] ]
 220                     drawRelScore sel scoresPos
 221                     fillArea (posLeft+^hw) (map (posLeft+^) [zero,hw,neg hv])
 222                         [ \pos -> (lift $ registerSelectable pos 0 (SelScoreLock (Just sel) accessed $ ActiveLock us i)) >>
 223                             drawNameWithCharAndCol us white (lockIndexChar i) col pos
 224                         | i <- [0..2]
 225                         , let accessed = accesses !! 0 !! i
 226                         , let col
 227                                 | accessed == Just AccessedPub = dim pubColour
 228                                 | (maybe False winsPoint) accessed = dim $ scoreColour $ -3
 229                                 | otherwise = obscure $ scoreColour 3 ]
 230                     fillArea (posRight+^hw) (map (posRight+^) [zero,hw,neg hv])
 231                         [ \pos -> (lift $ registerSelectable pos 0 (SelScoreLock Nothing accessed $ ActiveLock sel i)) >>
 232                             drawNameWithCharAndCol sel white (lockIndexChar i) col pos
 233                         | i <- [0..2]
 234                         , let accessed = accesses !! 1 !! i
 235                         , let col
 236                                 | accessed == Just AccessedPub = obscure pubColour
 237                                 | (maybe False winsPoint) accessed = dim $ scoreColour $ 3
 238                                 | otherwise = obscure $ scoreColour $ -3 ]
 239                 (posScore,negScore) <- MaybeT $ (snd<$>) <$> getRelScoreDetails sel
 240                 lift.lift $ sequence_
 241                     [ do
 242                         renderToMain $ renderStrColAt (scoreColour score) (sign:show (abs score)) pos
 243                         registerSelectable pos 0 SelRelScoreComponent
 244                     | (sign,score,pos) <-
 245                         [ ('-',-negScore,posLeft+^neg hv+^hw)
 246                         , ('+',posScore,posRight+^neg hv+^hw) ] ]
 247
 248         drawMainState' _ = return ()
 249
 250     drawMessage = say
 251     drawPrompt full s = say $ s ++ (if full then "" else "_")
 252     endPrompt = say ""
 253     drawError = sayError
 254
 255     reportAlerts = playAlertSounds
 256
 257     getChRaw = do
 258         events <- liftIO getEvents
 259         if not.null $ [ True | MouseButtonDown _ _ ButtonRight <- events ]
 260         then return Nothing
 261         else maybe getChRaw (return.Just) $ listToMaybe $ [ ch
 262             | KeyDown (Keysym _ _ ch) <- events
 263             , ch /= '\0' ]
 264
 265     setUIBinding mode cmd ch =
 266         modify $ \s -> s { uiKeyBindings =
 267                 Map.insertWith (\[bdg] -> \bdgs -> if bdg `elem` bdgs then delete bdg bdgs else bdg:bdgs)
 268                     mode [(ch,cmd)] $ uiKeyBindings s }
 269
 270     getUIBinding mode cmd = ($cmd) <$> getBindingStr mode
 271
 272     initUI = liftM isJust (runMaybeT $ do
 273         catchIOErrorMT $ SDL.init
 274 #ifdef SOUND
 275             [InitVideo,InitAudio]
 276 #else
 277             [InitVideo]
 278 #endif
 279         catchIOErrorMT TTF.init
 280         lift $ do
 281             readUIConfigFile
 282             initVideo 0 0
 283             liftIO $ initMisc
 284             w <- gets scrWidth
 285             h <- gets scrHeight
 286             liftIO $ warpMouse (fi $ w`div`2) (fi $ h`div`2)
 287             renderToMain $ erase
 288             initAudio
 289             readBindings
 290         )
 291         where
 292             catchIOErrorMT m = MaybeT $ liftIO $ catchIO (m >> return (Just ())) (\_ -> return Nothing)
 293
 294     endUI = do
 295         writeUIConfigFile
 296         writeBindings
 297         liftIO $ quit
 298
 299     unblockInput = return $ pushEvent VideoExpose
 300     suspend = return ()
 301     redraw = return ()
 302
 303     impatience ticks = do
 304         liftIO $ threadDelay 50000
 305         if (ticks>20) then do
 306                 let pos = serverWaitPos
 307                 smallFont <- gets dispFontSmall
 308                 renderToMain $ do
 309                     mapM (drawAtRel (FilledHexGlyph $ bright black)) [ pos +^ i*^hu | i <- [0..3] ]
 310                     withFont smallFont $
 311                         renderStrColAtLeft errorCol ("waiting..."++replicate ((ticks`div`5)`mod`3) '.') $ pos
 312                 clearButtons
 313                 registerButton (pos +^ neg hv) CmdQuit 0 [("abort",hu+^neg hw)]
 314                 drawButtons IMImpatience
 315                 refresh
 316                 cmds <- getInput IMImpatience
 317                 return $ CmdQuit `elem` cmds
 318             else return False
 319
 320     warpPointer pos = do
 321         (scrCentre, size) <- getGeom
 322         centre <- gets dispCentre
 323         let SVec x y = hexVec2SVec size (pos-^centre) +^ scrCentre
 324         liftIO $ warpMouse (fi x) (fi y)
 325         lbp <- gets leftButtonDown
 326         rbp <- gets rightButtonDown
 327         let [lbp',rbp'] = fmap (fmap (\_ -> (pos-^centre))) [lbp,rbp]
 328         modify $ \s -> s {leftButtonDown = lbp', rightButtonDown = rbp'}
 329
 330     getUIMousePos = do
 331         centre <- gets dispCentre
 332         (Just.(+^centre).fst) <$> gets mousePos
 333
 334     setYNButtons = do
 335         clearButtons
 336         registerButton (periphery 5 +^ hw) (CmdInputChar 'Y') 2 []
 337         registerButton (periphery 5 +^ neg hv) (CmdInputChar 'N') 0 []
 338         drawButtons IMTextInput
 339         refresh
 340
 341     toggleColourMode = modify $ \s -> s {uiOptions = (uiOptions s){
 342         useFiveColouring = not $ useFiveColouring $ uiOptions s}}
 343
 344     getInput mode = do
 345         fps <- gets fps
 346         events <- liftIO $ nubMouseMotions <$> getEventsTimeout (10^6`div`fps)
 347         (cmds,uiChanged) <- if null events then return ([],False) else do
 348             oldUIState <- get
 349             cmds <- concat <$> mapM processEvent events
 350             setPaintFromCmds cmds
 351             newUIState <- get
 352             return (cmds,uistatesMayVisiblyDiffer oldUIState newUIState)
 353         now <- liftIO getTicks
 354         animFrameReady <- maybe False (<now) <$> gets nextAnimFrameAt
 355         return $ cmds ++ if uiChanged || animFrameReady then [CmdRefresh] else []
 356         where
 357             nubMouseMotions evs =
 358                 -- drop all but last mouse motion event
 359                 let nubMouseMotions' False (mm@(MouseMotion {}):evs) = mm:(nubMouseMotions' True evs)
 360                     nubMouseMotions' True (mm@(MouseMotion {}):evs) = nubMouseMotions' True evs
 361                     nubMouseMotions' b (ev:evs) = ev:(nubMouseMotions' b evs)
 362                     nubMouseMotions' _ [] = []
 363                 in reverse $ nubMouseMotions' False $ reverse evs
 364             setPaintFromCmds cmds = sequence_
 365                 [ modify $ \s -> s { paintTileIndex = pti }
 366                     | (pti,pt) <- zip [0..] paintTiles
 367                     , cmd <- cmds
 368                     , (isNothing pt && cmd == CmdDelete) ||
 369                         (isJust $ do
 370                             pt' <- pt
 371                             CmdTile t <- Just cmd
 372                             guard $ ((==)`on`tileType) t pt') ]
 373
 374             uistatesMayVisiblyDiffer uis1 uis2 =
 375                 uis1 { mousePos = (zero,False), lastFrameTicks=0 }
 376                 /= uis2 {mousePos = (zero,False), lastFrameTicks=0 }
 377             processEvent (KeyDown (Keysym _ _ ch)) = case mode of
 378                 IMTextInput -> return [CmdInputChar ch]
 379                 _ -> do
 380                     setting <- gets settingBinding
 381                     if isJust setting && ch /= '\0'
 382                     then do
 383                         modify $ \s -> s {settingBinding = Nothing}
 384                         when (ch /= '\ESC') $ setUIBinding mode (fromJust setting) ch
 385                         return []
 386                     else do
 387                         uibdgs <- Map.findWithDefault [] mode `liftM` gets uiKeyBindings
 388                         let mCmd = lookup ch $ uibdgs ++ bindings mode
 389                         return $ maybeToList mCmd
 390             processEvent (MouseMotion {}) = do
 391                 (oldMPos,_) <- gets mousePos
 392                 (pos@(mPos,_),(sx,sy,sz)) <- getMousePos
 393                 updateMousePos mode pos
 394                 lbp <- gets leftButtonDown
 395                 rbp <- gets rightButtonDown
 396                 centre <- gets dispCentre
 397                 let drag :: Maybe HexVec -> Maybe Command
 398                     drag bp = do
 399                         fromPos@(HexVec x y z) <- bp
 400                         -- check we've dragged at least a full hex's distance:
 401                         guard $ not.all (\(a,b) -> abs ((fi a) - b) < 1.0) $ [(x,sx),(y,sy),(z,sz)]
 402                         let dir = hexVec2HexDirOrZero $ mPos -^ fromPos
 403                         guard $ dir /= zero
 404                         return $ CmdDrag (fromPos+^centre) dir
 405                 case mode of
 406                     IMEdit -> case drag rbp of
 407                         Just cmd -> return [cmd]
 408                         Nothing -> if mPos /= oldMPos
 409                             then do
 410                                 pti <- getEffPaintTileIndex
 411                                 return $ [ CmdMoveTo $ mPos +^ centre ] ++
 412                                     (if isJust lbp then [ CmdPaintFromTo (paintTiles!!pti) (oldMPos+^centre) (mPos+^centre) ] else [])
 413                             else return []
 414                     IMPlay -> return $ maybeToList $ msum $ map drag [lbp, rbp]
 415                     _ -> return []
 416                 where
 417                     mouseFromTo from to = do
 418                         let dir = hexVec2HexDirOrZero $ to -^ from
 419                         if dir /= zero
 420                             then (CmdDir WHSSelected dir:) <$> mouseFromTo (from +^ dir) to
 421                             else return []
 422             processEvent (MouseButtonDown _ _ ButtonLeft) = do
 423                 pos@(mPos,central) <- gets mousePos
 424                 modify $ \s -> s { leftButtonDown = Just mPos }
 425                 rb <- isJust <$> gets rightButtonDown
 426                 mcmd <- cmdAtMousePos pos mode (Just False)
 427                 let hotspotAction = listToMaybe
 428                         $ map (\cmd -> return [cmd]) (maybeToList mcmd)
 429                         ++ [ (modify $ \s -> s {paintTileIndex = i}) >> return []
 430                             | i <- take (length paintTiles) [0..]
 431                             , mPos == paintButtonStart +^ i*^hv ]
 432                         ++ [ toggleUIOption uiOB1 >> updateHoverStr mode >> return []
 433                             | mPos == uiOptPos uiOB1 && mode `elem` uiOptModes uiOB1 ]
 434                         ++ [ toggleUIOption uiOB2 >> updateHoverStr mode >> return []
 435                             | mPos == uiOptPos uiOB2 && mode `elem` uiOptModes uiOB2 ]
 436                         ++ [ toggleUIOption uiOB3 >> updateHoverStr mode >> return []
 437                             | mPos == uiOptPos uiOB3 && mode `elem` uiOptModes uiOB3 ]
 438                         ++ [ toggleUIOption uiOB4 >> updateHoverStr mode >> return []
 439                             | mPos == uiOptPos uiOB4 && mode `elem` uiOptModes uiOB4 ]
 440                         ++ [ toggleUIOption uiOB5 >> updateHoverStr mode >> return []
 441                             | mPos == uiOptPos uiOB5 && mode `elem` uiOptModes uiOB5 ]
 442 #ifdef SOUND
 443                         ++ [ toggleUIOption uiOB6 >> updateHoverStr mode >> return []
 444                             | mPos == uiOptPos uiOB6 && mode `elem` uiOptModes uiOB6 ]
 445 #endif
 446
 447                 if rb
 448                 then return [ CmdWait ]
 449                 else flip fromMaybe hotspotAction $ case mode of
 450                     IMEdit -> do
 451                         pti <- getEffPaintTileIndex
 452                         return $ [ drawCmd (paintTiles!!pti) False ]
 453                     IMPlay -> do
 454                         centre <- gets dispCentre
 455                         return $ [ CmdManipulateToolAt $ mPos +^ centre ]
 456                     _ -> return []
 457             processEvent (MouseButtonUp _ _ ButtonLeft) = do
 458                 modify $ \s -> s { leftButtonDown = Nothing }
 459                 return []
 460             processEvent (MouseButtonDown _ _ ButtonRight) = do
 461                 pos@(mPos,_) <- gets mousePos
 462                 modify $ \s -> s { rightButtonDown = Just mPos }
 463                 lb <- isJust <$> gets leftButtonDown
 464                 if lb
 465                 then return [ CmdWait ]
 466                 else (fromMaybe [] <$>) $ runMaybeT $ msum
 467                     [ do
 468                         cmd <- MaybeT $ cmdAtMousePos pos mode Nothing
 469                         guard $ mode /= IMTextInput
 470                         -- modify $ \s -> s { settingBinding = Just cmd }
 471                         return [ CmdBind $ Just cmd ]
 472                     , do
 473                         cmd <- MaybeT $ cmdAtMousePos pos mode (Just True)
 474                         return [cmd]
 475                     , case mode of
 476                         IMPlay -> return [ CmdClear, CmdWait ]
 477                         _ -> return [ CmdClear, CmdSelect ] ]
 478             processEvent (MouseButtonUp _ _ ButtonRight) = do
 479                 modify $ \s -> s { rightButtonDown = Nothing }
 480                 return [ CmdUnselect ]
 481             processEvent (MouseButtonDown _ _ ButtonWheelUp) = doWheel 1
 482             processEvent (MouseButtonDown _ _ ButtonWheelDown) = doWheel $ -1
 483             processEvent (MouseButtonDown _ _ ButtonMiddle) = do
 484                 (mPos,_) <- gets mousePos
 485                 modify $ \s -> s { middleButtonDown = Just mPos }
 486                 rb <- isJust <$> gets rightButtonDown
 487                 return $ if rb then [ CmdDelete ] else []
 488             processEvent (MouseButtonUp _ _ ButtonMiddle) = do
 489                 modify $ \s -> s { middleButtonDown = Nothing }
 490                 return []
 491             processEvent (VideoResize w h) = do
 492                 initVideo w h
 493                 return [ CmdRedraw ]
 494             processEvent VideoExpose = return [ CmdRefresh ]
 495             processEvent Quit = return [ CmdForceQuit ]
 496
 497             processEvent _ = return []
 498
 499             doWheel dw = do
 500                 rb <- isJust <$> gets rightButtonDown
 501                 mb <- isJust <$> gets middleButtonDown
 502                 if ((rb || mb || mode == IMReplay) && mode /= IMEdit)
 503                     || (mb && mode == IMEdit)
 504                 then return [ if dw == 1 then CmdRedo else CmdUndo ]
 505                 else if mode /= IMEdit || rb
 506                 then return [ CmdRotate WHSSelected dw ]
 507                 else do
 508                     modify $ \s -> s { paintTileIndex = (paintTileIndex s + dw) `mod` (length paintTiles) }
 509                     return []
 510
 511
 512             drawCmd mt True = CmdPaint mt
 513             drawCmd (Just t) False = CmdTile t
 514             drawCmd Nothing _ = CmdDelete
 515
 516             getMousePos :: UIM ((HexVec,Bool),(Double,Double,Double))
 517             getMousePos = do
 518                 (scrCentre, size) <- getGeom
 519                 (x,y,_) <- lift getMouseState
 520                 let sv = (SVec (fi x) (fi y)) +^ neg scrCentre
 521                 let mPos@(HexVec x y z) = sVec2HexVec size sv
 522                 let (sx,sy,sz) = sVec2dHV size sv
 523                 let isCentral = all (\(a,b) -> abs ((fi a) - b) < 0.5) $
 524                         [(x,sx),(y,sy),(z,sz)]
 525                 return ((mPos,isCentral),(sx,sy,sz))
 526             updateMousePos mode newPos = do
 527                 oldPos <- gets mousePos
 528                 when (newPos /= oldPos) $ do
 529                     modify $ \ds -> ds { mousePos = newPos }
 530                     updateHoverStr mode
 531
 532     showHelp mode HelpPageInput = do
 533         bdgs <- nub <$> getBindings mode
 534         smallFont <- gets dispFontSmall
 535         renderToMain $ do
 536             erase
 537             let bdgWidth = (screenWidthHexes-6) `div` 3
 538                 showKeys chs = intercalate "/" (map showKeyFriendly chs)
 539                 maxkeyslen = maximum . (0:) $ map (length.showKeys.map fst) $ groupBy ((==) `on` snd) bdgs
 540                 extraHelpStrs = [["Mouse commands:", "Right-click on a button to set a keybinding;"]
 541                         ++ case mode of
 542                             IMPlay -> ["Click on tool to select, drag to move;",
 543                                 "Click by tool to move; right-click to wait;", "Scroll wheel to rotate hook;",
 544                                 "Scroll wheel with right button held down to undo/redo."]
 545                             IMEdit -> ["Left-click to draw selected; scroll to change selection;",
 546                                 "Right-click on piece to select, drag to move;",
 547                                 "While holding right-click: left-click to advance time, middle-click to delete;",
 548                                 "Scroll wheel to rotate selected piece; scroll wheel while held down to undo/redo."]
 549                             IMReplay -> ["Scroll wheel with right button held down to undo/redo."]
 550                             IMMeta -> ["Left-clicking on something does most obvious thing;"
 551                                 , "Right-clicking does second-most obvious thing."]]
 552                     ++ case mode of
 553                         IMMeta -> [[
 554                             "Basic game instructions:"
 555                             , "Choose [C]odename, then [R]egister it;"
 556                             , "select other players, and [S]olve their locks;"
 557                             , "go [H]ome, then [E]dit and [P]lace a lock of your own;"
 558                             , "you can then [D]eclare your solutions."
 559                             , "Make other players green by solving their locks and not letting them solve yours."]]
 560                         _ -> []
 561             renderStrColAt cyan "Keybindings:" $ (screenHeightHexes`div`4)*^(hv+^neg hw)
 562             let keybindingsHeight = screenHeightHexes - (3 + length extraHelpStrs + sum (map length extraHelpStrs))
 563             sequence_ [ with $ renderStrColAtLeft messageCol
 564                         ( keysStr ++ ": " ++ desc )
 565                         $ (x*bdgWidth-(screenWidthHexes-6)`div`2)*^hu +^ neg hv +^
 566                           (screenHeightHexes`div`4 - y`div`2)*^(hv+^neg hw) +^
 567                           (y`mod`2)*^hw
 568                 | ((keysStr,with,desc),(x,y)) <- zip [(keysStr,with,desc)
 569                         | group <- groupBy ((==) `on` snd) $ sortBy (compare `on` snd) bdgs
 570                         , let cmd = snd $ head group
 571                         , let desc = describeCommand cmd
 572                         , not $ null desc
 573                         , let chs = map fst group
 574                         , let keysStr = showKeys chs
 575                         , let with = if True -- 3*(bdgWidth-1) < length desc + length keysStr + 1
 576                                 then withFont smallFont
 577                                 else id
 578                         ]
 579                     (map (`divMod` keybindingsHeight) [0..])
 580                 , (x+1)*bdgWidth < screenWidthHexes]
 581             sequence_ [ renderStrColAt (if firstLine then cyan else messageCol) str
 582                         $ (screenHeightHexes`div`4 - y`div`2)*^(hv+^neg hw)
 583                           +^ hw
 584                           +^ (y`mod`2)*^hw
 585                 | ((str,firstLine),y) <- (intercalate [("",False)] $ (map (`zip` (True:repeat False)) extraHelpStrs)) `zip` [(keybindingsHeight+1)..] ]
 586         refresh
 587         return True
 588     showHelp IMMeta HelpPageGame = do
 589         renderToMain $ do
 590             erase
 591             let headPos = (screenHeightHexes`div`4)*^(hv+^neg hw)
 592             renderStrColAt red "INTRICACY" headPos
 593             sequence_
 594                 [ renderStrColAt purple str $
 595                     headPos
 596                       +^ (y`div`2)*^(hw+^neg hv)
 597                       +^ (y`mod`2)*^hw
 598                 | (y,str) <- zip [1..]
 599                     metagameHelpText
 600                 ]
 601         return True
 602     showHelp _ _ = return False
 603
 604     onNewMode mode = modify (\ds -> ds{needHoverUpdate=True}) >> say ""
 605
 606 drawShortMouseHelp mode = do
 607     mwhs <- gets $ whsButtons.uiOptions
 608     showBT <- showButtonText <$> gets uiOptions
 609     when (showBT && isNothing mwhs) $ do
 610         let helps = shortMouseHelp mode
 611         smallFont <- gets dispFontSmall
 612         renderToMain $ withFont smallFont $ sequence_
 613             [ renderStrColAtLeft (dim cyan) help
 614                 (periphery 3 +^ neg hu +^ (2-n)*^hv )
 615             | (n,help) <- zip [0..] helps ]
 616     where
 617         shortMouseHelp IMPlay =
 618             [ "LMB: select/move tool"
 619             , "LMB+drag: move tool"
 620             , "Wheel: turn hook"
 621             , "RMB: wait a turn"
 622             , "RMB+Wheel: undo/redo"
 623             ]
 624         shortMouseHelp IMEdit =
 625             [ "LMB: paint; Ctrl+LMB: delete"
 626             , "Wheel: set paint type"
 627             , "RMB: select piece; drag to move"
 628             , "RMB+LMB: wait; RMB+MMB: delete piece"
 629             , "MMB+Wheel: undo/redo"
 630             ]
 631         shortMouseHelp IMReplay =
 632             [ "Wheel: advance/regress time" ]
 633         shortMouseHelp _ = []
 634
 635 -- waitEvent' : copy of SDL.Events.waitEvent, with the timeout increased
 636 -- drastically to reduce CPU load when idling.
 637 waitEvent' :: IO Event
 638 waitEvent' = loop
 639     where loop = do pumpEvents
 640                     event <- pollEvent
 641                     case event of
 642                       NoEvent -> threadDelay 10000 >> loop
 643                       _ -> return event
 644
 645 getEvents = do
 646     e <- waitEvent'
 647     es <- pollEvents
 648     return $ e:es
 649
 650 getEventsTimeout us = do
 651     es <- maybeToList <$> timeout us waitEvent'
 652     es' <- pollEvents
 653     return $ es++es'
 654
 655 updateHoverStr :: InputMode -> UIM ()
 656 updateHoverStr mode = do
 657     p@(mPos,isCentral) <- gets mousePos
 658     showBT <- showButtonText <$> gets uiOptions
 659     hstr <- runMaybeT $ msum
 660         [ MaybeT ( cmdAtMousePos p mode Nothing ) >>= lift . describeCommandAndKeys
 661         , guard showBT >> MaybeT (helpAtMousePos p mode)
 662         , guard (showBT && mode == IMEdit) >> msum
 663             [ return $ "set paint mode: " ++ describeCommand (paintTileCmds!!i)
 664             | i <- take (length paintTiles) [0..]
 665             , mPos == paintButtonStart +^ i*^hv ]
 666         , guard (mPos == uiOptPos uiOB1 && mode `elem` uiOptModes uiOB1) >> describeUIOptionButton uiOB1
 667         , guard (mPos == uiOptPos uiOB2 && mode `elem` uiOptModes uiOB2) >> describeUIOptionButton uiOB2
 668         , guard (mPos == uiOptPos uiOB3 && mode `elem` uiOptModes uiOB3) >> describeUIOptionButton uiOB3
 669         , guard (mPos == uiOptPos uiOB4 && mode `elem` uiOptModes uiOB4) >> describeUIOptionButton uiOB4
 670         , guard (mPos == uiOptPos uiOB5 && mode `elem` uiOptModes uiOB5) >> describeUIOptionButton uiOB5
 671 #ifdef SOUND
 672         , guard (mPos == uiOptPos uiOB6 && mode `elem` uiOptModes uiOB6) >> describeUIOptionButton uiOB6
 673 #endif
 674         ]
 675     modify $ \ds -> ds { hoverStr = hstr }
 676     where
 677         describeCommandAndKeys :: Command -> UIM String
 678         describeCommandAndKeys cmd = do
 679             uibdgs <- Map.findWithDefault [] mode `liftM` gets uiKeyBindings
 680             return $ describeCommand cmd ++ " ["
 681                 ++ concat (intersperse ","
 682                     (map showKeyFriendly $ findBindings (uibdgs ++ bindings mode) cmd))
 683                 ++ "]"
 684
 685
 686 fillArea :: HexVec -> [HexVec] -> [HexVec -> MainStateT UIM ()] -> MainStateT UIM ()
 687 fillArea centre area draws = do
 688     offset <- gets listOffset
 689     let na = length area
 690         listButton cmd = \pos -> lift $ registerButton pos cmd 3 []
 691         draws' = if offset > 0 && length draws > na
 692             then listButton CmdPrevPage :
 693                 drop (max 0 $ min (length draws - (na-1)) (na-1 + (na-2)*(offset-1))) draws
 694             else draws
 695         selDraws = if length draws' > na
 696             then take (na-1) draws' ++ [listButton CmdNextPage]
 697             else take na draws'
 698     sequence_ $ map (uncurry ($)) $
 699         zip selDraws $ sortBy (compare `on` hexVec2SVec 37) $
 700             take (length selDraws) $ sortBy
 701                 (compare `on` (hexLen . (-^centre)))
 702                 area
 703
 704 drawOldLock ls pos = void.runMaybeT $ msum [ do
 705         lock <- mgetLock ls
 706         lift.lift $ drawMiniLock lock pos
 707     , lift.lift.renderToMain $
 708             renderStrColAt messageCol (show ls) pos
 709     ]
 710
 711
 712 drawName name pos = nameCol name >>= drawNameCol name pos
 713 drawNullName name pos = drawNameCol name pos $ invisible white
 714 drawNameCol name pos col = do
 715     lift.renderToMain $ do
 716         drawAtRel (playerGlyph col) pos
 717         renderStrColAt buttonTextCol name pos
 718 drawRelScore name pos = do
 719     col <- nameCol name
 720     relScore <- getRelScore name
 721     flip (maybe (return ())) relScore $ \score ->
 722         lift $ do
 723             renderToMain $ renderStrColAt col
 724                 ((if score > 0 then "+" else "") ++ show score) pos
 725             registerSelectable pos 0 SelRelScore
 726
 727 drawNote note pos = case noteBehind note of
 728     Just al -> drawActiveLock al pos
 729     Nothing -> drawPublicNote (noteAuthor note) pos
 730 drawActiveLock al@(ActiveLock name i) pos = do
 731     accessed <- accessedAL al
 732     drawNameWithChar name
 733         (if accessed then accColour else white)
 734         (lockIndexChar i) pos
 735 drawPublicNote name =
 736     drawNameWithChar name pubColour 'P'
 737 drawNameWithChar name charcol char pos = do
 738     col <- nameCol name
 739     drawNameWithCharAndCol name charcol char col pos
 740 drawNameWithCharAndCol :: String -> Pixel -> Char -> Pixel -> HexVec -> MainStateT UIM ()
 741 drawNameWithCharAndCol name charcol char col pos = do
 742     size <- fi.snd <$> lift getGeom
 743     let up = SVec 0 $ - (ysize size - size`div`2)
 744     let down = SVec 0 $ ysize size
 745     smallFont <- lift $ gets dispFontSmall
 746     lift.renderToMain $ do
 747         drawAtRel (playerGlyph col) pos
 748         displaceRender up $
 749             renderStrColAt buttonTextCol name pos
 750         displaceRender down $ withFont smallFont $
 751             renderStrColAt charcol [char] pos
 752 pubWheelAngle = 5
 753 pubColour = colourWheel pubWheelAngle -- ==purple
 754 accColour = cyan
 755 nameCol name = do
 756     ourName <- (authUser <$>) <$> gets curAuth
 757     relScore <- getRelScore name
 758     return $ dim $ case relScore of
 759             Nothing -> Pixel $ if ourName == Just name then 0xc0c0c000 else 0x80808000
 760             Just score -> scoreColour score
 761 scoreColour :: Int -> Pixel
 762 scoreColour score = Pixel $ case score of
 763         0 -> 0x80800000
 764         1 -> 0x70a00000
 765         2 -> 0x40c00000
 766         3 -> 0x00ff0000
 767         (-1) -> 0xa0700000
 768         (-2) -> 0xc0400000
 769         (-3) -> 0xff000000
 770
 771 drawLockInfo :: ActiveLock -> Maybe LockInfo -> MainStateT UIM ()
 772 drawLockInfo al@(ActiveLock name idx) Nothing = do
 773     let centre = hw+^neg hv +^ 7*(idx-1)*^hu
 774     lift $ drawEmptyMiniLock centre
 775     drawNameWithCharAndCol name white (lockIndexChar idx) (invisible white) centre
 776     ourName <- (authUser <$>) <$> gets curAuth
 777     lift $ registerSelectable centre 3 $ SelLockUnset (ourName == Just name) al
 778 drawLockInfo al@(ActiveLock name idx) (Just lockinfo) = do
 779     let centre = locksPos +^ 7*(idx-1)*^hu
 780     let accessedByPos = centre +^ 3*^(hv +^ neg hw)
 781     let accessedPos = centre +^ 2*^(hw +^ neg hv)
 782     let notesPos = centre +^ 3*^(hw +^ neg hv)
 783     ourName <- (authUser <$>) <$> gets curAuth
 784     runMaybeT $ msum [
 785         do
 786             lock <- mgetLock $ lockSpec lockinfo
 787             lift.lift $ do
 788                 drawMiniLock lock centre
 789                 registerSelectable centre 3 $ SelLock al
 790         , lift $ do
 791                 drawActiveLock al centre
 792                 lift $ registerSelectable centre 3 $ SelLock al
 793         ]
 794
 795     size <- snd <$> lift getGeom
 796     lift $ do
 797         renderToMain $ displaceRender (SVec size 0) $ renderStrColAt (brightish white) "UNLOCKED BY" $ accessedByPos +^ hv
 798         registerSelectable (accessedByPos +^ hv) 0 SelPrivyHeader
 799         registerSelectable (accessedByPos +^ hv +^ hu) 0 SelPrivyHeader
 800     if public lockinfo
 801     then lift $ do
 802         renderToMain $ renderStrColAt pubColour "All" accessedByPos
 803         registerSelectable accessedByPos 1 SelPublicLock
 804     else if null $ accessedBy lockinfo
 805         then lift.renderToMain $ renderStrColAt dimWhiteCol "No-one" accessedByPos
 806         else fillArea accessedByPos
 807                 [ accessedByPos +^ d | j <- [0..2], i <- [-2..3]
 808                     , i-j > -4, i-j < 3
 809                     , let d = j*^hw +^ i*^hu ]
 810                 $ [ \pos -> (lift $ registerSelectable pos 0 (SelSolution note)) >> drawNote note pos
 811                     | note <- lockSolutions lockinfo ] ++
 812                 [ \pos -> (lift $ registerSelectable pos 0 (SelAccessed name)) >> drawName name pos
 813                     | name <- accessedBy lockinfo \\ map noteAuthor (lockSolutions lockinfo) ]
 814
 815     undecls <- gets undeclareds
 816     case if isJust $ guard . (|| public lockinfo) . (`elem` map noteAuthor (lockSolutions lockinfo)) =<< ourName
 817             then if public lockinfo
 818                 then Just (pubColour,"Accessed!",AccessedPublic)
 819                 else Just (accColour, "Solved!",AccessedSolved)
 820             else if any (\(Undeclared _ ls _) -> ls == lockSpec lockinfo) undecls
 821                 then Just (yellow, "Undeclared",AccessedUndeclared)
 822                 else Nothing
 823         of
 824         Just (col,str,selstr) -> lift $ do
 825             renderToMain $ renderStrColAt col str accessedPos
 826             registerSelectable accessedPos 1 (SelAccessedInfo selstr)
 827         Nothing -> do
 828             read <- take 3 <$> getNotesReadOn lockinfo
 829             unless (ourName == Just name) $ do
 830                 let readPos = accessedPos +^ (-3)*^hu
 831                 lift.renderToMain $ renderStrColAt (if length read == 3 then accColour else dimWhiteCol)
 832                     "Read:" $ readPos
 833                 when (length read == 3) $ lift $ registerSelectable readPos 0 (SelAccessedInfo AccessedReadNotes)
 834                 fillArea (accessedPos+^neg hu) [ accessedPos +^ i*^hu | i <- [-1..1] ]
 835                     $ take 3 $ [ \pos -> (lift $ registerSelectable pos 0 (SelReadNote note)) >> drawNote note pos
 836                         | note <- read ] ++ (repeat $ \pos -> (lift $ registerSelectable pos 0 SelReadNoteSlot >>
 837                                 renderToMain (drawAtRel (HollowGlyph $ dim green) pos)))
 838
 839     lift $ do
 840         renderToMain $ displaceRender (SVec size 0) $ renderStrColAt (brightish white) "SECURING" $ notesPos +^ hv
 841         registerSelectable (notesPos +^ hv) 0 SelNotesHeader
 842         registerSelectable (notesPos +^ hv +^ hu) 0 SelNotesHeader
 843     if null $ notesSecured lockinfo
 844         then lift.renderToMain $ renderStrColAt dimWhiteCol "None" notesPos
 845         else fillArea notesPos
 846                 [ notesPos +^ d | j <- [0..2], i <- [-2..3]
 847                     , i-j > -4, i-j < 3
 848                     , let d = j*^hw +^ i*^hu ]
 849                 [ \pos -> (lift $ registerSelectable pos 0 (SelSecured note)) >> drawActiveLock (noteOn note) pos
 850                     | note <- notesSecured lockinfo ]
 851