diff --git a/.gitignore b/.gitignore index 7806da8..63ee796 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,8 @@ +* + +!*.* +!*/ + *.hi *.o *.prof diff --git a/AI/Human.hs b/AI/Human.hs new file mode 100644 index 0000000..5b817d9 --- /dev/null +++ b/AI/Human.hs @@ -0,0 +1,37 @@ +module AI.Human where + +import Control.Monad.Trans (liftIO) + +import Player +import Pile +import Card +import Utils +import Render + +data Human = Human { getTeam :: Team + , getHand :: Hand } + deriving Show + +instance Player Human where + team = getTeam + hand = getHand + chooseCard p table _ hand = do + trumpCol <- trumpColour + turnCol <- turnColour + let possible = filter (isAllowed trumpCol turnCol hand) hand + c <- liftIO $ askIO (map getCard table) possible hand + return $ (c, p) + +askIO :: [Card] -> [Card] -> [Card] -> IO Card +askIO table possible hand = do + putStrLn "Your hand" + render hand + putStrLn "These options are possible" + render possible + putStrLn "These cards are on the table" + render table + idx <- query + "Which card do you want to play? Give the index of the card" + if idx >= 0 && idx < length possible + then return $ possible !! idx + else askIO table possible hand diff --git a/AI/Rulebased.hs b/AI/Rulebased.hs new file mode 100644 index 0000000..0101e92 --- /dev/null +++ b/AI/Rulebased.hs @@ -0,0 +1,405 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} + +module AI.Rulebased ( + mkAIEnv +) where + +import Data.Ord +import Data.Monoid ((<>)) +import Data.List +import Control.Monad.State +import Control.Monad.Reader +import qualified Data.Map.Strict as M + +import Player +import qualified Player.Utils as P +import Pile +import Card +import Utils +import Skat (Skat, modifyp, mkSkatEnv) +import Operations + +data AIEnv = AIEnv { getTeam :: Team + , getHand :: Hand + , table :: [CardS Played] + , fallen :: [CardS Played] + , myHand :: [Card] + , guess :: Guess + , simulationDepth :: Int } + deriving Show + +setTable :: [CardS Played] -> AIEnv -> AIEnv +setTable tab env = env { table = tab } + +setHand :: [Card] -> AIEnv -> AIEnv +setHand hand env = env { myHand = hand } + +setFallen :: [CardS Played] -> AIEnv -> AIEnv +setFallen fallen env = env { fallen = fallen } + +setDepth :: Int -> AIEnv -> AIEnv +setDepth depth env = env { simulationDepth = depth } + +modifyg :: MonadPlayer m => (Guess -> Guess) -> AI m () +modifyg f = modify g + where g env@(AIEnv {guess}) = env { guess = f guess } + +type AI m = StateT AIEnv m + +instance MonadPlayer m => MonadPlayer (AI m) where + trumpColour = lift $ trumpColour + turnColour = lift $ turnColour + showSkat = lift . showSkat + +instance MonadPlayerOpen m => MonadPlayerOpen (AI m) where + showPiles = lift $ showPiles + +type Simulator m = ReaderT Piles (AI m) + +instance MonadPlayer m => MonadPlayer (Simulator m) where + trumpColour = lift $ trumpColour + turnColour = lift $ turnColour + showSkat = lift . showSkat + +instance MonadPlayer m => MonadPlayerOpen (Simulator m) where + showPiles = ask + +runWithPiles :: MonadPlayer m + => Piles -> Simulator m a -> AI m a +runWithPiles ps sim = runReaderT sim ps + +instance Player AIEnv where + team = getTeam + hand = getHand + chooseCard p table fallen hand = runStateT (do + modify $ setTable table + modify $ setHand hand + modify $ setFallen fallen + choose) p + onCardPlayed p card = execStateT (do + onPlayed card) p + chooseCardOpen p = evalStateT chooseOpen p + +value :: Card -> Int +value (Card Ace _) = 100 +value _ = 0 + +data Option = H Hand + | Skt + deriving (Show, Eq, Ord) + +-- | possible card distributions +type Guess = M.Map Card [Option] + +newGuess :: Guess +newGuess = M.fromList l + where l = map (\c -> (c, [H Hand1, H Hand2, H Hand3, Skt])) allCards + +hasBeenPlayed :: Card -> Guess -> Guess +hasBeenPlayed card = M.delete card + +has :: Hand -> [Card] -> Guess -> Guess +has hand cs = M.mapWithKey f + where f card hands + | card `elem` cs = [H hand] + | otherwise = hands + +hasNoLonger :: MonadPlayer m => Hand -> Colour -> AI m () +hasNoLonger hand colour = do + trCol <- trumpColour + modifyg $ hasNoLonger_ trCol hand colour + +hasNoLonger_ :: Colour -> Hand -> Colour -> Guess -> Guess +hasNoLonger_ trColour hand effCol = M.mapWithKey f + where f card hands + | effectiveColour trColour card == effCol && (H hand) `elem` hands = filter (/=H hand) hands + | otherwise = hands + +isSkat :: [Card] -> Guess -> Guess +isSkat cs = M.mapWithKey f + where f card hands + | card `elem` cs = [Skt] + | otherwise = hands + +type Turn = (CardS Played, CardS Played, CardS Played) + +analyzeTurn :: MonadPlayer m => Turn -> AI m () +analyzeTurn (c1, c2, c3) = do + modifyg (getCard c1 `hasBeenPlayed`) + modifyg (getCard c2 `hasBeenPlayed`) + modifyg (getCard c3 `hasBeenPlayed`) + trCol <- trumpColour + let turnCol = getColour $ getCard c1 + demanded = effectiveColour trCol (getCard c1) + col2 = effectiveColour trCol (getCard c2) + col3 = effectiveColour trCol (getCard c3) + if col2 /= demanded + then origin c2 `hasNoLonger` demanded + else return () + if col3 /= demanded + then origin c3 `hasNoLonger` demanded + else return () + +type Distribution = ([Card], [Card], [Card], [Card]) + +toPiles :: [CardS Played] -> Distribution -> Piles +toPiles table (h1, h2, h3, skt) = Piles (cs1 ++ cs2 ++ cs3) table ss + where cs1 = map (putAt Hand1) h1 + cs2 = map (putAt Hand2) h2 + cs3 = map (putAt Hand3) h3 + ss = map (putAt SkatP) skt + +distributions :: Guess -> (Int, Int, Int, Int) -> [Distribution] +distributions guess nos = + helper (sortBy (comparing $ length . snd) $ M.toList guess) nos + where helper [] _ = [] + helper ((c, hs):[]) ns = map fst (distr c hs ns) + helper ((c, hs):gs) ns = + let dsWithNs = distr c hs ns + go (d, ns') = map (d <>) (helper gs ns') + in concatMap go dsWithNs + distr card hands (n1, n2, n3, n4) = + let f card (H Hand1) = + (([card], [], [], []), (n1+1, n2, n3, n4)) + f card (H Hand2) = + (([], [card], [], []), (n1, n2+1, n3, n4)) + f card (H Hand3) = + (([], [], [card], []), (n1, n2, n3+1, n4)) + f card Skt = + (([], [], [], [card]), (n1, n2, n3, n4+1)) + isOk (H Hand1) = n1 < cardsPerHand + isOk (H Hand2) = n2 < cardsPerHand + isOk (H Hand3) = n3 < cardsPerHand + isOk Skt = n4 < 2 + in filterMap isOk (f card) hands + cardsPerHand = (length guess - 2) `div` 3 + +simplify :: Int -> [Distribution] -> [Distribution] +simplify 10 ds = nubBy is789Variation ds +simplify _ ds = ds + +is789Variation :: Distribution -> Distribution -> Bool +is789Variation (ha1, ha2, ha3, sa) (hb1, hb2, hb3, sb) = + f ha1 hb1 && f ha2 hb2 && f ha3 hb3 && f sa sb + where f cs1 cs2 + | n789s cs1 /= n789s cs2 = False + | otherwise = and (zipCs (c789s cs1) (c789s cs2)) + +zipCs :: [[Card]] -> [[Card]] -> [Bool] +zipCs xs ys = zipWith g xs ys + +c789s :: [Card] -> [[Card]] +c789s cs = groupBy (grouping getColour) $ + sortBy (comparing getColour) $ + filter ((==(0 :: Int)) . count) cs + +n789s :: [Card] -> [Card] +n789s cs = filter ((/=(0 :: Int)) . count) cs + +g :: [a] -> [b] -> Bool +g xs ys = length xs == length ys + +onPlayed :: MonadPlayer m => CardS Played -> AI m () +onPlayed c = do + liftIO $ print c + modifyg (getCard c `hasBeenPlayed`) + trCol <- trumpColour + turnCol <- turnColour + let col = effectiveColour trCol (getCard c) + case turnCol of + Just demanded -> if col /= demanded + then origin c `hasNoLonger` demanded else return () + Nothing -> return () + +choose :: MonadPlayer m => AI m Card +choose = do + handCards <- gets myHand + table <- gets table + case length table of + 0 -> if length handCards >= 7 + then chooseLead + else chooseStatistic + n -> chooseStatistic + +chooseStatistic :: MonadPlayer m => AI m Card +chooseStatistic = do + h <- gets getHand + handCards <- gets myHand + let depth = case length handCards of + 0 -> 0 + 1 -> 1 + -- simulate whole game + 2 -> 2 + 3 -> 3 + -- simulate only partially + 4 -> 2 + 5 -> 1 + 6 -> 1 + 7 -> 1 + 8 -> 1 + 9 -> 1 + 10 -> 1 + modify $ setDepth depth + guess__ <- gets guess + self <- get + maySkat <- showSkat self + let guess_ = (hand self `has` handCards) guess__ + guess = case maySkat of + Just cs -> (cs `isSkat`) guess_ + Nothing -> guess_ + table <- gets table + let ns = case length table of + 0 -> (0, 0, 0, 0) + 1 -> (-1, 0, -1, 0) + 2 -> (0, 0, -1, 0) + let dis = distributions guess ns + disNo = length dis + piless = map (toPiles table) dis + limit = if depth == 1 && length table == 2 + then 1 + else min 10000 $ disNo `div` 2 + liftIO $ putStrLn $ "possible distrs " ++ show disNo + vals <- M.toList <$> foldWithLimit limit runOnPiles M.empty piless + liftIO $ print vals + return $ fst $ maximumBy (comparing snd) vals + +foldWithLimit :: Monad m + => Int + -> (M.Map k Int -> a -> m (M.Map k Int)) + -> M.Map k Int + -> [a] + -> m (M.Map k Int) +foldWithLimit _ _ start [] = return start +foldWithLimit limit f start (x:xs) = do + case M.size (M.filter (>=limit) start) of + 0 -> do m <- f start x + foldWithLimit limit f m xs + _ -> return start + +runOnPiles :: MonadPlayer m + => M.Map Card Int -> Piles -> AI m (M.Map Card Int) +runOnPiles m ps = do + c <- runWithPiles ps chooseOpen + return $ M.insertWith (+) c 1 m + +chooseOpen :: (MonadState AIEnv m, MonadPlayerOpen m) => m Card +chooseOpen = do + piles <- showPiles + hand <- gets getHand + let myCards = handCards hand piles + possible <- filterM (P.isAllowed myCards) myCards + case length myCards of + 0 -> do + liftIO $ print hand + liftIO $ print piles + error "no cards left to choose from" + 1 -> return $ head myCards + _ -> chooseSimulating + +chooseSimulating :: (MonadState AIEnv m, MonadPlayerOpen m) + => m Card +chooseSimulating = do + piles <- showPiles + hand <- gets getHand + let myCards = handCards hand piles + possible <- filterM (P.isAllowed myCards) myCards + case possible of + [card] -> return card + cs -> do + results <- mapM simulate cs + let both = zip results cs + best = maximumBy (comparing fst) both + return $ snd best + +simulate :: (MonadState AIEnv m, MonadPlayerOpen m) + => Card -> m Int +simulate card = do + -- retrieve all relevant info + piles <- showPiles + turnCol <- turnColour + trumpCol <- trumpColour + myTeam <- gets getTeam + myHand <- gets getHand + depth <- gets simulationDepth + let newDepth = depth - 1 + -- create a virtual env with 3 ai players + ps = Players + (PL $ mkAIEnv Team Hand1 newDepth) + (PL $ mkAIEnv Team Hand2 newDepth) + (PL $ mkAIEnv Single Hand3 newDepth) + env = mkSkatEnv piles turnCol trumpCol ps + -- simulate the game after playing the given card + (sgl, tm) <- liftIO $ evalStateT (do + modifyp $ playCard card + turnGeneric playOpen depth (next myHand)) env + let v = if myTeam == Single then (sgl, tm) else (tm, sgl) + -- put the value into context for when not the whole game is + -- simulated + predictValue v + +predictValue :: (MonadState AIEnv m, MonadPlayerOpen m) + => (Int, Int) -> m Int +predictValue (own, others) = do + hand <- gets getHand + piles <- showPiles + let cs = handCards hand piles + pot <- potential cs + return $ own + pot + +potential :: (MonadState AIEnv m, MonadPlayerOpen m) + => [Card] -> m Int +potential cs = do + tr <- trumpColour + let trs = filter (isTrump tr) cs + value = count cs + positions <- filter (==0) <$> mapM position cs + return $ length trs * 10 + value + length positions * 5 + +position :: (MonadState AIEnv m, MonadPlayer m) + => Card -> m Int +position card = do + tr <- trumpColour + guess <- gets guess + let effCol = effectiveColour tr card + l = M.toList guess + cs = filterMap ((==effCol) . effectiveColour tr . fst) fst l + csInd = zip [0..] cs + Just (pos, _) = find ((== card) . snd) csInd + return pos + +leadPotential :: (MonadState AIEnv m, MonadPlayer m) + => Card -> m Int +leadPotential card = do + pos <- position card + isTr <- P.isTrump card + let value = count card + case pos of + 0 -> return value + _ -> return $ -value + +chooseLead :: (MonadState AIEnv m, MonadPlayer m) => m Card +chooseLead = do + cards <- gets myHand + possible <- filterM (P.isAllowed cards) cards + pots <- mapM leadPotential possible + return $ snd $ maximumBy (comparing fst) (zip pots possible) + +mkAIEnv :: Team -> Hand -> Int -> AIEnv +mkAIEnv tm h depth = AIEnv tm h [] [] [] newGuess depth + +-- | TESTING VARS + +aienv :: AIEnv +aienv = AIEnv Single Hand3 [] [] [] newGuess 10 + +testguess :: Guess +testguess = isSkat (take 2 $ drop 10 allCards) + $ Hand3 `has` (take 10 allCards) $ m + where l = map (\c -> (c, [H Hand1, H Hand2, H Hand3, Skt])) (take 32 allCards) + m = M.fromList l + +testds :: [Distribution] +testds = distributions testguess (0, 0, 0, 0) diff --git a/AI/Stupid.hs b/AI/Stupid.hs new file mode 100644 index 0000000..7e8e2f7 --- /dev/null +++ b/AI/Stupid.hs @@ -0,0 +1,18 @@ +module AI.Stupid where + +import Player +import Pile +import Card + +data Stupid = Stupid { getTeam :: Team + , getHand :: Hand } + deriving Show + +instance Player Stupid where + team = getTeam + hand = getHand + chooseCard p _ _ hand = do + trumpCol <- trumpColour + turnCol <- turnColour + let possible = filter (isAllowed trumpCol turnCol hand) hand + return (head possible, p) diff --git a/AI/Test.hs b/AI/Test.hs new file mode 100644 index 0000000..cbcc930 --- /dev/null +++ b/AI/Test.hs @@ -0,0 +1,39 @@ +import Card +import Pile +import Utils + +import qualified Data.Map.Strict as M +import Data.Monoid ((<>)) + +type Guess = M.Map Card [Hand] +type Distribution = ([Card], [Card], [Card]) + +distributions :: Guess -> [Distribution] +distributions guess = --filter equilibrated + (helper (M.toList guess) (0, 0, 0)) + where helper [] _ = [] + helper ((c, hs):[]) ns = map fst (distr c hs ns) + helper ((c, hs):gs) ns = + let dsWithNs = distr c hs ns + go (d, ns') = map (d <>) (helper gs ns') + in concatMap go dsWithNs + distr card hands (n1, n2, n3) = + let f card Hand1 = (([card], [], []), (n1+1, n2, n3)) + f card Hand2 = (([], [card], []), (n1, n2+1, n3)) + f card Hand3 = (([], [], [card]), (n1, n2, n3+1)) + isOk Hand1 = n1 < cardsPerHand + isOk Hand2 = n2 < cardsPerHand + isOk Hand3 = n3 < cardsPerHand + in filterMap isOk (f card) hands + equilibrated (cs1, cs2, cs3) = + let ls = [length cs1, length cs2, length cs3] + in (maximum ls - minimum ls) <= 1 + cardsPerHand = (length guess `div` 3) + +testguess :: Guess +testguess = foldr (Hand3 `has`) m (take 10 allCards) + where l = map (\c -> (c, [Hand1, Hand2, Hand3])) (take 30 allCards) + m = M.fromList l + +main :: IO () +main = print $ length $ distributions testguess diff --git a/Card.hs b/Card.hs index 151e68a..43dc686 100644 --- a/Card.hs +++ b/Card.hs @@ -35,7 +35,7 @@ data Colour = Diamonds deriving (Eq, Ord, Show, Enum, Read) data Card = Card Type Colour - deriving (Eq, Show) + deriving (Eq, Show, Ord) getColour :: Card -> Colour getColour (Card _ c) = c @@ -74,19 +74,22 @@ compareCards :: Colour -> 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 + case (trp1, trp2) of + (True, True) -> compare tp1 tp2 + (False, False) -> case compare (col1 `equals` turnCol) + (col2 `equals` turnCol) of + EQ -> compare tp1 tp2 + v -> v + _ -> compare trp1 trp2 where trp1 = isTrump trumpCol c1 trp2 = isTrump trumpCol c2 sortCards :: Colour -> Maybe Colour -> [Card] -> [Card] sortCards trumpCol turnCol cs = sortBy (compareCards trumpCol turnCol) cs +highestCard :: Colour -> Maybe Colour -> [Card] -> Card +highestCard trumpCol turnCol cs = maximumBy (compareCards trumpCol turnCol) cs + shuffleCards :: IO [Card] shuffleCards = do gen <- newStdGen diff --git a/Main.hs b/Main.hs index 091ce03..b90a4ec 100644 --- a/Main.hs +++ b/Main.hs @@ -4,13 +4,54 @@ import Control.Monad.State import Card import Skat -import Reizen import Operations +import Player +import Pile +import AI.Stupid +import AI.Human +import AI.Rulebased main :: IO () -main = do - env <- reizen - (sgl, tm) <- evalStateT runGame env - putStrLn $ "Single player has " ++ show sgl ++ " points." - putStrLn $ "Team has " ++ show tm ++ " points." +main = putStrLn "Hello World" + +env :: SkatEnv +env = SkatEnv piles Nothing Spades playersExamp + where piles = distribute allCards + +envStupid :: SkatEnv +envStupid = SkatEnv piles Nothing Spades pls2 + where piles = distribute allCards + +playersExamp :: Players +playersExamp = Players + (PL $ Stupid Team Hand1) + (PL $ Stupid Team Hand2) + (PL $ mkAIEnv Single Hand3 10) + +pls2 :: Players +pls2 = Players + (PL $ Stupid Team Hand1) + (PL $ Stupid Team Hand2) + (PL $ Stupid Team Hand3) + +shuffledEnv :: IO SkatEnv +shuffledEnv = do + cards <- shuffleCards + return $ SkatEnv (distribute cards) Nothing Spades playersExamp + +env2 :: SkatEnv +env2 = SkatEnv piles Nothing Spades playersExamp + where hand1 = [Card Seven Clubs, Card King Clubs, Card Ace Clubs, Card Queen Diamonds] + hand2 = [Card Seven Hearts, Card King Hearts, Card Ace Hearts, Card Queen Spades] + hand3 = [Card Seven Spades, Card King Spades, Card Ace Spades, Card Queen Clubs] + h1 = map (putAt Hand1) hand1 + h2 = map (putAt Hand2) hand2 + h3 = map (putAt Hand3) hand3 + piles = Piles (h1 ++ h2 ++ h3) [] [] + +testAI :: Int -> IO () +testAI n = do + let acs = repeat (shuffledEnv >>= evalStateT (turnGeneric playOpen 10 Hand1) ) + vals <- sequence (take n acs) + putStrLn $ "average won points " ++ show (fromIntegral (sum (map fst vals)) / fromIntegral n) diff --git a/Operations.hs b/Operations.hs index c901eea..6f76006 100644 --- a/Operations.hs +++ b/Operations.hs @@ -8,7 +8,8 @@ import Data.Ord import Card import Skat import Pile -import Player +import Player (chooseCard, Players(..), Player(..), PL(..), + updatePlayer, playersToList, player) import Utils (shuffle) compareRender :: Card -> Card -> Ordering @@ -19,22 +20,32 @@ compareRender (Card t1 c1) (Card t2 c2) = case compare c1 c2 of sortRender :: [Card] -> [Card] sortRender = sortBy compareRender -turn :: Hand -> Skat (Int, Int) -turn n = do +turnGeneric :: (PL -> Skat Card) + -> Int + -> Hand + -> Skat (Int, Int) +turnGeneric playFunc depth n = do table <- getp tableCards ps <- gets players let p = player ps n hand <- getp $ handCards n + trCol <- gets trumpColour case length table of - 0 -> play p >> turn (next n) + 0 -> playFunc p >> turnGeneric playFunc depth (next n) 1 -> do - modify $ setTurnColour (Just $ getColour $ head table) - play p - turn (next n) - 2 -> play p >> turn (next n) + modify $ setTurnColour + (Just $ effectiveColour trCol $ head table) + playFunc p + turnGeneric playFunc depth (next n) + 2 -> playFunc p >> turnGeneric playFunc depth (next n) 3 -> do w <- evaluateTable - if length hand == 0 then countGame else turn w + if depth <= 1 || length hand == 0 + then countGame + else turnGeneric playFunc (depth - 1) w + +turn :: Hand -> Skat (Int, Int) +turn n = turnGeneric play 10 n evaluateTable :: Skat Hand evaluateTable = do @@ -42,7 +53,7 @@ evaluateTable = do turnCol <- gets turnColour table <- getp tableCards ps <- gets players - let winningCard = head $ sortCards trumpCol turnCol table + let winningCard = highestCard trumpCol turnCol table Just winnerHand <- getp $ originOfCard winningCard let winner = player ps winnerHand modifyp $ cleanTable (team winner) @@ -52,29 +63,26 @@ evaluateTable = do countGame :: Skat (Int, Int) countGame = getp count -play :: Player p => p -> Skat Card +play :: (Show p, Player p) => p -> Skat Card play p = do - table <- getp tableCards + liftIO $ putStrLn "playing" + table <- getp tableCardsS turnCol <- gets turnColour trump <- gets trumpColour hand <- getp $ handCards (hand p) - let card = chooseCard p trump turnCol hand + fallen <- getp played + (card, p') <- chooseCard p table fallen hand + modifyPlayers $ updatePlayer p' modifyp $ playCard card + ps <- fmap playersToList $ gets players + table' <- getp tableCardsS + ps' <- mapM (\p -> onCardPlayed p (head table')) ps + mapM_ (modifyPlayers . updatePlayer) ps' return card ----- TESTING VARS - -env :: SkatEnv -env = SkatEnv piles Nothing Spades playersExamp - where piles = distribute allCards - -playersExamp :: Players -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 +playOpen :: (Show p, Player p) => p -> Skat Card +playOpen p = do + --liftIO $ putStrLn $ show (hand p) ++ " playing open" + card <- chooseCardOpen p + modifyp $ playCard card + return card diff --git a/Pile.hs b/Pile.hs index f6dfd34..0d23062 100644 --- a/Pile.hs +++ b/Pile.hs @@ -20,7 +20,7 @@ instance Countable (CardS p) Int where count = count . getCard data Hand = Hand1 | Hand2 | Hand3 - deriving (Show, Eq) + deriving (Show, Eq, Ord) next :: Hand -> Hand next Hand1 = Hand2 @@ -80,6 +80,11 @@ 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 diff --git a/Player.hs b/Player.hs index 17b84c2..f2eaaf9 100644 --- a/Player.hs +++ b/Player.hs @@ -2,23 +2,42 @@ module Player where +import Control.Monad.IO.Class + import Card import Pile +class (Monad m, MonadIO m) => MonadPlayer m where + trumpColour :: m Colour + turnColour :: m (Maybe Colour) + showSkat :: Player p => p -> m (Maybe [Card]) + +class (Monad m, MonadIO m, MonadPlayer m) => MonadPlayerOpen m where + showPiles :: m (Piles) + 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 + chooseCard :: MonadPlayer m + => p + -> [CardS Played] + -> [CardS Played] + -> [Card] + -> m (Card, p) + onCardPlayed :: MonadPlayer m + => p + -> CardS Played + -> m p + onCardPlayed p _ = return p + chooseCardOpen :: MonadPlayerOpen m + => p + -> m Card + chooseCardOpen p = do + piles <- showPiles + let table = tableCardsS piles + fallen = played piles + myCards = handCards (hand p) piles + fmap fst $ chooseCard p table fallen myCards data PL = forall p. (Show p, Player p) => PL p @@ -28,7 +47,13 @@ instance Show PL where instance Player PL where team (PL p) = team p hand (PL p) = hand p - chooseCard (PL p) = chooseCard p + chooseCard (PL p) table fallen hand = do + (v, a) <- chooseCard p table fallen hand + return $ (v, PL a) + onCardPlayed (PL p) card = do + v <- onCardPlayed p card + return $ PL v + chooseCardOpen (PL p) = chooseCardOpen p data Players = Players PL PL PL deriving Show @@ -38,5 +63,11 @@ 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) +updatePlayer :: (Show p, Player p) => p -> Players -> Players +updatePlayer p (Players p1 p2 p3) = case hand p of + Hand1 -> Players (PL p) p2 p3 + Hand2 -> Players p1 (PL p) p3 + Hand3 -> Players p1 p2 (PL p) + +playersToList :: Players -> [PL] +playersToList (Players p1 p2 p3) = [p1, p2, p3] diff --git a/Player/Utils.hs b/Player/Utils.hs new file mode 100644 index 0000000..39a8a91 --- /dev/null +++ b/Player/Utils.hs @@ -0,0 +1,18 @@ +module Player.Utils ( + isAllowed, isTrump +) where + +import Player +import qualified Card as C +import Card (Card) + +isAllowed :: MonadPlayer m => [Card] -> Card -> m Bool +isAllowed hand card = do + trCol <- trumpColour + turnCol <- turnColour + return $ C.isAllowed trCol turnCol hand card + +isTrump :: MonadPlayer m => Card -> m Bool +isTrump card = do + trCol <- trumpColour + return $ C.isTrump trCol card diff --git a/Render.hs b/Render.hs index 9a25fa5..9924af5 100644 --- a/Render.hs +++ b/Render.hs @@ -1,7 +1,6 @@ module Render where import Card -import Operations import Data.List render :: [Card] -> IO () diff --git a/Skat.hs b/Skat.hs index d014eb6..fe01b78 100644 --- a/Skat.hs +++ b/Skat.hs @@ -1,4 +1,6 @@ {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} module Skat where @@ -8,7 +10,8 @@ import Data.List import Card import Pile -import Player +import Player (Players) +import qualified Player as P data SkatEnv = SkatEnv { piles :: Piles , turnColour :: Maybe Colour @@ -18,6 +21,16 @@ data SkatEnv = SkatEnv { piles :: Piles type Skat = StateT SkatEnv IO +instance P.MonadPlayer Skat where + trumpColour = gets trumpColour + turnColour = gets turnColour + showSkat p = case P.team p of + Single -> fmap (Just . skatCards) $ gets piles + Team -> return Nothing + +instance P.MonadPlayerOpen Skat where + showPiles = gets piles + modifyp :: (Piles -> Piles) -> Skat () modifyp f = modify g where g env@(SkatEnv {piles}) = env { piles = f piles} @@ -25,5 +38,12 @@ modifyp f = modify g getp :: (Piles -> a) -> Skat a getp f = gets piles >>= return . f +modifyPlayers :: (Players -> Players) -> Skat () +modifyPlayers f = modify g + where g env@(SkatEnv {players}) = env { players = f players } + setTurnColour :: Maybe Colour -> SkatEnv -> SkatEnv setTurnColour col sk = sk { turnColour = col } + +mkSkatEnv :: Piles -> Maybe Colour -> Colour -> Players -> SkatEnv +mkSkatEnv = SkatEnv diff --git a/Utils.hs b/Utils.hs index b1a2e67..744f43c 100644 --- a/Utils.hs +++ b/Utils.hs @@ -30,3 +30,13 @@ remove pred xs = foldr f (undefined, []) xs 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 + +--filterM :: Monad m => (a -> m Bool) -> [a] -> m [a] +--filterM _ [] = return [] +--filterM pred (x:xs) = do +-- b <- pred x +-- if b then filterM pred xs >>= \l -> return $ x : l +-- else filterM pred xs + +grouping :: Eq a => (b -> a) -> b -> b -> Bool +grouping f a b = f a == f b