Memoization in Haskell?

Eventuali suggerimenti su come risolvere in modo efficiente la seguente funzione in Haskell, per grandi numeri (n > 108)

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

Ho visto esempi di memoizzazione in Haskell per risolvere i numeri di fibonacci, che comportavano il calcolo (pigramente) di tutti i numeri di fibonacci fino al n richiesto. Ma in questo caso, per una data n, abbiamo solo bisogno di calcolare pochissimi risultati intermedi.

Grazie

Possiamo farlo in modo molto efficiente creando una struttura che possiamo indicizzare in un tempo sub-lineare.

Ma prima,

{-# LANGUAGE BangPatterns #-}

import Data.Function (fix)

Definiamolo f, ma utilizziamolo "ricorsione aperta" anziché chiamarsi direttamente.

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)

È possibile ottenere un nonemo futilizzandofix f

Questo ti consentirà di testare fciò che intendi per piccoli valori fchiamando, ad esempio:fix f 123 = 144

Potremmo memorizzarlo definendo:

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

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

Ciò si comporta passabilmente bene e sostituisce ciò che avrebbe impiegato O (n ^ 3) tempo con qualcosa che memorizza i risultati intermedi.

Ma ci vuole ancora tempo lineare solo per indicizzare per trovare la risposta memorizzata mf. Ciò significa che risulta come:

*Main Data.List> faster_f 123801
248604

sono tollerabili, ma il risultato non scala molto meglio di così. Possiamo fare di meglio!

Innanzitutto, definiamo un albero infinito:

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)

E poi definiremo un modo per indicizzarlo, così possiamo trovare un nodo con indice nnel tempo 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

... e potremmo trovare un albero pieno di numeri naturali per essere conveniente, quindi non dobbiamo armeggiare con quegli indici:

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

Dal momento che possiamo indicizzare, puoi semplicemente convertire un albero in un elenco:

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

Puoi controllare il lavoro finora verificando che toList natsti dia[0..]

Adesso,

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

fastest_f :: Int -> Int
fastest_f = index f_tree

funziona proprio come con l'elenco sopra, ma invece di impiegare un tempo lineare per trovare ciascun nodo, può inseguirlo nel tempo logaritmico.

Il risultato è notevolmente più veloce:

*Main> fastest_f 12380192300
67652175206

*Main> fastest_f 12793129379123
120695231674999

In effetti è molto più veloce che puoi passare e sostituire Intcon Integersopra e ottenere risposte ridicolmente grandi quasi istantaneamente

*Main> fastest_f' 1230891823091823018203123
93721573993600178112200489

*Main> fastest_f' 12308918230918230182031231231293810923
11097012733777002208302545289166620866358

La risposta di Edward è una gemma così meravigliosa che l'ho duplicata e fornito implementazioni memoListe memoTreecombinatori che memorizzano una funzione in forma aperta ricorsiva.

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

Non è il modo più efficiente, ma memorizza:

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

al momento della richiesta f !! 144, viene verificato che f !! 143esista, ma il suo valore esatto non viene calcolato. È ancora impostato come risultato sconosciuto di un calcolo. Gli unici valori esatti calcolati sono quelli necessari.

Quindi inizialmente, per quanto è stato calcolato, il programma non sa nulla.

f = .... 

Quando facciamo la richiesta f !! 12, inizia a fare una corrispondenza del modello:

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

Ora inizia il calcolo

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

Questo in modo ricorsivo fa un'altra richiesta su f, quindi calcoliamo

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

Ora possiamo tornare indietro

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

Ciò significa che il programma ora sa:

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

Continuando a gocciolare:

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

Ciò significa che il programma ora sa:

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

Ora continuiamo con il nostro calcolo di 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

Ciò significa che il programma ora sa:

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

Ora continuiamo con il nostro calcolo di 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

Ciò significa che il programma ora sa:

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

Quindi il calcolo è fatto abbastanza pigramente. Il programma sa che f !! 8esiste un valore per , che è uguale a g 8, ma non ha idea di cosa g 8sia.

Questa è un'aggiunta alla risposta eccellente di Edward Kmett.

Quando ho provato il suo codice, le definizioni natse indexsembravano piuttosto misteriose, quindi scrivo una versione alternativa che ho trovato più facile da capire.

Definisco indexe natsin termini di index'e nats'.

index' t nè definito nell'intervallo [1..]. (Ricordiamo che index tè definito nell'intervallo [0..].) Funziona cerca l'albero trattando ncome una stringa di bit e leggendo i bit al contrario. Se il bit lo è 1, prende il ramo di destra. Se il bit è 0, prende il ramo di sinistra. Si ferma quando raggiunge l'ultimo bit (che deve essere a 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'

Proprio come natsè definito per indexciò che index nats n == nè sempre vero, nats'è definito per 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

Ora, natse indexsono semplicemente nats'e index'ma con i valori spostati di 1:

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

Come indicato nella risposta di Edward Kmett, per velocizzare le cose, è necessario memorizzare nella cache costosi calcoli ed essere in grado di accedervi rapidamente.

Per mantenere la funzione non monadica, la soluzione di costruire un albero pigro infinito, con un modo appropriato di indicizzarlo (come mostrato nei post precedenti) soddisfa tale obiettivo. Se si rinuncia alla natura non monadica della funzione, è possibile utilizzare i contenitori associativi standard disponibili in Haskell in combinazione con monadi "state-like" (come State o ST).

Mentre il principale svantaggio è che ottieni una funzione non monadica, non devi più indicizzare la struttura da solo e puoi semplicemente usare implementazioni standard di contenitori associativi.

Per fare ciò, devi prima riscrivere la tua funzione per accettare qualsiasi tipo di monade:

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)

Per i tuoi test, puoi comunque definire una funzione che non memorizza memoization usando Data.Function.fix, anche se è un po 'più dettagliata:

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

È quindi possibile utilizzare la monade di stato in combinazione con Data.Map per accelerare le cose:

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'

Con modifiche minori, puoi invece adattare il codice affinché funzioni con 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'

Invece di strutture di dati persistenti, puoi anche provare strutture di dati mutabili (come Data.HashTable) in combinazione con la monade 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'

Rispetto all'implementazione senza alcuna memoizzazione, ognuna di queste implementazioni consente, per enormi input, di ottenere risultati in micro-secondi invece di dover attendere diversi secondi.

Utilizzando Criterion come parametro di riferimento, ho potuto osservare che l'implementazione con Data.HashMap ha effettivamente ottenuto risultati leggermente migliori (circa il 20%) rispetto a Data.Map e Data.HashTable per i quali i tempi erano molto simili.

Ho trovato i risultati del benchmark un po 'sorprendenti. La mia sensazione iniziale era che HashTable avrebbe superato l'implementazione di HashMap perché era mutabile. Potrebbe esserci qualche difetto prestazionale nascosto in quest'ultima implementazione.

Un paio di anni dopo, ho visto questo e ho capito che c'era un modo semplice per memorizzarlo in tempo lineare usando zipWithuna funzione di supporto:

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

dilateha la proprietà pratica che dilate n xs !! i == xs !! div i n.

Quindi, supponendo che ci sia dato f (0), questo semplifica il calcolo a

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

Assomiglia molto alla descrizione del problema originale e offre una soluzione lineare ( sum $ take n fsprenderà O (n)).

Ennesimo addendum alla risposta di Edward Kmett: un esempio autonomo:

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 

Usalo come segue per memorizzare una funzione con un singolo argomento intero arg (es. Fibonacci):

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

Verranno memorizzati nella cache solo i valori per argomenti non negativi.

Per memorizzare nella cache anche valori per argomenti negativi, utilizzare memoInt, definito come segue:

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

Per memorizzare nella cache valori per funzioni con due argomenti interi utilizzare memoIntInt, definito come segue:

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

Una soluzione senza indicizzazione e non basata su Edward KMETT.

Fattorizzo i sottotitoli comuni a un genitore comune ( f(n/4)è condiviso tra f(n/2)e f(n/4)ed f(n/6)è condiviso tra f(2)e f(3)). Salvandoli come una singola variabile nel genitore, il calcolo del sottostruttura viene eseguito una volta.

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.

Il codice non si estende facilmente a una funzione di memoization generale (almeno, non saprei come farlo), e devi davvero pensare a come i sottoproblemi si sovrappongono, ma la strategia dovrebbe funzionare per più parametri generali non interi . (L'ho pensato per due parametri di stringa.)

Il promemoria viene eliminato dopo ogni calcolo. (Ancora una volta, stavo pensando a due parametri di stringa.)

Non so se questo sia più efficiente delle altre risposte. Ogni ricerca è tecnicamente solo uno o due passaggi ("Guarda il tuo bambino o il bambino di tuo figlio"), ma potrebbe essere necessario un uso eccessivo della memoria.

Modifica: questa soluzione non è ancora corretta. La condivisione è incompleta.

Modifica: ora dovrei condividere correttamente i bambini piccoli, ma mi sono reso conto che questo problema ha molta condivisione non banale: n/2/2/2e n/3/3potrebbe essere lo stesso. Il problema non è adatto alla mia strategia.