From 1c3f85b9a65dc078be8f1648d9f3cfffd5e5e0a6 Mon Sep 17 00:00:00 2001 From: flavis Date: Sat, 4 Apr 2020 00:23:14 +0200 Subject: [PATCH] serialization of piles --- package.yaml | 1 + skat.cabal | 5 +++- src/Skat.hs | 1 - src/Skat/AI/Online.hs | 5 ++++ src/Skat/Card.hs | 19 +++++++++++---- src/Skat/Matches.hs | 4 ++-- src/Skat/Pile.hs | 53 ++++++++++++++++++++++++++++++++++++++++- src/Skat/Preperation.hs | 8 ++++++- src/Skat/Utils.hs | 40 ++++++++++++++++++++++++++++++- 9 files changed, 125 insertions(+), 11 deletions(-) diff --git a/package.yaml b/package.yaml index 4866e6b..c9fa4be 100644 --- a/package.yaml +++ b/package.yaml @@ -34,6 +34,7 @@ dependencies: - containers - case-insensitive - vector +- transformers library: source-dirs: src diff --git a/skat.cabal b/skat.cabal index e53ca43..fc82430 100644 --- a/skat.cabal +++ b/skat.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 9c412ae20820c69f342fb431118c3d2be6a5461e1b5a521d92c1546f163ee94a +-- hash: a181979e99bc6631140cc5973d1714c0b5aa021f74c72938c0ee7ab47b581cf2 name: skat version: 0.1.0.7 @@ -62,6 +62,7 @@ library , random , split , text + , transformers , vector , websockets default-language: Haskell2010 @@ -88,6 +89,7 @@ executable skat-exe , skat , split , text + , transformers , vector , websockets default-language: Haskell2010 @@ -114,6 +116,7 @@ test-suite skat-test , skat , split , text + , transformers , vector , websockets default-language: Haskell2010 diff --git a/src/Skat.hs b/src/Skat.hs index 112e341..5ff06c2 100644 --- a/src/Skat.hs +++ b/src/Skat.hs @@ -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]) diff --git a/src/Skat/AI/Online.hs b/src/Skat/AI/Online.hs index 05eb944..baade37 100644 --- a/src/Skat/AI/Online.hs +++ b/src/Skat/AI/Online.hs @@ -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 diff --git a/src/Skat/Card.hs b/src/Skat/Card.hs index 2ac33eb..2547305 100644 --- a/src/Skat/Card.hs +++ b/src/Skat/Card.hs @@ -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 diff --git a/src/Skat/Matches.hs b/src/Skat/Matches.hs index b0f02c9..ad33d71 100644 --- a/src/Skat/Matches.hs +++ b/src/Skat/Matches.hs @@ -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 diff --git a/src/Skat/Pile.hs b/src/Skat/Pile.hs index ed760ed..d874773 100644 --- a/src/Skat/Pile.hs +++ b/src/Skat/Pile.hs @@ -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) diff --git a/src/Skat/Preperation.hs b/src/Skat/Preperation.hs index 3900772..35827f7 100644 --- a/src/Skat/Preperation.hs +++ b/src/Skat/Preperation.hs @@ -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 diff --git a/src/Skat/Utils.hs b/src/Skat/Utils.hs index 4f641ee..03a1ee6 100644 --- a/src/Skat/Utils.hs +++ b/src/Skat/Utils.hs @@ -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)