viewcvs.cgi/types/types.ml

open Recursive
open Printf


let map_sort f l =
  SortedList.from_list (List.map f l)

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

module LabelPool = Pool.Make(HashedString)
module AtomPool  = Pool.Make(HashedString)

type label = LabelPool.t
type atom  = AtomPool.t

type const = Integer of Big_int.big_int | Atom of atom | Char of Chars.Unichar.t

type pair_kind = [ `Normal | `XML ]

module I = struct
  type 'a t = {
    atoms : atom Atoms.t;
    ints  : Intervals.t;
    chars : Chars.t;
    times : ('a * 'a) Boolean.t;
    xml   : ('a * 'a) Boolean.t;
    arrow : ('a * 'a) Boolean.t;
(*    record: (label * bool * 'a) Boolean.t; *)
    record: (bool * (label, (bool * 'a)) SortedMap.t) Boolean.t;
  }

  let empty = { 
    times = Boolean.empty; 
    xml   = Boolean.empty; 
    arrow = Boolean.empty; 
    record= Boolean.empty;
    ints  = Intervals.empty;
    atoms = Atoms.empty;
    chars = Chars.empty;
  }

  let any =  {
    times = Boolean.full; 
    xml   = Boolean.full; 
    arrow = Boolean.full; 
    record= Boolean.full; 
    ints  = Intervals.any;
    atoms = Atoms.any;
    chars = Chars.any;
  }

               
  let interval i = { empty with ints = i }
  let times x y = { empty with times = Boolean.atom (x,y) }
  let xml x y = { empty with xml = Boolean.atom (x,y) }
  let arrow x y = { empty with arrow = Boolean.atom (x,y) }
  let record label opt t = 
    { empty with record = Boolean.atom (true,[label,(opt,t)]) }
  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 = Boolean.cup x.times y.times;
      xml   = Boolean.cup x.xml y.xml;
      arrow = Boolean.cup x.arrow y.arrow;
      record= Boolean.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;
    }
      
  let cap x y = 
    if x = y then x else {
      times = Boolean.cap x.times y.times;
      xml   = Boolean.cap x.xml y.xml;
      record= Boolean.cap x.record y.record;
      arrow = Boolean.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;
    }
      
  let diff x y = 
    if x = y then empty else { 
      times = Boolean.diff x.times y.times;
      xml   = Boolean.diff x.xml y.xml;
      arrow = Boolean.diff x.arrow y.arrow;
      record= Boolean.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;
    }

                   
  let rec equal_rec e r1 r2 =
    match (r1,r2) with
    | [],[] -> ()
    | (l1,(o1,x1))::r1,(l2,(o2,x2))::r2 ->
        if (l1 <> l2) || (o1 <> o2) then raise NotEqual;
        e x1 x2; equal_rec e r1 r2
    | _ -> raise NotEqual
(* check: faster to reverse the calls to e and to equal_rec ? *)

  let equal e a b =
    if a.atoms <> b.atoms then raise NotEqual;
    if a.chars <> b.chars then raise NotEqual;
    if a.ints <> b.ints then raise NotEqual;
    Boolean.equal (fun (x1,x2) (y1,y2) -> e x1 y1; e x2 y2) a.times b.times;
    Boolean.equal (fun (x1,x2) (y1,y2) -> e x1 y1; e x2 y2) a.xml b.xml;
    Boolean.equal (fun (x1,x2) (y1,y2) -> e x1 y1; e x2 y2) a.arrow b.arrow;
    Boolean.equal (fun (o1,r1) (o2,r2) ->
                     if (o1 <> o2) then raise NotEqual;
                     equal_rec e r1 r2)
      a.record b.record
      
  let map f a =
    { times = Boolean.map (fun (x1,x2) -> (f x1, f x2)) a.times;
      xml   = Boolean.map (fun (x1,x2) -> (f x1, f x2)) a.xml;
      arrow = Boolean.map (fun (x1,x2) -> (f x1, f x2)) a.arrow;
      record= Boolean.map (fun (o,r) -> 
                             (o, List.map (fun (l,(o,x)) -> (l,(o,f x))) r))
                a.record;
      ints  = a.ints;
      atoms = a.atoms;
      chars = a.chars;
    }
    
  let hash h a =
    Hashtbl.hash (map h a)
(*
    (Hashtbl.hash { (map h a) with ints = Intervals.empty })
    + (Intervals.hash a.ints)
*)
      
  let iter f a =
    ignore (map f a)
     
  let deep = 4
end

     
module Algebra = Recursive_noshare.Make(I)
include I
include Algebra
module DescrHash = 
  Hashtbl.Make(
    struct 
      type t = descr
      let hash = hash_descr
      let equal = equal_descr
    end
  )

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

(*
let define n d = check d; define n d
*)

let cons d =
  let n = make () in
  define n d;
  internalize n

(*
let any_rec = cons { empty with record = Boolean.full }
let any_node = make ();;
define any_node   {
  times = Boolean.full; 
  xml   = Boolean.atom 
            (cons { empty with atoms = Atoms.any },
             cons (times any_rec any_node));
  arrow = Boolean.full; 
  record= Boolean.full; 
  ints  = Intervals.any;
  atoms = Atoms.any;
  chars = Chars.any;
};;
internalize any_node;;
let any = descr any_node
*)

let neg x = diff any x

(*
let get_record r =
  let add = SortedMap.add (fun (o1,t1) (o2,t2) -> (o1&&o2, cap t1 t2)) in
  let line (p,n) =
    let accu = List.fold_left 
                 (fun accu (l,o,t) -> add l (o,descr t) accu) [] p in
    List.fold_left 
      (fun accu (l,o,t) -> add l (not o,neg (descr t)) accu) accu n in
  List.map line r
*)
    
module LabelSet = Set.Make(LabelPool)

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

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

let check d =
  Boolean.check d.times;
  Boolean.check d.xml;
  Boolean.check d.arrow;
  Boolean.check d.record;
  ()


(* 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)


module Assumptions = Set.Make(struct type t = descr let compare = compare end)

let memo = ref Assumptions.empty
let cache_false = ref Assumptions.empty

exception NotEmpty

let rec empty_rec d =
  if Assumptions.mem d !cache_false then false 
  else if Assumptions.mem d !memo then true
  else 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 (
    let backup = !memo in
    memo := Assumptions.add d backup;
    if 
      (empty_rec_times d.times) &&
      (empty_rec_times d.xml) &&
      (empty_rec_arrow d.arrow) &&
      (empty_rec_record d.record) 
    then true
    else (
      memo := backup;
      cache_false := Assumptions.add d !cache_false;
      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 ->
(* This avoids explosion with huge rhs (+/- degenerated partitioning)
   May be slower when List.length right is small; could optimize
   this case... *)
        if empty_rec (cap_t accu1 t1) || empty_rec (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
(*
  let right' = List.filter 
                 (fun (t1,t2) ->
                    not 
                    (empty_rec (cap_t accu1 t1) || empty_rec (cap_t accu2 t2)
                    )
                 ) right in
  if List.length right > 15 then (
    Format.fprintf Format.std_formatter "[%i=>%i]@." 
                                    (List.length right) (List.length right');
    Format.fprintf Format.std_formatter "(%a,%a)@." 
                                    !print_descr accu1
                                    !print_descr accu2;
    List.iter (fun (t1,t2) ->
                 Format.fprintf Format.std_formatter "\ (%a,%a)@." 
                   !print_descr (descr t1)
                   !print_descr (descr t2);
              ) right
  );
  let right = right' in
*)

  (empty_rec accu1) || (empty_rec accu2) ||
(* OPT? It does'nt seem so ...  The hope was to return false quickly
   for large right hand-side *)
  (
    (* (if (List.length right > 2) then
       let (cup1,cup2) = cup_product right in
       (empty_rec (diff accu1 cup1)) && (empty_rec (diff accu2 cup2))
     else true)
    && *)
    (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_opt,left)),rights) =
  let rec aux = function
    | [] -> raise NotEmpty
    | (oright,(right_opt,right))::rights ->
        let next =
          (oleft && (not oright)) ||
          exists (Array.length left)
            (fun i ->
               (not (left_opt.(i) && right_opt.(i))) &&
               (empty_rec (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 oback = left_opt.(i) in
            let odi = oback && (not right_opt.(i)) in
            let di = diff back right.(i) in
            if odi || not (empty_rec di) then (
              left.(i) <- diff back right.(i);
              left_opt.(i) <- odi;
              aux rights;
              left.(i) <- back;
              left_opt.(i) <- oback;
            )
          done
  in
  exists (Array.length left) 
    (fun i -> not left_opt.(i) && (empty_rec left.(i))) 
  ||
  (try aux rights; true with NotEmpty -> false)
            

and empty_rec_record c =
(*
  let aux = List.exists (fun (_,(opt,t)) -> (not opt) && (empty_rec t)) in
*)
  List.for_all empty_rec_record_aux (get_record c)

let is_empty d =
(*  Printf.eprintf "+"; flush stderr; *)
  let old = !memo in
  let r = empty_rec d in
  if not r then memo := old; 
(*  cache_false := Assumptions.empty;  *)
(*  Printf.eprintf "-\n"; flush stderr; *)
  r

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 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 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 d;
    !accu

  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 restrict_1 rects pi1 =
    let aux accu (t1,t2) = 
      let t1 = cap t1 pi1 in if is_empty t1 then accu else (t1,t2)::accu in
    List.fold_left aux [] rects
  
  type normal = t

  module Memo = Map.Make(struct 
                           type t = (node * node) Boolean.t
                           let compare = compare end)
                           

  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
          memo := Memo.add d n !memo;
          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_atom ppf a = 
    Format.fprintf ppf "`%s" (AtomPool.value a)

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

  let print_const ppf = function
    | Integer i -> Format.fprintf ppf "%s" (Big_int.string_of_big_int i)
    | Atom a -> print_atom ppf a
    | Char c -> Chars.Unichar.print 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 bool_iter f b =
    List.iter (fun (p,n) -> List.iter f p; List.iter f n) b

  let trivial b = b = Boolean.empty || b = Boolean.full

  let worth_abbrev d = 
    not (trivial d.times && trivial d.arrow && trivial 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);
        bool_iter (fun (n1,n2) -> mark n1; mark n2) d.times;
        bool_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;
        bool_iter (fun (n1,n2) -> mark n1; mark n2) d.arrow;
        bool_iter (fun (o,l) -> List.iter (fun (l,(o,n)) -> mark n) 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 d = any then Format.fprintf ppf "Any" else
      print_union ppf 
        (Intervals.print d.ints @
         Chars.print d.chars @
         Atoms.print "Atom" print_atom d.atoms @
         Boolean.print "Pair" print_times d.times @
         Boolean.print "XML" print_xml d.xml @
         Boolean.print "Arrow" print_arrow d.arrow @
         Boolean.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,(o,t)) ->
                 let sep = if !first then (first := false; " ") else ";@ " in
                 Format.fprintf ppf "%s@[%s =%s@] %a" sep
                   (LabelPool.value l) (if o then "?" else "") print t
              ) 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 =
    (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 ]
  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)

  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 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 Big_int.big_int
  | Atom of atom
  | Char of Chars.Unichar.t
  | Pair of (t * t)
  | Xml of (t * t)
  | Record of (label * t) list
  | Fun of (node * node) list
  | Other

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 (fun _ -> AtomPool.dummy_min) d.atoms) with 
        Not_found ->
(* Here: could create a fresh atom ... *)
    try Char (Chars.sample d.chars) with Not_found ->
    try sample_rec_arrow d.arrow with Not_found ->

    let memo = Assumptions.add d memo in
    try Pair (sample_rec_times memo d.times) with Not_found ->
    try Xml (sample_rec_times memo 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 ->
        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 fields =
(*TODO*)
  raise Not_found
(*
  let aux acc (l,(o,t)) = if o then acc else (l, sample_rec memo t) :: acc in
  List.fold_left aux [] fields
*)

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 -> Format.fprintf ppf "%s" (Big_int.string_of_big_int i)
    | Atom a ->    
        if a = LabelPool.dummy_min then
          Format.fprintf ppf "(almost any atom)"
        else
          Format.fprintf ppf "`%s" (AtomPool.value a)
    | Char c -> Chars.Unichar.print ppf c
    | Pair (x1,x2) -> Format.fprintf ppf "(%a,%a)" print x1 print x2
    | Xml (x1,x2) -> Format.fprintf ppf "XML(%a,%a)" print x1 print x2
    | Record r ->
        Format.fprintf ppf "{ %a }"
          (print_sep 
             (fun ppf (l,x) -> 
                Format.fprintf ppf "%s = %a"
                (LabelPool.value l)
                print x
             )
             " ; "
          ) r
    | 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
  type atom = bool * (label, (bool * node)) SortedMap.t
  type t = atom Boolean.t

  let get d = d.record

  let restrict_label_absent t l =
    Boolean.compute_bool
      (fun (o,r) as x ->
         try
           let (lo,_) = List.assoc l r in
           if lo then Boolean.atom (o,SortedMap.diff r [l])
           else Boolean.empty
         with Not_found -> Boolean.atom x
      )
      t

  let restrict_field t l d =
    (* Is it correct ?  Do we need to keep track of "first component"
       (value of l) as in label_present, then filter at the end ... ? *)
    Boolean.compute_bool
      (fun (o,r) as x ->
         try
           let (lo,lt) = List.assoc l r in
           if (not lo) && (is_empty (cap d (descr lt))) then Boolean.empty
           else  Boolean.atom (o, SortedMap.diff r [l])
         with Not_found -> 
           if o then Boolean.atom x else Boolean.empty
      )
      t


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

  let label_present (t:t) l : (descr * t) list =
    let x =
      Boolean.compute_bool
        (fun (o,r) as x ->
           try
             let (_,lt) = List.assoc l r in
             Boolean.atom (descr lt, Boolean.atom (o, SortedMap.diff r [l]))
           with Not_found -> 
             if o then Boolean.atom (any, Boolean.atom x) else Boolean.empty
        )
        t
    in
    TR.boolean x

  let is_label_present t l =
    Boolean.compute
      ~empty:false ~full:true
      ~cup:(||) ~cap:(&&)
      ~diff:(fun x y -> x && not y)
      ~atom:(fun (o,r) ->
               try let (lo,_) = List.assoc l r in not lo
               with Not_found -> false
            )
      t

  let restrict_label_present t l =
    t
(*
    let r = label_present t l in
    List.fold_left (fun accu (_,t) -> Boolean.cup accu t) Boolean.empty r
*)

  let project_field t l =
    let r = label_present t l in
    List.fold_left (fun accu (d,_) -> cup accu d) empty r

  let project t l =
    let t = get t in
    if is_label_present t l then project_field t l else raise Not_found
           
  type normal = 
      [ `Success
      | `Fail
      | `Label of label * (descr * normal) list * normal ]

  let first_label t =
    let min = ref None in
    let lab l = match !min with 
      | Some l' when l >= l' -> () 
      | _ -> min := Some l in
    let aux = function
      | _,[] -> ()
      | _,(l,_)::_ -> lab l in
    Boolean.iter aux t;
    match !min with
      | Some l -> `Label l
      | None -> 
          let n = 
            Boolean.compute
              ~empty:0
              ~full:3
              ~cup:(lor)
              ~cap:(land)
              ~diff:(fun a b -> a land lnot b)
              ~atom:(function (true,[]) -> 3 | (false,[]) -> 1 | _ -> assert false)
              t in
          match n with
            | 0 -> `Fail
            | 1 -> `NoField
            | 2 -> `SomeField
            | _ -> `Success


  let rec normal_aux t =
    match first_label t with
      | `Label l ->
          let present = label_present t l
          and absent = restrict_label_absent t l in
          `Label (l, List.map (fun (d,t) -> d, normal_aux t) present,
                  normal_aux absent)
      | `Fail -> `Fail
      | `Success -> `Success
      | _ -> assert false

  let normal t = normal_aux (get t)
    

  let descr x = { empty with record = x }
  let is_empty x = is_empty (descr x)
(*

  type t = (label, (bool * descr)) SortedMap.t list

  let get d =
    let line r = List.for_all (fun (l,(o,d)) -> o || non_empty d) r in
    List.filter line (get_record d.record)

  let restrict_label_present t l =
    let restr = function 
      | (true, d) -> if non_empty d then (false,d) else raise Exit 
      | x -> x in
    let aux accu r =  
      try SortedMap.change l restr (false,any) r :: accu
      with Exit -> accu in
    List.fold_left aux [] t

  let restrict_label_absent t l =
    let restr = function (true, _) -> (true,empty) | _ -> raise Exit in
    let aux accu r =  
      try SortedMap.change l restr (true,empty) r :: accu
      with Exit -> accu in
    List.fold_left aux [] t

  let restrict_field t l d =
    let restr (_,d1) = 
      let d1 = cap d d1 in 
      if is_empty d1 then raise Exit else (false,d1) in
    let aux accu r = 
      try SortedMap.change l restr (false,d) r :: accu 
      with Exit -> accu in
    List.fold_left aux [] t

  let project_field t l =
    let aux accu x =
      match List.assoc l x with
        | (false,t) -> cup accu t
        | _ -> raise Not_found
    in
    List.fold_left aux empty t

  let project d l =
    project_field (get_record d.record) l

  type normal = 
      [ `Success
      | `Fail
      | `Label of label * (descr * normal) list * normal ]

  let rec merge_record n r =
    match (n, r) with
      | (`Success, _) | (_, []) -> `Success
      | (`Fail, r) ->
          let aux (l,(o,t)) n = 
            `Label (l, [t,n], if o then n else `Fail) in
          List.fold_right aux r `Success
      | (`Label (l1,present,absent), (l2,(o,t2))::r') ->
          if (l1 < l2) then
            let pr =  List.map (fun (t,x) -> (t, merge_record x r)) present in
            let t = List.fold_left (fun a (t,_) -> diff a t) any present in
            let pr = 
              if non_empty t then (t, merge_record `Fail r) :: pr
              else pr in
            `Label (l1,pr,merge_record absent r)
          else if (l2 < l1) then
            let n' = merge_record n r' in
            `Label (l2, [t2, n'], if o then n' else n)
          else
            let res = ref [] in
            let aux a (t,x) = 
              (let t = diff t t2 in 
               if non_empty t then res := (t,x) :: !res);
              (let t = cap t t2 in
               if non_empty t then res := (t, merge_record x r') :: !res);
              diff a t 
            in
            let t2 = List.fold_left aux t2 present in
            let () = 
              if non_empty t2 then 
              res := (t2, merge_record `Fail r') :: !res in
            let abs = if o then merge_record absent r' else absent in
            `Label (l1, !res, abs)

  module Unify = Map.Make(struct type t = normal let compare = compare end)

  let repository = ref Unify.empty

  let rec canonize = function
    | `Label (l,pr,ab) as x ->
        (try Unify.find x !repository 
         with Not_found -> 
           let pr = List.map (fun (t,n) -> canonize n,t) pr in
           let pr = SortedMap.from_list cup pr in
           let pr = List.map (fun (n,t) -> (t,n)) pr in
           let x = `Label (l, pr, canonize ab) in
           try Unify.find x !repository
           with Not_found -> repository := Unify.add x x !repository; x
        )
    | x -> x

  let normal d =
    let r = canonize (List.fold_left merge_record `Fail (get d)) in
    repository := Unify.empty;
    r

  type normal' =
      [ `Success
      | `Label of label * (descr * descr) list * descr option ] option

(* NOTE: this function relies on the fact that generic order
         makes smallest labels appear first *)

  let first_label d =
    let d = d.record in
    let min = ref None in
    let lab (l,o,t) = match !min with 
      | Some l' when l >= l' -> () 
      | _ -> if o && (descr t = any) then () else min := Some l in
    let line (p,n) =
      (match p with f::_ -> lab f | _ -> ());
      (match n with f::_ -> lab f | _ -> ()) in
    List.iter line d;
    match !min with
      | None -> if d = [] then `Empty else `Any
      | Some l -> `Label l

  let normal' (d : descr) l =
    let ab = ref empty in
    let rec extract f = function
      | (l',o,t) :: rem when l = l' -> 
          f o (descr t); extract f rem
      | x :: rem -> x :: (extract f rem)
      | [] -> [] in
    let line (p,n) =
      let ao = ref true and ad = ref any in
      let p = 
        extract (fun o d -> ao := !ao && o; ad := cap !ad d) p
      and n = 
        extract (fun o d -> ao := !ao && not o; ad := diff !ad d) n
      in
      (* Note: p and n are still sorted *)
      let d = { empty with record = [(p,n)] } in
      if !ao then ab := cup d !ab;
      (!ad, d) in
    let pr = List.map line d.record in
    let pr = Product.normal_aux pr in
    let ab = if is_empty !ab then None else Some !ab in
    (pr, ab)
            
*)

  let any = { empty with record = any.record }
(*
  let is_empty d = d = []
  let descr l =
    let line l = map_sort (fun (l,(o,d)) -> (l,o,cons d)) l, [] in 
    { empty with record = map_sort line l }
*)
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 = 
      map_sort
        (fun (d1,d2) -> [(rec_normalize d1, rec_normalize d2)],[])
        (Product.normal d)
    in
    let xml = 
      map_sort
        (fun (d1,d2) -> [(rec_normalize d1, rec_normalize d2)],[])
        (Product.normal ~kind:`XML d)
    in
    let record = d.record
(*
      map_sort
        (fun f -> map_sort (fun (l,(o,d)) -> (l,o,rec_normalize d)) f, [])
        (Record.get d)
*)
    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 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 = [ (SortedList.cup left p, n) ] }
          else aux rem
    in
    aux s.arrow

  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 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, [])
      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
end

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

(*
let rec print_normal_record ppf = function
  | Success -> Format.fprintf ppf "Yes"
  | Fail -> Format.fprintf ppf "No"
  | FirstLabel (l,present,absent) ->
      Format.fprintf ppf "%s?@[<v>@\n" (label_name l);
      List.iter
        (fun (t,n) ->
           Format.fprintf ppf "(%a)=>@[%a@]@\n" 
             Print.print_descr t
             print_normal_record n
        ) present;
      if absent <> Fail then
        Format.fprintf ppf "(absent)=>@[%a@]@\n" print_normal_record absent;
      Format.fprintf ppf "@]" 
*)


(* 
let pr s = Types.Print.print Format.std_formatter (Syntax.make_type (Syntax.parse s));;

let pr' s = Types.Print.print Format.std_formatter 
   (Types.normalize (Syntax.make_type (Syntax.parse s)));;

BUG:
pr "'a | 'b where 'a = ('a , 'a) and 'b= ('b , 'b)";;
*)


(*
  let nr s =
    let t = Types.descr (Syntax.make_type (Syntax.parse s)) in
    let n = Types.normal_record' t.Types.record in
    Types.print_normal_record Format.std_formatter n;;
*)