open System; // mutable AVL balanced binary search trees: // each vertex contains a value, height, and left/right trees all referenced type 'a tree when 'a:comparison = | Emp | Vertex of 'a ref * int ref * 'a tree ref * 'a tree ref;; let rec searchr x = function | Emp -> false | Vertex(px,_,_,_) when x=(!px) -> true | Vertex(px,_,L,_) when x<(!px) -> searchr x (!L) | Vertex(_,_,_,{contents = R}) -> searchr x R;; // note direct match on ref let height = function // return height value (direct on referenced tree) | {contents=Emp} -> 0 | {contents=Vertex(_,ph,_,_)} -> !ph;; let diffheight = function // calculate difference in height, need dereference | Emp -> 0 | Vertex(x,hx,L,R) -> let hl,hr = height(L),height(R) hl - hr;; let setheight = function // sets height and return tree | Emp as v-> v | Vertex(_,ph,L,R) as v -> let hl,hr = height(L),height(R) if (hl>hr) then ph:= hl+1 else ph:= hr+1 // if-else used here v;; (* ***** AVL rotations: An LL-rotation as used in balanced binary tree algorithms such as with AVL trees or Red-Black trees. Even in C#, it would be difficult to write this without reverting to using a bunch of confusing if-elses. LL rotation diagram: x y / \ / \ y r ---> ll x / \ / \ ll lr lr r In F#, we can take advantage of deep pattern matching to implement this operation more declaratively. *) let LL = function | Vertex(x,hx,{contents=Vertex(y,hy,ll,lr)},r) -> Vertex(y,hy,ll,ref (setheight(Vertex(x,hx,lr,r)))) |> setheight | n -> setheight(n);; let RR = function | Vertex(y,hy,ll,{contents=Vertex(x,hx,lr,r)}) -> Vertex(x,hx,Vertex(y,hy,ll,lr)|>setheight|>ref,r) |> setheight | n -> setheight(n);; // a double LR(n) rotation is just a RR(LL(n)) and RL is a LL(RR(n)) // balance a vertex after insert/delete by apply rotations if needed: let balance = function // if-then-else used to diffheight | Emp as v -> v | Vertex(x,hx,L,R) as v when diffheight(v)>1 -> if diffheight(!L)>=0 then LL(v) else LL(Vertex(x,hx,ref (RR(!L)),R)) | Vertex(x,hx,L,R) as v when diffheight(v) < -1 -> if diffheight(!R)<=0 then RR(v) else RR(setheight(Vertex(x,hx,L,ref (LL(!R))))) | v -> setheight(v);; let rec tostringr = function | Emp -> "" | Vertex(px,_,L,R) -> tostringr(!L)+" "+string(!px)+tostringr(!R);; (* more efficient? depends on implementation underneath let LL2 = function | Vertex(x,hx,{contents=Vertex(y,hy,ll,lr)} as l,r) -> let x0 = !x x := !y l := !ll r := Vertex(ref x0,hy,lr,r);; | n -> n;; // no change *) // destructive insert into tree, (except for Emp): let rec insert x = function | Emp as v-> Vertex(ref x,ref 1,ref Emp,ref Emp) | Vertex(py,ph,L,R) as v when x < (!py) -> L := insert x !L v |> balance | Vertex(py,ph,L,R) as v when x>(!py) -> R:= insert x !R v |> balance | t -> t;; // no duplicates in BSTs // delete: Vertex(px,L,R): // if L is empty, return R, else delete largest value in L, and // replace !px with that largest value // delmax takes modpoint (px) so it can assign when it finds node let rec delmax modpointer = function | Emp -> Emp //raise (Exception("delmax should never be called on Emp")) | Vertex(px,ph,L,{contents=Emp}) -> modpointer := !px !L | Vertex(px,ph,L,R) as v -> R := delmax modpointer !R v |> balance;; let rec delete x = function | Emp -> Emp | Vertex(px,ph,L,R) as v when x<(!px) -> L := delete x !L v |> balance | Vertex(px,ph,L,R) as v when x>(!px) -> R := delete x !R v |> balance | Vertex(px,ph,{contents=Emp},R) -> !R | Vertex(px,ph,L,R) as v -> L := delmax px !L v |> balance;; // compute recursive depth for verification: let rec depth = function | Emp -> 0 | Vertex(_,_,L,R) -> let dl,dr = depth(!L),depth(!R) if (dl>dr) then dl+1 else dr+1;; let testtree = ref (insert 2000 Emp); for i in 1..1000000 do // 1 million nodes ignore (insert (2*i+1) !testtree) ignore (insert (2*i) !testtree);; //Console.WriteLine(tostringr(!testtree)); //Console.WriteLine(depth(!testtree)); //Console.WriteLine(height(testtree)); //testtree := balance !testtree; //Console.WriteLine(depth(!testtree)); Console.WriteLine(height(testtree));; // height 21 (log 1meg + 1)