Memoization w Haskell?

Question

Wszelkie wskazówki, w jaki sposób rozwiązać efektywnie następujące funkcje w Haskell, dla licznie (n > 108)

f(n) = max(n, f(n/2) + f(n/3) + f(n/4)) 

Widziałem przykłady memoization w Haskell, aby rozwiązać Fibonacci numery, które zaangażowane computing (leniwie) wszystkie Fibonacciego numery do wymaganej wartości n. Ale w tym przypadku, dla danego n, musimy tylko obliczyć bardzo mało pośrednich wyników.

Dzięki

Answer 1

Możemy to zrobić bardzo skutecznie, tworząc strukturę, którą możemy indeksować w czasie podliniowym.

Ale najpierw

{-# LANGUAGE BangPatterns #-} 

import Data.Function (fix) 

Zdefiniujmy f, ale sprawiają, że korzystać z „otwartą” rekursji zamiast nazywać się bezpośrednio.

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) 

można uzyskać unmemoized f za pomocą fix f

To pozwoli Ci przetestować że f robi to, co oznacza dla małych wartości f wywołując na przykład: fix f 123 = 144

Mogliśmy memoize to przez zdefiniowanie:

f_list :: [Int] 
f_list = map (f faster_f) [0..] 

faster_f :: Int -> Int 
faster_f n = f_list !! n 

Który wykonuje się dobrze i dobrze asy, co miało zabrać czas na coś, co zapamiętuje wyniki pośrednie.

Ale wciąż trwa liniowy czas tylko po to, aby znaleźć indeksowaną odpowiedź dla mf. Oznacza to, że wyniki takie jak:

*Main Data.List> faster_f 123801 
248604 

są dopuszczalne, ale wynik nie jest o wiele lepszy. Możemy zrobić lepiej!

Najpierw określić nieskończoną drzewa:

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) 

A potem będziemy definiować sposób indeksu do niego, więc możemy znaleźć węzła o indeksie n w O (log n) czasie zamiast:

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 

... i możemy znaleźć drzewo pełne liczb naturalnych, aby być wygodne, więc nie trzeba bawić się wokół tych indeksów:

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 

Ponieważ możemy indeksu, można po prostu przekonwertować drzewa na listę:

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

można sprawdzić pracę dotychczas przez weryfikację że toList nats daje [0..]

Teraz

f_tree :: Tree Int 
f_tree = fmap (f fastest_f) nats 

fastest_f :: Int -> Int 
fastest_f = index f_tree 

działa tak jak z powyższą listą, ale zamiast brać liniowy czas na znalezienie każdego węzła, może go ścigać w logarytmicznym czasie.

Rezultatem jest znacznie szybsze:

*Main> fastest_f 12380192300 
67652175206 

*Main> fastest_f 12793129379123 
120695231674999 

W rzeczywistości jest to o wiele szybciej, że można przejść i zastąpić Int z Integer powyżej dostać absurdalnie duże odpowiedzi niemal natychmiast

*Main> fastest_f' 1230891823091823018203123 
93721573993600178112200489 

*Main> fastest_f' 12308918230918230182031231231293810923 
11097012733777002208302545289166620866358 

Answer 2

Nie jest to najbardziej skuteczny sposób, ale robi memoize:

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

przy żądaniu f !! 144, to jest zaznaczone, że f !! 143 istnieje, ale jego dokładna wartość nie jest obliczana. Jest nadal ustawiony jako nieznany wynik obliczeń. Obliczone są tylko dokładne wartości.

Początkowo, o ile zostało obliczone, program nic nie wie.

f = .... 

Kiedy wykonujemy wniosek f !! 12, to zaczyna robić jakieś dopasowanie Wzór:

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 : ... 

Teraz rozpocznie obliczanie

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

to rekurencyjnie doprowadza inną popytu na F, więc możemy obliczyć

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 

Teraz możemy sączyć z powrotem trochę

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

Czyli program już wie:

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 : ... 

kontynuując sączyć się:

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

Czyli program już wie:

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

Teraz możemy kontynuować nasze obliczenia 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 

co oznacza, że ​​program już wie:

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

Teraz możemy kontynuować nasze obliczenia 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 

co oznacza, program wie teraz:

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

Więc obliczenie odbywa się dość leniwie.Program wie, że istnieje pewna wartość dla f !! 8, że jest równa g 8, ale nie ma pojęcia, co to jest g 8.

Answer 3

ten jest uzupełnieniem znakomitej odpowiedzi Edwarda Kmetta.

Kiedy wypróbowałem jego kod, definicje nats i index wydawały się dość tajemnicze, więc piszę alternatywną wersję, którą uważam za łatwiejszą do zrozumienia.

Definiuję index i nats pod względem index' i nats'.

index' t n jest zdefiniowany w zakresie [1..]. (Przypomnij sobie, że index t jest zdefiniowany w zakresie [0..].) Działa przeszukując drzewo traktując n jako ciąg bitów i odczytując bity w odwrotnej kolejności. Jeśli bit jest 1, zajmuje gałąź po prawej stronie. Jeśli bit jest 0, zajmuje gałąź po lewej stronie. Zatrzymuje się, gdy osiągnie ostatni bit (który musi być 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' 

Podobnie jak nats jest zdefiniowany dla index tak że index nats n == n jest zawsze prawdziwe, nats' jest zdefiniowany dla 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 

Teraz nats i index są po prostu nats' i index' ale z wartościami przesunięte o 1:

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

Answer 4

Edward's answer jest taki wspaniały klejnot, że mam go powielane i pod warunkiem implementacje memoList i Kombinatory memoTree, które zapamiętują funkcję w formie otwartej rekursywnej.

{-# 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 

Answer 5

Kolejny dodatek do odpowiedzi Edward Kmett to: samowystarczalną przykład:

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 

użyć go w następujący sposób memoize funkcję z Arg jedną liczbę (np Fibonacci)

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

Tylko wartości dla nieujemnych argumentów będą buforowane.

Aby również wartości cache dla ujemnych argumentów użyciu memoInt zdefiniowane następująco:

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 

do wartości podręcznej dla funkcji z dwoma argumentami całkowitą użyciu memoIntInt, zdefiniowane w następujący sposób:

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

Answer 6

Jak w odpowiedzi Edwarda Kmetta, aby przyspieszyć działanie, musisz buforować kosztowne obliczenia i mieć szybki dostęp do nich.

Aby zachować funkcję nie monadyczną, rozwiązanie budowy nieskończonego leniwego drzewa, z odpowiednim sposobem jego indeksowania (jak pokazano w poprzednich wpisach), spełnia ten cel. Jeśli zrezygnujesz z funkcji niemonadycznej funkcji, możesz użyć standardowych pojemników asocjacyjnych dostępnych w Haskell w połączeniu z "monstycznymi" monadami (takimi jak State lub ST).

Chociaż główną wadą jest to, że uzyskujesz funkcję niemonadyczną, nie musisz już sam indeksować struktury i możesz po prostu użyć standardowych implementacji pojemników asocjacyjnych.

Aby to zrobić, trzeba najpierw ponownie napisać Ci działać, aby zaakceptować jakiejkolwiek monady:

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) 

Dla swoich badań, nadal można zdefiniować funkcję, która ogranicza memoization korzystając Data.Function. naprawić, choć jest nieco bardziej rozwlekły:

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

następnie można użyć Monada państwa w połączeniu z Data.Map aby przyspieszyć:

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' 

z niewielkimi zmianami, można dostosować kod do prac z Data.HashMap zamiast:

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' 

Zamiast trwałych struktur danych, można także spróbować zmienny struktur danych (jak Data.HashTable) w połączeniu z monada 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' 

porównaniu do wykonania bez memoization, każda z tych realizacji pozwala na ogromnych nakładów, aby uzyskać wyniki w mikro sekund zamiast czekać kilka sekund.

Posługując się Kryterium jako wskaźnikiem, mogłem zauważyć, że implementacja z Data.HashMap faktycznie wykonała nieco lepiej (około 20%) niż dane Data.Map i Data.HashTable, dla których czasy były bardzo podobne.

Wyniki benchmarku uznałem za zaskakujące. Początkowo sądziłem, że HashTable będzie lepszy od implementacji HashMap, ponieważ jest zmienny. W tej ostatniej implementacji może być ukryta wada wydajności.

Answer 7

Kilka lat później, patrzyłem na to i zrozumiał, że to prosta droga do memoize to w czasie liniowym przy użyciu zipWith oraz funkcję pomocnika:

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

dilate ma tę właściwość, że dilate n xs !! i == xs !! div i n poręczny.

Więc zakładając, mamy podane f (0), to upraszcza obliczenia do

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

szuka dużo jak naszym oryginalnym opisem problemu i daje rozwiązanie liniowego (sum $ take n fs zajmie O (n)).

Answer 8

Rozwiązanie bez indeksowania, a nie oparte na programie Edward KMETT.

I czynnik wspólne poddrzewa do wspólnego rodzica (f(n/4) dzielone między f(n/2) i f(n/4) i f(n/6) dzielone między f(2) i f(3)). Zapisując je jako pojedynczą zmienną w obiekcie macierzystym, obliczanie poddrzewa jest wykonywane jednokrotnie.

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. 

Kod nie łatwo rozszerzyć do ogólnej funkcji memoization (przynajmniej ja nie wiem, jak to zrobić), i naprawdę trzeba myśleć, jak podproblemów pokrywają się, ale strategia powinien działać dla ogólnych wielu parametrów niecałkowitych. (Myślałem o tym za dwa parametry smyczkowe.)

Notatka jest odrzucana po każdym obliczeniu. (Ponownie, myślałem o dwóch parametrach struny.)

Nie wiem, czy jest to bardziej wydajne niż inne odpowiedzi. Każde wyszukiwanie jest technicznie tylko jednym lub dwoma krokami ("Spójrz na dziecko lub dziecko twojego dziecka"), ale może być dużo dodatkowego użycia pamięci.

Edytuj: To rozwiązanie jeszcze nie jest poprawne. Udostępnianie jest niekompletne.

Edycja: Należy dzielić subchildren właściwie teraz, ale zdałem sobie sprawę, że problem ten ma wiele nietrywialnej Udostępnianie: n/2/2/2 i n/3/3 mogą być takie same. Problem nie pasuje do mojej strategii.