Solving a problem from Google Code Jam (2009.1A.A: "Multi-base happiness") I came up with an awkward (code-wise) solution, and I'm interested in how it could be improved.

The problem description, shortly, is: Find the smallest number bigger than 1 for which iteratively calculating the sum of squares of digits reaches 1, for all bases from a given list.

Or description in pseudo-Haskell (code that would solve it if elem could always work for infinite lists):

solution = head . (`filter` [2..]) . all ((1 `elem`) . (`iterate` i) . sumSquareOfDigitsInBase)

And my awkward solution:

By awkward I mean it has this kind of code: happy <- lift . lift . lift $ isHappy Set.empty base cur

I memoize results of the isHappy function. Using the State monad for the memoized results Map.

Trying to find the first solution, I did not use head and filter (like the pseudo-haskell above does), because the computation isn't pure (changes state). So I iterated by using StateT with a counter, and a MaybeT to terminate the computation when condition holds.

and (like the pseudo-haskell above does), because the computation isn't pure (changes state). So I iterated by using StateT with a counter, and a MaybeT to terminate the computation when condition holds. Already inside a MaybeT (StateT a (State b)) , if the condition doesn't hold for one base, there is no need to check the other ones, so I have another MaybeT in the stack for that.

Code:

import Control.Monad.Maybe import Control.Monad.State import Data.Maybe import qualified Data.Map as Map import qualified Data.Set as Set type IsHappyMemo = State (Map.Map (Integer, Integer) Bool) isHappy :: Set.Set Integer -> Integer -> Integer -> IsHappyMemo Bool isHappy _ _ 1 = return True isHappy path base num = do memo <- get case Map.lookup (base, num) memo of Just r -> return r Nothing -> do r <- calc when (num < 1000) . modify $ Map.insert (base, num) r return r where calc | num `Set.member` path = return False | otherwise = isHappy (Set.insert num path) base nxt nxt = sum . map ((^ (2::Int)) . (`mod` base)) . takeWhile (not . (== 0)) . iterate (`div` base) $ num solve1 :: [Integer] -> IsHappyMemo Integer solve1 bases = fmap snd . (`runStateT` 2) . runMaybeT . forever $ do (`when` mzero) . isJust =<< runMaybeT (mapM_ f bases) lift $ modify (+ 1) where f base = do cur <- lift . lift $ get happy <- lift . lift . lift $ isHappy Set.empty base cur unless happy mzero solve :: [String] -> String solve = concat . (`evalState` Map.empty) . mapM f . zip [1 :: Integer ..] where f (idx, prob) = do s <- solve1 . map read . words $ prob return $ "Case #" ++ show idx ++ ": " ++ show s ++ "

" main :: IO () main = getContents >>= putStr . solve . tail . lines

Other contestants using Haskell did have nicer solutions, but solved the problem differently. My question is about small iterative improvements to my code.