Пам'ятка в Haskell?

Будь-які вказівки на те, як ефективно вирішити наступну функцію в Haskell, для великої кількості (n > 108)

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

Я бачив приклади запам'ятовування в 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)

Ви можете не помітити 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)

І тоді ми визначимо спосіб індексувати його, щоб ми могли знайти вузол з індексом 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

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

Результат значно швидший:

*Main> fastest_f 12380192300
67652175206

*Main> fastest_f 12793129379123
120695231674999

Насправді це набагато швидше, ніж ви можете пройти і замінити Intз Integerвище і отримати сміховинно великі відповіді майже миттєво

*Main> fastest_f' 1230891823091823018203123
93721573993600178112200489

*Main> fastest_f' 12308918230918230182031231231293810923
11097012733777002208302545289166620866358

Відповідь Едварда - це така чудова дорогоцінний камінь, що я його продублював і надав реалізацію 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

Не найефективніший спосіб, але запам'ятовує:

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)

Для ваших тестів ви все ще можете визначити функцію, яка не запам’ятовує, використовуючи Data.Function.fix, хоча це дещо докладніше:

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

Потім можна використовувати State monad у поєднанні з 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'

У порівнянні з реалізацією без запам'ятовування, будь-яка з цих реалізацій дозволяє за величезні входи отримувати результати за мікросекунди, замість того, щоб чекати кілька секунд.

Використовуючи критерій як орієнтир, я міг зауважити, що реалізація з 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)).

Ще одне доповнення до відповіді Едварда Кметта: автономний приклад:

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 

Використовуйте його наступним чином, щоб запам'ятати функцію з одним цілим аргументом (наприклад, поле):

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))

Рішення без індексації та не на основі Едварда КМЕТТ.

Я розбиваю на загальні батьківські підпункти ( 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.

Код не легко поширюється на загальну функцію запам'ятовування (принаймні, я б не знав, як це зробити), і вам дійсно потрібно продумати, як підпрограми перетинаються, але стратегія повинна працювати для загальних кількох не цілих параметрів . (Я придумав це для двох параметрів рядка.)

Пам'ятка відкидається після кожного розрахунку. (Знову ж я думав про два параметри рядка.)

Я не знаю, чи це більш ефективно, ніж інші відповіді. Технічно кожен пошук - це лише один або два кроки ("Подивіться на дитину чи дитину"), але можливо додаткове використання пам'яті.

Редагувати: це рішення ще не правильне. Обмін є неповним.

Редагувати: Зараз слід правильно ділитися дітьми, але я зрозумів, що ця проблема має багато нетривіального обміну: n/2/2/2і n/3/3може бути однаковою. Проблема не дуже відповідає моїй стратегії.