126 lines
3.6 KiB
Haskell
126 lines
3.6 KiB
Haskell
{-# 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)
|
|
|
|
toInt :: Hand -> Int
|
|
toInt Hand1 = 1
|
|
toInt Hand2 = 2
|
|
toInt Hand3 = 3
|
|
|
|
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
|