Try an early simplification of types.

types/types.ml

@@ -2546,9 +2546,7 @@ struct
 
 
   (* returns a recursive type where all occurrences of alpha n t
-   * are substituted with a recursive variable X and all fresh variables
-   * in covariant position are substituted with empty and contravariant
-   * position with any *)
+   * are substituted with a recursive variable X *)
   let substituterec t alpha =
     let subst x d =
       if Var.equal d alpha then x
@@ -2605,9 +2603,9 @@ struct
       end)
       in
       let vars = Hashtbl.create 17 in
-      let memo =  Memo.create 17 in
-      let t_emp = ty empty in
-      let t_any = ty any in
+      let memo = Memo.create 17 in
+      let t_emp = cup [] in
+      let t_any = cap [] in
       let idx = ref 0 in
 
     (* we memoize based on the pair (pos, v), since v can occur both
@@ -2623,7 +2621,7 @@ struct
             let td = Hashtbl.find vars d in
             if ((td == t_emp) && not pos)
               || ((td == t_any) && pos)
-            then (* polarity problem, replace the binding by a new,
+            then (* polarity conflict, replace the binding by a new,
                     pretty-printed variable *)
               begin
                 let id = pretty_name !idx "" in
@@ -2659,20 +2657,33 @@ struct
         descr (solve new_t)
       end
 
-  let clean_type t =
-    if no_var t then t else
-      if not (subtype t Arrow.any) then clean_variables t
-      else
-        let _, u_arrow = Arrow.get t in
+    let rec uniq = function
+      | ([] | [ _ ]) as l ->  l
+      | t1 :: ((t2 :: _) as l1) ->
+        if equiv t1 t2 then uniq l1 else t1 :: uniq l1
+
+    let clean_type t =
+      if no_var t then t else
+        let t = clean_variables t in
+        let arrow_t, non_arrow_t =
+          { empty with arrow = t.arrow },
+          { t with arrow = empty.arrow }
+        in
+        let _, u_arrow = Arrow.get arrow_t in
         List.fold_left (fun acc i_arrow ->
           T.cup acc (
-            (List.fold_left (fun acc (dom, cdom) ->
+            let conj_arrow = (List.fold_left (fun acc (dom, cdom) ->
               let indiv_arrow = T.arrow (T.cons dom) (T.cons cdom) in
-              let pretty_arrow = clean_variables indiv_arrow in
-              T.cap acc pretty_arrow
-             ) T.any i_arrow)
+              indiv_arrow::acc
+            ) [] i_arrow)
+            in
+            let sorted_conj = List.sort (fun t1 t2 -> if equiv t1 t2 then 0 else
+                compare t1 t2) conj_arrow
+            in
+            List.fold_left (T.cap) T.any (uniq sorted_conj)
+
           )
-        ) T.empty u_arrow
+        ) non_arrow_t u_arrow
 
 end
 
@@ -3231,6 +3242,7 @@ let apply_raw  s t =
   let get a i = if i < 0 then any else (!a).(i) in
   let gamma = var (Var.mk "Gamma") in
   let cgamma = cons gamma in
+  (* cell i of ai contains /\k<=i s_k, cell j of aj contains /\k<=j t_k *)
   let ai = ref [| |]
   and aj = ref [| |] in
   let result = ref any in
@@ -3244,20 +3256,24 @@ let apply_raw  s t =
           cap tacc (List.fold_left (fun tacc subst ->
             Positive.substitute tacc subst) gamma constr_lst)) any sl
       in
+      let new_res = Positive.clean_type new_res in
       if subtype new_res !result && not (subtype !result new_res)
-      then
+      then begin
         (* strictly improved the result, continue *)
+        Format.printf "Found a partial solution at %i, %i: %a@\n@."
+          i j Print.print new_res;
         result := new_res
+      end
       else raise (Found(new_res,i,j,sl))
     with
-      Tallying.Step1Fail -> raise (Tallying.UnSatConstr "apply_raw step1")
+      Tallying.Step1Fail -> (assert (i == 0 &&  j == 0); raise (Tallying.UnSatConstr "apply_raw step1"))
     | Tallying.Step2Fail -> () (* continue *)
   in
   let rec loop i =
     try
       Format.printf "Starting expansion %i @\n@." i;
-      set ai (i) (cap (Positive.substitutefree s) (get ai (i-1)));
-      set aj (i) (cap (Positive.substitutefree t) (get aj (i-1)));
+      set ai i (cap (Positive.substitutefree s) (get ai (i-1)));
+      set aj i (cap (Positive.substitutefree t) (get aj (i-1)));
       for j = 0 to i-1 do
         tallying j i;
         tallying i j;
@@ -3275,7 +3291,6 @@ let apply_raw  s t =
 
 let apply_full s t =
   let _,_,_,res = apply_raw s t in
-  let res = Positive.clean_type res in
   Format.printf "result: %a@\n@." Print.print res;
   res