HCard (empty) → 0.0
raw patch · 13 files changed
+678/−0 lines, 13 filesdep +QuickCheckdep +basedep +mtlsetup-changed
Dependencies added: QuickCheck, base, mtl, random, random-shuffle
Files
- Data/HCard.hs +27/−0
- Data/HCard/Card.hs +80/−0
- Data/HCard/Deck.hs +82/−0
- Data/HCard/Examples.hs +20/−0
- Data/HCard/Examples/Cribbage.hs +95/−0
- Data/HCard/Hand.hs +33/−0
- Data/HCard/Instances.hs +20/−0
- Data/HCard/Instances/Classic.hs +117/−0
- Data/HCard/Misc.hs +29/−0
- Data/HCard/Test/Test.hs +109/−0
- HCard.cabal +34/−0
- LICENSE +30/−0
- Setup.hs +2/−0
+ Data/HCard.hs view
@@ -0,0 +1,27 @@+--------------------------------------------------------------------------------+--------------------------------------------------------------------------------+-- |+--Module : Data.HCard+--Author : Joe Fredette+--License : BSD3+--Copyright : Joe Fredette+--+--Maintainer : Joe Fredette <jfredett.at.gmail.dot.com>+--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
+ Data/HCard/Card.hs view
@@ -0,0 +1,80 @@+--------------------------------------------------------------------------------+--------------------------------------------------------------------------------+-- |+--Module : Data.HCard.Card+--Author : Joe Fredette+--License : BSD3+--Copyright : Joe Fredette+--+--Maintainer : Joe Fredette <jfredett.at.gmail.dot.com>+--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" (<index>-<suit>) 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 "<index>-<suit>"+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 +++++
+ Data/HCard/Deck.hs view
@@ -0,0 +1,82 @@+--------------------------------------------------------------------------------+--------------------------------------------------------------------------------+-- |+--Module : Data.HCard.Deck+--Author : Joe Fredette+--License : BSD3+--Copyright : Joe Fredette+--+--Maintainer : Joe Fredette <jfredett.at.gmail.dot.com>+--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::<your deck type here>`, 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+++++
+ Data/HCard/Examples.hs view
@@ -0,0 +1,20 @@+--------------------------------------------------------------------------------+--------------------------------------------------------------------------------+-- |+--Module : Data.HCard.Examples+--Author : Joe Fredette+--License : BSD3+--Copyright : Joe Fredette+--+--Maintainer : Joe Fredette <jfredett.at.gmail.dot.com>+--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
+ Data/HCard/Examples/Cribbage.hs view
@@ -0,0 +1,95 @@+--------------------------------------------------------------------------------+--------------------------------------------------------------------------------+-- |+--Module : Cribbage+--Author : Joe Fredette+--License : BSD3+--Copyright : Joe Fredette+--+--Maintainer : Joe Fredette <jfredett.at.gmail.dot.com>+--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)
+ Data/HCard/Hand.hs view
@@ -0,0 +1,33 @@+--------------------------------------------------------------------------------+--------------------------------------------------------------------------------+-- |+--Module : Data.HCard.Hand+--Author : Joe Fredette+--License : BSD3+--Copyright : Joe Fredette+--+--Maintainer : Joe Fredette <jfredett.at.gmail.dot.com>+--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)+
+ Data/HCard/Instances.hs view
@@ -0,0 +1,20 @@+--------------------------------------------------------------------------------+--------------------------------------------------------------------------------+-- |+--Module : Data.HCard.Instances+--Author : Joe Fredette+--License : BSD3+--Copyright : Joe Fredette+--+--Maintainer : Joe Fredette <jfredett.at.gmail.dot.com>+--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
+ Data/HCard/Instances/Classic.hs view
@@ -0,0 +1,117 @@+--------------------------------------------------------------------------------+--------------------------------------------------------------------------------+-- |+--Module : Data.HCard.Instances.Classic+--Author : Joe Fredette+--License : BSD3+--Copyright : Joe Fredette+--+--Maintainer : Joe Fredette <jfredett.at.gmail.dot.com>+--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++
+ Data/HCard/Misc.hs view
@@ -0,0 +1,29 @@+--------------------------------------------------------------------------------+--------------------------------------------------------------------------------+-- |+--Module : Data.HCard.Misc+--Author : Joe Fredette+--License : BSD3+--Copyright : Joe Fredette+--+--Maintainer : Joe Fredette <jfredett.at.gmail.dot.com>+--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
+ Data/HCard/Test/Test.hs view
@@ -0,0 +1,109 @@+--------------------------------------------------------------------------------+--------------------------------------------------------------------------------+-- |+--Module : Test+--Author : Joe Fredette+--License : BSD3+--Copyright : Joe Fredette+--+--Maintainer : Joe Fredette <jfredett.at.gmail.dot.com>+--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.cabal view
@@ -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+
+ LICENSE view
@@ -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.++
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain