Commits

Sébastien Ferré committed 7308e5f

Initial revision

Comments (0)

Files changed (1)

+
+module Mask =
+  struct
+    type t = bool list
+    let dim bs = List.length bs
+    let size bs = List.fold_left (fun res b -> if b then res + 1 else res) 0 bs
+  end
+
+module type T =
+  sig
+    type t
+    exception Invalid_dimension
+    val dim : t -> int
+    val empty : int -> t
+    val is_empty : t -> bool
+    val cardinal : t -> int
+    val mem : int list -> t -> bool
+    val singleton : int list -> t
+    val add : int list -> t -> t
+    val remove : int list -> t -> t
+    val union : t -> t -> t
+    val inter : t -> t -> t
+    val diff : t -> t -> t
+    val union_r : t list -> t
+    val inter_r : t list -> t
+    val fold : ('a -> int list -> 'a) -> 'a -> t -> 'a
+    val iter : (int list -> unit) -> t -> unit
+
+    val select : Mask.t -> t -> t
+    val group_by : Mask.t -> t -> t
+    val restriction : int -> ?filter:(int list -> t -> bool) -> t -> t
+	(* restriction k (int^(n-k) -> t_k -> bool) t_n -> t_(n-k) *)
+    val extension : int -> (int list -> t) -> t -> t
+	(* extension k (int^n -> t_k) -> t_n -> t_(n+k) *)
+
+    val memory_size : t -> int
+  end
+
+module Intmap : T =
+  struct
+    module M = Intmap.M
+
+    type t = {dim : int; data : Obj.t}
+	  
+    exception Invalid_dimension
+	
+    (* utilities *)
+
+    type obj = R0 of bool | R1 of unit M.t | Rn of int * Obj.t M.t
+	
+    let repr = function
+      | R0 b -> if b then Obj.repr () else Obj.repr M.empty
+      | R1 s -> Obj.repr s
+      | Rn (_,m) -> Obj.repr m
+	    
+    let obj n d =
+      if n = 0 then R0 (d = Obj.repr ())
+      else if n = 1 then R1 (Obj.obj d : unit M.t)
+      else Rn (n, (Obj.obj d : Obj.t M.t))
+	  
+    let split xs = List.hd xs, List.tl xs
+
+    (* public interface *)
+
+    let dim r = r.dim
+	
+    let empty n =
+      {dim = n; data = Obj.repr M.empty}
+    let empty_obj n =
+      if n = 0 then R0 false
+      else if n = 1 then R1 M.empty
+      else Rn (n,M.empty)
+	  
+    let is_empty r = (r.data = Obj.repr M.empty)
+    let is_empty_obj = function
+      | R0 b -> not b
+      | R1 s -> M.is_empty s
+      | Rn (n,m) -> M.is_empty m
+	
+    let rec cardinal r =
+      cardinal_obj (obj r.dim r.data)
+    and cardinal_obj = function
+      | R0 b -> if b then 1 else 0
+      | R1 s -> M.cardinal s
+      | Rn (n, m) -> M.fold (fun res x d1 -> res + cardinal_obj (obj (n-1) d1)) 0 m
+	    
+    let rec mem xs r =
+      if List.length xs = r.dim
+      then mem_obj xs (obj r.dim r.data)
+      else raise Invalid_dimension
+    and mem_obj xs = function
+      | R0 b -> b
+      | R1 s -> M.mem (List.hd xs) s
+      | Rn (n, m) ->
+	  let x, xs1 = split xs in
+	  try mem_obj xs1 (obj (n-1) (M.get x m))
+	  with Not_found -> false
+
+    let rec singleton xs =
+      let n = List.length xs in
+      {dim = n; data = repr (singleton_obj n xs)}
+    and singleton_obj n = function
+      | [] -> R0 true
+      | [x] -> R1 (M.singleton x)
+      | x::xs1 -> Rn (n, M.set x (repr (singleton_obj (n-1) xs1)) M.empty)
+	      
+    let rec add xs r =
+      if List.length xs = r.dim
+      then {r with data = repr (add_obj xs (obj r.dim r.data))}
+      else raise Invalid_dimension
+    and add_obj xs = function
+      | R0 _ -> R0 true
+      | R1 s -> R1 (M.add (List.hd xs) s)
+      | Rn (n,m) ->
+	  let x, xs1 = split xs in
+	  let d1 = try obj (n-1) (M.get x m) with Not_found -> empty_obj (n-1) in
+	  Rn (n, M.set x (repr (add_obj xs1 d1)) m)
+
+    let rec remove xs r =
+      if List.length xs = r.dim
+      then {r with data = repr (remove_obj xs (obj r.dim r.data))}
+      else raise Invalid_dimension
+    and remove_obj xs = function
+      | R0 _ -> R0 false
+      | R1 s -> R1 (M.remove (List.hd xs) s)
+      | Rn (n,m) ->
+	  let x, xs1 = split xs in
+	  try
+	    let d1' = remove_obj xs1 (obj (n-1) (M.get x m)) in
+	    if is_empty_obj d1'
+	    then Rn (n, M.remove x m)
+	    else Rn (n, M.set x (repr d1') m)
+	  with Not_found ->
+	    Rn (n,m)
+
+    let rec union r1 r2 =
+      if r1.dim = r2.dim
+      then {dim = r1.dim; data = repr (union_obj (obj r1.dim r1.data) (obj r2.dim r2.data))}
+      else raise Invalid_dimension
+    and union_obj d1 d2 =
+      match d1, d2 with
+      | R0 b1, R0 b2 -> R0 (b1 || b2)
+      | R1 s1, R1 s2 -> R1 (M.domain_union s1 s2)
+      | Rn (n,m1), Rn (_,m2) ->
+	  let n1 = n-1 in
+	  Rn (n,
+	      M.map_union
+		(fun x d1_opt d2_opt ->
+		  match d1_opt, d2_opt with
+		  | None, None -> None
+		  | Some _, None -> d1_opt
+		  | None, Some _ -> d2_opt
+		  | Some d1, Some d2 -> Some (repr (union_obj (obj n1 d1) (obj n1 d2))))
+		m1 m2)
+      | _, _ -> assert false
+
+    let rec inter r1 r2 =
+      if r1.dim = r2.dim
+      then {dim = r1.dim; data = repr (inter_obj (obj r1.dim r1.data) (obj r2.dim r2.data))}
+      else raise Invalid_dimension
+    and inter_obj d1 d2 =
+      match d1, d2 with
+      | R0 b1, R0 b2 -> R0 (b1 && b2)
+      | R1 s1, R1 s2 -> R1 (M.domain_inter s1 s2)
+      | Rn (n,m1), Rn (_,m2) ->
+	  let n1 = n-1 in
+	  Rn (n,
+	      M.map_inter
+		(fun x d1 d2 ->
+		  let d = inter_obj (obj n1 d1) (obj n1 d2) in
+		  if is_empty_obj d
+		  then None
+		  else Some (repr d))
+		m1 m2)
+      | _, _ -> assert false
+
+    let rec diff r1 r2 =
+      if r1.dim = r2.dim
+      then {dim = r1.dim; data = repr (diff_obj (obj r1.dim r1.data) (obj r2.dim r2.data))}
+      else raise Invalid_dimension
+    and diff_obj d1 d2 =
+      match d1, d2 with
+      | R0 b1, R0 b2 -> R0 (b1 && not b2)
+      | R1 s1, R1 s2 -> R1 (M.domain_diff s1 s2)
+      | Rn (n,m1), Rn (_,m2) ->
+	  let n1 = n-1 in
+	  Rn (n,
+	      M.map_diff
+		(fun x d1 d2_opt ->
+		  match d2_opt with
+		  | None -> Some d1
+		  | Some d2 ->
+		      let d = diff_obj (obj n1 d1) (obj n1 d2) in
+		      if is_empty_obj d
+		      then None
+		      else Some (repr d))
+		m1 m2)
+      | _, _ -> assert false
+
+    let union_r = function
+      | [] -> invalid_arg "Intreln.Intmap.union_r: empty list of relations"
+      | r::rs -> List.fold_left union r rs
+
+    let inter_r = function
+      | [] -> invalid_arg "Intreln.Intmap.inter_r : empty list of relations"
+      | r::rs -> List.fold_left inter r rs
+
+    let rec fold f init r =
+      fold_obj f init [] (obj r.dim r.data)
+    and fold_obj f acc xs = function
+      | R0 b -> if b then f acc [] else acc
+      | R1 s -> M.fold (fun res x _ -> f res (List.rev (x::xs))) acc s
+      | Rn (n,m) ->
+	  let n1 = n-1 in
+	  M.fold
+	    (fun res x d1 ->
+	      fold_obj f res (x::xs) (obj n1 d1))
+	    acc m
+
+    let rec iter f r =
+      iter_obj f [] (obj r.dim r.data)
+    and iter_obj f xs = function
+      | R0 b -> if b then f [] else ()
+      | R1 s -> M.iter (fun x _ -> f (List.rev (x::xs))) s
+      | Rn (n,m) ->
+	  let n1 = n-1 in
+	  M.iter
+	    (fun x d1 ->
+	      iter_obj f (x::xs) (obj n1 d1))
+	    m
+
+
+    let rec select ps r =
+      if Mask.dim ps = r.dim
+      then {dim = Mask.size ps;
+	    data = repr (select_obj ps (obj r.dim r.data))}
+      else raise Invalid_dimension
+    and select_obj ps = function
+      | R0 b -> R0 b
+      | R1 s ->
+	  if List.hd ps
+	  then R1 s
+	  else R0 (not (M.is_empty s))
+      | Rn (n,m) ->
+	  let n1 = n-1 in
+	  let p, ps1 = split ps in
+	  let n' = Mask.size ps in
+	  if p
+	  then 
+	    if n' = 1
+	    then R1 (M.domain m)
+	    else Rn (n', M.map (fun x d1 -> Some (repr (select_obj ps1 (obj n1 d1)))) m)
+	  else
+	    let n1' = Mask.size ps1 in
+	    if n1' = 0
+	    then R0 (not (M.is_empty m))
+	    else M.fold (fun res x d1 -> union_obj res (select_obj ps1 (obj n1 d1))) (empty_obj n1') m
+
+    let rec group_by ps r =
+      if Mask.dim ps = r.dim
+      then {dim = Mask.size ps;
+	    data = repr (group_by_obj ps [] (obj r.dim r.data))}
+      else raise Invalid_dimension
+    and group_by_obj ps xs = function
+      | R0 b ->
+	  if b
+	  then singleton_obj (List.length xs) (List.rev xs)
+	  else R0 false
+      | R1 s ->
+	  if xs = []
+	  then R1 s
+	  else
+	    let k = List.length xs in
+	    if List.hd ps
+	    then
+	      let xs' = List.rev xs in
+	      Rn (1+k, M.map (fun x _ -> Some (repr (singleton_obj k xs'))) s)
+	    else
+	      let k' = 1 + k in
+	      M.fold (fun res x _ -> union_obj res (singleton_obj k' (List.rev (x::xs)))) (empty_obj k') s
+      | Rn (n,m) ->
+	  let n1 = n-1 in
+	  let k = List.length xs in
+	  let p, ps1 = split ps in
+	  if p
+	  then Rn (n+k, M.map (fun x d1 -> Some (repr (group_by_obj ps1 xs (obj n1 d1)))) m)
+	  else M.fold (fun res x d1 -> union_obj res (group_by_obj ps1 (x::xs) (obj n1 d1))) (empty_obj (n+k)) m
+
+    let rec restriction k ?(filter = fun xs r_k -> true) r =
+      if k >= 0 && k <= r.dim
+      then {dim = r.dim - k; data = repr (restriction_obj k filter [] (obj r.dim r.data))}
+      else raise Invalid_dimension
+    and restriction_obj k f xs = function
+      | R0 b ->
+	  if b
+	  then R0 (f (List.rev xs) {dim=0; data=Obj.repr ()})
+	  else R0 false
+      | R1 s ->
+	  if k = 1 then R0 (f (List.rev xs) {dim=1; data=Obj.repr s})
+	  else (* k = 0 *)
+	    R1 (M.domain ~filter:(fun x d1 -> f (List.rev (x::xs)) {dim=0; data=Obj.repr ()}) s)
+      | Rn (n,m) ->
+	  if k = n then R0 (f (List.rev xs) {dim=n; data=Obj.repr m})
+	  else if k+1 = n then R1 (M.domain ~filter:(fun x d1 -> f (List.rev (x::xs)) {dim=k; data=d1}) m)
+	  else
+	    let n1 = n-1 in
+	    Rn (n-k, M.map (fun x d1 -> Some (repr (restriction_obj k f (x::xs) (obj n1 d1)))) m)
+
+    let rec extension k f r =
+      if k >= 0
+      then {dim = r.dim + k; data = repr (extension_obj k f [] (obj r.dim r.data))}
+      else raise Invalid_dimension
+    and extension_obj k f xs = function
+      | R0 b ->
+	  if b
+	  then
+	    let r_k = f xs in
+	    if r_k.dim <> k then raise Invalid_dimension;
+	    if is_empty r_k
+	    then empty_obj k
+	    else obj r_k.dim r_k.data
+	  else empty_obj k
+      | R1 s ->
+	  if k = 0
+	  then R1 (M.domain
+		     ~filter:(fun x _ -> 
+		       let r_k = f (List.rev (x::xs)) in
+		       if r_k.dim <> k then raise Invalid_dimension;
+		       not (is_empty r_k))
+		     s)
+	  else Rn (1+k,
+		   M.map
+		     (fun x _ ->
+		       let r_k = f (List.rev (x::xs)) in
+		       if r_k.dim <> k then raise Invalid_dimension;
+		       if is_empty r_k
+		       then None
+		       else Some r_k.data)
+		     s)
+      | Rn (n,m) ->
+	  let n1 = n-1 in
+	  Rn (n + k,
+	      M.map
+		(fun x d1 ->
+		  let d1_k = extension_obj k f (x::xs) (obj n1 d1) in
+		  if is_empty_obj d1_k
+		  then None
+		  else Some (repr d1_k))
+		m)
+
+    let rec memory_size r =
+      3 (* reference + tag + dim *)
+	+ memory_size_obj (obj r.dim r.data)
+    and memory_size_obj = function
+      | R0 _ -> 1
+      | R1 s -> M.memory_size s
+      | Rn (n,m) -> M.memory_size ~f:(fun d1 -> memory_size_obj (obj (n-1) d1)) m
+
+  end