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