add debug info to ai

.gitignore

@@ -2,8 +2,13 @@
 
 !*.*
 !*/
+!LICENSE
 
 *.hi
 *.o
 *.prof
 *.hp
+
+# ignore stack work files
+.stack-work/
+stack.yaml.lock

AI/Test.hs

@@ -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

AI/Test2.hs

@@ -1,5 +0,0 @@
-import AI.Rulebased
-import Pile
-
-main :: IO ()
-main = print $ length $ simplify Hand3 testds

ChangeLog.md

@@ -0,0 +1,3 @@
+# Changelog for skat
+
+## Unreleased changes

LICENSE

@@ -0,0 +1,30 @@
+Copyright Author name here (c) 2019
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Author name here nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

README.md

@@ -0,0 +1,4 @@
+# Skat
+
+This is a Haskell implementation of the famous german card game Skat. It provides
+a library implementing all the game mechanics and a simple AI.

Reizen.hs

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

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 Skat.Card
-import Player
+import Skat.Operations
-import Pile
+import Skat.Player
+import Skat.Pile
 
-import AI.Stupid
+import Skat.AI.Stupid
-import AI.Human
+import Skat.AI.Online
-import AI.Rulebased
+import Skat.AI.Rulebased
 
 main :: IO ()
 main = testAI 10
@@ -28,7 +33,10 @@ 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
+            return pts
         else runAI
 
 env :: SkatEnv
@@ -66,3 +74,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

package.yaml

@@ -0,0 +1,60 @@
+name:                skat
+version:             0.1.0.1
+github:              "githubuser/skat"
+license:             BSD3
+author:              "flavis"
+maintainer:          "christian@flavigny.de"
+copyright:           "2019"
+
+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 Gitea at <https://git.flavigny.de/christian/skat>
+
+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

skat.cabal

@@ -0,0 +1,112 @@
+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: 0d6eafec0c3ba6bb4c0150a39f4dbab784c7a519ec911d0f0344edd1c5d916da
+
+name:           skat
+version:        0.1.0.1
+description:    Please see the README on Gitea at <https://git.flavigny.de/christian/skat>
+homepage:       https://github.com/githubuser/skat#readme
+bug-reports:    https://github.com/githubuser/skat/issues
+author:         flavis
+maintainer:     christian@flavigny.de
+copyright:      2019
+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.Matches
+      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

src/Skat.hs

@@ -8,10 +8,10 @@ import Control.Monad.State
 import Control.Monad.Reader
 import Data.List
 
-import Card
+import Skat.Card
-import Pile
+import Skat.Pile
-import Player (Players)
+import Skat.Player (Players)
-import qualified Player as P
+import qualified Skat.Player as P
 
 data SkatEnv = SkatEnv { piles :: Piles
                        , turnColour :: Maybe Colour

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 Skat.Player
-import Pile
+import Skat.Pile
-import Card
+import Skat.Card
-import Utils
+import Skat.Utils
-import Render
+import Skat.Render
 
 data Human = Human { getTeam :: Team
                    , getHand :: Hand }

src/Skat/AI/Online.hs

@@ -0,0 +1,95 @@
+{-# 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
+    onGameStart p singlePlayer = runReaderT (onStart singlePlayer) 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)
+
+onStart :: MonadPlayer m => Hand -> Online m ()
+onStart singlePlayer = do
+    trCol <- trumpColour
+    ownHand <- asks getHand
+    query (BS.unpack $ encode $ GameStartQuery trCol ownHand singlePlayer)
+    
+data Query = ChooseQuery [Card] [CardS Played]
+           | CardPlayedQuery (CardS Played)
+           | GameResultsQuery Int Int
+           | GameStartQuery Colour Hand Hand
+
+data Response = ChosenResponse Card
+     
+instance ToJSON Query where
+    toJSON (ChooseQuery hand table) =
+        object ["query" .= ("choose_card" :: String), "hand" .= hand, "table" .= table]
+    toJSON (CardPlayedQuery card) =
+        object ["query" .= ("card_played" :: String), "card" .= card]
+    toJSON (GameResultsQuery sgl tm) =
+        object ["query" .= ("results" :: String), "single" .= sgl, "team" .= tm]
+    toJSON (GameStartQuery trumps handNo sglPlayer) =
+        object ["query" .= ("start_game" :: String), "trumps" .= show trumps,
+                "hand" .= toInt handNo, "single" .= toInt sglPlayer]
+
+instance FromJSON Response where
+    parseJSON = withObject "ChosenResponse" $ \v -> ChosenResponse
+        <$> v .: "card"

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 Skat.Player
-import qualified Player.Utils as P
+import qualified Skat.Player.Utils as P
-import Pile
+import Skat.Pile
-import Card
+import Skat.Card
-import Utils
+import Skat.Utils
 import Skat (Skat, modifyp, mkSkatEnv) 
-import Operations
+import Skat.Operations
 
 data AIEnv = AIEnv { getTeam :: Team
                    , getHand :: Hand
@@ -250,7 +250,7 @@ chooseStatistic = do
                     3 -> 3
                     -- simulate only partially
                     4 -> 3
-                    5 -> 2
+                    5 -> 3
                     6 -> 2
                     7 -> 1
                     8 -> 1
@@ -277,6 +277,7 @@ chooseStatistic = do
         limit = if depth == 1 && length table == 2
             then 1
             else min 10000 $ realDisNo `div` 2
+    liftIO $ putStrLn $ "players hand" ++ show handCards
     liftIO $ putStrLn $ "possible distrs without simp " ++ show realDisNo
     liftIO $ putStrLn $ "possible distrs " ++ show reducedDisNo
     vals <- M.toList <$> foldWithLimit limit runOnPiles M.empty piless
@@ -307,6 +308,7 @@ chooseOpen = do
     piles <- showPiles
     hand <- gets getHand
     let myCards = handCards hand piles
+    liftIO $ putStrLn $ show hand ++ " chooses from " ++ show myCards
     possible <- filterM (P.isAllowed myCards) myCards
     case length myCards of
         0 -> do
@@ -329,6 +331,7 @@ chooseSimulating = do
             results <- mapM simulate cs
             let both = zip results cs
                 best = maximumBy (comparing fst) both
+            liftIO $ putStrLn $ "results " ++ show both
             return $ snd best
 
 simulate :: (MonadState AIEnv m, MonadPlayerOpen m)
@@ -341,6 +344,7 @@ simulate card = do
     myTeam <- gets getTeam
     myHand <- gets getHand
     depth <- gets simulationDepth
+    liftIO $ putStrLn $ "simulate: " ++ show myHand ++ " plays " ++ show card
     let newDepth = depth - 1
         -- create a virtual env with 3 ai players
         ps = Players
@@ -364,7 +368,8 @@ predictValue (own, others) = do
     piles <- showPiles
     let cs = handCards hand piles
     pot <- potential cs
-    return $ own + pot
+    --return $ own + pot
+    return (own-others)
 
 potential :: (MonadState AIEnv m, MonadPlayerOpen m)
           => [Card] -> m Int
@@ -383,7 +388,7 @@ position card = do
     let effCol = effectiveColour tr card
         l = M.toList guess
         cs = filterMap ((==effCol) . effectiveColour tr . fst) fst l
-        csInd = zip [0..] cs
+        csInd = zip [0..] (reverse cs)
         Just (pos, _) = find ((== card) . snd) csInd
     return pos
 
@@ -401,8 +406,11 @@ chooseLead :: (MonadState AIEnv m, MonadPlayer m) => m Card
 chooseLead = do
     cards <- gets myHand
     possible <- filterM (P.isAllowed cards) cards
+    liftIO $ putStrLn $ "choosing lead from " ++ show possible
     pots <- mapM leadPotential possible
-    return $ snd $ maximumBy (comparing fst) (zip pots possible)
+    let ps = zip pots possible
+    liftIO $ putStrLn $ "lead potential of cards " ++ show ps
+    return $ snd $ maximumBy (comparing fst) ps
 
 mkAIEnv :: Team -> Hand -> Int -> AIEnv
 mkAIEnv tm h depth = AIEnv tm h [] [] [] newGuess depth

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

src/Skat/AI/Stupid.hs

@@ -1,8 +1,8 @@
-module AI.Stupid where
+module Skat.AI.Stupid where
 
-import Player
+import Skat.Player
-import Pile
+import Skat.Pile
-import Card
+import Skat.Card
 
 data Stupid = Stupid { getTeam :: Team
                      , getHand :: Hand }

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 System.Random (newStdGen)
+import Data.Aeson
-import Utils
+import System.Random (newStdGen, StdGen)
 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
 
@@ -110,6 +123,9 @@ shuffleCards = do
     gen <- newStdGen
     return $ shuffle gen allCards
 
+shuffleCardsWithGen :: StdGen -> [Card]
+shuffleCardsWithGen gen = shuffle gen allCards
+
 -- TESTING VARS
 
 c1 :: Card

src/Skat/Matches.hs

@@ -0,0 +1,44 @@
+module Skat.Matches (
+    singleVsBots
+) where
+
+import Control.Monad.State
+import System.Random (mkStdGen)
+
+import Skat
+import Skat.Operations
+import Skat.Player
+import Skat.Pile
+import Skat.Card
+
+import Skat.AI.Rulebased
+import Skat.AI.Online
+import Skat.AI.Stupid
+
+-- | predefined card distribution for testing purposes
+cardDistr :: Piles
+cardDistr = Piles hands [] (map (putAt SkatP) skt)
+    where hand3 = [Card Ace Spades, Card Jack Diamonds, Card Jack Clubs, Card King Spades,
+                   Card Nine Spades, Card Ace Diamonds, Card Queen Diamonds, Card Ten Clubs,
+                   Card Eight Clubs, Card King Clubs]
+          hand1 = [Card Jack Spades, Card Jack Hearts, Card Ten Spades, Card Ace Hearts, Card Ten Hearts,
+                   Card Nine Hearts, Card Seven Clubs, Card Ace Clubs, Card King Diamonds,
+                   Card Ten Diamonds]
+          hand2 = [Card Eight Spades, Card Queen Spades, Card Seven Spades, Card Seven Diamonds,
+                   Card Seven Hearts, Card Eight Hearts, Card Queen Hearts, Card King Hearts,
+                   Card Nine Diamonds, Card Eight Diamonds]
+          hands = map (putAt Hand1) hand1
+            ++ map (putAt Hand2) hand2
+            ++ map (putAt Hand3) hand3
+          skt = [Card Nine Clubs, Card Queen Clubs]
+
+singleVsBots :: (Team -> Hand -> OnlineEnv) -> IO ()
+singleVsBots mkPlayer = do
+    --let gen = mkStdGen 123
+    --    cards = shuffleCardsWithGen gen
+    let ps = Players
+                (PL $ mkPlayer Team Hand1)
+                (PL $ Stupid Team Hand2)
+                (PL $ mkAIEnv Single Hand3 10)
+        env = SkatEnv cardDistr Nothing Spades ps
+    liftIO $ evalStateT (publishGameStart Hand3 >> turn Hand1 >>= publishGameResults) env

src/Skat/Operations.hs

@@ -1,16 +1,19 @@
-module Operations where
+module Skat.Operations (
+    turn, turnGeneric, play, playOpen, publishGameResults,
+    publishGameStart
+) where
 
 import Control.Monad.State
 import System.Random (newStdGen, randoms)
 import Data.List
 import Data.Ord
 
-import Card
 import Skat
-import Pile
+import Skat.Card
-import Player (chooseCard, Players(..), Player(..), PL(..),
+import Skat.Pile
-    updatePlayer, playersToList, player)
+import Skat.Player (chooseCard, Players(..), Player(..), PL(..),
-import Utils (shuffle)
+    updatePlayer, playersToList, player, MonadPlayer)
+import Skat.Utils (shuffle)
 
 compareRender :: Card -> Card -> Ordering
 compareRender (Card t1 c1) (Card t2 c2) = case compare c1 c2 of
@@ -86,3 +89,13 @@ playOpen p = do
     card <- chooseCardOpen p
     modifyp $ playCard card
     return card
+
+publishGameResults :: (Int, Int) -> Skat ()
+publishGameResults res = do
+    pls <- gets players
+    mapM_ (\p -> onGameResults p res) (playersToList pls)
+
+publishGameStart :: Hand -> Skat ()
+publishGameStart sglPlayer = do
+    pls <- gets players
+    mapM_ (\p -> onGameStart p sglPlayer) (playersToList pls)

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 Data.Aeson
-import Card
-import Utils
 import Control.Exception
 
+import Skat.Card
+import Skat.Utils
+
 data Team = Team | Single
             deriving (Show, Eq, Ord, Enum)
 
@@ -19,9 +21,18 @@ 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)
 
+toInt :: Hand -> Int
+toInt Hand1 = 1
+toInt Hand2 = 2
+toInt Hand3 = 3
+
 next :: Hand -> Hand
 next Hand1 = Hand2
 next Hand2 = Hand3
@@ -36,6 +47,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)
 

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 Skat.Card
-import Pile
+import Skat.Pile
 
 class (Monad m, MonadIO m) => MonadPlayer m where
     trumpColour :: m Colour
@@ -38,6 +38,16 @@ 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 ()
+    onGameStart :: MonadPlayer m
+                => p
+                -> Hand
+                -> m ()
+    onGameStart _ _ = return ()
 
 data PL = forall p. (Show p, Player p) => PL p
 
@@ -54,6 +64,8 @@ instance Player PL where
         v <- onCardPlayed p card
         return $ PL v
     chooseCardOpen (PL p) = chooseCardOpen p
+    onGameResults (PL p) res = onGameResults p res
+    onGameStart (PL p) singlePlayer = onGameStart p singlePlayer
 
 data Players = Players PL PL PL
                deriving Show

src/Skat/Player/Utils.hs

@@ -1,10 +1,10 @@
-module Player.Utils (
+module Skat.Player.Utils (
     isAllowed, isTrump
 ) where
 
-import Player
+import Skat.Player
-import qualified Card as C
+import qualified Skat.Card as C
-import Card (Card)
+import Skat.Card (Card)
 
 isAllowed :: MonadPlayer m => [Card] -> Card -> m Bool
 isAllowed hand card = do

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

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

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

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

test/Spec.hs

@@ -0,0 +1,2 @@
+main :: IO ()
+main = putStrLn "Test suite not yet implemented"