Мемуаризация в Хаскелле?

Эдварда!--5--> Это такой замечательный драгоценный камень, что я дублировал его и предоставил реализации memoList и memoTree комбинаторы, которые запоминают функцию в открытой рекурсивной форме.

{-# LANGUAGE BangPatterns #-}

import Data.Function (fix)

f :: (Integer -> Integer) -> Integer -> Integer
f mf 0 = 0
f mf n = max n $ mf (div n 2) +
                 mf (div n 3) +
                 mf (div n 4)


-- Memoizing using a list

-- The memoizing functionality depends on this being in eta reduced form!
memoList :: ((Integer -> Integer) -> Integer -> Integer) -> Integer -> Integer
memoList f = memoList_f
  where memoList_f = (memo !!) . fromInteger
        memo = map (f memoList_f) [0..]

faster_f :: Integer -> Integer
faster_f = memoList f


-- Memoizing using a tree

data Tree a = Tree (Tree a) a (Tree a)
instance Functor Tree where
    fmap f (Tree l m r) = Tree (fmap f l) (f m) (fmap f r)

index :: Tree a -> Integer -> a
index (Tree _ m _) 0 = m
index (Tree l _ r) n = case (n - 1) `divMod` 2 of
    (q,0) -> index l q
    (q,1) -> index r q

nats :: Tree Integer
nats = go 0 1
    where
        go !n !s = Tree (go l s') n (go r s')
            where
                l = n + s
                r = l + s
                s' = s * 2

toList :: Tree a -> [a]
toList as = map (index as) [0..]

-- The memoizing functionality depends on this being in eta reduced form!
memoTree :: ((Integer -> Integer) -> Integer -> Integer) -> Integer -> Integer
memoTree f = memoTree_f
  where memoTree_f = index memo
        memo = fmap (f memoTree_f) nats

fastest_f :: Integer -> Integer
fastest_f = memoTree f

не самый эффективный способ, но делает memoize:

f = 0 : [ g n | n <- [1..] ]
    where g n = max n $ f!!(n `div` 2) + f!!(n `div` 3) + f!!(n `div` 4)

при обращении f !! 144, проверено, что f !! 143 существует, но его точное значение не вычисляется. Он все еще установлен как какой-то неизвестный результат вычисления. Единственные точные рассчитанные значения-это те, которые необходимы.

так что изначально, насколько было рассчитано, программа ничего не знает.

f = .... 

когда мы делаем запрос f !! 12, он начинает делать некоторые картины соответствие:

f = 0 : g 1 : g 2 : g 3 : g 4 : g 5 : g 6 : g 7 : g 8 : g 9 : g 10 : g 11 : g 12 : ...

теперь он начинает вычислять

f !! 12 = g 12 = max 12 $ f!!6 + f!!4 + f!!3

это рекурсивно делает еще одно требование на f, поэтому мы вычисляем

f !! 6 = g 6 = max 6 $ f !! 3 + f !! 2 + f !! 1
f !! 3 = g 3 = max 3 $ f !! 1 + f !! 1 + f !! 0
f !! 1 = g 1 = max 1 $ f !! 0 + f !! 0 + f !! 0
f !! 0 = 0

теперь мы можем просочиться обратно некоторые

f !! 1 = g 1 = max 1 $ 0 + 0 + 0 = 1

что означает, что программа теперь знает:

f = 0 : 1 : g 2 : g 3 : g 4 : g 5 : g 6 : g 7 : g 8 : g 9 : g 10 : g 11 : g 12 : ...

продолжая просачиваться вверх:

f !! 3 = g 3 = max 3 $ 1 + 1 + 0 = 3

что означает, что программа теперь знает:

f = 0 : 1 : g 2 : 3 : g 4 : g 5 : g 6 : g 7 : g 8 : g 9 : g 10 : g 11 : g 12 : ...

теперь мы продолжим наш расчет f!!6:

f !! 6 = g 6 = max 6 $ 3 + f !! 2 + 1
f !! 2 = g 2 = max 2 $ f !! 1 + f !! 0 + f !! 0 = max 2 $ 1 + 0 + 0 = 2
f !! 6 = g 6 = max 6 $ 3 + 2 + 1 = 6

что означает, что программа теперь знает:

f = 0 : 1 : 2 : 3 : g 4 : g 5 : 6 : g 7 : g 8 : g 9 : g 10 : g 11 : g 12 : ...

теперь мы продолжим наш расчет f!!12:

f !! 12 = g 12 = max 12 $ 6 + f!!4 + 3
f !! 4 = g 4 = max 4 $ f !! 2 + f !! 1 + f !! 1 = max 4 $ 2 + 1 + 1 = 4
f !! 12 = g 12 = max 12 $ 6 + 4 + 3 = 13

что означает, что программа теперь знает:

f = 0 : 1 : 2 : 3 : 4 : g 5 : 6 : g 7 : g 8 : g 9 : g 10 : g 11 : 13 : ...

так что расчет делается довольно лениво. Программа знает, что некоторое значение для f !! 8 существует, что он равен g 8, но он понятия не имеет, что g 8 есть.

как указано в ответе Эдварда Кметта, чтобы ускорить процесс, вам нужно кэшировать дорогостоящие вычисления и иметь возможность быстро получить к ним доступ.

чтобы сохранить функцию не монадической, решение построения бесконечного ленивого дерева с соответствующим способом его индексирования (как показано в предыдущих сообщениях) выполняет эту цель. Если вы отказываетесь от номера-монадическом характер функции, вы можете использовать стандартные ассоциативные контейнеры доступны в Haskell в сочетании с "квазигосударственный" монад (как State или ST).

А главный недостаток в том, что вы получаете не монадические функции, вам не придется больше индексировать структуру самостоятельно, а можете просто использовать стандартные реализации ассоциативных контейнеров.

для этого вам сначала нужно переписать свою функцию, чтобы принять любую монаду:

fm :: (Integral a, Monad m) => (a -> m a) -> a -> m a
fm _    0 = return 0
fm recf n = do
   recs <- mapM recf $ div n <$> [2, 3, 4]
   return $ max n (sum recs)

для ваших тестов вы все еще можете определить функцию, которая не делает memoization с использованием данных.Функция.исправить, хотя это немного больше многословно:

noMemoF :: (Integral n) => n -> n
noMemoF = runIdentity . fix fm

затем вы можете использовать состояние монады в сочетании с данными.Карта для ускорения работы:

import qualified Data.Map.Strict as MS

withMemoStMap :: (Integral n) => n -> n
withMemoStMap n = evalState (fm recF n) MS.empty
   where
      recF i = do
         v <- MS.lookup i <$> get
         case v of
            Just v' -> return v' 
            Nothing -> do
               v' <- fm recF i
               modify $ MS.insert i v'
               return v'

С незначительными изменениями, вы можете адаптировать код для работы с данными.Вместо этого HashMap:

import qualified Data.HashMap.Strict as HMS

withMemoStHMap :: (Integral n, Hashable n) => n -> n
withMemoStHMap n = evalState (fm recF n) HMS.empty
   where
      recF i = do
         v <- HMS.lookup i <$> get
         case v of
            Just v' -> return v' 
            Nothing -> do
               v' <- fm recF i
               modify $ HMS.insert i v'
               return v'

вместо постоянных структур данных вы также можете попробовать изменяемые структуры данных (например, данные.HashTable) в сочетании с ST monad:

import qualified Data.HashTable.ST.Linear as MHM

withMemoMutMap :: (Integral n, Hashable n) => n -> n
withMemoMutMap n = runST $
   do ht <- MHM.new
      recF ht n
   where
      recF ht i = do
         k <- MHM.lookup ht i
         case k of
            Just k' -> return k'
            Nothing -> do 
               k' <- fm (recF ht) i
               MHM.insert ht i k'
               return k'

по сравнению с реализацией без какой-либо memoization, любая из этих реализаций позволяет вам, для огромных входных сигналов, получить результаты в микро-секундах вместо ждать несколько секунд.

используя критерий в качестве эталона, я мог наблюдать, что реализация с данными.HashMap на самом деле выполняется немного лучше (около 20%), чем данные.Карта и данные.Хэш-таблица, для которой тайминги были очень похожи.

я нашел результаты теста немного удивляет. Мое первоначальное чувство состояло в том, что хэш-таблица будет превосходить хэш-карту потому что это изменяемо. В этой последней реализации может быть скрыт некоторый дефект производительности.

это дополнения к отличный ответ Эдвард Kmett по.

когда я попробовал его код, определения nats и index казалось довольно загадочным, поэтому я пишу альтернативную версию, которую мне легче понять.

я определяю index и nats С точки зрения index' и nats'.

index' t n определяется по диапазону [1..]. (Напомним, что index t определяется по диапазону [0..].) Он работает ищет дерево, обрабатывая n как строка бит, и биты в обратном порядке. Если бит 1, он берет правую ветку. Если бит 0, он берет левую ветку. Он останавливается, когда он достигает последнего бита (который должен быть 1).

index' (Tree l m r) 1 = m
index' (Tree l m r) n = case n `divMod` 2 of
                          (n', 0) -> index' l n'
                          (n', 1) -> index' r n'

как nats определен index, так что index nats n == n это всегда так, nats' определен index'.

nats' = Tree l 1 r
  where
    l = fmap (\n -> n*2)     nats'
    r = fmap (\n -> n*2 + 1) nats'
    nats' = Tree l 1 r

теперь nats и index просто nats' и index' но с значения сдвинуты на 1:

index t n = index' t (n+1)
nats = fmap (\n -> n-1) nats'

пару лет спустя я посмотрел на это и понял, что есть простой способ запомнить это в линейном времени с помощью zipWith и вспомогательная функция:

dilate :: Int -> [x] -> [x]
dilate n xs = replicate n =<< xs

dilate имеет удобное свойство, которое dilate n xs !! i == xs !! div i n.

Итак, предположим, что нам дано f (0), это упрощает вычисление до

fs = f0 : zipWith max [1..] (tail $ fs#/2 .+. fs#/3 .+. fs#/4)
  where (.+.) = zipWith (+)
        infixl 6 .+.
        (#/) = flip dilate
        infixl 7 #/

очень похоже на наше исходное описание проблемы и дает линейное решение (sum $ take n fs займет O (n)).

очередное дополнение к ответу Эдвард Kmett по: самодостаточный пример:

data NatTrie v = NatTrie (NatTrie v) v (NatTrie v)

memo1 arg_to_index index_to_arg f = (\n -> index nats (arg_to_index n))
  where nats = go 0 1
        go i s = NatTrie (go (i+s) s') (f (index_to_arg i)) (go (i+s') s')
          where s' = 2*s
        index (NatTrie l v r) i
          | i <  0    = f (index_to_arg i)
          | i == 0    = v
          | otherwise = case (i-1) `divMod` 2 of
             (i',0) -> index l i'
             (i',1) -> index r i'

memoNat = memo1 id id 

используйте его следующим образом, чтобы запомнить функцию с одним целым числом arg (например, Фибоначчи):

fib = memoNat f
  where f 0 = 0
        f 1 = 1
        f n = fib (n-1) + fib (n-2)

кэшируются только значения для неотрицательных аргументов.

также кэшировать значения для отрицательных аргументов, используйте memoInt, определяется следующим образом:

memoInt = memo1 arg_to_index index_to_arg
  where arg_to_index n
         | n < 0     = -2*n
         | otherwise =  2*n + 1
        index_to_arg i = case i `divMod` 2 of
           (n,0) -> -n
           (n,1) ->  n

для кэширования значений функций с двумя целочисленными аргументами используйте memoIntInt, определяемая как следует:

memoIntInt f = memoInt (\n -> memoInt (f n))

решение без индексации, а не основываться на Эдварда KMETT это.

я учитываю общие поддеревья для общего родителя (f(n/4) разделен между f(n/2) и f(n/4) и f(n/6) разделен между f(2) и f(3)). При сохранении их в виде одной переменной в Родительском, вычисление поддерева выполняется один раз.

data Tree a =
  Node {datum :: a, child2 :: Tree a, child3 :: Tree a}

f :: Int -> Int
f n = datum root
  where root = f' n Nothing Nothing


-- Pass in the arg
  -- and this node's lifted children (if any).
f' :: Integral a => a -> Maybe (Tree a) -> Maybe (Tree a)-> a
f' 0 _ _ = leaf
    where leaf = Node 0 leaf leaf
f' n m2 m3 = Node d c2 c3
  where
    d = if n < 12 then n
            else max n (d2 + d3 + d4)
    [n2,n3,n4,n6] = map (n `div`) [2,3,4,6]
    [d2,d3,d4,d6] = map datum [c2,c3,c4,c6]
    c2 = case m2 of    -- Check for a passed-in subtree before recursing.
      Just c2' -> c2'
      Nothing -> f' n2 Nothing (Just c6)
    c3 = case m3 of
      Just c3' -> c3'
      Nothing -> f' n3 (Just c6) Nothing
    c4 = child2 c2
    c6 = f' n6 Nothing Nothing

    main =
      print (f 123801)
      -- Should print 248604.

код не легко распространяется на общую функцию memoization (по крайней мере, я бы не знал, как это сделать), и вам действительно нужно подумайте, как подзадачи перекрываются, но стратегия должен работать для общих нескольких нецелочисленных параметров. (Я придумал его для двух строковых параметров.)

памятка отбрасывается после каждого расчета. (Опять же, я думал о двух строковых параметров.)

Я не знаю, если это более эффективно, чем другие ответы. Каждый поиск технически всего один или два шага ("посмотрите на своего ребенка или ребенка вашего ребенка"), но может быть много дополнительных использование памяти.

Edit: это решение еще не является правильным. Обмен является неполным.

Edit: теперь он должен правильно делиться дочерними элементами, но я понял, что эта проблема имеет много нетривиального обмена: n/2/2/2 и n/3/3 может быть то же самое. Проблема не очень хорошо подходит для моей стратегии.