Load loadpath.
Require Import ZArith List Recdef Coq.MSets.MSetInterface Coq.Sorting.Mergesort
               Permutation Coq.MSets.MSetAVL.
Require Import veristar.basic veristar.tactics veristar.variables veristar.datatypes
               veristar.compare veristar.redblack.

(** The clause datatype and related definitions and lemmas *)

(** pure_atom:
pure atoms *)

Inductive pure_atom := Eqv : expr -> expr -> pure_atom.

Let var1 : var := Z2id 1.
Let var0 : var := Z2id 0.
Let var2 : var := Z2id 2.

Fixpoint list_prio {A} (weight: var) (l: list A) (p: var) : var :=
  match l with
  | nil => p
  | _::l' => list_prio weight l' (add_id weight p)
  end.

(** Weight the positive atoms 1 each, and the negative atoms 2 each.
    Then the highest-priority terms will be the positive unit clauses *)

Definition prio (gamma delta: list pure_atom) : var :=
    list_prio var2 gamma (list_prio var1 delta var0).

(** clause:
clauses are either pure (no spatial atoms), negative spatial (spatial atom on the left)
or positive spatial. *)

Inductive clause : Type :=
| PureClause : forall (gamma : list pure_atom) (delta : list pure_atom)
                         (priority : var)
                         (prio_ok: prio gamma delta = priority), clause
| PosSpaceClause : forall (gamma : list pure_atom) (delta : list pure_atom)
  (sigma : list space_atom), clause
| NegSpaceClause : forall (gamma : list pure_atom) (sigma : list space_atom)
  (delta : list pure_atom), clause.

Definition expr_cmp e e' :=
 match e, e' with
   | Nil , Nil => Eq
   | Nil, _ => Lt
   | _, Nil => Gt
   | Var v, Var v' => Ident.compare v v'
 end.

Lemma var_cspec : StrictCompSpec (@Logic.eq var) Ident.lt Ident.compare.
Proof. split; [apply Ident.lt_strorder|apply Ident.compare_spec]. Qed.

Hint Resolve var_cspec.

Lemma expr_cspec: CompSpec' expr_cmp.
Proof.
 repeat constructor; repeat intro.
 destruct x; simpl in *; try discriminate.
 rewrite <- (lt_comp _ _ var_cspec) in H.
 contradiction (Ilt_irrefl H).
 repeat intro.
 destruct x; destruct y; simpl in *; try discriminate;
   destruct z; simpl in *; try discriminate; auto.
 rewrite <- (lt_comp _ _ var_cspec) in *.
  eapply Ilt_trans; eauto.
 destruct x; destruct y; simpl; try econstructor; auto.
 do_comp var_cspec v v0; subst; econstructor; simpl; eauto.
 rewrite <- lt_comp; eauto.
 rewrite <- lt_comp; eauto.
Qed.

Hint Resolve expr_cspec.

Definition pure_atom_cmp (a a': pure_atom) : comparison :=
 match a, a' with
   | Eqv e1 e2, Eqv e1' e2' =>
     match expr_cmp e1 e1' with
       Eq => expr_cmp e2 e2' | c => c
     end
 end.

#[export] Hint Rewrite @comp_refl using solve[auto] : comp.

Ltac comp_tac :=
    progress (autorewrite with comp in *; auto)
  || discriminate
  || solve [eapply comp_trans;  eauto]
  || subst
 || match goal with
  | H: Lt = ?A |- context [?A] => rewrite <- H
  | H: Gt = ?A |- context [?A] => rewrite <- H
  | H: Eq = ?A |- context [?A] => rewrite <- H
 end.

Lemma pure_atom_cspec: CompSpec' pure_atom_cmp.
Proof with repeat comp_tac.
 repeat split; repeat intro.
 destruct x; simpl in H...
 destruct x; destruct y; destruct z; simpl in *...
 do_comp expr_cspec e e1...
 do_comp expr_cspec e1 e3...
 do_comp expr_cspec e1 e3...
 rewrite <- (comp_trans _ expr_cspec _ _ _ e5 e6)...
 destruct x; destruct y.
 simpl.
 do_comp expr_cspec e e1...
 do_comp expr_cspec e0 e2; econstructor; eauto; simpl...
 econstructor; simpl...
 econstructor; simpl...
Qed.

Hint Resolve pure_atom_cspec.

Lemma pure_atom_cmp_eq a b : a = b <-> Eq = pure_atom_cmp a b.
Proof. intuition. subst; rewrite comp_refl; auto.
  do_comp pure_atom_cspec a b; auto; congruence.
Qed.
Hint Resolve pure_atom_cmp_eq.

(** ordering expressions, atoms and clauses *)

Definition expr_order (t t': expr) := isGe (expr_cmp t t').

Inductive max_expr (t : expr) : pure_atom -> Prop :=
| mexpr_left : forall t', expr_order t t' -> max_expr t (Eqv t t')
| mexpr_right : forall t', expr_order t t' -> max_expr t (Eqv t' t).

Definition order_eqv_pure_atom (a: pure_atom) :=
  match a with
    | Eqv i j => match expr_cmp i j with Lt => Eqv j i | _ => Eqv i j end
  end.

Definition nonreflex_atom a :=
  match a with Eqv i j => match expr_cmp i j with Eq => false | _ => true end
  end.

Definition normalize_atoms pa :=
  rsort_uniq pure_atom_cmp (map order_eqv_pure_atom pa).

Definition mkPureClause (gamma delta: list pure_atom) : clause :=
  PureClause gamma delta _ (eq_refl _).

Definition order_eqv_clause (c: clause) :=
  match c with
  | PureClause pa pa' _ _ =>
        mkPureClause (normalize_atoms (filter nonreflex_atom pa)) (normalize_atoms pa')
  | PosSpaceClause pa pa' sa' =>
    PosSpaceClause (normalize_atoms (filter nonreflex_atom pa))
                   (normalize_atoms pa') sa'
  | NegSpaceClause pa sa pa' =>
    NegSpaceClause (normalize_atoms (filter nonreflex_atom pa)) sa
                   (normalize_atoms pa')
  end.

Definition mk_pureL (a: pn_atom) : clause :=
 match a with
 | Equ x y => mkPureClause nil (order_eqv_pure_atom(Eqv x y)::nil)
 | Nequ x y => mkPureClause (order_eqv_pure_atom(Eqv x y)::nil) nil
 end.

Fixpoint mk_pureR (al: list pn_atom) : list pure_atom * list pure_atom :=
 match al with
 | nil => (nil,nil)
 | Equ x y :: l' => match mk_pureR l' with (p,n) =>
                      (order_eqv_pure_atom(Eqv x y)::p, n) end
 | Nequ x y :: l' => match mk_pureR l' with (p,n) =>
                       (p, order_eqv_pure_atom(Eqv x y)::n) end
 end.

(** cnf:
clausal normal form *)

Definition cnf (en: entailment) : list clause :=
 match en with
  Entailment (Assertion pureL spaceL) (Assertion pureR spaceR) =>
   match mk_pureR pureR with (p,n) =>
     map mk_pureL pureL ++ (PosSpaceClause nil nil spaceL :: nil) ++
       match spaceL, spaceR with
       | nil, nil => mkPureClause p n :: nil
       | _, _ => NegSpaceClause p spaceR n :: nil
       end
   end
  end.

(** various comparison functions *)

Definition pure_atom_geq a b := isGeq (pure_atom_cmp a b).
Definition pure_atom_gt a b := match pure_atom_cmp a b with Gt => true | _ => false end.
Definition pure_atom_eq a b := match pure_atom_cmp a b with Eq => true | _ => false end.
Definition expr_lt a b := match expr_cmp a b with Lt => true | _ => false end.
Definition expr_eq a b := match expr_cmp a b with Eq => true | _ => false end.
Definition expr_geq a b := match expr_cmp a b with Lt => false | _ => true end.

Definition norm_pure_atom (a : pure_atom) :=
  match a with
    | Eqv i j => if expr_lt i j then Eqv j i else Eqv i j
  end.

Definition subst_pure (i: var) (t: expr) (a: pure_atom) :=
 match a with
   | Eqv t1 t2 => Eqv (subst_expr i t t1) (subst_expr i t t2)
 end.

Definition subst_pures (i: var) (t: expr) (pa: list pure_atom)
  : list pure_atom := map (subst_pure i t) pa.

Definition compare_space_atom (a b : space_atom) : comparison :=
 match a , b with
  | Next i j , Next i' j' => match expr_cmp i i' with Eq => expr_cmp j j' | c => c end
  | Next i j, Lseg i' j' =>
    match expr_cmp i i' with
    | Lt => Lt
    | Eq => Lt
    | Gt => Gt
    end
  | Lseg i j, Next i' j' =>
    match expr_cmp i i' with
    | Lt => Lt
    | Eq => Gt
    | Gt => Gt
    end
  | Lseg i j , Lseg i' j' => match expr_cmp i i' with Eq => expr_cmp j j' | c => c end
  end.

Lemma space_atom_cspec: CompSpec' compare_space_atom.
Proof with (repeat (comp_tac || solve [econstructor; simpl; repeat comp_tac])).
 repeat constructor; repeat intro.
 destruct x; simpl in *...
 destruct x; destruct y; simpl in *...
 do_comp expr_cspec e e1...
 destruct z; simpl in *...
 do_comp expr_cspec e1 e...
 destruct z; simpl in *...
 do_comp expr_cspec e1 e4...
 rewrite <- (comp_trans _ expr_cspec _ _ _ e3 e6)...
 do_comp expr_cspec e1 e4...
 rewrite <- (comp_trans _ expr_cspec _ _ _ e3 e6)...
 do_comp expr_cspec e e1...
 destruct z; simpl in *.
 do_comp expr_cspec e1 e...
 do_comp expr_cspec e1 e...
 destruct z; simpl in *.
 do_comp expr_cspec e1 e4...
 rewrite <- (comp_trans _ expr_cspec _ _ _ e3 e6)...
 do_comp expr_cspec e1 e4...
 rewrite <- (comp_trans _ expr_cspec _ _ _ e3 e6)...
 destruct z; simpl in *.
 do_comp expr_cspec e e1...
 do_comp expr_cspec e1 e3...
 rewrite <- (comp_trans _ expr_cspec _ _ _ e5 e6)...
 do_comp expr_cspec e e1...
 do_comp expr_cspec e1 e3...
 rewrite <- (comp_trans _ expr_cspec _ _ _ e5 e6)...
 do_comp expr_cspec e e1...
 destruct z; simpl in *.
 do_comp expr_cspec e1 e...
 do_comp expr_cspec e1 e...
 destruct z; simpl in *.
 do_comp expr_cspec e1 e4...
 rewrite <- (comp_trans _ expr_cspec _ _ _ e3 e6)...
 do_comp expr_cspec e1 e4...
 rewrite <- (comp_trans _ expr_cspec _ _ _ e3 e6)...
 destruct x; destruct y; simpl...
 do_comp expr_cspec e e1; simpl...
 do_comp expr_cspec e0 e2...
 do_comp expr_cspec e e1...
 do_comp expr_cspec e e1...
 do_comp expr_cspec e e1...
 do_comp expr_cspec e0 e2...
Qed.

Hint Resolve space_atom_cspec.

Definition compare_clause (cl1 cl2 : clause) : comparison :=
  match cl1 , cl2 with
  | PureClause neg pos _ _ , PureClause neg' pos' _ _ =>
    match compare_list pure_atom_cmp neg neg' with
    | Eq => compare_list pure_atom_cmp pos pos'
    | c => c
    end
  | PureClause _ _ _ _ , _ => Lt
  | _ , PureClause _ _ _ _ => Gt
  | PosSpaceClause gamma delta sigma , PosSpaceClause gamma' delta' sigma'
  | NegSpaceClause gamma sigma delta , NegSpaceClause gamma' sigma' delta' =>
    match compare_list pure_atom_cmp gamma gamma' with
    | Eq => match compare_list pure_atom_cmp delta delta' with
                 | Eq => compare_list compare_space_atom sigma sigma'
                 | c => c
                 end
    | c => c
    end
  | PosSpaceClause _ _ _ , NegSpaceClause _ _ _ => Lt
  | NegSpaceClause _ _ _ , PosSpaceClause _ _ _ => Gt
  end.

Lemma clause_cspec: CompSpec' compare_clause.
Proof with (repeat (comp_tac || solve [econstructor; simpl; repeat comp_tac])).
 repeat constructor; repeat intro.
 (* irreflexive *)
 destruct x; simpl in *...
 (* transitive *)
 destruct x; destruct y; destruct z; simpl in *...
 do_comp (list_cspec _ pure_atom_cspec) gamma gamma0...
 do_comp (list_cspec _ pure_atom_cspec) gamma0 gamma1...
 do_comp (list_cspec _ pure_atom_cspec) gamma0 gamma1...
 replace (compare_list pure_atom_cmp gamma gamma1)  with Lt by (eapply comp_trans; eauto)...
 do_comp (list_cspec _ pure_atom_cspec) gamma gamma0...
 do_comp (list_cspec _ pure_atom_cspec) gamma0 gamma1...
 do_comp (list_cspec _ pure_atom_cspec) delta delta0...
 do_comp (list_cspec _ pure_atom_cspec) delta0 delta1...
 do_comp (list_cspec _ pure_atom_cspec) delta0 delta1...
 replace (compare_list pure_atom_cmp delta delta1)  with Lt by (eapply comp_trans; eauto)...
 do_comp (list_cspec _ pure_atom_cspec) gamma0 gamma1...
 replace (compare_list pure_atom_cmp gamma gamma1)  with Lt by (eapply comp_trans; eauto)...
 do_comp (list_cspec _ pure_atom_cspec) gamma gamma0...
 do_comp (list_cspec _ pure_atom_cspec) gamma0 gamma1...
 do_comp (list_cspec _ pure_atom_cspec) delta delta0...
 do_comp (list_cspec _ pure_atom_cspec) delta0 delta1...
 do_comp (list_cspec _ pure_atom_cspec) delta0 delta1...
 replace (compare_list pure_atom_cmp delta delta1)  with Lt by (eapply comp_trans; eauto)...
 do_comp (list_cspec _ pure_atom_cspec) gamma0 gamma1...
 replace (compare_list pure_atom_cmp gamma gamma1)  with Lt by (eapply comp_trans; eauto)...
 (* CompSpec *)
 destruct x; destruct y; simpl in *...
 do_comp (list_cspec _ pure_atom_cspec) gamma gamma0...
 do_comp (list_cspec _ pure_atom_cspec) delta delta0...
 do_comp (list_cspec _ pure_atom_cspec) gamma gamma0...
 do_comp (list_cspec _ pure_atom_cspec) delta delta0...
 do_comp (list_cspec _ space_atom_cspec) sigma sigma0...
 do_comp (list_cspec _ pure_atom_cspec) gamma gamma0...
 do_comp (list_cspec _ pure_atom_cspec) delta delta0...
 do_comp (list_cspec _ space_atom_cspec) sigma sigma0...
Qed.

Hint Resolve clause_cspec.

Definition rev_cmp {A : Type} (cmp : A -> A -> comparison) :=
  fun a b => match cmp a b with Eq => Eq | Lt => Gt | Gt => Lt end.

Lemma rev_cmp_cspec {A} (c: A -> A -> comparison) :
  CompSpec' c -> CompSpec' (rev_cmp c).
Proof with try solve[congruence].
intro H; unfold rev_cmp; repeat constructor; repeat intro.
apply comp_refl with (x := x) in H... rewrite H in H0...
do_comp H x y... do_comp H y z...
assert (Lt = c z x) by (eapply comp_trans; eauto).
rewrite comp_antisym in H2; auto. rewrite <-H2; auto.
do_comp H x y. subst; constructor; auto.
constructor; rewrite comp_antisym in e; auto; rewrite <-e; auto.
constructor. rewrite comp_antisym in e; auto. rewrite <-e; auto.
Qed.

Lemma rev_cmp_eq : forall {A : Type} (cmp : A -> A -> comparison) (x y : A),
  (forall x0 y0 : A, Eq = cmp x0 y0 -> x0 = y0) ->
  Eq = rev_cmp cmp x y -> x = y.
Proof.
intros until y; intros H H1.
unfold rev_cmp in H1. remember (cmp x y) as b. destruct b;try solve[congruence].
apply H; auto.
Qed.

Definition prio1000 := Z2id 1000.
Definition prio1001 := Z2id 1001.

Definition clause_prio (cl : clause) : var :=
  match cl with
  | PureClause gamma delta prio _ => prio
  | PosSpaceClause _ _ _ => prio1000
  | NegSpaceClause gamma sigma delta => prio1001
  end%Z.

Definition compare_clause' (cl1 cl2 : clause) : comparison :=
  match Ident.compare (clause_prio cl1) (clause_prio cl2) with
  | Eq => compare_clause cl1 cl2
  | c => c
  end.

Lemma clause_cspec': CompSpec' compare_clause'.
Proof with (repeat (comp_tac || solve [econstructor; simpl; repeat comp_tac])).
 unfold compare_clause';
  repeat constructor; repeat intro.
 (* irrefl *)
  id_compare (clause_prio x) (clause_prio x)...
  apply (Ilt_irrefl l).
 (* trans *)
  id_compare (clause_prio x) (clause_prio y). rewrite e.
  id_compare (clause_prio y) (clause_prio z)...
  id_compare (clause_prio y) (clause_prio z)...
  rewrite e in l.
  id_compare (clause_prio x) (clause_prio z)...
  rewrite e0 in l.   contradiction (Ilt_irrefl l).
  contradiction (Ilt_irrefl (Ilt_trans l l0)).
  id_compare (clause_prio x) (clause_prio z)...
  rewrite e in *.   contradiction (Ilt_irrefl (Ilt_trans l l0)).
  contradiction (Ilt_irrefl (Ilt_trans l1 (Ilt_trans l l0))).
  id_compare (clause_prio y) (clause_prio z)...
  (* CompSpec *)
  id_compare (clause_prio x) (clause_prio y).
  do_comp clause_cspec x y...
  econstructor. rewrite e.
  id_compare (clause_prio y) (clause_prio y)...
  contradiction (Ilt_irrefl l).
  constructor... rewrite e.
  id_compare (clause_prio y) (clause_prio y)...
  contradiction (Ilt_irrefl l).
  constructor...
  id_compare (clause_prio x) (clause_prio y)...
  rewrite e in l.
  contradiction (Ilt_irrefl l).
  contradiction (Ilt_irrefl (Ilt_trans l l0)).
  constructor...
  id_compare (clause_prio y) (clause_prio x)...
  rewrite e in l.
  contradiction (Ilt_irrefl l).
  contradiction (Ilt_irrefl (Ilt_trans l l0)).
Qed.

Hint Resolve clause_cspec'.

Definition clause_length (cl : clause) : Z :=
  match cl with
  | PureClause gamma delta _ _ => Zlength gamma + Zlength delta
  | PosSpaceClause gamma delta sigma =>
      Zlength gamma + Zlength delta + Zlength sigma
  | NegSpaceClause gamma sigma delta =>
      Zlength gamma + Zlength sigma + Zlength delta
  end%Z.

Definition compare_clause_length (cl1 cl2 : clause) :=
   Zcompare (clause_length cl1) (clause_length cl2).

Definition compare_clause'1 (cl1 cl2 : clause) : comparison :=
  match compare_clause_length cl1 cl2 with
  | Eq => compare_clause cl1 cl2
  | c => c
  end.

Lemma clause_cspec'1: CompSpec' compare_clause'1.
Proof with (repeat (comp_tac || solve [econstructor; simpl; repeat comp_tac])).
 unfold compare_clause'1;
  repeat constructor; repeat intro.
 (* irrefl *)
  rewrite (comp_refl _ clause_cspec) in H;   unfold compare_clause_length in *;
  destruct x; simpl in *;
  rewrite Zcompare_refl in H; repeat (rewrite comp_refl in H; auto); congruence.
 (* trans *)
  remember (compare_clause_length x y) as j; destruct j.
  remember (compare_clause_length y z) as j; destruct j.
  replace (compare_clause_length x z) with Eq...
  symmetry in Heqj,Heqj0|-*.
  clear - Heqj Heqj0.
  apply Zcompare_Eq_iff_eq.
  apply Zcompare_Eq_eq in Heqj.
  apply Zcompare_Eq_eq in Heqj0.
  congruence.
  unfold compare_clause_length in *.
  symmetry in Heqj; apply Zcompare_Eq_eq in Heqj. rewrite Heqj. rewrite <- Heqj0; auto.
  unfold compare_clause_length in *.
  symmetry in Heqj; apply Zcompare_Eq_eq in Heqj. rewrite Heqj. rewrite <- Heqj0; auto.
  remember (compare_clause_length y z) as j; destruct j.
  unfold compare_clause_length in *.
  symmetry in Heqj0; apply Zcompare_Eq_eq in Heqj0. rewrite <- Heqj0. rewrite <- Heqj; auto.
  replace (compare_clause_length x z) with Lt; auto.
  unfold compare_clause_length in *.
  symmetry in Heqj,Heqj0|-*.
  eapply Zcompare_Lt_trans; eauto.
  inversion H0.
  inversion H.
  (* CompSpec *)
  remember (compare_clause_length x y) as j; destruct j.
  do_comp clause_cspec x y...
  econstructor.
  unfold compare_clause_length in *.
  symmetry in Heqj.
  apply Zcompare_Eq_eq in Heqj. rewrite Heqj.
  rewrite Zcompare_refl. auto.
  constructor; auto. rewrite <- Heqj; auto.
  constructor; auto.
  replace (compare_clause_length y x) with Lt; auto.
  symmetry in Heqj|-*; apply Zcompare_Gt_Lt_antisym; auto.
Qed.

Hint Resolve clause_cspec'1.

Module OrderedClause <: OrderedType
  with Definition t:=clause
  with Definition compare:=compare_clause'.

Definition t := clause.

Definition eq : clause -> clause -> Prop := Logic.eq.

Lemma eq_equiv : Equivalence eq.
Proof.  apply eq_equivalence. Qed.

Definition lt (c1 c2 : clause) := Lt = compare_clause' c1 c2.

Lemma lt_compat : Proper (eq ==> eq ==> iff) lt.
Proof.
intros. constructor; unfold eq in H,H0; subst; auto.
Qed.

Definition compare := compare_clause'.

Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y).
Proof.  destruct clause_cspec'; auto. Qed.

Lemma eq_dec : forall x y, {eq x y}+{~eq x y}.
Proof.
intros; unfold eq.
remember (compare x y) as j; destruct j.
destruct (CompSpec2Type (compare_spec x y)); try discriminate. left; auto.
right; intro; subst.
unfold compare in Heqj; rewrite comp_refl in Heqj; auto.
inversion Heqj.
do_comp clause_cspec' x y; subst; auto.
right; intro; subst. rewrite comp_refl in e; auto. inversion e.
right; intro; subst. rewrite comp_refl in e; auto. inversion e.
Qed.

Lemma lt_strorder : StrictOrder lt.
Proof. destruct clause_cspec'; auto. Qed.

End OrderedClause.

(* The clause database.  There are two alternate implementations.
  The first uses MSetAVL from the Coq library, the second uses red-black trees.
  Since red-black trees match an enhanced interface MSetPlus,
  in the first implementation we define the additional operator(s) in terms
  of what's available in MSetAVL.
*)

(* First implementation *)

Module M1 : redblack.MSetPlus
   with Definition E.t := OrderedClause.t
   with Definition E.compare := OrderedClause.compare
   with Definition E.eq := OrderedClause.eq
   with Definition E.lt := OrderedClause.lt
   with Definition E.compare := OrderedClause.compare.
 Include MSetAVL.Make(OrderedClause).
 Definition delete_min (s: t) : option (elt * t) :=
   match min_elt s with
   | Some x => Some (x, remove x s)
   | None => None
  end.
 Lemma delete_min_spec1: forall (s: t) k s',
    delete_min s = Some (k,s') <->
    (min_elt s = Some k /\ remove k s = s').
  Proof.
   intros. unfold delete_min.
   case_eq (min_elt s); intros.
   intuition. inversion H0; clear H0; subst; auto.
     inversion H0; clear H0; subst; auto. inversion H1; clear H1; subst; auto.
     intuition; discriminate.
  Qed.
 Lemma delete_min_spec2: forall s, delete_min s = None <-> Empty s.
 Proof. unfold delete_min; intros.
   case_eq (min_elt s); intros.
  intuition; try discriminate.
  apply min_elt_spec1 in H.
  apply H0 in H; contradiction.
  apply min_elt_spec3 in H.
  intuition.
  Qed.
Definition mem_add (x: elt) (s: t) : option t :=
 if mem x s then None else Some (add x s).

Lemma mem_add_spec:
    forall x s, mem_add x s = if mem x s then None else Some (add x s).
Proof. auto. Qed.
End M1.

(* Second implementation *)
Module M := redblack.Make(OrderedClause).

Definition clause_list2set (l : list clause) : M.t :=
  fold_left (fun s0 c => M.add c s0) l M.empty.

Definition empty_clause : clause := mkPureClause nil nil.

Definition remove_trivial_atoms := filter (fun a =>
  match a with
  | Eqv e1 e2 => match expr_cmp e1 e2 with
                 | Eq => false
                 | _ => true
                 end
  end).

Definition subst_pures_delete (i: var) (e: expr)
  : list pure_atom -> list pure_atom :=
  remove_trivial_atoms oo subst_pures i e.

Definition isEq cc := match cc with Eq => true | _ => false end.

Definition eq_space_atom (a b : space_atom) : bool :=
  isEq (compare_space_atom a b).

Definition eq_space_atomlist (a b : list space_atom) : bool :=
  isEq (compare_list compare_space_atom a b).

Definition eq_var i j : bool := isEq (Ident.compare i j).

Definition drop_reflex_lseg : list space_atom -> list space_atom :=
  filter (fun sa =>
                    match sa with
                    | Lseg (Var x) (Var y) => negb (eq_var x y)
                    | Lseg Nil Nil => false
                    | _ => true
                    end).

Definition order_eqv_pure_atoms := map order_eqv_pure_atom.

Definition greater_than_expr (i: var) (e: expr) :=
  match e with Var j => match Ident.compare i j with Gt => true | _ => false end
                        | Nil => true
  end.

Definition greatereq_than_expr (i: var) (e: expr) :=
  match e with
  | Var j => match Ident.compare i j with Gt => true | Eq => true | Lt => false
             end
  | Nil => true
  end.

Definition greater_than_atom (s u : pure_atom) :=
  match s , u with
  | Eqv s t , Eqv u v =>
    ((expr_lt u s && (expr_geq s v || expr_geq t v)) ||
      (expr_lt v s && (expr_geq s u || expr_geq t u))) ||
    ((expr_lt u t && (expr_geq s v || expr_geq t v)) ||
      (expr_lt v t && (expr_geq s u || expr_geq t u)))
  end.

Definition greater_than_atoms (s : pure_atom) (delta : list pure_atom) :=
  forallb (fun u => greater_than_atom s u) delta.

Definition greater_than_all (i: var) : list pure_atom -> bool :=
  forallb (fun a => match a with Eqv x y =>
             andb (greater_than_expr i x) (greater_than_expr i y) end).

Definition subst_clause i e cl : clause :=
  match cl with
  | PureClause pa pa' _ _ =>
      mkPureClause (subst_pures_delete i e pa) (subst_pures i e pa')
  | NegSpaceClause pa sa pa' =>
      NegSpaceClause (subst_pures_delete i e pa) (subst_spaces i e sa)
                     (subst_pures i e pa')
  | PosSpaceClause pa pa' sa' =>
      PosSpaceClause (subst_pures_delete i e pa) (subst_pures i e pa')
                     (subst_spaces i e sa')
  end.

(* fix this *)

Definition var_eqZ v v' := Ident.eq v v'.

Lemma eq_pos_var_eqZ v v' : true = eq_var v v' -> var_eqZ v v'.
Proof.
unfold eq_var, var_eqZ.
intros; id_compare v v'; auto; discriminate.
Qed.

(* general functions that should be moved elsewhere *)

Definition ocons {A : Type} (o : option A) l :=
  match o with Some a => a :: l | None => l end.

Fixpoint omapl {A B : Type} (f : A -> option B) (l : list A) : list B :=
  match l with
  | a :: l' => ocons (f a) (omapl f l')
  | nil => nil
  end.

Fixpoint merge {A: Type} (cmp : A -> A -> comparison) l1 l2 :=
  let fix merge_aux l2 :=
  match l1, l2 with
  | [], _ => l2
  | _, [] => l1
  | a1::l1', a2::l2' =>
      match cmp a1 a2 with
      | Eq => a1 :: merge cmp l1' l2'
      | Gt => a1 :: merge cmp l1' l2
      | _ => a2 :: merge_aux l2' end
  end
  in merge_aux l2.

Notation sortu_atms := (rsort_uniq pure_atom_cmp).
Notation insu_atm := (insert_uniq pure_atom_cmp).
Notation sortu_clauses := (rsort_uniq compare_clause).

Lemma compare_clause_eq_equivalence:
     RelationClasses.Equivalence (fun c1 c2 => Eq = compare_clause c1 c2).
Proof.
constructor; repeat intro.
rewrite comp_refl; auto.
do_comp clause_cspec x y; try congruence. subst; rewrite comp_refl; auto.
do_comp clause_cspec x y; try congruence.
Qed.

Lemma pure_clause_ext:
  forall gamma delta p Pp p' Pp',
     PureClause gamma delta p Pp = PureClause gamma delta p' Pp'.
Proof.
  intros. subst. auto.
Qed.

Lemma expr_eq_eq' : forall e1 e2, true = expr_eq e1 e2 -> e1=e2.
Proof.
unfold expr_eq; intros; do_comp expr_cspec e1 e2; subst; auto; congruence.
Qed.

Lemma mem_spec': forall s x, M.mem x s = false <-> ~M.In x s.
Proof.
 intros. rewrite <- M.mem_spec. destruct (M.mem x s); intuition discriminate.
Qed.

Lemma is_empty_spec': forall s, M.is_empty s = false <-> ~M.Empty s.
Proof.
 intros. rewrite <- M.is_empty_spec. destruct (M.is_empty s); intuition discriminate.
Qed.

Lemma empty_set_elems':
  forall s, M.Empty s <-> M.elements s = nil.
Proof.
intros.
generalize (M.elements_spec1 s); intro.
destruct (M.elements s); intuition.
intros ? ?.
rewrite <- H in H1.
inversion H1.
contradiction (H0 e).
rewrite <- H. left; auto.
inversion H0.
Qed.

Lemma Melements_spec1: forall (s: M.t) x, List.In x (M.elements s) <-> M.In x s.
Proof.
intros.
rewrite <- M.elements_spec1.
induction (M.elements s); intuition;
try solve [inversion H].
simpl in H1. destruct H1; subst.
constructor; auto.
constructor 2; auto.
inversion H1; clear H1; subst; simpl; auto.
Qed.

Require Import Finite_sets_facts.
Require Import VST.msl.Axioms.

Lemma Mcardinal_spec': forall s,   cardinal _ (Basics.flip M.In s) (M.cardinal s).
Proof.
 intros.
 rewrite (M.cardinal_spec s).
 generalize (M.elements_spec1 s); intro.
 replace (Basics.flip M.In s) with (Basics.flip (@List.In _) (M.elements s)).
Focus 2.
unfold Basics.flip; apply extensionality; intro x;
apply prop_ext; rewrite <- (H x).
clear; intuition.
apply SetoidList.In_InA; auto.
apply eq_equivalence.
rewrite SetoidList.InA_alt in H.
destruct H as [? [? ?]].
subst; auto.
(* End Focus 2 *)
 clear H.
 generalize (M.elements_spec2w s); intro.
 remember (M.elements s) as l.
 clear s Heql.
 induction H.
 replace (Basics.flip (@List.In M.elt) (@nil clause)) with (@Empty_set M.elt).
 constructor 1.
 apply Axioms.extensionality; intro; apply Axioms.prop_ext; intuition; inversion H.
 simpl.
 replace (Basics.flip (@List.In M.elt) (@cons clause x l))
   with (Add M.elt (Basics.flip (@List.In _) l) x).
 constructor 2; auto.
 contradict H.
 simpl.
 apply SetoidList.In_InA; auto.
 apply eq_equivalence.
 clear.
 apply Axioms.extensionality; intro; apply Axioms.prop_ext; intuition.
 unfold Basics.flip; simpl.
 unfold Add in H. destruct H; auto.
 apply Singleton_inv in H. auto.
 simpl in H; destruct H; [right | left].
 apply Singleton_intro. auto.
 apply H.
Qed.

Lemma remove_decreases:
  forall giv unselected,
  M.In giv unselected ->
  M.cardinal  (M.remove giv unselected)  < M.cardinal  unselected.
Proof.
 intros.
 generalize (Mcardinal_spec' (M.remove giv unselected)); intro.
 generalize (Mcardinal_spec' unselected); intro.
 generalize (card_soustr_1 _ _ _ H1 _ H); intro.
 rewrite (cardinal_is_functional _ _ _ H0 _ _ H2).
 assert (M.cardinal unselected > 0).
 generalize (Mcardinal_spec' unselected); intro.
 inversion H3; clear H3; subst.
 assert (Empty_set M.elt giv). rewrite H5. unfold Basics.flip. auto.
 inversion H3.
 omega.
 omega.
 clear - H.
 apply Axioms.extensionality;  intro x.
 unfold Basics.flip at 1.
 apply Axioms.prop_ext; intuition.
rewrite M.remove_spec in H0.
destruct H0.
split.
unfold In, Basics.flip. auto.
intro.
apply Singleton_inv in H2.
subst. contradiction H1; auto.
destruct H0.
rewrite M.remove_spec.
split; auto.
intro.
subst.
apply H1; apply Singleton_intro.
auto.
Qed.

(** a second comparison function on clauses that meets the requirements
   of model generation *)

Definition pure_atom2pn_atom (b : bool) (a : pure_atom) :=
  match a with
  | Eqv e1 e2 => if b then Equ e1 e2 else Nequ e1 e2
  end.

Definition pn_atom_cmp (a1 a2 : pn_atom) : comparison :=
  match a1, a2 with
  | Equ e1 e2, Equ e1' e2' => pure_atom_cmp (Eqv e1 e2) (Eqv e1' e2')
  | Nequ e1 e2, Equ e1' e2' =>
    if expr_eq e1 e1' then Gt else pure_atom_cmp (Eqv e1 e2) (Eqv e1' e2')
  | Equ e1 e2, Nequ e1' e2' =>
    if expr_eq e1 e1' then Lt else pure_atom_cmp (Eqv e1 e2) (Eqv e1' e2')
  | Nequ e1 e2, Nequ e1' e2' => pure_atom_cmp (Eqv e1 e2) (Eqv e1' e2')
  end.

Definition pure_clause2pn_list (c : clause) :=
  match c with
  | PureClause gamma delta _ _ =>
    rsort pn_atom_cmp
      (map (pure_atom2pn_atom false) gamma ++ map (pure_atom2pn_atom true) delta)
  | _ => nil
  end.

Definition compare_clause2 (cl1 cl2 : clause) :=
  match cl1, cl2 with
  | PureClause _ _ _ _, PureClause _ _ _ _ =>
    compare_list pn_atom_cmp (pure_clause2pn_list cl1) (pure_clause2pn_list cl2)
  | _, _ => compare_clause cl1 cl2
  end.

Lemma compare_clause_eq cl1 cl2 : Eq = compare_clause cl1 cl2 -> cl1 = cl2.
Proof. intros; do_comp clause_cspec cl1 cl2; auto; congruence. Qed.

Inductive ce_type := CexpL | CexpR | CexpEf.

(** Patch until Coq extraction of sharing constraints is fixed *)

Module DebuggingHooks.

(* To add a new debugging hook, do the following:
   -define a new function equal to the identity on the type of whatever
   value you want to report
   -define a corresponding ML function with the same name in extract/debugging.ml
   to do the actual reporting
*)
Definition print_new_pures_set (s: M.t) := s.

Definition print_wf_set (s: M.t) := s.

Definition print_unfold_set (s: M.t) := s.

Definition print_inferred_list (l: list clause) := l.

Definition print_pures_list (l: list clause) := l.

Definition print_eqs_list (l: list clause) := l.

Definition print_spatial_model (c: clause) (R: list (var * expr)) := c.

Definition print_spatial_model2 (c c': clause) (R: list (var * expr)) := c'.

Definition print_ce_clause (R: list (var * expr)) (cl : clause) (ct : ce_type)
  := (R, cl, ct).

End DebuggingHooks.

Export DebuggingHooks.

Hint Unfold print_new_pures_set print_wf_set print_inferred_list print_spatial_model
            print_pures_list print_eqs_list
  : DEBUG_UNFOLD.


(**********************************************************************************
 * KSSem.v                                                                         *
 * Formalizing Domains, Ultrametric Spaces and Semantics of Programming Languages *
 * Nick Benton, Lars Birkedal, Andrew Kennedy and Carsten Varming                 *
 * Jan 2012                                                                       *
 * Build with Coq 8.3pl2 plus SSREFLECT                                           *
 **********************************************************************************)

(* semantics of types for the kitchen sink language *)

Require Export MetricRec mpremet.
Require Export Fin KSTy KSTm KSTyping KSOp.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Open Scope C_scope.
Open Scope O_scope.
Open Scope M_scope.

Definition CValue := Tm.Value O.
Definition CExp := Tm.Exp O.

(*=MetBF *)
Definition BF : BiFunctor pcmECatType := findomBF
 ((BiComp (halveBF idBF) (constBF (upred_pcmType CValue)) BiArrow))
                                                         [compType of nat]. (*CLEAR*)
Lemma BF_ob A B : ob BF A B = findom_pcmType [compType of nat] (halve_pcmType A -=> upred_pcmType CValue).
by [].
Qed.

Lemma morph_contractive A B C D : contractive (MetricRec.morph BF A B C D).
unfold BF. apply findom_BF_contractive.
apply comp_BF_contractive ; last by apply constBF_contractive. by apply halve_morph_contractive.
Qed.

Module Type RecMet.

Variable W : pcmType.
Variable Unfold : W =-> findom_pcmType [compType of nat] (halve_pcmType W -=> upred_pcmType CValue).
Variable Fold : findom_pcmType [compType of nat] (halve_pcmType W -=> upred_pcmType CValue) =-> W.

Variable FU_id : Fold << Unfold =-= Id.
Variable UF_id : Unfold << Fold =-= Id.

End RecMet.

Module Solution : RecMet.

(*CLEARED*)
Definition W : pcmType := @DInf BF morph_contractive.
Definition Unfold := @Unfold BF morph_contractive :
  W =-> findom_pcmType [compType of nat] (halve_pcmType W -=> upred_pcmType CValue).
Definition Fold  := @Fold BF morph_contractive :
  findom_pcmType [compType of nat] (halve_pcmType W -=> upred_pcmType CValue) =-> W.
(*=End *)

Lemma FU_id : Fold << Unfold =-= Id.
apply (@FU_iso BF morph_contractive).
Qed.

Lemma UF_id : Unfold << Fold =-= Id.
apply (@UF_iso BF morph_contractive).
Qed.

End Solution.
Export Solution.

Lemma Fold_monic x y : Fold x <= Fold y -> x <= y.
move => X. have M:=fmonotonic Unfold X. have e:= (UF_id x). have e':=UF_id y.
apply (pcm_respect e e' M).
Qed.

Lemma Unfold_monic x y : Unfold x <= Unfold y -> x <= y.
move => X. have M:=fmonotonic Fold X. have e:= (FU_id x). have e':=FU_id y.
apply (pcm_respect e e' M).
Qed.

Lemma Unfold_antinonexp n (w w':W) : Unfold w = n = Unfold w' -> w = n = w'.
move => X. have Y:=fnonexpansive Fold X. clear X.
apply (Mrel_trans (Msym (proj2 (Mrefl _ _) (FU_id w) n))).
refine (Mrel_trans _ (proj2 (Mrefl _ _) (FU_id w') n)). by apply Y.
Qed.

Lemma Fold_antinonexp n w w' : Fold w = n = Fold w' -> w = n = w'.
move => X. have Y:=fnonexpansive Unfold X. clear X.
apply (Mrel_trans (Msym (proj2 (Mrefl _ _) (UF_id w) n))).
refine (Mrel_trans _ (proj2 (Mrefl _ _) (UF_id w') n)). by apply Y.
Qed.

Lemma less_nil j (P:j < 0) : False.
move: P ; by rewrite ltn0.
Qed.

(*=TV *)
Definition TV := halve_pcmType W -=> upred_pcmType CValue.
Fixpoint TVal (n:nat) : cmetricType :=
match n with | O => One | S n => TVal n * TV end.

Fixpoint pick n (j : Fin n) : cmetricCatType (TVal n) TV :=
  match j with
  | FinZ _   => pi2
  | FinS _ v => pick v << pi1
  end.
(*=End *)

Lemma upred_unit_down : downclosed (fun kt => match snd kt : Tm.Value O with | Tm.UNIT => True | _ => False end).
move => k m v l. simpl. by case: v.
Qed.

Definition upred_unit : upred_pcmType CValue := Eval hnf in mk_upred upred_unit_down.

Lemma upred_prod_down (X : upred_metricType CValue * upred_metricType CValue) :
   downclosed (fun kt => let v := snd kt in
                             match v with
                             | Tm.PAIR v0 v1 => (fst X) (fst kt, v0) /\ (snd X) (fst kt, v1)
                             | _ => False
                             end).
move => k k'. case => v L; try by []. simpl.
move => P [A B].
split ; first by apply (upred_downclosed (ltnW P) A). by apply (upred_downclosed (ltnW P) B).
Qed.

Definition upred_prod (p : (upred_cmetricType CValue) * (upred_cmetricType CValue) )
  : upred_cmetricType CValue := Eval hnf in mk_upred (@upred_prod_down p).

Lemma upred_product_ne : nonexpansive upred_prod.
move => n.
case => x0 x1. case => y0 y1. case => e0 e1.
move => k v L. case v ; try by [].
move => v0 v1.
specialize (e0 k).
specialize (e1 k). simpl in e0,e1. simpl. rewrite e0. by rewrite e1. by [].
Qed.

Definition upred_productN : metricCatType (upred_pcmType CValue * upred_pcmType CValue) (upred_pcmType CValue) := Eval hnf in mk_fmet upred_product_ne.

Lemma upred_product_mono : monotonic upred_productN.
case => x0 x1. case => y0 y1. case => e0 e1. case => k. case; try by [].
move => v0 v1. specialize (e0 (k,v0)).
specialize (e1 (k,v1)). move => [A B]. split ; by [apply e0 | apply e1].
Qed.

Definition upred_product : upred_pcmType CValue * upred_pcmType CValue =-> upred_pcmType CValue :=
  Eval hnf in mk_fpcm upred_product_mono.

Add Parametric Morphism : @upred_product
with signature (@tset_eq ((upred_pcmType CValue * upred_pcmType CValue))) ==> (@tset_eq (upred_pcmType CValue))
as upred_product_eq_compat.
case => x y. case => x' y'. case => e0 e1. case => k v. simpl. case: v; try done.
move => v0 v1. simpl in e1,e0. specialize (e0 (k,v0)).
specialize (e1 (k,v1)). rewrite e0. by rewrite e1.
Qed.

Lemma upred_sumP (X:upred_cmetricType CValue * upred_cmetricType CValue) :
  downclosed (fun kt => let v := snd kt:CValue in
                             match v with
                               | Tm.INL p0 => (fst X) (fst kt, p0)
                               | Tm.INR p0 => (snd X) (fst kt, p0)
                               | _ => False end).
move => k k'. case => v L; simpl; try by []; move => A; apply (upred_downclosed (ltnW L) A).
Qed.

Definition upred_sumt (p:upred_cmetricType CValue * upred_cmetricType CValue) : upred_cmetricType CValue :=
  Eval hnf in mk_upred (@upred_sumP p).

Lemma upred_sum_ne : nonexpansive upred_sumt.
move => n.
case => x0 x1. case => y0 y1. case => e0 e1.
move => k. case => v; simpl; try by [].
- move => L; by rewrite (e0 k v L).
- move => L. by rewrite (e1 k v L).
Qed.

Definition upred_sumN : metricCatType (upred_pcmType CValue * upred_pcmType CValue) (upred_pcmType CValue) := Eval hnf in mk_fmet upred_sum_ne.

Lemma upred_sum_mono : monotonic upred_sumN.
case => x0 x1. case => y0 y1. case => e0 e1. move => [k v]. destruct v; simpl; try by [].
- move => H. by apply (e0 (k,v)).
- move => H. by apply (e1 (k,v)).
Qed.

Definition upred_sum : (upred_pcmType CValue * upred_pcmType CValue =-> upred_pcmType CValue) :=
  Eval hnf in mk_fpcm upred_sum_mono.

Add Parametric Morphism : @upred_sum
with signature (@tset_eq ((upred_pcmType CValue * upred_pcmType CValue))) ==> (@tset_eq (upred_pcmType CValue))
as upred_sum_eq_compat.
case => x y. case => x' y'. case => e0 e1. move => [k v]. destruct v; simpl; try by [].
Qed.

(*=upred_mu_down *)
Lemma upred_mu_down n
   (R: TVal n.+1 =-> halve_pcmType W -=> upred_pcmType CValue) (s:TVal n)
   (P:(halve_pcmType W =-> upred_pcmType CValue) * halve_pcmType W) :
downclosed (fun kt => let: v' := snd kt in
  match fst kt, v' with
 | O, Tm.FOLD v => True
 | S k, Tm.FOLD v => (R ((s,fst P)) (snd P)) (k,v)
 | _, _ => False
  end).
(*=End *)
case ; first by []. move => m k v. destruct v; simpl; try done.
move => L. destruct k; first by [].
refine (upred_downclosed _). by apply (ssrnat.ltn_trans (ltnSn k) L).
Qed.

(*=upred_mut *)
Definition upred_mut n R s w : upred_pcmType CValue :=
  Eval hnf in mk_upred (@upred_mu_down n R s w).
(*=End *)

Definition ne_mono (M:cmetricType) (P Q:pcmType) (f:M * P -> Q) :=
   (nonexpansive f) /\ forall m, monotonic (fun x => f (m,x)).

Lemma ne_mono_ne2 (M:cmetricType) (P Q:pcmType) (f:M * P -> Q) (X:ne_mono f) (m:M) : nonexpansive (fun x : P => f (m, x)).
move => n x x' e. simpl. by apply (proj1 X).
Qed.

Definition ne_monoN M P Q f (X:@ne_mono M P Q f) (m:M) : P =-> Q := Eval hnf in mk_fpcmX (ne_mono_ne2 X m) ((proj2 X) m).

Lemma mk_nemon_ne M P Q f (X:@ne_mono M P Q f) : nonexpansive (ne_monoN X).
move => n m m' e x. simpl. by apply ((proj1 X)).
Qed.

Definition mk_nemon M P Q f (X:@ne_mono M P Q f) : M =-> (P -=> Q) := Eval hnf in mk_fmet (mk_nemon_ne X).

(*upred_muS *)
Lemma upred_mu_ne n R s : ne_mono (@upred_mut n R s).
(*=End *)
Proof.
split.
- move => m. case => f w. case => f' w'. case. case:m ; first by [].
  move => m e e' k. simpl. case => v; try done.
  simpl. have d:(R (s, f)) = m.+1 = (R (s, f')) by apply fnonexpansive.
  specialize (d w). have dd:=fnonexpansive ( (R (s, f'))) e'.
  case: k ; first by []. move => k L. apply ((Mrel_trans d dd) k v). by apply (ssrnat.ltn_trans (ltnSn k) L).
- move => f. simpl in f. move => w w' L. case => k. case; simpl; try done.
  move => v. case: k; first by []. move => k. simpl in w,w'.
  have e:(R (s, f)) w <= (R (s, f)) w' by apply: fmonotonic.
  by apply (e _).
Qed.

Definition upred_mup n (R:TVal n.+1 =-> halve_pcmType W -=> upred_pcmType CValue) (s:TVal n) :
   cmetricCatType (halve_pcmType W -=> upred_pcmType CValue) (halve_pcmType W -=> (upred_pcmType CValue)) :=
   Eval hnf in mk_nemon (upred_mu_ne R s).

Lemma upred_muC n R (s:TVal n) : contractive (upred_mup R s).
move => m. move => f g e.
move => w. simpl. move => k. case ; try done. case: k ; first by []. move => k v L.
have d:(R (s, f)) = m = (R (s, g)) by apply fnonexpansive.
apply: d. by apply L.
Qed.

Definition upred_muc n (R: TVal n.+1 =-> halve_pcmType W -=> upred_pcmType CValue) (s:TVal n) :
  morphc_pcmType (halve_pcmType W -=> upred_pcmType CValue) (halve_pcmType W -=> upred_pcmType CValue) :=
exist _ (upred_mup R s) (upred_muC R s).

Lemma upred_mun n R : nonexpansive (@upred_muc n R).
move => m s s' e f w. case: m e ; first by []. move => m e k. simpl.
case ; try done. move => v. case: k ; first by []. move => k L.
simpl. have d:(R (s, f)) = m.+1 = (R (s', f)) by apply fnonexpansive.
apply (d w k _). by apply (ssrnat.ltn_trans (ltnSn k) L).
Qed.

(*=upred_mu *)
Definition upred_mu n (R: TVal n.+1 =-> halve_pcmType W -=> upred_pcmType CValue) :
   TVal n =-> morphc_pcmType TV TV :=
    Eval hnf in mk_fmet (@upred_mun n R).
(*=End *)

Definition bool_option (b:bool) : b + not b.
case: b. by left.
by right.
Defined.

(*=heap_world *)
Definition heap_world k (h:Heap) (w:W) :=
    forall j, j < k -> dom h =i dom (Unfold w) /\
    forall l,  match Unfold w l, h l with Some w',Some v' => w' w (j,v')
                     | _,_ => True end.
(*=End *)
(*=IExp *)
Definition IExp (f:TV) (k:nat) (e:Tm.Exp 0) (w:W) :=
   forall j, (j <= k) ->
   forall (h h':Heap) v (D:EV j e h v h'), heap_world k h w ->
    exists w':W, w <= w' /\ heap_world (k - j) h' w' /\ (f w') (k-j,v).
(*=End *)
Lemma IExp_respect (f f':TV) (k:nat) (e:Tm.Exp 0) (w:W) : f =-= f' -> IExp f k e w =-= IExp f' k e w.
move => E. unfold IExp. split.
- move => X j L h h' v ev hv. specialize (X j L h h' v ev hv). case: X => w' [LL [HV Y]].
  exists w'. split ; first by []. split ; first by []. specialize (E w'). simpl in E.
  specialize (E (k - j, v)). rewrite <- E. by apply Y.
- move => X j L h h' v ev hv. specialize (X j L h h' v ev hv). case: X => w' [LL [HV Y]].
  exists w'. split ; first by []. split ; first by []. specialize (E w' (k-j,v)). simpl in E.
  rewrite E. by apply Y.
Qed.

Lemma upred_all_down n (R:TVal n.+1 =-> halve_pcmType W -=> upred_pcmType CValue)
  (s:TVal n * halve_pcmType W) : downclosed (fun kt => let: (k,v) := kt in
   match v with
    | Tm.TLAM v => forall (r:TV) (w':W) j, (j <= k) -> snd s <= w' ->
             (IExp (R (fst s,r)) j v w')
    | _ => False
   end).
move => m k v L. simpl. case: v; try done. case: s => e w.
move => E X r w' j L'. simpl. move => LL. simpl in X. apply X. by apply (leqW (leq_ltn_trans L' L)). by apply LL.
Qed.

Definition upred_allt n R s : upred_pcmType CValue := mk_upred (@upred_all_down n R s).

Lemma world_extend n (w0 w1 v0 : W) : w0 = n = v0 -> w0 <= w1 -> exists v1:W, w1 = n = v1 /\ v0 <= v1.
case: n w0 w1 v0. move => w0 w1 v0 _ L. by exists v0.
move => n w0 w1 v0 e l.
exists (Fold (create_findomF (Unfold w1) (fun x => match Unfold v0 x with | None => Unfold w1 x | Some v => Some v end))).
have e':=fnonexpansive ( Unfold) e. clear e. split.
- have A:=proj1 e'. have B:=proj2 e'. clear e'.
apply Unfold_antinonexp.
refine (Mrel_trans _ (proj2 (Mrefl _ _) (tset_sym (UF_id _)) _)).
split.
  + move => i. rewrite dom_create_findomF. rewrite in_filter.
    specialize (A i). case: (Unfold v0 i). simpl. by rewrite andbT.
    rewrite findom_indom. by case: (Unfold w1 i).
  + move => i I I'. specialize (B i). rewrite create_findomF_simpl. do 2 rewrite findom_indom in B.
    move: B. case_eq (Unfold v0 i).
    * move => s U. rewrite U. simpl. move => X.
      specialize (A i). do 2 rewrite findom_indom in A. rewrite U in A. rewrite A in X.
      specialize (X is_true_true is_true_true). clear A. rewrite I. rewrite <- X.
      have ll:=fmonotonic Unfold l. clear l. specialize (ll i).
      case: (Unfold w0 i) X ll ; last by []. move => w0i e X. specialize (X _ (refl_equal _)). case: X => m [e0 e1].
      rewrite e0. apply Msym. by apply: (proj2 (Mrefl _ _) e1 _).
    * move => e _. specialize (A i). do 2 rewrite findom_indom in A. rewrite e in A. simpl in A.
      rewrite findom_indom. by case: (Unfold w1 i).
- apply Unfold_monic.
  refine (@pcm_respect _ _ _ _ _ (tset_refl _) (tset_sym (UF_id _)) _).
  move => i f E. have ll:=fmonotonic Unfold l. specialize (ll i). clear l.
  have A:=proj2 e' i. do 2 rewrite findom_indom in A. rewrite E in A.
  rewrite create_findomF_simpl. rewrite E. exists f. split ; last by [].
  have e0:=proj1 e' i. do 2 rewrite -> findom_indom in e0. rewrite E in e0.
  rewrite e0 in A. specialize (A is_true_true is_true_true). case: (Unfold w0 i) A ll ; last by [].
  move => w0i A ll. specialize (ll w0i (refl_equal _)). case: ll => w1i [P Q].
  rewrite findom_indom. by rewrite P.
Qed.

Lemma heap_world0 w h : heap_world 0 h w.
by [].
Qed.

Hint Resolve heap_world0.

Lemma heap_world_eq m h w w' j : (j <= m) -> w = m = w' -> heap_world j h w -> heap_world j h w'.
rewrite natO_le. case:m h w w' j ; first by move => h w w' j L E _ ; rewrite leqn0 in L ; rewrite (eqP L).
move => m h w w'. case ; first by [].
move => j L E. move => X k l. specialize (X k l). case: X => D X.
have E':=fnonexpansive Unfold E. case: E' => D' E'.
split ; first by move => i ; rewrite -> D ; apply D'.
move => i. specialize (X i). case_eq (Unfold w' i) ; last by [].
move => wi' e'. specialize (D' i). do 2 rewrite findom_indom in D'. rewrite e' in D'.
specialize (E' i). do 2 rewrite findom_indom in E'. rewrite e' in E'. rewrite D' in E'.
specialize (E' is_true_true is_true_true). clear D'. case: (Unfold w i) X E' ; last by [].
move => wi. case: (h i) ; last by []. move => v A X. specialize (X w'). simpl in X.
have Y:=fnonexpansive wi. specialize (Y m.+2 w w' E). rewrite <- (Mmono Y) in X.
specialize (X k v). specialize (X (leq_trans l L)). by rewrite <- X.
Qed.

Lemma upred_allN n R : ne_mono (@upred_allt n R).
split.
- move => m.
  case => x0 x1. case => y0 y1. case:m ; first by [].
  move => m. case => e e'. move => k. case ; try done.
  move => ee Lk. split.
  + move => A r w j Lj. specialize (A r). move => Lw i Li h h' v ev hv.
    simpl in e'. destruct (world_extend (Msym e') Lw) as [w' [X L']].
    specialize (A w' j Lj L' i Li). specialize (A h h' v ev).
    have hv':= heap_world_eq (leq_trans Lj Lk) X hv.
    specialize (A hv'). destruct A as [w0 [lw0 [hv0 A]]].
    destruct (world_extend (Msym X) lw0) as [w1 [E1 L1]]. exists w1. split ; first by [].
    split ; first by apply: (heap_world_eq (leq_trans (leq_subr _ _) (leq_trans Lj Lk)) E1 hv0).
    have EE:(R ((x0, r))) = m.+1 = R ((y0, r)) by apply fnonexpansive.
      specialize (EE w0). have e0:R ((y0, r)) w0 = m.+1 = R ((y0, r)) w1. apply: fnonexpansive. by apply E1.
    have e1:=Mrel_trans EE e0. clear EE e0.
    specialize (e1 (j-i) v).
    specialize (e1 (leq_trans (leq_subr _ _) (leq_trans Lj Lk))). by rewrite <- e1.
  + move => A r w j Lj. specialize (A r). move => Lw i Li h h' v ev hv.
    simpl in e'. destruct (world_extend e' Lw) as [w' [X L']].
    specialize (A w' j Lj L' i Li). specialize (A h h' v ev).
    have hv':= heap_world_eq (leq_trans Lj Lk) X hv.
    specialize (A hv'). destruct A as [w0 [lw0 [hv0 A]]].
    destruct (world_extend (Msym X) lw0) as [w1 [E1 L1]]. exists w1. split ; first by [].
    split ; first by apply: (heap_world_eq (leq_trans (leq_subr _ _) (leq_trans Lj Lk)) E1 hv0).
    have EE:(R ((x0, r))) = m.+1 = R ((y0, r)) by apply fnonexpansive. specialize (EE w1).
    have e0:R (y0, r) w1 = m.+1 = R (y0, r) w0 by apply: fnonexpansive ; apply (Msym E1).
    have e1:=Mrel_trans EE e0. clear EE e0.
    specialize (e1 (j-i) v (leq_trans (leq_subr _ _) (leq_trans Lj Lk))). by rewrite e1.
- move => s w w' L. case => k v. simpl. case: v ; try done.
  move => v X f we' j Lj Lw'. specialize (X f we' j Lj (Ole_trans L Lw')).
  move => i Li h h' v' ev hv. specialize (X i Li h h' v' ev hv).
  destruct X as [we [Lw [hv' X]]]. exists we. split ; first by []. split ; first by []. by apply X.
Qed.

Definition upred_all n (R : TVal n.+1 =-> halve_pcmType W -=> upred_pcmType CValue) :
      (TVal n) =-> (halve_pcmType W -=> upred_pcmType CValue) :=
  Eval hnf in mk_nemon (upred_allN R).

(*=upred_ref_down *)
Lemma upred_ref_down n
 (R : TVal n =-> halve_pcmType W -=> upred_pcmType CValue)
 (s:TVal n) (w: halve_pcmType W) :
(*=End *)
   downclosed (fun kt => let: (k,v) := kt in
    match k,(v:Tm.Value O) with
     | O,Tm.LOC l => True
     | S k,Tm.LOC l => Unfold w l = k.+1 = Some (R s)
     | _,_ => False
    end).
move => m k v L. case: m L ; first by []. move => m L. case v ; try done.
move => l P. case: k L ; first by []. move => k L. by apply (Mrel_mono (ltnW L)).
Qed.

(*=upred_reft *)
Definition upred_reft n R w : upred_pcmType CValue :=
  mk_upred (@upred_ref_down n R (fst w) (snd w)).
(*=End *)

Lemma upred_refN n R : ne_mono (@upred_reft n R).
split.
- move => m.
  case => s w. case => s' w'. case: m ; first by []. move => m. case => e e'. move => k v.
  case: k ; first by []. move => k.
  case: v; try done. move => l. have X:=fnonexpansive Unfold e'. clear e'.
  simpl in e. simpl in X. case: m e X ; first by []. move => m e X L. simpl.
  have e0:=proj2 X l. have e1:=fnonexpansive R e. clear e. rewrite <- (proj1 X) in e0.
  rewrite findom_indom in e0. move: (proj1 X l). do 2 rewrite findom_indom.
  case: (Unfold w l) e0 ; last by simpl ; case: (Unfold w' l).
  move => wl. simpl. move => Y. specialize (Y is_true_true is_true_true).
  unfold Mrel. simpl. clear X. case: (Unfold w' l) Y ; last by [].
  move => wl' Y _. unfold Mrel in Y. simpl in Y. rewrite -> (@Mrel_mono _ _ _ k.+1 m.+1 L Y).
  by rewrite -> (@Mrel_mono _ _ _ k.+1 m.+1 L (Mmono e1)).
- move => s. move => w w' Lw. simpl. case => k v. simpl. case: k ; first by []. case: v ; try done.
  move => l k. have L:=fmonotonic Unfold Lw. clear Lw. specialize (L l).
  case: (Unfold w l) L ; last by []. move => wl L. specialize (L wl (refl_equal _)).
  case: L => wl' [e e']. rewrite e. unfold Mrel ; simpl. move => A. rewrite <- A. apply Msym.
  by apply (proj2 (Mrefl _ _) e' k.+1).
Qed.

(*=upred_ref *)
Definition upred_ref n
     (R : TVal n =-> halve_pcmType W -=> upred_pcmType CValue) :
     (TVal n) =-> (halve_pcmType W -=> upred_pcmType CValue) :=
     Eval hnf in mk_nemon (upred_refN R).
(*=End *)

(*=upred_int_down *)
Lemma upred_int_down :
  downclosed (fun kt => match snd kt : Tm.Value O with
                       | Tm.INT i => True | _ => False end). (*CLEAR*)
move => k m v l. simpl. by case: v.
Qed.

(*CLEARED*)
Definition upred_int : upred_pcmType CValue := Eval hnf in mk_upred upred_int_down.
(*=End *)

(*=upred_arrow_down *)
Lemma upred_arrow_down n
  (R0 R1: TVal n =-> halve_pcmType W -=> upred_pcmType CValue)
  (s:TVal n) (w: halve_pcmType W) : downclosed (fun kt => let: (k,v) := kt in
   match v with
   | Tm.LAM e => forall w' j (va:Tm.Value O), w <= w' -> (j <= k) ->
              (R0 s w') (j,va) -> IExp (R1 s) j (Tm.subExp (cons va (@Tm.idSub _)) e) w'
   | _ => False end).
(*=End *)
move => m k. simpl. case ; try done. move => e L X.
move => w' j va Lw Lj. by apply (X w' j va Lw (ssrnat.leq_trans Lj (leqW L))).
Qed.

(*=upred_arrowt *)
Definition upred_arrowt n R0 R1 s w : upred_pcmType CValue :=
  Eval hnf in mk_upred (@upred_arrow_down n R0 R1 s w).
(*=End *)

Lemma IExp_nonexp m (f f':TV) (k:nat) (e:Tm.Exp 0) (w w':halve_cmetricType W) : f = m = f' -> w = m = w' -> k < m -> IExp f k e w =-= IExp f' k e w'.
move => E Ew l. unfold IExp. case: m E Ew l ; first by []. move => m E Ew l. split.
- move => X j L h h' v ev hv. specialize (X j L h h' v ev).
  have hv':=heap_world_eq _ (Msym Ew) hv. specialize (X (hv' l)). destruct X as [w0 [LL [HV Y]]].
  case: (world_extend Ew LL) => w0' [Ew' LL']. exists w0'. split ; first by [].
  split ; first by apply: (heap_world_eq (ssrnat.leq_trans (leq_subr _ _) _) Ew').
  specialize (E w0). simpl in E.
  have E':f w0 = m.+1 = f' w0' by apply Mrel_trans with (y:=f' w0) ; [by apply E | apply: fnonexpansive].
  specialize (E' (k - j) (v)).
  specialize (E' (leq_ltn_trans (leq_subr j k) l)). rewrite <- E'. by apply Y.
- move => X j L h h' v ev hv. specialize (X j L h h' v ev).
  have hv':=heap_world_eq _ Ew hv. specialize (X (hv' l)). destruct X as [w0 [LL [HV Y]]].
  case: (world_extend (Msym Ew) LL) => w0' [Ew' LL']. exists w0'. split ; first by [].
  split ; first by apply: (heap_world_eq (ssrnat.leq_trans (leq_subr _ _) _) Ew').
  have E':f w0' = m.+1 = f' w0 by apply Mrel_trans with (y:=f' w0') ; [by apply E | apply: fnonexpansive ; apply (Msym Ew')].
  specialize (E' (k - j) v).
  specialize (E' (leq_ltn_trans (leq_subr j k) l)). rewrite -> E'. by apply Y.
Qed.

Lemma upred_arrowN n R : ne_mono (fun a => @upred_arrowt n (fst R) (snd R) (fst a) (snd a)).
split.
- case: R => R0 R1 m x y E. case: m E ; first by []. move => m E. move => k v. simpl. case: v ; try done.
  move => e.
  move => Lk. split ; move => B w' j va lw Lj T I.
  + have E':=proj2 E. simpl in E'. case: (world_extend (Msym E') lw) => x' [E0 L0]. specialize (B x' j va L0 Lj).
    apply (proj1 (IExp_nonexp (Tm.subExp (cons va _) e) (Mrel_refl m.+1 (R1 (fst y))) (Msym E0) (ssrnat.leq_trans Lj Lk))).
    have e2:(R1 (fst x)) = m.+1 = (R1 (fst y)) by apply: (fnonexpansive R1) ; apply (proj1 E).
    apply (IExp_nonexp _ e2 (Mrel_refl _ x')). by apply (leq_ltn_trans Lj Lk). apply B.
    have E1:R0 (fst x) = m.+1 = R0 (fst y) by apply fnonexpansive ; apply (proj1 E).
    specialize (E1 x'). have E1':=fnonexpansive ((R0 (fst y))). specialize (E1' m.+1 x' w'  (Msym E0)).
    have E2:=Mrel_trans E1 E1'. clear E1 E1'. specialize (E2 j va (leq_ltn_trans Lj Lk)). by rewrite E2.
  + have E':=proj2 E. simpl in E'. case: (world_extend E' lw) => x' [E0 L0]. specialize (B x' j va L0 Lj).
    apply (proj2 (IExp_nonexp (Tm.subExp (cons va _) e) (Mrel_refl m.+1 (R1 (fst x))) (E0) (ssrnat.leq_trans Lj Lk))).
    have e2:(R1 (fst x)) = m.+1 = (R1 (fst y)) by apply: (fnonexpansive R1) ; apply (proj1 E).
    apply (IExp_nonexp _ e2 (Mrel_refl _ x')). by apply (leq_ltn_trans Lj Lk). apply B.
    have E1:R0 (fst y) = m.+1 = R0 (fst x) by apply fnonexpansive ; apply (Msym E). specialize (E1 x').
    have E1':R0 (fst x) x' = m.+1 = R0 (fst x) w' by apply (fnonexpansive (R0 (fst x))) ; apply (Msym E0).
    have E2:=Mrel_trans E1 E1'. clear E1 E1'. specialize (E2 j va (leq_ltn_trans Lj Lk)). by rewrite E2.
- case: R => R0 R1. move => s w w' Lw. case => k v. simpl. case: v; try done. move => e0 X w1 j va Lw1 Lj.
  by apply (X w1 j va (Ole_trans Lw Lw1) Lj).
Qed.

(*=upred_arrow *)
Definition upred_arrow n
   (R0 R1:TVal n =-> halve_pcmType W -=> upred_pcmType CValue) :
   cmetricCatType (TVal n) (halve_pcmType W -=> upred_pcmType CValue) :=
   Eval hnf in mk_nemon (upred_arrowN (R0,R1)).
(*=End *)

Add Parametric Morphism n : (@upred_arrow n)
with signature (@tset_eq ((metricCatType (TVal n) TV))) ==>
               (@tset_eq ((metricCatType (TVal n) TV))) ==>
               (@tset_eq ((metricCatType (TVal n) TV)))
as upred_arrow_eq_compat.
move => x x' e y y' e'. move => s w. case => k. simpl. case ; try done.
move => ee. split ; move => X w' j va Lw Lj ; specialize (X w' j va Lw Lj).
- move => Y. apply: (proj1 (IExp_respect _ _ _ _) (X _)) ; first by move => w0 ; apply: e'.
  specialize (e s w' (j,va)). by rewrite e.
- move => Y. apply: (proj2 (IExp_respect _ _ _ _) (X _)) ; first by move => w0 ; apply: e'.
  specialize (e s w' (j,va)). by rewrite <- e.
Qed.

Fixpoint Prod (T:Type) n : Type :=
match n with
| O => unit
| S n => (Prod T n * T)%type
end.

Lemma Prod_constP n T (p:(upred_pcmType (Prod T n) * upred_pcmType T)) :
  downclosed (fun kt => fst p (fst kt,fst (snd kt)) /\ snd p (fst kt,snd (snd kt))).
case:p => A B.
move => m k. simpl. case => te t l. simpl. move => [C D].
by split ; [apply (upred_downclosed (ltnW l) C) | apply (upred_downclosed (ltnW l) D)].
Qed.

Definition Prod_const n T (p:(upred_pcmType (Prod T n) * upred_pcmType T)) : upred_pcmType (Prod T n.+1) :=
  Eval hnf in mk_upred (@Prod_constP n T p).

Lemma Prod_consN n T : nonexpansive (@Prod_const n T).
move => m. case => x y. case => x' y'. case: m ; first by [].
move => m. case => e0 e1. move => k. simpl. case => te t l. simpl.
specialize (e0 k te l). specialize (e1 k t l). rewrite e0. by rewrite e1.
Qed.

Lemma Prod_consM n T : monotonic (mk_fmet (@Prod_consN n T)).
case => x t. case => x' t'. case => e0 e1. case => k v. simpl. simpl in v. case: v => vt v.
specialize (e0 (k,vt)). specialize (e1 (k,v)). by move => [A B] ; split ; [apply e0 | apply e1].
Qed.

Definition Prod_cons n T : upred_pcmType (Prod T n) * upred_pcmType T =-> upred_pcmType (Prod T n.+1) :=
  Eval hnf in mk_fpcm (@Prod_consM n T).

Implicit Arguments Prod_cons [n T].

(*=IVal *)

Import Ty.
Fixpoint IVal n (t:Ty.Ty n) : cmetricCatType (TVal n) TV :=
match t with
| TVar J => pick J
| Int => mconst _ (pconst _ upred_int)
| Unit => mconst _ (pconst _ upred_unit)
| Mu t => FIXP << upred_mu (IVal t)
| t ** t' => (exp_fun Pcomp upred_product : metricCatType _ _) << pprod_fun_ne
                                                      << <|IVal t,IVal t'|>
| Sum t t' => (exp_fun Pcomp upred_sum : metricCatType _ _) << Pprod_fun
                                                      << <|IVal t, IVal t'|>
| All t => upred_all (IVal t)
| t --> t' => upred_arrow (IVal t) (IVal t')
| Ref t => upred_ref (IVal t)
end.
(*=End *)

(*=IEnv *)
Fixpoint IEnv E n :
  TEnv E n -> TVal E =-> halve_pcmType W -=> upred_pcmType (Prod CValue n)  :=
  match n with
  | 0 => fun env => mconst _ (pconst _ (upred_empty unit))
  | n.+1 => fun env => (pcompM _ _ _ << ppair _ Prod_cons << Pprod_fun) <<
                                          <| IEnv (tl env),  (IVal (hd env)) |>
end.
(*=End *)

(*=IStore *)
Lemma IStore_down E (Se:StoreType E) (s:TVal E) :
  downclosed (fun kt => forall l t, Se l = t ->
                        (IVal (Ref t) s (snd kt)) (fst kt, Tm.LOC l)). (*CLEAR*)
move => m k w Lk. move => X.
move => l t E'. specialize (X l t E').
by apply (upred_downclosed (ltnW Lk) X).
Qed.
(*CLEARED*)
Definition IStore E (Se:StoreType E) (s:TVal E) : upred_pcmType W :=
    Eval hnf in mk_upred (@IStore_down E Se s).
(*=End *)

Definition emptyMap T : FMap 0 T. intros var. Require Import Program. dependent destruction var. Defined.
Fixpoint Prod_subst T n : Prod T n -> FMap n T :=
match n with
| O => fun _ => emptyMap T
| S n => fun P => cons (snd P) (Prod_subst (fst P))
end.

(*=VRel *)
Definition VRel E n (env:TEnv E n) (Se:StoreType E) (v:Tm.Value n) (t:Ty.Ty E) :=
  forall k (s:TVal E) g w,
  (IEnv env s w) (k,g) -> (IStore Se s) (k,w) ->
  (IVal t s w) (k, Tm.subVal (Prod_subst g) v).

Definition ERel E n (env:TEnv E n) (Se:StoreType E) (e:Tm.Exp n) (t:Ty.Ty E) :=
  forall k (s:TVal E) g w,
     (IEnv env s w) (k,g) -> (IStore Se s) (k,w) ->
     IExp (IVal t s) k (Tm.subExp (Prod_subst g) e) w.
(*=End *)

Lemma FT_var E n m (env:TEnv E n) s w k g : (IEnv env s w) (k, g) -> IVal (env m) s w (k,nth m (Prod_subst g)).
Proof.
dependent induction m.
- simpl. by case => A B ; apply B.
- simpl. case => A B. rewrite tlCons. by apply (IHm (tl env)).
Qed.

Lemma IVal_mapTy P (ops:Map.Ops P) n (t:Ty n) s m s' (a:FMap n (P m)) :
     (forall n (t:P n) s s', IVal (Map.vl ops t) s' =-= IVal (Map.vl ops (Map.wk ops t)) (s', s)) ->
     (forall i, pick i s =-= (@IVal m (Map.vl ops (a i)) s')) ->
                          IVal t s =-= IVal (Map.mapTy ops a t) s'.
move => Y. elim: n / t s m s' a.
- simpl. move => e i s m s' a X. by apply X.
- by [].
- by [].
- move => E t IH t' IH' s m s' a X. simpl. specialize (IH s m s' a X). specialize (IH' s m s' a X).
  move => aa. simpl. specialize (IH aa). specialize (IH' aa). simpl in IH. simpl in IH'.
  by apply (frespect upred_product (pair_eq_compat IH IH')).
- move => E t IH t' IH' s m s' a X. simpl. specialize (IH s m s' a X). specialize (IH' s m s' a X).
  move => aa. simpl. specialize (IH aa). specialize (IH' aa). simpl in IH. simpl in IH'.
  by apply (frespect upred_sum (pair_eq_compat IH IH')).
- move => E t IH s m s' a X. simpl. apply: frespect. move => ss. simpl. move => bb. simpl. case => k v. simpl.
  case: k ; first by []. case: v ; try done. move => v n.
  specialize (IH (s,ss) m.+1 (s',ss)). specialize (IH (Map.lift ops a)).
  apply IH. move => i. clear IH. move: Y X. clear. move => Y X. rewrite Map.liftAsCons.
  dependent destruction i ; simpl ; first by rewrite Map.vlvr. unfold Map.shift. rewrite -> (X i).
  by apply Y.
- move => E t IH s m s' a X. simpl. move => w. simpl. case => k v. case: v ; try done.
  move => e. simpl. split.
  + move => A r w' j Lj Lw. specialize (IH (s,r) m.+1 (s',r) (Map.lift ops a)).
    specialize (A r w' j Lj Lw). apply: (proj1 (IExp_respect _ _ _ (IH _)) A).
    move => i. dependent destruction i ; simpl ; first by rewrite Map.vlvr.
    rewrite -> (X i). by apply Y.
  + move => A r w' j Lj Lw. specialize (IH (s,r) m.+1 (s',r) (Map.lift ops a)).
    specialize (A r w' j Lj Lw). apply: (proj2 (IExp_respect _ _ _ (IH _)) A).
    move => i. dependent destruction i ; simpl ; first by rewrite Map.vlvr.
    rewrite -> (X i). by apply Y.
- move => E t IH t' IH' s m s' a X w. simpl. case => k v. simpl. case: v ; try done.
  move => e. split.
  + move => A w' j v Lw Lj Iv. specialize (A w' j v Lw Lj).
    specialize (IH s m s' a X w' (j,v)).  rewrite <- IH in Iv. simpl in Iv. specialize (A Iv).
    specialize (IH' s m s' a X). by apply(proj1 (IExp_respect _ _ _ IH') A).
  + move => A w' j v Lw Lj Iv. specialize (A w' j v Lw Lj).
    specialize (IH s m s' a X w' (j,v)).  rewrite -> IH in Iv. simpl in Iv. specialize (A Iv).
    specialize (IH' s m s' a X). by apply(proj2 (IExp_respect _ _ _ IH') A).
- move => E t IH s m s' a X w. simpl. case => k v. simpl. case: k ; first by [].
  case: v ; try done. move => l k. specialize (IH s m s' a X). split.
  + move => A. rewrite -> A. by apply: (proj2 (Mrefl _ _) IH).
  + move => A. rewrite -> A. by apply: (proj2 (Mrefl _ _) (tset_sym IH)).
Qed.

Lemma IVal_shiftTy n (t:Ty n) s s' : IVal t s =-= IVal (shiftTy t) (s,s').
by apply IVal_mapTy.
Qed.

(*=IValSubst *)
Lemma IVal_substTy n (t:Ty n) s m s' a :
     (forall i, pick i s =-= (@IVal m (a i) s')) -> IVal t s =-= IVal (subTy a t) s'.
(*=End *)
move => X. apply IVal_mapTy ; simpl ; last by [].
clear. move => n t s s'. by apply: IVal_shiftTy.
Qed.

Lemma IEnv_shiftTy E n (env:TEnv E n) (s:TVal E) w r :
  IEnv (fun v : Fin n => shiftTy (env v)) (s, r) w =-= IEnv env s w.
dependent induction n ; first by [].
simpl. specialize (IHn (tl env) s w r).
case => k. case => p v. simpl. split.
- case => A B. split ; first by apply (proj1 (IHn (k,p)) A).
  have X:=IVal_shiftTy (hd env) s r w (k,v). rewrite X. by apply B.
- case => A B. split ; first by apply (proj2 (IHn (k,p)) A).
  have X:=IVal_shiftTy (hd env) s r w (k,v). rewrite <- X. by apply B.
Qed.

Lemma heap_world_down j k h w : j <= k -> heap_world k h w -> heap_world j h w.
move => L X i Li. specialize (X i (ssrnat.leq_trans Li L)). split ; case: X ; move => X Y ; first by apply X.
move => l. specialize (Y l). by apply Y.
Qed.

Lemma IStore_upclosed n t (s:TVal n) j w w' : w <= w' -> (IStore t s) (j,w) -> (IStore t s) (j,w').
move => L. unfold IStore. simpl. move => X l t' E. specialize (X l t' E).
case: j X ; first by []. move => j. have ll:=fmonotonic Unfold L. clear L.
move => A. rewrite <- A. specialize (ll l). case: (Unfold w l) ll A ; last by [].
move => wl ll _. specialize (ll _ (refl_equal _)). case: ll => wl' [e0 e1].
rewrite e0. apply Msym. by apply: (proj2 (Mrefl _ _) e1 _).
Qed.

Lemma IVal_upclosed n (t:Ty n) s w w' k v : w <= w' -> (IVal t s w) (k,v) -> (IVal t s w') (k,v).
move => Lw. apply (fmonotonic (IVal t s) Lw (k,v)).
Qed.

Lemma IEnv_upclosed E n (env:TEnv E n) (s:TVal E) k v w w' : w <= w' -> (IEnv env s w) (k,v) -> (IEnv env s w') (k,v).
elim: n env v ; first by [].
move => n IH env v L. simpl. case => A B.
split.
- specialize (IH (tl env) (fst v) L). by apply IH.
- by apply (IVal_upclosed L B).
Qed.

Lemma IExp_eq f k w e e' : e = e' -> IExp f k e w -> IExp f k e' w.
move => E. by rewrite E.
Qed.

Lemma world_update (w:W) f l : l \notin dom (Unfold w) -> w <= (Fold (updMap l f (Unfold w))).
move => X.
apply Unfold_monic. have ee:=UF_id (updMap l f (Unfold w)).
refine (pcm_respect (tset_refl _) (tset_sym ee) _). clear ee. simpl.
move => l0 m e. case_eq (l0 == l) => A.
- rewrite <-(eqP A) in X. rewrite findom_indom in X. by rewrite e in X.
- have B:(l0 != l) by rewrite A. clear A.
  exists m. rewrite updMap_simpl2 ; last by apply B. by rewrite e.
Qed.

Lemma csubst_var n m (g:Prod CValue n)  : Tm.subVal (Prod_subst g) (Tm.VAR m) = nth m (Prod_subst g).
Proof.
dependent induction m; first by []. simpl. specialize (IHm (fst g)).
unfold Tm.subVal, Tm.Map.mapVal. simpl. by rewrite tlCons.
Qed.

Lemma negbI (b:bool) : (b -> False) -> ~~ b.
case:b ; last by [].
move => X. simpl. by case: (X is_true_true).
Qed.

(*=Fundamental *)
Lemma FT E (se:StoreType E) :
  (forall n (env : TEnv E n) v t, VTy se env v t -> VRel env se v t) /\
  (forall n (env : TEnv E n) e t, ETy se env e t -> ERel env se e t).
(*=End *)
move: E se ; apply (@Typing_ind) => E se n env.
(* VAR *)
- move => m k s g w. move => X Y. rewrite csubst_var. by apply FT_var.
(* LOC *)
- move => l k s g w. Tm.UnfoldRenSub. unfold Tm.Map.mapVal. case: k ; first by [].
  move => k Ig Is. simpl. by apply: Is.
(* INT *)
- by [].
(* UNIT *)
- by [].
(* LAM *)
- move => t0 t1 e D R. unfold VRel. move => k s g w Ie Is. unfold Tm.subVal. rewrite Tm.Map.mapLAM.
  fold Tm.liftSub. fold Tm.subExp. simpl.
  move => w' j v l L Iv. unfold ERel in R. specialize (R j). rewrite <- (proj2 (Tm.applyComposeSub _)).
  rewrite Tm.composeSingleSub. specialize (R s). specialize (R (g,v)). simpl in R. apply R.
  rewrite tlCons. rewrite hdCons. split ; last by []. apply (IEnv_upclosed l). by apply (upred_downclosed L Ie).
  move => ll t sll. clear R. specialize (Is ll _ sll). simpl in Is.
  case: k Ie Is L.
  + rewrite natO_le. rewrite leqn0. move => _ _ ee. by rewrite (eqP ee).
  + move => k Ie Is L. clear Iv. case: j L ; first by [].
    move => j L. case_eq (Unfold w ll) ; last by move => ee ; rewrite ee in Is.
    move => wll wle. case: (fmonotonic Unfold l ll wll wle) => wl'. case => wle' ee.
    rewrite wle'. rewrite wle in Is. rewrite <- (Mrel_mono L Is). unfold Mrel. simpl.
    by apply (proj2 (Mrefl _ _) (tset_sym ee)).
(* TLAM *)
- move => t'. move => e X Y k ts g w. move => A B. unfold Tm.subVal. autorewrite with mapHints.
  fold Tm.subExp. simpl. move => r w' j Lj Lw. specialize (Y j (ts,r) g). apply Y.
  + apply: (IEnv_upclosed Lw). apply (upred_downclosed Lj).
    by apply (proj2 (IEnv_shiftTy _ _ _ _ _) A).
  + simpl. move => l t ee. simpl in B. specialize (B l (se l) (refl_equal _)).
    case: k A B Lj.
    * rewrite natO_le. rewrite leqn0. move => _ _ ke. by rewrite (eqP ke).
    * move => k A B. clear Y. case: j ; first by [].
      move => j Lj. rewrite <- ee. clear t ee. have Lww:=fmonotonic Unfold Lw. clear Lw.
      specialize (Lww l). case: (Unfold w l) B Lww ; last by [].
      move => wl B Lw. specialize (Lw wl (refl_equal _)). case: Lw => wl'. case => ee e'.
      rewrite ee. unfold Mrel. simpl. unfold Mrel in B. simpl in B. apply (Mrel_mono Lj).
      have aa:= Mrel_trans (proj2 (Mrefl _ _) (tset_sym e') k.+1) B. apply (Mrel_trans aa). clear.
      by apply (proj2 (Mrefl _ _) (IVal_shiftTy (se l) _ _)).
(* PAIR *)
- move => t0 t1 e0 e1. move => _ IH0 _ IH1. move => k s g w Ig Is. simpl.
  specialize (IH0 k s g w Ig Is). specialize (IH1 k s g w Ig Is). split.
  + by apply IH0. + by apply IH1.
(* INL *)
- move => t0 t1 e _ IH0. move => k s g w Ig Is.
  by apply (IH0 k s g w Ig Is).
(* INR *)
- move => t0 t1 e _ IH0. move => k s g w Ig Is.
  by apply (IH0 k s g w Ig Is).
(* FOLD *)
- move => e t' td IH. move => k s g w Ig Is.
  have ee:=FIXP_fp (upred_mu (IVal t') s).
  specialize (ee w (k, Tm.subVal (Prod_subst g) (Tm.FOLD e))). apply (proj2 ee). clear ee.
  case: k Ig Is ; first by []. move => k Ig Is. unfold Tm.subVal. autorewrite with mapHints. fold Tm.subVal.
  specialize (IH k.+1 s g w Ig Is). simpl.
  have A:=proj2 (IVal_substTy _ _ _ _) IH.
  specialize (A (s,FIXP (upred_mu (IVal t') s))).
  apply: (upred_downclosed (leqW (leqnn _)) (A _)).
  move => i. by dependent destruction i.
(* VAL *)
- move => v t td IH k s g w Ig Is. specialize (IH k s g w Ig Is).
  unfold Tm.subExp. autorewrite with mapHints. fold Tm.subVal.
  move => j Lj h h' v0 ev. inversion ev. clear h0 H0. clear v1 H1.
  move: ev. move => ev.
  move: ev. rewrite <- H2. clear v0 H2. rewrite <- H. clear Lj H j.
  move => ev hv. exists w. split ; first by []. rewrite subn0. split ; first by [].
  by apply IH.
(* LET *)
- move => e0 e1 t0 t1 _ IH0 _ IH1. move => k s g w Ig Is.
  move => j Lj h h' v.  unfold Tm.subExp. autorewrite with mapHints. fold Tm.subExp. move => ev.
  inversion ev. clear h0 H0. clear v1 H3. clear e2 H1 e3 H2 H4.
  move => hv. have Ln0 := leq_addr n1 n0. rewrite H in Ln0.
  specialize (IH0 k s g w Ig Is n0 (leq_trans Ln0 Lj) h _ _ X hv).
  case: IH0 => w1 [Lw [hv0 IH0]]. specialize (IH1 (k-n0) s (g,v0) w1).
  have A:IEnv (cons t0 env) s w1 (k - n0, (g, v0)). split ; simpl ; last by apply IH0.
    rewrite tlCons. by apply: (IEnv_upclosed Lw) ; apply: (upred_downclosed _ Ig) ; apply leq_subr.
  specialize (IH1 A).
  have B: (IStore se s) (k - n0, w1) by apply (IStore_upclosed Lw) ; apply: (upred_downclosed _ Is) ; apply leq_subr.
  specialize (IH1 B n1).
  have Ln1:(n1 <= k - n0). rewrite natO_le. rewrite <- (leq_add2l n0). rewrite H. rewrite subnKC ; first by [].
    by apply (leq_trans Ln0).
  specialize (IH1 Ln1 h1 h'). unfold subSingle in X0. rewrite <- (proj2 (Tm.applyComposeSub _)) in X0.
  rewrite -> Tm.composeSingleSub in X0. specialize (IH1 _ X0 hv0). case: IH1 => wr. case => Lw' R.
  exists wr. split ; first by apply (Ole_trans Lw Lw').
  by rewrite subnDA.
(* FST *)
- move => v t1 t2 td IH k s g w Ig Is. move => j Lj h h' v'.
  unfold Tm.subExp. autorewrite with mapHints. fold Tm.subVal. move => ev. inversion ev. clear h0 H0.
  specialize (IH k s g w Ig Is). move: ev. rewrite <- H. clear j H Lj. rewrite H2 in H1. clear v0 H2.
  move => ev hv. exists w. split ; first by []. rewrite subn0. split ; first by [].
  rewrite <- H1 in IH. simpl in IH. by case: IH.
(* SND *)
- move => v t1 t2 td IH k s g w Ig Is. move => j Lj h h' v'.
  unfold Tm.subExp. autorewrite with mapHints. fold Tm.subVal. move => ev. inversion ev. clear h0 H0.
  specialize (IH k s g w Ig Is). move: ev. rewrite <- H. clear j H Lj. rewrite H2 in H1. clear v1 H2.
  move => ev hv. exists w. split ; first by []. rewrite subn0. split ; first by [].
  rewrite <- H1 in IH. simpl in IH. by case: IH.
(* OP *)
- move => op v. move => A B. move => k s g w Ie Is. simpl. unfold Tm.subExp. autorewrite with mapHints. fold Tm.subVal.
  move => j Lj h h' vv ev. inversion ev. clear op0 H1. rewrite <- H in Lj, ev. clear j H ev.
  clear h0 H0. rewrite <- H4. clear h' H4. clear vv H3. rewrite subn0. simpl. move => hv. exists w. by split ; last split.
(* UNFOLD *)
- move => t v _ IH. move => k s g w Ie Is. move => j' Lj h h' vr.
  unfold Tm.subExp. autorewrite with mapHints. fold Tm.subVal. move => ev. inversion ev.
  rewrite -> H2 in H1. clear v0 H2. rewrite <- H in Lj. clear ev j' H. clear h0 H0.
  rewrite <- H3. clear h' H3.  move => hw. specialize (IH k s g w Ie Is). simpl in IH. rewrite <- H1 in IH.
  clear Ie Is H1 v g. case: k Lj IH hw ; first by [].
  move => k _ IH hw. have IIH:= proj1 (FIXP_fp (upred_muc (IVal t) s) w (k.+1, Tm.FOLD vr)) IH. clear IH.
  simpl in IIH. rewrite subSS. rewrite subn0. unfold unfoldTy. unfold subOneTy.
  exists w ; split ; first by []. split ; first by apply (heap_world_down (leqW (leqnn k))).
  apply: (proj1 (IVal_substTy t _ w _) IIH) => i. by dependent destruction i.
(* REF *)
- move => v t _ IH. move => k s g w Ie Is. move => j' Lj h h' vr.
  unfold Tm.subExp. autorewrite with mapHints. fold Tm.subVal. move => ev. inversion ev.
  rewrite <- H0 in Lj. clear H0 j' ev. clear vr H3. clear v0 H. clear h0 H2. clear h' H4.
  move => hw. case: k Ie Is Lj hw ; first by [].
  move => k Ie Is _ hw. rewrite subSS. rewrite subn0. simpl.
  exists (Fold (updMap l (IVal t s) (Unfold w))).
  have Lw:w <= Fold (updMap l (IVal t s) (Unfold w)).
  + apply: Unfold_monic. move => ll m e. have F:=proj1 (hw k (ltnSn _)). specialize (F l). rewrite F in H1.
    case_eq (l == ll) => ee.
    * rewrite <- (eqP ee) in e. rewrite findom_indom in H1. by rewrite e in H1.
    * case_eq (Unfold (Fold (updMap l (IVal t s) (Unfold w))) ll).
      - move => ufwl eaa. exists ufwl. split ; first by [].
        have xxx:Some m =-= Some ufwl ; last by apply xxx. rewrite <- eaa. clear ufwl eaa.
        have aaa:= (UF_id (updMap l (IVal t s) (Unfold w))). simpl in aaa. unfold Datatypes.id in aaa.
        have bb:= (proj2 aaa ll). rewrite -> bb. rewrite updMap_simpl2. by rewrite e.
        apply negbI => ea. rewrite (eqP ea) in ee. by rewrite eq_refl in ee.
        clear bb. rewrite (proj1 aaa). rewrite indomUpdMap. rewrite findom_indom. rewrite e. simpl. by rewrite orbT.
      - move => a. have b:=UF_id (updMap l (IVal t s) (Unfold w)). simpl in b. unfold Datatypes.id in b.
        have ne:= findom_indom (Unfold (Fold (updMap l (IVal t s) (Unfold w)))) ll. rewrite a in ne. simpl in ne.
        rewrite -> (proj1 b) in ne. rewrite indomUpdMap in ne. rewrite findom_indom in ne. rewrite e in ne.
        simpl in ne. by rewrite orbT in ne.
  split ; first by apply Lw.
  + split. move => j' Lj. split.
    * move => ll. rewrite indomUpdMap.
      have b:=UF_id (updMap l (IVal t s) (Unfold w)). simpl in b. unfold Datatypes.id in b.
      rewrite (proj1 b ll). rewrite indomUpdMap. have e0:=proj1 (hw k (ltnSn _)) ll. by rewrite e0.
    * move => l0. case_eq (Unfold (Fold (updMap l (IVal t s) (Unfold w))) l0) ; last by [].
      move => ufl0 e0. have e1:=UF_id (updMap l (IVal t s) (Unfold w)). simpl in e1.
      unfold Datatypes.id in e1. have b1:=proj2 e1 l0. rewrite findom_indom in b1. rewrite e0 in b1.
      specialize (b1 is_true_true). clear e0. clear e1. specialize (hw k (ltnSn _)).
      case: hw => dhe hw. specialize (hw l0). case_eq (l == l0).
      - move => e. rewrite (eqP e). simpl.
        rewrite (updMap_simpl l0 (Tm.subVal (Prod_subst g) v) h). rewrite -> (eqP e) in b1.
        rewrite (updMap_simpl l0) in b1. unfold tset_eq in b1. simpl in b1. simpl.
        apply (proj2 ((b1 (Fold (updMap l0 ((IVal t) s) (Unfold w)))) (j', Tm.subVal (Prod_subst g) v))).
        clear ufl0 b1.
        specialize (IH j' s g w). rewrite <- (eqP e). apply: (IVal_upclosed Lw). apply IH.
        by apply (upred_downclosed (leqW (ltnW Lj)) Ie). by apply (upred_downclosed (leqW (ltnW Lj)) Is).
      - move => ee. simpl. rewrite updMap_simpl2.
        rewrite updMap_simpl2 in b1. specialize (dhe l0). do 2 rewrite findom_indom in dhe.
        case_eq (h l0) ; last by move => F ; rewrite F.
        move => hl0 e. rewrite e. case: (Unfold w l0) hw b1 ; last by [].
        move => uwl0 hw b1. rewrite e in hw. unfold tset_eq in b1. simpl in b1.
        specialize (b1 w (k,hl0)). simpl in b1. have hh := proj2 b1 hw. clear uwl0 b1 hw.
        apply (fmonotonic ufl0 Lw (j',hl0)). by apply (@upred_downclosed _ _ j' k _ (leqW Lj) hh).
      apply negbI => e. rewrite (eqP e) in ee. by rewrite eq_refl in ee.
      apply negbI => e. rewrite (eqP e) in ee. by rewrite eq_refl in ee.
  + case: k Ie Is hw ; first by [].
    move => k Iw Is hw. have ee:=UF_id (updMap l (IVal t s) (Unfold w)). simpl in ee. unfold Datatypes.id in ee.
    have aa:=(proj2 ee l _). rewrite (proj1 ee) in aa. rewrite indomUpdMap in aa. rewrite eq_refl in aa.
    specialize (aa is_true_true).
    rewrite -> (proj2 (Mrefl _ _) aa). by rewrite updMap_simpl.
(* REF *)
- move => v t _ IH. move => k s g w Ie Is. move => j Lj h h' vr.
  unfold Tm.subExp. autorewrite with mapHints. fold Tm.subVal. move => ev. inversion ev.
  clear h0 H2. clear v0 H3. rewrite <- H0 in Lj. clear j H0 ev. rewrite <- H4. rewrite <- H4 in H1. clear h' H4.
  move => hw. exists w ; split ; first by []. split.
  + case: k Lj Ie Is hw ; first by [].
    move => k _ Ie Is hw. rewrite subSS. rewrite subn0. by apply: (heap_world_down (leqW (leqnn k)) hw).
  + specialize (IH k s g w Ie Is). rewrite <- H in IH. simpl in IH.
    case: k IH Lj Ie Is hw ; first by []. move => k IH _ Ie Is hw.
    rewrite subSS. rewrite subn0. specialize (hw k (ltnSn _)). case: hw => D hw.
    specialize (hw l). case: (Unfold w l) IH hw ; last by [].
    move => wl IH hw. rewrite H1 in hw. unfold Mrel in IH. simpl in IH.
    specialize (IH w k vr (ltnSn _)). simpl in IH. by apply (proj1 IH hw).
(* ASSIGN *)
- move => v0 v1 t _ IH0 _ IH1. move => k s g w Ie Is. move => j Lj h h' vr.
  unfold Tm.subExp. autorewrite with mapHints. fold Tm.subVal. move => ev. inversion ev.
  rewrite <- H0 in Lj. clear j ev H0. clear v H2. clear h0 H1. clear vr H3. clear h' H4.
  specialize (IH0 k s g w Ie Is). rewrite <- H in IH0. clear v0 H.
  specialize (IH1 k s g w Ie Is). simpl in IH0. case: k IH0 IH1 Ie Is Lj ; first by [].
  move => k IH0 IH1 Ie Is _ hw. rewrite subSS. rewrite subn0. exists w ; split ;first by [].
  split ; last by [].
  move => j Lj. split.
  + move => ll. rewrite indomUpdMap. specialize (hw k (ltnSn _)). rewrite <- (proj1 hw).
    case_eq (ll == l) => ee ; last by []. rewrite (eqP ee). rewrite findom_indom. by rewrite H5.
  + move => l0. case_eq (Unfold w l0) ; last by []. move => wl0 e0.
    case_eq (l == l0) => e.
    * rewrite <- (eqP e). rewrite updMap_simpl.
      rewrite <- (eqP e) in e0. clear l0 e. rewrite e0 in IH0.
      specialize (IH0 w j (Tm.subVal (Prod_subst g) v1) (ltnW Lj)). simpl in IH0. apply (proj2 IH0). clear IH0 wl0 e0.
      apply: (upred_downclosed _ IH1). by apply (leqW (leqW Lj)).
    * rewrite updMap_simpl2. case_eq (h l0) ; last by move => e1.
      move => hl0 e1. specialize (hw j (leqW Lj)). case: hw => D hw.
      specialize (hw l0). rewrite e0 in hw. rewrite e1 in hw. by apply hw.
    apply negbI => e1. rewrite (eqP e1) in e. by rewrite eq_refl in e.
- move => t0 t1 v0 v1 _ IH0 _ IH1. move => k s g w Ie Is. specialize (IH0 k s g w Ie Is).
  specialize (IH1 k s g w Ie Is). move => j Lj h h' vr.
  unfold Tm.subExp. autorewrite with mapHints. fold Tm.subVal. move => ev. inversion ev.
  clear n0 H. clear h0 H0. clear v2 H3. clear h1 H4. clear v H2. clear ev. move => hw.
  rewrite <- H1 in IH0. clear H1 v0. simpl in IH0. have IH0':= (IH0 w k _ (Ole_refl _) (leqnn _) IH1). clear IH0.
  specialize (IH0' j Lj h h'). unfold subSingle in X. by apply (IH0' _ X hw).
- move => t v t' _ IH. move => k s g w Ie Is. specialize (IH k s g w Ie Is).
  move => j Lj h h' vr.
  unfold Tm.subExp. autorewrite with mapHints. fold Tm.subVal. move => ev. inversion ev.
  clear n0 H. clear h0 H0. clear v0 H2. clear h1 H3. rewrite <- H1 in IH. clear H1 v ev.
  move => hw. simpl in IH. specialize (IH (IVal t' s) w k (leqnn _) (Ole_refl _) j Lj h h' _ X hw).
  unfold subOneTy. case: IH => w'. case => Lw. case => hw' IH. exists w'. split ; first by []. split ; first by [].
  apply: (proj1 (IVal_substTy t _ _ _) IH). move => i. by dependent destruction i.
- move => t0 t1 v e0 e1 t' _ IH0 _ IH1 _ IH2. move => k s g w Ie Is.
  specialize (IH0 k s g w Ie Is). move => j Lj h h' vr.
  unfold Tm.subExp. autorewrite with mapHints. fold Tm.subExp. fold Tm.subVal. move => ev. inversion ev.
  + clear n0 H. clear e2 H2. clear e3 H3. clear h0 H0. clear v1 H4. clear h1 H5. rewrite <- H1 in IH0. clear v H1 ev.
    simpl in IH0. specialize (IH1 k s (g,v0) w).
    have IE2:IEnv (cons t0 env) s w (k, (g, v0)). simpl. rewrite tlCons. split ; first by []. by apply IH0.
    specialize (IH1 IE2 Is j Lj h h'). apply IH1.
    unfold subSingle in X. rewrite <- (proj2 (Tm.applyComposeSub _)) in X. fold Tm.liftSub in X.
    rewrite Tm.composeSingleSub in X. by apply X.
  + clear n0 H. clear e2 H2. clear e3 H3. clear h0 H0. clear v1 H4. clear h1 H5. rewrite <- H1 in IH0. clear v H1 ev.
    simpl in IH0. specialize (IH2 k s (g,v0) w).
    have IE2:IEnv (cons t1 env) s w (k, (g, v0)). simpl. rewrite tlCons. split ; first by []. by apply IH0.
    specialize (IH2 IE2 Is j Lj h h'). apply IH2.
    unfold subSingle in X. rewrite <- (proj2 (Tm.applyComposeSub _)) in X. fold Tm.liftSub in X.
    rewrite Tm.composeSingleSub in X. by apply X.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C D O X Y P Q : Universe, ((wd_ X Y /\ (wd_ X O /\ (wd_ O C /\ (wd_ C D /\ (wd_ O D /\ (wd_ O A /\ (wd_ A B /\ (wd_ O B /\ (col_ O X Y /\ (col_ X Y P /\ (col_ A B P /\ (col_ X Y Q /\ col_ C D Q)))))))))))) -> col_ O X Q)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C D Bprime Cprime : Universe, ((wd_ A B /\ (wd_ B C /\ (wd_ A Bprime /\ (wd_ Bprime Cprime /\ (wd_ Cprime D /\ (wd_ A D /\ (wd_ A C /\ (wd_ D B /\ (wd_ D C /\ (col_ A B Bprime /\ (col_ A Bprime Cprime /\ (col_ A Bprime D /\ col_ Cprime C D)))))))))))) -> col_ A B Cprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Export Category.Duals DiscreteCategory Category.Equality.
Require Import Common.

Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.
Set Universe Polymorphism.

Local Open Scope category_scope.

(** The discrete categories are propositionally self-dual. *)

Local Ltac dual_t :=
  repeat match goal with
           | _ => reflexivity
           | _ => progress (repeat (apply path_forall; intro); simpl)
           | _ => apply (path_universe (symmetry _ _))
           | [ |- @sigT ?A ?P ] => cut A;
                                  [ let t := fresh in
                                    intro t; exists t
                                  | ]
           | _ => exact (center _)
           | _ => progress category_eq; simpl
         end.

Lemma SelfDual_Discrete `{Funext} `{Univalence} `{IsHSet X}
: (DiscreteCategory X)^op = DiscreteCategory X.
Proof.
  repeat match goal with
           | _ => reflexivity
           | _ => progress (repeat (apply path_forall; intro); simpl)
           | _ => apply (path_universe (symmetry _ _))
           | [ |- @sigT ?A ?P ] => cut A;
                                  [ let t := fresh in
                                    intro t; exists t
                                  | ]
           | _ => exact (center _)
         end.
  category_eq; simpl.
  repeat match goal with
           | _ => reflexivity
           | _ => progress (repeat (apply path_forall; intro); simpl)
           | _ => apply (path_universe (symmetry _ _))
           | [ |- @sigT ?A ?P ] => cut A;
                                  [ let t := fresh in
                                    intro t; exists t
                                  | ]
         end.
  exact (center _).
Qed.