Ghi nhớ trong Haskell?

Bất kỳ con trỏ nào về cách giải quyết hiệu quả chức năng sau trong Haskell, với số lượng lớn (n > 108)

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

Tôi đã thấy các ví dụ về ghi nhớ trong Haskell để giải các số của Wikipedia, liên quan đến tính toán (một cách lười biếng) tất cả các số của Wikipedia cho đến n cần thiết. Nhưng trong trường hợp này, với một n cho trước, chúng ta chỉ cần tính toán rất ít kết quả trung gian.

Cảm ơn

Chúng ta có thể làm điều này rất hiệu quả bằng cách tạo ra một cấu trúc mà chúng ta có thể lập chỉ mục trong thời gian tuyến tính phụ.

Nhưng trước tiên,

{-# LANGUAGE BangPatterns #-}

import Data.Function (fix)

Hãy xác định f, nhưng làm cho nó sử dụng 'đệ quy mở' thay vì gọi trực tiếp.

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)

Bạn có thể nhận được một unmemoized fbằng cách sử dụngfix f

Điều này sẽ cho phép bạn kiểm tra fxem ý nghĩa của bạn đối với các giá trị nhỏ fbằng cách gọi, ví dụ:fix f 123 = 144

Chúng ta có thể ghi nhớ điều này bằng cách định nghĩa:

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

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

Điều đó thực hiện rất tốt, và thay thế những gì sẽ mất thời gian O (n ^ 3) bằng một cái gì đó ghi nhớ các kết quả trung gian.

Nhưng nó vẫn mất thời gian tuyến tính chỉ để lập chỉ mục để tìm câu trả lời ghi nhớ cho mf. Điều này có nghĩa là kết quả như:

*Main Data.List> faster_f 123801
248604

có thể chấp nhận được, nhưng kết quả không có quy mô tốt hơn thế nhiều. Chúng ta có thể làm tốt hơn!

Đầu tiên, hãy xác định một cây vô hạn:

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)

Và sau đó chúng ta sẽ xác định một cách để lập chỉ mục vào nó, vì vậy chúng ta có thể tìm thấy một nút có chỉ mục ntrong thời gian 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

... Và chúng ta có thể tìm thấy một cây chứa đầy số tự nhiên để thuận tiện vì vậy chúng ta không phải loay hoay với những chỉ số đó:

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

Vì chúng tôi có thể lập chỉ mục, bạn chỉ có thể chuyển đổi một cây thành một danh sách:

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

Bạn có thể kiểm tra công việc cho đến nay bằng cách xác minh toList natscung cấp cho bạn[0..]

Hiện nay,

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

fastest_f :: Int -> Int
fastest_f = index f_tree

hoạt động giống như với danh sách ở trên, nhưng thay vì mất thời gian tuyến tính để tìm từng nút, có thể đuổi nó xuống theo thời gian logarit.

Kết quả nhanh hơn đáng kể:

*Main> fastest_f 12380192300
67652175206

*Main> fastest_f 12793129379123
120695231674999

Trong thực tế, nó nhanh hơn rất nhiều mà bạn có thể đi qua và thay thế Intbằng Integerở trên và nhận được câu trả lời lớn một cách lố bịch gần như ngay lập tức

*Main> fastest_f' 1230891823091823018203123
93721573993600178112200489

*Main> fastest_f' 12308918230918230182031231231293810923
11097012733777002208302545289166620866358

Câu trả lời của Edward là một viên ngọc tuyệt vời đến nỗi tôi đã sao chép nó và cung cấp các triển khai memoListvàmemoTree tổ hợp ghi nhớ một chức năng ở dạng đệ quy mở.

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

Không phải là cách hiệu quả nhất, nhưng ghi nhớ:

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

Khi yêu cầu f !! 144, nó được kiểm tra rằngf !! 143 tồn tại, nhưng giá trị chính xác của nó không được tính. Nó vẫn được đặt là một kết quả chưa biết của một phép tính. Các giá trị chính xác duy nhất được tính là những giá trị cần thiết.

Vì vậy, ban đầu, theo như đã tính được bao nhiêu, chương trình không biết gì.

f = .... 

Khi chúng tôi thực hiện yêu cầu f !! 12, nó bắt đầu thực hiện một số khớp mẫu:

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

Bây giờ nó bắt đầu tính toán

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

Điều này đệ quy làm cho một nhu cầu khác trên f, vì vậy chúng tôi tính toán

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

Bây giờ chúng ta có thể sao lưu một số

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

Điều đó có nghĩa là chương trình hiện biết:

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

Tiếp tục nhỏ giọt:

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

Điều đó có nghĩa là chương trình hiện biết:

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

Bây giờ chúng tôi tiếp tục với tính toán của chúng tôi về 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

Điều đó có nghĩa là chương trình hiện biết:

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

Bây giờ chúng tôi tiếp tục với tính toán của chúng tôi về 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

Điều đó có nghĩa là chương trình hiện biết:

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

Vì vậy, việc tính toán được thực hiện khá lười biếng. Chương trình biết rằng một số giá trị f !! 8tồn tại, nó bằng g 8, nhưng nó không biết nó g 8là gì .

Đây là phần phụ lục cho câu trả lời xuất sắc của Edward Kmett.

Khi tôi thử mã của anh ấy, các định nghĩa về natsvàindex có vẻ khá bí ẩn, vì vậy tôi viết một phiên bản thay thế mà tôi thấy dễ hiểu hơn.

Tôi xác định indexvà natstrong điều khoản index'và nats'.

index' t nđược xác định trong phạm vi [1..]. (Nhớ lại index tđược xác định trong phạm vi [0..].) Nó hoạt động tìm kiếm cây bằng cách xử lý nnhư một chuỗi bit và đọc qua các bit theo chiều ngược lại. Nếu bit là 1, nó mất nhánh bên phải. Nếu bit là 0, nó lấy nhánh bên trái. Nó dừng lại khi đạt đến bit cuối cùng (phải là 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'

Cũng như natsđược định nghĩa cho indexnên index nats n == nlúc nào cũng là sự thật, nats'được định nghĩa cho 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

Bây giờ, natsvà indexchỉ đơn giản nats'và index'nhưng với các giá trị được thay đổi bởi 1:

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

Như đã nêu trong câu trả lời của Edward Kmett, để tăng tốc mọi thứ, bạn cần lưu trữ các tính toán tốn kém và có thể truy cập chúng nhanh chóng.

Để giữ cho chức năng không đơn điệu, giải pháp xây dựng một cây lười vô hạn, với một cách thích hợp để lập chỉ mục cho nó (như được hiển thị trong các bài viết trước) hoàn thành mục tiêu đó. Nếu bạn từ bỏ tính chất không đơn điệu của chức năng, bạn có thể sử dụng các thùng chứa kết hợp tiêu chuẩn có sẵn trong Haskell kết hợp với các đơn vị giống như nhà nước của Drake (như Bang hoặc ST).

Mặc dù nhược điểm chính là bạn có được một hàm không đơn điệu, bạn không phải tự lập chỉ mục cấu trúc nữa và chỉ có thể sử dụng các triển khai tiêu chuẩn của các thùng chứa kết hợp.

Để làm như vậy, trước tiên bạn cần phải viết lại chức năng của mình để chấp nhận bất kỳ loại đơn nguyên nào:

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)

Đối với các thử nghiệm của bạn, bạn vẫn có thể xác định một chức năng không ghi nhớ bằng Data.Function.fix, mặc dù nó dài hơn một chút:

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

Sau đó, bạn có thể sử dụng trạng thái đơn nguyên kết hợp với Data.Map để tăng tốc mọi thứ:

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'

Với những thay đổi nhỏ, bạn có thể điều chỉnh mã để hoạt động với Data.HashMap thay thế:

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'

Thay vì các cấu trúc dữ liệu liên tục, bạn cũng có thể thử các cấu trúc dữ liệu có thể thay đổi (như Data.HashTable) kết hợp với đơn vị 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'

So với việc thực hiện mà không có bất kỳ ghi nhớ nào, bất kỳ triển khai nào trong số này cho phép bạn, đối với các đầu vào lớn, để có kết quả trong vài giây thay vì phải chờ vài giây.

Sử dụng Tiêu chí làm điểm chuẩn, tôi có thể thấy rằng việc triển khai với Data.HashMap thực sự hoạt động tốt hơn một chút (khoảng 20%) so với Data.Map và Data.HashTable mà thời gian rất giống nhau.

Tôi tìm thấy kết quả của điểm chuẩn một chút đáng ngạc nhiên. Cảm giác ban đầu của tôi là HashTable sẽ vượt trội hơn so với triển khai HashMap vì nó có thể thay đổi được. Có thể có một số khiếm khuyết hiệu năng ẩn trong triển khai cuối cùng này.

Một vài năm sau, tôi đã xem xét điều này và nhận ra có một cách đơn giản để ghi nhớ điều này trong thời gian tuyến tính bằng cách sử dụng zipWithvà một hàm trợ giúp:

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

dilateCó tài sản tiện dụng mà dilate n xs !! i == xs !! div i n.

Vì vậy, giả sử chúng ta đã cho f (0), điều này đơn giản hóa việc tính toán thành

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

Nhìn rất giống mô tả vấn đề ban đầu của chúng tôi và đưa ra giải pháp tuyến tính ( sum $ take n fssẽ lấy O (n)).

Một phụ lục khác cho câu trả lời của Edward Kmett: một ví dụ khép kí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 

Sử dụng nó như sau để ghi nhớ một hàm với một số nguyên arg (ví dụ: Wikipedia):

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

Chỉ các giá trị cho các đối số không âm sẽ được lưu trữ.

Để cũng lưu các giá trị bộ đệm cho các đối số phủ định, sử dụng memoInt, được xác định như sau:

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

Để lưu giá trị bộ đệm cho các hàm có sử dụng hai đối số nguyên memoIntInt, được định nghĩa như sau:

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

Một giải pháp mà không cần lập chỉ mục, và không dựa trên Edward KMETT.

Tôi tính ra các cây con chung cho một cha mẹ chung ( f(n/4)được chia sẻ giữa f(n/2)và f(n/4), và f(n/6)được chia sẻ giữa f(2)và f(3)). Bằng cách lưu chúng dưới dạng một biến duy nhất trong cha mẹ, việc tính toán cây con được thực hiện một lần.

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.

Mã không dễ dàng mở rộng đến chức năng ghi nhớ chung (ít nhất, tôi sẽ không biết cách thực hiện) và bạn thực sự phải nghĩ cách các biểu tượng con chồng chéo, nhưng chiến lược nên hoạt động cho nhiều tham số không nguyên. . (Tôi nghĩ rằng nó lên cho hai tham số chuỗi.)

Bản ghi nhớ bị loại bỏ sau mỗi phép tính. (Một lần nữa, tôi đã suy nghĩ về hai tham số chuỗi.)

Tôi không biết nếu điều này hiệu quả hơn các câu trả lời khác. Mỗi lần tra cứu về mặt kỹ thuật chỉ có một hoặc hai bước ("Nhìn vào con của bạn hoặc con của bạn"), nhưng có thể có rất nhiều sử dụng bộ nhớ bổ sung.

Chỉnh sửa: Giải pháp này chưa chính xác. Việc chia sẻ không đầy đủ.

Chỉnh sửa: Bây giờ nên chia sẻ con đúng cách, nhưng tôi nhận ra rằng vấn đề này có rất nhiều chia sẻ không cần thiết: n/2/2/2và n/3/3có thể giống nhau. Vấn đề không phù hợp với chiến lược của tôi.