add socket server

.gitignore

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

AI/Human.hs

@@ -1,12 +1,12 @@
-module Skat.AI.Human where
+module AI.Human where
 
 import Control.Monad.Trans (liftIO)
 
-import Skat.Player
-import Skat.Pile
-import Skat.Card
-import Skat.Utils
-import Skat.Render
+import Player
+import Pile
+import Card
+import Utils
+import Render
 
 data Human = Human { getTeam :: Team
                    , getHand :: Hand }

AI/Rulebased.hs

@@ -3,7 +3,7 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE FlexibleContexts #-}
 
-module Skat.AI.Rulebased (
+module 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 Skat.Player
-import qualified Skat.Player.Utils as P
-import Skat.Pile
-import Skat.Card
-import Skat.Utils
+import Player
+import qualified Player.Utils as P
+import Pile
+import Card
+import Utils
 import Skat (Skat, modifyp, mkSkatEnv) 
-import Skat.Operations
+import Operations
 
 data AIEnv = AIEnv { getTeam :: Team
                    , getHand :: Hand
@@ -250,7 +250,7 @@ chooseStatistic = do
                     3 -> 3
                     -- simulate only partially
                     4 -> 3
-                    5 -> 3
+                    5 -> 2
                     6 -> 2
                     7 -> 1
                     8 -> 1
@@ -277,7 +277,6 @@ 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
@@ -308,7 +307,6 @@ 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
@@ -331,7 +329,6 @@ 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)
@@ -344,7 +341,6 @@ 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
@@ -368,8 +364,7 @@ predictValue (own, others) = do
     piles <- showPiles
     let cs = handCards hand piles
     pot <- potential cs
-    --return $ own + pot
-    return (own-others)
+    return $ own + pot
 
 potential :: (MonadState AIEnv m, MonadPlayerOpen m)
           => [Card] -> m Int
@@ -388,7 +383,7 @@ position card = do
     let effCol = effectiveColour tr card
         l = M.toList guess
         cs = filterMap ((==effCol) . effectiveColour tr . fst) fst l
-        csInd = zip [0..] (reverse cs)
+        csInd = zip [0..] cs
         Just (pos, _) = find ((== card) . snd) csInd
     return pos
 
@@ -406,11 +401,8 @@ 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
-    let ps = zip pots possible
-    liftIO $ putStrLn $ "lead potential of cards " ++ show ps
-    return $ snd $ maximumBy (comparing fst) ps
+    return $ snd $ maximumBy (comparing fst) (zip pots possible)
 
 mkAIEnv :: Team -> Hand -> Int -> AIEnv
 mkAIEnv tm h depth = AIEnv tm h [] [] [] newGuess depth

AI/Server.hs

@@ -1,4 +1,4 @@
-module Skat.AI.Server where
+module AI.Server where
 
 import qualified Network.Socket as Net
 import qualified System.IO as Sys

AI/Socket.hs

@@ -0,0 +1,98 @@
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module AI.Socket (
+    mkSocketEnv
+) where
+
+import Control.Monad.Trans (liftIO)
+import Control.Monad.Reader
+import Control.Monad.State
+import Control.Concurrent
+import Control.Concurrent.Chan
+
+import Player
+import Pile
+import Card
+import Utils
+import Render
+import AI.Server
+
+data SocketEnv = SocketEnv { getTeam :: Team
+                           , getHand :: Hand
+                           , table :: [CardS Played]
+                           , myHand :: [Card]
+                           , socketThread :: Maybe ThreadId
+                           , socketServer :: Maybe ServerEnv }
+                  deriving Show
+
+setTable :: [CardS Played] -> SocketEnv -> SocketEnv
+setTable tab env = env { table = tab }
+
+setHand :: [Card] -> SocketEnv -> SocketEnv
+setHand hand env = env { myHand = hand }
+
+setSocket :: ThreadId -> SocketEnv -> SocketEnv
+setSocket n env = env { socketThread = Just n }
+
+clearSocket :: SocketEnv -> SocketEnv
+clearSocket env = env { socketThread = Nothing }
+
+setServer :: ServerEnv -> SocketEnv -> SocketEnv
+setServer s env = env { socketServer = Just s }
+
+type Socket m = StateT SocketEnv m
+
+instance MonadPlayer m => MonadPlayer (Socket m) where
+    trumpColour = lift $ trumpColour
+    turnColour = lift $ turnColour
+    showSkat = lift . showSkat
+
+instance Player SocketEnv where
+    team = getTeam
+    hand = getHand
+    chooseCard p table _ hand = runStateT (do
+        modify $ setTable table
+        modify $ setHand hand
+        choose) p
+
+choose :: MonadPlayer m => Socket m Card
+choose = do
+    initialize
+    trumpCol <- trumpColour
+    turnCol <- turnColour
+    hand <- gets myHand
+    (Just server) <- gets socketServer
+    liftIO $ writeChan (global server) "hi"
+    let possible = filter (isAllowed trumpCol turnCol hand) hand
+    case length hand of
+        1 -> liftIO (putStrLn "stopping server") >> stop
+        _ -> return ()
+    return $ head possible
+
+initialize :: MonadPlayer m => Socket m ()
+initialize = do
+    state <- gets socketThread
+    case state of
+        Just _ -> return ()
+        Nothing -> do
+            liftIO $ putStrLn "initializing server"
+            server <- liftIO $ initServer 4242 (DelimiterBuffering "\n") sampleHandler
+            n <- liftIO $ forkIO $ runReaderT procRequests server
+            modify $ setSocket n
+            modify $ setServer server
+
+stop :: MonadPlayer m => Socket m ()
+stop = do
+    state <- gets socketThread
+    case state of
+        Just n -> do liftIO $ putStrLn "killing thread"
+                     liftIO $ killThread n
+                     modify clearSocket
+                     Just server <- gets socketServer
+                     liftIO $ close server
+        Nothing -> return ()
+
+mkSocketEnv :: Team -> Hand -> SocketEnv
+mkSocketEnv tm h = SocketEnv tm h [] [] Nothing Nothing

AI/Stupid.hs

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

AI/Test.hs

@@ -0,0 +1,39 @@
+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

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

Card.hs

@@ -1,16 +1,13 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE OverloadedStrings #-}
 
-module Skat.Card where
+module Card where
 
 import Data.List
-import Data.Aeson
-import System.Random (newStdGen, StdGen)
+import System.Random (newStdGen)
+import Utils
 import Control.DeepSeq
 
-import Skat.Utils
-
 class Countable a b where
     count :: a -> b
 
@@ -22,7 +19,7 @@ data Type = Seven
           | Ten
           | Ace
           | Jack
-            deriving (Eq, Ord, Show, Enum, Read)
+            deriving (Eq, Ord, Show, Enum)
 
 instance Countable Type Int where
     count Ace   = 11
@@ -41,16 +38,6 @@ 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
 
@@ -123,9 +110,6 @@ shuffleCards = do
     gen <- newStdGen
     return $ shuffle gen allCards
 
-shuffleCardsWithGen :: StdGen -> [Card]
-shuffleCardsWithGen gen = shuffle gen allCards
-
 -- TESTING VARS
 
 c1 :: Card

ChangeLog.md

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

LICENSE

@@ -1,30 +0,0 @@
-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.

Main.hs

@@ -1,21 +1,16 @@
 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 Skat.Card
-import Skat.Operations
-import Skat.Player
-import Skat.Pile
+import Operations
+import Player
+import Pile
 
-import Skat.AI.Stupid
-import Skat.AI.Online
-import Skat.AI.Rulebased
+import AI.Stupid
+import AI.Socket
+import AI.Rulebased
 
 main :: IO ()
 main = testAI 10
@@ -35,8 +30,7 @@ runAI = do
     if length trs >= 5 && any ((==32) . getID) cs
         then do
             pts <- fst <$> evalStateT (turn Hand1) env
-            -- if pts > 60 then return 1 else return 0
-            return pts
+            if pts > 60 then return 1 else return 0
         else runAI
 
 env :: SkatEnv
@@ -50,7 +44,7 @@ envStupid = SkatEnv piles Nothing Spades pls2
 playersExamp :: Players
 playersExamp = Players
     (PL $ Stupid Team Hand1)
-    (PL $ Stupid Team Hand2)
+    (PL $ mkSocketEnv Team Hand2)
     (PL $ mkAIEnv Single Hand3 10)
 
 pls2 :: Players
@@ -74,14 +68,3 @@ 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

Operations.hs

@@ -1,19 +1,16 @@
-module Skat.Operations (
-    turn, turnGeneric, play, playOpen, publishGameResults,
-    publishGameStart
-) where
+module Operations where
 
 import Control.Monad.State
 import System.Random (newStdGen, randoms)
 import Data.List
 import Data.Ord
 
+import Card
 import Skat
-import Skat.Card
-import Skat.Pile
-import Skat.Player (chooseCard, Players(..), Player(..), PL(..),
-    updatePlayer, playersToList, player, MonadPlayer)
-import Skat.Utils (shuffle)
+import Pile
+import Player (chooseCard, Players(..), Player(..), PL(..),
+    updatePlayer, playersToList, player)
+import Utils (shuffle)
 
 compareRender :: Card -> Card -> Ordering
 compareRender (Card t1 c1) (Card t2 c2) = case compare c1 c2 of
@@ -89,13 +86,3 @@ 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)

Pile.hs

@@ -1,15 +1,13 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE OverloadedStrings #-}
 
-module Skat.Pile where
+module Pile where
 
 import Data.List
-import Data.Aeson
-import Control.Exception
 
-import Skat.Card
-import Skat.Utils
+import Card
+import Utils
+import Control.Exception
 
 data Team = Team | Single
             deriving (Show, Eq, Ord, Enum)
@@ -21,18 +19,9 @@ 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
@@ -47,12 +36,6 @@ 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)
 

Player.hs

@@ -1,11 +1,11 @@
 {-# LANGUAGE ExistentialQuantification #-}
 
-module Skat.Player where
+module Player where
 
 import Control.Monad.IO.Class
 
-import Skat.Card
-import Skat.Pile
+import Card
+import Pile
 
 class (Monad m, MonadIO m) => MonadPlayer m where
     trumpColour :: m Colour
@@ -38,16 +38,6 @@ 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
 
@@ -64,8 +54,6 @@ 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

Player/Utils.hs

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

README.md

@@ -1,4 +0,0 @@
-# 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

@@ -0,0 +1,73 @@
+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)

Render.hs

@@ -1,8 +1,7 @@
-module Skat.Render where
+module 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..]

Skat.hs

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

Utils.hs

@@ -1,9 +1,7 @@
-module Skat.Utils where
+module 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
@@ -42,17 +40,3 @@ 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

package.yaml

@@ -1,60 +0,0 @@
-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

@@ -1,112 +0,0 @@
-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/AI/Online.hs

@@ -1,97 +0,0 @@
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-module Skat.AI.Online where
-
-import Control.Monad.Reader
-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 Communicator a where
-    send :: a -> String -> IO ()
-    receive :: a -> IO String
-
-class Monad m => MonadClient m where
-    query :: String -> m ()
-    response :: m String
-
-data OnlineEnv c = OnlineEnv { getTeam :: Team
-                             , getHand :: Hand
-                             , connection :: c }
-
-instance Show (OnlineEnv c) where
-    show _ = "An online env"
-
-instance Communicator c => Player (OnlineEnv c) 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 a m = ReaderT (OnlineEnv a) m
-
-instance (Communicator c, MonadIO m) => MonadClient (Online c m) where
-    query s = do
-        conn <- asks connection
-        liftIO $ send conn s
-    response = do
-        conn <- asks connection
-        liftIO $ receive conn
-
-instance MonadPlayer m => MonadPlayer (Online a m) where
-    trumpColour = lift $ trumpColour
-    turnColour = lift $ turnColour
-    showSkat = lift . showSkat
-
-choose :: (Communicator c, MonadPlayer m) => [CardS Played] -> [Card] -> Online c 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 :: (Communicator c, MonadPlayer m) => CardS Played -> Online c m ()
-cardPlayed card = query (BS.unpack $ encode $ CardPlayedQuery card)
-
-onResults :: (Communicator c, MonadIO m) => (Int, Int) -> Online c m ()
-onResults (sgl, tm) = query (BS.unpack $ encode $ GameResultsQuery sgl tm)
-
-onStart :: (Communicator c, MonadPlayer m) => Hand -> Online c 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/Matches.hs

@@ -1,44 +0,0 @@
-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 :: Communicator c => c -> IO ()
-singleVsBots comm = do
-    --let gen = mkStdGen 123
-    --    cards = shuffleCardsWithGen gen
-    let ps = Players
-                (PL $ OnlineEnv Team Hand1 comm)
-                (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/WebSocketServer.hs

@@ -1,123 +0,0 @@
-{-# 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

@@ -1,66 +0,0 @@
-# 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

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