skat/src/Skat/Card.hs

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}

module Skat.Card where

import Data.List
import Data.Aeson
import System.Random (newStdGen)
import Control.DeepSeq

import Skat.Utils

class Countable a b where
    count :: a -> b

data Type = Seven
          | Eight
          | Nine
          | Queen
          | King
          | Ten
          | Ace
          | Jack
            deriving (Eq, Ord, Show, Enum, Read)

instance Countable Type Int where
    count Ace   = 11
    count Ten   = 10
    count King  = 4
    count Queen = 3
    count Jack  = 2
    count _     = 0

data Colour = Diamonds
            | Hearts
            | Spades
            | Clubs
              deriving (Eq, Ord, Show, Enum, Read)

data Card = Card Type Colour
            deriving (Eq, Show, Ord)

instance ToJSON Card where
    toJSON (Card t c) =
        object ["type" .= show t, "colour" .= show c]

instance FromJSON Card where
    parseJSON = withObject "Card" $ \v -> do
        t <- v .: "type"
        c <- v .: "colour"
        return $ Card (read t) (read c)

getColour :: Card -> Colour
getColour (Card _ c) = c

getID :: Card -> Int
getID (Card t _) = case t of
    Seven -> 0
    Eight -> 0
    Nine -> 0
    Queen -> 2
    King -> 4
    Ten -> 8
    Ace -> 16
    Jack -> 32

instance Countable Card Int where
    count (Card t _) = count t

instance Countable [Card] Int where
    count = sum . map count

instance NFData Card where
    rnf (Card t c) = t `seq` c `seq` ()

equals :: Colour -> Maybe Colour -> Bool
equals col (Just x) = col == x
equals col Nothing = True

isTrump :: Colour -> Card -> Bool
isTrump trumpCol (Card tp col)
    | tp == Jack = True
    | otherwise = col == trumpCol

effectiveColour :: Colour -> Card -> Colour
effectiveColour trumpCol card@(Card _ col) =
    if trump then trumpCol else col
  where trump = isTrump trumpCol card

isAllowed :: Colour -> Maybe Colour -> [Card] -> Card -> Bool
isAllowed trumpCol turnCol cs card =
    if col `equals` turnCol
        then True
        else not $ any (\ca -> effectiveColour trumpCol ca `equals` turnCol && ca /= card) cs
  where col = effectiveColour trumpCol card

compareCards :: Colour
             -> Maybe Colour
             -> Card
             -> Card
             -> Ordering
compareCards _ _ (Card Jack col1) (Card Jack col2) = compare col1 col2
compareCards trumpCol turnCol c1@(Card tp1 col1) c2@(Card tp2 col2) =
    case (trp1, trp2) of
        (True, True) -> compare tp1 tp2
        (False, False) -> case compare (col1 `equals` turnCol)
                                       (col2 `equals` turnCol) of
                            EQ -> compare tp1 tp2
                            v -> v
        _ -> compare trp1 trp2
  where trp1 = isTrump trumpCol c1
        trp2 = isTrump trumpCol c2

sortCards :: Colour -> Maybe Colour -> [Card] -> [Card]
sortCards trumpCol turnCol cs = sortBy (compareCards trumpCol turnCol) cs

highestCard :: Colour -> Maybe Colour -> [Card] -> Card
highestCard trumpCol turnCol cs = maximumBy (compareCards trumpCol turnCol) cs

shuffleCards :: IO [Card]
shuffleCards = do
    gen <- newStdGen
    return $ shuffle gen allCards

-- TESTING VARS

c1 :: Card
c1 = Card Jack Spades

c2 :: Card
c2 = Card Ace Diamonds

c3 :: Card
c3 = Card Queen Diamonds

c4 :: Card
c4 = Card Queen Hearts

c5 :: Card
c5 = Card Jack Clubs

h1 :: [Card]
h1 = [c1,c2,c3,c4,c5]

allCards :: [Card]
allCards = [ Card t c | t <- tps, c <- cols ]
    where tps = [Seven .. Jack]
          cols = [Diamonds .. Clubs]