Random.map without stack overflow

[TysonMN]

This issue is a spin off of #238 (comment)

Recall that the type 'a -> 'b is (covariant) functor in 'b. The map function for this functor is function composition (which is either >> or << with only the order of inputs chanding). Our Random<'c> type is a (covariant) functor in 'c because it is just an wrapper around the type 'a -> 'b -> 'c, which is also a (covarant) functor in 'c. We can simplify things by uncurrying to get back to a function of the form 'a -> 'b.

The naive way to implement map for the (covariant) functor 'a -> 'b can overflow the stack. Specifically, the following test fails.

[<Fact>]
let ``Does function composition overflow the stack? Answer: Yes`` () =
  let n = 100_000
  let f =
    id
    |> List.replicate n
    |> List.fold (>>) id
  f ()

Here is one way to avoid overflowing the stack. I will be the first to say that this is not elegant.

type Fun<'a, 'b> =
  { In: 'a -> obj
    FuncsBefore: (obj -> obj) list
    FuncsAfter: (obj -> obj) list
    Out: obj -> 'b }


module Fun =

  let id<'a> =
    { In = box<'a>
      FuncsBefore = []
      FuncsAfter = []
      Out = unbox<'a> }

  let evaluate f a =
    (f.FuncsBefore @ List.rev f.FuncsAfter)
    |> List.fold (fun a f -> f a) (f.In a)
    |> f.Out

  let composeBefore (g: 'a -> 'b) (f: Fun<'b, 'c>) : Fun<'a, 'c> =
    { In = box<'a>
      FuncsBefore = (unbox<'a> >> g >> box<'b>) :: f.FuncsBefore
      FuncsAfter = f.FuncsAfter
      Out = f.Out }

  let composeAfter (g: 'b -> 'c) (f: Fun<'a, 'b>) : Fun<'a, 'c> =
    { In = f.In
      FuncsBefore = f.FuncsBefore
      FuncsAfter = (unbox<'b> >> g >> box<'c>) :: f.FuncsAfter
      Out = unbox<'c> }


[<Fact>]
let ``Custom function composition`` () =
  let flip f b a = f a b

  let n = 1_000_000
  let f =
    (+) 1
    |> List.replicate n
    |> List.fold (flip Fun.composeAfter) Fun.id
    |> Fun.evaluate
  let actual = f 0
  Assert.Equal(n, actual)

  let n = 1_000_000
  let f =
    (+) 1
    |> List.replicate n
    |> List.fold (flip Fun.composeBefore) Fun.id
    |> Fun.evaluate
  let actual = f 0
  Assert.Equal(n, actual)

  let f =
    Fun.id<double>
    |> Fun.composeAfter (sprintf "%f")
    |> Fun.composeAfter (fun s -> s |> String.length)
    |> Fun.composeAfter (fun n -> n % 2 = 0)
    |> Fun.evaluate
  let b = f 3.141592
  Assert.True(b)

  let f =
    Fun.id<bool>
    |> Fun.composeBefore (fun n -> n % 2 = 0)
    |> Fun.composeBefore (fun s -> s |> String.length)
    |> Fun.composeBefore (sprintf "%f")
    |> Fun.evaluate
  let b = f 3.141592
  Assert.True(b)

[TysonMN]

The behavior might depend on DEBUG vs RELEASE.

[TysonMN]

I should be more specific. Here is a test that fails because Random.map "causes" a stack overflow (even when compiled in RELEASE mode).

[<Fact>]
let ``map does not overflow the stack`` () =
  let flip f b a = f a b
  let n = 100_000
  id
  |> List.replicate n
  |> List.fold (flip Random.map) (Random.constant 1)
  |> Random.run (Seed.random ()) 0
  |> ignore

[TysonMN]

There is something subtle that I don't understand yet between left and right function composition.

This test using right composition fails even when compiled in RELEASE mode.

[<Fact>]
let ``Right composition overflow the stack`` () =
  let n = 1_000_000
  let f =
    id
    |> List.replicate n
    |> List.fold (>>) id
  f ()

But the same test using left composition passes when compiled in RELEASE mode (even for a larger value of n).

[<Fact>]
let ``Left composition overflow the stack`` () =
  let n = 10_000_000
  let f =
    id
    |> List.replicate n
    |> List.fold (<<) id
  f ()

[TysonMN]

There is a difference between f >> acc and acc >> f, where acc is the accumulation of many function compositions. The first is reminiscent of List.cons (the constant-time operation that adds an element to the head of a list) and doesn't cause the stack to overflow when executed (if compiled in RELEASE mode). The second is reminiscent of snoc (which is cons backwards and is the operation that adds an element to the end of a list in linear time) and does cause the stack to overflow even when compiled in RELEASE mode.

Maybe a John Hughes difference list could be used to reverse the order of the function composition and thus avoid the stack overflow without any calls to box or unbox.

[TysonMN]

Maybe a John Hughes difference list could be used to reverse the order of the function composition and thus avoid the stack overflow without any calls to box or unbox.

Yes and no. I think the calls to box and unbox are necessary. What isn't necessary is an explicit list. The "John Hughes difference list" technique makes it possible to compose in the other direction without collecting all the functions first.

Here is the type, a partial implementation, and some tests. I will create a full implementation and some benchmarks soon.

type Random<'a> =
  private { Initial: Seed -> Size -> obj
            Mappings: (obj -> obj) -> obj -> obj
            Unbox: obj -> 'a }

module Random =

    let private unsafeRun (seed : Seed) (size : Size) (data : Random<'a>) : 'a =
        data.Initial seed size
        |> data.Mappings id
        |> data.Unbox

    let run (seed : Seed) (size : Size) (r : Random<'a>) : 'a =
        unsafeRun seed (max 1 size) r

    let constant (x : 'a) : Random<'a> =
        { Initial = fun _ _ -> box<'a> x
          Mappings = fun f obj -> f obj
          Unbox = unbox<'a> }

    let map (f : 'a -> 'b) (data: Random<'a>) : Random<'b> =
        { Initial = data.Initial
          Mappings = (>>) (unbox<'a> >> f >> box<'b>) >> data.Mappings
          Unbox = unbox<'b> }


[<Fact>]
let ``map does not overflow the stack`` () =
  let flip f b a = f a b
  let n = 1_000_000
  id
  |> List.replicate n
  |> List.fold (flip Random.map) (Random.constant 1)
  |> Random.run (Seed.random ()) 0
  |> ignore
  
[<Fact>]
let ``map can change its type parameter`` () =
  Random.constant 3.14159
  |> Random.map (sprintf "%f")
  |> Random.map (fun s -> s |> String.length)
  |> Random.map (fun n -> n % 2 = 0)
  |> Random.run (Seed.random ()) 0
  |> ignore

[TysonMN]

I was able to simplify. Now there is only one function (like the code in master instead of three like in my previous comment) and there is exactly one call to box and one call to unbox per call to unsafeRun. I also added a function called variable to show how to create this new type given a function used in the old type.

type Random<'a> = private Random of (('a -> obj) -> Seed -> Size -> obj)

module Random =

    let private unsafeRun (seed : Seed) (size : Size) (Random r: Random<'a>) : 'a =
        r box<'a> seed size |> unbox<'a>

    let run (seed : Seed) (size : Size) (r : Random<'a>) : 'a =
        unsafeRun seed (max 1 size) r

    let constant (x : 'a) : Random<'a> =
        Random (fun f _ _ -> x |> f)

    let variable (f: Seed -> Size -> 'a) : Random<'a> =
        Random (fun g seed size -> f seed size |> g)

    let map (f : 'a -> 'b) (Random r: Random<'a>) : Random<'b> =
        (>>) f >> r |> Random

[TysonMN]

There have been great improvements to Random lately including PRs #266 and #276. The last one in the queue is PR #290. After that PR is completed, I will create a PR for the following change. Then I will create a PR for the fix that I posted above.

Recall that

• bind f = map f >> flatten and
• flatten = bind id.

So we can implement one of these functions "directly" and then define the renaming one via the first one.

I think we should directly define Random.flatten (or join if to be consist with Tree), which doesn't even exist at the moment, and then define bind via it.

[ghost]

@TysonMN I don't think #290 should have to block the work you've done here, have I missed something? It seems like a PR for this would be ready to go with or without #290.

If you put up PRs to get this done, I'd merge them straight away.

[TysonMN]

Ok, I will try. Let's do PR #314 first.