cat.hs

import Data.Set (delete, fromList, Set)
import Data.List (find)
import Prelude hiding (iterate)
import Text.Printf (printf)

-- Produce a cartesian product of 0 to n for each n in a list.
cartesianProduct :: (Enum a, Num a) => [a] -> [[a]]
cartesianProduct = mapM (enumFromTo 0 . subtract 1)

-- Produce a list of all strategies of length n
strategies :: Int -> [[Int]]
strategies n = cartesianProduct $ replicate n n

-- Filter valid positions
validPos :: Int -> Int -> Bool
validPos size pos = pos >= 0 && pos < size

-- Generate new positions for a given superposition
newPos :: Int -> Set Int -> Set Int
newPos size superpos = fromList (filter (validPos size) (concatMap (\b -> [b+1, b-1]) superpos))

-- Iterate once. Remove current guess, update superposition
iterate :: Int -> Int -> Set Int -> Set Int
iterate size guess superpos = newPos size (delete guess superpos)

-- Check to see if a strategy works. Could be lazy and quit as soon as we get an empty set.
checkStrat :: Int -> [Int] -> Bool
checkStrat size strategy = null (foldr (iterate size) (fromList [0..(size-1)]) strategy)

-- Find all solutions of length n
solutionsOfLength :: Int -> Int -> [[Int]]
solutionsOfLength boxes_len solution_len  = filter (checkStrat boxes_len) (strategies solution_len)

-- find minimum solutions for boxes of length n
minLengthSolutions :: Int -> Maybe [[Int]]
minLengthSolutions boxes_len = find (not . null) (map (solutionsOfLength boxes_len) [1..])

-- Print the results
printSolutions :: Int -> Maybe [[Int]] -> IO()
printSolutions boxes solutions = printf "%d boxes => %s min solutions\n" boxes (show solutions)

main :: IO()
main = foldr1 (>>) [printSolutions n (minLengthSolutions n) | n <- [1..6]]