неуклюжий монадный стек трансформаторов

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. Использование Государственной монады для запоминания результатов. Карта.
• Пытаясь найти первое решение, я не использовал 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

Ваше решение, конечно, неудобно в использовании (и злоупотреблении) монад:

• Обычно монады строят по частям, складывая несколько трансформаторов
• Это менее обычно, но иногда случается, чтобы сложить несколько состояний
• Очень необычно сложить несколько трансформаторов Maybe
• Еще более необычно использовать MaybeT для прерывания цикла

Ваш код слишком бессмысленный:

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

вместо более простого для чтения

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

Теперь остановимся на функции solve1, давайте упростим ее. Самый простой способ сделать это - удалить внутреннюю монаду MaybeT. Вместо вечного цикла, который прерывается, когда найдено счастливое число, вы можете пойти другим путем и выполнить рекурсию только в том случае, если номер не радует.

Более того, вам не нужна государственная монада, не так ли? Всегда можно заменить состояние явным аргументом.

Используя эти идеи, решение execute1 теперь выглядит намного лучше:

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

Answer 2

Классы Monad * существуют для устранения необходимости повторного подъема. Если вы измените свои подписи, как это:

type IsHappyMemo = Map.Map (Integer, Integer) Bool

isHappy :: MonadState IsHappyMemo m => Set.Set Integer -> Integer -> Integer -> m Bool

Таким образом, вы можете удалить большую часть лифта. Однако, самая длинная последовательность подъемов не может быть удалена, так как это монада State внутри StateT, поэтому использование класса типа MonadState даст вам внешний StateT, где вам нужно попасть во внутреннее состояние. Вы можете обернуть вашу монаду State в новый тип и создать класс MonadHappy, похожий на существующие классы монад.

Answer 3

ListT (из пакета List ) выполняет гораздо более приятную работу, чем MaybeT, когда останавливает вычисление при необходимости.

solve1 :: [Integer] -> IsHappyMemo Integer
solve1 bases = do
  Cons result _ <- runList . filterL cond $ fromList [2..]
  return result
  where
    cond num = andL . mapL (isHappy Set.empty num) $ fromList bases

Некоторые подробности о том, как это работает:

Если бы мы использовали обычный список, код выглядел бы так:

solve1 bases = do
  result:_ <- filterM cond [2..]
  return result
  where
    cond num = fmap and . mapM (isHappy Set.empty num) bases

Это вычисление происходит в монаде State, но если мы хотим получить результирующее состояние, у нас возникнет проблема, потому что filterM запускает монадический предикат, который он получает для каждого элемента [2..], бесконечный список.

С монадическим списком filterL cond (fromList [2..]) представляет список, к которому мы можем обращаться по одному элементу за раз как монадическое действие, поэтому наш монадический предикат cond фактически не выполняется (и не влияет на состояние), если мы не используем соответствующие пункты списка.

Аналогично, реализация cond с использованием andL заставляет нас не вычислять и не обновлять состояние, если мы уже получили результат False из одного из isHappy Set.empty num вычислений.