serialization of piles

package.yaml

@@ -34,6 +34,7 @@ dependencies:
 - containers
 - case-insensitive
 - vector
+- transformers
 
 library:
   source-dirs: src

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

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

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

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

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

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)

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

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)