MemoizedFibonacci.fsx

// Fibonacci
// not originally mine, can't remember where I got it

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

type StateContBuilder() = 
    member __.Return value =
        StateContMonad (fun state k -> k state value)
    member __.Bind (StateContMonad contStateMonad, f) =
        StateContMonad (fun state k ->
            contStateMonad state (fun state' value ->
                let (StateContMonad contMonad') = f value
                contMonad' state' k))
    member __.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)