add handleskat routine

.gitignore

@@ -2,6 +2,7 @@
 
 !*.*
 !*/
+!LICENSE
 
 *.hi
 *.o

LICENSE

@@ -0,0 +1,30 @@
+Copyright Author name here (c) 2019
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Author name here nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Operations.hs

@@ -1,88 +0,0 @@
-module Operations where
-
-import Control.Monad.State
-import System.Random (newStdGen, randoms)
-import Data.List
-import Data.Ord
-
-import Card
-import Skat
-import Pile
-import Player (chooseCard, Players(..), Player(..), PL(..),
-    updatePlayer, playersToList, player)
-import Utils (shuffle)
-
-compareRender :: Card -> Card -> Ordering
-compareRender (Card t1 c1) (Card t2 c2) = case compare c1 c2 of
-    EQ -> compare t1 t2
-    v  -> v
-
-sortRender :: [Card] -> [Card]
-sortRender = sortBy compareRender
-
-turnGeneric :: (PL -> Skat Card)
-            -> Int
-            -> Hand
-            -> Skat (Int, Int)
-turnGeneric playFunc depth n = do
-    table <- getp tableCards
-    ps <- gets players
-    let p = player ps n
-    hand <- getp $ handCards n
-    trCol <- gets trumpColour
-    case length table of
-        0 -> playFunc p >> turnGeneric playFunc depth (next n)
-        1 -> do
-            modify $ setTurnColour
-                (Just $ effectiveColour trCol $ head table)
-            playFunc p
-            turnGeneric playFunc depth (next n)
-        2 -> playFunc p >> turnGeneric playFunc depth (next n)
-        3 -> do
-            w <- evaluateTable
-            if 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
-    trumpCol <- gets trumpColour
-    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
-    modifyp $ cleanTable (team winner)
-    modify $ setTurnColour Nothing
-    return $ hand winner
-
-countGame :: Skat (Int, Int)
-countGame = getp count
-
-play :: (Show p, Player p) => p -> Skat Card
-play p = do
-    liftIO $ putStrLn "playing"
-    table <- getp tableCardsS
-    turnCol <- gets turnColour
-    trump <- gets trumpColour
-    hand <- getp $ handCards (hand p)
-    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
-
-playOpen :: (Show p, Player p) => p -> Skat Card
-playOpen p = do
-    --liftIO $ putStrLn $ show (hand p) ++ " playing open"
-    card <- chooseCardOpen p
-    modifyp $ playCard card
-    return card

README.md

@@ -1 +1,4 @@
-# skat
+# Skat
+
+This is a Haskell implementation of the famous german card game Skat. It provides
+a library implementing all the game mechanics and a simple AI.

app/Main.hs

@@ -16,9 +16,15 @@ import Skat.Pile
 import Skat.AI.Stupid
 import Skat.AI.Online
 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
@@ -34,16 +40,17 @@ runAI = do
         trs = filter (isTrump Spades) cs
     if length trs >= 5 && any ((==32) . getID) cs
         then do
-            pts <- fst <$> evalStateT (turn Hand1) env
+            pts <- fst <$> evalStateT turn env
-            if pts > 60 then return 1 else return 0
+            -- if pts > 60 then return 1 else return 0
+            return pts
         else runAI
 
 env :: SkatEnv
-env = SkatEnv piles Nothing Spades playersExamp
+env = SkatEnv piles Nothing Spades playersExamp Hand1
     where piles = distribute allCards 
 
 envStupid :: SkatEnv
-envStupid = SkatEnv piles Nothing Spades pls2
+envStupid = SkatEnv piles Nothing Spades pls2 Hand1
     where piles = distribute allCards 
 
 playersExamp :: Players
@@ -56,22 +63,37 @@ pls2 :: Players
 pls2 = Players
     (PL $ Stupid Team Hand1)
     (PL $ Stupid Team Hand2)
-    (PL $ Stupid Team Hand3)
+    (PL $ Stupid Single Hand3)
 
 shuffledEnv :: IO SkatEnv
 shuffledEnv = do
     cards <- shuffleCards
-    return $ SkatEnv (distribute cards) Nothing Spades playersExamp
+    return $ SkatEnv (distribute cards) Nothing Spades playersExamp Hand1
+
+shuffledEnv2 :: IO SkatEnv
+shuffledEnv2 = do
+    cards <- shuffleCards
+    return $ SkatEnv (distribute cards) Nothing Spades pls2 Hand1
 
 env2 :: SkatEnv
-env2 = SkatEnv piles Nothing Spades playersExamp
+env2 = SkatEnv piles Nothing Hearts playersExamp Hand2
-    where hand1 = [Card Seven Clubs, Card King Clubs, Card Ace Clubs, Card Queen Diamonds]
+    where hand1 = [Card Eight Hearts, Card Queen Hearts, Card Ace Clubs, Card Queen Diamonds]
-          hand2 = [Card Seven Hearts, Card King Hearts, Card Ace Hearts, Card Queen Spades]
+          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
+          piles = emptyPiles hand1 hand2 hand3 []
-          h2 = map (putAt Hand2) hand2
+
-          h3 = map (putAt Hand3) hand3
+env3 :: SkatEnv
-          piles = Piles (h1 ++ h2 ++ h3) [] []
+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
 
 runWebSocketServer :: IO ()
 runWebSocketServer = do
@@ -84,3 +106,6 @@ application pending = do
     forever $ do
         msg <- WS.receiveData conn
         putStrLn $ BS.unpack msg
+
+playSkat :: IO ()
+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

@@ -1,10 +1,10 @@
 name:                skat
-version:             0.1.0.0
+version:             0.1.0.1
 github:              "githubuser/skat"
 license:             BSD3
-author:              "Author name here"
+author:              "flavis"
-maintainer:          "example@example.com"
+maintainer:          "christian@flavigny.de"
-copyright:           "2019 Author name here"
+copyright:           "2019"
 
 extra-source-files:
 - README.md
@@ -17,7 +17,7 @@ extra-source-files:
 # To avoid duplicated efforts in documentation and dealing with the
 # complications of embedding Haddock markup inside cabal files, it is
 # common to point users to the README.md file.
-description:         Please see the README on GitHub at <https://github.com/githubuser/skat#readme>
+description:         Please see the README on Gitea at <https://git.flavigny.de/christian/skat>
 
 dependencies:
 - base >= 4.7 && < 5
@@ -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,16 +4,16 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: e2db48733c92b94d7f2d8f4991dd2f7cec26d59666cd3c618710a8a3c22616d0
+-- hash: 0b9b42e767fdfcdc821bfc31f5c002e1f6752ba6af032ff402339ef667f60209
 
 name:           skat
-version:        0.1.0.0
+version:        0.1.0.1
-description:    Please see the README on GitHub at <https://github.com/githubuser/skat#readme>
+description:    Please see the README on Gitea at <https://git.flavigny.de/christian/skat>
 homepage:       https://github.com/githubuser/skat#readme
 bug-reports:    https://github.com/githubuser/skat/issues
-author:         Author name here
+author:         flavis
-maintainer:     example@example.com
+maintainer:     christian@flavigny.de
-copyright:      2019 Author name here
+copyright:      2019
 license:        BSD3
 license-file:   LICENSE
 build-type:     Simple
@@ -29,15 +29,19 @@ library
   exposed-modules:
       Skat
       Skat.AI.Human
+      Skat.AI.Minmax
       Skat.AI.Online
       Skat.AI.Rulebased
       Skat.AI.Server
       Skat.AI.Stupid
+      Skat.Bidding
       Skat.Card
+      Skat.Matches
       Skat.Operations
       Skat.Pile
       Skat.Player
       Skat.Player.Utils
+      Skat.Preperation
       Skat.Render
       Skat.Utils
       Skat.WebSocketServer
@@ -58,16 +62,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
@@ -82,6 +88,7 @@ executable skat-exe
     , skat
     , split
     , text
+    , vector
     , websockets
   default-language: Haskell2010
 
@@ -92,7 +99,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
@@ -107,5 +114,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
@@ -16,7 +17,8 @@ import qualified Skat.Player as P
 data SkatEnv = SkatEnv { piles :: Piles
                        , turnColour :: Maybe Colour
                        , trumpColour :: Colour
-                       , players :: Players }
+                       , players :: Players
+                       , currentHand :: Hand }
                deriving Show
 
 type Skat = StateT SkatEnv IO
@@ -45,5 +47,16 @@ modifyPlayers f = modify g
 setTurnColour :: Maybe Colour -> SkatEnv -> SkatEnv
 setTurnColour col sk = sk { turnColour = col }
 
-mkSkatEnv :: Piles -> Maybe Colour -> Colour -> Players -> SkatEnv
+setCurrentHand :: Hand -> SkatEnv -> SkatEnv
+setCurrentHand hand sk = sk { currentHand = hand }
+
+mkSkatEnv :: Piles -> Maybe Colour -> Colour -> Players -> Hand -> SkatEnv
 mkSkatEnv = SkatEnv
+
+allowedCards :: Skat [CardS Owner]
+allowedCards = do
+    curHand <- gets currentHand
+    pls <- gets players
+    turnCol <- gets turnColour
+    trumpCol <- gets trumpColour
+    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

@@ -0,0 +1,319 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE TupleSections #-}
+
+module Skat.AI.Minmax (
+    choose, playCLI
+) where
+
+import Control.Monad.State
+import Control.Exception (assert)
+import Control.Monad.Fail
+import Data.Ord
+import Text.Read (readMaybe)
+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 hiding (trumpColour, turnColour)
+import qualified Skat.Render as S
+--import TestEnvs (env3, shuffledEnv2)
+
+debug :: Bool
+debug = False
+
+class (Ord v, Eq v) => Value v where
+    invert :: v -> v
+    win :: v
+    loss :: v
+
+class Player p where
+    maxing :: p -> Bool
+
+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 (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 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)
+    showTurn :: t -> m ()
+    winner :: m (Maybe p)
+
+-- Skat implementation
+
+instance Player S.PL where
+    maxing p = S.team p == S.Team
+
+instance Value Int where
+    invert = negate
+    win = 120
+    loss = -120
+
+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
+    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
+    evaluate = do
+        player <- currentPlayer
+        piles <- gets S.piles
+        let (sgl, tm) = S.count piles
+        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
+
+data TicTacToe = Tic | Tac | Toe
+                 deriving (Eq, Ord)
+
+instance Show TicTacToe where
+    show Tic = "O"
+    show Tac = "X"
+    show Toe = "_"
+
+data WinLossTie = Loss | Tie | Win
+                  deriving (Eq, Show, Ord)
+
+instance Value WinLossTie where
+    invert Win = Loss
+    invert Loss = Win
+    invert Tie = Tie
+    win = Win
+    loss = Loss
+
+data GameState = GameState { getBoard :: [TicTacToe]
+                           , getCurrent :: Bool }
+             deriving Show
+
+instance Player Bool where
+    maxing = id
+
+instance Monad m => MonadGame Int [] WinLossTie Bool (StateT GameState m) where
+    currentPlayer = gets getCurrent
+    turns = do
+        board <- gets getBoard
+        let fields = zip [0..] board
+        return $ map fst $ filter ((==Toe) . snd) fields
+    play turn = do
+        env <- get
+        let value = if getCurrent env then Tic else Tac
+            board' = updateAt turn (getBoard env) value
+            current' = not $ getCurrent env
+        put $ GameState board' current'
+    simulate turn action = do
+        backup <- get
+        play turn
+        res <- action
+        put backup
+        return $! res
+    evaluate = do
+        board <- gets getBoard
+        current <- currentPlayer
+        let mayWinner = ticWinner board
+        case mayWinner of
+            Just Tic -> return $ if current then Win else Loss
+            Just Tac -> return $ if current then Loss else Win
+            Just Toe -> return Tie
+            Nothing -> return Tie
+    over = do
+        board <- gets getBoard
+        case ticWinner board of
+            Just _ -> return True
+            _      -> return False
+
+ticWinner :: [TicTacToe] -> Maybe TicTacToe
+ticWinner board
+    | ticWon    = Just Tic
+    | tacWon    = Just Tac
+    | over      = Just Toe
+    | otherwise = Nothing
+  where ticWon = hasWon $ map (==Tic) board
+        tacWon = hasWon $ map (==Tac) board
+        hasWon (True:_:_:True:_:_:True:_:_:[]) = True
+        hasWon (True:_:_:_:True:_:_:_:True:[]) = True
+        hasWon (_:True:_:_:True:_:_:True:_:[]) = True
+        hasWon (_:_:True:_:_:True:_:_:True:[]) = True
+        hasWon (_:_:True:_:True:_:True:_:_:[]) = True
+        hasWon (True:True:True:_:_:_:_:_:_:[]) = True
+        hasWon (_:_:_:True:True:True:_:_:_:[]) = True
+        hasWon (_:_:_:_:_:_:True:True:True:[]) = True
+        hasWon _                               = False
+        over = (length $ filter (==Toe) board) == 0
+
+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 l v p m)
+       => Int
+       -> t
+       -> v
+       -> v
+       -> m (t, v)
+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 (turn_,) <$> lift evaluate
+    else do
+        -- 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) (turn_, alpha) $ forM_ availableTurns $ \turn -> do
+            currentMax <- gets snd
+            -- beta cutoff
+            unless (currentMax >= beta) $ do
+                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))
+
+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]
+
+otherBoard :: [TicTacToe]
+otherBoard = [Tic, Tac, Tac, Tic, Tac, Tic, Toe, Tic, Toe]
+
+print9x9 :: (Int -> IO ()) -> IO ()
+print9x9 pr = pr 0 >> pr 1 >> pr 2 >> putStrLn ""
+    >> pr 3 >> pr 4 >> pr 5 >> putStrLn ""
+    >> pr 6 >> pr 7 >> pr 8 >> putStrLn ""
+
+printBoard :: [TicTacToe] -> IO ()
+printBoard board = print9x9 pr >> putStrLn ""
+    where pr n = putStr (show $ board !! n) >> putStr " "
+
+printOptions :: [Int] -> IO ()
+printOptions opts = print9x9 pr
+    where pr n
+            | n `elem` opts = putStr (show n) >> putStr " "
+            | otherwise     = putStr "  "
+
+instance MonadIO m => PlayableGame Int [] WinLossTie Bool (StateT GameState m) where
+    showBoard = do
+        board <- gets getBoard
+        liftIO $ printBoard board
+    showTurns = turns >>= liftIO . printOptions
+    winner = do
+        board <- gets getBoard
+        let win = ticWinner board
+        case win of
+            Just Toe -> return Nothing
+            Just Tic -> return $ Just True
+            Just Tac -> return $ Just False
+            Nothing -> return Nothing
+    askTurn = readMaybe <$> liftIO getLine
+    showTurn _ = return ()
+
+instance PlayableGame (S.CardS S.Owner) [] Int S.PL S.Skat where
+    showBoard = do
+        liftIO $ putStrLn ""
+        table <- S.getp S.tableCards
+        liftIO $ putStr "Table: "
+        liftIO $ print table
+    showTurns = do
+        cards <- turns
+        player <- currentPlayer
+        liftIO $ print player
+        liftIO $ S.render cards
+    winner = do
+        piles <- gets S.piles
+        pls <- gets S.players
+        let res = S.count piles :: (Int, Int)
+            winnerTeam = trace (show res) $ if fst res > snd res then S.Single else S.Team
+            winners = filter ((==winnerTeam) . S.team) (S.playersToList pls)
+        return $ Just $ head winners
+    askTurn = do
+        cards <- turns
+        let sorted = cards
+        input <- liftIO getLine
+        case readMaybe input of
+            Just n -> if n >= 0 && n < length sorted then return $ Just (sorted !! n)
+                else return Nothing
+            Nothing -> return Nothing
+    showTurn card = do
+        player <- currentPlayer
+        liftIO $ putStrLn $ show player ++ " plays " ++ show card
+
+playCLI :: (MonadFail m, Read t, PlayableGame t l v p m) => m ()
+playCLI = do
+    gameOver <- over
+    if gameOver
+        then announceWinner
+        else do
+            when debug showBoard
+            current <- currentPlayer
+            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
+        liftIO $ putStr "> "
+        mayTurn <- askTurn
+        case mayTurn of
+            Just val -> if val `elem` options then return val else readTurn
+            Nothing -> readTurn
+      announceWinner = do
+        showBoard
+        win <- winner
+        liftIO $ putStrLn $ show win ++ " wins the game!"
+
+playTicTacToe :: IO ()
+playTicTacToe = void $ (flip runStateT) (GameState emptyBoard True) playCLI

src/Skat/AI/Online.hs

@@ -5,8 +5,9 @@
 module Skat.AI.Online where
 
 import Control.Monad.Reader
-import Network.WebSockets (Connection, sendTextData, receiveData)
+import Control.Concurrent.Chan
 import Data.Aeson
+import Data.Maybe
 import qualified Data.ByteString.Lazy.Char8 as BS
 
 import Skat.Player
@@ -14,74 +15,178 @@ import qualified Skat.Player.Utils as P
 import Skat.Pile
 import Skat.Card
 import Skat.Render
+import Skat.Preperation
+import Skat.Bidding
+
+class Communicator a where
+    send :: a -> String -> IO ()
+    receive :: a -> IO String
+
+instance Communicator (Chan String) where
+    send = writeChan
+    receive = readChan
 
 class Monad m => MonadClient m where
     query :: String -> m ()
     response :: m String
 
-data OnlineEnv = OnlineEnv { getTeam :: Team
+data OnlineEnv c = OnlineEnv { getTeam :: Team
-                           , getHand :: Hand
+                             , getHand :: Hand
-                           , connection :: Connection }
+                             , connection :: c }
-                 deriving Show
 
-instance Show Connection where
+data PrepOnline c = PrepOnline { prepHand :: Hand
-    show _ = "A connection"
+                               , prepConnection :: c
+                               , prepCards :: [Card] }
 
-instance Player OnlineEnv where
+instance Show (OnlineEnv c) where
+    show _ = "An online env"
+
+instance Show (PrepOnline c) where
+    show _ = "An online prep env"
+
+instance Communicator c => Player (OnlineEnv c) where
     team = getTeam
     hand = getHand
     chooseCard p table _ hand = runReaderT (choose table hand) p >>= \c -> return (c, p)
     onCardPlayed p c = runReaderT (cardPlayed c) p >> return p
     onGameResults p res = runReaderT (onResults res) p
+    onGameStart p singlePlayer = runReaderT (onStartOnline singlePlayer) p
 
-type Online m = ReaderT OnlineEnv m
+instance Communicator c => Bidder (PrepOnline c) where
+    hand = prepHand
+    askBid p against bid = do
+        liftIO $ send (prepConnection p) (BS.unpack $ encode $ BidQuery against bid)
+        r <- liftIO $ receive (prepConnection p)
+        case decode (BS.pack r) of
+            Just (BidResponse newBid) -> do
+                if newBid > bid then return $ Just newBid else return Nothing
+            Nothing -> askBid p against bid
+    askResponse p bidder bid = do
+        liftIO $ send (prepConnection p) (BS.unpack $ encode $ BidResponseQuery bidder bid)
+        r <- liftIO $ receive (prepConnection p)
+        case decode (BS.pack r) of
+            Just (YesNo value) -> return value
+            Nothing -> askResponse p bidder bid
+    askGame p bid = do
+        liftIO $ send (prepConnection p) (BS.unpack $ encode $ AskGameQuery bid)
+        r <- liftIO $ receive (prepConnection p)
+        case decode (BS.pack r) of
+            Just (GameResponse game) -> return game
+            Nothing -> askGame p bid
+    askHand p bid = do
+        liftIO $ send (prepConnection p) (BS.unpack $ encode $ AskHandQuery)
+        r <- liftIO $ receive (prepConnection p)
+        case decode (BS.pack r) of
+            Just (YesNo value) -> return value
+            Nothing -> askHand p bid
+    askSkat p bid cards = do
+        liftIO $ send (prepConnection p) (BS.unpack $ encode $ AskSkatQuery cards bid)
+        r <- liftIO $ receive (prepConnection p)
+        case decode (BS.pack r) of
+            Just (ChosenCards cards) -> return cards
+            Nothing -> askSkat p bid cards
+    toPlayer p tm = PL $ OnlineEnv tm (prepHand p) (prepConnection p)
+    onStart p = do
+        let cards = prepCards p
+        liftIO $ send (prepConnection p) (BS.unpack $ encode $ CardsQuery cards)
 
-instance MonadIO m => MonadClient (Online m) where
+type Online a m = ReaderT (OnlineEnv a) m
+
+instance (Communicator c, MonadIO m) => MonadClient (Online c m) where
     query s = do
         conn <- asks connection
-        liftIO $ sendTextData conn (BS.pack s)
+        liftIO $ send conn s
     response = do
         conn <- asks connection
-        liftIO $ BS.unpack <$> receiveData conn
+        liftIO $ receive conn
 
-instance MonadPlayer m => MonadPlayer (Online m) where
+instance MonadPlayer m => MonadPlayer (Online a m) where
     trumpColour = lift $ trumpColour
     turnColour = lift $ turnColour
     showSkat = lift . showSkat
 
-choose :: MonadPlayer m => [CardS Played] -> [Card] -> Online m Card
+choose :: HasCard a => (Communicator c, MonadPlayer m) => [CardS Played] -> [a] -> Online c m Card
-choose table hand = do
+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
+            if card `elem` hand && allowed then return card else choose table hand'
-        Nothing -> choose table hand
+        Nothing -> choose table hand'
 
-cardPlayed :: MonadPlayer m => CardS Played -> Online m ()
+cardPlayed :: (Communicator c, MonadPlayer m) => CardS Played -> Online c m ()
 cardPlayed card = query (BS.unpack $ encode $ CardPlayedQuery card)
 
-onResults :: MonadIO m => (Int, Int) -> Online m ()
+onResults :: (Communicator c, MonadIO m) => (Int, Int) -> Online c m ()
 onResults (sgl, tm) = query (BS.unpack $ encode $ GameResultsQuery sgl tm)
 
-data ChooseQuery = ChooseQuery [Card] [CardS Played]
+onStartOnline :: (Communicator c, MonadPlayer m) => Hand -> Online c m ()
-data CardPlayedQuery = CardPlayedQuery (CardS Played)
+onStartOnline singlePlayer = do
-data GameResultsQuery = GameResultsQuery Int Int
+    trCol <- trumpColour
-data ChosenResponse = ChosenResponse Card
+    ownHand <- asks getHand
+    query (BS.unpack $ encode $ GameStartQuery trCol ownHand singlePlayer)
 
-instance ToJSON ChooseQuery where
+-- | QUERIES AND RESPONSES
+    
+data Query = ChooseQuery [Card] [CardS Played]
+           | CardPlayedQuery (CardS Played)
+           | GameResultsQuery Int Int
+           | GameStartQuery Colour Hand Hand
+           | BidQuery Hand Bid
+           | BidResponseQuery Hand Bid
+           | AskGameQuery Bid
+           | AskHandQuery
+           | AskSkatQuery [Card] Bid
+           | CardsQuery [Card]
+
+newtype ChosenResponse = ChosenResponse Card
+newtype BidResponse = BidResponse Int
+newtype YesNo = YesNo Bool
+newtype GameResponse = GameResponse Game
+                       deriving Show
+newtype ChosenCards = ChosenCards [Card]
+     
+instance ToJSON Query where
     toJSON (ChooseQuery hand table) =
         object ["query" .= ("choose_card" :: String), "hand" .= hand, "table" .= table]
-
-instance ToJSON CardPlayedQuery where
     toJSON (CardPlayedQuery card) =
         object ["query" .= ("card_played" :: String), "card" .= card]
-
-instance ToJSON GameResultsQuery where
     toJSON (GameResultsQuery sgl tm) =
         object ["query" .= ("results" :: String), "single" .= sgl, "team" .= tm]
+    toJSON (GameStartQuery trumps handNo sglPlayer) =
+        object ["query" .= ("start_game" :: String), "trumps" .= show trumps,
+                "hand" .= toInt handNo, "single" .= toInt sglPlayer ]
+    toJSON (BidQuery hand bid) =
+        object ["query" .= ("bid" :: String), "whom" .= show hand, "current" .= bid]
+    toJSON (BidResponseQuery hand bid) =
+        object ["query" .= ("bid_response" :: String), "from" .= show hand ]
+    toJSON (AskHandQuery) =
+        object ["query" .= ("play_hand" :: String)]
+    toJSON (AskSkatQuery cards bid) =
+        object ["query" .= ("skat" :: String), "cards" .= cards, "bid" .= bid ]
+    toJSON (CardsQuery cards) =
+        object ["query" .= ("cards" :: String), "cards" .= cards ]
+    toJSON (AskGameQuery bid) =
+        object ["query" .= ("ask_game" :: String), "bid" .= bid]
 
 instance FromJSON ChosenResponse where
     parseJSON = withObject "ChosenResponse" $ \v -> ChosenResponse
         <$> v .: "card"
+
+instance FromJSON BidResponse where
+    parseJSON = withObject "BidResponse" $ \v -> BidResponse
+        <$> v .: "bid"
+
+instance FromJSON YesNo where
+    parseJSON = withObject "BidYesNo" $ \v -> YesNo
+        <$> v .: "yesno"
+
+instance FromJSON GameResponse where
+    parseJSON = withObject "GameResponse" $ \v -> GameResponse
+        <$> v .: "game"
+
+instance FromJSON ChosenCards where
+    parseJSON = withObject "ChosenCards" $ \v -> ChosenCards
+        <$> v .: "cards"

src/Skat/AI/Rulebased.hs

@@ -19,11 +19,13 @@ 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) 
 import Skat.Operations
+import qualified Skat.AI.Minmax as Minmax
+import qualified Skat.AI.Stupid as Stupid (Stupid(..))
 
 data AIEnv = AIEnv { getTeam :: Team
                    , getHand :: Hand
@@ -79,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
@@ -140,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
+toPiles table (h1, h2, h3, skt) = makePiles h1 h2 h3 table skt
-    where cs1 = map (putAt Hand1) h1
-          cs2 = map (putAt Hand2) h2
-          cs3 = map (putAt Hand3) h3
-          ss  = map (putAt SkatP) skt
 
 compareGuess :: (Card, [Option]) -> (Card, [Option]) -> Ordering
 compareGuess (c1, ops1) (c2, ops2)
@@ -225,37 +223,28 @@ 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
-choose = do
+choose = chooseStatistic
-    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
+    table <- gets table
-                    0 -> 0
+    let tableNo = length table
-                    1 -> 1
+        left = 3 - tableNo
-                    -- simulate whole game
+        depth = case length handCards of
-                    2 -> 2
+            10 -> 3 + tableNo
-                    3 -> 3
+            9 -> 3 + tableNo
-                    -- simulate only partially
+            8 -> 3 + tableNo
-                    4 -> 3
+            7 -> 6 + tableNo
-                    5 -> 2
+            6 -> 9 + tableNo
-                    6 -> 2
+            5 -> 12 + tableNo
-                    7 -> 1
+            4 -> 15 + tableNo
-                    8 -> 1
+            _ -> 100
-                    9 -> 1
-                    10 -> 1
     modify $ setDepth depth
     guess__ <- gets guess
     self <- get
@@ -264,8 +253,7 @@ chooseStatistic = do
         guess = case maySkat of
             Just cs -> (cs `isSkat`) guess_
             Nothing -> guess_
-    table <- gets table
+    let ns = case tableNo of
-    let ns = case length table of
                 0 -> (0,  0,  0, 0)
                 1 -> (-1, 0, -1, 0)
                 2 -> (0,  0, -1, 0)
@@ -274,9 +262,8 @@ chooseStatistic = do
         reducedDis = simplify Hand3 realDis
         reducedDisNo = length reducedDis
         piless = map (\(d, n) -> (toPiles table d, n)) reducedDis
-        limit = if depth == 1 && length table == 2
+        limit = min 10000 $ realDisNo `div` 2
-            then 1
+    liftIO $ putStrLn $ "players hand" ++ show handCards
-            else min 10000 $ realDisNo `div` 2
     liftIO $ putStrLn $ "possible distrs without simp " ++ show realDisNo
     liftIO $ putStrLn $ "possible distrs " ++ show reducedDisNo
     vals <- M.toList <$> foldWithLimit limit runOnPiles M.empty piless
@@ -308,28 +295,27 @@ chooseOpen = do
     hand <- gets getHand
     let myCards = handCards hand piles
     possible <- filterM (P.isAllowed myCards) myCards
-    case length myCards of
+    case length possible of
         0 -> do
             liftIO $ print hand
             liftIO $ print piles
             error "no cards left to choose from"
-        1 -> return $ head myCards
+        1 -> return $ toCard $ head possible
         _ -> chooseSimulating
 
 chooseSimulating :: (MonadState AIEnv m, MonadPlayerOpen m)
                  => m Card
 chooseSimulating = do
     piles <- showPiles
-    hand <- gets getHand
+    turnCol <- turnColour
-    let myCards = handCards hand piles
+    trumpCol <- trumpColour
-    possible <- filterM (P.isAllowed myCards) myCards
+    myHand <- gets getHand
-    case possible of
+    depth <- gets simulationDepth
-        [card] -> return card
+    let ps = Players (PL $ Stupid.Stupid Team Hand1)
-        cs -> do
+                     (PL $ Stupid.Stupid Team Hand2)
-            results <- mapM simulate cs
+                     (PL $ Stupid.Stupid Single Hand3)
-            let both = zip results cs
+        env = mkSkatEnv piles turnCol trumpCol ps myHand
-                best = maximumBy (comparing fst) both
+    liftIO $ evalStateT (toCard <$> (Minmax.choose depth :: Skat (CardS Owner))) env
-            return $ snd best
 
 simulate :: (MonadState AIEnv m, MonadPlayerOpen m)
          => Card -> m Int
@@ -341,17 +327,18 @@ simulate card = do
     myTeam <- gets getTeam
     myHand <- gets getHand
     depth <- gets simulationDepth
+    liftIO $ putStrLn $ "simulate: " ++ show myHand ++ " plays " ++ show card
     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
+        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 (next myHand)) env
+        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
     -- simulated
@@ -364,15 +351,16 @@ predictValue (own, others) = do
     piles <- showPiles
     let cs = handCards hand piles
     pot <- potential cs
-    return $ own + pot
+    --return $ own + pot
+    return (own-others)
 
-potential :: (MonadState AIEnv m, MonadPlayerOpen m)
+potential :: (MonadState AIEnv m, MonadPlayerOpen m, HasCard c)
-          => [Card] -> m Int
+          => [c] -> m Int
 potential cs = do
     tr <- trumpColour
     let trs = filter (isTrump tr) cs
-        value = count cs
+        value = count . map toCard $ cs
-    positions <- filter (==0) <$> mapM position cs
+    positions <- filter (==0) <$> mapM (position . toCard) cs
     return $ length trs * 10 + value + length positions * 5
 
 position :: (MonadState AIEnv m, MonadPlayer m)
@@ -383,7 +371,7 @@ position card = do
     let effCol = effectiveColour tr card
         l = M.toList guess
         cs = filterMap ((==effCol) . effectiveColour tr . fst) fst l
-        csInd = zip [0..] cs
+        csInd = zip [0..] (reverse cs)
         Just (pos, _) = find ((== card) . snd) csInd
     return pos
 
@@ -401,8 +389,11 @@ chooseLead :: (MonadState AIEnv m, MonadPlayer m) => m Card
 chooseLead = do
     cards <- gets myHand
     possible <- filterM (P.isAllowed cards) cards
+    liftIO $ putStrLn $ "choosing lead from " ++ show possible
     pots <- mapM leadPotential possible
-    return $ snd $ maximumBy (comparing fst) (zip pots possible)
+    let ps = zip pots possible
+    liftIO $ putStrLn $ "lead potential of cards " ++ show ps
+    return $ snd $ maximumBy (comparing fst) ps
 
 mkAIEnv :: Team -> Hand -> Int -> AIEnv
 mkAIEnv tm h depth = AIEnv tm h [] [] [] newGuess depth

src/Skat/AI/Stupid.hs

@@ -3,6 +3,7 @@ module Skat.AI.Stupid where
 import Skat.Player
 import Skat.Pile
 import Skat.Card
+import Skat.Preperation
 
 data Stupid = Stupid { getTeam :: Team
                      , getHand :: Hand }
@@ -15,4 +16,18 @@ 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)
+
+newtype NoBidder = NoBidder Hand
+                   deriving Show
+
+-- | no bidding from that player
+instance Bidder NoBidder where
+    hand (NoBidder h) = h
+    askBid _ _ _ = return Nothing
+    askResponse _ _ _ = return False
+    askGame _ _ = undefined -- never called
+    askHand _ _ = return False -- never called
+    askSkat _ _ _ = undefined -- never called
+    toPlayer (NoBidder h) team = PL $ Stupid team h
+    onStart _ = return ()

src/Skat/Bidding.hs

@@ -0,0 +1,117 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Skat.Bidding (
+    biddingScore, Game(..), Modifier(..)
+) where
+
+import Data.Aeson hiding (Null)
+
+import Skat.Card
+import Data.List (sortOn)
+import Data.Ord (Down(..))
+import Control.Monad
+
+-- | different game types
+data Game = Colour Colour Modifier
+          | Grand Modifier
+          | Null
+          | NullHand
+          | NullOuvert
+          | NullOuvertHand
+            deriving (Show, Eq)
+
+instance FromJSON Game where
+    parseJSON = withObject "Game" $ \v -> do
+        gamekind <- v .: "game"
+        case (gamekind :: String) of
+            "colour" -> do
+                col <- v .: "colour"
+                mod <- v .: "modifier"
+                return $ Colour (read col) mod
+            "grand" -> do
+                mod <- v .: "modifier"
+                return $ Grand mod
+            "null" -> return Null
+            "nullhand" -> return NullHand
+            "nullouvert" -> return NullOuvert
+            "nullouverthand" -> return NullOuvertHand
+            _ -> mzero
+
+-- | modifiers for grand and colour games
+data Modifier = Einfach
+              | Schneider
+              | Schwarz
+              | Hand
+              | HandSchneider
+              | HandSchneiderAngesagt
+              | HandSchneiderSchwarz
+              | HandSchneiderAngesagtSchwarz
+              | HandSchwarzAngesagt
+              | Ouvert
+                deriving (Show, Eq)
+
+instance FromJSON Modifier where
+    parseJSON = withObject "Modifier" $ \v -> do
+        hnd <- v .: "hand"
+        if hnd then do
+            schneider <- v .:? "schneider" .!= False
+            schwarz <- v .:? "schwarz" .!= False
+            ouvert <- v .:? "ouvert" .!= False
+            case (schneider, schwarz, ouvert) of
+                (_, _, True) -> return Ouvert
+                (True, False, _) -> return HandSchneiderAngesagt
+                (_, True, _) -> return HandSchwarzAngesagt
+                _ -> return Hand
+        else return Einfach
+
+-- | calculate the value of a game with given cards
+biddingScore :: HasCard c => Game -> [c] -> Int
+biddingScore game@(Grand           mod) cards = (spitzen game cards + modifierFactor mod) * 24
+biddingScore game@(Colour Clubs    mod) cards = (spitzen game cards + modifierFactor mod) * 12
+biddingScore game@(Colour Spades   mod) cards = (spitzen game cards + modifierFactor mod) * 11
+biddingScore game@(Colour Hearts   mod) cards = (spitzen game cards + modifierFactor mod) * 10
+biddingScore game@(Colour Diamonds mod) cards = (spitzen game cards + modifierFactor mod) * 9
+biddingScore Null                       _     = 23
+biddingScore NullHand                   _     = 35
+biddingScore NullOuvert                 _     = 46
+biddingScore NullOuvertHand             _     = 59
+
+-- | calculate the modifier based on the game kind
+modifierFactor :: Modifier -> Int
+modifierFactor Einfach                      = 1
+modifierFactor Schneider                    = 2
+modifierFactor Schwarz                      = 3
+modifierFactor Hand                         = 2
+modifierFactor HandSchneider                = 3
+modifierFactor HandSchneiderAngesagt        = 4
+modifierFactor HandSchneiderSchwarz         = 4
+modifierFactor HandSchneiderAngesagtSchwarz = 5
+modifierFactor HandSchwarzAngesagt          = 6
+modifierFactor Ouvert                       = 7
+
+-- | get all available trumps for a given game
+allTrumps :: Game -> [Card]
+allTrumps (Grand _) = jacks
+allTrumps (Colour col _) = jacks ++ [Card t col | t <- [Ace,Ten .. Seven] ]
+
+jacks :: [Card]
+jacks = [ Card Jack Clubs, Card Jack Spades, Card Jack Hearts, Card Jack Diamonds ]
+
+-- | calculate the spitzen count
+spitzen :: HasCard c => Game -> [c] -> Int
+spitzen game cards
+      | null trumps = length $ allTrumps game
+      | mit = foldl (\val (a, o) -> if a == o then val + 1 else val) 0 zipped
+      | otherwise = findOhne (allTrumps game) 0
+    where trumps = getTrumps game cards
+          zipped = zip (allTrumps game) trumps
+          mit = Card Jack Clubs == head trumps
+          findOhne []     acc = acc
+          findOhne (c:cs) acc = if c /= highest then findOhne cs (acc+1) else acc
+          highest = head trumps
+
+-- | get all trumps for a given game out of a hand of cards
+getTrumps :: HasCard c => Game -> [c] -> [Card]
+getTrumps (Grand _) cards = sortOn Down $ filter ((==Jack) . getType) $ map toCard cards
+getTrumps (Colour col _) cards = sortOn Down $ filter (isTrump col) $ map toCard cards
+getTrumps _              _      = []

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)
+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
 
@@ -39,7 +46,16 @@ data Colour = Diamonds
               deriving (Eq, Ord, Show, Enum, Read)
 
 data Card = Card Type Colour
-            deriving (Eq, Show, Ord)
+            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) =
@@ -51,11 +67,8 @@ instance FromJSON Card where
         c <- v .: "colour"
         return $ Card (read t) (read c)
 
-getColour :: Card -> Colour
+getID :: HasCard c => c -> Int
-getColour (Card _ c) = c
+getID card = let t = getType $ toCard card in case t of
-
-getID :: Card -> Int
-getID (Card t _) = 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
+instance Foldable t => Countable (t Card) Int where
-    count = sum . map count
+    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 :: HasCard c => Colour -> c -> Bool
-isTrump trumpCol (Card tp col)
+isTrump trumpCol crd
-    | tp == Jack = True
+    | getType (toCard crd) == Jack = True
-    | otherwise = col == trumpCol
+    | otherwise = getColour (toCard crd) == trumpCol
 
-effectiveColour :: Colour -> Card -> Colour
+effectiveColour :: HasCard c => Colour -> c -> Colour
-effectiveColour trumpCol card@(Card _ col) =
+effectiveColour trumpCol crd = if trump then trumpCol else getColour (toCard crd)
-    if trump then trumpCol else col
+  where trump = isTrump trumpCol crd
-  where trump = isTrump trumpCol card
 
-isAllowed :: Colour -> Maybe Colour -> [Card] -> Card -> Bool
+isAllowed :: (Foldable t, HasCard c1, HasCard c2) => Colour -> Maybe Colour -> t c1 -> c2 -> Bool
-isAllowed trumpCol turnCol cs card =
+isAllowed trumpCol turnCol cs crd =
     if col `equals` turnCol
         then True
-        else not $ any (\ca -> effectiveColour trumpCol ca `equals` turnCol && ca /= card) cs
+        else not $ F.any (\ca -> effectiveColour trumpCol ca `equals` turnCol && toCard ca /= toCard crd) cs
-  where col = effectiveColour trumpCol card
+  where col = effectiveColour trumpCol (toCard crd)
 
 compareCards :: Colour
              -> Maybe Colour
@@ -112,17 +135,22 @@ 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 :: HasCard c => Colour -> Maybe Colour -> [c] -> [c]
-sortCards trumpCol turnCol cs = sortBy (compareCards trumpCol turnCol) cs
+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 :: HasCard c => Colour -> Maybe Colour -> [c] -> c
-highestCard trumpCol turnCol cs = maximumBy (compareCards trumpCol turnCol) cs
+highestCard trumpCol turnCol cs = maximumBy f cs
+    where f c1 c2 = compareCards trumpCol turnCol (toCard c1) (toCard c2)
 
 shuffleCards :: IO [Card]
 shuffleCards = do
     gen <- newStdGen
     return $ shuffle gen allCards
 
+shuffleCardsWithGen :: StdGen -> [Card]
+shuffleCardsWithGen gen = shuffle gen allCards
+
 -- TESTING VARS
 
 c1 :: Card

src/Skat/Matches.hs

@@ -0,0 +1,86 @@
+module Skat.Matches (
+    singleVsBots, pvp, pvpWithBidding, singleWithBidding
+) where
+
+import Control.Monad.State
+import Control.Monad.Reader
+import System.Random (mkStdGen)
+
+import Skat
+import Skat.Operations
+import Skat.Player
+import Skat.Pile
+import Skat.Card
+import Skat.Preperation
+
+import Skat.AI.Rulebased
+import Skat.AI.Online
+import Skat.AI.Stupid
+
+-- | predefined card distribution for testing purposes
+cardDistr :: Piles
+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]
+          hand1 = [Card Jack Spades, Card Jack Hearts, Card Ten Spades, Card Ace Hearts, Card Ten Hearts,
+                   Card Nine Hearts, Card Seven Clubs, Card Ace Clubs, Card King Diamonds,
+                   Card Ten Diamonds]
+          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]
+          skt = [Card Nine Clubs, Card Queen Clubs]
+
+singleVsBots :: Communicator c => c -> IO ()
+singleVsBots comm = do
+    cards <- shuffleCards
+    let ps = Players
+                (PL $ OnlineEnv Team Hand1 comm)
+                (PL $ Stupid Team Hand2)
+                (PL $ mkAIEnv Single Hand3 10)
+        env = SkatEnv (distribute cards) Nothing Spades ps Hand1
+    liftIO $ evalStateT (publishGameStart >> turn >>= publishGameResults) env
+
+singleWithBidding :: Communicator c => c -> IO ()
+singleWithBidding comm = do
+    cards <- shuffleCards
+    let ps = distribute cards
+        h1 = map toCard $ handCards Hand1 ps
+        bs = Bidders
+                (BD $ PrepOnline Hand1 comm h1)
+                (BD $ NoBidder Hand2)
+                (BD $ NoBidder Hand3)
+        env = PrepEnv ps bs
+    maySkatEnv <- liftIO $ runReaderT runPreperation env
+    case maySkatEnv of
+        Just skatEnv ->
+            liftIO $ evalStateT (publishGameStart >> turn >>= publishGameResults) skatEnv
+        Nothing -> putStrLn "No one wanted to play."
+
+pvp :: Communicator c => c -> c -> c -> IO ()
+pvp comm1 comm2 comm3 = do
+    cards <- shuffleCards
+    let ps = Players
+                (PL $ OnlineEnv Team Hand1 comm1)
+                (PL $ OnlineEnv Team Hand2 comm2)
+                (PL $ OnlineEnv Team Hand3 comm3)
+        env = SkatEnv (distribute cards) Nothing Spades ps Hand1
+    liftIO $ evalStateT (publishGameStart >> turn >>= publishGameResults) env
+
+pvpWithBidding :: Communicator c => c -> c -> c -> IO ()
+pvpWithBidding comm1 comm2 comm3 = do
+    cards <- shuffleCards
+    let ps = distribute cards
+        h1 = map toCard $ handCards Hand1 ps
+        h2 = map toCard $ handCards Hand2 ps
+        h3 = map toCard $ handCards Hand3 ps
+        bs = Bidders
+                (BD $ PrepOnline Hand1 comm1 $ h1)
+                (BD $ PrepOnline Hand2 comm2 $ h2)
+                (BD $ PrepOnline Hand3 comm3 $ h3)
+        env = PrepEnv ps bs
+    maySkatEnv <- liftIO $ runReaderT runPreperation env
+    case maySkatEnv of
+        Just skatEnv ->
+            liftIO $ evalStateT (publishGameStart >> turn >>= publishGameResults) skatEnv
+        Nothing -> putStrLn "No one wanted to play."

src/Skat/Operations.hs

@@ -1,15 +1,19 @@
-module Skat.Operations where
+module Skat.Operations (
+    turn, turnGeneric, play, playOpen, publishGameResults,
+    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
 import Skat.Pile
 import Skat.Player (chooseCard, Players(..), Player(..), PL(..),
-    updatePlayer, playersToList, player, MonadPlayer)
+    updatePlayer, playersToList, player, MonadPlayer, getSinglePlayer)
 import Skat.Utils (shuffle)
 
 compareRender :: Card -> Card -> Ordering
@@ -20,32 +24,51 @@ compareRender (Card t1 c1) (Card t2 c2) = case compare c1 c2 of
 sortRender :: [Card] -> [Card]
 sortRender = sortBy compareRender
 
+play_ :: HasCard c => c -> Skat ()
+play_ card = do
+    hand <- gets currentHand
+    trCol <- gets trumpColour
+    modifyp $ playCard hand card
+    table <- getp tableCards
+    case length table of
+        1 -> do modify (setCurrentHand $ next hand)
+                modify $ setTurnColour (Just $ effectiveColour trCol $ head table)
+        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
-            -> Hand
             -> Skat (Int, Int)
-turnGeneric playFunc depth n = do
+turnGeneric playFunc depth = do
+    n <- gets currentHand
     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 >> turnGeneric playFunc depth (next n)
+        0 -> playFunc p >> modify (setCurrentHand $ next n) >> turnGeneric playFunc depth
         1 -> do
             modify $ setTurnColour
                 (Just $ effectiveColour trCol $ head table)
             playFunc p
-            turnGeneric playFunc depth (next n)
+            modify (setCurrentHand $ next n)
-        2 -> playFunc p >> turnGeneric playFunc depth (next n)
+            turnGeneric playFunc depth
+        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 turnGeneric playFunc (depth - 1) w
+                else modify (setCurrentHand w) >> turnGeneric playFunc (depth - 1)
 
-turn :: Hand -> Skat (Int, Int)
+turn :: Skat (Int, Int)
-turn n = turnGeneric play 10 n
+turn = turnGeneric play 10
 
 evaluateTable :: Skat Hand
 evaluateTable = do
@@ -53,9 +76,8 @@ evaluateTable = do
     turnCol <- gets turnColour
     table <- getp tableCards
     ps <- gets players
-    let winningCard = highestCard trumpCol turnCol table
+    let winnerHand = uorigin $ getPile $ highestCard trumpCol turnCol table
-    Just winnerHand <- getp $ originOfCard winningCard
+        winner = player ps winnerHand
-    let winner = player ps winnerHand
     modifyp $ cleanTable (team winner)
     modify $ setTurnColour Nothing
     return $ hand winner
@@ -65,24 +87,34 @@ countGame = getp count
 
 play :: (Show p, Player p) => p -> Skat Card
 play p = do
-    liftIO $ putStrLn "playing"
+    table <- getp tableCards
-    table <- getp tableCardsS
     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 ()
+publishGameResults res = do
+    pls <- gets players
+    mapM_ (\p -> onGameResults p res) (playersToList pls)
+
+publishGameStart :: Skat ()
+publishGameStart = do
+    pls <- gets players
+    let sglPlayer = getSinglePlayer pls
+    mapM_ (\p -> onGameStart p sglPlayer) (playersToList pls)

src/Skat/Pile.hs

@@ -1,32 +1,52 @@
 {-# 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
+toInt Hand2 = 2
+toInt Hand3 = 3
 
 next :: Hand -> Hand
 next Hand1 = Hand2
@@ -38,76 +58,126 @@ prev Hand1 = Hand3
 prev Hand2 = Hand1
 prev Hand3 = Hand2
 
-data Played = Table Hand
+data Owner = P Hand | S
-            | Won Hand Team
+             deriving (Show, Eq, Ord, Read)
-              deriving (Show, Eq, Ord)
 
-instance ToJSON Played where
+instance ToJSON Owner where
-    toJSON (Table hand) =
+    toJSON (P hand) = object ["owner" .= show hand]
-        object ["state" .= ("table" :: String), "played_by" .= show hand]
+    toJSON S        = object ["owner" .= ("skat" :: String) ]
-    toJSON (Won hand team) =
-        object ["state" .= ("won" :: String), "played_by" .= show hand, "won_by" .= show team]
 
-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]
+toTable :: Hand -> Card -> Piles -> Piles
-                   , played :: [CardS Played]
+toTable hand card ps = ps { _table = (CardS card (P hand)) : _table ps }
-                   , skat :: [CardS SkatP] }
-             deriving (Show, Eq, Ord)
 
 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
+played :: Piles -> [CardS Owner]
-origin (CardS _ (Table hand)) = hand
+played ps = _wonSingle ps ++ _wonTeam ps ++ _table ps
-origin (CardS _ (Won hand _)) = hand
 
-originOfCard :: Card -> Piles -> Maybe Hand
+origin :: Owner -> Maybe Hand
-originOfCard card (Piles _ pld _) = origin <$> find ((==card) . getCard) pld
+origin (P hand)   = Just hand
+origin S          = Nothing
 
-playCard :: Card -> Piles -> Piles
+uorigin :: Owner -> Hand
-playCard card (Piles hs pld skt) = Piles hs' (ca : pld) skt
+uorigin owner = case origin owner of
-    where (CardS _ hand, hs') = remove ((==card) . getCard) hs
+    Just hand -> hand
-          ca = CardS card (Table hand)
+    Nothing   -> error "has no origin"
 
-winCard :: Team -> CardS Played -> CardS Played
+removeFromHand :: Hand -> Card -> Piles -> Piles
-winCard team (CardS card (Table hand)) = CardS card (Won hand team)
+removeFromHand Hand1 card ps = ps { _hand1 = delete (CardS card (P Hand1)) (_hand1 ps) }
-winCard team c                         = c
+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]
+addToHand :: Hand -> Card -> Piles -> Piles
-wonCards team (Piles _ pld _) = filterMap (f . getPile) getCard pld
+addToHand Hand1 card ps = ps { _hand1 = (CardS card (P Hand1)) : (_hand1 ps) }
-    where f (Won _ tm) = tm == team
+addToHand Hand2 card ps = ps { _hand2 = (CardS card (P Hand2)) : (_hand2 ps) }
-          f _          = False
+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'
+
+moveToSkat :: HasCard c => Hand -> [c] -> Piles -> Maybe Piles
+moveToSkat hand cards' piles
+      | length cards' == 2 && all (`elem` possible) cards =
+            Just $ updated { _skat = newSkat }
+      | otherwise = Nothing
+    where cards = map toCard cards'
+          oldSkat = skatCards piles
+          noLongerSkat = filter (not . (`elem` cards)) oldSkat
+          possible = map toCard (handCards hand piles) ++ oldSkat
+          newSkat = map (putAt S) cards
+          removed = foldr (\card ps -> removeFromHand hand card ps) piles cards
+          updated = foldr (\card ps -> addToHand hand card ps) removed noLongerSkat
+
+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
+cleanTable Team ps = ps { _table = [], _wonTeam = _table ps ++ _wonTeam ps }
-    where table = tableCards ps
+cleanTable Single ps = ps { _table = [], _wonSingle = _table ps ++ _wonSingle ps }
-          pld' = map (winCard winner) pld
 
-tableCards :: Piles -> [Card]
+tableCards :: Piles -> [CardS Owner]
-tableCards (Piles _ pld _) = filterMap (f . getPile) getCard pld
+tableCards = _table
-    where f (Table _) = True
-          f _         = False
 
-tableCardsS :: Piles -> [CardS Played]
+handEmpty :: Hand -> Piles -> Bool
-tableCardsS (Piles _ pld _) = filter (f . getPile) pld
+handEmpty Hand1 = null . _hand1
-    where f (Table _) = True
+handEmpty Hand2 = null . _hand2
-          f _         = False
+handEmpty Hand3 = null . _hand3
 
-handCards :: Hand -> Piles -> [Card]
+handCards :: Hand -> Piles -> [CardS Owner]
-handCards hand (Piles hs _ _) = filterMap ((==hand) . getPile) getCard hs
+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)
@@ -115,6 +185,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,15 +34,20 @@ 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)
                   -> m ()
     onGameResults _ _ = return ()
+    onGameStart :: MonadPlayer m
+                => p
+                -> Hand
+                -> m ()
+    onGameStart _ _ = return ()
 
 data PL = forall p. (Show p, Player p) => PL p
 
@@ -60,6 +65,7 @@ instance Player PL where
         return $ PL v
     chooseCardOpen (PL p) = chooseCardOpen p
     onGameResults (PL p) res = onGameResults p res
+    onGameStart (PL p) singlePlayer = onGameStart p singlePlayer
 
 data Players = Players PL PL PL
                deriving Show
@@ -77,3 +83,9 @@ updatePlayer p (Players p1 p2 p3) = case hand p of
 
 playersToList :: Players -> [PL]
 playersToList (Players p1 p2 p3) = [p1, p2, p3]
+
+getSinglePlayer :: Players -> Hand
+getSinglePlayer (Players p1 p2 p3) = case (team p1, team p2, team p3) of
+    (Single, _, _) -> Hand1
+    (_, Single, _) -> Hand2
+    _              -> Hand3

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/Preperation.hs

@@ -0,0 +1,108 @@
+{-# LANGUAGE ExistentialQuantification #-}
+
+module Skat.Preperation (
+    Bidder(..), Bid, BD(..), Bidders(..), PrepEnv(..), runPreperation
+) where
+
+import Control.Monad.IO.Class
+import Control.Monad.Reader
+
+import Skat.Pile
+import Skat.Card
+import Skat.Player (PL, Players(..))
+import Skat.Bidding
+import Skat (SkatEnv, mkSkatEnv)
+
+type Bid = Int
+
+data PrepEnv = PrepEnv { piles :: Piles
+                       , bidders :: Bidders }
+               deriving Show
+
+type Preperation = ReaderT PrepEnv IO
+
+class Bidder a where
+    hand :: a -> Hand
+    onStart :: MonadIO m => a -> m ()
+    askBid :: MonadIO m => a -> Hand -> Bid -> m (Maybe Bid)
+    askResponse :: MonadIO m => a -> Hand -> Bid -> m Bool
+    askGame :: MonadIO m => a -> Bid -> m Game
+    askHand :: MonadIO m => a -> Bid -> m Bool
+    askSkat :: MonadIO m => a -> Bid -> [Card] -> m [Card]
+    toPlayer :: a -> Team -> PL
+
+-- | trick to allow heterogenous bidder list
+data BD = forall b. (Show b, Bidder b) => BD b
+
+instance Show BD where
+    show (BD b) = show b
+
+instance Bidder BD where
+    hand (BD b) = hand b
+    askBid (BD b) = askBid b
+    askGame (BD b) = askGame b
+    askHand (BD b) = askHand b
+    askSkat (BD b) = askSkat b
+    askResponse (BD b) = askResponse b
+    toPlayer (BD b) = toPlayer b
+    onStart (BD b) = onStart b
+
+data Bidders = Bidders BD BD BD
+               deriving Show
+
+bidder :: Bidders -> Hand -> BD
+bidder (Bidders b _ _) Hand1 = b
+bidder (Bidders _ b _) Hand2 = b
+bidder (Bidders _ _ b) Hand3 = b
+
+toPlayers :: Hand -> Bidders -> Players
+toPlayers single (Bidders b1 b2 b3) =
+    Players (toPlayer b1 $ if single == Hand1 then Single else Team)
+            (toPlayer b2 $ if single == Hand2 then Single else Team)
+            (toPlayer b3 $ if single == Hand3 then Single else Team)
+
+runPreperation :: Preperation (Maybe SkatEnv)
+runPreperation = do
+    bds <- asks bidders
+    onStart (bidder bds Hand1)
+    onStart (bidder bds Hand2)
+    onStart (bidder bds Hand3)
+    (winner, bid) <- runBidding 0 (bidder bds Hand2) (bidder bds Hand1)
+    (finalWinner, finalBid) <- runBidding 0 (bidder bds Hand3) (bidder bds winner)
+    if finalBid == 0 then do
+        bid <- askBid (bidder bds finalWinner) finalWinner 0
+        case bid of
+            Just val -> Just <$> initGame finalWinner val
+            Nothing -> return Nothing
+        else Just <$> initGame finalWinner finalBid
+
+runBidding :: Bid -> BD -> BD -> Preperation (Hand, Bid)
+runBidding startingBid reizer gereizter = do
+    first <- askBid reizer (hand gereizter) startingBid
+    case first of
+        Just val -> do
+            response <- askResponse gereizter (hand reizer) val
+            if response then runBidding val reizer gereizter
+            else return (hand reizer, val)
+        Nothing -> return (hand gereizter, startingBid)
+
+initGame :: Hand -> Bid -> Preperation SkatEnv
+initGame single bid = do
+    ps <- asks piles
+    bds <- asks bidders
+    -- ask if player wants to play hand
+    noSkat <- askHand (bidder bds single) bid
+    -- either return piles or ask for skat cards and modify piles
+    ps' <- if noSkat then return ps else handleSkat (bidder bds single) bid ps
+    -- ask for game kind
+    (Colour col _) <- askGame (bidder bds single) bid
+    -- construct skat env
+    return $ mkSkatEnv ps Nothing col (toPlayers single bds) Hand1
+
+handleSkat :: BD -> Bid -> Piles -> Preperation Piles
+handleSkat bd bid ps = do
+    let skat = skatCards ps
+    skat' <- askSkat bd bid skat
+    case moveToSkat (hand bd) skat' ps of
+        Just correct -> return correct
+        Nothing -> handleSkat bd bid ps

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 :: HasCard c => [c] -> IO ()
-render = putStrLn . intercalate "\n" . zipWith (\n c -> show n ++ ") " ++ show c) [0..]
+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 []