import Test.QuickCheck -- Data type for suit of a card (spades, hearts, diamonds, clubs) data Suit = Spades | Hearts | Diamonds | Clubs deriving (Eq, Show) -- Data type for colour of a card (black, red) data Color = Black | Red deriving (Eq, Show) -- Function that returns the color of a card color :: Suit -> Color color Spades = Black color Clubs = Black color Hearts = Red color Diamonds = Red -- Data type for rank of a card (numeric, jack, queen, king, ace) data Rank = Numeric Integer | Jack | Queen | King | Ace deriving (Eq, Show) -- rankBeats rank1 rank2 checks if rank1 beats rank2 rankBeats :: Rank -> Rank -> Bool rankBeats _ Ace = False rankBeats Ace _ = True rankBeats _ King = False rankBeats King _ = True rankBeats _ Queen = False rankBeats Queen _ = True rankBeats _ Jack = False rankBeats Jack _ = True rankBeats (Numeric r1) (Numeric r2) = r1 > r2 -- Property that checks that either r1 beats r2 or vice versa prop_rankBeats r1 r2 = r1/=r2 ==> rankBeats r1 r2 /= rankBeats r2 r1 -- Data type for card: a rank and a suit data Card = Card {rank :: Rank, suit :: Suit} deriving (Eq, Show) -- Record syntax c1 = Card Ace Spades c2 = Card {suit = Spades} c3 = c2 {rank = Ace} defCard :: Suit -> Card defCard s = Card Ace s -- cardBeats card1 card2 checks if card1 beats card2 (same suit and higher rank) cardBeats :: Card -> Card -> Bool cardBeats c1 c2 = suit c1 == suit c2 && rankBeats (rank c1) (rank c2) -- cardBeats (Card r1 s1) (Card r2 s2) = s1==s2 && rankBeats r1 r2 -- Data type for a hand of cards data Hand = Empty | Add Card Hand deriving (Eq, Show) c4 = Card (Numeric 2) Hearts hand = Add c1 (Add c4 Empty) -- handBeats h c checks if any card in h beats c handBeats :: Hand -> Card -> Bool handBeats Empty beat = False handBeats (Add c h) beat = cardBeats c beat || handBeats h beat -- chooseCard beat hand chooses a card from hand to -- play, when beat is the card to be beaten chooseCard :: Card -> Hand -> Card chooseCard beat (Add c Empty) = c chooseCard beat (Add c h) | cardBeats c beat = c | otherwise = chooseCard beat h chooseCard beat Empty = error "chooseCard: Empty" prop_chooseCardWinsIfPossible beat h = h/=Empty ==> handBeats h beat == cardBeats (chooseCard beat h) beat -- Add property that the chosen card was really in the hand ------------------------------------------------------------------------- instance Arbitrary Suit where arbitrary = elements [Spades, Hearts, Diamonds, Clubs] instance Arbitrary Rank where arbitrary = oneof $ [ do return c | c <- [Jack,Queen,King,Ace] ] ++ [ do n <- choose (2,10) return (Numeric n) ] -- shrink Ace = [King] -- shrink King = [Queen] -- shrink Queen = [Jack] -- shrink Jack = [Numeric 10] -- shrink (Numeric n) = [Numeric n' | n' <- shrink n, 2<=n'] instance Arbitrary Card where arbitrary = do r <- arbitrary s <- arbitrary return (Card r s) -- shrink (Card r s) = -- [Card r' s | r' <- shrink r] instance Arbitrary Hand where arbitrary = do cs <- arbitrary let hand [] = Empty hand (c:cs) = Add c (hand [ c' | c' <- cs, c' /= c ]) return (hand cs) -- shrink (Add c h) = -- h : [Add c' h' | (c',h') <- shrink (c,h)] -- shrink Empty = []