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