hanafuda
/
lib
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Defining a generic Key newtype to provide IDs for Players and Games

This commit is contained in:
Tissevert 2019-08-15 23:34:59 +02:00
parent f1ee562809
commit efddc9f07e
7 changed files with 58 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
hanafuda.cabal
View File

@ -31,6 +31,7 @@ library
exposed-modules: Hanafuda
, Hanafuda.KoiKoi
, Hanafuda.Player
, Hanafuda.Key
other-modules: Hanafuda.KoiKoi.Game
, Hanafuda.KoiKoi.Round
, Hanafuda.KoiKoi.Turn

10
src/Hanafuda/Key.hs Normal file
View File

@ -0,0 +1,10 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Hanafuda.Key (
Key(..)
, getKey
) where
newtype Key a = Key Int deriving (Eq, Ord, Enum, Read, Show)
getKey :: Key a -> String
getKey (Key n) = show n

11
src/Hanafuda/KoiKoi.hs
View File

@ -5,8 +5,10 @@ module Hanafuda.KoiKoi (
, Card(..)
, Game(..)
, Environment
, GameKey
, Mode(..)
, Move(..)
, PlayerKey
, Score
, Source(..)
, Step(..)
@ -18,13 +20,16 @@ module Hanafuda.KoiKoi (
import Hanafuda (Card(..), Flower(Pine), contains, flower, match, remove)
import qualified Hanafuda.Player as Player (players, random, scores)
import Hanafuda.KoiKoi.Yaku (Yaku(..), Score)
import Hanafuda.KoiKoi.Game (Action(..), Environment, Game(..), Mode(..), Move(..), Source(..), Step(..))
import Hanafuda.KoiKoi.Game (
Action(..), Environment, Game(..), GameKey, Mode(..), Move(..), PlayerKey
, Source(..), Step(..)
)
import qualified Hanafuda.KoiKoi.Round as Round (deal, next)
import qualified Hanafuda.KoiKoi.Turn as Turn (catch, end, next)
import Control.Monad.Except (MonadError(..))
import Control.Monad.IO.Class (MonadIO)
play :: (Environment m, Ord player) => Move -> Game player -> m (Game player)
play :: Environment m => Move -> Game -> m Game
play move game@(Game {river, step}) =
case (step, move) of
(ToPlay, Play card) ->
@ -43,7 +48,7 @@ play move game@(Game {river, step}) =
where
canCatch card1 card2 = flower card1 == flower card2 && river `contains` card2
new :: (MonadIO m, Ord player) => [player] -> Mode -> m (Game player)
new :: MonadIO m => [PlayerKey] -> Mode -> m Game
new playersList mode = do
playing <- Player.random players
Round.deal $ Game {

27
src/Hanafuda/KoiKoi/Game.hs
View File

@ -5,8 +5,11 @@ module Hanafuda.KoiKoi.Game (
Action(..)
, Game(..)
, Environment
, GameKey
, Key
, Mode(..)
, Move(..)
, PlayerKey
, Source(..)
, Step(..)
, end
@ -17,8 +20,10 @@ import Control.Monad.Except (MonadError)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Writer (MonadWriter)
import Hanafuda (Card, Flower, Pack)
import Hanafuda.Key (Key)
import qualified Hanafuda.KoiKoi.Yaku as KoiKoi (Score)
import Hanafuda.Player (Players, Player, Scores, set)
import Hanafuda.KoiKoi.Yaku (Score)
import qualified Hanafuda.Player as Player (Key)
data Mode = FirstAt Int | WholeYear deriving (Show)
data Move = Play Card | Capture (Card, Card) | Choose Card | KoiKoi Bool
@ -31,24 +36,26 @@ data Action = Action {
} deriving (Show)
type Environment m = (MonadIO m, MonadError String m, MonadWriter [Action] m)
type PlayerKey = Player.Key KoiKoi.Score
type GameKey = Key Game
data Game player = Game {
data Game = Game {
mode :: Mode
, scores :: Scores player
, scores :: Scores KoiKoi.Score
, month :: Flower
, players :: Players player Score
, playing :: player
, winning :: player
, oyake :: player
, players :: Players KoiKoi.Score
, playing :: PlayerKey
, winning :: PlayerKey
, oyake :: PlayerKey
, deck :: [Card]
, river :: Pack
, step :: Step
, trick :: [Card]
, rounds :: [(player, Score)]
, rounds :: [(PlayerKey, KoiKoi.Score)]
} deriving (Show)
setPlayer :: Ord player => Game player -> Player player Score -> Game player
setPlayer :: Game -> Player KoiKoi.Score -> Game
setPlayer game@(Game {players, playing}) player = game {players = set playing player players}
end :: Monad m => Game player -> m (Game player)
end :: Monad m => Game -> m Game
end game = return $ game {step = Over}

4
src/Hanafuda/KoiKoi/Round.hs
View File

@ -12,7 +12,7 @@ import Data.Map ((!), insert)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.State (runState, state)
deal :: (MonadIO m, Ord player) => Game player -> m (Game player)
deal :: MonadIO m => Game -> m Game
deal game@(Game {players}) = do
((hand1, hand2, river), deck) <- runState getTriple <$> shuffle cards
return game {
@ -24,7 +24,7 @@ deal game@(Game {players}) = do
take8 = state $ splitAt 8
getTriple = (,,) <$> take8 <*> take8 <*> take8
next :: (MonadIO m, Ord player) => Game player -> m (Game player)
next :: MonadIO m => Game -> m Game
next game@(Game {mode, scores, month, players, oyake, winning, rounds}) =
case mode of
FirstAt n | n <= newScore -> end scored

8
src/Hanafuda/KoiKoi/Turn.hs
View File

@ -27,14 +27,14 @@ log source played cards = tell [
captures [_, captured] = Just captured
captures _ = Nothing
catch :: (Environment m, Ord player) => Game player -> Card -> (Pack, [Card]) -> m (Game player)
catch :: Environment m => Game -> Card -> (Pack, [Card]) -> m Game
catch game@(Game {players, playing}) card (river, trick) = do
log Hand card trick
(setPlayer (game {river, trick})) <$> played >>= popNextCard
where
played = (Player.get playing players) `plays` card
popNextCard :: (Environment m, Ord player) => Game player -> m (Game player)
popNextCard :: Environment m => Game -> m Game
popNextCard (Game {deck = []}) = throwError "No more cards in the stack"
popNextCard game@(Game {river, deck = turned : others}) =
let pop = game {deck = others} in
@ -42,7 +42,7 @@ popNextCard game@(Game {river, deck = turned : others}) =
Right (newRiver, newCaptured) -> end pop turned (newRiver, newCaptured)
Left _ -> return $ pop {step = Turned turned}
end :: (MonadWriter [Action] m, MonadIO m, Ord player) => Game player -> Card -> (Pack, [Card]) -> m (Game player)
end :: (MonadWriter [Action] m, MonadIO m) => Game -> Card -> (Pack, [Card]) -> m Game
end game@(Game {month, trick, playing, players}) card (river, newCaptured) = do
log Deck card newCaptured
let updatedGame = setPlayer (game {river, trick = []}) updatedPlayer
@ -55,7 +55,7 @@ end game@(Game {month, trick, playing, players}) card (river, newCaptured) = do
(scored, newMeld) = runReader (newTrick `meldInto` (meld player)) month
updatedPlayer = player {meld = newMeld, yakus = scored `mappend` (yakus player)}
next :: (MonadIO m, Ord player) => Game player -> m (Game player)
next :: MonadIO m => Game -> m Game
next game@(Game {players, playing}) =
let newPlaying = Player.next players playing in
if hand (Player.get newPlaying players) == empty

30
src/Hanafuda/Player.hs
View File

@ -3,21 +3,23 @@
module Hanafuda.Player where
import Hanafuda (Card, Pack, contains, packOfCards, remove)
import qualified Hanafuda.Key as Hanafuda (Key)
import Data.Map ((!), Map, adjust, elemAt, empty, findMin, fromList, insert, keys, singleton, size)
import qualified Data.Map as Map (filter)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Except (MonadError(..))
import System.Random (Random(..))
data Player key yakus = Player {
type Key yakus = Hanafuda.Key (Player yakus)
data Player yakus = Player {
hand :: Pack
, meld :: Pack
, nextPlayer :: key
, nextPlayer :: Key yakus
, yakus :: yakus
} deriving (Show)
newtype Players key yakus = Players (Map key (Player key yakus)) deriving (Show)
newtype Players yakus = Players (Map (Key yakus) (Player yakus)) deriving (Show)
new :: Monoid yakus => key -> Player key yakus
new :: Monoid yakus => (Key yakus) -> Player yakus
new nextPlayer = Player {
hand = packOfCards []
, meld = packOfCards []
@ -25,7 +27,7 @@ new nextPlayer = Player {
, yakus = mempty
}
players :: (Ord key, Monoid yakus) => [key] -> Players key yakus
players :: Monoid yakus => [Key yakus] -> Players yakus
players [] = Players empty
players [player] = Players $ singleton player $ new player
players (alice:others@(bob:_)) =
@ -35,39 +37,39 @@ players (alice:others@(bob:_)) =
where
setNextPlayer nextPlayer player = player {nextPlayer}
next :: Ord key => Players key yakus -> key -> key
next :: Players yakus -> (Key yakus) -> (Key yakus)
next (Players playersByKey) = nextPlayer . (playersByKey !)
random :: MonadIO m => Players key yakus -> m key
random :: MonadIO m => Players yakus -> m (Key yakus)
random (Players playersByKey) =
fst . ($ playersByKey) . elemAt <$> randomIndex
where
randomIndex = liftIO $ randomRIO (0, size playersByKey - 1)
get :: Ord key => key -> Players key yakus -> Player key yakus
get :: (Key yakus) -> Players yakus -> Player yakus
get key (Players playersByKey) = playersByKey ! key
set :: Ord key => key -> Player key yakus -> Players key yakus -> Players key yakus
set :: (Key yakus) -> Player yakus -> Players yakus -> Players yakus
set key player (Players playersByKey) = Players $ insert key player playersByKey
deal :: (Ord key, Monoid yakus) => Players key yakus -> [[Card]] -> Players key yakus
deal :: Monoid yakus => Players yakus -> [[Card]] -> Players yakus
deal (Players playersByKey) hands =
Players $ snd $ foldl dealTo (fst $ findMin playersByKey, playersByKey) hands
where
setHand cards (Player {nextPlayer}) = (new nextPlayer) {hand = packOfCards cards}
dealTo (key, m) hand = (nextPlayer $ m ! key, adjust (setHand hand) key m)
plays :: MonadError String m => Player key yakus -> Card -> m (Player key yakus)
plays :: MonadError String m => Player yakus -> Card -> m (Player yakus)
plays player@(Player {hand}) card =
if hand `contains` card
then return $ player {hand = remove hand card}
else throwError "You don't have this card"
type Points = Int
type Scores key = Map key Points
type Scores yakus = Map (Key yakus) Points
score :: (yakus -> Points) -> Player key yakus -> Points
score :: (yakus -> Points) -> Player yakus -> Points
score rater = rater . yakus
scores :: Ord key => Players key yakus -> [Points] -> Scores key
scores :: Players yakus -> [Points] -> Scores yakus
scores (Players playersByKey) = fromList . zip (keys playersByKey)