Monadic Memoization

Modular memoization within a pure functional setting that is implemented as a convenient computation builder.

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10: 
11: 
12: 
13: 
14: 
15: 
16: 
17: 
18: 
19: 
20: 
21: 
22: 
23: 
24: 
25: 
26: 
27: 
28: 
29: 
30: 
31: 
32: 
33: 
34: 
35: 
36: 
37: 
38: 
39: 
40: 
41: 
42: 
43: 
44: 
45: 
46: 
47: 
48: 
49: 
50: 
51: 
52: 
53: 
54: 
55: 
56: 
57: 
58: 
59: 
60: 
61: 
62:

// Inspired by http://www.cs.utexas.edu/~wcook/Drafts/2006/MemoMixins.pdf

// State Monad combined with Continuation Monad (StateT Monad transformer)
type StateContMonad<'s, 'a, 'r> = StateContMonad of ('s -> ('s -> 'a -> 'r) -> 'r)

// Computation Builder
type StateContBuilder() =
    member self.Return value = 
        StateContMonad (fun state k -> k state value)
    member self.Bind(StateContMonad contStateMonad, f) = 
        StateContMonad (fun state k -> 
            contStateMonad state (fun state' value -> 
                let (StateContMonad contMonad') = f value
                contMonad' state' k))
    member self.Delay( f : unit -> StateContMonad<'s, 'a, 'r> ) = 
        StateContMonad (fun state k -> 
            let (StateContMonad contStateMonad) = f ()
            contStateMonad state k)
 
let memo = new StateContBuilder()
 
// Tell me Y 
let rec Y f v = f (Y f) v

// Map functions
let check (value : 'a) : StateContMonad<Map<'a, 'r>, option<'r>, 'r> = 
    StateContMonad (fun map k -> k map (Map.tryFind value map))

let store (argument : 'a, result : 'r) : StateContMonad<Map<'a, 'r>, unit, 'r> = 
    StateContMonad (fun map k -> k (Map.add argument result map) ())

// Memoization Mixin
let memoize f argument =
    memo {
        let! checkResult = check argument
        match checkResult with
        | Some result -> return result
        | None ->
            let! result = f argument
            do! store (argument, result)
            return result
    }


let execute f n = 
    let (StateContMonad contStateMonad) = Y (memoize << f) n
    contStateMonad Map.empty (fun _ value -> value)
 
// Example
let big (value : int) = new System.Numerics.BigInteger(value)

let fib f n =
    if n = big 0 then memo { return big 0 }
    elif n = big 1 then memo { return big 1 }
    else
        memo {
            let! nMinus1Fib = f (n - big 1)
            let! nMinus2Fib = f (n - big 2)
            return nMinus1Fib + nMinus2Fib
        }
 
execute fib (big 100000)

Multiple items
union case StateContMonad.StateContMonad: ('s -> ('s -> 'a -> 'r) -> 'r) -> StateContMonad<'s,'a,'r>

--------------------
type StateContMonad<'s,'a,'r> = | StateContMonad of ('s -> ('s -> 'a -> 'r) -> 'r)

Full name: Script.StateContMonad<_,_,_>

Multiple items
type StateContBuilder =
  new : unit -> StateContBuilder
  member Bind : StateContMonad<'a,'b,'c> * f:('b -> StateContMonad<'a,'d,'c>) -> StateContMonad<'a,'d,'c>
  member Delay : f:(unit -> StateContMonad<'s,'a,'r>) -> StateContMonad<'s,'a,'r>
  member Return : value:'e -> StateContMonad<'f,'e,'g>

Full name: Script.StateContBuilder

--------------------
new : unit -> StateContBuilder

val self : StateContBuilder

member StateContBuilder.Return : value:'e -> StateContMonad<'f,'e,'g>

Full name: Script.StateContBuilder.Return

val value : 'e

val state : 'f

val k : ('f -> 'e -> 'g)

member StateContBuilder.Bind : StateContMonad<'a,'b,'c> * f:('b -> StateContMonad<'a,'d,'c>) -> StateContMonad<'a,'d,'c>

Full name: Script.StateContBuilder.Bind

val contStateMonad : ('a -> ('a -> 'b -> 'c) -> 'c)

val f : ('b -> StateContMonad<'a,'d,'c>)

val state : 'a

val k : ('a -> 'd -> 'c)

val state' : 'a

val value : 'b

val contMonad' : ('a -> ('a -> 'd -> 'c) -> 'c)

member StateContBuilder.Delay : f:(unit -> StateContMonad<'s,'a,'r>) -> StateContMonad<'s,'a,'r>

Full name: Script.StateContBuilder.Delay

val f : (unit -> StateContMonad<'s,'a,'r>)

type unit = Unit

Full name: Microsoft.FSharp.Core.unit

val state : 's

val k : ('s -> 'a -> 'r)

val contStateMonad : ('s -> ('s -> 'a -> 'r) -> 'r)

val memo : StateContBuilder

Full name: Script.memo

val Y : f:(('a -> 'b) -> 'a -> 'b) -> v:'a -> 'b

Full name: Script.Y

val f : (('a -> 'b) -> 'a -> 'b)

val v : 'a

val check : value:'a -> StateContMonad<Map<'a,'r>,'r option,'r> (requires comparison)

Full name: Script.check

val value : 'a (requires comparison)

Multiple items
module Map

from Microsoft.FSharp.Collections

--------------------
type Map<'Key,'Value (requires comparison)> =
  interface IEnumerable
  interface IComparable
  interface IEnumerable<KeyValuePair<'Key,'Value>>
  interface ICollection<KeyValuePair<'Key,'Value>>
  interface IDictionary<'Key,'Value>
  new : elements:seq<'Key * 'Value> -> Map<'Key,'Value>
  member Add : key:'Key * value:'Value -> Map<'Key,'Value>
  member ContainsKey : key:'Key -> bool
  override Equals : obj -> bool
  member Remove : key:'Key -> Map<'Key,'Value>
  ...

Full name: Microsoft.FSharp.Collections.Map<_,_>

--------------------
new : elements:seq<'Key * 'Value> -> Map<'Key,'Value>

type 'T option = Option<'T>

Full name: Microsoft.FSharp.Core.option<_>

val map : Map<'a,'r> (requires comparison)

val k : (Map<'a,'r> -> 'r option -> 'r) (requires comparison)

val tryFind : key:'Key -> table:Map<'Key,'T> -> 'T option (requires comparison)

Full name: Microsoft.FSharp.Collections.Map.tryFind

val store : argument:'a * result:'r -> StateContMonad<Map<'a,'r>,unit,'r> (requires comparison)

Full name: Script.store

val argument : 'a (requires comparison)

val result : 'r

val k : (Map<'a,'r> -> unit -> 'r) (requires comparison)

val add : key:'Key -> value:'T -> table:Map<'Key,'T> -> Map<'Key,'T> (requires comparison)

Full name: Microsoft.FSharp.Collections.Map.add

val memoize : f:('a -> StateContMonad<Map<'a,'b>,'b,'b>) -> argument:'a -> StateContMonad<Map<'a,'b>,'b,'b> (requires comparison)

Full name: Script.memoize

val f : ('a -> StateContMonad<Map<'a,'b>,'b,'b>) (requires comparison)

val checkResult : 'b option

union case Option.Some: Value: 'T -> Option<'T>

val result : 'b

union case Option.None: Option<'T>

val execute : f:(('a -> StateContMonad<Map<'a,'b>,'b,'b>) -> 'a -> StateContMonad<Map<'a,'b>,'b,'b>) -> n:'a -> 'b (requires comparison)

Full name: Script.execute

val f : (('a -> StateContMonad<Map<'a,'b>,'b,'b>) -> 'a -> StateContMonad<Map<'a,'b>,'b,'b>) (requires comparison)

val n : 'a (requires comparison)

val contStateMonad : (Map<'a,'b> -> (Map<'a,'b> -> 'b -> 'b) -> 'b) (requires comparison)

val empty<'Key,'T (requires comparison)> : Map<'Key,'T> (requires comparison)

Full name: Microsoft.FSharp.Collections.Map.empty

val big : value:int -> System.Numerics.BigInteger

Full name: Script.big

val value : int

Multiple items
val int : value:'T -> int (requires member op_Explicit)

Full name: Microsoft.FSharp.Core.Operators.int

--------------------
type int = int32

Full name: Microsoft.FSharp.Core.int

--------------------
type int<'Measure> = int

Full name: Microsoft.FSharp.Core.int<_>

namespace System

namespace System.Numerics

Multiple items
type BigInteger =
  struct
    new : value:int -> BigInteger + 7 overloads
    member CompareTo : other:int64 -> int + 3 overloads
    member Equals : obj:obj -> bool + 3 overloads
    member GetHashCode : unit -> int
    member IsEven : bool
    member IsOne : bool
    member IsPowerOfTwo : bool
    member IsZero : bool
    member Sign : int
    member ToByteArray : unit -> byte[]
    ...
  end

Full name: System.Numerics.BigInteger

--------------------
System.Numerics.BigInteger()
System.Numerics.BigInteger(value: int) : unit
System.Numerics.BigInteger(value: uint32) : unit
System.Numerics.BigInteger(value: int64) : unit
System.Numerics.BigInteger(value: uint64) : unit
System.Numerics.BigInteger(value: float32) : unit
System.Numerics.BigInteger(value: float) : unit
System.Numerics.BigInteger(value: decimal) : unit
System.Numerics.BigInteger(value: byte []) : unit

val fib : f:(System.Numerics.BigInteger -> StateContMonad<'a,System.Numerics.BigInteger,'b>) -> n:System.Numerics.BigInteger -> StateContMonad<'a,System.Numerics.BigInteger,'b>

Full name: Script.fib

val f : (System.Numerics.BigInteger -> StateContMonad<'a,System.Numerics.BigInteger,'b>)

val n : System.Numerics.BigInteger

val nMinus1Fib : System.Numerics.BigInteger

val nMinus2Fib : System.Numerics.BigInteger

Previous Version Raw view Test code New version

More information

Link:	http://fssnip.net/3v
Posted:	13 years ago
Author:	Nick Palladinos
Tags:	monads , memoization