skat/src/Skat/Bidding.hs

{-# LANGUAGE OverloadedStrings #-}

module Skat.Bidding (
    biddingScore, Game(..), Modifier(..), isHand, getTrump, Result(..),
    getResults, isOuvert, isSchwarz, Bid, checkGame, HideGame(..)
) where

import Data.Aeson hiding (Null, Result)

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

type Bid = Int

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

newtype HideGame = HideGame Game
                   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 ToJSON HideGame where
    toJSON (HideGame (Grand mod)) =
        object ["game" .= ("grand" :: String), "modifier" .= prettyShow mod]
    toJSON (HideGame (Colour col mod)) =
        object ["game" .= ("colour" :: String), "modifier" .= prettyShow mod, "colour" .= show col]
    toJSON (HideGame game) = toJSON game

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
              | HandSchwarz
              | 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

prettyShow :: Modifier -> String
prettyShow Schneider                    = show Einfach
prettyShow Schwarz                      = show Einfach
prettyShow HandSchneider                = show Hand
prettyShow HandSchwarz                  = show Hand
prettyShow HandSchneiderAngesagtSchwarz = show HandSchneiderAngesagt
prettyShow mod                          = show mod

isHand :: Game -> Bool
isHand NullHand = True
isHand NullOuvertHand = True
isHand (Colour _ mod) = modIsHand mod
isHand (Grand mod) = modIsHand mod
isHand _ = False

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

isOuvert :: Game -> Bool
isOuvert NullOuvert        = True
isOuvert NullOuvertHand    = True
isOuvert (Grand Ouvert)    = True
isOuvert (Colour _ Ouvert) = True
isOuvert _                 = False

baseFactor :: Game -> Int
baseFactor (Grand _)           = 24
baseFactor (Colour Clubs _)    = 12
baseFactor (Colour Spades _)   = 11
baseFactor (Colour Hearts _)   = 10
baseFactor (Colour Diamonds _) = 9
baseFactor Null                = 23
baseFactor NullHand            = 35
baseFactor NullOuvert          = 46
baseFactor NullOuvertHand      = 59

-- | 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 game                       _     = baseFactor game

-- | 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 HandSchwarz                  = 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] ]
allTrumps _              = []

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, HandSchwarz)
    (b, Einfach) -> (b, Hand)
meetsCall Schneider ps = case wonByPoints ps of
    (b, Schneider) -> (b, Schneider)
    (b, Schwarz) -> (b, Schwarz)
    (b, Einfach) -> (False, Schneider)
meetsCall Schwarz ps = case wonByPoints ps of
    (b, Schneider) -> (False, Schwarz)
    (b, Schwarz) -> (b, Schwarz)
    (b, Einfach) -> (False, Schwarz)
meetsCall HandSchneider ps = case wonByPoints ps of
    (b, Schneider) -> (b, HandSchneider)
    (b, Schwarz) -> (b, HandSchwarz)
    (b, Einfach) -> (False, HandSchneider)
meetsCall HandSchneiderAngesagt ps = case wonByPoints ps of
    (b, Schneider) -> (b, HandSchneiderAngesagt)
    (b, Schwarz) -> (b, HandSchneiderAngesagtSchwarz)
    (b, Einfach) -> (False, HandSchneiderAngesagt)
meetsCall HandSchwarz ps = case wonByPoints ps of
    (b, Schneider) -> (False, HandSchwarz)
    (b, Schwarz) -> (b, HandSchwarz)
    (b, Einfach) -> (False, HandSchwarz)
meetsCall HandSchwarzAngesagt ps = case wonByPoints ps of
    (b, Schneider) -> (False, HandSchwarzAngesagt)
    (b, Schwarz) -> (b, HandSchwarzAngesagt)
    (b, Einfach) -> (False, HandSchwarzAngesagt)
meetsCall Ouvert ps = case wonByPoints ps of
    (b, Schneider) -> (False, Ouvert)
    (b, Schwarz) -> (b, Ouvert)
    (b, Einfach) -> (False, Ouvert)
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 -> Bid -> Hand -> Piles -> Piles -> Result
getResults game bid sglPlayer before after = case checkGame bid hand game of
        Just game' -> let (won, afterGame) = hasWon game' after
                          gameScore = biddingScore afterGame hand 
                          score = if won then gameScore else (-2) * gameScore
            in Result afterGame score sglPoints teamPoints
        Nothing -> let gameScore = baseFactor game * ceiling (fromIntegral bid / fromIntegral (baseFactor game))
                       score = (-2) * gameScore
            in Result game score sglPoints teamPoints
    where hand = skatCards before ++ (map toCard $ handCards sglPlayer before)
          (sglPoints, teamPoints) = count after

checkGame :: HasCard c => Bid -> [c] -> Game -> Maybe Game
checkGame bid cards game@(Colour col mod)
    | biddingScore game cards >= bid = Just game
    | otherwise                      = upgrade mod >>= \mod' -> checkGame bid cards (Colour col mod')
checkGame bid cards game@(Grand mod)
    | biddingScore game cards >= bid = Just game
    | otherwise                      = upgrade mod >>= \mod' -> checkGame bid cards (Grand mod')
checkGame bid cards game
    | biddingScore game cards >= bid = Just game
    | otherwise                      = Nothing

upgrade :: Modifier -> Maybe Modifier
upgrade Einfach               = Just Schneider
upgrade Schneider             = Just Schwarz
upgrade Hand                  = Just HandSchneider
upgrade HandSchneider         = Just HandSchwarz
upgrade HandSchneiderAngesagt = Just HandSchneiderAngesagtSchwarz
upgrade _                     = Nothing