Haskell Quiz/Yahtzee/Solution Bobstopper
< Haskell Quiz | Yahtzee
Jump to navigation
Jump to search
The printable version is no longer supported and may have rendering errors. Please update your browser bookmarks and please use the default browser print function instead.
This is a bit longer than the ruby solution but is a bit more featureful.
import Control.Arrow (first, second, (&&&))
import Control.Monad
import Control.Monad.State
import Data.List
import Data.Maybe
import qualified Data.Map as Map
import System.Exit
import System.Random
-- Possible values of a 6 sided dice roll
data DiceRoll = One | Two | Three | Four | Five | Six
deriving (Eq, Ord, Enum, Bounded, Show)
value = (1+) . fromEnum
-- Some Random Utilities
instance Random DiceRoll where
randomR (min,max) g = first toEnum $ randomR (fromEnum min,fromEnum max) g
random = randomR (minBound,maxBound)
randomIOs :: Random a => IO [a]
randomIOs = fmap randoms newStdGen
rollDice = randomIO :: IO DiceRoll
-- Generates n random dice
rollNDice :: Int -> IO [DiceRoll]
rollNDice n = (take n) `fmap` randomIOs
-- reRollDice ns dice returns a new set of dice with dices at positions
-- given by ns replaced with newly generated dice
reRollDice :: [Int] -> [DiceRoll] -> IO [DiceRoll]
reRollDice [] dice = return dice
reRollDice (n:ns) dice = do
next <- fmap (replace dice n) $ rollDice
reRollDice ns next
replace :: [a] -> Int -> a -> [a]
replace xs i x = (take i xs) ++ [x] ++ (drop (i+1) xs)
-- Scoring logic
-- Yahtzee categories which can be scored against
data Category = Ones | Twos | Threes | Fours | Fives | Sixes
| ThreeOfAKind | FourOfAKind | FullHouse
| SmallStraight | LargeStraight | Chance | Yahtzee
deriving (Show, Read, Ord, Eq)
-- Small Mapping just for counting
type Count = Map.Map DiceRoll Int
initCount = Map.fromAscList [ (One, 0), (Two, 0), (Three, 0)
, (Four, 0), (Five, 0), (Six, 0)]
-- Count how many of each DiceRoll there is in a hand
countDice :: [DiceRoll] -> Count
countDice = foldr (Map.adjust (+1)) initCount
-- Count how many of a specific DiceRoll there is in a hand
numberMatching :: DiceRoll -> [DiceRoll] -> Int
numberMatching = (length .) . filter . (==)
-- Test if a list is ascending incrementally
isStraight :: (Bounded a, Enum a, Eq a) => [a] -> Bool
isStraight [] = True
isStraight xs = and $ zipWith isSucc xs (tail xs)
where isSucc x y | x == maxBound = False
| otherwise = y == succ x
-- Determine a hand's score against a specific category
score :: [DiceRoll] -> Category -> Int
score dice Ones = numberMatching One dice
score dice Twos = (numberMatching Two dice) * 2
score dice Threes = (numberMatching Three dice) * 3
score dice Fours = (numberMatching Four dice) * 4
score dice Fives = (numberMatching Five dice) * 5
score dice Sixes = (numberMatching Six dice) * 6
score dice ThreeOfAKind | Map.null $ Map.filter (>=3) $ countDice dice = 0
| otherwise = sum (map value dice)
score dice FourOfAKind | Map.null $ Map.filter (>=4) $ countDice dice = 0
| otherwise = sum (map value dice)
score dice Yahtzee | Map.null $ Map.filter (==5) $ countDice dice = 0
| otherwise = 50
score dice FullHouse | Map.size gt2 == 1 && head (Map.elems gt2) == 5 = 25
| Map.size gt2 == 2
&& (not $ Map.null $ Map.filter (==3) gt2)
= 25
| otherwise = 0
where gt2 = Map.filter (>=2) $ countDice dice
score dice SmallStraight | (isStraight $ tail $ sort dice)
|| (isStraight $ take 4 $ sort dice) = 30
| otherwise = 0
score dice LargeStraight | isStraight $ sort dice = 40
| otherwise = 0
score dice Chance = sum $ map value dice
-- The Game Logic
type PlayerName = String
type PlayerTotal = (PlayerName, Int)
type ScoreCard = Map.Map Category (Maybe Int)
maxReRolls = 2
-- An initial score with all categories unscored
clearScore = Map.fromAscList [ (Ones, Nothing), (Twos, Nothing)
, (Threes, Nothing), (Fours, Nothing)
, (Fives, Nothing), (Sixes, Nothing)
, (ThreeOfAKind, Nothing), (FourOfAKind, Nothing)
, (FullHouse, Nothing), (SmallStraight, Nothing)
, (LargeStraight, Nothing), (Chance, Nothing)
, (Yahtzee, Nothing) ]
data GameState = GameState { playerQueue :: [ PlayerName ]
, players :: Map.Map PlayerName ScoreCard
, reRolls :: Int }
-- Generate a new game using the player names given
newGame :: [PlayerName] -> GameState
newGame [] = error "Need to define at least one player"
newGame ps = GameState { playerQueue = cycle ps
, players = Map.fromList $ zip ps (repeat clearScore)
, reRolls = maxReRolls }
-- Change a specific player's score by scoring the given hand against
-- the given category
adjustScore :: PlayerName -> Category -> [DiceRoll] -> GameState -> GameState
adjustScore n c ds g = g { players =
Map.adjust (adjustCategory c (score ds c))
n (players g) }
-- Adjust the score for a specific category in a scorecard
adjustCategory :: Category -> Int -> ScoreCard -> ScoreCard
adjustCategory Yahtzee x s = Map.adjust (maybe (Just 50) (Just . (+x)))
Yahtzee s
adjustCategory c x s = Map.adjust (maybe (Just x)
(error "Category already used"))
c s
currentPlayer :: GameState -> PlayerName
currentPlayer = head . playerQueue
-- Get the current scorecard of the given player
playerScore :: PlayerName -> GameState -> ScoreCard
playerScore n g = Map.findWithDefault err n (players g)
where err = error $ "Couldn't find Player " ++ n ++ " in game!"
-- Get the current scorecard for the current player
currentPlayerScore :: GameState -> ScoreCard
currentPlayerScore g = playerScore (currentPlayer g) g
-- Uses up one of the available rerolls
useReRoll :: GameState -> GameState
useReRoll g = g { reRolls = (reRolls g)-1 }
-- Reset the game for the next player
newRound :: GameState -> GameState
newRound g = g { reRolls = maxReRolls
, playerQueue = tail $ playerQueue g }
-- Returns the number of rounds in a game
gameLength :: GameState -> Int
gameLength = (13*) . Map.size . players
-- Look up the score of the given category from a scorecard
category :: Category -> ScoreCard -> Maybe Int
category c s = Map.findWithDefault err c s
where err = error $ "Couldn't find Category " ++ (show c) ++
" in player's score!"
-- Determines whether it is ok to place a score against the category
-- This function should always be used prior to scoring a category
categoryOK :: Category -> ScoreCard -> Bool
categoryOK Yahtzee _ = True
categoryOK c s = isNothing $ category c s
-- Calculates the "upper" total of the scorecard
scoreUpper :: ScoreCard -> Int
scoreUpper s = sum $ mapMaybe ((flip category) s)
[Ones,Twos,Threes,Fours,Fives,Sixes]
-- Calculates the "lower" total of the scorecard
scoreLower :: ScoreCard -> Int
scoreLower s = sum $ mapMaybe ((flip category) s)
[ ThreeOfAKind, FourOfAKind, FullHouse
, SmallStraight, LargeStraight, Yahtzee, Chance ]
-- Calculates the grand total of the scorecard
scoreTotal :: ScoreCard -> Int
scoreTotal = (uncurry (+)) . (scoreUpper &&& scoreLower)
-- Data structure to account for draws as well as outright winners
data GameOutcome = Winner PlayerTotal | Draw [PlayerTotal]
-- Determines the winner between two players
winner :: PlayerTotal -> GameOutcome -> GameOutcome
winner y (Winner x) | (snd x) > (snd y) = Winner x
| (snd x) < (snd y) = Winner y
| otherwise = Draw [x,y]
winner y (Draw xs@(x:_)) | (snd x) > (snd y) = Draw xs
| (snd x) < (snd y) = Winner y
| otherwise = Draw $ y:xs
-- Score printing utilities
-- Prints the player's score
printScore :: PlayerName -> Yahtzee ()
printScore p = do
score <- gets (playerScore p)
liftIO $ print score
-- Prints the player's final score totals
printFinalScore :: PlayerName -> ScoreCard -> IO ()
printFinalScore n s = do
putStrLn $ "*** Final Score for " ++ n ++ " ***"
putStrLn $ "Lower Score: " ++ (show $ scoreLower s)
putStrLn $ "Upper Score: " ++ (show $ scoreUpper s)
newline
putStrLn $ "TOTAL Score: " ++ (show $ scoreTotal s)
-- Print the overall winner(s) and their score(s)
printWinner :: GameOutcome -> IO ()
printWinner (Winner (n,s)) =
putStrLn $ n++ " is the winner with " ++ (show s) ++ "!"
printWinner (Draw ws) = do
putStrLn "The game is a Draw!"
mapM_ (\(n,s) -> putStrLn $ n++ "with " ++ (show s)) ws
-- The Interface
-- Valid user input types
data Input = Accept Category | ShowScore | ReRoll [Int] | ReRollAll
| Quit | Help | CategoryHelp
deriving Read
-- The game monad
type Yahtzee a = StateT GameState IO a
newline = putStrLn ""
-- Persists in asking the given question until a valid answer is given.
-- Valid answers are determined and returned by the given function
ask :: String -> (String -> Maybe a) -> IO a
ask question f = do
putStr (question ++ "> ")
x <- fmap f getLine
case x of
(Just answer) -> return answer
Nothing -> putStrLn "Invalid input. Try again" >> ask question f
-- Attempts to read a string. Returns Nothing if it fails
maybeRead :: Read a => String -> Maybe a
maybeRead s = listToMaybe r >>= fst
where r = reads s
-- The Game start and completion
main :: IO ()
main = do
playerNames <- getPlayerNames
let game = newGame playerNames
gameOver <- execStateT (replicateM_ (gameLength game) playerUp) game
let scores = Map.toList $ players gameOver
mapM_ (uncurry printFinalScore) scores
let topScore = foldr winner (Winner ("Nobody",0))
(map (second scoreTotal) scores)
printWinner topScore
-- Ask for each player names until a blank line is reached
getPlayerNames :: IO [PlayerName]
getPlayerNames = do
name <- ask "Enter player name (blank line to finish)" Just
if null name
then return []
else fmap (name:) getPlayerNames
-- Start a round for the next player
playerUp :: Yahtzee ()
playerUp = do
player <- gets currentPlayer
liftIO $ newline
liftIO $ putStrLn "Next Round"
liftIO $ newline
printScore player
liftIO $ newline
liftIO $ putStrLn $ player ++ ", you're up!"
(liftIO $ rollNDice 5) >>= userAction
modify newRound
-- Interact with the user during the round
userAction :: [DiceRoll] -> Yahtzee ()
userAction dice = do
liftIO $ putStrLn $ "Your roll is " ++ (show dice)
input <- liftIO $ ask "Input Action (type Help for help)" maybeRead
processInput input dice
-- Process a user's input
processInput :: Input -> [DiceRoll] -> Yahtzee ()
processInput (Accept c) ds = do
player <- gets currentPlayer
playerScore <- gets $ playerScore player
if categoryOK c playerScore
then do modify $ adjustScore player c ds
printScore player
else do (liftIO $ putStrLn ("Category " ++ (show c) ++ " already used"))
userAction ds
processInput ShowScore ds = gets currentPlayer >>= printScore >> userAction ds
processInput (ReRoll is) ds = maybeReRoll ds $
modify useReRoll >> (liftIO $ reRollDice is ds)
processInput ReRollAll ds = maybeReRoll ds $
modify useReRoll >> (liftIO $ rollNDice 5)
processInput Quit _ = liftIO $ exitWith ExitSuccess
processInput Help ds = do
liftIO $ putStrLn "* Command List *"
liftIO $ putStrLn "Accept category: Accept this roll and score against category"
liftIO $ putStrLn "Score: Print your current score"
liftIO $ putStrLn "ReRoll indexes: reroll the dice specified by the Haskell list of Ints in indexes"
liftIO $ putStrLn "ReRollAll: discard all dice and roll a fresh set"
liftIO $ putStrLn "Quit: Exit the game"
liftIO $ putStrLn "Help: Display this help"
liftIO $ putStrLn "CategoryHelp: Display available categories"
liftIO $ newline
userAction ds
processInput CategoryHelp ds = do
liftIO $ putStrLn "* Category List *"
liftIO $ putStrLn "Ones | Twos | Threes | Fours | Fives | Sixes"
liftIO $ putStrLn "| ThreeOfAKind | FourOfAKind | FullHouse"
liftIO $ putStrLn "| SmallStraight | LargeStraight | Yahtzee | Chance"
userAction ds
-- takes a current diceroll and a command to reroll.
-- Performs the reroll action only if the player has rerolls left.
-- Otherwise tells the player no rerolls are left
maybeReRoll :: [DiceRoll] -> Yahtzee [DiceRoll] -> Yahtzee ()
maybeReRoll dice cmd = do
nextRound <- gets ((<=0) . reRolls)
if nextRound
then (liftIO $ putStrLn "No rolls left. Accept a category") >>
userAction dice
else cmd >>= userAction