Another update from ingydotnet^djgoku

Task/Set-puzzle/Haskell/set-puzzle.hs

@@ -0,0 +1,75 @@
+import Data.List
+import System.Random
+import Control.Monad.State
+
+combinations :: Int -> [a] -> [[a]]
+combinations 0 _      = [[]]
+combinations _ []     = []
+combinations k (y:ys) = map (y:) (combinations (k - 1) ys) ++ combinations k ys
+
+data Color = Red | Green | Purple deriving (Show, Enum, Bounded, Ord, Eq)
+data Symbol = Oval | Squiggle | Diamond deriving (Show, Enum, Bounded, Ord, Eq)
+data Count = One | Two | Three deriving (Show, Enum, Bounded, Ord, Eq)
+data Shading = Solid | Open | Striped deriving (Show, Enum, Bounded, Ord, Eq)
+
+data Card = Card {
+              color :: Color,
+              symbol :: Symbol,
+              count :: Count,
+              shading :: Shading
+            } deriving (Show)
+
+-- Identify a set of three cards by counting all attribute types.
+-- if each count is 3 or 1 ( not 2 ) the the cards compose a set.
+isSet :: [Card] -> Bool
+isSet cs =
+        let colorCount = length $ nub $ sort $ map color cs
+            symbolCount = length $ nub $ sort $ map symbol cs
+            countCount = length $ nub $ sort $ map count cs
+            shadingCount = length $ nub $ sort $ map shading cs
+        in colorCount /= 2 && symbolCount /= 2 && countCount /= 2 && shadingCount /= 2
+
+-- Get a random card from a deck. Returns the card and removes it from the deck.
+getCard :: State (StdGen, [Card]) Card
+getCard = state $ \(gen, cs) -> let (i, newGen) = randomR (0, length cs - 1) gen
+                                    (a,b) = splitAt i cs
+                                in (head b, (newGen, a ++ tail b))
+
+-- Get a hand of cards.  Starts with new deck and then removes the
+-- appropriate number of cards from that deck.
+getHand :: Int -> State StdGen [Card]
+getHand n = state $ \gen ->
+       let deck = [Card co sy ct sh |
+                  co <- [minBound..maxBound],
+                  sy <- [minBound..maxBound],
+                  ct <- [minBound..maxBound],
+                  sh <- [minBound..maxBound]]
+           (a,(newGen, _)) = runState (replicateM n getCard) (gen,deck)
+       in (a, newGen)
+
+-- Get an unbounded number of hands of the appropriate number of cards.
+getManyHands :: Int -> State StdGen [[Card]]
+getManyHands n = (sequence.repeat) (getHand n)
+
+-- Deal out hands of the appropriate size until one with the desired number
+-- of sets is found.  then print the hand and the sets.
+showSolutions :: Int -> Int -> IO ()
+showSolutions cardCount solutionCount = do
+       putStrLn $ "Showing hand of " ++ show cardCount ++ " cards with " ++ show solutionCount ++ " solutions."
+       gen <- newStdGen
+       let Just z = find (\ls -> length (filter isSet $ combinations 3 ls) == solutionCount) $
+               evalState (getManyHands cardCount) gen
+       mapM_ print z
+       putStrLn ""
+       putStrLn "Solutions:"
+       mapM_ putSet  $ filter isSet $ combinations 3 z where
+           putSet st = do
+               mapM_ print st
+               putStrLn ""
+
+-- Show a hand of 9 cards with 4 solutions
+-- and a hand of 12 cards with 6 solutions.
+main :: IO ()
+main = do
+       showSolutions 9 4
+       showSolutions 12 6