Initial data commit

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

@@ -0,0 +1,103 @@
+import Control.Monad.State
+       (State, evalState, replicateM, runState, state)
+import System.Random (StdGen, newStdGen, randomR)
+import Data.List (find, nub, sort)
+
+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 total = length . nub . sort . flip map cs
+  in notElem 2 [total color, total symbol, total count, total shading]
+
+-- 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 az = [minBound .. maxBound]
+         deck =
+           [ Card co sy ct sh
+           | co <- az
+           , sy <- az
+           , ct <- az
+           , sh <- az ]
+         (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 ((solutionCount ==) . length . filter isSet . combinations 3) $
+        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