From 95b2132a107372bf53b694f065d393e51a7dd8d0 Mon Sep 17 00:00:00 2001 From: Sasha Date: Wed, 7 Mar 2018 17:32:28 +0100 Subject: [PATCH] Purify types into newtypes to ease writing instances --- src/Hanafuda/Card.hs | 39 +++++++++++++++++++++------------------ src/Hanafuda/Game.hs | 14 ++++++++++---- src/Hanafuda/Month.hs | 21 +++++++++++---------- src/Hanafuda/Year.hs | 38 ++++++++++++++++++++------------------ 4 files changed, 62 insertions(+), 50 deletions(-) diff --git a/src/Hanafuda/Card.hs b/src/Hanafuda/Card.hs index 38ef445..daa21be 100644 --- a/src/Hanafuda/Card.hs +++ b/src/Hanafuda/Card.hs @@ -51,49 +51,52 @@ flower = toEnum . (`div` 4) . fromEnum type Monthly a = Reader Flower a -type Pack = Word64 +newtype Pack = Pack { unpack :: Word64 } deriving (Eq) empty :: Pack -empty = 0 +empty = Pack 0 packOfCards :: [Card] -> Pack -packOfCards = foldl add 0 +packOfCards = foldl add empty smallest :: Pack -> Card -smallest = toEnum . countTrailingZeros +smallest = toEnum . countTrailingZeros . unpack cardsOfPack :: Pack -> [Card] -cardsOfPack 0 = [] -cardsOfPack pack = - let n = countTrailingZeros pack in - toEnum n : cardsOfPack (clearBit pack n) +cardsOfPack (Pack 0) = [] +cardsOfPack p = + let c = smallest p in + c : cardsOfPack (remove p c) -port :: (Bits a, Enum e) => (a -> Int -> b) -> a -> e -> b -port f bits = f bits . fromEnum +portEnum :: Enum e => (Word64 -> Int -> b) -> Pack -> e -> b +portEnum f (Pack p) = f p . fromEnum contains :: Pack -> Card -> Bool -contains = port testBit +contains = portEnum testBit size :: Pack -> Int -size = popCount +size (Pack p) = popCount p add :: Pack -> Card -> Pack -add = port setBit +add p = Pack . portEnum setBit p remove :: Pack -> Card -> Pack -remove = port clearBit +remove p = Pack . portEnum clearBit p + +portBinary :: (Word64 -> Word64 -> Word64) -> Pack -> Pack -> Pack +portBinary operator (Pack a) (Pack b) = Pack $ operator a b union :: Pack -> Pack -> Pack -union = (.|.) +union = portBinary (.|.) intersection :: Pack -> Pack -> Pack -intersection = (.&.) +intersection = portBinary (.&.) difference :: Pack -> Pack -> Pack -difference a b = a `xor` (a .&. b) +difference = portBinary (\a b -> a `xor` (a .&. b)) sameMonth :: Card -> Pack -sameMonth card = 0xf `shift` (fromEnum card .&. 0xfc) +sameMonth card = Pack $ 0xf `shift` (fromEnum card .&. 0xfc) cards :: [Card] cards = [Pine0 .. Phoenix] diff --git a/src/Hanafuda/Game.hs b/src/Hanafuda/Game.hs index 9eeed3f..f2d27d8 100644 --- a/src/Hanafuda/Game.hs +++ b/src/Hanafuda/Game.hs @@ -1,7 +1,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} module Hanafuda.Game where -import Data.Map (Map, empty, fromList) +import Data.Map (Map, empty, fromList, (!)) import Hanafuda.Card (Card, Pack, packOfCards) import Hanafuda.Yaku (Score, Points) @@ -21,9 +21,15 @@ data PlayerState = PlayerState { } type Players = Map Player PlayerState -initPlayers :: [Card] -> [Card] -> Players -initPlayers hand1 hand2 = - fromList [(Player1, player hand1), (Player2, player hand2)] +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 diff --git a/src/Hanafuda/Month.hs b/src/Hanafuda/Month.hs index 53fe937..786fc84 100644 --- a/src/Hanafuda/Month.hs +++ b/src/Hanafuda/Month.hs @@ -1,7 +1,5 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} module Hanafuda.Month where import Hanafuda.Card (Card, Flower(Pine), cards, shuffle, packOfCards) @@ -26,7 +24,10 @@ data Over = Over { , score :: Int } -type Month = Either Over On +newtype Month = Month (Either Over On) + +go :: On -> Month +go = Month . Right new :: Player -> [Card] -> On new playing shuffled = @@ -42,25 +43,25 @@ new playing shuffled = where take8 = state $ splitAt 8 ([hand1, hand2, river], next:stock) = runState (replicateM 3 take8) shuffled - players = initPlayers hand1 hand2 + players = initPlayers [hand1, hand2] next :: On -> IO On -next month@(On {flower, oyake}) = do +next (On {flower, oyake}) = do shuffled <- shuffle cards - return $ (new (Game.next oyake) cards) {flower = succ flower} + return $ (new (Game.next oyake) shuffled) {flower = succ flower} instance Game On Month where - play month@(On {flower, day, playing, players, stock = next : moreStock}) move = + 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}}) = - Left $ Over {winner = playing, score = foldl (+) 0 yakus} + Month . Left $ Over {winner = playing, score = foldl (+) 0 yakus} after (Day {step = Day.Over False, player, river}) = let otherPlayer = Game.next playing in - Right $ month { + go $ on { players = insert playing player players , playing = otherPlayer , day = (Day.new river (players ! otherPlayer) next) { month = flower } , stock = moreStock } - after newDay = Right $ month {day = newDay} + after newDay = go $ on {day = newDay} diff --git a/src/Hanafuda/Year.hs b/src/Hanafuda/Year.hs index a735eae..eee2f12 100644 --- a/src/Hanafuda/Year.hs +++ b/src/Hanafuda/Year.hs @@ -1,14 +1,13 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} module Hanafuda.Year where import Hanafuda.Card (Flower(Paulownia), cards, shuffle) -import Hanafuda.Month (flower, next, score, winner) +import Hanafuda.Month (Month(..), flower, next, score, winner) import qualified Hanafuda.Month as Month (On(..), Over(..), new) -import Hanafuda.Game (Game(..), Player(Player1), Scores) -import Data.Map (Map, empty, insert, (!)) +import Hanafuda.Game (Game(..), Player(Player1), Scores, deal) +import Data.Map (Map, insert, (!)) import System.Random (StdGen) data Mode = FirstAt Int | WholeYear @@ -22,35 +21,38 @@ data Over = Over { finalScores :: Scores } -type Year = IO (Either Over On) +newtype Year = Year (Either Over On) -new :: Mode -> Year +go :: On -> IO Year +go = return . Year . Right + +new :: Mode -> IO Year new mode = do shuffled <- shuffle cards - return . Right $ On { + go $ On { mode , month = Month.new Player1 shuffled - , scores = empty + , scores = deal $ cycle [0] } -consolidate :: On -> Player -> Int -> Year -consolidate year@(On {mode, month, scores}) winner score = +consolidate :: On -> Player -> Int -> IO Year +consolidate on@(On {mode, month, scores}) winner score = case mode of - FirstAt n | n <= newScore -> over + FirstAt n | n <= newScore -> stop FirstAt n -> continue - WholeYear | flower month == Paulownia -> over + WholeYear | flower month == Paulownia -> stop WholeYear -> continue where newScore = scores ! winner + score newScores = insert winner newScore scores - over = return . Left $ Over {finalScores = newScores} + stop = return . Year . Left $ Over {finalScores = newScores} continue = do nextMonth <- next month - return . Right $ year {scores = newScores, month = nextMonth} + go $ on {scores = newScores, month = nextMonth} -instance Game On Year where - play year@(On {mode, month}) move = +instance Game On (IO Year) where + play on@(On {mode, month}) move = fmap after $ play month move where - after (Left (Month.Over {winner, score})) = consolidate year winner score - after (Right newMonth) = return . Right $ year {month = newMonth} + after (Month (Left (Month.Over {winner, score}))) = consolidate on winner score + after (Month (Right newMonth)) = go $ on {month = newMonth}