restructure everything
This commit is contained in:
Christian Merten
@@ -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
|
||||
countType Ace = 11
|
||||
countType Ten = 10
|
||||
countType King = 4
|
||||
countType Queen = 3
|
||||
countType Jack = 2
|
||||
countType _ = 0
|
||||
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
|
||||
@@ -30,73 +37,14 @@ data Colour = Diamonds
|
||||
data Card = Card Type Colour
|
||||
deriving (Eq, Show)
|
||||
|
||||
countCard :: Card -> Int
|
||||
countCard (Card t _) = countType t
|
||||
getColour :: Card -> Colour
|
||||
getColour (Card _ c) = c
|
||||
|
||||
count :: [Card] -> Int
|
||||
count = sum . map countCard
|
||||
instance Countable Card Int where
|
||||
count (Card t _) = count t
|
||||
|
||||
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]
|
||||
instance Countable [Card] Int where
|
||||
count = sum . map count
|
||||
|
||||
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
|
||||
putAt sp c = CardS c sp sp
|
||||
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
|
||||
|
||||
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]
|
||||
sortCards :: Colour -> Maybe Colour -> [Card] -> [Card]
|
||||
sortCards trumpCol turnCol cs = sortBy (compareCards trumpCol turnCol) cs
|
||||
|
||||
playersFromTable :: Players -> [CardS] -> [Player]
|
||||
playersFromTable ps = map (player ps . playerOfHand . getOwner)
|
||||
shuffleCards :: IO [Card]
|
||||
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
|
||||
|
||||
+34
-157
@@ -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
|
||||
turning :: Index -> Skat (Int, Int)
|
||||
turning n = undefined
|
||||
|
||||
turn2 :: Index -> Skat (Int, Int)
|
||||
turn2 n = do
|
||||
t <- table
|
||||
turn :: Hand -> Skat (Int, Int)
|
||||
turn n = do
|
||||
table <- getp tableCards
|
||||
ps <- gets players
|
||||
let p = player ps n
|
||||
hand <- cardsAt (playerHand $ index p)
|
||||
if length hand == 0
|
||||
then countGame
|
||||
else case length t of
|
||||
0 -> play p >> turn2 (next n)
|
||||
hand <- getp $ handCards n
|
||||
case length table of
|
||||
0 -> play p >> turn (next n)
|
||||
1 -> do
|
||||
modify (setTurnColour . f . head $ t)
|
||||
modify $ setTurnColour (Just $ getColour $ head table)
|
||||
play p
|
||||
turn2 (next n)
|
||||
2 -> play p >> evaluateTable >>= turn2
|
||||
3 -> evaluateTable >>= turn2
|
||||
where f (Card _ col) = Just col
|
||||
turn (next n)
|
||||
2 -> play p >> turn (next n)
|
||||
3 -> do
|
||||
w <- evaluateTable
|
||||
if length hand == 0 then countGame else turn w
|
||||
|
||||
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 :: Skat Hand
|
||||
evaluateTable = do
|
||||
trumpCol <- gets trumpColour
|
||||
turnCol <- gets turnColour
|
||||
t <- table
|
||||
ts <- tableS
|
||||
table <- getp tableCards
|
||||
ps <- gets players
|
||||
let psOrdered = playersFromTable ps ts
|
||||
l = zip psOrdered t
|
||||
g a b = compareCards trumpCol turnCol (snd a) (snd b)
|
||||
(winner, _) = last (sortBy g l)
|
||||
pile = teamPile $ team winner
|
||||
forM t (\c -> move c pile)
|
||||
let winningCard = head $ sortCards trumpCol turnCol table
|
||||
Just winnerHand <- getp $ originOfCard winningCard
|
||||
let winner = player ps winnerHand
|
||||
modifyp $ cleanTable (team winner)
|
||||
modify $ setTurnColour Nothing
|
||||
return $ index winner
|
||||
return $ hand winner
|
||||
|
||||
countGame :: Skat (Int, Int)
|
||||
countGame = do
|
||||
sgl <- count <$> cardsAt WonSingle
|
||||
tm <- count <$> cardsAt WonTeam
|
||||
return (sgl, tm)
|
||||
countGame = getp count
|
||||
|
||||
turn :: Index -> Skat Index
|
||||
turn n = do
|
||||
ps <- gets players
|
||||
let p1 = player ps n
|
||||
p2 = player ps (next n)
|
||||
p3 = player ps (next $ next n)
|
||||
c1@(Card _ col) <- play p1
|
||||
modify $ setTurnColour (Just col)
|
||||
c2 <- play p2
|
||||
c3 <- play p3
|
||||
trumpCol <- gets trumpColour
|
||||
turnCol <- gets turnColour
|
||||
let l = zip3 [p1, p2, p3] [c1, c2, c3] [n, next n, next $ next n]
|
||||
g a b = compareCards trumpCol turnCol (f a) (f b)
|
||||
(winner, _, idx) = last (sortBy g l)
|
||||
pile = teamPile $ team winner
|
||||
move c1 pile
|
||||
move c2 pile
|
||||
move c3 pile
|
||||
modify $ setTurnColour Nothing
|
||||
return idx
|
||||
where f (_, x, _) = x
|
||||
|
||||
play :: Player -> Skat Card
|
||||
play :: Player p => p -> Skat Card
|
||||
play p = do
|
||||
table <- table
|
||||
table <- getp tableCards
|
||||
turnCol <- gets turnColour
|
||||
trump <- gets trumpColour
|
||||
hand <- cardsAt (playerHand $ index p)
|
||||
let card = playCard p table hand trump turnCol
|
||||
move card Table
|
||||
hand <- getp $ handCards (hand p)
|
||||
let card = chooseCard p trump turnCol hand
|
||||
modifyp $ playCard card
|
||||
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
|
||||
---- 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
|
||||
env = SkatEnv piles Nothing Spades playersExamp
|
||||
where piles = distribute allCards
|
||||
|
||||
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
|
||||
|
||||
@@ -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
|
||||
@@ -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)
|
||||
@@ -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]
|
||||
table = gets cards >>= return . foldr f []
|
||||
where f (CardS c Table _) cs = c : cs
|
||||
f _ cs = cs
|
||||
modifyp :: (Piles -> Piles) -> Skat ()
|
||||
modifyp f = modify g
|
||||
where g env@(SkatEnv {piles}) = env { piles = f piles}
|
||||
|
||||
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
|
||||
getp :: (Piles -> a) -> Skat a
|
||||
getp f = gets piles >>= return . f
|
||||
|
||||
setTurnColour :: Maybe Colour -> SkatEnv -> SkatEnv
|
||||
setTurnColour col sk = sk { turnColour = col }
|
||||
|
||||
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user