upgrade lts

.gitignore

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

AI/Stupid.hs

@@ -1,18 +0,0 @@
-module AI.Stupid where
-
-import Player
-import Pile
-import 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)

AI/Test.hs

@@ -1,39 +0,0 @@
-import Card
-import Pile
-import Utils
-
-import qualified Data.Map.Strict as M
-import Data.Monoid ((<>))
-
-type Guess = M.Map Card [Hand]
-type Distribution = ([Card], [Card], [Card])
-
-distributions :: Guess -> [Distribution]
-distributions guess = --filter equilibrated
-        (helper (M.toList guess) (0, 0, 0))
-    where helper []           _ = []
-          helper ((c, hs):[]) ns = map fst (distr c hs ns)
-          helper ((c, hs):gs) ns =
-                let dsWithNs = distr c hs ns
-                    go (d, ns') = map (d <>) (helper gs ns')
-                in concatMap go dsWithNs
-          distr card hands (n1, n2, n3) =
-                let f card Hand1 = (([card], [], []), (n1+1, n2, n3))
-                    f card Hand2 = (([], [card], []), (n1, n2+1, n3))
-                    f card Hand3 = (([], [], [card]), (n1, n2, n3+1))
-                    isOk Hand1 = n1 < cardsPerHand
-                    isOk Hand2 = n2 < cardsPerHand
-                    isOk Hand3 = n3 < cardsPerHand
-                in filterMap isOk (f card) hands
-          equilibrated (cs1, cs2, cs3) =
-              let ls = [length cs1, length cs2, length cs3]
-              in (maximum ls - minimum ls) <= 1 
-          cardsPerHand = (length guess `div` 3)
-
-testguess :: Guess
-testguess = foldr (Hand3 `has`) m (take 10 allCards)
-    where l = map (\c -> (c, [Hand1, Hand2, Hand3])) (take 30 allCards)
-          m = M.fromList l
-
-main :: IO ()
-main = print $ length $ distributions testguess

Card.hs

@@ -1,121 +0,0 @@
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE FlexibleInstances #-}
-
-module Card where
-
-import Data.List
-import System.Random (newStdGen)
-import Utils
-
-class Countable a b where
-    count :: a -> b
-
-data Type = Seven
-          | Eight
-          | Nine
-          | Queen
-          | King
-          | Ten
-          | Ace
-          | Jack
-            deriving (Eq, Ord, Show, Enum)
-
-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)
-
-getColour :: Card -> Colour
-getColour (Card _ c) = c
-
-instance Countable Card Int where
-    count (Card t _) = count t
-
-instance Countable [Card] Int where
-    count = sum . map count
-
-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]

ChangeLog.md

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

LICENSE

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

Main.hs

@@ -1,57 +0,0 @@
-module Main where
-
-import Control.Monad.State
-
-import Card
-import Skat
-import Operations
-import Player
-import Pile
-
-import AI.Stupid
-import AI.Human
-import AI.Rulebased
-
-main :: IO ()
-main = putStrLn "Hello World"
-
-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) [] []
-
-testAI :: Int -> IO ()
-testAI n = do
-    let acs = repeat (shuffledEnv >>= evalStateT (turnGeneric playOpen 10 Hand1) )
-    vals <- sequence (take n acs)
-    putStrLn $ "average won points " ++ show (fromIntegral (sum (map fst vals)) / fromIntegral n)

Operations.hs

@@ -1,88 +0,0 @@
-module Operations where
-
-import Control.Monad.State
-import System.Random (newStdGen, randoms)
-import Data.List
-import Data.Ord
-
-import Card
-import Skat
-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
-    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

Pile.hs

@@ -1,108 +0,0 @@
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE FlexibleInstances #-}
-
-module Pile where
-
-import Data.List
-
-import Card
-import Utils
-import Control.Exception
-
-data Team = Team | Single
-            deriving (Show, Eq, Ord, Enum)
-
-data CardS p = CardS { getCard :: Card
-                     , getPile :: p }
-               deriving (Show, Eq)
-
-instance Countable (CardS p) Int where
-    count = count . getCard
-
-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)
-
-data SkatP = SkatP
-             deriving (Show, Eq)
-
-data Piles = Piles { hands :: [CardS Hand]
-                   , played :: [CardS Played]
-                   , skat :: [CardS SkatP] }
-             deriving (Show, Eq)
-
-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

Player/Utils.hs

@@ -1,18 +0,0 @@
-module Player.Utils (
-    isAllowed, isTrump
-) where
-
-import Player
-import qualified Card as C
-import 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

README.md

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

Reizen.hs

@@ -1,73 +0,0 @@
-module Reizen where
-
-import Skat
-import Card
-import Utils
-import Operations
-import Render
-
-data Reizer = Reizer Index [Card]
-              deriving Show
-
-getHand :: Index -> [Reizer] -> [Card]
-getHand n rs = let (Reizer _ h) = head $ filter (\(Reizer i cs) -> i == n) rs
-            in h
-
-goWith :: [Card] -> Int -> IO Bool
-goWith cs n = query $ "Go with " ++ show n
-
-goUp :: [Card] -> Int -> IO Int
-goUp cs n = query $ "Go up " ++ show n
-
-askColour :: [Card] -> IO Colour
-askColour cs = render (sortRender cs) >> query "Trump should be:"
-
-askSkat :: [Card] -> IO (Card, Card)
-askSkat cs_ = do
-    let cs = sortRender cs_
-    render cs
-    (n1, n2) <- query "Drop two cards:"
-    if n1 < length cs && n2 < length cs && n1 >= 0 && n2 >= 0 && n1 /= n2
-        then return (cs !! n1, cs !! n2)
-        else askSkat cs
-
-reizen :: IO SkatEnv
-reizen = do
-    cs <- shuffleCards
-    let cards = distribute cs
-        p1 = Reizer One   $ findCards Hand1 cards
-        p2 = Reizer Two   $ findCards Hand2 cards
-        p3 = Reizer Three $ findCards Hand3 cards
-        skt = findCards SkatP cards
-    (winner1, new) <- combat p2 p1 0
-    (Reizer idx _, _) <- combat p3 winner1 new
-    let ps = Players (Player (if idx == One then Single else Team) One)
-                     (Player (if idx == Two then Single else Team) Two)
-                     (Player (if idx == Three then Single else Team) Three)
-        sglHand = playerHand idx
-        cards' = foldr (\c css -> moveCard c sglHand css) cards skt
-    trumpCol <- askColour (findCards sglHand cards')
-    (s1, s2) <- askSkat (findCards sglHand cards')
-    let cards'' = moveCard s2 WonSingle (moveCard s1 WonSingle cards')
-    return $ SkatEnv cards'' Nothing trumpCol ps
-
-combat :: Reizer -> Reizer -> Int -> IO (Reizer, Int)
-combat r2@(Reizer p2 h2) r1@(Reizer p1 h1) start = do
-    -- advantage for h1 (being challenged)
-    putStrLn $ "Player " ++ show p2 ++ " challenging " ++ show p1
-    putStrLn $ "Player " ++ show p2 ++ "'s turn"
-    new <- goUp h2 start
-    if new > start
-        then do
-            putStrLn $ "Player " ++ show p2 ++ " goes up to " ++ show new
-            putStrLn $ "Player " ++ show p1 ++ "'s turn"
-            yes <- goWith h1 new
-            if yes then combat r2 r1 new
-                else do
-                    putStrLn $ "Player " ++ show p1 ++ " gives up"
-                    putStrLn $ "Player " ++ show p2 ++ " wins"
-                    return (r2, new)
-        else do
-            putStrLn $ "Player " ++ show p2 ++ " gives up"
-            putStrLn $ "Player " ++ show p1 ++ " wins"
-            return (r1, start)

Render.hs

@@ -1,7 +0,0 @@
-module Render where
-
-import Card
-import Data.List
-
-render :: [Card] -> IO ()
-render = putStrLn . intercalate "\n" . zipWith (\n c -> show n ++ ") " ++ show c) [0..]

Skat.hs

@@ -1,49 +0,0 @@
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE FlexibleInstances #-}
-
-module Skat where
-
-import Control.Monad.State
-import Control.Monad.Reader
-import Data.List
-
-import Card
-import Pile
-import Player (Players)
-import qualified 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

Utils.hs

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

app/Main.hs

@@ -0,0 +1,112 @@
+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.Bidding
+
+import Skat.AI.Stupid
+import Skat.AI.Online
+import Skat.AI.Rulebased
+import Skat.AI.Minmax (playCLI)
+
+main :: IO ()
+main = testMinmax 10
+
+testMinmax :: Int -> IO ()
+testMinmax n = do
+    let acs = repeat playSkat
+    sequence_ (take n acs)
+
+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 $ TrumpColour Spades) cs
+    if length trs >= 5 && any ((==32) . getID) cs
+        then do
+            pts <- fst <$> evalSkat turn env
+            -- if pts > 60 then return 1 else return 0
+            return pts
+        else runAI
+
+env :: SkatEnv
+env = SkatEnv piles Nothing (Colour Spades Einfach) playersExamp Hand1 Hand3
+    where piles = distribute allCards 
+
+envStupid :: SkatEnv
+envStupid = SkatEnv piles Nothing (Colour Spades Einfach) pls2 Hand1 Hand3
+    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 Single Hand3)
+
+shuffledEnv :: IO SkatEnv
+shuffledEnv = do
+    cards <- shuffleCards
+    return $ SkatEnv (distribute cards) Nothing (Colour Spades Einfach) playersExamp Hand1 Hand3
+
+shuffledEnv2 :: IO SkatEnv
+shuffledEnv2 = do
+    cards <- shuffleCards
+    return $ SkatEnv (distribute cards) Nothing (Colour Spades Einfach) pls2 Hand1 Hand3
+
+env2 :: SkatEnv
+env2 = SkatEnv piles Nothing (Colour Hearts Einfach) playersExamp Hand2 Hand3
+    where hand1 = [Card Eight Hearts, Card Queen Hearts, Card Ace Clubs, Card Queen Diamonds]
+          hand2 = [Card Seven Hearts, Card King Hearts, Card Ten Hearts, Card Queen Spades]
+          hand3 = [Card Seven Spades, Card King Spades, Card Ace Spades, Card Queen Clubs]
+          piles = emptyPiles hand1 hand2 hand3 []
+
+env3 :: SkatEnv
+env3 = SkatEnv piles Nothing (Colour Diamonds Einfach) pls2 Hand3 Hand3
+    where hand1 = [ Card Jack Diamonds, Card Jack Clubs, Card Nine Spades, Card King Spades
+                  , Card Seven Diamonds, Card Nine Diamonds, Card Seven Clubs, Card Eight Clubs
+                  , Card Ten Clubs, Card Eight Hearts ]
+          hand2 = [ Card Seven Spades, Card Eight Spades, Card Seven Hearts, Card Nine Hearts
+                  , Card Ace Hearts, Card King Diamonds, Card Ace Diamonds, Card Nine Clubs
+                  , Card King Clubs, Card Ace Clubs ]
+          hand3 = [ Card Jack Hearts, Card Jack Spades, Card Ten Spades, Card Ace Spades, Card Eight Diamonds
+                  , Card Queen Diamonds, Card Ten Diamonds, Card Ten Hearts, Card Queen Hearts, Card King Hearts ]
+          skat = [ Card Queen Clubs, Card Queen Spades]
+          piles = emptyPiles hand1 hand2 hand3 skat
+
+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
+
+playSkat :: IO ()
+playSkat = void $ (flip runSkat) env3 playCLI

app/TestEnvs.hs

@@ -0,0 +1,32 @@
+module TestEnvs where
+
+import Skat
+import Skat.Card
+import Skat.Pile
+import Skat.Player
+import Skat.AI.Stupid
+import Skat.Bidding
+
+pls2 :: Players
+pls2 = Players
+    (PL $ Stupid Team Hand1)
+    (PL $ Stupid Team Hand2)
+    (PL $ Stupid Single Hand3)
+
+env3 :: SkatEnv
+env3 = SkatEnv piles Nothing (Colour Diamonds Einfach) pls2 Hand3 Hand3
+    where hand1 = [ Card Jack Diamonds, Card Jack Clubs, Card Nine Spades, Card King Spades
+                  , Card Seven Diamonds, Card Nine Diamonds, Card Seven Clubs, Card Eight Clubs
+                  , Card Ten Clubs, Card Eight Hearts ]
+          hand2 = [ Card Seven Spades, Card Eight Spades, Card Seven Hearts, Card Nine Hearts
+                  , Card Ace Hearts, Card King Diamonds, Card Ace Diamonds, Card Nine Clubs
+                  , Card King Clubs, Card Ace Clubs ]
+          hand3 = [ Card Jack Hearts, Card Jack Spades, Card Ten Spades, Card Ace Spades, Card Eight Diamonds
+                  , Card Queen Diamonds, Card Ten Diamonds, Card Ten Hearts, Card Queen Hearts, Card King Hearts ]
+          skat = [ Card Queen Clubs, Card Queen Spades]
+          piles = emptyPiles hand1 hand2 hand3 skat
+
+shuffledEnv2 :: IO SkatEnv
+shuffledEnv2 = do
+    cards <- shuffleCards
+    return $ SkatEnv (distribute cards) Nothing (Colour Spades Einfach) pls2 Hand1 Hand3

package.yaml

@@ -0,0 +1,65 @@
+name:                skat
+version:             0.1.0.8
+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
+- vector
+- transformers
+- exceptions
+
+library:
+  source-dirs: src
+
+executables:
+  skat-exe:
+    main:                Main.hs
+    source-dirs:         app
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    - -O2
+    dependencies:
+    - skat
+
+tests:
+  skat-test:
+    main:                Spec.hs
+    source-dirs:         test
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    - -O2
+    dependencies:
+    - skat

skat.cabal

@@ -0,0 +1,125 @@
+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: a2e08e04140990ba90e6d7b70c6bc70b99d073ba723efa9d5e35708995da45e1
+
+name:           skat
+version:        0.1.0.8
+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.Minmax
+      Skat.AI.Online
+      Skat.AI.Rulebased
+      Skat.AI.Server
+      Skat.AI.Stupid
+      Skat.Bidding
+      Skat.Card
+      Skat.Matches
+      Skat.Operations
+      Skat.Pile
+      Skat.Player
+      Skat.Player.Utils
+      Skat.Preperation
+      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
+    , exceptions
+    , mtl
+    , network
+    , parallel
+    , random
+    , split
+    , text
+    , transformers
+    , vector
+    , websockets
+  default-language: Haskell2010
+
+executable skat-exe
+  main-is: Main.hs
+  other-modules:
+      TestEnvs
+      Paths_skat
+  hs-source-dirs:
+      app
+  ghc-options: -threaded -rtsopts -with-rtsopts=-N -O2
+  build-depends:
+      aeson
+    , base >=4.7 && <5
+    , bytestring
+    , case-insensitive
+    , containers
+    , deepseq
+    , exceptions
+    , mtl
+    , network
+    , parallel
+    , random
+    , skat
+    , split
+    , text
+    , transformers
+    , vector
+    , 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 -O2
+  build-depends:
+      aeson
+    , base >=4.7 && <5
+    , bytestring
+    , case-insensitive
+    , containers
+    , deepseq
+    , exceptions
+    , mtl
+    , network
+    , parallel
+    , random
+    , skat
+    , split
+    , text
+    , transformers
+    , vector
+    , websockets
+  default-language: Haskell2010

src/Skat.hs

@@ -0,0 +1,78 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+module Skat where
+
+import Control.Monad.State
+import Control.Monad.Writer
+import Control.Monad.Reader
+import Data.List
+import Data.Vector (Vector)
+
+import Skat.Card
+import Skat.Bidding
+import Skat.Pile
+import Skat.Player (Players)
+import qualified Skat.Player as P
+
+data SkatEnv = SkatEnv { piles :: Piles
+                       , turnColour :: Maybe TurnColour
+                       , skatGame :: Game
+                       , players :: Players
+                       , currentHand :: Hand
+                       , skatSinglePlayer :: Hand }
+               deriving Show
+
+type Skat = StateT SkatEnv (WriterT [Trick] IO)
+
+runSkat :: Skat a -> SkatEnv -> IO (a, SkatEnv, [Trick])
+runSkat action env = do
+    ((val, env'), tricks) <- runWriterT $ runStateT action env
+    return (val, env', tricks)
+
+evalSkat :: Skat a -> SkatEnv -> IO a
+evalSkat action = (fmap fst) . runWriterT . evalStateT action
+
+execSkat :: Skat a -> SkatEnv -> IO SkatEnv
+execSkat action = (fmap fst) . runWriterT . execStateT action
+
+instance P.MonadPlayer Skat where
+    trump = getTrump <$> P.game
+    turnColour = gets turnColour
+    showSkat p = case P.team p of
+        Single -> fmap (Just . skatCards) $ gets piles
+        Team -> return Nothing
+    singlePlayer = gets skatSinglePlayer
+    game = gets skatGame
+
+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 TurnColour -> SkatEnv -> SkatEnv
+setTurnColour col sk = sk { turnColour = col }
+
+setCurrentHand :: Hand -> SkatEnv -> SkatEnv
+setCurrentHand hand sk = sk { currentHand = hand }
+
+mkSkatEnv :: Piles -> Maybe TurnColour -> Game -> Players -> Hand -> Hand -> SkatEnv
+mkSkatEnv = SkatEnv
+
+allowedCards :: Skat [CardS Owner]
+allowedCards = do
+    curHand <- gets currentHand
+    pls <- gets players
+    turnCol <- P.turnColour
+    trumpCol <- P.trump
+    getp $ allowed curHand trumpCol turnCol

src/Skat/AI/Human.hs

@@ -1,12 +1,12 @@
-module AI.Human where
+module Skat.AI.Human where
 
 import Control.Monad.Trans (liftIO)
 
-import Player
-import Pile
-import Card
-import Utils
-import Render
+import Skat.Player
+import Skat.Pile
+import Skat.Card
+import Skat.Utils
+import Skat.Render
 
 data Human = Human { getTeam :: Team
                    , getHand :: Hand }
@@ -15,11 +15,11 @@ data Human = Human { getTeam :: Team
 instance Player Human where
     team = getTeam
     hand = getHand
-    chooseCard p table _ hand = do
-        trumpCol <- trumpColour
+    chooseCard p table _ _ hand = do
+        trumpCol <- trump
         turnCol <- turnColour
         let possible = filter (isAllowed trumpCol turnCol hand) hand
-        c <- liftIO $ askIO (map getCard table) possible hand
+        c <- liftIO $ askIO (map getCard table) (map toCard possible) (map toCard hand)
         return $ (c, p)
 
 askIO :: [Card] -> [Card] -> [Card] -> IO Card

src/Skat/AI/Minmax.hs

@@ -0,0 +1,319 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE TupleSections #-}
+
+module Skat.AI.Minmax (
+    choose, playCLI
+) where
+
+import Control.Monad.State
+import Control.Exception (assert)
+import Control.Monad.Fail
+import Data.Ord
+import Text.Read (readMaybe)
+import Data.List (maximumBy, sortBy)
+import Debug.Trace
+
+import qualified Skat as S
+import qualified Skat.Card as S
+import qualified Skat.Operations as S
+import qualified Skat.Pile as S
+import qualified Skat.Player as S hiding (trumpColour, turnColour)
+import qualified Skat.Render as S
+--import TestEnvs (env3, shuffledEnv2)
+
+debug :: Bool
+debug = False
+
+class (Ord v, Eq v) => Value v where
+    invert :: v -> v
+    win :: v
+    loss :: v
+
+class Player p where
+    maxing :: p -> Bool
+
+class (Traversable l, Monad m, Value v, Player p, Eq t) => MonadGame t l v p m | m -> t, m -> p, m -> v, m -> l where
+    currentPlayer :: m p
+    turns :: m (l t)
+    play :: t -> m ()
+    simulate :: t -> m a -> m a
+    evaluate :: m v
+    over :: m Bool
+
+class (MonadIO m, Show t, Show v, Show p, MonadGame t l v p m) => PlayableGame t l v p m | m -> t, m -> p, m -> v where
+    showTurns :: m ()
+    showBoard :: m ()
+    askTurn :: m (Maybe t)
+    showTurn :: t -> m ()
+    winner :: m (Maybe p)
+
+-- Skat implementation
+
+instance Player S.PL where
+    maxing p = S.team p == S.Team
+
+instance Value Int where
+    invert = negate
+    win = 120
+    loss = -120
+
+instance MonadGame (S.CardS S.Owner) [] Int S.PL S.Skat where
+    currentPlayer = do
+        hand <- gets S.currentHand
+        pls <- gets S.players
+        return $! S.player pls hand
+    turns = S.allowedCards
+        --player <- currentPlayer
+        --trCol <- gets S.trumpColour
+        --return $! if maxing player
+        --    then sortBy (optimalTeam trCol) cards
+        --    else sortBy (optimalSingle trCol) cards
+    play = S.play_
+    simulate card action = do
+        --oldCurrent <- gets S.currentHand
+        --oldTurnCol <- gets S.turnColour
+        backup <- get
+        play card
+        --oldWinner <- currentPlayer
+        res <- action
+        --S.undo_ card oldCurrent oldTurnCol (S.team oldWinner)
+        put backup
+        return $! res
+    over = ((==0) . length) <$!> S.allowedCards
+    evaluate = do
+        player <- currentPlayer
+        piles <- gets S.piles
+        let (sgl, tm) = S.count piles
+        return $! (if maxing player then tm - sgl else sgl - tm)
+
+potentialByType :: S.Type -> Int
+potentialByType S.Ace = 11
+potentialByType S.Jack = 10
+potentialByType S.Ten = 4
+potentialByType S.Seven = 7
+potentialByType S.Eight = 7
+potentialByType S.Nine = 7
+potentialByType S.Queen = 5
+potentialByType S.King = 5
+
+optimalSingle :: S.Colour -> S.Card -> S.Card -> Ordering
+optimalSingle trCol (S.Card t1 _) (S.Card t2 _) = (comparing potentialByType) t2 t1
+
+optimalTeam :: S.Colour -> S.Card -> S.Card -> Ordering
+optimalTeam trCol (S.Card t1 _) (S.Card t2 _) = (comparing potentialByType) t2 t1
+
+-- TIC TAC TOE implementation
+
+data TicTacToe = Tic | Tac | Toe
+                 deriving (Eq, Ord)
+
+instance Show TicTacToe where
+    show Tic = "O"
+    show Tac = "X"
+    show Toe = "_"
+
+data WinLossTie = Loss | Tie | Win
+                  deriving (Eq, Show, Ord)
+
+instance Value WinLossTie where
+    invert Win = Loss
+    invert Loss = Win
+    invert Tie = Tie
+    win = Win
+    loss = Loss
+
+data GameState = GameState { getBoard :: [TicTacToe]
+                           , getCurrent :: Bool }
+             deriving Show
+
+instance Player Bool where
+    maxing = id
+
+instance Monad m => MonadGame Int [] WinLossTie Bool (StateT GameState m) where
+    currentPlayer = gets getCurrent
+    turns = do
+        board <- gets getBoard
+        let fields = zip [0..] board
+        return $ map fst $ filter ((==Toe) . snd) fields
+    play turn = do
+        env <- get
+        let value = if getCurrent env then Tic else Tac
+            board' = updateAt turn (getBoard env) value
+            current' = not $ getCurrent env
+        put $ GameState board' current'
+    simulate turn action = do
+        backup <- get
+        play turn
+        res <- action
+        put backup
+        return $! res
+    evaluate = do
+        board <- gets getBoard
+        current <- currentPlayer
+        let mayWinner = ticWinner board
+        case mayWinner of
+            Just Tic -> return $ if current then Win else Loss
+            Just Tac -> return $ if current then Loss else Win
+            Just Toe -> return Tie
+            Nothing -> return Tie
+    over = do
+        board <- gets getBoard
+        case ticWinner board of
+            Just _ -> return True
+            _      -> return False
+
+ticWinner :: [TicTacToe] -> Maybe TicTacToe
+ticWinner board
+    | ticWon    = Just Tic
+    | tacWon    = Just Tac
+    | over      = Just Toe
+    | otherwise = Nothing
+  where ticWon = hasWon $ map (==Tic) board
+        tacWon = hasWon $ map (==Tac) board
+        hasWon (True:_:_:True:_:_:True:_:_:[]) = True
+        hasWon (True:_:_:_:True:_:_:_:True:[]) = True
+        hasWon (_:True:_:_:True:_:_:True:_:[]) = True
+        hasWon (_:_:True:_:_:True:_:_:True:[]) = True
+        hasWon (_:_:True:_:True:_:True:_:_:[]) = True
+        hasWon (True:True:True:_:_:_:_:_:_:[]) = True
+        hasWon (_:_:_:True:True:True:_:_:_:[]) = True
+        hasWon (_:_:_:_:_:_:True:True:True:[]) = True
+        hasWon _                               = False
+        over = (length $ filter (==Toe) board) == 0
+
+updateAt :: Int -> [a] -> a -> [a]
+updateAt n xs y = map f $ zip [0..] xs
+    where f (i, x) = if i == n then y else x
+
+minmax :: (MonadIO m, Show v, Show t, Show p, Value v, Eq t, Player p, MonadGame t l v p m)
+       => Int
+       -> t
+       -> v
+       -> v
+       -> m (t, v)
+minmax depth turn_ alpha beta = (flip evalStateT) (alpha, beta) $ do
+    gameOver <- lift over
+    -- if last step or game is over then evaluate situation
+    if depth == 0 || gameOver then (turn_,) <$> lift evaluate
+    else do
+        -- generate a list of possible turns
+        currentlyMaxing <- maxing <$> lift currentPlayer
+        availableTurns <- lift turns
+        (alpha, beta) <- get
+        -- try every turn, StateT wraps current best turn and current max value
+        (flip execStateT) (turn_, alpha) $ forM_ availableTurns $ \turn -> do
+            currentMax <- gets snd
+            -- beta cutoff
+            unless (currentMax >= beta) $ do
+                value <- lift $! lift $! simulate turn $! do
+                    nextMaxing <- maxing <$!> currentPlayer
+                    if nextMaxing /= currentlyMaxing
+                        then (invert . snd) <$!> minmax (depth-1) turn (invert beta) (invert currentMax)
+                        else snd <$!> minmax (depth-1) turn currentMax beta
+                when (value > currentMax) (put (turn, value))
+
+choose :: (MonadIO m, Show v, Show t, Show p, Value v, Eq t, Player p, MonadGame t l v p m)
+       => Int
+       -> m t
+choose depth = fst <$> minmax depth (error "choose") loss win
+
+emptyBoard :: [TicTacToe]
+emptyBoard = [Toe, Toe, Toe, Toe, Toe, Toe, Toe, Toe, Toe]
+
+otherBoard :: [TicTacToe]
+otherBoard = [Tic, Tac, Tac, Tic, Tac, Tic, Toe, Tic, Toe]
+
+print9x9 :: (Int -> IO ()) -> IO ()
+print9x9 pr = pr 0 >> pr 1 >> pr 2 >> putStrLn ""
+    >> pr 3 >> pr 4 >> pr 5 >> putStrLn ""
+    >> pr 6 >> pr 7 >> pr 8 >> putStrLn ""
+
+printBoard :: [TicTacToe] -> IO ()
+printBoard board = print9x9 pr >> putStrLn ""
+    where pr n = putStr (show $ board !! n) >> putStr " "
+
+printOptions :: [Int] -> IO ()
+printOptions opts = print9x9 pr
+    where pr n
+            | n `elem` opts = putStr (show n) >> putStr " "
+            | otherwise     = putStr "  "
+
+instance MonadIO m => PlayableGame Int [] WinLossTie Bool (StateT GameState m) where
+    showBoard = do
+        board <- gets getBoard
+        liftIO $ printBoard board
+    showTurns = turns >>= liftIO . printOptions
+    winner = do
+        board <- gets getBoard
+        let win = ticWinner board
+        case win of
+            Just Toe -> return Nothing
+            Just Tic -> return $ Just True
+            Just Tac -> return $ Just False
+            Nothing -> return Nothing
+    askTurn = readMaybe <$> liftIO getLine
+    showTurn _ = return ()
+
+instance PlayableGame (S.CardS S.Owner) [] Int S.PL S.Skat where
+    showBoard = do
+        liftIO $ putStrLn ""
+        table <- S.getp S.tableCards
+        liftIO $ putStr "Table: "
+        liftIO $ print table
+    showTurns = do
+        cards <- turns
+        player <- currentPlayer
+        liftIO $ print player
+        liftIO $ S.render cards
+    winner = do
+        piles <- gets S.piles
+        pls <- gets S.players
+        let res = S.count piles :: (Int, Int)
+            winnerTeam = trace (show res) $ if fst res > snd res then S.Single else S.Team
+            winners = filter ((==winnerTeam) . S.team) (S.playersToList pls)
+        return $ Just $ head winners
+    askTurn = do
+        cards <- turns
+        let sorted = cards
+        input <- liftIO getLine
+        case readMaybe input of
+            Just n -> if n >= 0 && n < length sorted then return $ Just (sorted !! n)
+                else return Nothing
+            Nothing -> return Nothing
+    showTurn card = do
+        player <- currentPlayer
+        liftIO $ putStrLn $ show player ++ " plays " ++ show card
+
+playCLI :: (MonadFail m, Read t, PlayableGame t l v p m) => m ()
+playCLI = do
+    gameOver <- over
+    if gameOver
+        then announceWinner
+        else do
+            when debug showBoard
+            current <- currentPlayer
+            turn <- choose 10
+            when debug $ showTurn turn
+            play turn
+            playCLI
+   where
+      readTurn :: (MonadFail m, Read t, PlayableGame t l v p m) => m t
+      readTurn = do
+        options <- turns
+        showTurns
+        liftIO $ putStr "> "
+        mayTurn <- askTurn
+        case mayTurn of
+            Just val -> if val `elem` options then return val else readTurn
+            Nothing -> readTurn
+      announceWinner = do
+        showBoard
+        win <- winner
+        liftIO $ putStrLn $ show win ++ " wins the game!"
+
+playTicTacToe :: IO ()
+playTicTacToe = void $ (flip runStateT) (GameState emptyBoard True) playCLI

src/Skat/AI/Online.hs

@@ -0,0 +1,215 @@
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Skat.AI.Online where
+
+import Control.Monad.Reader
+import Control.Concurrent.Chan
+import Data.Aeson hiding (Result)
+import Data.Maybe
+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
+import Skat.Preperation
+import Skat.Bidding
+
+class Communicator a where
+    send :: a -> String -> IO ()
+    receive :: a -> IO String
+
+instance Communicator (Chan String) where
+    send = writeChan
+    receive = readChan
+
+class Monad m => MonadClient m where
+    query :: String -> m ()
+    response :: m String
+
+data OnlineEnv c = OnlineEnv { getTeam :: Team
+                             , getHand :: Hand
+                             , connection :: c }
+
+data PrepOnline c = PrepOnline { prepHand :: Hand
+                               , prepConnection :: c
+                               , prepCards :: [Card] }
+
+instance Show (OnlineEnv c) where
+    show _ = "An online env"
+
+instance Show (PrepOnline c) where
+    show _ = "An online prep env"
+
+instance Communicator c => Player (OnlineEnv c) where
+    team = getTeam
+    hand = getHand
+    chooseCard p table _ mayOuvert hand = runReaderT (choose table mayOuvert hand) p >>= \c -> return (c, p)
+    onCardPlayed p c = runReaderT (cardPlayed c) p >> return p
+
+instance Communicator c => Bidder (PrepOnline c) where
+    hand = prepHand
+    askBid p against bid = do
+        liftIO $ send (prepConnection p) (BS.unpack $ encode $ BidQuery against bid)
+        r <- liftIO $ receive (prepConnection p)
+        case decode (BS.pack r) of
+            Just (BidResponse newBid) -> do
+                if newBid > bid then return $ Just newBid else return Nothing
+            Nothing -> askBid p against bid
+    askResponse p bidder bid = do
+        liftIO $ send (prepConnection p) (BS.unpack $ encode $ BidResponseQuery bidder bid)
+        r <- liftIO $ receive (prepConnection p)
+        case decode (BS.pack r) of
+            Just (YesNo value) -> return value
+            Nothing -> askResponse p bidder bid
+    askGame p bid = do
+        liftIO $ send (prepConnection p) (BS.unpack $ encode $ AskGameQuery bid)
+        r <- liftIO $ receive (prepConnection p)
+        case decode (BS.pack r) of
+            Just (GameResponse game) -> return game
+            Nothing -> askGame p bid
+    askHand p bid = do
+        liftIO $ send (prepConnection p) (BS.unpack $ encode $ AskHandQuery)
+        r <- liftIO $ receive (prepConnection p)
+        case decode (BS.pack r) of
+            Just (YesNo value) -> return value
+            Nothing -> askHand p bid
+    askSkat p bid cards = do
+        liftIO $ send (prepConnection p) (BS.unpack $ encode $ AskSkatQuery cards bid)
+        r <- liftIO $ receive (prepConnection p)
+        case decode (BS.pack r) of
+            Just (ChosenCards cards) -> return cards
+            Nothing -> askSkat p bid cards
+    toPlayer p tm = PL $ OnlineEnv tm (prepHand p) (prepConnection p)
+    onBid p mayBid reizer gereizter =
+        liftIO $ send (prepConnection p) (BS.unpack $ encode $ BidEvent mayBid reizer gereizter)
+    onResponse p response reizer gereizter =
+        liftIO $ send (prepConnection p) (BS.unpack $ encode $ ResponseEvent response reizer gereizter)
+    onStart p = do
+        let cards = sortRender Jacks $ prepCards p
+        liftIO $ send (prepConnection p) (BS.unpack $ encode $ CardsQuery cards)
+    onResult p res =
+        liftIO $ send (prepConnection p) (BS.unpack $ encode $ GameResultsQuery res)
+    onGame p game sglPlayer = do
+        liftIO $ send (prepConnection p) (BS.unpack $ encode $ GameStartQuery game sglPlayer)
+    onNoGame p = do
+        liftIO $ send (prepConnection p) (BS.unpack $ encode $ NoGameQuery)
+
+type Online a m = ReaderT (OnlineEnv a) m
+
+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
+    trump = lift $ trump
+    turnColour = lift $ turnColour
+    showSkat = lift . showSkat
+    singlePlayer = lift singlePlayer
+    game = lift game
+
+choose :: (HasCard b, HasCard a) => (Communicator c, MonadPlayer m) => [CardS Played] -> Maybe [b] -> [a] -> Online c m Card
+choose table mayOuvert hand' = do
+    gm <- game
+    let hand = sortRender (getTrump gm) $ map toCard hand'
+        ouvertCards = fmap (sortRender (getTrump gm) . map toCard) mayOuvert
+    query (BS.unpack $ encode $ ChooseQuery hand table ouvertCards)
+    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 mayOuvert hand'
+        Nothing -> choose table mayOuvert hand'
+
+cardPlayed :: (Communicator c, MonadPlayer m) => CardS Played -> Online c m ()
+cardPlayed card = query (BS.unpack $ encode $ CardPlayedQuery card)
+
+-- | QUERIES AND RESPONSES
+    
+data Query = ChooseQuery [Card] [CardS Played] (Maybe [Card])
+           | CardPlayedQuery (CardS Played)
+           | GameResultsQuery Result
+           | GameStartQuery HideGame Hand
+           | BidQuery Hand Bid
+           | BidResponseQuery Hand Bid
+           | AskGameQuery Bid
+           | AskHandQuery
+           | AskSkatQuery [Card] Bid
+           | CardsQuery [Card]
+           | BidEvent (Maybe Bid) Hand Hand
+           | ResponseEvent Bool Hand Hand
+           | NoGameQuery
+
+newtype ChosenResponse = ChosenResponse Card
+newtype BidResponse = BidResponse Int
+newtype YesNo = YesNo Bool
+newtype GameResponse = GameResponse Game
+                       deriving Show
+newtype ChosenCards = ChosenCards [Card]
+     
+instance ToJSON Query where
+    toJSON (ChooseQuery hand table mayOuvert) =
+        object [ "query" .= ("choose_card" :: String), "hand" .= hand, "table" .= table
+               , "single_hand" .= mayOuvert]
+    toJSON (CardPlayedQuery card) =
+        object ["query" .= ("card_played" :: String), "card" .= card]
+    toJSON (GameResultsQuery result) =
+        object ["query" .= ("results" :: String), "result" .= result]
+    toJSON (GameStartQuery game sglPlayer) =
+        object [ "query" .= ("start_game" :: String)
+               , "game" .= game
+               , "single" .= show sglPlayer ]
+    toJSON (BidQuery hand bid) =
+        object ["query" .= ("bid" :: String), "whom" .= show hand, "current" .= bid]
+    toJSON (BidResponseQuery hand bid) =
+        object ["query" .= ("bid_response" :: String), "from" .= show hand, "bid" .= bid ]
+    toJSON (AskHandQuery) =
+        object ["query" .= ("play_hand" :: String)]
+    toJSON (AskSkatQuery cards bid) =
+        object ["query" .= ("skat" :: String), "cards" .= cards, "bid" .= bid ]
+    toJSON (CardsQuery cards) =
+        object ["query" .= ("cards" :: String), "cards" .= cards ]
+    toJSON (AskGameQuery bid) =
+        object ["query" .= ("ask_game" :: String), "bid" .= bid]
+    toJSON (BidEvent (Just bid) reizer gereizter) =
+        object ["query" .= ("bid_event" :: String), "bid" .= bid, "reizer" .= show reizer,
+                "gereizter" .= show gereizter ]
+    toJSON (BidEvent Nothing reizer gereizter) =
+        object [ "query" .= ("bid_event" :: String)
+               , "bid" .= ("weg" :: String)
+               , "reizer" .= show reizer
+               , "gereizter" .= show gereizter ]
+    toJSON (ResponseEvent response reizer gereizter) =
+        object [ "query" .= ("response_event" :: String)
+               , "response" .= response
+               , "reizer" .= show reizer
+               , "gereizter" .= show gereizter ]
+    toJSON NoGameQuery =
+        object [ "query" .= ("no_game" :: String) ]
+
+instance FromJSON ChosenResponse where
+    parseJSON = withObject "ChosenResponse" $ \v -> ChosenResponse
+        <$> v .: "card"
+
+instance FromJSON BidResponse where
+    parseJSON = withObject "BidResponse" $ \v -> BidResponse
+        <$> v .: "bid"
+
+instance FromJSON YesNo where
+    parseJSON = withObject "BidYesNo" $ \v -> YesNo
+        <$> v .: "yesno"
+
+instance FromJSON GameResponse where
+    parseJSON = withObject "GameResponse" $ \v -> GameResponse
+        <$> v .: "game"
+
+instance FromJSON ChosenCards where
+    parseJSON = withObject "ChosenCards" $ \v -> ChosenCards
+        <$> v .: "cards"

src/Skat/AI/Rulebased.hs

@@ -3,24 +3,30 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE FlexibleContexts #-}
 
-module AI.Rulebased (
-    mkAIEnv
+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 Player
-import qualified Player.Utils as P
-import Pile
-import Card
-import Utils
-import Skat (Skat, modifyp, mkSkatEnv) 
-import Operations
+import Skat.Player
+import qualified Skat.Player.Utils as P
+import Skat.Pile hiding (isSkat)
+import Skat.Card
+import Skat.Utils
+import Skat (Skat, modifyp, mkSkatEnv, evalSkat)
+import Skat.Operations
+import qualified Skat.AI.Minmax as Minmax
+import qualified Skat.AI.Stupid as Stupid (Stupid(..))
+import Skat.Bidding
 
 data AIEnv = AIEnv { getTeam :: Team
                    , getHand :: Hand
@@ -50,8 +56,8 @@ modifyg f = modify g
 type AI m = StateT AIEnv m
 
 instance MonadPlayer m => MonadPlayer (AI m) where
-    trumpColour = lift $ trumpColour
-    turnColour = lift $ turnColour
+    trump = lift trump
+    turnColour = lift turnColour
     showSkat = lift . showSkat
 
 instance MonadPlayerOpen m => MonadPlayerOpen (AI m) where
@@ -60,7 +66,7 @@ instance MonadPlayerOpen m => MonadPlayerOpen (AI m) where
 type Simulator m = ReaderT Piles (AI m)
 
 instance MonadPlayer m => MonadPlayer (Simulator m) where
-    trumpColour = lift $ trumpColour
+    trump = lift trump
     turnColour = lift $ turnColour
     showSkat = lift . showSkat
 
@@ -74,9 +80,9 @@ runWithPiles ps sim = runReaderT sim ps
 instance Player AIEnv where
     team = getTeam
     hand = getHand
-    chooseCard p table fallen hand = runStateT (do
+    chooseCard p table fallen _ hand = runStateT (do
         modify $ setTable table
-        modify $ setHand hand
+        modify $ setHand (map toCard hand)
         modify $ setFallen fallen
         choose) p
     onCardPlayed p card = execStateT (do
@@ -107,15 +113,15 @@ has hand cs = M.mapWithKey f
             | card `elem` cs = [H hand]
             | otherwise      = hands
 
-hasNoLonger :: MonadPlayer m => Hand -> Colour -> AI m ()
+hasNoLonger :: MonadPlayer m => Hand -> TurnColour -> AI m ()
 hasNoLonger hand colour = do
-    trCol <- trumpColour
+    trCol <- trump
     modifyg $ hasNoLonger_ trCol hand colour
 
-hasNoLonger_ :: Colour -> Hand -> Colour -> Guess -> Guess
-hasNoLonger_ trColour hand effCol = M.mapWithKey f
+hasNoLonger_ :: Trump -> Hand -> TurnColour -> Guess -> Guess
+hasNoLonger_ trump hand effCol = M.mapWithKey f
     where f card hands
-            | effectiveColour trColour card == effCol && (H hand) `elem` hands = filter (/=H hand) hands
+            | effectiveColour trump card == effCol && (H hand) `elem` hands = filter (/=H hand) hands
             | otherwise = hands
 
 isSkat :: [Card] -> Guess -> Guess
@@ -131,30 +137,34 @@ analyzeTurn (c1, c2, c3) = do
     modifyg (getCard c1 `hasBeenPlayed`)
     modifyg (getCard c2 `hasBeenPlayed`)
     modifyg (getCard c3 `hasBeenPlayed`)
-    trCol <- trumpColour
+    trCol <- trump
     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
+        then uorigin (getPile c2) `hasNoLonger` demanded
         else return ()
     if col3 /= demanded
-        then origin c3 `hasNoLonger` demanded
+        then uorigin (getPile 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
+toPiles table (h1, h2, h3, skt) = makePiles h1 h2 h3 table 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 (comparing $ length . snd) $ M.toList 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 =
@@ -177,71 +187,65 @@ distributions guess nos =
                 in filterMap isOk (f card) hands
           cardsPerHand = (length guess - 2) `div` 3
 
-simplify :: Int -> [Distribution] -> [Distribution]
-simplify 10 ds = nubBy is789Variation ds
-simplify _ ds = ds
+type Abstract = (Int, Int, Int, Int)
 
-is789Variation :: Distribution -> Distribution -> Bool
-is789Variation (ha1, ha2, ha3, sa) (hb1, hb2, hb3, sb) =
-        f ha1 hb1 && f ha2 hb2 && f ha3 hb3 && f sa sb
-    where f cs1 cs2
-             | n789s cs1 /= n789s cs2 = False
-             | otherwise = and (zipCs (c789s cs1) (c789s cs2))
+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)
 
-zipCs :: [[Card]] -> [[Card]] -> [Bool]
-zipCs xs ys = zipWith g xs ys
+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)
 
-c789s :: [Card] -> [[Card]]
-c789s cs = groupBy (grouping getColour) $
-    sortBy (comparing getColour) $
-    filter ((==(0 :: Int)) . count) cs
-
-n789s :: [Card] -> [Card]
-n789s cs = filter ((/=(0 :: Int)) . count) cs
-
-g :: [a] -> [b] -> Bool
-g xs ys = length xs == length ys
+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
+    trCol <- trump
     turnCol <- turnColour
     let col = effectiveColour trCol (getCard c)
     case turnCol of
         Just demanded -> if col /= demanded
-            then origin c `hasNoLonger` demanded else return ()
+            then uorigin (getPile 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
+choose = 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 -> 2
-                    5 -> 1
-                    6 -> 1
-                    7 -> 1
-                    8 -> 1
-                    9 -> 1
-                    10 -> 1
+    table <- gets table
+    let tableNo = length table
+        left = 3 - tableNo
+        depth = case length handCards of
+            10 -> 3 + tableNo
+            9 -> 3 + tableNo
+            8 -> 3 + tableNo
+            7 -> 6 + tableNo
+            6 -> 9 + tableNo
+            5 -> 12 + tableNo
+            4 -> 15 + tableNo
+            _ -> 100
     modify $ setDepth depth
     guess__ <- gets guess
     self <- get
@@ -250,18 +254,19 @@ chooseStatistic = do
         guess = case maySkat of
             Just cs -> (cs `isSkat`) guess_
             Nothing -> guess_
-    table <- gets table
-    let ns = case length table of
+    let ns = case tableNo of
                 0 -> (0,  0,  0, 0)
                 1 -> (-1, 0, -1, 0)
                 2 -> (0,  0, -1, 0)
-    let dis = distributions guess ns
-        disNo = length dis
-        piless = map (toPiles table) dis
-        limit = if depth == 1 && length table == 2
-            then 1
-            else min 10000 $ disNo `div` 2
-    liftIO $ putStrLn $ "possible distrs " ++ show disNo
+    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 = 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
     liftIO $ print vals
     return $ fst $ maximumBy (comparing snd) vals
@@ -280,10 +285,10 @@ foldWithLimit limit f start (x:xs) = do
         _ -> return start
 
 runOnPiles :: MonadPlayer m
-           => M.Map Card Int -> Piles -> AI m (M.Map Card Int)
-runOnPiles m ps = do
+           => 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 1 m
+    return $ M.insertWith (+) c n m
 
 chooseOpen :: (MonadState AIEnv m, MonadPlayerOpen m) => m Card
 chooseOpen = do
@@ -291,28 +296,28 @@ chooseOpen = do
     hand <- gets getHand
     let myCards = handCards hand piles
     possible <- filterM (P.isAllowed myCards) myCards
-    case length myCards of
+    case length possible of
         0 -> do
             liftIO $ print hand
             liftIO $ print piles
             error "no cards left to choose from"
-        1 -> return $ head myCards
+        1 -> return $ toCard $ head possible
         _ -> 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
+    turnCol <- turnColour
+    trumpCol <- trump
+    myHand <- gets getHand
+    depth <- gets simulationDepth
+    let ps = Players (PL $ Stupid.Stupid Team Hand1)
+                     (PL $ Stupid.Stupid Team Hand2)
+                     (PL $ Stupid.Stupid Single Hand3)
+        -- TODO: fix
+        env = mkSkatEnv piles turnCol undefined ps myHand undefined
+    liftIO $ evalSkat (toCard <$> (Minmax.choose depth :: Skat (CardS Owner))) env
 
 simulate :: (MonadState AIEnv m, MonadPlayerOpen m)
          => Card -> m Int
@@ -320,21 +325,23 @@ simulate card = do
     -- retrieve all relevant info
     piles <- showPiles
     turnCol <- turnColour
-    trumpCol <- trumpColour
+    trumpCol <- trump
     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
             (PL $ mkAIEnv Team Hand1 newDepth)
             (PL $ mkAIEnv Team Hand2 newDepth)
             (PL $ mkAIEnv Single Hand3 newDepth)
-        env = mkSkatEnv piles turnCol trumpCol ps
+        -- TODO: fix
+        env = mkSkatEnv piles turnCol undefined ps (next myHand) undefined
     -- simulate the game after playing the given card
-    (sgl, tm) <- liftIO $ evalStateT (do
-        modifyp $ playCard card
-        turnGeneric playOpen depth (next myHand)) env
+    (sgl, tm) <- liftIO $ evalSkat (do
+        modifyp $ playCard myHand card
+        turnGeneric playOpen depth) 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
@@ -347,26 +354,27 @@ predictValue (own, others) = do
     piles <- showPiles
     let cs = handCards hand piles
     pot <- potential cs
-    return $ own + pot
+    --return $ own + pot
+    return (own-others)
 
-potential :: (MonadState AIEnv m, MonadPlayerOpen m)
-          => [Card] -> m Int
+potential :: (MonadState AIEnv m, MonadPlayerOpen m, HasCard c)
+          => [c] -> m Int
 potential cs = do
-    tr <- trumpColour
+    tr <- trump
     let trs = filter (isTrump tr) cs
-        value = count cs
-    positions <- filter (==0) <$> mapM position cs
+        value = count . map toCard $ cs
+    positions <- filter (==0) <$> mapM (position . toCard) cs
     return $ length trs * 10 + value + length positions * 5
 
 position :: (MonadState AIEnv m, MonadPlayer m)
          => Card -> m Int
 position card = do
-    tr <- trumpColour
+    tr <- trump
     guess <- gets guess
     let effCol = effectiveColour tr card
         l = M.toList guess
         cs = filterMap ((==effCol) . effectiveColour tr . fst) fst l
-        csInd = zip [0..] cs
+        csInd = zip [0..] (reverse cs)
         Just (pos, _) = find ((== card) . snd) csInd
     return pos
 
@@ -384,8 +392,11 @@ chooseLead :: (MonadState AIEnv m, MonadPlayer m) => m Card
 chooseLead = do
     cards <- gets myHand
     possible <- filterM (P.isAllowed cards) cards
+    liftIO $ putStrLn $ "choosing lead from " ++ show possible
     pots <- mapM leadPotential possible
-    return $ snd $ maximumBy (comparing fst) (zip pots possible)
+    let ps = zip pots possible
+    liftIO $ putStrLn $ "lead potential of cards " ++ show ps
+    return $ snd $ maximumBy (comparing fst) ps
 
 mkAIEnv :: Team -> Hand -> Int -> AIEnv
 mkAIEnv tm h depth = AIEnv tm h [] [] [] newGuess depth
@@ -396,10 +407,21 @@ aienv :: AIEnv
 aienv = AIEnv Single Hand3 [] [] [] newGuess 10
 
 testguess :: Guess
-testguess = isSkat (take 2 $ drop 10 allCards)
-        $ Hand3 `has` (take 10 allCards) $ m
-    where l = map (\c -> (c, [H Hand1, H Hand2, H Hand3, Skt])) (take 32 allCards)
+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,110 @@
+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
+    addr <- Net.addrAddress <$> resolve
+    Net.bind sock addr
+    Net.listen sock 5
+    chan <- newChan
+    forkIO $ forever $ do
+        msg <- readChan chan -- clearing the main channel
+        return ()
+    return (ServerEnv buffermode sock chan handler)
+  where resolve = do
+            let hints = Net.defaultHints { Net.addrSocketType = Net.Stream }
+            addrs <- Net.getAddrInfo (Just hints) (Just "127.0.0.1") (Just $ show port)
+            return $ head addrs
+
+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,38 @@
+module Skat.AI.Stupid where
+
+import Control.Concurrent
+import Control.Monad.State
+
+import Skat.Player
+import Skat.Pile
+import Skat.Card
+import Skat.Preperation
+import Skat.Bidding
+
+data Stupid = Stupid { getTeam :: Team
+                     , getHand :: Hand }
+              deriving Show
+
+instance Player Stupid where
+    team = getTeam
+    hand = getHand
+    chooseCard p _ _ _ hand = do
+        trumpCol <- trump
+        turnCol <- turnColour
+        liftIO $ threadDelay 1000000
+        let possible = filter (isAllowed trumpCol turnCol hand) hand
+        return (toCard $ head possible, p)
+
+newtype NoBidder = NoBidder Hand
+                   deriving Show
+
+-- | no bidding from that player
+instance Bidder NoBidder where
+    hand (NoBidder h) = h
+    askBid _ _ bid = return $ Just 120
+    askResponse _ _ bid = if bid < 24 then return True else return False
+    askGame _ _ = return $ Grand Hand
+    askHand _ _ = return True
+    askSkat _ _ _ = undefined -- never called
+    toPlayer (NoBidder h) team = PL $ Stupid team h
+    onStart _ = return ()

src/Skat/Bidding.hs

@@ -0,0 +1,282 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Skat.Bidding (
+    biddingScore, Game(..), Modifier(..), isHand, getTrump, Result(..),
+    getResults, isOuvert, isSchwarz, Bid, checkGame, HideGame(..)
+) where
+
+import Data.Aeson hiding (Null, Result)
+
+import Skat.Card
+import Data.List (sortOn)
+import Data.Ord (Down(..))
+import Control.Monad
+import Skat.Pile
+
+type Bid = Int
+
+-- | different game types
+data Game = Colour Colour Modifier
+          | Grand Modifier
+          | Null
+          | NullHand
+          | NullOuvert
+          | NullOuvertHand
+            deriving (Show, Eq)
+
+newtype HideGame = HideGame Game
+                   deriving (Show, Eq)
+
+instance ToJSON Game where
+    toJSON (Grand mod) =
+        object ["game" .= ("grand" :: String), "modifier" .= show mod]
+    toJSON (Colour col mod) =
+        object ["game" .= ("colour" :: String), "modifier" .= show mod, "colour" .= show col]
+    toJSON Null           = object ["game" .= ("null" :: String)]
+    toJSON NullHand       = object ["game" .= ("nullhand" :: String)]
+    toJSON NullOuvert     = object ["game" .= ("nullouvert" :: String)]
+    toJSON NullOuvertHand = object ["game" .= ("nullouverthand" :: String)]
+
+instance ToJSON HideGame where
+    toJSON (HideGame (Grand mod)) =
+        object ["game" .= ("grand" :: String), "modifier" .= prettyShow mod]
+    toJSON (HideGame (Colour col mod)) =
+        object ["game" .= ("colour" :: String), "modifier" .= prettyShow mod, "colour" .= show col]
+    toJSON (HideGame game) = toJSON game
+
+instance FromJSON Game where
+    parseJSON = withObject "Game" $ \v -> do
+        gamekind <- v .: "game"
+        case (gamekind :: String) of
+            "colour" -> do
+                col <- v .: "colour"
+                mod <- v .: "modifier"
+                return $ Colour (read col) mod
+            "grand" -> do
+                mod <- v .: "modifier"
+                return $ Grand mod
+            "null" -> return Null
+            "nullhand" -> return NullHand
+            "nullouvert" -> return NullOuvert
+            "nullouverthand" -> return NullOuvertHand
+            _ -> mzero
+
+-- | modifiers for grand and colour games
+data Modifier = Einfach
+              | Schneider
+              | Schwarz
+              | Hand
+              | HandSchneider
+              | HandSchneiderAngesagt
+              | HandSchwarz
+              | HandSchneiderAngesagtSchwarz
+              | HandSchwarzAngesagt
+              | Ouvert
+                deriving (Show, Eq)
+
+instance FromJSON Modifier where
+    parseJSON = withObject "Modifier" $ \v -> do
+        hnd <- v .: "hand"
+        if hnd then do
+            schneider <- v .:? "schneider" .!= False
+            schwarz <- v .:? "schwarz" .!= False
+            ouvert <- v .:? "ouvert" .!= False
+            case (schneider, schwarz, ouvert) of
+                (_, _, True) -> return Ouvert
+                (True, False, _) -> return HandSchneiderAngesagt
+                (_, True, _) -> return HandSchwarzAngesagt
+                _ -> return Hand
+        else return Einfach
+
+prettyShow :: Modifier -> String
+prettyShow Schneider                    = show Einfach
+prettyShow Schwarz                      = show Einfach
+prettyShow HandSchneider                = show Hand
+prettyShow HandSchwarz                  = show Hand
+prettyShow HandSchneiderAngesagtSchwarz = show HandSchneiderAngesagt
+prettyShow mod                          = show mod
+
+isHand :: Game -> Bool
+isHand NullHand = True
+isHand NullOuvertHand = True
+isHand (Colour _ mod) = modIsHand mod
+isHand (Grand mod) = modIsHand mod
+isHand _ = False
+
+modIsHand :: Modifier -> Bool
+modIsHand Einfach   = False
+modIsHand Schneider = False
+modIsHand Schwarz   = False
+modIsHand _         = True
+
+isOuvert :: Game -> Bool
+isOuvert NullOuvert        = True
+isOuvert NullOuvertHand    = True
+isOuvert (Grand Ouvert)    = True
+isOuvert (Colour _ Ouvert) = True
+isOuvert _                 = False
+
+baseFactor :: Game -> Int
+baseFactor (Grand _)           = 24
+baseFactor (Colour Clubs _)    = 12
+baseFactor (Colour Spades _)   = 11
+baseFactor (Colour Hearts _)   = 10
+baseFactor (Colour Diamonds _) = 9
+baseFactor Null                = 23
+baseFactor NullHand            = 35
+baseFactor NullOuvert          = 46
+baseFactor NullOuvertHand      = 59
+
+-- | calculate the value of a game with given cards
+biddingScore :: HasCard c => Game -> [c] -> Int
+biddingScore game@(Grand           mod) cards = (spitzen game cards + modifierFactor mod) * 24
+biddingScore game@(Colour Clubs    mod) cards = (spitzen game cards + modifierFactor mod) * 12
+biddingScore game@(Colour Spades   mod) cards = (spitzen game cards + modifierFactor mod) * 11
+biddingScore game@(Colour Hearts   mod) cards = (spitzen game cards + modifierFactor mod) * 10
+biddingScore game@(Colour Diamonds mod) cards = (spitzen game cards + modifierFactor mod) * 9
+biddingScore game                       _     = baseFactor game
+
+-- | calculate the modifier based on the game kind
+modifierFactor :: Modifier -> Int
+modifierFactor Einfach                      = 1
+modifierFactor Schneider                    = 2
+modifierFactor Schwarz                      = 3
+modifierFactor Hand                         = 2
+modifierFactor HandSchneider                = 3
+modifierFactor HandSchneiderAngesagt        = 4
+modifierFactor HandSchwarz                  = 4
+modifierFactor HandSchneiderAngesagtSchwarz = 5
+modifierFactor HandSchwarzAngesagt          = 6
+modifierFactor Ouvert                       = 7
+
+-- | get all available trumps for a given game
+allTrumps :: Game -> [Card]
+allTrumps (Grand _) = jacks
+allTrumps (Colour col _) = jacks ++ [Card t col | t <- [Ace,Ten .. Seven] ]
+
+jacks :: [Card]
+jacks = [ Card Jack Clubs, Card Jack Spades, Card Jack Hearts, Card Jack Diamonds ]
+
+-- | calculate the spitzen count
+spitzen :: HasCard c => Game -> [c] -> Int
+spitzen game cards
+      | null trumps = length $ allTrumps game
+      | mit = foldl (\val (a, o) -> if a == o then val + 1 else val) 0 zipped
+      | otherwise = findOhne (allTrumps game) 0
+    where trumps = getTrumps game cards
+          zipped = zip (allTrumps game) trumps
+          mit = Card Jack Clubs == head trumps
+          findOhne []     acc = acc
+          findOhne (c:cs) acc = if c /= highest then findOhne cs (acc+1) else acc
+          highest = head trumps
+
+-- | get all trumps for a given game out of a hand of cards
+getTrumps :: HasCard c => Game -> [c] -> [Card]
+getTrumps (Grand _) cards = sortOn Down $ filter (isTrump Jacks) $ map toCard cards
+getTrumps (Colour col _) cards = sortOn Down $ filter (isTrump $ TrumpColour col) $ map toCard cards
+getTrumps _              _      = []
+
+-- | get trump for a given game
+getTrump :: Game -> Trump
+getTrump (Colour col _) = TrumpColour col
+getTrump (Grand _)      = Jacks
+getTrump _              = None
+
+data Result = Result { resultGame :: Game
+                     , resultScore :: Int
+                     , resultSinglePoints :: Int
+                     , resultTeamPoints :: Int }
+              deriving (Show, Eq)
+
+instance ToJSON Result where
+    toJSON (Result game points sgl tm) =
+        object ["game" .= game, "points" .= points, "single" .= sgl, "team" .= tm]
+
+isSchwarz :: Team -> Piles -> Bool
+isSchwarz tm = null . wonCards tm 
+
+hasWon :: Game -> Piles -> (Bool, Game)
+hasWon Null           ps = (Single `isSchwarz` ps, Null)
+hasWon NullHand       ps = (Single `isSchwarz` ps, NullHand)
+hasWon NullOuvert     ps = (Single `isSchwarz` ps, NullOuvert)
+hasWon NullOuvertHand ps = (Single `isSchwarz` ps, NullOuvertHand)
+hasWon (Colour col mod) ps = let (b, mod') = meetsCall mod ps
+                             in (b, Colour col mod')
+hasWon (Grand mod) ps = let (b, mod') = meetsCall mod ps
+                        in (b, Grand mod')
+
+meetsCall :: Modifier -> Piles -> (Bool, Modifier)
+meetsCall Hand ps = case wonByPoints ps of
+    (b, Schneider) -> (b, HandSchneider)
+    (b, Schwarz) -> (b, HandSchwarz)
+    (b, Einfach) -> (b, Hand)
+meetsCall Schneider ps = case wonByPoints ps of
+    (b, Schneider) -> (b, Schneider)
+    (b, Schwarz) -> (b, Schwarz)
+    (b, Einfach) -> (False, Schneider)
+meetsCall Schwarz ps = case wonByPoints ps of
+    (b, Schneider) -> (False, Schwarz)
+    (b, Schwarz) -> (b, Schwarz)
+    (b, Einfach) -> (False, Schwarz)
+meetsCall HandSchneider ps = case wonByPoints ps of
+    (b, Schneider) -> (b, HandSchneider)
+    (b, Schwarz) -> (b, HandSchwarz)
+    (b, Einfach) -> (False, HandSchneider)
+meetsCall HandSchneiderAngesagt ps = case wonByPoints ps of
+    (b, Schneider) -> (b, HandSchneiderAngesagt)
+    (b, Schwarz) -> (b, HandSchneiderAngesagtSchwarz)
+    (b, Einfach) -> (False, HandSchneiderAngesagt)
+meetsCall HandSchwarz ps = case wonByPoints ps of
+    (b, Schneider) -> (False, HandSchwarz)
+    (b, Schwarz) -> (b, HandSchwarz)
+    (b, Einfach) -> (False, HandSchwarz)
+meetsCall HandSchwarzAngesagt ps = case wonByPoints ps of
+    (b, Schneider) -> (False, HandSchwarzAngesagt)
+    (b, Schwarz) -> (b, HandSchwarzAngesagt)
+    (b, Einfach) -> (False, HandSchwarzAngesagt)
+meetsCall Ouvert ps = case wonByPoints ps of
+    (b, Schneider) -> (False, Ouvert)
+    (b, Schwarz) -> (b, Ouvert)
+    (b, Einfach) -> (False, Ouvert)
+meetsCall _ ps = wonByPoints ps
+
+wonByPoints :: Piles -> (Bool, Modifier)
+wonByPoints ps
+    | Team `isSchwarz` ps    = (True,     Schwarz)
+    | sgl              >= 90 = (True,     Schneider)
+    | Single `isSchwarz` ps  = (False,    Schwarz)
+    | sgl              <= 30 = (False,    Schneider)
+    | otherwise              = (sgl > 60, Einfach)
+  where (sgl, _) = count ps :: (Int, Int)
+
+-- | get result of game
+getResults :: Game -> Bid -> Hand -> Piles -> Piles -> Result
+getResults game bid sglPlayer before after = case checkGame bid hand game of
+        Just game' -> let (won, afterGame) = hasWon game' after
+                          gameScore = biddingScore afterGame hand 
+                          score = if won then gameScore else (-2) * gameScore
+            in Result afterGame score sglPoints teamPoints
+        Nothing -> let gameScore = baseFactor game * ceiling (fromIntegral bid / fromIntegral (baseFactor game))
+                       score = (-2) * gameScore
+            in Result game score sglPoints teamPoints
+    where hand = skatCards before ++ (map toCard $ handCards sglPlayer before)
+          (sglPoints, teamPoints) = count after
+
+checkGame :: HasCard c => Bid -> [c] -> Game -> Maybe Game
+checkGame bid cards game@(Colour col mod)
+    | biddingScore game cards >= bid = Just game
+    | otherwise                      = upgrade mod >>= \mod' -> checkGame bid cards (Colour col mod')
+checkGame bid cards game@(Grand mod)
+    | biddingScore game cards >= bid = Just game
+    | otherwise                      = upgrade mod >>= \mod' -> checkGame bid cards (Grand mod')
+checkGame bid cards game
+    | biddingScore game cards >= bid = Just game
+    | otherwise                      = Nothing
+
+upgrade :: Modifier -> Maybe Modifier
+upgrade Einfach               = Just Schneider
+upgrade Schneider             = Just Schwarz
+upgrade Hand                  = Just HandSchneider
+upgrade HandSchneider         = Just HandSchwarz
+upgrade HandSchneiderAngesagt = Just HandSchneiderAngesagtSchwarz
+upgrade _                     = Nothing

src/Skat/Card.hs

@@ -0,0 +1,247 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Skat.Card where
+
+import Data.List
+import Data.Foldable (Foldable)
+import qualified Data.Foldable as F
+import qualified Data.Set as S
+import Data.Aeson
+import System.Random (newStdGen, StdGen)
+import Control.DeepSeq
+
+import Skat.Utils
+
+class HasCard c where
+    toCard :: c -> Card
+
+class Countable a b where
+    count :: a -> b
+
+data Type = Seven
+          | Eight
+          | Nine
+          | Queen
+          | King
+          | Ten
+          | Ace
+          | Jack
+            deriving (Eq, Ord, Show, Enum, Read, Bounded)
+
+data NullType = NSeven
+              | NEight
+              | NNine
+              | NTen
+              | NJack
+              | NQueen
+              | NKing
+              | NAce
+                deriving (Eq, Ord, Show, Enum, Read, Bounded)
+
+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, Bounded)
+
+data Trump = TrumpColour Colour
+           | Jacks
+           | None
+             deriving (Show, Eq)
+
+data TurnColour = TurnColour Colour
+                | Trump
+                  deriving (Show, Eq)
+
+data Card = Card Type Colour
+            deriving (Eq, Show, Ord, Read, Bounded)
+
+getType :: Card -> Type
+getType (Card t _) = t
+
+getColour :: Card -> Colour
+getColour (Card _ c) = c
+
+instance HasCard Card where
+    toCard = id
+
+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)
+
+getID :: HasCard c => c -> Int
+getID card = let t = getType $ toCard card in case t of
+    Seven -> 0
+    Eight -> 0
+    Nine -> 0
+    Queen -> 2
+    King -> 4
+    Ten -> 8
+    Ace -> 16
+    Jack -> 32
+
+instance Enum Card where
+    fromEnum (Card tp col) = fromEnum col * 8 + fromEnum tp
+    toEnum n = Card tp col
+        where col = toEnum (n `div` 8)
+              tp = toEnum (n `mod` 8)
+
+instance Countable Card Int where
+    count (Card t _) = count t
+
+instance Foldable t => Countable (t Card) Int where
+    count = foldl' f 0
+        where f acc c = count c + acc
+
+instance Countable (S.Set Card) Int where
+    count = S.foldl' f 0
+        where f acc card = count card + acc
+
+instance NFData Card where
+    rnf (Card t c) = t `seq` c `seq` ()
+
+base64table :: [Char]
+base64table = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
+
+class Serialize c a where
+    serialize :: a -> c
+    deserialize :: c -> Maybe a
+
+instance Serialize Char Card where
+    serialize card = base64table !! fromEnum card
+    deserialize char = base64table `indexOf` char >>= safeToEnum 
+
+equals :: TurnColour -> Maybe TurnColour -> Bool
+equals col (Just x) = col == x
+equals col Nothing = True
+
+isTrump :: HasCard c => Trump -> c -> Bool
+isTrump None crd = False
+isTrump Jacks crd = getType (toCard crd) == Jack
+isTrump (TrumpColour trumpCol) crd
+    | getType (toCard crd) == Jack = True
+    | otherwise = getColour (toCard crd) == trumpCol
+
+effectiveColour :: HasCard c => Trump -> c -> TurnColour
+effectiveColour trump card
+    | isTrump trump card = Trump
+    | otherwise          = TurnColour $ getColour (toCard card)
+
+isAllowed :: (Foldable t, HasCard c1, HasCard c2) => Trump -> Maybe TurnColour -> t c1 -> c2 -> Bool
+isAllowed trump turnCol cs crd =
+    if col `equals` turnCol
+        then True
+        else not $ F.any (\ca -> effectiveColour trump ca `equals` turnCol && toCard ca /= toCard crd) cs
+  where col = effectiveColour trump (toCard crd)
+
+compareCards :: Trump
+             -> Maybe TurnColour
+             -> Card
+             -> Card
+             -> Ordering
+compareCards _ _ (Card Jack col1) (Card Jack col2) = compare col1 col2
+compareCards trump turnCol c1@(Card tp1 col1) c2@(Card tp2 col2) =
+    case (trp1, trp2) of
+        (True, True) -> compare tp1 tp2
+        (False, False) -> case ( effectiveColour trump c1 `equals` turnCol
+                               , effectiveColour trump c2 `equals` turnCol ) of
+                            (True, True) -> compareTypes trump tp1 tp2
+                            (True, False) -> GT
+                            (False, True) -> LT
+                            _             -> EQ
+        _ -> compare trp1 trp2
+  where trp1 = isTrump trump c1
+        trp2 = isTrump trump c2
+
+compareRender :: Trump -> Card -> Card -> Ordering
+compareRender trump c1@(Card tp1 col1) c2@(Card tp2 col2) =
+    case (trp1, trp2) of
+        (True, True) -> case compare tp1 tp2 of
+            EQ -> compare col1 col2
+            v  -> v
+        (False, False) -> case compare col1 col2 of
+                            EQ -> compareTypes trump tp1 tp2
+                            v  -> v
+        _ -> compare trp1 trp2
+  where trp1 = isTrump trump c1
+        trp2 = isTrump trump c2
+
+compareTypes :: Trump
+             -> Type
+             -> Type
+             -> Ordering
+compareTypes None tp1 tp2 = compare (toNullType tp1) (toNullType tp2)
+    where toNullType Seven = NSeven
+          toNullType Eight = NEight
+          toNullType Nine = NNine
+          toNullType Ten = NTen
+          toNullType Jack = NJack
+          toNullType Queen = NQueen
+          toNullType King = NKing
+          toNullType Ace = NAce
+compareTypes _ tp1 tp2 = compare tp1 tp2
+
+-- | ascending sort of cards, depending on turn colour
+sortCards :: HasCard c => Trump -> Maybe TurnColour -> [c] -> [c]
+sortCards trump turnCol cs = sortBy f cs
+    where f c1 c2 = compareCards trump turnCol (toCard c1) (toCard c2)
+
+-- | descending sort of cards, independent of turn colour
+sortRender :: HasCard c => Trump -> [c] -> [c]
+sortRender trump cs = sortBy f cs
+    -- note: reversed order of c1 and c2 to get a descending sort
+    where f c1 c2 = compareRender trump (toCard c2) (toCard c1)
+
+highestCard :: HasCard c => Trump -> Maybe TurnColour -> [c] -> c
+highestCard trump turnCol cs = maximumBy f cs
+    where f c1 c2 = compareCards trump turnCol (toCard c1) (toCard c2)
+
+shuffleCards :: IO [Card]
+shuffleCards = do
+    gen <- newStdGen
+    return $ shuffle gen allCards
+
+shuffleCardsWithGen :: StdGen -> [Card]
+shuffleCardsWithGen gen = 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/Matches.hs

@@ -0,0 +1,137 @@
+module Skat.Matches (
+    singleVsBots, pvp, singleWithBidding, Match(..), Unfinished(..), continue,
+    Table(..)
+) where
+
+import Control.Monad.State
+import Control.Monad.Reader
+import System.Random (mkStdGen)
+
+import Skat
+import Skat.Operations
+import Skat.Player as P
+import Skat.Pile
+import Skat.Card
+import Skat.Preperation
+import Skat.Bidding
+
+import Skat.AI.Rulebased
+import Skat.AI.Online
+import Skat.AI.Stupid
+
+data Table = Unfinished Unfinished
+           | Finished Match
+           | Pass { tablePiles :: Piles }
+             deriving Show
+
+data Match = Match { matchPiles :: Piles
+                   , matchResult :: Result
+                   , matchTricks :: [Trick]
+                   , matchSingle :: Hand }
+             deriving Show
+
+data Unfinished = UnfinishedGame { unfinishedGame :: SkatEnv
+                                 , unfinishedPrep :: PrepEnv
+                                 , unfinishedTricks :: [Trick] }
+                | UnfinishedPrep { unfinishedPrep :: PrepEnv }
+                  deriving Show
+
+continue :: Communicator c => Unfinished -> c -> c -> c -> IO Table
+continue (UnfinishedGame skatEnv prepEnv tricks) comm1 comm2 comm3 = do
+    let ps = players skatEnv
+        ps' = Players
+            (PL $ OnlineEnv (P.team $ player ps Hand1) (P.hand $ player ps Hand1) comm1)
+            (PL $ OnlineEnv (P.team $ player ps Hand2) (P.hand $ player ps Hand2) comm2)
+            (PL $ OnlineEnv (P.team $ player ps Hand3) (P.hand $ player ps Hand3) comm3)
+        bs = bidders prepEnv
+        bs' = Bidders
+            (BD $ PrepOnline (Skat.Preperation.hand $ bidder bs Hand1) comm1 [])
+            (BD $ PrepOnline (Skat.Preperation.hand $ bidder bs Hand2) comm2 [])
+            (BD $ PrepOnline (Skat.Preperation.hand $ bidder bs Hand3) comm3 [])
+        skatEnv' = skatEnv { players = ps' }
+        prepEnv' = prepEnv { bidders = bs' }
+    runGame prepEnv' skatEnv'
+
+match :: PrepEnv -> IO Table
+match prepEnv = do
+    (maySkatEnv, prepEnv') <- runStateT runPreperation prepEnv
+    case maySkatEnv of
+        Just skatEnv -> runGame prepEnv' skatEnv
+        Nothing -> do
+            putStrLn "no one wanted to play"
+            return $ Pass $ Skat.Preperation.piles prepEnv'
+
+runGame :: PrepEnv -> SkatEnv -> IO Table
+runGame prepEnv skatEnv = do
+    (isFinished, finalEnv, tricks) <- (flip runSkat) skatEnv $ do
+        -- send current table cards to clients
+        -- only relevant if this is a continued game
+        -- otherwise table is empty
+        table <- getp tableCards
+        ps <- playersToList <$> gets players
+        mapM_ (\card -> mapM_ (\p -> onCardPlayed p card) ps) (reverse table)
+        -- run game
+        turn
+        -- return if game has finished
+        gameOver
+    if isFinished then do
+        let res = getResults
+                (skatGame skatEnv)
+                (Skat.Preperation.current prepEnv)
+                (skatSinglePlayer skatEnv)
+                (Skat.Preperation.piles prepEnv)
+                (Skat.piles finalEnv)
+        publishGameResults res (bidders prepEnv)
+        return $ Finished $ Match (Skat.Preperation.piles prepEnv) res tricks (skatSinglePlayer skatEnv)
+    else do -- if not finished an error has occured, thus returning unfinished game state
+        return $ Unfinished $ UnfinishedGame finalEnv prepEnv tricks
+
+-- | predefined card distribution for testing purposes
+cardDistr :: Piles
+cardDistr = emptyPiles hand1 hand2 hand3 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]
+          skt = [Card Nine Clubs, Card Queen Clubs]
+
+singleVsBots :: Communicator c => c -> IO ()
+singleVsBots comm = do
+    cards <- shuffleCards
+    let ps = Players
+                (PL $ OnlineEnv Team Hand1 comm)
+                (PL $ Stupid Team Hand2)
+                (PL $ mkAIEnv Single Hand3 10)
+        env = SkatEnv (distribute cards) Nothing (Colour Spades Einfach) ps Hand1 Hand3
+    void $ evalSkat turn env
+
+singleWithBidding :: Communicator c => c -> IO ()
+singleWithBidding comm = do
+    cards <- shuffleCards
+    let ps = distribute cards
+        h1 = map toCard $ handCards Hand1 ps
+        bs = Bidders
+                (BD $ PrepOnline Hand1 comm h1)
+                (BD $ NoBidder Hand2)
+                (BD $ NoBidder Hand3)
+        env = makePrep ps bs
+    void $ match env
+
+pvp :: Communicator c => c -> c -> c -> IO Table
+pvp comm1 comm2 comm3 = do
+    cards <- shuffleCards
+    let ps = distribute cards
+        h1 = map toCard $ handCards Hand1 ps
+        h2 = map toCard $ handCards Hand2 ps
+        h3 = map toCard $ handCards Hand3 ps
+        bs = Bidders
+                (BD $ PrepOnline Hand1 comm1 $ h1)
+                (BD $ PrepOnline Hand2 comm2 $ h2)
+                (BD $ PrepOnline Hand3 comm3 $ h3)
+        env = makePrep ps bs
+    match env

src/Skat/Operations.hs

@@ -0,0 +1,135 @@
+module Skat.Operations (
+    turn, turnGeneric, play, playOpen,
+    play_, sortRender, undo_, gameOver
+) where
+
+import Control.Monad.State
+import Control.Monad.Catch
+import Control.Exception hiding (catch, bracketOnError)
+import Control.Monad.Writer (tell)
+import System.Random (newStdGen, randoms)
+import Data.List
+import Data.Ord
+import qualified Data.Set as S
+
+import Skat
+import Skat.Card
+import Skat.Pile
+import Skat.Player (chooseCard, Players(..), Player(..), PL(..),
+    updatePlayer, playersToList, player, MonadPlayer, getSinglePlayer, trump, game,
+    singlePlayer)
+import Skat.Utils (shuffle)
+import Skat.Bidding
+
+play_ :: HasCard c => c -> Skat ()
+play_ card = do
+    hand <- gets currentHand
+    trCol <- trump
+    modifyp $ playCard hand card
+    table <- getp tableCards
+    case length table of
+        1 -> do modify (setCurrentHand $ next hand)
+                modify $ setTurnColour (Just $ effectiveColour trCol $ head table)
+        3 -> evaluateTable >>= modify . setCurrentHand
+        _ -> modify (setCurrentHand $ next hand)
+
+undo_ :: HasCard c => c -> Hand -> Maybe TurnColour -> Team -> Skat ()
+undo_ card oldCurrent oldTurnCol oldWinner = do
+    modify $ setCurrentHand oldCurrent
+    modify $ setTurnColour oldTurnCol
+    modifyp $ unplayCard oldCurrent (toCard card) oldWinner
+
+turnGeneric :: (PL -> Skat Card)
+            -> Int
+            -> Skat (Int, Int)
+turnGeneric playFunc depth = do
+    n <- gets currentHand
+    table <- getp tableCards
+    ps <- gets players
+    let p = player ps n
+    trCol <- trump
+    case length table of
+        0 -> do
+            catchAll
+                (do
+                    playFunc p
+                    modify (setCurrentHand $ next n)
+                    turnGeneric playFunc depth)
+                (\_ -> countGame)
+        1 -> do
+            modify $ setTurnColour
+                (Just $ effectiveColour trCol $ head table)
+            catchAll
+                (do
+                    playFunc p
+                    modify (setCurrentHand $ next n)
+                    turnGeneric playFunc depth)
+                (\_ -> countGame)
+        2 -> do
+            catchAll
+                (do
+                    playFunc p
+                    modify (setCurrentHand $ next n)
+                    turnGeneric playFunc depth)
+                (\_ -> countGame)
+        3 -> do
+            w <- evaluateTable
+            over <- gameOver
+            if depth <= 1 || over
+                then countGame
+                else modify (setCurrentHand w) >> turnGeneric playFunc (depth - 1)
+
+turn :: Skat (Int, Int)
+turn = turnGeneric play 10
+
+evaluateTable :: Skat Hand
+evaluateTable = do
+    trumpCol <- trump
+    turnCol <- gets turnColour
+    table <- getp tableCards
+    ps <- gets players
+    let winnerHand = uorigin $ getPile $ highestCard trumpCol turnCol table
+        winner = player ps winnerHand
+    modifyp $ cleanTable (team winner)
+    modify $ setTurnColour Nothing
+    tell [(table !! 2, table !! 1, table !! 0)]
+    return $ hand winner
+
+countGame :: Skat (Int, Int)
+countGame = getp count
+
+play :: (Show p, Player p) => p -> Skat Card
+play p = do
+    table <- getp tableCards
+    turnCol <- gets turnColour
+    trump <- trump
+    cards <- getp $ handCards (hand p)
+    fallen <- getp played
+    ouvert <- isOuvert <$> game
+    mayOuvert <- if ouvert then Just <$> (singlePlayer >>= getp . handCards)
+        else return Nothing
+    (card, p') <- chooseCard p table fallen mayOuvert cards
+    modifyPlayers $ updatePlayer p'
+    modifyp $ playCard (hand p) card
+    ps <- fmap playersToList $ gets players
+    table' <- getp tableCards
+    ps' <- mapM (\p -> onCardPlayed p (head table')) ps
+    mapM_ (modifyPlayers . updatePlayer) ps'
+    return (toCard card)
+
+playOpen :: (Show p, Player p) => p -> Skat Card
+playOpen p = do
+    --liftIO $ putStrLn $ show (hand p) ++ " playing open"
+    card <- chooseCardOpen p
+    modifyp $ playCard (hand p) card
+    return card
+
+gameOver :: Skat Bool
+gameOver = do
+    tr <- trump
+    case tr of
+        None -> do
+            singleLost <- gets piles >>= return . not . (Single `isSchwarz`)
+            if singleLost then return True
+            else gets currentHand >>= getp . handCards >>= return . null
+        _ -> gets currentHand >>= getp . handCards >>= return . null

src/Skat/Pile.hs

@@ -0,0 +1,238 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
+
+module Skat.Pile where
+
+import Control.Monad.State
+import Control.Monad.Trans.Maybe
+
+import Prelude hiding (lookup)
+import qualified Data.Map.Strict as M
+import qualified Data.Vector as V
+import Data.Vector (Vector)
+import Data.Foldable (toList, foldl', Foldable)
+import Data.Maybe
+import Data.Aeson
+import Control.Exception
+import Data.List (delete)
+import Text.Read (readMaybe)
+import Debug.Trace
+
+import Skat.Card
+import Skat.Utils
+
+data Team = Team | Single
+            deriving (Show, Eq, Ord, Enum, Read)
+
+data CardS p = CardS { getCard :: Card
+                     , getPile :: p }
+               deriving (Show, Eq, Ord, Read)
+
+instance HasCard (CardS p) where
+    toCard = getCard
+
+instance Countable (CardS p) Int where
+    count = count . getCard
+
+instance Foldable t => Countable (t (CardS p)) Int where
+    count = foldl' f 0
+        where f acc c = count c + acc
+
+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, Read, Enum, Bounded)
+
+toInt :: Hand -> Int
+toInt Hand1 = 1
+toInt Hand2 = 2
+toInt Hand3 = 3
+
+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 Owner = P Hand | S
+             deriving (Show, Eq, Ord, Read)
+
+instance Enum Owner where
+    fromEnum (P hand) = fromEnum hand
+    fromEnum S        = 3
+    toEnum 0          = P Hand1
+    toEnum 1          = P Hand2
+    toEnum 2          = P Hand3
+    toEnum 3          = S
+
+instance Bounded Owner where
+    maxBound = S
+    minBound = P Hand1
+
+instance ToJSON Owner where
+    toJSON (P hand) = object ["owner" .= show hand]
+    toJSON S        = object ["owner" .= ("skat" :: String) ]
+
+instance Serialize String (CardS Owner) where
+    serialize (CardS card owner) = show (fromEnum owner) ++ [serialize card]
+    deserialize str = (flip evalState) str $ runMaybeT $ do
+        owner <- pop >>= MaybeT . return . (>>= safeToEnum) . readMaybe . (:[])
+        card <- pop >>= MaybeT . return . deserialize
+        return $ CardS card owner
+
+type Played = Owner -- TODO: remove
+
+type Trick = (CardS Owner, CardS Owner, CardS Owner)
+
+data Piles = Piles { _hand1 :: [CardS Owner]
+                   , _hand2 :: [CardS Owner]
+                   , _hand3 :: [CardS Owner]
+                   , _table :: [CardS Owner]
+                   , _wonSingle :: [CardS Owner]
+                   , _wonTeam :: [CardS Owner]
+                   , _skat :: [CardS Owner] }
+             deriving (Show, Eq, Ord)
+
+toTable :: Hand -> Card -> Piles -> Piles
+toTable hand card ps = ps { _table = (CardS card (P hand)) : _table ps }
+
+instance Countable Piles (Int, Int) where
+    count ps = (sgl, tm)
+        where sgl = count (skatCards ps) + count (wonCards Single ps)
+              tm = count (wonCards Team ps)
+
+played :: Piles -> [CardS Owner]
+played ps = _wonSingle ps ++ _wonTeam ps ++ _table ps
+
+origin :: Owner -> Maybe Hand
+origin (P hand)   = Just hand
+origin S          = Nothing
+
+uorigin :: Owner -> Hand
+uorigin owner = case origin owner of
+    Just hand -> hand
+    Nothing   -> error "has no origin"
+
+removeFromHand :: Hand -> Card -> Piles -> Piles
+removeFromHand Hand1 card ps = ps { _hand1 = delete (CardS card (P Hand1)) (_hand1 ps) }
+removeFromHand Hand2 card ps = ps { _hand2 = delete (CardS card (P Hand2)) (_hand2 ps) }
+removeFromHand Hand3 card ps = ps { _hand3 = delete (CardS card (P Hand3)) (_hand3 ps) }
+
+addToHand :: Hand -> Card -> Piles -> Piles
+addToHand Hand1 card ps = ps { _hand1 = (CardS card (P Hand1)) : (_hand1 ps) }
+addToHand Hand2 card ps = ps { _hand2 = (CardS card (P Hand2)) : (_hand2 ps) }
+addToHand Hand3 card ps = ps { _hand3 = (CardS card (P Hand3)) : (_hand3 ps) }
+
+playCard :: HasCard c => Hand -> c -> Piles -> Piles
+playCard hand card' ps = (removeFromHand hand card ps) { _table = (CardS card (P hand)) : _table ps }
+    where card = toCard card'
+
+moveToSkat :: HasCard c => Hand -> [c] -> Piles -> Maybe Piles
+moveToSkat hand cards' piles
+      | length cards' == 2 && all (`elem` possible) cards =
+            Just $ updated { _skat = newSkat }
+      | otherwise = Nothing
+    where cards = map toCard cards'
+          oldSkat = skatCards piles
+          noLongerSkat = filter (not . (`elem` cards)) oldSkat
+          possible = map toCard (handCards hand piles) ++ oldSkat
+          newSkat = map (putAt S) cards
+          removed = foldr (\card ps -> removeFromHand hand card ps) piles cards
+          updated = foldr (\card ps -> addToHand hand card ps) removed noLongerSkat
+
+unplayCard :: Hand -> Card -> Team -> Piles -> Piles
+unplayCard hand card winner ps
+    | null table = case winner of
+        Team -> ps' { _table = tail $ take 3 (_wonTeam ps), _wonTeam = drop 3 (_wonTeam ps) }
+        Single -> ps' { _table = tail $ take 3 (_wonSingle ps), _wonSingle = drop 3 (_wonSingle ps) }
+    | otherwise = ps' { _table = tail (_table ps) }
+  where ps' = addToHand hand card ps
+        table = tableCards ps
+
+wonCards :: Team -> Piles -> [CardS Owner]
+wonCards Team = _wonTeam
+wonCards Single = _wonSingle
+
+cleanTable :: Team -> Piles -> Piles
+cleanTable Team ps = ps { _table = [], _wonTeam = _table ps ++ _wonTeam ps }
+cleanTable Single ps = ps { _table = [], _wonSingle = _table ps ++ _wonSingle ps }
+
+tableCards :: Piles -> [CardS Owner]
+tableCards = _table
+
+handEmpty :: Hand -> Piles -> Bool
+handEmpty Hand1 = null . _hand1
+handEmpty Hand2 = null . _hand2
+handEmpty Hand3 = null . _hand3
+
+handCards :: Hand -> Piles -> [CardS Owner]
+handCards Hand1 = _hand1
+handCards Hand2 = _hand2
+handCards Hand3 = _hand3
+
+allowed :: Hand -> Trump -> Maybe TurnColour -> Piles -> [CardS Owner]
+allowed hand trump turnCol ps
+        | null sameColour = cards
+        | otherwise = sameColour
+    where cards = handCards hand ps
+          sameColour = filter (\ca -> effectiveColour trump ca `equals` turnCol) cards
+
+skatCards :: Piles -> [Card]
+skatCards = map getCard . _skat
+
+emptyPiles :: [Card] -> [Card] -> [Card] -> [Card] -> Piles
+emptyPiles h1 h2 h3 skt = makePiles h1 h2 h3 [] skt
+
+putAt :: p -> Card -> CardS p
+putAt = flip CardS
+
+makePiles :: [Card] -> [Card] -> [Card] -> [CardS Owner] -> [Card] -> Piles
+makePiles h1 h2 h3 table skt = Piles h1' h2' h3' table [] [] skt'
+    where h1' = map (putAt $ P Hand1) h1
+          h2' = map (putAt $ P Hand2) h2
+          h3' = map (putAt $ P Hand3) h3
+          skt' = map (putAt S) skt
+
+distribute :: [Card] -> Piles
+distribute cards = emptyPiles hand1 hand2 hand3 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]
+
+instance Serialize String Piles where
+    serialize piles = sers (_hand1 piles) ++ sers (_hand2 piles) ++ sers (_hand3 piles)
+            ++ sers (_skat piles)
+        where sers cards = map (serialize . toCard) cards
+    deserialize str = (flip evalState) str $ runMaybeT $ do
+            hand1 <- takeG 10 >>= mapM deser
+            hand2 <- takeG 10 >>= mapM deser
+            hand3 <- takeG 10 >>= mapM deser
+            skat <- takeG 2 >>= mapM deser
+            return $ emptyPiles hand1 hand2 hand3 skat
+        where deser char = MaybeT $ return $ deserialize char
+
+instance Serialize String [Trick] where
+    serialize []                    = ""
+    serialize ((c1, c2, c3):tricks) = serialize c1 ++ serialize c2 ++ serialize c3
+        ++ serialize tricks
+    deserialize str = (flip evalState) str $ runMaybeT $ reverse <$> go []
+        where go acc = do
+                empty <- isEmpty
+                if empty then return acc else do
+                   card1 <- takeG 2 >>= MaybeT . return . deserialize
+                   card2 <- takeG 2 >>= MaybeT . return . deserialize
+                   card3 <- takeG 2 >>= MaybeT . return . deserialize
+                   go ((card1, card2, card3):acc)

src/Skat/Player.hs

@@ -1,16 +1,19 @@
 {-# LANGUAGE ExistentialQuantification #-}
 
-module Player where
+module Skat.Player where
 
 import Control.Monad.IO.Class
 
-import Card
-import Pile
+import Skat.Card
+import Skat.Pile
+import Skat.Bidding
 
 class (Monad m, MonadIO m) => MonadPlayer m where
-    trumpColour :: m Colour
-    turnColour :: m (Maybe Colour)
+    trump :: m Trump
+    turnColour :: m (Maybe TurnColour)
     showSkat :: Player p => p -> m (Maybe [Card])
+    singlePlayer :: m Hand
+    game :: m Game
 
 class (Monad m, MonadIO m, MonadPlayer m) => MonadPlayerOpen m where
     showPiles :: m (Piles)
@@ -18,11 +21,12 @@ class (Monad m, MonadIO m, MonadPlayer m) => MonadPlayerOpen m where
 class Player p where
     team :: p -> Team
     hand :: p -> Hand
-    chooseCard :: MonadPlayer m
+    chooseCard :: (HasCard d, HasCard c, MonadPlayer m)
                => p
                -> [CardS Played]
                -> [CardS Played]
-               -> [Card]
+               -> Maybe [d]
+               -> [c]
                -> m (Card, p)
     onCardPlayed :: MonadPlayer m
                  => p
@@ -34,10 +38,13 @@ class Player p where
                    -> m Card
     chooseCardOpen p = do
         piles <- showPiles
-        let table = tableCardsS piles
+        let table = tableCards piles
             fallen = played piles
             myCards = handCards (hand p) piles
-        fmap fst $ chooseCard p table fallen myCards
+        ouvert <- isOuvert <$> game
+        mayOuvert <- if ouvert then Just <$> (singlePlayer >>= \hnd -> return $ handCards hnd piles)
+            else return Nothing
+        fst <$> chooseCard p table fallen mayOuvert myCards
 
 data PL = forall p. (Show p, Player p) => PL p
 
@@ -47,8 +54,8 @@ instance Show PL where
 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
+    chooseCard (PL p) table fallen mayOuvert hand = do
+        (v, a) <- chooseCard p table fallen mayOuvert hand
         return $ (v, PL a)
     onCardPlayed (PL p) card = do
         v <- onCardPlayed p card
@@ -71,3 +78,9 @@ updatePlayer p (Players p1 p2 p3) = case hand p of
 
 playersToList :: Players -> [PL]
 playersToList (Players p1 p2 p3) = [p1, p2, p3]
+
+getSinglePlayer :: Players -> Hand
+getSinglePlayer (Players p1 p2 p3) = case (team p1, team p2, team p3) of
+    (Single, _, _) -> Hand1
+    (_, Single, _) -> Hand2
+    _              -> Hand3

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, HasCard(..))
+
+isAllowed :: (HasCard c, MonadPlayer m) => [c] -> c -> m Bool
+isAllowed hand card = do
+    tr <- trump
+    turnCol <- turnColour
+    return $ C.isAllowed tr turnCol hand card
+
+isTrump :: MonadPlayer m => Card -> m Bool
+isTrump card = do
+    tr <- trump
+    return $ C.isTrump tr card

src/Skat/Preperation.hs

@@ -0,0 +1,173 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE TupleSections #-}
+
+module Skat.Preperation (
+    Bidder(..), Bid, BD(..), Bidders(..), PrepEnv(..), runPreperation,
+    publishGameResults, bidder, makePrep
+) where
+
+import Control.Monad.IO.Class
+import Control.Monad.State
+
+import Skat.Pile
+import Skat.Card
+import Skat.Player (PL, Players(..))
+import Skat.Bidding
+import Skat (SkatEnv, mkSkatEnv)
+
+data PrepEnv = PrepEnv { piles :: Piles
+                       , bidders :: Bidders
+                       , current :: Bid }
+               deriving Show
+
+makePrep :: Piles -> Bidders -> PrepEnv
+makePrep ps bd = PrepEnv ps bd 0
+
+type Preperation = StateT PrepEnv IO
+
+class Bidder a where
+    hand :: a -> Hand
+    onStart :: MonadIO m => a -> m ()
+    askBid :: MonadIO m => a -> Hand -> Bid -> m (Maybe Bid)
+    askResponse :: MonadIO m => a -> Hand -> Bid -> m Bool
+    askGame :: MonadIO m => a -> Bid -> m Game
+    askHand :: MonadIO m => a -> Bid -> m Bool
+    askSkat :: MonadIO m => a -> Bid -> [Card] -> m [Card]
+    toPlayer :: a -> Team -> PL
+    onBid :: MonadIO m => a -> Maybe Bid -> Hand -> Hand -> m ()
+    onBid _ _ _ _ = return ()
+    onResponse :: MonadIO m => a -> Bool -> Hand -> Hand -> m ()
+    onResponse _ _ _ _ = return ()
+    onGame :: MonadIO m => a -> HideGame -> Hand -> m ()
+    onGame _ _ _ = return ()
+    onResult :: MonadIO m => a -> Result -> m ()
+    onResult _ _ = return ()
+    onNoGame :: MonadIO m => a -> m ()
+    onNoGame _ = return ()
+
+-- | trick to allow heterogenous bidder list
+data BD = forall b. (Show b, Bidder b) => BD b
+
+instance Show BD where
+    show (BD b) = show b
+
+instance Bidder BD where
+    hand (BD b) = hand b
+    askBid (BD b) = askBid b
+    askGame (BD b) = askGame b
+    askHand (BD b) = askHand b
+    askSkat (BD b) = askSkat b
+    askResponse (BD b) = askResponse b
+    toPlayer (BD b) = toPlayer b
+    onStart (BD b) = onStart b
+    onGame (BD b) = onGame b
+    onResult (BD b) = onResult b
+    onBid (BD b) = onBid b
+    onResponse (BD b) = onResponse b
+    onNoGame (BD b) = onNoGame b
+
+data Bidders = Bidders BD BD BD
+               deriving Show
+
+bidder :: Bidders -> Hand -> BD
+bidder (Bidders b _ _) Hand1 = b
+bidder (Bidders _ b _) Hand2 = b
+bidder (Bidders _ _ b) Hand3 = b
+
+toPlayers :: Hand -> Bidders -> Players
+toPlayers single (Bidders b1 b2 b3) =
+    Players (toPlayer b1 $ if single == Hand1 then Single else Team)
+            (toPlayer b2 $ if single == Hand2 then Single else Team)
+            (toPlayer b3 $ if single == Hand3 then Single else Team)
+
+runPreperation :: Preperation (Maybe SkatEnv)
+runPreperation = do
+    bds <- gets bidders
+    onStart (bidder bds Hand1)
+    onStart (bidder bds Hand2)
+    onStart (bidder bds Hand3)
+    (winner, bid) <- runBidding 0 (bidder bds Hand2) (bidder bds Hand1)
+    (finalWinner, finalBid) <- runBidding bid (bidder bds Hand3) (bidder bds winner)
+    if finalBid == 0 then do
+        bid <- askBid (bidder bds finalWinner) finalWinner 0
+        publishBid bid finalWinner finalWinner
+        case bid of
+            Just val -> Just <$> initGame finalWinner val
+            Nothing -> publishNoGame >> return Nothing
+        else Just <$> initGame finalWinner finalBid
+
+runBidding :: Bid -> BD -> BD -> Preperation (Hand, Bid)
+runBidding startingBid reizer gereizter = do
+    first <- askBid reizer (hand gereizter) startingBid
+    case first of
+        Just val
+            | val > startingBid -> do
+                publishBid first (hand reizer) (hand gereizter)
+                modify $ \env -> env { current = val }
+                response <- askResponse gereizter (hand reizer) val
+                publishResponse response (hand reizer) (hand gereizter)
+                if response then runBidding val reizer gereizter
+                else return (hand reizer, val)
+            | otherwise -> do
+                publishBid Nothing (hand reizer) (hand gereizter)
+                return (hand gereizter, startingBid)
+        Nothing -> do
+            publishBid Nothing (hand reizer) (hand gereizter)
+            return (hand gereizter, startingBid)
+
+initGame :: Hand -> Bid -> Preperation SkatEnv
+initGame single bid = do
+    ps <- gets piles
+    bds <- gets bidders
+    -- ask if player wants to play hand
+    noSkat <- askHand (bidder bds single) bid
+    -- either return piles or ask for skat cards and modify piles
+    ps' <- if noSkat then return ps else handleSkat (bidder bds single) bid ps
+    -- ask for game kind
+    game <- handleGame (bidder bds single) bid noSkat
+    -- publish game start
+    publishGameStart game single
+    -- construct skat env
+    return $ mkSkatEnv ps' Nothing game (toPlayers single bds) Hand1 single
+
+handleGame :: BD -> Bid -> Bool -> Preperation Game
+handleGame bd bid noSkat = do
+    cards <- (\ps -> map toCard (handCards (hand bd) ps) ++ skatCards ps) <$> gets piles
+    -- ask bidder for game
+    proposal <- askGame bd bid
+    -- check if proposal is allowed
+    if isHand proposal == noSkat then return proposal else handleGame bd bid noSkat
+
+handleSkat :: BD -> Bid -> Piles -> Preperation Piles
+handleSkat bd bid ps = do
+    let skat = skatCards ps
+    skat' <- askSkat bd bid skat
+    liftIO $ putStrLn $ "received skat " ++ show skat'
+    case moveToSkat (hand bd) skat' ps of
+        Just correct -> return correct
+        Nothing -> handleSkat bd bid ps
+
+publishGameResults :: MonadIO m => Result -> Bidders -> m ()
+publishGameResults res bidders = do
+    onResult (bidder bidders Hand1) res
+    onResult (bidder bidders Hand2) res
+    onResult (bidder bidders Hand3) res
+
+publishGameStart :: Game -> Hand -> Preperation ()
+publishGameStart game sglPlayer = mapBidders (\b -> onGame b (HideGame game) sglPlayer)
+
+publishBid :: Maybe Bid -> Hand -> Hand -> Preperation ()
+publishBid bid reizer gereizter = mapBidders (\b -> onBid b bid reizer gereizter)
+
+publishResponse :: Bool -> Hand -> Hand -> Preperation ()
+publishResponse response reizer gereizter = mapBidders (\b -> onResponse b response reizer gereizter)
+
+publishNoGame :: Preperation ()
+publishNoGame = mapBidders onNoGame
+
+mapBidders :: (BD -> Preperation ()) -> Preperation ()
+mapBidders f = do
+    bds <- gets bidders
+    f (bidder bds Hand1)
+    f (bidder bds Hand2)
+    f (bidder bds Hand3)

src/Skat/Render.hs

@@ -0,0 +1,12 @@
+module Skat.Render where
+
+import Data.List
+import Data.Vector (Vector, toList)
+
+import Skat.Card
+
+render :: HasCard c => [c] -> IO ()
+render = putStrLn . intercalate "\n" . zipWith (\n c -> show n ++ ") " ++ show c) [0..] . map toCard
+
+renderVector :: Vector Card -> IO ()
+renderVector = render . toList

src/Skat/Utils.hs

@@ -0,0 +1,97 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Skat.Utils where
+
+import Control.Monad.State
+import Control.Monad.Trans.Maybe
+
+import System.Random
+import Text.Read hiding (get, lift)
+import qualified Data.ByteString.Char8 as B (ByteString, unpack, pack)
+import qualified Data.Text as T (Text, unpack, pack)
+import Data.List (foldl')
+
+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
+
+indexOf :: Eq a => [a] -> a -> Maybe Int
+indexOf [] _ = Nothing
+indexOf (x:xs) item
+    | x == item = Just 0
+    | otherwise = (1+) <$> xs `indexOf` item
+
+type Generator c = MaybeT (State [c])
+
+pop :: Generator c c
+pop = do
+    cs <- get
+    if null cs then mzero else put (tail cs) >> return (head cs)
+
+isEmpty :: Generator c Bool
+isEmpty = get >>= return . null
+
+takeG :: Int -> Generator c [c]
+takeG n = do
+    cs <- lift get
+    if length cs >= n
+        then do
+            put (drop n cs)
+            return (take n cs)
+        else mzero
+
+-- forall is needed to allow scoped type variables
+safeToEnum :: forall a. (Enum a, Bounded a) => Int -> Maybe a
+safeToEnum n
+    | maxN < n || minN > n = Nothing
+    | otherwise            = Just $ toEnum n
+  where maxN = fromEnum (maxBound :: a)
+        minN = fromEnum (minBound :: a)

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-18.18
+
+# 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"