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.  
  54. (* TODO check if default compare works the same. If you are my reviewer please reminde me about this ;) *)
  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. OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!
 
Top