introduce stack build system and restructure code
This commit is contained in:
+49
@@ -0,0 +1,49 @@
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
|
||||
module Skat where
|
||||
|
||||
import Control.Monad.State
|
||||
import Control.Monad.Reader
|
||||
import Data.List
|
||||
|
||||
import Skat.Card
|
||||
import Skat.Pile
|
||||
import Skat.Player (Players)
|
||||
import qualified Skat.Player as P
|
||||
|
||||
data SkatEnv = SkatEnv { piles :: Piles
|
||||
, turnColour :: Maybe Colour
|
||||
, trumpColour :: Colour
|
||||
, players :: Players }
|
||||
deriving Show
|
||||
|
||||
type Skat = StateT SkatEnv IO
|
||||
|
||||
instance P.MonadPlayer Skat where
|
||||
trumpColour = gets trumpColour
|
||||
turnColour = gets turnColour
|
||||
showSkat p = case P.team p of
|
||||
Single -> fmap (Just . skatCards) $ gets piles
|
||||
Team -> return Nothing
|
||||
|
||||
instance P.MonadPlayerOpen Skat where
|
||||
showPiles = gets piles
|
||||
|
||||
modifyp :: (Piles -> Piles) -> Skat ()
|
||||
modifyp f = modify g
|
||||
where g env@(SkatEnv {piles}) = env { piles = f piles}
|
||||
|
||||
getp :: (Piles -> a) -> Skat a
|
||||
getp f = gets piles >>= return . f
|
||||
|
||||
modifyPlayers :: (Players -> Players) -> Skat ()
|
||||
modifyPlayers f = modify g
|
||||
where g env@(SkatEnv {players}) = env { players = f players }
|
||||
|
||||
setTurnColour :: Maybe Colour -> SkatEnv -> SkatEnv
|
||||
setTurnColour col sk = sk { turnColour = col }
|
||||
|
||||
mkSkatEnv :: Piles -> Maybe Colour -> Colour -> Players -> SkatEnv
|
||||
mkSkatEnv = SkatEnv
|
||||
@@ -0,0 +1,37 @@
|
||||
module Skat.AI.Human where
|
||||
|
||||
import Control.Monad.Trans (liftIO)
|
||||
|
||||
import Skat.Player
|
||||
import Skat.Pile
|
||||
import Skat.Card
|
||||
import Skat.Utils
|
||||
import Skat.Render
|
||||
|
||||
data Human = Human { getTeam :: Team
|
||||
, getHand :: Hand }
|
||||
deriving Show
|
||||
|
||||
instance Player Human where
|
||||
team = getTeam
|
||||
hand = getHand
|
||||
chooseCard p table _ hand = do
|
||||
trumpCol <- trumpColour
|
||||
turnCol <- turnColour
|
||||
let possible = filter (isAllowed trumpCol turnCol hand) hand
|
||||
c <- liftIO $ askIO (map getCard table) possible hand
|
||||
return $ (c, p)
|
||||
|
||||
askIO :: [Card] -> [Card] -> [Card] -> IO Card
|
||||
askIO table possible hand = do
|
||||
putStrLn "Your hand"
|
||||
render hand
|
||||
putStrLn "These options are possible"
|
||||
render possible
|
||||
putStrLn "These cards are on the table"
|
||||
render table
|
||||
idx <- query
|
||||
"Which card do you want to play? Give the index of the card"
|
||||
if idx >= 0 && idx < length possible
|
||||
then return $ possible !! idx
|
||||
else askIO table possible hand
|
||||
@@ -0,0 +1,87 @@
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Skat.AI.Online where
|
||||
|
||||
import Control.Monad.Reader
|
||||
import Network.WebSockets (Connection, sendTextData, receiveData)
|
||||
import Data.Aeson
|
||||
import qualified Data.ByteString.Lazy.Char8 as BS
|
||||
|
||||
import Skat.Player
|
||||
import qualified Skat.Player.Utils as P
|
||||
import Skat.Pile
|
||||
import Skat.Card
|
||||
import Skat.Render
|
||||
|
||||
class Monad m => MonadClient m where
|
||||
query :: String -> m ()
|
||||
response :: m String
|
||||
|
||||
data OnlineEnv = OnlineEnv { getTeam :: Team
|
||||
, getHand :: Hand
|
||||
, connection :: Connection }
|
||||
deriving Show
|
||||
|
||||
instance Show Connection where
|
||||
show _ = "A connection"
|
||||
|
||||
instance Player OnlineEnv 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
|
||||
|
||||
type Online m = ReaderT OnlineEnv m
|
||||
|
||||
instance MonadIO m => MonadClient (Online m) where
|
||||
query s = do
|
||||
conn <- asks connection
|
||||
liftIO $ sendTextData conn (BS.pack s)
|
||||
response = do
|
||||
conn <- asks connection
|
||||
liftIO $ BS.unpack <$> receiveData conn
|
||||
|
||||
instance MonadPlayer m => MonadPlayer (Online m) where
|
||||
trumpColour = lift $ trumpColour
|
||||
turnColour = lift $ turnColour
|
||||
showSkat = lift . showSkat
|
||||
|
||||
choose :: MonadPlayer m => [CardS Played] -> [Card] -> Online m Card
|
||||
choose table hand = do
|
||||
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
|
||||
|
||||
cardPlayed :: MonadPlayer m => CardS Played -> Online m ()
|
||||
cardPlayed card = query (BS.unpack $ encode $ CardPlayedQuery card)
|
||||
|
||||
onResults :: MonadIO m => (Int, Int) -> Online m ()
|
||||
onResults (sgl, tm) = query (BS.unpack $ encode $ GameResultsQuery sgl tm)
|
||||
|
||||
data ChooseQuery = ChooseQuery [Card] [CardS Played]
|
||||
data CardPlayedQuery = CardPlayedQuery (CardS Played)
|
||||
data GameResultsQuery = GameResultsQuery Int Int
|
||||
data ChosenResponse = ChosenResponse Card
|
||||
|
||||
instance ToJSON ChooseQuery 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]
|
||||
|
||||
instance FromJSON ChosenResponse where
|
||||
parseJSON = withObject "ChosenResponse" $ \v -> ChosenResponse
|
||||
<$> v .: "card"
|
||||
@@ -0,0 +1,433 @@
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
|
||||
module Skat.AI.Rulebased (
|
||||
mkAIEnv, testds, simplify
|
||||
) where
|
||||
|
||||
import Control.Parallel.Strategies
|
||||
|
||||
import Data.Ord
|
||||
import Data.Monoid ((<>))
|
||||
import Data.List
|
||||
import qualified Data.Set as S
|
||||
import Control.Monad.State
|
||||
import Control.Monad.Reader
|
||||
import qualified Data.Map.Strict as M
|
||||
|
||||
import Skat.Player
|
||||
import qualified Skat.Player.Utils as P
|
||||
import Skat.Pile
|
||||
import Skat.Card
|
||||
import Skat.Utils
|
||||
import Skat (Skat, modifyp, mkSkatEnv)
|
||||
import Skat.Operations
|
||||
|
||||
data AIEnv = AIEnv { getTeam :: Team
|
||||
, getHand :: Hand
|
||||
, table :: [CardS Played]
|
||||
, fallen :: [CardS Played]
|
||||
, myHand :: [Card]
|
||||
, guess :: Guess
|
||||
, simulationDepth :: Int }
|
||||
deriving Show
|
||||
|
||||
setTable :: [CardS Played] -> AIEnv -> AIEnv
|
||||
setTable tab env = env { table = tab }
|
||||
|
||||
setHand :: [Card] -> AIEnv -> AIEnv
|
||||
setHand hand env = env { myHand = hand }
|
||||
|
||||
setFallen :: [CardS Played] -> AIEnv -> AIEnv
|
||||
setFallen fallen env = env { fallen = fallen }
|
||||
|
||||
setDepth :: Int -> AIEnv -> AIEnv
|
||||
setDepth depth env = env { simulationDepth = depth }
|
||||
|
||||
modifyg :: MonadPlayer m => (Guess -> Guess) -> AI m ()
|
||||
modifyg f = modify g
|
||||
where g env@(AIEnv {guess}) = env { guess = f guess }
|
||||
|
||||
type AI m = StateT AIEnv m
|
||||
|
||||
instance MonadPlayer m => MonadPlayer (AI m) where
|
||||
trumpColour = lift $ trumpColour
|
||||
turnColour = lift $ turnColour
|
||||
showSkat = lift . showSkat
|
||||
|
||||
instance MonadPlayerOpen m => MonadPlayerOpen (AI m) where
|
||||
showPiles = lift $ showPiles
|
||||
|
||||
type Simulator m = ReaderT Piles (AI m)
|
||||
|
||||
instance MonadPlayer m => MonadPlayer (Simulator m) where
|
||||
trumpColour = lift $ trumpColour
|
||||
turnColour = lift $ turnColour
|
||||
showSkat = lift . showSkat
|
||||
|
||||
instance MonadPlayer m => MonadPlayerOpen (Simulator m) where
|
||||
showPiles = ask
|
||||
|
||||
runWithPiles :: MonadPlayer m
|
||||
=> Piles -> Simulator m a -> AI m a
|
||||
runWithPiles ps sim = runReaderT sim ps
|
||||
|
||||
instance Player AIEnv where
|
||||
team = getTeam
|
||||
hand = getHand
|
||||
chooseCard p table fallen hand = runStateT (do
|
||||
modify $ setTable table
|
||||
modify $ setHand hand
|
||||
modify $ setFallen fallen
|
||||
choose) p
|
||||
onCardPlayed p card = execStateT (do
|
||||
onPlayed card) p
|
||||
chooseCardOpen p = evalStateT chooseOpen p
|
||||
|
||||
value :: Card -> Int
|
||||
value (Card Ace _) = 100
|
||||
value _ = 0
|
||||
|
||||
data Option = H Hand
|
||||
| Skt
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
-- | possible card distributions
|
||||
type Guess = M.Map Card [Option]
|
||||
|
||||
newGuess :: Guess
|
||||
newGuess = M.fromList l
|
||||
where l = map (\c -> (c, [H Hand1, H Hand2, H Hand3, Skt])) allCards
|
||||
|
||||
hasBeenPlayed :: Card -> Guess -> Guess
|
||||
hasBeenPlayed card = M.delete card
|
||||
|
||||
has :: Hand -> [Card] -> Guess -> Guess
|
||||
has hand cs = M.mapWithKey f
|
||||
where f card hands
|
||||
| card `elem` cs = [H hand]
|
||||
| otherwise = hands
|
||||
|
||||
hasNoLonger :: MonadPlayer m => Hand -> Colour -> AI m ()
|
||||
hasNoLonger hand colour = do
|
||||
trCol <- trumpColour
|
||||
modifyg $ hasNoLonger_ trCol hand colour
|
||||
|
||||
hasNoLonger_ :: Colour -> Hand -> Colour -> Guess -> Guess
|
||||
hasNoLonger_ trColour hand effCol = M.mapWithKey f
|
||||
where f card hands
|
||||
| effectiveColour trColour card == effCol && (H hand) `elem` hands = filter (/=H hand) hands
|
||||
| otherwise = hands
|
||||
|
||||
isSkat :: [Card] -> Guess -> Guess
|
||||
isSkat cs = M.mapWithKey f
|
||||
where f card hands
|
||||
| card `elem` cs = [Skt]
|
||||
| otherwise = hands
|
||||
|
||||
type Turn = (CardS Played, CardS Played, CardS Played)
|
||||
|
||||
analyzeTurn :: MonadPlayer m => Turn -> AI m ()
|
||||
analyzeTurn (c1, c2, c3) = do
|
||||
modifyg (getCard c1 `hasBeenPlayed`)
|
||||
modifyg (getCard c2 `hasBeenPlayed`)
|
||||
modifyg (getCard c3 `hasBeenPlayed`)
|
||||
trCol <- trumpColour
|
||||
let turnCol = getColour $ getCard c1
|
||||
demanded = effectiveColour trCol (getCard c1)
|
||||
col2 = effectiveColour trCol (getCard c2)
|
||||
col3 = effectiveColour trCol (getCard c3)
|
||||
if col2 /= demanded
|
||||
then origin c2 `hasNoLonger` demanded
|
||||
else return ()
|
||||
if col3 /= demanded
|
||||
then origin c3 `hasNoLonger` demanded
|
||||
else return ()
|
||||
|
||||
type Distribution = ([Card], [Card], [Card], [Card])
|
||||
|
||||
toPiles :: [CardS Played] -> Distribution -> Piles
|
||||
toPiles table (h1, h2, h3, skt) = Piles (cs1 ++ cs2 ++ cs3) table ss
|
||||
where cs1 = map (putAt Hand1) h1
|
||||
cs2 = map (putAt Hand2) h2
|
||||
cs3 = map (putAt Hand3) h3
|
||||
ss = map (putAt SkatP) skt
|
||||
|
||||
compareGuess :: (Card, [Option]) -> (Card, [Option]) -> Ordering
|
||||
compareGuess (c1, ops1) (c2, ops2)
|
||||
| length ops1 == 1 = LT
|
||||
| length ops2 == 1 = GT
|
||||
| c1 > c2 = LT
|
||||
| c1 < c2 = GT
|
||||
|
||||
distributions :: Guess -> (Int, Int, Int, Int) -> [Distribution]
|
||||
distributions guess nos =
|
||||
helper (sortBy compareGuess $ M.toList guess) nos
|
||||
`using` parList rdeepseq
|
||||
where helper [] _ = []
|
||||
helper ((c, hs):[]) ns = map fst (distr c hs ns)
|
||||
helper ((c, hs):gs) ns =
|
||||
let dsWithNs = distr c hs ns
|
||||
go (d, ns') = map (d <>) (helper gs ns')
|
||||
in concatMap go dsWithNs
|
||||
distr card hands (n1, n2, n3, n4) =
|
||||
let f card (H Hand1) =
|
||||
(([card], [], [], []), (n1+1, n2, n3, n4))
|
||||
f card (H Hand2) =
|
||||
(([], [card], [], []), (n1, n2+1, n3, n4))
|
||||
f card (H Hand3) =
|
||||
(([], [], [card], []), (n1, n2, n3+1, n4))
|
||||
f card Skt =
|
||||
(([], [], [], [card]), (n1, n2, n3, n4+1))
|
||||
isOk (H Hand1) = n1 < cardsPerHand
|
||||
isOk (H Hand2) = n2 < cardsPerHand
|
||||
isOk (H Hand3) = n3 < cardsPerHand
|
||||
isOk Skt = n4 < 2
|
||||
in filterMap isOk (f card) hands
|
||||
cardsPerHand = (length guess - 2) `div` 3
|
||||
|
||||
type Abstract = (Int, Int, Int, Int)
|
||||
|
||||
abstract :: [Card] -> Abstract
|
||||
abstract cs = foldr f (0, 0, 0, 0) cs
|
||||
where f c (clubs, spades, hearts, diamonds) =
|
||||
let v = getID c in
|
||||
case getColour c of
|
||||
Diamonds -> (clubs, spades, hearts, diamonds + 1 + v*100)
|
||||
Hearts -> (clubs, spades, hearts + 1 + v*100, diamonds)
|
||||
Spades -> (clubs, spades + 1 + v*100, hearts, diamonds)
|
||||
Clubs -> (clubs + 1 + v*100, spades, hearts, diamonds)
|
||||
|
||||
remove789s :: Hand
|
||||
-> [Distribution]
|
||||
-> M.Map (Abstract, Abstract) (Distribution, Int)
|
||||
remove789s hand ds = foldl' f M.empty ds
|
||||
where f cleaned d =
|
||||
let (c1, c2) = reduce hand d
|
||||
a = (abstract c1, abstract c2) in
|
||||
M.insertWith (\(oldD, n) _ -> (oldD, n+1)) a (d, 1) cleaned
|
||||
reduce Hand1 (_, h2, h3, _) = (h2, h3)
|
||||
reduce Hand2 (h1, _, h3, _) = (h1, h3)
|
||||
reduce Hand3 (h1, h2, _, _) = (h1, h2)
|
||||
|
||||
simplify :: Hand -> [Distribution] -> [(Distribution, Int)]
|
||||
simplify hand ds = M.elems cleaned
|
||||
where cleaned = remove789s hand ds
|
||||
|
||||
onPlayed :: MonadPlayer m => CardS Played -> AI m ()
|
||||
onPlayed c = do
|
||||
liftIO $ print c
|
||||
modifyg (getCard c `hasBeenPlayed`)
|
||||
trCol <- trumpColour
|
||||
turnCol <- turnColour
|
||||
let col = effectiveColour trCol (getCard c)
|
||||
case turnCol of
|
||||
Just demanded -> if col /= demanded
|
||||
then origin c `hasNoLonger` demanded else return ()
|
||||
Nothing -> return ()
|
||||
|
||||
choose :: MonadPlayer m => AI m Card
|
||||
choose = do
|
||||
handCards <- gets myHand
|
||||
table <- gets table
|
||||
case length table of
|
||||
0 -> if length handCards >= 7
|
||||
then chooseLead
|
||||
else chooseStatistic
|
||||
n -> chooseStatistic
|
||||
|
||||
chooseStatistic :: MonadPlayer m => AI m Card
|
||||
chooseStatistic = do
|
||||
h <- gets getHand
|
||||
handCards <- gets myHand
|
||||
let depth = case length handCards of
|
||||
0 -> 0
|
||||
1 -> 1
|
||||
-- simulate whole game
|
||||
2 -> 2
|
||||
3 -> 3
|
||||
-- simulate only partially
|
||||
4 -> 3
|
||||
5 -> 2
|
||||
6 -> 2
|
||||
7 -> 1
|
||||
8 -> 1
|
||||
9 -> 1
|
||||
10 -> 1
|
||||
modify $ setDepth depth
|
||||
guess__ <- gets guess
|
||||
self <- get
|
||||
maySkat <- showSkat self
|
||||
let guess_ = (hand self `has` handCards) guess__
|
||||
guess = case maySkat of
|
||||
Just cs -> (cs `isSkat`) guess_
|
||||
Nothing -> guess_
|
||||
table <- gets table
|
||||
let ns = case length table of
|
||||
0 -> (0, 0, 0, 0)
|
||||
1 -> (-1, 0, -1, 0)
|
||||
2 -> (0, 0, -1, 0)
|
||||
let realDis = distributions guess ns
|
||||
realDisNo = length realDis
|
||||
reducedDis = simplify Hand3 realDis
|
||||
reducedDisNo = length reducedDis
|
||||
piless = map (\(d, n) -> (toPiles table d, n)) reducedDis
|
||||
limit = if depth == 1 && length table == 2
|
||||
then 1
|
||||
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
|
||||
liftIO $ print vals
|
||||
return $ fst $ maximumBy (comparing snd) vals
|
||||
|
||||
foldWithLimit :: Monad m
|
||||
=> Int
|
||||
-> (M.Map k Int -> a -> m (M.Map k Int))
|
||||
-> M.Map k Int
|
||||
-> [a]
|
||||
-> m (M.Map k Int)
|
||||
foldWithLimit _ _ start [] = return start
|
||||
foldWithLimit limit f start (x:xs) = do
|
||||
case M.size (M.filter (>=limit) start) of
|
||||
0 -> do m <- f start x
|
||||
foldWithLimit limit f m xs
|
||||
_ -> return start
|
||||
|
||||
runOnPiles :: MonadPlayer m
|
||||
=> M.Map Card Int -> (Piles, Int) -> AI m (M.Map Card Int)
|
||||
runOnPiles m (ps, n) = do
|
||||
c <- runWithPiles ps chooseOpen
|
||||
return $ M.insertWith (+) c n m
|
||||
|
||||
chooseOpen :: (MonadState AIEnv m, MonadPlayerOpen m) => m Card
|
||||
chooseOpen = do
|
||||
piles <- showPiles
|
||||
hand <- gets getHand
|
||||
let myCards = handCards hand piles
|
||||
possible <- filterM (P.isAllowed myCards) myCards
|
||||
case length myCards of
|
||||
0 -> do
|
||||
liftIO $ print hand
|
||||
liftIO $ print piles
|
||||
error "no cards left to choose from"
|
||||
1 -> return $ head myCards
|
||||
_ -> chooseSimulating
|
||||
|
||||
chooseSimulating :: (MonadState AIEnv m, MonadPlayerOpen m)
|
||||
=> m Card
|
||||
chooseSimulating = do
|
||||
piles <- showPiles
|
||||
hand <- gets getHand
|
||||
let myCards = handCards hand piles
|
||||
possible <- filterM (P.isAllowed myCards) myCards
|
||||
case possible of
|
||||
[card] -> return card
|
||||
cs -> do
|
||||
results <- mapM simulate cs
|
||||
let both = zip results cs
|
||||
best = maximumBy (comparing fst) both
|
||||
return $ snd best
|
||||
|
||||
simulate :: (MonadState AIEnv m, MonadPlayerOpen m)
|
||||
=> Card -> m Int
|
||||
simulate card = do
|
||||
-- retrieve all relevant info
|
||||
piles <- showPiles
|
||||
turnCol <- turnColour
|
||||
trumpCol <- trumpColour
|
||||
myTeam <- gets getTeam
|
||||
myHand <- gets getHand
|
||||
depth <- gets simulationDepth
|
||||
let newDepth = depth - 1
|
||||
-- create a virtual env with 3 ai players
|
||||
ps = Players
|
||||
(PL $ mkAIEnv Team Hand1 newDepth)
|
||||
(PL $ mkAIEnv Team Hand2 newDepth)
|
||||
(PL $ mkAIEnv Single Hand3 newDepth)
|
||||
env = mkSkatEnv piles turnCol trumpCol ps
|
||||
-- simulate the game after playing the given card
|
||||
(sgl, tm) <- liftIO $ evalStateT (do
|
||||
modifyp $ playCard card
|
||||
turnGeneric playOpen depth (next myHand)) env
|
||||
let v = if myTeam == Single then (sgl, tm) else (tm, sgl)
|
||||
-- put the value into context for when not the whole game is
|
||||
-- simulated
|
||||
predictValue v
|
||||
|
||||
predictValue :: (MonadState AIEnv m, MonadPlayerOpen m)
|
||||
=> (Int, Int) -> m Int
|
||||
predictValue (own, others) = do
|
||||
hand <- gets getHand
|
||||
piles <- showPiles
|
||||
let cs = handCards hand piles
|
||||
pot <- potential cs
|
||||
return $ own + pot
|
||||
|
||||
potential :: (MonadState AIEnv m, MonadPlayerOpen m)
|
||||
=> [Card] -> m Int
|
||||
potential cs = do
|
||||
tr <- trumpColour
|
||||
let trs = filter (isTrump tr) cs
|
||||
value = count cs
|
||||
positions <- filter (==0) <$> mapM position cs
|
||||
return $ length trs * 10 + value + length positions * 5
|
||||
|
||||
position :: (MonadState AIEnv m, MonadPlayer m)
|
||||
=> Card -> m Int
|
||||
position card = do
|
||||
tr <- trumpColour
|
||||
guess <- gets guess
|
||||
let effCol = effectiveColour tr card
|
||||
l = M.toList guess
|
||||
cs = filterMap ((==effCol) . effectiveColour tr . fst) fst l
|
||||
csInd = zip [0..] cs
|
||||
Just (pos, _) = find ((== card) . snd) csInd
|
||||
return pos
|
||||
|
||||
leadPotential :: (MonadState AIEnv m, MonadPlayer m)
|
||||
=> Card -> m Int
|
||||
leadPotential card = do
|
||||
pos <- position card
|
||||
isTr <- P.isTrump card
|
||||
let value = count card
|
||||
case pos of
|
||||
0 -> return value
|
||||
_ -> return $ -value
|
||||
|
||||
chooseLead :: (MonadState AIEnv m, MonadPlayer m) => m Card
|
||||
chooseLead = do
|
||||
cards <- gets myHand
|
||||
possible <- filterM (P.isAllowed cards) cards
|
||||
pots <- mapM leadPotential possible
|
||||
return $ snd $ maximumBy (comparing fst) (zip pots possible)
|
||||
|
||||
mkAIEnv :: Team -> Hand -> Int -> AIEnv
|
||||
mkAIEnv tm h depth = AIEnv tm h [] [] [] newGuess depth
|
||||
|
||||
-- | TESTING VARS
|
||||
|
||||
aienv :: AIEnv
|
||||
aienv = AIEnv Single Hand3 [] [] [] newGuess 10
|
||||
|
||||
testguess :: Guess
|
||||
testguess = isSkat (take 2 $ drop 10 cs)
|
||||
$ Hand3 `has` (take 10 cs) $ m
|
||||
where l = map (\c -> (c, [H Hand1, H Hand2, H Hand3, Skt])) (take 32 cs)
|
||||
m = M.fromList l
|
||||
cs = allCards
|
||||
|
||||
testguess2 :: Guess
|
||||
testguess2 = isSkat (take 2 $ drop 6 cs)
|
||||
$ Hand3 `has` [head cs, head $ drop 5 cs] $ m
|
||||
where l = map (\c -> (c, [H Hand1, H Hand2, H Hand3, Skt])) cs
|
||||
m = M.fromList l
|
||||
cs = take 8 $ drop 8 allCards
|
||||
|
||||
testds :: [Distribution]
|
||||
testds = distributions testguess (0, 0, 0, 0)
|
||||
|
||||
testds2 :: [Distribution]
|
||||
testds2 = distributions testguess2 (0, 0, 0, 0)
|
||||
@@ -0,0 +1,105 @@
|
||||
module Skat.AI.Server where
|
||||
|
||||
import qualified Network.Socket as Net
|
||||
import qualified System.IO as Sys
|
||||
import Control.Concurrent
|
||||
import Control.Concurrent.Chan
|
||||
import Control.Monad (forever)
|
||||
import Control.Monad.Reader
|
||||
import Data.List.Split
|
||||
|
||||
data Buffering = NoBuffering
|
||||
| LengthBuffering
|
||||
| DelimiterBuffering String
|
||||
deriving (Show)
|
||||
|
||||
data ServerEnv = ServerEnv
|
||||
{ buffering :: Buffering -- ^ Buffermode
|
||||
, socket :: Net.Socket -- ^ the socket used to communicate
|
||||
, global :: Chan String
|
||||
, onReceive :: OnReceive
|
||||
}
|
||||
|
||||
instance Show ServerEnv where
|
||||
show env = "A Server"
|
||||
|
||||
type Server = ReaderT ServerEnv IO
|
||||
|
||||
type OnReceive = Sys.Handle -> Net.SockAddr -> String -> Server ()
|
||||
|
||||
broadcast :: String -> Server ()
|
||||
broadcast msg = do
|
||||
bufmode <- asks buffering
|
||||
chan <- asks global
|
||||
case bufmode of
|
||||
DelimiterBuffering delim -> liftIO $ writeChan chan $ msg ++ delim
|
||||
_ -> liftIO $ writeChan chan msg
|
||||
|
||||
send :: Sys.Handle -> String -> Server ()
|
||||
send connhdl msg = do
|
||||
bufmode <- asks buffering
|
||||
case bufmode of
|
||||
DelimiterBuffering delim -> liftIO $ Sys.hPutStr connhdl $ msg ++ delim
|
||||
_ -> liftIO $ Sys.hPutStr connhdl msg
|
||||
|
||||
|
||||
-- | Initialize a new server with the given port number and buffering mode
|
||||
initServer :: Net.PortNumber -> Buffering -> OnReceive -> IO ServerEnv
|
||||
initServer port buffermode handler = do
|
||||
sock <- Net.socket Net.AF_INET Net.Stream 0
|
||||
Net.setSocketOption sock Net.ReuseAddr 1
|
||||
Net.bind sock (Net.SockAddrInet port Net.iNADDR_ANY)
|
||||
Net.listen sock 5
|
||||
chan <- newChan
|
||||
forkIO $ forever $ do
|
||||
msg <- readChan chan -- clearing the main channel
|
||||
return ()
|
||||
return (ServerEnv buffermode sock chan handler)
|
||||
|
||||
close :: ServerEnv -> IO ()
|
||||
close = Net.close . socket
|
||||
|
||||
-- | Looping over requests and establish connection
|
||||
procRequests :: Server ()
|
||||
procRequests = do
|
||||
sock <- asks socket
|
||||
(conn, clientaddr) <- liftIO $ Net.accept sock
|
||||
env <- ask
|
||||
liftIO $ forkIO $ runReaderT (procMessages conn clientaddr) env
|
||||
procRequests
|
||||
|
||||
-- | Handle one client
|
||||
procMessages :: Net.Socket -> Net.SockAddr -> Server ()
|
||||
procMessages conn clientaddr = do
|
||||
connhdl <- liftIO $ Net.socketToHandle conn Sys.ReadWriteMode
|
||||
liftIO $ Sys.hSetBuffering connhdl Sys.NoBuffering
|
||||
globalChan <- asks global
|
||||
|
||||
commChan <- liftIO $ dupChan globalChan
|
||||
|
||||
reader <- liftIO $ forkIO $ forever $ do
|
||||
msg <- readChan commChan
|
||||
Sys.hPutStrLn connhdl msg
|
||||
|
||||
handler <- asks onReceive
|
||||
messages <- liftIO $ Sys.hGetContents connhdl
|
||||
buffermode <- asks buffering
|
||||
case buffermode of
|
||||
DelimiterBuffering delimiter ->
|
||||
mapM_ (handler connhdl clientaddr) (splitOn delimiter messages)
|
||||
LengthBuffering -> liftIO $ putStrLn (take 4 messages)
|
||||
_ -> return ()
|
||||
|
||||
-- clean up
|
||||
liftIO $ do killThread reader
|
||||
Sys.hClose connhdl
|
||||
|
||||
sampleHandler :: OnReceive
|
||||
sampleHandler connhdl addr query = do
|
||||
liftIO $ putStrLn $ "new query " ++ query
|
||||
send connhdl $ "> " ++ query
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
env <- initServer 4242 LengthBuffering sampleHandler
|
||||
runReaderT procRequests env
|
||||
@@ -0,0 +1,18 @@
|
||||
module Skat.AI.Stupid where
|
||||
|
||||
import Skat.Player
|
||||
import Skat.Pile
|
||||
import Skat.Card
|
||||
|
||||
data Stupid = Stupid { getTeam :: Team
|
||||
, getHand :: Hand }
|
||||
deriving Show
|
||||
|
||||
instance Player Stupid where
|
||||
team = getTeam
|
||||
hand = getHand
|
||||
chooseCard p _ _ hand = do
|
||||
trumpCol <- trumpColour
|
||||
turnCol <- turnColour
|
||||
let possible = filter (isAllowed trumpCol turnCol hand) hand
|
||||
return (head possible, p)
|
||||
@@ -0,0 +1,149 @@
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Skat.Card where
|
||||
|
||||
import Data.List
|
||||
import Data.Aeson
|
||||
import System.Random (newStdGen)
|
||||
import Control.DeepSeq
|
||||
|
||||
import Skat.Utils
|
||||
|
||||
class Countable a b where
|
||||
count :: a -> b
|
||||
|
||||
data Type = Seven
|
||||
| Eight
|
||||
| Nine
|
||||
| Queen
|
||||
| King
|
||||
| Ten
|
||||
| Ace
|
||||
| Jack
|
||||
deriving (Eq, Ord, Show, Enum, Read)
|
||||
|
||||
instance Countable Type Int where
|
||||
count Ace = 11
|
||||
count Ten = 10
|
||||
count King = 4
|
||||
count Queen = 3
|
||||
count Jack = 2
|
||||
count _ = 0
|
||||
|
||||
data Colour = Diamonds
|
||||
| Hearts
|
||||
| Spades
|
||||
| Clubs
|
||||
deriving (Eq, Ord, Show, Enum, Read)
|
||||
|
||||
data Card = Card Type Colour
|
||||
deriving (Eq, Show, Ord)
|
||||
|
||||
instance ToJSON Card where
|
||||
toJSON (Card t c) =
|
||||
object ["type" .= show t, "colour" .= show c]
|
||||
|
||||
instance FromJSON Card where
|
||||
parseJSON = withObject "Card" $ \v -> do
|
||||
t <- v .: "type"
|
||||
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
|
||||
Seven -> 0
|
||||
Eight -> 0
|
||||
Nine -> 0
|
||||
Queen -> 2
|
||||
King -> 4
|
||||
Ten -> 8
|
||||
Ace -> 16
|
||||
Jack -> 32
|
||||
|
||||
instance Countable Card Int where
|
||||
count (Card t _) = count t
|
||||
|
||||
instance Countable [Card] Int where
|
||||
count = sum . map count
|
||||
|
||||
instance NFData Card where
|
||||
rnf (Card t c) = t `seq` c `seq` ()
|
||||
|
||||
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
|
||||
|
||||
effectiveColour :: Colour -> Card -> Colour
|
||||
effectiveColour trumpCol card@(Card _ col) =
|
||||
if trump then trumpCol else col
|
||||
where trump = isTrump trumpCol card
|
||||
|
||||
isAllowed :: Colour -> Maybe Colour -> [Card] -> Card -> Bool
|
||||
isAllowed trumpCol turnCol cs card =
|
||||
if col `equals` turnCol
|
||||
then True
|
||||
else not $ any (\ca -> effectiveColour trumpCol ca `equals` turnCol && ca /= card) cs
|
||||
where col = effectiveColour trumpCol card
|
||||
|
||||
compareCards :: Colour
|
||||
-> Maybe Colour
|
||||
-> Card
|
||||
-> Card
|
||||
-> Ordering
|
||||
compareCards _ _ (Card Jack col1) (Card Jack col2) = compare col1 col2
|
||||
compareCards trumpCol turnCol c1@(Card tp1 col1) c2@(Card tp2 col2) =
|
||||
case (trp1, trp2) of
|
||||
(True, True) -> compare tp1 tp2
|
||||
(False, False) -> case compare (col1 `equals` turnCol)
|
||||
(col2 `equals` turnCol) of
|
||||
EQ -> compare tp1 tp2
|
||||
v -> v
|
||||
_ -> compare trp1 trp2
|
||||
where trp1 = isTrump trumpCol c1
|
||||
trp2 = isTrump trumpCol c2
|
||||
|
||||
sortCards :: Colour -> Maybe Colour -> [Card] -> [Card]
|
||||
sortCards trumpCol turnCol cs = sortBy (compareCards trumpCol turnCol) cs
|
||||
|
||||
highestCard :: Colour -> Maybe Colour -> [Card] -> Card
|
||||
highestCard trumpCol turnCol cs = maximumBy (compareCards trumpCol turnCol) cs
|
||||
|
||||
shuffleCards :: IO [Card]
|
||||
shuffleCards = do
|
||||
gen <- newStdGen
|
||||
return $ shuffle gen allCards
|
||||
|
||||
-- TESTING VARS
|
||||
|
||||
c1 :: Card
|
||||
c1 = Card Jack Spades
|
||||
|
||||
c2 :: Card
|
||||
c2 = Card Ace Diamonds
|
||||
|
||||
c3 :: Card
|
||||
c3 = Card Queen Diamonds
|
||||
|
||||
c4 :: Card
|
||||
c4 = Card Queen Hearts
|
||||
|
||||
c5 :: Card
|
||||
c5 = Card Jack Clubs
|
||||
|
||||
h1 :: [Card]
|
||||
h1 = [c1,c2,c3,c4,c5]
|
||||
|
||||
allCards :: [Card]
|
||||
allCards = [ Card t c | t <- tps, c <- cols ]
|
||||
where tps = [Seven .. Jack]
|
||||
cols = [Diamonds .. Clubs]
|
||||
@@ -0,0 +1,88 @@
|
||||
module Skat.Operations where
|
||||
|
||||
import Control.Monad.State
|
||||
import System.Random (newStdGen, randoms)
|
||||
import Data.List
|
||||
import Data.Ord
|
||||
|
||||
import Skat
|
||||
import Skat.Card
|
||||
import Skat.Pile
|
||||
import Skat.Player (chooseCard, Players(..), Player(..), PL(..),
|
||||
updatePlayer, playersToList, player, MonadPlayer)
|
||||
import Skat.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
|
||||
@@ -0,0 +1,120 @@
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Skat.Pile where
|
||||
|
||||
import Data.List
|
||||
import Data.Aeson
|
||||
import Control.Exception
|
||||
|
||||
import Skat.Card
|
||||
import Skat.Utils
|
||||
|
||||
data Team = Team | Single
|
||||
deriving (Show, Eq, Ord, Enum)
|
||||
|
||||
data CardS p = CardS { getCard :: Card
|
||||
, getPile :: p }
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
instance Countable (CardS p) Int where
|
||||
count = count . getCard
|
||||
|
||||
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)
|
||||
|
||||
next :: Hand -> Hand
|
||||
next Hand1 = Hand2
|
||||
next Hand2 = Hand3
|
||||
next Hand3 = Hand1
|
||||
|
||||
prev :: Hand -> Hand
|
||||
prev Hand1 = Hand3
|
||||
prev Hand2 = Hand1
|
||||
prev Hand3 = Hand2
|
||||
|
||||
data Played = Table Hand
|
||||
| Won Hand Team
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
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]
|
||||
|
||||
data SkatP = SkatP
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
data Piles = Piles { hands :: [CardS Hand]
|
||||
, played :: [CardS Played]
|
||||
, 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
|
||||
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
|
||||
|
||||
cleanTable :: Team -> Piles -> Piles
|
||||
cleanTable winner ps@(Piles hs pld skt) = Piles hs pld' skt
|
||||
where table = tableCards ps
|
||||
pld' = map (winCard winner) pld
|
||||
|
||||
tableCards :: Piles -> [Card]
|
||||
tableCards (Piles _ pld _) = filterMap (f . getPile) getCard pld
|
||||
where f (Table _) = True
|
||||
f _ = False
|
||||
|
||||
tableCardsS :: Piles -> [CardS Played]
|
||||
tableCardsS (Piles _ pld _) = filter (f . getPile) pld
|
||||
where f (Table _) = True
|
||||
f _ = False
|
||||
|
||||
handCards :: Hand -> Piles -> [Card]
|
||||
handCards hand (Piles hs _ _) = filterMap ((==hand) . getPile) getCard hs
|
||||
|
||||
skatCards :: Piles -> [Card]
|
||||
skatCards (Piles _ _ skat) = map getCard skat
|
||||
|
||||
putAt :: p -> Card -> CardS p
|
||||
putAt = flip CardS
|
||||
|
||||
distribute :: [Card] -> Piles
|
||||
distribute cards = Piles hands [] (map (putAt SkatP) skt)
|
||||
where round1 = chunksOf 3 (take 9 cards)
|
||||
skt = take 2 $ drop 9 cards
|
||||
round2 = chunksOf 4 (take 12 $ drop 11 cards)
|
||||
round3 = chunksOf 3 (take 9 $ drop 23 cards)
|
||||
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
|
||||
@@ -0,0 +1,79 @@
|
||||
{-# LANGUAGE ExistentialQuantification #-}
|
||||
|
||||
module Skat.Player where
|
||||
|
||||
import Control.Monad.IO.Class
|
||||
|
||||
import Skat.Card
|
||||
import Skat.Pile
|
||||
|
||||
class (Monad m, MonadIO m) => MonadPlayer m where
|
||||
trumpColour :: m Colour
|
||||
turnColour :: m (Maybe Colour)
|
||||
showSkat :: Player p => p -> m (Maybe [Card])
|
||||
|
||||
class (Monad m, MonadIO m, MonadPlayer m) => MonadPlayerOpen m where
|
||||
showPiles :: m (Piles)
|
||||
|
||||
class Player p where
|
||||
team :: p -> Team
|
||||
hand :: p -> Hand
|
||||
chooseCard :: MonadPlayer m
|
||||
=> p
|
||||
-> [CardS Played]
|
||||
-> [CardS Played]
|
||||
-> [Card]
|
||||
-> m (Card, p)
|
||||
onCardPlayed :: MonadPlayer m
|
||||
=> p
|
||||
-> CardS Played
|
||||
-> m p
|
||||
onCardPlayed p _ = return p
|
||||
chooseCardOpen :: MonadPlayerOpen m
|
||||
=> p
|
||||
-> m Card
|
||||
chooseCardOpen p = do
|
||||
piles <- showPiles
|
||||
let table = tableCardsS piles
|
||||
fallen = played piles
|
||||
myCards = handCards (hand p) piles
|
||||
fmap fst $ chooseCard p table fallen myCards
|
||||
onGameResults :: MonadIO m
|
||||
=> p
|
||||
-> (Int, Int)
|
||||
-> m ()
|
||||
onGameResults _ _ = return ()
|
||||
|
||||
data PL = forall p. (Show p, Player p) => PL p
|
||||
|
||||
instance Show PL where
|
||||
show (PL p) = show p
|
||||
|
||||
instance Player PL where
|
||||
team (PL p) = team p
|
||||
hand (PL p) = hand p
|
||||
chooseCard (PL p) table fallen hand = do
|
||||
(v, a) <- chooseCard p table fallen hand
|
||||
return $ (v, PL a)
|
||||
onCardPlayed (PL p) card = do
|
||||
v <- onCardPlayed p card
|
||||
return $ PL v
|
||||
chooseCardOpen (PL p) = chooseCardOpen p
|
||||
onGameResults (PL p) res = onGameResults p res
|
||||
|
||||
data Players = Players PL PL PL
|
||||
deriving Show
|
||||
|
||||
player :: Players -> Hand -> PL
|
||||
player (Players p _ _) Hand1 = p
|
||||
player (Players _ p _) Hand2 = p
|
||||
player (Players _ _ p) Hand3 = p
|
||||
|
||||
updatePlayer :: (Show p, Player p) => p -> Players -> Players
|
||||
updatePlayer p (Players p1 p2 p3) = case hand p of
|
||||
Hand1 -> Players (PL p) p2 p3
|
||||
Hand2 -> Players p1 (PL p) p3
|
||||
Hand3 -> Players p1 p2 (PL p)
|
||||
|
||||
playersToList :: Players -> [PL]
|
||||
playersToList (Players p1 p2 p3) = [p1, p2, p3]
|
||||
@@ -0,0 +1,18 @@
|
||||
module Skat.Player.Utils (
|
||||
isAllowed, isTrump
|
||||
) where
|
||||
|
||||
import Skat.Player
|
||||
import qualified Skat.Card as C
|
||||
import Skat.Card (Card)
|
||||
|
||||
isAllowed :: MonadPlayer m => [Card] -> Card -> m Bool
|
||||
isAllowed hand card = do
|
||||
trCol <- trumpColour
|
||||
turnCol <- turnColour
|
||||
return $ C.isAllowed trCol turnCol hand card
|
||||
|
||||
isTrump :: MonadPlayer m => Card -> m Bool
|
||||
isTrump card = do
|
||||
trCol <- trumpColour
|
||||
return $ C.isTrump trCol card
|
||||
@@ -0,0 +1,8 @@
|
||||
module Skat.Render where
|
||||
|
||||
import Data.List
|
||||
|
||||
import Skat.Card
|
||||
|
||||
render :: [Card] -> IO ()
|
||||
render = putStrLn . intercalate "\n" . zipWith (\n c -> show n ++ ") " ++ show c) [0..]
|
||||
@@ -0,0 +1,58 @@
|
||||
module Skat.Utils where
|
||||
|
||||
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)
|
||||
|
||||
shuffle :: StdGen -> [a] -> [a]
|
||||
shuffle g xs = shuffle' (randoms g) xs
|
||||
|
||||
shuffle' :: [Int] -> [a] -> [a]
|
||||
shuffle' _ [] = []
|
||||
shuffle' (i:is) xs = let (firsts, rest) = splitAt (1 + i `mod` length xs) xs
|
||||
in (last firsts) : shuffle' is (init firsts ++ rest)
|
||||
|
||||
chunksOf :: Int -> [a] -> [[a]]
|
||||
chunksOf n [] = []
|
||||
chunksOf n xs = take n xs : chunksOf n (drop n xs)
|
||||
|
||||
query :: Read a => String -> IO a
|
||||
query s = do
|
||||
putStrLn s
|
||||
l <- fmap readMaybe getLine
|
||||
case l of
|
||||
Just x -> return x
|
||||
Nothing -> query s
|
||||
|
||||
remove :: (a -> Bool) -> [a] -> (a, [a])
|
||||
remove pred xs = foldr f (undefined, []) xs
|
||||
where f c (old, cs) = if pred c then (c, cs) else (old, c : cs)
|
||||
|
||||
filterMap :: (a -> Bool) -> (a -> b) -> [a] -> [b]
|
||||
filterMap pred f as = foldr g [] as
|
||||
where g a bs = if pred a then f a : bs else bs
|
||||
|
||||
--filterM :: Monad m => (a -> m Bool) -> [a] -> m [a]
|
||||
--filterM _ [] = return []
|
||||
--filterM pred (x:xs) = do
|
||||
-- b <- pred x
|
||||
-- if b then filterM pred xs >>= \l -> return $ x : l
|
||||
-- else filterM pred xs
|
||||
|
||||
grouping :: Eq a => (b -> a) -> b -> b -> Bool
|
||||
grouping f a b = f a == f b
|
||||
|
||||
-- handy little string type class that takes care of string
|
||||
-- conversion
|
||||
class Stringy a where
|
||||
toString :: a -> String
|
||||
fromString :: String -> a
|
||||
|
||||
instance Stringy B.ByteString where
|
||||
toString = B.unpack
|
||||
fromString = B.pack
|
||||
|
||||
instance Stringy T.Text where
|
||||
toString = T.unpack
|
||||
fromString = T.pack
|
||||
@@ -0,0 +1,123 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
|
||||
module Skat.WebSocketServer where
|
||||
|
||||
import qualified Network.WebSockets as WS
|
||||
import Control.Concurrent
|
||||
import Control.Exception
|
||||
import Control.Monad
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.State
|
||||
import Control.Monad.IO.Class
|
||||
|
||||
import Data.CaseInsensitive (original)
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Lazy.Char8 as BS8
|
||||
import Data.Maybe
|
||||
|
||||
import Skat.Utils (toString)
|
||||
|
||||
data ServerState = ServerState { clients :: Clients
|
||||
, queue :: Clients }
|
||||
|
||||
|
||||
newtype Server a = Server { unServer :: ReaderT (MVar ServerState) IO a }
|
||||
deriving (Monad, MonadIO, Functor, Applicative,
|
||||
MonadReader (MVar ServerState))
|
||||
|
||||
runServer :: Server a -> MVar ServerState -> IO a
|
||||
runServer (Server action) var = runReaderT action var
|
||||
|
||||
instance MonadState ServerState Server where
|
||||
get = execute get
|
||||
put = execute . put
|
||||
|
||||
-- | dangerous shitty function
|
||||
-- enables to run state operations on an mvar of a reader monad
|
||||
execute :: (MonadIO m, MonadReader (MVar r) m) => StateT r m a -> m a
|
||||
execute manipulation = do
|
||||
var <- ask
|
||||
state <- liftIO $ takeMVar var
|
||||
(a, state') <- runStateT manipulation state
|
||||
liftIO $ putMVar var state'
|
||||
return a
|
||||
|
||||
addClient :: String -> WS.Connection -> ServerState -> ServerState
|
||||
addClient key conn ss = ss { clients = (key, conn) : cls }
|
||||
where cls = clients ss
|
||||
|
||||
removeClient :: String -> ServerState -> ServerState
|
||||
removeClient key ss = ss { clients = filter ((/=key) . fst) cls }
|
||||
where cls = clients ss
|
||||
|
||||
queueClient :: String -> WS.Connection -> ServerState -> ServerState
|
||||
queueClient key conn ss = ss { queue = (key, conn) : cls }
|
||||
where cls = queue ss
|
||||
|
||||
type Clients = [(String, WS.Connection)]
|
||||
|
||||
instance Show WS.Connection where
|
||||
show _ = "a connection"
|
||||
|
||||
send :: WS.Connection -> String -> IO ()
|
||||
send conn s = WS.sendTextData conn (BS8.pack s)
|
||||
|
||||
receive :: WS.Connection -> IO String
|
||||
receive conn = BS8.unpack <$> WS.receiveData conn
|
||||
|
||||
currentClients :: Server Clients
|
||||
currentClients = do
|
||||
ss <- execute get
|
||||
return $ clients ss
|
||||
|
||||
runDebugServer :: String -> Int -> IO (MVar ServerState)
|
||||
runDebugServer address port = do
|
||||
state <- newMVar (ServerState [] [])
|
||||
forkIO $ WS.runServer address port (application onLogin state)
|
||||
return state
|
||||
|
||||
onLogin :: Server ()
|
||||
onLogin = do
|
||||
liftIO $ putStrLn "a new client joined"
|
||||
cls <- currentClients
|
||||
uncurry lobby $ head cls
|
||||
|
||||
lobby :: String -> WS.Connection -> Server ()
|
||||
lobby key conn = do
|
||||
msg <- liftIO $ receive conn
|
||||
case msg of
|
||||
"hi" -> liftIO $ send conn "hi client"
|
||||
"queue" -> do
|
||||
qu <- gets queue
|
||||
liftIO $ send conn "ok, put you in the queue"
|
||||
liftIO $ putStrLn "client queued up"
|
||||
if length qu >= 3
|
||||
then do
|
||||
let ps = take 3 qu
|
||||
liftIO $ putStrLn "3 players in queue, starting a game"
|
||||
--forkIO $ onlineMatch (ps !! 0) (ps !! 1) (ps !! 2)
|
||||
else return ()
|
||||
modify $ queueClient key conn
|
||||
lobby key conn
|
||||
|
||||
application :: Server () -> MVar ServerState -> WS.PendingConnection -> IO ()
|
||||
application onlogin stateVar pending = do
|
||||
conn <- WS.acceptRequest pending
|
||||
WS.forkPingThread conn 30
|
||||
print $ WS.pendingRequest pending
|
||||
let headers = WS.requestHeaders $ WS.pendingRequest pending
|
||||
hs = map (\(k, v) -> (toString (original k), toString v)) headers
|
||||
key = fromMaybe "" $ lookup "Sec-WebSocket-Key" hs
|
||||
putStrLn "new connection"
|
||||
let disconnect = flip runServer stateVar $ do
|
||||
modify $ removeClient key
|
||||
liftIO $ putStrLn "client disconnected"
|
||||
flip finally disconnect $ flip runServer stateVar $ do
|
||||
modify $ addClient key conn
|
||||
onlogin
|
||||
liftIO $ forever $ threadDelay 1000
|
||||
Reference in New Issue
Block a user