intricacy-0.3: 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.
--
-- 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 #-}
module CursesUIMInstance () where
import qualified UI.HSCurses.Curses as Curses
import qualified UI.HSCurses.CursesHelper as CursesH
import Control.Concurrent.STM
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 -> StateT MainState 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 -> StateT MainState UIM ()
drawActiveLock pos (ActiveLock name i) = do
drawName False (pos <+> CVec 0 (-1)) name
lift $ drawStr bold white (pos <+> CVec 0 1) [':',lockIndexChar i]
data Gravity = GravUp | GravLeft | GravRight | GravDown | GravCentre
deriving (Eq, Ord, Show, Enum)
fillBox :: CVec -> CVec -> Int -> Gravity -> [CVec -> StateT MainState UIM ()] -> StateT MainState 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)) 3 GravDown $
[ \pos -> drawName False pos name | name <- accessedBy 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 saddr undecls cOnly auth names _ _ rnamestvar _ _ mretired path lock _) = do
let ourName = liftM authUser auth
let selName = listToMaybe names
(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) $
drawStrGrey (CVec 2 (w`div`2+1+9)) =<<
(bindingsStr IMMeta $ if isNothing muirc then [CmdRegister] 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 <- MaybeT $ return selName
us <- MaybeT $ return 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]
drawAlerts 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
drawError = sayError
showHelp mode = 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 white (CVec 0 (w`div`2)) "Bindings:"
sequence_ [ drawStr a0 white (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
void $ getInput mode
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 bdgs ++ [bdg])
mode [(ch,cmd)] $ uiKeyBindings s }
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 ()
getDrawImpatience = return $ \_ -> return ()
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]
else (maybeToList . lookup ch . (unblockBinding:)) <$> getBindings mode