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 ownedTileGlyph mono@False colouring reversed (owner,t) =
  84     let (ch,attr) = tileChar t
  85         pair = case Map.lookup owner colouring of
  86                     Nothing -> 0
  87                     Just n  -> n+1
  88         rev = owner `elem` reversed
  89     in Glyph ch pair (Curses.setReverse attr rev)
  90
  91 addCh :: Char ->  IO ()
  92 addCh c = Curses.wAddStr Curses.stdScr [c]
  93 mvAddCh :: CVec -> Char ->  IO ()
  94 mvAddCh (CVec y x) c = Curses.mvAddCh y x $ fromIntegral $ ord c
  95 mvAddStr :: CVec -> String -> IO ()
  96 mvAddStr (CVec y x) = Curses.mvWAddStr Curses.stdScr y x
  97 mvAddGlyph :: [Curses.Pair] -> CVec -> Glyph -> IO ()
  98 mvAddGlyph cpairs v (Glyph ch col attr) =
  99     Curses.attrSet attr (cpairs!!col) >> mvAddCh v ch
 100 move :: CVec -> IO ()
 101 move (CVec y x) = Curses.move y x
 102 clearLine :: Int -> IO ()
 103 clearLine y = Curses.move y 0 >> Curses.clrToEol