christian
/
skat
1
0
Fork 0
Code Issues 0 Pull Requests 0 Releases 0 Wiki Activity
Browse Source

some optimizations

master
flavis 6 years ago
parent
5846a22d8a
commit
672746e302
18 changed files with 340 additions and 195 deletions
Split View
Diff Options
Show Stats Download Patch File Download Diff File
  1. +12
    -15
      app/Main.hs
  2. +31
    -0
      app/TestEnvs.hs
  3. +3
    -0
      package.yaml
  4. +7
    -2
      skat.cabal
  5. +3
    -5
      src/Skat.hs
  6. +1
    -1
      src/Skat/AI/Human.hs
  7. +61
    -41
      src/Skat/AI/Minmax.hs
  8. +6
    -4
      src/Skat/AI/Online.hs
  9. +28
    -20
      src/Skat/AI/Rulebased.hs
  10. +1
    -1
      src/Skat/AI/Stupid.hs
  11. +48
    -23
      src/Skat/Card.hs
  12. +1
    -4
      src/Skat/Matches.hs
  13. +21
    -15
      src/Skat/Operations.hs
  14. +103
    -55
      src/Skat/Pile.hs
  15. +4
    -4
      src/Skat/Player.hs
  16. +2
    -2
      src/Skat/Player/Utils.hs
  17. +6
    -2
      src/Skat/Render.hs
  18. +2
    -1
      src/Skat/Utils.hs

+ 12
- 15
app/Main.hs View File

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

+ 31
- 0
app/TestEnvs.hs View File

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

+ 3
- 0
package.yaml View File

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

+ 7
- 2
skat.cabal View File

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

+ 3
- 5
src/Skat.hs View File

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

+ 1
- 1
src/Skat/AI/Human.hs View File

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


+ 61
- 41
src/Skat/AI/Minmax.hs View File

@@ -10,18 +10,20 @@ module Skat.AI.Minmax (
) where

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

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

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

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

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

instance MonadGame S.Card Int S.PL S.Skat where
instance MonadGame (S.CardS S.Owner) [] Int S.PL S.Skat where
currentPlayer = do
hand <- gets S.currentHand
pls <- gets S.players
return $ S.player pls hand
return $! S.player pls hand
turns = S.allowedCards
--player <- currentPlayer
--trCol <- gets S.trumpColour
--return $! if maxing player
-- then sortBy (optimalTeam trCol) cards
-- else sortBy (optimalSingle trCol) cards
play = S.play_
simulate card action = do
--oldCurrent <- gets S.currentHand
--oldTurnCol <- gets S.turnColour
backup <- get
play card
--oldWinner <- currentPlayer
res <- action
--S.undo_ card oldCurrent oldTurnCol (S.team oldWinner)
put backup
return res
over = ((==0) . length) <$> S.allowedCards
return $! res
over = ((==0) . length) <$!> S.allowedCards
evaluate = do
player <- currentPlayer
piles <- gets S.piles
let (sgl, tm) = S.count piles
return $ (if maxing player then tm - sgl else sgl - tm)
return $! (if maxing player then tm - sgl else sgl - tm)

potentialByType :: S.Type -> Int
potentialByType S.Ace = 11
potentialByType S.Jack = 10
potentialByType S.Ten = 4
potentialByType S.Seven = 7
potentialByType S.Eight = 7
potentialByType S.Nine = 7
potentialByType S.Queen = 5
potentialByType S.King = 5

optimalSingle :: S.Colour -> S.Card -> S.Card -> Ordering
optimalSingle trCol (S.Card t1 _) (S.Card t2 _) = (comparing potentialByType) t2 t1

optimalTeam :: S.Colour -> S.Card -> S.Card -> Ordering
optimalTeam trCol (S.Card t1 _) (S.Card t2 _) = (comparing potentialByType) t2 t1

-- TIC TAC TOE implementation

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

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

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

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

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

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

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

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


+ 6
- 4
src/Skat/AI/Online.hs View File

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


+ 28
- 20
src/Skat/AI/Rulebased.hs View File

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


+ 1
- 1
src/Skat/AI/Stupid.hs View File

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

+ 48
- 23
src/Skat/Card.hs View File

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


+ 1
- 4
src/Skat/Matches.hs View File

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


+ 21
- 15
src/Skat/Operations.hs View File

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


+ 103
- 55
src/Skat/Pile.hs View File

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

+ 4
- 4
src/Skat/Player.hs View File

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


+ 2
- 2
src/Skat/Player/Utils.hs View File

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


+ 6
- 2
src/Skat/Render.hs View File

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

+ 2
- 1
src/Skat/Utils.hs View File

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


Write Preview
Loading…
Cancel
Save