Personal tools

Haskell Quiz/Yahtzee/Solution Burton

From HaskellWiki

< Haskell Quiz | Yahtzee(Difference between revisions)
Jump to: navigation, search
(added my solution)
 
m
 
(4 intermediate revisions by 3 users not shown)
Line 1: Line 1:
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.
+
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.
   
[[Category:Code]]
+
[[Category:Haskell Quiz solutions|Yahtzee]]
   
 
<haskell>
 
<haskell>
Line 10: Line 10:
 
import Foreign
 
import Foreign
 
import Maybe
 
import Maybe
  +
import Data.Ord
 
import List
 
import List
 
import Char
 
import Char
  +
import Monad
   
 
data Round = Ones | Twos | Threes | Fours | Fives | Sixes | ThreeOfAKind
 
data Round = Ones | Twos | Threes | Fours | Fives | Sixes | ThreeOfAKind
Line 77: Line 79:
 
--positions of first occurences of (x:xs) in cup
 
--positions of first occurences of (x:xs) in cup
 
delemIndices :: [Die] -> Cup -> [Int]
 
delemIndices :: [Die] -> Cup -> [Int]
delemIndices [] c = []
+
delemIndices l c = map (fromJust . (`delemIndex` c)) l
delemIndices (x:xs) c = fromJust (delemIndex x c) : delemIndices xs c
 
 
--true if this round isn't taken in the scorecard
 
--true if this round isn't taken in the scorecard
 
isFree :: Round -> ScoreCard -> Bool
 
isFree :: Round -> ScoreCard -> Bool
Line 124: Line 126:
   
 
dgroup :: Cup -> [[Die]]
 
dgroup :: Cup -> [[Die]]
dgroup = sortBy (\a b -> if length a > length b then LT else GT) . group . sort . dlist
+
dgroup = sortBy (comparing length) . group . sort . dlist
   
 
hasrun :: Int -> Cup -> Bool
 
hasrun :: Int -> Cup -> Bool
hasrun n c = if null rs then False else (maximum $ map length $ rs) >= 0
+
hasrun n c = not (null rs) && (maximum $ map length $ rs) >= 0
 
where rs = runs c
 
where rs = runs c
   
Line 187: Line 189:
   
 
readints :: String -> [Int]
 
readints :: String -> [Int]
readints = map (read . (:[])) . filter isDigit
+
readints = map digitToInt . filter isDigit
   
 
showcard :: ScoreCard -> String
 
showcard :: ScoreCard -> String
showcard = concat . intersperse " " . map
+
showcard = unwords . map
(\(r, c) -> if isNothing c
+
(\(r, c) -> case c of
then (show r ++ " [-]")
+
Nothing -> show r ++ " [-]"
else (show r ++ " ["++show (score r (fromJust c)) ++ "]"))
+
Just x -> show r ++ " ["++show (score r x) ++ "]")
   
 
updatesc :: ScoreCard -> Cup -> Round -> ScoreCard
 
updatesc :: ScoreCard -> Cup -> Round -> ScoreCard
Line 229: Line 231:
 
--shake a cup, only the locations in the list (x:xs)
 
--shake a cup, only the locations in the list (x:xs)
 
shakecup :: Cup -> [Int] -> IO Cup
 
shakecup :: Cup -> [Int] -> IO Cup
shakecup c [] = return c
+
shakecup = foldM shakecup'
shakecup c (x:xs) = do y <- rolldie
+
where shakecup' c x = do y <- rolldie
c' <- return (dset c x y)
+
return (dset c x y)
shakecup c' xs
 
 
 
 
rolldie :: IO Die
 
rolldie :: IO Die
Line 238: Line 240:
   
 
{--
 
{--
Heuristics for computer turns:
+
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
 
Roll Dice
IF dice match *Yahtzee* THEN *Yahtzee*
+
IF dice match *Yahtzee* THEN
  +
IF *Yahtzee* is free THEN *Yahtzee*
  +
ELSE *Lowest*
 
ELSE IF dice match *FourOfAKind*
 
ELSE IF dice match *FourOfAKind*
 
IF Can Throw Again THEN throw the die which isn't in the matching set again
 
IF Can Throw Again THEN throw the die which isn't in the matching set again
Line 264: Line 266:
 
ELSE IF *Chance* is free THEN *Chance*
 
ELSE IF *Chance* is free THEN *Chance*
 
ELSE IF *FourOfAKind* is free THEN *FourOfAKind*
 
ELSE IF *FourOfAKind* is free THEN *FourOfAKind*
ELSE IF *Ones* is free THEN *Ones*
+
ELSE *Lowest*
  +
  +
Lowest : Pick the lowest value evailable slot
  +
IF *Ones* is free THEN *Ones*
 
...
 
...
 
ELSE IF *Yahtzee* is free then *Yahtzee*
 
ELSE IF *Yahtzee* is free then *Yahtzee*
 
   
 
--}
 
--}
Line 307: Line 308:
 
yorlowest = if isFree Yahtzee sc
 
yorlowest = if isFree Yahtzee sc
 
then Yahtzee
 
then Yahtzee
else scratch
+
else lowest
  +
lowest = head $ dropWhile (not . flip isFree sc) [Ones .. Yahtzee]
 
scratch = if isFree Yahtzee sc && length (filter (isNothing . snd) sc) > 10
 
scratch = if isFree Yahtzee sc && length (filter (isNothing . snd) sc) > 10
 
then Yahtzee
 
then Yahtzee
Line 314: Line 315:
 
else if isFree FourOfAKind sc
 
else if isFree FourOfAKind sc
 
then FourOfAKind
 
then FourOfAKind
else head $ dropWhile (not . (flip isFree) sc) [Ones .. Yahtzee]
+
else lowest
   
 
shake :: ScoreCard -> Int -> Cup -> String -> [Int] -> IO ScoreCard
 
shake :: ScoreCard -> Int -> Cup -> String -> [Int] -> IO ScoreCard
Line 336: Line 337:
 
putStr (n++"> ")
 
putStr (n++"> ")
 
x <- getLine
 
x <- getLine
x' <- return (clean x)
+
let x' = clean x
 
if elem x' ss then return x' else getInp s n ss
 
if elem x' ss then return x' else getInp s n ss
 
getInp2 s n ss = do putStrLn s
 
getInp2 s n ss = do putStrLn s
 
putStr (n++"> ")
 
putStr (n++"> ")
 
x <- getLine
 
x <- getLine
x' <- return (clean x)
+
let x' = clean x
 
if reroll x' || elem x' ss
 
if reroll x' || elem x' ss
 
then return x'
 
then return x'
Line 362: Line 363:
 
--take a string into a round to score against
 
--take a string into a round to score against
 
parseR :: String -> IO Round
 
parseR :: String -> IO Round
parseR = return . fromJust . ((flip lookup) uiflags)
+
parseR = return . fromJust . flip lookup uiflags
   
 
--let each player take 13 moves
 
--let each player take 13 moves
 
playgame :: Player -> Player -> IO ()
 
playgame :: Player -> Player -> IO ()
 
playgame = takemoves 0
 
playgame = takemoves 0
where takemoves n p1 p2 = if n < 13
+
where takemoves n p1 p2 | n < 13 = do p1' <- move p1
then do p1' <- move p1
+
p2' <- move p2
p2' <- move p2
+
takemoves (n+1) p1' p2'
takemoves (n+1) p1' p2'
+
| otherwise = end p1 p2
else end p1 p2
 
   
 
main = do putStrLn "Yahtzee!"
 
main = do putStrLn "Yahtzee!"
Line 377: Line 378:
 
playgame (getplayer x1 "Player 1") (getplayer x2 "Player 2")
 
playgame (getplayer x1 "Player 1") (getplayer x2 "Player 2")
 
where hc = ["H", "C"]
 
where hc = ["H", "C"]
getplayer t n = if t == "H" then (Human emptysc n) else (Computer emptysc n)
+
getplayer "H" n = Human emptysc n
  +
getplayer _ n = Computer emptysc n
  +
  +
 
</haskell>
 
</haskell>

Latest revision as of 00:18, 22 February 2010

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