[SOLVED] CS module Memoization (memoFix, memoFix2, lift0, lift1, lift2, liftMany, TableBased, Booster) where

module Memoization (memoFix, memoFix2, lift0, lift1, lift2, liftMany, TableBased, Booster) where

import Control.Monad
import qualified Data.Map as Map

Heres everything you need to know about the interface
for using this module.

The type TableBased c v a is a fancy version of the
type a. More specifically, a thing of this type is
like a thing of type a, except its calculated in
such a way that it makes use of a memoized lookup
table that maps things of type c (for cells)
to things of type v (for values). For short,
think of TableBased c v a as memoization-based a.

The lift functions let you take functions that youve written
for working with normal things and use them for working with
memoization-based things.
lift0 :: x -> TableBased c v x
lift1 :: (x -> y) -> TableBased c v x -> TableBased c v y
lift2 :: (x -> y -> z) -> TableBased c v x -> TableBased c v y -> TableBased c v z
liftMany :: ([a] -> a) -> [TableBased c v a] -> TableBased c v a

In particular the lift functions are useful for writing
de-recursive-ized versions of recursive functions. Then
you can create memoized versions of the recursive function
using the memoize functions. These memoize functions
tie up a de-recursive-ized function to make it recursive,
like just fix does, but they add in the memoization
along the way.
type Booster a = (a -> a)
memoFix :: (Ord c) => Booster (c -> TableBased c a a) -> c -> a
memoFix2 :: (Ord c1, Ord c2) => Booster (c1 -> c2 -> TableBased (c1,c2) a a) -> c1 -> c2 -> a

IMPLEMENTATION DETAILS FROM HERE ON

data TableBased c v a = MkTableBased (Map.Map c v -> (a, Map.Map c v))

instance Functor (TableBased c v) where
fmap = liftM
instance Applicative (TableBased c v) where
pure x = MkTableBased (
-> (x,n))
(<*>) = ap
instance Monad (TableBased c v) where
DIY state monad
(MkTableBased fa) >>= k =
MkTableBased $
->
let (a,n) = fa n in
let (MkTableBased fb) = k a in
let (b,n) = fb n in
(b,n)

lift0 :: x -> TableBased c a x
lift0 = pure

lift1 :: (x -> y) -> TableBased c a x -> TableBased c a y
lift1 = liftM

lift2 :: (x -> y -> z) -> TableBased c a x -> TableBased c a y -> TableBased c a z
lift2 = liftM2

lift3 :: (w -> x -> y -> z) -> TableBased c a w -> TableBased c a x -> TableBased c a y -> TableBased c a z
lift3 = liftM3

liftMany :: ([a] -> a) -> [TableBased c a a] -> TableBased c a a
liftMany f xs = liftM f (sequence xs)

tryRetrieveElse :: (Ord c) => (c -> TableBased c a a) -> c -> TableBased c a a
tryRetrieveElse f c =
let yield x = MkTableBased (tbl -> (x, Map.insert c x tbl)) in
MkTableBased (tbl -> (Map.lookup c tbl, tbl)) >>= (r ->
case r of
Just x -> pure x
Nothing -> (f c) >>= yield
)

goFromEmptyTable :: TableBased c a a -> a
goFromEmptyTable (MkTableBased f) = fst (f Map.empty)

type Booster a = (a -> a)

fix :: Booster a -> a
fix f = let x = f x in x

memoFix :: (Ord c) => Booster (c -> TableBased c a a) -> c -> a
memoFix f = x -> goFromEmptyTable (fix (tryRetrieveElse . f) x)

memoFix2 :: (Ord c1, Ord c2) => Booster (c1 -> c2 -> TableBased (c1,c2) a a) -> c1 -> c2 -> a
memoFix2 f = curry (memoFix (uncurry . f . curry))