hand comparer

comparer.hs

{-# LANGUAGE ScopedTypeVariables #-}
module Lib where
import Data.List
import Data.Maybe
import Safe
import Debug.Trace
import Data.Function

data Suit = Hearts | Clubs | Spades | Diamonds deriving (Eq, Show, Ord)

data Card = Card Suit Integer deriving (Eq, Show)

data HandType =
  HTOneHigh |
  HTPair |
  HTTwoPair |
  HTTriple |
  HTStraight |
  HTFlush |
  HTFullHouse |
  HTQuadruple |
  HTStraightFlush
  deriving (Ord, Eq, Show)

type ComparableHand = (HandType, [Integer])

get_suit (Card suit number) = suit
get_number (Card suit number) = number

elementsWithLength lists l  = filter (\list -> (length list == l)) lists

largestNumberOccurringTimes numbers times = maximumMay $ numbersOccurringTimes numbers times

numbersOccurringTimes numbers times = let grouped = group $ sort numbers
                                          lists = filter (\list -> (length list == times)) grouped
                                      in map head lists

makeDescend = reverse . sort

-- what to name this?
fnorb handType targets numbers = do
                    biggestHits :: [Integer] <- sequence $ map (largestNumberOccurringTimes numbers) targets
                    let remainders = makeDescend $ filter (not . (flip elem biggestHits)) numbers
                    return $ (handType, biggestHits ++ remainders)

getPair :: [Integer] -> Maybe ComparableHand
getPair = fnorb HTPair [2]

getTriple :: [Integer] -> Maybe ComparableHand
getTriple = fnorb HTTriple [3]

getQuadruple :: [Integer] -> Maybe ComparableHand
getQuadruple = fnorb HTQuadruple [4]

getTwoPair :: [Integer] -> Maybe ComparableHand
getTwoPair numbers = let twos = sort $ numbersOccurringTimes numbers 2
                     in do
                       bigPair <- atMay twos 1
                       smallPair <- atMay twos 0
                       let remainders = makeDescend $ filter (\x -> not (x `elem` [bigPair, smallPair])) numbers
                       return $ (HTTwoPair, [bigPair, smallPair] ++ remainders)

getFullHouse :: [Integer] -> Maybe ComparableHand
getFullHouse = fnorb HTFullHouse [3, 2]

myshow x = trace (show x) x

isStraight numbers = let lowest = minimum numbers
                         highest = maximum numbers
                         expected = [lowest..highest]
                     in (sort numbers) == expected

getStraight numbers = if isStraight numbers
                        then Just $ (HTStraight, [maximum numbers])
                        else Nothing

numUniqueElements = length . group . sort

isFlush suits = (numUniqueElements suits) == 1

getFlush suits numbers = if isFlush suits
                         then Just $ (HTFlush, makeDescend numbers)
                         else Nothing

getStraightFlush :: [Suit] -> [Integer] -> Maybe ComparableHand
getStraightFlush suits numbers = if (isFlush suits) && (isStraight numbers)
                                 then Just $ (HTStraightFlush, [maximum numbers])
                                 else Nothing

make_hand :: (Card, Card, Card, Card, Card) -> ComparableHand
make_hand card_tuple = let (a,b,c,d,e) = card_tuple
                           card_list = [a,b,c,d,e]
                           numbers = map get_number card_list
                           suits = map get_suit card_list
                           descending = reverse $ sort $ numbers
                       in head $ catMaybes [
                         getStraightFlush suits numbers,
                         getQuadruple numbers,
                         getFullHouse numbers,
                         getFlush suits numbers,
                         getStraight numbers,
                         getTwoPair numbers,
                         getTriple numbers,
                         getPair numbers,
                         Just $ (HTOneHigh, descending)
                       ]

newtype CardCollection = CardCollection (Card, Card, Card, Card, Card) deriving (Eq)

instance Ord CardCollection where
  compare = compare `on` (make_hand . getCards)
    where getCards (CardCollection cards) = cards

spec.hs

import Test.HUnit
import Lib
--import Data.Map
--import Test.QuickCheck

test_make_onehigh =
  TestCase $ assertEqual
               "make one-high with 10 of clubs"
               (HTOneHigh, [10, 5, 3, 2, 1])
               hand
  where hand = make_hand ((Card Hearts 1), (Card Hearts 5), (Card Clubs 2), (Card Clubs 3), (Card Clubs 10))

test_make_pair =
  TestCase $ assertEqual
               "make pair of ones"
               (HTPair, [1, 10, 8, 5])
               hand
  where hand = make_hand ((Card Hearts 1), (Card Clubs 1), (Card Spades 5), (Card Clubs 8), (Card Clubs 10))

test_make_triple =
  TestCase $ assertEqual
               "make three of a kind with ones"
               (HTTriple, [1,10,8])
               hand
  where hand = make_hand ((Card Hearts 1), (Card Clubs 1), (Card Spades 1), (Card Clubs 8), (Card Clubs 10))

test_make_twopair =
  TestCase $ assertEqual
               "make twopair"
               (HTTwoPair, [2, 1, 10])
               hand
  where hand = make_hand ((Card Hearts 1), (Card Clubs 1), (Card Spades 2), (Card Clubs 2), (Card Clubs 10))

test_make_straight =
  TestCase $ assertEqual
               "make straight"
               (HTStraight, [5])
               hand
  where hand = make_hand ((Card Hearts 1), (Card Clubs 2), (Card Spades 3), (Card Clubs 4), (Card Diamonds 5))

test_make_flush =
  TestCase $ assertEqual
               "make flush"
               (HTFlush, [7,4,3,2,1])
               hand
  where hand = make_hand ((Card Hearts 1), (Card Hearts 2), (Card Hearts 3), (Card Hearts 4), (Card Hearts 7))

test_make_straight_flush =
  TestCase $ assertEqual
               "make straight flush"
               (HTStraightFlush, [6])
               hand
  where hand = make_hand ((Card Hearts 2), (Card Hearts 3), (Card Hearts 4), (Card Hearts 5), (Card Hearts 6))

test_make_full_house =
  TestCase $ assertEqual
               "make full house"
               (HTFullHouse, [3,1])
               hand
  where hand = make_hand ((Card Hearts 1), (Card Clubs 1), (Card Hearts 3), (Card Spades 3), (Card Diamonds 3))

test_full_hous_fight =
  TestCase $ assertBool
               "make full house"
               (badFullHouse < goodFullHouse)
  where badFullHouse = make_hand ((Card Hearts 1), (Card Clubs 1), (Card Hearts 3), (Card Spades 3), (Card Diamonds 3))
        goodFullHouse = make_hand ((Card Hearts 1), (Card Clubs 1), (Card Hearts 8), (Card Spades 8), (Card Diamonds 8))

test_three_of_a_kind_fight_tied_kicker =
  TestCase $ assertBool
               "three of a kind with better second-kicker wins"
               (badTriple < goodTriple)
  where badTriple = make_hand ((Card Hearts 1), (Card Clubs 1), (Card Spades 1), (Card Diamonds 10), (Card Diamonds 3))
        goodTriple = make_hand ((Card Diamonds 1), (Card Clubs 1), (Card Hearts 1), (Card Spades 10), (Card Diamonds 8))

test_fullhouse_beats_pair =
  TestCase $ assertBool
               "full house beats pair"
               (fullHouse > pair)
  where fullHouse = make_hand ((Card Hearts 1), (Card Clubs 1), (Card Spades 1), (Card Diamonds 2), (Card Diamonds 2))
        pair = make_hand ((Card Diamonds 1), (Card Clubs 1), (Card Hearts 3), (Card Spades 5), (Card Diamonds 9))


tests = TestList [
          test_fullhouse_beats_pair,
          test_make_onehigh,
          test_make_pair,
          test_make_triple,
          test_make_twopair,
          test_make_straight,
          test_make_flush,
          test_make_full_house,
          test_make_straight_flush,
          test_full_hous_fight,
          test_three_of_a_kind_fight_tied_kicker
        ]

main :: IO ()
main = do
  runTestTT tests
  return ()