{- Given the number of weighings, prints instructions to solve the following riddle: You have (3^N - 3) / 2 identical looking objects, one of which is lighter or heavier than the others (but you don't know which). In N weighings, determine which is the odd one, and whether it is lighter or heavier. -} module Main where import IO import System.Environment main :: IO () main = do args <- getArgs let w :: Int w = read $ head args -- number of weighings l = labels w -- list of object labels n = length l -- number of objects you can use putStr $ " You can find the odd one out of " ++ show n ++ " objects with " ++ show w ++ " weighings, as follows:\n\n"++ " 1. Assign the following \"magic number\" labels to the objects:\n" ++ " " ++ unwords l ++ "\n\n" ++ " 2. Keep track of two strings of numbers, LIGHT and HEAVY.\n\n" ++ " 3. Record weighing results as follows:\n" ++ " If pans balance, append 1 to both LIGHT and HEAVY.\n" ++ " If left side is lighter, append 0 to LIGHT and 2 to HEAVY.\n" ++ " If right side is lighter, append 2 to LIGHT and 0 to HEAVY.\n\n" ++ " 4. Perform weighings in this order:\n" ++ weighingOrder 1 w ++ "\n" ++ " 5. After " ++ show w ++ " weighings, either LIGHT or HEAVY will " ++ "match one of the object labels. That object is the odd one, and " ++ "its fault is shown by whether LIGHT or HEAVY matched.\n" weighingOrder :: Int -> Int -> String weighingOrder current total = " #" ++ show current ++ ":\n" ++ " Left : " ++ unwords (weighing current total '0') ++ "\n" ++ " Right: " ++ unwords (weighing current total '2') ++ "\n" ++ if current == total then "" else weighingOrder (current+1) total weighing i w lr = filter (\l -> l !! (i-1) == lr) $ labels w labels = filter (isValidLabel) . labelsOfLength -- if entire string is the same character, or it's a bad sequence, -- this label is not valid isValidLabel l = not $ or [ allSame l, badSequence l ] allSame l@(x:_) = l == (replicate (length l) x) badSequence [] = True badSequence (x:[]) = False badSequence (x:y:ys) = if x == y then badSequence (y:ys) else badChange x y where badChange '0' '1' = False badChange '1' '2' = False badChange '2' '0' = False badChange _ _ = True -- list of all strings of length n consisting of '0', '1', and '2' labelsOfLength n = foldr ($) [""] ( replicate n $ cartesia "012" ) -- Gives the cartesion product of a list and a list of lists cartesia :: [a] -> [[a]] -> [[a]] cartesia xs = concat . map ( \ys -> map ( \x -> ys ++ [x] ) xs )