Re: 'a Set

Re: 'a Set

[tuzi]

[-- Attachment #1: Type: text/plain, Size: 549 bytes --]


> Is there any clean way to make a type 'a set, corresponding to
> Set.Make 
> of a module with type t='a and compare=Pervasives.compare?  I'm
> trying 
> to make a module which uses sets of arbitrary types of objects, and I 
> don't want to have to make it a functor.

I do not like functors.
Sometimes it is not convenient. 
So, i have modified the standard lib's Set, Map and Hashtbl into
non-functor versions.
It is actually rearrange of standard lib's Set . 
Here is the code , I hope it will help.
(It is called PtkSet)

Best regards

Tuzi 


[-- Attachment #2: ptkSet.ml --]
[-- Type: text/plain, Size: 9300 bytes --]

type 'a cell = Empty | Node of 'a cell * 'a * 'a cell * int  

type 'a t = {
  compare : 'a -> 'a -> int;
  mutable set : 'a cell;
}

let create compare = {
  compare = compare;
  set = Empty;
}

let height_cell s = 
  match s with
  Empty -> 0
 |Node (_,_,_,h) -> h

let create_cell l v r =
  let hl = match l with Empty -> 0 | Node (_,_,_,h) -> h in
  let hr = match r with Empty -> 0 | Node (_,_,_,h) -> h in
  Node(l,v,r,(if hl >= hr then hl +1 else hr +1))
  

let bal_cell l v r =
  let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in
  let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in
  if hl > hr + 2 then (
    match l with
      Empty -> invalid_arg "PtkSet.bal"
    | Node(ll, lv, lr, _) ->
        if height_cell ll >= height_cell lr then
          create_cell ll lv (create_cell lr v r)
        else (
          match lr with
            Empty -> invalid_arg "PtkSet.bal"
          | Node(lrl, lrv, lrr, _)->
              create_cell (create_cell ll lv lrl) lrv (create_cell lrr v r)
        )
  )
  else if hr > hl + 2 then (
    match r with
      Empty -> invalid_arg "PtkSet.bal"
    | Node(rl, rv, rr, _) ->
        if height_cell rr >= height_cell rl then
          create_cell (create_cell l v rl) rv rr
        else (
          match rl with
            Empty -> invalid_arg "PtkSet.bal"
          | Node(rll, rlv, rlr, _) ->
              create_cell (create_cell l v rll) rlv (create_cell rlr rv rr)
        )
  )
  else
    Node(l, v, r, (if hl >= hr then hl + 1 else hr + 1))

let rec add_cell x compare  = function 
   Empty -> Node(Empty, x, Empty, 1)
  |Node(l, v, r, _) as t ->
    let c = compare x v in
    if c = 0 then t 
    else if c < 0 then bal_cell (add_cell x compare l) v r 
    else bal_cell l v (add_cell x compare  r)


let add s x =
  let set =  add_cell x s.compare s.set in
  s.set <- set

let rec join_cell l v r compare=
  match (l, r) with
    (Empty, _) -> add_cell v compare r
  | (_, Empty) -> add_cell v compare l
  | (Node(ll, lv, lr, lh), Node(rl, rv, rr, rh)) ->
      if lh > rh + 2 then bal_cell ll lv (join_cell lr v r compare) else
      if rh > lh + 2 then bal_cell (join_cell l v rl compare) rv rr else
      create_cell l v r

let rec min_elt_cell = function
    Empty -> raise Not_found
  | Node(Empty, v, r, _) -> v
  | Node(l, v, r, _) -> min_elt_cell l

let min_elt s =
  min_elt_cell s.set

let rec max_elt_cell = function
    Empty -> raise Not_found
  | Node(l, v, Empty, _) -> v
  | Node(l, v, r, _) -> max_elt_cell  r

let max_elt s =
  max_elt_cell s.set

let rec remove_min_elt = function
    Empty -> invalid_arg "PtkSet.remove_min_elt"
  | Node(Empty, v, r, _) -> r
  | Node(l, v, r, _) -> bal_cell (remove_min_elt l) v r

let merge_cell t1 t2 =
  match (t1, t2) with
    (Empty, t) -> t
  | (t, Empty) -> t
  | (_, _) -> bal_cell t1 (min_elt_cell t2) (remove_min_elt t2)

let concat_cell t1 t2 compare =
  match (t1, t2) with
    (Empty, t) -> t
  | (t, Empty) -> t
  | (_, _) -> join_cell t1 (min_elt_cell t2) (remove_min_elt t2) compare

let rec split_cell x compare  = function
    Empty -> (Empty, false, Empty)
  | Node(l, v, r, _) ->
      let c = compare x v in
      if c = 0 then (l, true, r)
      else if c < 0 then
        let (ll, pres, rl) = split_cell x compare l in 
        (ll, pres, join_cell rl v r compare)
      else
        let (lr, pres, rr) = split_cell x compare r in 
        (join_cell l v lr compare, pres,  rr)

let is_empty_cell = function Empty -> true | _ -> false

let is_empty s = 
  is_empty_cell s.set

let rec mem_cell x compare = function
    Empty -> false
  | Node(l, v, r, _) -> 
      let c = compare x v in
      c = 0 || mem_cell x compare (if c < 0 then l else r)

let mem s x =
  mem_cell x s.compare s.set

  
let rec remove_cell x compare  = function
    Empty -> Empty
  | Node(l, v, r, _) ->
      let c = compare x v in
      if c = 0 then merge_cell l r 
      else if c < 0 then bal_cell (remove_cell x compare l) v r 
      else bal_cell l v (remove_cell x compare r)

let remove s x =
  let set =  remove_cell x s.compare s.set in
  s.set <- set

let rec union_cell s1 s2 compare =
  match (s1, s2) with
    (Empty, t2) -> t2
  | (t1, Empty) -> t1
  | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) ->
      if h1 >= h2 then
        if h2 = 1 then add_cell v2 compare  s1 else (
          let (l2, _, r2) = split_cell v1 compare s2 in
          join_cell (union_cell l1 l2 compare) v1 (union_cell r1 r2 compare)
            compare
         )
        else
          if h1 = 1 then add_cell v1 compare  s2 else (
            let (l1, _, r1) = split_cell v2 compare s1 in
            join_cell (union_cell l1 l2 compare) v2 (union_cell r1 r2 compare)
              compare
          )

let union s1 s2 =
  let set = union_cell s1.set s2.set s1.compare in
  {
    compare = s1.compare;
    set = set
  }

let rec inter_cell s1 s2 compare =
  match (s1, s2) with
    (Empty, t2) -> Empty
  | (t1, Empty) -> Empty
  | (Node(l1, v1, r1, _), t2) ->
      match split_cell v1 compare t2 with
        (l2, false, r2) -> 
          concat_cell (inter_cell l1 l2 compare) (inter_cell r1 r2 compare)
            compare 
      | (l2, true, r2) -> 
          join_cell (inter_cell l1 l2 compare) v1 (inter_cell r1 r2 compare) compare

let inter s1 s2 =
  let set = inter_cell s1.set s2.set s1.compare in
  {
    compare = s1.compare;
    set = set;
  }
    

let rec diff_cell s1 s2 compare =
  match (s1, s2) with
    (Empty, t2) -> Empty
  | (t1, Empty) -> t1
  | (Node(l1, v1, r1, _), t2) ->
      match split_cell v1 compare t2 with
       (l2, false, r2) ->
         join_cell (diff_cell l1 l2 compare) v1 (diff_cell r1 r2 compare) compare
     | (l2, true, r2) ->
         concat_cell (diff_cell l1 l2 compare) (diff_cell r1 r2 compare) compare

let diff s1 s2 =
  let set = diff_cell s1.set s2.set s1.compare in
  {
    compare = s1.compare;
    set=set
  }

let rec compare_aux_cell l1 l2 compare =
  match (l1, l2) with
    ([], []) -> 0
  | ([], _)  -> -1
  | (_, []) -> 1
  | (Empty :: t1, Empty :: t2) ->
      compare_aux_cell t1 t2 compare
  | (Node(Empty, v1, r1, _) :: t1, Node(Empty, v2, r2, _) :: t2) ->
      let c = compare v1 v2 in
      if c <> 0 then c else compare_aux_cell (r1::t1) (r2::t2) compare
  | (Node(l1, v1, r1, _ ) :: t1, t2) ->
      compare_aux_cell (l1 :: Node(Empty, v1, r1, 0) :: t1) t2 compare
  | (t1, Node(l2, v2, r2, _) :: t2) ->
      compare_aux_cell t1 (l2 :: Node(Empty, v2, r2, 0) :: t2) compare

let compare  s1 s2 =
  compare_aux_cell [s1.set] [s2.set] s1.compare

let equal s1 s2 =
  compare s1 s2 = 0

let rec subset_cell s1 s2 compare =
  match (s1, s2) with
    Empty, _ -> true
  | _, Empty -> false
  | Node (l1, v1, r1, _), (Node (l2, v2, r2, _) as t2) ->
      let c = compare v1 v2 in
      if c = 0 then subset_cell l1 l2 compare && subset_cell r1 r2 compare
      else if c < 0 then  
        subset_cell (Node (l1, v1, Empty, 0)) l2 compare && 
        subset_cell r1 t2 compare
      else
        subset_cell (Node (Empty, v1, r1, 0)) r2 compare && 
        subset_cell l1 t2 compare

let subset s1 s2 =
  subset_cell s1.set s2.set s1.compare

let rec iter_cell f = function
    Empty -> ()
  | Node(l, v, r, _) -> (
      iter_cell f l; 
      f v; 
      iter_cell f r
  )
let iter s f = 
  iter_cell f s.set

let rec fold_cell f s accu =
  match s with
    Empty -> accu
  | Node(l, v, r, _) -> fold_cell f l (f v (fold_cell f r accu))

let fold s a f = 
  fold_cell f a s.set
  
let rec for_all_cell p = function
    Empty -> true
  | Node(l, v, r, _) -> p v && for_all_cell p l && for_all_cell p r

let for_all s f =
  for_all_cell f s.set

let rec exists_cell p = function
    Empty -> false
  | Node(l, v, r, _) -> p v || exists_cell p l || exists_cell p r

let exists s f =
  exists_cell f s.set

let filter_cell p s compare =
  let rec filt accu = function
    | Empty -> accu
    | Node(l, v, r, _) ->
        filt (filt (if p v then add_cell v compare accu  else accu) l) r in
  filt Empty s

let filter s f =
  let set = filter_cell f s.set s.compare in
  {
    compare = s.compare;
    set = s.set
  }

let partition_cell p s compare =
  let rec part (t, f as accu) = function
    | Empty -> accu
    | Node(l, v, r, _) ->
        part (part (
          if p v then (add_cell v compare t, f) 
          else (t, add_cell v compare f)) l
        ) r in
  part (Empty, Empty) s

let partition s f =
  let r = partition_cell f s.set s.compare in
  let s1 = {
    compare=s.compare;
    set= fst r
  } in
  let s2 = {
    compare=s.compare;
    set=snd r
  } in
  (s1,s2)

let rec cardinal_cell = function
    Empty -> 0
  | Node(l, v, r, _) -> cardinal_cell l + 1 + cardinal_cell r

let size s = cardinal_cell s.set


let rec elements_aux_cell accu = function
    Empty -> accu
  | Node(l, v, r, _) -> elements_aux_cell (v :: elements_aux_cell accu r) l

let elements s =
  elements_aux_cell [] s.set


let demo () =
  let a = [1;2;3;4;5;6] in
  let b = [2;32;3;4;121;6;7;8] in
  let sa = create (fun x1 x2 -> x1 - x2) in
  List.iter (fun x -> add sa x) a ;
  let sb = create (fun x1 x2 -> x1 - x2) in
  List.iter (fun x -> add sb x) b;
  let sc = union sb sa in
  remove sb 32;
  let na= size sa in
  let nb = size sb in
  Printf.printf "nb=%i\n" na;
  PervEx.println_bool (subset sb sc)






[-- Attachment #3: ptkSet.mli --]
[-- Type: text/plain, Size: 819 bytes --]

(** None functor version of Set modified from standard library
*)

type 'a t 

(** [create compare]*)
val create : ('a -> 'a -> int) -> 'a t

val add : 'a t -> 'a -> unit

val size : 'a t -> int

val min_elt : 'a t -> 'a

val max_elt : 'a t -> 'a

val is_empty : 'a t -> bool

val mem : 'a t -> 'a -> bool

val remove : 'a t -> 'a -> unit

val union : 'a t -> 'a t -> 'a t

val inter : 'a t -> 'a t -> 'a t

val diff : 'a t -> 'a t -> 'a t

val compare : 'a t -> 'a t -> int

val equal : 'a t -> 'a t -> bool

(** [subset s1 s2]
    tests whether the set [s1] is a subset of the set [s2]
*)
val subset : 'a t -> 'a t -> bool

val iter : 'a t -> ( 'a -> unit) -> unit

val filter : 'a t -> ('a -> bool) ->'a t

val partition : 'a t -> ('a -> bool) -> 'a t * 'a t

val elements : 'a t -> 'a list

val demo : unit -> unit