diff --git a/Data/HCard.hs b/Data/HCard.hs new file mode 100644 --- /dev/null +++ b/Data/HCard.hs @@ -0,0 +1,27 @@ +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- +-- | +--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 diff --git a/Data/HCard/Card.hs b/Data/HCard/Card.hs new file mode 100644 --- /dev/null +++ b/Data/HCard/Card.hs @@ -0,0 +1,80 @@ +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- +-- | +--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 + + + + + diff --git a/Data/HCard/Deck.hs b/Data/HCard/Deck.hs new file mode 100644 --- /dev/null +++ b/Data/HCard/Deck.hs @@ -0,0 +1,82 @@ +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- +-- | +--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 + + + + + diff --git a/Data/HCard/Examples.hs b/Data/HCard/Examples.hs new file mode 100644 --- /dev/null +++ b/Data/HCard/Examples.hs @@ -0,0 +1,20 @@ +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- +-- | +--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 diff --git a/Data/HCard/Examples/Cribbage.hs b/Data/HCard/Examples/Cribbage.hs new file mode 100644 --- /dev/null +++ b/Data/HCard/Examples/Cribbage.hs @@ -0,0 +1,95 @@ +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- +-- | +--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) diff --git a/Data/HCard/Hand.hs b/Data/HCard/Hand.hs new file mode 100644 --- /dev/null +++ b/Data/HCard/Hand.hs @@ -0,0 +1,33 @@ +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- +-- | +--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) + diff --git a/Data/HCard/Instances.hs b/Data/HCard/Instances.hs new file mode 100644 --- /dev/null +++ b/Data/HCard/Instances.hs @@ -0,0 +1,20 @@ +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- +-- | +--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 diff --git a/Data/HCard/Instances/Classic.hs b/Data/HCard/Instances/Classic.hs new file mode 100644 --- /dev/null +++ b/Data/HCard/Instances/Classic.hs @@ -0,0 +1,117 @@ +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- +-- | +--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 + + diff --git a/Data/HCard/Misc.hs b/Data/HCard/Misc.hs new file mode 100644 --- /dev/null +++ b/Data/HCard/Misc.hs @@ -0,0 +1,29 @@ +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- +-- | +--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 diff --git a/Data/HCard/Test/Test.hs b/Data/HCard/Test/Test.hs new file mode 100644 --- /dev/null +++ b/Data/HCard/Test/Test.hs @@ -0,0 +1,109 @@ +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- +-- | +--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 + ] + diff --git a/HCard.cabal b/HCard.cabal new file mode 100644 --- /dev/null +++ b/HCard.cabal @@ -0,0 +1,34 @@ +Name: 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 + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ + + +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. + + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain