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
|
{------------------------------------------------------------------------------
Control.Monad.Operational
Example:
An implementation of the game TicTacToe.
Each player (human, AI, ...) is implemented in a separate monad
which are then intermingled to run the game. This resembles the
PoorMansConcurrency.hs example.
Many thanks to Yves Par`es and Bertram Felgenhauer
http://www.haskell.org/pipermail/haskell-cafe/2010-April/076216.html
------------------------------------------------------------------------------}
{-# LANGUAGE GADTs, Rank2Types #-}
import Control.Monad
import Control.Monad.Operational
import Control.Monad.State
import Data.Either
import Data.List
-- external libraries needed
import System.Random
{------------------------------------------------------------------------------
The Player monad for implementing players (human, AI, ...)
provides two operations
readBoard -- read the current board position
playMove -- play a move
to query the current board position and perform a move, respectively.
Moreover, it's actually a monad transformer intended to be used over IO.
This way, the players can perform IO computations.
------------------------------------------------------------------------------}
data PlayerI a where
ReadBoard :: PlayerI Board
PlayMove :: Int -> PlayerI Bool
type Player m a = ProgramT PlayerI m a
readBoard = singleton ReadBoard
playMove = singleton . PlayMove
-- interpreter
runGame :: Player IO () -> Player IO () -> IO ()
runGame player1 player2 = eval' initialGameState player1 player2
where
eval' game p1 p2 = viewT p1 >>= \p1view -> eval game p1view p2
eval :: GameState
-> ProgramViewT PlayerI IO () -> Player IO ()
-> IO ()
eval game (Return _) _ = return ()
eval game (ReadBoard :>>= p1) p2 = eval' game (p1 (board game)) p2
eval game (PlayMove mv :>>= p1) p2 =
case makeMove mv game of
Nothing -> eval' game (p1 False) p2
Just game'
| won game' -> let p = activePlayer game in
putStrLn $ "Player " ++ show p ++ " has won!"
| draw game'-> putStrLn $ "It's a draw."
| otherwise -> eval' game' p2 (p1 True)
-- example: human vs AI
main = do
g <- getStdGen
runGame playerHuman (playerAI g)
{------------------------------------------------------------------------------
TicTacToe Board type and logic
The board looks like this:
+---+---+---+ some squares already played on
| 1 | 2 | 3 | the empty squares are numbered
+---+---+---+
| 4 | 5 |OOO|
+---+---+---+
| 7 |XXX| 9 |
+---+---+---+
------------------------------------------------------------------------------}
data Symbol = X | O deriving (Eq,Show)
type Square = Either Int Symbol
type Board = [[Square]]
data GameState = Game { board :: Board, activePlayer :: Symbol }
initialGameState :: GameState
initialGameState = Game (map (map Left) [[1,2,3],[4,5,6],[7,8,9]]) X
-- list the possible moves to play
possibleMoves :: Board -> [Int]
possibleMoves board = [k | Left k <- concat board]
-- play a stone at a square
makeMove :: Int -> GameState -> Maybe GameState
makeMove k (Game board player)
| not (k `elem` possibleMoves board) = Nothing -- illegal move
| otherwise = Just $ Game (map (map replace) board) (switch player)
where
replace (Left k') | k' == k = Right player
replace x = x
switch X = O
switch O = X
-- has somebody won the game?
won :: GameState -> Bool
won (Game board _) = any full $ diagonals board ++ rows board ++ cols board
where
full [a,b,c] = a == b && b == c
diagonals [[a1,_,b1],
[_ ,c,_ ],
[b2,_,a2]] = [[a1,c,a2],[b1,c,b2]]
rows = id
cols = transpose
-- is the game a draw?
draw :: GameState -> Bool
draw (Game board _) = null (possibleMoves board)
-- print the board
showSquare = either (\n -> " " ++ show n ++ " ") (concat . replicate 3 . show)
showBoard :: Board -> String
showBoard board =
unlines . surround "+---+---+---+"
. map (concat . surround "|". map showSquare)
$ board
where
surround x xs = [x] ++ intersperse x xs ++ [x]
printBoard = putStr . showBoard
{------------------------------------------------------------------------------
Player examples
------------------------------------------------------------------------------}
-- a human player on the command line
playerHuman :: Player IO ()
playerHuman = forever $ readBoard >>= liftIO . printBoard >> doMove
where
-- ask the player where to move
doMove :: Player IO ()
doMove = do
liftIO . putStrLn $ "At which number would you like to play?"
n <- liftIO getLine
b <- playMove (read n)
unless b $ do
liftIO . putStrLn $ "Position " ++ show n ++ " is already full."
doMove
-- a random AI,
-- also demonstrates how to use a custom StateT on top
-- of the Player monad
playerAI :: Monad m => StdGen -> Player m ()
playerAI = evalStateT ai
where
ai :: Monad m => StateT StdGen (ProgramT PlayerI m) ()
ai = forever $ do
board <- lift $ readBoard
n <- uniform (possibleMoves board) -- select a random move
lift $ playMove n
where
-- select one element at random
uniform :: Monad m => [a] -> StateT StdGen m a
uniform xs = do
gen <- get
let (n,gen') = randomR (1,length xs) gen
put gen'
return (xs !! (n-1))
|
