import Test.QuickCheck ------------------------------------------------------------------------- -- datatype for suit of a card data Suit = Spades | Hearts | Diamonds | Clubs deriving (Eq, Show) -- datatype for colour of a card data Colour = Black | Red deriving (Eq, Show) colour :: Suit -> Colour colour Spades = Black colour Hearts = Red colour Diamonds = Red colour Clubs = Black ------------------------------------------------------------------------- -- datatype for rank of a card data Rank = Numeric Integer | Jack | Queen | King | Ace deriving (Eq, Show, Ord) -- 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 m) (Numeric n) = m > n prop_RankBeats a b = a /= b ==> rankBeats a b || rankBeats b a -- Alternative way of defining the function, taking advantage of the -- "deriving ...,Ord". Note that this only works because we happen to -- define the constructors in the right order in the definition. rankBeats' :: Rank -> Rank -> Bool rankBeats' r s = r > s prop_RankBeats' a b = rankBeats a b == rankBeats' a b ------------------------------------------------------------------------- -- datatype for card: a rank and a suit data Card = Card{ rank :: Rank, suit :: Suit } deriving (Eq, Show) -- cardBeats card1 card2 checks if card1 beats card2 cardBeats :: Card -> Card -> Bool cardBeats c c' = suit c == suit c' && rankBeats (rank c) (rank c') ------------------------------------------------------------------------- -- datatype for a hand of cards data Hand = Empty | Add Card Hand deriving (Eq, Show) -- handBeats hand card checks if hand beats card handBeats :: Hand -> Card -> Bool handBeats Empty c' = False handBeats (Add c h) c' = cardBeats c c' || handBeats h c' -- 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 rest) | suit c == suit beat && suit c' /= suit beat = c | suit c /= suit beat && suit c' == suit beat = c' | rankBeats (rank c) (rank c') = c' | otherwise = c where c' = chooseCard beat rest prop_chooseCardWinsIfPossible c h = h /= Empty ==> handBeats h c == cardBeats (chooseCard c h) c ------------------------------------------------------------------------- -- The quickCheck "magic" we need to get it to generate arbitrary -- elements of our new datatypes: 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) ] instance Arbitrary Card where arbitrary = do r <- arbitrary s <- arbitrary return (Card r s) 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) ------------------------------------------------------------------------- {- | cardBeats c beat && not (cardBeats c' beat) = c | cardBeats c' beat && not (cardBeats c beat) = c' -}