ConcatTree.fs

#if STACK_VARIANT1
module MutableStack =
  type Stack<'T> (size :int ) =
    class
      let mutable vs : 'T []  = Array.zeroCreate size
      let mutable last        = -1

      member x.IsEmpty = last < 0

      member x.IsNotEmpty = last >= 0

      member x.Count = last + 1

      member x.Pop () : 'T =
        let v = vs.[last]
        last <- last - 1
        v

      member x.Push (v: 'T) : unit =
        let l = last + 1
        if l < vs.Length then
          vs.[l] <- v
          last <- l
        else
          System.Array.Resize (&vs, vs.Length <<< 1)
          vs.[l] <- v
          last <- l

    end

  module Stack =
    let inline count (stack : Stack<'T>) : int =
      stack.Count

    let inline isEmpty (stack : Stack<'T>) : bool =
      stack.IsEmpty

    let inline isNotEmpty (stack : Stack<'T>) : bool =
      stack.IsNotEmpty

    let inline init (size : int) : Stack<'T> = 
      Stack size

    let inline push (stack : Stack<'T>) v : unit = 
      stack.Push v

    let inline pop (stack : Stack<'T>) : 'T =
      stack.Pop ()
#else
module MutableStack =
  type Stack<'T> = System.Collections.Generic.Stack<'T>

  module Stack =
    let inline count (stack : Stack<'T>) : int =
      stack.Count

    let inline isEmpty (stack : Stack<'T>) : bool =
      stack.Count = 0

    let inline isNotEmpty (stack : Stack<'T>) : bool =
      stack.Count > 0

    let inline init (size : int) : Stack<'T> = 
      Stack size

    let inline push (stack : Stack<'T>) v : unit = 
      stack.Push v

    let inline pop (stack : Stack<'T>) : 'T =
      stack.Pop ()
#endif

module CT0 =
  type [<RequireQualifiedAccess>] ConcatTree<'T> =
    | Empty
    | Leaf  of 'T
    | Fork  of ConcatTree<'T>*ConcatTree<'T>

  module ConcatTree =
    module Details =
      module Loops =
        let rec fold (f : OptimizedClosures.FSharpFunc<_, _, _>) s t =
          match t with
          | ConcatTree.Empty ->
              s
          | ConcatTree.Leaf v ->
            f.Invoke (s, v)
          | ConcatTree.Fork (l, r) ->
            let s = fold f s l
            fold f s r
    open Details
  
    [<GeneralizableValue>]
    let empty = ConcatTree.Empty

    let inline leaf v = ConcatTree.Leaf v

    let inline concat (l : ConcatTree<'T>) (r : ConcatTree<'T>) : ConcatTree<'T> =
      match l, r with
      | ConcatTree.Empty  , _                 -> r
      | _                 , ConcatTree.Empty  -> l
      | _                 , _                 -> ConcatTree.Fork (l, r)

    let inline fold (f : 'S -> 'T -> 'S) (z : 'S) (t : ConcatTree<'T>) : 'S =
      let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt f
      Loops.fold f z t

    let toArray (t : ConcatTree<'T>) : 'T [] =
      let ra = ResizeArray 16
      fold (fun _ v -> ra.Add v) () t
      ra.ToArray ()

    let toList (t : ConcatTree<'T>) : 'T list =
      fold (fun s v -> v::s) [] t |> List.rev

    let ofArray (vs : 'T []) : ConcatTree<'T> =
      let rec loop b e =
        if b = e then
          empty
        elif b + 1 = e then
          leaf (vs.[b])
        else
          let m = (b + e) / 2
          concat (loop b m) (loop m e)
      loop 0 vs.Length

  module Test =

    type Properties =
      static member ``ofArray/to*`` (vs : int []) =
        let ea = vs
        let aa = vs |> ConcatTree.ofArray |> ConcatTree.toArray

        let el = vs |> Array.toList
        let al = vs |> ConcatTree.ofArray |> ConcatTree.toList

        ea = aa && el = al

    open FsCheck
 
    let run () =
      let config = { Config.Quick with MaxTest = 1000; MaxRejected = 1000 }
      Check.All<Properties> config

module CT1 =
  type [<RequireQualifiedAccess>] ConcatTree<'T> =
    | Empty
    | Leaf  of 'T
    | Fork  of ConcatTree<'T>*ConcatTree<'T>

  module ConcatTree =
    open MutableStack

    module Details =
      module Loops =
        let rec fold (stack : Stack<_>) (f : OptimizedClosures.FSharpFunc<_, _, _>) s t =
          match t with
          | ConcatTree.Empty ->
            if Stack.isNotEmpty stack then
              fold stack f s (Stack.pop stack)
            else
              s
          | ConcatTree.Leaf v ->
            let s = f.Invoke (s, v)
            if Stack.isNotEmpty stack then
              fold stack f s (Stack.pop stack)
            else
              s
          | ConcatTree.Fork (l, r) ->
            Stack.push stack r
            fold stack f s l
    open Details
  
    [<GeneralizableValue>]
    let empty = ConcatTree.Empty

    let inline leaf v = ConcatTree.Leaf v

    let inline concat (l : ConcatTree<'T>) (r : ConcatTree<'T>) : ConcatTree<'T> =
      match l, r with
      | ConcatTree.Empty  , _                 -> r
      | _                 , ConcatTree.Empty  -> l
      | _                 , _                 -> ConcatTree.Fork (l, r)

    let inline fold (f : 'S -> 'T -> 'S) (z : 'S) (t : ConcatTree<'T>) : 'S =
      let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt f
      Loops.fold (Stack 16) f z t

    let toArray (t : ConcatTree<'T>) : 'T [] =
      let ra = ResizeArray 16
      fold (fun _ v -> ra.Add v) () t
      ra.ToArray ()

    let toList (t : ConcatTree<'T>) : 'T list =
      fold (fun s v -> v::s) [] t |> List.rev

    let ofArray (vs : 'T []) : ConcatTree<'T> =
      let rec loop b e =
        if b = e then
          empty
        elif b + 1 = e then
          leaf (vs.[b])
        else
          let m = (b + e) / 2
          concat (loop b m) (loop m e)
      loop 0 vs.Length

  module Test =

    type Properties =
      static member ``ofArray/to*`` (vs : int []) =
        let ea = vs
        let aa = vs |> ConcatTree.ofArray |> ConcatTree.toArray

        let el = vs |> Array.toList
        let al = vs |> ConcatTree.ofArray |> ConcatTree.toList

        ea = aa && el = al

    open FsCheck
 
    let run () =
      let config = { Config.Quick with MaxTest = 1000; MaxRejected = 1000 }
      Check.All<Properties> config

module CT2 =
  open MutableStack

  type [<AbstractClass>] ConcatTree<'T> (isEmpty : bool) =
    class
      member x.IsEmpty = isEmpty

      member x.Fold (f : 'S -> 'T -> 'S) (z : 'S) : 'S =
        let stack = Stack<_> 16
        x.FoldImpl stack f z

      abstract FoldImpl: Stack<ConcatTree<'T>> -> ('S -> 'T -> 'S) -> 'S -> 'S
    end

  module ConcatTree =
    type [<Sealed>] Empty<'T> () =
      class
        inherit ConcatTree<'T> true

        override x.FoldImpl stack f s = 
          if Stack.isNotEmpty stack then
            let t = Stack.pop stack
            t.FoldImpl stack f s
          else
            s
      end

    type [<Sealed>] Leaf<'T> (v : 'T) =
      class
        inherit ConcatTree<'T> false

        override x.FoldImpl stack f s = 
          let s = f s v
          if Stack.isNotEmpty stack then
            let t = Stack.pop stack
            t.FoldImpl stack f s
          else
            s
      end
  
    type [<Sealed>] Fork<'T> (l : ConcatTree<'T>, r : ConcatTree<'T>) =
      class
        inherit ConcatTree<'T> false

        override x.FoldImpl stack f s =
          Stack.push stack r
          l.FoldImpl stack f s
      end
  
    [<GeneralizableValue>]
    let empty<'T> : ConcatTree<'T> = upcast Empty<'T> ()

    let inline leaf v  : ConcatTree<'T> = upcast Leaf v

    let inline concat (l : ConcatTree<'T>) (r : ConcatTree<'T>) : ConcatTree<'T> =
      if l.IsEmpty then
        r
      elif r.IsEmpty then
        l
      else
        upcast Fork (l, r)

    let inline fold (f : 'S -> 'T -> 'S) (z : 'S) (t : ConcatTree<'T>) : 'S =
      t.Fold f z

    let toArray (t : ConcatTree<'T>) : 'T [] =
      let ra = ResizeArray 16
      fold (fun _ v -> ra.Add v) () t
      ra.ToArray ()

    let toList (t : ConcatTree<'T>) : 'T list =
      fold (fun s v -> v::s) [] t |> List.rev

    let ofArray (vs : 'T []) : ConcatTree<'T> =
      let rec loop b e =
        if b = e then
          empty
        elif b + 1 = e then
          leaf (vs.[b])
        else
          let m = (b + e) / 2
          concat (loop b m) (loop m e)
      loop 0 vs.Length


  module Test =
    type Properties =
      static member ``ofArray/to*`` (vs : int []) =
        let ea = vs
        let aa = vs |> ConcatTree.ofArray |> ConcatTree.toArray

        let el = vs |> Array.toList
        let al = vs |> ConcatTree.ofArray |> ConcatTree.toList

        ea = aa && el = al

    open FsCheck
 
    let run () =
      let config = { Config.Quick with MaxTest = 1000; MaxRejected = 1000 }
      Check.All<Properties> config

module CT3 =
  type [<AbstractClass>] ConcatTree<'T> (nodeType : int) =
    class
      member x.IsEmpty = nodeType = 0
      member x.IsLeaf  = nodeType = 1
      member x.IsFork  = nodeType = 2

      abstract LeafValue : 'T
      abstract ForkValue : struct (ConcatTree<'T>*ConcatTree<'T>)

    end

  module ConcatTree =
    type [<Sealed>] Empty<'T> () =
      class
        inherit ConcatTree<'T> 0

        override x.LeafValue = failwith "Not a leaf"
        override x.ForkValue = failwith "Not a node"
      end

    type [<Sealed>] Leaf<'T> (v : 'T) =
      class
        inherit ConcatTree<'T> 1

        override x.LeafValue = v
        override x.ForkValue = failwith "Not a node"
      end
  
    type [<Sealed>] Fork<'T> (l : ConcatTree<'T>, r : ConcatTree<'T>) =
      class
        inherit ConcatTree<'T> 2

        override x.LeafValue = failwith "Not a leaf"
        override x.ForkValue = struct (l, r)
      end
  
    open MutableStack

    module Details =
      module Loops =
        let rec fold (stack : Stack<_>) (f : OptimizedClosures.FSharpFunc<_, _, _>) s (t : ConcatTree<_>) =
          if t.IsFork then
            let struct (l, r) = t.ForkValue
            Stack.push stack r
            fold stack f s l
          elif t.IsLeaf then
            let s = f.Invoke (s, t.LeafValue)
            if Stack.isNotEmpty stack then
              fold stack f s (Stack.pop stack)
            else
              s
          else
            if Stack.isNotEmpty stack then
              fold stack f s (Stack.pop stack)
            else
              s
    open Details

    [<GeneralizableValue>]
    let empty<'T> : ConcatTree<'T> = upcast Empty<'T> ()

    let inline leaf v  : ConcatTree<'T> = upcast Leaf v

    let inline concat (l : ConcatTree<'T>) (r : ConcatTree<'T>) : ConcatTree<'T> =
      if l.IsEmpty then
        r
      elif r.IsEmpty then
        l
      else
        upcast Fork (l, r)

    let inline fold (f : 'S -> 'T -> 'S) (z : 'S) (t : ConcatTree<'T>) : 'S =
      let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt f
      Loops.fold (Stack 16) f z t

    let toArray (t : ConcatTree<'T>) : 'T [] =
      let ra = ResizeArray 16
      fold (fun _ v -> ra.Add v) () t
      ra.ToArray ()

    let toList (t : ConcatTree<'T>) : 'T list =
      fold (fun s v -> v::s) [] t |> List.rev

    let ofArray (vs : 'T []) : ConcatTree<'T> =
      let rec loop b e =
        if b = e then
          empty
        elif b + 1 = e then
          leaf (vs.[b])
        else
          let m = (b + e) / 2
          concat (loop b m) (loop m e)
      loop 0 vs.Length


  module Test =
    type Properties =
      static member ``ofArray/to*`` (vs : int []) =
        let ea = vs
        let aa = vs |> ConcatTree.ofArray |> ConcatTree.toArray

        let el = vs |> Array.toList
        let al = vs |> ConcatTree.ofArray |> ConcatTree.toList

        ea = aa && el = al

    open FsCheck
 
    let run () =
      let config = { Config.Quick with MaxTest = 1000; MaxRejected = 1000 }
      Check.All<Properties> config

module PerformanceTests =
  open FSharp.Core.Printf

  open System
  open System.Collections
  open System.Diagnostics
  open System.IO
  open System.Text

  // now () returns current time in milliseconds since start
  let now : unit -> int64 =
    let sw = System.Diagnostics.Stopwatch ()
    sw.Start ()
    fun () -> sw.ElapsedMilliseconds

  // time estimates the time 'action' repeated a number of times
  let time repeat action =
    let inline cc i       = System.GC.CollectionCount i

    let v                 = action ()

    System.GC.Collect (2, System.GCCollectionMode.Forced, true)

    let bcc0, bcc1, bcc2  = cc 0, cc 1, cc 2
    let b                 = now ()

    for i in 1..repeat do
      action () |> ignore

    let e = now ()
    let ecc0, ecc1, ecc2  = cc 0, cc 1, cc 2

    v, e - b, ecc0 - bcc0, ecc1 - bcc1, ecc2 - bcc2

  type [<Struct>] QueueState = QueueState of obj

  type ValueType = int
  let valueCreator (v : int) = int v

  module CT0Run =
    open CT0

    let run (vs : ValueType []) =
      vs |> ConcatTree.ofArray |> ConcatTree.toArray |> ignore

  module CT1Run =
    open CT1

    let run (vs : ValueType []) =
      vs |> ConcatTree.ofArray |> ConcatTree.toArray |> ignore

  module CT2Run =
    open CT2

    let run (vs : ValueType []) =
      vs |> ConcatTree.ofArray |> ConcatTree.toArray |> ignore

  module CT3Run =
    open CT3

    let run (vs : ValueType []) =
      vs |> ConcatTree.ofArray |> ConcatTree.toArray |> ignore

  type TestResult =  TestResult of string*string*string*int64*int*int*int
  let testResult t y x tm cc0 cc1 cc2 = TestResult (t, y, x, tm, cc0, cc1, cc2)
  let testClass (TestResult (t, _, _, _, _, _, _))  = t
  let testY     (TestResult (_, y, _, _, _, _, _))  = y
  let testX     (TestResult (_, _, x, _, _, _, _))  = x

  let run () =
    use log = System.IO.File.CreateText "log.txt"

    let trace (l : string) = 
      log.WriteLine l
      System.Console.WriteLine l
    let tracef f = kprintf trace f

    let total   = 10000000
    let inners  = [| 100; 10000; 1000000|]

    let tests =
      let maxSize = Int32.MaxValue
      [|
        "ct0"   , maxSize, CT0Run.run
        "ct1"   , maxSize, CT1Run.run
        "ct2"   , 10000  , CT2Run.run
        "ct3"   , maxSize, CT3Run.run
      |]

    let results = ResizeArray 16

    for inner in inners do
      let outer = total / inner
      let vs = Array.init inner valueCreator

      let testClass = "run"
      let x         = sprintf "%d" inner

      for (name, maxSize, run) in tests do
        if inner > maxSize then
          tracef "Skipping - %s - total:%d (outer:%d - inner:%d) " name (outer*inner) outer inner
        else
          tracef "Running - %s - total:%d (outer:%d - inner:%d) " name (outer*inner) outer inner

          let _, ms, cc0, cc1, cc2 = time outer (fun () -> run vs)

          results.Add <| testResult testClass name x ms cc0 cc1 cc2

          tracef "  the result is %d ms (%d, %d, %d) cc" ms cc0 cc1 cc2

    let results = results.ToArray ()

    let testClasses = results |> Array.groupBy testClass

    for name, results in testClasses do
      let testXs      = results |> Array.groupBy testX |> Array.map fst
      let testYs      = results |> Array.groupBy testY
      let header  = "'Name" + (testXs |> Array.map (fun i -> ",'" + string i) |> Array.reduce (+))

      use perf      = new StreamWriter ("perf_" + name + ".csv")
      use cc        = new StreamWriter ("cc_"   + name + ".csv")
      let line sw l = (sw : StreamWriter).WriteLine (l : string)
      let linef sw f= kprintf (line sw) f

      line perf header
      line cc   header

      for name, result in testYs do
        let write sb s  = (sb : StringBuilder).Append (s : string) |> ignore
        let field sb s  = (sb : StringBuilder).Append ',' |> ignore; write sb s
        let fieldf sb f = kprintf (field sb) f
        let psb         = StringBuilder 16
        let csb         = StringBuilder 16
        write psb name
        write csb name
        let m = result |> Array.map (fun tc -> testX tc, tc) |> Map.ofArray
        for testInner in testXs do
          match m.TryFind testInner with
          | None    ->
            field psb ""
            field csb ""
          | Some tr ->
            let (TestResult (_, _, _, tm, cc0, cc1, cc2)) = tr
            // TODO: Bah this doesn't work. Want to visualize as different dimensions
            let cc =
              if cc2 > 0 then 
                100000*cc2
              elif cc1 > 0 then
                1000*cc1
              else
                cc0
            fieldf psb "%d" tm
            fieldf csb "%d" cc

        line perf <| psb.ToString ()
        line cc   <| csb.ToString ()

[<EntryPoint>]
let main argv = 
#if DEBUG
  CT0.Test.run ()
  CT1.Test.run ()
  CT2.Test.run ()
  CT3.Test.run ()
#else
  PerformanceTests.run ()
#endif
  0