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

Generalize the output monad of basic functions by only expressing constraints on it

Browse source
This commit is contained in:
Tissevert 2019-01-08 22:34:29 +01:00
parent f2428f353f
commit 561ef5060d
2 changed files with 13 additions and 7 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
src/Hanafuda.hs
View file

@ -29,6 +29,7 @@ import Data.Bits (
, countTrailingZeros , countTrailingZeros
) )
import System.Random (randomRIO) import System.Random (randomRIO)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Reader (Reader) import Control.Monad.Reader (Reader)
data Flower = data Flower =
@ -116,13 +117,13 @@ sameMonth card = Pack $ 0xf `shift` (fromEnum card .&. 0xfc)
cards :: [Card] cards :: [Card]
cards = [Pine0 .. Phoenix] cards = [Pine0 .. Phoenix]
shuffle :: [a] -> IO [a] shuffle :: MonadIO m => [a] -> m [a]
shuffle l = shuffle l =
aux (length l) l aux (length l) l
where where
aux _ [] = return [] aux _ [] = return []
aux n (h:t) = do aux n (h:t) = do
cut <- randomRIO (0, n-1) cut <- liftIO $ randomRIO (0, n-1)
shuffled <- shuffle t shuffled <- shuffle t
let (top, bottom) = splitAt cut shuffled let (top, bottom) = splitAt cut shuffled
return $ top ++ h : bottom return $ top ++ h : bottom

15
src/Hanafuda/Player.hs
View file

@ -1,9 +1,12 @@
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE FlexibleContexts #-}
module Hanafuda.Player where module Hanafuda.Player where
import Hanafuda (Card, Pack, contains, packOfCards, remove) import Hanafuda (Card, Pack, contains, packOfCards, remove)
import Data.Map ((!), Map, adjust, elemAt, empty, findMin, fromList, insert, keys, singleton, size) import Data.Map ((!), Map, adjust, elemAt, empty, findMin, fromList, insert, keys, singleton, size)
import qualified Data.Map as Map (filter) import qualified Data.Map as Map (filter)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Except (MonadError(..))
import System.Random (Random(..)) import System.Random (Random(..))
data Player key yakus = Player { data Player key yakus = Player {
@ -35,9 +38,11 @@ players (alice:others@(bob:_)) =
next :: Ord key => Players key yakus -> key -> key next :: Ord key => Players key yakus -> key -> key
next (Players playersByKey) = nextPlayer . (playersByKey !) next (Players playersByKey) = nextPlayer . (playersByKey !)
random :: Players key yakus -> IO key random :: MonadIO m => Players key yakus -> m key
random (Players playersByKey) = random (Players playersByKey) =
fst . ($ playersByKey) . elemAt <$> randomRIO (0, size playersByKey - 1) fst . ($ playersByKey) . elemAt <$> randomIndex
where
randomIndex = liftIO $ randomRIO (0, size playersByKey - 1)
get :: Ord key => key -> Players key yakus -> Player key yakus get :: Ord key => key -> Players key yakus -> Player key yakus
get key (Players playersByKey) = playersByKey ! key get key (Players playersByKey) = playersByKey ! key
@ -52,11 +57,11 @@ deal (Players playersByKey) hands =
setHand cards (Player {nextPlayer}) = (new nextPlayer) {hand = packOfCards cards} setHand cards (Player {nextPlayer}) = (new nextPlayer) {hand = packOfCards cards}
dealTo (key, m) hand = (nextPlayer $ m ! key, adjust (setHand hand) key m) dealTo (key, m) hand = (nextPlayer $ m ! key, adjust (setHand hand) key m)
plays :: Player key yakus -> Card -> Either String (Player key yakus) plays :: MonadError String m => Player key yakus -> Card -> m (Player key yakus)
plays player@(Player {hand}) card = plays player@(Player {hand}) card =
if hand `contains` card if hand `contains` card
then Right $ player {hand = remove hand card} then return $ player {hand = remove hand card}
else Left "You don't have this card" else throwError "You don't have this card"
type Points = Int type Points = Int
type Scores key = Map key Points type Scores key = Map key Points