Commits

Sébastien Ferré committed 2c2c01f

new functions:
- fold_restr
- filter_restr
- project

Comments (0)

Files changed (1)

     val union_r : t list -> t
     val inter_r : t list -> t
     val fold : ('a -> int list -> 'a) -> 'a -> t -> 'a
+    val fold_restr : (string * int) list -> string list -> ('a -> (string * int) list -> 'a) -> 'a -> t -> 'a
+    val filter_restr : (string * int) list -> string list -> ((string * int) list -> bool) -> t -> t
     val iter : (int list -> unit) -> t -> unit
 
-    val select : Mask.t -> t -> t
+    val project : 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) *)
     module M = Intmap.M
 
     type t = {dim : int; data : Obj.t}
-	  
+
     exception Invalid_dimension
 	
     (* utilities *)
 
     let dim r = r.dim
 	
-    let empty n =
-      {dim = n; data = Obj.repr M.empty}
-    let empty_obj n =
+    let rec empty n =
+      {dim = n; data = repr (empty_obj n)}
+    and 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
+    let rec is_empty r = is_empty_obj (obj r.dim r.data) (*r.data = Obj.repr M.empty*)
+    and is_empty_obj = function
       | R0 b -> not b
       | R1 s -> M.is_empty s
       | Rn (n,m) -> M.is_empty m
       | R0 _ -> R0 true
       | R1 s -> R1 (M.add (List.hd xs) s)
       | Rn (n,m) ->
+	  let n1 = n-1 in
 	  let x, xs1 = split xs in
-	  let d1 = try obj (n-1) (M.get x m) with Not_found -> empty_obj (n-1) in
+	  let d1 = try obj n1 (M.get x m) with Not_found -> empty_obj n1 in
 	  Rn (n, M.set x (repr (add_obj xs1 d1)) m)
 
     let rec remove xs r =
 	      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 =
+    let rec project ps r =
       if Mask.dim ps = r.dim
-      then {dim = Mask.size ps;
-	    data = repr (select_obj ps (obj r.dim r.data))}
+      then
+	if Mask.size ps = r.dim
+	then r
+	else{dim = Mask.size ps;
+	     data = repr (project_obj ps (obj r.dim r.data))}
       else raise Invalid_dimension
-    and select_obj ps = function
+    and project_obj ps = function
       | R0 b -> R0 b
       | R1 s ->
 	  if List.hd ps
 	  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 Rn (n', M.map (fun x d1 -> Some (repr (project_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
+	    else M.fold (fun res x d1 -> union_obj res (project_obj ps1 (obj n1 d1))) (empty_obj n1') m
+
+    let rec fold_restr mu vs f init r =
+         (* "" variables must be ignored in generated mappings *)
+      let r' = project (List.map ((<>) "") vs) r in (* done to avoid doublons when folding *)
+      let vs' = List.filter ((<>) "") vs in
+      fold_restr_obj f init mu vs' (obj r'.dim r'.data)
+    and fold_restr_obj f acc mu vs = function
+      | R0 b -> if b then f acc mu else acc
+      | R1 s ->
+	  let v = List.hd vs in
+	  (try
+	    let x = List.assoc v mu in
+	    if M.mem x s
+	    then f acc mu
+	    else acc
+	  with Not_found ->
+	    M.fold (fun res x _ -> f res ((v,x)::mu)) acc s)
+      | Rn (n,m) ->
+	  let n1 = n-1 in
+	  let v = List.hd vs in
+	  (try
+	    let x = List.assoc v mu in
+	    try
+	      let d1 = M.get x m in
+	      fold_restr_obj f acc mu (List.tl vs) (obj n1 d1)
+	    with Not_found ->
+	      acc
+	  with Not_found ->
+	    M.fold
+	      (fun res x d1 ->
+		fold_restr_obj f res ((v,x)::mu) (List.tl vs) (obj n1 d1))
+	      acc m)
+
+    let rec filter_restr mu vs f r =
+         (* "" variables must be ignored in generated mappings *)
+      let r' = project (List.map ((<>) "") vs) r in (* done to avoid doublons when folding *)
+      let vs' = List.filter ((<>) "") vs in
+      {dim = List.length vs'; data = repr (filter_restr_obj f mu vs' (obj r'.dim r'.data))}
+    and filter_restr_obj f mu vs = function
+      | R0 b -> R0 (b && f mu)
+      | R1 s ->
+	  let v = List.hd vs in
+	  (try
+	    let x = List.assoc v mu in
+	    if M.mem x s && f mu
+	    then R1 s
+	    else R1 M.empty
+	  with Not_found ->
+	    R1 (M.domain ~filter:(fun x _ -> f ((v,x)::mu)) s))
+      | Rn (n,m) ->
+	  let n1 = n-1 in
+	  let v = List.hd vs in
+	  (try
+	    let x = List.assoc v mu in
+	    try
+	      let d1 = M.get x m in
+	      let d1' = filter_restr_obj f mu (List.tl vs) (obj n1 d1) 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)
+	  with Not_found ->
+	    Rn (n,
+		M.map
+		  (fun x d1 ->
+		    let d1' = filter_restr_obj f ((v,x)::mu) (List.tl vs) (obj n1 d1) in
+		    if is_empty_obj d1'
+		    then None
+		    else Some (repr d1'))
+		  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 group_by ps r =
       if Mask.dim ps = r.dim