CursesUI.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 module CursesUI where
  12
  13 import           Control.Applicative
  14 import           Control.Concurrent.STM
  15 import           Control.Monad.State
  16 import           Control.Monad.Trans.Maybe
  17 import           Data.Array
  18 import           Data.Bifunctor            (second)
  19 import           Data.Function             (on)
  20 import           Data.List
  21 import           Data.Map                  (Map)
  22 import qualified Data.Map                  as Map
  23 import           Data.Maybe
  24 import           Data.Monoid
  25 import           Data.Semigroup            as Sem
  26 import qualified UI.HSCurses.Curses        as Curses
  27
  28 import           BoardColouring
  29 import           Command
  30 import           CursesRender
  31 import           CVec
  32 import           Frame
  33 import           GameState                 (stateBoard)
  34 import           GameStateTypes
  35 import           Hex
  36 import           InputMode
  37 import           KeyBindings
  38 import           Mundanities
  39 import           ServerAddr
  40
  41 data UIState = UIState
  42     { dispCPairs    :: [Curses.Pair]
  43     , dispCentre    :: HexPos
  44     , dispLastCol   :: PieceColouring
  45     , uiKeyBindings :: Map InputMode KeyBindings
  46     , monochrome    :: Bool
  47     , message       :: Maybe (Curses.Attr, ColPair, String)}
  48 type UIM = StateT UIState IO
  49 nullUIState = UIState [] (PHS zero) Map.empty Map.empty False Nothing
  50
  51 readBindings :: UIM ()
  52 readBindings = void.runMaybeT $ do
  53     path <- liftIO $ confFilePath "bindings"
  54     bdgs <- MaybeT $ liftIO $ readReadFile path
  55     lift $ modify $ \s -> s {uiKeyBindings = bdgs}
  56 writeBindings :: UIM ()
  57 writeBindings = do
  58     path <- liftIO $ confFilePath "bindings"
  59     bdgs <- gets uiKeyBindings
  60     liftIO makeConfDir
  61     liftIO $ writeFile path $ show bdgs
  62
  63 getBindings :: InputMode -> UIM KeyBindings
  64 getBindings mode = do
  65     uibdgs <- gets (Map.findWithDefault [] mode . uiKeyBindings)
  66     return $ uibdgs ++ bindings mode
  67
  68 bindingsStr :: InputMode -> [Command] -> UIM String
  69 bindingsStr mode cmds = do
  70     bdgs <- getBindings mode
  71     return $ (("["++).(++"]")) $ intercalate "," $
  72         maybe "" showKey . findBinding bdgs <$> cmds
  73
  74
  75 data Gravity = GravUp | GravLeft | GravRight | GravDown | GravCentre
  76     deriving (Eq, Ord, Show, Enum)
  77
  78 data Draw = Draw { drawWidth :: Int, doDraw :: CVec -> UIM () }
  79
  80 doDrawAt :: CVec -> Draw -> UIM ()
  81 doDrawAt = flip doDraw
  82
  83 alignDraw :: Gravity -> Int -> Draw -> Draw
  84 alignDraw gravity w (Draw w' d) = Draw (max w w') $ \(CVec y x) ->
  85     d $ CVec y $ x + shift
  86     where
  87         shift = case gravity of
  88             GravLeft   -> 0
  89             GravRight  -> max 0 $ w - w'
  90             GravCentre -> w - w' `div` 2
  91
  92 instance Sem.Semigroup Draw where
  93     (Draw w d) <> (Draw w' d') =
  94         Draw (w+w') $ \cpos@(CVec y x) -> d cpos >> d' (CVec y (x+w))
  95 instance Monoid Draw where
  96     mempty = Draw 0 (const $ return ())
  97     mappend = (Sem.<>)
  98
  99 stringDraw :: Curses.Attr -> ColPair -> String -> Draw
 100 stringDraw attr col str =
 101     Draw (length str) $ \cpos -> drawStr attr col cpos str
 102
 103 greyDraw :: String -> Draw
 104 greyDraw = stringDraw a0 white
 105
 106 bindingsDraw :: KeyBindings -> [Command] -> Draw
 107 bindingsDraw = bindingsDrawColour white
 108 bindingsDrawColour :: ColPair -> KeyBindings -> [Command] -> Draw
 109 bindingsDrawColour col bdgs cmds =
 110     mconcat . (stringDraw a0 col "[" :) . (++ [stringDraw a0 col "]"]) .
 111     intersperse (stringDraw a0 col ",") $
 112         mapMaybe ((keyDraw <$>) . findBinding bdgs) cmds
 113     where
 114         keyDraw = stringDraw bold col . showKeyFriendlyShort
 115
 116 bindingDrawChar :: KeyBindings -> Curses.Attr -> Command -> Draw
 117 bindingDrawChar bdgs a cmd = mconcat . maybeToList $
 118     stringDraw a white . (:[]) . showKeyChar <$> findBinding bdgs cmd
 119
 120 drawDirBindings :: InputMode -> KeyBindings -> WrHoSel -> Draw
 121 drawDirBindings mode bdgs whs = Draw 5 $ \cpos -> do
 122     let c | mode == IMEdit = '_'
 123             | otherwise = case whs of
 124                 WHSHook     -> '@'
 125                 WHSWrench   -> '*'
 126                 WHSSelected -> '_'
 127         gl = Glyph c white a0
 128     drawAtCVec gl cpos
 129     sequence_ [ doDrawAt (cpos +^ hexVec2CVec dir) .
 130             bindingDrawChar bdgs bold $ CmdDir whs dir
 131         | dir <- hexDirs ]
 132
 133 data BindingsEntry = BindingsEntry String [Command]
 134
 135 drawBindingsTables :: InputMode -> (Command -> Bool) -> Frame -> UIM ()
 136 drawBindingsTables mode censor frame | mode `elem` [ IMEdit, IMPlay ] = do
 137     bdgs <- getBindings mode
 138     (h,w) <- liftIO Curses.scrSize
 139     let startRight = frameWidth frame + 3
 140     let maxWidth = (w `div` 2) - startRight - 1
 141     let entryDraws (BindingsEntry desc cmds) =
 142             (greyDraw desc, bindingsDraw bdgs cmds)
 143     forM_ [GravLeft, GravRight] $ \grav -> do
 144         let table = filter (\(_,BindingsEntry _ cs) -> not $ null cs) $
 145                 second (\(BindingsEntry s cs) -> BindingsEntry s $ filter censor cs) <$>
 146                 bindingsTable mode grav
 147             drawsTable = second entryDraws <$> table
 148             maxDesc = maximum $ drawWidth . fst . snd <$> drawsTable
 149             maxBdgs = maximum $ drawWidth . snd . snd <$> drawsTable
 150             descX = (w `div` 2) + if grav == GravRight
 151                 then startRight + maxBdgs + 2
 152                 else -(startRight + maxBdgs + 2 + maxDesc)
 153             bdgsX = (w `div` 2) + if grav == GravRight
 154                 then startRight
 155                 else -(startRight + maxBdgs)
 156             oppGrav = if grav == GravRight then GravLeft else GravRight
 157             useDescs = maxDesc + 1 + maxBdgs <= maxWidth
 158         sequence_
 159             [ do
 160                 when (maxBdgs <= maxWidth) $
 161                     doDrawAt (CVec y bdgsX) $ alignDraw
 162                         (if useDescs then grav else oppGrav) maxBdgs
 163                         bdgsDraw
 164                 when useDescs $
 165                     doDrawAt (CVec y descX) $ alignDraw oppGrav maxDesc descDraw
 166             | (yoff, (descDraw, bdgsDraw)) <- drawsTable
 167             , let y = (h `div` 2) + yoff
 168             ]
 169         when (mode `elem` [IMPlay,IMEdit] && grav == GravLeft && maxWidth >= 5) $
 170             let (halfw,poss)
 171                     | maxWidth < 15 = (3,[CVec (-5) 0])
 172                     | maxWidth < 19 = (7,[CVec (-4) 0, CVec (-6) 5, CVec (-6) (-5)])
 173                     | otherwise = (9,[CVec (-5) 0, CVec (-5) 7, CVec (-5) (-7)])
 174             in sequence_ [ doDrawAt pos $ drawDirBindings mode bdgs whs
 175                 | (whs,pos) <- zip [WHSSelected, WHSWrench, WHSHook] $
 176                     (CVec (h `div` 2) ((w `div` 2) - startRight -
 177                         min (maxWidth - halfw) (max (maxBdgs+1) halfw)) +^) <$> poss ]
 178         when (mode == IMEdit && grav == GravRight && maxWidth >= 9) $
 179             let c = CVec ((h`div`2) - 4) ((w`div`2) + startRight +
 180                         min (maxWidth - 5) (max (maxBdgs+1) 5))
 181             in sequence_ [ do
 182                     drawAtCVec gl (c +^ CVec 0 x)
 183                     doDrawAt (c +^ CVec 1 x) . bindingDrawChar bdgs bold $ CmdTile tile
 184                 | (x,tile) <- zip [-4,-2,0,2,4]
 185                         [ BlockTile []
 186                         , SpringTile Relaxed zero
 187                         , PivotTile zero
 188                         , ArmTile zero False
 189                         , BallTile ]
 190                 , let gl = Glyph (fst $ tileChar tile) white a0 ]
 191
 192     where
 193         bindingsTable IMPlay GravLeft =
 194             [ (-2, BindingsEntry "select tool"
 195                 [CmdToggle, CmdTile $ WrenchTile zero, CmdTile HookTile])
 196             , (-1, BindingsEntry "rotate hook" $
 197                 nub [CmdRotate whs dir | whs <- [WHSSelected, WHSHook], dir <- [-1,1]])
 198             , ( 0, BindingsEntry "wait" [CmdWait])
 199             , ( 2, BindingsEntry "open lock" [CmdOpen])
 200             , ( 4, BindingsEntry "undo, redo" [CmdUndo, CmdRedo])
 201             , ( 5, BindingsEntry "marks" [CmdMark, CmdJumpMark, CmdReset])
 202             ]
 203         bindingsTable IMPlay GravRight =
 204             [ (-7, BindingsEntry "help" [CmdHelp])
 205             , (-6, BindingsEntry "bind" [CmdBind Nothing])
 206             , (7, BindingsEntry "quit" [CmdQuit])
 207             ]
 208         bindingsTable IMReplay GravLeft =
 209             [ ( 0, BindingsEntry "wait" [CmdWait])
 210             , ( 4, BindingsEntry "undo, redo" [CmdUndo, CmdRedo])
 211             , ( 5, BindingsEntry "marks" [CmdMark, CmdJumpMark, CmdReset])
 212             ]
 213         bindingsTable IMReplay GravRight =
 214             [ (-7, BindingsEntry "help" [CmdHelp])
 215             , (-6, BindingsEntry "bind" [CmdBind Nothing])
 216             , (7, BindingsEntry "quit" [CmdQuit])
 217             ]
 218         bindingsTable IMEdit GravLeft =
 219             [ (-1, BindingsEntry "rotate" $
 220                 nub [CmdRotate whs dir | whs <- [WHSSelected, WHSHook], dir <- [-1,1]])
 221             , ( 0, BindingsEntry "select" [CmdSelect])
 222             , ( 1, BindingsEntry "delete" [CmdDelete])
 223             , ( 2, BindingsEntry "merge" [CmdMerge])
 224             , ( 4, BindingsEntry "undo, redo" [CmdUndo, CmdRedo])
 225             , ( 5, BindingsEntry "marks" [CmdMark, CmdJumpMark, CmdReset])
 226             ]
 227         bindingsTable IMEdit GravRight =
 228             [ (-7, BindingsEntry "help" [CmdHelp])
 229             , (-6, BindingsEntry "bind" [CmdBind Nothing])
 230             , (-1, BindingsEntry "test" [CmdTest])
 231             , ( 0, BindingsEntry "play" [CmdPlay])
 232             , ( 1, BindingsEntry "step" [CmdWait])
 233             , ( 4, BindingsEntry "write" [CmdWriteState])
 234             , ( 7, BindingsEntry "quit" [CmdQuit])
 235             ]
 236         bindingsTable _ _ = []
 237
 238 drawBindingsTables _ _ _ = return ()
 239
 240 -- |frameWidth = maximum . map (abs . cx . hexVec2CVec) .
 241 --      blockPattern . placedPiece . framePiece
 242 frameWidth :: Frame -> Int
 243 frameWidth frame@(BasicFrame size) = max (2*size) $
 244     2*(size + boltWidth frame) - (size`div`2)
 245
 246 erase :: UIM ()
 247 erase = liftIO Curses.erase
 248 refresh :: UIM ()
 249 refresh = liftIO Curses.refresh
 250
 251 type Geom = (CVec, HexPos)
 252 getGeom :: UIM Geom
 253 getGeom = do
 254     (h,w) <- liftIO Curses.scrSize
 255     centre <- gets dispCentre
 256     return (CVec (h`div`2) (w`div`2), centre)
 257
 258 drawAt :: Glyph -> HexPos -> UIM ()
 259 drawAt gl pos =
 260     drawAtWithGeom gl pos =<< getGeom
 261
 262 drawAtWithGeom :: Glyph -> HexPos -> Geom -> UIM ()
 263 drawAtWithGeom gl pos geom@(scrCentre,centre) =
 264     drawAtCVec gl $ scrCentre +^ hexVec2CVec (pos -^ centre)
 265
 266 drawAtCVec :: Glyph -> CVec -> UIM ()
 267 drawAtCVec gl cpos = do
 268     cpairs <- gets dispCPairs
 269     liftIO $ mvAddGlyph cpairs cpos gl
 270
 271 drawStr :: Curses.Attr -> ColPair -> CVec -> String -> UIM ()
 272 drawStr attr col v str = do
 273     cpairs <- gets dispCPairs
 274     liftIO $ Curses.attrSet attr (cpairs!!col) >> mvAddStr v str
 275 drawStrGrey :: CVec -> String -> UIM ()
 276 drawStrGrey = drawStr a0 0
 277 drawStrCentred :: Curses.Attr -> ColPair -> CVec -> [Char] -> UIM ()
 278 drawStrCentred attr col v str =
 279     drawStr attr col (truncateCVec (v +^ CVec 0 (-length str `div` 2))) str
 280
 281
 282 drawCursorAt :: Maybe HexPos -> UIM ()
 283 drawCursorAt Nothing =
 284     void $ liftIO $ Curses.cursSet Curses.CursorInvisible
 285 drawCursorAt (Just pos) = do
 286     geom@(scrCentre,centre) <- getGeom
 287     liftIO $ Curses.cursSet Curses.CursorVisible
 288     liftIO $ move $ scrCentre +^ hexVec2CVec (pos -^ centre)
 289
 290 drawState :: [PieceIdx] -> Bool -> [Alert] -> GameState -> UIM ()
 291 drawState reversed colourFixed alerts st = do
 292     lastCol <- gets dispLastCol
 293     colouring <- drawStateWithGeom reversed colourFixed lastCol st =<< getGeom
 294     modify $ \ds -> ds { dispLastCol = colouring }
 295
 296 drawStateWithGeom :: [PieceIdx] -> Bool -> PieceColouring -> GameState -> Geom -> UIM PieceColouring
 297 drawStateWithGeom reversed colourFixed lastCol st geom = do
 298     let colouring = boardColouring st (colouredPieces colourFixed st) lastCol
 299     mono <- gets monochrome
 300     sequence_ [ drawAtWithGeom glyph pos geom |
 301         (pos,glyph) <- Map.toList $ ownedTileGlyph mono colouring reversed <$> stateBoard st
 302         ]
 303     return colouring
 304
 305 drawMsgLine = void.runMaybeT $ do
 306     (attr,col,str) <- MaybeT $ gets message
 307     lift $ do
 308         (h,w) <- liftIO Curses.scrSize
 309         liftIO $ clearLine $ h-1
 310         let str' = take (w-1) str
 311         drawStr attr col (CVec (h-1) 0) str'
 312 setMsgLine attr col str = do
 313     modify $ \s -> s { message = Just (attr,col,str) }
 314     drawMsgLine
 315     refresh
 316
 317 drawTitle (Just (title,n)) = do
 318     (h,w) <- liftIO Curses.scrSize
 319     drawStrCentred a0 white (CVec 0 (w`div`2)) title
 320 drawTitle Nothing = return ()
 321
 322 say = setMsgLine bold white
 323 sayError = setMsgLine bold red