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 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
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)

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. 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
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')
_ -> 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'
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
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)
```