6 people like it.

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