some optimizations

2020-03-01 21:35:23 +01:00
parent 5846a22d8a
commit 672746e302
18 changed files with 336 additions and 192 deletions
@@ -7,6 +7,7 @@ module Skat where
 import Control.Monad.State
 import Control.Monad.Reader
 import Data.List
+import Data.Vector (Vector)

 import Skat.Card
 import Skat.Pile
@@ -52,13 +53,10 @@ setCurrentHand hand sk = sk { currentHand = hand }
 mkSkatEnv :: Piles -> Maybe Colour -> Colour -> Players -> Hand -> SkatEnv
 mkSkatEnv = SkatEnv

-allowedCards :: Skat [Card]
+allowedCards :: Skat [CardS Owner]
 allowedCards = do
    curHand <- gets currentHand
    pls <- gets players
    turnCol <- gets turnColour
    trumpCol <- gets trumpColour
-    ps <- gets piles
-    let p = P.player pls curHand
-        cards = handCards curHand ps
-    return $ filter (isAllowed trumpCol turnCol cards) cards
+    getp $ allowed curHand trumpCol turnCol
@@ -19,7 +19,7 @@ instance Player Human where
        trumpCol <- trumpColour
        turnCol <- turnColour
        let possible = filter (isAllowed trumpCol turnCol hand) hand
-        c <- liftIO $ askIO (map getCard table) possible hand
+        c <- liftIO $ askIO (map getCard table) (map toCard possible) (map toCard hand)
        return $ (c, p)

 askIO :: [Card] -> [Card] -> [Card] -> IO Card
@@ -10,18 +10,20 @@ module Skat.AI.Minmax (
 ) where

 import Control.Monad.State
+import Control.Exception (assert)
 import Control.Monad.Fail
 import Data.Ord
 import Text.Read (readMaybe)
-import Data.List (minimumBy, maximumBy)
+import Data.List (maximumBy, sortBy)
 import Debug.Trace

 import qualified Skat as S
 import qualified Skat.Card as S
 import qualified Skat.Operations as S
 import qualified Skat.Pile as S
-import qualified Skat.Player as S
+import qualified Skat.Player as S hiding (trumpColour, turnColour)
 import qualified Skat.Render as S
+--import TestEnvs (env3, shuffledEnv2)

 debug :: Bool
 debug = False
@@ -34,15 +36,15 @@ class (Ord v, Eq v) => Value v where
 class Player p where
    maxing :: p -> Bool

-class (Monad m, Value v, Player p, Eq t) => MonadGame t v p m | m -> t, m -> p, m -> v where
+class (Traversable l, Monad m, Value v, Player p, Eq t) => MonadGame t l v p m | m -> t, m -> p, m -> v, m -> l where
    currentPlayer :: m p
-    turns :: m [t]
+    turns :: m (l t)
    play :: t -> m ()
    simulate :: t -> m a -> m a
    evaluate :: m v
    over :: m Bool

-class (MonadIO m, Show t, Show v, Show p, MonadGame t v p m) => PlayableGame t v p m | m -> t, m -> p, m -> v where
+class (MonadIO m, Show t, Show v, Show p, MonadGame t l v p m) => PlayableGame t l v p m | m -> t, m -> p, m -> v where
    showTurns :: m ()
    showBoard :: m ()
    askTurn :: m (Maybe t)
@@ -59,25 +61,50 @@ instance Value Int where
    win = 120
    loss = -120

-instance MonadGame S.Card Int S.PL S.Skat where
+instance MonadGame (S.CardS S.Owner) [] Int S.PL S.Skat where
    currentPlayer = do
        hand <- gets S.currentHand
        pls <- gets S.players
-        return $ S.player pls hand
+        return $! S.player pls hand
    turns = S.allowedCards
+        --player <- currentPlayer
+        --trCol <- gets S.trumpColour
+        --return $! if maxing player
+        --    then sortBy (optimalTeam trCol) cards
+        --    else sortBy (optimalSingle trCol) cards
    play = S.play_
    simulate card action = do
+        --oldCurrent <- gets S.currentHand
+        --oldTurnCol <- gets S.turnColour
        backup <- get
        play card
+        --oldWinner <- currentPlayer
        res <- action
+        --S.undo_ card oldCurrent oldTurnCol (S.team oldWinner)
        put backup
-        return res
-    over = ((==0) . length) <$> S.allowedCards
+        return $! res
+    over = ((==0) . length) <$!> S.allowedCards
    evaluate = do
        player <- currentPlayer
        piles <- gets S.piles
        let (sgl, tm) = S.count piles
-        return $ (if maxing player then tm - sgl else sgl - tm)
+        return $! (if maxing player then tm - sgl else sgl - tm)
+
+potentialByType :: S.Type -> Int
+potentialByType S.Ace = 11
+potentialByType S.Jack = 10
+potentialByType S.Ten = 4
+potentialByType S.Seven = 7
+potentialByType S.Eight = 7
+potentialByType S.Nine = 7
+potentialByType S.Queen = 5
+potentialByType S.King = 5
+
+optimalSingle :: S.Colour -> S.Card -> S.Card -> Ordering
+optimalSingle trCol (S.Card t1 _) (S.Card t2 _) = (comparing potentialByType) t2 t1
+
+optimalTeam :: S.Colour -> S.Card -> S.Card -> Ordering
+optimalTeam trCol (S.Card t1 _) (S.Card t2 _) = (comparing potentialByType) t2 t1

 -- TIC TAC TOE implementation

@@ -106,7 +133,7 @@ data GameState = GameState { getBoard :: [TicTacToe]
 instance Player Bool where
    maxing = id

-instance Monad m => MonadGame Int WinLossTie Bool (StateT GameState m) where
+instance Monad m => MonadGame Int [] WinLossTie Bool (StateT GameState m) where
    currentPlayer = gets getCurrent
    turns = do
        board <- gets getBoard
@@ -123,7 +150,7 @@ instance Monad m => MonadGame Int WinLossTie Bool (StateT GameState m) where
        play turn
        res <- action
        put backup
-        return res
+        return $! res
    evaluate = do
        board <- gets getBoard
        current <- currentPlayer
@@ -162,45 +189,37 @@ updateAt :: Int -> [a] -> a -> [a]
 updateAt n xs y = map f $ zip [0..] xs
    where f (i, x) = if i == n then y else x

-minmax :: (MonadIO m, Show v, Show t, Show p, Value v, Eq t, Player p, MonadGame t v p m)
+minmax :: (MonadIO m, Show v, Show t, Show p, Value v, Eq t, Player p, MonadGame t l v p m)
       => Int
       -> t
       -> v
       -> v
       -> m (t, v)
-minmax depth turn alpha beta = (flip evalStateT) (alpha, beta) $ do
+minmax depth turn_ alpha beta = (flip evalStateT) (alpha, beta) $ do
    gameOver <- lift over
    -- if last step or game is over then evaluate situation
-    if depth == 0 || gameOver then do
-        val <- lift evaluate
-        when debug $ liftIO $ putStrLn $ "evaluation: " ++ show val
-        return (turn, val)
+    if depth == 0 || gameOver then (turn_,) <$> lift evaluate
    else do
-        when debug $ liftIO $ putStrLn $ "depth " ++ show depth
        -- generate a list of possible turns
        currentlyMaxing <- maxing <$> lift currentPlayer
        availableTurns <- lift turns
        (alpha, beta) <- get
        -- try every turn, StateT wraps current best turn and current max value
-        (flip execStateT) (undefined, alpha) $ forM_ availableTurns $ \turn -> do
+        (flip execStateT) (turn_, alpha) $ forM_ availableTurns $ \turn -> do
            currentMax <- gets snd
-            when debug $ liftIO $ putStrLn $ "simulating " ++ show turn ++ " with max " ++ show currentMax
-                ++ " and beta " ++ show beta
-            --when (currentMax >= beta && debug) $ liftIO $ putStrLn "beta cutoff"
            -- beta cutoff
            unless (currentMax >= beta) $ do
-            --unless False $ do
-                value <- lift $ lift $ simulate turn $ step currentlyMaxing beta currentMax
-                when debug $ liftIO $ putStrLn $ "value " ++ show value
+                value <- lift $! lift $! simulate turn $! do
+                    nextMaxing <- maxing <$!> currentPlayer
+                    if nextMaxing /= currentlyMaxing
+                        then (invert . snd) <$!> minmax (depth-1) turn (invert beta) (invert currentMax)
+                        else snd <$!> minmax (depth-1) turn currentMax beta
                when (value > currentMax) (put (turn, value))
-  where step currentlyMaxing beta currentMax = do
-            nextMaxing <- maxing <$> currentPlayer
-            if nextMaxing /= currentlyMaxing
-                then (invert . snd) <$> minmax (depth-1) turn (invert beta) (invert currentMax)
-                else snd <$> minmax (depth-1) turn currentMax beta

-choose :: (MonadIO m, Show v, Show t, Show p, Value v, Eq t, Player p, MonadGame t v p m) => m t
-choose = fst <$> minmax 10 undefined loss win
+choose :: (MonadIO m, Show v, Show t, Show p, Value v, Eq t, Player p, MonadGame t l v p m)
+       => Int
+       -> m t
+choose depth = fst <$> minmax depth (error "choose") loss win

 emptyBoard :: [TicTacToe]
 emptyBoard = [Toe, Toe, Toe, Toe, Toe, Toe, Toe, Toe, Toe]
@@ -223,7 +242,7 @@ printOptions opts = print9x9 pr
            | n `elem` opts = putStr (show n) >> putStr " "
            | otherwise     = putStr "  "

-instance MonadIO m => PlayableGame Int WinLossTie Bool (StateT GameState m) where
+instance MonadIO m => PlayableGame Int [] WinLossTie Bool (StateT GameState m) where
    showBoard = do
        board <- gets getBoard
        liftIO $ printBoard board
@@ -239,7 +258,7 @@ instance MonadIO m => PlayableGame Int WinLossTie Bool (StateT GameState m) wher
    askTurn = readMaybe <$> liftIO getLine
    showTurn _ = return ()

-instance PlayableGame S.Card Int S.PL S.Skat where
+instance PlayableGame (S.CardS S.Owner) [] Int S.PL S.Skat where
    showBoard = do
        liftIO $ putStrLn ""
        table <- S.getp S.tableCards
@@ -249,7 +268,7 @@ instance PlayableGame S.Card Int S.PL S.Skat where
        cards <- turns
        player <- currentPlayer
        liftIO $ print player
-        liftIO $ S.render (S.sortRender cards)
+        liftIO $ S.render cards
    winner = do
        piles <- gets S.piles
        pls <- gets S.players
@@ -259,7 +278,7 @@ instance PlayableGame S.Card Int S.PL S.Skat where
        return $ Just $ head winners
    askTurn = do
        cards <- turns
-        let sorted = S.sortRender cards
+        let sorted = cards
        input <- liftIO getLine
        case readMaybe input of
            Just n -> if n >= 0 && n < length sorted then return $ Just (sorted !! n)
@@ -269,19 +288,20 @@ instance PlayableGame S.Card Int S.PL S.Skat where
        player <- currentPlayer
        liftIO $ putStrLn $ show player ++ " plays " ++ show card

-playCLI :: (MonadFail m, Read t, PlayableGame t v p m) => m ()
+playCLI :: (MonadFail m, Read t, PlayableGame t l v p m) => m ()
 playCLI = do
    gameOver <- over
    if gameOver
        then announceWinner
        else do
-            showBoard
+            when debug showBoard
            current <- currentPlayer
-            turn <- if not (maxing current) then readTurn else choose
-            showTurn turn
+            turn <- choose 10
+            when debug $ showTurn turn
            play turn
            playCLI
   where
+      readTurn :: (MonadFail m, Read t, PlayableGame t l v p m) => m t
      readTurn = do
        options <- turns
        showTurns
@@ -6,6 +6,7 @@ module Skat.AI.Online where

 import Control.Monad.Reader
 import Data.Aeson
+import Data.Maybe
 import qualified Data.ByteString.Lazy.Char8 as BS

 import Skat.Player
@@ -52,15 +53,16 @@ instance MonadPlayer m => MonadPlayer (Online a m) where
    turnColour = lift $ turnColour
    showSkat = lift . showSkat

-choose :: (Communicator c, MonadPlayer m) => [CardS Played] -> [Card] -> Online c m Card
-choose table hand = do
+choose :: HasCard a => (Communicator c, MonadPlayer m) => [CardS Played] -> [a] -> Online c m Card
+choose table hand' = do
+    let hand = map toCard hand'
    query (BS.unpack $ encode $ ChooseQuery hand table)
    r <- response
    case decode (BS.pack r) of
        Just (ChosenResponse card) -> do
            allowed <- P.isAllowed hand card
-            if card `elem` hand && allowed then return card else choose table hand
-        Nothing -> choose table hand
+            if card `elem` hand && allowed then return card else choose table hand'
+        Nothing -> choose table hand'

 cardPlayed :: (Communicator c, MonadPlayer m) => CardS Played -> Online c m ()
 cardPlayed card = query (BS.unpack $ encode $ CardPlayedQuery card)
@@ -19,7 +19,7 @@ import qualified Data.Map.Strict as M

 import Skat.Player
 import qualified Skat.Player.Utils as P
-import Skat.Pile
+import Skat.Pile hiding (isSkat)
 import Skat.Card
 import Skat.Utils
 import Skat (Skat, modifyp, mkSkatEnv) 
@@ -81,7 +81,7 @@ instance Player AIEnv where
    hand = getHand
    chooseCard p table fallen hand = runStateT (do
        modify $ setTable table
-        modify $ setHand hand
+        modify $ setHand (map toCard hand)
        modify $ setFallen fallen
        choose) p
    onCardPlayed p card = execStateT (do
@@ -142,20 +142,16 @@ analyzeTurn (c1, c2, c3) = do
        col2 = effectiveColour trCol (getCard c2)
        col3 = effectiveColour trCol (getCard c3)
    if col2 /= demanded
-        then origin c2 `hasNoLonger` demanded
+        then uorigin (getPile c2) `hasNoLonger` demanded
        else return ()
    if col3 /= demanded
-        then origin c3 `hasNoLonger` demanded
+        then uorigin (getPile 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
+toPiles table (h1, h2, h3, skt) = makePiles h1 h2 h3 table skt

 compareGuess :: (Card, [Option]) -> (Card, [Option]) -> Ordering
 compareGuess (c1, ops1) (c2, ops2)
@@ -227,7 +223,7 @@ onPlayed c = do
    let col = effectiveColour trCol (getCard c)
    case turnCol of
        Just demanded -> if col /= demanded
-            then origin c `hasNoLonger` demanded else return ()
+            then uorigin (getPile c) `hasNoLonger` demanded else return ()
        Nothing -> return ()

 choose :: MonadPlayer m => AI m Card
@@ -237,6 +233,19 @@ chooseStatistic :: MonadPlayer m => AI m Card
 chooseStatistic = do
    h <- gets getHand
    handCards <- gets myHand
+    table <- gets table
+    let tableNo = length table
+        left = 3 - tableNo
+        depth = case length handCards of
+            10 -> 3 + tableNo
+            9 -> 3 + tableNo
+            8 -> 3 + tableNo
+            7 -> 6 + tableNo
+            6 -> 9 + tableNo
+            5 -> 12 + tableNo
+            4 -> 15 + tableNo
+            _ -> 100
+    modify $ setDepth depth
    guess__ <- gets guess
    self <- get
    maySkat <- showSkat self
@@ -244,8 +253,7 @@ chooseStatistic = do
        guess = case maySkat of
            Just cs -> (cs `isSkat`) guess_
            Nothing -> guess_
-    table <- gets table
-    let ns = case length table of
+    let ns = case tableNo of
                0 -> (0,  0,  0, 0)
                1 -> (-1, 0, -1, 0)
                2 -> (0,  0, -1, 0)
@@ -286,14 +294,13 @@ chooseOpen = do
    piles <- showPiles
    hand <- gets getHand
    let myCards = handCards hand piles
-    liftIO $ putStrLn $ show hand ++ " chooses from " ++ show myCards
    possible <- filterM (P.isAllowed myCards) myCards
    case length possible of
        0 -> do
            liftIO $ print hand
            liftIO $ print piles
            error "no cards left to choose from"
-        1 -> return $ head possible
+        1 -> return $ toCard $ head possible
        _ -> chooseSimulating

 chooseSimulating :: (MonadState AIEnv m, MonadPlayerOpen m)
@@ -303,11 +310,12 @@ chooseSimulating = do
    turnCol <- turnColour
    trumpCol <- trumpColour
    myHand <- gets getHand
+    depth <- gets simulationDepth
    let ps = Players (PL $ Stupid.Stupid Team Hand1)
                     (PL $ Stupid.Stupid Team Hand2)
                     (PL $ Stupid.Stupid Single Hand3)
        env = mkSkatEnv piles turnCol trumpCol ps myHand
-    liftIO $ evalStateT (Minmax.choose :: Skat Card) env
+    liftIO $ evalStateT (toCard <$> (Minmax.choose depth :: Skat (CardS Owner))) env

 simulate :: (MonadState AIEnv m, MonadPlayerOpen m)
         => Card -> m Int
@@ -329,7 +337,7 @@ simulate card = do
        env = mkSkatEnv piles turnCol trumpCol ps (next myHand)
    -- simulate the game after playing the given card
    (sgl, tm) <- liftIO $ evalStateT (do
-        modifyp $ playCard card
+        modifyp $ playCard myHand card
        turnGeneric playOpen depth) env
    let v = if myTeam == Single then (sgl, tm) else (tm, sgl)
    -- put the value into context for when not the whole game is
@@ -346,13 +354,13 @@ predictValue (own, others) = do
    --return $ own + pot
    return (own-others)

-potential :: (MonadState AIEnv m, MonadPlayerOpen m)
-          => [Card] -> m Int
+potential :: (MonadState AIEnv m, MonadPlayerOpen m, HasCard c)
+          => [c] -> m Int
 potential cs = do
    tr <- trumpColour
    let trs = filter (isTrump tr) cs
-        value = count cs
-    positions <- filter (==0) <$> mapM position cs
+        value = count . map toCard $ cs
+    positions <- filter (==0) <$> mapM (position . toCard) cs
    return $ length trs * 10 + value + length positions * 5

 position :: (MonadState AIEnv m, MonadPlayer m)
@@ -15,4 +15,4 @@ instance Player Stupid where
        trumpCol <- trumpColour
        turnCol <- turnColour
        let possible = filter (isAllowed trumpCol turnCol hand) hand
-        return (head possible, p)
+        return (toCard $ head possible, p)
@@ -1,16 +1,23 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}

 module Skat.Card where

 import Data.List
+import Data.Foldable (Foldable)
+import qualified Data.Foldable as F
+import qualified Data.Set as S
 import Data.Aeson
 import System.Random (newStdGen, StdGen)
 import Control.DeepSeq

 import Skat.Utils

+class HasCard c where
+    toCard :: c -> Card
+
 class Countable a b where
    count :: a -> b

@@ -41,6 +48,15 @@ data Colour = Diamonds
 data Card = Card Type Colour
            deriving (Eq, Show, Ord, Read)

+getType :: Card -> Type
+getType (Card t _) = t
+
+getColour :: Card -> Colour
+getColour (Card _ c) = c
+
+instance HasCard Card where
+    toCard = id
+
 instance ToJSON Card where
    toJSON (Card t c) =
        object ["type" .= show t, "colour" .= show c]
@@ -51,11 +67,8 @@ instance FromJSON Card where
        c <- v .: "colour"
        return $ Card (read t) (read c)

-getColour :: Card -> Colour
-getColour (Card _ c) = c
-
-getID :: Card -> Int
-getID (Card t _) = case t of
+getID :: HasCard c => c -> Int
+getID card = let t = getType $ toCard card in case t of
    Seven -> 0
    Eight -> 0
    Nine -> 0
@@ -65,11 +78,22 @@ getID (Card t _) = case t of
    Ace -> 16
    Jack -> 32

+instance Enum Card where
+    fromEnum (Card tp col) = fromEnum col * 8 + fromEnum tp
+    toEnum n = Card tp col
+        where col = toEnum (n `div` 8)
+              tp = toEnum (n `mod` 8)
+
 instance Countable Card Int where
    count (Card t _) = count t

-instance Countable [Card] Int where
-    count = sum . map count
+instance Foldable t => Countable (t Card) Int where
+    count = foldl' f 0
+        where f acc c = count c + acc
+
+instance Countable (S.Set Card) Int where
+    count = S.foldl' f 0
+        where f acc card = count card + acc

 instance NFData Card where
    rnf (Card t c) = t `seq` c `seq` ()
@@ -78,22 +102,21 @@ equals :: Colour -> Maybe Colour -> Bool
 equals col (Just x) = col == x
 equals col Nothing = True

-isTrump :: Colour -> Card -> Bool
-isTrump trumpCol (Card tp col)
-    | tp == Jack = True
-    | otherwise = col == trumpCol
+isTrump :: HasCard c => Colour -> c -> Bool
+isTrump trumpCol crd
+    | getType (toCard crd) == Jack = True
+    | otherwise = getColour (toCard crd) == trumpCol

-effectiveColour :: Colour -> Card -> Colour
-effectiveColour trumpCol card@(Card _ col) =
-    if trump then trumpCol else col
-  where trump = isTrump trumpCol card
+effectiveColour :: HasCard c => Colour -> c -> Colour
+effectiveColour trumpCol crd = if trump then trumpCol else getColour (toCard crd)
+  where trump = isTrump trumpCol crd

-isAllowed :: Colour -> Maybe Colour -> [Card] -> Card -> Bool
-isAllowed trumpCol turnCol cs card =
+isAllowed :: (Foldable t, HasCard c1, HasCard c2) => Colour -> Maybe Colour -> t c1 -> c2 -> Bool
+isAllowed trumpCol turnCol cs crd =
    if col `equals` turnCol
        then True
-        else not $ any (\ca -> effectiveColour trumpCol ca `equals` turnCol && ca /= card) cs
-  where col = effectiveColour trumpCol card
+        else not $ F.any (\ca -> effectiveColour trumpCol ca `equals` turnCol && toCard ca /= toCard crd) cs
+  where col = effectiveColour trumpCol (toCard crd)

 compareCards :: Colour
             -> Maybe Colour
@@ -112,11 +135,13 @@ compareCards trumpCol turnCol c1@(Card tp1 col1) c2@(Card tp2 col2) =
  where trp1 = isTrump trumpCol c1
        trp2 = isTrump trumpCol c2

-sortCards :: Colour -> Maybe Colour -> [Card] -> [Card]
-sortCards trumpCol turnCol cs = sortBy (compareCards trumpCol turnCol) cs
+sortCards :: HasCard c => Colour -> Maybe Colour -> [c] -> [c]
+sortCards trumpCol turnCol cs = sortBy f cs
+    where f c1 c2 = compareCards trumpCol turnCol (toCard c1) (toCard c2)

-highestCard :: Colour -> Maybe Colour -> [Card] -> Card
-highestCard trumpCol turnCol cs = maximumBy (compareCards trumpCol turnCol) cs
+highestCard :: HasCard c => Colour -> Maybe Colour -> [c] -> c
+highestCard trumpCol turnCol cs = maximumBy f cs
+    where f c1 c2 = compareCards trumpCol turnCol (toCard c1) (toCard c2)

 shuffleCards :: IO [Card]
 shuffleCards = do
@@ -17,7 +17,7 @@ import Skat.AI.Stupid

 -- | predefined card distribution for testing purposes
 cardDistr :: Piles
-cardDistr = Piles hands [] (map (putAt SkatP) skt)
+cardDistr = emptyPiles hand1 hand2 hand3 skt
    where hand3 = [Card Ace Spades, Card Jack Diamonds, Card Jack Clubs, Card King Spades,
                   Card Nine Spades, Card Ace Diamonds, Card Queen Diamonds, Card Ten Clubs,
                   Card Eight Clubs, Card King Clubs]
@@ -27,9 +27,6 @@ cardDistr = Piles hands [] (map (putAt SkatP) skt)
          hand2 = [Card Eight Spades, Card Queen Spades, Card Seven Spades, Card Seven Diamonds,
                   Card Seven Hearts, Card Eight Hearts, Card Queen Hearts, Card King Hearts,
                   Card Nine Diamonds, Card Eight Diamonds]
-          hands = map (putAt Hand1) hand1
-            ++ map (putAt Hand2) hand2
-            ++ map (putAt Hand3) hand3
          skt = [Card Nine Clubs, Card Queen Clubs]

 singleVsBots :: Communicator c => c -> IO ()
@@ -1,12 +1,13 @@
 module Skat.Operations (
    turn, turnGeneric, play, playOpen, publishGameResults,
-    publishGameStart, play_, sortRender
+    publishGameStart, play_, sortRender, undo_
 ) where

 import Control.Monad.State
 import System.Random (newStdGen, randoms)
 import Data.List
 import Data.Ord
+import qualified Data.Set as S

 import Skat
 import Skat.Card
@@ -23,11 +24,11 @@ compareRender (Card t1 c1) (Card t2 c2) = case compare c1 c2 of
 sortRender :: [Card] -> [Card]
 sortRender = sortBy compareRender

-play_ :: Card -> Skat ()
+play_ :: HasCard c => c -> Skat ()
 play_ card = do
    hand <- gets currentHand
    trCol <- gets trumpColour
-    modifyp $ playCard card
+    modifyp $ playCard hand card
    table <- getp tableCards
    case length table of
        1 -> do modify (setCurrentHand $ next hand)
@@ -35,6 +36,12 @@ play_ card = do
        3 -> evaluateTable >>= modify . setCurrentHand
        _ -> modify (setCurrentHand $ next hand)

+undo_ :: HasCard c => c -> Hand -> Maybe Colour -> Team -> Skat ()
+undo_ card oldCurrent oldTurnCol oldWinner = do
+    modify $ setCurrentHand oldCurrent
+    modify $ setTurnColour oldTurnCol
+    modifyp $ unplayCard oldCurrent (toCard card) oldWinner
+
 turnGeneric :: (PL -> Skat Card)
            -> Int
            -> Skat (Int, Int)
@@ -43,7 +50,7 @@ turnGeneric playFunc depth = do
    table <- getp tableCards
    ps <- gets players
    let p = player ps n
-    hand <- getp $ handCards n
+    over <- getp $ handEmpty n
    trCol <- gets trumpColour
    case length table of
        0 -> playFunc p >> modify (setCurrentHand $ next n) >> turnGeneric playFunc depth
@@ -56,7 +63,7 @@ turnGeneric playFunc depth = do
        2 -> playFunc p >> modify (setCurrentHand $ next n) >> turnGeneric playFunc depth
        3 -> do
            w <- evaluateTable
-            if depth <= 1 || length hand == 0
+            if depth <= 1 || over
                then countGame
                else modify (setCurrentHand w) >> turnGeneric playFunc (depth - 1)

@@ -69,9 +76,8 @@ evaluateTable = do
    turnCol <- gets turnColour
    table <- getp tableCards
    ps <- gets players
-    let winningCard = highestCard trumpCol turnCol table
-    Just winnerHand <- getp $ originOfCard winningCard
-    let winner = player ps winnerHand
+    let winnerHand = uorigin $ getPile $ highestCard trumpCol turnCol table
+        winner = player ps winnerHand
    modifyp $ cleanTable (team winner)
    modify $ setTurnColour Nothing
    return $ hand winner
@@ -82,25 +88,25 @@ countGame = getp count
 play :: (Show p, Player p) => p -> Skat Card
 play p = do
    liftIO $ putStrLn "playing"
-    table <- getp tableCardsS
+    table <- getp tableCards
    turnCol <- gets turnColour
    trump <- gets trumpColour
-    hand <- getp $ handCards (hand p)
+    cards <- getp $ handCards (hand p)
    fallen <- getp played
-    (card, p') <- chooseCard p table fallen hand
+    (card, p') <- chooseCard p table fallen cards
    modifyPlayers $ updatePlayer p'
-    modifyp $ playCard card
+    modifyp $ playCard (hand p) card
    ps <- fmap playersToList $ gets players
-    table' <- getp tableCardsS
+    table' <- getp tableCards
    ps' <- mapM (\p -> onCardPlayed p (head table')) ps
    mapM_ (modifyPlayers . updatePlayer) ps'
-    return card
+    return (toCard card)

 playOpen :: (Show p, Player p) => p -> Skat Card
 playOpen p = do
    --liftIO $ putStrLn $ show (hand p) ++ " playing open"
    card <- chooseCardOpen p
-    modifyp $ playCard card
+    modifyp $ playCard (hand p) card
    return card

 publishGameResults :: (Int, Int) -> Skat ()
@@ -1,32 +1,47 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}

 module Skat.Pile where

-import Data.List
+import Prelude hiding (lookup)
+import qualified Data.Map.Strict as M
+import qualified Data.Vector as V
+import Data.Vector (Vector)
+import Data.Foldable (toList, foldl', Foldable)
+import Data.Maybe
 import Data.Aeson
 import Control.Exception
+import Data.List (delete)

 import Skat.Card
 import Skat.Utils

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

 data CardS p = CardS { getCard :: Card
                     , getPile :: p }
-               deriving (Show, Eq, Ord)
+               deriving (Show, Eq, Ord, Read)
+
+instance HasCard (CardS p) where
+    toCard = getCard

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

+instance Foldable t => Countable (t (CardS p)) Int where
+    count = foldl' f 0
+        where f acc c = count c + acc
+
 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)
+            deriving (Show, Eq, Ord, Read)

 toInt :: Hand -> Int
 toInt Hand1 = 1
@@ -43,76 +58,112 @@ prev Hand1 = Hand3
 prev Hand2 = Hand1
 prev Hand3 = Hand2

-data Played = Table Hand
-            | Won Hand Team
-              deriving (Show, Eq, Ord)
+data Owner = P Hand | S
+             deriving (Show, Eq, Ord, Read)

-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]
+instance ToJSON Owner where
+    toJSON _ = undefined -- TODO: fix

-data SkatP = SkatP
+type Played = Owner -- TODO: remove
+
+data Piles = Piles { _hand1 :: [CardS Owner]
+                   , _hand2 :: [CardS Owner]
+                   , _hand3 :: [CardS Owner]
+                   , _table :: [CardS Owner]
+                   , _wonSingle :: [CardS Owner]
+                   , _wonTeam :: [CardS Owner]
+                   , _skat :: [CardS Owner] }
             deriving (Show, Eq, Ord)

-data Piles = Piles { hands :: [CardS Hand]
-                   , played :: [CardS Played]
-                   , skat :: [CardS SkatP] }
-             deriving (Show, Eq, Ord)
+toTable :: Hand -> Card -> Piles -> Piles
+toTable hand card ps = ps { _table = (CardS card (P hand)) : _table ps }

 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
+played :: Piles -> [CardS Owner]
+played ps = _wonSingle ps ++ _wonTeam ps ++ _table ps

-originOfCard :: Card -> Piles -> Maybe Hand
-originOfCard card (Piles _ pld _) = origin <$> find ((==card) . getCard) pld
+origin :: Owner -> Maybe Hand
+origin (P hand)   = Just hand
+origin S          = Nothing

-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)
+uorigin :: Owner -> Hand
+uorigin owner = case origin owner of
+    Just hand -> hand
+    Nothing   -> error "has no origin"

-winCard :: Team -> CardS Played -> CardS Played
-winCard team (CardS card (Table hand)) = CardS card (Won hand team)
-winCard team c                         = c
+removeFromHand :: Hand -> Card -> Piles -> Piles
+removeFromHand Hand1 card ps = ps { _hand1 = delete (CardS card (P Hand1)) (_hand1 ps) }
+removeFromHand Hand2 card ps = ps { _hand2 = delete (CardS card (P Hand2)) (_hand2 ps) }
+removeFromHand Hand3 card ps = ps { _hand3 = delete (CardS card (P Hand3)) (_hand3 ps) }

-wonCards :: Team -> Piles -> [Card]
-wonCards team (Piles _ pld _) = filterMap (f . getPile) getCard pld
-    where f (Won _ tm) = tm == team
-          f _          = False
+addToHand :: Hand -> Card -> Piles -> Piles
+addToHand Hand1 card ps = ps { _hand1 = (CardS card (P Hand1)) : (_hand1 ps) }
+addToHand Hand2 card ps = ps { _hand2 = (CardS card (P Hand2)) : (_hand2 ps) }
+addToHand Hand3 card ps = ps { _hand3 = (CardS card (P Hand3)) : (_hand3 ps) }
+
+playCard :: HasCard c => Hand -> c -> Piles -> Piles
+playCard hand card' ps = (removeFromHand hand card ps) { _table = (CardS card (P hand)) : _table ps }
+    where card = toCard card'
+
+unplayCard :: Hand -> Card -> Team -> Piles -> Piles
+unplayCard hand card winner ps
+    | null table = case winner of
+        Team -> ps' { _table = tail $ take 3 (_wonTeam ps), _wonTeam = drop 3 (_wonTeam ps) }
+        Single -> ps' { _table = tail $ take 3 (_wonSingle ps), _wonSingle = drop 3 (_wonSingle ps) }
+    | otherwise = ps' { _table = tail (_table ps) }
+  where ps' = addToHand hand card ps
+        table = tableCards ps
+
+wonCards :: Team -> Piles -> [CardS Owner]
+wonCards Team = _wonTeam
+wonCards Single = _wonSingle

 cleanTable :: Team -> Piles -> Piles
-cleanTable winner ps@(Piles hs pld skt) = Piles hs pld' skt
-    where table = tableCards ps
-          pld' = map (winCard winner) pld
+cleanTable Team ps = ps { _table = [], _wonTeam = _table ps ++ _wonTeam ps }
+cleanTable Single ps = ps { _table = [], _wonSingle = _table ps ++ _wonSingle ps }

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

-tableCardsS :: Piles -> [CardS Played]
-tableCardsS (Piles _ pld _) = filter (f . getPile) pld
-    where f (Table _) = True
-          f _         = False
+handEmpty :: Hand -> Piles -> Bool
+handEmpty Hand1 = null . _hand1
+handEmpty Hand2 = null . _hand2
+handEmpty Hand3 = null . _hand3

-handCards :: Hand -> Piles -> [Card]
-handCards hand (Piles hs _ _) = filterMap ((==hand) . getPile) getCard hs
+handCards :: Hand -> Piles -> [CardS Owner]
+handCards Hand1 = _hand1
+handCards Hand2 = _hand2
+handCards Hand3 = _hand3
+
+allowed :: Hand -> Colour -> Maybe Colour -> Piles -> [CardS Owner]
+allowed hand trCol turnCol ps
+        | null sameColour = cards
+        | otherwise = sameColour
+    where cards = handCards hand ps
+          sameColour = filter (\ca -> effectiveColour trCol ca `equals` turnCol) cards

 skatCards :: Piles -> [Card]
-skatCards (Piles _ _ skat) = map getCard skat
+skatCards = map getCard . _skat
+
+emptyPiles :: [Card] -> [Card] -> [Card] -> [Card] -> Piles
+emptyPiles h1 h2 h3 skt = makePiles h1 h2 h3 [] skt

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

+makePiles :: [Card] -> [Card] -> [Card] -> [CardS Owner] -> [Card] -> Piles
+makePiles h1 h2 h3 table skt = Piles h1' h2' h3' table [] [] skt'
+    where h1' = map (putAt $ P Hand1) h1
+          h2' = map (putAt $ P Hand2) h2
+          h3' = map (putAt $ P Hand3) h3
+          skt' = map (putAt S) skt
+
 distribute :: [Card] -> Piles
-distribute cards = Piles hands [] (map (putAt SkatP) skt)
+distribute cards = emptyPiles hand1 hand2 hand3 skt
    where round1 = chunksOf 3 (take 9 cards)
          skt = take 2 $ drop 9 cards
          round2 = chunksOf 4 (take 12 $ drop 11 cards)
@@ -120,6 +171,3 @@ distribute cards = Piles hands [] (map (putAt SkatP) skt)
          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
@@ -18,11 +18,11 @@ class (Monad m, MonadIO m, MonadPlayer m) => MonadPlayerOpen m where
 class Player p where
    team :: p -> Team
    hand :: p -> Hand
-    chooseCard :: MonadPlayer m
+    chooseCard :: (HasCard c, MonadPlayer m)
               => p
               -> [CardS Played]
               -> [CardS Played]
-               -> [Card]
+               -> [c]
               -> m (Card, p)
    onCardPlayed :: MonadPlayer m
                 => p
@@ -34,10 +34,10 @@ class Player p where
                   -> m Card
    chooseCardOpen p = do
        piles <- showPiles
-        let table = tableCardsS piles
+        let table = tableCards piles
            fallen = played piles
            myCards = handCards (hand p) piles
-        fmap fst $ chooseCard p table fallen myCards
+        fst <$> chooseCard p table fallen myCards
    onGameResults :: MonadIO m
                  => p
                  -> (Int, Int)
@@ -4,9 +4,9 @@ module Skat.Player.Utils (

 import Skat.Player
 import qualified Skat.Card as C
-import Skat.Card (Card)
+import Skat.Card (Card, HasCard(..))

-isAllowed :: MonadPlayer m => [Card] -> Card -> m Bool
+isAllowed :: (HasCard c, MonadPlayer m) => [c] -> c -> m Bool
 isAllowed hand card = do
    trCol <- trumpColour
    turnCol <- turnColour
@@ -1,8 +1,12 @@
 module Skat.Render where

 import Data.List
+import Data.Vector (Vector, toList)

 import Skat.Card

-render :: [Card] -> IO ()
-render = putStrLn . intercalate "\n" . zipWith (\n c -> show n ++ ") " ++ show c) [0..]
+render :: HasCard c => [c] -> IO ()
+render = putStrLn . intercalate "\n" . zipWith (\n c -> show n ++ ") " ++ show c) [0..] . map toCard
+
+renderVector :: Vector Card -> IO ()
+renderVector = render . toList
@@ -4,6 +4,7 @@ import System.Random
 import Text.Read
 import qualified Data.ByteString.Char8 as B (ByteString, unpack, pack)
 import qualified Data.Text as T (Text, unpack, pack)
+import Data.List (foldl')

 shuffle :: StdGen -> [a] -> [a]
 shuffle g xs = shuffle' (randoms g) xs
@@ -31,7 +32,7 @@ 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
+    where g a bs = if pred a then (f $! a) : bs else bs

 --filterM :: Monad m => (a -> m Bool) -> [a] -> m [a]
 --filterM _    []     = return []