intricacy-0.8.1: CursesUI.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/.
module CursesUI where
import Control.Applicative
import Control.Concurrent.STM
import Control.Monad.State
import Control.Monad.Trans.Maybe
import Data.Array
import Data.Bifunctor (second)
import Data.Function (on)
import Data.List
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe
import Data.Monoid
import Data.Semigroup as Sem
import qualified UI.HSCurses.Curses as Curses
import BoardColouring
import CVec
import Command
import CursesRender
import Frame
import GameState (stateBoard)
import GameStateTypes
import Hex
import InputMode
import KeyBindings
import Mundanities
import ServerAddr
data UIState = UIState
{ dispCPairs :: [Curses.Pair]
, dispCentre :: HexPos
, dispLastCol :: PieceColouring
, uiKeyBindings :: Map InputMode KeyBindings
, monochrome :: Bool
, message :: Maybe (Curses.Attr, ColPair, String)}
type UIM = StateT UIState IO
nullUIState = UIState [] (PHS zero) Map.empty Map.empty False Nothing
readBindings :: UIM ()
readBindings = void.runMaybeT $ do
path <- liftIO $ confFilePath "bindings"
bdgs <- MaybeT $ liftIO $ readReadFile path
lift $ modify $ \s -> s {uiKeyBindings = bdgs}
writeBindings :: UIM ()
writeBindings = do
path <- liftIO $ confFilePath "bindings"
bdgs <- gets uiKeyBindings
liftIO makeConfDir
liftIO $ writeFile path $ show bdgs
getBindings :: InputMode -> UIM KeyBindings
getBindings mode = do
uibdgs <- gets (Map.findWithDefault [] mode . uiKeyBindings)
return $ uibdgs ++ bindings mode
bindingsStr :: InputMode -> [Command] -> UIM String
bindingsStr mode cmds = do
bdgs <- getBindings mode
return $ (("["++).(++"]")) $ intercalate "," $
maybe "" showKey . findBinding bdgs <$> cmds
data Gravity = GravUp | GravLeft | GravRight | GravDown | GravCentre
deriving (Eq, Ord, Show, Enum)
data Draw = Draw { drawWidth :: Int, doDraw :: CVec -> UIM () }
doDrawAt :: CVec -> Draw -> UIM ()
doDrawAt = flip doDraw
alignDraw :: Gravity -> Int -> Draw -> Draw
alignDraw gravity w (Draw w' d) = Draw (max w w') $ \(CVec y x) ->
d $ CVec y $ x + shift
where
shift = case gravity of
GravLeft -> 0
GravRight -> max 0 $ w - w'
GravCentre -> w - w' `div` 2
instance Sem.Semigroup Draw where
(Draw w d) <> (Draw w' d') =
Draw (w+w') $ \cpos@(CVec y x) -> d cpos >> d' (CVec y (x+w))
instance Monoid Draw where
mempty = Draw 0 (const $ return ())
mappend = (Sem.<>)
stringDraw :: Curses.Attr -> ColPair -> String -> Draw
stringDraw attr col str =
Draw (length str) $ \cpos -> drawStr attr col cpos str
greyDraw :: String -> Draw
greyDraw = stringDraw a0 white
bindingsDraw :: KeyBindings -> [Command] -> Draw
bindingsDraw = bindingsDrawColour white
bindingsDrawColour :: ColPair -> KeyBindings -> [Command] -> Draw
bindingsDrawColour col bdgs cmds =
mconcat . (stringDraw a0 col "[" :) . (++ [stringDraw a0 col "]"]) .
intersperse (stringDraw a0 col ",") $
catMaybes $ (keyDraw <$>) . findBinding bdgs <$> cmds
where
keyDraw = stringDraw bold col . showKeyFriendlyShort
bindingDrawChar :: KeyBindings -> Curses.Attr -> Command -> Draw
bindingDrawChar bdgs a cmd = mconcat . maybeToList $
stringDraw a white . (:[]) . showKeyChar <$> findBinding bdgs cmd
drawDirBindings :: InputMode -> KeyBindings -> WrHoSel -> Draw
drawDirBindings mode bdgs whs = Draw 5 $ \cpos -> do
let c | mode == IMEdit = '_'
| otherwise = case whs of
WHSHook -> '@'
WHSWrench -> '*'
WHSSelected -> '_'
gl = Glyph c white a0
drawAtCVec gl cpos
sequence_ [ doDrawAt (cpos +^ hexVec2CVec dir) .
bindingDrawChar bdgs bold $ CmdDir whs dir
| dir <- hexDirs ]
data BindingsEntry = BindingsEntry String [Command]
drawBindingsTables :: InputMode -> (Command -> Bool) -> Frame -> UIM ()
drawBindingsTables mode censor frame | mode `elem` [ IMEdit, IMPlay ] = do
bdgs <- getBindings mode
(h,w) <- liftIO Curses.scrSize
let startRight = frameWidth frame + 3
let maxWidth = (w `div` 2) - startRight - 1
let entryDraws (BindingsEntry desc cmds) =
(greyDraw desc, bindingsDraw bdgs cmds)
forM_ [GravLeft, GravRight] $ \grav -> do
let table = filter (\(_,BindingsEntry _ cs) -> not $ null cs) $
second (\(BindingsEntry s cs) -> BindingsEntry s $ filter censor cs) <$>
bindingsTable mode grav
drawsTable = second entryDraws <$> table
maxDesc = maximum $ drawWidth . fst . snd <$> drawsTable
maxBdgs = maximum $ drawWidth . snd . snd <$> drawsTable
descX = (w `div` 2) + if grav == GravRight
then startRight + maxBdgs + 2
else -(startRight + maxBdgs + 2 + maxDesc)
bdgsX = (w `div` 2) + if grav == GravRight
then startRight
else -(startRight + maxBdgs)
oppGrav = if grav == GravRight then GravLeft else GravRight
useDescs = maxDesc + 1 + maxBdgs <= maxWidth
sequence_
[ do
when (maxBdgs <= maxWidth) $
doDrawAt (CVec y bdgsX) $ alignDraw
(if useDescs then grav else oppGrav) maxBdgs
bdgsDraw
when useDescs $
doDrawAt (CVec y descX) $ alignDraw oppGrav maxDesc descDraw
| (yoff, (descDraw, bdgsDraw)) <- drawsTable
, let y = (h `div` 2) + yoff
]
when (mode `elem` [IMPlay,IMEdit] && grav == GravLeft && maxWidth >= 5) $
let (halfw,poss)
| maxWidth < 15 = (3,[CVec (-5) 0])
| maxWidth < 19 = (7,[CVec (-4) 0, CVec (-6) 5, CVec (-6) (-5)])
| otherwise = (9,[CVec (-5) 0, CVec (-5) 7, CVec (-5) (-7)])
in sequence_ [ doDrawAt pos $ drawDirBindings mode bdgs whs
| (whs,pos) <- zip [WHSSelected, WHSWrench, WHSHook] $
(CVec (h `div` 2) ((w `div` 2) - startRight -
min (maxWidth - halfw) (max (maxBdgs+1) halfw)) +^) <$> poss ]
when (mode == IMEdit && grav == GravRight && maxWidth >= 9) $
let c = CVec ((h`div`2) - 4) ((w`div`2) + startRight +
min (maxWidth - 5) (max (maxBdgs+1) 5))
in sequence_ [ do
drawAtCVec gl (c +^ CVec 0 x)
doDrawAt (c +^ CVec 1 x) . bindingDrawChar bdgs bold $ CmdTile tile
| (x,tile) <- zip [-4,-2,0,2,4]
[ BlockTile []
, SpringTile Relaxed zero
, PivotTile zero
, ArmTile zero False
, BallTile ]
, let gl = Glyph (fst $ tileChar tile) white a0 ]
where
bindingsTable IMPlay GravLeft =
[ (-2, BindingsEntry "select tool"
[CmdToggle, CmdTile $ WrenchTile zero, CmdTile HookTile])
, (-1, BindingsEntry "rotate hook" $
nub [CmdRotate whs dir | whs <- [WHSSelected, WHSHook], dir <- [-1,1]])
, ( 0, BindingsEntry "wait" [CmdWait])
, ( 2, BindingsEntry "open lock" [CmdOpen])
, ( 4, BindingsEntry "undo, redo" [CmdUndo, CmdRedo])
, ( 5, BindingsEntry "marks" [CmdMark, CmdJumpMark, CmdReset])
]
bindingsTable IMPlay GravRight =
[ (-7, BindingsEntry "help" [CmdHelp])
, (-6, BindingsEntry "bind" [CmdBind Nothing])
, (7, BindingsEntry "quit" [CmdQuit])
]
bindingsTable IMReplay GravLeft =
[ ( 0, BindingsEntry "wait" [CmdWait])
, ( 4, BindingsEntry "undo, redo" [CmdUndo, CmdRedo])
, ( 5, BindingsEntry "marks" [CmdMark, CmdJumpMark, CmdReset])
]
bindingsTable IMReplay GravRight =
[ (-7, BindingsEntry "help" [CmdHelp])
, (-6, BindingsEntry "bind" [CmdBind Nothing])
, (7, BindingsEntry "quit" [CmdQuit])
]
bindingsTable IMEdit GravLeft =
[ (-1, BindingsEntry "rotate" $
nub [CmdRotate whs dir | whs <- [WHSSelected, WHSHook], dir <- [-1,1]])
, ( 0, BindingsEntry "select" [CmdSelect])
, ( 1, BindingsEntry "delete" [CmdDelete])
, ( 2, BindingsEntry "merge" [CmdMerge])
, ( 4, BindingsEntry "undo, redo" [CmdUndo, CmdRedo])
, ( 5, BindingsEntry "marks" [CmdMark, CmdJumpMark, CmdReset])
]
bindingsTable IMEdit GravRight =
[ (-7, BindingsEntry "help" [CmdHelp])
, (-6, BindingsEntry "bind" [CmdBind Nothing])
, (-1, BindingsEntry "test" [CmdTest])
, ( 0, BindingsEntry "play" [CmdPlay])
, ( 1, BindingsEntry "step" [CmdWait])
, ( 4, BindingsEntry "write" [CmdWriteState])
, ( 7, BindingsEntry "quit" [CmdQuit])
]
bindingsTable _ _ = []
drawBindingsTables _ _ _ = return ()
-- |frameWidth = maximum . map (abs . cx . hexVec2CVec) .
-- blockPattern . placedPiece . framePiece
frameWidth :: Frame -> Int
frameWidth frame@(BasicFrame size) = max (2*size) $
2*(size + boltWidth frame) - (size`div`2)
erase :: UIM ()
erase = liftIO Curses.erase
refresh :: UIM ()
refresh = liftIO Curses.refresh
type Geom = (CVec, HexPos)
getGeom :: UIM Geom
getGeom = do
(h,w) <- liftIO Curses.scrSize
centre <- gets dispCentre
return (CVec (h`div`2) (w`div`2), centre)
drawAt :: Glyph -> HexPos -> UIM ()
drawAt gl pos =
drawAtWithGeom gl pos =<< getGeom
drawAtWithGeom :: Glyph -> HexPos -> Geom -> UIM ()
drawAtWithGeom gl pos geom@(scrCentre,centre) =
drawAtCVec gl $ scrCentre +^ hexVec2CVec (pos -^ centre)
drawAtCVec :: Glyph -> CVec -> UIM ()
drawAtCVec gl cpos = do
cpairs <- gets dispCPairs
liftIO $ mvAddGlyph cpairs cpos gl
drawStr :: Curses.Attr -> ColPair -> CVec -> String -> UIM ()
drawStr attr col v str = do
cpairs <- gets dispCPairs
liftIO $ Curses.attrSet attr (cpairs!!col) >> mvAddStr v str
drawStrGrey :: CVec -> String -> UIM ()
drawStrGrey = drawStr a0 0
drawStrCentred :: Curses.Attr -> ColPair -> CVec -> [Char] -> UIM ()
drawStrCentred attr col v str =
drawStr attr col (truncateCVec (v +^ CVec 0 (-length str `div` 2))) str
drawCursorAt :: Maybe HexPos -> UIM ()
drawCursorAt Nothing =
void $ liftIO $ Curses.cursSet Curses.CursorInvisible
drawCursorAt (Just pos) = do
geom@(scrCentre,centre) <- getGeom
liftIO $ Curses.cursSet Curses.CursorVisible
liftIO $ move $ scrCentre +^ hexVec2CVec (pos -^ centre)
drawState :: [PieceIdx] -> Bool -> [Alert] -> GameState -> UIM ()
drawState reversed colourFixed alerts st = do
lastCol <- gets dispLastCol
colouring <- drawStateWithGeom reversed colourFixed lastCol st =<< getGeom
modify $ \ds -> ds { dispLastCol = colouring }
drawStateWithGeom :: [PieceIdx] -> Bool -> PieceColouring -> GameState -> Geom -> UIM PieceColouring
drawStateWithGeom reversed colourFixed lastCol st geom = do
let colouring = boardColouring st (colouredPieces colourFixed st) lastCol
mono <- gets monochrome
sequence_ [ drawAtWithGeom glyph pos geom |
(pos,glyph) <- Map.toList $ ownedTileGlyph mono colouring reversed <$> stateBoard st
]
return colouring
drawMsgLine = void.runMaybeT $ do
(attr,col,str) <- MaybeT $ gets message
lift $ do
(h,w) <- liftIO Curses.scrSize
liftIO $ clearLine $ h-1
let str' = take (w-1) str
drawStr attr col (CVec (h-1) 0) str'
setMsgLine attr col str = do
modify $ \s -> s { message = Just (attr,col,str) }
drawMsgLine
refresh
drawTitle (Just (title,n)) = do
(h,w) <- liftIO Curses.scrSize
drawStrCentred a0 white (CVec 0 (w`div`2)) title
drawTitle Nothing = return ()
say = setMsgLine bold white
sayError = setMsgLine bold red