restructure everything

Card.hs

@@ -1,8 +1,15 @@
+{-# 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
@@ -13,13 +20,13 @@ data Type = Seven
           | Jack
             deriving (Eq, Ord, Show, Enum)
 
-countType :: Type -> Int
+instance Countable Type Int where
-countType Ace   = 11
+    count Ace   = 11
-countType Ten   = 10
+    count Ten   = 10
-countType King  = 4
+    count King  = 4
-countType Queen = 3
+    count Queen = 3
-countType Jack  = 2
+    count Jack  = 2
-countType _     = 0
+    count _     = 0
 
 data Colour = Diamonds
             | Hearts
@@ -30,73 +37,14 @@ data Colour = Diamonds
 data Card = Card Type Colour
             deriving (Eq, Show)
 
-countCard :: Card -> Int
+getColour :: Card -> Colour
-countCard (Card t _) = countType t
+getColour (Card _ c) = c
 
-count :: [Card] -> Int
+instance Countable Card Int where
-count = sum . map countCard
+    count (Card t _) = count t
 
-data Team = Team | Single
+instance Countable [Card] Int where
-            deriving (Show, Eq, Ord, Enum)
+    count = sum . map count
-
-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
@@ -112,31 +60,37 @@ effectiveColour trumpCol card@(Card _ col) =
     if trump then trumpCol else col
   where trump = isTrump trumpCol card
 
-isAllowed :: Colour -> Maybe Colour -> Hand -> Card -> Bool
+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
 
-putAt :: Space -> Card -> CardS
+compareCards :: Colour
-putAt sp c = CardS c sp sp
+             -> 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
 
-distribute :: [Card] -> [CardS]
+sortCards :: Colour -> Maybe Colour -> [Card] -> [Card]
-distribute cards = map (putAt Hand1) hand1
+sortCards trumpCol turnCol cs = sortBy (compareCards trumpCol turnCol) cs
-        ++ 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]
+shuffleCards :: IO [Card]
-playersFromTable ps = map (player ps . playerOfHand . getOwner)
+shuffleCards = do
+    gen <- newStdGen
+    return $ shuffle gen allCards
 
 -- TESTING VARS
 
@@ -155,15 +109,10 @@ c4 = Card Queen Hearts
 c5 :: Card
 c5 = Card Jack Clubs
 
-h1 :: Hand
+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]
-
-distributePutSkat :: [Card] -> [CardS]
-distributePutSkat cards = foldr (\c m -> moveCard c WonSingle m) distributed skt
-    where distributed = distribute cards
-          skt = findCards SkatP distributed

Operations.hs

@@ -7,28 +7,10 @@ import Data.Ord
 
 import Card
 import Skat
+import Pile
+import Player
 import Utils (shuffle)
 
-compareCards :: Colour
-             -> Maybe Colour
-             -> Card
-             -> Card
-             -> Ordering
-compareCards _ _ (Card Jack col1) (Card Jack col2) = compare col1 col2
-compareCards trumpCol turnCol c1@(Card tp1 col1) c2@(Card tp2 col2) =
-    case compare trp1 trp2 of
-        EQ ->
-            case compare (col1 `equals` turnCol)
-                         (col2 `equals` turnCol) of
-                EQ -> compare tp1 tp2
-                v -> v
-        v  -> v
-  where trp1 = isTrump trumpCol c1
-        trp2 = isTrump trumpCol c2
-
-sortCards :: Colour -> Maybe Colour -> [Card] -> [Card]
-sortCards trumpCol turnCol cs = sortBy (compareCards trumpCol turnCol) cs
-
 compareRender :: Card -> Card -> Ordering
 compareRender (Card t1 c1) (Card t2 c2) = case compare c1 c2 of
     EQ -> compare t1 t2
@@ -37,167 +19,62 @@ compareRender (Card t1 c1) (Card t2 c2) = case compare c1 c2 of
 sortRender :: [Card] -> [Card]
 sortRender = sortBy compareRender
 
--- | finishes the calculation of a match
+turn :: Hand -> Skat (Int, Int)
-turning :: Index -> Skat (Int, Int)
+turn n = do
-turning n = undefined
+    table <- getp tableCards
-
-turn2 :: Index -> Skat (Int, Int)
-turn2 n = do
-    t <- table
     ps <- gets players
     let p = player ps n
-    hand <- cardsAt (playerHand $ index p)
+    hand <- getp $ handCards n
-    if length hand == 0
+    case length table of
-        then countGame
+        0 -> play p >> turn (next n)
-        else case length t of
+        1 -> do
-            0 -> play p >> turn2 (next n)
+            modify $ setTurnColour (Just $ getColour $ head table)
-            1 -> do
+            play p
-                modify (setTurnColour . f . head $ t)
+            turn (next n)
-                play p
+        2 -> play p >> turn (next n)
-                turn2 (next n)
+        3 -> do
-            2 -> play p >> evaluateTable >>= turn2
+            w <- evaluateTable
-            3 -> evaluateTable >>= turn2
+            if length hand == 0 then countGame else turn w
-   where f (Card _ col) = Just col
 
-simulate :: Team -> Index -> Skat (Int, Int)
+evaluateTable :: Skat Hand
-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
+    table <- getp tableCards
-    ts <- tableS
     ps <- gets players
-    let psOrdered = playersFromTable ps ts
+    let winningCard = head $ sortCards trumpCol turnCol table
-        l = zip psOrdered t
+    Just winnerHand <- getp $ originOfCard winningCard
-        g a b = compareCards trumpCol turnCol (snd a) (snd b)
+    let winner = player ps winnerHand
-        (winner, _) = last (sortBy g l)
+    modifyp $ cleanTable (team winner)
-        pile = teamPile $ team winner
-    forM t (\c -> move c pile)
     modify $ setTurnColour Nothing
-    return $ index winner
+    return $ hand winner
 
 countGame :: Skat (Int, Int)
-countGame = do
+countGame = getp count
-    sgl <- count <$> cardsAt WonSingle
-    tm <- count <$> cardsAt WonTeam
-    return (sgl, tm)
 
-turn :: Index -> Skat Index
+play :: Player p => p -> Skat Card
-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
+    table <- getp tableCards
     turnCol <- gets turnColour
     trump <- gets trumpColour
-    hand <- cardsAt (playerHand $ index p)
+    hand <- getp $ handCards (hand p)
-    let card = playCard p table hand trump turnCol
+    let card = chooseCard p trump turnCol hand
-    move card Table
+    modifyp $ playCard card
     return card
 
-playOpen :: Team -> Player -> Skat Card
+---- TESTING VARS
-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
+env = SkatEnv piles Nothing Spades playersExamp
-    where hand1 = take 10 allCards
+    where piles = distribute 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)
+playersExamp = 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 Spades playersExamp
-
-shuffledEnv2 :: IO SkatEnv
-shuffledEnv2 = do
-    cards <- shuffleCards
-    return $ SkatEnv (distributePutSkat cards) Nothing Spades playersExamp

Pile.hs

@@ -0,0 +1,103 @@
+{-# 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)
+
+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
+
+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.hs

@@ -0,0 +1,42 @@
+{-# LANGUAGE ExistentialQuantification #-}
+
+module Player where
+
+import Card
+import Pile
+
+class Player p where
+    team :: p -> Team
+    hand :: p -> Hand
+    chooseCard :: p -> Colour -> Maybe Colour -> [Card] -> Card
+
+data Stupid = Stupid { getTeam :: Team
+                     , getHand :: Hand }
+              deriving Show
+
+instance Player Stupid where
+    team = getTeam
+    hand = getHand
+    chooseCard p trumpCol turnCol hand = head possible
+        where possible = filter (isAllowed trumpCol turnCol hand) hand
+
+data PL = forall p. (Show p, Player p) => PL p
+
+instance Show PL where
+    show (PL p) = show p
+
+instance Player PL where
+    team (PL p) = team p
+    hand (PL p) = hand p
+    chooseCard (PL p) = chooseCard p
+
+data Players = Players PL PL PL
+               deriving Show
+
+player :: Players -> Hand -> PL
+player (Players p _ _) Hand1 = p
+player (Players _ p _) Hand2 = p
+player (Players _ _ p) Hand3 = p
+
+--playersFromTable :: Players -> [CardS] -> [Player]
+--playersFromTable ps = map (player ps . playerOfHand . getOwner)

Skat.hs

@@ -1,11 +1,16 @@
+{-# LANGUAGE NamedFieldPuns #-}
+
 module Skat where
 
-import Card
 import Control.Monad.State
 import Control.Monad.Reader
 import Data.List
 
-data SkatEnv = SkatEnv { cards :: [CardS]
+import Card
+import Pile
+import Player
+
+data SkatEnv = SkatEnv { piles :: Piles
                        , turnColour :: Maybe Colour
                        , trumpColour :: Colour
                        , players :: Players }
@@ -13,24 +18,12 @@ data SkatEnv = SkatEnv { cards :: [CardS]
 
 type Skat = StateT SkatEnv IO
 
-table :: Skat [Card]
+modifyp :: (Piles -> Piles) -> Skat ()
-table = gets cards >>= return . foldr f []
+modifyp f = modify g
-    where f (CardS c Table _) cs = c : cs
+    where g env@(SkatEnv {piles}) = env { piles = f piles}
-          f _               cs = cs
 
-tableS :: Skat [CardS]
+getp :: (Piles -> a) -> Skat a
-tableS = gets cards >>= return . foldr f []
+getp f = gets piles >>= return . 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

@@ -22,3 +22,11 @@ query s = do
     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