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