Last active
January 14, 2018 19:20
-
-
Save mrange/bdbe7de09baedbaa6519b201c42e2774 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
#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 |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment