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