curses set game

root / Game.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
module Game (
    GameOptions(..),
    start
    ) where

import Prelude hiding (catch)
import qualified System.Random
import qualified UI.HSCurses.Curses as Curses
import Control.Concurrent (threadDelay)
import qualified Data.Time.Clock as Time
import Control.Exception (catch)
import qualified Data.Char as Char
import qualified Control.Monad as Monad
import Text.Printf (printf)

import qualified Set
import qualified Deck
import Board
import Interface
import Util

data GameOptions = GameOptions{
  gameInfinite :: Bool,
  gamePlayers :: [String]
}

data Game = Game{
  gameOptions :: GameOptions,
  gameBoard :: Board,
  gameLastSet :: [Set.Card],
  gamePlayer :: Int,
  gameScores :: [Int],
  gameSetLevels :: [Int],
  gameStartTime, gameLastSetTime :: Time.UTCTime
}

helpMsg = columnize [AtLeft, AtLeft] [
  ["I",	  "Show game information and scores" ],
  ["C",	  "Show details about selection cards" ],
  ["R",	  "Resort cards on board" ],
  ["D",	  "Deal more cards" ],
  ["H",	  "Give a hint" ],
  ["P",	  "Pause game" ],
  [],
  ["1-9", "Choose player" ],
  ["a-z", "Select/unselect card in specified slot" ],
  ["<BS>","Unselect last selected card" ],
  ["^U",  "Unselect all cards" ],
  ["<Enter>", "Call a Set!" ],
  [],
  ["Q",	  "Quit" ]
  ]

msg = statusMsg
err t = Curses.beep >> msg t

setPlayer game n = titleMsg (gamePlayers (gameOptions game) !! n) >>. game{ gamePlayer = n }
scoreList game = zipWith (\x y -> [x ++ ":", show y]) (gamePlayers (gameOptions game)) (gameScores game)
gameInfo game@Game{
    gameBoard = board,
    gameStartTime = stime,
    gameLastSetTime = etime,
    gameSetLevels = levs
  } = do
  now <- Time.getCurrentTime
  let
    gamet = Time.diffUTCTime now stime
    playt = Time.diffUTCTime etime stime
  return $ columnize [AtRight, AtRight] ([
    ["Cards dealt:", show dealt],
    ["Sets found:", show sets]
    ] ++ scoreList game ++ [
    ["Set levels:", unwords (map show levs)],
    ["Game time:", showtime gamet],
    ["Average time/set:", if sets == 0 then "" else showtime (playt / fromIntegral sets)]])
  where
    dealt = boardDealt board
    taken = dealt - boardCount board
    sets = taken `div` Set.width
    showtime x = if m >= 60
      then printf "%d:%02d:%05.2f" (m `div` 60) (m `mod` 60) (realToFrac s :: Float)
      else printf "%d:%05.2f" (m :: Int) (realToFrac s :: Float) 
      where (m,s) = quotRemainder x 60

iter :: Game -> IO Game
iter game@Game{
    gameBoard = board,
    gameScores = score
  } = input >>= msg "" >>- inkey where

  goboard b = return game{ gameBoard = b }

  inkey :: Curses.Key -> IO Game
  inkey (Curses.KeyChar ch) = inch ch
  inkey Curses.KeyBackspace = rmsel
  inkey k = gameError ("Unknown key: " ++ show k)

  inch 'Q' = gameOver "Quit"
  inch '\DEL' = rmsel
  inch 'U' = whileJustM unselectSlot board >>= goboard
  inch '\NAK' = inch 'U'
  inch '\f' = msg [] >> Curses.touchWin Curses.stdScr >>. game
  inch 'I' = gameInfo game >>= dialogue "Info" >>. game
  inch 'C' = dialogue "Selected Cards" (columnize (repeat AtCenter) (selectionDescriptions board)) >>. game
  inch 'D' = dealMore board >>= goboard
  inch 'H' = selectHint board >>= goboard
  inch 'R' = sortBoard board >>= goboard
  inch 'P' = do
    st <- Time.getCurrentTime
    Interface.clear
    dialogue "Paused" []
    redrawBoard board
    setPlayer game (gamePlayer game)
    et <- Time.getCurrentTime
    return game{ gameStartTime = Time.addUTCTime (Time.diffUTCTime et st) (gameStartTime game) }
  inch '?' = dialogue "Help" helpMsg >>. game
  inch '\r' = tryset board
  inch ch
    | Char.isDigit ch && ch /= '0' = setPlayer game (Char.ord ch - Char.ord '1')
    | Char.isLower ch = addsel (labelVal ch)
    | otherwise = gameError ("Unknown key: " ++ show ch)

  tryboard b
    | length (boardSelection b) == Set.width = tryset b
    | otherwise = goboard b
  runboard = (>>= goboard)
  addsel l = maybe (gameError $ "No card in slot " ++ [valLabel l]) runboard $ selectSlot board l
  rmsel = maybe (gameError "No cards selected") runboard $ unselectSlot board
  tryset b
    | Set.width /= length s = err ("Select " ++ show Set.width ++ " cards") >> goboard b
    | Set.set s = do
	msg "Set!"
	flashSelection b
	Curses.refresh
	threadDelay 1000000
	msg ""
	b <- clearSelection b >>= dealBoard
	now <- Time.getCurrentTime
	return game{
	  gameBoard = b, 
	  gameLastSet = s, 
	  gameScores = update 0 (Set.width+) (gamePlayer game) score,
	  gameSetLevels = update 0 succ (Set.setLevel s) (gameSetLevels game),
	  gameLastSetTime = now
	}
    | otherwise = msg "That is not a set" >> return game{ gameScores = update 0 pred (gamePlayer game) score }
    where s = boardSelection b

end :: Game -> String -> IO Bool
end game msg = do
  info <- gameInfo game
  key <- dialogue "Game Over" (msg : info ++ ["", "Would you like to play again [n]?"])
  return (Curses.KeyChar 'y' == key)

play :: Game -> IO (Maybe Game)
play g = catch (Just `Monad.liftM` iter g) exn where
  exn (GameError s) = Monad.unless (null s) (err s) >>. Just g
  exn (GameOver s) = end g s >>= next
  next True = Just `Monad.liftM` newGame (gameOptions g)
  next False = return Nothing

newGame :: GameOptions -> IO Game
newGame opts = do
  stdgen <- System.Random.newStdGen
  let deck = Deck.deal Set.allCards (gameInfinite opts) stdgen
  board <- newBoard deck >>= dealBoard
  now <- Time.getCurrentTime
  setPlayer Game{
    gameOptions = opts,
    gameBoard = board,
    gameLastSet = [],
    gamePlayer = 0,
    gameScores = [],
    gameSetLevels = [],
    gameStartTime = now,
    gameLastSetTime = now
  } 0

start :: GameOptions -> IO ()
start opts = newGame opts >>= whileMJust play