introduce stack build system and restructure code

.gitignore

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

Card.hs

@@ -1,169 +0,0 @@
-module Card where
-
-import Data.List
-import Utils
-
-data Type = Seven
-          | Eight
-          | Nine
-          | Queen
-          | King
-          | Ten
-          | Ace
-          | Jack
-            deriving (Eq, Ord, Show, Enum)
-
-countType :: Type -> Int
-countType Ace   = 11
-countType Ten   = 10
-countType King  = 4
-countType Queen = 3
-countType Jack  = 2
-countType _     = 0
-
-data Colour = Diamonds
-            | Hearts
-            | Spades
-            | Clubs
-              deriving (Eq, Ord, Show, Enum, Read)
-
-data Card = Card Type Colour
-            deriving (Eq, Show)
-
-countCard :: Card -> Int
-countCard (Card t _) = countType t
-
-count :: [Card] -> Int
-count = sum . map countCard
-
-data Team = Team | Single
-            deriving (Show, Eq, Ord, Enum)
-
-data Space = Table | Hand1 | Hand2 | Hand3 | WonTeam | WonSingle | SkatP
-             deriving (Show, Eq, Ord, Enum)
-
-teamPile :: Team -> Space
-teamPile Team = WonTeam
-teamPile Single = WonSingle
-
-playerHand :: Index -> Space
-playerHand One = Hand1
-playerHand Two = Hand2
-playerHand Three = Hand3
-
-playerOfHand :: Space -> Index
-playerOfHand Hand1 = One
-playerOfHand Hand2 = Two
-playerOfHand Hand3 = Three
-
-data CardS = CardS { getCard :: Card
-                   , getSpace :: Space
-                   , getOwner :: Space }
-             deriving (Show, Eq)
-
-moveCard :: Card -> Space -> [CardS] -> [CardS]
-moveCard card sp cards = map f cards
-    where f c = if card == getCard c then c { getSpace = sp } else c
-
-findCards :: Space -> [CardS] -> [Card]
-findCards sp cards = foldr f [] cards
-    where f (CardS c s _) cs
-                | s == sp   = c : cs 
-                | otherwise = cs
-
-data Index = One | Two | Three
-             deriving (Show, Ord, Eq, Enum)
-
-next :: Index -> Index
-next One = Two
-next Two = Three
-next Three = One
-
-prev :: Index -> Index
-prev One = Three
-prev Two = One
-prev Three = Two
-
-data Player = Player { team :: Team
-                     , index :: Index }
-              deriving Show
-
-data Players = Players Player Player Player
-               deriving Show
-
-player :: Players -> Index -> Player
-player (Players p _ _) One   = p
-player (Players _ p _) Two   = p
-player (Players _ _ p) Three = p
-
-type Hand = [Card]
-
-equals :: Colour -> Maybe Colour -> Bool
-equals col (Just x) = col == x
-equals col Nothing = True
-
-isTrump :: Colour -> Card -> Bool
-isTrump trumpCol (Card tp col)
-    | tp == Jack = True
-    | otherwise = col == trumpCol
-
-effectiveColour :: Colour -> Card -> Colour
-effectiveColour trumpCol card@(Card _ col) =
-    if trump then trumpCol else col
-  where trump = isTrump trumpCol card
-
-isAllowed :: Colour -> Maybe Colour -> Hand -> Card -> Bool
-isAllowed trumpCol turnCol cs card =
-    if col `equals` turnCol
-        then True
-        else not $ any (\ca -> effectiveColour trumpCol ca `equals` turnCol && ca /= card) cs
-  where col = effectiveColour trumpCol card
-
-putAt :: Space -> Card -> CardS
-putAt sp c = CardS c sp sp
-
-distribute :: [Card] -> [CardS]
-distribute cards = map (putAt Hand1) hand1
-        ++ map (putAt Hand2) hand2
-        ++ map (putAt Hand3) hand3
-        ++ map (putAt SkatP) skt
-    where round1 = chunksOf 3 (take 9 cards)
-          skt = take 2 $ drop 9 cards
-          round2 = chunksOf 4 (take 12 $ drop 11 cards)
-          round3 = chunksOf 3 (take 9 $ drop 23 cards)
-          hand1 = concatMap (!! 0) [round1, round2, round3]
-          hand2 = concatMap (!! 1) [round1, round2, round3]
-          hand3 = concatMap (!! 2) [round1, round2, round3]
-
-playersFromTable :: Players -> [CardS] -> [Player]
-playersFromTable ps = map (player ps . playerOfHand . getOwner)
-
--- TESTING VARS
-
-c1 :: Card
-c1 = Card Jack Spades
-
-c2 :: Card
-c2 = Card Ace Diamonds
-
-c3 :: Card
-c3 = Card Queen Diamonds
-
-c4 :: Card
-c4 = Card Queen Hearts
-
-c5 :: Card
-c5 = Card Jack Clubs
-
-h1 :: Hand
-h1 = [c1,c2,c3,c4,c5]
-
-allCards :: [Card]
-allCards = [ Card t c | t <- tps, c <- cols ]
-    where tps = [Seven .. Jack]
-          cols = [Diamonds .. Clubs]
-
-distributePutSkat :: [Card] -> [CardS]
-distributePutSkat cards = foldr (\c m -> moveCard c WonSingle m) distributed skt
-    where distributed = distribute cards
-          skt = findCards SkatP distributed

ChangeLog.md

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

Main.hs

@@ -1,16 +0,0 @@
-module Main where
-
-import Control.Monad.State
-
-import Card
-import Skat
-import Reizen
-import Operations
-
-
-main :: IO ()
-main = do
-    env <- reizen
-    (sgl, tm) <- evalStateT runGame env
-    putStrLn $ "Single player has " ++ show sgl ++ " points."
-    putStrLn $ "Team has " ++ show tm ++ " points."

Operations.hs

@@ -7,28 +7,11 @@ import Data.Ord
 
 import Card
 import Skat
+import Pile
+import Player (chooseCard, Players(..), Player(..), PL(..),
+    updatePlayer, playersToList, player)
 import Utils (shuffle)
 
-compareCards :: Colour
-             -> Maybe Colour
-             -> Card
-             -> Card
-             -> Ordering
-compareCards _ _ (Card Jack col1) (Card Jack col2) = compare col1 col2
-compareCards trumpCol turnCol c1@(Card tp1 col1) c2@(Card tp2 col2) =
-    case compare trp1 trp2 of
-        EQ ->
-            case compare (col1 `equals` turnCol)
-                         (col2 `equals` turnCol) of
-                EQ -> compare tp1 tp2
-                v -> v
-        v  -> v
-  where trp1 = isTrump trumpCol c1
-        trp2 = isTrump trumpCol c2
-
-sortCards :: Colour -> Maybe Colour -> [Card] -> [Card]
-sortCards trumpCol turnCol cs = sortBy (compareCards trumpCol turnCol) cs
-
 compareRender :: Card -> Card -> Ordering
 compareRender (Card t1 c1) (Card t2 c2) = case compare c1 c2 of
     EQ -> compare t1 t2
@@ -37,167 +20,69 @@ compareRender (Card t1 c1) (Card t2 c2) = case compare c1 c2 of
 sortRender :: [Card] -> [Card]
 sortRender = sortBy compareRender
 
--- | finishes the calculation of a match
-turning :: Index -> Skat (Int, Int)
-turning n = undefined
-
-turn2 :: Index -> Skat (Int, Int)
-turn2 n = do
-    t <- table
+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 <- cardsAt (playerHand $ index p)
-    if length hand == 0
-        then countGame
-        else case length t of
-            0 -> play p >> turn2 (next n)
+    hand <- getp $ handCards n
+    trCol <- gets trumpColour
+    case length table of
+        0 -> playFunc p >> turnGeneric playFunc depth (next n)
         1 -> do
-                modify (setTurnColour . f . head $ t)
-                play p
-                turn2 (next n)
-            2 -> play p >> evaluateTable >>= turn2
-            3 -> evaluateTable >>= turn2
-   where f (Card _ col) = Just col
-
-simulate :: Team -> Index -> Skat (Int, Int)
-simulate team n = do
-    t <- table
-    ps <- gets players
-    let p = player ps n
-    hand <- cardsAt (playerHand $ index p)
-    if length hand == 0
+            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 case length t of
-            0 -> playOpen team p >> simulate team (next n)
-            1 -> do
-                modify (setTurnColour . f . head $ t)
-                playOpen team p
-                simulate team (next n)
-            2 -> playOpen team p >> evaluateTable >>= simulate team
-            3 -> evaluateTable >>= simulate team
-   where f (Card _ col) = Just col
+                else turnGeneric playFunc (depth - 1) w
 
-evaluateTable :: Skat Index
+turn :: Hand -> Skat (Int, Int)
+turn n = turnGeneric play 10 n
+
+evaluateTable :: Skat Hand
 evaluateTable = do
     trumpCol <- gets trumpColour
     turnCol <- gets turnColour
-    t <- table
-    ts <- tableS
+    table <- getp tableCards
     ps <- gets players
-    let psOrdered = playersFromTable ps ts
-        l = zip psOrdered t
-        g a b = compareCards trumpCol turnCol (snd a) (snd b)
-        (winner, _) = last (sortBy g l)
-        pile = teamPile $ team winner
-    forM t (\c -> move c pile)
+    let winningCard = highestCard trumpCol turnCol table
+    Just winnerHand <- getp $ originOfCard winningCard
+    let winner = player ps winnerHand
+    modifyp $ cleanTable (team winner)
     modify $ setTurnColour Nothing
-    return $ index winner
+    return $ hand winner
 
 countGame :: Skat (Int, Int)
-countGame = do
-    sgl <- count <$> cardsAt WonSingle
-    tm <- count <$> cardsAt WonTeam
-    return (sgl, tm)
+countGame = getp count
 
-turn :: Index -> Skat Index
-turn n = do
-    ps <- gets players
-    let p1 = player ps n
-        p2 = player ps (next n)
-        p3 = player ps (next $ next n)
-    c1@(Card _ col) <- play p1
-    modify $ setTurnColour (Just col)
-    c2 <- play p2
-    c3 <- play p3
-    trumpCol <- gets trumpColour
-    turnCol <- gets turnColour
-    let l = zip3 [p1, p2, p3] [c1, c2, c3] [n, next n, next $ next n]
-        g a b = compareCards trumpCol turnCol (f a) (f b)
-        (winner, _, idx) = last (sortBy g l)
-        pile = teamPile $ team winner
-    move c1 pile
-    move c2 pile
-    move c3 pile
-    modify $ setTurnColour Nothing
-    return idx
- where f (_, x, _) = x
-
-play :: Player -> Skat Card
+play :: (Show p, Player p) => p -> Skat Card
 play p = do
-    table <- table
+    liftIO $ putStrLn "playing"
+    table <- getp tableCardsS
     turnCol <- gets turnColour
     trump <- gets trumpColour
-    hand <- cardsAt (playerHand $ index p)
-    let card = playCard p table hand trump turnCol
-    move card Table
+    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 :: Team -> Player -> Skat Card
-playOpen team p = do
-    card <- playCardOpenAI team p
-    move card Table
+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
-
--- | cheating AI that knows all cards (open play)
-playCardOpenAI :: Team -> Player -> Skat Card
-playCardOpenAI team p = do
-    table <- table
-    turnCol <- gets turnColour
-    trump <- gets trumpColour
-    hand <- cardsAt (playerHand $ index p)
-    let possible = filter (isAllowed trump turnCol hand) hand
-        ownResult = if team == Single then fst else snd
-        ownIdx = index p
-    results <- forM possible (\card -> do
-        move card Table
-        val <- ownResult <$> simulate team ownIdx
-        move card (playerHand $ index p)
-        return (val, card))
-    return $ snd $ maximumBy (comparing fst) results
-
-playCard :: Player
-         -> [Card]
-         -> [Card]
-         -> Colour
-         -> Maybe Colour
-         -> Card
-playCard p table hand trump turnCol = head possible
-    where possible = filter (isAllowed trump turnCol hand) hand
-
-runGame :: Skat (Int, Int)
-runGame = do
-    foldM_ (\i _ -> turn i) One [1..10]
-    sgl <- fmap count $ cardsAt WonSingle
-    tm <- fmap count $ cardsAt WonTeam
-    return (sgl, tm)
-
-shuffleCards :: IO [Card]
-shuffleCards = do
-    gen <- newStdGen
-    return $ shuffle gen allCards
-
--- TESTING VARS
-
-env :: SkatEnv
-env = SkatEnv cards Nothing Spades playersExamp
-    where hand1 = take 10 allCards
-          hand2 = take 10 $ drop 10 allCards
-          hand3 = take 10 $ drop 20 allCards
-          skt = drop 30 allCards
-          cards = map (putAt Hand1) hand1
-               ++ map (putAt Hand2) hand2
-               ++ map (putAt Hand3) hand3
-               ++ map (putAt WonSingle) skt
-
-playersExamp :: Players
-playersExamp = Players (Player Team One) (Player Team Two) (Player Single Three)
-
-shuffledEnv :: IO SkatEnv
-shuffledEnv = do
-    cards <- shuffleCards
-    return $ SkatEnv (distribute cards) Nothing Spades playersExamp
-
-shuffledEnv2 :: IO SkatEnv
-shuffledEnv2 = do
-    cards <- shuffleCards
-    return $ SkatEnv (distributePutSkat cards) Nothing Spades playersExamp

README.md

@@ -0,0 +1 @@
+# skat

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)

Skat.hs

@@ -1,36 +0,0 @@
-module Skat where
-
-import Card
-import Control.Monad.State
-import Control.Monad.Reader
-import Data.List
-
-data SkatEnv = SkatEnv { cards :: [CardS]
-                       , turnColour :: Maybe Colour
-                       , trumpColour :: Colour
-                       , players :: Players }
-               deriving Show
-
-type Skat = StateT SkatEnv IO
-
-table :: Skat [Card]
-table = gets cards >>= return . foldr f []
-    where f (CardS c Table _) cs = c : cs
-          f _               cs = cs
-
-tableS :: Skat [CardS]
-tableS = gets cards >>= return . foldr f []
-    where f c@(CardS _ Table _) cs = c : cs
-          f _                   cs = cs
-
-move :: Card -> Space -> Skat ()
-move card sp = do
-    cs <- gets cards
-    let cs' = moveCard card sp cs
-    modify (\env -> env { cards = cs' })
-
-cardsAt :: Space -> Skat [Card]
-cardsAt sp = gets cards >>= return . findCards sp
-
-setTurnColour :: Maybe Colour -> SkatEnv -> SkatEnv
-setTurnColour col sk = sk { turnColour = col }

Utils.hs

@@ -1,24 +0,0 @@
-module Utils where
-
-import System.Random
-import Text.Read
-
-shuffle :: StdGen -> [a] -> [a]
-shuffle g xs = shuffle' (randoms g) xs
-
-shuffle' :: [Int] -> [a] -> [a]
-shuffle' _      [] = []
-shuffle' (i:is) xs = let (firsts, rest) = splitAt (1 + i `mod` length xs) xs
-                     in (last firsts) : shuffle' is (init firsts ++ rest)
-
-chunksOf :: Int -> [a] -> [[a]]
-chunksOf n [] = []
-chunksOf n xs = take n xs : chunksOf n (drop n xs)
-
-query :: Read a => String -> IO a
-query s = do
-    putStrLn s
-    l <- fmap readMaybe getLine
-    case l of
-        Just x -> return x
-        Nothing -> query s

app/Main.hs

@@ -0,0 +1,86 @@
+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 Skat
+import Skat.Card
+import Skat.Operations
+import Skat.Player
+import Skat.Pile
+
+import Skat.AI.Stupid
+import Skat.AI.Online
+import Skat.AI.Rulebased
+
+main :: IO ()
+main = testAI 10
+
+testAI :: Int -> IO ()
+testAI n = do
+    let acs = repeat runAI
+    vals <- sequence (take n acs)
+    putStrLn $ "average won points " ++ show (fromIntegral (sum vals) / fromIntegral n)
+
+runAI :: IO Int
+runAI = do
+    env <- shuffledEnv
+    let ps = piles env
+        cs = handCards Hand3 ps
+        trs = filter (isTrump Spades) cs
+    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
+        else runAI
+
+env :: SkatEnv
+env = SkatEnv piles Nothing Spades playersExamp
+    where piles = distribute allCards 
+
+envStupid :: SkatEnv
+envStupid = SkatEnv piles Nothing Spades pls2
+    where piles = distribute allCards 
+
+playersExamp :: Players
+playersExamp = Players
+    (PL $ Stupid Team Hand1)
+    (PL $ Stupid Team Hand2)
+    (PL $ mkAIEnv Single Hand3 10)
+
+pls2 :: Players
+pls2 = Players
+    (PL $ Stupid Team Hand1)
+    (PL $ Stupid Team Hand2)
+    (PL $ Stupid Team Hand3)
+
+shuffledEnv :: IO SkatEnv
+shuffledEnv = do
+    cards <- shuffleCards
+    return $ SkatEnv (distribute cards) Nothing Spades playersExamp
+
+env2 :: SkatEnv
+env2 = SkatEnv piles Nothing Spades playersExamp
+    where hand1 = [Card Seven Clubs, Card King Clubs, Card Ace Clubs, Card Queen Diamonds]
+          hand2 = [Card Seven Hearts, Card King Hearts, Card Ace Hearts, Card Queen Spades]
+          hand3 = [Card Seven Spades, Card King Spades, Card Ace Spades, Card Queen Clubs]
+          h1 = map (putAt Hand1) hand1
+          h2 = map (putAt Hand2) hand2
+          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.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 <https://github.com/githubuser/skat#readme>
+
+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,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 <https://github.com/githubuser/skat#readme>
+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

src/Skat.hs

@@ -0,0 +1,49 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+module Skat where
+
+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
+
+data SkatEnv = SkatEnv { piles :: Piles
+                       , turnColour :: Maybe Colour
+                       , trumpColour :: Colour
+                       , players :: Players }
+               deriving Show
+
+type Skat = StateT SkatEnv IO
+
+instance P.MonadPlayer Skat where
+    trumpColour = gets trumpColour
+    turnColour = gets turnColour
+    showSkat p = case P.team p of
+        Single -> fmap (Just . skatCards) $ gets piles
+        Team -> return Nothing
+
+instance P.MonadPlayerOpen Skat where
+    showPiles = gets piles
+
+modifyp :: (Piles -> Piles) -> Skat ()
+modifyp f = modify g
+    where g env@(SkatEnv {piles}) = env { piles = f piles}
+
+getp :: (Piles -> a) -> Skat a
+getp f = gets piles >>= return . f
+
+modifyPlayers :: (Players -> Players) -> Skat ()
+modifyPlayers f = modify g
+    where g env@(SkatEnv {players}) = env { players = f players }
+
+setTurnColour :: Maybe Colour -> SkatEnv -> SkatEnv
+setTurnColour col sk = sk { turnColour = col }
+
+mkSkatEnv :: Piles -> Maybe Colour -> Colour -> Players -> SkatEnv
+mkSkatEnv = SkatEnv

src/Skat/AI/Human.hs

@@ -0,0 +1,37 @@
+module Skat.AI.Human where
+
+import Control.Monad.Trans (liftIO)
+
+import Skat.Player
+import Skat.Pile
+import Skat.Card
+import Skat.Utils
+import Skat.Render
+
+data Human = Human { getTeam :: Team
+                   , getHand :: Hand }
+              deriving Show
+
+instance Player Human where
+    team = getTeam
+    hand = getHand
+    chooseCard p table _ hand = do
+        trumpCol <- trumpColour
+        turnCol <- turnColour
+        let possible = filter (isAllowed trumpCol turnCol hand) hand
+        c <- liftIO $ askIO (map getCard table) possible hand
+        return $ (c, p)
+
+askIO :: [Card] -> [Card] -> [Card] -> IO Card
+askIO table possible hand = do
+    putStrLn "Your hand"
+    render hand
+    putStrLn "These options are possible"
+    render possible
+    putStrLn "These cards are on the table"
+    render table
+    idx <- query
+        "Which card do you want to play? Give the index of the card"
+    if idx >= 0 && idx < length possible
+        then return $ possible !! idx
+        else askIO table possible hand

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"

src/Skat/AI/Rulebased.hs

@@ -0,0 +1,433 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module Skat.AI.Rulebased (
+    mkAIEnv, testds, simplify
+) where
+
+import Control.Parallel.Strategies
+
+import Data.Ord
+import Data.Monoid ((<>))
+import Data.List
+import qualified Data.Set as S
+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 Skat (Skat, modifyp, mkSkatEnv) 
+import Skat.Operations
+
+data AIEnv = AIEnv { getTeam :: Team
+                   , getHand :: Hand
+                   , table :: [CardS Played]
+                   , fallen :: [CardS Played]
+                   , myHand :: [Card]
+                   , guess :: Guess
+                   , simulationDepth :: Int }
+             deriving Show
+
+setTable :: [CardS Played] -> AIEnv -> AIEnv
+setTable tab env = env { table = tab }
+
+setHand :: [Card] -> AIEnv -> AIEnv
+setHand hand env = env { myHand = hand }
+
+setFallen :: [CardS Played] -> AIEnv -> AIEnv
+setFallen fallen env = env { fallen = fallen }
+
+setDepth :: Int -> AIEnv -> AIEnv
+setDepth depth env = env { simulationDepth = depth }
+
+modifyg :: MonadPlayer m => (Guess -> Guess) -> AI m ()
+modifyg f = modify g
+    where g env@(AIEnv {guess}) = env { guess = f guess }
+    
+type AI m = StateT AIEnv m
+
+instance MonadPlayer m => MonadPlayer (AI m) where
+    trumpColour = lift $ trumpColour
+    turnColour = lift $ turnColour
+    showSkat = lift . showSkat
+
+instance MonadPlayerOpen m => MonadPlayerOpen (AI m) where
+    showPiles = lift $ showPiles
+
+type Simulator m = ReaderT Piles (AI m)
+
+instance MonadPlayer m => MonadPlayer (Simulator m) where
+    trumpColour = lift $ trumpColour
+    turnColour = lift $ turnColour
+    showSkat = lift . showSkat
+
+instance MonadPlayer m => MonadPlayerOpen (Simulator m) where
+    showPiles = ask
+
+runWithPiles :: MonadPlayer m
+             => Piles -> Simulator m a -> AI m a
+runWithPiles ps sim = runReaderT sim ps
+
+instance Player AIEnv where
+    team = getTeam
+    hand = getHand
+    chooseCard p table fallen hand = runStateT (do
+        modify $ setTable table
+        modify $ setHand hand
+        modify $ setFallen fallen
+        choose) p
+    onCardPlayed p card = execStateT (do
+        onPlayed card) p
+    chooseCardOpen p = evalStateT chooseOpen p
+
+value :: Card -> Int
+value (Card Ace _) = 100
+value _            = 0
+
+data Option = H Hand
+            | Skt
+              deriving (Show, Eq, Ord)
+
+-- | possible card distributions
+type Guess = M.Map Card [Option]
+
+newGuess :: Guess
+newGuess = M.fromList l
+    where l = map (\c -> (c, [H Hand1, H Hand2, H Hand3, Skt])) allCards
+
+hasBeenPlayed :: Card -> Guess -> Guess
+hasBeenPlayed card = M.delete card
+
+has :: Hand -> [Card] -> Guess -> Guess
+has hand cs = M.mapWithKey f
+    where f card hands
+            | card `elem` cs = [H hand]
+            | otherwise      = hands
+
+hasNoLonger :: MonadPlayer m => Hand -> Colour -> AI m ()
+hasNoLonger hand colour = do
+    trCol <- trumpColour
+    modifyg $ hasNoLonger_ trCol hand colour
+
+hasNoLonger_ :: Colour -> Hand -> Colour -> Guess -> Guess
+hasNoLonger_ trColour hand effCol = M.mapWithKey f
+    where f card hands
+            | effectiveColour trColour card == effCol && (H hand) `elem` hands = filter (/=H hand) hands
+            | otherwise = hands
+
+isSkat :: [Card] -> Guess -> Guess
+isSkat cs = M.mapWithKey f
+    where f card hands
+            | card `elem` cs = [Skt]
+            | otherwise      = hands
+
+type Turn = (CardS Played, CardS Played, CardS Played)
+
+analyzeTurn :: MonadPlayer m => Turn -> AI m ()
+analyzeTurn (c1, c2, c3) = do
+    modifyg (getCard c1 `hasBeenPlayed`)
+    modifyg (getCard c2 `hasBeenPlayed`)
+    modifyg (getCard c3 `hasBeenPlayed`)
+    trCol <- trumpColour
+    let turnCol = getColour $ getCard c1
+        demanded = effectiveColour trCol (getCard c1)
+        col2 = effectiveColour trCol (getCard c2)
+        col3 = effectiveColour trCol (getCard c3)
+    if col2 /= demanded
+        then origin c2 `hasNoLonger` demanded
+        else return ()
+    if col3 /= demanded
+        then origin c3 `hasNoLonger` demanded
+        else return ()
+
+type Distribution = ([Card], [Card], [Card], [Card])
+
+toPiles :: [CardS Played] -> Distribution -> Piles
+toPiles table (h1, h2, h3, skt) = Piles (cs1 ++ cs2 ++ cs3) table ss
+    where cs1 = map (putAt Hand1) h1
+          cs2 = map (putAt Hand2) h2
+          cs3 = map (putAt Hand3) h3
+          ss  = map (putAt SkatP) skt
+
+compareGuess :: (Card, [Option]) -> (Card, [Option]) -> Ordering
+compareGuess (c1, ops1) (c2, ops2)
+    | length ops1 == 1 = LT
+    | length ops2 == 1 = GT
+    | c1 > c2 = LT
+    | c1 < c2 = GT
+
+distributions :: Guess -> (Int, Int, Int, Int) -> [Distribution]
+distributions guess nos =
+        helper (sortBy compareGuess $ M.toList guess) nos
+        `using` parList rdeepseq
+    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, n4) =
+                let f card (H Hand1) =
+                        (([card], [], [], []), (n1+1, n2, n3, n4))
+                    f card (H Hand2) =
+                        (([], [card], [], []), (n1, n2+1, n3, n4))
+                    f card (H Hand3) =
+                        (([], [], [card], []), (n1, n2, n3+1, n4))
+                    f card Skt =
+                        (([], [], [], [card]), (n1, n2, n3, n4+1))
+                    isOk (H Hand1) = n1 < cardsPerHand
+                    isOk (H Hand2) = n2 < cardsPerHand
+                    isOk (H Hand3) = n3 < cardsPerHand
+                    isOk Skt       = n4 < 2
+                in filterMap isOk (f card) hands
+          cardsPerHand = (length guess - 2) `div` 3
+
+type Abstract = (Int, Int, Int, Int)
+
+abstract :: [Card] -> Abstract
+abstract cs = foldr f (0, 0, 0, 0) cs
+    where f c (clubs, spades, hearts, diamonds) =
+            let v = getID c in
+            case getColour c of
+                Diamonds -> (clubs, spades, hearts, diamonds + 1 + v*100)
+                Hearts -> (clubs, spades, hearts + 1 + v*100, diamonds)
+                Spades -> (clubs, spades + 1 + v*100, hearts, diamonds)
+                Clubs -> (clubs + 1 + v*100, spades, hearts, diamonds)
+
+remove789s :: Hand
+           -> [Distribution]
+           -> M.Map (Abstract, Abstract) (Distribution, Int)
+remove789s hand ds = foldl' f M.empty ds
+    where f cleaned d =
+            let (c1, c2) = reduce hand d
+                a = (abstract c1, abstract c2) in
+            M.insertWith (\(oldD, n) _ -> (oldD, n+1)) a (d, 1) cleaned
+          reduce Hand1 (_, h2, h3, _) = (h2, h3)
+          reduce Hand2 (h1, _, h3, _) = (h1, h3)
+          reduce Hand3 (h1, h2, _, _) = (h1, h2)
+
+simplify :: Hand -> [Distribution] -> [(Distribution, Int)]
+simplify hand ds = M.elems cleaned
+    where cleaned = remove789s hand ds
+
+onPlayed :: MonadPlayer m => CardS Played -> AI m ()
+onPlayed c = do
+    liftIO $ print c
+    modifyg (getCard c `hasBeenPlayed`)
+    trCol <- trumpColour
+    turnCol <- turnColour
+    let col = effectiveColour trCol (getCard c)
+    case turnCol of
+        Just demanded -> if col /= demanded
+            then origin c `hasNoLonger` demanded else return ()
+        Nothing -> return ()
+
+choose :: MonadPlayer m => AI m Card
+choose = do
+    handCards <- gets myHand
+    table <- gets table
+    case length table of
+        0 -> if length handCards >= 7
+            then chooseLead
+            else chooseStatistic
+        n -> chooseStatistic
+
+chooseStatistic :: MonadPlayer m => AI m Card
+chooseStatistic = do
+    h <- gets getHand
+    handCards <- gets myHand
+    let depth = case length handCards of
+                    0 -> 0
+                    1 -> 1
+                    -- simulate whole game
+                    2 -> 2
+                    3 -> 3
+                    -- simulate only partially
+                    4 -> 3
+                    5 -> 2
+                    6 -> 2
+                    7 -> 1
+                    8 -> 1
+                    9 -> 1
+                    10 -> 1
+    modify $ setDepth depth
+    guess__ <- gets guess
+    self <- get
+    maySkat <- showSkat self
+    let guess_ = (hand self `has` handCards) guess__
+        guess = case maySkat of
+            Just cs -> (cs `isSkat`) guess_
+            Nothing -> guess_
+    table <- gets table
+    let ns = case length table of
+                0 -> (0,  0,  0, 0)
+                1 -> (-1, 0, -1, 0)
+                2 -> (0,  0, -1, 0)
+    let realDis = distributions guess ns
+        realDisNo = length realDis
+        reducedDis = simplify Hand3 realDis
+        reducedDisNo = length reducedDis
+        piless = map (\(d, n) -> (toPiles table d, n)) reducedDis
+        limit = if depth == 1 && length table == 2
+            then 1
+            else min 10000 $ realDisNo `div` 2
+    liftIO $ putStrLn $ "possible distrs without simp " ++ show realDisNo
+    liftIO $ putStrLn $ "possible distrs " ++ show reducedDisNo
+    vals <- M.toList <$> foldWithLimit limit runOnPiles M.empty piless
+    liftIO $ print vals
+    return $ fst $ maximumBy (comparing snd) vals
+
+foldWithLimit :: Monad m
+              => Int
+              -> (M.Map k Int -> a -> m (M.Map k Int))
+              -> M.Map k Int
+              -> [a]
+              -> m (M.Map k Int)
+foldWithLimit _     _ start []     = return start
+foldWithLimit limit f start (x:xs) = do
+    case M.size (M.filter (>=limit) start) of
+        0 -> do m <- f start x
+                foldWithLimit limit f m xs
+        _ -> return start
+
+runOnPiles :: MonadPlayer m
+           => M.Map Card Int -> (Piles, Int) -> AI m (M.Map Card Int)
+runOnPiles m (ps, n) = do
+    c <- runWithPiles ps chooseOpen
+    return $ M.insertWith (+) c n m
+
+chooseOpen :: (MonadState AIEnv m, MonadPlayerOpen m) => m Card
+chooseOpen = do
+    piles <- showPiles
+    hand <- gets getHand
+    let myCards = handCards hand piles
+    possible <- filterM (P.isAllowed myCards) myCards
+    case length myCards of
+        0 -> do
+            liftIO $ print hand
+            liftIO $ print piles
+            error "no cards left to choose from"
+        1 -> return $ head myCards
+        _ -> chooseSimulating
+
+chooseSimulating :: (MonadState AIEnv m, MonadPlayerOpen m)
+                 => m Card
+chooseSimulating = do
+    piles <- showPiles
+    hand <- gets getHand
+    let myCards = handCards hand piles
+    possible <- filterM (P.isAllowed myCards) myCards
+    case possible of
+        [card] -> return card
+        cs -> do
+            results <- mapM simulate cs
+            let both = zip results cs
+                best = maximumBy (comparing fst) both
+            return $ snd best
+
+simulate :: (MonadState AIEnv m, MonadPlayerOpen m)
+         => Card -> m Int
+simulate card = do
+    -- retrieve all relevant info
+    piles <- showPiles
+    turnCol <- turnColour
+    trumpCol <- trumpColour
+    myTeam <- gets getTeam
+    myHand <- gets getHand
+    depth <- gets simulationDepth
+    let newDepth = depth - 1
+        -- create a virtual env with 3 ai players
+        ps = Players
+            (PL $ mkAIEnv Team Hand1 newDepth)
+            (PL $ mkAIEnv Team Hand2 newDepth)
+            (PL $ mkAIEnv Single Hand3 newDepth)
+        env = mkSkatEnv piles turnCol trumpCol ps
+    -- simulate the game after playing the given card
+    (sgl, tm) <- liftIO $ evalStateT (do
+        modifyp $ playCard card
+        turnGeneric playOpen depth (next myHand)) env
+    let v = if myTeam == Single then (sgl, tm) else (tm, sgl)
+    -- put the value into context for when not the whole game is
+    -- simulated
+    predictValue v
+
+predictValue :: (MonadState AIEnv m, MonadPlayerOpen m)
+             => (Int, Int) -> m Int
+predictValue (own, others) = do
+    hand <- gets getHand
+    piles <- showPiles
+    let cs = handCards hand piles
+    pot <- potential cs
+    return $ own + pot
+
+potential :: (MonadState AIEnv m, MonadPlayerOpen m)
+          => [Card] -> m Int
+potential cs = do
+    tr <- trumpColour
+    let trs = filter (isTrump tr) cs
+        value = count cs
+    positions <- filter (==0) <$> mapM position cs
+    return $ length trs * 10 + value + length positions * 5
+
+position :: (MonadState AIEnv m, MonadPlayer m)
+         => Card -> m Int
+position card = do
+    tr <- trumpColour
+    guess <- gets guess
+    let effCol = effectiveColour tr card
+        l = M.toList guess
+        cs = filterMap ((==effCol) . effectiveColour tr . fst) fst l
+        csInd = zip [0..] cs
+        Just (pos, _) = find ((== card) . snd) csInd
+    return pos
+
+leadPotential :: (MonadState AIEnv m, MonadPlayer m)
+              => Card -> m Int
+leadPotential card = do
+    pos <- position card
+    isTr <- P.isTrump card 
+    let value = count card
+    case pos of
+        0 -> return value
+        _ -> return $ -value
+
+chooseLead :: (MonadState AIEnv m, MonadPlayer m) => m Card
+chooseLead = do
+    cards <- gets myHand
+    possible <- filterM (P.isAllowed cards) cards
+    pots <- mapM leadPotential possible
+    return $ snd $ maximumBy (comparing fst) (zip pots possible)
+
+mkAIEnv :: Team -> Hand -> Int -> AIEnv
+mkAIEnv tm h depth = AIEnv tm h [] [] [] newGuess depth
+
+-- | TESTING VARS
+
+aienv :: AIEnv
+aienv = AIEnv Single Hand3 [] [] [] newGuess 10
+
+testguess :: Guess
+testguess = isSkat (take 2 $ drop 10 cs)
+        $ Hand3 `has` (take 10 cs) $ m
+    where l = map (\c -> (c, [H Hand1, H Hand2, H Hand3, Skt])) (take 32 cs)
+          m = M.fromList l
+          cs = allCards
+
+testguess2 :: Guess
+testguess2 = isSkat (take 2 $ drop 6 cs)
+        $ Hand3 `has` [head cs, head $ drop 5 cs] $ m
+    where l = map (\c -> (c, [H Hand1, H Hand2, H Hand3, Skt])) cs
+          m = M.fromList l
+          cs = take 8 $ drop 8 allCards
+
+testds :: [Distribution]
+testds = distributions testguess (0, 0, 0, 0)
+
+testds2 :: [Distribution]
+testds2 = distributions testguess2 (0, 0, 0, 0)

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

@@ -0,0 +1,18 @@
+module Skat.AI.Stupid where
+
+import Skat.Player
+import Skat.Pile
+import Skat.Card
+
+data Stupid = Stupid { getTeam :: Team
+                     , getHand :: Hand }
+              deriving Show
+
+instance Player Stupid where
+    team = getTeam
+    hand = getHand
+    chooseCard p _ _ hand = do
+        trumpCol <- trumpColour
+        turnCol <- turnColour
+        let possible = filter (isAllowed trumpCol turnCol hand) hand
+        return (head possible, p)

src/Skat/Card.hs

@@ -0,0 +1,149 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Skat.Card where
+
+import Data.List
+import Data.Aeson
+import System.Random (newStdGen)
+import Control.DeepSeq
+
+import Skat.Utils
+
+class Countable a b where
+    count :: a -> b
+
+data Type = Seven
+          | Eight
+          | Nine
+          | Queen
+          | King
+          | Ten
+          | Ace
+          | Jack
+            deriving (Eq, Ord, Show, Enum, Read)
+
+instance Countable Type Int where
+    count Ace   = 11
+    count Ten   = 10
+    count King  = 4
+    count Queen = 3
+    count Jack  = 2
+    count _     = 0
+
+data Colour = Diamonds
+            | Hearts
+            | Spades
+            | Clubs
+              deriving (Eq, Ord, Show, Enum, Read)
+
+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
+
+getID :: Card -> Int
+getID (Card t _) = case t of
+    Seven -> 0
+    Eight -> 0
+    Nine -> 0
+    Queen -> 2
+    King -> 4
+    Ten -> 8
+    Ace -> 16
+    Jack -> 32
+
+instance Countable Card Int where
+    count (Card t _) = count t
+
+instance Countable [Card] Int where
+    count = sum . map count
+
+instance NFData Card where
+    rnf (Card t c) = t `seq` c `seq` ()
+
+equals :: Colour -> Maybe Colour -> Bool
+equals col (Just x) = col == x
+equals col Nothing = True
+
+isTrump :: Colour -> Card -> Bool
+isTrump trumpCol (Card tp col)
+    | tp == Jack = True
+    | otherwise = col == trumpCol
+
+effectiveColour :: Colour -> Card -> Colour
+effectiveColour trumpCol card@(Card _ col) =
+    if trump then trumpCol else col
+  where trump = isTrump trumpCol card
+
+isAllowed :: Colour -> Maybe Colour -> [Card] -> Card -> Bool
+isAllowed trumpCol turnCol cs card =
+    if col `equals` turnCol
+        then True
+        else not $ any (\ca -> effectiveColour trumpCol ca `equals` turnCol && ca /= card) cs
+  where col = effectiveColour trumpCol card
+
+compareCards :: Colour
+             -> Maybe Colour
+             -> Card
+             -> Card
+             -> Ordering
+compareCards _ _ (Card Jack col1) (Card Jack col2) = compare col1 col2
+compareCards trumpCol turnCol c1@(Card tp1 col1) c2@(Card tp2 col2) =
+    case (trp1, trp2) of
+        (True, True) -> compare tp1 tp2
+        (False, False) -> case compare (col1 `equals` turnCol)
+                                       (col2 `equals` turnCol) of
+                            EQ -> compare tp1 tp2
+                            v -> v
+        _ -> compare trp1 trp2
+  where trp1 = isTrump trumpCol c1
+        trp2 = isTrump trumpCol c2
+
+sortCards :: Colour -> Maybe Colour -> [Card] -> [Card]
+sortCards trumpCol turnCol cs = sortBy (compareCards trumpCol turnCol) cs
+
+highestCard :: Colour -> Maybe Colour -> [Card] -> Card
+highestCard trumpCol turnCol cs = maximumBy (compareCards trumpCol turnCol) cs
+
+shuffleCards :: IO [Card]
+shuffleCards = do
+    gen <- newStdGen
+    return $ shuffle gen allCards
+
+-- TESTING VARS
+
+c1 :: Card
+c1 = Card Jack Spades
+
+c2 :: Card
+c2 = Card Ace Diamonds
+
+c3 :: Card
+c3 = Card Queen Diamonds
+
+c4 :: Card
+c4 = Card Queen Hearts
+
+c5 :: Card
+c5 = Card Jack Clubs
+
+h1 :: [Card]
+h1 = [c1,c2,c3,c4,c5]
+
+allCards :: [Card]
+allCards = [ Card t c | t <- tps, c <- cols ]
+    where tps = [Seven .. Jack]
+          cols = [Diamonds .. Clubs]

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

src/Skat/Pile.hs

@@ -0,0 +1,120 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Skat.Pile where
+
+import Data.List
+import Data.Aeson
+import Control.Exception
+
+import Skat.Card
+import Skat.Utils
+
+data Team = Team | Single
+            deriving (Show, Eq, Ord, Enum)
+
+data CardS p = CardS { getCard :: Card
+                     , getPile :: p }
+               deriving (Show, Eq, Ord)
+
+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)
+
+next :: Hand -> Hand
+next Hand1 = Hand2
+next Hand2 = Hand3
+next Hand3 = Hand1
+
+prev :: Hand -> Hand
+prev Hand1 = Hand3
+prev Hand2 = Hand1
+prev Hand3 = Hand2
+
+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)
+
+data Piles = Piles { hands :: [CardS Hand]
+                   , played :: [CardS Played]
+                   , skat :: [CardS SkatP] }
+             deriving (Show, Eq, Ord)
+
+instance Countable Piles (Int, Int) where
+    count ps = (sgl, tm)
+        where sgl = count (skatCards ps) + count (wonCards Single ps)
+              tm = count (wonCards Team ps)
+
+origin :: CardS Played -> Hand
+origin (CardS _ (Table hand)) = hand
+origin (CardS _ (Won hand _)) = hand
+
+originOfCard :: Card -> Piles -> Maybe Hand
+originOfCard card (Piles _ pld _) = origin <$> find ((==card) . getCard) pld
+
+playCard :: Card -> Piles -> Piles
+playCard card (Piles hs pld skt) = Piles hs' (ca : pld) skt
+    where (CardS _ hand, hs') = remove ((==card) . getCard) hs
+          ca = CardS card (Table hand)
+
+winCard :: Team -> CardS Played -> CardS Played
+winCard team (CardS card (Table hand)) = CardS card (Won hand team)
+winCard team c                         = c
+
+wonCards :: Team -> Piles -> [Card]
+wonCards team (Piles _ pld _) = filterMap (f . getPile) getCard pld
+    where f (Won _ tm) = tm == team
+          f _          = False
+
+cleanTable :: Team -> Piles -> Piles
+cleanTable winner ps@(Piles hs pld skt) = Piles hs pld' skt
+    where table = tableCards ps
+          pld' = map (winCard winner) pld
+
+tableCards :: Piles -> [Card]
+tableCards (Piles _ pld _) = filterMap (f . getPile) getCard pld
+    where f (Table _) = True
+          f _         = False
+
+tableCardsS :: Piles -> [CardS Played]
+tableCardsS (Piles _ pld _) = filter (f . getPile) pld
+    where f (Table _) = True
+          f _         = False
+
+handCards :: Hand -> Piles -> [Card]
+handCards hand (Piles hs _ _) = filterMap ((==hand) . getPile) getCard hs
+
+skatCards :: Piles -> [Card]
+skatCards (Piles _ _ skat) = map getCard skat
+
+putAt :: p -> Card -> CardS p
+putAt = flip CardS
+
+distribute :: [Card] -> Piles
+distribute cards = Piles hands [] (map (putAt SkatP) skt)
+    where round1 = chunksOf 3 (take 9 cards)
+          skt = take 2 $ drop 9 cards
+          round2 = chunksOf 4 (take 12 $ drop 11 cards)
+          round3 = chunksOf 3 (take 9 $ drop 23 cards)
+          hand1 = concatMap (!! 0) [round1, round2, round3]
+          hand2 = concatMap (!! 1) [round1, round2, round3]
+          hand3 = concatMap (!! 2) [round1, round2, round3]
+          hands = map (putAt Hand1) hand1
+            ++ map (putAt Hand2) hand2
+            ++ map (putAt Hand3) hand3

src/Skat/Player.hs

@@ -0,0 +1,79 @@
+{-# LANGUAGE ExistentialQuantification #-}
+
+module Skat.Player where
+
+import Control.Monad.IO.Class
+
+import Skat.Card
+import Skat.Pile
+
+class (Monad m, MonadIO m) => MonadPlayer m where
+    trumpColour :: m Colour
+    turnColour :: m (Maybe Colour)
+    showSkat :: Player p => p -> m (Maybe [Card])
+
+class (Monad m, MonadIO m, MonadPlayer m) => MonadPlayerOpen m where
+    showPiles :: m (Piles)
+
+class Player p where
+    team :: p -> Team
+    hand :: p -> Hand
+    chooseCard :: MonadPlayer m
+               => p
+               -> [CardS Played]
+               -> [CardS Played]
+               -> [Card]
+               -> m (Card, p)
+    onCardPlayed :: MonadPlayer m
+                 => p
+                 -> CardS Played
+                 -> m p
+    onCardPlayed p _ = return p
+    chooseCardOpen :: MonadPlayerOpen m
+                   => p
+                   -> m Card
+    chooseCardOpen p = do
+        piles <- showPiles
+        let table = tableCardsS piles
+            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
+
+instance Show PL where
+    show (PL p) = show p
+
+instance Player PL where
+    team (PL p) = team p
+    hand (PL p) = hand p
+    chooseCard (PL p) table fallen hand = do
+        (v, a) <- chooseCard p table fallen hand
+        return $ (v, PL a)
+    onCardPlayed (PL p) card = do
+        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
+
+player :: Players -> Hand -> PL
+player (Players p _ _) Hand1 = p
+player (Players _ p _) Hand2 = p
+player (Players _ _ p) Hand3 = p
+
+updatePlayer :: (Show p, Player p) => p -> Players -> Players
+updatePlayer p (Players p1 p2 p3) = case hand p of
+    Hand1 -> Players (PL p) p2 p3
+    Hand2 -> Players p1 (PL p) p3
+    Hand3 -> Players p1 p2 (PL p)
+
+playersToList :: Players -> [PL]
+playersToList (Players p1 p2 p3) = [p1, p2, p3]

src/Skat/Player/Utils.hs

@@ -0,0 +1,18 @@
+module Skat.Player.Utils (
+    isAllowed, isTrump
+) where
+
+import Skat.Player
+import qualified Skat.Card as C
+import Skat.Card (Card)
+
+isAllowed :: MonadPlayer m => [Card] -> Card -> m Bool
+isAllowed hand card = do
+    trCol <- trumpColour
+    turnCol <- turnColour
+    return $ C.isAllowed trCol turnCol hand card
+
+isTrump :: MonadPlayer m => Card -> m Bool
+isTrump card = do
+    trCol <- trumpColour
+    return $ C.isTrump trCol card

src/Skat/Render.hs

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

@@ -0,0 +1,58 @@
+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
+
+shuffle' :: [Int] -> [a] -> [a]
+shuffle' _      [] = []
+shuffle' (i:is) xs = let (firsts, rest) = splitAt (1 + i `mod` length xs) xs
+                     in (last firsts) : shuffle' is (init firsts ++ rest)
+
+chunksOf :: Int -> [a] -> [[a]]
+chunksOf n [] = []
+chunksOf n xs = take n xs : chunksOf n (drop n xs)
+
+query :: Read a => String -> IO a
+query s = do
+    putStrLn s
+    l <- fmap readMaybe getLine
+    case l of
+        Just x -> return x
+        Nothing -> query s
+
+remove :: (a -> Bool) -> [a] -> (a, [a])
+remove pred xs = foldr f (undefined, []) xs
+    where f c (old, cs) = if pred c then (c, cs) else (old, c : cs)
+
+filterMap :: (a -> Bool) -> (a -> b) -> [a] -> [b]
+filterMap pred f as = foldr g [] as
+    where g a bs = if pred a then f a : bs else bs
+
+--filterM :: Monad m => (a -> m Bool) -> [a] -> m [a]
+--filterM _    []     = return []
+--filterM pred (x:xs) = do
+--    b <- pred x
+--    if b then filterM pred xs >>= \l -> return $ x : l
+--        else filterM pred xs
+
+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"