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: