1(* Splaytree -- modified for Moscow ML from
2 * SML/NJ library which is
3 * COPYRIGHT (c) 1993 by AT&T Bell Laboratories.
4 * See file mosml/copyrght/copyrght.att for details.
5 *
6 * Splay tree structure.
7 *)
8
9datatype 'a splay =
10    SplayObj of {value : 'a,
11		 right : 'a splay,
12		 left : 'a splay}
13  | SplayNil
14
15datatype 'a ans_t = No | Eq of 'a | Lt of 'a | Gt of 'a
16
17fun splay (compf, root) = let
18    fun adj SplayNil = (No,SplayNil,SplayNil)
19      | adj (arg as SplayObj{value,left,right}) =
20          (case compf value of
21            EQUAL => (Eq value, left, right)
22          | GREATER =>
23              (case left of
24                SplayNil => (Gt value,SplayNil,right)
25              | SplayObj{value=value',left=left',right=right'} =>
26                  (case compf value' of
27                    EQUAL => (Eq value',left',
28                                SplayObj{value=value,left=right',right=right})
29                  | GREATER =>
30                      (case left' of
31                        SplayNil => (Gt value',left',SplayObj{value=value,left=right',right=right})
32                      | _ =>
33                        let val (V,L,R) = adj left'
34                            val rchild = SplayObj{value=value,left=right',right=right}
35                        in
36                          (V,L,SplayObj{value=value',left=R,right=rchild})
37                        end
38                      ) (* end case *)
39                  | _ =>
40                      (case right' of
41                        SplayNil => (Lt value',left',SplayObj{value=value,left=right',right=right})
42                      | _ =>
43                        let val (V,L,R) = adj right'
44                             val rchild = SplayObj{value=value,left=R,right=right}
45                             val lchild = SplayObj{value=value',left=left',right=L}
46                        in
47                          (V,lchild,rchild)
48                        end
49                      ) (* end case *)
50                  ) (* end case *)
51              ) (* end case *)
52          | _ =>
53             (case right of
54               SplayNil => (Lt value,left,SplayNil)
55             | SplayObj{value=value',left=left',right=right'} =>
56                 (case compf value' of
57                   EQUAL =>
58                     (Eq value',SplayObj{value=value,left=left,right=left'},right')
59                 | LESS =>
60                     (case right' of
61                       SplayNil => (Lt value',SplayObj{value=value,left=left,right=left'},right')
62                     | _ =>
63                       let val (V,L,R) = adj right'
64                           val lchild = SplayObj{value=value,left=left,right=left'}
65                       in
66                         (V,SplayObj{value=value',left=lchild,right=L},R)
67                       end
68                     ) (* end case *)
69                 | _ =>
70                     (case left' of
71                       SplayNil => (Gt value',SplayObj{value=value,left=left,right=left'},right')
72                     | _ =>
73                       let val (V,L,R) = adj left'
74                           val rchild = SplayObj{value=value',left=R,right=right'}
75                           val lchild = SplayObj{value=value,left=left,right=L}
76                       in
77                         (V,lchild,rchild)
78                       end
79                     ) (* end case *)
80                 ) (* end case *)
81             ) (* end case *)
82          ) (* end case *)
83  in
84    case adj root of
85      (No,_,_) => (GREATER,SplayNil)
86    | (Eq v,l,r) => (EQUAL,SplayObj{value=v,left=l,right=r})
87    | (Lt v,l,r) => (LESS,SplayObj{value=v,left=l,right=r})
88    | (Gt v,l,r) => (GREATER,SplayObj{value=v,left=l,right=r})
89  end
90
91fun lrotate SplayNil = SplayNil
92  | lrotate (arg as SplayObj{value,left,right=SplayNil}) = arg
93  | lrotate (SplayObj{value,left,right=SplayObj{value=v,left=l,right=r}}) =
94    lrotate (SplayObj{value=v,
95		      left=SplayObj{value=value,left=left,right=l},
96		      right=r})
97
98fun join (SplayNil, SplayNil) = SplayNil
99  | join (SplayNil, t       ) = t
100  | join (t,        SplayNil) = t
101  | join (l,r) =
102    case lrotate l of
103        SplayNil => r      (* impossible as l is not SplayNil *)
104      | SplayObj{value,left,right} => SplayObj{value=value,left=left,right=r}
105