(* Copied from coq-hahn: github.com/vafeiadis/hahn *)

(* ************************************************************************** *)
(** * Basic tactics *)
(* ************************************************************************** *)

(** This file collects a number of basic tactics for better proof automation,
    structuring large proofs, or rewriting.  Many of the definitions have been
    ported from ss-reflect. *)

(** Symbols starting with [hahn__] are internal. *)

Require Import Bool Arith ZArith String.
Require ClassicalFacts.
Require Export ClassicalDescription FunctionalExtensionality.

Open Scope bool_scope.
Open Scope list_scope.

Set Implicit Arguments.
Unset Strict Implicit.

(** Set up hint databases *)
Create HintDb hahn discriminated.      (* General stuff, used by done *)
Create HintDb hahn_refl discriminated. (* Decidable equalities *)
Create HintDb hahn_full discriminated. (* Expensive lemmas *)

(** Shorthand for applying functional extensionality. *)

Ltac exten := apply functional_extensionality.

(** Notation for classical if-then-else *)

Notation "'ifP' c 'then' u 'else' v" :=
  (if excluded_middle_informative c then u else v)
  (at level 200).

(* ************************************************************************** *)
(** ** Coersion of [bool] into [Prop] *)
(* ************************************************************************** *)

(** Coersion of bools into Prop *)
Coercion is_true (b : bool) : Prop := b = true.

(** Hints for auto *)
Lemma hahn__true_is_true : true.
Proof. reflexivity. Qed.

Lemma hahn__not_false_is_true : ~ false.
Proof. discriminate. Qed.

Global Hint Resolve hahn__true_is_true hahn__not_false_is_true : core.

(* ************************************************************************** *)
(** ** Very basic automation *)
(* ************************************************************************** *)

(** Set up for basic simplification *)

(** Adaptation of the ss-reflect "[done]" tactic. *)

Ltac hahn__basic_done :=
  solve [trivial with hahn | simple apply sym_equal; trivial | discriminate | contradiction].

Ltac done := trivial with hahn; hnf; intros;
  solve [try hahn__basic_done; split;
         try hahn__basic_done; split;
         try hahn__basic_done; split;
         try hahn__basic_done; split;
         try hahn__basic_done; split; hahn__basic_done
    | match goal with H : ~ _ |- _ => solve [case H; trivial] end].

(** A variant of the ssr "done" tactic that performs "eassumption". *)

Ltac edone := try eassumption; trivial; hnf; intros;
  solve [try eassumption; try hahn__basic_done; split;
         try eassumption; try hahn__basic_done; split;
         try eassumption; try hahn__basic_done; split;
         try eassumption; try hahn__basic_done; split;
         try eassumption; try hahn__basic_done; split;
         try eassumption; hahn__basic_done
    | match goal with H : ~ _ |- _ => solve [case H; trivial] end].

Tactic Notation "by"  tactic(tac) := (tac; done).
Tactic Notation "eby" tactic(tac) := (tac; edone).

(* ************************************************************************** *)
(** ** Equality types *)
(* ************************************************************************** *)

Module Equality.

  Definition axiom T (e : T -> T -> bool) :=
    forall x y, reflect (x = y) (e x y).

  Structure mixin_of T := Mixin {op : T -> T -> bool; _ : axiom op}.
  Notation class_of := mixin_of (only parsing).

  Section ClassDef.

    Structure type := Pack {sort; _ : class_of sort; _ : Type}.

    Definition class cT' :=
      match cT' return class_of (sort cT') with @Pack _ c _ => c end.

    Definition pack (T: Type) c := @Pack T c T.

  End ClassDef.

  Module Exports.
    Coercion sort : type >-> Sortclass.
    Notation eqType := type.
    Notation EqMixin := Mixin.
    Notation EqType T m := (@pack T m).
  End Exports.

End Equality.
Export Equality.Exports.

Definition eq_op T := Equality.op (Equality.class T).
Arguments eq_op {T}.

Lemma eqE : forall T x, eq_op x = Equality.op (Equality.class T) x.
Proof. done. Qed.

Lemma eqP : forall T, Equality.axiom (@eq_op T).
Proof. by unfold eq_op; destruct T as [? []]. Qed.
Arguments eqP [T] x y.

(*
Notation "x == y" := (eq_op x y)
  (at level 70, no associativity) : bool_scope.
Notation "x == y :> T" := ((x : T) == (y : T))
  (at level 70, y at next level) : bool_scope.
Notation "x != y" := (negb (x == y))
  (at level 70, no associativity) : bool_scope.
Notation "x != y :> T" := (negb (x == y :> T))
  (at level 70, y at next level) : bool_scope.
*)

Lemma hahn__internal_eqP :
  forall (T: eqType) (x y : T), reflect (x = y) (eq_op x y).
Proof. apply eqP. Qed.

Lemma neqP : forall (T: eqType) (x y: T), reflect (x <> y) (negb (eq_op x y)).
Proof. intros; case eqP; constructor; auto. Qed.

Lemma beq_refl : forall (T : eqType) (x : T), eq_op x x.
Proof. by intros; case eqP. Qed.

Lemma beq_sym : forall (T : eqType) (x y : T), (eq_op x y) = (eq_op y x).
Proof. intros; do 2 case eqP; congruence. Qed.

Global Hint Resolve beq_refl : hahn.
Hint Rewrite beq_refl : hahn_trivial.

Notation eqxx := beq_refl.

(** Comparison for [nat] *)

Fixpoint eqn_rec (x y: nat) {struct x} :=
   match x, y with
     | O, O => true
     | S x, S y => eqn_rec x y
     | _, _ => false
   end.

Definition eqn := match tt with tt => eqn_rec end.

Lemma eqnP: forall x y, reflect (x = y) (eqn x y).
Proof.
  induction x; destruct y; try (constructor; done).
  change (eqn (S x) (S y)) with (eqn x y).
  case IHx; constructor; congruence.
Qed.

Canonical Structure nat_eqMixin := EqMixin eqnP.
Canonical Structure nat_eqType := Eval hnf in EqType nat nat_eqMixin.

Lemma eqnE : eqn = (@eq_op _).
Proof. done. Qed.

(* ************************************************************************** *)
(** ** Basic simplification tactics *)
(* ************************************************************************** *)

Lemma hahn__negb_rewrite : forall b, negb b -> b = false.
Proof. by intros []. Qed.

Lemma hahn__andb_split : forall b1 b2, b1 && b2 -> b1 /\ b2.
Proof. by intros [] []. Qed.

Lemma hahn__nandb_split : forall b1 b2, b1 && b2 = false -> b1 = false \/ b2 = false.
Proof. intros [] []; auto. Qed.

Lemma hahn__orb_split : forall b1 b2, b1 || b2 -> b1 \/ b2.
Proof. intros [] []; auto. Qed.

Lemma hahn__norb_split : forall b1 b2, b1 || b2 = false -> b1 = false /\ b2 = false.
Proof. intros [] []; auto. Qed.

Lemma hahn__eqb_split : forall b1 b2 : bool, (b1 -> b2) -> (b2 -> b1) -> b1 = b2.
Proof. intros [] [] H H'; unfold is_true in *; auto using sym_eq. Qed.

Lemma hahn__beq_rewrite (T : eqType) (x1 x2 : T) : eq_op x1 x2 -> x1 = x2.
Proof. by case eqP. Qed.

(** Set up for basic simplification: database of reflection lemmas *)

Global Hint Resolve hahn__internal_eqP neqP eqnP : hahn_refl.
Global Hint Resolve Z.eqb_spec Z.leb_spec0 Z.ltb_spec0 : hahn_refl.
Global Hint Resolve N.eqb_spec N.leb_spec0 N.ltb_spec0 : hahn_refl.
Global Hint Resolve Pos.eqb_spec Pos.leb_spec0 Pos.ltb_spec0 : hahn_refl.
Global Hint Resolve Nat.eqb_spec Nat.leb_spec0 Nat.ltb_spec0 : hahn_refl.
Global Hint Resolve Ascii.eqb_spec String.eqb_spec : hahn_refl.
Global Hint Resolve Bool.eqb_spec : hahn_refl.

Ltac hahn__complaining_inj f H :=
  let X := fresh in
  (match goal with | [|- ?P ] => set (X := P) end);
  injection H; clear H; intros; subst X;
  try subst.

Ltac hahn__clarify1 :=
  try subst;
  repeat match goal with
  | [H: is_true (andb _ _) |- _] =>
      let H' := fresh H in case (hahn__andb_split H); clear H; intros H' H
  | [H: is_true (negb ?x) |- _] => rewrite (hahn__negb_rewrite H) in *
  | [H: is_true ?x        |- _] => rewrite H in *
  | [H: ?x = true         |- _] => rewrite H in *
  | [H: ?x = false        |- _] => rewrite H in *
  | [H: is_true (eq_op _ _)  |- _] => generalize (hahn__beq_rewrite H); clear H; intro H
  | [H: @existT _ _ _ _ = @existT _ _ _ _ |- _] => apply inj_pair2 in H; try subst
  | [H: ?f _             = ?f _             |- _] => hahn__complaining_inj f H
  | [H: ?f _ _           = ?f _ _           |- _] => hahn__complaining_inj f H
  | [H: ?f _ _ _         = ?f _ _ _         |- _] => hahn__complaining_inj f H
  | [H: ?f _ _ _ _       = ?f _ _ _ _       |- _] => hahn__complaining_inj f H
  | [H: ?f _ _ _ _ _     = ?f _ _ _ _ _     |- _] => hahn__complaining_inj f H
  | [H: ?f _ _ _ _ _ _   = ?f _ _ _ _ _ _   |- _] => hahn__complaining_inj f H
  | [H: ?f _ _ _ _ _ _ _ = ?f _ _ _ _ _ _ _ |- _] => hahn__complaining_inj f H
  end; try done.

(** Perform injections & discriminations on all hypotheses *)

Ltac clarify :=
  hahn__clarify1;
  repeat match goal with
    | H1: ?x = Some _, H2: ?x = None   |- _ => rewrite H2 in H1; discriminate
    | H1: ?x = Some _, H2: ?x = Some _ |- _ => rewrite H2 in H1; hahn__clarify1
  end; (* autorewrite with hahn_trivial; *) try done.

(** Kill simple goals that require up to two econstructor calls. *)

Ltac vauto :=
  (clarify; try edone;
   try [> econstructor; (solve [edone | [> econstructor; edone]])]).

Ltac inv x := inversion x; clarify.
Ltac simpls  := simpl in *; try done.
Ltac ins := simpl in *; try done; intros.

Ltac hahn__clarsimp1 :=
  clarify; (autorewrite with hahn_trivial hahn in * );
  (autorewrite with hahn_trivial in * ); try done;
  clarify; auto 1 with hahn.

Ltac clarsimp := intros; simpl in *; hahn__clarsimp1.

Ltac autos   := clarsimp; auto with hahn.

Tactic Notation "econs" := econstructor.
Tactic Notation "econs" int_or_var(x) := econstructor x.

(* ************************************************************************** *)
(** Destruct but give useful names *)
(* ************************************************************************** *)

Definition  NW (P: unit -> Prop) : Prop := P tt.

Notation "⟪ x : t ⟫" := (NW (fun x => t)) (at level 80, x ident, no associativity).
Notation "<< x : t >>" := (NW (fun x => t))
  (at level 80, x ident, no associativity, only parsing).
Notation "⟪ t ⟫" := (NW (fun _ => t)) (at level 79, no associativity, format "⟪ t ⟫").

Ltac unnw := unfold NW in *.
Ltac rednw := red; unnw.
Ltac getnw :=
  repeat match goal with
  | H : NW (fun y => _) |- _ => rename H into y; red in y
  end.

Global Hint Unfold NW : core.

Ltac splits :=
  intros; unfold NW;
  repeat match goal with
  | [ |- _ /\ _ ] => split
  end.

Ltac esplits :=
  intros; unfold NW;
  repeat match goal with
  | [ |- @ex _ _ ] => eexists
  | [ |- _ /\ _ ] => split
  | [ |- @sig _ _ ] => eexists
  | [ |- @sigT _ _ ] => eexists
  | [ |- @prod _  _ ] => split
  end.

(** Destruct, but no case split *)
Ltac desc :=
  repeat match goal with
    | H: is_true (eq_op _ _) |- _ => generalize (hahn__beq_rewrite H); clear H; intro H
    | H : exists x, NW (fun y => _) |- _ =>
      progress first [try (destruct H as [? H] ; fail 1) | (* Check it's not a Section Hypothesis *)
      let x' := fresh x in let y' := fresh y in destruct H as [x' y']; red in y']
    | H : exists x, ?p |- _ =>
      let x' := fresh x in destruct H as [x' H]
    | H : ?p /\ ?q |- _ =>
      progress first [try (destruct H as [H ?] ; fail 1) | (* Check it's not a Section Hypothesis *)
      let x' := match p with | NW (fun z => _) => fresh z | _ => H end in
      let y' := match q with | NW (fun z => _) => fresh z | _ => fresh H end in
      destruct H as [x' y'];
      match p with | NW _ => red in x' | _ => idtac end;
      match q with | NW _ => red in y' | _ => idtac end]
    | H : is_true (_ && _) |- _ =>
          let H' := fresh H in case (hahn__andb_split H); clear H; intros H H'
    | H : (_ || _) = false |- _ =>
          let H' := fresh H in case (hahn__norb_split H); clear H; intros H H'
    | H : ?x = ?x   |- _ => clear H

(*    | H: is_true ?x |- _ => eapply elimT in H; [|solve [trivial with hahn_refl]]
    | H: ?x = true  |- _ => eapply elimT in H; [|solve [trivial with hahn_refl]]
    | H: ?x = false |- _ => eapply elimFn in H; [|solve [trivial with hahn_refl]]
    | H: ?x = false |- _ => eapply elimF in H; [|solve [trivial with hahn_refl]]  *)
  end.

Ltac des :=
  repeat match goal with
    | H: is_true (eq_op _ _) |- _ => generalize (hahn__beq_rewrite H); clear H; intro H
    | H : exists x, NW (fun y => _) |- _ =>
      progress first [try (destruct H as [? H] ; fail 1) | (* Check it's not a Section Hypothesis *)
      let x' := fresh x in let y' := fresh y in destruct H as [x' y']; red in y']
    | H : exists x, ?p |- _ =>
      let x' := fresh x in destruct H as [x' H]
    | H : ?p /\ ?q |- _ =>
      progress first [try (destruct H as [H ?] ; fail 1) | (* Check it's not a Section Hypothesis *)
      let x' := match p with | NW (fun z => _) => fresh z | _ => H end in
      let y' := match q with | NW (fun z => _) => fresh z | _ => fresh H end in
      destruct H as [x' y'];
      match p with | NW _ => red in x' | _ => idtac end;
      match q with | NW _ => red in y' | _ => idtac end]
    | H : is_true (_ && _) |- _ =>
        let H' := fresh H in case (hahn__andb_split H); clear H; intros H H'
    | H : (_ || _) = false |- _ =>
        let H' := fresh H in case (hahn__norb_split H); clear H; intros H H'
    | H : ?x = ?x |- _ => clear H
    | H : ?p <-> ?q |- _ =>
      progress first [try (destruct H as [H ?] ; fail 1) | (* Check it's not a Section Hypothesis *)
      let x' := match p with | NW (fun z => _) => fresh z | _ => H end in
      let y' := match q with | NW (fun z => _) => fresh z | _ => fresh H end in
      destruct H as [x' y'];
      match p with | NW _ => unfold NW at 1 in x'; red in y' | _ => idtac end;
      match q with | NW _ => unfold NW at 1 in y'; red in x' | _ => idtac end]
    | H : ?p \/ ?q |- _ =>
      progress first [try (destruct H as [H|H] ; fail 1) | (* Check it's not a Section Hypothesis *)
      let x' := match p with | NW (fun z => _) => fresh z | _ => H end in
      let y' := match q with | NW (fun z => _) => fresh z | _ => H end in
      destruct H as [x' | y'];
      [ match p with | NW _ => red in x' | _ => idtac end
      | match q with | NW _ => red in y' | _ => idtac end]]
    | H : is_true (_ || _) |- _ => case (hahn__orb_split H); clear H; intro H
    | H : (_ && _) = false |- _ => case (hahn__nandb_split H); clear H; intro H
  end.

Ltac desc_section :=
  repeat match goal with
    | H : exists x, NW (fun y => _) |- _ =>
      try (destruct H as [? H] ; fail 1); (* Check it is a Section Hypothesis *)
      let x' := fresh x in let y' := fresh y in destruct H as [x' y']; clear H; red in y'
    | H : exists x, ?p |- _ =>
      try (destruct H as [? H] ; fail 1); (* Check it is a Section Hypothesis *)
      let x' := fresh x in let y' := fresh H in destruct H as [x' y']; clear H; red in y'
    | H : ?p /\ ?q |- _ =>
      try (destruct H as [H ?] ; fail 1); (* Check it is a Section Hypothesis *)
      let x' := match p with | NW (fun z => _) => fresh z | _ => fresh H end in
      let y' := match q with | NW (fun z => _) => fresh z | _ => fresh H end in
      destruct H as [x' y']; clear H;
      match p with | NW _ => red in x' | _ => idtac end;
      match q with | NW _ => red in y' | _ => idtac end
    | H : ?x = ?x   |- _ => clear H
  end; desc.

Ltac cdes H :=
  let H' := fresh H in assert (H' := H); try red in H'; desc.

Ltac des_if_asm :=
  clarify;
  repeat
    match goal with
      | H: context[ match ?x with _ => _ end ] |- _ =>
        match (type of x) with
          | { _ } + { _ } => destruct x; clarify
          | bool =>
            let Heq := fresh "Heq" in
            let P := fresh in
            evar(P: Prop);
            assert (Heq: reflect P x) by (subst P; trivial with hahn_refl);
            subst P; destruct Heq as [Heq|Heq]
          | _ => let Heq := fresh "Heq" in destruct x as [] eqn: Heq; clarify
        end
    end.

Ltac des_if_goal :=
  clarify;
  repeat
    match goal with
      | |- context[match ?x with _ => _ end] =>
        match (type of x) with
          | { _ } + { _ } => destruct x; clarify
          | bool =>
            let Heq := fresh "Heq" in
            let P := fresh in
            evar(P: Prop);
            assert (Heq: reflect P x) by (subst P; trivial with hahn_refl);
            subst P; destruct Heq as [Heq|Heq]
          | _ => let Heq := fresh "Heq" in destruct x as [] eqn: Heq; clarify
        end
    end.

Ltac des_if :=
  clarify;
  repeat
    match goal with
      | |- context[match ?x with _ => _ end] =>
        match (type of x) with
          | { _ } + { _ } => destruct x; clarify
          | bool =>
            let Heq := fresh "Heq" in
            let P := fresh in
            evar(P: Prop);
            assert (Heq: reflect P x) by (subst P; trivial with hahn_refl);
            subst P; destruct Heq as [Heq|Heq]
          | _ => let Heq := fresh "Heq" in destruct x as [] eqn: Heq; clarify
        end
      | H: context[ match ?x with _ => _ end ] |- _ =>
        match (type of x) with
          | { _ } + { _ } => destruct x; clarify
          | bool =>
            let Heq := fresh "Heq" in
            let P := fresh in
            evar(P: Prop);
            assert (Heq: reflect P x) by (subst P; trivial with hahn_refl);
            subst P; destruct Heq as [Heq|Heq]
          | _ => let Heq := fresh "Heq" in destruct x as [] eqn: Heq; clarify
        end
    end.

Ltac des_eqrefl :=
  match goal with
    | H: context[match ?X with _ => _ end Logic.eq_refl] |- _ =>
    let EQ := fresh "EQ" in
    let id' := fresh "x" in
    revert H;
    generalize (Logic.eq_refl X); generalize X at 1 3;
    intros id' EQ; destruct id'; intros H
    | |- context[match ?X with _ => _ end Logic.eq_refl] =>
    let EQ := fresh "EQ" in
    let id' := fresh "x" in
    generalize (Logic.eq_refl X); generalize X at 1 3;
    intros id' EQ; destruct id'
  end.

Ltac desf_asm := clarify; des; des_if_asm.

Ltac desf := clarify; des; des_if.

Ltac clarassoc := clarsimp; autorewrite with hahn_trivial hahn hahnA in *; try done.

Ltac hahn__hacksimp1 :=
   clarsimp;
   match goal with
     | H: _ |- _ => solve [rewrite H; clear H; clarsimp
                         |rewrite <- H; clear H; clarsimp]
     | _ => solve [f_equal; clarsimp]
   end.

Ltac hacksimp :=
   clarsimp;
   try match goal with
   | H: _ |- _ => solve [rewrite H; clear H; clarsimp
                              |rewrite <- H; clear H; clarsimp]
   | |- context[match ?p with _ => _ end] => solve [destruct p; hahn__hacksimp1]
   | _ => solve [f_equal; clarsimp]
   end.

Ltac clarify_not :=
  repeat (match goal with
  | H : ~ False |- _ => clear H
  | H : ~ ~ _ |- _ => apply NNPP in H
  | H : ~ _ |- _ => apply imply_to_and in H; desc
  | H : ~ _ |- _ => apply not_or_and in H; desc
  | H : ~ _ |- _ => apply not_and_or in H; des
  | H : ~ _ |- _ => apply not_all_ex_not in H; desc
  end; clarify).

Tactic Notation "tertium_non_datur" constr(P) :=
  destruct (classic P); clarify_not.

Tactic Notation "tertium_non_datur" constr(P) "as" simple_intropattern(pattern) :=
  destruct (classic P) as pattern; clarify_not.

(* ************************************************************************** *)
(** ** Unification helpers *)
(* ************************************************************************** *)

Tactic Notation "pattern_lhs" uconstr(term) :=
  match goal with
    |- _ ?lhs _ =>
    let P := fresh in
    pose (P := lhs); pattern term in P; change lhs with P; subst P
  end.

Tactic Notation "pattern_rhs" uconstr(term) :=
  match goal with
    |- _ _ ?rhs =>
    let P := fresh in
    pose (P := rhs); pattern term in P; change rhs with P; subst P
  end.

(* ************************************************************************** *)
(** ** Exploiting a hypothesis *)
(* ************************************************************************** *)

Tactic Notation "specialize_full" ident(H) :=
  let foo := fresh in
  evar (foo : Prop); cut (foo); subst foo; cycle 1; [eapply H|try clear H; intro H].

(** Exploit an assumption (adapted from CompCert). *)

Ltac exploit x :=
    refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _) _)
 || refine ((fun x y => y x) (x _ _) _)
 || refine ((fun x y => y x) (x _) _).


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 A1 A2 B1 B2 C1 C2 P Cprime B C D X Y : Universe, ((wd_ A1 A2 /\ (wd_ B1 B2 /\ (wd_ C1 C2 /\ (wd_ Cprime P /\ (wd_ B P /\ (wd_ P C /\ (wd_ P D /\ (wd_ P X /\ (wd_ A1 B1 /\ (wd_ A1 B2 /\ (wd_ Cprime B1 /\ (wd_ Cprime B2 /\ (wd_ P A1 /\ (wd_ P A2 /\ (wd_ P Y /\ (wd_ Cprime C /\ (wd_ A1 Cprime /\ (wd_ A2 Cprime /\ (wd_ A1 C1 /\ (wd_ A1 C2 /\ (wd_ A2 C1 /\ (wd_ A2 C2 /\ (wd_ A2 B1 /\ (wd_ A2 B2 /\ (col_ P B1 B2 /\ (col_ P C1 C2 /\ (col_ C1 C2 Cprime /\ (col_ B B1 B2 /\ (col_ X A1 Y /\ (col_ P C Y /\ (col_ P B X /\ (col_ P D A1 /\ (col_ B D C /\ (col_ Cprime P C /\ col_ A1 B Cprime)))))))))))))))))))))))))))))))))) -> col_ B1 B2 X)).
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 G Aprime Aprimeprime Bprime Cprime Bprimeprime Bprimeprimeprime : Universe, ((wd_ Aprime Bprimeprime /\ (wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ Bprime A /\ (wd_ Bprime C /\ (wd_ Aprime B /\ (wd_ Aprime C /\ (wd_ Cprime A /\ (wd_ Cprime B /\ (wd_ Aprimeprime Bprimeprime /\ (wd_ Aprime Bprimeprimeprime /\ (wd_ Aprime Bprime /\ (wd_ Bprime Bprimeprimeprime /\ (wd_ G Aprime /\ (wd_ G Aprimeprime /\ (wd_ G Bprimeprime /\ (wd_ Bprimeprime Bprimeprimeprime /\ (wd_ G Bprimeprimeprime /\ (wd_ Aprime Aprimeprime /\ (wd_ B G /\ (wd_ Bprimeprime B /\ (wd_ A G /\ (wd_ Aprimeprime A /\ (col_ Aprime Bprime Bprimeprimeprime /\ (col_ G Bprimeprime Bprimeprimeprime /\ (col_ Bprimeprime B G /\ (col_ Cprime A B /\ (col_ Bprime A C /\ (col_ G Aprime Aprimeprime /\ (col_ Aprimeprime A G /\ (col_ Aprime B C /\ col_ Bprime Aprime Bprimeprime)))))))))))))))))))))))))))))))) -> col_ A B G)).
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 O E Eprime A B C D U Bu Du Bprime Dprime Dprimeprime : Universe, ((wd_ U O /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ A O /\ (wd_ B O /\ (wd_ C O /\ (wd_ D O /\ (wd_ U Eprime /\ (wd_ A Eprime /\ (wd_ Bu O /\ (wd_ D Du /\ (wd_ B Bu /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C /\ (col_ O E D /\ (col_ O E U /\ (col_ O Eprime Bu /\ (col_ Bu A Eprime /\ (col_ O A Eprime /\ (col_ O E O /\ (col_ O Eprime Du /\ (col_ O Eprime Bprime /\ (col_ O Eprime Dprime /\ col_ O Eprime Dprimeprime))))))))))))))))))))))))) -> col_ O E Eprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import FcEtt.imports.

Require Export FcEtt.ett_ott.
Require Export FcEtt.utils.

(**************** Ext_Wf ****************)

Module Type ext_wf_sig.

Axiom ctx_wff_mutual :
  (forall G0 a A, Typing G0 a A -> Ctx G0) /\
  (forall G0 phi,   PropWff G0 phi -> Ctx G0) /\
  (forall G0 D p1 p2, Iso G0 D p1 p2 -> Ctx G0) /\
  (forall G0 D A B T,   DefEq G0 D A B T -> Ctx G0) /\
  (forall G0, Ctx G0 -> True).

Axiom lc_mutual :
  (forall G0 a A, Typing G0 a A -> lc_tm a /\ lc_tm A) /\
  (forall G0 phi,   PropWff G0 phi -> lc_constraint phi) /\
  (forall G0 D p1 p2, Iso G0 D p1 p2 -> lc_constraint p1 /\ lc_constraint p2) /\
  (forall G0 D A B T,   DefEq G0 D A B T -> lc_tm A /\ lc_tm B /\ lc_tm T) /\
  (forall G0, Ctx G0 -> forall x s , binds x s G0 -> lc_sort s).

Axiom Typing_lc  : forall G0 a A, Typing G0 a A -> lc_tm a /\ lc_tm A.
Axiom PropWff_lc : forall G0 phi,   PropWff G0 phi -> lc_constraint phi.
Axiom Iso_lc : forall G0 D p1 p2, Iso G0 D p1 p2 -> lc_constraint p1 /\ lc_constraint p2.
Axiom DefEq_lc : forall G0 D A B T,   DefEq G0 D A B T -> lc_tm A /\ lc_tm B /\ lc_tm T.

Axiom Typing_lc1 : forall G0 a A, Typing G0 a A -> lc_tm a.
Axiom Typing_lc2 : forall G0 a A, Typing G0 a A -> lc_tm A.

Axiom Iso_lc1 : forall G0 D p1 p2, Iso G0 D p1 p2 -> lc_constraint p1.
Axiom Iso_lc2 : forall G0 D p1 p2, Iso G0 D p1 p2 -> lc_constraint p2.

Axiom DefEq_lc1 : forall G0 D A B T,   DefEq G0 D A B T -> lc_tm A.
Axiom DefEq_lc2 : forall G0 D A B T,   DefEq G0 D A B T -> lc_tm B.
Axiom DefEq_lc3 : forall G0 D A B T,   DefEq G0 D A B T -> lc_tm T.

Axiom Ctx_lc : forall G0, Ctx G0 -> forall x s , binds x s G0 -> lc_sort s.

Axiom Ctx_uniq : forall G, Ctx G -> uniq G.

Axiom Toplevel_lc : forall c s, binds c s toplevel -> lc_sig_sort s.

(* Axiom Path_lc : forall T a, Path T a -> lc_tm a.

Axiom DataTy_lc : forall A, DataTy A a_Star -> lc_tm A. *)

Axiom Value_lc : forall A, Value A -> lc_tm A.

Axiom CoercedValue_lc : forall A, CoercedValue A -> lc_tm A.

End ext_wf_sig.

(**************** EXT Weak ****************)

Module Type ext_weak_sig.

Include ext_wf_sig.

Axiom weaken_available_mutual:
  (forall G1  a A,   Typing G1 a A -> True) /\
  (forall G1  phi,   PropWff G1 phi -> True) /\
  (forall G1 D p1 p2, Iso G1 D p1 p2 -> forall D', D [<=] D' -> Iso G1 D' p1 p2) /\
  (forall G1 D A B T,   DefEq G1 D A B T -> forall D', D [<=] D' -> DefEq G1 D' A B T) /\
  (forall G1 ,       Ctx G1 -> True).

Axiom respects_atoms_eq_mutual :
  (forall G a A,     Typing  G a A       -> True) /\
  (forall G phi,     PropWff G phi       -> True) /\
  (forall G D p1 p2, Iso G D p1 p2 -> forall D', D [=] D' -> Iso G D' p1 p2) /\
  (forall G D A B T,   DefEq G D A B T  -> forall D', D [=] D' -> DefEq G D' A B T) /\
  (forall G,           Ctx G           -> True).

Axiom remove_available_mutual:
  (forall G1  a A,   Typing G1 a A -> True) /\
  (forall G1  phi,   PropWff G1 phi -> True) /\
  (forall G1 D p1 p2, Iso G1 D p1 p2 ->
                   Iso G1 (AtomSetImpl.inter D (dom G1)) p1 p2) /\
  (forall G1 D A B T,   DefEq G1 D A B T ->
                   DefEq G1 (AtomSetImpl.inter D (dom G1)) A B T) /\
  (forall G1 ,       Ctx G1 -> True).

Axiom DefEq_weaken_available :
  forall G D A B T, DefEq G D A B T -> DefEq G (dom G) A B T.

Axiom Iso_weaken_available :
  forall G D A B, Iso G D A B -> Iso G (dom G) A B.

Axiom typing_weakening_mutual:
  (forall G0 a A,   Typing G0 a A ->
     forall E F G, (G0 = F ++ G) -> Ctx (F ++ E ++ G) -> Typing (F ++ E ++ G) a A) /\
  (forall G0 phi,   PropWff G0 phi ->
     forall E F G, (G0 = F ++ G) -> Ctx (F ++ E ++ G) -> PropWff (F ++ E ++ G) phi) /\
  (forall G0 D p1 p2, Iso G0 D p1 p2 ->
     forall E F G, (G0 = F ++ G) -> Ctx (F ++ E ++ G) -> Iso (F ++ E ++ G) D p1 p2) /\
  (forall G0 D A B T,   DefEq G0 D A B T ->
     forall E F G, (G0 = F ++ G) -> Ctx (F ++ E ++ G) -> DefEq (F ++ E ++ G) D A B T) /\
  (forall G0,       Ctx G0 ->
     forall E F G, (G0 = F ++ G) -> Ctx (F ++ E ++ G) -> Ctx (F ++ E ++ G)).

Definition Typing_weakening  := first  typing_weakening_mutual.
Definition PropWff_weakening := second typing_weakening_mutual.
Definition Iso_weakening     := third  typing_weakening_mutual.
Definition DefEq_weakening   := fourth typing_weakening_mutual.

End ext_weak_sig.

(**************** Ext Substitution ****************)

Module Type ext_subst_sig.
Include ext_weak_sig.

Axiom Ctx_strengthen : forall G1 G2, Ctx (G2 ++ G1) -> Ctx G1.

Axiom binds_to_PropWff: forall G0 A B T c,
    Ctx G0 ->
    binds c (Co (Eq A B T)) G0 -> PropWff G0 (Eq A B T).

Axiom tm_subst_tm_tm_dom_invariance: forall x a F,
    dom F = dom (map (tm_subst_tm_sort a x) F).

Axiom tm_subst_fresh_1 :
forall G a A a0 x s,
  Typing G a A -> Ctx ((x ~ s) ++ G) -> tm_subst_tm_tm a0 x A = A.

Axiom tm_subst_fresh_2 :
forall G a A a0 x s,
  Typing G a A -> Ctx ((x ~ s) ++ G) -> tm_subst_tm_tm a0 x a = a.

Axiom tm_subst_co_fresh_1 :
forall G a A a0 c s,
  Typing G a A -> Ctx ((c ~ s) ++ G) -> co_subst_co_tm a0 c A = A.

Axiom tm_substitution_mutual :  (forall G0 b B (H : Typing G0 b B),
      forall G a A, Typing G a A ->
               forall F x, G0 = (F ++ (x ~ Tm A) ++ G) ->
                      Typing (map (tm_subst_tm_sort a x) F ++ G)
                             (tm_subst_tm_tm a x b)
                             (tm_subst_tm_tm a x B)) /\
    (forall G0 phi (H : PropWff G0 phi),
        forall G a A, Typing G a A ->
                 forall F x, G0 = (F ++ (x ~ Tm A) ++ G) ->
                        PropWff (map (tm_subst_tm_sort a x) F ++ G)
                                (tm_subst_tm_constraint a x phi)) /\
    (forall G0 D p1 p2 (H : Iso G0 D p1 p2),
        forall G a A, Typing G a A ->
                 forall F x, G0 = (F ++ (x ~ Tm A) ++ G) ->
                Iso (map (tm_subst_tm_sort a x) F ++ G) D
                    (tm_subst_tm_constraint a x p1)
                    (tm_subst_tm_constraint a x p2)) /\
    (forall G0 D A B T (H : DefEq G0 D A B T),
       forall G a A0, Typing G a A0 ->
                 forall F x, G0 = (F ++ (x ~ Tm A0) ++ G) ->
                        DefEq (map (tm_subst_tm_sort a x) F ++ G) D
                              (tm_subst_tm_tm a x A)
                              (tm_subst_tm_tm a x B) (tm_subst_tm_tm a x T)) /\
    (forall G0 (H : Ctx G0),
        forall G a A, Typing G a A ->
                 forall F x, G0 = (F ++ (x ~ Tm A) ++ G) ->
                        Ctx (map (tm_subst_tm_sort a x) F ++ G)).

Axiom Typing_tm_subst : forall G x A b B (H : Typing ((x ~ Tm A) ++ G) b B),
  forall a, Typing G a A ->
       Typing G (tm_subst_tm_tm a x b) (tm_subst_tm_tm a x B).

Axiom co_substitution_mutual :
    (forall G0 b B (H : Typing G0 b B),
        forall G D A1 A2 T F c ,
          G0 = (F ++ (c ~ Co (Eq A1 A2 T) ) ++ G)
          -> DefEq G D A1 A2 T
          -> Typing (map (co_subst_co_sort g_Triv c) F ++ G) (co_subst_co_tm g_Triv c b) (co_subst_co_tm g_Triv c B)) /\
    (forall G0 phi (H : PropWff G0 phi),
        forall G D A1 A2 T F c,
          G0 = (F ++ (c ~ Co (Eq A1 A2 T) ) ++ G)
          -> DefEq G D A1 A2 T
          -> PropWff (map (co_subst_co_sort g_Triv c) F ++ G) (co_subst_co_constraint g_Triv c phi)) /\
    (forall G0 D0 p1 p2 (H : Iso G0 D0 p1 p2),
          forall G D A1 A2 T F c,
            G0 = (F ++ (c ~ Co (Eq A1 A2 T) ) ++ G)
            -> DefEq G D A1 A2 T
            -> Iso (map (co_subst_co_sort g_Triv c) F ++ G) (union D (remove c D0))
                    (co_subst_co_constraint g_Triv c p1)
                    (co_subst_co_constraint g_Triv c p2)) /\
    (forall G0 D0 A B T (H : DefEq G0 D0 A B T),
        forall G D F c A1 A2 T1,
          G0 = (F ++ (c ~ Co (Eq A1 A2 T1) ) ++ G)
          -> DefEq G D A1 A2 T1
          -> DefEq (map (co_subst_co_sort g_Triv c) F ++ G) (union D (remove c D0))
                  (co_subst_co_tm g_Triv c A) (co_subst_co_tm g_Triv c B)
                  (co_subst_co_tm g_Triv c T)) /\
    (forall G0 (H : Ctx G0),
        forall G D F c A1 A2 T,
          G0 = (F ++ (c ~ Co (Eq A1 A2 T) ) ++ G)
          -> DefEq G D A1 A2 T
          -> Ctx (map (co_subst_co_sort g_Triv c) F ++ G)).

Axiom Typing_co_subst:
   forall G D c a1 a2 A b B (H : Typing (c ~ (Co (Eq a1 a2 A)) ++ G) b B),
     DefEq G D a1 a2 A ->
     Typing G (co_subst_co_tm g_Triv c b) (co_subst_co_tm g_Triv c B).

Axiom Typing_swap : forall x1 x G a A B,
      x1 `notin` fv_tm_tm_tm a \u fv_tm_tm_tm B
    -> x `notin` dom G \u {{ x1 }}
    -> Typing ([(x1, Tm A)] ++ G) (open_tm_wrt_tm a (a_Var_f x1))
             (open_tm_wrt_tm B (a_Var_f x1))
    -> Typing ([(x, Tm A)] ++ G) (open_tm_wrt_tm a (a_Var_f x))
             (open_tm_wrt_tm B (a_Var_f x)).

Axiom E_Pi_exists : forall x (G : context) (rho : relflag) (A B : tm),
      x `notin` dom G \u fv_tm_tm_tm B
      -> Typing ([(x, Tm A)] ++ G) (open_tm_wrt_tm B (a_Var_f x)) a_Star
      -> Typing G A a_Star -> Typing G (a_Pi rho A B) a_Star.

Axiom E_Abs_exists :  forall x (G : context) (rho : relflag) (a A B : tm),
    x `notin` fv_tm_tm_tm a \u fv_tm_tm_tm B
    -> Typing ([(x, Tm A)] ++ G) (open_tm_wrt_tm a (a_Var_f x)) (open_tm_wrt_tm B (a_Var_f x))
    -> Typing G A a_Star
    -> RhoCheck rho x (open_tm_wrt_tm a (a_Var_f x))
    -> Typing G (a_UAbs rho a) (a_Pi rho A B).

End ext_subst_sig.

(**************** Ext invert ****************)

Module Type ext_invert_sig.
  Include ext_subst_sig.

(* ---------- inversion lemmas ---------------- *)

Axiom binds_to_Typing: forall G T A, Ctx G -> binds T (Tm A) G -> Typing G A a_Star.

(*Axiom invert_a_Const : forall G T A,
    Typing G (a_Const T) A ->
    exists B, DataTy B a_Star /\ DefEq G (dom G) A B  a_Star
         /\ binds T (Cs B) toplevel.
*)
Axiom invert_a_Pi: forall G rho A0 A B0,
    Typing G (a_Pi rho A0 B0) A ->
    DefEq G (dom G) A a_Star a_Star /\ (exists L, forall x, x `notin` L -> Typing ([(x, Tm A0)] ++ G) (open_tm_wrt_tm B0 (a_Var_f x)) a_Star) /\ Typing G A0 a_Star.

Axiom invert_a_CPi: forall G phi A B0,
    Typing G (a_CPi phi B0) A ->
      DefEq G (dom G) A a_Star a_Star /\ (exists L, forall c, c `notin` L -> Typing ([(c, Co phi)] ++ G) (open_tm_wrt_co B0 (g_Var_f c) ) a_Star) /\ PropWff G phi.

Axiom invert_a_App_Rel : forall G a b C,
    Typing G (a_App a Rel b) C ->
    exists A B, Typing G a (a_Pi Rel A B) /\
           Typing G b A /\
           DefEq G (dom G) C (open_tm_wrt_tm B b) a_Star.

Axiom invert_a_App_Irrel : forall G a b C,
    Typing G (a_App a Irrel b) C ->
    exists A B b0, Typing G a (a_Pi Irrel A B) /\
              Typing G b0 A /\
              DefEq G (dom G) C (open_tm_wrt_tm B b0) a_Star.

Axiom invert_a_CApp : forall G a g A,
    Typing G (a_CApp a g) A ->
    g = g_Triv /\
    exists a1 b1 A1 B, Typing G a (a_CPi (Eq a1 b1 A1) B) /\
             DefEq G (dom G) a1 b1 A1 /\
             DefEq G (dom G) A (open_tm_wrt_co B g_Triv) a_Star.

Axiom invert_a_UAbs:
  forall G rho A b0,
    Typing G (a_UAbs rho b0) A
    -> exists A1 B1, DefEq G (dom G) A (a_Pi rho A1 B1) a_Star
               /\ (exists L, forall x, x `notin` L ->
                            Typing ([(x, Tm A1)] ++ G)
                                   (open_tm_wrt_tm b0 (a_Var_f x))
                                   (open_tm_wrt_tm B1 (a_Var_f x))
                            /\ Typing ([(x, Tm A1)] ++ G)
                                     (open_tm_wrt_tm B1 (a_Var_f x)) a_Star
                            /\ RhoCheck rho x (open_tm_wrt_tm b0 (a_Var_f x)))
               /\ Typing G A1 a_Star.

Axiom invert_a_UCAbs: forall G A b0,
    Typing G (a_UCAbs b0) A ->
    exists a b T B1, PropWff G (Eq a b T)
                /\ DefEq G (dom G) A (a_CPi (Eq a b T) B1) a_Star /\
                (exists L, forall c, c `notin` L ->
                           Typing ([(c, Co (Eq a b T))] ++ G)
                                  (open_tm_wrt_co b0 (g_Var_f c))
                                  (open_tm_wrt_co B1 (g_Var_f c)) /\
                           Typing ([(c, Co (Eq a b T))] ++ G)
                                  (open_tm_wrt_co B1 (g_Var_f c)) a_Star).

Axiom invert_a_Var :
  forall G x A, Typing G (a_Var_f x) A -> exists A', binds x (Tm A') G /\ DefEq G (dom G) A A' a_Star.

Axiom invert_a_Star: forall A G, Typing G a_Star A -> DefEq G (dom G) A a_Star a_Star.

Axiom invert_a_Fam : forall G F A,
    Typing G (a_Fam F) A ->
    exists a B, DefEq G (dom G) A B a_Star /\
           binds F (Ax a B) toplevel /\ Typing nil B a_Star.

(* ---------- context conversion -------------- *)
(* Terms still type check even after varying the context *)

Inductive context_DefEq : available_props -> context -> context -> Prop :=
| Nul_Eqcontext: forall D, context_DefEq D nil nil
| Factor_Eqcontext_tm: forall G1 G2 D A A' x,
    context_DefEq D G1 G2 ->
    DefEq G1 D A A' a_Star ->
    DefEq G2 D A A' a_Star ->
    context_DefEq D ([(x, Tm A)] ++ G1) ([(x, Tm A')] ++ G2)
| Factor_Eqcontext_co: forall D G1 G2 Phi1 Phi2 c,
    context_DefEq D G1 G2 ->
    Iso G1 D Phi1 Phi2 ->
    Iso G2 D Phi1 Phi2 ->
    context_DefEq D ([(c, Co Phi1)] ++ G1) ([(c, Co Phi2)] ++ G2).

Axiom refl_context_defeq: forall G D, Ctx G -> context_DefEq D G G.

Axiom context_DefEq_weaken_available :
  forall D G1 G2, context_DefEq D G1 G2 -> context_DefEq (dom G1) G1 G2.

Axiom context_DefEq_typing:
  (forall G1  a A, Typing G1 a A -> forall D G2, Ctx G2 -> context_DefEq D G1 G2 -> Typing G2 a A).

(* ---------------- regularity lemmas ------------------- *)

Axiom Typing_regularity: forall e A G, Typing G e A -> Typing G A a_Star.

Axiom DefEq_regularity :
  forall G D A B T, DefEq G D A B T -> PropWff G (Eq A B T).

Axiom Iso_regularity :
  forall G D phi1 phi2, Iso G D phi1 phi2 -> PropWff G phi1 /\ PropWff G phi2.

Axiom PropWff_regularity :
  forall G A B T, PropWff G (Eq A B T) ->  Typing G A T /\ Typing  G B T.

(* ------- smart constructors --------- *)

Axiom DefEq_conv : forall G D a b A B, DefEq G D a b A -> DefEq G (dom G) A B a_Star -> DefEq G D a b B.

Axiom refl_iso: forall G D phi, PropWff G phi -> Iso G D phi phi.

Axiom sym_iso: forall G D phi1 phi2, Iso G D phi1 phi2 -> Iso G D phi2 phi1.

Axiom trans_iso : forall G D phi1 phi2 phi3, Iso G D phi1 phi2 -> Iso G D phi2 phi3 -> Iso G D phi1 phi3.

Axiom iso_cong : forall G D A A' B B' T T', DefEq G D A A' T -> DefEq G D B B' T -> DefEq G D T T' a_Star ->
                     Iso G D (Eq A B T) (Eq A' B' T').

Axiom E_PiCong2 :  ∀ (L : atoms) (G : context) (D : available_props) rho (A1 B1 A2 B2 : tm),
    DefEq G D A1 A2 a_Star
    → (∀ x : atom,
          x `notin` L
          → DefEq ([(x, Tm A1)] ++ G) D (open_tm_wrt_tm B1 (a_Var_f x))
                  (open_tm_wrt_tm B2 (a_Var_f x)) a_Star)
    → DefEq G D (a_Pi rho A1 B1) (a_Pi rho A2 B2) a_Star.

Axiom E_CPiCong2  : ∀ (L : atoms) (G : context) (D : available_props) (phi1 : constraint)
                      (A : tm) (phi2 : constraint) (B : tm),
    Iso G D phi1 phi2
    → (∀ c : atom,
          c `notin` L
              → DefEq ([(c, Co phi1)] ++ G) D (open_tm_wrt_co A (g_Var_f c))
                      (open_tm_wrt_co B (g_Var_f c)) a_Star)
    → DefEq G D (a_CPi phi1 A) (a_CPi phi2 B) a_Star.

Axiom E_Pi2 : forall L G rho A B,
    (∀ x : atom, x `notin` L → Typing ([(x, Tm A)] ++ G) (open_tm_wrt_tm B (a_Var_f x)) a_Star) ->
    Typing G (a_Pi rho A B) a_Star.

Axiom E_Abs2 : ∀ (L : atoms) (G : context) (rho : relflag) (a A B : tm),
    (∀ x : atom,
        x `notin` L → Typing ([(x, Tm A)] ++ G) (open_tm_wrt_tm a (a_Var_f x)) (open_tm_wrt_tm B (a_Var_f x)))
    → (∀ x : atom, x `notin` L → RhoCheck rho x (open_tm_wrt_tm a (a_Var_f x)))
    → Typing G (a_UAbs rho a) (a_Pi rho A B).

Axiom E_Conv2 : ∀ (G : context) (a B A : tm),
    Typing G a A → DefEq G (dom G) A B a_Star →
    Typing G a B.

Axiom E_CPi2 :  ∀ (L : atoms) (G : context) (phi : constraint) (B : tm),
    (∀ c : atom, c `notin` L → Typing ([(c, Co phi)] ++ G) (open_tm_wrt_co B (g_Var_f c)) a_Star) ->
    Typing G (a_CPi phi B) a_Star.

Axiom E_CAbs2 : ∀ (L : atoms) (G : context) (a : tm) (phi : constraint) (B : tm),
       (∀ c : atom,
        c `notin` L → Typing ([(c, Co phi)] ++ G) (open_tm_wrt_co a (g_Var_f c)) (open_tm_wrt_co B (g_Var_f c)))
       → Typing G (a_UCAbs a) (a_CPi phi B).

Axiom E_AbsCong2
     : ∀ (L : atoms) (G : context) (D : available_props) (rho : relflag) (b1 b2 A1 B : tm),
       (∀ x : atom,
        x `notin` L
        → DefEq ([(x, Tm A1)] ++ G) D (open_tm_wrt_tm b1 (a_Var_f x)) (open_tm_wrt_tm b2 (a_Var_f x))
            (open_tm_wrt_tm B (a_Var_f x)))
       → (∀ x : atom, x `notin` L → RhoCheck rho x (open_tm_wrt_tm b1 (a_Var_f x)))
       → (∀ x : atom, x `notin` L → RhoCheck rho x (open_tm_wrt_tm b2 (a_Var_f x)))
       → DefEq G D (a_UAbs rho b1) (a_UAbs rho b2) (a_Pi rho A1 B).

Axiom E_CAbsCong2
     : ∀ (L : atoms) (G : context) (D : available_props) (a b : tm) (phi1 : constraint)
       (B : tm),
       (∀ c : atom,
        c `notin` L
        → DefEq ([(c, Co phi1)] ++ G) D (open_tm_wrt_co a (g_Var_f c)) (open_tm_wrt_co b (g_Var_f c))
                (open_tm_wrt_co B (g_Var_f c))) → DefEq G D (a_UCAbs a) (a_UCAbs b) (a_CPi phi1 B).

End ext_invert_sig.

(**************** FC Wf ****************)

Module Type fc_wf_sig.

Axiom AnnTyping_AnnCtx  : forall G0 a A, AnnTyping G0 a A -> AnnCtx G0.
Axiom AnnPropWff_AnnCtx : forall G0 phi, AnnPropWff G0 phi -> AnnCtx G0.
Axiom AnnIso_AnnCtx     : forall G0 D g p1 p2, AnnIso G0 D g p1 p2 -> AnnCtx G0.
Axiom AnnDefEq_AnnCtx   : forall G0 D g A B,   AnnDefEq G0 D g A B -> AnnCtx G0.

Axiom AnnCtx_uniq : forall G, AnnCtx G -> uniq G.

Axiom AnnTyping_lc  :  forall G0 a A, AnnTyping G0 a A -> lc_tm a /\ lc_tm A.
Axiom AnnPropWff_lc : forall G0 phi, AnnPropWff G0 phi -> lc_constraint phi.
Axiom AnnIso_lc :  forall G0 D g p1 p2, AnnIso G0 D g p1 p2 -> lc_constraint p1 /\ lc_constraint p2 /\ lc_co g.
Axiom AnnDefEq_lc : forall G0 D g A B,  AnnDefEq G0 D g A B -> lc_tm A /\ lc_tm B /\ lc_co g.
Axiom AnnCtx_lc : forall G0, AnnCtx G0 -> forall x s , binds x s G0 -> lc_sort s.

Axiom AnnTyping_lc1 : forall G a A, AnnTyping G a A -> lc_tm a.
Axiom AnnTyping_lc2 : forall G a A, AnnTyping G a A -> lc_tm A.
Axiom AnnIso_lc1 : forall G D g p1 p2, AnnIso G D g p1 p2 -> lc_constraint p1.
Axiom AnnIso_lc2 : forall G D g p1 p2, AnnIso G D g p1 p2 -> lc_constraint p2.
Axiom AnnIso_lc3 : forall G D g p1 p2, AnnIso G D g p1 p2 -> lc_co g.
Axiom AnnDefEq_lc1 : forall G D g A B,  AnnDefEq G D g A B -> lc_tm A.
Axiom AnnDefEq_lc2 : forall G D g A B,  AnnDefEq G D g A B -> lc_tm B.
Axiom AnnDefEq_lc3 : forall G D g A B,  AnnDefEq G D g A B -> lc_co g.

Axiom AnnToplevel_lc : forall c s, binds c s an_toplevel -> lc_sig_sort s.

End fc_wf_sig.

(**************** FC Weakening ****************)

Module Type fc_weak_sig.

Axiom ann_respects_atoms_eq_mutual :
  (forall G a A,       AnnTyping  G a A       -> True) /\
  (forall G phi,       AnnPropWff G phi       -> True) /\
  (forall G D g p1 p2, AnnIso     G D g p1 p2 -> forall D', D [=] D' -> AnnIso   G D' g p1 p2) /\
  (forall G D g A B,   AnnDefEq   G D g A B   -> forall D', D [=] D' -> AnnDefEq G D' g A B) /\
  (forall G,           AnnCtx     G           -> True).

Definition AnnIso_respects_atoms_eq   := third  ann_respects_atoms_eq_mutual.
Definition AnnDefEq_respects_atoms_eq := fourth ann_respects_atoms_eq_mutual.

Axiom ann_strengthen_noncovar:
  (forall G1  a A,   AnnTyping G1 a A -> True) /\
  (forall G1  phi,   AnnPropWff G1 phi -> True) /\
  (forall G1 D g p1 p2, AnnIso G1 D g p1 p2 -> forall x, not (exists phi, binds x (Co phi) G1) ->
                     AnnIso G1 (remove x D) g p1 p2) /\
  (forall G1 D g A B,   AnnDefEq G1 D g A B ->  forall x, not (exists phi, binds x (Co phi) G1) ->
                    AnnDefEq G1 (remove x D) g A B) /\
  (forall G1 ,       AnnCtx G1 -> True).

Axiom AnnDefEq_strengthen_available_tm :
  forall G D g A B, AnnDefEq G D g A B ->  forall x A', binds x (Tm A') G ->
                    forall D', D' [=] remove x D ->
                    AnnDefEq G D' g A B.

Axiom ann_weaken_available_mutual:
  (forall G1  a A,   AnnTyping G1 a A -> True) /\
  (forall G1  phi,   AnnPropWff G1 phi -> True) /\
  (forall G1 D g p1 p2, AnnIso G1 D g p1 p2 -> forall D', D [<=] D' -> AnnIso G1 D' g p1 p2) /\
  (forall G1 D g A B,   AnnDefEq G1 D g A B -> forall D', D [<=] D' -> AnnDefEq G1 D' g A B) /\
  (forall G1 ,       AnnCtx G1 -> True).

Axiom ann_remove_available_mutual:
  (forall G1  a A,   AnnTyping G1 a A -> True) /\
  (forall G1  phi,   AnnPropWff G1 phi -> True) /\
  (forall G1 D g p1 p2, AnnIso G1 D g p1 p2 ->
                   AnnIso G1 (AtomSetImpl.inter D (dom G1)) g p1 p2) /\
  (forall G1 D g A B,   AnnDefEq G1 D g A B ->
                   AnnDefEq G1 (AtomSetImpl.inter D (dom G1)) g A B) /\
  (forall G1 ,       AnnCtx G1 -> True).

Axiom AnnDefEq_weaken_available :
  forall G D g A B, AnnDefEq G D g A B -> AnnDefEq G (dom G) g A B.

Axiom AnnIso_weaken_available :
  forall G D g A B, AnnIso G D g A B -> AnnIso G (dom G) g A B.

Axiom ann_typing_weakening_mutual:
  (forall G0 a A,       AnnTyping  G0 a A       ->
     forall E F G, (G0 = F ++ G) -> AnnCtx (F ++ E ++ G) -> AnnTyping (F ++ E ++ G) a A) /\
  (forall G0 phi,       AnnPropWff G0 phi       ->
     forall E F G, (G0 = F ++ G) ->
        AnnCtx (F ++ E ++ G) -> AnnPropWff (F ++ E ++ G) phi) /\
  (forall G0 D g p1 p2, AnnIso     G0 D g p1 p2 ->
     forall E F G, (G0 = F ++ G) ->
        AnnCtx (F ++ E ++ G) -> AnnIso (F ++ E ++ G) D g p1 p2) /\
  (forall G0 D g A B,   AnnDefEq   G0 D g A B   ->
     forall E F G, (G0 = F ++ G) ->
        AnnCtx (F ++ E ++ G) -> AnnDefEq (F ++ E ++ G) D g A B) /\
  (forall G0,           AnnCtx     G0           ->
     forall E F G, (G0 = F ++ G) ->
        AnnCtx (F ++ E ++ G) -> AnnCtx (F ++ E ++ G)).

Definition AnnTyping_weakening  := first  ann_typing_weakening_mutual.
Definition AnnPropWff_weakening := second ann_typing_weakening_mutual.
Definition AnnIso_weakening     := third  ann_typing_weakening_mutual.
Definition AnnDefEq_weakening   := fourth ann_typing_weakening_mutual.
Definition AnnCtx_weakening     := fifth  ann_typing_weakening_mutual.

End fc_weak_sig.

(**************** FC Substitution ****************)
Module Type fc_subst_sig.

  (*
  Axiom context_fv_mutual :
  (forall G (a : tm) A (H: AnnTyping G a A),
      fv_tm_tm_tm a [<=] dom G /\ fv_co_co_tm a [<=] dom G /\
      fv_tm_tm_tm A [<=] dom G /\ fv_co_co_tm A [<=] dom G)
  /\
  (forall G phi (H : AnnPropWff G phi),
      fv_tm_tm_constraint phi [<=] dom G /\ fv_co_co_constraint phi [<=] dom G)
  /\
  (forall G D g p1 p2 (H : AnnIso G D g p1 p2),
      fv_tm_tm_co         g  [<=] dom G /\ fv_co_co_co         g  [<=] dom G /\
      fv_tm_tm_constraint p1 [<=] dom G /\ fv_co_co_constraint p1 [<=] dom G /\
      fv_tm_tm_constraint p2 [<=] dom G /\ fv_co_co_constraint p2 [<=] dom G)
  /\
  (forall G D g A B (H : AnnDefEq G D g A B),
      fv_tm_tm_co g [<=] dom G /\ fv_co_co_co g [<=] dom G /\
      fv_tm_tm_tm A [<=] dom G /\ fv_co_co_tm A [<=] dom G /\
      fv_tm_tm_tm B [<=] dom G /\ fv_co_co_tm B [<=] dom G)
  /\
  (forall G (H : AnnCtx G),
      (forall x A,
          binds x (Tm A)   G ->
          fv_tm_tm_tm         A   [<=] dom G /\ fv_co_co_tm         A   [<=] dom G) /\
      (forall c phi,
          binds c (Co phi) G ->
          fv_tm_tm_constraint phi [<=] dom G /\ fv_co_co_constraint phi [<=] dom G)).

  Definition AnnTyping_context_fv  := @first  _ _ _ _ _ context_fv_mutual.
  Definition AnnPropWff_context_fv := @second _ _ _ _ _ context_fv_mutual.
  Definition AnnIso_context_fv     := @third  _ _ _ _ _ context_fv_mutual.
  Definition AnnDefEq_context_fv   := @fourth _ _ _ _ _ context_fv_mutual.
  Definition AnnCtx_context_fv     := @fifth  _ _ _ _ _ context_fv_mutual.
*)

  Axiom AnnCtx_strengthen : forall G1 G2, AnnCtx (G2 ++ G1) -> AnnCtx G1.

  Axiom binds_to_AnnTyping :
    forall G x A, AnnCtx G -> binds x (Tm A) G -> AnnTyping G A a_Star.

  Axiom binds_to_AnnPropWff: forall G0 a b A c,
      AnnCtx G0 -> binds c (Co (Eq a b A)) G0 -> AnnPropWff G0 (Eq a b A).

  Axiom tm_subst_fresh_1 :
  forall G a A a0 x s,
    AnnTyping G a A -> AnnCtx ((x ~ s) ++ G) -> tm_subst_tm_tm a0 x A = A.

  Axiom tm_subst_fresh_2 :
  forall G a A a0 x s,
    AnnTyping G a A -> AnnCtx ((x ~ s) ++ G) -> tm_subst_tm_tm a0 x a = a.

  Axiom ann_tm_substitution_mutual :
  (forall G0 b B (H : AnnTyping G0 b B),
      forall G a A, AnnTyping G a A ->
               forall F x, G0 = (F ++ (x ~ Tm A) ++ G) ->
                      AnnTyping (map (tm_subst_tm_sort a x) F ++ G)
                                (tm_subst_tm_tm a x b)
                                (tm_subst_tm_tm a x B)) /\
  (forall G0 phi (H : AnnPropWff G0 phi),
      forall G a A, AnnTyping G a A ->
               forall F x, G0 = (F ++ (x ~ Tm A) ++ G) ->
                      AnnPropWff (map (tm_subst_tm_sort a x) F ++ G)
                                 (tm_subst_tm_constraint a x phi)) /\
  (forall G0 D g p1 p2 (H : AnnIso G0 D g p1 p2),
      forall G a A, AnnTyping G a A ->
               forall F x, G0 = (F ++ (x ~ Tm A) ++ G) ->
                      AnnIso (map (tm_subst_tm_sort a x) F ++ G)
                             D
                             (tm_subst_tm_co a x g)
                             (tm_subst_tm_constraint a x p1)
                             (tm_subst_tm_constraint a x p2)) /\
  (forall  G0 D g A B (H : AnnDefEq G0 D g A B),
      forall G a A0, AnnTyping G a A0 ->
                forall F x, G0 = (F ++ (x ~ Tm A0) ++ G) ->
                       AnnDefEq (map (tm_subst_tm_sort a x) F ++ G)
                                D
                                (tm_subst_tm_co a x g)
                                (tm_subst_tm_tm a x A)
                                (tm_subst_tm_tm a x B)) /\
  (forall G0 (H : AnnCtx G0),
  forall G a A, AnnTyping G a A ->
  forall F x, G0 = (F ++ (x ~ Tm A) ++ G) ->
                AnnCtx (map (tm_subst_tm_sort a x) F ++ G)).

  Axiom AnnTyping_tm_subst : forall G x A b B (H : AnnTyping ((x ~ Tm A) ++ G) b B),
    forall a, AnnTyping G a A ->
         AnnTyping G (tm_subst_tm_tm a x b) (tm_subst_tm_tm a x B).

  Axiom AnnTyping_tm_subst_nondep : forall L G a A b B,
      AnnTyping G a A ->
      (forall x, x `notin` L -> AnnTyping ([(x,Tm A)] ++ G) (open_tm_wrt_tm b (a_Var_f x)) B) ->
      AnnTyping G (open_tm_wrt_tm b a) B.

  Axiom AnnTyping_co_subst : forall G x A1 A2 A3 b B
                               (H : AnnTyping ((x ~ Co (Eq A1 A2 A3)) ++ G) b B),
    forall D a, AnnDefEq G D a A1 A2 ->
         AnnTyping G (co_subst_co_tm a x b) (co_subst_co_tm a x B).

  Axiom AnnTyping_co_subst_nondep : forall L G D g A1 A2 A3 b B,
      AnnDefEq G D g A1 A2 ->
      (forall x, x `notin` L -> AnnTyping ([(x,Co (Eq A1 A2 A3))] ++ G) (open_tm_wrt_co b (g_Var_f x)) B) ->
      AnnTyping G (open_tm_wrt_co b g) B.

  (* -----  exists forms of the binding constructors ----------- *)

  Axiom An_Pi_exists : forall x G rho A B,
      x `notin` dom G \u fv_tm_tm_tm B
    → AnnTyping ([(x, Tm A)] ++ G)
                (open_tm_wrt_tm B (a_Var_f x)) a_Star
    → AnnTyping G A a_Star
    → AnnTyping G (a_Pi rho A B) a_Star.

  Axiom An_Abs_exists :   forall x (G:context) rho (A a B:tm),
       x \notin dom G \u fv_tm_tm_tm a \u fv_tm_tm_tm B ->
       AnnTyping G A a_Star ->
       AnnTyping  (( x ~ Tm  A) ++ G) (open_tm_wrt_tm a (a_Var_f x))
                  (open_tm_wrt_tm B (a_Var_f x))  ->
       RhoCheck rho x (erase_tm (open_tm_wrt_tm a (a_Var_f x))) ->
        AnnTyping G (a_Abs rho A a) (a_Pi rho A B).

  Axiom An_CPi_exists :  ∀ c (G : context) (phi : constraint) (B : tm),
          c \notin dom G \u fv_co_co_tm B ->
         AnnPropWff G phi
         → AnnTyping ([(c, Co phi)] ++ G) (open_tm_wrt_co B (g_Var_f c)) a_Star
         → AnnTyping G (a_CPi phi B) a_Star.

  Axiom An_CAbs_exists :  ∀ c (G : context) (phi : constraint) (a B : tm),
      c \notin dom G \u fv_co_co_tm a \u fv_co_co_tm B ->
         AnnPropWff G phi
         → AnnTyping ([(c, Co phi)] ++ G) (open_tm_wrt_co a (g_Var_f c))
                (open_tm_wrt_co B (g_Var_f c))
         → AnnTyping G (a_CAbs phi a) (a_CPi phi B).

  Axiom An_CAbs_inversion : ∀ (G : context) (phi : constraint) (a A : tm),
    AnnTyping G (a_CAbs phi a) A ->
      exists B, A = (a_CPi phi B) /\
      forall c, c  `notin` dom G (* \u fv_co_co_tm a \u fv_co_co_tm B *) ->
        AnnPropWff G phi /\
        AnnTyping ([(c, Co phi)] ++ G) (open_tm_wrt_co a (g_Var_f c))
                  (open_tm_wrt_co B (g_Var_f c)).

  Axiom An_AbsCong_exists : ∀ x1 x2 (G : context) D rho (g1 g2 : co) (A1 b1 A2 b3 b2 B : tm),
      x1 `notin` (dom G \u fv_tm_tm_tm b1 \u fv_tm_tm_tm b2 \u  fv_tm_tm_co g2)
      -> x2 `notin` (dom G \u fv_tm_tm_tm b2 \u fv_tm_tm_tm b3 \u  fv_tm_tm_co g1)
      ->  AnnDefEq G D g1 A1 A2
      → (AnnDefEq ([(x1, Tm A1)] ++ G) D  (open_co_wrt_tm g2 (a_Var_f x1))
                  (open_tm_wrt_tm b1 (a_Var_f x1)) (open_tm_wrt_tm b2 (a_Var_f x1)))
      → (open_tm_wrt_tm b3 (a_Var_f x2) =
         open_tm_wrt_tm b2 (a_Conv (a_Var_f x2) (g_Sym g1)))
      → AnnTyping G A1 a_Star
      → AnnTyping G A2 a_Star
      → RhoCheck rho x1 (erase_tm (open_tm_wrt_tm b1 (a_Var_f x1)))
      → RhoCheck rho x2 (erase_tm (open_tm_wrt_tm b3 (a_Var_f x2)))
      → AnnTyping G (a_Abs rho A1 b2) B
      → AnnDefEq G D (g_AbsCong rho g1 g2) (a_Abs rho A1 b1) (a_Abs rho A2 b3).

  Axiom An_AbsCong_inversion :
    forall G D rho g1 g2 B1 B2,
      AnnDefEq G D (g_AbsCong rho g1 g2) B1 B2 ->
    exists A1 A2 b1 b2 b3 B,
      B1 = (a_Abs rho A1 b1) /\
      B2 = (a_Abs rho A2 b3) /\
      AnnTyping G A1 a_Star  /\
      AnnTyping G A2 a_Star  /\
      AnnDefEq G D g1 A1 A2  /\
      AnnTyping G (a_Abs rho A1 b2) B /\
      (forall x, x \notin dom G  (* \u fv_tm_tm_tm b1 \u fv_tm_tm_tm b2 \u fv_tm_tm_tm b3 *) ->
          AnnDefEq  (( x ~ Tm A1) ++  G) D (open_co_wrt_tm g2 (a_Var_f x)) (open_tm_wrt_tm b1 (a_Var_f x))  ((open_tm_wrt_tm b2 (a_Var_f x))) /\
          (open_tm_wrt_tm b3 (a_Var_f x)) = (open_tm_wrt_tm b2 (a_Conv (a_Var_f x) (g_Sym g1))) /\
          (RhoCheck rho x  (erase_tm (open_tm_wrt_tm b1 (a_Var_f x)))) /\
          (RhoCheck rho x  (erase_tm (open_tm_wrt_tm b3 (a_Var_f x))))).

  Axiom An_CPiCong_exists : ∀ c1 c2 (G : context) D (g1 g3 : co) (phi1 : constraint)
       (B1 : tm) (phi2 : constraint) (B3 B2 : tm),
    AnnIso G D g1 phi1 phi2
    -> c1 `notin` D \u fv_co_co_tm B2 \u fv_co_co_tm B1 \u fv_co_co_co g3
    -> c2 `notin` fv_co_co_co g1 \u fv_co_co_tm B2 \u fv_co_co_tm B3
    → (AnnDefEq ([(c1, Co phi1)] ++ G) D (open_co_wrt_co g3 (g_Var_f c1))
                (open_tm_wrt_co B1 (g_Var_f c1)) (open_tm_wrt_co B2 (g_Var_f c1)))
    → (open_tm_wrt_co B3 (g_Var_f c2) =
       open_tm_wrt_co B2 (g_Cast (g_Var_f c2) (g_Sym g1)))
    → AnnTyping G (a_CPi phi1 B1) a_Star
    → AnnTyping G (a_CPi phi2 B3) a_Star
    -> AnnTyping G (a_CPi phi1 B2) a_Star
    → AnnDefEq G D (g_CPiCong g1 g3) (a_CPi phi1 B1)
               (a_CPi phi2 B3).

  Axiom An_CPiCong_inversion :  ∀ (G : context) D (g1 g3 : co) (A1 A2 : tm),
    AnnDefEq G D (g_CPiCong g1 g3) A1 A2 ->
      exists phi1 phi2 B1 B2 B3,
        A1 = (a_CPi phi1 B1) /\
        A2 = (a_CPi phi2 B3) /\
        AnnIso G D g1 phi1 phi2 /\
        AnnTyping G (a_CPi phi1 B1) a_Star /\
        AnnTyping G (a_CPi phi2 B3) a_Star /\
        AnnTyping G (a_CPi phi1 B2) a_Star /\
        (forall c, c `notin` dom G (* \u D \u fv_co_co_tm B2 \u fv_co_co_tm B1
             \u fv_co_co_co g3 \u
                fv_co_co_co g1 \u fv_co_co_tm B3 *) →
          (AnnDefEq ([(c, Co phi1)] ++ G) D (open_co_wrt_co g3 (g_Var_f c))
          (open_tm_wrt_co B1 (g_Var_f c)) (open_tm_wrt_co B2 (g_Var_f c))) /\
          (open_tm_wrt_co B3 (g_Var_f c) = open_tm_wrt_co B2 (g_Cast (g_Var_f c) (g_Sym g1)))).

  Axiom An_PiCong_exists : forall x1 x2 (G:context) D rho
                             (g1 g2 : co) (A1 B1 A2 B3 B2 : tm),
      x1 `notin` (dom G \u fv_tm_tm_tm B1 \u fv_tm_tm_tm B2 \u  fv_tm_tm_co g2)
      -> x2 `notin` (dom G \u fv_tm_tm_tm B2 \u fv_tm_tm_tm B3 \u  fv_tm_tm_co g1)
      ->  AnnDefEq G D g1 A1 A2
      → AnnDefEq ([(x1, Tm A1)] ++ G) D (open_co_wrt_tm g2 (a_Var_f x1))
                 (open_tm_wrt_tm B1 (a_Var_f x1)) (open_tm_wrt_tm B2 (a_Var_f x1))
      → (open_tm_wrt_tm B3 (a_Var_f x2) =
         open_tm_wrt_tm B2 (a_Conv (a_Var_f x2) (g_Sym g1)))
      → AnnTyping G (a_Pi rho A1 B1) a_Star
      → AnnTyping G (a_Pi rho A2 B3) a_Star
      → AnnTyping G (a_Pi rho A1 B2) a_Star
      → AnnDefEq G D (g_PiCong rho g1 g2) (a_Pi rho A1 B1) (a_Pi rho A2 B3).

  Axiom An_PiCong_inversion : forall (G:context) (D:available_props) (rho:relflag) (g1 g2:co) (C1 C2 :tm),
    AnnDefEq G D (g_PiCong rho g1 g2) C1 C2 ->
      exists A1 B1 A2 B2 B3,
      C1 = (a_Pi rho A1 B1) /\
      C2 = (a_Pi rho A2 B3) /\
      AnnTyping G (a_Pi rho A1 B1) a_Star /\
      AnnTyping G (a_Pi rho A2 B3) a_Star /\
      AnnTyping G (a_Pi rho A1 B2) a_Star /\
      AnnDefEq G D g1 A1 A2 /\
      (forall x , x \notin dom G  ->
            AnnDefEq  ((x ~ Tm  A1) ++ G) D (open_co_wrt_tm g2 (a_Var_f x)) (open_tm_wrt_tm B1 (a_Var_f x)) ((open_tm_wrt_tm B2 (a_Var_f x)))  /\
            (open_tm_wrt_tm B3 (a_Var_f x)  = (open_tm_wrt_tm  B2 (a_Conv (a_Var_f x) (g_Sym g1))))).

  Axiom An_CAbsCong_exists :
  forall c1 c2 (G : context) (D : available_props) (g1 g3 g4 : co)
    (phi1 : constraint) (a1 : tm) (phi2 : constraint) (a3 a2 B1 B2 B: tm),
    AnnIso G D g1 phi1 phi2
    -> c1 `notin` D \u fv_co_co_tm a2 \u fv_co_co_tm a1 \u fv_co_co_co g3
    -> c2 `notin` fv_co_co_co g1 \u fv_co_co_tm a2 \u fv_co_co_tm a3
    → (AnnDefEq ([(c1, Co phi1)] ++ G) D (open_co_wrt_co g3 (g_Var_f c1))
                (open_tm_wrt_co a1 (g_Var_f c1)) (open_tm_wrt_co a2 (g_Var_f c1)))
    → (open_tm_wrt_co a3 (g_Var_f c2) =
       open_tm_wrt_co a2 (g_Cast (g_Var_f c2) (g_Sym g1)))
    → AnnTyping G (a_CAbs phi1 a1) (a_CPi phi1 B1)
    → AnnTyping G (a_CAbs phi2 a3) (a_CPi phi2 B2)
    → AnnDefEq G (dom G) g4 (a_CPi phi1 B1) (a_CPi phi2 B2)
    -> AnnTyping G (a_CAbs phi1 a2) B
    → AnnDefEq G D (g_CAbsCong g1 g3 g4) (a_CAbs phi1 a1) (a_CAbs phi2 a3).

  Axiom An_CAbsCong_inversion :
  forall (G : context) (D : available_props) (g1 g3 g4 : co) A1 A2,
    AnnDefEq G D (g_CAbsCong g1 g3 g4) A1 A2
    -> exists phi1 phi2 a1 a2 a3 B1 B2 B,
      A1 = (a_CAbs phi1 a1) /\
      A2 = (a_CAbs phi2 a3) /\
      AnnIso G D g1 phi1 phi2 /\
      AnnTyping G (a_CAbs phi1 a1) (a_CPi phi1 B1) /\
      AnnTyping G (a_CAbs phi2 a3) (a_CPi phi2 B2) /\
      AnnTyping G (a_CAbs phi1 a2) B /\
      AnnDefEq G (dom G) g4 (a_CPi phi1 B1) (a_CPi phi2 B2) /\
 forall c1,
      c1`notin` dom G (* \u D \u fv_co_co_tm a2 \u fv_co_co_tm a1 \u fv_co_co_co g3
                  \u fv_co_co_co g1 \u fv_co_co_tm a3 *)
    → (AnnDefEq ([(c1, Co phi1)] ++ G) D (open_co_wrt_co g3 (g_Var_f c1))
                (open_tm_wrt_co a1 (g_Var_f c1)) (open_tm_wrt_co a2 (g_Var_f c1))) /\
      (open_tm_wrt_co a3 (g_Var_f c1) =
       open_tm_wrt_co a2 (g_Cast (g_Var_f c1) (g_Sym g1))).

  (* -----  inversion lemmas for some typing judgments (with maximal co-finite quantification) ----------- *)

  Axiom An_Pi_inversion :
    ∀ (G:context) rho A B T,
      AnnTyping G (a_Pi rho A B) T ->
      T = a_Star /\
      AnnTyping G A a_Star /\
      ∀ x, x \notin dom G -> AnnTyping (( x ~ Tm  A) ++ G) (open_tm_wrt_tm B (a_Var_f x)) a_Star.

  Axiom An_Abs_inversion :
    ∀ (G:context) rho (a:tm) A A1,
    AnnTyping G (a_Abs rho A a) A1 ->
    (exists B, A1 = a_Pi rho A B /\
    AnnTyping G A a_Star /\
    ∀ x, x \notin dom G ->
      RhoCheck rho x (erase_tm (open_tm_wrt_tm a (a_Var_f x))) /\
      AnnTyping (( x ~ Tm  A) ++ G)
                (open_tm_wrt_tm a (a_Var_f x))
                (open_tm_wrt_tm B (a_Var_f x))).

  Axiom An_CPi_inversion :
    ∀ (G:context) (phi : constraint) (B T : tm),
      AnnTyping G (a_CPi phi B) T ->
      T = a_Star /\
      AnnPropWff G phi /\
      ∀ c, c \notin dom G -> AnnTyping ([(c, Co phi)] ++ G) (open_tm_wrt_co B (g_Var_f c)) a_Star.

  (* -------------- name swapping ------------------------ *)

  Axiom AnnTyping_tm_swap : forall c c0 B G a A,
    c `notin` fv_tm_tm_tm A ->
    c `notin` fv_tm_tm_tm a ->
    c0 `notin` dom G \u {{ c }} ->
    AnnTyping ([(c, Tm B)] ++ G) (open_tm_wrt_tm a (a_Var_f c))
         (open_tm_wrt_tm A (a_Var_f c)) ->
    AnnTyping ([(c0, Tm B)] ++ G) (open_tm_wrt_tm a (a_Var_f c0))
                  (open_tm_wrt_tm A (a_Var_f c0)).

  Axiom AnnDefEq_tm_swap : forall x1 x G A1 D g2 b1 b2,
   x1 `notin` fv_tm_tm_co g2 \u fv_tm_tm_tm b1 \u fv_tm_tm_tm b2
  -> x `notin` dom G \u {{ x1 }}
  -> AnnDefEq ([(x1, Tm A1)] ++ G) D  (open_co_wrt_tm g2 (a_Var_f x1))
             (open_tm_wrt_tm b1 (a_Var_f x1)) (open_tm_wrt_tm b2 (a_Var_f x1))
  -> AnnDefEq ([(x, Tm A1)] ++ G) D  (open_co_wrt_tm g2 (a_Var_f x))
             (open_tm_wrt_tm b1 (a_Var_f x)) (open_tm_wrt_tm b2 (a_Var_f x)).

 Axiom AnnTyping_co_swap : forall c c0 phi G a A,
    c `notin` fv_co_co_tm A ->
    c `notin` fv_co_co_tm a ->
    c0 `notin` dom G \u {{ c }} ->
    AnnTyping ([(c, Co phi)] ++ G) (open_tm_wrt_co a (g_Var_f c))
         (open_tm_wrt_co A (g_Var_f c)) ->
    AnnTyping ([(c0, Co phi)] ++ G) (open_tm_wrt_co a (g_Var_f c0))
                  (open_tm_wrt_co A (g_Var_f c0)).

  Axiom AnnDefEq_co_swap : forall c1 c phi1 G D g3 B1 B2,
    c1 `notin` D \u fv_co_co_tm B1 \u fv_co_co_tm B2 \u fv_co_co_co g3 ->
    c `notin` dom G \u {{ c1 }} ->
    (AnnDefEq ([(c1, Co phi1)] ++ G) D (open_co_wrt_co g3 (g_Var_f c1))
              (open_tm_wrt_co B1 (g_Var_f c1)) (open_tm_wrt_co B2 (g_Var_f c1)))
    -> (AnnDefEq ([(c, Co phi1)] ++ G) D (open_co_wrt_co g3 (g_Var_f c))
              (open_tm_wrt_co B1 (g_Var_f c)) (open_tm_wrt_co B2 (g_Var_f c))).

  Create HintDb smart_cons_exists discriminated.
  Hint Resolve An_Pi_exists An_Abs_exists An_CPi_exists An_CAbs_exists An_AbsCong_exists An_CPiCong_exists An_CAbsCong_exists : smart_cons_exists.

End fc_subst_sig.

(**************** FC Uniqueness ****************)
Module Type fc_unique_sig.

Axiom AnnTyping_unique :
    forall G a A1, AnnTyping G a A1 -> forall {A2}, AnnTyping G a A2 -> A1 = A2.
Axiom AnnIso_unique  :
  forall G D g p1 p2, AnnIso G D g p1 p2 ->
                 forall {q1 q2}, AnnIso G D g q1 q2 -> p1 = q1 /\ p2 = q2.
Axiom AnnDefEq_unique    :
  forall G D g a b,
      AnnDefEq G D g a b -> forall {a1 b1}, AnnDefEq G D g a1 b1 -> a = a1 /\ b = b1.

End fc_unique_sig.


(* -------------------------------------------------------------------- *)
From mathcomp Require Import all_ssreflect all_algebra.
From mathcomp.analysis Require Import boolp reals distr.
(* ------- *) Require Import inhabited notations.

Require Import Eqdep_dec.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Import GRing.Theory Num.Theory.

Local Open Scope ring_scope.

(* -------------------------------------------------------------------- *)
Declare Scope syn_scope.
Declare Scope xsyn_scope.
Declare Scope vsyn_scope.
Declare Scope mem_scope.

Delimit Scope syn_scope with S.
Delimit Scope xsyn_scope with X.
Delimit Scope vsyn_scope with V.
Delimit Scope mem_scope with M.

(* -------------------------------------------------------------------- *)
Parameter R : realType.

Canonical real_ihbType := Eval hnf in IhbType R 0.

Notation Distr T := {distr T / R}.

(* -------------------------------------------------------------------- *)
Section MemType.
Variable (mident : eqType).

Record memType_ : Type := mkMem {
  mheap    :> choiceType;
  mget_    :  mheap -> forall (T : ihbType), mident -> T;
  mset_    :  mheap -> forall (T : ihbType), mident -> T -> mheap;
  mget_eq_  : forall T m x v, @mget_ (@mset_ m T x v) T x = v;
  mget_neq_ : forall T U m x y v, (T <> U \/ x != y) ->
                @mget_ (@mset_ m T x v) U y = @mget_ m U y;
}.

Section GetSet.
Variable (M : memType_) (T : ihbType).

Definition mget (m : M) (x : mident) :=
  nosimpl (@mget_ M m T x).

Definition mset (m : M) (x : mident) (v : T) :=
  nosimpl (@mset_ M m T x v).

End GetSet.

Variable (M : memType_) (T U : ihbType).

Lemma mget_eq (m : M) (x : mident) (v : T) : mget T (mset m x v) x = v.
Proof. by unlock mget mset; apply/mget_eq_. Qed.

Lemma mget_neq (m : M) (x y : mident) (v : T) : (T <> U \/ x != y) ->
  mget U (mset m x v) y = mget U m y.
Proof. by unlock mget mset; apply/mget_neq_. Qed.

Definition memType_of of phant mident := memType_.
End MemType.

Notation memType T := (memType_of (Phant T)).

(* -------------------------------------------------------------------- *)
(* Expressions and probabilistic expressions *)

Section Vars.
Context {ident : eqType}.

Inductive vars_r (T : ihbType) :=
| Var of ident.

Definition vars_of of phant ident := vars_r.
End Vars.

Notation vars_ ident := (vars_of (Phant ident)).

(* -------------------------------------------------------------------- *)
Section Syntax.
Context {ident : eqType} {mem : memType ident}.

Local Notation vars := (vars_ ident).

Definition vname {T} (v : vars T) :=
  let: Var name := v in name.

Definition vtype {T} (v : vars T) := T.

Inductive expr_ : Type -> Type :=
| var_  {T}   of vars T : expr_ T
| cst_  {T}   of T : expr_ T
| prp_        of pred mem : expr_ bool
| app_  {T U} of expr_ (T -> U) & expr_ T : expr_ U.

Notation bexpr   := (expr_ bool).
Notation dexpr T := (expr_ (Distr T)).

(* -------------------------------------------------------------------- *)
Bind Scope syn_scope with expr_.

(* -------------------------------------------------------------------- *)
Section VarsEqType.
Variables (T : ihbType) (I : eqType).

Definition vars_eq (x y : vars_ I T) :=
  let: Var x := x in let: Var y := y in x == y.

Lemma vars_eqP (x y : vars_ I T) : reflect (x = y) (vars_eq x y).
Proof.
by case: x y => [x] [y]; apply: (iffP idP) => /= [/eqP->|[->]].
Qed.

Definition vars_eqMixin := EqMixin vars_eqP.
Canonical vars_eqType := EqType (vars_ I T) vars_eqMixin.
End VarsEqType.

Canonical tvars_eqType (I : eqType) := Eval hnf in @tag_eqType
  (EqType ihbType (comparableMixin (fun x y => pselect (x = y))))
  (vars_eqType^~ I).

(* -------------------------------------------------------------------- *)
Lemma eq_vars {t u : ihbType} (x : vars t) (y : vars u) :
      (Tagged vars y = Tagged vars x)
  <-> (vtype x = vtype y /\ vname x == vname y).
Proof. split.
+ case: x y => [x] [y]; rewrite /vtype /= => /(@eqP (tvars_eqType ident)).
  rewrite -tag_eqE /tag_eq /= => /andP[/eqP] /= ->.
  by rewrite tagged_asE => /eqP[->]; rewrite eqxx.
+ by case: x y => [x] [y]; rewrite /vtype /= => -[-> /eqP->].
Qed.

(* -------------------------------------------------------------------- *)
(* Commands *)

Inductive cmd_ : Type :=
| abort
| skip
| assign {t} of vars t & expr_ t
| random {t} of vars t & dexpr t
| cond       of bexpr & cmd_ & cmd_
| while      of bexpr & cmd_
| seqc       of cmd_ & cmd_.

Bind Scope syn_scope with cmd_.
End Syntax.

(* -------------------------------------------------------------------- *)
Notation "'If' e 'then' c1 'else' c2"
  := (cond e%X c1%S c2%S) : syn_scope.

Notation "'IfT' e 'then' c1"
  := (cond e%X c1%S skip) : syn_scope.

Notation "'While' e 'Do' c"
  := (while e%X c%S) : syn_scope.

Notation "x <<- e"
  := (assign x%V e%X) : syn_scope.

Notation "x <$- d"
  := (random x%V d%X) : syn_scope.

Notation "c1 ;; c2"
  := (seqc c1%S c2%S) : syn_scope.

Local Open Scope syn_scope.

(* -------------------------------------------------------------------- *)
Arguments expr_ : clear implicits.
Arguments cmd_  : clear implicits.

(* -------------------------------------------------------------------- *)
Parameter ident : countType.

Notation sident := (Countable.sort ident).

(* -------------------------------------------------------------------- *)
Section CoreMem.

Inductive coremem :=
  CoreMem (m : forall {T : ihbType}, ident -> T).

Definition coremem_get := (fun m => let: CoreMem m := m in m).

Coercion coremem_get : coremem >-> Funclass.

Definition coremem_set := nosimpl (fun (m : coremem) {T : ihbType} x v =>
  CoreMem (fun U y =>
    if pselect (T = U) is left eq then
      if x == y then ecast _ _ eq v else m U y
    else coremem_get m U y)).

Lemma get_set_eq {T : ihbType} (m : coremem) (x : ident) (v : T) :
  (coremem_set m x v) T x = v.
Proof.
rewrite /coremem_get /=; case: (pselect _) => // eq; rewrite eqxx.
suff ->: eq = erefl T by done.
by apply/UIP_dec=> {}x y; apply/pselect.
Qed.

Lemma get_set_nex {T U : ihbType} (m : coremem) (x y : ident) (v : T) :
  x != y -> (coremem_set m x v) U y = m U y.
Proof.
move=> ne_xy; rewrite /coremem_set /coremem_get /=.
by case: pselect => //; rewrite (negbTE ne_xy).
Qed.

Lemma get_set_net {T U : ihbType} (m : coremem) (x y: ident) (v : T) :
  T <> U -> (coremem_set m x v) U y = m U y.
Proof. by rewrite /coremem_set /coremem_get; case: pselect. Qed.

Lemma get_set_ne {T U : ihbType} (m : coremem) (x y : ident) (v : T) :
  (T <> U \/ x !=y) -> (coremem_set m x v) U y = m U y.
Proof. by move=> [/get_set_net |/get_set_nex] ->. Qed.

Lemma coremem_comparable : comparable coremem.
Proof. by move=> m1 m2; apply/pselect. Qed.

Definition coremem_eqMixin := comparableMixin coremem_comparable.
Canonical  coremem_eqType  := Eval hnf in EqType coremem coremem_eqMixin.

Axiom coremem_choice : choiceMixin coremem.
Canonical coremem_choiceType := Eval hnf in ChoiceType coremem coremem_choice.

End CoreMem.

Arguments coremem : clear implicits.

(* -------------------------------------------------------------------- *)
Definition cmem : memType ident := locked {|
  mheap     := [choiceType of coremem];
  mget_     := coremem_get;
  mset_     := coremem_set;
  mget_eq_  := @get_set_eq;
  mget_neq_ := @get_set_ne;
|}.

Notation dmem := (Distr cmem).

(* -------------------------------------------------------------------- *)
Inductive side : predArgType := SLeft | SRight.

Coercion bool_of_side (s : side) :=
  match s with SLeft => false | SRight => true end.

Definition side_of_bool (b : bool) :=
  if b then SRight else SLeft.

Lemma side_of_boolK : cancel bool_of_side side_of_bool.
Proof. by case. Qed.

Definition side_eqMixin := CanEqMixin side_of_boolK.
Canonical  side_eqType := Eval hnf in EqType side side_eqMixin.
Definition side_choiceMixin := CanChoiceMixin side_of_boolK.
Canonical  side_choiceType := Eval hnf in ChoiceType side side_choiceMixin.
Definition side_countMixin := CanCountMixin side_of_boolK.
Canonical  side_countType := Eval hnf in CountType side side_countMixin.
Definition side_finMixin := CanFinMixin side_of_boolK.
Canonical  side_finType := Eval hnf in FinType side side_finMixin.

Notation "''1'" := SLeft.
Notation "''2'" := SRight.

Definition mselect {T : Type} (s : side) (m : T * T) :=
  match s with
  | '1 => m.1
  | '2 => m.2
  end.

Notation "m # s" := (mselect s m) (at level 2, format "m # s") : mem_scope.

(* -------------------------------------------------------------------- *)
Lemma side2 {A : Type} s (x : A * A) : ((fst, snd)#s x = x#s)%M.
Proof. by case: s. Qed.

Lemma side_app {A B : Type} (f : A -> B) s (x y : A) :
  (f (x, y)#s = (f x, f y)#s)%M.
Proof. by case: s. Qed.

(* -------------------------------------------------------------------- *)
Notation rident := (sident * side)%type.

Definition coremem2 := (mheap cmem * mheap cmem)%type.

Definition coremem2_get (m : coremem2) T xs :=
  mget T (m#(xs.2))%M xs.1.

Definition coremem2_set (m : coremem2) (T : ihbType) xs (v : T) :=
  match xs.2 return coremem2 with
  | '1 => (mset m.1 xs.1 v, m.2)
  | '2 => (m.1, mset m.2 xs.1 v)
  end.

Coercion coremem2_get : coremem2 >-> Funclass.

Set Printing Coercions.

Lemma get_set2_eq {T} m x v : (@coremem2_set m T x v) T x = v.
Proof. by case: m x => m1 m2 [x []] /=; apply mget_eq. Qed.

Lemma get_set2_ne {T U} m x y v :
  (T <> U \/ x != y) -> (@coremem2_set m T x v) U y = m U y.
Proof.
case: m x y => m1 m2 [x []] [y []] //= h; apply mget_neq => /=;
  by (elim: h => h; [left | right; apply: contra h => /eqP->]).
Qed.

Canonical coremem2_choiceType := Eval hnf in [choiceType of coremem2].

(* -------------------------------------------------------------------- *)
Definition rmem : memType rident := nosimpl {|
  mheap     := [choiceType of coremem2];
  mget_     := coremem2_get;
  mset_     := coremem2_set;
  mget_eq_  := @get_set2_eq;
  mget_neq_ := @get_set2_ne;
|}.

(* -------------------------------------------------------------------- *)
Notation vars    := (vars_ sident).
Notation expr    := (expr_ _ cmem).
Notation cmd     := (cmd_  _ cmem).
Notation bexpr   := (expr bool).
Notation dexpr T := (expr (Distr T)).
Notation prp     := (@prp_ _ cmem).

(* -------------------------------------------------------------------- *)
Notation app2_ f x1 x2 := (app_ (app_ f x1) x2).

Reserved Notation "x =b y" (at level 70, no associativity).
Reserved Notation "x =i y" (at level 70, no associativity).

Definition beq (x y : bool) : bool := x == y.
Definition ieq (x y : int ) : bool := x == y.

Notation "c %:S"    := (@cst_ _ _ _ c) (at level 2, format "c %:S").
Notation "e1 =b e2" := (app2_ (cst_ beq) e1 e2)   : xsyn_scope.
Notation "e1 =i e2" := (app2_ (cst_ ieq) e1 e2)   : xsyn_scope.
Notation "e1 || e2" := (app2_ (cst_ orb  ) e1 e2) : xsyn_scope.
Notation "e1 && e2" := (app2_ (cst_ andb ) e1 e2) : xsyn_scope.
Notation "~~ e"     := (app_ (cst_ negb) e)       : xsyn_scope.
Notation "e1 + e2"  := (app2_ (cst_ +%R) e1 e2)   : xsyn_scope.
Notation "e1 * e2"  := (app2_ (cst_ *%R) e1 e2)   : xsyn_scope.
Notation "e1 :: e2" := (app2_ (cst_ cons) e1 e2)  : xsyn_scope.
Notation "` x"      := (@var_ _ _ _ x%V)          : xsyn_scope.

(* -------------------------------------------------------------------- *)
Section SynInject.
Context {I1 I2 : eqType} {mem1 : memType I1} {mem2:memType I2}
        (h : I1 -> I2) (mh : mem2 -> mem1).

Local Notation vars1 := (vars_ I1).
Local Notation vars2 := (vars_ I2).
Local Notation expr1 := (@expr_ I1 mem1).
Local Notation expr2 := (@expr_ I2 mem2).
Local Notation cmd1  := (cmd_  I1 mem1).
Local Notation cmd2  := (cmd_  I2 mem2).

Definition ivar {T : ihbType} (x : vars1 T) : vars2 T :=
  let: Var x := x in Var T (h x).

Definition iprop (p : pred mem1) : pred mem2 :=
  fun m => p (mh m).

Fixpoint iexpr {T : Type} (e : expr1 T) : expr2 T :=
  match e with
  | var_ _   x     => var_ (ivar x)
  | cst_ _   c     => cst_ c
  | prp_     p     => prp_ (iprop p)
  | app_ _ _ e1 e2 => app_ (iexpr e1) (iexpr e2)
  end.

Fixpoint icmd (c : cmd1) : cmd2 :=
  match c with
  | abort => abort
  | skip  => skip

  | x <<- e =>
      ivar x <<- iexpr e

  | x <$- e =>
      ivar x <$- iexpr e

  | If e then c1 else c2 =>
      If iexpr e then icmd c1 else icmd c2

  | While e Do c =>
      While iexpr e Do icmd c

  | seqc c1 c2 =>
      seqc (icmd c1) (icmd c2)
  end.
End SynInject.

(* -------------------------------------------------------------------- *)
Notation rvars := (vars_ rident).
Notation rexpr := (expr_ _ rmem).
Notation rcmd  := (cmd_  _ rmem).

Implicit Types (s : side).

Notation   irvar  s := (@ivar  _ _ (fun x => (x, s))) (only parsing).
Definition irexpr s := (@iexpr _ _ cmem rmem (fun x : ident => (x, s)) (fun m=> (m#s)%M)).
Definition ircmd  s := (@icmd  _ _ cmem rmem (fun x : ident => (x, s)) (fun m=> (m#s)%M)).

Reserved Notation "x # s" (at level 2, format "x # s").

Notation "x # s" := (ivar (pair^~ s) x) : vsyn_scope.
Notation "e # s" := (irexpr s e) : xsyn_scope.
Notation "c # s" := (ircmd s c) : syn_scope.
Notation rmem1 m := (m.1 : mem).
Notation rmem2 m := (m.2 : mem).
Notation rprp    := (@prp_ _ rmem).

(* -------------------------------------------------------------------- *)
Notation assn  := (pred cmem).
Notation dassn := (pred dmem).
Notation rassn := (pred rmem).


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Machine- and ABI-dependent layout information for activation records. *)

Require Import Coqlib.
Require Import Bounds.

(** The general shape of activation records is as follows,
  from bottom (lowest offsets) to top:
- Space for outgoing arguments to function calls.
- Back link to parent frame
- Local stack slots of integer type.
- Saved values of integer callee-save registers used by the function.
- Local stack slots of float type.
- Saved values of float callee-save registers used by the function.
- Space for the stack-allocated data declared in Cminor
- Return address.

The [frame_env] compilation environment records the positions of
the boundaries between these areas of the activation record.
*)

Definition fe_ofs_arg := 0.

Record frame_env : Type := mk_frame_env {
  fe_size: Z;
(*  fe_ofs_link: Z; *)
(*  fe_ofs_retaddr: Z; *)
  fe_ofs_int_local: Z;
  fe_ofs_int_callee_save: Z;
  fe_num_int_callee_save: Z;
  fe_ofs_float_local: Z;
  fe_ofs_float_callee_save: Z;
  fe_num_float_callee_save: Z;
  fe_stack_data: Z
}.

(** Computation of the frame environment from the bounds of the current
  function. *)

Parameter is_strong_align : unit -> bool. (* whether to align stack by 8 or 16 *)

Definition strong_align : Z := if is_strong_align tt then 16 else 8.

Lemma strong_align_pos: strong_align > 0.
Proof.
  unfold strong_align. destruct (is_strong_align tt); omega.
Qed.

Definition make_env (b: bounds) :=
  let olink := 4 * b.(bound_outgoing) in  (* back link -- CANCELLED *)
  let oil := olink (* + 4 *) in              (* integer locals *)
  let oics := oil + 4 * b.(bound_int_local) in (* integer callee-saves *)
  let oendi := oics + 4 * b.(bound_int_callee_save) in
  let ofl := align oendi 8 in             (* float locals *)
  let ofcs := ofl + 8 * b.(bound_float_local) in (* float callee-saves *)
  let ostkdata := ofcs + 8 * b.(bound_float_callee_save) in (* stack data *)
  let oretaddr := align (ostkdata + b.(bound_stack_data)) 4 in (* return address *)
  let sz := align (oretaddr + 4) strong_align - 4  in
  mk_frame_env sz (* olink *) (* oretaddr *)
                  oil oics b.(bound_int_callee_save)
                  ofl ofcs b.(bound_float_callee_save)
                  ostkdata.

(** Separation property *)

Remark frame_env_separated:
  forall b,
  let fe := make_env b in
  0 <= fe_ofs_arg
  /\ fe_ofs_arg + 4 * b.(bound_outgoing) <= (* fe.(fe_ofs_link)
  /\ fe.(fe_ofs_link) + 4 <= *) fe.(fe_ofs_int_local)
  /\ fe.(fe_ofs_int_local) + 4 * b.(bound_int_local) <= fe.(fe_ofs_int_callee_save)
  /\ fe.(fe_ofs_int_callee_save) + 4 * b.(bound_int_callee_save) <= fe.(fe_ofs_float_local)
  /\ fe.(fe_ofs_float_local) + 8 * b.(bound_float_local) <= fe.(fe_ofs_float_callee_save)
  /\ fe.(fe_ofs_float_callee_save) + 8 * b.(bound_float_callee_save) <= fe.(fe_stack_data)
  /\ fe.(fe_stack_data) + b.(bound_stack_data) <= (* fe.(fe_ofs_retaddr)
  /\ fe.(fe_ofs_retaddr) + 4 <= *) fe.(fe_size).
Proof.
  intros.
  generalize (align_le (fe.(fe_ofs_int_callee_save) + 4 * b.(bound_int_callee_save)) 8 (refl_equal _)).
  generalize (align_le (fe.(fe_stack_data) + b.(bound_stack_data)) 4 (refl_equal _)).
  generalize (align_le (align (fe.(fe_stack_data) + b.(bound_stack_data)) 4 + 4) _ strong_align_pos) .
  unfold fe, make_env, fe_size, (* fe_ofs_link, *) (* fe_ofs_retaddr, *)
    fe_ofs_int_local, fe_ofs_int_callee_save,
    fe_num_int_callee_save,
    fe_ofs_float_local, fe_ofs_float_callee_save, fe_num_float_callee_save,
    fe_stack_data, fe_ofs_arg.
  intros.
  generalize (bound_int_local_pos b); intro;
  generalize (bound_float_local_pos b); intro;
  generalize (bound_int_callee_save_pos b); intro;
  generalize (bound_float_callee_save_pos b); intro;
  generalize (bound_outgoing_pos b); intro;
  generalize (bound_stack_data_pos b); intro.
  omega.
Qed.

(** Alignment property *)

Lemma align_strong_align: (8 | strong_align).
Proof.
  unfold strong_align. destruct (is_strong_align tt).
   exists 2; reflexivity.
  exists 1; reflexivity.
Qed.

Remark frame_env_aligned:
  forall b,
  let fe := make_env b in
  (* (4 | fe.(fe_ofs_link))
  /\ *) (4 | fe.(fe_ofs_int_local))
  /\ (4 | fe.(fe_ofs_int_callee_save))
  /\ (8 | fe.(fe_ofs_float_local))
  /\ (8 | fe.(fe_ofs_float_callee_save))
(*  /\ (4 | fe.(fe_ofs_retaddr)) *)
  /\ (8 | fe.(fe_stack_data))
  /\ (4 | fe.(fe_size))
  /\ (strong_align | fe.(fe_size) + 4) (* to cope with the return address *)
.
Proof.
  intros.
  unfold fe, make_env, fe_size, (* fe_ofs_link, *) (* fe_ofs_retaddr, *)
    fe_ofs_int_local, fe_ofs_int_callee_save,
    fe_num_int_callee_save,
    fe_ofs_float_local, fe_ofs_float_callee_save, fe_num_float_callee_save,
    fe_stack_data.
  set (x1 := 4 * bound_outgoing b).
  assert (4 | x1). unfold x1; exists (bound_outgoing b); ring.
  set (x2 := x1 (* + 4 *)).
  assert (4 | x2). unfold x2; auto. (* apply Zdivide_plus_r; auto. exists 1; auto. *)
  set (x3 := x2 + 4 * bound_int_local b).
  assert (4 | x3). unfold x2; apply Zdivide_plus_r; auto. exists (bound_int_local b); ring.
  set (x4 := x3 + 4 * bound_int_callee_save b).
  set (x5 := align x4 8).
  assert (8 | x5). unfold x5. apply align_divides. omega.
  set (x6 := x5 + 8 * bound_float_local b).
  assert (8 | x6). unfold x6. apply Zdivide_plus_r; auto. exists (bound_float_local b); ring.
  set (x7 := x6 + 8 * bound_float_callee_save b).
  assert (8 | x7).
    unfold x7. apply Zdivide_plus_r; auto. exists (bound_float_callee_save b); ring.
  set (x8 := align (x7 + bound_stack_data b) 4).
  assert (4 | x8). apply align_divides. omega.
  replace (align (x8 + 4) strong_align - 4 + 4) with (align (x8 + 4) strong_align) by ring.
  generalize (align_divides (x8 + 4) _ strong_align_pos).
  intro.
  assert (4 | 8) by (exists 2; reflexivity).
  generalize (align_strong_align).
  intro.
  assert (4 | strong_align) by eauto using Zdivide_trans.
  assert (4 | align (x8 + 4) strong_align) by eauto using Zdivide_trans.
  assert (4 | align (x8 + 4) strong_align - 4).
   eapply Zdivide_plus_r.
   assumption.
   exists (-1); reflexivity.
  tauto.
Qed.
(*  set (x9 := x8 + 4).
  assert (4 | x9). unfold x8; apply Zdivide_plus_r; auto. exists 1; auto.
  tauto.
Qed.
*)

Extract Constant is_strong_align => "fun _ -> false".