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