add ai system and a decent simulation based ai

.gitignore

@@ -1,3 +1,8 @@
+*
+
+!*.*
+!*/
+
 *.hi
 *.o
 *.prof

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

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)

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)

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

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
+    case (trp1, trp2) of
-        EQ ->
+        (True, True) -> compare tp1 tp2
-            case compare (col1 `equals` turnCol)
+        (False, False) -> case compare (col1 `equals` turnCol)
                                        (col2 `equals` turnCol) of
                             EQ -> compare tp1 tp2
                             v -> v
-        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

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
+main = putStrLn "Hello World"
-    env <- reizen
+
-    (sgl, tm) <- evalStateT runGame env
+env :: SkatEnv
-    putStrLn $ "Single player has " ++ show sgl ++ " points."
+env = SkatEnv piles Nothing Spades playersExamp
-    putStrLn $ "Team has " ++ show tm ++ " points."
+    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)

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)
+turnGeneric :: (PL -> Skat Card)
-turn n = do
+            -> 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)
+            modify $ setTurnColour
-            play p
+                (Just $ effectiveColour trCol $ head table)
-            turn (next n)
+            playFunc p
-        2 -> play p >> turn (next n)
+            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
+playOpen :: (Show p, Player p) => p -> Skat Card
-
+playOpen p = do
-env :: SkatEnv
+    --liftIO $ putStrLn $ show (hand p) ++ " playing open"
-env = SkatEnv piles Nothing Spades playersExamp
+    card <- chooseCardOpen p
-    where piles = distribute allCards 
+    modifyp $ playCard card
-
+    return card
-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

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
 

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
+    chooseCard :: MonadPlayer m
-
+               => p
-data Stupid = Stupid { getTeam :: Team
+               -> [CardS Played]
-                     , getHand :: Hand }
+               -> [CardS Played]
-              deriving Show
+               -> [Card]
-
+               -> m (Card, p)
-instance Player Stupid where
+    onCardPlayed :: MonadPlayer m
-    team = getTeam
+                 => p
-    hand = getHand
+                 -> CardS Played
-    chooseCard p trumpCol turnCol hand = head possible
+                 -> m p
-        where possible = filter (isAllowed trumpCol turnCol hand) hand
+    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]
+updatePlayer :: (Show p, Player p) => p -> Players -> Players
---playersFromTable ps = map (player ps . playerOfHand . getOwner)
+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]

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

Render.hs

@@ -1,7 +1,6 @@
 module Render where
 
 import Card
-import Operations
 import Data.List
 
 render :: [Card] -> IO ()

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

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