curses set game

root / Board.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
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
module Board (
    boardSize,
    Board, newBoard,
    dealBoard, dealMore,
    redrawBoard, sortBoard,
    selectSlot, unselectSlot,
    boardSelection, flashSelection, clearSelection,
    selectHint, selectionDescriptions,
    boardCount, boardDealt
    ) where

import Data.Array
import Data.List
import qualified Control.Monad as Monad

import qualified Set
import qualified Find
import qualified Display
import qualified Interface
import qualified Deck
import Util

boardSize = 24
boardDeal = 12
boardIncr = Set.width

type Slot = Set.Card
slotEmpty :: Slot
slotEmpty = Set.nullCard

hasCard :: Slot -> Bool
hasCard = (/=) slotEmpty
noCard = (==) slotEmpty

data Board = Board{
  boardDeck :: Deck.Deck Set.Card,
  boardSlots :: Array Int Slot,
  boardEmpties :: [Int],
  boardSel :: [Int],
  boardNew :: [Int],
  boardSets :: [[Int]],
  boardDealt :: Int
}

get :: Board -> Int -> Slot
get Board{ boardSlots = sl } = (!) sl

set :: Board -> Int -> Slot -> Board
set b@Board{
    boardSlots = cl,
    boardEmpties = el,
    boardSets = sl
  } n c =
  b{
    boardSlots = cl // [(n,c)],
    boardEmpties = el1,
    boardSets = sl1
  } where
  (el0, sl0) = if hasCard (cl ! n)
    then (el, filter (notElem n) sl)
    else (n `delete` el, sl)
  (el1, sl1) = if hasCard c
    then (el0, Find.newSets (elems cl) (n, c) ++ sl0)
    else (n `insert` el0, sl0)

boardCount :: Board -> Int
boardCount Board{ boardSlots = sl } = count hasCard (elems sl)

--boardCards :: Board -> [Set.Card]
--boardCards Board{ boardSlots = sl } = filter hasCard (elems sl)

slotMark :: Board -> Int -> Display.CardMark
slotMark b n
  | n `elem` boardSel b = Display.markSel
  | n `elem` boardNew b = Display.markNew
  | otherwise = Display.markNon

clearNew :: Board -> IO Board
clearNew b = mapM clear (boardNew b) >>. b{ boardNew = [] } where
  clear n
    | hasCard $ get b n = Display.markCard n Display.markNon
    | otherwise = nop

drawSlot :: Board -> Int -> IO ()
drawSlot b n = Display.drawCard n (get b n) $ slotMark b n

setSlot :: Board -> Int -> Slot -> IO Board
setSlot b n s = drawSlot b' n >>. b' where
  b' = set b n s

dealCard :: Board -> IO Board
dealCard b@Board{ boardDeck = deck }
  | Deck.empty deck = gameError "No cards left in deck"
  | null empties = gameError "No space left on board"
  | otherwise = setSlot b' n card
  where
    empties = boardEmpties b
    n = head empties
    (card, deck') = Deck.draw deck
    b' = b{ boardDeck = deck', boardNew = n:boardNew b, boardDealt = succ $ boardDealt b }

deal :: Board -> IO Board
deal b
  | c < boardDeal && not done = put 1
  | has = return b
  | done = gameOver "Game over"
  | otherwise = put boardIncr
  where
    c = boardCount b
    has = not $ null (boardSets b)
    put n = repM n dealCard b >>= deal
    done = Deck.empty (boardDeck b)

dealBoard :: Board -> IO Board
dealBoard b = clearNew b >>= deal

dealMore :: Board -> IO Board
dealMore = repM boardIncr dealCard

newBoard :: Deck.Deck Set.Card -> IO Board
newBoard deck = Interface.clear >>. Board{
    boardSlots = listArray (0,pred boardSize) (repeat slotEmpty),
    boardEmpties = [0..pred boardSize],
    boardDeck = deck,
    boardSel = [],
    boardNew = [],
    boardSets = [],
    boardDealt = 0
  }

redrawBoard :: Board -> IO ()
redrawBoard b = Interface.clear >> mapM_ draw [ 0 .. pred boardSize ] where
  draw n = Monad.when (hasCard $ get b n) $ drawSlot b n

sortBoard :: Board -> IO Board
sortBoard b@Board{ boardSlots = sl } = redrawBoard b' >>. b' where
  cl = elems sl
  cl' = sortBy ord cl
  sl' = listArray (0,pred boardSize) cl'
  ord x y = compare (noCard x, x) (noCard y, y)
  b' = b{
    boardSlots = sl',
    boardNew = [],
    boardSel = [],
    boardSets = Find.allSets cl',
    boardEmpties = [ i | (i, c) <- assocs sl, noCard c ]
  }

updateSelect :: Board -> Int -> [Int] -> IO Board
updateSelect b n s = Display.markCard n (slotMark b' n) >>. b'
  where b' = b{ boardSel = s }

selectSlot :: Board -> Int -> Maybe (IO Board)
selectSlot b@Board{ boardSel = sel } n
  | n >= boardSize = Nothing
  | noCard $ get b n = Nothing
  | n `elem` sel = res (n `delete` sel)
  | otherwise = res (n:sel)
  where res s = Just $ updateSelect b n s

unselectSlot :: Board -> Maybe (IO Board)
unselectSlot Board{ boardSel = [] } = Nothing
unselectSlot b@Board{ boardSel = n:sel } = Just $ updateSelect b n sel

selectHint :: Board -> IO Board
selectHint b@Board{ boardSel = sel, boardSets = sets }
  | null rem && null add = return b
  | otherwise = updateSelect b n sel'
  where
    set = maximumWith (length . intersect sel) sets
    rem = sel \\ set
    add = set \\ sel
    n = head $ rem ++ add
    sel' = (if null rem then (:) else delete) n sel

boardSelection :: Board -> [Set.Card]
boardSelection b = map (get b) (boardSel b)

flashSelection :: Board -> IO ()
flashSelection b = mapM_ (\n -> Display.markCard n Display.markSet) (boardSel b)

clearSelection :: Board -> IO Board
clearSelection b = Monad.foldM (\b i -> setSlot b i slotEmpty) b{ boardSel = [] } (boardSel b)

selectionDescriptions :: Board -> [[String]]
selectionDescriptions b = h : map desc (boardSel b) where
  h = "":Display.attrDescriptions
  desc i = [valLabel i] : Display.cardDescriptions (get b i)