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

serialization of piles

Browse Source
This commit is contained in:
christian
2020-04-04 00:23:14 +02:00
parent a7824bebea
commit 1c3f85b9a6
9 changed files with 125 additions and 11 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Skat.hs
-1
View File
@@ -23,7 +23,6 @@ data SkatEnv = SkatEnv { piles :: Piles
, currentHand :: Hand }
deriving Show
type Trick = (CardS Owner, CardS Owner, CardS Owner)
type Skat = StateT SkatEnv (WriterT [Trick] IO)
runSkat :: Skat a -> SkatEnv -> IO (a, SkatEnv, [Trick])
src/Skat/AI/Online.hs
+5
View File
@@ -95,6 +95,8 @@ instance Communicator c => Bidder (PrepOnline c) where
liftIO $ send (prepConnection p) (BS.unpack $ encode $ GameResultsQuery res)
onGame p game sglPlayer = do
liftIO $ send (prepConnection p) (BS.unpack $ encode $ GameStartQuery game sglPlayer)
onNoGame p = do
liftIO $ send (prepConnection p) (BS.unpack $ encode $ NoGameQuery)
type Online a m = ReaderT (OnlineEnv a) m
@@ -139,6 +141,7 @@ data Query = ChooseQuery [Card] [CardS Played]
| CardsQuery [Card]
| BidEvent (Maybe Bid) Hand Hand
| ResponseEvent Bool Hand Hand
| NoGameQuery
newtype ChosenResponse = ChosenResponse Card
newtype BidResponse = BidResponse Int
@@ -183,6 +186,8 @@ instance ToJSON Query where
, "response" .= response
, "reizer" .= show reizer
, "gereizter" .= show gereizter ]
toJSON NoGameQuery =
object [ "query" .= ("no_game" :: String) ]
instance FromJSON ChosenResponse where
parseJSON = withObject "ChosenResponse" $ \v -> ChosenResponse
src/Skat/Card.hs
+15 -4
View File
@@ -29,7 +29,7 @@ data Type = Seven
| Ten
| Ace
| Jack
deriving (Eq, Ord, Show, Enum, Read)
deriving (Eq, Ord, Show, Enum, Read, Bounded)
data NullType = NSeven
| NEight
@@ -39,7 +39,7 @@ data NullType = NSeven
| NQueen
| NKing
| NAce
deriving (Eq, Ord, Show, Enum, Read)
deriving (Eq, Ord, Show, Enum, Read, Bounded)
instance Countable Type Int where
count Ace = 11
@@ -53,7 +53,7 @@ data Colour = Diamonds
| Hearts
| Spades
| Clubs
deriving (Eq, Ord, Show, Enum, Read)
deriving (Eq, Ord, Show, Enum, Read, Bounded)
data Trump = TrumpColour Colour
| Jacks
@@ -65,7 +65,7 @@ data TurnColour = TurnColour Colour
deriving (Show, Eq)
data Card = Card Type Colour
deriving (Eq, Show, Ord, Read)
deriving (Eq, Show, Ord, Read, Bounded)
getType :: Card -> Type
getType (Card t _) = t
@@ -117,6 +117,17 @@ instance Countable (S.Set Card) Int where
instance NFData Card where
rnf (Card t c) = t `seq` c `seq` ()
base64table :: [Char]
base64table = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
class Serialize c a where
serialize :: a -> c
deserialize :: c -> Maybe a
instance Serialize Char Card where
serialize card = base64table !! fromEnum card
deserialize char = base64table `indexOf` char >>= safeToEnum
equals :: TurnColour -> Maybe TurnColour -> Bool
equals col (Just x) = col == x
equals col Nothing = True
src/Skat/Matches.hs
+2 -2
View File
@@ -33,10 +33,10 @@ match prepEnv = do
let res = getResults
(game skatEnv)
sglPlayer
(Skat.piles skatEnv)
(Skat.Preperation.piles prepEnv)
(Skat.piles finished)
publishGameResults res (bidders prepEnv)
return $ Just $ Match (Skat.piles skatEnv) res tricks sglPlayer
return $ Just $ Match (Skat.Preperation.piles prepEnv) res tricks sglPlayer
Nothing -> putStrLn "no one wanted to play" >> return Nothing
-- | predefined card distribution for testing purposes
src/Skat/Pile.hs
+52 -1
View File
@@ -6,6 +6,9 @@
module Skat.Pile where
import Control.Monad.State
import Control.Monad.Trans.Maybe
import Prelude hiding (lookup)
import qualified Data.Map.Strict as M
import qualified Data.Vector as V
@@ -15,6 +18,8 @@ import Data.Maybe
import Data.Aeson
import Control.Exception
import Data.List (delete)
import Text.Read (readMaybe)
import Debug.Trace
import Skat.Card
import Skat.Utils
@@ -41,7 +46,7 @@ instance ToJSON p => ToJSON (CardS p) where
object ["card" .= card, "pile" .= pile]
data Hand = Hand1 | Hand2 | Hand3
deriving (Show, Eq, Ord, Read)
deriving (Show, Eq, Ord, Read, Enum, Bounded)
toInt :: Hand -> Int
toInt Hand1 = 1
@@ -61,12 +66,33 @@ prev Hand3 = Hand2
data Owner = P Hand | S
deriving (Show, Eq, Ord, Read)
instance Enum Owner where
fromEnum (P hand) = fromEnum hand
fromEnum S = 3
toEnum 0 = P Hand1
toEnum 1 = P Hand2
toEnum 2 = P Hand3
toEnum 3 = S
instance Bounded Owner where
maxBound = S
minBound = P Hand1
instance ToJSON Owner where
toJSON (P hand) = object ["owner" .= show hand]
toJSON S = object ["owner" .= ("skat" :: String) ]
instance Serialize String (CardS Owner) where
serialize (CardS card owner) = show (fromEnum owner) ++ [serialize card]
deserialize str = (flip evalState) str $ runMaybeT $ do
owner <- pop >>= MaybeT . return . (>>= safeToEnum) . readMaybe . (:[])
card <- pop >>= MaybeT . return . deserialize
return $ CardS card owner
type Played = Owner -- TODO: remove
type Trick = (CardS Owner, CardS Owner, CardS Owner)
data Piles = Piles { _hand1 :: [CardS Owner]
, _hand2 :: [CardS Owner]
, _hand3 :: [CardS Owner]
@@ -185,3 +211,28 @@ distribute cards = emptyPiles hand1 hand2 hand3 skt
hand1 = concatMap (!! 0) [round1, round2, round3]
hand2 = concatMap (!! 1) [round1, round2, round3]
hand3 = concatMap (!! 2) [round1, round2, round3]
instance Serialize String Piles where
serialize piles = sers (_hand1 piles) ++ sers (_hand2 piles) ++ sers (_hand3 piles)
++ sers (_skat piles)
where sers cards = map (serialize . toCard) cards
deserialize str = (flip evalState) str $ runMaybeT $ do
hand1 <- takeG 10 >>= mapM deser
hand2 <- takeG 10 >>= mapM deser
hand3 <- takeG 10 >>= mapM deser
skat <- takeG 2 >>= mapM deser
return $ emptyPiles hand1 hand2 hand3 skat
where deser char = MaybeT $ return $ deserialize char
instance Serialize String [Trick] where
serialize [] = ""
serialize ((c1, c2, c3):tricks) = serialize c1 ++ serialize c2 ++ serialize c3
++ serialize tricks
deserialize str = (flip evalState) str $ runMaybeT $ reverse <$> go []
where go acc = do
empty <- isEmpty
if empty then return acc else do
card1 <- takeG 2 >>= MaybeT . return . deserialize
card2 <- takeG 2 >>= MaybeT . return . deserialize
card3 <- takeG 2 >>= MaybeT . return . deserialize
go ((card1, card2, card3):acc)
src/Skat/Preperation.hs
+7 -1
View File
@@ -40,6 +40,8 @@ class Bidder a where
onGame _ _ _ = return ()
onResult :: MonadIO m => a -> Result -> m ()
onResult _ _ = return ()
onNoGame :: MonadIO m => a -> m ()
onNoGame _ = return ()
-- | trick to allow heterogenous bidder list
data BD = forall b. (Show b, Bidder b) => BD b
@@ -60,6 +62,7 @@ instance Bidder BD where
onResult (BD b) = onResult b
onBid (BD b) = onBid b
onResponse (BD b) = onResponse b
onNoGame (BD b) = onNoGame b
data Bidders = Bidders BD BD BD
deriving Show
@@ -88,7 +91,7 @@ runPreperation = do
publishBid bid finalWinner finalWinner
case bid of
Just val -> (Just . (finalWinner,)) <$> initGame finalWinner val
Nothing -> return Nothing
Nothing -> publishNoGame >> return Nothing
else (Just . (finalWinner,)) <$> initGame finalWinner finalBid
runBidding :: Bid -> BD -> BD -> Preperation (Hand, Bid)
@@ -160,6 +163,9 @@ publishBid bid reizer gereizter = mapBidders (\b -> onBid b bid reizer gereizter
publishResponse :: Bool -> Hand -> Hand -> Preperation ()
publishResponse response reizer gereizter = mapBidders (\b -> onResponse b response reizer gereizter)
publishNoGame :: Preperation ()
publishNoGame = mapBidders onNoGame
mapBidders :: (BD -> Preperation ()) -> Preperation ()
mapBidders f = do
bds <- asks bidders
src/Skat/Utils.hs
+39 -1
View File
@@ -1,7 +1,12 @@
{-# LANGUAGE ScopedTypeVariables #-}
module Skat.Utils where
import Control.Monad.State
import Control.Monad.Trans.Maybe
import System.Random
import Text.Read
import Text.Read hiding (get, lift)
import qualified Data.ByteString.Char8 as B (ByteString, unpack, pack)
import qualified Data.Text as T (Text, unpack, pack)
import Data.List (foldl')
@@ -57,3 +62,36 @@ instance Stringy B.ByteString where
instance Stringy T.Text where
toString = T.unpack
fromString = T.pack
indexOf :: Eq a => [a] -> a -> Maybe Int
indexOf [] _ = Nothing
indexOf (x:xs) item
| x == item = Just 0
| otherwise = (1+) <$> xs `indexOf` item
type Generator c = MaybeT (State [c])
pop :: Generator c c
pop = do
cs <- get
if null cs then mzero else put (tail cs) >> return (head cs)
isEmpty :: Generator c Bool
isEmpty = get >>= return . null
takeG :: Int -> Generator c [c]
takeG n = do
cs <- lift get
if length cs >= n
then do
put (drop n cs)
return (take n cs)
else mzero
-- forall is needed to allow scoped type variables
safeToEnum :: forall a. (Enum a, Bounded a) => Int -> Maybe a
safeToEnum n
| maxN < n || minN > n = Nothing
| otherwise = Just $ toEnum n
where maxN = fromEnum (maxBound :: a)
minN = fromEnum (minBound :: a)