Auswendiglernen in Haskell?

Hinweise zur effizienten Lösung der folgenden Funktion in Haskell für große Zahlen (n > 108)

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

Ich habe Beispiele für das Auswendiglernen in Haskell gesehen, um Fibonacci-Zahlen zu lösen, bei denen alle Fibonacci-Zahlen (träge) bis zum erforderlichen n berechnet wurden. In diesem Fall müssen wir für ein gegebenes n nur sehr wenige Zwischenergebnisse berechnen.

Vielen Dank

Wir können dies sehr effizient tun, indem wir eine Struktur erstellen, die wir in sublinearer Zeit indizieren können.

Aber zuerst,

{-# LANGUAGE BangPatterns #-}

import Data.Function (fix)

Lassen Sie uns definieren f, aber lassen Sie es "offene Rekursion" verwenden, anstatt sich selbst direkt aufzurufen.

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)

Sie können eine unmemoized fmit verwendenfix f

Auf diese Weise können Sie testen, fwas Sie für kleine Werte fvon tun, indem Sie beispielsweise Folgendes aufrufen:fix f 123 = 144

Wir könnten dies auswendig lernen, indem wir definieren:

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

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

Das funktioniert passabel gut und ersetzt das, was O (n ^ 3) Zeit in Anspruch nehmen würde, durch etwas, das die Zwischenergebnisse auswendig lernt.

Es dauert jedoch immer noch eine lineare Zeit, nur um zu indizieren, um die gespeicherte Antwort für zu finden mf. Dies bedeutet, dass Ergebnisse wie:

*Main Data.List> faster_f 123801
248604

sind erträglich, aber das Ergebnis skaliert nicht viel besser. Wir können es besser machen!

Definieren wir zunächst einen unendlichen Baum:

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)

Und dann definieren wir einen Weg, um darin zu indizieren, damit wir stattdessen einen Knoten mit Index nin O (log n) Zeit finden können:

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

... und wir finden vielleicht einen Baum voller natürlicher Zahlen, damit wir nicht mit diesen Indizes herumspielen müssen:

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

Da wir indizieren können, können Sie einfach einen Baum in eine Liste konvertieren:

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

Sie können die bisherige Arbeit überprüfen, indem Sie überprüfen, ob toList natsSie diese erhalten[0..]

Jetzt,

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

fastest_f :: Int -> Int
fastest_f = index f_tree

funktioniert genau wie in der obigen Liste, aber anstatt lineare Zeit zu benötigen, um jeden Knoten zu finden, kann er in logarithmischer Zeit verfolgt werden.

Das Ergebnis ist erheblich schneller:

*Main> fastest_f 12380192300
67652175206

*Main> fastest_f 12793129379123
120695231674999

In der Tat ist es so viel schneller , dass Sie durchmachen können und ersetzen Intmit Integeroben und fast augenblicklich lächerlich großen Antworten erhalten

*Main> fastest_f' 1230891823091823018203123
93721573993600178112200489

*Main> fastest_f' 12308918230918230182031231231293810923
11097012733777002208302545289166620866358

Edwards Antwort ist so ein wunderbares Juwel, dass ich sie dupliziert und Implementierungen von memoListund bereitgestellt habememoTree Kombinatoren , die eine Funktion in offen-rekursiver Form auswendig lernen.

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

Nicht der effizienteste Weg, merkt sich aber:

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

auf Anfrage f !! 144wird geprüft, obf !! 143 vorhanden, der genaue Wert wird jedoch nicht berechnet. Es ist immer noch als unbekanntes Ergebnis einer Berechnung festgelegt. Die einzigen exakten berechneten Werte sind die benötigten.

Soweit berechnet, weiß das Programm zunächst nichts.

f = .... 

Wenn wir die Anfrage stellen f !! 12, wird ein Mustervergleich durchgeführt:

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

Jetzt beginnt die Berechnung

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

Dies stellt rekursiv eine weitere Anforderung an f, also berechnen wir

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

Jetzt können wir einige wieder hochrinnen

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

Das heißt, das Programm weiß jetzt:

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

Weiter rieseln:

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

Das heißt, das Programm weiß jetzt:

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

Nun fahren wir mit unserer Berechnung fort von 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

Das heißt, das Programm weiß jetzt:

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

Nun fahren wir mit unserer Berechnung fort von 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

Das heißt, das Programm weiß jetzt:

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

Die Berechnung erfolgt also ziemlich träge. Das Programm weiß, dass ein Wert für f !! 8existiert, der gleich ist g 8, aber es hat keine Ahnung, was g 8ist.

Dies ist ein Nachtrag zu Edward Kmotts ausgezeichneter Antwort.

Als ich seinen Code ausprobierte, schienen die Definitionen von natsund indexziemlich mysteriös zu sein, also schreibe ich eine alternative Version, die ich leichter verständlich fand.

Ich definiere indexund natsin Bezug auf index'undnats' .

index' t nwird über den Bereich definiert [1..]. (Erinnern Sie sich daran, dass dies index tüber den Bereich definiert ist [0..].) Es durchsucht den Baum, indem es nals eine Folge von Bits behandelt und die Bits in umgekehrter Reihenfolge durchliest. Wenn das Bit ist 1, nimmt es den rechten Zweig. Wenn das Bit ist 0, nimmt es den linken Zweig. Es stoppt, wenn es das letzte Bit erreicht (das a sein muss 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'

Genau wie natsfür definiert, indexso dass index nats n == nimmer wahr ist, nats'ist für definiert 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

Nun, natsund indexsind einfach nats'und index'doch mit den um 1 verschobenen Werten:

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

Wie in der Antwort von Edward Kmett angegeben, müssen Sie kostspielige Berechnungen zwischenspeichern und schnell darauf zugreifen können, um die Dinge zu beschleunigen.

Um die Funktion nicht monadisch zu halten, erfüllt die Lösung des Erstellens eines unendlichen faulen Baums mit einer geeigneten Methode zum Indizieren (wie in den vorherigen Beiträgen gezeigt) dieses Ziel. Wenn Sie die nicht-monadische Natur der Funktion aufgeben, können Sie die in Haskell verfügbaren assoziativen Standardcontainer in Kombination mit „zustandsähnlichen“ Monaden (wie State oder ST) verwenden.

Während der Hauptnachteil darin besteht, dass Sie eine nicht monadische Funktion erhalten, müssen Sie die Struktur nicht mehr selbst indizieren und können nur Standardimplementierungen von assoziativen Containern verwenden.

Dazu müssen Sie zuerst Ihre Funktion neu schreiben, um jede Art von Monade zu akzeptieren:

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)

Für Ihre Tests können Sie weiterhin eine Funktion definieren, die mit Data.Function.fix keine Memoisierung ausführt, obwohl sie etwas ausführlicher ist:

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

Sie können dann State Monad in Kombination mit Data.Map verwenden, um die Dinge zu beschleunigen:

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'

Mit geringfügigen Änderungen können Sie den Code so anpassen, dass er stattdessen mit Data.HashMap funktioniert:

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'

Anstelle von persistenten Datenstrukturen können Sie auch veränderbare Datenstrukturen (wie die Data.HashTable) in Kombination mit der ST-Monade ausprobieren:

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'

Im Vergleich zur Implementierung ohne Memoisierung können Sie mit jeder dieser Implementierungen für große Eingaben Ergebnisse in Mikrosekunden erzielen, anstatt mehrere Sekunden warten zu müssen.

Anhand von Criterion als Benchmark konnte ich feststellen, dass die Implementierung mit der Data.HashMap tatsächlich etwas besser abschnitt (etwa 20%) als die mit der Data.Map und der Data.HashTable, für die die Timings sehr ähnlich waren.

Ich fand die Ergebnisse des Benchmarks etwas überraschend. Mein anfängliches Gefühl war, dass die HashTable die HashMap-Implementierung übertreffen würde, da sie veränderbar ist. In dieser letzten Implementierung ist möglicherweise ein Leistungsfehler verborgen.

Ein paar Jahre später habe ich mir das angeschaut und festgestellt, dass es eine einfache Möglichkeit gibt, dies in linearer Zeit mithilfe zipWitheiner Hilfsfunktion zu speichern :

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

dilatehat die handliche Eigenschaft, dass dilate n xs !! i == xs !! div i n.

Angenommen, wir erhalten f (0), vereinfacht dies die Berechnung auf

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

Sieht unserer ursprünglichen Problembeschreibung sehr ähnlich und gibt eine lineare Lösung an ( sum $ take n fsnimmt O (n)).

Noch ein Nachtrag zu Edward Kmotts Antwort: ein in sich geschlossenes Beispiel:

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 

Verwenden Sie es wie folgt, um eine Funktion mit einem einzelnen ganzzahligen Argument (z. B. Fibonacci) zu speichern:

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

Es werden nur Werte für nicht negative Argumente zwischengespeichert.

Verwenden Sie memoIntFolgendes , um auch Werte für negative Argumente zwischenzuspeichern :

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

Verwenden Sie memoIntIntFolgendes, um Werte für Funktionen mit zwei ganzzahligen Argumenten zwischenzuspeichern :

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

Eine Lösung ohne Indizierung und nicht basierend auf Edward KMETTs.

Ich zähle gemeinsame Teilbäume zu einem gemeinsamen Elternteil aus ( f(n/4)wird zwischen f(n/2)und geteilt f(n/4)und f(n/6)wird zwischen f(2)und geteilt f(3)). Durch Speichern als einzelne Variable im übergeordneten Element wird die Berechnung des Teilbaums einmal durchgeführt.

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.

Der Code lässt sich nicht leicht auf eine allgemeine Memo-Funktion erweitern (zumindest würde ich nicht wissen, wie es geht), und Sie müssen wirklich darüber nachdenken, wie sich Teilprobleme überschneiden, sondern über die Strategie sollte für allgemeine mehrere nicht ganzzahlige Parameter funktionieren . (Ich habe es mir für zwei String-Parameter ausgedacht.)

Das Memo wird nach jeder Berechnung verworfen. (Wieder dachte ich über zwei String-Parameter nach.)

Ich weiß nicht, ob dies effizienter ist als die anderen Antworten. Jede Suche besteht technisch gesehen nur aus einem oder zwei Schritten ("Sehen Sie sich Ihr Kind oder das Kind Ihres Kindes an"), aber es kann viel zusätzlichen Speicherplatz geben.

Bearbeiten: Diese Lösung ist noch nicht korrekt. Die Freigabe ist unvollständig.

Bearbeiten: Es sollte jetzt Unterkinder richtig teilen, aber ich erkannte, dass dieses Problem viele nicht triviale Freigaben hat: n/2/2/2und n/3/3möglicherweise dasselbe ist. Das Problem passt nicht zu meiner Strategie.