gistfile1.hs

{-# LANGUAGE FlexibleInstances, UndecidableInstances, TypeSynonymInstances #-}

module Poker where
  
  import Control.Applicative
  import Text.ParserCombinators.Parsec
  import System.Environment
  import System.IO

  class ParsecRead a where
    parsecRead :: Parser a
  
  instance (ParsecRead a) => Read a where
    readsPrec _ = either (const []) id . parse parsecRead' "" where
      parsecRead' = 
        do a <- parsecRead
           rest <- getInput
           return [(a, rest)]
           
  data Player = P1 | P2
    deriving (Show, Eq)
  
  data Suit = Hearts | Clubs | Spades | Diamonds
    deriving (Eq, Enum, Bounded)
    
  instance Show Suit where
    show Hearts   = "H"
    show Clubs    = "C"
    show Spades   = "S"
    show Diamonds = "D"
  
  instance ParsecRead Suit where
    parsecRead = choice 
      [ char 'H' *> pure Hearts
      , char 'C' *> pure Clubs
      , char 'S' *> pure Spades
      , char 'D' *> pure Diamonds ]

  data Face = Ace | Two | Three | Four | Five | Six | Seven | Eight | Nine | Ten | Jack | Queen | King
    deriving (Eq, Ord, Enum)
    
  instance Show Face where
    show Jack  = "J"
    show Queen = "Q"
    show King  = "K"
    show Ace   = "A"
    show Ten   = "X"
    show x     = show $ (fromEnum x) + 1
  
  instance ParsecRead Face where
    parsecRead = choice 
      [ char '2' *> pure Two
      , char '3' *> pure Three
      , char '4' *> pure Four
      , char '5' *> pure Five
      , char '6' *> pure Six
      , char '7' *> pure Seven
      , char '8' *> pure Eight
      , char '9' *> pure Nine
      , char 'T' *> pure Ten
      , char 'J' *> pure Jack
      , char 'Q' *> pure Queen
      , char 'K' *> pure King
      , char 'A' *> pure Ace ]
      where 

  data Card = Card Face Suit
    deriving (Eq)
    
  instance Show Card where
    show (Card f s) = show s ++ show f
    
  instance Ord Card where
    compare (Card f _) (Card f' _) = compare f f'
    
  instance ParsecRead Card where
    parsecRead = pure Card <*> parsecRead <*> parsecRead
    
  data Hand = Hand [Card]
    deriving (Show, Eq)
    
  instance Ord Hand where
    compare = error "implement compare on Hand, please"
  
  instance ParsecRead Hand where
    parsecRead = do
      let rc = parsecRead :: Parser Card
      cards <- sequence [rc <* space, rc <* space, rc <* space, rc <* space, rc]
      return $ Hand cards
    
  data Round = Round Hand Hand
    deriving (Show, Eq)
  
  instance ParsecRead Round where
    parsecRead = pure Round <*> (parsecRead <* space) <*> (parsecRead)
    
  newtype Match = Match [Round]
    deriving (Show, Eq)
    
  match :: Parser Match
  match = pure Match <*> some parsecRead
    
  winner :: Round -> Player
  winner (Round h1 h2) 
    | h1 == h2  = error ("BUG! " ++ show h1 ++ " == " ++ show h2)
    | h1 > h2   = P1
    | otherwise = P2
    
  main = do
    args <- getArgs
    file <- openFile (args !! 0) ReadMode
    text <- hGetContents file
    print text
    case (parse match "stdio" text) of
      (Left err) -> print err
      (Right (Match rounds)) -> print $ (winner <$> rounds)