diff --git a/.gitignore b/.gitignore index eb9d3cc..b4eb552 100644 --- a/.gitignore +++ b/.gitignore @@ -7,3 +7,7 @@ *.o *.prof *.hp + +# ignore stack work files +.stack-work/ +stack.yaml.lock diff --git a/AI/Test.hs b/AI/Test.hs deleted file mode 100644 index cbcc930..0000000 --- a/AI/Test.hs +++ /dev/null @@ -1,39 +0,0 @@ -import Card -import Pile -import Utils - -import qualified Data.Map.Strict as M -import Data.Monoid ((<>)) - -type Guess = M.Map Card [Hand] -type Distribution = ([Card], [Card], [Card]) - -distributions :: Guess -> [Distribution] -distributions guess = --filter equilibrated - (helper (M.toList guess) (0, 0, 0)) - 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) = - let f card Hand1 = (([card], [], []), (n1+1, n2, n3)) - f card Hand2 = (([], [card], []), (n1, n2+1, n3)) - f card Hand3 = (([], [], [card]), (n1, n2, n3+1)) - isOk Hand1 = n1 < cardsPerHand - isOk Hand2 = n2 < cardsPerHand - isOk Hand3 = n3 < cardsPerHand - in filterMap isOk (f card) hands - equilibrated (cs1, cs2, cs3) = - let ls = [length cs1, length cs2, length cs3] - in (maximum ls - minimum ls) <= 1 - cardsPerHand = (length guess `div` 3) - -testguess :: Guess -testguess = foldr (Hand3 `has`) m (take 10 allCards) - where l = map (\c -> (c, [Hand1, Hand2, Hand3])) (take 30 allCards) - m = M.fromList l - -main :: IO () -main = print $ length $ distributions testguess diff --git a/AI/Test2.hs b/AI/Test2.hs deleted file mode 100644 index 1834a61..0000000 --- a/AI/Test2.hs +++ /dev/null @@ -1,5 +0,0 @@ -import AI.Rulebased -import Pile - -main :: IO () -main = print $ length $ simplify Hand3 testds diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 index 0000000..6d44ac0 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for skat + +## Unreleased changes diff --git a/README.md b/README.md new file mode 100644 index 0000000..41b815a --- /dev/null +++ b/README.md @@ -0,0 +1 @@ +# skat diff --git a/Reizen.hs b/Reizen.hs deleted file mode 100644 index 45fa540..0000000 --- a/Reizen.hs +++ /dev/null @@ -1,73 +0,0 @@ -module Reizen where - -import Skat -import Card -import Utils -import Operations -import Render - -data Reizer = Reizer Index [Card] - deriving Show - -getHand :: Index -> [Reizer] -> [Card] -getHand n rs = let (Reizer _ h) = head $ filter (\(Reizer i cs) -> i == n) rs - in h - -goWith :: [Card] -> Int -> IO Bool -goWith cs n = query $ "Go with " ++ show n - -goUp :: [Card] -> Int -> IO Int -goUp cs n = query $ "Go up " ++ show n - -askColour :: [Card] -> IO Colour -askColour cs = render (sortRender cs) >> query "Trump should be:" - -askSkat :: [Card] -> IO (Card, Card) -askSkat cs_ = do - let cs = sortRender cs_ - render cs - (n1, n2) <- query "Drop two cards:" - if n1 < length cs && n2 < length cs && n1 >= 0 && n2 >= 0 && n1 /= n2 - then return (cs !! n1, cs !! n2) - else askSkat cs - -reizen :: IO SkatEnv -reizen = do - cs <- shuffleCards - let cards = distribute cs - p1 = Reizer One $ findCards Hand1 cards - p2 = Reizer Two $ findCards Hand2 cards - p3 = Reizer Three $ findCards Hand3 cards - skt = findCards SkatP cards - (winner1, new) <- combat p2 p1 0 - (Reizer idx _, _) <- combat p3 winner1 new - let ps = Players (Player (if idx == One then Single else Team) One) - (Player (if idx == Two then Single else Team) Two) - (Player (if idx == Three then Single else Team) Three) - sglHand = playerHand idx - cards' = foldr (\c css -> moveCard c sglHand css) cards skt - trumpCol <- askColour (findCards sglHand cards') - (s1, s2) <- askSkat (findCards sglHand cards') - let cards'' = moveCard s2 WonSingle (moveCard s1 WonSingle cards') - return $ SkatEnv cards'' Nothing trumpCol ps - -combat :: Reizer -> Reizer -> Int -> IO (Reizer, Int) -combat r2@(Reizer p2 h2) r1@(Reizer p1 h1) start = do - -- advantage for h1 (being challenged) - putStrLn $ "Player " ++ show p2 ++ " challenging " ++ show p1 - putStrLn $ "Player " ++ show p2 ++ "'s turn" - new <- goUp h2 start - if new > start - then do - putStrLn $ "Player " ++ show p2 ++ " goes up to " ++ show new - putStrLn $ "Player " ++ show p1 ++ "'s turn" - yes <- goWith h1 new - if yes then combat r2 r1 new - else do - putStrLn $ "Player " ++ show p1 ++ " gives up" - putStrLn $ "Player " ++ show p2 ++ " wins" - return (r2, new) - else do - putStrLn $ "Player " ++ show p2 ++ " gives up" - putStrLn $ "Player " ++ show p1 ++ " wins" - return (r1, start) diff --git a/Main.hs b/app/Main.hs similarity index 68% rename from Main.hs rename to app/Main.hs index 82b2c24..5fa52f5 100644 --- a/Main.hs +++ b/app/Main.hs @@ -1,16 +1,21 @@ module Main where import Control.Monad.State +import Control.Monad.Reader +import Control.Concurrent + +import qualified Network.WebSockets as WS +import qualified Data.ByteString.Lazy.Char8 as BS -import Card import Skat -import Operations -import Player -import Pile +import Skat.Card +import Skat.Operations +import Skat.Player +import Skat.Pile -import AI.Stupid -import AI.Human -import AI.Rulebased +import Skat.AI.Stupid +import Skat.AI.Online +import Skat.AI.Rulebased main :: IO () main = testAI 10 @@ -28,7 +33,9 @@ runAI = do cs = handCards Hand3 ps trs = filter (isTrump Spades) cs if length trs >= 5 && any ((==32) . getID) cs - then fst <$> evalStateT (turn Hand1) env + then do + pts <- fst <$> evalStateT (turn Hand1) env + if pts > 60 then return 1 else return 0 else runAI env :: SkatEnv @@ -66,3 +73,14 @@ env2 = SkatEnv piles Nothing Spades playersExamp h3 = map (putAt Hand3) hand3 piles = Piles (h1 ++ h2 ++ h3) [] [] +runWebSocketServer :: IO () +runWebSocketServer = do + WS.runServer "localhost" 4243 application + +application :: WS.PendingConnection -> IO () +application pending = do + conn <- WS.acceptRequest pending + putStrLn "someone connected" + forever $ do + msg <- WS.receiveData conn + putStrLn $ BS.unpack msg diff --git a/package.yaml b/package.yaml new file mode 100644 index 0000000..d17a689 --- /dev/null +++ b/package.yaml @@ -0,0 +1,60 @@ +name: skat +version: 0.1.0.0 +github: "githubuser/skat" +license: BSD3 +author: "Author name here" +maintainer: "example@example.com" +copyright: "2019 Author name here" + +extra-source-files: +- README.md +- ChangeLog.md + +# Metadata used when publishing your package +# synopsis: Short description of your package +# category: Web + +# To avoid duplicated efforts in documentation and dealing with the +# complications of embedding Haddock markup inside cabal files, it is +# common to point users to the README.md file. +description: Please see the README on GitHub at + +dependencies: +- base >= 4.7 && < 5 +- mtl +- network +- websockets +- split +- bytestring +- text +- random +- deepseq +- aeson +- parallel +- containers +- case-insensitive + +library: + source-dirs: src + +executables: + skat-exe: + main: Main.hs + source-dirs: app + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - skat + +tests: + skat-test: + main: Spec.hs + source-dirs: test + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - skat diff --git a/skat.cabal b/skat.cabal new file mode 100644 index 0000000..2f5a2b7 --- /dev/null +++ b/skat.cabal @@ -0,0 +1,111 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: e2db48733c92b94d7f2d8f4991dd2f7cec26d59666cd3c618710a8a3c22616d0 + +name: skat +version: 0.1.0.0 +description: Please see the README on GitHub at +homepage: https://github.com/githubuser/skat#readme +bug-reports: https://github.com/githubuser/skat/issues +author: Author name here +maintainer: example@example.com +copyright: 2019 Author name here +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/githubuser/skat + +library + exposed-modules: + Skat + Skat.AI.Human + Skat.AI.Online + Skat.AI.Rulebased + Skat.AI.Server + Skat.AI.Stupid + Skat.Card + Skat.Operations + Skat.Pile + Skat.Player + Skat.Player.Utils + Skat.Render + Skat.Utils + Skat.WebSocketServer + other-modules: + Paths_skat + hs-source-dirs: + src + build-depends: + aeson + , base >=4.7 && <5 + , bytestring + , case-insensitive + , containers + , deepseq + , mtl + , network + , parallel + , random + , split + , text + , websockets + default-language: Haskell2010 + +executable skat-exe + main-is: Main.hs + other-modules: + Paths_skat + hs-source-dirs: + app + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + aeson + , base >=4.7 && <5 + , bytestring + , case-insensitive + , containers + , deepseq + , mtl + , network + , parallel + , random + , skat + , split + , text + , websockets + default-language: Haskell2010 + +test-suite skat-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_skat + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + aeson + , base >=4.7 && <5 + , bytestring + , case-insensitive + , containers + , deepseq + , mtl + , network + , parallel + , random + , skat + , split + , text + , websockets + default-language: Haskell2010 diff --git a/Skat.hs b/src/Skat.hs similarity index 92% rename from Skat.hs rename to src/Skat.hs index fe01b78..526c2ce 100644 --- a/Skat.hs +++ b/src/Skat.hs @@ -8,10 +8,10 @@ import Control.Monad.State import Control.Monad.Reader import Data.List -import Card -import Pile -import Player (Players) -import qualified Player as P +import Skat.Card +import Skat.Pile +import Skat.Player (Players) +import qualified Skat.Player as P data SkatEnv = SkatEnv { piles :: Piles , turnColour :: Maybe Colour diff --git a/AI/Human.hs b/src/Skat/AI/Human.hs similarity index 88% rename from AI/Human.hs rename to src/Skat/AI/Human.hs index 5b817d9..991dc6a 100644 --- a/AI/Human.hs +++ b/src/Skat/AI/Human.hs @@ -1,12 +1,12 @@ -module AI.Human where +module Skat.AI.Human where import Control.Monad.Trans (liftIO) -import Player -import Pile -import Card -import Utils -import Render +import Skat.Player +import Skat.Pile +import Skat.Card +import Skat.Utils +import Skat.Render data Human = Human { getTeam :: Team , getHand :: Hand } diff --git a/src/Skat/AI/Online.hs b/src/Skat/AI/Online.hs new file mode 100644 index 0000000..63f1ca1 --- /dev/null +++ b/src/Skat/AI/Online.hs @@ -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" diff --git a/AI/Rulebased.hs b/src/Skat/AI/Rulebased.hs similarity index 98% rename from AI/Rulebased.hs rename to src/Skat/AI/Rulebased.hs index 636d8f3..bb82aef 100644 --- a/AI/Rulebased.hs +++ b/src/Skat/AI/Rulebased.hs @@ -3,7 +3,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} -module AI.Rulebased ( +module Skat.AI.Rulebased ( mkAIEnv, testds, simplify ) where @@ -17,13 +17,13 @@ import Control.Monad.State import Control.Monad.Reader import qualified Data.Map.Strict as M -import Player -import qualified Player.Utils as P -import Pile -import Card -import Utils +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 Operations +import Skat.Operations data AIEnv = AIEnv { getTeam :: Team , getHand :: Hand diff --git a/src/Skat/AI/Server.hs b/src/Skat/AI/Server.hs new file mode 100644 index 0000000..a0ac766 --- /dev/null +++ b/src/Skat/AI/Server.hs @@ -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 diff --git a/AI/Stupid.hs b/src/Skat/AI/Stupid.hs similarity index 82% rename from AI/Stupid.hs rename to src/Skat/AI/Stupid.hs index 7e8e2f7..1214be0 100644 --- a/AI/Stupid.hs +++ b/src/Skat/AI/Stupid.hs @@ -1,8 +1,8 @@ -module AI.Stupid where +module Skat.AI.Stupid where -import Player -import Pile -import Card +import Skat.Player +import Skat.Pile +import Skat.Card data Stupid = Stupid { getTeam :: Team , getHand :: Hand } diff --git a/Card.hs b/src/Skat/Card.hs similarity index 88% rename from Card.hs rename to src/Skat/Card.hs index d7cf155..8e4ec21 100644 --- a/Card.hs +++ b/src/Skat/Card.hs @@ -1,13 +1,16 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} -module Card where +module Skat.Card where import Data.List +import Data.Aeson import System.Random (newStdGen) -import Utils import Control.DeepSeq +import Skat.Utils + class Countable a b where count :: a -> b @@ -19,7 +22,7 @@ data Type = Seven | Ten | Ace | Jack - deriving (Eq, Ord, Show, Enum) + deriving (Eq, Ord, Show, Enum, Read) instance Countable Type Int where count Ace = 11 @@ -38,6 +41,16 @@ data Colour = Diamonds 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 diff --git a/src/Skat/Operations.hs b/src/Skat/Operations.hs new file mode 100644 index 0000000..68e53a2 --- /dev/null +++ b/src/Skat/Operations.hs @@ -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 diff --git a/Pile.hs b/src/Skat/Pile.hs similarity index 86% rename from Pile.hs rename to src/Skat/Pile.hs index 08eb448..9635580 100644 --- a/Pile.hs +++ b/src/Skat/Pile.hs @@ -1,14 +1,16 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} -module Pile where +module Skat.Pile where import Data.List - -import Card -import Utils +import Data.Aeson import Control.Exception +import Skat.Card +import Skat.Utils + data Team = Team | Single deriving (Show, Eq, Ord, Enum) @@ -19,6 +21,10 @@ data CardS p = CardS { getCard :: Card 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) @@ -36,6 +42,12 @@ 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) diff --git a/Player.hs b/src/Skat/Player.hs similarity index 88% rename from Player.hs rename to src/Skat/Player.hs index f2eaaf9..17a09c6 100644 --- a/Player.hs +++ b/src/Skat/Player.hs @@ -1,11 +1,11 @@ {-# LANGUAGE ExistentialQuantification #-} -module Player where +module Skat.Player where import Control.Monad.IO.Class -import Card -import Pile +import Skat.Card +import Skat.Pile class (Monad m, MonadIO m) => MonadPlayer m where trumpColour :: m Colour @@ -38,6 +38,11 @@ class Player p where 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 @@ -54,6 +59,7 @@ instance Player PL where 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 diff --git a/Player/Utils.hs b/src/Skat/Player/Utils.hs similarity index 76% rename from Player/Utils.hs rename to src/Skat/Player/Utils.hs index 39a8a91..9010f41 100644 --- a/Player/Utils.hs +++ b/src/Skat/Player/Utils.hs @@ -1,10 +1,10 @@ -module Player.Utils ( +module Skat.Player.Utils ( isAllowed, isTrump ) where -import Player -import qualified Card as C -import Card (Card) +import Skat.Player +import qualified Skat.Card as C +import Skat.Card (Card) isAllowed :: MonadPlayer m => [Card] -> Card -> m Bool isAllowed hand card = do diff --git a/Render.hs b/src/Skat/Render.hs similarity index 75% rename from Render.hs rename to src/Skat/Render.hs index 9924af5..3f88b35 100644 --- a/Render.hs +++ b/src/Skat/Render.hs @@ -1,7 +1,8 @@ -module Render where +module Skat.Render where -import Card import Data.List +import Skat.Card + render :: [Card] -> IO () render = putStrLn . intercalate "\n" . zipWith (\n c -> show n ++ ") " ++ show c) [0..] diff --git a/Utils.hs b/src/Skat/Utils.hs similarity index 71% rename from Utils.hs rename to src/Skat/Utils.hs index 744f43c..352552d 100644 --- a/Utils.hs +++ b/src/Skat/Utils.hs @@ -1,7 +1,9 @@ -module Utils where +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 @@ -40,3 +42,17 @@ filterMap pred f as = foldr g [] as 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 diff --git a/src/Skat/WebSocketServer.hs b/src/Skat/WebSocketServer.hs new file mode 100644 index 0000000..47e09b0 --- /dev/null +++ b/src/Skat/WebSocketServer.hs @@ -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 diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..4c13e9f --- /dev/null +++ b/stack.yaml @@ -0,0 +1,66 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# https://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# +# The location of a snapshot can be provided as a file or url. Stack assumes +# a snapshot provided as a file might change, whereas a url resource does not. +# +# resolver: ./custom-snapshot.yaml +# resolver: https://example.com/snapshots/2018-01-01.yaml +resolver: lts-14.3 + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# subdirs: +# - auto-update +# - wai +packages: +- . +# Dependency packages to be pulled from upstream that are not in the resolver. +# These entries can reference officially published versions as well as +# forks / in-progress versions pinned to a git hash. For example: +# +# extra-deps: +# - acme-missiles-0.3 +# - git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# +# extra-deps: [] + +# Override default flag values for local packages and extra-deps +# flags: {} + +# Extra package databases containing global packages +# extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=2.1" +# +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 index 0000000..cd4753f --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"