AvlTree.fsx

type 'a Tree =
    | Node of int * 'a Tree * 'a * 'a (* height, left child, value, right child *) Tree
    | Nil

(*
    Notation:
        h = height
        x = value
        l = left child
        r = right child

        lh = left child's height
        lx = left child's value
        ll = left child's left child
        lr = left child's right child

        rh = right child's height
        rx = right child's value
        rl = right child's left child
        rr = right child's right child
*)

let height =
    function
    | Node (h, _, _, _) -> h
    | Nil -> 0

let make l x r =
    let h = 1 + max (height l) (height r)
    Node(h, l, x, r)

let rotRight =
    function
    | Node (_, Node (_, ll, lx, lr), x, r) ->
        let r' = make lr x r
        make ll lx r'
    | node -> node

let rotLeft =
    function
    | Node (_, l, x, Node (_, rl, rx, rr)) ->
        let l' = make l x rl
        make l' rx rr
    | node -> node

let doubleRotLeft =
    function
    | Node (h, l, x, r) ->
        let r' = rotRight r
        let node' = make l x r'
        rotLeft node'
    | node -> node

let doubleRotRight =
    function
    | Node (h, l, x, r) ->
        let l' = rotLeft l
        let node' = make l' x r
        rotRight node'
    | node -> node

let balanceFactor =
    function
    | Nil -> 0
    | Node (_, l, _, r) -> (height l) - (height r)

let balance =
    function
    (* left unbalanced *)
    | Node (h, l, x, r) as node when balanceFactor node >= 2 ->
        if balanceFactor l >= 1
        then rotRight node (* left left case *)
        else doubleRotRight node (* left right case *)
    (* right unbalanced *)
    | Node (h, l, x, r) as node when balanceFactor node <= -2 ->
        if balanceFactor r <= -1
        then rotLeft node (* right right case *)
        else doubleRotLeft node (* right left case *)
    | node -> node

let rec insert v =
    function
    | Nil -> Node(1, Nil, v, Nil)
    | Node (_, l, x, r) as node ->
        if v = x then
            node
        else
            let l', r' =
                if v < x then insert v l, r else l, insert v r

            let node' = make l' x r'
            balance <| node'

let rec contains v =
    function
    | Nil -> false
    | Node (_, l, x, r) ->
        if v = x then true
        else if v < x then contains v l
        else contains v r

type AvlTree<'a when 'a: comparison>(tree: 'a Tree) =
    member this.Height = height tree

    member this.Left =
        match tree with
        | Node (_, l, _, _) -> new AvlTree<'a>(l)
        | Nil -> failwith "Empty tree"

    member this.Right =
        match tree with
        | Node (_, _, _, r) -> new AvlTree<'a>(r)
        | Nil -> failwith "Empty tree"

    member this.Value =
        match tree with
        | Node (_, _, x, _) -> x
        | Nil -> failwith "Empty tree"

    member this.Insert(x) = new AvlTree<'a>(insert x tree)

    member this.Contains(v) = contains v tree

//TODO
module AvlTree =
    [<GeneralizableValue>]
    let empty<'a> : AvlTree<'a> = new AvlTree<'a>(Nil)

https://en.wikibooks.org/wiki/F_Sharp_Programming/Advanced_Data_Structures#Red_Black_Trees のコードをコピペしたうえで少し修正したが、が取り切れない事案。
修正したのは type AvlTree<'a when 'a: comparison>(tree: 'a Tree) = で error FS0001: 型パラメーターに制約 'when 'a : comparison' がありません というエラー表示に従って when 'a : comparison をつけた。
最後の module AvlTree でも同じ型制約に関するエラーが出たのでいろいろ制約をつけてみたがわからない。
例えば次のようにすると error FS0010: 予期しない キーワード 'when' です 型引数内。',' または他のトークンを指定してください。 と言われる。

module AvlTree =
[]
let empty<'a> : AvlTree<'a when 'a : comparison> = new AvlTree<'a>(Nil)

次のようなご指摘を頂いて直したら直った。

制約は AvlTree<'a when 'a : comparison>ではなく let empty<'a> = .. の方の 'a につけないといけません。ここで型変数 'a が宣言（束縛）されているからです。（comparison という制約は AvlTree にではなく、型変数そのものについている）

制約をつける場所、きちんと覚えておこう。