HCard-0.0/0000755000000000000000000000000011167002353010516 5ustar0000000000000000HCard-0.0/Setup.hs0000644000000000000000000000005611167002353012153 0ustar0000000000000000import Distribution.Simple main = defaultMain HCard-0.0/LICENSE0000644000000000000000000000260011167002353011521 0ustar0000000000000000 Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. Neither the name of the ; nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. HCard-0.0/HCard.cabal0000644000000000000000000000265311167002353012471 0ustar0000000000000000Name: HCard Version: 0.0 Synopsis: A library for implementing a Deck of Cards Description: HCard provides a standard interface to a deck of cards -- providing shuffling, permutation irrelevant equality of hands, etc. Homepage: http://patch-tag.com/publicrepos/HCard Package-Url: http://patch-tag.com/publicrepos/HCard Category: Game License: BSD3 License-file: LICENSE Author: Joe Fredette Maintainer: jfredett@gmail.com Build-Type: Simple Cabal-Version: >=1.6 Library Build-Depends: base, random-shuffle >= 0.0.2, mtl >= 1.1.0.2, random >= 1.0.0.1, QuickCheck >= 2.1.0.1 Exposed-Modules: Data.HCard, Data.HCard.Instances, Data.HCard.Examples Other-Modules: Data.HCard.Card, Data.HCard.Deck, Data.HCard.Hand, Data.HCard.Misc, Data.HCard.Instances.Classic, Data.HCard.Test.Test, Data.HCard.Examples.Cribbage HCard-0.0/Data/0000755000000000000000000000000011167002353011367 5ustar0000000000000000HCard-0.0/Data/HCard.hs0000644000000000000000000000172011167002353012704 0ustar0000000000000000-------------------------------------------------------------------------------- -------------------------------------------------------------------------------- -- | --Module : Data.HCard --Author : Joe Fredette --License : BSD3 --Copyright : Joe Fredette -- --Maintainer : Joe Fredette --Stability : Unstable --Portability : portable -- -------------------------------------------------------------------------------- --Description : Wrapper to export the whole library -------------------------------------------------------------------------------- -------------------------------------------------------------------------------- module Data.HCard ( module Data.HCard.Card , module Data.HCard.Deck , module Data.HCard.Hand , module Data.HCard.Instances ) where import Data.HCard.Card import Data.HCard.Deck import Data.HCard.Hand import Data.HCard.Instances HCard-0.0/Data/HCard/0000755000000000000000000000000011167002353012350 5ustar0000000000000000HCard-0.0/Data/HCard/Misc.hs0000644000000000000000000000164611167002353013606 0ustar0000000000000000-------------------------------------------------------------------------------- -------------------------------------------------------------------------------- -- | --Module : Data.HCard.Misc --Author : Joe Fredette --License : BSD3 --Copyright : Joe Fredette -- --Maintainer : Joe Fredette --Stability : Unstable --Portability : portable -- -------------------------------------------------------------------------------- --Description : Miscellaneous helper functions -------------------------------------------------------------------------------- -------------------------------------------------------------------------------- module Data.HCard.Misc where import Data.List subset :: Eq a => [a] -> [a] -> Bool subset [] _ = True subset (x:xs) ls = (x `elem` ls) && (subset xs (ls \\ [x])) allBdd :: (Enum a, Bounded a) => [a] allBdd = enumFromTo minBound maxBound HCard-0.0/Data/HCard/Card.hs0000644000000000000000000000606611167002353013565 0ustar0000000000000000-------------------------------------------------------------------------------- -------------------------------------------------------------------------------- -- | --Module : Data.HCard.Card --Author : Joe Fredette --License : BSD3 --Copyright : Joe Fredette -- --Maintainer : Joe Fredette --Stability : Unstable --Portability : portable -- -------------------------------------------------------------------------------- --Description : A module containing the main "Card" class, a sort of type-indexed -- record type. -------------------------------------------------------------------------------- -------------------------------------------------------------------------------- {-# LANGUAGE TypeFamilies, MultiParamTypeClasses #-} module Data.HCard.Card where import Data.HCard.Misc -- | The Main class, this is -- effectively -- a type-indexed record. Specifically, it requires -- two types, one representing the suit, the other representing the index/rank. The suit, -- index, and construct functions are generic forms of the record accessors. -- -- The bulk of the implementation takes place in generic type instances, supporting equality -- irrelevant of ordering, ordering, parsing from a "normal form" (-) and enum/bounded -- -- -- TODO: Write deriving instance? class (Eq s, Eq i, Show s, Show i) => Card s i where data CardT s i :: * suit :: CardT s i -> s index :: CardT s i -> i construct :: i -> s -> CardT s i (@@) :: i -> s -> CardT s i -- MRD : Everything but @@ x @@ y = construct x y instance Card s i => Show (CardT s i) where show c = (show . index $ c) ++ "-" ++ (show . suit $ c) instance Card s i => Eq (CardT s i) where ca == cb = (suit ca == suit cb) && (index ca == index cb) type Cards s i = [CardT s i] -- | Parse is just a read instance with read exposed as the MRD. For most types, this will -- just be Read, but when dealing w/ index types, it can be a pain to parse numbers via -- read and end up with the expected format of "-" class Parse a where parse :: String -> a instance (Parse s, Parse i, Card s i) => Parse (CardT s i) where parse s = construct (parse idx) (parse suit) where (idx, suit) = (\(x,y) -> (x, tail y)) $ break (=='-') s instance (Ord s, Ord i, Card s i) => Ord (CardT s i) where compare c1 c2 | suit c1 < suit c2 = LT | suit c1 > suit c2 = GT | suit c1 == suit c2 = compare (index c1) (index c2) instance (Bounded s, Bounded i, Enum s, Enum i, Card s i) => Enum (CardT s i) where toEnum i = [construct x y | x <- allBdd, y <- allBdd] !! i fromEnum v = ((1 + fromEnum (suit v)) * (fromEnum (index v))) - 1 instance (Bounded s, Bounded i, Enum s, Enum i, Card s i) => Bounded (CardT s i) where minBound = construct minBound minBound maxBound = construct maxBound maxBound HCard-0.0/Data/HCard/Instances.hs0000644000000000000000000000150111167002353014630 0ustar0000000000000000-------------------------------------------------------------------------------- -------------------------------------------------------------------------------- -- | --Module : Data.HCard.Instances --Author : Joe Fredette --License : BSD3 --Copyright : Joe Fredette -- --Maintainer : Joe Fredette --Stability : Unstable --Portability : portable -- -------------------------------------------------------------------------------- --Description : Wrapper for exporting all instances of the main Card class -------------------------------------------------------------------------------- -------------------------------------------------------------------------------- module Data.HCard.Instances (module Data.HCard.Instances.Classic) where import Data.HCard.Instances.Classic HCard-0.0/Data/HCard/Deck.hs0000644000000000000000000000563211167002353013560 0ustar0000000000000000-------------------------------------------------------------------------------- -------------------------------------------------------------------------------- -- | --Module : Data.HCard.Deck --Author : Joe Fredette --License : BSD3 --Copyright : Joe Fredette -- --Maintainer : Joe Fredette --Stability : Unstable --Portability : portable -- -------------------------------------------------------------------------------- --Description : Functions relating to a Deck of cards, eg shuffling, dealing, -- etc. -------------------------------------------------------------------------------- -------------------------------------------------------------------------------- module Data.HCard.Deck where import System.Random import System.Random.Shuffle import Control.Monad.State import Data.HCard.Misc import Data.HCard.Card import Data.HCard.Hand -- | Separate Deck from Hand, even though the types are isomorphic, we don't want shuffling to -- be to liberal. -- -- TODO: Make Deck clever enough to support reshuffling when the deck runs out -- it should store cards it has -- already seen till it runs out of the main deck, reshuffle, redeal. newtype Deck s i = Deck (Cards s i) deriving (Show) -- | Type wrapper for stateful decks, useful for sorting type DeckST s i = State (Deck s i) instance Card s i => Eq (Deck s i) where (Deck h1) == (Deck h2) = (h1 `subset` h2) && (h2 `subset` h1) -- | Creates a deck, used as in: `mkDeck::`, or w/ inference. mkDeck :: (Bounded s, Bounded i, Enum s, Enum i, Card s i) => Deck s i mkDeck = Deck $ enumFromTo minBound maxBound -- | Shuffles a deck given a generator shuffleDeck :: (Card s i, RandomGen g) => Deck s i -> g -> Deck s i shuffleDeck (Deck ds) g = Deck (shuffle' ds (length ds) g) -- | Shuffles using the standard generator shuffleDeckIO :: Card s i => Deck s i -> IO (Deck s i) shuffleDeckIO (Deck ds) = do gen <- getStdGen return $ Deck (shuffle' ds (length ds) gen) -- | Deals `n` hands of `qty` cards, written in the state monad. dealHands :: Card s i => Int -> Int -> (DeckST s i) [Hand s i] dealHands 0 _ = return [] dealHands _ 0 = error "Can't deal zero cards." dealHands num qty = do (Deck deck) <- get if (length deck < qty) then error "Not enough cards in deck" else do { hand <- dealHand qty ; next <- dealHands (num - 1) qty ; return $ hand : next } -- | Helper for dealHands, also somewhat useful, equiv. to `dealHands 1 qty` dealHand :: Card s i => Int -> (DeckST s i) (Hand s i) dealHand qty = do (Deck deck) <- get let (hand, rem) = splitAt qty deck put (Deck rem) return $ Hand hand HCard-0.0/Data/HCard/Hand.hs0000644000000000000000000000215711167002353013563 0ustar0000000000000000-------------------------------------------------------------------------------- -------------------------------------------------------------------------------- -- | --Module : Data.HCard.Hand --Author : Joe Fredette --License : BSD3 --Copyright : Joe Fredette -- --Maintainer : Joe Fredette --Stability : Unstable --Portability : portable -- -------------------------------------------------------------------------------- --Description : Functions relating to a particular dealt hand of cards. -------------------------------------------------------------------------------- -------------------------------------------------------------------------------- module Data.HCard.Hand where import Data.HCard.Card import Data.HCard.Misc import Data.List -- | A type to separate Hands from Decks. newtype Hand s i = Hand (Cards s i) deriving (Show) instance Card s i => Eq (Hand s i) where (Hand h1) == (Hand h2) = (h1 `subset` h2) && (h2 `subset` h1) instance (Parse s, Parse i, Card s i) => Parse (Hand s i) where parse s = Hand $ map parse (words s) HCard-0.0/Data/HCard/Examples.hs0000644000000000000000000000146511167002353014470 0ustar0000000000000000-------------------------------------------------------------------------------- -------------------------------------------------------------------------------- -- | --Module : Data.HCard.Examples --Author : Joe Fredette --License : BSD3 --Copyright : Joe Fredette -- --Maintainer : Joe Fredette --Stability : Unstable --Portability : portable -- -------------------------------------------------------------------------------- --Description : Wrapper to export all the example uses of HCard -------------------------------------------------------------------------------- -------------------------------------------------------------------------------- module Data.HCard.Examples (module Data.HCard.Examples.Cribbage) where import Data.HCard.Examples.Cribbage HCard-0.0/Data/HCard/Instances/0000755000000000000000000000000011167002353014277 5ustar0000000000000000HCard-0.0/Data/HCard/Instances/Classic.hs0000644000000000000000000000721511167002353016221 0ustar0000000000000000-------------------------------------------------------------------------------- -------------------------------------------------------------------------------- -- | --Module : Data.HCard.Instances.Classic --Author : Joe Fredette --License : BSD3 --Copyright : Joe Fredette -- --Maintainer : Joe Fredette --Stability : Unstable --Portability : portable -- -------------------------------------------------------------------------------- --Description : Describes the "French Deck" set of playing cards, the most -- common deck in the US -------------------------------------------------------------------------------- -------------------------------------------------------------------------------- {-# LANGUAGE MultiParamTypeClasses, TypeFamilies #-} module Data.HCard.Instances.Classic where import Data.HCard.Card import Data.HCard.Misc import Data.HCard.Deck import Data.HCard.Hand -- | The Suits of the so-called "French" deck, the most common American deck of -- cards. data Suit = H | D | C | S deriving (Eq, Ord, Show, Read, Enum, Bounded) -- | The Indices of the french deck data Index = Ace | Jack | Queen | King | V Int deriving (Eq) instance Show (Index) where show i = case i of Ace -> "A" Jack -> "J" Queen -> "Q" King -> "K" V i -> show i instance Ord Index where compare i j = case i of Ace -> if j == Ace then EQ else LT King -> if j == King then EQ else GT Queen -> case j of Queen -> EQ King -> LT _ -> GT Jack -> case j of Jack -> EQ Queen -> LT King -> LT _ -> GT (V x) -> case j of (V y) -> compare x y Ace -> LT _ -> GT instance Enum Index where toEnum i | i >= 2 && i <= 10 = V i | otherwise = case i of 1 -> Ace 11 -> Jack 12 -> Queen 13 -> King _ -> error $ "No enum for " ++ show i ++ "." fromEnum i = case i of Ace -> 1 Jack -> 11 Queen -> 12 King -> 13 V x -> x instance Bounded Index where minBound = Ace maxBound = King instance Parse Suit where parse = read instance Parse Index where parse i = case i of "A" -> Ace "J" -> Jack "Q" -> Queen "K" -> King i -> if (ri > 10 || ri < 2) then error "Valid Number cards are 2-10" else V ri where ri = read i :: Int instance Card Suit Index where data CardT Suit Index = Classic Suit Index suit (Classic s _) = s index (Classic _ i) = i construct i s = Classic s i -- | Type synonyms to make using the polymorphic bits easier type Classic = CardT Suit Index type ClassicDeck = Deck Suit Index type ClassicDeckST = DeckST Suit Index type ClassicHand = Hand Suit Index -- | Wrapper which forces the polymorphic dealHands to work with French-deck cards only. deal :: Int -> Int -> ClassicDeckST [ClassicHand] deal x y = dealHands x y HCard-0.0/Data/HCard/Test/0000755000000000000000000000000011167002353013267 5ustar0000000000000000HCard-0.0/Data/HCard/Test/Test.hs0000644000000000000000000000667411167002353014557 0ustar0000000000000000-------------------------------------------------------------------------------- -------------------------------------------------------------------------------- -- | --Module : Test --Author : Joe Fredette --License : BSD3 --Copyright : Joe Fredette -- --Maintainer : Joe Fredette --Stability : Unstable --Portability : portable -- -------------------------------------------------------------------------------- --Description : Tests for HCard -- -- TODO: This is an anaemic set of tests, flesh it out! -------------------------------------------------------------------------------- -------------------------------------------------------------------------------- module Data.HCard.Test.Test where import Test.QuickCheck import Data.HCard import Data.HCard.Instances import Data.HCard.Misc import System.Random import Control.Monad.State -- conf = Config 1000 0 (configSize defaultConfig) (configEvery defaultConfig) instance (Arbitrary s, Arbitrary i, Card s i) => Arbitrary (CardT s i) where arbitrary = do x <- arbitrary y <- arbitrary return $ construct x y instance (Arbitrary s, Arbitrary i, Card s i) => Arbitrary (Deck s i) where arbitrary = do x <- arbitrary return $ Deck x instance Arbitrary Suit where arbitrary = elements [H,S,C,D] instance Arbitrary Index where arbitrary = elements ([Ace,King,Queen,Jack] ++ map V [2..10]) instance Arbitrary StdGen where arbitrary = do x <- arbitrary return (mkStdGen x) -- Tests --------------------- -- Deck/Hand tests -- --------------------- classic_shuffle_eq :: StdGen -> Bool classic_shuffle_eq g = shuffleDeck (mkDeck::ClassicDeck) g == mkDeck classic_deal_subset_deck :: StdGen -> Int -> Int -> Property classic_deal_subset_deck g n q = (n >= 1 && q >= 1 && n <= len `div` q) ==> (all (\(Hand x) -> x `subset` shuffled) hands) where (shuffled, len) = (\(Deck d) -> (d, length d)) $ shuffleDeck (mkDeck::ClassicDeck) g (hands, _) = runState (dealHands n q) (Deck shuffled) classic_deal_union_id :: StdGen -> Int -> Int -> Property classic_deal_union_id g n q = (n >= 1 && q >= 1 && n <= len `div` q) ==> undealt == shuffled where (shuffled, len) = (\(Deck d) -> (d, length d)) $ shuffleDeck (mkDeck::ClassicDeck) g undealt = uncurry undeal $ runState (dealHands n q) (Deck shuffled) undeal hs (Deck d) = ((concatMap (\(Hand h) -> h) hs) ++ d) deck_hand_tests = [ quickCheck classic_shuffle_eq , quickCheck classic_deal_subset_deck , quickCheck classic_deal_union_id] ---------------------- -- Parse/Show tests -- ---------------------- show_parse_id_classic :: Classic -> Bool show_parse_id_classic a = (parse $ show a) == a parse_show_tests = [quickCheck show_parse_id_classic] ---------------- -- Misc tests -- ---------------- subset_prop :: [Int] -> [Int] -> Bool subset_prop ls as = ls `subset` (ls ++ as) subset_eq :: [Int] -> Bool subset_eq ls = ls `subset` ls misc_tests = [quickCheck subset_prop, quickCheck subset_eq] -- Run tests: test = sequence_ $ concat [ misc_tests , deck_hand_tests , parse_show_tests ] HCard-0.0/Data/HCard/Examples/0000755000000000000000000000000011167002353014126 5ustar0000000000000000HCard-0.0/Data/HCard/Examples/Cribbage.hs0000644000000000000000000000652711167002353016172 0ustar0000000000000000-------------------------------------------------------------------------------- -------------------------------------------------------------------------------- -- | --Module : Cribbage --Author : Joe Fredette --License : BSD3 --Copyright : Joe Fredette -- --Maintainer : Joe Fredette --Stability : Unstable --Portability : portable -- -------------------------------------------------------------------------------- --Description : A simple cribbage score counter (minus the "his heels" and -- "nobs" rules). Example of how to use the library. -------------------------------------------------------------------------------- -------------------------------------------------------------------------------- module Data.HCard.Examples.Cribbage where import Data.HCard import Data.HCard.Instances import Data.List import Data.Function score h = cribbageScore cut hand where (cut, hand) = (\(Hand x) -> (head x, Hand . tail $ x)) ((parse h)::ClassicHand) cribbageScore :: Classic -> ClassicHand -> Int cribbageScore cut hand = sum $ map (\f -> f cut hand) [ countFifteens , countPairs , countRuns , countFlush --, countHeels ] toValue :: Classic -> Int toValue c = case index c of Ace -> 1 V x -> x _ -> 10 -- countFifteens, countPairs, countRuns, countFlush, countHeels :: Classic -> ClassicHand -> [Int] countFifteens cut (Hand hand) = 2 * (length $ filter (==15) $ map valSum extHand) where extHand = allKTups $ hand ++ [cut] valSum xs = sum $ map toValue xs countPairs cut (Hand hand) = 2 * (length $ filter isPair extHand) where extHand = uniqPairs $ hand ++ [cut] isPair (x,y) = index x == index y countRuns cut (Hand hand) = sum $ map length $ filter (\x -> length x >= 3) $ filter isRun $ map (map toValue) extHand where extHand = map (sortBy (compare `on` index)) $ allKTups (hand ++ [cut]) countFlush cut (Hand hand) = getMax $ filter (>=4) $ map (length . (\(Hand h) -> h)) $ filterSuits extHand where extHand = Hand $ hand ++ [cut] getMax [] = 0 getMax ls = maximum ls countHeels cut (Hand hand) = case index cut of Jack -> if (suit cut) `elem` (map suit hand) then 1 else 0 _ -> if Jack `elem` suited then 2 else 0 where suited = map index $ filter (\x -> suit x == suit cut) hand isRun [] = True isRun [x] = True isRun (x:y:xs) = (abs $ x - y) == 1 && isRun (y:xs) hand1 = (parse "5-H 5-S 6-D 7-S" ) :: ClassicHand hand2 = (parse "5-H 6-H 7-S 10-H") :: ClassicHand cut = parse "Q-H" :: Classic filterSuits :: ClassicHand -> [ClassicHand] filterSuits (Hand hand) = map Hand $ groupBy matchSuit (sort hand) where matchSuit c1 c2 = suit c1 == suit c2 allKTups :: [a] -> [[a]] allKTups [] = [] allKTups (x:xs) = ([x] : (map (x:) (allKTups xs))) ++ allKTups xs uniqPairs :: Eq a => [a] -> [(a,a)] uniqPairs xs = map (\(x:y:_) -> (x,y)) $ filter (\x -> length x == 2) (allKTups xs)