CursesRender.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 CursesRender where
  12
  13 import           Data.Char          (ord)
  14 import           Data.Map           (Map)
  15 import qualified Data.Map           as Map
  16 import qualified UI.HSCurses.Curses as Curses
  17
  18 import           AsciiLock
  19 import           BoardColouring     (PieceColouring)
  20 import           CVec
  21 import           GameStateTypes
  22 import           Hex
  23
  24 -- From Curses.CursesHelper:
  25 -- | Converts a list of 'Curses.Color' pairs (foreground color and
  26 --   background color) into the curses representation 'Curses.Pair'.
  27 colorsToPairs :: [(Curses.Color, Curses.Color)] -> IO [Curses.Pair]
  28 colorsToPairs cs = do
  29     p <- Curses.colorPairs
  30     let nColors = length cs
  31         blackWhite = p < nColors
  32     if blackWhite then do
  33         print ("Terminal does not support enough colors. Number of " ++
  34                   " colors requested: " ++ show nColors ++
  35                   ". Number of colors supported: " ++ show p)
  36         return $ replicate nColors $ Curses.Pair 0
  37     else mapM toPairs (zip [1..] cs)
  38     where toPairs (n, (fg, bg)) = do
  39             let p = Curses.Pair n
  40             Curses.initPair p fg bg
  41             return p
  42
  43 type AttrChar = (Char, Curses.Attr)
  44 type ColPair = Int
  45 white,red,green,yellow,blue,magenta,cyan :: ColPair
  46 white = 0
  47 red = 1
  48 green = 2
  49 yellow = 3
  50 blue = 4
  51 magenta = 5
  52 cyan = 6
  53 data Glyph = Glyph Char ColPair Curses.Attr
  54 a0 = Curses.attr0
  55 bold = Curses.setBold a0 True
  56
  57 tileChar :: Tile -> AttrChar
  58 tileChar (BlockTile _) = ('#',a0)
  59 tileChar (PivotTile dir)
  60     | dir == zero = ('o',bold)
  61     | canonDir dir == hu = ('-',bold)
  62     | canonDir dir == hv = ('\\',bold)
  63     | canonDir dir == hw = ('/',bold)
  64 tileChar (ArmTile dir principal) =
  65     let cdir = canonDir dir
  66         c | cdir == hu = '-'
  67           | cdir == hv = '\\'
  68           | cdir == hw = '/'
  69           | otherwise = '-'
  70         a = if principal then bold else a0
  71     in (c,a)
  72 tileChar HookTile = ('@',bold)
  73 tileChar (WrenchTile mom) = ('*',if mom /= zero then bold else a0)
  74 tileChar BallTile = ('O',a0)
  75 tileChar (SpringTile Relaxed _) = ('S',a0)
  76 tileChar (SpringTile Compressed _) = ('$',bold)
  77 tileChar (SpringTile Stretched _) = ('s',bold)
  78 tileChar _ = ('?',bold)
  79
  80 ownedTileGlyph :: Bool -> PieceColouring -> [PieceIdx] -> OwnedTile -> Glyph
  81 ownedTileGlyph mono@True colouring reversed ot =
  82     Glyph (monochromeOTileChar' colouring ot) white a0
  83     where
  84     -- |add fifth colour, to differentiate from lock frame;
  85     -- adding this to the asciilock format would break back-compatibility.
  86     monochromeOTileChar' colouring (idx,BlockTile _) =
  87         case Map.lookup idx colouring of
  88             Just 0 -> ';'
  89             Just 1 -> '%'
  90             Just 2 -> '"'
  91             Just 3 -> '&'
  92             Just 4 -> '~'
  93             _      -> '#'
  94     monochromeOTileChar' colouring ot = monochromeOTileChar colouring ot
  95 ownedTileGlyph mono@False colouring reversed (owner,t) =
  96     let (ch,attr) = tileChar t
  97         pair = case Map.lookup owner colouring of
  98                     Nothing -> 0
  99                     Just 3  -> cyan  -- replace blue with cyan for visibility
 100                     Just n  -> n+1
 101         rev = owner `elem` reversed
 102     in Glyph ch pair (Curses.setReverse attr rev)
 103
 104 addCh :: Char ->  IO ()
 105 addCh c = Curses.wAddStr Curses.stdScr [c]
 106 mvAddCh :: CVec -> Char ->  IO ()
 107 mvAddCh (CVec y x) c = Curses.mvAddCh y x $ fromIntegral $ ord c
 108 mvAddStr :: CVec -> String -> IO ()
 109 mvAddStr (CVec y x) = Curses.mvWAddStr Curses.stdScr y x
 110 mvAddGlyph :: [Curses.Pair] -> CVec -> Glyph -> IO ()
 111 mvAddGlyph cpairs v (Glyph ch col attr) =
 112     Curses.attrSet attr (cpairs!!col) >> mvAddCh v ch
 113 move :: CVec -> IO ()
 114 move (CVec y x) = Curses.move y x
 115 clearLine :: Int -> IO ()
 116 clearLine y = Curses.move y 0 >> Curses.clrToEol