• API
• FAQ
• Tools
• Archive
SHARE
TWEET # Untitled a guest Nov 17th, 2019 98 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
1. type interval = int * int
2.
3. type set = Empty | Node of set * interval * set * int
4.
5. type t = {cmp: interval -> interval -> int; set: set}
6.
7. (* returns height of interval set *)
8. let height = function Node (_, _, _, h) -> h | Empty -> 0
9.
10. (* Interval set constructor *)
11. let make l i r = Node (l, i, r, max (height l) (height r) + 1)
12.
13. let bal l k r =
14.   let hl = height l in
15.   let hr = height r in
16.   if hl > hr + 2 then
17.     match l with
18.     | Node (ll, lk, lr, _) -> (
19.         if height ll >= height lr then make ll lk (make lr k r)
20.         else
21.           match lr with
22.           | Node (lrl, lrk, lrr, _) -> make (make ll lk lrl) lrk (make lrr k r)
23.           | Empty -> assert false )
24.     | Empty -> assert false
25.   else if hr > hl + 2 then
26.     match r with
27.     | Node (rl, rk, rr, _) -> (
28.         if height rr >= height rl then make (make l k rl) rk rr
29.         else
30.           match rl with
31.           | Node (rll, rlk, rlr, _) -> make (make l k rll) rlk (make rlr rk rr)
32.           | Empty -> assert false )
33.     | Empty -> assert false
34.   else Node (l, k, r, max hl hr + 1)
35.
36. let rec min_elt = function
37.   | Node (Empty, k, _, _) -> k
38.   | Node (l, _, _, _) -> min_elt l
39.   | Empty -> raise Not_found
40.
41. let rec remove_min_elt = function
42.   | Node (Empty, _, r, _) -> r
43.   | Node (l, k, r, _) -> bal (remove_min_elt l) k r
44.   | Empty -> invalid_arg "PSet.remove_min_elt"
45.
46. let merge t1 t2 =
47.   match (t1, t2) with
48.   | Empty, _ -> t2
49.   | _, Empty -> t1
50.   | _ ->
51.       let i = min_elt t2 in
52.       bal t1 i (remove_min_elt t2)
53.
55. let interval_compare (a, b) (c, d) = if a = c then compare b d else compare a c
56.
57. let empty = {cmp= interval_compare; set= Empty}
58.
59. let are_overlapping a b =
60.   let check (a1, a2) (b1, b2) =
61.     (a1 <= b1 && b1 <= a2) || (a1 <= b2 && b2 <= a2)
62.   in
63.   check a b || check b a
64.
65. let are_neighboring a b =
66.   let check (_, a2) (b1, _) = a2 + 1 = b1 in
67.   are_overlapping a b || check a b || check b a
68.
69. let union (a1, a2) (b1, b2) = (min a1 b1, max a2 b2)
70.
71. let checked (a, b) =
72.   if a <= b then (a, b)
73.   else raise (Invalid_argument "invalid interval values order")
74.
75. let rec add_one cmp x s =
76.   let rec loop i = function
77.     | Empty -> (i, Empty)
78.     | Node (l, v, r, _) ->
79.         if are_neighboring i v then loop (union i v) (merge l r)
80.         else
81.           let c = cmp i v in
82.           if 0 < c then
83.             let ir, nr = loop i r in
84.             (ir, make l v nr)
85.           else
86.             let il, nl = loop i l in
87.             (il, make nl v r)
88.   in
89.   let x = checked x in
90.   match s with
91.   | Empty -> make Empty x Empty
92.   | Node (l, i, r, h) ->
93.       let c = cmp x i in
94.       let overlap = are_neighboring x i in
95.       if c = 0 then make l x r
96.       else if not overlap then
97.         if c < 0 then
98.           let nl = add_one cmp x l in
99.           bal nl i r
100.         else
101.           let nr = add_one cmp x r in
102.           bal l i nr
103.       else
104.         let u = union x i in
105.         let il, nl = loop u l in
106.         let ir, nr = loop u r in
107.         bal nl (union u (union il ir)) nr
108.
109. (*
110. let rec add_one cmp x = function
111.   | Node (l, i, r, h) ->
112.       let c = cmp x i in
113.       if c = 0 then Node (l, x, r, h)
114.       else if c < 0 then
115.         let nl = add_one cmp x l in
116.         bal nl i r
117.       else
118.         let nr = add_one cmp x r in
119.         bal l i nr
120.   | Empty -> make Empty x Empty *)
121.
122. let add x {cmp; set} = {cmp; set= add_one cmp x set}
123.
124. let rec join cmp l v r =
125.   match (l, r) with
126.   | Empty, _ -> add_one cmp v r
127.   | _, Empty -> add_one cmp v l
128.   | Node (ll, lv, lr, lh), Node (rl, rv, rr, rh) ->
129.       if lh > rh + 2 then bal ll lv (join cmp lr v r)
130.       else if rh > lh + 2 then bal (join cmp l v rl) rv rr
131.       else make l v r
132.
133. let split x {cmp; set} =
134.   let rec loop x = function
135.     | Empty -> (Empty, false, Empty)
136.     | Node (l, v, r, _) ->
137.         let c = cmp x v in
138.         if c = 0 then (l, true, r)
139.         else if c < 0 then
140.           let ll, pres, rl = loop x l in
141.           (ll, pres, join cmp rl v r)
142.         else
143.           let lr, pres, rr = loop x r in
144.           (join cmp l v lr, pres, rr)
145.   in
146.   let setl, pres, setr = loop x set in
147.   ({cmp; set= setl}, pres, {cmp; set= setr})
148.
149. let intersection (a, b) (c, d) =
150.   if a > d || c > b then None else Some (max a c, min b d)
151.
152. let difference a b =
153.   match intersection a b with
154.   | None -> (Some a, None)
155.   | Some i ->
156.       if a = i then (None, None)
157.       else
158.         let (a1, a2), (i1, i2) = (a, i) in
159.         if a1 = i1 then (None, Some (i2 + 1, a2))
160.         else if a2 = i2 then (Some (a1, i1 - 1), None)
161.         else (Some (a1, i1 - 1), Some (i2 + 1, a2))
162.
163. let remove x {cmp; set} =
164.   let rec loop = function
165.     | Empty -> Empty
166.     | Node (l, i, r, _) -> (
167.         let overlap = are_overlapping x i in
168.         if not overlap then
169.           let c = cmp x i in
170.           if c < 0 then bal (loop l) i r else bal l i (loop r)
171.         else
172.           match difference i x with
173.           | Some a, Some b -> add_one cmp a (bal l b r)
174.           | Some a, None -> bal l a (loop r)
175.           | None, Some b -> bal (loop l) b r
176.           | None, None -> merge (loop l) (loop r) )
177.   in
178.   {cmp; set= loop set}
179.
180. (* let remove x { cmp = cmp; set = set } =
181.   let rec loop = function
182.     | Node (l, k, r, _) ->
183.         let c = cmp x k in
184.         if c = 0 then merge l r else
185.         if c < 0 then bal (loop l) k r else bal l k (loop r)
186.     | Empty -> Empty in
187.   { cmp = cmp; set = loop set } *)
188.
189. let mem x {cmp; set} =
190.   let x = (x, x) in
191.   let rec loop = function
192.     | Node (l, k, r, _) ->
193.         let c = cmp x k in
194.         are_overlapping x k || loop (if c < 0 then l else r)
195.     | Empty -> false
196.   in
197.   loop set
198.
199. let iter f {set} =
200.   let rec loop = function
201.     | Empty -> ()
202.     | Node (l, k, r, _) -> loop l ; f k ; loop r
203.   in
204.   loop set
205.
206. let fold f {cmp; set} acc =
207.   let rec loop acc = function
208.     | Empty -> acc
209.     | Node (l, k, r, _) -> loop (f k (loop acc l)) r
210.   in
211.   loop acc set
212.
213. let elements {set} =
214.   let rec loop acc = function
215.     | Empty -> acc
216.     | Node (l, k, r, _) -> loop (k :: loop acc r) l
217.   in
218.   loop [] set
219.
220. let is_empty s = s = Empty
221.
222. let lenght (a, b) =
223.   let l = 1 + b - a in
224.   if l < 0 then max_int else l
225.
226. let below x t =
227.   let below_interval (a, b) x =
228.     if are_overlapping (x, x) (a, b) then lenght (a, x) else 0
229.   in
230.   let helper i acc =
231.     if acc = max_int then max_int else acc + below_interval i x
232.   in
233.   fold helper t 0
234.
235. let split x ({cmp} as t) =
236.   let helper (a, b) (l, p, r) =
237.     if are_overlapping (x, x) (a, b) then
238.       (add_one cmp (a, x - 1) l, true, add_one cmp (x + 1, b) r)
239.     else if x < a then (l, p, add_one cmp (a, b) r)
240.     else (add_one cmp (a, b) l, p, r)
241.   in
242.   let l, p, r = fold helper t (Empty, false, Empty) in
243.   ({cmp; set= l}, p, {cmp; set= r})
RAW Paste Data
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.
Not a member of Pastebin yet?