first try

Card.hs

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

Main.hs

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

Operations.hs

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

Reizen.hs

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

Render.hs

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

Skat.hs

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

Utils.hs

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