some optimizations

app/Main.hs

@@ -19,7 +19,12 @@ import Skat.AI.Rulebased
 import Skat.AI.Minmax (playCLI)
 
 main :: IO ()
-main = testAI 10
+main = testMinmax 10
+
+testMinmax :: Int -> IO ()
+testMinmax n = do
+    let acs = repeat playSkat
+    sequence_ (take n acs)
 
 testAI :: Int -> IO ()
 testAI n = do
@@ -71,14 +76,11 @@ shuffledEnv2 = do
     return $ SkatEnv (distribute cards) Nothing Spades pls2 Hand1
 
 env2 :: SkatEnv
-env2 = SkatEnv piles Nothing Spades playersExamp Hand1
-    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]
+env2 = SkatEnv piles Nothing Hearts playersExamp Hand2
+    where hand1 = [Card Eight Hearts, Card Queen Hearts, Card Ace Clubs, Card Queen Diamonds]
+          hand2 = [Card Seven Hearts, Card King Hearts, Card Ten 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) [] []
+          piles = emptyPiles hand1 hand2 hand3 []
 
 env3 :: SkatEnv
 env3 = SkatEnv piles Nothing Diamonds pls2 Hand3
@@ -91,11 +93,7 @@ env3 = SkatEnv piles Nothing Diamonds pls2 Hand3
           hand3 = [ Card Jack Hearts, Card Jack Spades, Card Ten Spades, Card Ace Spades, Card Eight Diamonds
                   , Card Queen Diamonds, Card Ten Diamonds, Card Ten Hearts, Card Queen Hearts, Card King Hearts ]
           skat = [ Card Queen Clubs, Card Queen Spades]
-          h1 = map (putAt Hand1) hand1
-          h2 = map (putAt Hand2) hand2
-          h3 = map (putAt Hand3) hand3
-          skt = map (putAt SkatP) skat
-          piles = Piles (h1 ++ h2 ++ h3) [] skt
+          piles = emptyPiles hand1 hand2 hand3 skat
 
 runWebSocketServer :: IO ()
 runWebSocketServer = do
@@ -110,5 +108,4 @@ application pending = do
         putStrLn $ BS.unpack msg
 
 playSkat :: IO ()
-playSkat = do
-    void $ (flip runStateT) env3 playCLI
+playSkat = void $ (flip runStateT) env3 playCLI

app/TestEnvs.hs

@@ -0,0 +1,31 @@
+module TestEnvs where
+
+import Skat
+import Skat.Card
+import Skat.Pile
+import Skat.Player
+import Skat.AI.Stupid
+
+pls2 :: Players
+pls2 = Players
+    (PL $ Stupid Team Hand1)
+    (PL $ Stupid Team Hand2)
+    (PL $ Stupid Single Hand3)
+
+env3 :: SkatEnv
+env3 = SkatEnv piles Nothing Diamonds pls2 Hand3
+    where hand1 = [ Card Jack Diamonds, Card Jack Clubs, Card Nine Spades, Card King Spades
+                  , Card Seven Diamonds, Card Nine Diamonds, Card Seven Clubs, Card Eight Clubs
+                  , Card Ten Clubs, Card Eight Hearts ]
+          hand2 = [ Card Seven Spades, Card Eight Spades, Card Seven Hearts, Card Nine Hearts
+                  , Card Ace Hearts, Card King Diamonds, Card Ace Diamonds, Card Nine Clubs
+                  , Card King Clubs, Card Ace Clubs ]
+          hand3 = [ Card Jack Hearts, Card Jack Spades, Card Ten Spades, Card Ace Spades, Card Eight Diamonds
+                  , Card Queen Diamonds, Card Ten Diamonds, Card Ten Hearts, Card Queen Hearts, Card King Hearts ]
+          skat = [ Card Queen Clubs, Card Queen Spades]
+          piles = emptyPiles hand1 hand2 hand3 skat
+
+shuffledEnv2 :: IO SkatEnv
+shuffledEnv2 = do
+    cards <- shuffleCards
+    return $ SkatEnv (distribute cards) Nothing Spades pls2 Hand1

package.yaml

@@ -33,6 +33,7 @@ dependencies:
 - parallel
 - containers
 - case-insensitive
+- vector
 
 library:
   source-dirs: src
@@ -45,6 +46,7 @@ executables:
     - -threaded
     - -rtsopts
     - -with-rtsopts=-N
+    - -O2
     dependencies:
     - skat
 
@@ -56,5 +58,6 @@ tests:
     - -threaded
     - -rtsopts
     - -with-rtsopts=-N
+    - -O2
     dependencies:
     - skat

skat.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
+-- hash: 3f130a9bf454b63893b6f1958214229a75ad6916b19eb7bb6797a19f0f14dd3e
 
 name:           skat
 version:        0.1.0.1
@@ -60,16 +60,18 @@ library
     , random
     , split
     , text
+    , vector
     , websockets
   default-language: Haskell2010
 
 executable skat-exe
   main-is: Main.hs
   other-modules:
+      TestEnvs
       Paths_skat
   hs-source-dirs:
       app
-  ghc-options: -threaded -rtsopts -with-rtsopts=-N
+  ghc-options: -threaded -rtsopts -with-rtsopts=-N -O2
   build-depends:
       aeson
     , base >=4.7 && <5
@@ -84,6 +86,7 @@ executable skat-exe
     , skat
     , split
     , text
+    , vector
     , websockets
   default-language: Haskell2010
 
@@ -94,7 +97,7 @@ test-suite skat-test
       Paths_skat
   hs-source-dirs:
       test
-  ghc-options: -threaded -rtsopts -with-rtsopts=-N
+  ghc-options: -threaded -rtsopts -with-rtsopts=-N -O2
   build-depends:
       aeson
     , base >=4.7 && <5
@@ -109,5 +112,6 @@ test-suite skat-test
     , skat
     , split
     , text
+    , vector
     , websockets
   default-language: Haskell2010

src/Skat.hs

@@ -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

src/Skat/AI/Human.hs

@@ -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

src/Skat/AI/Minmax.hs

@@ -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

src/Skat/AI/Online.hs

@@ -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)

src/Skat/AI/Rulebased.hs

@@ -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)

src/Skat/AI/Stupid.hs

@@ -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)

src/Skat/Card.hs

@@ -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

src/Skat/Matches.hs

@@ -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 ()

src/Skat/Operations.hs

@@ -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 ()

src/Skat/Pile.hs

@@ -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
-             deriving (Show, Eq, Ord)
+type Played = Owner -- TODO: remove
 
-data Piles = Piles { hands :: [CardS Hand]
-                   , played :: [CardS Played]
-                   , skat :: [CardS SkatP] }
+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)
 
+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
-
-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
+played :: Piles -> [CardS Owner]
+played ps = _wonSingle ps ++ _wonTeam ps ++ _table ps
+
+origin :: Owner -> Maybe Hand
+origin (P hand)   = Just hand
+origin S          = Nothing
+
+uorigin :: Owner -> Hand
+uorigin owner = case origin owner of
+    Just hand -> hand
+    Nothing   -> error "has no origin"
+
+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) }
+
+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 -> [CardS Owner]
+tableCards = _table
 
-tableCards :: Piles -> [Card]
-tableCards (Piles _ pld _) = filterMap (f . getPile) getCard pld
-    where f (Table _) = True
-          f _         = False
+handEmpty :: Hand -> Piles -> Bool
+handEmpty Hand1 = null . _hand1
+handEmpty Hand2 = null . _hand2
+handEmpty Hand3 = null . _hand3
 
-tableCardsS :: Piles -> [CardS Played]
-tableCardsS (Piles _ pld _) = filter (f . getPile) pld
-    where f (Table _) = True
-          f _         = False
+handCards :: Hand -> Piles -> [CardS Owner]
+handCards Hand1 = _hand1
+handCards Hand2 = _hand2
+handCards Hand3 = _hand3
 
-handCards :: Hand -> Piles -> [Card]
-handCards hand (Piles hs _ _) = filterMap ((==hand) . getPile) getCard hs
+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

src/Skat/Player.hs

@@ -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)

src/Skat/Player/Utils.hs

@@ -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

src/Skat/Render.hs

@@ -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

src/Skat/Utils.hs

@@ -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 []