diff --git a/hanafuda.cabal b/hanafuda.cabal index 6de3071..c5a479c 100644 --- a/hanafuda.cabal +++ b/hanafuda.cabal @@ -17,12 +17,12 @@ extra-source-files: ChangeLog.md cabal-version: >=1.10 library - exposed-modules: Hanafuda.Year - , Hanafuda.Month - , Hanafuda.Day - , Hanafuda.Game - , Hanafuda.Yaku - , Hanafuda.Card + exposed-modules: Hanafuda + , Hanafuda.KoiKoi + , Hanafuda.Player + other-modules: Hanafuda.KoiKoi.Round + , Hanafuda.KoiKoi.Turn + , Hanafuda.KoiKoi.Yaku -- other-modules: -- other-extensions: build-depends: base >=4.10 && <4.11 diff --git a/src/Hanafuda/Card.hs b/src/Hanafuda.hs similarity index 86% rename from src/Hanafuda/Card.hs rename to src/Hanafuda.hs index 048bd70..413d25d 100644 --- a/src/Hanafuda/Card.hs +++ b/src/Hanafuda.hs @@ -1,4 +1,19 @@ -module Hanafuda.Card where +module Hanafuda ( + Card(..) + , Flower(..) + , Monthly + , Pack + , add + , cards + , contains + , flower + , intersection + , match + , packOfCards + , remove + , shuffle + , size + ) where import Data.Word (Word64) import Data.Bits ( @@ -67,6 +82,9 @@ cardsOfPack p = let c = smallest p in c : cardsOfPack (remove p c) +instance Show Pack where + show = ("packOfCards " ++) . show . cardsOfPack + portEnum :: Enum e => (Word64 -> Int -> b) -> Pack -> e -> b portEnum f (Pack p) = f p . fromEnum @@ -111,10 +129,10 @@ shuffle l = let (top, bottom) = splitAt cut shuffled return $ top ++ h : bottom -pair :: Card -> Pack -> Either String (Pack, [Card]) -pair card pack = +match :: Card -> Pack -> Either String (Pack, [Card]) +match card pack = let sameMonthCards = sameMonth card `intersection` pack in case size sameMonthCards of 0 -> Right (add pack card, []) 1 -> Right (difference pack sameMonthCards, card : cardsOfPack sameMonthCards) - _ -> Left "This card can pair with several others" + _ -> Left "This card can match several others" diff --git a/src/Hanafuda/Day.hs b/src/Hanafuda/Day.hs deleted file mode 100644 index 44b31fd..0000000 --- a/src/Hanafuda/Day.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE MultiParamTypeClasses #-} -module Hanafuda.Day where - -import Hanafuda.Card (Card, Pack, Flower(Pine), contains, flower, pair, remove) -import Hanafuda.Yaku (rate) -import Hanafuda.Game (Game(..), Move(..), PlayerState(..), plays) -import Data.Map (union) -import Control.Monad.Reader (runReader) - -data Step = ToPlay | Turned Card | Scored | Over Bool - -data Day = Day { - river :: Pack - , month :: Flower - , player :: PlayerState - , next :: Card - , step :: Step - , trick :: [Card] - } - -new :: Pack -> PlayerState -> Card -> Day -new river player next = Day { - river - , month = Pine - , player - , next - , step = ToPlay - , trick = [] - } - -instance Game Day Day where - play day@(Day {river, step, next, trick, player}) move = - case (step, move) of - (ToPlay, Play card) -> pair card river >>= play card - (ToPlay, Capture (card, caught)) -> - if card `canCatch` caught - then play card (remove river caught, [card, caught]) - else Left "You can't choose that card" - (Turned card, Choose caught) -> - if card `canCatch` caught - then end $ day {river = remove river caught, trick = [card, caught] ++ trick} - else Left "You can't choose that card" - (Scored, KoiKoi win) -> Right $ day {step = Over win} - (_, _) -> Left "You can't play this move in that state" - where - canCatch card1 card2 = flower card1 == flower card2 && river `contains` card2 - play card (river, trick) = do - played <- player `plays` card - turnOver $ day {river, trick, player = played} - -turnOver :: Day -> Either String Day -turnOver day@(Day {river, next, trick}) = - case pair next river of - Right (newRiver, newCaptured) -> end $ day {river = newRiver, trick = trick ++ newCaptured} - Left _ -> Right $ day {step = Turned next} - -end :: Day -> Either String Day -end day@(Day {month, trick, player}) = - let (scored, newMeld) = runReader (rate (meld player) trick) month in - let updatedPlayer = day {player = player {meld = newMeld, yakus = scored `union` (yakus player)}} in - Right $ if null scored - then updatedPlayer {step = Over False} - else updatedPlayer {step = Scored} diff --git a/src/Hanafuda/Game.hs b/src/Hanafuda/Game.hs deleted file mode 100644 index 901ee59..0000000 --- a/src/Hanafuda/Game.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE MultiParamTypeClasses #-} -module Hanafuda.Game where - -import Data.Map (Map, empty, fromList) -import Hanafuda.Card (Card, Pack, contains, packOfCards, remove) -import Hanafuda.Yaku (Score, Points) - -data Player = - Player1 - | Player2 - deriving (Eq, Ord) - -next :: Player -> Player -next Player1 = Player2 -next _ = Player1 - -data PlayerState = PlayerState { - hand :: Pack - , meld :: Pack - , yakus :: Score - } -type Players = Map Player PlayerState - -players :: [Player] -players = [Player1, Player2] - -deal :: [a] -> Map Player a -deal = fromList . zip players - -initPlayers :: [[Card]] -> Players -initPlayers = - deal . map player - where - player cards = PlayerState { - hand = packOfCards cards - , meld = packOfCards [] - , yakus = empty - } - -plays :: PlayerState -> Card -> Either String PlayerState -plays player@(PlayerState {hand}) card = - if hand `contains` card - then Right $ player {hand = remove hand card} - else Left "You don't have this card" - -data Move = Play Card | Capture (Card, Card) | Choose Card | KoiKoi Bool - -type Scores = Map Player Points - -class Game a b where - play :: a -> Move -> Either String b diff --git a/src/Hanafuda/KoiKoi.hs b/src/Hanafuda/KoiKoi.hs new file mode 100644 index 0000000..1d521cd --- /dev/null +++ b/src/Hanafuda/KoiKoi.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +module Hanafuda.KoiKoi ( + new + , play + , Card(..) + , Mode(..) + , Move(..) + , On + , Over(..) + ) where + +import Prelude hiding (round) +import Hanafuda (Flower(Paulownia), Card(..)) +import Hanafuda.KoiKoi.Round (Round(..), flower, next, score, winner) +import qualified Hanafuda.KoiKoi.Round as Round (On(..), Over(..), new, play) +import Hanafuda.Player (Move(..), Player(Player1), Scores, deal) +import Data.Map (insert, (!)) +import System.Random (StdGen) + +data Mode = FirstAt Int | WholeYear deriving (Show) + +data On = On { + mode :: Mode + , round :: Round.On + , scores :: Scores + } deriving (Show) +data Over = Over { + finalScores :: Scores + } deriving (Show) + +newtype Game = Game (Either Over On) deriving (Show) + +go :: On -> IO Game +go = return . Game . Right + +new :: Mode -> IO On +new mode = do + round <- Round.new Player1 + return $ On {mode , round , scores = deal [0, 0]} + +consolidate :: On -> Player -> Int -> IO Game +consolidate on@(On {mode, round, scores}) winner score = + case mode of + FirstAt n | n <= newScore -> stop + FirstAt n -> continue + WholeYear | flower round == Paulownia -> stop + WholeYear -> continue + where + newScore = scores ! winner + score + newScores = insert winner newScore scores + stop = return . Game . Left $ Over {finalScores = newScores} + continue = do + nextMonth <- next round + go $ on {scores = newScores, round = nextMonth} + +play :: On -> Move -> IO (Either String Game) +play on@(On {mode, round}) move = + either (return . Left) (fmap Right) . fmap after $ Round.play round move + where + after (Round (Left (Round.Over {winner, score}))) = consolidate on winner score + after (Round (Right newMonth)) = go $ on {round = newMonth} diff --git a/src/Hanafuda/KoiKoi/Round.hs b/src/Hanafuda/KoiKoi/Round.hs new file mode 100644 index 0000000..92647fe --- /dev/null +++ b/src/Hanafuda/KoiKoi/Round.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Hanafuda.KoiKoi.Round where + +import Hanafuda (Card, Flower(Pine), cards, shuffle, packOfCards) +import Hanafuda.KoiKoi.Yaku (Score, sumYakus) +import Hanafuda.KoiKoi.Turn (Turn(..)) +import qualified Hanafuda.KoiKoi.Turn as Turn (Step(Over), new, play) +import Hanafuda.Player (Move, Player, Players, deal) +import qualified Hanafuda.Player as Player (next, new, score) +import Data.Map ((!), empty, insert) +import Control.Monad.State (replicateM, runState, state) + +data On = On { + flower :: Flower + , players :: Players Score + , turn :: Turn + , playing :: Player + , lastScored :: Player + , oyake :: Player + , stock :: [Card] + } deriving (Show) +data Over = Over { + winner :: Player + , score :: Int + } + +newtype Round = Round (Either Over On) + +go :: On -> Round +go = Round . Right + +new :: Player -> IO On +new playing = do + ([hand1, hand2, river], next:stock) <- fmap (runState (replicateM 3 take8)) $ shuffle cards + let players = fmap Player.new $ deal [hand1, hand2] + return On { + flower = Pine + , players + , turn = Turn.new (packOfCards river) (players ! playing) next + , playing + , lastScored = playing + , oyake = playing + , stock + } + where + take8 = state $ splitAt 8 + +next :: On -> IO On +next (On {flower, oyake}) = do + on <- new $ Player.next oyake + return $ on {flower = succ flower} + +play :: On -> Move -> Either String Round +play on@(On {flower, turn, playing, players, stock = next : moreStock}) move = + fmap after $ Turn.play turn move + where + after (Turn {step = Turn.Over True, player}) = + Round . Left $ Over {winner = playing, score = Player.score sumYakus player} + after (Turn {step = Turn.Over False, player, river}) = + let otherPlayer = Player.next playing in + go $ on { + players = insert playing player players + , playing = otherPlayer + , turn = (Turn.new river (players ! otherPlayer) next) { month = flower } + , stock = moreStock + } + after newTurn = go $ on {turn = newTurn} diff --git a/src/Hanafuda/KoiKoi/Turn.hs b/src/Hanafuda/KoiKoi/Turn.hs new file mode 100644 index 0000000..f333aad --- /dev/null +++ b/src/Hanafuda/KoiKoi/Turn.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Hanafuda.KoiKoi.Turn where + +import Hanafuda (Card, Pack, Flower(Pine), contains, flower, match, remove) +import Hanafuda.KoiKoi.Yaku (Score, meldInto) +import Hanafuda.Player (Move(..), State(..), plays) +import Control.Monad.Reader (runReader) + +data Step = ToPlay | Turned Card | Scored | Over Bool deriving (Show) +type Player = State Score + +data Turn = Turn { + river :: Pack + , month :: Flower + , player :: Player + , next :: Card + , step :: Step + , trick :: [Card] + } deriving (Show) + +new :: Pack -> Player -> Card -> Turn +new river player next = Turn { + river + , month = Pine + , player + , next + , step = ToPlay + , trick = [] + } + +play :: Turn -> Move -> Either String Turn +play turn@(Turn {river, step, next, trick, player}) move = + case (step, move) of + (ToPlay, Play card) -> match card river >>= play card + (ToPlay, Capture (card, caught)) -> + if card `canCatch` caught + then play card (remove river caught, [card, caught]) + else Left "You can't choose that card" + (Turned card, Choose caught) -> + if card `canCatch` caught + then end $ turn {river = remove river caught, trick = [card, caught] ++ trick} + else Left "You can't choose that card" + (Scored, KoiKoi win) -> Right $ turn {step = Over win} + (_, _) -> Left "You can't play this move in that state" + where + canCatch card1 card2 = flower card1 == flower card2 && river `contains` card2 + play card (river, trick) = do + played <- player `plays` card + turnOver $ turn {river, trick, player = played} + +turnOver :: Turn -> Either String Turn +turnOver turn@(Turn {river, next, trick}) = + case match next river of + Right (newRiver, newCaptured) -> end $ turn {river = newRiver, trick = trick ++ newCaptured} + Left _ -> Right $ turn {step = Turned next} + +end :: Turn -> Either String Turn +end turn@(Turn {month, trick, player}) = + let (scored, newMeld) = runReader (trick `meldInto` (meld player)) month in + let updatedPlayer = turn {player = player {meld = newMeld, yakus = scored `mappend` (yakus player)}} in + Right $ if null scored + then updatedPlayer {step = Over False} + else updatedPlayer {step = Scored} diff --git a/src/Hanafuda/Yaku.hs b/src/Hanafuda/KoiKoi/Yaku.hs similarity index 89% rename from src/Hanafuda/Yaku.hs rename to src/Hanafuda/KoiKoi/Yaku.hs index 38ff655..b1a666d 100644 --- a/src/Hanafuda/Yaku.hs +++ b/src/Hanafuda/KoiKoi/Yaku.hs @@ -1,8 +1,8 @@ {-# LANGUAGE NamedFieldPuns #-} -module Hanafuda.Yaku where +module Hanafuda.KoiKoi.Yaku where -import Hanafuda.Card (Card(..), Monthly, Pack, add, contains, intersection, packOfCards, size) -import qualified Data.Map as M (Map, empty, insert, unionWith, (!)) +import Hanafuda (Card(..), Monthly, Pack, add, contains, intersection, packOfCards, size) +import qualified Data.Map as M (Map, empty, insert, union, unionWith, (!)) import qualified Data.Set as S (Set, empty, singleton, union) import Control.Monad.Reader (reader) @@ -81,11 +81,14 @@ finders = do akatan = [PinePoetry, PlumPoetry, CherryPoetry] plains = (foldl (++) [] [map toEnum [4*i, 4*i+1] | i <- [0..10]]) ++ Lightning : [Paulownia0 .. Sand] -rate :: Pack -> [Card] -> Monthly (Score, Pack) -rate pack cards = do +meldInto :: [Card] -> Pack -> Monthly (Score, Pack) +meldInto cards pack = do yakusToCheck <- fmap toCheck finders return (foldl scored M.empty yakusToCheck, newPack) where newPack = foldl add pack cards toCheck map = foldl (\set key -> S.union set (map M.! key)) S.empty cards scored score (YakuFinder {yaku, rater}) = foldr (M.insert yaku) score $ rater newPack + +sumYakus :: Score -> Points +sumYakus = foldl (+) 0 diff --git a/src/Hanafuda/Month.hs b/src/Hanafuda/Month.hs deleted file mode 100644 index 7d56919..0000000 --- a/src/Hanafuda/Month.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE MultiParamTypeClasses #-} -module Hanafuda.Month where - -import Hanafuda.Card (Card, Flower(Pine), cards, shuffle, packOfCards) -import Hanafuda.Day (Day(..)) -import qualified Hanafuda.Day as Day (Step(Over), new) -import Hanafuda.Game (Game(..), Player, Players, PlayerState(..), initPlayers) -import qualified Hanafuda.Game as Game (next) -import Data.Map ((!), insert) -import Control.Monad.State (replicateM, runState, state) - -data On = On { - flower :: Flower - , players :: Players - , day :: Day - , playing :: Player - , lastScored :: Player - , oyake :: Player - , stock :: [Card] - } -data Over = Over { - winner :: Player - , score :: Int - } - -newtype Month = Month (Either Over On) - -go :: On -> Month -go = Month . Right - -new :: Player -> IO On -new playing = do - ([hand1, hand2, river], next:stock) <- fmap (runState (replicateM 3 take8)) $ shuffle cards - let players = initPlayers [hand1, hand2] - return On { - flower = Pine - , players - , day = Day.new (packOfCards river) (players ! playing) next - , playing - , lastScored = playing - , oyake = playing - , stock - } - where - take8 = state $ splitAt 8 - -next :: On -> IO On -next (On {flower, oyake}) = do - on <- new $ Game.next oyake - return $ on {flower = succ flower} - -instance Game On Month where - play on@(On {flower, day, playing, players, stock = next : moreStock}) move = - fmap after $ play day move - where - after (Day {step = Day.Over True, player = PlayerState {yakus}}) = - Month . Left $ Over {winner = playing, score = foldl (+) 0 yakus} - after (Day {step = Day.Over False, player, river}) = - let otherPlayer = Game.next playing in - go $ on { - players = insert playing player players - , playing = otherPlayer - , day = (Day.new river (players ! otherPlayer) next) { month = flower } - , stock = moreStock - } - after newDay = go $ on {day = newDay} diff --git a/src/Hanafuda/Player.hs b/src/Hanafuda/Player.hs new file mode 100644 index 0000000..c4a02df --- /dev/null +++ b/src/Hanafuda/Player.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Hanafuda.Player where + +import Data.Map (Map, empty, fromList) +import Hanafuda (Card, Pack, contains, packOfCards, remove) + +data Player = + Player1 + | Player2 + deriving (Eq, Ord, Show) + +next :: Player -> Player +next Player1 = Player2 +next _ = Player1 + +data State a = State { + hand :: Pack + , meld :: Pack + , yakus :: a + } deriving (Show) +type Players a = Map Player (State a) + +deal :: [a] -> Map Player a +deal = fromList . zip [Player1, Player2] + +new :: Monoid a => [Card] -> State a +new cards = State { + hand = packOfCards cards + , meld = packOfCards [] + , yakus = mempty + } + +plays :: State a -> Card -> Either String (State a) +plays player@(State {hand}) card = + if hand `contains` card + then Right $ player {hand = remove hand card} + else Left "You don't have this card" + +data Move = Play Card | Capture (Card, Card) | Choose Card | KoiKoi Bool + +type Points = Int + +score :: (a -> Points) -> State a -> Int +score rater = rater . yakus + +type Scores = Map Player Points diff --git a/src/Hanafuda/Year.hs b/src/Hanafuda/Year.hs deleted file mode 100644 index 81be772..0000000 --- a/src/Hanafuda/Year.hs +++ /dev/null @@ -1,54 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -module Hanafuda.Year where - -import Hanafuda.Card (Flower(Paulownia)) -import Hanafuda.Month (Month(..), flower, next, score, winner) -import qualified Hanafuda.Month as Month (On(..), Over(..), new) -import Hanafuda.Game (Game(..), Player(Player1), Scores, deal) -import Data.Map (insert, (!)) -import System.Random (StdGen) - -data Mode = FirstAt Int | WholeYear - -data On = On { - mode :: Mode - , month :: Month.On - , scores :: Scores - } -data Over = Over { - finalScores :: Scores - } - -newtype Year = Year (Either Over On) - -go :: On -> IO Year -go = return . Year . Right - -new :: Mode -> IO Year -new mode = do - month <- Month.new Player1 - go $ On {mode , month , scores = deal $ cycle [0]} - -consolidate :: On -> Player -> Int -> IO Year -consolidate on@(On {mode, month, scores}) winner score = - case mode of - FirstAt n | n <= newScore -> stop - FirstAt n -> continue - WholeYear | flower month == Paulownia -> stop - WholeYear -> continue - where - newScore = scores ! winner + score - newScores = insert winner newScore scores - stop = return . Year . Left $ Over {finalScores = newScores} - continue = do - nextMonth <- next month - go $ on {scores = newScores, month = nextMonth} - -instance Game On (IO Year) where - play on@(On {mode, month}) move = - fmap after $ play month move - where - after (Month (Left (Month.Over {winner, score}))) = consolidate on winner score - after (Month (Right newMonth)) = go $ on {month = newMonth}