Haskell Quiz/Yahtzee/Solution Burton

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