viewcvs.cgi/types/types.ml

open Ident

(*
To be sure not to use generic comparison ...
*)
let (=) : int -> int -> bool = (==)
let (<) : int -> int -> bool = (<)
let (<=) : int -> int -> bool = (<=)
let (<>) : int -> int -> bool = (<>)
let compare = 1


module HashedString = 
struct 
  type t = string 
  let hash = Hashtbl.hash
  let equal = (=)
end


type const = 
  | Integer of Intervals.v
  | Atom of Atoms.v
  | Char of Chars.v

let compare_const c1 c2 =
  match (c1,c2) with
    | Integer x, Integer y -> Intervals.vcompare x y
    | Integer _, _ -> -1
    | _, Integer _ -> 1
    | Atom x, Atom y -> Atoms.vcompare x y
    | Atom _, _ -> -1
    | _, Atom _ -> 1
    | Char x, Char y -> Chars.vcompare x y

let hash_const = function
  | Integer x -> Intervals.vhash x
  | Atom x -> Atoms.vhash x
  | Char x -> Chars.vhash x

let equal_const c1 c2 = compare_const c1 c2 = 0

type pair_kind = [ `Normal | `XML ]

type 'a node0 = { id : int; mutable descr : 'a }

module NodePair = struct
  type 'a t = 'a node0 * 'a node0
  let dump ppf (x,y) =
    Format.fprintf ppf "(%i,%i)" x.id y.id
  let compare (y1,x1) (y2,x2) =
    if x1.id < x2.id then -1
    else if x1.id > x2.id then 1
    else y1.id - y2.id
  let equal (x1,y1) (x2,y2) = (x1==x2) && (y1==y2)
  let hash (x,y) = x.id + 17 * y.id
end 

module RecArg = struct
  type 'a t = bool * 'a node0 label_map
  
  let dump ppf (o,r) = ()

  let rec compare_rec r1 r2 =
    if r1 == r2 then 0
    else match (r1,r2) with
      | (l1,x1)::r1,(l2,x2)::r2 ->
          if ((l1:int) < l2) then -1 
          else if (l1 > l2) then 1 
          else if x1.id < x2.id then -1
          else if x1.id > x2.id then 1
          else compare_rec r1 r2
      | ([],_) -> -1
      | _ -> 1

  let compare (o1,r1) (o2,r2) =
    if o1 && not o2 then -1 
    else if o2 && not o1 then 1
    else compare_rec (LabelMap.get r1) (LabelMap.get r2)

  let rec equal_rec r1 r2 =
    (r1 == r2) ||
    match (r1,r2) with
      | (l1,x1)::r1,(l2,x2)::r2 ->
          (x1.id == x2.id) && (l1 == l2) && (equal_rec r1 r2)
      | _ -> false

  let equal (o1,r1) (o2,r2) =
    (o1 == o2) && (equal_rec (LabelMap.get r1) (LabelMap.get r2))

  let rec hash_rec accu = function
    | (l,x)::rem -> hash_rec (257 * accu + 17 * l + x.id) rem
    | [] -> accu + 5
      
  let hash (o,r) = hash_rec (if o then 2 else 1) (LabelMap.get r)
end

module BoolPair = Bool.Make(NodePair)
module BoolRec = Bool.Make(RecArg)

type descr = {
  atoms : Atoms.t;
  ints  : Intervals.t;
  chars : Chars.t;
  times : descr BoolPair.t;
  xml   : descr BoolPair.t;
  arrow : descr BoolPair.t;
  record: descr BoolRec.t;
  absent: bool
} and node = descr node0

               
let empty = { 
  times = BoolPair.empty; 
  xml   = BoolPair.empty; 
  arrow = BoolPair.empty; 
  record= BoolRec.empty;
  ints  = Intervals.empty;
  atoms = Atoms.empty;
  chars = Chars.empty;
  absent= false;
}
              
let any =  {
  times = BoolPair.full; 
  xml   = BoolPair.full; 
  arrow = BoolPair.full; 
  record= BoolRec.full; 
  ints  = Intervals.any;
  atoms = Atoms.any;
  chars = Chars.any;
  absent= false;
}
             
             
let interval i = { empty with ints = i }
let times x y = { empty with times = BoolPair.atom (x,y) }
let xml x y = { empty with xml = BoolPair.atom (x,y) }
let arrow x y = { empty with arrow = BoolPair.atom (x,y) }
let record label t = 
  { empty with record = BoolRec.atom (true,LabelMap.singleton label t) }
let record' (x : bool * node Ident.label_map) =
  { empty with record = BoolRec.atom x }
let atom a = { empty with atoms = a }
let char c = { empty with chars = c }
let constant = function
  | Integer i -> interval (Intervals.atom i)
  | Atom a -> atom (Atoms.atom a)
  | Char c -> char (Chars.atom c)
      
let cup x y = 
  if x == y then x else {
    times = BoolPair.cup x.times y.times;
    xml   = BoolPair.cup x.xml y.xml;
    arrow = BoolPair.cup x.arrow y.arrow;
    record= BoolRec.cup x.record y.record;
    ints  = Intervals.cup x.ints  y.ints;
    atoms = Atoms.cup x.atoms y.atoms;
    chars = Chars.cup x.chars y.chars;
    absent= x.absent || y.absent;
  }
    
let cap x y = 
  if x == y then x else {
    times = BoolPair.cap x.times y.times;
    xml   = BoolPair.cap x.xml y.xml;
    record= BoolRec.cap x.record y.record;
    arrow = BoolPair.cap x.arrow y.arrow;
    ints  = Intervals.cap x.ints  y.ints;
    atoms = Atoms.cap x.atoms y.atoms;
    chars = Chars.cap x.chars y.chars;
    absent= x.absent && y.absent;
  }
    
let diff x y = 
  if x == y then empty else {
    times = BoolPair.diff x.times y.times;
    xml   = BoolPair.diff x.xml y.xml;
    arrow = BoolPair.diff x.arrow y.arrow;
    record= BoolRec.diff x.record y.record;
    ints  = Intervals.diff x.ints  y.ints;
    atoms = Atoms.diff x.atoms y.atoms;
    chars = Chars.diff x.chars y.chars;
    absent= x.absent && not y.absent;
  }
    

let equal_descr a b =
  (Atoms.equal a.atoms b.atoms) &&
  (Chars.equal a.chars b.chars) &&
  (Intervals.equal a.ints  b.ints) &&
  (BoolPair.equal a.times b.times) &&
  (BoolPair.equal a.xml b.xml) &&
  (BoolPair.equal a.arrow b.arrow) &&
  (BoolRec.equal a.record b.record) &&
  (a.absent == b.absent)

let compare_descr a b =
  if a == b then 0 
  else let c = Atoms.compare a.atoms b.atoms in if c <> 0 then c
  else let c = Chars.compare a.chars b.chars in if c <> 0 then c
  else let c = Intervals.compare a.ints b.ints in if c <> 0 then c
  else let c = BoolPair.compare a.times b.times in if c <> 0 then c
  else let c = BoolPair.compare a.xml b.xml in if c <> 0 then c
  else let c = BoolPair.compare a.arrow b.arrow in if c <> 0 then c
  else let c = BoolRec.compare a.record b.record in if c <> 0 then c
  else if a.absent && not b.absent then -1
  else if b.absent && not a.absent then 1
  else 0

let hash_descr a =
  let accu = Chars.hash 1 a.chars in
  let accu = Intervals.hash accu a.ints in
  let accu = Atoms.hash accu a.atoms in
  let accu = 17 * accu + BoolPair.hash a.times in
  let accu = 17 * accu + BoolPair.hash a.xml in
  let accu = 17 * accu + BoolPair.hash a.arrow in
  let accu = 17 * accu + BoolRec.hash a.record in
  let accu = if a.absent then accu+5 else accu in
  accu

(* TODO: optimize disjoint check for boolean combinations *)
let trivially_disjoint a b =
  (Chars.disjoint a.chars b.chars) &&
  (Intervals.disjoint a.ints b.ints) &&
  (Atoms.disjoint a.atoms b.atoms) &&
  (BoolPair.trivially_disjoint a.times b.times) &&
  (BoolPair.trivially_disjoint a.xml b.xml) &&
  (BoolPair.trivially_disjoint a.arrow b.arrow) &&
  (BoolRec.trivially_disjoint a.record b.record) &&
  (not (a.absent && b.absent))


module Descr =
struct 
  type t = descr
  let hash = hash_descr
  let equal = equal_descr
  let compare = compare_descr
end
module DescrHash = Hashtbl.Make(Descr)
module DescrMap = Map.Make(Descr)

module Descr1 =
struct 
  type 'a t = descr
  let hash = hash_descr
  let equal = equal_descr
  let compare = compare_descr
end
module DescrSList = SortedList.Make(Descr1)

let hash_cons = DescrHash.create 17000

let count = ref 0
let make () = incr count; { id = !count; descr = empty }
let define n d = 
(*  DescrHash.add hash_cons d n; *)
  n.descr <- d
let cons d = 
  (* try DescrHash.find hash_cons d with Not_found ->
  incr count; let n = { id = !count; descr = d } in
  DescrHash.add hash_cons d n; n *)
  incr count; { id = !count; descr = d }
let descr n = n.descr
let internalize n = n
let id n = n.id


let print_descr = ref (fun _ _  -> assert false)

let neg x = diff any x

let any_node = cons any

module LabelS = Set.Make(LabelPool)

let get_record r =
  let labs accu (_,r) = 
    List.fold_left 
      (fun accu (l,_) -> LabelS.add l accu) accu (LabelMap.get r) in
  let extend descrs labs (o,r) =
    let rec aux i labs r =
      match labs with
        | [] -> ()
        | l1::labs ->
            match r with
              | (l2,x)::r when l1 == l2 -> 
                  descrs.(i) <- cap descrs.(i) (descr x);
                  aux (i+1) labs r
              | r ->
                  if not o then descrs.(i) <- 
                    cap descrs.(i) { empty with absent = true };
                  aux (i+1) labs r
    in
    aux 0 labs (LabelMap.get r);
    o
  in
  let line (p,n) =
    let labels = 
      List.fold_left labs (List.fold_left labs LabelS.empty p) n in
    let labels = LabelS.elements labels in
    let nlab = List.length labels in
    let mk () = Array.create nlab { any with absent = true } in

    let pos = mk () in
    let opos = List.fold_left 
                 (fun accu x -> 
                    (extend pos labels x) && accu)
                 true p in
    let p = (opos, pos) in

    let n = List.map (fun x ->
                        let neg = mk () in
                        let o = extend neg labels x in
                        (o,neg)
                     ) n in
    (labels,p,n)
  in
  List.map line (BoolRec.get r)
   

(* Subtyping algorithm *)

let diff_t d t = diff d (descr t)
let cap_t d t = cap d (descr t)
let cup_t d t = cup d (descr t)
let cap_product l =
  List.fold_left 
    (fun (d1,d2) (t1,t2) -> (cap_t d1 t1, cap_t d2 t2))
    (any,any)
    l
let cup_product l =
  List.fold_left 
    (fun (d1,d2) (t1,t2) -> (cup_t d1 t1, cup_t d2 t2))
    (empty,empty)
    l

let rec exists max f =
  (max > 0) && (f (max - 1) || exists (max - 1) f)

let trivially_empty d = equal_descr d empty

exception NotEmpty

type slot = { mutable status : status; 
               mutable notify : notify;
               mutable active : bool }
and status = Empty | NEmpty | Maybe
and notify = Nothing | Do of slot * (slot -> unit) * notify

let memo = DescrHash.create 33000

let marks = ref [] 
let slot_empty = { status = Empty; active = false; notify = Nothing }
let slot_not_empty = { status = NEmpty; active = false; notify = Nothing }

let rec notify = function
  | Nothing -> ()
  | Do (n,f,rem) -> 
      if n.status == Maybe then (try f n with NotEmpty -> ());
      notify rem

let rec iter_s s f = function
  | [] -> ()
  | arg::rem -> f arg s; iter_s s f rem


let set s =
  s.status <- NEmpty;
  notify s.notify;
  s.notify <- Nothing; 
  raise NotEmpty

let count_slot = ref 0
let rec big_conj f l n =
  match l with
    | [] -> set n
    | [arg] -> f arg n
    | arg::rem ->
        let s = { status = Maybe; active = false; notify = Do (n,(big_conj f rem), Nothing) } in
        try 
          f arg s;
          if s.active then n.active <- true
        with NotEmpty -> if n.status == NEmpty then raise NotEmpty

let rec guard a f n =
  match slot a with
    | { status = Empty } -> ()
    | { status = Maybe } as s -> n.active <- true; s.notify <- Do (n,f,s.notify)
    | { status = NEmpty } -> f n

and slot d =
  if not ((Intervals.is_empty d.ints) && 
          (Atoms.is_empty d.atoms) &&
          (Chars.is_empty d.chars) &&
          (not d.absent)) then slot_not_empty 
  else try DescrHash.find memo d
  with Not_found ->
    (*    incr count_slot;
    Printf.eprintf "%i;" !count_slot; *)
(*    Format.fprintf Format.std_formatter "Empty:%a@\n" !print_descr d; *)
    let s = { status = Maybe; active = false; notify = Nothing } in
    DescrHash.add memo d s;
    (try
(*       Format.fprintf Format.std_formatter "check_times_bool:@[%a@]@\n"
         BoolPair.dump d.times;  *)
(*       check_times_bool any any d.times s; *)
       iter_s s check_times (BoolPair.get d.times);  
       iter_s s check_times (BoolPair.get d.xml); 
       iter_s s check_arrow (BoolPair.get d.arrow);
       iter_s s check_record (get_record d.record);
       if s.active then marks := s :: !marks else s.status <- Empty;
     with
         NotEmpty -> ());
    s

and check_times (left,right) s =
(*  Printf.eprintf "[%i]" (List.length right);
  flush stderr;  *)
  let rec aux accu1 accu2 right s = match right with
    | (t1,t2)::right ->
        let t1 = descr t1 and t2 = descr t2 in
        if trivially_disjoint accu1 t1 || 
           trivially_disjoint accu2 t2 then (
             aux accu1 accu2 right s )
        else (
          let accu1' = diff accu1 t1 in 
          guard accu1' (aux accu1' accu2 right) s;

          let accu2' = diff accu2 t2 in 
            guard accu2' (aux accu1 accu2' right) s  
(*        let accu1 = cap accu1 t1 in (* TODO: approximation of cap ... *)
          let accu2' = diff accu2 t2 in 
          guard accu1 (guard accu2' (aux accu1 accu2' right)) s *)

        )
    | [] -> set s
  in
  let (accu1,accu2) = cap_product left in
(*  if List.length right > 6 then (
    Printf.eprintf "HEURISTIC\n"; flush stderr; 
    let (n1,n2) = cup_product right in
    let n1 = diff accu1 n1 and n2 = diff accu2 n2 in
    guard n1 set s;
    guard n2 set s;
    Printf.eprintf "HEURISTIC failed\n"; flush stderr; 
  );  *)
  guard accu1 (guard accu2 (aux accu1 accu2 right)) s


(*
and check_times_bool accu1 accu2 b s =
  match b with
    | BoolPair.True -> guard accu1 (guard accu2 set) s
    | BoolPair.False -> ()
    | BoolPair.Split (_, (t1,t2), p,i,n) ->
        check_times_bool accu1 accu2 i s;
        let t1 = descr t1 and t2 = descr t2 in
        if (trivially_disjoint accu1 t1 || trivially_disjoint accu2 t2)
        then check_times_bool accu1 accu2 n s else
          (
            if p <> BoolPair.False then
              (let accu1 = cap accu1 t1 
               and accu2 = cap accu2 t2 in
               if not (trivially_empty accu1 || trivially_empty accu2) then
                 check_times_bool accu1 accu2 p s);
            
            if n <> BoolPair.False then
              (let accu1' = diff accu1 t1 in 
               check_times_bool accu1' accu2 n s;
               let accu2' = diff accu2 t2 in 
               check_times_bool accu1 accu2' n s)
          )
*)


and check_arrow (left,right) s =
  let single_right (s1,s2) s =
    let rec aux accu1 accu2 left s = match left with
      | (t1,t2)::left ->
          let accu1' = diff_t accu1 t1 in guard accu1' (aux accu1' accu2 left) s;
          let accu2' = cap_t  accu2 t2 in guard accu2' (aux accu1 accu2' left) s
      | [] -> set s
    in
    let accu1 = descr s1 in
    guard accu1 (aux accu1 (neg (descr s2)) left) s
  in
  big_conj single_right right s

and check_record (labels,(oleft,left),rights) s =
  let rec aux rights s = match rights with
    | [] -> set s
    | (oright,right)::rights ->
        let next =
          (oleft && (not oright)) ||
          exists (Array.length left)
            (fun i -> trivially_disjoint left.(i) right.(i))
        in
        if next then aux rights s
        else
          for i = 0 to Array.length left - 1 do
            let back = left.(i) in
            let di = diff back right.(i) in
            guard di (fun s ->
                        left.(i) <- diff back right.(i);
                        aux rights s;
                        left.(i) <- back;
                     ) s
          done
  in
  let rec start i s =
    if (i < 0) then aux rights s
    else
      guard left.(i) (start (i - 1)) s
  in
  start (Array.length left - 1) s


let is_empty d =
(*  Printf.eprintf "is_empty: start\n"; flush stderr; *)
  let s = slot d in
  List.iter 
    (fun s' -> 
       if s'.status == Maybe then s'.status <- Empty; s'.notify <- Nothing) 
    !marks;
  marks := [];
(*  Printf.eprintf "is_empty: done\n"; flush stderr; *)
  s.status == Empty
  

module Assumptions = Set.Make(struct type t = descr let compare = compare_descr end)
let memo = ref Assumptions.empty
let cache_false = DescrHash.create 33000

let rec empty_rec d =
  if not (Intervals.is_empty d.ints) then false
  else if not (Atoms.is_empty d.atoms) then false
  else if not (Chars.is_empty d.chars) then false
  else if d.absent then false
  else if DescrHash.mem cache_false d then false 
  else if Assumptions.mem d !memo then true
  else (
    let backup = !memo in
    memo := Assumptions.add d backup;
    if 
      (empty_rec_times (BoolPair.get d.times)) &&
      (empty_rec_times (BoolPair.get d.xml)) &&
      (empty_rec_arrow (BoolPair.get d.arrow)) &&
      (empty_rec_record d.record) 
    then true
    else (
      memo := backup;
      DescrHash.add cache_false d ();
      false
    )
  )

and empty_rec_times c =
  List.for_all empty_rec_times_aux c

and empty_rec_times_aux (left,right) =
  let rec aux accu1 accu2 = function
    | (t1,t2)::right ->
        if trivially_empty (cap_t accu1 t1) || 
           trivially_empty (cap_t accu2 t2) then
          aux accu1 accu2 right
        else
          let accu1' = diff_t accu1 t1 in
          if not (empty_rec accu1') then aux accu1' accu2 right;
          let accu2' = diff_t accu2 t2 in
          if not (empty_rec accu2') then aux accu1 accu2' right
    | [] -> raise NotEmpty
  in
  let (accu1,accu2) = cap_product left in
  (empty_rec accu1) || (empty_rec accu2) ||
    (try aux accu1 accu2 right; true with NotEmpty -> false)


and empty_rec_arrow c =
  List.for_all empty_rec_arrow_aux c

and empty_rec_arrow_aux (left,right) =
  let single_right (s1,s2) =
    let rec aux accu1 accu2 = function
      | (t1,t2)::left ->
          let accu1' = diff_t accu1 t1 in
          if not (empty_rec accu1') then aux accu1' accu2 left;
          let accu2' = cap_t accu2 t2 in
          if not (empty_rec accu2') then aux accu1 accu2' left
      | [] -> raise NotEmpty
    in
    let accu1 = descr s1 in
    (empty_rec accu1) ||
    (try aux accu1 (diff any (descr s2)) left; true with NotEmpty -> false)
  in
  List.exists single_right right

and empty_rec_record_aux (labels,(oleft,left),rights) =
  let rec aux = function
    | [] -> raise NotEmpty
    | (oright,right)::rights ->
        let next =
          (oleft && (not oright)) ||
          exists (Array.length left)
            (fun i ->
               trivially_empty (cap left.(i) right.(i)))
        in
        if next then aux rights 
        else
          for i = 0 to Array.length left - 1 do
            let back = left.(i) in
            let di = diff back right.(i) in
            if not (empty_rec di) then (
              left.(i) <- diff back right.(i);
              aux rights;
              left.(i) <- back;
            )
          done
  in
  exists (Array.length left) 
    (fun i -> empty_rec left.(i))
  ||
  (try aux rights; true with NotEmpty -> false)
            

and empty_rec_record c =
  List.for_all empty_rec_record_aux (get_record c)

(*
let is_empty d =
  empty_rec d
  *)

let non_empty d = 
  not (is_empty d)

let subtype d1 d2 =
  is_empty (diff d1 d2)

module Product =
struct
  type t = (descr * descr) list

  let other ?(kind=`Normal) d = 
    match kind with
      | `Normal -> { d with times = empty.times }
      | `XML -> { d with xml = empty.xml }

  let is_product ?kind d = is_empty (other ?kind d)

  let need_second = function _::_::_ -> true | _ -> false

  let normal_aux = function
    | ([] | [ _ ]) as d -> d
    | d ->

    let res = ref [] in

    let add (t1,t2) =
      let rec loop t1 t2 = function
        | [] -> res := (ref (t1,t2)) :: !res
        | ({contents = (d1,d2)} as r)::l ->
            (*OPT*) 
(*          if equal_descr d1 t1 then r := (d1,cup d2 t2) else*)
              
              let i = cap t1 d1 in
              if is_empty i then loop t1 t2 l
              else (
                r := (i, cup t2 d2);
                let k = diff d1 t1 in 
                if non_empty k then res := (ref (k,d2)) :: !res;
                
                let j = diff t1 d1 in 
                if non_empty j then loop j t2 l
              )
      in
      loop t1 t2 !res
    in
    List.iter add d;
    List.map (!) !res

(*
This version explodes when dealing with
   Any - [ t1? t2? t3? ... tn? ]
==> need partitioning 
*)
  let get_aux d =
    let line accu (left,right) =
      let rec aux accu d1 d2 = function
        | (t1,t2)::right ->
            let accu = 
              let d1 = diff_t d1 t1 in
              if is_empty d1 then accu else aux accu d1 d2 right in
            let accu =
              let d2 = diff_t d2 t2 in
              if is_empty d2 then accu else aux accu d1 d2 right in
            accu
        | [] -> (d1,d2) :: accu
      in
      let (d1,d2) = cap_product left in
      if (is_empty d1) || (is_empty d2) then accu else aux accu d1 d2 right
    in
    List.fold_left line [] d

(* Partitioning:

(t,s) - ((t1,s1) | (t2,s2) | ... | (tn,sn))
=
(t & t1, s - s1) | ... | (t & tn, s - sn) | (t - (t1|...|tn), s)

*)
  let get_aux d =
    let accu = ref [] in
    let line (left,right) =
      let (d1,d2) = cap_product left in
      if (non_empty d1) && (non_empty d2) then
        let right = List.map (fun (t1,t2) -> descr t1, descr t2) right in
        let right = normal_aux right in
        let resid1 = ref d1 in
        let () = 
          List.iter
            (fun (t1,t2) ->
               let t1 = cap d1 t1 in
               if (non_empty t1) then
                 let () = resid1 := diff !resid1 t1 in
                 let t2 = diff d2 t2 in
                 if (non_empty t2) then accu := (t1,t2) :: !accu
            ) right in
        if non_empty !resid1 then accu := (!resid1, d2) :: !accu 
    in
    List.iter line (BoolPair.get d);
    !accu
(* Maybe, can improve this function with:
     (t,s) \ (t1,s1) = (t&t',s\s') | (t\t',s),
   don't call normal_aux *)


  let get ?(kind=`Normal) d = 
    match kind with
      | `Normal -> get_aux d.times
      | `XML -> get_aux d.xml

  let pi1 = List.fold_left (fun acc (t1,_) -> cup acc t1) empty
  let pi2 = List.fold_left (fun acc (_,t2) -> cup acc t2) empty
  let pi2_restricted restr = 
    List.fold_left (fun acc (t1,t2) -> 
                      if is_empty (cap t1 restr) then acc
                      else cup acc t2) empty

  let restrict_1 rects pi1 =
    let aux acc (t1,t2) = 
      let t1 = cap t1 pi1 in if is_empty t1 then acc else (t1,t2)::acc in
    List.fold_left aux [] rects
  
  type normal = t

  module Memo = Map.Make(struct type t = descr BoolPair.t let compare = BoolPair.compare end)

  (* TODO: try with an hashtable *)
  (* Also, avoid lookup for simple products (t1,t2) *)
  let memo = ref Memo.empty
  let normal ?(kind=`Normal) d = 
    let d = match kind with `Normal -> d.times | `XML -> d.xml in
    try Memo.find d !memo 
    with
        Not_found ->
          let gd = get_aux d in
          let n = normal_aux gd in
(* Could optimize this call to normal_aux because one already
   know that each line is normalized ... *)
          memo := Memo.add d n !memo;
          n

  let constraint_on_2 n t1 =
    List.fold_left 
      (fun accu (d1,d2) ->
         if is_empty (cap d1 t1) then accu else cap accu d2)
      any
      n

  let any = { empty with times = any.times }
  and any_xml = { empty with xml = any.xml }
  let is_empty d = d == []
end

module Print = 
struct
  let rec print_union ppf = function
    | [] -> Format.fprintf ppf "Empty"
    | [h] -> h ppf
    | h::t -> Format.fprintf ppf "@[%t |@ %a@]" h print_union t

  let print_tag ppf a =
    match Atoms.is_atom a with
      | Some a -> Format.fprintf ppf "%s" (Atoms.value a)
      | None -> Format.fprintf ppf "(%a)" print_union (Atoms.print a)

  let print_const ppf = function
    | Integer i -> Intervals.print_v ppf i
    | Atom a -> Atoms.print_v ppf a
    | Char c -> Chars.print_v ppf c

  let named = State.ref "Types.Printf.named" DescrMap.empty
  let register_global name d = 
    named := DescrMap.add d name !named

  let marks = DescrHash.create 63
  let wh = ref []
  let count_name = ref 0
  let name () =
    incr count_name;
    "X" ^ (string_of_int !count_name)
(* TODO: 
   check that these generated names does not conflict with declared types *)

  let trivial_rec b = b == BoolRec.empty || b == BoolRec.full
  let trivial_pair b = b == BoolPair.empty || b == BoolPair.full

  let worth_abbrev d = 
    not (trivial_pair d.times && trivial_pair d.xml && 
         trivial_pair d.arrow && trivial_rec d.record) 

  let rec mark n = mark_descr (descr n)
  and mark_descr d =
    if not (DescrMap.mem d !named) then
      try 
        let r = DescrHash.find marks d in
        if (!r == None) && (worth_abbrev d) then 
          let na = name () in 
          r := Some na;
          wh := (na,d) :: !wh
      with Not_found -> 
        DescrHash.add marks d (ref None);
        BoolPair.iter (fun (n1,n2) -> mark n1; mark n2) d.times;
        BoolPair.iter 
          (fun (n1,n2) -> mark n1; mark n2
(*
             List.iter
               (fun (d1,d2) ->
                  mark_descr d2;
                  bool_iter 
                    (fun (o,l) -> List.iter (fun (l,(o,n)) -> mark n) l) 
                    d1.record
                  let l = get_record d1.record in
                  List.iter (fun labs,(_,(_,p)),ns ->
                               Array.iter mark_descr p;
                               List.iter (fun (_,(_,n)) -> 
                                            Array.iter mark_descr n) ns
                            ) l
               )
               (Product.normal (descr n2))
*)
          ) d.xml;
        BoolPair.iter (fun (n1,n2) -> mark n1; mark n2) d.arrow;
        BoolRec.iter 
          (fun (o,l) -> List.iter (fun (l,n) -> mark n) (LabelMap.get l)) 
          d.record

    
  let rec print ppf n = print_descr ppf (descr n)
  and print_descr ppf d = 
    try 
      let name = DescrMap.find d !named in
      Format.fprintf ppf "%s" name
    with Not_found ->
      try
        match !(DescrHash.find marks d) with
          | Some n -> Format.fprintf ppf "%s" n
          | None -> real_print_descr ppf d
      with
          Not_found -> assert false
  and real_print_descr ppf d = 
    if equal_descr d any then Format.fprintf ppf "Any" else
      (
        if d.absent then Format.fprintf ppf "?";
        print_union ppf 
          (Intervals.print d.ints @
           Chars.print d.chars @
           Atoms.print d.atoms @
           BoolPair.print "Pair" print_times d.times @
           BoolPair.print "XML" print_xml d.xml @
           BoolPair.print "Arrow" print_arrow d.arrow @
           BoolRec.print "Record" print_record d.record
          )
      )
  and print_times ppf (t1,t2) =
    Format.fprintf ppf "@[(%a,%a)@]" print t1 print t2
  and print_xml ppf (t1,t2) =
    Format.fprintf ppf "@[XML(%a,%a)@]" print t1 print t2
(*
    let l = Product.normal (descr t2) in
    let l = List.map
              (fun (d1,d2) ppf ->
                 Format.fprintf ppf "@[<><%a%a>%a@]" 
                   print_tag (descr t1).atoms
                   print_attribs d1.record 
                   print_descr d2) l
    in
    print_union ppf l
*)
  and print_arrow ppf (t1,t2) =
    Format.fprintf ppf "@[(%a -> %a)@]" print t1 print t2
  and print_record ppf (o,r) =
    let o = if o then "" else "|" in
    Format.fprintf ppf "@[{%s" o;
    let first = ref true in
    List.iter (fun (l,t) ->
                 let sep = if !first then (first := false; "") else ";" in
                 Format.fprintf ppf "%s@ @[%s =@] %a" sep
                   (LabelPool.value l) print t
              ) (LabelMap.get r);
    Format.fprintf ppf " %s}@]" o
(*
  and print_attribs ppf r =
    let l = get_record r in
    if l <> [ [] ] then 
    let l = List.map 
      (fun att ppf ->
         let first = ref true in
         Format.fprintf ppf "{" ;
         List.iter (fun (l,(o,d)) ->
                      Format.fprintf ppf "%s%s=%s%a" 
                        (if !first then "" else " ")
                        (LabelPool.value l) (if o then "?" else "")
                        print_descr d; 
                      first := false
                   ) att;
           Format.fprintf ppf "}"
      ) l in
    print_union ppf l
*)

          
  let end_print ppf =
    Format.fprintf ppf "@]";
    (match List.rev !wh with
       | [] -> ()
       | (na,d)::t ->
           Format.fprintf ppf " where@ @[%s = %a" na real_print_descr d;
           List.iter 
             (fun (na,d) -> 
                Format.fprintf ppf " and@ %s = %a" na real_print_descr d)
             t;
           Format.fprintf ppf "@]"
    );
(*    Format.fprintf ppf "@]"; *)
    count_name := 0;
    wh := [];
    DescrHash.clear marks

  let print_descr ppf d =
    mark_descr d;
    Format.fprintf ppf "@[%a" print_descr d;
    end_print ppf

   let print ppf n = print_descr ppf (descr n)

end

let () = print_descr := Print.print_descr

module Positive =
struct
  type rhs = [ `Type of descr | `Cup of v list | `Times of v * v | `Xml of v * v ]
  and v = { mutable def : rhs; mutable node : node option }


  let rec make_descr seen v =
    if List.memq v seen then empty
    else
      let seen = v :: seen in
      match v.def with
        | `Type d -> d
        | `Cup vl -> 
            List.fold_left (fun acc v -> cup acc (make_descr seen v)) empty vl
        | `Times (v1,v2) -> times (make_node v1) (make_node v2)
        | `Xml (v1,v2) -> xml (make_node v1) (make_node v2)

  and make_node v =
    match v.node with
      | Some n -> n
      | None ->
          let n = make () in
          v.node <- Some n;
          let d = make_descr [] v in
          define n d;
          n

  let forward () = { def = `Cup []; node = None }
  let def v d = v.def <- d
  let cons d = let v = forward () in def v d; v
  let ty d = cons (`Type d)
  let cup vl = cons (`Cup vl)
  let times d1 d2 = cons (`Times (d1,d2))
  let xml d1 d2 = cons (`Xml (d1,d2))
  let define v1 v2 = def v1 (`Cup [v2]) 

  let solve v = internalize (make_node v)
end


(* Sample value *)
module Sample =
struct


let rec find f = function
  | [] -> raise Not_found
  | x::r -> try f x with Not_found -> find f r

type t =
  | Int of Intervals.v
  | Atom of Atoms.v
  | Char of Chars.v
  | Pair of (t * t)
  | Xml of (t * t)
  | Record of (bool * (label * t) list)
  | Fun of (node * node) list
  | Other
 exception FoundSampleRecord of bool * (label * t) list

let rec sample_rec memo d =
  if (Assumptions.mem d memo) || (is_empty d) then raise Not_found 
  else 
    try Int (Intervals.sample d.ints) with Not_found ->
    try Atom (Atoms.sample d.atoms) with 
        Not_found ->
(* Here: could create a fresh atom ... *)
    try Char (Chars.sample d.chars) with Not_found ->
    try sample_rec_arrow (BoolPair.get d.arrow) with Not_found ->

    let memo = Assumptions.add d memo in
    try Pair (sample_rec_times memo (BoolPair.get d.times)) with Not_found ->
    try Xml (sample_rec_times memo (BoolPair.get d.xml)) with Not_found ->
    try sample_rec_record memo d.record with Not_found ->  
    raise Not_found


and sample_rec_times memo c = 
  find (sample_rec_times_aux memo) c

and sample_rec_times_aux memo (left,right) =
  let rec aux accu1 accu2 = function
    | (t1,t2)::right ->
(*TODO: check: is this correct ?  non_empty could return true
  but because of coinduction, the call to aux may raise Not_found, no ? *)
        let accu1' = diff_t accu1 t1 in
        if non_empty accu1' then aux accu1' accu2 right else
          let accu2' = diff_t accu2 t2 in
          if non_empty accu2' then aux accu1 accu2' right else
            raise Not_found
    | [] -> (sample_rec memo accu1, sample_rec memo accu2)
  in
  let (accu1,accu2) = cap_product left in
  if (is_empty accu1) || (is_empty accu2) then raise Not_found;
  aux accu1 accu2 right

and sample_rec_arrow c =
  find sample_rec_arrow_aux c

and check_empty_simple_arrow_line left (s1,s2) = 
  let rec aux accu1 accu2 = function
    | (t1,t2)::left ->
        let accu1' = diff_t accu1 t1 in
        if non_empty accu1' then aux accu1 accu2 left;
        let accu2' = cap_t accu2 t2 in
        if non_empty accu2' then aux accu1 accu2 left
    | [] -> raise NotEmpty
  in
  let accu1 = descr s1 in
  (is_empty accu1) ||
  (try aux accu1 (diff any (descr s2)) left; true with NotEmpty -> false)

and check_empty_arrow_line left right = 
  List.exists (check_empty_simple_arrow_line left) right

and sample_rec_arrow_aux (left,right) =
  if (check_empty_arrow_line left right) then raise Not_found
  else Fun left


and sample_rec_record memo c =
  Record (find (sample_rec_record_aux memo) (get_record c))

and sample_rec_record_aux memo (labels,(oleft,left),rights) =
  let rec aux = function
    | [] -> 
        let l = ref labels and fields = ref [] in
        for i = 0 to Array.length left - 1 do
          fields := (List.hd !l, sample_rec memo left.(i))::!fields;
          l := List.tl !l
        done;
        raise (FoundSampleRecord (oleft, List.rev !fields))
    | (oright,right)::rights ->
        let next = (oleft && (not oright)) in
        if next then aux rights 
        else
          for i = 0 to Array.length left - 1 do
            let back = left.(i) in
            let di = diff back right.(i) in
            if not (is_empty di) then (
              left.(i) <- diff back right.(i);
              aux rights;
              left.(i) <- back;
            )
          done
  in
  if exists (Array.length left) 
    (fun i -> is_empty left.(i)) then raise Not_found;
  try aux rights; raise Not_found
  with FoundSampleRecord (o,r) -> (o,r)

            
let get x = try sample_rec Assumptions.empty x with Not_found -> Other

  let rec print_sep f sep ppf = function
    | [] -> ()
    | [x] -> f ppf x
    | x::rem -> f ppf x; Format.fprintf ppf "%s" sep; print_sep f sep ppf rem


  let rec print ppf = function
    | Int i -> Intervals.print_v ppf i
    | Atom a -> Atoms.print_v ppf a
    | Char c -> Chars.print_v ppf c
    | Pair (x1,x2) -> Format.fprintf ppf "(%a,%a)" print x1 print x2
    | Xml (Atom tag, Pair (attr, child)) -> 
        Format.fprintf ppf "<%s %a>%a" (Atoms.value tag) print attr print child
    | Xml (x1,x2) -> Format.fprintf ppf "XML(%a,%a)" print x1 print x2
    | Record (o,r) ->
        Format.fprintf ppf "{ %a%s }"
          (print_sep 
             (fun ppf (l,x) -> 
                Format.fprintf ppf "%s = %a"
                (LabelPool.value l)
                print x
             )
             " ; "
          ) r
          (if o then "; ..." else "")
    | Fun iface ->
        Format.fprintf ppf "(fun ( %a ) x -> ...)"
          (print_sep
             (fun ppf (t1,t2) ->
                Format.fprintf ppf "%a -> %a; "
                Print.print t1 Print.print t2
             )
             " ; "
          ) iface
    | Other ->
        Format.fprintf ppf "[cannot determine value]"
end


module Record = 
struct
  let has_record d = not (is_empty { empty with record = d.record })
  let or_absent d = { d with absent = true }
  let any_or_absent = or_absent any
  let has_absent d = d.absent

  let only_absent = {empty with absent = true}
  let only_absent_node = cons only_absent

  module T = struct
    type t = descr
    let any = any_or_absent
    let cap = cap
    let cup = cup
    let diff = diff
    let is_empty = is_empty
    let empty = empty
  end
  module R = struct
    type t = descr
    let any = { empty with record = any.record }
    let cap = cap
    let cup = cup
    let diff = diff
    let is_empty = is_empty
    let empty = empty
  end
  module TR = Normal.Make(T)(R)

  let any_record = { empty with record = BoolRec.full }

  let atom o l = 
    if o && LabelMap.is_empty l then any_record else
    { empty with record = BoolRec.atom (o,l) }

  type zor = Pair of descr * descr | Any

  let aux_split d l=
    let f (o,r) =
      try
        let (lt,rem) = LabelMap.assoc_remove l r in
        Pair (descr lt, atom o rem)
      with Not_found -> 
        if o then
          if LabelMap.is_empty r then Any else
            Pair (any_or_absent, { empty with record = BoolRec.atom (o,r) })
        else
          Pair (only_absent,
                { empty with record = BoolRec.atom (o,r) })
    in
    List.fold_left 
      (fun b (p,n) ->
         let rec aux_p accu = function
           | x::p -> 
               (match f x with
                  | Pair (t1,t2) -> aux_p ((t1,t2)::accu) p
                  | Any -> aux_p accu p)
           | [] -> aux_n accu [] n
         and aux_n p accu = function
           | x::n -> 
               (match f x with
                  | Pair (t1,t2) -> aux_n p ((t1,t2)::accu) n
                  | Any -> b)
           | [] -> (p,accu) :: b in
         aux_p [] p)
      []
      (BoolRec.get d.record)

  let split (d : descr) l =
    TR.boolean (aux_split d l)

  let split_normal d l =
    TR.boolean_normal (aux_split d l)


  let project d l =
    let t = TR.pi1 (split d l) in
    if t.absent then raise Not_found;
    t

  let project_opt d l =
    let t = TR.pi1 (split d l) in
    { t with absent = false }

  let condition d l t =
    TR.pi2_restricted t (split d l)

(* TODO: eliminate this cap ... (reord l only_absent_node) when
   not necessary. eg. {| ..... |} \ l *)

  let remove_field d l = 
    cap (TR.pi2 (split d l)) (record l only_absent_node)

  let first_label d =
    let min = ref LabelPool.dummy_max in
    let aux (_,r) = 
      match LabelMap.get r with
          (l,_)::_ -> if (l:int) < !min then min := l | _ -> () in
    BoolRec.iter aux d.record;
    !min

  let empty_cases d =
    let x = BoolRec.compute
              ~empty:0 ~full:3 ~cup:(lor) ~cap:(land)
              ~diff:(fun a b -> a land lnot b)
              ~atom:(function (o,r) ->
                       assert (LabelMap.get r == []);
                       if o then 3 else 1
                    )
              d.record in
    (x land 2 <> 0, x land 1 <> 0)

  let has_empty_record d =
    BoolRec.compute
      ~empty:false ~full:true ~cup:(||) ~cap:(&&)
      ~diff:(fun a b -> a && not b)
      ~atom:(function (o,r) ->
               List.for_all 
                 (fun (l,t) -> (descr t).absent)
                 (LabelMap.get r)
            )
      d.record
    

(*TODO: optimize merge
   - pre-compute the sequence of labels
   - remove empty or full { l = t }
*)

  let merge d1 d2 = 
    let res = ref empty in
    let rec aux accu d1 d2 =
      let l = min (first_label d1) (first_label d2) in
      if l = LabelPool.dummy_max then
        let (some1,none1) = empty_cases d1 
        and (some2,none2) = empty_cases d2 in
        let none = none1 && none2 and some = some1 || some2 in
        let accu = LabelMap.from_list (fun _ _ -> assert false) accu in
        (* approx for the case (some && not none) ... *)
        res := cup !res (record' (some, accu))
      else
        let l1 = split d1 l and l2 = split d2 l in
        let loop (t1,d1) (t2,d2) =
          let t = 
            if t2.absent 
            then cup t1 { t2 with absent = false } 
            else t2 
          in
          aux ((l,cons t)::accu) d1 d2
        in
        List.iter (fun x -> List.iter (loop x) l2) l1
          
    in
    aux [] d1 d2;
    !res

  let any = { empty with record = any.record }
end


let memo_normalize = ref DescrMap.empty


let rec rec_normalize d =
  try DescrMap.find d !memo_normalize
  with Not_found ->
    let n = make () in
    memo_normalize := DescrMap.add d n !memo_normalize;
    let times = 
      List.fold_left 
        (fun accu (d1,d2) -> BoolPair.cup accu (BoolPair.atom (rec_normalize d1, rec_normalize d2)))
        BoolPair.empty (Product.normal d)
    in
    let xml = 
      List.fold_left 
        (fun accu (d1,d2) -> BoolPair.cup accu (BoolPair.atom (rec_normalize d1, rec_normalize d2)))
        BoolPair.empty (Product.normal ~kind:`XML d)
    in
    let record = d.record
    in
    define n { d with times = times; xml = xml; record = record };
    n

let normalize n =
  descr (internalize (rec_normalize n))

module Arrow =
struct
  let check_simple left s1 s2 =
    let rec aux accu1 accu2 = function
      | (t1,t2)::left ->
          let accu1' = diff_t accu1 t1 in
          if non_empty accu1' then aux accu1 accu2 left;
          let accu2' = cap_t accu2 t2 in
          if non_empty accu2' then aux accu1 accu2 left
      | [] -> raise NotEmpty
    in
    let accu1 = descr s1 in
    (is_empty accu1) ||
    (try aux accu1 (diff any (descr s2)) left; true with NotEmpty -> false)
      
  let check_strenghten t s =
(*
    let left = match (BoolPair.get t.arrow) with [ (p,[]) ] -> p | _ -> assert false in
    let rec aux = function
      | [] -> raise Not_found
      | (p,n) :: rem ->
          if (List.for_all (fun (a,b) -> check_simple left a b) p) &&
            (List.for_all (fun (a,b) -> not (check_simple left a b)) n) then
              { empty with arrow = Obj.magic [ (SortedList.cup left p, n) ] }  (* rework this ! *)
          else aux rem
    in
    aux (BoolPair.get s.arrow)
*)
    if subtype t s then t else raise Not_found

  let check_simple_iface left s1 s2 =
    let rec aux accu1 accu2 = function
      | (t1,t2)::left ->
          let accu1' = diff accu1 t1 in
          if non_empty accu1' then aux accu1 accu2 left;
          let accu2' = cap accu2 t2 in
          if non_empty accu2' then aux accu1 accu2 left
      | [] -> raise NotEmpty
    in
    let accu1 = descr s1 in
    (is_empty accu1) ||
    (try aux accu1 (diff any (descr s2)) left; true with NotEmpty -> false)

  let check_iface iface s =
    let rec aux = function
      | [] -> false
      | (p,n) :: rem ->
          ((List.for_all (fun (a,b) -> check_simple_iface iface a b) p) &&
           (List.for_all (fun (a,b) -> not (check_simple_iface iface a b)) n))
          || (aux rem)
    in
    aux (BoolPair.get s.arrow)

  type t = descr * (descr * descr) list list

  let get t =
    List.fold_left
      (fun ((dom,arr) as accu) (left,right) ->
         if Sample.check_empty_arrow_line left right 
         then accu
         else (
           let left =
             List.map 
               (fun (t,s) -> (descr t, descr s)) left in
           let d = List.fold_left (fun d (t,_) -> cup d t) empty left in
           (cap dom d, left :: arr)
         )
      )
      (any, [])
      (BoolPair.get t.arrow)

  let domain (dom,_) = dom

  let apply_simple t result left = 
    let rec aux result accu1 accu2 = function
      | (t1,s1)::left ->
          let result = 
            let accu1 = diff accu1 t1 in
            if non_empty accu1 then aux result accu1 accu2 left
            else result in
          let result =
            let accu2 = cap accu2 s1 in
            aux result accu1 accu2 left in
          result
      | [] -> 
          if subtype accu2 result 
          then result
          else cup result accu2
    in
    aux result t any left
      
  let apply (_,arr) t =
    List.fold_left (apply_simple t) empty arr

  let need_arg (dom, arr) =
    List.exists (function [_] -> false | _ -> true) arr

  let apply_noarg (_,arr) =
    List.fold_left 
      (fun accu -> 
         function 
           | [(t,s)] -> cup accu s
           | _ -> assert false
      )
      empty arr

  let any = { empty with arrow = any.arrow }
  let is_empty (_,arr) = arr == []
end
  

module Int = struct
  let has_int d i = Intervals.contains i d.ints

  let get d = d.ints
  let put i = { empty with ints = i }
  let is_int d = is_empty { d with ints = Intervals.empty }
  let any = { empty with ints = Intervals.any }
end

module Atom = struct
  let has_atom d a = Atoms.contains a d.atoms
  let get d = d.atoms
end

module Char = struct
  let has_char d c = Chars.contains c d.chars
  let any = { empty with chars = Chars.any }
  let get d = d.chars
end

let print_stat ppf =
(*  Format.fprintf ppf "nb_rec = %i@." !nb_rec;
  Format.fprintf ppf "nb_norec = %i@." !nb_norec;
*)
  ()
