diff --git a/Card.hs b/Card.hs index d9f0d0b..151e68a 100644 --- a/Card.hs +++ b/Card.hs @@ -1,8 +1,15 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} + module Card where import Data.List +import System.Random (newStdGen) import Utils +class Countable a b where + count :: a -> b + data Type = Seven | Eight | Nine @@ -13,13 +20,13 @@ data Type = Seven | Jack deriving (Eq, Ord, Show, Enum) -countType :: Type -> Int -countType Ace = 11 -countType Ten = 10 -countType King = 4 -countType Queen = 3 -countType Jack = 2 -countType _ = 0 +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 @@ -30,73 +37,14 @@ data Colour = Diamonds data Card = Card Type Colour deriving (Eq, Show) -countCard :: Card -> Int -countCard (Card t _) = countType t - -count :: [Card] -> Int -count = sum . map countCard - -data Team = Team | Single - deriving (Show, Eq, Ord, Enum) - -data Space = Table | Hand1 | Hand2 | Hand3 | WonTeam | WonSingle | SkatP - deriving (Show, Eq, Ord, Enum) - -teamPile :: Team -> Space -teamPile Team = WonTeam -teamPile Single = WonSingle - -playerHand :: Index -> Space -playerHand One = Hand1 -playerHand Two = Hand2 -playerHand Three = Hand3 - -playerOfHand :: Space -> Index -playerOfHand Hand1 = One -playerOfHand Hand2 = Two -playerOfHand Hand3 = Three - -data CardS = CardS { getCard :: Card - , getSpace :: Space - , getOwner :: Space } - deriving (Show, Eq) +getColour :: Card -> Colour +getColour (Card _ c) = c -moveCard :: Card -> Space -> [CardS] -> [CardS] -moveCard card sp cards = map f cards - where f c = if card == getCard c then c { getSpace = sp } else c +instance Countable Card Int where + count (Card t _) = count t -findCards :: Space -> [CardS] -> [Card] -findCards sp cards = foldr f [] cards - where f (CardS c s _) cs - | s == sp = c : cs - | otherwise = cs - -data Index = One | Two | Three - deriving (Show, Ord, Eq, Enum) - -next :: Index -> Index -next One = Two -next Two = Three -next Three = One - -prev :: Index -> Index -prev One = Three -prev Two = One -prev Three = Two - -data Player = Player { team :: Team - , index :: Index } - deriving Show - -data Players = Players Player Player Player - deriving Show - -player :: Players -> Index -> Player -player (Players p _ _) One = p -player (Players _ p _) Two = p -player (Players _ _ p) Three = p - -type Hand = [Card] +instance Countable [Card] Int where + count = sum . map count equals :: Colour -> Maybe Colour -> Bool equals col (Just x) = col == x @@ -112,31 +60,37 @@ effectiveColour trumpCol card@(Card _ col) = if trump then trumpCol else col where trump = isTrump trumpCol card -isAllowed :: Colour -> Maybe Colour -> Hand -> Card -> Bool +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 -putAt :: Space -> Card -> CardS -putAt sp c = CardS c sp sp - -distribute :: [Card] -> [CardS] -distribute cards = map (putAt Hand1) hand1 - ++ map (putAt Hand2) hand2 - ++ map (putAt Hand3) hand3 - ++ 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] - -playersFromTable :: Players -> [CardS] -> [Player] -playersFromTable ps = map (player ps . playerOfHand . getOwner) +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 compare trp1 trp2 of + EQ -> + case compare (col1 `equals` turnCol) + (col2 `equals` turnCol) of + EQ -> compare tp1 tp2 + v -> v + v -> v + where trp1 = isTrump trumpCol c1 + trp2 = isTrump trumpCol c2 + +sortCards :: Colour -> Maybe Colour -> [Card] -> [Card] +sortCards trumpCol turnCol cs = sortBy (compareCards trumpCol turnCol) cs + +shuffleCards :: IO [Card] +shuffleCards = do + gen <- newStdGen + return $ shuffle gen allCards -- TESTING VARS @@ -155,15 +109,10 @@ c4 = Card Queen Hearts c5 :: Card c5 = Card Jack Clubs -h1 :: Hand +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] - -distributePutSkat :: [Card] -> [CardS] -distributePutSkat cards = foldr (\c m -> moveCard c WonSingle m) distributed skt - where distributed = distribute cards - skt = findCards SkatP distributed diff --git a/Operations.hs b/Operations.hs index 2ca34e5..c901eea 100644 --- a/Operations.hs +++ b/Operations.hs @@ -7,28 +7,10 @@ import Data.Ord import Card import Skat +import Pile +import Player import Utils (shuffle) -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 compare trp1 trp2 of - EQ -> - case compare (col1 `equals` turnCol) - (col2 `equals` turnCol) of - EQ -> compare tp1 tp2 - v -> v - v -> v - where trp1 = isTrump trumpCol c1 - trp2 = isTrump trumpCol c2 - -sortCards :: Colour -> Maybe Colour -> [Card] -> [Card] -sortCards trumpCol turnCol cs = sortBy (compareCards trumpCol turnCol) cs - compareRender :: Card -> Card -> Ordering compareRender (Card t1 c1) (Card t2 c2) = case compare c1 c2 of EQ -> compare t1 t2 @@ -37,167 +19,62 @@ compareRender (Card t1 c1) (Card t2 c2) = case compare c1 c2 of sortRender :: [Card] -> [Card] sortRender = sortBy compareRender --- | finishes the calculation of a match -turning :: Index -> Skat (Int, Int) -turning n = undefined - -turn2 :: Index -> Skat (Int, Int) -turn2 n = do - t <- table - ps <- gets players - let p = player ps n - hand <- cardsAt (playerHand $ index p) - if length hand == 0 - then countGame - else case length t of - 0 -> play p >> turn2 (next n) - 1 -> do - modify (setTurnColour . f . head $ t) - play p - turn2 (next n) - 2 -> play p >> evaluateTable >>= turn2 - 3 -> evaluateTable >>= turn2 - where f (Card _ col) = Just col - -simulate :: Team -> Index -> Skat (Int, Int) -simulate team n = do - t <- table +turn :: Hand -> Skat (Int, Int) +turn n = do + table <- getp tableCards ps <- gets players let p = player ps n - hand <- cardsAt (playerHand $ index p) - if length hand == 0 - then countGame - else case length t of - 0 -> playOpen team p >> simulate team (next n) - 1 -> do - modify (setTurnColour . f . head $ t) - playOpen team p - simulate team (next n) - 2 -> playOpen team p >> evaluateTable >>= simulate team - 3 -> evaluateTable >>= simulate team - where f (Card _ col) = Just col - -evaluateTable :: Skat Index + hand <- getp $ handCards n + case length table of + 0 -> play p >> turn (next n) + 1 -> do + modify $ setTurnColour (Just $ getColour $ head table) + play p + turn (next n) + 2 -> play p >> turn (next n) + 3 -> do + w <- evaluateTable + if length hand == 0 then countGame else turn w + +evaluateTable :: Skat Hand evaluateTable = do trumpCol <- gets trumpColour turnCol <- gets turnColour - t <- table - ts <- tableS + table <- getp tableCards ps <- gets players - let psOrdered = playersFromTable ps ts - l = zip psOrdered t - g a b = compareCards trumpCol turnCol (snd a) (snd b) - (winner, _) = last (sortBy g l) - pile = teamPile $ team winner - forM t (\c -> move c pile) + let winningCard = head $ sortCards trumpCol turnCol table + Just winnerHand <- getp $ originOfCard winningCard + let winner = player ps winnerHand + modifyp $ cleanTable (team winner) modify $ setTurnColour Nothing - return $ index winner + return $ hand winner countGame :: Skat (Int, Int) -countGame = do - sgl <- count <$> cardsAt WonSingle - tm <- count <$> cardsAt WonTeam - return (sgl, tm) - -turn :: Index -> Skat Index -turn n = do - ps <- gets players - let p1 = player ps n - p2 = player ps (next n) - p3 = player ps (next $ next n) - c1@(Card _ col) <- play p1 - modify $ setTurnColour (Just col) - c2 <- play p2 - c3 <- play p3 - trumpCol <- gets trumpColour - turnCol <- gets turnColour - let l = zip3 [p1, p2, p3] [c1, c2, c3] [n, next n, next $ next n] - g a b = compareCards trumpCol turnCol (f a) (f b) - (winner, _, idx) = last (sortBy g l) - pile = teamPile $ team winner - move c1 pile - move c2 pile - move c3 pile - modify $ setTurnColour Nothing - return idx - where f (_, x, _) = x +countGame = getp count -play :: Player -> Skat Card +play :: Player p => p -> Skat Card play p = do - table <- table + table <- getp tableCards turnCol <- gets turnColour trump <- gets trumpColour - hand <- cardsAt (playerHand $ index p) - let card = playCard p table hand trump turnCol - move card Table - return card - -playOpen :: Team -> Player -> Skat Card -playOpen team p = do - card <- playCardOpenAI team p - move card Table + hand <- getp $ handCards (hand p) + let card = chooseCard p trump turnCol hand + modifyp $ playCard card return card --- | cheating AI that knows all cards (open play) -playCardOpenAI :: Team -> Player -> Skat Card -playCardOpenAI team p = do - table <- table - turnCol <- gets turnColour - trump <- gets trumpColour - hand <- cardsAt (playerHand $ index p) - let possible = filter (isAllowed trump turnCol hand) hand - ownResult = if team == Single then fst else snd - ownIdx = index p - results <- forM possible (\card -> do - move card Table - val <- ownResult <$> simulate team ownIdx - move card (playerHand $ index p) - return (val, card)) - return $ snd $ maximumBy (comparing fst) results - -playCard :: Player - -> [Card] - -> [Card] - -> Colour - -> Maybe Colour - -> Card -playCard p table hand trump turnCol = head possible - where possible = filter (isAllowed trump turnCol hand) hand - -runGame :: Skat (Int, Int) -runGame = do - foldM_ (\i _ -> turn i) One [1..10] - sgl <- fmap count $ cardsAt WonSingle - tm <- fmap count $ cardsAt WonTeam - return (sgl, tm) - -shuffleCards :: IO [Card] -shuffleCards = do - gen <- newStdGen - return $ shuffle gen allCards - --- TESTING VARS +---- TESTING VARS env :: SkatEnv -env = SkatEnv cards Nothing Spades playersExamp - where hand1 = take 10 allCards - hand2 = take 10 $ drop 10 allCards - hand3 = take 10 $ drop 20 allCards - skt = drop 30 allCards - cards = map (putAt Hand1) hand1 - ++ map (putAt Hand2) hand2 - ++ map (putAt Hand3) hand3 - ++ map (putAt WonSingle) skt +env = SkatEnv piles Nothing Spades playersExamp + where piles = distribute allCards playersExamp :: Players -playersExamp = Players (Player Team One) (Player Team Two) (Player Single Three) +playersExamp = Players + (PL $ Stupid Team Hand1) + (PL $ Stupid Team Hand2) + (PL $ Stupid Single Hand3) shuffledEnv :: IO SkatEnv shuffledEnv = do cards <- shuffleCards return $ SkatEnv (distribute cards) Nothing Spades playersExamp - -shuffledEnv2 :: IO SkatEnv -shuffledEnv2 = do - cards <- shuffleCards - return $ SkatEnv (distributePutSkat cards) Nothing Spades playersExamp diff --git a/Pile.hs b/Pile.hs new file mode 100644 index 0000000..f6dfd34 --- /dev/null +++ b/Pile.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} + +module Pile where + +import Data.List + +import Card +import Utils +import Control.Exception + +data Team = Team | Single + deriving (Show, Eq, Ord, Enum) + +data CardS p = CardS { getCard :: Card + , getPile :: p } + deriving (Show, Eq) + +instance Countable (CardS p) Int where + count = count . getCard + +data Hand = Hand1 | Hand2 | Hand3 + deriving (Show, Eq) + +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) + +data SkatP = SkatP + deriving (Show, Eq) + +data Piles = Piles { hands :: [CardS Hand] + , played :: [CardS Played] + , skat :: [CardS SkatP] } + deriving (Show, Eq) + +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 + +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 diff --git a/Player.hs b/Player.hs new file mode 100644 index 0000000..17b84c2 --- /dev/null +++ b/Player.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE ExistentialQuantification #-} + +module Player where + +import Card +import Pile + +class Player p where + team :: p -> Team + hand :: p -> Hand + chooseCard :: p -> Colour -> Maybe Colour -> [Card] -> Card + +data Stupid = Stupid { getTeam :: Team + , getHand :: Hand } + deriving Show + +instance Player Stupid where + team = getTeam + hand = getHand + chooseCard p trumpCol turnCol hand = head possible + where possible = filter (isAllowed trumpCol turnCol hand) hand + +data PL = forall p. (Show p, Player p) => PL p + +instance Show PL where + show (PL p) = show p + +instance Player PL where + team (PL p) = team p + hand (PL p) = hand p + chooseCard (PL p) = chooseCard p + +data Players = Players PL PL PL + deriving Show + +player :: Players -> Hand -> PL +player (Players p _ _) Hand1 = p +player (Players _ p _) Hand2 = p +player (Players _ _ p) Hand3 = p + +--playersFromTable :: Players -> [CardS] -> [Player] +--playersFromTable ps = map (player ps . playerOfHand . getOwner) diff --git a/Skat.hs b/Skat.hs index cf169c3..d014eb6 100644 --- a/Skat.hs +++ b/Skat.hs @@ -1,11 +1,16 @@ +{-# LANGUAGE NamedFieldPuns #-} + module Skat where -import Card import Control.Monad.State import Control.Monad.Reader import Data.List -data SkatEnv = SkatEnv { cards :: [CardS] +import Card +import Pile +import Player + +data SkatEnv = SkatEnv { piles :: Piles , turnColour :: Maybe Colour , trumpColour :: Colour , players :: Players } @@ -13,24 +18,12 @@ data SkatEnv = SkatEnv { cards :: [CardS] type Skat = StateT SkatEnv IO -table :: Skat [Card] -table = gets cards >>= return . foldr f [] - where f (CardS c Table _) cs = c : cs - f _ cs = cs - -tableS :: Skat [CardS] -tableS = gets cards >>= return . foldr f [] - where f c@(CardS _ Table _) cs = c : cs - f _ cs = cs - -move :: Card -> Space -> Skat () -move card sp = do - cs <- gets cards - let cs' = moveCard card sp cs - modify (\env -> env { cards = cs' }) +modifyp :: (Piles -> Piles) -> Skat () +modifyp f = modify g + where g env@(SkatEnv {piles}) = env { piles = f piles} -cardsAt :: Space -> Skat [Card] -cardsAt sp = gets cards >>= return . findCards sp +getp :: (Piles -> a) -> Skat a +getp f = gets piles >>= return . f setTurnColour :: Maybe Colour -> SkatEnv -> SkatEnv setTurnColour col sk = sk { turnColour = col } diff --git a/Utils.hs b/Utils.hs index aefc2dc..b1a2e67 100644 --- a/Utils.hs +++ b/Utils.hs @@ -22,3 +22,11 @@ query s = do case l of Just x -> return x Nothing -> query s + +remove :: (a -> Bool) -> [a] -> (a, [a]) +remove pred xs = foldr f (undefined, []) xs + where f c (old, cs) = if pred c then (c, cs) else (old, c : cs) + +filterMap :: (a -> Bool) -> (a -> b) -> [a] -> [b] +filterMap pred f as = foldr g [] as + where g a bs = if pred a then f a : bs else bs