curses set game

root / Display.hs

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
module Display (
    initDisplay,
    drawCard,
    CardMark,
    markNon, markSel, markNew, markSet,
    markCard,
    attrDescriptions, cardDescriptions
    ) where

import qualified Data.Maybe as Maybe
import qualified Control.Monad as Monad
import UI.HSCurses.Curses
import Curses

import qualified Set
import Interface
import Util

cardDim = (5, 4 + 5*Set.width)
cardsAcross = 4

data CardAttr = ANumber | AColor | AShape | ATexture | AIntensity deriving (Enum, Show)
attrs = [toEnum 0..toEnum (pred Set.dimen)]

cardAttr :: Set.Card -> CardAttr -> Int
cardAttr c a = if i >= Set.dimen then 0 else Set.cardAttr c i where
  i = fromEnum a

attrPairBase = 1
attrPair i = Pair (attrPairBase + i)

initDisplay :: IO ()
initDisplay =
  Monad.zipWithM_ (\i c -> initPair (attrPair i) (Maybe.fromJust $ color c) defaultBackground) [0..pred Set.width] (attrDescs AColor)

cardPos :: Int -> Dim
cardPos n = dimInc $ dimOp (*) p cardDim where
  p = n `divMod` cardsAcross

cardLabel :: Int -> IO ()
cardLabel n = move y x >> drawChar stdScr (valLabel n) where
  (y,x) = dimInc $ cardPos n

cardDraw :: Int -> Set.Card -> IO ()
cardDraw n c = do
  wAttrSet stdScr (attr, attrPair $ a AColor)
  drawStrings stdScr (dimInc $ cardPos n) full
  where
    a = cardAttr c
    attr = cardAttrs !! a AIntensity $ attr0
    char = cardChars !! a ATexture
    patt = cardPatts !! a AShape
    line s = align AtCenter (snd cardDim-2) $ concat $ replicate (1+a ANumber) (" " ++ s ++ " ")
    full = map line patt

    cardAttrs = [
      id,
      (`setBold` True),
      (`setBlink` True)
      ]
    cardChars = [ckBoard, diamond, plus]
    cardPatts = [
      [[x,x,x],[x,x,x],[x,x,x]],
      [[o,x,o],[x,x,x],[o,x,o]],
      [[o,o,x],[o,x,o],[x,o,o]]
      ] where
      x = char
      o = space

type CardMark = Attr
markNon, markSel, markNew, markSet :: CardMark
markNon = attr0
markSel = setReverse attr0 True
markNew = setBold attr0 True
markSet = setBlink (setReverse attr0 True) True

markAttr :: CardMark -> Attr
markAttr = id

cardBox :: Int -> CardMark -> IO ()
cardBox n m = do
  wAttrSet stdScr (markAttr m, Pair 0)
  drawBox stdScr (cardPos n) cardDim

markCard :: Int -> CardMark -> IO ()
markCard n m = cardBox n m >> cardLabel n
{-markCard n m = do
  move y x >> wChgAttr stdScr w ap
  mapM_ (\y ->
      move y x >> wChgAttr stdScr 1 ap >>
      move y (x+w-1) >> wChgAttr stdScr 1 ap)
    [y+1 .. y+h-2]
  move (y+h-1) x >> wChgAttr stdScr w ap
  where
    (y,x) = cardPos n
    (h,w) = cardDim
    ap = (markAttr m, Pair 0) -}

clearCard :: Int -> IO ()
clearCard n = attrRst >> clearArea (cardPos n) cardDim

drawCard :: Int -> Set.Card -> CardMark -> IO ()
drawCard n c m
  | c == Set.nullCard = clearCard n
  | otherwise = cardDraw n c >> cardBox n m >> cardLabel n

attrName a = tail (show a)
attrDescs ANumber = ["one", "two", "three"]
attrDescs AColor = ["red", "green", "blue"]
attrDescs AShape = ["square", "cross", "squiggle"]
attrDescs ATexture = ["blocks", "diamonds", "slashes"]
attrDescs AIntensity = ["medium", "bright", "blinking"]

attrDescriptions = map attrName attrs
cardDescriptions c = map (\a -> attrDescs a !! cardAttr c a) attrs