| 1212 |
if o && LabelMap.is_empty l then any_record else |
if o && LabelMap.is_empty l then any_record else |
| 1213 |
{ empty with record = BoolRec.atom (o,l) } |
{ empty with record = BoolRec.atom (o,l) } |
| 1214 |
|
|
| 1215 |
type zor = Pair of descr * descr | Any | Empty |
type zor = Pair of descr * descr | Any |
| 1216 |
|
|
| 1217 |
let aux d l= |
let aux_split d l= |
| 1218 |
let f (o,r) = |
let f (o,r) = |
| 1219 |
try |
try |
| 1220 |
let (lt,rem) = LabelMap.assoc_remove l r in |
let (lt,rem) = LabelMap.assoc_remove l r in |
| 1223 |
if o then |
if o then |
| 1224 |
if LabelMap.is_empty r then Any else |
if LabelMap.is_empty r then Any else |
| 1225 |
Pair (any_or_absent, { empty with record = BoolRec.atom (o,r) }) |
Pair (any_or_absent, { empty with record = BoolRec.atom (o,r) }) |
| 1226 |
else Empty |
else |
| 1227 |
|
Pair ({empty with absent = true}, |
| 1228 |
|
{ empty with record = BoolRec.atom (o,r) }) |
| 1229 |
in |
in |
| 1230 |
List.fold_left |
List.fold_left |
| 1231 |
(fun b (p,n) -> |
(fun b (p,n) -> |
| 1233 |
| x::p -> |
| x::p -> |
| 1234 |
(match f x with |
(match f x with |
| 1235 |
| Pair (t1,t2) -> aux_p ((t1,t2)::accu) p |
| Pair (t1,t2) -> aux_p ((t1,t2)::accu) p |
| 1236 |
| Any -> aux_p accu p |
| Any -> aux_p accu p) |
|
| Empty -> b) |
|
| 1237 |
| [] -> aux_n accu [] n |
| [] -> aux_n accu [] n |
| 1238 |
and aux_n p accu = function |
and aux_n p accu = function |
| 1239 |
| x::n -> |
| x::n -> |
| 1240 |
(match f x with |
(match f x with |
| 1241 |
| Pair (t1,t2) -> aux_n p ((t1,t2)::accu) n |
| Pair (t1,t2) -> aux_n p ((t1,t2)::accu) n |
|
| Empty -> aux_n p accu n |
|
| 1242 |
| Any -> b) |
| Any -> b) |
| 1243 |
| [] -> (p,accu) :: b in |
| [] -> (p,accu) :: b in |
| 1244 |
aux_p [] p) |
aux_p [] p) |
| 1246 |
(BoolRec.get d.record) |
(BoolRec.get d.record) |
| 1247 |
|
|
| 1248 |
let split (d : descr) l = |
let split (d : descr) l = |
| 1249 |
TR.boolean (aux d l) |
TR.boolean (aux_split d l) |
| 1250 |
|
|
| 1251 |
let split_normal d l = |
let split_normal d l = |
| 1252 |
TR.boolean_normal (aux d l) |
TR.boolean_normal (aux_split d l) |
| 1253 |
|
|
| 1254 |
|
|
| 1255 |
let project d l = |
let project d l = |
| 1257 |
if t.absent then raise Not_found; |
if t.absent then raise Not_found; |
| 1258 |
t |
t |
| 1259 |
|
|
| 1260 |
|
let remove_field d l = |
| 1261 |
|
TR.pi2 (split d l) |
| 1262 |
|
|
| 1263 |
let first_label d = |
let first_label d = |
| 1264 |
let min = ref LabelPool.dummy_max in |
let min = ref LabelPool.dummy_max in |
| 1265 |
let aux (_,r) = |
let aux (_,r) = |
| 1280 |
(x land 2 <> 0, x land 1 <> 0) |
(x land 2 <> 0, x land 1 <> 0) |
| 1281 |
|
|
| 1282 |
|
|
| 1283 |
|
(*TODO: optimize merge |
| 1284 |
|
- pre-compute the sequence of labels |
| 1285 |
|
- remove empty or full { l = t } |
| 1286 |
|
*) |
| 1287 |
|
|
| 1288 |
|
let merge d1 d2 = |
| 1289 |
|
let res = ref empty in |
| 1290 |
|
let rec aux accu d1 d2 = |
| 1291 |
|
let l = min (first_label d1) (first_label d2) in |
| 1292 |
|
if l = LabelPool.dummy_max then |
| 1293 |
|
let (some1,none1) = empty_cases d1 |
| 1294 |
|
and (some2,none2) = empty_cases d2 in |
| 1295 |
|
let none = none1 && none2 and some = some1 || some2 in |
| 1296 |
|
let accu = LabelMap.from_list (fun _ _ -> assert false) accu in |
| 1297 |
|
(* approx for the case (some && not none) ... *) |
| 1298 |
|
res := cup !res (record' (some, accu)) |
| 1299 |
|
else |
| 1300 |
|
let l1 = split d1 l and l2 = split d2 l in |
| 1301 |
|
let loop (t1,d1) (t2,d2) = |
| 1302 |
|
let t = |
| 1303 |
|
if t2.absent |
| 1304 |
|
then cup t1 { t2 with absent = false } |
| 1305 |
|
else t2 |
| 1306 |
|
in |
| 1307 |
|
aux ((l,cons t)::accu) d1 d2 |
| 1308 |
|
in |
| 1309 |
|
List.iter (fun x -> List.iter (loop x) l2) l1 |
| 1310 |
|
|
| 1311 |
|
in |
| 1312 |
|
aux [] d1 d2; |
| 1313 |
|
!res |
| 1314 |
|
|
| 1315 |
let any = { empty with record = any.record } |
let any = { empty with record = any.record } |
| 1316 |
end |
end |
| 1317 |
|
|
Parent Directory
| 
Revision Log
| 
Patch