6 people like it.
Like the snippet!

Red-Black-Trees with insert

Found an very good article on RS-Trees in Haskell (see: http://www.eecs.usma.edu/webs/people/okasaki/jfp99.ps) It heavyly uses pattern recognition to translate those pesky balance-rules into short code. Bellowe is the simple rewrite of the haskell-implementation in F# - enjoy

implementation

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10: 
11: 
12: 
13: 
14: 
15: 
16: 
17: 
18: 
19: 
20: 
21: 
22: 
23: 
24: 
25: 
26: 
27: 
28: 
29: 
30: 
31: 
32: 
33: 
34: 
35: 
36: 
37: 
38: 
39: 
40: 
41: 
42: 
43: 
44: 
45: 
46: 
47: 
48: 
49: 
50: 
51: 
52: 
53: 
54: 
55: 
56: 
57: 
58: 
59:

type Color = Red | Black

type 'a Tree = 
    | Empty
    | Node of 'a TreeNode
and 'a TreeNode = { value : 'a; color : Color; left : 'a Tree; right : 'a Tree }

module RSTree =
    
    /// a empty RS-Tree
    let empty : 'a Tree = Empty

    /// member predicate
    /// please note: the compiler got issues if you use '==' on v and v'
    let rec isMember (t : 'a Tree) (v : 'a) : bool =
        match t with
        | Empty -> false
        | Node { value = v'; color = _; left = l; right = r } ->
            if v < v' then isMember l v
            else if v > v' then isMember r v
            else true

    /// inserts a new Element
    let insert (x : 'a) (t : 'a Tree) : 'a Tree =
        // force resulting node's color to be black
        let makeBlack = function
            | Node { value = y; color = _; left = a; right = b} -> Node { value = y; color = Black; left = a; right = b }
            | Empty -> failwith "unexpected case"

        // balance the tree
        let rec balance (color : Color) (a : 'a Tree) (x : 'a) (b : 'a Tree) =
            // rather unreadable - see the mentioned article for details
            match (color, a, x, b) with
            | (Black, Node { value = y; color = Red; left = Node { value = x; color = Red; left = a; right = b }; right = c}, z, d)
            | (Black, Node { value = x; color = Red; left = a; right = Node { value = y; color = Red; left = b; right = c }; }, z, d)
            | (Black, a, x, Node { value = z; color = Red; left = Node { value = y; color = Red; left = b; right = c }; right = d; })
            | (Black, a, x, Node { value = y; color = Red; left = b; right = Node { value = z; color = Red; left = c; right = d }; }) ->
                Node {  value = y; color = Red; 
                        left = Node {value = x; color = Black; left = a; right = b}; 
                        right = Node {value = z; color = Black; left = c; right = d}
                     }
            | _ -> Node { value = x; color = color; left = a; right = b }

        // recursive insert
        let rec ins t =
            match t with
            // initialise a new node's color to red
            | Empty -> Node { value = x; color = Red; left = Empty; right = Empty }
            | Node { value = y; color = color; left = a; right = b } ->
                if x < y then balance color (ins a) y b
                else if x > y then balance color a y (ins b)
                else Node { value = y; color = color; left = a; right = b }

        makeBlack (ins t)

    /// insert many values
    let insertMany (xs : 'a seq) (t : 'a Tree) : 'a Tree =
        let switch f = fun y x -> f x y
        xs |> Seq.fold (switch insert) t

sample

1:	`let t = Empty \|> RSTree.insertMany [2;5;8;7;10;3;4;1;9;6];;`

union case Color.Red: Color

union case Color.Black: Color

type 'a Tree =
| Empty
| Node of 'a TreeNode

Full name: Script.Tree<_>

union case Tree.Empty: 'a Tree

union case Tree.Node: 'a TreeNode -> 'a Tree

type 'a TreeNode =
  {value: 'a;
   color: Color;
   left: 'a Tree;
   right: 'a Tree;}

Full name: Script.TreeNode<_>

TreeNode.value: 'a

TreeNode.color: Color

type Color =
| Red
| Black

Full name: Script.Color

TreeNode.left: 'a Tree

TreeNode.right: 'a Tree

val empty : 'a Tree

Full name: Script.RSTree.empty

a empty RS-Tree

val isMember : t:'a Tree -> v:'a -> bool (requires comparison)

Full name: Script.RSTree.isMember

member predicate
please note: the compiler got issues if you use '==' on v and v'

val t : 'a Tree (requires comparison)

val v : 'a (requires comparison)

type bool = System.Boolean

Full name: Microsoft.FSharp.Core.bool

val v' : 'a (requires comparison)

val l : 'a Tree (requires comparison)

val r : 'a Tree (requires comparison)

val insert : x:'a -> t:'a Tree -> 'a Tree (requires comparison)

Full name: Script.RSTree.insert

inserts a new Element

val x : 'a (requires comparison)

val makeBlack : ('b Tree -> 'b Tree)

val y : 'b

val a : 'b Tree

val b : 'b Tree

val failwith : message:string -> 'T

Full name: Microsoft.FSharp.Core.Operators.failwith

val balance : (Color -> 'a Tree -> 'a -> 'a Tree -> 'a Tree) (requires comparison)

val color : Color

val a : 'a Tree (requires comparison)

val b : 'a Tree (requires comparison)

val y : 'a (requires comparison)

val c : 'a Tree (requires comparison)

val z : 'a (requires comparison)

val d : 'a Tree (requires comparison)

val ins : ('a Tree -> 'a Tree) (requires comparison)

val insertMany : xs:seq<'a> -> t:'a Tree -> 'a Tree (requires comparison)

Full name: Script.RSTree.insertMany

insert many values

val xs : seq<'a> (requires comparison)

Multiple items
val seq : sequence:seq<'T> -> seq<'T>

Full name: Microsoft.FSharp.Core.Operators.seq

--------------------
type seq<'T> = System.Collections.Generic.IEnumerable<'T>

Full name: Microsoft.FSharp.Collections.seq<_>

val switch : (('b -> 'c -> 'd) -> 'c -> 'b -> 'd)

val f : ('b -> 'c -> 'd)

val y : 'c

val x : 'b

module Seq

from Microsoft.FSharp.Collections

val fold : folder:('State -> 'T -> 'State) -> state:'State -> source:seq<'T> -> 'State

Full name: Microsoft.FSharp.Collections.Seq.fold

val t : int Tree

Full name: Script.t

module RSTree

from Script

Raw view Test code New version

More information

Link:	http://fssnip.net/4F
Posted:	13 years ago
Author:	Carsten König
Tags:	red black trees , pattern matching , trees