F# Code Optimization for Left Leaning Red Black Tree

Question

I've been working on porting a C# implementation of a LLRBT to F# and I now have it running correctly. My question is how would I go about optimizing this?

Some ideas I have

• Using a Discriminated Union for Node to remove the use of null
• Remove getters and setters
  • you cant have a null attribute and a struct at the same time

Full source can be found here. C# code taken from Delay's Blog.

Current performance
F# Elapsed = 00:00:01.1379927 Height: 26, Count: 487837
C# Elapsed = 00:00:00.7975849 Height: 26, Count: 487837

module Erik

let Black = true
let Red = false

[<AllowNullLiteralAttribute>]
type Node(_key, _value, _left:Node, _right:Node, _color:bool) =
    let mutable key = _key
    let mutable value = _value
    let mutable left = _left
    let mutable right = _right
    let mutable color = _color
    let mutable siblings = 0

    member this.Key with get() = key and set(x) = key <- x
    member this.Value with get() = value and set(x) = value <- x
    member this.Left with get() = left and set(x) = left <- x
    member this.Right with get() = right and set(x) = right <- x
    member this.Color with get() = color and set(x) = color <- x
    member this.Siblings with get() = siblings and set(x) = siblings <- x

    static member inline IsRed(node : Node) =
        if node = null then
            // "Virtual" leaf nodes are always black
            false
        else
            node.Color = Red

    static member inline Flip(node : Node) =
        node.Color <- not node.Color
        node.Right.Color <- not node.Right.Color
        node.Left.Color <- not node.Left.Color

    static member inline RotateLeft(node : Node) =
        let x = node.Right
        node.Right <- x.Left
        x.Left <- node
        x.Color <- node.Color
        node.Color <- Red
        x

    static member inline RotateRight(node : Node) =
        let x = node.Left
        node.Left <- x.Right
        x.Right <- node
        x.Color <- node.Color
        node.Color <- Red
        x

    static member inline MoveRedLeft(_node : Node) =
        let mutable node = _node
        Node.Flip(node)

        if Node.IsRed(node.Right.Left) then
            node.Right <- Node.RotateRight(node.Right)
            node <- Node.RotateLeft(node)
            Node.Flip(node)

            if Node.IsRed(node.Right.Right) then
                node.Right <- Node.RotateLeft(node.Right)
        node

    static member inline MoveRedRight(_node : Node) =
        let mutable node = _node
        Node.Flip(node)

        if Node.IsRed(node.Left.Left) then
            node <- Node.RotateRight(node)
            Node.Flip(node)
        node

    static member DeleteMinimum(_node : Node) =
        let mutable node = _node

        if node.Left = null then
            null
        else
            if not(Node.IsRed(node.Left)) && not(Node.IsRed(node.Left.Left)) then
                node <- Node.MoveRedLeft(node)

            node.Left <- Node.DeleteMinimum(node)
            Node.FixUp(node)

    static member FixUp(_node : Node) =
        let mutable node = _node

        if Node.IsRed(node.Right) then
            node <- Node.RotateLeft(node)

        if Node.IsRed(node.Left) && Node.IsRed(node.Left.Left) then
            node <- Node.RotateRight(node)

        if Node.IsRed(node.Left) && Node.IsRed(node.Right) then
            Node.Flip(node)

        if node.Left <> null && Node.IsRed(node.Left.Right) && not(Node.IsRed(node.Left.Left)) then
            node.Left <- Node.RotateLeft(node.Left)
            if Node.IsRed(node.Left) then
                node <- Node.RotateRight(node)
        node

type LeftLeaningRedBlackTree(?isMultiDictionary) =
    let mutable root = null
    let mutable count = 0        

    member this.IsMultiDictionary =
       Option.isSome isMultiDictionary

    member this.KeyAndValueComparison(leftKey, leftValue, rightKey, rightValue) =
        let comparison = leftKey - rightKey
        if comparison = 0 && this.IsMultiDictionary then
            leftValue - rightValue
        else
            comparison

    member this.Add(key, value) =
        root <- this.add(root, key, value)

    member private this.add(_node : Node, key, value) =
        let mutable node = _node

        if node = null then
            count <- count + 1
            new Node(key, value, null, null, Red)
        else
            if Node.IsRed(node.Left) && Node.IsRed(node.Right) then
                Node.Flip(node)

            let comparison = this.KeyAndValueComparison(key, value, node.Key, node.Value)

            if comparison < 0 then
                node.Left <- this.add(node.Left, key, value)
            elif comparison > 0 then
                node.Right <- this.add(node.Right, key, value)
            else
                if this.IsMultiDictionary then
                    node.Siblings <- node.Siblings + 1
                    count <- count + 1
                else
                   node.Value <- value

            if Node.IsRed(node.Right) then
                node <- Node.RotateLeft(node)

            if Node.IsRed(node.Left) && Node.IsRed(node.Left.Left) then
                node <- Node.RotateRight(node)

            node

Answer 1

If you're willing to consider an immutable implementation, you might want to look at Chris Okasaki's paper on red-black trees in a functional setting here.

Answer 2

I'm surprised there's such a perf difference, since this looks like a straightforward transliteration. I presume both are compiled in 'Release' mode? Did you run both separately (cold start), or if both versions in the same program, reverse the order of the two (e.g. warm cache)? Done any profiling (have a good profiler)? Compared memory consumption (even fsi.exe can help with that)?

(I don't see any obvious improvements to be had for this mutable data structure implementation.)

Answer 3

I wrote an immutable version and it's performing better than the above mutable one. I've only implemented insert so far. I'm still trying to figure out what the performance issues are.

type ILLRBT =
    | Red   of ILLRBT * int * ILLRBT
    | Black of ILLRBT * int * ILLRBT
    | Nil

let flip node = 
    let inline flip node =
        match node with
        |   Red(l, v, r) -> Black(l, v, r)
        | Black(l, v, r) ->   Red(l, v, r)
        | Nil -> Nil
    match node with
    |   Red(l, v, r) -> Black(flip l, v, flip r)
    | Black(l, v, r) ->   Red(flip l, v, flip r)
    | Nil -> Nil

let lRot = function
    |   Red(l, v,   Red(l', v', r'))
    |   Red(l, v, Black(l', v', r')) ->   Red(Red(l, v, l'), v', r')
    | Black(l, v,   Red(l', v', r'))
    | Black(l, v, Black(l', v', r')) -> Black(Red(l, v, l'), v', r')
    | _ -> Nil // could raise an error here

let rRot = function
    |   Red(  Red(l', v', r'), v, r)
    |   Red(Black(l', v', r'), v, r) ->   Red(l', v', Red(r', v, r))
    | Black(  Red(l', v', r'), v, r)
    | Black(Black(l', v', r'), v, r) -> Black(l', v', Red(r', v, r))
    | _ -> Nil // could raise an error here

let rec insert node value = 
    match node with
    | Nil -> Red(Nil, value, Nil)
    | n ->
        n
        |> function
            |   Red(Red(_), v, Red(_))
            | Black(Red(_), v, Red(_)) as node -> flip node
            | x -> x
        |> function
            |   Red(l, v, r) when value < v ->   Red(insert l value, v, r)
            | Black(l, v, r) when value < v -> Black(insert l value, v, r)
            |   Red(l, v, r) when value > v ->   Red(l, v, insert r value)
            | Black(l, v, r) when value > v -> Black(l, v, insert r value)
            | x -> x
        |> function
            |   Red(l, v, Red(_))
            | Black(l, v, Red(_)) as node -> lRot node
            | x -> x
        |> function
            |   Red(Red(Red(_),_,_), v, r)
            | Black(Red(Red(_),_,_), v, r) as node -> rRot node
            | x -> x

let rec iter node =
    seq {
        match node with
        |   Red(l, v, r)
        | Black(l, v, r) ->
            yield! iter l
            yield v
            yield! iter r
        | Nil -> ()
    }