CursesUIMInstance.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 FlexibleContexts  #-}
  12 {-# LANGUAGE FlexibleInstances #-}
  13 {-# LANGUAGE LambdaCase        #-}
  14 module CursesUIMInstance () where
  15
  16 import           Control.Applicative
  17 import           Control.Concurrent
  18 import           Control.Concurrent.STM
  19 import           Control.Monad.State
  20 import           Control.Monad.Trans.Maybe
  21 import           Data.Array
  22 import           Data.Char                 (chr, ord)
  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           Data.Monoid
  30 import           Safe                      (maximumBound)
  31 import qualified UI.HSCurses.Curses        as Curses
  32 import qualified UI.HSCurses.CursesHelper  as CursesH
  33
  34 import           CVec
  35 import           Cache
  36 import           Command
  37 import           CursesRender
  38 import           CursesUI
  39 import           Database
  40 import           Frame
  41 import           GameStateTypes
  42 import           Hex
  43 import           InputMode
  44 import           KeyBindings
  45 import           MainState
  46 import           Metagame
  47 import           Physics
  48 import           Protocol
  49 import           ServerAddr
  50 import           Util
  51
  52
  53 drawName :: Bool -> CVec -> Codename -> MainStateT UIM ()
  54 drawName showScore pos name = do
  55     ourName <- gets ((authUser <$>) . curAuth)
  56     relScore <- getRelScore name
  57     let (attr,col) = case relScore of
  58             Just 0 -> (a0,yellow)
  59             Just 1 -> (bold,cyan)
  60             Just 2 -> (a0,green)
  61             Just 3 -> (bold,green)
  62             Just (-1) -> (bold,magenta)
  63             Just (-2) -> (a0,red)
  64             Just (-3) -> (bold,red)
  65             _ -> if ourName == Just name then (bold,white) else (a0,white)
  66     lift $ drawStrCentred attr col pos
  67         (name ++ if showScore then " " ++ maybe "" show relScore else "")
  68
  69 drawActiveLock :: CVec -> ActiveLock -> MainStateT UIM ()
  70 drawActiveLock pos al@(ActiveLock name i) = do
  71     accessed <- accessedAL al
  72     drawNameWithChar pos name
  73         (if accessed then green else white)
  74         (lockIndexChar i)
  75
  76 drawNameWithChar :: CVec -> Codename -> ColPair -> Char -> MainStateT UIM ()
  77 drawNameWithChar pos name charcol char = do
  78     drawName False (pos +^ CVec 0 (-1)) name
  79     lift $ drawStr bold charcol (pos +^ CVec 0 1) [':',char]
  80
  81 drawNote :: CVec -> NoteInfo -> MainStateT UIM ()
  82 drawNote pos note = case noteBehind note of
  83     Just al -> drawActiveLock pos al
  84     Nothing -> drawPublicNote pos (noteAuthor note)
  85     where
  86         drawPublicNote pos name =
  87             drawNameWithChar pos name magenta 'P'
  88
  89
  90 fillBox :: CVec -> CVec -> Int -> Gravity -> [CVec -> MainStateT UIM ()] -> MainStateT UIM Int
  91 fillBox (CVec t l) (CVec b r) width grav draws = do
  92     offset <- gets listOffset
  93     let half = width`div`2
  94         starty = (if grav == GravDown then b else t)
  95         cv = (b+t)`div`2
  96         ch = (l+r)`div`2
  97         gravCentre = case grav of
  98             GravDown   -> CVec b ch
  99             GravUp     -> CVec t ch
 100             GravLeft   -> CVec cv l
 101             GravRight  -> CVec cv r
 102             GravCentre -> CVec cv ch
 103         locs = sortBy (compare `on` dist) $ concat
 104             [ [CVec j (l + margin + (width + 1) * i)
 105                 | i <- [0 .. (r - l - (2 * margin)) `div` (width + 1)]]
 106             | j <- [t..b]
 107             , let margin = if even (j-starty) then half else width ]
 108         dist v = sqlen $ v -^ gravCentre
 109         sqlen (CVec y x) = (y*(width+1))^2+x^2
 110         na = length locs
 111         nd = length draws
 112         drawChar c = \cvec -> lift . drawStr bold white cvec $ ' ':c:" "
 113         draws' = if offset > 0 && length draws > na
 114             then drop (max 0 $ na-1 + (na-2)*(offset-1)) draws
 115                 ++ [drawChar '<']
 116             else draws
 117         (selDraws,allDrawn) = if length draws' > na
 118             then (take (na-1) draws' ++ [drawChar '>'], False)
 119             else (take na draws', True)
 120         zipped = zip locs selDraws
 121     unless allDrawn . modify $ \ms -> ms { listOffsetMax = False }
 122     mapM_ (uncurry ($)) (zip selDraws locs)
 123     return $ (if grav==GravDown then minimum.(b:) else maximum.(t:)) [ y | (CVec y x,_) <- zipped ]
 124
 125 drawLockInfo al@(ActiveLock name i) lockinfo = do
 126     (h,w) <- liftIO Curses.scrSize
 127     let [left,vcentre,right] = [ (k+2*i)*w`div`6 + (1-k) | k <- [0,1,2] ]
 128     let [top,bottom] = [6, h-2]
 129     let hcentre = (top+bottom)`div`2 - 1
 130     ourName <- gets ((authUser <$>) . curAuth)
 131
 132     (lockTop, lockBottom) <- (fromJust<$>)$ runMaybeT $ msum
 133         [ do
 134             lock <- mgetLock $ lockSpec lockinfo
 135             let size = frameSize $ fst lock
 136             guard $ bottom - top >= 5 + 2*size+1 + 1 + 5 && right-left >= 4*size+1
 137             lift.lift $ drawStateWithGeom [] False Map.empty (snd lock) (CVec hcentre vcentre,origin)
 138             return (hcentre - size - 1, hcentre + size + 1)
 139         , lift $ do
 140             drawActiveLock (CVec hcentre vcentre) al
 141             return (hcentre - 1, hcentre + 1)
 142         ]
 143
 144     startOn <-
 145         if public lockinfo
 146         then lift $ drawStrCentred bold magenta (CVec (lockTop-1) vcentre) "Public"
 147             >> return (lockTop-1)
 148         else if null $ accessedBy lockinfo
 149             then lift $ drawStrCentred a0 white (CVec (lockTop-1) vcentre) "None"
 150                 >> return (lockTop-1)
 151             else
 152                 fillBox (CVec (top+1) (left+1)) (CVec (lockTop-1) (right-1)) 5 GravDown $
 153         [ (`drawNote` note) | note <- lockSolutions lockinfo ]
 154     lift $ drawStrCentred a0 white (CVec (startOn-1) vcentre) "Solutions:"
 155
 156     undecls <- gets undeclareds
 157     if isJust $ guard . (|| public lockinfo) . (`elem` accessedBy lockinfo) =<< ourName
 158     then lift $ drawStrCentred a0 green (CVec (lockBottom+1) vcentre) "Accessed!"
 159     else if any (\(Undeclared _ ls _) -> ls == lockSpec lockinfo) undecls
 160     then lift $ drawStrCentred a0 yellow (CVec (lockBottom+1) vcentre) "Undeclared solution!"
 161     else do
 162         read <- take 3 <$> getNotesReadOn lockinfo
 163         unless (null read || ourName == Just name) $ do
 164             let rntext = if right-left > 30 then "Read notes by:" else "Notes:"
 165                 s = vcentre - (length rntext+(3+1)*3)`div`2
 166             lift $ drawStr a0 white (CVec (lockBottom+1) s) rntext
 167             void $ fillBox (CVec (lockBottom+1) (s+length rntext+1)) (CVec (lockBottom+1) right) 3 GravLeft
 168                 [ \pos -> drawName False pos name | name <- noteAuthor <$> read ]
 169
 170     lift $ drawStrCentred a0 white (CVec (lockBottom+2) vcentre) "Notes held:"
 171     if null $ notesSecured lockinfo
 172         then lift $
 173             drawStrCentred a0 white (CVec (lockBottom+3) vcentre) "None"
 174         else
 175             void $ fillBox (CVec (lockBottom+3) (left+1)) (CVec bottom (right-1)) 5 GravUp
 176                 [ (`drawActiveLock` al) | al <- noteOn <$> notesSecured lockinfo ]
 177
 178
 179 data HelpReturn = HelpNone | HelpDone | HelpContinue Int
 180
 181 showHelpPaged :: Int -> InputMode -> HelpPage -> UIM Bool
 182 showHelpPaged from mode page =
 183     showHelpPaged' from mode page >>= \case
 184         HelpNone -> return False
 185         HelpDone -> return True
 186         HelpContinue from' -> do
 187             drawPrompt False "[MORE]"
 188             getInput IMTextInput
 189             showHelpPaged from' mode page
 190 showHelpPaged' :: Int -> InputMode -> HelpPage -> UIM HelpReturn
 191 showHelpPaged' from mode HelpPageInput = do
 192     bdgs <- nub <$> getBindings mode
 193     erase
 194     (h,w) <- liftIO Curses.scrSize
 195     let bdgWidth = 39
 196         showKeys chs = intercalate "/" (showKey <$> chs)
 197         maxkeyslen = maximum $ length . showKeys . map fst <$> groupBy ((==) `on` snd) bdgs
 198     drawStrCentred a0 cyan (CVec 0 (w`div`2)) "Bindings:"
 199     let groups = filter (not . null . describeCommand . snd . head) $
 200             drop from $ groupBy ((==) `on` snd) $ sortBy (compare `on` snd) bdgs
 201     let draws =
 202             [ drawStr a0 cyan (CVec (y+2) (x*bdgWidth) ) $
 203                 keysStr ++ replicate pad ' ' ++ ": " ++ desc
 204             | ((keysStr,pad,desc),(x,y)) <- zip
 205                 [ (keysStr,pad,desc)
 206                 | group <- groups
 207                 , let cmd = snd $ head group
 208                 , let desc = describeCommand cmd
 209                 , let chs = fst <$> group
 210                 , let keysStr = showKeys chs
 211                 , let pad = max 0 $ minimum [maxkeyslen + 1 - length keysStr,
 212                         bdgWidth - length desc - length keysStr - 1 - 1]
 213                 ] $ (`divMod` (h-3)) <$> [0..]
 214             , (x+1)*bdgWidth < w]
 215     sequence_ draws
 216     refresh
 217     return $ if length draws < length groups
 218         then HelpContinue $ from + length draws
 219         else HelpDone
 220 showHelpPaged' from IMInit HelpPageGame =
 221     drawBasicHelpPage from ("INTRICACY",magenta) (initiationHelpText,magenta)
 222 showHelpPaged' from IMMeta HelpPageGame =
 223     drawBasicHelpPage from ("INTRICACY",magenta) (metagameHelpText,magenta)
 224 showHelpPaged' from IMMeta (HelpPageInitiated n) =
 225     drawBasicHelpPage from ("Initiation complete",magenta) (initiationCompleteText n,magenta)
 226 showHelpPaged' from IMEdit HelpPageFirstEdit =
 227     drawBasicHelpPage from ("Your first lock:",magenta) (firstEditHelpText,green)
 228 showHelpPaged' _ _ _ = return HelpNone
 229
 230 drawBasicHelpPage :: Int -> (String,ColPair) -> ([String],ColPair) -> UIM HelpReturn
 231 drawBasicHelpPage from (title,titleCol) (body,bodyCol) = do
 232     erase
 233     (h,w) <- liftIO Curses.scrSize
 234     let strs = drop from $
 235             if w >= maximum (length <$> metagameHelpText)
 236             then body
 237             else
 238                 let wrap max = wrap' max max
 239                     wrap' _ _ [] = []
 240                     wrap' max left (w:ws) = if 1+length w > left
 241                         then if left == max
 242                             then take max w ++ "\n" ++
 243                                 wrap' max max (drop max w : ws)
 244                             else '\n' : wrap' max max (w:ws)
 245                         else let prepend = if left == max then w else ' ':w
 246                             in prepend ++ wrap' max (left - length prepend) ws
 247                 in lines . wrap w . words $ unwords body
 248         top = max 0 $ (h - length strs) `div` 2
 249     drawStrCentred a0 titleCol (CVec top $ w`div`2) title
 250     let draws = [drawStrCentred a0 bodyCol (CVec y $ w`div`2) str |
 251                 (y,str) <- zip [top+2..h-2] strs ]
 252     sequence_ draws
 253     return $ if length draws < length strs
 254         then HelpContinue $ from + length draws
 255         else HelpDone
 256
 257
 258 charify :: Curses.Key -> Maybe Char
 259 charify key = case key of
 260     Curses.KeyChar ch   -> Just ch
 261     Curses.KeyBackspace -> Just '\b'
 262     Curses.KeyLeft      -> Just '4'
 263     Curses.KeyRight     -> Just '6'
 264     Curses.KeyDown      -> Just '2'
 265     Curses.KeyUp        -> Just '8'
 266     Curses.KeyHome      -> Just '7'
 267     Curses.KeyNPage     -> Just '3'
 268     Curses.KeyPPage     -> Just '9'
 269     Curses.KeyEnd       -> Just '1'
 270     _                   -> Nothing
 271
 272 handleEsc k@(Curses.KeyChar '\ESC') = do
 273     Curses.timeout 100
 274     cch <- Curses.getch
 275     Curses.timeout (-1)
 276     return $ if cch == -1 then k
 277         else Curses.KeyChar $ chr $ fi cch+128
 278 handleEsc k = return k
 279
 280 instance UIMonad (StateT UIState IO) where
 281     runUI m = evalStateT m nullUIState
 282
 283     drawMainState = do
 284         lift erase
 285         s <- get
 286         lift . drawTitle =<< getTitle
 287         lift drawMsgLine
 288         drawMainState' s
 289         lift refresh
 290         where
 291         drawMainState' PlayState { psCurrentState=st, psLastAlerts=alerts,
 292                 wrenchSelected=wsel, psFrame=frame, psTutLevel=tutLevel } = lift $ do
 293             drawState [] False alerts st
 294             drawBindingsTables IMPlay filterBindings frame
 295             drawCursorAt $ listToMaybe [ pos |
 296                 (_, PlacedPiece pos p) <- enumVec $ placedPieces st
 297                 , (wsel && isWrench p) || (not wsel && isHook p) ]
 298             where
 299             filterBindings (CmdRotate _ _) = not $ wrenchOnlyTutLevel tutLevel
 300             filterBindings CmdUndo         = not $ noUndoTutLevel tutLevel
 301             filterBindings CmdRedo         = not $ noUndoTutLevel tutLevel
 302             filterBindings CmdMark         = not $ noUndoTutLevel tutLevel
 303             filterBindings CmdJumpMark     = not $ noUndoTutLevel tutLevel
 304             filterBindings CmdReset        = not $ noUndoTutLevel tutLevel
 305             filterBindings _               = True
 306         drawMainState' ReplayState {} = do
 307             lift . drawState [] False [] =<< gets rsCurrentState
 308             lift $ drawCursorAt Nothing
 309         drawMainState' EditState { esGameState=st, selectedPiece=selPiece,
 310                 selectedPos=selPos, esFrame=frame } = lift $ do
 311             drawState (maybeToList selPiece) True [] st
 312             drawBindingsTables IMEdit (const True) frame
 313             drawCursorAt $ if isNothing selPiece then Just selPos else Nothing
 314         drawMainState' InitState {initLocks=initLocks, tutProgress=TutProgress{tutSolved=tutSolved}} = lift $ do
 315             drawCursorAt Nothing
 316             (h,w) <- liftIO Curses.scrSize
 317             when (h<15 || w<30) $ liftIO CursesH.end >> error "Terminal too small!"
 318             let centre = CVec (h`div`2) (w`div`2)
 319             drawStrCentred bold white (centre +^ CVec (-5) 0) "I N T R I C A C Y"
 320             bdgs <- getBindings IMInit
 321             doDrawAt (centre +^ CVec 5 0) . alignDraw GravCentre 0 $ bindingsDraw bdgs [CmdSolveInit Nothing] <> greyDraw " solve lock"
 322             doDrawAt (centre +^ CVec 6 0) . alignDraw GravCentre 0 $ bindingsDraw bdgs [CmdHelp] <> greyDraw " help"
 323             doDrawAt (centre +^ CVec 7 0) . alignDraw GravCentre 0 $ bindingsDraw bdgs [CmdQuit] <> greyDraw " quit"
 324             let cvec v = clampHoriz $ centre +^ CVec y (3*x-1) where
 325                     CVec y x = hexVec2CVec v
 326                     clampHoriz (CVec y x) = CVec y . max 0 $ min (w-4) x
 327                 drawInitLock v = do
 328                     let pos = tutPos +^ 2 *^ v
 329                     drawStr bold (if solved v then green else red) (cvec pos) (name v)
 330                     sequence_
 331                         [ drawStr a0 green (cvec $ pos +^ h) str
 332                         | (h,str) <- [(hu,"---"), (neg hv," \\ "), (neg hw," / ")]
 333                         , let v' = v +^ h
 334                         , abs (hy v') < 2 && hx v' >= 0 && hz v' <= 0
 335                         , v' `Map.member` accessible || (isLast v && h == hu)
 336                         , solved v || solved v' ]
 337             drawInitLock zero
 338             mapM_ drawInitLock $ Map.keys accessible
 339             where
 340             accessible = accessibleInitLocks tutSolved initLocks
 341             tutPos = maximumBound 0 (hx <$> Map.keys accessible) *^ neg hu
 342             name v | v == zero = "TUT"
 343                 | otherwise = maybe "???" initLockName $ Map.lookup v accessible
 344             solved v | v == zero = tutSolved
 345                 | otherwise = Just True == (initLockSolved <$> Map.lookup v accessible)
 346             isLast v | v == zero = False
 347                 | otherwise = Just True == (isLastInitLock <$> Map.lookup v accessible)
 348         drawMainState' MetaState {curServer=saddr, undeclareds=undecls,
 349                 cacheOnly=cOnly, curAuth=auth, codenameStack=names,
 350                 randomCodenames=rnamestvar, retiredLocks=mretired, curLockPath=path,
 351                 curLock=lock} = do
 352             modify $ \ms -> ms { listOffsetMax = True }
 353             let ourName = authUser <$> auth
 354             let selName = listToMaybe names
 355             let home = isJust ourName && ourName == selName
 356             (h,w) <- liftIO Curses.scrSize
 357             when (h<20 || w<40) $ liftIO CursesH.end >> error "Terminal too small!"
 358             bdgs <- lift $ getBindings IMMeta
 359             lift $ do
 360                 drawCursorAt Nothing
 361                 let serverBdgsDraw = bindingsDraw bdgs
 362                         [CmdSetServer, CmdToggleCacheOnly]
 363                     lockBdgsDraw = bindingsDraw bdgs $
 364                         CmdEdit : [CmdPlaceLock Nothing | path /= ""]
 365                     leftBdgsWidth = (+3) . maximum $ drawWidth <$> [serverBdgsDraw, lockBdgsDraw]
 366                     helpDraw = bindingsDraw bdgs [CmdInitiation] <> greyDraw " initiation  " <>
 367                         bindingsDraw bdgs [CmdHelp] <> greyDraw " help"
 368                     serverTextDraw = greyDraw . take (w - leftBdgsWidth - drawWidth helpDraw - 1) $
 369                         " Server: " ++ saddrStr saddr ++ (if cOnly then "  (offline mode) " else "")
 370                     lockBdgsDraw' = bindingsDraw bdgs $
 371                         CmdSelectLock : if path == "" then [] else [CmdNextLock, CmdPrevLock]
 372                     lockTextDraw = greyDraw . take (w - leftBdgsWidth - drawWidth lockBdgsDraw' - 1) $
 373                         " Lock: " ++ path ++ replicate 5 ' '
 374                 doDrawAt (CVec 0 0) $ alignDraw GravLeft leftBdgsWidth serverBdgsDraw <> serverTextDraw
 375                 doDrawAt (CVec 0 0) $ alignDraw GravRight w helpDraw
 376                 doDrawAt (CVec 1 0) $ alignDraw GravLeft leftBdgsWidth lockBdgsDraw <> lockTextDraw <> lockBdgsDraw'
 377
 378                 doDrawAt (CVec 2 $ maximum [w`div`3+1, w`div`2 - 13]) $ bindingsDraw bdgs [CmdSelCodename Nothing]
 379
 380             maybe (return ()) (drawName True (CVec 2 (w`div`2))) selName
 381             void.runMaybeT $ MaybeT (return selName) >>= lift . getUInfoFetched 300 >>=
 382                 \(FetchedRecord fresh err muirc) -> lift $ do
 383                     lift $ do
 384                         unless fresh $ drawAtCVec (Glyph '*' red bold) $ CVec 2 (w`div`2+7)
 385                         maybe (return ()) sayError err
 386                         when (fresh && (isNothing ourName || home || isNothing muirc)) $
 387                             doDrawAt (CVec 2 (w`div`2+1+9)) $
 388                                 bindingsDraw bdgs $
 389                                     if (isNothing muirc && isNothing ourName) || home
 390                                     then [CmdRegister $ isJust ourName] else [CmdAuth]
 391                     for_ muirc $ \(RCUserInfo (_,uinfo)) -> case mretired of
 392                         Just retired -> do
 393                             (h,w) <- liftIO Curses.scrSize
 394                             void $ fillBox (CVec 6 2) (CVec (h-1) (w-2)) 5 GravCentre
 395                                 [ \pos -> lift $ drawStrGrey pos $ show ls | ls <- retired ]
 396                             lift $ doDrawAt (CVec 5 (w`div`3)) $ bindingsDraw bdgs $
 397                                 CmdShowRetired : [CmdPlayLockSpec Nothing | not (null retired)]
 398                         Nothing -> do
 399                             sequence_ [ drawLockInfo (ActiveLock (codename uinfo) i) lockinfo |
 400                                 (i,Just lockinfo) <- assocs $ userLocks uinfo ]
 401                             unless (null $ elems $ userLocks uinfo) $ lift $
 402                                 doDrawAt (CVec 5 (w`div`3)) $ bindingsDraw bdgs $
 403                                 CmdSolve Nothing : [CmdViewSolution Nothing | isJust ourName]
 404             when (isJust ourName && ourName == selName) $ do
 405                 rnames <- liftIO $ readTVarIO rnamestvar
 406                 unless (null rnames) $
 407                     void $ fillBox (CVec 2 0) (CVec 5 (w`div`3)) 3 GravCentre
 408                         [ \pos -> drawName False pos name | name <- rnames ]
 409                 unless (null undecls) $
 410                     let declareBdgDraw = bindingsDraw bdgs [CmdDeclare Nothing]
 411                         declareText = " Undeclared solutions:"
 412                         y = 4
 413                         leftBound = w`div`3 + 1
 414                         undeclsWidth = 1 + 6 * length undecls
 415                         declareDraw =
 416                             if leftBound + drawWidth declareBdgDraw + length declareText + undeclsWidth >= w
 417                             then declareBdgDraw
 418                             else declareBdgDraw <> stringDraw bold white declareText
 419                         width = drawWidth declareDraw + undeclsWidth
 420                         left = max leftBound ((w - width) `div` 2)
 421                     in do
 422                         lift $ doDrawAt (CVec y left) declareDraw
 423                         void $ fillBox
 424                             (CVec y $ left + drawWidth declareDraw + 1)
 425                             (CVec y (w-1)) 5 GravLeft
 426                             [ (`drawActiveLock` al) | Undeclared _ _ al <- undecls ]
 427
 428             when (ourName /= selName) $ void $ runMaybeT $ do
 429                 sel <- liftMaybe selName
 430                 us <- liftMaybe ourName
 431                 ourUInfo <- mgetUInfo us
 432                 let accessed = [ ActiveLock us i
 433                         | i<-[0..2]
 434                         , Just lock <- [ userLocks ourUInfo ! i ]
 435                         , public lock || selName `elem` (Just <$> accessedBy lock) ]
 436                 guard $ not $ null accessed
 437                 let str = "has accessed:"
 438                 let s = (w-(4 + length str + 6*length accessed))`div`2
 439                 let y = 4
 440                 lift $ do
 441                     drawName False (CVec y (s+1)) sel
 442                     lift $ drawStrGrey (CVec y $ s+4) str
 443                     void $ fillBox (CVec y (s+4+length str+1)) (CVec y (w-1)) 5 GravLeft $
 444                         [ (`drawActiveLock` al) | al <- accessed]
 445
 446     reportAlerts _ alerts =
 447         do mapM_ drawAlert alerts
 448            unless (null alerts)
 449             $ do refresh
 450                  liftIO $ threadDelay $ 5*10^4
 451         where
 452             drawAlert (AlertCollision pos) = drawAt cGlyph pos
 453             drawAlert _                    = return ()
 454             cGlyph = Glyph '!' 0 a0
 455
 456     clearMessage = say ""
 457     drawMessage = say
 458     drawPrompt full s = liftIO (void $ Curses.cursSet Curses.CursorVisible) >> say s
 459     endPrompt = say "" >> liftIO (void $ Curses.cursSet Curses.CursorInvisible)
 460     drawError = sayError
 461
 462     showHelp = showHelpPaged 0
 463
 464     getChRaw = (charify<$>) $ liftIO $ CursesH.getKey (return ()) >>= handleEsc
 465     setUIBinding mode cmd ch =
 466         modify $ \s -> s { uiKeyBindings =
 467                 Map.insertWith (\ [bdg] bdgs -> if bdg `elem` bdgs then delete bdg bdgs else bdg:bdgs)
 468                     mode [(ch,cmd)] $ uiKeyBindings s }
 469     getUIBinding mode cmd = do
 470         bdgs <- getBindings mode
 471         return $ maybe "" showKey $ findBinding bdgs cmd
 472
 473     initUI = do
 474         liftIO CursesH.start
 475         cpairs <- liftIO $ colorsToPairs [ (f, CursesH.black)
 476             | f <- [ CursesH.white, CursesH.red, CursesH.green, CursesH.yellow
 477                 , CursesH.blue, CursesH.magenta, CursesH.cyan] ]
 478         modify $ \s -> s {dispCPairs = cpairs}
 479         readBindings
 480         return True
 481
 482     endUI = do
 483         writeBindings
 484         liftIO CursesH.end
 485     unblockInput = return $ Curses.ungetCh 0
 486     suspend = do
 487         liftIO $ do
 488             CursesH.suspend
 489             Curses.resetParams
 490         redraw
 491     redraw = liftIO $ do
 492         Curses.endWin
 493         Curses.refresh
 494
 495     warpPointer _ = return ()
 496     getUIMousePos = return Nothing
 497     setYNButtons = return ()
 498     onNewMode _ = say ""
 499     withNoBG = id
 500
 501     toggleColourMode = modify $ \s -> s {monochrome = not $ monochrome s}
 502
 503     impatience ticks = do
 504         when (ticks>20) $ say "Waiting for server (^C to abort)..."
 505         unblock <- unblockInput
 506         liftIO $ forkIO $ threadDelay 50000 >> unblock
 507         cmds <- getInput IMImpatience
 508         return $ CmdQuit `elem` cmds
 509
 510     getInput mode = do
 511         let userResizeCode = 1337  -- XXX: chosen not to conflict with HSCurses codes
 512         key <- liftIO $ CursesH.getKey (Curses.ungetCh userResizeCode) >>=
 513             handleEsc
 514         if key == Curses.KeyUnknown userResizeCode
 515             then do
 516                 liftIO Curses.scrSize
 517                 return [CmdRedraw]
 518             else do
 519                 let mch = charify key
 520                     unblockBinding = (toEnum 0, CmdRefresh) -- c.f. unblockInput above
 521                 flip (maybe $ return []) mch $ \ch ->
 522                     if mode == IMTextInput
 523                     then return [ CmdInputChar ch `fromMaybe` lookup ch [unblockBinding] ]
 524                     else maybeToList . lookup ch . (unblockBinding:) <$> getBindings mode