intricacy-0.6: CursesUIMInstance.hs
-- This file is part of Intricacy
-- Copyright (C) 2013 Martin Bays <mbays@sdf.org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of version 3 of the GNU General Public License as
-- published by the Free Software Foundation, or any later version.
--
-- You should have received a copy of the GNU General Public License
-- along with this program. If not, see http://www.gnu.org/licenses/.
{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
module CursesUIMInstance () where
import qualified UI.HSCurses.Curses as Curses
import qualified UI.HSCurses.CursesHelper as CursesH
import Control.Concurrent.STM
import Control.Concurrent
import Control.Applicative
import Data.Char (ord)
import Data.Monoid
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Array
import Data.Maybe
import Data.List
import Control.Monad.Trans.Maybe
import Control.Concurrent (threadDelay)
import Control.Monad.State
import Data.Function (on)
import Data.Foldable (for_)
import Hex
import GameStateTypes
import Physics
import Frame
import Command
import KeyBindings
import ServerAddr
import Cache
import Database
import Metagame
import Protocol
import Util
import InputMode
import MainState
import CursesUI
import CursesRender
import CVec
drawName :: Bool -> CVec -> Codename -> MainStateT UIM ()
drawName showScore pos name = do
ourName <- (authUser <$>) <$> gets curAuth
relScore <- getRelScore name
let (attr,col) = case relScore of
Just 0 -> (a0,yellow)
Just 1 -> (bold,cyan)
Just 2 -> (a0,green)
Just 3 -> (bold,green)
Just (-1) -> (bold,magenta)
Just (-2) -> (a0,red)
Just (-3) -> (bold,red)
_ -> if ourName == Just name then (bold,white) else (a0,white)
lift $ drawStrCentred attr col pos
(name ++ if showScore then " " ++ maybe "" show relScore else "")
drawActiveLock :: CVec -> ActiveLock -> MainStateT UIM ()
drawActiveLock pos al@(ActiveLock name i) = do
accessed <- accessedAL al
drawNameWithChar pos name
(if accessed then green else white)
(lockIndexChar i)
drawNameWithChar :: CVec -> Codename -> ColPair -> Char -> MainStateT UIM ()
drawNameWithChar pos name charcol char = do
drawName False (pos +^ CVec 0 (-1)) name
lift $ drawStr bold charcol (pos +^ CVec 0 1) [':',char]
drawNote :: CVec -> NoteInfo -> MainStateT UIM ()
drawNote pos note = case noteBehind note of
Just al -> drawActiveLock pos al
Nothing -> drawPublicNote pos (noteAuthor note)
where
drawPublicNote pos name =
drawNameWithChar pos name magenta 'P'
data Gravity = GravUp | GravLeft | GravRight | GravDown | GravCentre
deriving (Eq, Ord, Show, Enum)
fillBox :: CVec -> CVec -> Int -> Gravity -> [CVec -> MainStateT UIM ()] -> MainStateT UIM Int
fillBox (CVec t l) (CVec b r) width grav draws = do
let half = width`div`2
starty = (if grav == GravDown then b else t)
cv = (b+t)`div`2
ch = (l+r)`div`2
gravCentre = case grav of
GravDown -> CVec b ch
GravUp -> CVec t ch
GravLeft -> CVec cv l
GravRight -> CVec cv r
GravCentre -> CVec cv ch
locs = sortBy (compare `on` dist) $ concat
[ map (CVec j) [ l+margin + (width+1)*i | i <- [0..(r-l-(2*margin))`div`(width+1)] ]
| j <- [t..b]
, let margin = if (j-starty)`mod`2 == 0 then half else width ]
dist v = sqlen $ v -^ gravCentre
sqlen (CVec y x) = (y*(width+1))^2+x^2
selDraws <- do
offset <- gets listOffset
let na = length locs
nd = length draws
return $ drop (max 0 $ min (nd - na) (na*offset)) $ draws
let zipped = zip locs selDraws
sequence_ $ map (uncurry ($)) $ zip selDraws locs
return $ (if grav==GravDown then (minimum.(b:)) else (maximum.(t:))) [ y | (CVec y x,_) <- zipped ]
drawLockInfo al@(ActiveLock name i) lockinfo = do
(h,w) <- liftIO Curses.scrSize
let [left,vcentre,right] = [ (k+2*i)*w`div`6 + (1-k) | k <- [0,1,2] ]
let [top,bottom] = [6, h-1]
let hcentre = (top+bottom)`div`2 - 1
ourName <- (authUser <$>) <$> gets curAuth
(lockTop, lockBottom) <- (fromJust<$>)$ runMaybeT $ msum
[ do
lock <- mgetLock $ lockSpec lockinfo
let size = frameSize $ fst lock
guard $ bottom - top >= 5 + 2*size+1 + 1 + 5 && right-left >= 4*size+1
lift.lift $ drawStateWithGeom [] False Map.empty (snd lock) (CVec hcentre vcentre,origin)
return (hcentre - size - 1, hcentre + size + 1)
, lift $ do
drawActiveLock (CVec hcentre vcentre) al
return (hcentre - 1, hcentre + 1)
]
startOn <-
if (public lockinfo)
then lift $ drawStrCentred bold white (CVec (lockTop-1) vcentre) "Everyone!"
>> return (lockTop-1)
else if null $ accessedBy lockinfo
then lift $ drawStrCentred a0 white (CVec (lockTop-1) vcentre) "No-one"
>> return (lockTop-1)
else
fillBox (CVec (top+1) (left+1)) (CVec (lockTop-1) (right-1)) 5 GravDown $
[ \pos -> drawNote pos note | note <- lockSolutions lockinfo ] ++
[ \pos -> drawName False pos name
| name <- accessedBy lockinfo \\ map noteAuthor (lockSolutions lockinfo) ]
lift $ drawStrCentred a0 white (CVec (startOn-1) vcentre) "Accessed by:"
undecls <- gets undeclareds
if isJust $ guard . (|| public lockinfo) . (`elem` accessedBy lockinfo) =<< ourName
then lift $ drawStrCentred a0 green (CVec (lockBottom+1) vcentre) "Accessed!"
else if any (\(Undeclared _ ls _) -> ls == lockSpec lockinfo) undecls
then lift $ drawStrCentred a0 yellow (CVec (lockBottom+1) vcentre) "Undeclared solution!"
else do
read <- take 3 <$> getNotesReadOn lockinfo
unless (null read || ourName == Just name) $ do
let rntext = if right-left > 30 then "Read notes by:" else "Notes:"
s = vcentre - (length rntext+(3+1)*3)`div`2
lift $ drawStr a0 white (CVec (lockBottom+1) s) rntext
void $ fillBox (CVec (lockBottom+1) (s+length rntext+1)) (CVec (lockBottom+1) right) 3 GravLeft
[ \pos -> drawName False pos name | name <- map noteAuthor read ]
lift $ drawStrCentred a0 white (CVec (lockBottom+2) vcentre) "Notes held:"
if null $ notesSecured lockinfo
then lift $
drawStrCentred a0 white (CVec (lockBottom+3) vcentre) "None"
else
void $ fillBox (CVec (lockBottom+3) (left+1)) (CVec bottom (right-1)) 5 GravUp
[ (`drawActiveLock` al) | al <- map noteOn $ notesSecured lockinfo ]
charify :: Curses.Key -> Maybe Char
charify key = case key of
Curses.KeyChar ch -> Just ch
Curses.KeyBackspace -> Just '\b'
Curses.KeyLeft -> Just '4'
Curses.KeyRight -> Just '6'
Curses.KeyDown -> Just '2'
Curses.KeyUp -> Just '8'
Curses.KeyHome -> Just '7'
Curses.KeyNPage -> Just '3'
Curses.KeyPPage -> Just '9'
Curses.KeyEnd -> Just '1'
_ -> Nothing
instance UIMonad (StateT UIState IO) where
runUI m = evalStateT m nullUIState
drawMainState = do
lift erase
s <- get
lift . drawTitle =<< getTitle
lift drawMsgLine
drawMainState' s
lift refresh
where
drawMainState' (PlayState { psCurrentState=st, psLastAlerts=alerts, wrenchSelected=wsel }) = lift $ do
drawState [] False alerts st
drawCursorAt $ listToMaybe [ pos |
(_, PlacedPiece pos p) <- enumVec $ placedPieces st
, or [wsel && isWrench p, not wsel && isHook p] ]
drawMainState' (ReplayState {}) = do
lift . drawState [] False [] =<< gets rsCurrentState
lift $ drawCursorAt Nothing
drawMainState' (EditState { esGameStateStack=(st:_), selectedPiece=selPiece, selectedPos=selPos }) = lift $ do
drawState (maybeToList selPiece) True [] st
drawCursorAt $ if isNothing selPiece then Just selPos else Nothing
drawMainState' (MetaState {curServer=saddr, undeclareds=undecls,
cacheOnly=cOnly, curAuth=auth, codenameStack=names,
randomCodenames=rnamestvar, retiredLocks=mretired, curLockPath=path,
curLock=lock}) = do
let ourName = liftM authUser auth
let selName = listToMaybe names
let home = isJust ourName && ourName == selName
(h,w) <- liftIO Curses.scrSize
when (h<20 || w<40) $ liftIO CursesH.end >> error "Terminal too small!"
lift $ do
drawCursorAt Nothing
sstr <- (++" Server: ") <$> bindingsStr IMMeta [CmdSetServer, CmdToggleCacheOnly]
hstr <- (\[ks,ts] -> ts++" tut "++ks++" keys") <$>
bindingsStr IMMeta `mapM` [[CmdHelp],[CmdTutorials]]
drawStrGrey (CVec 0 0) $ sstr ++
take (w - length sstr - length hstr)
(saddrStr saddr ++ (if cOnly then " (cache only) " else "") ++ repeat ' ') ++
hstr
drawStrGrey (CVec 1 0) =<<
(\[es,ls] -> take 5 (es ++ repeat ' ') ++ " Lock: " ++ path ++ " " ++ ls) <$>
bindingsStr IMMeta `mapM`
[ [CmdEdit] ++ if path == "" then [] else [CmdPlaceLock Nothing]
, [CmdSelectLock] ++ if path == "" then [] else [CmdNextLock, CmdPrevLock]
]
lift $ drawStrGrey (CVec 2 (maximum [w`div`3+1, w`div`2 - 13])) =<< bindingsStr IMMeta [CmdSelCodename Nothing]
maybe (return ()) (drawName True (CVec 2 (w`div`2))) selName
void.runMaybeT $ MaybeT (return selName) >>= lift . getUInfoFetched 300 >>=
\(FetchedRecord fresh err muirc) -> lift $ do
lift $ do
unless fresh $ drawAtCVec (Glyph '*' red bold) $ CVec 2 (w`div`2+7)
maybe (return ()) sayError err
when (fresh && (isNothing ourName || home || isNothing muirc)) $
drawStrGrey (CVec 2 (w`div`2+1+9)) =<<
(bindingsStr IMMeta $
if (isNothing muirc && isNothing ourName) || home then [CmdRegister $ isJust ourName] else [CmdAuth])
for_ muirc $ \(RCUserInfo (_,uinfo)) -> case mretired of
Just retired -> do
(h,w) <- liftIO Curses.scrSize
void $ fillBox (CVec 6 2) (CVec (h-1) (w-2)) 5 GravCentre
[ \pos -> lift $ drawStrGrey pos $ show ls | ls <- retired ]
lift $ drawStrGrey (CVec 5 (w`div`3)) =<< bindingsStr IMMeta
([CmdShowRetired] ++ if null retired then [] else [CmdPlayLockSpec Nothing])
Nothing -> do
sequence_ [ drawLockInfo (ActiveLock (codename uinfo) i) lockinfo |
(i,Just lockinfo) <- assocs $ userLocks uinfo ]
unless (null $ elems $ userLocks uinfo) $ lift $
drawStrGrey (CVec 5 (w`div`3)) =<< bindingsStr IMMeta [CmdSolve Nothing, CmdViewSolution Nothing]
when (isJust ourName && ourName == selName) $ do
unless (null undecls) $ do
str <- lift $ (++" Undeclared solutions:") <$> bindingsStr IMMeta [CmdDeclare Nothing]
let s = max 1 $ (w-(length str + 6*length undecls))`div`2
let y = 4
lift $ drawStr bold white (CVec y s) str
void $ fillBox (CVec y (s+length str+1)) (CVec y (w-1)) 5 GravLeft
[ (`drawActiveLock` al) | Undeclared _ _ al <- undecls ]
rnames <- liftIO $ atomically $ readTVar rnamestvar
unless (null rnames) $
void $ fillBox (CVec 2 5) (CVec 5 (w`div`3)) 3 GravCentre
[ \pos -> drawName False pos name | name <- rnames ]
when (ourName /= selName) $ void $ runMaybeT $ do
sel <- liftMaybe selName
us <- liftMaybe ourName
ourUInfo <- mgetUInfo us
let accessed = [ ActiveLock us i
| i<-[0..2]
, Just lock <- [ userLocks ourUInfo ! i ]
, public lock || selName `elem` map Just (accessedBy lock) ]
guard $ not $ null accessed
let str = "has accessed:"
let s = (w-(4 + length str + 6*(length accessed)))`div`2
let y = 4
lift $ do
drawName False (CVec y (s+1)) sel
lift $ drawStrGrey (CVec y $ s+4) str
void $ fillBox (CVec y (s+4+length str+1)) (CVec y (w-1)) 5 GravLeft $
[ (`drawActiveLock` al) | al <- accessed]
reportAlerts _ alerts =
do mapM_ drawAlert alerts
unless (null alerts)
$ do refresh
liftIO $ threadDelay $ 5*10^4
where
drawAlert (AlertCollision pos) = drawAt cGlyph pos
drawAlert _ = return ()
cGlyph = Glyph '!' 0 a0
drawMessage = say
drawPrompt full s = say s >> (liftIO $ void $ Curses.cursSet Curses.CursorVisible)
endPrompt = say "" >> (liftIO $ void $ Curses.cursSet Curses.CursorInvisible)
drawError = sayError
showHelp mode HelpPageInput = do
bdgs <- nub <$> getBindings mode
erase
(h,w) <- liftIO Curses.scrSize
let bdgWidth = 35
showKeys chs = intercalate "/" (map showKey chs)
maxkeyslen = maximum $ map (length.showKeys.map fst) $ groupBy ((==) `on` snd) bdgs
drawStrCentred a0 cyan (CVec 0 (w`div`2)) "Bindings:"
sequence_ [ drawStr a0 cyan (CVec (y+2) (x*bdgWidth) ) $
keysStr ++ replicate pad ' ' ++ ": " ++ desc |
((keysStr,pad,desc),(x,y)) <- zip [(keysStr,pad,desc)
| group <- groupBy ((==) `on` snd) $ sortBy (compare `on` snd) bdgs
, let cmd = snd $ head group
, let desc = describeCommand cmd
, not $ null desc
, let chs = map fst group
, let keysStr = showKeys chs
, let pad = max 0 $ minimum [maxkeyslen + 1 - length keysStr,
bdgWidth - length desc - length keysStr - 1]
]
(map (`divMod` (h-3)) [0..])
, (x+1)*bdgWidth < w]
refresh
return True
showHelp IMMeta HelpPageGame = do
erase
(h,w) <- liftIO Curses.scrSize
if w >= maximum (map length metagameHelpText)
then sequence_ [drawStrCentred a0 magenta (CVec line $ w`div`2) str |
(line,str) <- zip [0..h-2] $ ["INTRICACY",""] ++ metagameHelpText ]
else do
let wrap max = wrap' max max
wrap' _ _ [] = []
wrap' max left (w:ws) = if 1+length w > left
then if left == max
then take max w ++ "\n" ++
wrap' max max (drop max w : ws)
else '\n' : wrap' max max (w:ws)
else let prepend = if left == max then w else ' ':w
in prepend ++ wrap' max (left - length prepend) ws
sequence_ [drawStrCentred a0 magenta (CVec line $ w`div`2) str |
(line,str) <- zip [0..h] $
lines (wrap w $ words $ intercalate " " metagameHelpText) ]
return True
showHelp _ _ = return False
getChRaw = (charify<$>) $ liftIO $ CursesH.getKey (return ())
setUIBinding mode cmd ch =
modify $ \s -> s { uiKeyBindings =
Map.insertWith (\[bdg] -> \bdgs -> if bdg `elem` bdgs then delete bdg bdgs else bdg:bdgs)
mode [(ch,cmd)] $ uiKeyBindings s }
getUIBinding mode cmd = do
bdgs <- getBindings mode
return $ maybe "" showKey $ findBinding bdgs cmd
initUI = do
liftIO CursesH.start
cpairs <- liftIO $ colorsToPairs [ (f, CursesH.black)
| f <- [ CursesH.white, CursesH.red, CursesH.green, CursesH.yellow
, CursesH.blue, CursesH.magenta, CursesH.cyan] ]
modify $ \s -> s {dispCPairs = cpairs}
readBindings
return True
endUI = do
writeBindings
liftIO CursesH.end
unblockInput = return $ Curses.ungetCh 0
suspend = do
liftIO $ do
CursesH.suspend
Curses.resetParams
redraw
redraw = liftIO $ do
Curses.endWin
Curses.refresh
warpPointer _ = return ()
getUIMousePos = return Nothing
setYNButtons = return ()
onNewMode _ = say ""
toggleColourMode = modify $ \s -> s {monochrome = not $ monochrome s}
impatience ticks = do
when (ticks>20) $ say "Waiting for server (^C to abort)..."
unblock <- unblockInput
liftIO $ forkIO $ threadDelay 50000 >> unblock
cmds <- getInput IMImpatience
return $ CmdQuit `elem` cmds
getInput mode = do
let userResizeCode = 1337 -- XXX: chosen not to conflict with HSCurses codes
key <- liftIO $ CursesH.getKey (Curses.ungetCh userResizeCode)
if key == Curses.KeyUnknown userResizeCode
then do
liftIO Curses.scrSize
return [CmdRedraw]
else do
let mch = charify key
unblockBinding = (toEnum 0, CmdRefresh) -- c.f. unblockInput above
flip (maybe $ return []) mch $ \ch ->
if mode == IMTextInput
then return $ [ CmdInputChar ch `fromMaybe` lookup ch [unblockBinding] ]
else (maybeToList . lookup ch . (unblockBinding:)) <$> getBindings mode