Haskell Quiz/Yahtzee/Solution Burton
< Haskell Quiz | Yahtzee
Jump to navigation
Jump to search
Accepts 2 players only. Computer player uses a 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 List
import Char
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 [] c = []
delemIndices (x:xs) c = fromJust (delemIndex x c) : delemIndices xs c
--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 (\a b -> if length a > length b then LT else GT) . group . sort . dlist
hasrun :: Int -> Cup -> Bool
hasrun n c = if null rs then False else (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 (read . (:[])) . filter isDigit
showcard :: ScoreCard -> String
showcard = concat . intersperse " " . map
(\(r, c) -> if isNothing c
then (show r ++ " [-]")
else (show r ++ " ["++show (score r (fromJust c)) ++ "]"))
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 c [] = return c
shakecup c (x:xs) = do y <- rolldie
c' <- return (dset c x y)
shakecup c' xs
rolldie :: IO Die
rolldie = do x <- getStdRandom (randomR (1,6))
return $ [N .. D6]!!x
{--
Heuristics for computer turns:
Roll Dice
IF dice match *Yahtzee* THEN *Yahtzee*
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 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 scratch
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 head $ dropWhile (not . (flip isFree) sc) [Ones .. Yahtzee]
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
x' <- return (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
x' <- return (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 = if n < 13
then do p1' <- move p1
p2' <- move p2
takemoves (n+1) p1' p2'
else 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 t n = if t == "H" then (Human emptysc n) else (Computer emptysc n)