Haskell Quiz/Yahtzee/Solution Burton
< 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.
Accepts 2 players only. Computer player heuristic described in the comment by the function `shakeai'. In 20 computer vs. computer games the average score was 185.
module Main
where
import Random
import IO
import Foreign
import Maybe
import Data.Ord
import List
import Char
import Monad
data Round = Ones | Twos | Threes | Fours | Fives | Sixes | ThreeOfAKind
| FourOfAKind | FullHouse | LowStraight | HighStraight | Chance | Yahtzee
deriving (Show, Eq, Enum)
type Turn = Either Round [Int] --either the round to score these dice against or a list of die locations to roll again
data Die = N | D1 | D2 | D3 | D4 | D5 | D6 deriving Eq
instance Ord Die where
d <= d' = fromEnum d <= fromEnum d'
instance Show Die where show = show . fromEnum
instance Enum Die where
toEnum n = case n of
1 -> D1
2 -> D2
3 -> D3
4 -> D4
5 -> D5
6 -> D6
_ -> N
fromEnum d = case d of
D1 -> 1
D2 -> 2
D3 -> 3
D4 -> 4
D5 -> 5
D6 -> 6
_ -> 0
type Cup = (Die, Die, Die, Die, Die) --black, plastic, with imitation stitches round the top
type ScoreCard = [(Round, Maybe Cup)]
type Name = String
data Player = Human ScoreCard Name | Computer ScoreCard Name
scorecard :: Player -> ScoreCard
scorecard (Human sc n) = sc
scorecard (Computer sc n) = sc
name :: Player -> Name
name (Human sc n) = n
name (Computer sc n) = n
done, dtwo, dthree, dfour, dfive :: Cup -> Die
done (a, b, c, d, e) = a
dtwo (a, b, c, d, e) = b
dthree (a, b, c, d, e) = c
dfour (a, b, c, d, e) = d
dfive (a, b, c, d, e) = e
dmap :: (Die -> a) -> Cup -> [a]
dmap f = map f . dlist
dfilter :: (Die -> Bool) -> Cup -> [Die]
dfilter f = filter f . dlist
dlist :: Cup -> [Die]
dlist (a, b, c, d, e) = a:b:c:d:e:[]
dsum :: Cup -> Int
dsum = sum . dmap fromEnum
--position of first occurence of x
delemIndex :: Die -> Cup -> Maybe Int
delemIndex x (a, b, c, d, e) | x == a = Just 1
| x == b = Just 2
| x == c = Just 3
| x == d = Just 4
| x == e = Just 5
| otherwise = Nothing
--positions of first occurences of (x:xs) in cup
delemIndices :: [Die] -> Cup -> [Int]
delemIndices l c = map (fromJust . (`delemIndex` c)) l
--true if this round isn't taken in the scorecard
isFree :: Round -> ScoreCard -> Bool
isFree = curry (isNothing . fromJust . uncurry lookup)
score :: Round -> Cup -> Int
score Ones c = sum $ map fromEnum $ dfilter (==D1) c
score Twos c = sum $ map fromEnum $ dfilter (==D2) c
score Threes c = sum $ map fromEnum $ dfilter (==D3) c
score Fours c = sum $ map fromEnum $ dfilter (==D4) c
score Fives c = sum $ map fromEnum $ dfilter (==D5) c
score Sixes c = sum $ map fromEnum $ dfilter (==D6) c
score Chance c = dsum c
score ThreeOfAKind c = if haseq 3 c then dsum c else 0
score FourOfAKind c = if haseq 4 c then dsum c else 0
score FullHouse c = if elem 2 gs && elem 3 gs then 25 else 0
where gs = groups c
score LowStraight c = if hasrun 3 c then 30 else 0
score HighStraight c = if hasrun 4 c then 40 else 0
score Yahtzee c = if haseq 5 c then 50 else 0
--true if this cup contain a score for this round
fits :: Round -> Cup -> Bool
fits = curry ((/=0) . uncurry score)
uiflags :: [(String, Round)]
uiflags = [("3K", ThreeOfAKind),
("4K", FourOfAKind),
("1", Ones),
("2", Twos),
("3", Threes),
("4", Fours),
("5", Fives),
("6", Sixes),
("C", Chance),
("F", FullHouse),
("L", LowStraight),
("H", HighStraight),
("Y", Yahtzee)]
haseq :: Int -> Cup -> Bool
haseq n = (>=n) . maximum . groups
groups :: Cup -> [Int]
groups = map length . dgroup
dgroup :: Cup -> [[Die]]
dgroup = sortBy (comparing length) . group . sort . dlist
hasrun :: Int -> Cup -> Bool
hasrun n c = not (null rs) && (maximum $ map length $ rs) >= 0
where rs = runs c
runs :: Cup -> [[Die]]
runs = filter ((>1) . length) . map takeInSeq . tails . sort . dlist
--return the list of locations of dice in a cup which are not in the longest sequence
notinlongestrun :: Cup -> [Int]
notinlongestrun c = delemIndices (del1 lrun $ dlist c) c
where lrun = head $ runs c
--delete one occurence of each of xs from ys
del1 [] ys = ys
del1 xs [] = []
del1 (x:xs) ys = del1 xs (delete x ys)
--return the list of locations of dice in a cup which are not in any sequence
notinrun :: Cup -> [Int]
notinrun c = delemIndices (del1 rs $ dlist c) c
where rs = concat $ filter ((>1) . (length)) $ runs c
takeInSeq :: Enum a => [a] -> [a]
takeInSeq [] = []
takeInSeq [x] = [x]
takeInSeq (x:y:xs) | fromEnum (succ x) == fromEnum y = x : takeInSeq (y:xs)
| otherwise = takeInSeq (x:xs)
dset :: Cup -> Int -> Die -> Cup
dset c 1 d = (d, dtwo c, dthree c, dfour c, dfive c)
dset c 2 d = (done c, d, dthree c, dfour c, dfive c)
dset c 3 d = (done c, dtwo c, d, dfour c, dfive c)
dset c 4 d = (done c, dtwo c, dthree c, d, dfive c)
dset c 5 d = (done c, dtwo c, dthree c, dfour c, d)
dset _ _ _ = error "dset - Illegal dice arg"
scround :: Round -> ScoreCard -> (Round, Maybe Cup)
scround r sc = (r, fromJust $ lookup r sc)
emptysc :: ScoreCard
emptysc = [(r, Nothing) | r <- [Ones .. Yahtzee]]
emptycup :: Cup
emptycup = (N, N, N, N, N)
--get total value of a scorecard, including 35 point bonus if top half of
--scorecard scores more than 62, and scoring extra yahtzees as 100
total :: ScoreCard -> Int
total sc = ybonus + bonus + (sum $ map snd scores)
where scores = [(r, score r (fromJust d)) | (r, d) <- sc]
bonus = if (sum $ map (snd) $ take 6 scores) > 62 then 35 else 0
ybonus = if (fromJust $ lookup Yahtzee scores) == 50
then sum $ map yscore $ init sc
else 0
yscore (r, d) = if score Yahtzee (fromJust d) == 50
then 100-(score r (fromJust d))
else 0
showcup :: Cup -> String
showcup c = (show $ done c)++" "++(show $ dtwo c)++" "++(show $ dthree c) ++ " "++(show $ dfour c)
++" "++(show $ dfive c)
readints :: String -> [Int]
readints = map digitToInt . filter isDigit
showcard :: ScoreCard -> String
showcard = unwords . map
(\(r, c) -> case c of
Nothing -> show r ++ " [-]"
Just x -> show r ++ " ["++show (score r x) ++ "]")
updatesc :: ScoreCard -> Cup -> Round -> ScoreCard
updatesc sc c r = top ++ [(r, Just c)] ++ (tail rest)
where (top, rest) = break ((==r) . (fst)) sc
--trim and capitalise
clean :: String -> String
clean = map toUpper . reverse . dropWhile isSpace . reverse . dropWhile isSpace
{-- IO --}
--finish the game
end :: Player -> Player -> IO ()
end p1 p2 = do putStrLn ("Player 1> "++showcard (scorecard p1))
putStrLn ("Player 1 scored "++(show t1))
putStrLn ("Player 2> "++showcard (scorecard p2))
putStrLn ("Player 2 scored "++(show t2))
if t1 < t2
then putStrLn "Player 2 wins"
else if t1 > t2 then putStrLn "Player 1 wins" else putStrLn "Draw"
where t1 = total $ scorecard p1
t2 = total $ scorecard p2
--take a move, made up of 1-3 shakes
move :: Player -> IO Player
move p = do putStrLn $ name p
putStrLn $ showcard $ scorecard p
case p of
(Human sc n) -> do sc' <- shake sc 0 emptycup n [1 .. 5]
return (Human sc' n)
(Computer sc n) -> do sc' <- shakeai sc 0 emptycup [1 .. 5]
return (Computer sc' n)
--shake a cup, only the locations in the list (x:xs)
shakecup :: Cup -> [Int] -> IO Cup
shakecup = foldM shakecup'
where shakecup' c x = do y <- rolldie
return (dset c x y)
rolldie :: IO Die
rolldie = do x <- getStdRandom (randomR (1,6))
return $ [N .. D6]!!x
{--
Heuristics for computer turns. Words in *Asterisks* are rounds to score these dice against,
except *Lowest* and *BestThrees* which are subroutines described below
Roll Dice
IF dice match *Yahtzee* THEN
IF *Yahtzee* is free THEN *Yahtzee*
ELSE *Lowest*
ELSE IF dice match *FourOfAKind*
IF Can Throw Again THEN throw the die which isn't in the matching set again
ELSE IF *Chance* > 20 THEN *Chance*
ELSE *BestThrees*
ELSE IF dice match *ThreeOfAKind*
IF dice match *FullHouse* THEN *FullHouse*
ELSE IF can throw again THEN throw the dice which aren't in the matching set again
ELSE *BestThrees*
ELSE IF dice match *HighStraight* THEN *HighStraight*
ELSE IF dice match *LowStraight*
IF *HighStraight* is free and can Throw Again THEN throw the dice which aren't in the run again
ELSE *LowStraight*
ELSE IF Can Throw Again THEN throw the die which aren't in the longest sequence again
ELSE *BestThrees*
BestThrees: Pick the best available 'Threes' (ie *Ones* to *Sixes* + *ThreeOfAKind*)
IF longest matching set has a 6 and *Sixes* is free THEN *Sixes*
...
ELSE IF longest matching set has a 1 and *Ones* is free THEN *Ones*
ELSE IF *ThreeOfAKind* is free THEN *ThreeOfAKind*
ELSE IF *Yahtzee* is free and there are less than 3 moves left THEN *Yahtzee*
ELSE IF *Chance* is free THEN *Chance*
ELSE IF *FourOfAKind* is free THEN *FourOfAKind*
ELSE *Lowest*
Lowest : Pick the lowest value evailable slot
IF *Ones* is free THEN *Ones*
...
ELSE IF *Yahtzee* is free then *Yahtzee*
--}
shakeai :: ScoreCard -> Int -> Cup -> [Int] -> IO ScoreCard
shakeai sc i c xs = do c' <- shakecup c xs
putStrLn ("Computer rolled " ++ (showcup c'))
gs <- return (dgroup c')
case length $ head gs of
5 -> return $ updatesc sc c' yorlowest
4 -> if i < 2
then shakeai sc (i+1) c' $ delemIndices (concat $ tail gs) c'
else if isFree FourOfAKind sc
then return $ updatesc sc c' FourOfAKind
else if isFree Chance sc && score Chance c' > 20
then return $ updatesc sc c' Chance
else return $ updatesc sc c' (highest3s (head gs))
3 -> if isFree FullHouse sc && (length $ head $ tail gs) == 2
then return $ updatesc sc c' FullHouse
else if i < 2
then shakeai sc (i+1) c' (notinrun c')
else return $ updatesc sc c' (highest3s (head gs))
_ -> if isFree HighStraight sc && fits HighStraight c'
then return $ updatesc sc c' HighStraight
else if isFree LowStraight sc && fits LowStraight c'
then if isFree HighStraight sc && i < 2
then shakeai sc (i+1) c' (notinlongestrun c') --roll dice not in sequence again
else return $ updatesc sc c' LowStraight
else if i < 2
then shakeai sc (i+1) c' $ delemIndices (concat $ tail gs) c'
else return $ updatesc sc c' (highest3s (head gs))
where highest3s xs | elem D6 xs && isFree Sixes sc = Sixes
| elem D5 xs && isFree Fives sc = Fives
| elem D4 xs && isFree Fours sc = Fours
| elem D3 xs && isFree Threes sc = Threes
| elem D2 xs && isFree Twos sc = Twos
| elem D1 xs && isFree Ones sc = Ones
| isFree ThreeOfAKind sc = ThreeOfAKind
| otherwise = scratch
yorlowest = if isFree Yahtzee sc
then Yahtzee
else lowest
lowest = head $ dropWhile (not . flip isFree sc) [Ones .. Yahtzee]
scratch = if isFree Yahtzee sc && length (filter (isNothing . snd) sc) > 10
then Yahtzee
else if isFree Chance sc
then Chance
else if isFree FourOfAKind sc
then FourOfAKind
else lowest
shake :: ScoreCard -> Int -> Cup -> String -> [Int] -> IO ScoreCard
shake sc i c n xs = do c' <- shakecup c xs
putStrLn $ showcup c'
if i == 2
then do x <- confirm1 n
r <- parseR x
newround c' r
else do x <- confirm2 n
t <- parse x
either (shake sc (i+1) c' n) (newround c') t
where newround e r = if isNothing (snd $ scround r sc)
then return $ updatesc sc e r
else do putStrLn ((show r)++" is taken.")
shake sc i e n []
--get some input matching an element from a list of legal values
getInp, getInp2 :: String -> String -> [String] -> IO String
getInp s n ss = do putStrLn s
putStr (n++"> ")
x <- getLine
let x' = clean x
if elem x' ss then return x' else getInp s n ss
getInp2 s n ss = do putStrLn s
putStr (n++"> ")
x <- getLine
let x' = clean x
if reroll x' || elem x' ss
then return x'
else getInp s n ss
where reroll ('R':' ':xs) = True
reroll _ = False
confirm1, confirm2 :: String -> IO String
confirm1 n = getInp "Enter round to use these dice for" n moveinp
confirm2 n = getInp2 "Enter round to use these dice for or R [nums] to roll dice again" n moveinp
moveinp :: [String]
moveinp = map fst uiflags
--take a string into a list of die locations to roll again or a round to score against
parse :: String -> IO (Either [Int] Round)
parse ('R':' ':xs) = return (Left $ readints xs)
parse str = do r <- parseR str
return (Right r)
--take a string into a round to score against
parseR :: String -> IO Round
parseR = return . fromJust . flip lookup uiflags
--let each player take 13 moves
playgame :: Player -> Player -> IO ()
playgame = takemoves 0
where takemoves n p1 p2 | n < 13 = do p1' <- move p1
p2' <- move p2
takemoves (n+1) p1' p2'
| otherwise = end p1 p2
main = do putStrLn "Yahtzee!"
x1 <- getInp "Enter type for Player 1 [h - human, c - computer]" "" hc
x2 <- getInp "Enter type for Player 2 [h - human, c - computer]" "" hc
playgame (getplayer x1 "Player 1") (getplayer x2 "Player 2")
where hc = ["H", "C"]
getplayer "H" n = Human emptysc n
getplayer _ n = Computer emptysc n