尴尬的monad变压器堆栈

Question

从Google Code Jam解决问题(2009.1AA:"多基础幸福")我提出了一个尴尬(代码方面)的解决方案,我对如何改进它感兴趣.

不久,问题描述是:找到大于1的最小数字,对于来自给定列表的所有碱基,迭代计算数字的平方和达到1.

或伪Haskell中的描述(如果elem总是可以为无限列表工作则可以解决它的代码):

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

而我的尴尬解决方案:

• 尴尬我的意思是它有这样的代码: happy <- lift . lift . lift $ isHappy Set.empty base cur
• 我记住了isHappy函数的结果.使用State monad作为memoized结果Map.
• 试图找到第一个解决方案,我没有使用head和filter(像上面的伪haskell那样),因为计算不纯(改变状态).所以我通过使用带有计数器的StateT和一个MaybeT来迭代,以在条件成立时终止计算.
• 已经在一个内部MaybeT (StateT a (State b)),如果条件不适用于一个基数,则不需要检查其他基数,所以我MaybeT在堆栈中有另一个.

码:

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 ++ "\n"

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

其他使用Haskell的参赛者确实有更好的解决方案,但以不同的方式解决了问题.我的问题是关于我的代码的小迭代改进.

Answer 1

你对monad的使用(和滥用)肯定很尴尬:

• 通常通过堆叠几个变压器来逐个构建单子
• 它通常不常见,但有时候仍然会发生堆叠几个状态
• 堆叠几个Maybe变换器是非常不寻常的
• 使用MaybeT来中断循环更加不寻常

你的代码有点过于无意义了:

(`when` mzero) . isJust =<<
   runMaybeT (mapM_ f bases)

而不是更容易阅读

let isHappy = isJust $ runMaybeT (mapM_ f bases)
when isHappy mzero

现在关注函数solve1,让我们简化它.一个简单的方法是删除内在的MaybeT monad.当找到一个快乐的数字时,你可以走另一条路,只有在数字不满意的情况下递归,而不是一个永久的循环.

而且,你也不需要国家单身,是吗？人们总是可以用显式参数替换状态.

应用这些想法solve1现在看起来好多了:

solve1 :: [Integer] -> IsHappyMemo Integer
solve1 bases = go 2 where
  go i = do happyBases <- mapM (\b -> isHappy Set.empty b i) bases
            if and happyBases
              then return i
              else go (i+1)

我对这段代码更加满意.其余的解决方案都很好.困扰我的一件事是你丢弃每个子问题的备忘录缓存.这有什么理由吗？

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 ++ "\n"

如果你重新使用它,你的解决方案不会更有效吗？

solve :: [String] -> String
solve cases = (`evalState` Map.empty) $ do
   solutions <- mapM f (zip [1 :: Integer ..] cases)
   return (unlines solutions)
  where
    f (idx, prob) = do
      s <- solve1 . map read . words $ prob
      return $ "Case #" ++ show idx ++ ": " ++ show s