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