FingerTree.fs

#nowarn "25"
module Reference =
  type Node<'T>   =
    | Node2 of 'T*'T
    | Node3 of 'T*'T*'T

  type Digit<'T>  =
    | Digit1    of 'T
    | Digit2    of 'T*'T
    | Digit3    of 'T*'T*'T
    | Digit4    of 'T*'T*'T*'T

  type FingerTree<'T> =
    | Empty
    | Single    of 'T
    | Deep      of Digit<'T>*FingerTree<Node<'T>>*Digit<'T>

  module FingerTree =
    type [<Struct>] Uncons<'T> =
      | NoResult
      | Result    of 'T*FingerTree<'T>

    module Details =
      let inline adapt2 f = OptimizedClosures.FSharpFunc<_,_,_>.Adapt f
      let inline invoke2 (f : OptimizedClosures.FSharpFunc<_,_,_>) a b = f.Invoke(a, b)

      let inline ht h t = Result (h, t)

      let inline consDigit d v =
        match d with
        | Digit1 v0         -> Digit2 (v0,v)
        | Digit2 (v0,v1)    -> Digit3 (v0,v1,v)
        | Digit3 (v0,v1,v2) -> Digit4 (v0,v1,v2,v)
        | Digit4 _          -> failwith "Digit3"

      let inline headTailDigit d =
        match d with
        | Digit1 _                -> failwith "Digit1"
        | Digit2 (v0, v1)         -> struct (v0, Digit1 v1)
        | Digit3 (v0, v1, v2)     -> struct (v0, Digit2 (v1, v2))
        | Digit4 (v0, v1, v2, v3) -> struct (v0, Digit3 (v1, v2, v3))

      let inline foldDigit f s d =
        match d with
        | Digit1 v0               ->
          let s = invoke2 f s v0
          s
        | Digit2 (v0, v1)         ->
          let s = invoke2 f s v0
          let s = invoke2 f s v1
          s
        | Digit3 (v0, v1, v2)     ->
          let s = invoke2 f s v0
          let s = invoke2 f s v1
          let s = invoke2 f s v2
          s
        | Digit4 (v0, v1, v2, v3) ->
          let s = invoke2 f s v0
          let s = invoke2 f s v1
          let s = invoke2 f s v2
          let s = invoke2 f s v3
          s

      let rec foldImpl<'S, 'T> (f : OptimizedClosures.FSharpFunc<'S, 'T, 'S>) (s : 'S) (dq : FingerTree<'T>) : 'S =
        match dq with
        | Empty               -> s
        | Single  v0          -> invoke2 f s v0
        | Deep    (hh,ss,tt)  ->
          let ff s n =
            match n with
            | Node2 (v0,v1) ->
              let s = invoke2 f s v0
              let s = invoke2 f s v1
              s
            | Node3 (v0,v1,v2) ->
              let s = invoke2 f s v0
              let s = invoke2 f s v1
              let s = invoke2 f s v2
              s
          let ff = adapt2 ff
          let s = foldDigit               f   s hh
          let s = foldImpl<'S, Node<'T>>  ff  s ss
          let s = foldDigit               f   s tt
          s
    open Details

    [<GeneralizableValue>]
    let empty = Empty

    let rec tryUncons<'T> (dq : FingerTree<'T>) : Uncons<'T> =
      match dq with
      | Empty                               -> NoResult
      | Single  v                           -> ht v Empty
      | Deep    (Digit1 v0,Empty,Digit1 v1) -> ht v0 (Single v1)
      | Deep    (Digit1 v0,Empty,t)         ->
        let struct (v1,ds) = headTailDigit t
        ht v0 (Deep (Digit1 v1,Empty,ds))
      | Deep    (Digit1 v0,s,t)             ->
        match tryUncons<Node<'T>> s with
        | NoResult -> failwith "NoResult"
        | Result (n, ns) ->
          match n with
          | Node2 (v1, v2)      -> ht v0 (Deep (Digit2 (v1,v2),ns,t))
          | Node3 (v1, v2, v3)  -> ht v0 (Deep (Digit3 (v1,v2,v3),ns,t))
      | Deep    (h,s,t)                     ->
        let struct (v0,ds) = headTailDigit h
        ht v0 (Deep (ds,s,t))

    let rec conj<'T> (v : 'T) (dq : FingerTree<'T>) : FingerTree<'T> =
      match dq with
      | Empty                               -> Single v
      | Single  v0                          -> Deep (Digit1 v0, Empty, Digit1 v)
      | Deep    (h,s,Digit4 (v0,v1,v2,v3))  -> Deep (h,conj<Node<'T>> (Node3 (v0,v1,v2)) s ,Digit2 (v3, v))
      | Deep    (h,s,t)                     -> Deep (h,s,consDigit t v)

    let fold (f : 'S -> 'T -> 'S) (s : 'S) (dq : FingerTree<'T>) : 'S =
      let f = adapt2 f
      foldImpl f s dq

    let fromArray vs : FingerTree<'T> =
      Array.fold (fun dq v -> conj v dq) empty vs

    let toArray (dq : FingerTree<'T>) : 'T [] =
      let ra = ResizeArray 16
      fold (fun (ra : ResizeArray<_>) v -> ra.Add v; ra) ra dq |> ignore
      ra.ToArray ()

module DoubleListDequeue =
  type [<Struct>] Dequeue<'T> = Dequeue of 'T list*'T list

  module Dequeue =
    type [<Struct>] Uncons<'T> =
      | NoResult
      | Result    of 'T*Dequeue<'T>

    [<GeneralizableValue>]
    let empty<'T> : Dequeue<'T> = Dequeue ([], [])

    let inline conj v (Dequeue (t, b)) : Dequeue<'T> =
      match t with
      | [] -> Dequeue (v::List.rev b,[])
      | _  -> Dequeue (t,v::b)

    let inline cons v (Dequeue (t, b)) : Dequeue<'T> =
      Dequeue (v::t,b)

    (*
    let inline tryUnconj (Dequeue (t, b)) : Uncons<'T> =
      match t, b with
      | []    , _   -> NoResult
      | [v]   , []  -> Result (v, empty)
      | vs    , []  ->
        let v::vs =
      if List.isEmpty t then
        NoResult
      elif List.isEmpty b then
        let v::vs = t
        let v::vs = b
        Result (v, Dequeue (t, vs))
      else
        let v::vs = b
        Result (v, Dequeue (t, vs))
    *)

    let inline tryUncons (Dequeue (t, b)) : Uncons<'T> =
      match t with
      | []    -> NoResult
      | [v]   -> Result (v, Dequeue (List.rev b, []))
      | v::vs -> Result (v, Dequeue (vs, b))

    let inline fromArray vs : Dequeue<'T> =
      Dequeue (List.ofArray vs, [])

    let inline toArray (Dequeue (t, b)) : 'T [] =
      Array.append (t |> List.toArray) (b |> List.rev |> List.toArray)

module Quick =
  module Details =
    let inline noValue<'T>  = Unchecked.defaultof<'T>
    let inline adapt2 f     = OptimizedClosures.FSharpFunc<_,_,_>.Adapt f
    let inline invoke2 (f : OptimizedClosures.FSharpFunc<_,_,_>) a b = f.Invoke(a, b)

  open Details

  open System.Runtime.InteropServices

  type Node<'T> ( nc : int
                , n0 : 'T
                , n1 : 'T
                , n2 : 'T
                ) =
    class
      member x.NodeCount  = nc
      member x.Node0      = n0
      member x.Node1      = n1
      member x.Node2      = n2
    end

  type [<AbstractClass>] FingerTree<'T>() =
    class
      // TODO: The line below reduces performance by 3x. Is there anyway to
      //  cache an empty fingertree without sacrificing the performance?
      //static let empty : FingerTree<'T> = upcast Empty<'T>()
      static member Empty : FingerTree<'T> = upcast Empty<'T>()

      abstract IsEmpty    : bool
      abstract TryPopFront: [<Out>] h : byref<'T>*[<Out>] t : byref<FingerTree<'T>> -> bool
      abstract PushBack   : 'T   -> FingerTree<'T>
      abstract Fold       : OptimizedClosures.FSharpFunc<'S,'T,'S>*'S -> 'S
    end

  and [<Sealed>] Empty<'T>() =
    class
      inherit FingerTree<'T>()

      override x.IsEmpty                : bool            = true
      override x.TryPopFront  (rv, rdq) : bool            = false
      override x.PushBack     v         : FingerTree<'T>  = upcast Single<'T>(v)
      override x.Fold         (f, s)    : 'S              = s
    end

  and [<Sealed>] Single<'T>(v0 : 'T) =
    class
      inherit FingerTree<'T>()

      override x.IsEmpty                : bool            = false
      override x.TryPopFront  (rv, rdq) : bool            =
        rv  <- v0
        rdq <- FingerTree<'T>.Empty
        true
      override x.PushBack v             : FingerTree<'T>  = upcast Deep<'T>(1, v0, noValue<_>, noValue<_>, noValue<_>, FingerTree<Node<'T>>.Empty, 1, v, noValue<_>, noValue<_>, noValue<_>)
      override x.Fold         (f, s)    : 'S              = invoke2 f s v0
    end

  // TODO: Can nested arrays be merged too?
  and [<Sealed>] Deep<'T> ( hc : int
                          , h0 : 'T
                          , h1 : 'T
                          , h2 : 'T
                          , h3 : 'T
                          , spine : FingerTree<Node<'T>>
                          , tc : int
                          , t0 : 'T
                          , t1 : 'T
                          , t2 : 'T
                          , t3 : 'T
                          ) =
    class
      inherit FingerTree<'T>()

#if DEBUG
      do
        assert (hc > 0)
        assert (hc < 5)
        assert (tc > 0)
        assert (tc < 5)
#endif

      override x.IsEmpty : bool = false
      override x.TryPopFront (rv, rdq) : bool =
        if hc > 1 then
          // extract head from head digits
          let v = h0
          rv  <- v
          rdq <- Deep (hc - 1, h1, h2, h3, noValue<_>, spine, tc, t0, t1, t2, t3)

          true
        elif not spine.IsEmpty then
          let b, h, t = spine.TryPopFront ()
          assert b
          rv  <- h0
          rdq <- Deep (h.NodeCount, h.Node0, h.Node1, h.Node2, noValue<_>, t, tc, t0, t1, t2, t3)

          true
        elif tc > 1 then
          rv  <- h0
          rdq <-
            match tc with
            | 2 -> Deep (1, t0, noValue<_>, noValue<_>, noValue<_>, spine, 1, t1, noValue<_>, noValue<_>, noValue<_>)
            | 3 -> Deep (2, t0, t1, noValue<_>, noValue<_>, spine, 1, t2, noValue<_>, noValue<_>, noValue<_>)
            | 4 -> Deep (2, t0, t1, noValue<_>, noValue<_>, spine, 2, t2, t3, noValue<_>, noValue<_>)
            | _ -> failwith "PushBack"

          true
        else
          rv  <- h0
          rdq <- Single t0

          true
      override x.PushBack v : FingerTree<'T> =
        match tc with
        | 1 -> upcast Deep<'T>(hc, h0, h1, h2, h3, spine, 2, t0, v, noValue<_>, noValue<_>)
        | 2 -> upcast Deep<'T>(hc, h0, h1, h2, h3, spine, 3, t0, t1, v, noValue<_>)
        | 3 -> upcast Deep<'T>(hc, h0, h1, h2, h3, spine, 4, t0, t1, t2, v)
        | 4 ->
          // split tail into 2
          let node = Node(3, t0, t1, t2)
          upcast Deep<'T>(hc, h0, h1, h2, h3, spine.PushBack node, 2, t3, v, noValue<_>, noValue<_>)
        | _ -> failwith "PushBack"
      override x.Fold         (f, s)    : 'S              =
        let s =
          match hc with
          | 1 ->
            let s = invoke2 f s h0
            s
          | 2 ->
            let s = invoke2 f s h0
            let s = invoke2 f s h1
            s
          | 3 ->
            let s = invoke2 f s h0
            let s = invoke2 f s h1
            let s = invoke2 f s h2
            s
          | 4 ->
            let s = invoke2 f s h0
            let s = invoke2 f s h1
            let s = invoke2 f s h2
            let s = invoke2 f s h3
            s
          | _ -> failwith "Fold"
        // TODO: Figure out how to avoid creating folders
        let sf ss (nn : Node<_>) =
          match nn.NodeCount with
          | 2 ->
            let ss = invoke2 f ss nn.Node0
            let ss = invoke2 f ss nn.Node1
            ss
          | 3 ->
            let ss = invoke2 f ss nn.Node0
            let ss = invoke2 f ss nn.Node1
            let ss = invoke2 f ss nn.Node2
            ss
          | _ -> failwith "Fold"
        let sf = adapt2 sf
        let s = spine.Fold (sf, s)
        let s =
          match tc with
          | 1 ->
            let s = invoke2 f s t0
            s
          | 2 ->
            let s = invoke2 f s t0
            let s = invoke2 f s t1
            s
          | 3 ->
            let s = invoke2 f s t0
            let s = invoke2 f s t1
            let s = invoke2 f s t2
            s
          | 4 ->
            let s = invoke2 f s t0
            let s = invoke2 f s t1
            let s = invoke2 f s t2
            let s = invoke2 f s t3
            s
          | _ -> failwith "Fold"
        s
    end

  module FingerTree =

    type [<Struct>] PopResult<'T> =
      | NoResult
      | Result    of 'T*FingerTree<'T>

    [<GeneralizableValue>]
    let empty<'T> = FingerTree<'T>.Empty

    let inline isEmpty (dq : FingerTree<'T>) : bool =
      dq.IsEmpty

    let inline tryPopFront (dq : FingerTree<'T>) : PopResult<'T> =
      let b, h, t = dq.TryPopFront ()
      if b then
        Result (h, t)
      else
        NoResult

    let inline pushBack v (dq : FingerTree<'T>) : FingerTree<'T> =
      dq.PushBack v

    let inline fold (f : 'S -> 'T -> 'S) (s : 'S) (dq : FingerTree<'T>) : 'S =
      let f = adapt2 f
      dq.Fold (f, s)

    let inline fromArray vs : FingerTree<'T> =
      Array.fold (fun dq v -> pushBack v dq) empty vs

    let toArray (dq : FingerTree<'T>) : 'T [] =
      let ra = ResizeArray 16
      fold (fun (ra : ResizeArray<_>) v -> ra.Add v; ra) ra dq |> ignore
      ra.ToArray ()

module ArrayDequeue =
  type [<Struct>] Dequeue<'T> = Dequeue of 'T []

  module Dequeue =
    type [<Struct>] Uncons<'T> =
      | NoResult
      | Result    of 'T*Dequeue<'T>

    [<GeneralizableValue>]
    let empty<'T> : Dequeue<'T> = Dequeue Array.empty

    let inline conj v (Dequeue vs) : Dequeue<'T> =
      let nvs = Array.zeroCreate (vs.Length + 1)
      System.Array.Copy (vs, nvs, vs.Length)
      nvs.[vs.Length] <- v
      Dequeue nvs

    let inline tryUncons (Dequeue vs) : Uncons<'T> =
      if vs.Length = 0 then
        NoResult
      else
        let nvs = Array.zeroCreate (vs.Length - 1)
        System.Array.Copy (vs, 1, nvs, 0, vs.Length - 1)
        Result (vs.[0], Dequeue nvs)

    let inline fromArray vs : Dequeue<'T> =
      Dequeue (Array.copy vs)

    let inline toArray (Dequeue vs) : 'T [] =
      Array.copy vs

open ArrayDequeue.Dequeue

module LazyDequeue =
  type [<Struct>] Dequeue<'T> = Dequeue  of 'T list*Lazy<'T list>*int*'T list*int

  module Dequeue =
    type [<Struct>] Uncons<'T> =
      | NoResult
      | Result    of 'T*Dequeue<'T>

    [<GeneralizableValue>]
    let empty<'T> : Dequeue<'T> = Dequeue ([], lazy [], 0, [], 0)

    let isEmpty (Dequeue (_, _, lf, _, _)) = lf = 0

    let inline checkW (Dequeue (w, f, lf, r, lr) as dq) =
      if List.isEmpty w then
        Dequeue (f.Value, f, lf, r, lr)
      else
        dq

    let inline checkR (Dequeue (w, f, lf, r, lr) as dq) =
      if lr <= lf then
        dq
      else
        let ww = f.Value
        Dequeue (ww, lazy (ww @ List.rev r), lf + lr, [], 0)

    let inline queue dq = checkW (checkR dq)

    let conj v (Dequeue (w, f, lf, r, lr) as dq) =
      queue (Dequeue (w, f, lf, v::r, lr + 1))

    let inline lazyTail (ll : Lazy<_>) =
      lazy (
        let (_::tt) = ll.Value
        tt
        )

    let tryUncons (Dequeue (w, f, lf, r, lr) as dq) =
      match w with
      | v::vs   ->
        let t = queue (Dequeue (vs, lazyTail f, lf - 1, r, lr))
        Result (v, t)
      | _       -> 
        NoResult

    let fromArray vs : Dequeue<'T> =
      Array.fold (fun dq v -> conj v dq) empty vs

    let toArray (Dequeue (w, f, lf, r, lr) as dq) : 'T [] =
      let ra = ResizeArray 16
      let rec loop dq =
        match tryUncons dq with
        | NoResult      -> ()
        | Result (h, t) ->
          ra.Add h
          loop t
      loop dq
      ra.ToArray ()

module Lazy2Dequeue =
  // Based on Chris Okasaki's Physicist Queue

  // With a home-brewn Lazy2 implementation for hopefully lower overhead

  type Lazy2<'T when 'T: not struct>(c: unit -> 'T) =
    class
      [<VolatileField>]
      let mutable bc  = c |> box
      let mutable v   = Unchecked.defaultof<'T>

      member x.Value : 'T =
        let lbc = bc
        if isNull lbc then
          v
        else
          let lc = lbc :?> unit -> 'T
          v   <- lc ()
          bc  <- null
          v
    end

  module Lazy2 =
    let direct  (v : 'T)         = Lazy2<'T>(fun () -> v)
    let delayed (c : unit -> 'T) = Lazy2<'T>(c)

  type [<Struct>] Dequeue<'T> = Dequeue  of 'T list*Lazy2<'T list>*int*'T list*int

  module Dequeue =
    type [<Struct>] Uncons<'T> =
      | NoResult
      | Result    of 'T*Dequeue<'T>

    [<GeneralizableValue>]
    let empty<'T> : Dequeue<'T> = Dequeue ([], Lazy2.direct [], 0, [], 0)

    let isEmpty (Dequeue (_, _, lf, _, _)) = lf = 0

    let inline checkW (Dequeue (w, f, lf, r, lr) as dq) =
      if List.isEmpty w then
        Dequeue (f.Value, f, lf, r, lr)
      else
        dq

    let inline checkR (Dequeue (w, f, lf, r, lr) as dq) =
      if lr <= lf then
        dq
      else
        let ww = f.Value
        Dequeue (ww, Lazy2.delayed (fun () -> ww @ List.rev r), lf + lr, [], 0)

    let inline queue dq = checkW (checkR dq)

    let conj v (Dequeue (w, f, lf, r, lr) as dq) =
      queue (Dequeue (w, f, lf, v::r, lr + 1))

    let inline lazyTail (ll : Lazy2<_>) =
      Lazy2.delayed (fun () ->
        let (_::tt) = ll.Value
        tt
        )

    let tryUncons (Dequeue (w, f, lf, r, lr) as dq) =
      match w with
      | v::vs   ->
        let t = queue (Dequeue (vs, lazyTail f, lf - 1, r, lr))
        Result (v, t)
      | _       -> 
        NoResult

    let fromArray vs : Dequeue<'T> =
      Array.fold (fun dq v -> conj v dq) empty vs

    let toArray (Dequeue (w, f, lf, r, lr) as dq) : 'T [] =
      let ra = ResizeArray 16
      let rec loop dq =
        match tryUncons dq with
        | NoResult      -> ()
        | Result (h, t) ->
          ra.Add h
          loop t
      loop dq
      ra.ToArray ()

module CsFingerTree =
  open FingerTree

  let empty<'T> : FTree<'T> = upcast EmptyFTree<'T>()

  let inline fromArray vs =
    Array.fold (fun (dq : FTree<'T>) v -> dq.Push_Back v) empty vs

  let inline toArray (dq : FTree<'T>) = dq.ToSequence () |> Seq.toArray

  let inline conj v (dq : FTree<'T>) = dq.Push_Back v

  let inline tryUncons (dq : FTree<'T>) =
    let view = dq.LeftView ()
    if isNull view then
      None
    else
      Some (view.head, view.ftTail)

module FsFingerTree =
  open Fingertrees
  open Monoid
  open FingerTree
  open RandomAccess

  let empty = Empty

  let inline fromArray arr = Array.fold (Operations.append) Empty arr

  let inline toArray (dq : FingerTree<'T, 'U>) = 
    let ra = ResizeArray 16
    let rec loop dq =
      match Operations.popl dq with
      | EmptyTree   -> ()
      | View (h, t) ->
        ra.Add h
        loop t
    loop dq
    ra.ToArray ()

  let inline conj v dq = Operations.append dq v

  let inline tryUncons dq = Operations.popl dq

module FunctionalTests =
  open FsCheck
  open System.Collections.Generic

  type QueueOps<'T> =
    | TryUncons
    | Conj        of 'T

  type [<Struct>] Uncons<'Dequeue, 'T> =
    | NoResult
    | Result    of 'T*'Dequeue

  type IDequeueAdapter<'Dequeue, 'T> =
    interface
      abstract Empty        : 'Dequeue
      abstract FromArray    : 'T []     -> 'Dequeue
      abstract ToArray      : 'Dequeue  -> 'T []
      abstract TryUncons  : 'Dequeue  -> Uncons<'Dequeue, 'T>
      abstract Conj         : 'T        -> 'Dequeue  -> 'Dequeue
    end

  type Properties<'T, 'Dequeue when 'T : (new: unit -> 'T) and 'T :> IDequeueAdapter<'Dequeue, int>> () =
    static let adapter = new 'T ()

    static member ``fromArray => toArray should yield input`` (vs : int []) =
      let dq  = adapter.FromArray vs

      let e   = vs
      let a   = adapter.ToArray dq

      e = a

    static member ``tryHead/conj should have queue semantics`` (vs : QueueOps<int> []) =
      let oracle          = Queue<int> ()
      let mutable actual  = adapter.Empty

      let rec loop i =
        if i < vs.Length then
          match vs.[i] with
          | TryUncons ->
            match adapter.TryUncons actual with
            | NoResult ->
              oracle.Count = 0 && loop (i + 1)
            | Result (h, t) ->
              actual <- t
              oracle.Count > 0 && oracle.Dequeue () = h && loop (i + 1)
          | Conj v      ->
            oracle.Enqueue v
            actual <- adapter.Conj v actual
            loop (i + 1)
        else
          true
      loop 0

    static member ``tryHead/conj`` (vs : int []) =
      let dq = Array.fold (fun dq v -> adapter.Conj v dq) adapter.Empty vs

      let ra = ResizeArray 16

      let rec pop dq =
        match adapter.TryUncons dq with
        | NoResult -> ()
        | Result (h, t) ->
          ra.Add h
          pop t
      pop dq

      let e = vs
      let a = ra.ToArray ()

      e = a

  module ReferenceDequeue =
    open Reference

    type Dequeue = FingerTree<int>
    type Adapter() = 
      interface IDequeueAdapter<Dequeue, int> with
        member x.Empty              = FingerTree.empty
        member x.FromArray    vs    = FingerTree.fromArray vs
        member x.ToArray      dq    = FingerTree.toArray dq
        member x.TryUncons    dq    =
          match FingerTree.tryUncons dq with
          | FingerTree.NoResult      -> NoResult
          | FingerTree.Result (h, t) -> Result (h, t)
        member x.Conj         v dq  = FingerTree.conj v dq
    type Properties = Properties<Adapter, Dequeue>

  module QuickDequeue =
    open Quick

    type Dequeue = FingerTree<int>
    type Adapter() = 
      interface IDequeueAdapter<Dequeue, int> with
        member x.Empty              = FingerTree.empty
        member x.FromArray    vs    = FingerTree.fromArray vs
        member x.ToArray      dq    = FingerTree.toArray dq
        member x.TryUncons    dq    =
          match FingerTree.tryPopFront dq with
          | FingerTree.NoResult      -> NoResult
          | FingerTree.Result (h, t) -> Result (h, t)
        member x.Conj         v dq  = FingerTree.pushBack v dq
    type Properties = Properties<Adapter, Dequeue>

  module ArrayDequeue =
    open ArrayDequeue
    type Dequeue = Dequeue<int>
    type Adapter() = 
      interface IDequeueAdapter<Dequeue, int> with
        member x.Empty              = Dequeue.empty
        member x.FromArray    vs    = Dequeue.fromArray vs
        member x.ToArray      dq    = Dequeue.toArray dq
        member x.TryUncons    dq    =
          match Dequeue.tryUncons dq with
          | Dequeue.NoResult      -> NoResult
          | Dequeue.Result (h, t) -> Result (h, t)
        member x.Conj         v dq  = Dequeue.conj v dq
    type Properties = Properties<Adapter, Dequeue>

  module DoubleListDequeue =
    open DoubleListDequeue
    type Dequeue = Dequeue<int>
    type Adapter() = 
      interface IDequeueAdapter<Dequeue, int> with
        member x.Empty              = Dequeue.empty
        member x.FromArray    vs    = Dequeue.fromArray vs
        member x.ToArray      dq    = Dequeue.toArray dq
        member x.TryUncons    dq    =
          match Dequeue.tryUncons dq with
          | Dequeue.NoResult      -> NoResult
          | Dequeue.Result (h, t) -> Result (h, t)
        member x.Conj         v dq  = Dequeue.conj v dq

    type Properties = Properties<Adapter, Dequeue>

  module LazyDequeue =
    open LazyDequeue
    type Dequeue = Dequeue<int>
    type Adapter() = 
      interface IDequeueAdapter<Dequeue, int> with
        member x.Empty              = Dequeue.empty
        member x.FromArray    vs    = Dequeue.fromArray vs
        member x.ToArray      dq    = Dequeue.toArray dq
        member x.TryUncons    dq    =
          match Dequeue.tryUncons dq with
          | Dequeue.NoResult      -> NoResult
          | Dequeue.Result (h, t) -> Result (h, t)
        member x.Conj         v dq  = Dequeue.conj v dq

    type Properties = Properties<Adapter, Dequeue>

  module Lazy2Dequeue =
    open Lazy2Dequeue
    type Dequeue = Dequeue<int>
    type Adapter() = 
      interface IDequeueAdapter<Dequeue, int> with
        member x.Empty              = Dequeue.empty
        member x.FromArray    vs    = Dequeue.fromArray vs
        member x.ToArray      dq    = Dequeue.toArray dq
        member x.TryUncons    dq    =
          match Dequeue.tryUncons dq with
          | Dequeue.NoResult      -> NoResult
          | Dequeue.Result (h, t) -> Result (h, t)
        member x.Conj         v dq  = Dequeue.conj v dq

    type Properties = Properties<Adapter, Dequeue>

  module CsFingerTreeDequeue =
    type Dequeue = FingerTree.FTree<int>
    type Adapter() = 
      interface IDequeueAdapter<Dequeue, int> with
        member x.Empty              = CsFingerTree.empty
        member x.FromArray    vs    = CsFingerTree.fromArray vs
        member x.ToArray      dq    = CsFingerTree.toArray dq
        member x.TryUncons    dq    =
          match CsFingerTree.tryUncons dq with
          | None        -> NoResult
          | Some (h, t) -> Result (h, t)
        member x.Conj         v dq  = CsFingerTree.conj v dq

    type Properties = Properties<Adapter, Dequeue>

  module FsFingerTreeDequeue =
    open Fingertrees
    open FingerTree
    open Monoid
    open RandomAccess

    type Dequeue = FingerTree<Size, Value<int>>
    type Adapter() = 
      interface IDequeueAdapter<Dequeue, int> with
        member x.Empty              = FsFingerTree.empty
        member x.FromArray    vs    = vs |> Array.map Value |> FsFingerTree.fromArray
        member x.ToArray      dq    = dq |> FsFingerTree.toArray |> Array.map (fun (Value v) -> v)
        member x.TryUncons    dq    =
          match FsFingerTree.tryUncons dq with
          | EmptyTree           -> NoResult
          | View ((Value h), t) -> Result (h, t)
        member x.Conj         v dq  = FsFingerTree.conj (Value v) dq

    type Properties = Properties<Adapter, Dequeue>

  let run () =
    let config = { Config.Quick with MaxTest = 1000; MaxRejected = 1000 }
    printfn "ReferenceDequeue Properties"
    Check.All<ReferenceDequeue.Properties>    config
    printfn "QuickDequeue Properties"
    Check.All<QuickDequeue.Properties>        config
    printfn "ArrayDequeue Properties"
    Check.All<ArrayDequeue.Properties>        config
    printfn "DoubleListDequeue Properties"
    Check.All<DoubleListDequeue.Properties>   config
    printfn "LazyDequeue Properties"
    Check.All<LazyDequeue.Properties>         config
    printfn "Lazy2Dequeue Properties"
    Check.All<Lazy2Dequeue.Properties>        config
    printfn "CsFingerTreeDequeue Properties"
    Check.All<CsFingerTreeDequeue.Properties> config
    printfn "FsFingerTreeDequeue Properties"
    Check.All<FsFingerTreeDequeue.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 DoubleListRun =
    open DoubleListDequeue

    let init (vs : ValueType []) =
      Dequeue.fromArray vs |> box |> QueueState

    let pushBack (n : int) (QueueState (:? Dequeue<ValueType> as dq)) =
      let rec loop dq i =
        if i > 0 then
          let dq = Dequeue.conj i dq
          loop dq (i - 1)
        else
          dq
      loop dq n |> box |> QueueState

    let popFront (n : int) (QueueState (:? Dequeue<ValueType> as dq)) =
      let rec loop dq i =
        if i > 0 then
          match Dequeue.tryUncons dq with
          | Dequeue.NoResult -> failwith "Aborted"
          | Dequeue.Result (h, t) ->
            loop t (i - 1)
        else
          dq
      loop dq n |> box |> QueueState

  module LazyDequeueRun =
    open LazyDequeue

    let init (vs : ValueType []) =
      Dequeue.fromArray vs |> box |> QueueState

    let pushBack (n : int) (QueueState (:? Dequeue<ValueType> as dq)) =
      let rec loop dq i =
        if i > 0 then
          let dq = Dequeue.conj i dq
          loop dq (i - 1)
        else
          dq
      loop dq n |> box |> QueueState

    let popFront (n : int) (QueueState (:? Dequeue<ValueType> as dq)) =
      let rec loop dq i =
        if i > 0 then
          match Dequeue.tryUncons dq with
          | Dequeue.NoResult -> failwith "Aborted"
          | Dequeue.Result (h, t) ->
            loop t (i - 1)
        else
          dq
      loop dq n |> box |> QueueState

  module Lazy2DequeueRun =
    open Lazy2Dequeue

    let init (vs : ValueType []) =
      Dequeue.fromArray vs |> box |> QueueState

    let pushBack (n : int) (QueueState (:? Dequeue<ValueType> as dq)) =
      let rec loop dq i =
        if i > 0 then
          let dq = Dequeue.conj i dq
          loop dq (i - 1)
        else
          dq
      loop dq n |> box |> QueueState

    let popFront (n : int) (QueueState (:? Dequeue<ValueType> as dq)) =
      let rec loop dq i =
        if i > 0 then
          match Dequeue.tryUncons dq with
          | Dequeue.NoResult -> failwith "Aborted"
          | Dequeue.Result (h, t) ->
            loop t (i - 1)
        else
          dq
      loop dq n |> box |> QueueState

  module ArrayRun =
    open ArrayDequeue

    let init (vs : ValueType []) =
      Dequeue.fromArray vs |> box |> QueueState

    let pushBack (n : int) (QueueState (:? Dequeue<ValueType> as dq)) =
      let rec loop dq i =
        if i > 0 then
          let dq = Dequeue.conj i dq
          loop dq (i - 1)
        else
          dq
      loop dq n |> box |> QueueState

    let popFront (n : int) (QueueState (:? Dequeue<ValueType> as dq)) =
      let rec loop dq i =
        if i > 0 then
          match Dequeue.tryUncons dq with
          | Dequeue.NoResult -> failwith "Aborted"
          | Dequeue.Result (h, t) ->
            loop t (i - 1)
        else
          dq
      loop dq n |> box |> QueueState

  module ReferenceRun =
    open Reference

    let init (vs : ValueType []) =
      FingerTree.fromArray vs |> box |> QueueState

    let pushBack (n : int) (QueueState (:? FingerTree<ValueType> as dq)) =
      let rec loop dq i =
        if i > 0 then
          let dq = FingerTree.conj i dq
          loop dq (i - 1)
        else
          dq
      loop dq n |> box |> QueueState

    let popFront (n : int) (QueueState (:? FingerTree<ValueType> as dq)) =
      let rec loop dq i =
        if i > 0 then
          match FingerTree.tryUncons dq with
          | FingerTree.NoResult -> failwith "Aborted"
          | FingerTree.Result (h, t) ->
            loop t (i - 1)
        else
          dq
      loop dq n |> box |> QueueState

  module MutableRun =
    open System.Collections.Generic

    let init (vs : ValueType []) =
      Queue<ValueType> vs |> box |> QueueState

    let pushBack (n : int) (QueueState (:? Queue<ValueType> as dq)) =
      let rec loop (dq : Queue<ValueType>) i =
        if i > 0 then
          dq.Enqueue i
          loop dq (i - 1)
        else
          dq
      loop dq n |> box |> QueueState

    let popFront (n : int) (QueueState (:? Queue<ValueType> as dq)) =
      let rec loop (dq : Queue<ValueType>) i =
        if i > 0 then
          if dq.Count = 0 then
            failwith "Aborted"
          else
            dq.Dequeue () |> ignore
            loop dq (i - 1)
        else
          dq
      loop dq n |> box |> QueueState

  module QuickRun =
    open Quick

    let init (vs : ValueType []) =
      FingerTree.fromArray vs |> box |> QueueState

    let pushBack (n : int) (QueueState (:? FingerTree<ValueType> as dq)) =
      let rec loop (dq : FingerTree<ValueType>) i =
        if i > 0 then
          let dq = dq.PushBack i
          loop dq (i - 1)
        else
          dq
      loop dq n |> box |> QueueState

    let popFront (n : int) (QueueState (:? FingerTree<ValueType> as dq)) =
      let rec loop (dq : FingerTree<ValueType>) i =
        if i > 0 then
          let b, h, t = dq.TryPopFront ()
          if not b then
            failwith "Aborted"
          else
            loop t (i - 1)
        else
          dq
      loop dq n |> box |> QueueState

  module CsRun =
    open FingerTree
    open CsFingerTree

    let init (vs : ValueType []) =
      CsFingerTree.fromArray vs |> box |> QueueState

    let pushBack (n : int) (QueueState (:? FTree<ValueType> as dq)) =
      let rec loop (dq : FTree<ValueType>) i =
        if i > 0 then
          let dq = dq.Push_Back i
          loop dq (i - 1)
        else
          dq
      loop dq n |> box |> QueueState

    let popFront (n : int) (QueueState (:? FTree<ValueType> as dq)) =
      let rec loop (dq : FTree<ValueType>) i =
        if i > 0 then
          let view = dq.LeftView ()
          if isNull view then
            failwith "Aborted"
          else
            loop view.ftTail (i - 1)
        else
          dq
      loop dq n |> box |> QueueState

  module FsRun =
    open Fingertrees
    open Monoid
    open FingerTree
    open RandomAccess

    let init (vs : ValueType []) =
      let dq = vs |> Array.map Value |> FsFingerTree.fromArray
      dq |> box |> QueueState

    let pushBack (n : int) (QueueState (:? FingerTree<Size, Value<ValueType>> as dq)) =
      let rec loop dq i =
        if i > 0 then
          let dq = FsFingerTree.conj (Value i) dq
          loop dq (i - 1)
        else
          dq
      loop dq n |> box |> QueueState

    let popFront (n : int) (QueueState (:? FingerTree<Size, Value<ValueType>> as dq)) =
      let rec loop dq i =
        if i > 0 then
          let view = FsFingerTree.tryUncons dq
          match view with
          | EmptyTree -> failwith "Aborted"
          | View (h, t) -> loop t (i - 1)
        else
          dq
      loop dq n |> box |> QueueState

  module MsQueue =
    open System.Collections.Immutable

    let init (vs : ValueType []) =
      ImmutableQueue.Create<int>(vs) |> box |> QueueState

    let pushBack (n : int) (QueueState (:? IImmutableQueue<ValueType> as dq)) =
      let rec loop (dq : IImmutableQueue<ValueType>) i =
        if i > 0 then
          let dq = dq.Enqueue i
          loop dq (i - 1)
        else
          dq
      loop dq n |> box |> QueueState

    let popFront (n : int) (QueueState (:? IImmutableQueue<ValueType> as dq)) =
      let rec loop (dq : IImmutableQueue<ValueType>) i =
        if i > 0 then
          let dq = dq.Dequeue ()
          loop dq (i - 1)
        else
          dq
      loop dq n |> box |> QueueState

  module FsxQueue =
    open FSharpx.Collections

    let init (vs : ValueType []) =
      vs |> Seq.ofArray |> Queue.ofSeq |> box |> QueueState

    let pushBack (n : int) (QueueState (:? Queue<ValueType> as dq)) =
      let rec loop dq i =
        if i > 0 then
          let dq = Queue.conj i dq
          loop dq (i - 1)
        else
          dq
      loop dq n |> box |> QueueState

    let popFront (n : int) (QueueState (:? Queue<ValueType> as dq)) =
      let rec loop dq i =
        if i > 0 then
          match Queue.tryTail dq with
          | None -> failwith "Aborted"
          | Some t ->
            loop t (i - 1)
        else
          dq
      loop dq n |> box |> QueueState

  module FsxDequeue =
    open FSharpx.Collections

    let init (vs : ValueType []) =
      vs |> Seq.ofArray |> Deque.ofSeq |> box |> QueueState

    let pushBack (n : int) (QueueState (:? Deque<ValueType> as dq)) =
      let rec loop dq i =
        if i > 0 then
          let dq = Deque.conj i dq
          loop dq (i - 1)
        else
          dq
      loop dq n |> box |> QueueState

    let popFront (n : int) (QueueState (:? Deque<ValueType> as dq)) =
      let rec loop dq i =
        if i > 0 then
          match Deque.tryTail dq with
          | None -> failwith "Aborted"
          | Some t ->
            loop t (i - 1)
        else
          dq
      loop dq n |> box |> QueueState

  module FsxDlist =
    open FSharpx.Collections

    let init (vs : ValueType []) =
      vs |> Seq.ofArray |> DList.ofSeq |> box |> QueueState

    let pushBack (n : int) (QueueState (:? DList<ValueType> as dq)) =
      let rec loop dq i =
        if i > 0 then
          let dq = DList.conj i dq
          loop dq (i - 1)
        else
          dq
      loop dq n |> box |> QueueState

    let popFront (n : int) (QueueState (:? DList<ValueType> as dq)) =
      let rec loop dq i =
        if i > 0 then
          match DList.tryTail dq with
          | None -> failwith "Aborted"
          | Some t ->
            loop t (i - 1)
        else
          dq
      loop dq n |> box |> QueueState

  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 repeat  = 10
//                1000000
    let total   = 100000
    let inners  = [| 10(*; 1000*) |]
    let sizes   = [| 0 ; 100; 10000|]

    let tests =
      let maxSize = Int32.MaxValue
      [|
        "reference"     , maxSize , ReferenceRun.init   , ReferenceRun.pushBack   , ReferenceRun.popFront
        "mutable"       , maxSize , MutableRun.init     , MutableRun.pushBack     , MutableRun.popFront
        "double-list"   , maxSize , DoubleListRun.init  , DoubleListRun.pushBack  , DoubleListRun.popFront
        "lazy"          , 10000   , LazyDequeueRun.init , LazyDequeueRun.pushBack , LazyDequeueRun.popFront
        "lazy2"         , 10000   , Lazy2DequeueRun.init, Lazy2DequeueRun.pushBack, Lazy2DequeueRun.popFront
        "array"         , 10000   , ArrayRun.init       , ArrayRun.pushBack       , ArrayRun.popFront
        "quick"         , maxSize , QuickRun.init       , QuickRun.pushBack       , QuickRun.popFront
        "cs-fingertree" , maxSize , CsRun.init          , CsRun.pushBack          , CsRun.popFront
        "fs-fingertree" , maxSize , FsRun.init          , FsRun.pushBack          , FsRun.popFront
        "ms-queue"      , maxSize , MsQueue.init        , MsQueue.pushBack        , MsQueue.popFront
        "fsx-deque"     , maxSize , FsxDequeue.init     , FsxDequeue.pushBack     , FsxDequeue.popFront
        "fsx-dlist"     , maxSize , FsxDlist.init       , FsxDlist.pushBack       , FsxDlist.popFront
        "fsx-queue"     , maxSize , FsxQueue.init       , FsxQueue.pushBack       , FsxQueue.popFront
      |]

    let results = ResizeArray 16

    for size in sizes do
      let inits = Array.init size valueCreator
      for inner in inners do
        let outer = total / inner

        let testClass = sprintf "Batch_%d" inner
        let x         = sprintf "%d" size

        for (name, maxSize, init, pushBack, popFront) in tests do
          if maxSize < size then
            tracef "Skipped - %s - size:%d - total:%d (outer:%d - inner:%d) " name size (outer*inner) outer inner
          else
            tracef "Running - %s - size:%d - total:%d (outer:%d - inner:%d) " name size (outer*inner) outer inner

            let initial = init inits

            let rec loop qs rem =
              if rem > 0 then
                let qs    = pushBack inner qs
                let qs    = popFront inner qs
                loop qs (rem - 1)

            let _, ms, cc0, cc1, cc2 = time repeat (fun () -> loop initial outer)

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

            tracef "  repeated %d times the result was: %d (%d, %d, %d)" repeat 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
  FunctionalTests.run ()
#else
  PerformanceTests.run ()
#endif
  0