packages feed

draw-poker (empty) → 0.1.0.0

raw patch · 8 files changed

+507/−0 lines, 8 filesdep +basedep +draw-pokerdep +random-shufflesetup-changed

Dependencies added: base, draw-poker, random-shuffle, safe

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Your name here nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,5 @@+module Main where+import Game.Poker++main :: IO ()+main = simpleGame
+ draw-poker.cabal view
@@ -0,0 +1,43 @@+name:                draw-poker+version:             0.1.0.0+synopsis:            playing draw poker+description:         for http://tune.hateblo.jp/entry/2015/05/12/023112+homepage:            http://github.com/name/project+license:             BSD3+license-file:        LICENSE+author:              tune+maintainer:          its.out.of.tune.this.my.music@gmail.com+category:            Game+build-type:          Simple+cabal-version:       >=1.10++library+  hs-source-dirs:      src+  exposed-modules:     Game.Poker+                     , Game.Poker.Hands+                     , Game.Poker.Cards+  build-depends:       base >= 4.7 && < 5+                     , random-shuffle+                     , safe+  default-language:    Haskell2010++executable draw-poker+  hs-source-dirs:      app+  main-is:             Main.hs+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N+  build-depends:       base+                     , draw-poker+  default-language:    Haskell2010++test-suite draw-poker-test+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             Spec.hs+  build-depends:       base+                     , draw-poker+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N+  default-language:    Haskell2010++source-repository head+  type:     git+  location: https://github.com/name/project
+ src/Game/Poker.hs view
@@ -0,0 +1,174 @@+module Game.Poker+    ( module Game.Poker.Hands+    , module Game.Poker.Cards+    , simpleGame+    ) where+import System.Random.Shuffle++import Game.Poker.Hands+import Game.Poker.Cards++import Control.Applicative+import Control.Monad+import Data.Char+import Data.Maybe+import Safe++-----------+-- ハンドの入れ替え++type DiscardList = [Card] -- 捨て札+type Deck = [Card]        -- 山札++getHand :: Deck -> Maybe (Hand, Deck)+getHand deck = do+  hand <- toHand . take 5 $ deck+  return (hand, drop 5 deck)++drawHand :: Deck -> DiscardList -> Hand -> Maybe (Hand, Deck)+drawHand deck dis h = let+  nl = filter (flip notElem dis) (fromHand h)+  nr = drop (5 - length nl) deck+  in (,) <$> toHand (take 5 $ nl ++ deck) <*> Just nr++getDiscardList :: Hand -> IO (Maybe DiscardList)+getDiscardList h = do+    input <- getLine+    return $ do+      intList <- toIntList input+      res <- selectByIndexes (fromHand h) intList+      return res++------+-- helper++toIntList :: String -> Maybe [Int]+toIntList str = if and $ map isDigit str then Just $ reads str else Nothing+  where+    reads :: String -> [Int]+    reads = map $ read . (:[])++selectByIndexes :: [a] -> [Int] -> Maybe [a]+selectByIndexes l = sequence . map ((atMay l).(subtract 1))++-----------+-- AIの思考ルーチン(カードの入れ替え)++aiSelectDiscards :: Hand -> DiscardList+aiSelectDiscards hand = +  case straightHint hand `mplus` flushHint hand *> Just [] of +    Nothing -> nOfKindDiscards hand+    Just xs -> xs ++nOfKindDiscards :: Hand -> DiscardList+nOfKindDiscards hand = filter (flip notElem $ allNOfKinds hand) $ fromHand hand+  where+    allNOfKinds :: Hand -> [Card]+    allNOfKinds hand = concat . concat +      $ catMaybes [nOfKindHint 2 hand, nOfKindHint 3 hand, nOfKindHint 4 hand]++-----------+-- 勝敗判定++judgeVictory :: (PokerHand, Card) -> (PokerHand, Card) -> Ordering+judgeVictory l r = compare (pullStrength l) (pullStrength r)+  where+    pullStrength :: (PokerHand, Card) -> (PokerHand, Int)+    pullStrength = fmap cardStrength++-----------+-- プロトタイプ++simpleGame :: IO ()+simpleGame  = do+  putStrLn "------------------"+  putStrLn "-- simple poker --"+  putStrLn "------------------"+  deck <- shuffleM allCards+  case getHand deck of+    Nothing -> error "予期せぬエラー : getHand in simpleGame"+    Just res -> matchPoker res+  ynQuestion "-- もっかいやる？" simpleGame (putStrLn "-- またねノシノシ")++--------++data Player = Player | Enemy deriving Eq++showPlayerName :: Player -> String+showPlayerName Player = "あなた"+showPlayerName Enemy = "あいて"++matchPoker :: (Hand, Deck) -> IO ()+matchPoker (mhand, deck) = do+  (mres, ndeck, nmhand) <- playPoker mhand deck Player+  case getHand ndeck of+    Nothing -> error "予期せぬエラー : getHand in matchPoker"+    Just (ehand, odeck) -> do+      (eres, _, nehand) <- playPoker ehand odeck Enemy+      printResult nmhand nehand mres eres+  +playPoker :: Hand -> Deck -> Player -> IO ((PokerHand, Card), Deck, Hand)+playPoker hand deck player = do+  discards <- if player == Player +    then inputDisuse hand+    else aiDisuse hand+  case drawHand deck discards hand of+    Nothing -> error "予期せぬエラー : drawHand"+    Just (nhand, ndeck) -> do+      let res = pokerHand nhand+      return (res, ndeck, nhand)++inputDisuse :: Hand -> IO DiscardList+inputDisuse hand = do+  printHand [] hand Player+  putStrLn "-- 捨てるカードを選んでね"+  gotDisuse <- getDiscardList hand+  case gotDisuse of+    Nothing -> do+      putStrLn "-- 1~5の数値を並べて入力してね"+      inputDisuse hand+    Just disuses -> do+      printHand disuses hand Player+      ynQuestion "-- あなた：これでいい？" (return disuses) (inputDisuse hand)++aiDisuse :: Hand -> IO DiscardList+aiDisuse hand = do+  let res = aiSelectDiscards hand+  printHand res hand Enemy+  putStrLn "-- あいて：これでいいよ！" +  return res++----+          +printResult :: Hand -> Hand -> (PokerHand, Card) -> (PokerHand, Card) -> IO ()+printResult mhand ehand mres@(mph, mcard) eres@(eph, ecard) = do+  putStrLn " ***** 結果発表！！ *****"+  printHand [] mhand Player+  printHand [] ehand Enemy+  putStrLn $ concat ["あなたの手札は ", show mph, " で、最強カードは ", show mcard, " でした"]+  putStrLn $ concat ["あいての手札は ", show eph, " で、最強カードは ", show ecard, " でした"]+  case judgeVictory mres eres of+    LT -> putStrLn "あなたの負けです"+    EQ -> putStrLn "引き分けです"+    GT -> putStrLn "あなたの勝ちです"++printHand :: DiscardList -> Hand -> Player -> IO ()+printHand dis hand player = +  putStrLn $ "-- " ++ showPlayerName player ++ "の手札 : " ++ showChangeHand dis hand++ynQuestion :: String -> IO a -> IO a -> IO a+ynQuestion s yes no = do+  putStrLn $ s ++ "(y/n)"+  input <- getLine+  case input of +    "y" -> yes+    "n" -> no+    _ -> do+      putStrLn "-- `y`か`n`で入力してね"+      ynQuestion s yes no++showChangeHand :: DiscardList -> Hand -> String+showChangeHand dis h = let+  judge x = if elem x dis then " " ++ show x ++ " " else "[" ++ show x ++ "]"+  in concat $ map judge (fromHand h)+
+ src/Game/Poker/Cards.hs view
@@ -0,0 +1,103 @@+module Game.Poker.Cards +  ( Suit(..) +  , Card+  , allCards+  , cardSuit+  , cardNumber+  , cardStrength+  ----+  , h2 , h3 , h4 , h5 , h6 , h7 , h8 , h9 , h10 , hJ , hQ , hK , hA +  , d2 , d3 , d4 , d5 , d6 , d7 , d8 , d9 , d10 , dJ , dQ , dK , dA +  , c2 , c3 , c4 , c5 , c6 , c7 , c8 , c9 , c10 , cJ , cQ , cK , cA +  , s2 , s3 , s4 , s5 , s6 , s7 , s8 , s9 , s10 , sJ , sQ , sK , sA +  ) where+--import Control.DeepSeq++data Suit = Hearts | Diamonds | Clubs | Spades+  deriving (Show, Read, Eq, Ord, Enum)+data Card = Card Int Suit+  deriving (Eq, Ord)+instance Show Card where+  show (Card i Hearts) = "H" ++ showCardNumber i+  show (Card i Diamonds) = "D" ++ showCardNumber i+  show (Card i Clubs) = "C" ++ showCardNumber i+  show (Card i Spades) = "S" ++ showCardNumber i++showCardNumber :: Int -> String+showCardNumber 14 = "A_"+showCardNumber 13 = "K_"+showCardNumber 12 = "Q_"+showCardNumber 11 = "J_"+showCardNumber 10 = "10"+showCardNumber x = (show $ x) ++ "_"++allCards :: [Card]+allCards = [ Card num suit | suit <- [Hearts ..], num <- [2..14] ]++cardSuit :: Card -> Suit+cardSuit (Card _ s) = s++cardNumber :: Card -> Int+cardNumber (Card 14 _) = 1 -- Aは14なので+cardNumber (Card n _) = n++cardStrength :: Card -> Int+cardStrength (Card n _) = n++--------++h2 = Card 2 Hearts+h3 = Card 3 Hearts+h4 = Card 4 Hearts+h5 = Card 5 Hearts+h6 = Card 6 Hearts+h7 = Card 7 Hearts+h8 = Card 8 Hearts+h9 = Card 9 Hearts+h10 = Card 10 Hearts+hJ = Card 11 Hearts+hQ = Card 12 Hearts+hK = Card 13 Hearts+hA = Card 14 Hearts++d2 = Card 2 Diamonds+d3 = Card 3 Diamonds+d4 = Card 4 Diamonds+d5 = Card 5 Diamonds+d6 = Card 6 Diamonds+d7 = Card 7 Diamonds+d8 = Card 8 Diamonds+d9 = Card 9 Diamonds+d10 = Card 10 Diamonds+dJ = Card 11 Diamonds+dQ = Card 12 Diamonds+dK = Card 13 Diamonds+dA = Card 14 Diamonds++c2 = Card 2 Clubs+c3 = Card 3 Clubs+c4 = Card 4 Clubs+c5 = Card 5 Clubs+c6 = Card 6 Clubs+c7 = Card 7 Clubs+c8 = Card 8 Clubs+c9 = Card 9 Clubs+c10 = Card 10 Clubs+cJ = Card 11 Clubs+cQ = Card 12 Clubs+cK = Card 13 Clubs+cA = Card 14 Clubs++s2 = Card 2 Spades+s3 = Card 3 Spades+s4 = Card 4 Spades+s5 = Card 5 Spades+s6 = Card 6 Spades+s7 = Card 7 Spades+s8 = Card 8 Spades+s9 = Card 9 Spades+s10 = Card 10 Spades+sJ = Card 11 Spades+sQ = Card 12 Spades+sK = Card 13 Spades+sA = Card 14 Spades
+ src/Game/Poker/Hands.hs view
@@ -0,0 +1,148 @@+module Game.Poker.Hands +  ( Hand+  , toHand, fromHand+  , PokerHand(..)+  , pokerHand +  ----+  -- hint+  , straightHint+  , flushHint+  , nOfKindHint+  ----+  -- hand+  , straightFlush+  , fourOfAKind+  , fullHouse+  , flush+  , straight+  , threeOfAKind+  , twoPair+  , onePair +  ) where+import Game.Poker.Cards+import Data.List+import Control.Monad++newtype Hand = Hand { fromHand :: [Card] } deriving (Show, Eq, Ord)++toHand :: [Card] -> Maybe Hand+toHand l = +  if length l == 5 +    then Just $ Hand (sort l)+    else Nothing++pokerHand :: Hand -> (PokerHand, Card)+pokerHand h@(Hand l) = +    case foldl mplus Nothing $ fmap ($h) hands of+      Just pc -> pc+      Nothing -> (HighCards, last l)+  where+    hands :: [Hand -> Maybe (PokerHand, Card)]+    hands = +      [ straightFlush+      , fourOfAKind+      , fullHouse+      , flush+      , straight+      , threeOfAKind+      , twoPair+      , onePair +      ]++-------++-- ポーカー・ハンド+data PokerHand +  = HighCards+  | OnePair+  | TwoPair+  | ThreeOfAKind+  | Straight+  | Flush+  | FullHouse+  | FourOfAKind+  | StraightFlush+  deriving (Show, Read, Eq, Ord, Enum)++-------+-- Hint++straightHint :: Hand -> Maybe Card+straightHint (Hand l) = +  (judgeStright . extract cardStrength $ l)+  `mplus`+  (judgeStright . sort . extract cardNumber $ l)+    where+      isStright :: [Int] -> Bool+      isStright xs@(x:_) = xs == [x .. x + 4]+      isStright _ = False+      +      judgeStright :: [(Int, Card)] -> Maybe Card+      judgeStright l = +        if isStright $ map fst l+          then Just . snd . last $ l+          else Nothing++flushHint :: Hand -> Maybe Card+flushHint (Hand (x:xs)) = +  if all ((cardSuit x==).cardSuit) xs then Just (last xs) else Nothing++nOfKindHint :: Int -> Hand -> Maybe [[Card]]+nOfKindHint n (Hand h) = if cards /= [] then Just cards else Nothing+  where+    cards :: [[Card]]+    cards = filter ((==n).length) +      $ groupBy (\x y -> cardNumber x == cardNumber y) h++-------+-- PokerHand++straightFlush :: Hand -> Maybe (PokerHand, Card)+straightFlush h = do+  c <- straightHint  h+  d <- flushHint h+  return (StraightFlush, max c d)++fourOfAKind :: Hand -> Maybe (PokerHand, Card)+fourOfAKind h = do+  cs <- nOfKindHint 4 h+  return (FourOfAKind, last $ concat cs)++fullHouse :: Hand -> Maybe (PokerHand, Card)+fullHouse h = do+  cs <- nOfKindHint 3 h+  nOfKindHint 2 h+  return (FullHouse, last $ concat cs)++flush :: Hand -> Maybe (PokerHand, Card)+flush h = do+  c <- flushHint h+  return (Flush, c)++straight :: Hand -> Maybe (PokerHand, Card)+straight h = do+  c <- straightHint h+  return (Straight, c)++threeOfAKind :: Hand -> Maybe (PokerHand, Card)+threeOfAKind h = do+  cs <- nOfKindHint 3 h+  return (ThreeOfAKind, last $ concat cs)++twoPair :: Hand -> Maybe (PokerHand, Card)+twoPair h = do+  cs <- nOfKindHint 2 h+  if length cs == 2 +    then Just (TwoPair, last $ concat cs)+    else Nothing+  +onePair :: Hand -> Maybe (PokerHand, Card)+onePair h = do+  cs <- nOfKindHint 2 h+  return (OnePair, last $ concat cs)++-------+-- Helper++extract :: (b -> a) -> [b] -> [(a, b)]+extract f cs = map (\c -> (f c, c)) cs
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"