haskell - 尴尬的单子(monad)变压器堆栈

Question

解决来自 Google Code Jam (2009.1A.A: "Multi-base happiness") 的问题 我想出了一个笨拙的(代码方面)解决方案，我对如何改进它很感兴趣。

简而言之，问题描述是:对于给定列表中的所有碱基，找到大于 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 用于内存结果 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 的参赛者确实有 nicer solutions ，但以不同的方式解决了问题。我的问题是关于对我的代码进行小的迭代改进。

Answer 1

您的解决方案在使用(和滥用)单子(monad)时肯定很尴尬:

通常通过堆叠多个变压器来零碎地构建 monads

堆叠多个状态的情况不太常见，但有时仍会发生

堆叠几个 Maybe 变压器是很不寻常的

使用 MaybeT 中断循环更不寻常

你的代码有点太没有意义了:

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

而不是更容易阅读

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

现在关注函数solve1，让我们简化它。
一个简单的方法是删除内部的 MaybeT monad。当找到一个满意的数字时，您可以反过来并递归，而不是在找到一个快乐的数字时中断一个永远循环
数不开心。

此外，您也不需要 State 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