Skip to content

Instantly share code, notes, and snippets.

@GregRos

GregRos/GeneralizedList.fs

Last active December 13, 2015 19:19
Show Gist options
  • Save GregRos/4962120 to your computer and use it in GitHub Desktop.
Save GregRos/4962120 to your computer and use it in GitHub Desktop.
Download ZIP
Generalized list code
Raw
GeneralizedList.fs
namespace SolidTesting
open System
open System.Collections.Generic
open System.Collections
open System.Runtime.CompilerServices
open System.Runtime
module VariousLists =
//This attribute is added for optimization. It makes matches to the empty union case faster.
//http://stackoverflow.com/questions/11959321/why-is-none-represented-as-null
[<CompilationRepresentationAttribute(CompilationRepresentationFlags.UseNullAsTrueValue)>]
type MeasuredList<'a> =
| Nil
| MeasuredList of 'a * MeasuredList<'a> * int
with
//Since this union has a nullary case, invoking instance methods on it is unsafe.
//As such we add this attribute to make sure they get compiled as static methods.
[<CompilationRepresentationAttribute(CompilationRepresentationFlags.Static)>]
member this.Length =
match this with
| Nil -> 0
| MeasuredList(_,_,c) -> c
static member Empty : MeasuredList<'a> = Nil
static member Cons (hd : 'a,tl : MeasuredList<'a>) = MeasuredList(hd,tl,tl.Length + 1)
[<CompilationRepresentationAttribute(CompilationRepresentationFlags.Static)>]
member this.Head =
match this with
| Nil -> failwith "The list is empty."
| MeasuredList(h,_,_) -> h
[<CompilationRepresentationAttribute(CompilationRepresentationFlags.Static)>]
member this.Tail =
match this with
| Nil -> failwith "The list is empty."
| MeasuredList(_,t,_) -> t
[<CompilationRepresentationAttribute(CompilationRepresentationFlags.Static)>]
member this.IsEmpty =
match this with
| Nil -> true
| _ -> false
//This data structure is for demonstration purposes. We see how it caches a sum of its elements, instead of its length.
//It can be processed with all the list processing functions we will soon define.
type SumList =
| Nil
| SumList of int * SumList * int
with
member this.Length =
let rec len prev lst =
match lst with
| Nil -> prev
| SumList(_,t,_) -> len (prev + 1) t
len 0 this
member this.Sum =
match this with
| Nil -> 0
| SumList(_,_,c) -> c
static member Empty = Nil
static member Cons (hd : int,tl : SumList) = SumList(hd,tl,tl.Sum + hd)
member this.Head =
match this with
| Nil -> failwith "The list is empty."
| SumList(h,_,_) -> h
member this.Tail =
match this with
| Nil -> failwith "The list is empty."
| SumList(_,t,_) -> t
member this.IsEmpty =
match this with
| Nil -> true
| _ -> false
//Again, for demonstration purposes.
type SimpleList<'a> =
| Nil
| SimpleList of 'a * 'a SimpleList
with
member this.Length =
let rec len prev lst =
match lst with
| Nil -> prev
| SimpleList(_,t) -> len (prev + 1) t
len 0 this
static member Empty : SimpleList<'a> = Nil
static member Cons (hd : 'a,tl : 'a SimpleList) = SimpleList(hd,tl)
//member this.Cons (hd : 'a) = SimpleList(hd,this)
member this.Head =
match this with
| Nil -> failwith "The list is empty."
| SimpleList(h,_) -> h
member this.Tail =
match this with
| Nil -> failwith "The list is empty."
| SimpleList(_,t) -> t
member this.IsEmpty =
match this with
| Nil -> true
| _ -> false
///Provides generalized list processing functions.
module List' =
///A generalized list enumerator.
type ListEnumerator<'a,'b>(l : 'a,isEmpty : 'a -> bool, head : 'a -> 'b, tail : 'a -> 'a) =
let mutable current = l
let mutable isDisposed = false
interface System.Collections.Generic.IEnumerator<'b> with
member this.MoveNext() =
if isDisposed then
raise <| ObjectDisposedException("ListEnumerator")
elif current |> isEmpty then
false
else
do current <- tail current
current |> isEmpty |> not
member this.Current =
if isDisposed then
raise <| ObjectDisposedException("ListEnumerator")
else
head current
member this.Current : obj = (this :> IEnumerator<'b>).Current :> _
member this.Dispose() =
isDisposed <- true
member this.Reset() =
raise <| NotImplementedException()
//Note that yield statements perform slower than trivial enumerators by orders of magnitude.
//This is because yield-based iterators involve allocating hidden objects.
//By using a few inline members, we can generalize all these list processing functions to arbitrary list-like types.
//The strange syntax with parentheses and stuff is F#'s explicit invocation syntax for
//Members if member constrained type arguments. It's under-documented, but not deprecated or fslib-exclusive.
//Debugging them is also somewhat uncomfortable.
//Refer to the F# language spec: http://research.microsoft.com/en-us/um/cambridge/projects/fsharp/manual/spec.html#_Toc335818802
//http://research.microsoft.com/en-us/um/cambridge/projects/fsharp/manual/spec.html#_Toc335818850
let inline empty() : ^s = (^s : (static member Empty : ^s) () )
let inline cons (head : 'a) (stk : ^s) : ^s = (^s : (static member Cons : ^a -> ^s -> ^s) head, stk)
let inline tail (stk : 's) : 's = (^s : (member Tail : 's) stk)
let inline head (stk : 's) : 'a= (^s : (member Head : 'a) stk)
let inline length (stk : ^s) : int = (^s : (member Length : int) stk)
let inline isEmpty (stk : ^s) : bool = (^s: (member IsEmpty: bool) stk)
//Here we define the generalized list processing functions.
let inline rev(stk : 'a) : 'a =
let mutable stk1 = stk : ^a
let mutable stk2 = empty() : ^a
while stk1 |> isEmpty |> not do
stk2 <- stk2 |> cons (stk1 |> head)
stk1 <- stk1 |> tail
stk2
let inline ofArray (arr : 'a[]) : 's=
let mutable stk = empty() : 's
for i in 0 .. (arr.Length - 1) do
stk <- stk |> cons (arr.[i])
stk
//Array-based implementation. This is the only way to compete with the fslib implementation which uses hidden mutation.
let inline map (mapping : ^a -> ^b) ( stk : ^s) : ^t =
let arr = Array.zeroCreate (stk |> length)
let mutable stk = stk
for i in 0 .. (arr.Length - 1) do
arr.[i] <- stk |> head |> mapping
stk <- stk |> tail
let mutable stk2 = empty() : ^t
for i in 0 .. (arr.Length - 1) do
stk2 <- stk2 |> cons (arr.[arr.Length - i - 1])
stk2
let inline toArray (stk : ^s)=
let mutable stk = stk
let len = stk |> length
let arr = Array.zeroCreate len
for i in 0 .. (arr.Length - 1) do
arr.[len - i - 1] <- stk |> head
stk <- stk |> tail
arr
let inline toList (stk : ^s)=
let mutable lst = []
let mutable stk = stk
while stk |> isEmpty |> not do
lst <- List.Cons(stk |> head,lst)
stk <- stk |> tail
lst |> List.rev
let inline consList lst (stk : ^s) : ^s =
let mutable lst = lst
let mutable stk = stk
while lst |> List.isEmpty |> not do
stk <- cons (lst.Head) stk
lst <- lst.Tail
stk
let inline nth lst i =
let rec innerNth lst ix =
match i with
| _ when lst |> isEmpty -> failwith "The index does not exist in this list."
| 0 -> lst |> head
| i -> innerNth (lst |> tail) (ix - 1)
innerNth lst i
let inline filter (prd : ^a -> bool) (lst : ^s) : ^s =
let mutable lst' = empty() : ^s
let mutable arr = lst |> toArray
for i in 0 .. (arr.Length - 1) do
if arr.[arr.Length - i - 1] |> prd then
lst' <- lst' |> cons (arr.[i])
lst'
let inline consSeq (sq : seq<_>) (stk : ^s) : ^s =
let mutable stk = stk
for item in sq do
stk <- cons stk item
stk
let inline toSeq (stk : ^s) : seq<'a>=
{new IEnumerable<'a> with
member this.GetEnumerator() : IEnumerator<'a>=
new ListEnumerator<'s,'a>(stk, isEmpty, head, tail) :> _
member this.GetEnumerator() : IEnumerator =
(this.GetEnumerator() : IEnumerator<'a>) :> _
}
let inline ofList (lst : list<_>) : ^s = consList lst (empty() : ^s) |> rev
let inline ofSeq sq = empty() |> consSeq sq |> rev
[<AutoOpen>]
module AutoOpenList =
//This active pattern also uses code generation and works for any list-like type with the specified methods.
//The problem is that using this pattern is a lot slower than matching the union case directly.
//This is because using this active pattern involves allocating one or more hidden objects.
//As such, matching with this active pattern is 10 to 30 times slower than matching the union case directly.
let inline (|Empty|Cons|) (s : ^s) = if s |> List'.isEmpty then Empty else Cons(s |> List'.head, s |> List'.tail)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment