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 qualified UI.HSCurses.Curses as Curses
  14 import Data.Char (ord)
  15 import qualified Data.Map as Map
  16 import Data.Map (Map)
  17
  18 import Hex
  19 import CVec
  20 import GameStateTypes
  21 import BoardColouring (PieceColouring)
  22 import AsciiLock
  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