Любые указатели на то, как эффективно решить следующую функцию в Haskell для больших чисел (n > 108)
f(n) = max(n, f(n/2) + f(n/3) + f(n/4))
Я видел примеры memoization в Haskell для решения проблемы с фибоначчи числа, которые включали вычисление (лениво) всех чисел фибоначчи до требуемого n. Но в этом случае для данного n нам нужно только выведите очень мало промежуточных результатов.
Спасибо
Мы можем сделать это очень эффективно, создав структуру, которую мы можем индексировать в сублинейном времени.
Но сначала
{-# LANGUAGE BangPatterns #-}
import Data.Function (fix)
Пусть определите f, но заставьте его использовать "открытую рекурсию", а не напрямую.
f :: (Int -> Int) -> Int -> Int
f mf 0 = 0
f mf n = max n $ mf (n `div` 2) +
mf (n `div` 3) +
mf (n `div` 4)
Вы можете получить unmemoized f с помощью fix f
Это позволит вам проверить, что f делает то, что вы имеете в виду при малых значениях f, вызывая, например: fix f 123 = 144
Мы могли бы запомнить это, указав:
f_list :: [Int]
f_list = map (f faster_f) [0..]
faster_f :: Int -> Int
faster_f n = f_list !! n
Это хорошо работает и заменяет то, что должно было занять время O (n ^ 3), с чем-то, что запоминает промежуточные результаты.
Но для линейного времени требуется только индекс, чтобы найти мемуаризованный ответ для mf. Это означает, что результаты:
*Main Data.List> faster_f 123801
248604
допустимы, но результат не масштабируется намного лучше. Мы можем сделать лучше!
Сначала определим бесконечное дерево:
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)
И тогда мы определим способ индексирования в него, поэтому мы можем найти node с индексом n в O (log n):
index :: Tree a -> Int -> 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 Int
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..]
Вы можете проверить работу до сих пор, подтвердив, что toList nats дает вам [0..]
Теперь
f_tree :: Tree Int
f_tree = fmap (f fastest_f) nats
fastest_f :: Int -> Int
fastest_f = index f_tree
работает так же, как со списком выше, но вместо того, чтобы брать линейное время, чтобы найти каждый node, может преследовать его в логарифмическом времени.
Результат значительно быстрее:
*Main> fastest_f 12380192300
67652175206
*Main> fastest_f 12793129379123
120695231674999
На самом деле это намного быстрее, чем вы можете пройти и заменить Int на Integer выше и получить смехотворно большие ответы почти мгновенно
*Main> fastest_f' 1230891823091823018203123
93721573993600178112200489
*Main> fastest_f' 12308918230918230182031231231293810923
11097012733777002208302545289166620866358
Ответ Эдварда - это такой замечательный камень, который я продублировал и обеспечил реализацию комбинаторов memoList и memoTree, которые memoize функцию в open-recursive форма.
{-# 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.
Это дополнение к превосходному ответу Эдварда Кемта.
Когда я попробовал свой код, определения 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'
Как указано в ответе Эдварда Кемта, чтобы ускорить работу, вам нужно кэшировать дорогостоящие вычисления и иметь возможность быстро их получить.
Чтобы функция не монадическая, решение построения бесконечного ленивого дерева с соответствующим способом индексирования (как показано в предыдущих сообщениях) выполняет эту задачу. Если вы откажетесь от немонодического характера функции, вы можете использовать стандартные ассоциативные контейнеры, доступные в 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 с использованием Data.Function.fix, хотя это немного более подробно:
noMemoF :: (Integral n) => n -> n
noMemoF = runIdentity . fix fm
Затем вы можете использовать государственную монаду в сочетании с Data.Map для ускорения работы:
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'
С небольшими изменениями вы можете адаптировать код для работы с Data.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'
Вместо постоянных структур данных вы также можете попробовать измененные структуры данных (например, Data.HashTable) в сочетании с монадой ST:
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 любая из этих реализаций позволяет вам получать огромные входы для получения результатов в микросекундах вместо того, чтобы ждать несколько секунд.
Используя Criterion в качестве эталона, я мог заметить, что реализация с Data.HashMap фактически выполнялась немного лучше (около 20%), чем Data.Map и Data.HashTable, для которых тайминги были очень похожими.
Я нашел результаты теста немного удивителен. Мое первоначальное чувство состояло в том, что HashTable превзойдет реализацию HashMap, поскольку он изменен. В этой последней реализации может быть некоторый дефект производительности.
Спустя пару лет я посмотрел на это и понял, что существует простой способ запоминать это в линейном режиме с помощью 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)).
Решение без индексации, а не на основе Edward 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 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 (по крайней мере, я не знаю, как это сделать), и вам действительно нужно подумать о том, как перекрываются подзапросы, но стратегия должна работать для общих множественных -интегрированные параметры. (Я думал, что это два строковых параметра.)
Память отбрасывается после каждого расчета. (Опять же, я думал о двух строковых параметрах.)
Я не знаю, является ли это более эффективным, чем другие ответы. Каждый поиск является технически только одним или двумя шагами ( "Посмотрите на своего ребенка или вашего дочернего ребенка" ), но может быть много дополнительного использования памяти.
Изменить: Это решение еще не верное. Совместное использование является неполным.
Изменить: теперь нужно делиться дочерними элементами, но я понял, что эта проблема имеет много нетривиального обмена: n/2/2/2 и n/3/3 могут быть одинаковыми. Эта проблема не подходит для моей стратегии.
Еще одно добавление к Эдварду Кемту: автономный пример:
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
Используйте его следующим образом для memoize функции с одним целым arg (например, fibonacci):
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))