{- This is a framework in which all functions to be written are "undefined". - - Note that in most cases parameters, pattern-matching and guards have been - - omitted! You will have to add those yourself. -} module Assignment3 where import Control.Arrow ((&&&)) import Data.Function (on) import Data.List (group, sort, sortBy, foldl') import Data.Set (Set, empty, insert) -- | Containers data Rose a = a :> [Rose a] deriving (Eq, Show) -- * Exercise 1 instance Functor Rose where fmap f (a :> b) = f a :> map (fmap f) b class Monoid a where mempty :: a (<>) :: a -> a -> a instance Monoid [a] where mempty = [] (<>) = (++) newtype Sum a = Sum { unSum :: a } deriving (Eq, Show) newtype Product a = Product { unProduct :: a } deriving (Eq, Show) instance Num a => Monoid (Sum a) where mempty = Sum 0 Sum n1 <> Sum n2 = Sum (n1 + n2) -- * Exercise 2 instance Num a => Monoid (Product a) where mempty = Product 1 Product n1 <> Product n2 = Product (n1 * n2) class Functor f => Foldable f where fold :: Monoid m => f m -> m foldMap :: Monoid m => (a -> m) -> f a -> m -- * Exercise 4 foldMap t x = fold $ fmap t x instance Foldable [] where fold = foldr (<>) mempty -- * Exercise 3 instance Foldable Rose where fold (a :> b) = a <> (foldr (<>) mempty (map fold b)) -- * Exercise 5 fsum, fproduct :: (Foldable f, Num a) => f a -> a fsum = unSum . (foldMap Sum) fproduct = unProduct . (foldMap Product) -- | Poker data Rank = R2 | R3 | R4 | R5 | R6 | R7 | R8 | R9 | R10 | J | Q | K | A deriving (Bounded, Enum, Eq, Ord) -- * Exercise 6 instance Show Rank where show R2 = "2" show R3 = "3" show R4 = "4" show R5 = "5" show R6 = "6" show R7 = "7" show R8 = "8" show R9 = "9" show R10 = "10" show J = "J" show Q = "Q" show K = "K" show A = "A" data Suit = S | H | D | C deriving (Bounded, Enum, Eq, Ord, Show) data Card = Card { rank :: Rank, suit :: Suit } deriving (Eq, Ord) -- * Exercise 7 instance Show Card where show (Card { rank = r, suit = s }) = show r ++ show s type Deck = [Card] -- * Exercise 8 fullDeck, piquetDeck :: Deck fullDeck = [ Card { rank = r, suit = s} | r <- [R2 .. A], s <- [S .. C]] piquetDeck = [ Card { rank = r, suit = s} | r <- [R7 .. A], s <- [S .. C]] newtype Hand = Hand { unHand :: [Card] } deriving (Eq, Show) data HandCategory = HighCard [Rank] | OnePair Rank [Rank] | TwoPair Rank Rank Rank | ThreeOfAKind Rank Rank Rank | Straight Rank | Flush [Rank] | FullHouse Rank Rank | FourOfAKind Rank Rank | StraightFlush Rank deriving (Eq, Ord, Show) -- * Exercise 9 sameSuitsHelper :: Suit -> [Card] -> Bool sameSuitsHelper _ [] = True sameSuitsHelper s1 (Card { suit = s2 }:cs) | s1 /= s2 = False | otherwise = sameSuitsHelper s1 cs sameSuits :: Hand -> Bool sameSuits (Hand { unHand = [] }) = True -- no cards are do not differ from eachother, so they are the same sameSuits (Hand { unHand = (Card { suit = s1 }:cs) }) = sameSuitsHelper s1 cs -- * Exercise 10 isStraightHelper :: Rank -> [Rank] -> Maybe Rank isStraightHelper r [] = Just r isStraightHelper A (R2:rs) = isStraightHelper R2 rs isStraightHelper A (_:rs) = Nothing isStraightHelper r1 (r2:rs) | succ r1 == r2 = isStraightHelper r2 rs | otherwise = Nothing isStraight :: [Rank] -> Maybe Rank isStraight [] = Nothing isStraight ranks | simple == Nothing = isStraightHelper (last sorted) (init sorted) | otherwise = simple where sorted = sort ranks simple = isStraightHelper (head sorted) (tail sorted) -- * Exercise 11 -- switch comparison to reverse sort ranks :: Hand -> [Rank] ranks (Hand { unHand = cards } ) = sortBy (\x y -> compare y x) $ map (\(Card { rank = r }) -> r) cards -- * Exercise 12 orderHelper :: Int -> Rank -> [Rank] -> [(Int,Rank)] orderHelper count curr [] = [(count,curr)] orderHelper count curr (r:rs) | r == curr = orderHelper (count + 1) curr rs | otherwise = (count,curr):orderHelper 1 r rs -- note the reversal of the comparison, we need to reverse sort order :: Hand -> [(Int, Rank)] order (Hand { unHand = [] } ) = [] order hand = sortBy (\(a,_) (b,_) -> compare b a) $ orderHelper 1 (head ordered) (tail ordered) where ordered = ranks hand -- * Exercise 13 handCategoryHelper' :: [(Int,Rank)] -> HandCategory handCategoryHelper' ((4,r1):(1,r2):[]) = FourOfAKind r1 r2 handCategoryHelper' ((3,r1):(2,r2):[]) = FullHouse r1 r2 handCategoryHelper' ((3,r1):(1,r2):(1,r3):[]) = ThreeOfAKind r1 r2 r3 handCategoryHelper' ((2,r1):(2,r2):(1,r3):[]) = TwoPair r1 r2 r3 handCategoryHelper' ((2,r1):(1,r2):(1,r3):(1,r4):[]) = OnePair r1 [r2,r3,r4] -- assume poker hands have five cards -- assume there are no duplicate cards in the deck handCategoryHelper :: Maybe Rank -> Bool -> [Rank] -> Hand -> HandCategory handCategoryHelper (Just r) True _ _ = StraightFlush r handCategoryHelper (Just r) False _ _ = Straight r handCategoryHelper _ True handRanks _ = Flush handRanks handCategoryHelper _ _ handRanks hand | length handOrder == 5 = HighCard handRanks | otherwise = handCategoryHelper' handOrder where handOrder = order hand handCategory :: Hand -> HandCategory handCategory hand = handCategoryHelper (isStraight handRanks) (sameSuits hand) handRanks hand where handRanks = ranks hand -- * Exercise 14 instance Ord Hand where compare h1 h2 = compare (handCategory h1) (handCategory h2) -- * Exercise 15 combsHelper :: [a] -> Int -> [a] -> [[a]] combsHelper prefix 0 _ = [prefix] combsHelper prefix _ [] = [] combsHelper prefix size (x:xs) = (combsHelper (prefix ++ [x]) (size - 1) xs) ++ (combsHelper prefix size xs) combs :: Int -> [a] -> [[a]] combs size list = combsHelper [] size list -- * Exercise 16 allHands :: Deck -> [Hand] allHands deck = map Hand (combs 5 deck) -- * Exercise 17 distinctHands :: Deck -> Set Hand distinctHands deck = foldl' (\set hand -> insert hand set) empty (allHands deck) -- * Question 1 {- ANSWER -} -- * Question 2 {- ANSWER -}