1. Sébastien Ferré
  2. ocaml-lib

Commits

sbf  committed 35c5d91

Many new functions.

  • Participants
  • Parent commits 0df9257
  • Branches master

Comments (0)

Files changed (1)

File setset.ml

View file
     try ignore (find yss xs); true
     with Not_found -> true
 
+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 =
   | 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
   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 =
 
 let max_add : ('b -> 'b -> 'b) -> 'a LSet.t -> 'b -> ('a,'b) t -> ('a,'b) t =
   fun u xs v yss ->
-    max_union u (singleton 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
   | 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 =
   | 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 [] []