skat/src/Skat/Bidding.hs

{-# LANGUAGE OverloadedStrings #-}

module Skat.Bidding (
    biddingScore, Game(..), Modifier(..), isHand, getTrump, Result(..),
    getResults
) where

import Data.Aeson hiding (Null, Result)

import Skat.Card
import Data.List (sortOn)
import Data.Ord (Down(..))
import Control.Monad
import Skat.Pile

-- | different game types
data Game = Colour Colour Modifier
          | Grand Modifier
          | Null
          | NullHand
          | NullOuvert
          | NullOuvertHand
            deriving (Show, Eq)

instance ToJSON Game where
    toJSON (Grand mod) =
        object ["game" .= ("grand" :: String), "modifier" .= show mod]
    toJSON (Colour col mod) =
        object ["game" .= ("colour" :: String), "modifier" .= show mod, "colour" .= show col]
    toJSON Null           = object ["game" .= ("null" :: String)]
    toJSON NullHand       = object ["game" .= ("nullhand" :: String)]
    toJSON NullOuvert     = object ["game" .= ("nullouvert" :: String)]
    toJSON NullOuvertHand = object ["game" .= ("nullouverthand" :: String)]

instance FromJSON Game where
    parseJSON = withObject "Game" $ \v -> do
        gamekind <- v .: "game"
        case (gamekind :: String) of
            "colour" -> do
                col <- v .: "colour"
                mod <- v .: "modifier"
                return $ Colour (read col) mod
            "grand" -> do
                mod <- v .: "modifier"
                return $ Grand mod
            "null" -> return Null
            "nullhand" -> return NullHand
            "nullouvert" -> return NullOuvert
            "nullouverthand" -> return NullOuvertHand
            _ -> mzero

-- | modifiers for grand and colour games
data Modifier = Einfach
              | Schneider
              | Schwarz
              | Hand
              | HandSchneider
              | HandSchneiderAngesagt
              | HandSchneiderSchwarz
              | HandSchneiderAngesagtSchwarz
              | HandSchwarzAngesagt
              | Ouvert
                deriving (Show, Eq)

instance FromJSON Modifier where
    parseJSON = withObject "Modifier" $ \v -> do
        hnd <- v .: "hand"
        if hnd then do
            schneider <- v .:? "schneider" .!= False
            schwarz <- v .:? "schwarz" .!= False
            ouvert <- v .:? "ouvert" .!= False
            case (schneider, schwarz, ouvert) of
                (_, _, True) -> return Ouvert
                (True, False, _) -> return HandSchneiderAngesagt
                (_, True, _) -> return HandSchwarzAngesagt
                _ -> return Hand
        else return Einfach

isHand :: Modifier -> Bool
isHand Einfach   = False
isHand Schneider = False
isHand Schwarz   = False
isHand _         = True

-- | calculate the value of a game with given cards
biddingScore :: HasCard c => Game -> [c] -> Int
biddingScore game@(Grand           mod) cards = (spitzen game cards + modifierFactor mod) * 24
biddingScore game@(Colour Clubs    mod) cards = (spitzen game cards + modifierFactor mod) * 12
biddingScore game@(Colour Spades   mod) cards = (spitzen game cards + modifierFactor mod) * 11
biddingScore game@(Colour Hearts   mod) cards = (spitzen game cards + modifierFactor mod) * 10
biddingScore game@(Colour Diamonds mod) cards = (spitzen game cards + modifierFactor mod) * 9
biddingScore Null                       _     = 23
biddingScore NullHand                   _     = 35
biddingScore NullOuvert                 _     = 46
biddingScore NullOuvertHand             _     = 59

-- | calculate the modifier based on the game kind
modifierFactor :: Modifier -> Int
modifierFactor Einfach                      = 1
modifierFactor Schneider                    = 2
modifierFactor Schwarz                      = 3
modifierFactor Hand                         = 2
modifierFactor HandSchneider                = 3
modifierFactor HandSchneiderAngesagt        = 4
modifierFactor HandSchneiderSchwarz         = 4
modifierFactor HandSchneiderAngesagtSchwarz = 5
modifierFactor HandSchwarzAngesagt          = 6
modifierFactor Ouvert                       = 7

-- | get all available trumps for a given game
allTrumps :: Game -> [Card]
allTrumps (Grand _) = jacks
allTrumps (Colour col _) = jacks ++ [Card t col | t <- [Ace,Ten .. Seven] ]

jacks :: [Card]
jacks = [ Card Jack Clubs, Card Jack Spades, Card Jack Hearts, Card Jack Diamonds ]

-- | calculate the spitzen count
spitzen :: HasCard c => Game -> [c] -> Int
spitzen game cards
      | null trumps = length $ allTrumps game
      | mit = foldl (\val (a, o) -> if a == o then val + 1 else val) 0 zipped
      | otherwise = findOhne (allTrumps game) 0
    where trumps = getTrumps game cards
          zipped = zip (allTrumps game) trumps
          mit = Card Jack Clubs == head trumps
          findOhne []     acc = acc
          findOhne (c:cs) acc = if c /= highest then findOhne cs (acc+1) else acc
          highest = head trumps

-- | get all trumps for a given game out of a hand of cards
getTrumps :: HasCard c => Game -> [c] -> [Card]
getTrumps (Grand _) cards = sortOn Down $ filter (isTrump Jacks) $ map toCard cards
getTrumps (Colour col _) cards = sortOn Down $ filter (isTrump $ TrumpColour col) $ map toCard cards
getTrumps _              _      = []

-- | get trump for a given game
getTrump :: Game -> Trump
getTrump (Colour col _) = TrumpColour col
getTrump (Grand _)      = Jacks
getTrump _              = None

data Result = Result { resultGame :: Game
                     , resultScore :: Int
                     , resultSinglePoints :: Int
                     , resultTeamPoints :: Int }
              deriving (Show, Eq)

instance ToJSON Result where
    toJSON (Result game points sgl tm) =
        object ["game" .= game, "points" .= points, "single" .= sgl, "team" .= tm]

isSchwarz :: Team -> Piles -> Bool
isSchwarz tm = null . wonCards tm 

hasWon :: Game -> Piles -> (Bool, Game)
hasWon Null           ps = (Single `isSchwarz` ps, Null)
hasWon NullHand       ps = (Single `isSchwarz` ps, NullHand)
hasWon NullOuvert     ps = (Single `isSchwarz` ps, NullOuvert)
hasWon NullOuvertHand ps = (Single `isSchwarz` ps, NullOuvertHand)
hasWon (Colour col mod) ps = let (b, mod') = meetsCall mod ps
                             in (b, Colour col mod')
hasWon (Grand mod) ps = let (b, mod') = meetsCall mod ps
                        in (b, Grand mod')

meetsCall :: Modifier -> Piles -> (Bool, Modifier)
meetsCall Hand ps = case wonByPoints ps of
    (b, Schneider) -> (b, HandSchneider)
    (b, Schwarz) -> (b, HandSchneiderSchwarz)
    (b, Einfach) -> (b, Hand)
meetsCall HandSchneiderAngesagt ps = case wonByPoints ps of
    (b, Schneider) -> (b, HandSchneiderAngesagt)
    (b, Schwarz) -> (b, HandSchneiderAngesagtSchwarz)
    (b, Einfach) -> (False, HandSchneiderAngesagt)
meetsCall HandSchwarzAngesagt ps = case wonByPoints ps of
    (b, Schneider) -> (False, HandSchwarzAngesagt)
    (b, Schwarz) -> (b, HandSchwarzAngesagt)
    (b, Einfach) -> (False, HandSchwarzAngesagt)
meetsCall _ ps = wonByPoints ps

wonByPoints :: Piles -> (Bool, Modifier)
wonByPoints ps
    | Team `isSchwarz` ps    = (True,     Schwarz)
    | sgl              >= 90 = (True,     Schneider)
    | Single `isSchwarz` ps  = (False,    Schwarz)
    | sgl              <= 30 = (False,    Schneider)
    | otherwise              = (sgl > 60, Einfach)
  where (sgl, _) = count ps :: (Int, Int)

-- | get result of game
getResults :: Game -> Hand -> Piles -> Piles -> Result
getResults game sglPlayer before after = Result afterGame score sglPoints teamPoints
    where (won, afterGame) = hasWon game after
          hand = skatCards before ++ (map toCard $ handCards sglPlayer before)
          (sglPoints, teamPoints) = count after
          gameScore = biddingScore afterGame hand 
          score = if won then gameScore else (-2) * gameScore