set.hs

module Set where

import Control.Applicative
import Control.Monad.State
import Data.List
import Data.Maybe
import Data.Ord
import System.Random

data Colour = Red | Purple | Green      deriving (Eq, Enum, Ord, Bounded, Show)
data Shape = Diamond | Squiggle | Oval  deriving (Eq, Enum, Ord, Bounded, Show)
data Fill = Solid | Open | Stripe       deriving (Eq, Enum, Ord, Bounded, Show)
data Number = One | Two | Three         deriving (Eq, Enum, Ord, Bounded, Show)

data Card = Card { colour :: Colour 
                 , shape  :: Shape 
                 , fill   :: Fill 
                 , number :: Number
                 } deriving (Eq, Ord)

instance Show Card where
  show (Card c s f n) = unwords [show n, show c, show f, show s]

data GameState = GameState { hand :: [Card]
                           , deck :: [Card]
                           } deriving (Show)

type Game = State GameState

main :: IO ()
main = do
  g <- newStdGen
  mapM_ print $ take 10 $ shuffle g fullDeck

runGame :: RandomGen r => r -> Game [(Card, Card, Card)] -> [(Card, Card, Card)]
runGame r = flip evalState (initialState r)

initialState :: RandomGen r => r -> GameState
initialState r = GameState { hand = [], deck = shuffle r fullDeck }

deal :: Int -> Game ()
deal noOfCards = do
  GameState h d <- get
  let (h', d') = splitAt noOfCards d
  put GameState { hand = h ++ h', deck = d' }


fullDeck :: [Card]
fullDeck = Card <$> allValues <*> allValues <*> allValues <*> allValues

allValues :: (Enum a, Bounded a) => [a]
allValues = [minBound ..]

shuffle :: RandomGen g => g -> [a] -> [a]
shuffle g = map snd . sortBy (comparing fst) . zip (randoms g :: [Double])

isSet :: Card -> Card -> Card -> Bool
isSet c1 c2 c3 = and [ good colour
                     , good shape
                     , good fill
                     , good number]
  where good f = isGood f [c1, c2, c3]

isGood :: Eq a => (Card -> a) -> [Card] -> Bool
isGood f cards = let uniq = length . nub $ map f cards
                 in uniq == 1 || uniq == length cards

findSet :: [Card] -> Maybe ((Card, Card, Card), [Card])
findSet hand = listToMaybe [((c1, c2, c3), h3) 
                           | (c1, h1) <- pick hand
                           , (c2, h2) <- pick h1
                           , (c3, h3) <- pick h2
                           , isSet c1 c2 c3
                           ]

pick :: [a] -> [(a, [a])]
pick xs = unfoldr f ([], xs)
  where f (_, [])    = Nothing
        f (bs, x:xs) = Just ((x, bs ++ xs), (x:bs, xs))