ghc-dup: 36c69dc6b419e9cf3255f2081437ce7fdc5036bd
1: -- Taken from http://web.cs.wpi.edu/~cs4536/c06/Assignments/Game.hs
2: -- Game.hs
3:
4: module Game(State, Player(PlayerA, PlayerB), otherPlayer, applyMove, initialState, getScore, nextStates, getPlayer, simulateGame, simulateGame2) where
5:
6: import System.IO
7:
8: data Player = PlayerA | PlayerB deriving Eq
9: data PlayerState = PlayerState Player Int [Int]
10: data State = State PlayerState PlayerState
11:
12: instance Show Player where
13: show PlayerA = "A"
14: show PlayerB = "B"
15:
16: instance Show PlayerState where
17: show (PlayerState player score pits) =
18: (show player) ++ ": " ++ (show score) ++ "; " ++ (show pits)
19:
20: instance Show State where
21: show s =
22: "(A " ++ (show (getScore PlayerA s)) ++ ") " ++ (show (reverse (getPits PlayerA s))) ++
23: "\n(B " ++ (show (getScore PlayerB s)) ++ ") " ++ (show (getPits PlayerB s))
24:
25: otherPlayer :: Player -> Player
26: otherPlayer PlayerA = PlayerB
27: otherPlayer PlayerB = PlayerA
28:
29: initialState :: Player -> State
30: initialState p =
31: State (PlayerState p 0 (replicate 6 4)) (PlayerState (otherPlayer p) 0 (replicate 6 4))
32:
33: getScore :: Player -> State -> Int
34: getScore p (State (PlayerState a sa _) (PlayerState b sb _)) =
35: if p == a then sa else sb
36:
37: getPits :: Player -> State -> [Int]
38: getPits p (State (PlayerState a _ pa) (PlayerState b _ pb)) =
39: if p == a then pa else pb
40:
41: getPlayer :: State -> Player
42: getPlayer (State (PlayerState p _ _) _) = p
43:
44: incStones :: PlayerState -> PlayerState
45: incStones p = distStones [1..6] p
46:
47: incStonesBy :: Int -> PlayerState -> PlayerState
48: incStonesBy n p = (iterate incStones p) !! n
49:
50: incScore :: Int -> PlayerState -> PlayerState
51: incScore i (PlayerState p s ps) = (PlayerState p (s + i) ps)
52:
53: distStones :: [Int] -> PlayerState -> PlayerState
54: distStones is (PlayerState p s ps) =
55: (PlayerState p s (map (\ (i, n) -> if (elem i is) then n + 1 else n) (zip (iterate (+ 1) 1) ps)))
56:
57: isWinningState :: State -> Bool
58: isWinningState (State (PlayerState _ a _) (PlayerState _ b _)) =
59: a >= 24 || b >= 24
60:
61: isMoveValid :: Int -> Bool
62: isMoveValid n = elem n [1..6]
63:
64: isMoveLegal :: State -> Int -> Bool
65: isMoveLegal _ n | not (isMoveValid n) = False
66: isMoveLegal s _ | (isWinningState s) = False
67: isMoveLegal s n = case s of
68: (State (PlayerState a sa pa) _) -> not $ (pa !! (n - 1)) == 0
69:
70: applyMove :: State -> Int -> Maybe State
71: applyMove s n | not (isMoveLegal s n) = Nothing
72: applyMove s n = Just (applyMove' s' p')
73: where
74: (s', p') = case s of
75: (State (PlayerState a sa pa) playerother) ->
76: ((State (PlayerState a sa (killPit pa)) playerother), pa !! (n - 1))
77:
78: killPit xs = (take (n - 1) xs) ++ [0] ++ (drop n xs)
79:
80: applyMove' (State a b) p =
81: let (rounds, extras) = divMod p 13
82: sinc = rounds + (if (6 - n) < extras then 1 else 0)
83: extras' = if n == 6
84: then extras - 1
85: else if null adist then 0 else extras - (last adist) + (head adist) - 2
86: extras'' = if null bdist then 0 else extras' - (last bdist) + (head bdist) - 1
87: adist = [i | i <- [(n + 1)..6], i - n <= extras]
88: bdist = [i | i <- [1..6], i <= extras']
89: adist' = [i | i <- [1..6], i <= extras'']
90: currP = ((incScore sinc) . (distStones adist) . (distStones adist') . (incStonesBy rounds) $ a)
91: otherP = ((distStones bdist) . (incStonesBy rounds) $ b) in
92: if extras == (6 - n + 1) then (State currP otherP) else (State otherP currP)
93: --(State otherP currP)
94:
95: nextStates :: State -> [State]
96: nextStates s = [s | (Just s) <- (map (applyMove s) [1..6])]
97:
98: simulateGame :: IO ()
99: simulateGame = simulateGame' (Just (initialState PlayerA)) where
100: simulateGame' Nothing = return ()
101: simulateGame' (Just (State (PlayerState p s ps) b)) =
102: do
103: print (State (PlayerState p s ps) b)
104: putStr ((show p) ++ ": ")
105: move <- getLine
106: move <- return (read move) :: IO (Int)
107: s' <- return (applyMove (State (PlayerState p s ps) b) move)
108: case s' of
109: Nothing -> putStr "ERROR\n"
110: (Just a) -> if (isWinningState a)
111: then putStr ((show p) ++ " wins!\n")
112: else simulateGame' s'
113: return ()
114:
115: simulateGame2 :: (State -> Int) -> IO ()
116: simulateGame2 chooseMove = simulateGame' (Just (initialState PlayerA)) where
117: simulateGame' Nothing = return ()
118: simulateGame' (Just state@(State (PlayerState p s ps) b)) =
119: do
120: print state
121: putStr ((show p) ++ ": ")
122: hFlush stdout
123: move <-
124: if p == PlayerB then
125: do move <- getLine
126: return (read move) :: IO (Int)
127: else
128: do let move = (chooseMove state)
129: print move
130: return move
131: s' <- return (applyMove (State (PlayerState p s ps) b) move)
132: case s' of
133: Nothing ->
134: do putStr "ERROR\n"
135: simulateGame' (Just state)
136: (Just a) -> if (isWinningState a)
137: then putStr ((show p) ++ " wins!\n")
138: else simulateGame' s'
139: return ()
140:
Generated by git2html.