skat/src/Skat/Pile.hs

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

module Skat.Pile where

import Data.List
import Data.Aeson
import Control.Exception

import Skat.Card
import Skat.Utils

data Team = Team | Single
            deriving (Show, Eq, Ord, Enum)

data CardS p = CardS { getCard :: Card
                     , getPile :: p }
               deriving (Show, Eq, Ord)

instance Countable (CardS p) Int where
    count = count . getCard

instance ToJSON p => ToJSON (CardS p) where
    toJSON (CardS card pile) =
        object ["card" .= card, "pile" .= pile]

data Hand = Hand1 | Hand2 | Hand3
            deriving (Show, Eq, Ord)

next :: Hand -> Hand
next Hand1 = Hand2
next Hand2 = Hand3
next Hand3 = Hand1

prev :: Hand -> Hand
prev Hand1 = Hand3
prev Hand2 = Hand1
prev Hand3 = Hand2

data Played = Table Hand
            | Won Hand Team
              deriving (Show, Eq, Ord)

instance ToJSON Played where
    toJSON (Table hand) =
        object ["state" .= ("table" :: String), "played_by" .= show hand]
    toJSON (Won hand team) =
        object ["state" .= ("won" :: String), "played_by" .= show hand, "won_by" .= show team]

data SkatP = SkatP
             deriving (Show, Eq, Ord)

data Piles = Piles { hands :: [CardS Hand]
                   , played :: [CardS Played]
                   , skat :: [CardS SkatP] }
             deriving (Show, Eq, Ord)

instance Countable Piles (Int, Int) where
    count ps = (sgl, tm)
        where sgl = count (skatCards ps) + count (wonCards Single ps)
              tm = count (wonCards Team ps)

origin :: CardS Played -> Hand
origin (CardS _ (Table hand)) = hand
origin (CardS _ (Won hand _)) = hand

originOfCard :: Card -> Piles -> Maybe Hand
originOfCard card (Piles _ pld _) = origin <$> find ((==card) . getCard) pld

playCard :: Card -> Piles -> Piles
playCard card (Piles hs pld skt) = Piles hs' (ca : pld) skt
    where (CardS _ hand, hs') = remove ((==card) . getCard) hs
          ca = CardS card (Table hand)

winCard :: Team -> CardS Played -> CardS Played
winCard team (CardS card (Table hand)) = CardS card (Won hand team)
winCard team c                         = c

wonCards :: Team -> Piles -> [Card]
wonCards team (Piles _ pld _) = filterMap (f . getPile) getCard pld
    where f (Won _ tm) = tm == team
          f _          = False

cleanTable :: Team -> Piles -> Piles
cleanTable winner ps@(Piles hs pld skt) = Piles hs pld' skt
    where table = tableCards ps
          pld' = map (winCard winner) pld

tableCards :: Piles -> [Card]
tableCards (Piles _ pld _) = filterMap (f . getPile) getCard pld
    where f (Table _) = True
          f _         = False

tableCardsS :: Piles -> [CardS Played]
tableCardsS (Piles _ pld _) = filter (f . getPile) pld
    where f (Table _) = True
          f _         = False

handCards :: Hand -> Piles -> [Card]
handCards hand (Piles hs _ _) = filterMap ((==hand) . getPile) getCard hs

skatCards :: Piles -> [Card]
skatCards (Piles _ _ skat) = map getCard skat

putAt :: p -> Card -> CardS p
putAt = flip CardS

distribute :: [Card] -> Piles
distribute cards = Piles hands [] (map (putAt SkatP) skt)
    where round1 = chunksOf 3 (take 9 cards)
          skt = take 2 $ drop 9 cards
          round2 = chunksOf 4 (take 12 $ drop 11 cards)
          round3 = chunksOf 3 (take 9 $ drop 23 cards)
          hand1 = concatMap (!! 0) [round1, round2, round3]
          hand2 = concatMap (!! 1) [round1, round2, round3]
          hand3 = concatMap (!! 2) [round1, round2, round3]
          hands = map (putAt Hand1) hand1
            ++ map (putAt Hand2) hand2
            ++ map (putAt Hand3) hand3