(**********************************************************************)
(* (c) Greg Morrisett, Neal Glew, Dave Walker,                        *)
(*     June 1998, all rights reserved.                                *)
(**********************************************************************)

type ('a, 'b) splaytree =
   LEAF
 | NODE of ('a * 'b * ('a, 'b) splaytree * ('a, 'b) splaytree) ref
;;

type direction = LEFT | RIGHT ;;

let rotate_left node =
    match !node with
      key,data,NODE(node2),right -> 
          (match !node2 with
            left_key,left_data,left_left,left_right ->
              node := (left_key,left_data,left_left,
		       NODE(ref(key,data,left_right,right))))
    | _ -> invalid_arg "Splay.rotate_left"
;;

(*
let rotate_left (ref (key, data, NODE (ref (left_key, left_data, left_left, left_right)), right) as node) =  (* inex ok *)
   node := (left_key, left_data, left_left, NODE (ref (key, data, left_right, right)))
;;
*)

let rotate_right node =
    match !node with
      key,data,left,NODE(node2) ->
        (match !node2 with
          right_key,right_data,right_left,right_right ->
	    node := (right_key,right_data,
		     NODE(ref(key,data,left,right_left)),right_right))
    | _ -> invalid_arg "Splay.rotate_right"
;;
			       
(*
let rotate_right (ref (key, data, left, NODE (ref (right_key, right_data, right_left, right_right))) as node) =  (* inex ok *)
   node := (right_key, right_data, NODE (ref (key, data, left, right_left)), right_right)
;;
*)

let rec lift = function
   [] -> ()
 | [(LEFT, parent)] ->
      rotate_left parent
 | [(RIGHT, parent)] ->
      rotate_right parent
 | (LEFT, parent) :: (LEFT, grandparent) :: ancestors ->
      (
      rotate_left grandparent;
      rotate_left grandparent;  (* parent has moved into grandparent's position *)
      lift ancestors
      )
 | (RIGHT, parent) :: (RIGHT, grandparent) :: ancestors ->
      (
      rotate_right grandparent;
      rotate_right grandparent;  (* parent has moved into grandparent's position *)
      lift ancestors
      )
 | (LEFT, parent) :: (RIGHT, grandparent) :: ancestors ->
      (
      rotate_left parent;
      rotate_right grandparent;
      lift ancestors
      )
 | (RIGHT, parent) :: (LEFT, grandparent) :: ancestors ->
      (
      rotate_right parent;
      rotate_left grandparent;
      lift ancestors
      )
;;

let splay reln tree =
   let rec aux path = function (NODE node) ->
       (match !node with 
         (key, data, left, right) ->
         let comp = reln key
         in
            if comp = 0 then
               (
               lift path;
               true
               )
            else if comp < 0 then
               (* left *)
               aux ((LEFT, node) :: path) left
            else
               (* right *)
               aux ((RIGHT, node) :: path) right)
    | LEAF ->
         (match path with
             [] -> false
           | _ :: path' ->
                (
                lift path';
                false
                ))
   in
      aux [] tree
;;
