Source

ocaml-lib / setset.ml

Full commit
(** 
   Sets of sets represented by tries.
 
   author: Sebastien Ferre <ferre@irisa.fr>
*)

let compare x y = Pervasives.compare y x (* for compatibility with LSet (Oops!) *)

type ('a,'b) t = Add of ('a * ('a,'b) t * ('a,'b) t) * 'b option | Empty of 'b option

let yss_vopt : ('a,'b) t -> ('a,'b) t * 'b option =
  function
  | Empty vopt -> Empty None, vopt
  | Add (y,vopt) -> Add (y,None), vopt

let empty : ('a,'b) t = Empty None

let rec singleton : 'a LSet.t -> 'b -> ('a,'b) t =
  fun xs v ->
    match xs with
    | [] -> Empty (Some v)
    | x::xs -> Add ((x,singleton xs v,empty), None)

let rec add : ('b -> 'b -> 'b) -> 'a LSet.t -> 'b -> ('a,'b) t -> ('a,'b) t =
  fun u xs v yss ->
    match xs, yss with
    | [], Empty vopt ->
	Empty (add_vopt u vopt v)
    | x::xs1, Empty vopt ->
	Add ((x,add u xs1 v empty,empty), vopt)
    | [], Add (y, vopt) ->
       Add (y, add_vopt u vopt v)
    | x::xs1, Add ((y,yss1,yss2), vopt) ->
       let c = compare x y in
       if c = 0 then Add ((y,add u xs1 v yss1,yss2), vopt)
       else if c < 0 then
         let yss', vopt' = yss_vopt yss in
         Add ((x,add u xs1 v empty,yss'), vopt')
       else
(*         let yss2', vopt' = yss_vopt (add xs v yss2) in*)
         Add ((y,yss1,add u xs v yss2), vopt)
and add_vopt u vopt v =
  match vopt with
  | None -> Some v
  | Some v0 -> Some (u v0 v)

let replace xs v yss = add (fun _ v -> v) xs v yss

let rec find : ('a,'b) t -> 'a LSet.t -> 'b (* raise Not_found *) =
  fun yss xs ->
    match xs, yss with
    | [], Empty vopt -> find_vopt vopt
    | [], Add (y, vopt) -> find_vopt vopt
    | x::xs1, Empty vopt -> raise Not_found
    | x::xs1, Add ((y,yss1,yss2), vopt) ->
        let c = compare x y in
        if c = 0 then find yss1 xs1
        else if c < 0 then raise Not_found
        else (* c > 0 *) find yss2 xs
and find_vopt = function
  | None -> raise Not_found
  | Some v -> v

let mem : ('a,'b) t -> 'a LSet.t -> bool =
  fun yss xs ->
    try ignore (find yss xs); true
    with Not_found -> false

let rec fold_contained : ('a LSet.t -> 'b -> 'c -> 'c) -> ('a,'b) t -> 'a LSet.t -> 'c -> 'c =
  fun f yss xs e -> fold_contained2 f yss xs e []
and fold_contained2 f yss xs e ys =
  match xs, yss with
  | _, Empty vopt
  | [], Add (_, vopt) -> fold_contained_vopt f ys vopt e
  | x::xs1, Add ((y,yss1,yss2), vopt) ->
      let c = compare x y in
      if c = 0 then
        let e1 = fold_contained_vopt f ys vopt e in
        let e2 = fold_contained2 f yss2 xs1 e1 ys in
        fold_contained2 f yss1 xs1 e2 (ys@[y])
      else if c < 0 then fold_contained2 f yss xs1 e ys
      else (* c > 0 *)
        let e1 = fold_contained_vopt f ys vopt e in
        fold_contained2 f yss2 xs e1 ys
and fold_contained_vopt f ys vopt e =
  match vopt with
  | None -> e
  | Some v -> f ys v e

let rec exists_contained : ('a,'b) t -> 'a LSet.t -> ('a LSet.t -> 'b -> bool) -> bool =
  fun yss xs p -> exists_contained2 yss xs p []
and exists_contained2 yss xs p ys =
  match xs, yss with
  | _, Empty vopt
  | [], Add (_, vopt) -> exists_contained_vopt p ys vopt
  | x::xs1, Add ((y,yss1,yss2), vopt) ->
      let c = compare x y in
      if c = 0 then
        (exists_contained_vopt p ys vopt) or
        (exists_contained2 yss2 xs1 p ys) or
        (exists_contained2 yss1 xs1 p (ys@[y]))
      else if c < 0 then exists_contained2 yss xs1 p ys
      else (* c > 0 *)
        (exists_contained_vopt p ys vopt) or
        (exists_contained2 yss2 xs p ys)
and exists_contained_vopt p ys vopt =
  match vopt with
  | None -> false
  | Some v -> p ys v

let rec exists_contains : ('a,'b) t -> 'a LSet.t -> ('a LSet.t -> 'b -> bool) -> bool =
  fun yss xs p -> exists_contains2 yss xs p []
and exists_contains2 yss xs p ys =
  match xs, yss with
  | [], Empty vopt -> exists_contains_vopt p ys vopt
  | _, Empty vopt -> false
  | [], Add ((y,yss1,yss2), vopt) ->
     (exists_contains_vopt p ys vopt) or
     (exists_contains2 yss2 [] p ys) or
     (exists_contains2 yss1 [] p (ys@[y]))
  | x::xs1, Add ((y,yss1,yss2), vopt) ->
      let c = compare x y in
      if c = 0 then exists_contains2 yss1 xs1 p (ys@[y])
      else if c < 0 then false
      else (* c > 0 *)
        (exists_contains2 yss2 xs p ys) or
        (exists_contains2 yss1 xs p (ys@[y]))
and exists_contains_vopt p ys vopt =
  match vopt with
  | None -> false
  | Some v -> p ys v

let rec union : ('b -> 'b -> 'b) -> ('a,'b) t -> ('a,'b) t -> ('a,'b) t =
  fun u yss1 yss2 ->
    match yss1, yss2 with
    | Empty vopt1, Empty vopt2 -> Empty (union_vopt u vopt1 vopt2)
    | Empty vopt1, Add (y2, vopt2) -> Add (y2, union_vopt u vopt1 vopt2)
    | Add (y1, vopt1), Empty vopt2 -> Add (y1, union_vopt u vopt1 vopt2)
    | Add ((y1,yss11,yss21), vopt1), Add ((y2,yss12,yss22), vopt2) ->
        let c = compare y1 y2 in
        if c = 0 then
          let yss', vopt' = yss_vopt (union u yss21 yss22) in
          Add ((y1,union u yss11 yss12,yss'), union_vopt u (union_vopt u vopt1 vopt2) vopt')
        else if c < 0 then
          let yss', vopt' = yss_vopt (union u yss21 yss2) in
          Add ((y1,yss11,yss'), union_vopt u vopt1 vopt')
        else (* c > 0 *)
          let yss', vopt' = yss_vopt (union u yss1 yss22) in
          Add ((y2,yss12,yss'), union_vopt u vopt2 vopt')
and union_vopt u vopt1 vopt2 =
  match vopt1, vopt2 with
  | None, vopt2 -> vopt2
  | vopt1, None -> vopt1
  | Some v1, Some v2 -> Some (u v1 v2)

(*
let add : ('b -> 'b -> 'b) -> 'a LSet.t -> 'b -> ('a,'b) t -> ('a,'b) t =
  fun u xs v yss ->
    union u (singleton xs v) yss
*)

let rec subtract : ('b -> 'b -> 'b) -> ('a,'b) t -> ('a,'b) t -> ('a,'b) t =
  fun u yss1 yss2 ->
    match yss1, yss2 with
    | Empty vopt1, Empty vopt2 -> Empty (subtract_vopt u vopt1 vopt2)
    | Empty vopt1, Add (y2, vopt2) -> Empty (subtract_vopt u vopt1 vopt2)
    | Add (y1, vopt1), Empty vopt2 -> Add (y1, subtract_vopt u vopt1 vopt2)
    | Add ((y1,yss11,yss21), vopt1), Add ((y2,yss12,yss22), vopt2) ->
        let c = compare y1 y2 in
        if c = 0 then
          match subtract u yss11 yss12, subtract u yss21 yss22 with
          | Empty None, Empty None -> Empty None
          | yss1', yss2' -> Add ((y1,yss1',yss2'), subtract_vopt u vopt1 vopt2)
        else if c < 0 then
          let yss', vopt' = yss_vopt (subtract u yss21 yss2) in
          match yss11, yss' with
          | Empty None, Empty None -> Empty None
          | yss1', yss2' -> Add ((y1,yss1',yss2'), subtract_vopt u vopt1 vopt')
        else (* c > 0 *)
          let yss', vopt' = yss_vopt (subtract u yss1 yss22) in
          match yss12, yss' with
          | Empty None, Empty None -> Empty None
          | yss1', yss2' -> Add ((y2,yss1',yss2'), subtract_vopt u vopt2 vopt')
and subtract_vopt u vopt1 vopt2 =
  match vopt1, vopt2 with
  | None, _ -> None
  | Some v1, None -> Some v1
  | Some v1, Some v2 -> Some (u v1 v2)

let rec remove : 'a LSet.t -> ('a,'b) t -> ('a,'b) t =
  fun xs yss ->
    match xs, yss with
    | [], Empty vopt -> Empty None
    | _, Empty vopt -> Empty vopt
    | [], Add (y, vopt) -> Add (y, None)
    | x::xs1, Add ((y,yss1,yss2), vopt) ->
       let c = compare x y in
       if c = 0 then
         match remove xs1 yss1, yss2 with
         | Empty None, Empty None -> Empty None
         | yss1', yss2' -> Add ((y,yss1',yss2'),vopt)
       else if c < 0 then yss
       else (* c > 0 *)
         match yss1, remove xs yss2 with
         | Empty None, Empty None -> Empty None
         | yss1', yss2' -> Add ((y,yss1',yss2'), vopt)

(* max_subtract yss1 yss2 = {ys1 in yss1 | not exists ys2 in yss2: ys1 included in ys2} *)
(* Assumption: Max yss1 = yss1 *)
let rec max_subtract : ('a,'b) t -> ('a,'b) t -> ('a,'b) t =
  fun yss1 yss2 ->
    match yss1, yss2 with
    | Empty vopt1, Empty vopt2 -> Empty (max_subtract_vopt vopt1 vopt2)
    | Empty vopt1, Add (y2,vopt2) -> Empty None
    | Add (y1,vopt1), Empty vopt2 -> Add (y1, None)
    | Add ((y1,yss11,yss21), vopt1), Add ((y2,yss12,yss22), vopt2) ->
        let c = compare y1 y2 in
        if c = 0 then
          match max_subtract yss11 yss12, max_subtract (max_subtract yss21 yss22) yss12 with
          | Empty None, Empty None -> Empty None
          | yss1', yss2' -> Add ((y1,yss1',yss2'), None)
        else if c < 0 then Add ((y1,yss11,max_subtract yss21 yss2), None)
        else (* c > 0 *) max_subtract (max_subtract yss1 yss22) yss12
and max_subtract_vopt vopt1 vopt2 =
  match vopt1, vopt2 with
  | Some v1, None -> Some v1
  | _, _ -> None

(* max_union yss1 yss2 = Max (Union yss1 yss2) *)
(* Assumption: Max yss1 = yss1, Max yss2 = yss2 *)
let rec max_union : ('b -> 'b -> 'b) -> ('a,'b) t -> ('a,'b) t -> ('a,'b) t =
  fun u yss1 yss2 ->
    match yss1, yss2 with
    | Empty vopt1, Empty vopt2 -> Empty (max_union_vopt u vopt1 vopt2)
    | Empty vopt1, Add (y2, vopt2) -> Add (y2, None)
    | Add (y1, vopt1), Empty vopt2 -> Add (y1, None)
    | Add ((y1,yss11,yss21), vopt1), Add ((y2,yss12,yss22), vopt2) ->
        let c = compare y1 y2 in
        if c = 0 then
          let yss', vopt' = yss_vopt (max_union u (max_subtract yss21 yss12) (max_subtract yss22 yss11)) in
          Add ((y1,max_union u yss11 yss12,yss'), vopt')
        else if c < 0 then
          let yss', vopt' = yss_vopt (max_union u yss21 (max_subtract yss2 yss11)) in
          Add ((y1,yss11,yss'), vopt')
        else (* c > 0 *)
          let yss', vopt' = yss_vopt (max_union u (max_subtract yss1 yss12) yss22) in
          Add ((y2,yss12,yss'), vopt')
and max_union_vopt u vopt1 vopt2 =
  match vopt1, vopt2 with
  | None, vopt2 -> vopt2
  | vopt1, None -> vopt1
  | Some v1, Some v2 -> Some (u v1 v2)

let max_add : ('b -> 'b -> 'b) -> 'a LSet.t -> 'b -> ('a,'b) t -> ('a,'b) t =
  fun u xs v yss ->
    max_union u yss (singleton xs v)

let rec from_list : ('b -> 'b -> 'b) -> ('a LSet.t * 'b) list -> ('a,'b) t =
  fun u -> function
  | [] -> empty
  | (x,v)::l -> add u x v (from_list u l)

let rec fold : ('a LSet.t -> 'b -> 'c -> 'c) -> ('a,'b) t -> 'c -> 'c =
  fun f yss e -> fold2 f yss e []
and fold2 f yss e ys =
  match yss with
  | Empty vopt -> 
      fold_vopt f vopt e ys
  | Add ((y,yss1,yss2),vopt) ->
      let e1 = fold2 f yss1 e (ys@[y]) in
      let e2 = fold2 f yss2 e1 ys in
      fold_vopt f vopt e2 ys
and fold_vopt f vopt e ys =
  match vopt with
  | None -> e
  | Some v -> f ys v e

let cardinal : ('a,'b) t -> int =
  fun yss -> fold (fun _ _ n -> n+1) yss 0

let rec mapfilter : ('a LSet.t -> 'b -> 'c option) -> ('a,'b) t -> ('a,'c) t =
  fun f yss -> mapfilter2 f yss []
and mapfilter2 f yss ys =
  match yss with
  | Empty vopt -> Empty (mapfilter_vopt f vopt ys)
  | Add ((y,yss1,yss2), vopt) ->
      let vopt' = mapfilter_vopt f vopt ys in
      match mapfilter2 f yss1 (ys@[y]), mapfilter2 f yss2 ys with
      | Empty None, Empty None -> Empty vopt'
      | yss1', yss2' -> Add ((y,yss1',yss2'), vopt')
and mapfilter_vopt f vopt ys =
  match vopt with
  | None -> None
  | Some v -> f ys v


let rec mapfilter_contained : ('a LSet.t -> 'b -> 'b option) -> ('a,'b) t -> 'a LSet.t -> ('a,'b) t =
  fun f yss xs -> mapfilter_contained2 f yss xs []
and mapfilter_contained2 f yss xs ys =
  match xs, yss with
  | _, Empty vopt -> Empty (mapfilter_contained_vopt f vopt ys)
  | [], Add (y, vopt) -> Add (y, mapfilter_contained_vopt f vopt ys)
  | x::xs1, Add ((y,yss1,yss2), vopt) ->
      let c = compare x y in
      if c = 0 then
        let vopt' = mapfilter_contained_vopt f vopt ys in
        match mapfilter_contained2 f yss1 xs1 (ys@[y]), mapfilter_contained2 f yss2 xs1 ys with
        | Empty None, Empty None -> Empty vopt'
        | yss1', yss2' -> Add ((y,yss1',yss2'), vopt')
      else if c < 0 then mapfilter_contained2 f yss xs1 ys
      else (* c > 0 *)
        let vopt' = mapfilter_contained_vopt f vopt ys in
        match yss1, mapfilter_contained2 f yss2 xs ys with
        | Empty None, Empty None -> Empty vopt'
        | yss1', yss2' -> Add ((y,yss1',yss2'), vopt')
and mapfilter_contained_vopt f vopt ys =
  match vopt with
  | None -> None
  | Some v -> f ys v


let rec mapfilter_contains : ('a LSet.t -> 'b -> 'b option) -> ('a,'b) t -> 'a LSet.t -> ('a,'b) t =
  fun f yss xs -> mapfilter_contains2 f yss xs []
and mapfilter_contains2 f yss xs ys =
  match xs, yss with
  | [], Empty vopt -> Empty (mapfilter_contains_vopt f vopt ys)
  | _, Empty vopt -> Empty vopt
  | [], Add ((y,yss1,yss2), vopt) ->
      Add ((y,mapfilter_contains2 f yss1 [] (ys@[y]),mapfilter_contains2 f yss2 [] ys), mapfilter_contains_vopt f vopt ys)
  | x::xs1, Add ((y,yss1,yss2), vopt) ->
      let c = compare x y in
      if c = 0 then
        match mapfilter_contains2 f yss1 xs1 (ys@[y]), yss2 with
        | Empty None, Empty None -> Empty vopt
        | yss1', yss2' -> Add ((y,yss1',yss2'), vopt)
      else if c < 0 then yss
      else (* c > 0 *)
        match mapfilter_contains2 f yss1 xs (ys@[y]), mapfilter_contains2 f yss2 xs ys with
        | Empty None, Empty None -> Empty vopt
        | yss1', yss2' -> Add ((y,yss1',yss2'), vopt)
and mapfilter_contains_vopt f vopt ys =
  match vopt with
  | None -> None
  | Some v -> f ys v

let rec map_inter : ('a LSet.t -> 'b -> 'a LSet.t -> 'b option) -> ('b -> 'b -> 'b) -> ('a,'b) t -> 'a LSet.t -> ('a,'b) t =
  fun f u yss xs -> map_inter2 f u yss xs [] []
and map_inter2 f u yss xs ys ys' =
  match xs, yss with
  | _, Empty vopt -> Empty (map_inter_vopt f vopt ys ys')
(*
  | [], Add ((_,_,_), Some v) ->
      let vopt' = map_inter_vopt f (Some v) ys ys' in
      Empty vopt'
*)
  | [], Add ((y,yss1,yss2), vopt) ->
      let yss1' = map_inter2 f u yss1 xs (ys@[y]) ys' in
      let yss2' = map_inter2 f u yss2 xs ys ys' in
      let vopt' = map_inter_vopt f vopt ys ys' in
      union u (Empty vopt') (union u yss1' yss2')
  | x::xs1, Add ((y,yss1,yss2), vopt) ->
     let c = compare x y in
     if c = 0 then
       let yss1' = map_inter2 f u yss1 xs1 (ys@[y]) (ys'@[y]) in
       let yss2', vopt'' = yss_vopt (map_inter2 f u yss2 xs1 ys ys') in
       let vopt' = map_inter_vopt f vopt ys ys' in
       Add ((y,yss1',yss2'), union_vopt u vopt' vopt'')
     else if c < 0 then map_inter2 f u yss xs1 ys ys'
     else (* c > 0 *)
       let yss1' = map_inter2 f u yss1 xs (ys@[y]) ys' in
       let yss2' = map_inter2 f u yss2 xs ys ys' in
       let vopt' = map_inter_vopt f vopt ys ys' in
       union u (Empty vopt') (union u yss1' yss2')
and map_inter_vopt f vopt ys ys' =
  match vopt with
  | None -> None
  | Some v -> f ys v ys'

let rec fold_inter : ('a LSet.t -> 'b -> 'a LSet.t -> 'c -> 'c) -> ('a,'b) t -> 'a LSet.t -> 'c -> 'c =
  fun f yss xs e -> fold_inter2 f yss xs e [] []
and fold_inter2 f yss xs e ys ys' =
  match xs, yss with
  | _, Empty vopt -> fold_inter_vopt f vopt e ys ys'
  | [], Add ((y,yss1,yss2), vopt) ->
     let e1 = fold_inter2 f yss1 xs e (ys@[y]) ys' in
     let e2 = fold_inter2 f yss2 xs e1 ys ys' in
     fold_inter_vopt f vopt e2 ys ys'
  | x::xs1, Add ((y,yss1,yss2), vopt) ->
     let c = compare x y in
     if c = 0 then
       let e1 = fold_inter2 f yss1 xs1 e (ys@[y]) (ys'@[y]) in
       let e2 = fold_inter2 f yss2 xs1 e1 ys ys' in
       fold_inter_vopt f vopt e2 ys ys'
     else if c < 0 then fold_inter2 f yss xs1 e ys ys'
     else (* c > 0 *)
       let e1 = fold_inter2 f yss1 xs e (ys@[y]) ys' in
       let e2 = fold_inter2 f yss2 xs e1 ys ys' in
       fold_inter_vopt f vopt e2 ys ys'
and fold_inter_vopt f vopt e ys ys' =
  match vopt with
  | None -> e
  | Some v -> f ys v ys' e