(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require bool.Bool.
Require map.Map.
Require set.Set.

(* Why3 assumption *)
Definition unit := unit.

(* Why3 assumption *)
Inductive datatype :=
  | Tint : datatype
  | Tbool : datatype.
Axiom datatype_WhyType : WhyType datatype.
Existing Instance datatype_WhyType.

(* Why3 assumption *)
Inductive operator :=
  | Oplus : operator
  | Ominus : operator
  | Omult : operator
  | Ole : operator.
Axiom operator_WhyType : WhyType operator.
Existing Instance operator_WhyType.

(* Why3 assumption *)
Definition ident := Z.

(* Why3 assumption *)
Inductive term :=
  | Tconst : Z -> term
  | Tvar : Z -> term
  | Tderef : Z -> term
  | Tbin : term -> operator -> term -> term.
Axiom term_WhyType : WhyType term.
Existing Instance term_WhyType.

(* Why3 assumption *)
Inductive fmla :=
  | Fterm : term -> fmla
  | Fand : fmla -> fmla -> fmla
  | Fnot : fmla -> fmla
  | Fimplies : fmla -> fmla -> fmla
  | Flet : Z -> term -> fmla -> fmla
  | Fforall : Z -> datatype -> fmla -> fmla.
Axiom fmla_WhyType : WhyType fmla.
Existing Instance fmla_WhyType.

(* Why3 assumption *)
Inductive value :=
  | Vint : Z -> value
  | Vbool : bool -> value.
Axiom value_WhyType : WhyType value.
Existing Instance value_WhyType.

(* Why3 assumption *)
Definition env := (map.Map.map Z value).

Parameter eval_bin: value -> operator -> value -> value.

Axiom eval_bin_def : forall (x:value) (op:operator) (y:value), match (x,
  y) with
  | ((Vint x1), (Vint y1)) =>
      match op with
      | Oplus => ((eval_bin x op y) = (Vint (x1 + y1)%Z))
      | Ominus => ((eval_bin x op y) = (Vint (x1 - y1)%Z))
      | Omult => ((eval_bin x op y) = (Vint (x1 * y1)%Z))
      | Ole => ((x1 <= y1)%Z -> ((eval_bin x op y) = (Vbool true))) /\
          ((~ (x1 <= y1)%Z) -> ((eval_bin x op y) = (Vbool false)))
      end
  | (_, _) => ((eval_bin x op y) = (Vbool false))
  end.

(* Why3 assumption *)
Fixpoint eval_term (sigma:(map.Map.map Z value)) (pi:(map.Map.map Z value))
  (t:term) {struct t}: value :=
  match t with
  | (Tconst n) => (Vint n)
  | (Tvar id) => (map.Map.get pi id)
  | (Tderef id) => (map.Map.get sigma id)
  | (Tbin t1 op t2) => (eval_bin (eval_term sigma pi t1) op (eval_term sigma
      pi t2))
  end.

(* Why3 assumption *)
Fixpoint eval_fmla (sigma:(map.Map.map Z value)) (pi:(map.Map.map Z value))
  (f:fmla) {struct f}: Prop :=
  match f with
  | (Fterm t) => ((eval_term sigma pi t) = (Vbool true))
  | (Fand f1 f2) => (eval_fmla sigma pi f1) /\ (eval_fmla sigma pi f2)
  | (Fnot f1) => ~ (eval_fmla sigma pi f1)
  | (Fimplies f1 f2) => (eval_fmla sigma pi f1) -> (eval_fmla sigma pi f2)
  | (Flet x t f1) => (eval_fmla sigma (map.Map.set pi x (eval_term sigma pi
      t)) f1)
  | (Fforall x Tint f1) => forall (n:Z), (eval_fmla sigma (map.Map.set pi x
      (Vint n)) f1)
  | (Fforall x Tbool f1) => forall (b:bool), (eval_fmla sigma (map.Map.set pi
      x (Vbool b)) f1)
  end.

Parameter subst_term: term -> Z -> Z -> term.

Axiom subst_term_def : forall (e:term) (r:Z) (v:Z),
  match e with
  | (Tconst _) => ((subst_term e r v) = e)
  | (Tvar _) => ((subst_term e r v) = e)
  | (Tderef x) => ((r = x) -> ((subst_term e r v) = (Tvar v))) /\
      ((~ (r = x)) -> ((subst_term e r v) = e))
  | (Tbin e1 op e2) => ((subst_term e r v) = (Tbin (subst_term e1 r v) op
      (subst_term e2 r v)))
  end.

(* Why3 assumption *)
Fixpoint fresh_in_term (id:Z) (t:term) {struct t}: Prop :=
  match t with
  | (Tconst _) => True
  | (Tvar v) => ~ (id = v)
  | (Tderef _) => True
  | (Tbin t1 _ t2) => (fresh_in_term id t1) /\ (fresh_in_term id t2)
  end.

Axiom eval_subst_term : forall (sigma:(map.Map.map Z value)) (pi:(map.Map.map
  Z value)) (e:term) (x:Z) (v:Z), (fresh_in_term v e) -> ((eval_term sigma pi
  (subst_term e x v)) = (eval_term (map.Map.set sigma x (map.Map.get pi v))
  pi e)).

Axiom eval_term_change_free : forall (t:term) (sigma:(map.Map.map Z value))
  (pi:(map.Map.map Z value)) (id:Z) (v:value), (fresh_in_term id t) ->
  ((eval_term sigma (map.Map.set pi id v) t) = (eval_term sigma pi t)).

(* Why3 assumption *)
Fixpoint fresh_in_fmla (id:Z) (f:fmla) {struct f}: Prop :=
  match f with
  | (Fterm e) => (fresh_in_term id e)
  | ((Fand f1 f2)|(Fimplies f1 f2)) => (fresh_in_fmla id f1) /\
      (fresh_in_fmla id f2)
  | (Fnot f1) => (fresh_in_fmla id f1)
  | (Flet y t f1) => (~ (id = y)) /\ ((fresh_in_term id t) /\ (fresh_in_fmla
      id f1))
  | (Fforall y _ f1) => (~ (id = y)) /\ (fresh_in_fmla id f1)
  end.

(* Why3 assumption *)
Fixpoint subst (f:fmla) (x:Z) (v:Z) {struct f}: fmla :=
  match f with
  | (Fterm e) => (Fterm (subst_term e x v))
  | (Fand f1 f2) => (Fand (subst f1 x v) (subst f2 x v))
  | (Fnot f1) => (Fnot (subst f1 x v))
  | (Fimplies f1 f2) => (Fimplies (subst f1 x v) (subst f2 x v))
  | (Flet y t f1) => (Flet y (subst_term t x v) (subst f1 x v))
  | (Fforall y ty f1) => (Fforall y ty (subst f1 x v))
  end.

Axiom eval_subst : forall (f:fmla) (sigma:(map.Map.map Z value))
  (pi:(map.Map.map Z value)) (x:Z) (v:Z), (fresh_in_fmla v f) -> ((eval_fmla
  sigma pi (subst f x v)) <-> (eval_fmla (map.Map.set sigma x (map.Map.get pi
  v)) pi f)).

Axiom eval_swap : forall (f:fmla) (sigma:(map.Map.map Z value))
  (pi:(map.Map.map Z value)) (id1:Z) (id2:Z) (v1:value) (v2:value),
  (~ (id1 = id2)) -> ((eval_fmla sigma (map.Map.set (map.Map.set pi id1 v1)
  id2 v2) f) <-> (eval_fmla sigma (map.Map.set (map.Map.set pi id2 v2) id1
  v1) f)).

Axiom eval_change_free : forall (f:fmla) (sigma:(map.Map.map Z value))
  (pi:(map.Map.map Z value)) (id:Z) (v:value), (fresh_in_fmla id f) ->
  ((eval_fmla sigma (map.Map.set pi id v) f) <-> (eval_fmla sigma pi f)).

(* Why3 assumption *)
Inductive stmt :=
  | Sskip : stmt
  | Sassign : Z -> term -> stmt
  | Sseq : stmt -> stmt -> stmt
  | Sif : term -> stmt -> stmt -> stmt
  | Sassert : fmla -> stmt
  | Swhile : term -> fmla -> stmt -> stmt.
Axiom stmt_WhyType : WhyType stmt.
Existing Instance stmt_WhyType.

Axiom check_skip : forall (s:stmt), (s = Sskip) \/ ~ (s = Sskip).

(* Why3 assumption *)
Inductive one_step: (map.Map.map Z value) -> (map.Map.map Z value) -> stmt ->
  (map.Map.map Z value) -> (map.Map.map Z value) -> stmt -> Prop :=
  | one_step_assign : forall (sigma:(map.Map.map Z value)) (pi:(map.Map.map Z
      value)) (x:Z) (e:term), (one_step sigma pi (Sassign x e)
      (map.Map.set sigma x (eval_term sigma pi e)) pi Sskip)
  | one_step_seq : forall (sigma:(map.Map.map Z value)) (pi:(map.Map.map Z
      value)) (sigma':(map.Map.map Z value)) (pi':(map.Map.map Z value))
      (i1:stmt) (i1':stmt) (i2:stmt), (one_step sigma pi i1 sigma' pi'
      i1') -> (one_step sigma pi (Sseq i1 i2) sigma' pi' (Sseq i1' i2))
  | one_step_seq_skip : forall (sigma:(map.Map.map Z value)) (pi:(map.Map.map
      Z value)) (i:stmt), (one_step sigma pi (Sseq Sskip i) sigma pi i)
  | one_step_if_true : forall (sigma:(map.Map.map Z value)) (pi:(map.Map.map
      Z value)) (e:term) (i1:stmt) (i2:stmt), ((eval_term sigma pi
      e) = (Vbool true)) -> (one_step sigma pi (Sif e i1 i2) sigma pi i1)
  | one_step_if_false : forall (sigma:(map.Map.map Z value)) (pi:(map.Map.map
      Z value)) (e:term) (i1:stmt) (i2:stmt), ((eval_term sigma pi
      e) = (Vbool false)) -> (one_step sigma pi (Sif e i1 i2) sigma pi i2)
  | one_step_assert : forall (sigma:(map.Map.map Z value)) (pi:(map.Map.map Z
      value)) (f:fmla), (eval_fmla sigma pi f) -> (one_step sigma pi
      (Sassert f) sigma pi Sskip)
  | one_step_while_true : forall (sigma:(map.Map.map Z value))
      (pi:(map.Map.map Z value)) (e:term) (inv:fmla) (i:stmt), (eval_fmla
      sigma pi inv) -> (((eval_term sigma pi e) = (Vbool true)) -> (one_step
      sigma pi (Swhile e inv i) sigma pi (Sseq i (Swhile e inv i))))
  | one_step_while_false : forall (sigma:(map.Map.map Z value))
      (pi:(map.Map.map Z value)) (e:term) (inv:fmla) (i:stmt), (eval_fmla
      sigma pi inv) -> (((eval_term sigma pi e) = (Vbool false)) -> (one_step
      sigma pi (Swhile e inv i) sigma pi Sskip)).

(* Why3 assumption *)
Inductive many_steps: (map.Map.map Z value) -> (map.Map.map Z value) ->
  stmt -> (map.Map.map Z value) -> (map.Map.map Z value) -> stmt -> Z ->
  Prop :=
  | many_steps_refl : forall (sigma:(map.Map.map Z value)) (pi:(map.Map.map Z
      value)) (i:stmt), (many_steps sigma pi i sigma pi i 0%Z)
  | many_steps_trans : forall (sigma1:(map.Map.map Z value))
      (pi1:(map.Map.map Z value)) (sigma2:(map.Map.map Z value))
      (pi2:(map.Map.map Z value)) (sigma3:(map.Map.map Z value))
      (pi3:(map.Map.map Z value)) (i1:stmt) (i2:stmt) (i3:stmt) (n:Z),
      (one_step sigma1 pi1 i1 sigma2 pi2 i2) -> ((many_steps sigma2 pi2 i2
      sigma3 pi3 i3 n) -> (many_steps sigma1 pi1 i1 sigma3 pi3 i3
      (n + 1%Z)%Z)).

Axiom steps_non_neg : forall (sigma1:(map.Map.map Z value)) (pi1:(map.Map.map
  Z value)) (sigma2:(map.Map.map Z value)) (pi2:(map.Map.map Z value))
  (i1:stmt) (i2:stmt) (n:Z), (many_steps sigma1 pi1 i1 sigma2 pi2 i2 n) ->
  (0%Z <= n)%Z.

Axiom many_steps_seq : forall (sigma1:(map.Map.map Z value))
  (pi1:(map.Map.map Z value)) (sigma3:(map.Map.map Z value))
  (pi3:(map.Map.map Z value)) (i1:stmt) (i2:stmt) (n:Z), (many_steps sigma1
  pi1 (Sseq i1 i2) sigma3 pi3 Sskip n) -> exists sigma2:(map.Map.map Z
  value), exists pi2:(map.Map.map Z value), exists n1:Z, exists n2:Z,
  (many_steps sigma1 pi1 i1 sigma2 pi2 Sskip n1) /\ ((many_steps sigma2 pi2
  i2 sigma3 pi3 Sskip n2) /\ (n = ((1%Z + n1)%Z + n2)%Z)).

(* Why3 assumption *)
Definition valid_fmla (p:fmla): Prop := forall (sigma:(map.Map.map Z value))
  (pi:(map.Map.map Z value)), (eval_fmla sigma pi p).

(* Why3 assumption *)
Definition valid_triple (p:fmla) (i:stmt) (q:fmla): Prop :=
  forall (sigma:(map.Map.map Z value)) (pi:(map.Map.map Z value)), (eval_fmla
  sigma pi p) -> forall (sigma':(map.Map.map Z value)) (pi':(map.Map.map Z
  value)) (n:Z), (many_steps sigma pi i sigma' pi' Sskip n) -> (eval_fmla
  sigma' pi' q).

(* Why3 assumption *)
Definition assigns (sigma:(map.Map.map Z value)) (a:(set.Set.set Z))
  (sigma':(map.Map.map Z value)): Prop := forall (i:Z), (~ (set.Set.mem i
  a)) -> ((map.Map.get sigma i) = (map.Map.get sigma' i)).

Axiom assigns_refl : forall (sigma:(map.Map.map Z value)) (a:(set.Set.set
  Z)), (assigns sigma a sigma).

Axiom assigns_trans : forall (sigma1:(map.Map.map Z value))
  (sigma2:(map.Map.map Z value)) (sigma3:(map.Map.map Z value))
  (a:(set.Set.set Z)), ((assigns sigma1 a sigma2) /\ (assigns sigma2 a
  sigma3)) -> (assigns sigma1 a sigma3).

Axiom assigns_union_left : forall (sigma:(map.Map.map Z value))
  (sigma':(map.Map.map Z value)) (s1:(set.Set.set Z)) (s2:(set.Set.set Z)),
  (assigns sigma s1 sigma') -> (assigns sigma (set.Set.union s1 s2) sigma').

Axiom assigns_union_right : forall (sigma:(map.Map.map Z value))
  (sigma':(map.Map.map Z value)) (s1:(set.Set.set Z)) (s2:(set.Set.set Z)),
  (assigns sigma s2 sigma') -> (assigns sigma (set.Set.union s1 s2) sigma').

(* Why3 assumption *)
Fixpoint stmt_writes (i:stmt) (w:(set.Set.set Z)) {struct i}: Prop :=
  match i with
  | (Sskip|(Sassert _)) => True
  | (Sassign id _) => (set.Set.mem id w)
  | ((Sseq s1 s2)|(Sif _ s1 s2)) => (stmt_writes s1 w) /\ (stmt_writes s2 w)
  | (Swhile _ _ s) => (stmt_writes s w)
  end.

Axiom consequence_rule : forall (p:fmla) (p':fmla) (q:fmla) (q':fmla)
  (i:stmt), (valid_fmla (Fimplies p' p)) -> ((valid_triple p i q) ->
  ((valid_fmla (Fimplies q q')) -> (valid_triple p' i q'))).

Axiom skip_rule : forall (q:fmla), (valid_triple q Sskip q).

Axiom assign_rule : forall (q:fmla) (x:Z) (id:Z) (e:term), (fresh_in_fmla id
  q) -> (valid_triple (Flet id e (subst q x id)) (Sassign x e) q).

Axiom seq_rule : forall (p:fmla) (q:fmla) (r:fmla) (i1:stmt) (i2:stmt),
  ((valid_triple p i1 r) /\ (valid_triple r i2 q)) -> (valid_triple p
  (Sseq i1 i2) q).

Axiom if_rule : forall (e:term) (p:fmla) (q:fmla) (i1:stmt) (i2:stmt),
  ((valid_triple (Fand p (Fterm e)) i1 q) /\ (valid_triple (Fand p
  (Fnot (Fterm e))) i2 q)) -> (valid_triple p (Sif e i1 i2) q).

Axiom assert_rule : forall (f:fmla) (p:fmla), (valid_fmla (Fimplies p f)) ->
  (valid_triple p (Sassert f) p).

Axiom assert_rule_ext : forall (f:fmla) (p:fmla), (valid_triple (Fimplies f
  p) (Sassert f) p).

Axiom while_rule : forall (e:term) (inv:fmla) (i:stmt), (valid_triple
  (Fand (Fterm e) inv) i inv) -> (valid_triple inv (Swhile e inv i)
  (Fand (Fnot (Fterm e)) inv)).

Axiom while_rule_ext : forall (e:term) (inv:fmla) (inv':fmla) (i:stmt),
  (valid_fmla (Fimplies inv' inv)) -> ((valid_triple (Fand (Fterm e) inv') i
  inv') -> (valid_triple inv' (Swhile e inv i) (Fand (Fnot (Fterm e))
  inv'))).

Require Import Why3.
Ltac ae := why3 "Alt-Ergo,0.99.1," timelimit 5; admit.

(* Why3 goal *)
Theorem WP_parameter_wp : forall (i:stmt) (q:fmla), forall (x:term) (x1:fmla)
  (x2:stmt), (i = (Swhile x x1 x2)) -> forall (o:fmla), (valid_triple o x2
  x1) -> forall (o1:fmla), (forall (sigma:(map.Map.map Z value))
  (pi:(map.Map.map Z value)), (eval_fmla sigma pi o1) -> ((eval_fmla sigma pi
  (Fand (Fimplies (Fand (Fterm x) x1) o) (Fimplies (Fand (Fnot (Fterm x)) x1)
  q))) /\ forall (sigma':(map.Map.map Z value)) (pi':(map.Map.map Z value))
  (n:Z), (many_steps sigma pi x2 sigma' pi' Sskip n) -> (eval_fmla sigma' pi'
  o1))) -> (valid_triple (Fand x1 o1) i q).
(* Why3 intros i q x x1 x2 h1 o h2 o1 h3. *)
intros i Post cond inv body H_;rewrite H_ in *;clear H_ i.
intros WP_body H_WP_body.
intros abstracted_fmla H_abstracted.
red.
intros s1 p1 H1 s2 p2 n Hsteps.
assert (H_n_pos := steps_non_neg _ _ _ _ _ _ _ Hsteps).
generalize s1 p1 H1 Hsteps; clear s1 p1 H1 Hsteps.
apply Z_lt_induction with (P :=
  fun n => forall s1 p1 : Map.map Z value,
    eval_fmla s1 p1 (Fand inv abstracted_fmla) ->
    many_steps s1 p1 (Swhile cond inv body) s2 p2 Sskip n ->
    eval_fmla s2 p2 Post); auto.
intros.
elim H0; clear H0; intros H_inv_in_s2 H_abstr_in_s2.
inversion H1; subst; clear H1.
inversion H0; subst; clear H0.
(* case cond = true *)
destruct (many_steps_seq _ _ _ _ _ _ _ H2) as
  (s3 & p3 & n1 & n2 & First_iter & Next_iter & Hn1n2).
clear H2.
apply H with (3:=Next_iter).
  assert (Hn1_pos := steps_non_neg _ _ _ _ _ _ _ First_iter).
  assert (Hn2_pos := steps_non_neg _ _ _ _ _ _ _ Next_iter).
  omega.
destruct (H_abstracted sigma2 pi2 H_abstr_in_s2) as ((Htrue,_) & Hnext).
clear H_abstracted.
assert (H_abstr_in_s3 := Hnext s3 p3 n1 First_iter); clear Hnext.
split; auto.
red in H_WP_body.
apply H_WP_body with (2:=First_iter).
ae.
(*
apply Htrue; auto.
*)
(* case cond = false *)
inversion H2; [subst; clear H2 | inversion H0].
destruct (H_abstracted s2 p2 H_abstr_in_s2) as ((_,Hfalse) & Hnext).
clear H_abstracted.
ae.
(*
apply Hfalse; split; auto.
rewrite H11; discriminate.
*)
Admitted.


Require Import List.
Require Import MyTactics.
Require Import MySequences.
Require Import LCSyntax.
Require Import LCFreeVars.
Require Import LCValues.
Require Import LCReduction.

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

(* A big-step call-by-value semantics. *)

Inductive bigcbv : term -> term -> Prop :=
| BigcbvValue:
    forall v,
    is_value v ->
    bigcbv v v
| BigcbvApp:
    forall t1 t2 u1 v2 v,
    bigcbv t1 (Lam u1) ->
    bigcbv t2 v2 ->
    bigcbv u1.[v2/] v ->
    bigcbv (App t1 t2) v
| BigcbvLet:
    forall t1 t2 v1 v,
    bigcbv t1 v1 ->
    bigcbv t2.[v1/] v ->
    bigcbv (Let t1 t2) v
| BigcbvMatchNone:
  forall tc t1 v1 t2,
  bigcbv tc VariantNone ->
  bigcbv t1 v1 ->
  bigcbv (Match tc t1 t2) v1
| BigcbvMatchSome:
  forall tc t1 t2 vc v2,
  is_value vc ->
  bigcbv tc (VariantSome vc) ->
  bigcbv t2.[vc/]  v2 ->
  bigcbv (Match tc t1 t2) v2
| BigcbvSome:
  forall t v,
  bigcbv t v ->
  bigcbv (VariantSome t) (VariantSome v)
.

Global Hint Constructors bigcbv : bigcbv.

(* The tactic [invert_bigcbv] looks for a hypothesis of the form [bigcbv t v]
   and inverts it. *)

Ltac invert_bigcbv :=
  pick bigcbv invert;
  try solve [ false; eauto 3 with obvious ].

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

(* If [bigcbv t v] holds, then [v] must be a value. *)

Lemma bigcbv_is_value:
  forall t v,
  bigcbv t v ->
  is_value v.
Proof.
  induction 1; eauto.
Qed.

Global Hint Resolve bigcbv_is_value : is_value obvious.

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

(* If [t] evaluates to [v] according to the big-step semantics,
   then [t] reduces to [v] according to the small-step semantics. *)

Lemma bigcbv_star_cbv:
  forall t v,
  bigcbv t v ->
  star cbv t v.
Proof.
  (* A detailed proof: *)
  induction 1.
  (* BigcbvValue *)
  { eapply star_refl. }
  (* BigcbvApp *)
  { eapply star_trans. obvious.
    eapply star_trans. obvious.
    eapply star_step. obvious.
    eauto. }
  (* BigcbvLet *)
  { eapply star_trans. obvious.
    eapply star_step. obvious.
    eauto. }
  {
    eapply star_trans with (Match VariantNone t1 t2).
    { clear -IHbigcbv1. induction IHbigcbv1.
      * eapply star_refl.
      * eapply star_step; obvious.
    }
    eapply star_step. obvious.
    eauto.
  }
  {
    eapply star_trans with (Match (VariantSome vc) t1 t2).
    { clear -IHbigcbv1. induction IHbigcbv1;
      eauto with sequences obvious.
    }
    eapply star_step. obvious.
    eauto.
  }
  {
    { clear -IHbigcbv. induction IHbigcbv;
      eauto with sequences obvious. }
  }
  (* A much shorter proof: *)
  (* induction 1; eauto 6 with sequences obvious. *)
Qed.

(* Conversely, if [t] reduces to [v] in the small-step semantics,
   then [t] evaluates to [v] in the big-step semantics. *)

Lemma cbv_bigcbv_bigcbv:
  forall t1 t2,
  cbv t1 t2 ->
  forall v,
  bigcbv t2 v ->
  bigcbv t1 v.
Proof.

  (* A detailed proof: *)
  induction 1; intros; subst; try solve [ false; tauto ].
  (* BetaV *)
  { econstructor; eauto with bigcbv. }
  (* LetV *)
  { econstructor; eauto with bigcbv. }
  (* AppL *)
  { invert_bigcbv. eauto with bigcbv. }
  (* AppR *)
  { invert_bigcbv. eauto with bigcbv. }
  (* LetL *)
  { invert_bigcbv. eauto with bigcbv. }
  (* IteTrue *)
  { eapply BigcbvMatchNone; eauto with bigcbv. }
  (* IteFalse *)
  { eapply BigcbvMatchSome; eauto with bigcbv. }
  { invert_bigcbv; eauto with bigcbv. }
  { invert_bigcbv; eauto with bigcbv. }
(* (* Restart. *)
  (* A shorter proof: *)
  induction 1; intros; subst; try solve [ false; tauto
  | econstructor; eauto with bigcbv
  | invert_bigcbv; eauto with bigcbv
  ]. *)
Qed.

Lemma star_cbv_bigcbv:
  forall t v,
  star cbv t v ->
  is_value v ->
  bigcbv t v.
Proof.
  induction 1; eauto using cbv_bigcbv_bigcbv with bigcbv.
Qed.

(* In conclusion, we have the following equivalence: *)

Lemma star_cbv_bigcbv_eq:
  forall t v,
  (star cbv t v /\ is_value v) <-> bigcbv t v.
Proof.
  split; intros; unpack;
  eauto using star_cbv_bigcbv, bigcbv_star_cbv with is_value.
Qed.

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

(* Suppose the big-step semantics [bigcbv] is taken as the primary definition
   of the meaning of terms. Then, in terms of [bigcbv], we can define a
   relation [sim] between terms, which has the flavor of a small-step
   reduction relation. *)

(* The definition is as follows: if, whenever [u] can produce the value [v],
   [t] can produce [v] as well, then [t] simulates [u]. *)

Definition sim t u :=
  forall v,
  bigcbv u v ->
  bigcbv t v.

(* This simulation relation is reflexive and transitive, hence a preorder. *)

Lemma reflexive_sim:
  forall t,
  sim t t.
Proof.
  unfold sim. eauto.
Qed.

Lemma transitive_sim:
  forall t1 t2 t3,
  sim t1 t2 ->
  sim t2 t3 ->
  sim t1 t3.
Proof.
  unfold sim. eauto.
Qed.

Global Hint Resolve reflexive_sim transitive_sim : sim.

(* This simulation relation includes the small-step relation [cbv]. *)

Lemma cbv_sim:
  forall t u,
  cbv t u ->
  sim t u.
Proof.
  (* This is a direct consequence of the fact that the composition
     [cbv . bigcbv] is a subset of [bigcbv] -- a fact that was proved above. *)
  unfold sim. eauto using cbv_bigcbv_bigcbv.
Qed.

(* As a consequence, [star cbv] is also a subset of [sim]. *)

Lemma star_cbv_sim:
  forall t u,
  star cbv t u ->
  sim t u.
Proof.
  induction 1; eauto using cbv_sim with sim.
Qed.

(* The converse is not true. Clearly, [star cbv] forbids all reductions under
   a lambda-abstraction, whereas (somewhat nonobviously) [sim] allows certain
   reductions under lambda-abstractions: intuitively, it allows all necessary
   reductions, in a certain sense (?). *)

(* For this reason, [sim] can be more comfortable to work with than [star cbv].
   The proof of correctness of the CPS transformation in CPSCorrectnessBigStep
   provides an example. *)


(*
Process 65996 exit (max_proofs) Sat Nov 21 21:44:25 2015
MacBook-Air:~ billw$ /Applications/CoqIDE_8.4pl5.app/Contents/Resources/bin/coqtop
Welcome to Coq 8.4pl5 (October 2014)

Coq < Section Simplification_A.

Coq < Goal forall f t e:Prop, (~f /\ (t <-> e)) -> ~f.
1 subgoal

  ============================
   forall f t e : Prop, ~ f /\ (t <-> e) -> ~ f

Unnamed_thm < info_auto.
(* info auto : *)
idtac.
1 subgoal

  ============================
   forall f t e : Prop, ~ f /\ (t <-> e) -> ~ f

Unnamed_thm < intros.
1 subgoal

  f : Prop
  t : Prop
  e : Prop
  H : ~ f /\ (t <-> e)
  ============================
   ~ f

Unnamed_thm < apply H.
No more subgoals.

Unnamed_thm < Qed.
info_auto.
intros.
apply H.

Unnamed_thm is defined

Coq <

*)

Section Simplification_A.
Goal forall f t e:Prop, (~f /\ (t <-> e)) -> ~f.
intros.
apply H.
Qed.


Require Export Coq.Lists.List.
Require Import Coq.Program.Equality.
Require Import core fintype.
Import ScopedNotations.
From Chapter10 Require Export sysf_pat.
Require Import Coq.Program.Tactics.

Ltac inv H := inversion H; try clear H; try subst.

Ltac autorevert x :=
  try (match goal with
    | [y : ?Y |- ?claim] =>
      try (match x with y => idtac end; fail 1);
        match goal with [z : _ |- _] =>
          match claim with context[z] =>
            first
              [ match Y with context[z] => revert y; autorevert x end
              | match y with z => revert y; autorevert x end]
          end
        end
       end).

Definition ctx n := fin n -> ty n.
Definition dctx m n := fin m -> ty n.
Definition empty {X} : fin 0 -> X :=  fun x => match x with end.

Inductive unique {X} : list (nat * X) -> Prop :=
| unil : unique nil
| ucons l x xs : unique xs -> (forall x, ~ In (l, x) xs) ->  unique (cons (l,x) xs).

Hint Constructors unique.

Lemma unique_map {X Y: Type} {f : X -> Y} (xs : list (nat * X)) :
  unique xs -> unique (map (prod_map (fun x => x) f) xs).
Proof.
  intros.
  induction H; cbn; eauto.
  constructor; eauto.
  intros z A. rewrite in_map_iff in A. destruct A as ((?&?)&?&?).
  inv H1. eapply H0; eauto.
Qed.

Lemma unique_spec {X} (xs : list (nat * X)) :
  unique xs -> (forall l x y, In (l, x) xs -> In (l, y) xs -> x = y).
Proof.
  induction 1; intros; cbn in *.
  - contradiction.
  - destruct H1 as [|]; destruct H2 as [|]; try inversion H1; try inversion H2; subst; eauto; firstorder.
Qed.

Lemma in_map {X Y: Type} {f : X -> Y} (xs : list (nat * X)) l x:
  In (l, x) xs -> In (l, f x) (map (prod_map (fun x => x) f) xs).
Proof.
  unfold prod_map.
  induction xs;  cbn; eauto.
  - destruct a; eauto. intros [|]; eauto. inversion H; eauto.
Qed.

Definition label_equiv {X Y} (xs : list (nat * X)) (ys : list (nat * Y)) :=
   (forall i, (exists s, In (i, s) xs) <-> (exists A, In (i, A) ys)).

Lemma label_equiv_map {X X' Y Y': Type} {f : X -> X'} {g : Y -> Y'} (xs : list (nat * X)) (ys : list (nat * Y)) :
  label_equiv xs ys -> label_equiv (map (prod_map (fun x => x) f) xs) (map (prod_map (fun x => x) g) ys).
Proof.
  intros H. intros l.
  unfold prod_map. split; intros (?&?).
  - rewrite in_map_iff in H0. destruct H0 as ((?&?)&?&?). inv H0.
  unfold label_equiv in H. specialize (H l). assert (exists x0, In (l, x0) xs) by eauto.
  apply H in H0. destruct H0 as (?&?). exists (g x). rewrite in_map_iff. exists (l, x). eauto.
- rewrite in_map_iff in H0. destruct H0 as ((?&?)&?&?). inv H0.
  unfold label_equiv in H. specialize (H l). assert (exists x0, In (l, x0) ys) by eauto.
  apply H in H0. destruct H0 as (?&?). exists (f x). rewrite in_map_iff. exists (l, x). eauto.
Qed.

Hint Resolve unique_map label_equiv_map.

Definition update {X} (ts : list (nat * X)) l x : list (nat * X) :=
  map (fun p => if (Nat.eqb (fst p) l) then (l, x) else p) ts.

Lemma unique_update {X} (xs :list (nat * X)) l x :
  unique xs -> unique (update xs l x).
Proof.
  unfold update. intros H.
  induction xs; eauto. inv H. specialize (IHxs H2). cbn.
  destruct (Nat.eqb l0 l) eqn: H; cbn; eauto.
  - constructor; eauto. intros. apply PeanoNat.Nat.eqb_eq in H. subst. intros HH. apply in_map_iff in HH. destruct HH as (?&?&?). destruct x2. cbn in *.  destruct (Nat.eqb n l) eqn: HHH; eauto.
    apply PeanoNat.Nat.eqb_eq in HHH. subst. inv H. eapply H3. eauto. inv H. eapply H3. eauto.
  - constructor; eauto. intros z HH. apply in_map_iff in HH. destruct HH as ((?&?)&?&?). cbn in *.
    destruct (Nat.eqb n l) eqn:HHH; inversion H0; eauto. subst. apply PeanoNat.Nat.eqb_eq in HHH. subst. eapply H3. eauto. subst. eapply H3; eauto.
Qed.

Lemma natequiv_update {X Y} (xs :list (nat * X)) l x (ys: list (nat * Y)):
  label_equiv xs ys -> label_equiv (update xs l x) ys.
Proof.
  enough (label_equiv xs (update xs l x)).
  - intros A i. unfold label_equiv in H, A. now rewrite <- A, H.
  - clear ys. unfold label_equiv. induction xs; cbn; eauto.
    + intros _. split; eauto.
    + destruct a. intros i. cbn. split.
      * intros (?&?). destruct H; eauto.
        -- inv H. destruct (Nat.eqb i l) eqn:HH; eauto. apply PeanoNat.Nat.eqb_eq in HH. subst. eauto. -- assert (exists s, In (i, s) xs) by eauto. apply IHxs in H0. destruct H0 as (?&?). eauto.
      * intros (?&?). destruct H.
        -- destruct (Nat.eqb n l) eqn:HH; eauto. apply PeanoNat.Nat.eqb_eq in HH. subst. inv H. eauto.
        -- assert (exists A, In (i, A) (update xs l x)) by eauto. apply IHxs in H0.
           destruct H0. eauto.
Qed.

Lemma update_char {X} (xs : list (nat * X)) l x i s:
  In (i, s) (update xs l x) -> In (i, s) xs \/ (l = i /\ s = x).
Proof.
  induction xs; eauto. destruct a. cbn.
  destruct (Nat.eqb n l); intros [|]; try inversion H; eauto.
  all: destruct (IHxs H); eauto.
Qed.

Lemma list_dec {X} (P Q : X -> Prop) xs (IH : forall x, In x xs -> P x \/ Q x) :
  (forall x, In x xs -> P x) \/ (exists x, In x xs /\ Q x).
Proof.
  induction xs; cbn; eauto.
  - left. cbn. intros _ [].
  - cbn in IH. assert (forall x, In x xs -> P x \/ Q x) by firstorder.
    destruct (IHxs H) as [|(x&?&?)].
    + assert (P a \/ Q a) as[|] by eauto; cbn; eauto. left. intros z [->|]; cbn; eauto.
    + right. cbn. eauto.
Qed.

Hint Resolve unique_update natequiv_update.

(** POPLMark 1B. *)
Reserved Notation "'SUB' Delta |- A <: B" (at level 68, A at level 99, no associativity).

Open Scope fscope.

Inductive sub {n} (Delta : ctx n) : ty n -> ty n -> Prop :=
| SA_top A :
    SUB Delta |- A <: top
| SA_Refl x :
    SUB Delta |- var_ty x <: var_ty x
| SA_Trans x  B :
     SUB Delta |- (Delta x) <: B ->  SUB Delta |- var_ty x <: B
| SA_arrow A1 A2 B1 B2 :
    SUB Delta |- B1 <: A1 -> SUB Delta |- A2 <: B2 ->
    SUB Delta |- arr A1 A2 <: arr B1 B2
| SA_all (A1: ty n) (A2: ty (S n)) B1 B2 :
    SUB Delta |- B1 <: A1 -> @sub (S n) ((B1 .:  Delta) >> ⟨↑⟩) A2 B2 ->
    SUB Delta |- all A1 A2 <: all B1 B2
| SA_rec (xs ys : list (nat * ty n)) : (forall l T', In (l, T') ys -> exists T, In (l, T) xs /\ SUB Delta |- T <: T') ->
                       unique xs -> unique ys -> SUB Delta |- recty xs <: recty ys
where "'SUB' Delta |- A <: B" := (sub Delta A B).

Hint Constructors sub.

Lemma sub_rec :  forall P : forall n : nat, ctx n -> ty n -> ty n -> Prop,
       (forall (n : nat) (Delta : ctx n) (A : ty n), P n Delta A top) ->
       (forall (n : nat) (Delta : ctx n) (x : fin n), P n Delta (var_ty x) (var_ty x)) ->
       (forall (n : nat) (Delta : ctx n) (x : fin n) (B : ty n),
        SUB Delta |- Delta x <: B -> P n Delta (Delta x) B -> P n Delta (var_ty x) B) ->
       (forall (n : nat) (Delta : ctx n) (A1 A2 B1 B2 : ty n),
        SUB Delta |- B1 <: A1 ->
        P n Delta B1 A1 ->
        SUB Delta |- A2 <: B2 -> P n Delta A2 B2 -> P n Delta (arr A1 A2) (arr B1 B2)) ->
       (forall (n : nat) (Delta : ctx n) (A1 : ty n) (A2 : ty (S n)) (B1 : ty n) (B2 : ty (S n)),
        SUB Delta |- B1 <: A1 ->
        P n Delta B1 A1 ->
        SUB (B1 .: Delta) >> ⟨↑⟩ |- A2 <: B2 ->
        P (S n) ((B1 .: Delta) >> ⟨↑⟩) A2 B2 -> P n Delta (all A1 A2) (all B1 B2)) ->
       (forall (n : nat) (Delta : ctx n) (xs ys : list (nat * ty n)),
        (forall (i : nat) (T' : ty n),
         In (i, T') ys -> exists  (T : ty n), In (i, T) xs /\ SUB Delta |- T <: T' /\ P _ Delta T T') ->
        unique xs -> unique ys -> P n Delta (recty xs) (recty ys)) ->
       forall (n : nat) (Delta : ctx n) (t t0 : ty n), SUB Delta |- t <: t0 -> P n Delta t t0.
Proof. intros P. fix IH 11.
  intros. induction H5; try now (clear IH; eauto).
  eapply H4. intros. destruct (H5 _ _ H8) as (T&?&?).
  exists T. repeat split; eauto. all: eauto.
Qed.

Lemma ty_rec
     : forall P : forall nty : nat, ty nty -> Prop,
       (forall (nty : nat) (f : fin nty), P nty (var_ty f)) ->
       (forall nty : nat, P nty top) ->
       (forall (nty : nat) (t : ty nty), P nty t -> forall t0 : ty nty, P nty t0 -> P nty (arr t t0)) ->
       (forall (nty : nat) (t : ty nty),
        P nty t -> forall t0 : ty (S nty), P (S nty) t0 -> P nty (all t t0)) ->
       (forall (nty : nat) (l : list (nat * ty nty)), (forall i t, In (i,t) l -> P _ t) -> P nty (recty l)) ->
       forall (nty : nat) (t : ty nty), P nty t.
Proof.
  intros P. fix IH 7. intros.
  induction t; try now (clear IH; eauto).
  eapply H3. intros. induction l.
  - contradiction.
  - destruct H4 as [|].
    + destruct a. specialize (IH H H0 H1 H2 H3 _ t0). intros. inv H4. apply IH.
    + now apply IHl.
Qed.

Section Pattern.

(** We assume that the subtyping relation is reflexive.
A proof requires a well-formedness condition.*)
Variable sub_refl : forall  n (Delta : ctx n) A, SUB Delta |- A <: A.

Lemma sub_weak m n (Delta1: ctx m) (Delta2: ctx n) A1 A2 A1' A2' (xi: fin m -> fin n) :
  SUB Delta1 |- A1 <: A2 ->
 (forall x, (Delta1 x)⟨xi⟩ = Delta2 (xi x)) ->
  A1' = A1⟨xi⟩ -> A2' = A2⟨xi⟩ ->
  SUB Delta2 |- A1' <: A2' .
Proof.
  intros H. autorevert H. induction H using @sub_rec; intros; subst; asimpl; cbn; econstructor; eauto.
  - eapply IHsub2; try reflexivity.
    auto_case; eauto. rewrite <- H1. now asimpl.
    (* TODO same here as in Popl1. auto_case should call asimpl which direclty solves the goal, so why isn't it solved *)
    now asimpl.
  - intros l T' HH. rewrite in_map_iff in HH. destruct HH as ([]&HH&?).
    inv HH. destruct (H _ _ H3) as (?&?&?&?).
    exists (x⟨xi⟩). split; eauto. apply in_map; eauto.
 Qed.

Lemma sub_weak1 n (Delta : ctx n) A A' B B' C :
  SUB Delta |- A <: B ->  A' = A⟨↑⟩ ->  B' = B⟨↑⟩ -> SUB ((C .: Delta) >> ⟨↑⟩) |- A' <: B'.
Proof. intros. eapply sub_weak;  eauto. intros x. now asimpl. Qed.

Definition transitivity_at {n} (B: ty n) := forall m Gamma (A : ty m) C  (xi: fin n -> fin m),
  SUB Gamma |- A <: B⟨xi⟩ -> SUB Gamma |- B⟨ xi⟩ <: C ->  SUB Gamma |- A <: C.

Lemma transitivity_proj n (Gamma: ctx n) A B C :
  transitivity_at B ->
  SUB Gamma |- A <: B -> SUB Gamma |- B <: C -> SUB Gamma |- A <: C.
Proof. intros H. specialize (H n Gamma A C id).  now asimpl in H. Qed.

Hint Resolve transitivity_proj.

Lemma transitivity_ren m n B (xi: fin m -> fin n) : transitivity_at B -> transitivity_at B⟨xi⟩.
Proof. unfold transitivity_at. intros. eapply H with (xi:=funcomp xi0 xi); asimpl in H0; asimpl in H1; eauto. Qed.

Lemma sub_narrow n (Delta Delta': ctx n) A C :
  (forall x, SUB Delta' |- Delta' x <: Delta x) ->
  (forall x, Delta x = Delta' x \/ transitivity_at (Delta x)) ->
  SUB Delta |- A <: C -> SUB Delta' |- A <: C.
Proof with asimpl;eauto.
  intros H H' HH. autorevert HH. induction HH using sub_rec; intros; eauto.
  - destruct (H' x); eauto. rewrite H0 in *. eauto.
  - constructor; eauto.
    eapply IHHH2.
    + auto_case; try apply sub_refl.
      eapply sub_weak; try reflexivity. eapply H.
    (* a.d. TODO another instance of a goal already solved before asimpl *)
    (* now asimpl. *)
    + auto_case. destruct (H' f);  eauto using transitivity_ren.
      rewrite H0. now left.
  - econstructor; eauto. intros l T' HH.
    destruct (H _ _ HH) as (T&?&?&?). exists  T.
    split; eauto.
Qed.

Corollary sub_trans' n (B : ty n): transitivity_at B.
Proof with asimpl;eauto.
  unfold transitivity_at.
  autorevert B. induction B using ty_rec; intros...
  - depind H...
  - depind H... depind H0...
  - depind H... depind H1...
  - depind H... depind H1...
    econstructor... clear IHsub0 IHsub3 IHsub1 IHsub2.
    eapply IHB2; eauto.
    + asimpl. eapply sub_narrow; try eapply H0.
      * auto_case.
        eapply sub_weak with (xi := ↑); try reflexivity; eauto.
        (* adrian: as of 7b3472c the goal is already solved by eauto
         TODO find out why
         as of dd2f061 it's not solved anymore *)
        (* ad of now it's solved again         *)
        (* now asimpl. *)
      * intros [x|]; try cbn; eauto. right. apply transitivity_ren. apply transitivity_ren. eauto.
  (* but as of dd2f061 this is already solved *)
    (* + asimpl in H1_0. auto. *)
  - depind H0... depind H3...
    econstructor; eauto. intros.
    destruct (H5 _ _ H6) as (T&?&?). rewrite in_map_iff in H7.
    destruct H7 as ((?&?)&?&?). inv H7.
    edestruct (H2 l0 (t⟨xi⟩)) as (T&?&?).
    + apply in_map_iff. exists (l0, t). eauto.
    + eauto.
Qed.

Corollary sub_trans n (Delta  : ctx n) A B C:
  SUB Delta |- A <: B -> SUB Delta |- B <: C -> SUB Delta |- A <: C.
Proof. eauto using sub_trans'. Qed.

Require Import Setoid Morphisms.
Instance sub_morphism {n}:
  Proper (pointwise_relation _ eq ==> eq ==> eq ==> Basics.impl) (@sub n).
Proof.
  intros Gamma Gamma' HGamma T T' -> t t' ->.
  intros H. induction H in Gamma', HGamma |- *.
  - constructor.
  - constructor.
  - constructor. rewrite <- HGamma. apply IHsub. apply HGamma.
  - constructor.
    apply IHsub1, HGamma.
    apply IHsub2, HGamma.
  - constructor.
    apply IHsub1, HGamma.
    apply IHsub2.
    intros [|]. cbn. rewrite HGamma. reflexivity.
    cbn. reflexivity.
  - constructor; try assumption. intros.
    specialize (H l T' H2) as (T & HT0 & HT1 ).
    exists T. split. assumption.
    admit.
Admitted.

Lemma sub_substitution m m' (sigma : fin m -> ty m') Delta (Delta': ctx m') A B:
   (forall x ,  SUB Delta' |- sigma x <: (Delta x)[sigma] ) ->
   SUB Delta |- A <: B -> SUB Delta' |- subst_ty sigma A <: subst_ty sigma B.
Proof.
    intros eq H. autorevert H. induction H using sub_rec; try now (econstructor; eauto).
  - intros. asimpl. eapply sub_refl.
  - intros. asimpl. eauto. cbn in *. eauto using sub_trans.
  - intros. asimpl. econstructor; eauto.
    asimpl. eapply IHsub2.
    auto_case; asimpl; cbn; eauto using sub_refl.
    eapply sub_weak; try reflexivity. eapply eq.
    all: try now asimpl.

  - intros. asimpl. econstructor; eauto. intros. rewrite in_map_iff in H2. destruct H2 as ((?&?)&?&?).
    inv H2. destruct (H _ _ H3) as (T&?&?&?).
    exists (T[sigma]). split; eauto. apply in_map. eauto.
Qed.

(** POPLMark Challenge 2b *)

Variable pat_ty : forall {m} (p: nat), pat m -> ty m ->  (fin p -> (ty m)) -> Prop.
Variable pat_eval : forall {m n} p, pat m -> tm m n -> (fin p -> (tm m n)) -> Prop.
Variable pat_ty_subst: forall {m n} (sigma: fin m -> ty n) p pt A Gamma, pat_ty m p pt A Gamma -> pat_ty n p (pt[sigma]) (A[sigma]) (Gamma >>  subst_ty sigma).

Inductive value {m n}: tm m n -> Prop :=
| Value_abs A s : value(abs A s)
| Value_tabs A s : value(tabs A s)
| Value_rec xs : (forall i s, In (i, s) xs -> value s) -> value (rectm xs).

Reserved Notation "'TY' Delta ; Gamma |- A : B"
  (at level 68, A at level 99, no associativity,
   format "'TY'  Delta ; Gamma  |-  A  :  B").

Inductive has_ty {m n} (Delta : ctx m) (Gamma : dctx  n m) : tm m n -> ty m -> Prop :=
| T_Var  x :
    TY Delta;Gamma |- var_tm x : Gamma x
  | T_abs (A: ty m) B (s: tm m (S n)):
    @has_ty m (S n) Delta (A .: Gamma) s B   ->
    TY Delta;Gamma |- abs A s : arr A B
| T_app A B s t: TY Delta;Gamma |- s : arr A B  -> TY Delta;Gamma |- t : A -> TY Delta;Gamma |- app s t : B
| T_tabs A B s : @has_ty (S m) n ((A .: Delta) >> ⟨↑⟩) (Gamma >> ⟨↑⟩) s B -> TY Delta;Gamma |- tabs A s : all A B
| T_Tapp A B A' s B' : TY Delta;Gamma |- s : all A B -> SUB Delta |- A' <: A -> B' = B[A'..] ->  TY Delta;Gamma |- tapp s A' : B'
| T_Rcd xs As : unique xs -> unique As -> label_equiv xs As
                -> (forall i A s, In (i, s) xs -> In (i, A) As -> TY Delta; Gamma |- s : A) -> TY Delta;Gamma |- rectm xs : recty As
| T_Proj xs j A As: TY Delta; Gamma |- xs : recty As -> In (j, A) As -> TY Delta; Gamma |- proj xs j : A
| letpat_ty p (pt: pat m) (s : tm m n) (t: tm m (p + n)) A (B : ty m) (Gamma': fin p -> ty m): has_ty Delta Gamma s A -> pat_ty _ p pt A Gamma' -> @has_ty m (p + n) Delta (scons_p p Gamma' Gamma) t B ->  has_ty Delta Gamma (letpat  p pt s t) B
| T_Sub A B s :
    TY Delta;Gamma |- s : A  -> SUB Delta |- A <: B   ->
    TY Delta;Gamma |- s : B
where "'TY' Delta ; Gamma |- s : A" := (has_ty Delta Gamma s A).

Lemma T_Var' {m n} (Delta : ctx m) (Gamma : dctx n m) x :
  forall A, A = Gamma x -> TY Delta;Gamma |- var_tm x : A.
Proof. intros A ->. now econstructor. Qed.

Reserved Notation "'EV' s => t"
  (at level 68, s at level 80, no associativity, format "'EV'  s  =>  t").

Inductive eval {m n} : tm m n -> tm m n -> Prop :=
| E_appabs A s t : EV app (abs A s) t => s[ids; t..]
| E_Tapptabs A s B : EV tapp (tabs A s) B => s[B..; ids]
| E_RecProj  xs j s : In (j, s) xs -> EV (proj (rectm  xs) j) => s
| letpat_eval p (pt : pat m) (s : tm m n) (t : tm m (p + n)) (sigma: fin p -> tm m n) :  pat_eval _ _ p pt s sigma -> eval (letpat  p pt s t) (subst_tm (@var_ty m) (scons_p _ sigma (@var_tm _ _)) t)
| E_appFun s s' t :
     EV s => s' ->
     EV app s t => app s' t
| E_appArg s s' v:
     EV s => s' -> value v ->
     EV app v s => app v s'
| E_TyFun s s' A :
     EV s => s' ->
     EV tapp s A => tapp s' A
| E_Proj s s' j : EV s => s' -> EV (proj s j) => (proj s' j)
| E_Rec l ts t t' : EV t => t' -> In (l,t) ts -> EV (rectm ts) => rectm (update ts l t')                  | E_LetL p pt s s' t : EV s => s' -> EV (letpat p pt s t) => (letpat p pt s'  t)
where "'EV' s => t" := (eval s t).

(** Assumptions of progress and typing on patterns. *)
Variable pat_progress : forall p pt s A Gamma, TY empty; empty |- s : A -> pat_ty _ p pt A Gamma -> exists sigma, pat_eval _ _ p pt s sigma.

(** Progress *)

Lemma can_form_arr {s: tm 0 0} {A B}:
  TY empty;empty |- s : arr A B -> value s -> exists C t, s = abs C t.
Proof.
  intros H.
  depind H; intros; eauto.
  all: try now (try destruct x0;  try inversion H1).
 + inversion H0; subst; eauto. inversion x.
Qed.

Lemma can_form_all {s A B}:
  TY empty;empty |- s : all A B -> value s -> exists C t, s = tabs C t.
Proof.
  intros H.
  depind H; intros; eauto.
  all: try now (try destruct x0; try inversion H1).
  + inv H0; subst.  inversion x.  eauto.
Qed.

Lemma can_form_rectm {s A}:
  TY empty;empty |- s : recty A -> value s -> exists xs, s = rectm xs /\ forall l A', In (l, A') A -> exists s', In (l, s') xs.
Proof.
  intros H.
  depind H; intros; eauto.
   all: try now (try destruct x0; try inversion H1).
  + eexists. split; eauto.
    intros. apply H1; eauto.
  +  inv H0; subst; eauto.
     * inversion x.
     * edestruct IHhas_ty as (?&?&?); eauto.
       subst. exists x; split; eauto. intros.
       edestruct (H3 _ _ H0).
       eapply H2. apply H5.
Qed.

Theorem ev_progress s A:
  TY empty;empty |- s : A -> value s \/ exists t,  EV s => t.
Proof.
  intros. depind H; eauto; try now (left; constructor).
   - inversion x.
   - right. edestruct IHhas_ty1 as [? | [? ?]]; try reflexivity; eauto.
    + edestruct (can_form_arr H H1) as [? [? ?]]; subst.
      eexists. econstructor.
    + eexists. econstructor. eauto.
  - right. edestruct IHhas_ty as [? | [? ?]]; try reflexivity; eauto.
    + edestruct (can_form_all H H1) as [? [? ?]]; subst. eexists. econstructor.
    + eexists. econstructor. eauto.
  - assert ((forall p, In p xs -> value (snd p)) \/ (exists p, In p xs /\ exists s', EV (snd p) => s')) as [|].
    { apply list_dec. intros (?&?) ?. cbn.
      assert (exists A, In (n, A) As) as (A&?). apply H1; eauto.
      eauto. }
    + left. constructor. intros. specialize (H4 (i, s)). eauto.
    + destruct H4 as ((l&s)&?&(s'&?)).
      right. exists (rectm (update xs l s')). econstructor; eauto.

  - right. edestruct IHhas_ty as [? | [? ?]]; eauto.
    + edestruct (can_form_rectm H H1) as [? [? ?]]; try reflexivity. subst.
      rename x into xs.
      enough (exists x, In (j, x) xs) as (?&?).
      * eexists. constructor. eauto.
      * inversion H; eauto.
    + eexists. constructor. eassumption.
  - edestruct (IHhas_ty1 pat_ty_subst pat_progress s0 A0) as [|[? ?]]; eauto.
    + right. edestruct (pat_progress _ _ _ _ _ H H0). eexists. econstructor. eauto.
    + right. eexists. apply E_LetL; eauto.
Qed.

(** Preservation *)

(* a.d. apparently need the following setoid morphism *)
Instance pat_ty_morphism {m p:nat} :
  Proper (eq ==> eq ==> pointwise_relation _ eq ==> Basics.flip Basics.impl) (pat_ty m p).
Proof.
  intros pat0 pat1 -> T0 T1 -> f f' Hf.
  intros x.
Admitted.
(* Require Import core_axioms fintype_axioms. *)

Lemma context_renaming_lemma m m' n n' (Delta: ctx m') (Gamma: dctx n' m')                                                   (s: tm m n) A (xi : fin m -> fin m') (zeta: fin n -> fin n') Delta' (Gamma' : dctx n m):
  (forall x, (Delta' x)⟨xi⟩ = Delta (xi x)) ->
  (forall (x: fin n) , (Gamma' x)⟨xi⟩ =  (Gamma (zeta x))) ->
  TY Delta'; Gamma' |- s : A -> TY Delta; Gamma |- s⟨xi;zeta⟩ : A⟨xi⟩.
Proof.
  intros H H' ty. autorevert ty.
  depind ty; asimpl; intros; subst; try now (econstructor; eauto).
  - rewrite H0. constructor.
  - constructor. eapply IHty; eauto.
    auto_case; asimpl.
  - cbn. econstructor. apply IHty; eauto.
    + auto_case; try now asimpl. rewrite <- H. now asimpl.
    + intros. asimpl. rewrite <- H'. now asimpl.
  - cbn. eapply T_Tapp with (A0 := A⟨xi⟩) .
    Unshelve.
    4: exact (ren_ty (upRen_ty_ty xi) B).
    eapply IHty; eauto.
    eapply sub_weak; eauto. now asimpl.
  - econstructor; eauto.
    + intros.
      eapply in_map_iff in H5. destruct H5 as ([]&?&?). inv H5.
      eapply in_map_iff in H6. destruct H6 as ([j A']&?&?). inv H5.
      eapply H3; eassumption.
  - cbn. econstructor; eauto. now apply in_map.
  - cbn. asimpl. apply letpat_ty  with (A0 := A⟨xi⟩) (Gamma'0 := Gamma' >> ⟨xi⟩); eauto.
    +  unfold funcomp. substify.
       (* DONE a.d. in this case substify should use setoid_rewrite instead of normal rewrite *)
      (* unfold funcomp. setoid_rewrite rinstInst'_ty. eauto. *)
       eauto.
    (* a.d. TODO the following only works with fext asimpl *)
    + asimpl. eapply IHty2; eauto.
      (* auto_unfold. *)
      (* unfold upRen_p.  *)
      (* Unset Printing Notations. *)
      (* this setoid rewrite unfold scons_p but I don't know why.
       the varL'_ty lemma is an equality with subst_ty and scons_p does not use subst_ty in its definition *)
      (* the problem seems to be that varL'_ty holds directly by voncertibility and the setoid rewrite also evaluates the lhs of varL'_ty which is then just subst_ty x = subst_ty x.
       Although I still don't understand where tha actual rewrite then happens b/c subst_ty does not appear in the goal.
       But we can fix this behavior by making either scons_p or subst_ty opaque for setoid rewriting. *)
      (* Hint Opaque scons_p : rewrite. *)
      (* Hint Opaque subst_ty : rewrite. *)
      (* Print HintDb rewrite. *)
      Fail setoid_rewrite varL'_ty.
      Info 2 asimpl.
      * intros z.
        (* adrian: had to add the following line to make it compile.*)
        unfold dctx in Gamma, Gamma0. unfold upRen_p.
        (* https://coq.zulipchat.com/#narrow/stream/237656-Coq-devs.20.26.20plugin.20devs/topic/Change.20of.20case.20representation/near/220411671 *)
        (* TODO why does setoid_rewrite H' fail even though it works when I just apply the morphism *)
        (* TODO why does setoid_rewrite scons_p_head' fail? but it works when I apply the morphism *)
        asimpl.
        unfold funcomp.
        now setoid_rewrite H'.
        (* (* Set Typeclasses Debug. *) *)
        (* (* try setoid_rewrite scons_p_tail'. *) *)
        (* (* asimpl. *) *)
        (* simple apply scons_p_morphism. *)
        (* -- now setoid_rewrite scons_p_head'. *)
        (* -- setoid_rewrite scons_p_tail'. now setoid_rewrite H'. *)
        (* Info 3 asimpl_fext. *)
        (* (* TODO actually I did not have to use fext here since the goal compates the output of scons_p and we have a morphism *) *)
        (* apply scons_p_morphism; easy. *)
        (* f_equal. fext. eauto. *)
  - econstructor. eauto. eapply sub_weak; eauto.
Qed.

Lemma context_renaming_lemma' m m' n n' (Delta: ctx m') (Gamma: dctx n' m')                                                   (s: tm m n) A (xi : fin m -> fin m') (zeta: fin n -> fin n') Delta' (Gamma' : dctx n m):
  (forall x, (Delta' x)⟨xi⟩ = Delta (xi x)) ->
  (forall (x: fin n) , (Gamma' x)⟨xi⟩ =  (Gamma (zeta x))) ->
  TY Delta'; Gamma' |- s : A -> forall s' A', s' = s⟨xi;zeta⟩ -> A' = A⟨xi⟩ -> TY Delta; Gamma |- s' : A'.
Proof. intros. subst. now eapply context_renaming_lemma. Qed.

Lemma context_morphism_lemma m m' n n' (Delta: ctx m) (Delta': ctx m') (Gamma: dctx n m) (s: tm m n) A (sigma : fin m -> ty m') (tau: fin n -> tm m' n') (Gamma' : dctx n' m'):
  (forall x, SUB Delta' |- sigma x <: (Delta x)[sigma]) ->
  (forall (x: fin n) ,  TY Delta'; Gamma' |- tau x : subst_ty sigma (Gamma x)) ->
  TY Delta; Gamma |- s : A -> TY Delta'; Gamma' |- s[sigma;tau] : A[sigma].
Proof.
   intros eq1 eq2 ty. autorevert ty.
   depind ty; intros; subst; asimpl; try now (econstructor; eauto).
  - constructor. eapply IHty; eauto.
    auto_case; asimpl.
    +  assert (subst_ty sigma (Gamma f)  = ((Gamma f)[sigma]⟨id⟩)) as -> by (now asimpl) .
       eapply context_renaming_lemma; eauto; now asimpl.
    + econstructor.
  - constructor. eapply IHty; eauto.
    + auto_case.
      * asimpl.
        specialize (eq1 f).
        eapply sub_weak1 with (C := A[sigma]) in eq1; eauto.  asimpl in eq1. eapply eq1.
    + intros x. asimpl.
      assert ((Gamma x) [sigma >> ⟨↑⟩] = (Gamma x)[sigma]⟨↑⟩) by (now asimpl).
      auto_unfold in *. rewrite H.
      eapply context_renaming_lemma; try eapply eq2.
      * intros. now asimpl.
      * intros. now asimpl.
  - eapply T_Tapp with (A0 := subst_ty sigma A) (B0 := B[up_ty_ty sigma]).
    asimpl in IHty. eapply IHty; eauto.
    eapply sub_substitution; eauto.
    now asimpl.
  - econstructor; eauto.
    + intros.
      eapply in_map_iff in H5. destruct H5 as ([]&?&?). inv H5.
      eapply in_map_iff in H4. destruct H4 as ([j A']&?&?). inv H4.
      eapply H3; eauto.
  - econstructor; eauto. now apply in_map.
  - econstructor; eauto.
     { eapply IHty2.
      * eauto.
      * intros x.
        destruct (destruct_fin x) as [[x' ->] |[x' ->]]; asimpl; eauto.
        -- eapply T_Var'. now asimpl.
        -- eapply context_renaming_lemma' with (Delta':=Delta'); try eapply eq2.
           Unshelve.
           5: exact id.
           5: exact (shift_p p).
           5: exact x'.
           all: now asimpl.
           (* instantiate (1:=id). *)
           (* try now asimpl. *)
           (* intros z. *)
           (* now asimpl. *)
           (* (* a.d. TODO got one more goal left from context_renaming_lemma' *) *)
           (* intros x. now asimpl. *)
     }

  - econstructor.
    + eapply IHty; eauto.
    + eapply sub_substitution; eauto.
Qed.

Lemma ty_inv_abs m n Delta Gamma A A' B C (s: tm m (S n)):
  TY Delta;Gamma |- abs A s : C   ->   SUB Delta |- C <: arr A' B   ->
  (SUB Delta |- A' <: A /\
    exists B', TY Delta; A .: Gamma |- s : B' /\ SUB Delta |- B' <: B).
Proof.
  intros H. depind H; intros.
   - inv H0. split; eauto.
   - edestruct (IHhas_ty pat_ty_subst pat_progress  _ _ _ _ (eq_refl _) (sub_trans _ _ _ _ _ H0 H1)) as (?&?&?&?).
     split.
     + assumption.
     + eauto.
Qed.

Lemma ty_inv_rec {m n} {Delta Gamma A As'} xs  :
  TY Delta;Gamma |- rectm xs: A  ->  SUB Delta |- A <: recty As' ->
   (  (forall (i : nat) (s : tm m n) B',
          In (i, s) xs -> In (i, B') As' ->  exists (B : ty m),  TY Delta;Gamma |- s : B /\ SUB Delta |- B <: B')).
Proof.
  intros H. depind H; intros.
  - inv H4. eauto.
    assert (exists A, In (i, A) As) as [A ?].
    + apply H1. eauto.
    + specialize (H2 _ _ _ H5 H4).
      destruct (H9 _ _ H6) as (?&?&?).
      assert (x = A) as -> by eauto using unique_spec.
      eauto.
  - eauto using sub_trans.
Qed.

Lemma ty_subst m n (Gamma: dctx m n) (Delta: ctx n) Delta' s A:
    (forall x, SUB Delta' |- Delta' x <: Delta x) ->
  TY Delta; Gamma |- s : A -> TY Delta'; Gamma |- s : A.
Proof.
  intros eq H. autorevert H. depind H; eauto; intros; try now (econstructor; eauto).
  - econstructor; eauto. asimpl. eapply IHhas_ty. auto_case; eauto using sub_refl.
    eapply sub_weak; try reflexivity. apply eq. intros x. now asimpl.
  - econstructor; eauto.
    replace A with (A[ids]) by (now asimpl). replace A' with (A'[ids]) by (now asimpl).
    eapply sub_substitution; eauto. intros x.
    asimpl. econstructor. eauto.
 - econstructor; eauto. eapply sub_substitution with (sigma := ids) (Delta':=Delta') in H0; eauto.
    asimpl in H0. eapply H0. intros x. econstructor. asimpl. eapply eq.
Qed.

Lemma ty_inv_tabs {m n} {Delta Gamma A A' B C} (s : tm (S m) n):
  TY Delta;Gamma |- tabs A s : C -> SUB Delta |- C <: all A' B   ->
  (SUB Delta |- A' <: A /\ exists B',
   TY (A'.:Delta) >> ren_ty ↑; Gamma >> ren_ty ↑ |- s : B' /\ SUB (A' .: Delta) >> ren_ty ↑ |- B' <: B).
Proof.
  intros H. depind H; intros.
  - inv H0. split; eauto.
    eexists. split; eauto.
    eapply ty_subst; try eapply H.
    auto_case. eapply sub_weak; try reflexivity; eauto.
  - eauto using sub_trans.
Qed.

Variable pat_ty_eval : forall m n p pt s A (Gamma: fin n -> ty m) Gamma' Delta sigma, pat_ty m p pt A Gamma' -> TY Delta; Gamma |- s : A -> pat_eval m n p pt s sigma -> forall (x: fin p), TY Delta; Gamma |- sigma x : Gamma' x.

Theorem preservation m n Delta Gamma (s: tm m n) t A :
  TY Delta;Gamma |- s : A -> EV s => t ->
  TY Delta;Gamma |- t : A.
Proof.
  intros H_ty H_ev. autorevert H_ev.
  induction H_ev; intros; eauto using ty.
  all: try now (depind H_ty; [econstructor; eauto|eapply T_Sub; eauto]).
  - depind H_ty; [|eauto].
    + inv H_ty1; subst.
      * replace B with (B[ids]) by (now asimpl).
        eapply context_morphism_lemma; eauto.
        -- intros. asimpl. repeat constructor. now apply sub_refl.
        -- intros [|]; intros; cbn; asimpl;  eauto. econstructor; eauto.
      * pose proof (ty_inv_abs _ _ _ _ _ _ _ _ _ H H0) as (?&?&?&?).
        eapply T_Sub; eauto.
        replace x with (x[var_ty]) by (now asimpl).
        eapply context_morphism_lemma; eauto.
        -- intros. asimpl. repeat constructor. apply sub_refl.
        -- intros [|]; intros; cbn; asimpl; eauto; econstructor; eauto.
     + asimpl. econstructor; eauto.
  - depind H_ty; eauto.
    + depind H_ty.
      * asimpl in H_ty.
        eapply context_morphism_lemma; try eapply H_ty; eauto.
        -- auto_case; asimpl; eauto using sub_refl.
        -- intros x. asimpl. constructor.
      * pose proof (ty_inv_tabs _ H_ty H) as (?&?&?&?).
        eapply T_Sub.
        eapply context_morphism_lemma; eauto.
        -- auto_case; asimpl; eauto.
        -- intros z. asimpl. constructor.
        -- eapply sub_substitution; eauto.
           auto_case; asimpl.
    + econstructor; eauto.
  -  depind H_ty; eauto.
    + depind H_ty.
      * eapply H2; eauto.
      * pose proof (ty_inv_rec _ H_ty H  _ _ _ H1 H0) as(?&?&?).
        subst. eapply T_Sub; eauto.
    + econstructor; eauto.
  - depind H_ty.
    + replace B with (B[ids]) by now asimpl.
      eapply context_morphism_lemma; try now apply H_ty2.
      * intros. asimpl. constructor. now apply sub_refl.
      * intros. destruct (destruct_fin x) as [[]|[]]; subst.
        -- asimpl. eapply pat_ty_eval; eauto.
           (* a.d. TODO had to exact Gamma' twice below. Apparenly it's not inferred somewhere *)
           (* exact Gamma'. *)
        -- asimpl. constructor.
           (* exact Gamma'. *)
    + eapply T_Sub; eauto.
  - depind H_ty; [|eapply T_Sub; eauto].
    econstructor; eauto.
    + intros.
      apply update_char in H5 as [|(->&->)]; eauto.
Qed.

End Pattern.

Print Assumptions preservation.


From mathcomp Require Import all_ssreflect.

Set Implicit Arguments.
Unset Printing Implicit Defensive.

Require Import ClassicalExtras.
Require Import MyNotation.
Require Import Setoid.
Require Import FunctionalExtensionality.

Require Import Galois.
Require Import LanguageModel.
Require Import TraceModel.
Require Import Properties.
Require Import ChainModel.

Require Import PropExtensionality.
Definition prop_extensionality := propositional_extensionality.

Section Robust2relSSCHPreservation.

  Variable Source Target: Language.
  Variable compilation_chain : CompilationChain Source Target.

  (*CA: we don't need a particular structure of traces to define preservation
        e.g. traces = values or our defn of traces both make sense
   *)
  Variable trace__S trace__T : Type.

  Local Definition prop__S := prop trace__S.
  Local Definition prop__T := prop trace__T.

  Variable Source_Semantics : Semantics Source trace__S.
  Variable Target_Semantics : Semantics Target trace__T.

  Local Definition sem__S := sem Source_Semantics.
  Local Definition sem__T := sem Target_Semantics.
  Local Definition beh__S := beh Source_Semantics.
  Local Definition beh__T := beh Target_Semantics.
  Local Definition par__S := par Source.
  Local Definition par__T := par Target.
  Local Definition ctx__S := ctx Source.
  Local Definition ctx__T := ctx Target.
  Local Definition rsat__S := rhsat2 Source_Semantics.
  Local Definition rsat__T := rhsat2 Target_Semantics.

  Local Definition cmp := compile_par Source Target compilation_chain.

  Local Notation "P ↓" := (cmp P) (at level 50).
 (* CA: don't understand why this does not work

   Local Notation " C [ P ] " := (plug _  P C) (at level 50).
  *)
  Local Definition plug__S:= plug Source.
  Local Definition plug__T := plug Target.

  (* still mappings on trace properties *)
  Variable σ__π : (trace__T -> Prop) -> (trace__S -> Prop).
  Variable τ__π : (trace__S -> Prop) -> (trace__T -> Prop).

  Definition prod_σ : (prop__T * prop__T -> Prop) -> (prop__S * prop__S -> Prop) :=
    fun T =>
      fun Π => exists π__T π__T', fst Π = σ__π π__T /\
                        snd Π = σ__π π__T' /\
                        T (π__T, π__T').

  Definition prod_τ : (prop__S * prop__S -> Prop) -> (prop__T * prop__T -> Prop) :=
    fun S =>
      fun Π => exists π__S π__S', fst Π = τ__π π__S /\
                        snd Π = τ__π π__S' /\
                        S (π__S, π__S').

  Definition sCl_σ :  ((trace__T -> Prop) * (trace__T -> Prop) -> Prop) ->
                      ((trace__S -> Prop) * (trace__S -> Prop) -> Prop) :=
   sCl2  ∘ prod_σ.

  Definition sCl_τ : ((trace__S -> Prop) * (trace__S -> Prop) -> Prop) ->
                     ((trace__T -> Prop) * (trace__T -> Prop) -> Prop) :=
    sCl2  ∘ prod_τ.

  Definition sCl_σR2rhP (P1 P2 : par__S) (T : prop__T * prop__T -> Prop) :=
    rsat__S P1 P2 (sCl_σ T) -> rsat__T (P1 ↓) (P2 ↓) T.

  Definition sCl_τR2rhP (P1 P2 : par__S) (S : prop__S * prop__S -> Prop) :=
    rsat__S P1 P2 S -> rsat__T (P1 ↓) (P2 ↓) (sCl_τ S).

  Lemma contra_τR2rhP (P1 P2 : par__S) (S : prop__S * prop__S -> Prop) :
    (sCl_τR2rhP P1 P2 S) <-> ((exists C__T,  ~ (sCl_τ S) (beh__T (plug__T (P1 ↓) C__T),
                                          beh__T (plug__T (P2 ↓) C__T ))) ->
                             (exists C__S, ~ S (beh__S (plug__S P1 C__S), beh__S (plug__S P2 C__S)))).
  Proof.
    rewrite /sCl_τR2rhP. by rewrite [_ -> _] contra !neg_rhsat2.
  Qed.

  Lemma Galois_fst_lift (Hadj : Adjunction_law τ__π σ__π) :
    forall T, SCH2 T ->
       (sCl_τ (sCl_σ (T)) ⊆ T).
  Proof.
    move => T SCH2T [b__T1 b__T2] [b__t1 [b__t2 [Hτ [H1 H2]]]].
    move: Hτ. move => [b__s1 [b__s2 [H11 [H22 Hσ]]]].
    destruct Hσ as [b__s1' [b__s2' [Hσ' [H1' H2']]]].
    destruct Hσ' as [bt1'[ bt2' [H11' [H22' HT]]]].
    simpl in *. subst.
    apply: SCH2T.
    exact HT.
    apply: subset_trans. exact H1. by rewrite Hadj.
    apply: subset_trans. exact H2. by rewrite Hadj.
  Qed.

  Lemma Galois_snd_lift (Hadj : Adjunction_law τ__π σ__π) :
    forall S, SCH2 S ->
         S ⊆ (sCl_σ (sCl_τ S)).
  Proof.
    move => S SCH2S [bs1 bs2] HS.
    exists (σ__π (τ__π bs1)), (σ__π (τ__π bs2)). split.
    + exists (τ__π bs1), (τ__π bs2). repeat (split; auto).
      ++ exists (τ__π bs1), (τ__π bs2). repeat (split; auto).
         +++ now exists bs1, bs2.
    rewrite /=. by repeat rewrite -Hadj.
  Qed.

  Theorem Adj_sCl_σR2rSCHP_iff_sCl_τR2rSCHP :
     Adjunction_law τ__π σ__π ->
    (forall P1 P2 T, SCH2 T -> sCl_σR2rhP P1 P2 T) <->
    (forall P1 P2 S, SCH2 S -> sCl_τR2rhP P1 P2 S).
  Proof.
    move => H_adj. split.
    - move => Hσ P1 P2 S S_ssc Hrsat_src.
      have Hfoo: SCH2 (sCl_τ S) by apply: sCl2_SCH2.
      have Hfoo': rsat__S P1 P2 (sCl_σ (sCl_τ S)).
      { apply: rhsat2_upper_closed.
        exact Hrsat_src.
        by apply: Galois_snd_lift. }
      by move: (Hσ P1 P2 (sCl_τ S) Hfoo Hfoo') => Hsat__T.
    - move => Hτ P1 P2 T T_ssc Hrrsat_tgt.
      have H : rsat__T (P1 ↓) (P2 ↓) (sCl_τ (sCl_σ T)).
      { apply: Hτ. apply: sCl2_SCH2. assumption. }
      apply: rhsat2_upper_closed. exact H.
      by apply: Galois_fst_lift.
  Qed.

End Robust2relSSCHPreservation.


Require Import TestSuite.admit.
(* -*- coq-prog-args: ("-indices-matter") -*- *)
(* File reduced by coq-bug-finder from original input, then from 5302 lines to 4649 lines, then from 4660 lines to 355 lines, then from 360 lines to 269 lines, then from 269 lines to 175 lines, then from 144 lines to 119 lines, then from 297 lines to 117 lines, then from 95 lines to 79 lines, then from 82 lines to 68 lines *)

Set Universe Polymorphism.
Generalizable All Variables.
Inductive sigT {A:Type} (P:A -> Type) : Type := existT : forall x:A, P x -> sigT P.
Notation "{ x : A  & P }" := (sigT (fun x:A => P)) : type_scope.
Definition projT1 {A} {P : A -> Type} (x : sigT P) : A := let (a, _) := x in a.
Definition projT2 {A} {P : A -> Type} (x : sigT P) : P (projT1 x) := let (a, h) return P (projT1 x) := x in h.
Axiom admit : forall {T}, T.
Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope.
Arguments idpath {A a} , [A] a.
Definition inverse {A : Type} {x y : A} (p : x = y) : y = x := match p with idpath => idpath end.
Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y := match p with idpath => u end.
Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := forall x : A, r (s x) = x.
Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv { equiv_inv : B -> A ; eisretr : Sect equiv_inv f }.
Record Equiv A B := BuildEquiv { equiv_fun :> A -> B ; equiv_isequiv :> IsEquiv equiv_fun }.
Existing Instance equiv_isequiv.
Global Instance isequiv_inverse `{IsEquiv A B f} : IsEquiv (@equiv_inv _ _ f _) | 10000 := admit.
Definition equiv_path_sigma `(P : A -> Type) (u v : sigT P)
: Equiv {p : projT1 u = projT1 v &  transport _ p (projT2 u) = projT2 v} (u = v) := admit.
Definition hfiber {A B : Type} (f : A -> B) (y : B) := { x : A & f x = y }.
Definition path_universe {A B : Type} (f : A -> B) : (A = B) := admit.
Section AssumeFunext.
  Let equiv_fibration_replacement_eissect {B C f}
  : forall x : {y : B & {x : C & f x = y}},
      existT _ (f (projT1 (projT2 x))) (existT _ (projT1 (projT2 x)) idpath) = x.
    admit.
  Defined.
  Definition equiv_fibration_replacement  {B C} (f:C ->B):
    Equiv C {y:B & {x:C & f x = y}}.
  Proof.
    refine (BuildEquiv
              _ _ _
              (BuildIsEquiv
                 C {y:B & {x:C & f x = y}}
                 (fun c => existT _ (f c) (existT _ c idpath))
                 (fun c => projT1 (projT2 c))
                 equiv_fibration_replacement_eissect)).
  Defined.
  Definition equiv_total_paths (A : Type) (P : A-> Type) (x y : sigT P) :
    Equiv (x = y) { p : projT1 x = projT1 y & transport P p (projT2 x) = (projT2 y) }
    := BuildEquiv _ _ (@equiv_inv _ _ _ (equiv_path_sigma P x y)) _.
  Variable A:Type.
  Definition Fam A:=sigT (fun I:Type  => I->A).
  Definition p2f: (A->Type)-> Fam A := fun Q:(A->Type) => existT _ (sigT Q) (@projT1 _ _).
  Definition f2p: Fam A -> (A->Type) := fun F => let (I, f) := F in (fun a => (hfiber f a)).
  Definition exp {U V:Type}(w:Equiv U V):Equiv (U->A) (V->A).
    exists (fun f:(U->A)=> (fun x => (f (@equiv_inv _ _ w _ x)))).
    admit.
  Defined.
  Goal { h : Fam A -> A -> Type & Sect h p2f }.
  exists f2p.
  intros [I f].
  set (e:=@equiv_total_paths _ _ (@existT Type (fun I0 : Type => I0 -> A) I f)
                             (existT _ {a : A & hfiber f a} (@projT1 _ _))).
  simpl in e.
  cut ( {p : I = {a : A & @hfiber I A f a} &
                                           @transport _ (fun I0 : Type => I0 -> A) _ _ p f = @projT1 _ _}).
  { intro X.
    apply (inverse (@equiv_inv _ _ _ e X)). }
  set (w:=@equiv_fibration_replacement A I f).
  exists (path_universe w).
  assert (forall x, (exp w) f x = projT1 x); [ | admit ].
  intros [a [i p]].
  exact p.
  Qed.
(* Toplevel input, characters 15-19:
Error: In pattern-matching on term "x" the branch for constructor
"existT(*Top.256 Top.258*)" has type
 "forall (I : Type) (f : I -> A),
  existT (fun I0 : Type => I0 -> A) {a : A & hfiber f a} projT1 =
  existT (fun I0 : Type => I0 -> A) I f" which should be
 "forall (x : Type) (H : x -> A),
  p2f (f2p (existT (fun I : Type => I -> A) x H)) =
  existT (fun I : Type => I -> A) x H".
 *)


Require Import List Arith Lia Morphisms Setoid.
From Undecidability.HOU Require Import calculus.calculus.
From Undecidability.HOU Require Import
        unification.higher_order_unification unification.nth_order_unification
        concon.conservativity_constants concon.conservativity.
Import ListNotations ArsInstances.

#[local] Fact ge_plus_l n m : n + m >= n.
Proof. apply Nat.le_add_r. Qed.

#[local] Fact ge_plus_r n m : m + n >= n.
Proof. apply Nat.le_add_l. Qed.

#[local] Hint Resolve ge_plus_l ge_plus_r : core.

(* * Constants *)
(* ** Adding Constants *)
Section Retracts.
    Variable (X Y: Const).
    Variable (RE: retract X Y).
    Hypothesis consts_agree: forall x: X, ctype X x = ctype Y (I x).

    Let inj (c: X) := const (I c).
    Let re (f: Y -> nat) (d: Y) :=
      match tight RE d with
      | Some x => const x
      | None => inhab X (f d) (ctype Y d)
      end.

    Lemma inj_ren delta: inj >> ren delta = inj.
    Proof.
      fext; reflexivity.
    Qed.

    Lemma re_ren f delta: re f >> ren delta = re (f >> delta).
    Proof.
      fext; intros x; unfold funcomp, re.
      destruct tight; auto. now rewrite inhab_ren.
    Qed.

    Lemma subst_consts_inject_forward sigma s:
      subst_consts inj (sigma • s) =
      (sigma >> subst_consts inj) • (subst_consts inj s).
    Proof.
      induction s in sigma |-*; cbn in *; intuition.
      - f_equal. rewrite inj_ren.
        rewrite IHs. f_equal.
        fext; intros []; cbn; auto.
        rewrite <-inj_ren with (delta := shift) at 1.
        unfold funcomp at 2. now rewrite ren_subst_consts_commute.
      - now rewrite IHs1, IHs2.
    Qed.

    Lemma subst_consts_inject_backwards sigma s f:
      subst_consts (re f) (sigma • subst_consts inj s) =
      (sigma >> subst_consts (re f)) • s.
    Proof.
      induction s in sigma, f |-*; cbn.
      - reflexivity.
      - unfold funcomp. unfold re. unfold tight. rewrite retr.
        destruct (I c == I c); intuition.
      - f_equal.
        rewrite subst_consts_up, inj_ren, re_ren; auto.
      - rewrite IHs1, IHs2; auto.
    Qed.

    Lemma inj_typing n sigma Gamma Delta:
       Delta ⊩(n) sigma : Gamma ->
       Delta ⊩(n) sigma >> subst_consts inj : Gamma.
    Proof using consts_agree.
      intros ????. eapply ordertyping_preservation_consts; auto.
      intros ??; unfold inj.
      rewrite consts_agree.
      econstructor; rewrite <-consts_agree.
      eapply typing_constants; eauto.
    Qed.

    Lemma re_typing n Delta f sigma Gamma:
      1 <= n ->
      Delta ⊩(n) sigma : Gamma ->
      (forall x c, x ∈ dom Gamma -> c ∈ consts (sigma x) -> nth Delta (f c) = Some (target (ctype Y c))) ->
      Delta ⊩(n) sigma >> subst_consts (re f) : Gamma.
    Proof using consts_agree.
      intros L T Sub x A H; unfold funcomp.
      eapply ordertyping_preservation_consts; auto.
      intros y H'.
      unfold re. destruct (tight RE y) eqn: EQr.
      - eapply tight_is_tight in EQr. subst. rewrite <-consts_agree.
        econstructor. rewrite consts_agree. eapply typing_constants; eauto.
      - eapply ordertyping_monotone, inhab_typing; domin H; eauto.
    Qed.

    Program Instance unification_retract {n} (I: orduni n X) : orduni n Y :=
      {
        s₀ := subst_consts inj s₀;
        t₀ := subst_consts inj t₀;
        A₀ := A₀;
        Gamma₀ := Gamma₀;
      }.
    Next Obligation.
      eapply ordertyping_preservation_consts. eapply H1₀.
      intros x H1. unfold inj. rewrite consts_agree.
      econstructor. rewrite <-consts_agree.
      eapply typing_constants. eapply H1₀. auto.
    Qed.
    Next Obligation.
      eapply ordertyping_preservation_consts. eapply H2₀.
      intros x H1. unfold inj. rewrite consts_agree.
      econstructor. rewrite <-consts_agree.
      eapply typing_constants. eapply H2₀. auto.
    Qed.

    Lemma unification_retract_forward n (I: orduni n X):
      OU n X I -> OU n Y (unification_retract I).
    Proof.
      intros (Delta & sigma & T & EQ).
      exists Delta. exists (sigma >> subst_consts inj). split.
      - now eapply inj_typing.
      - unfold s₀, t₀; cbn.
        rewrite <-!subst_consts_inject_forward.
        now rewrite EQ.
    Qed.

    Lemma unification_retract_backward n (I: orduni n X):
      1 <= n -> OU n Y (unification_retract I) -> OU n X I.
    Proof.
      intros Leq (Delta & sigma & T & EQ).
      pose (C := Consts (map sigma (nats (length Gamma₀)))).
      pose (f y := match find y C with
                  | Some x => length Delta + x
                  | None => 0
                  end).
      exists (Delta ++ target' (map (ctype Y) C)).
      exists (sigma >> subst_consts (re f)). split.
      - eapply re_typing; auto.
        intros ???. eapply weakening_ordertyping_app; auto.
        intros x y H1 H2. eapply Consts_consts with (S := map sigma (nats (| Gamma₀ |))) in H2;
                            auto using in_map, lt_nats.
        unfold f, C. eapply find_in in H2 as [? H3]; rewrite H3.
        rewrite nth_error_app2; simplify; auto.
        unfold target'; erewrite map_map, map_nth_error; simplify; auto.
        now eapply find_Some.
      - unfold s₀, t₀ in EQ; cbn in EQ.
        now rewrite <-!subst_consts_inject_backwards, EQ.
    Qed.

    Lemma unification_constants_monotone n:
      1 <= n -> OU n X ⪯ OU n Y.
    Proof using re inj consts_agree RE.
      intros H; exists unification_retract.
      intros I; split;
        auto using unification_retract_forward, unification_retract_backward.
    Qed.

End Retracts.

(* ** Removing Constants *)
Section RemoveConstants.

  Variable (X Y: Const) (RE: retract Y X).

  Hypothesis (consts_agree: forall y, ctype Y y = ctype X (I y)).

  Let R' x  := tight RE x.

  Let enc_const (A: list X) (x: X): exp Y  :=
    match R' x with
    | Some y => const y
    | None =>
      match find x A with
      | Some n => var n
      | None => var 0
      end
    end.

  Let enc_var (A: list X) (y: nat) : exp X :=
    AppR (var (y + length A)) (map var (nats (length A))).

  Let enc_term (C: list X) (s: exp X): exp Y :=
    Lambda (length C) (subst_consts (enc_const C) (enc_var C • s)).

  Let enc_type (C: list X) (A: type): type :=
    Arr (rev (map (ctype X) C)) A.

  Let enc_ctx (C: list X) (Gamma: ctx): ctx :=
    map (enc_type C) Gamma.

  Let enc_subst (C: list X) (sigma: fin -> exp X) (x: nat) :=
    enc_term C (sigma x).

  Let ι (y: Y) : exp X := const (I y).

  Let inv_term C (s: exp Y) :=
    AppR (subst_consts ι s) (map const C).

  Let inv_subst C (sigma: fin -> exp Y) (x: nat) :=
    inv_term C (sigma x).

  Section EncodingLemmas.
    Variable (C: list X) (n: nat).
    Hypothesis (O: ord' (map (ctype X) C) < n).

    Lemma remove_constants_ordertyping Gamma s A:
      Gamma ⊢(n) s : A ->
      (forall x, x ∈ consts s -> R' x = None -> x ∈ C) ->
      enc_ctx C Gamma ⊢(n) enc_term C s : enc_type C A.
    Proof using consts_agree O.
      intros T H. eapply Lambda_ordertyping; simplify; trivial.
      eapply ordertyping_preservation_consts.
      eapply ordertyping_weak_preservation_under_substitution; [eassumption|..].
      - intros y B H1 H2. unfold enc_var.
        eapply AppR_ordertyping.
        + eapply map_var_typing with (L := map (ctype X) C).
          * intros x; rewrite dom_lt_iff; simplify.
            intros ? % nats_lt; lia.
          * rewrite select_nats.
            rewrite firstn_app; simplify.
            rewrite <-firstn_all; cbn; now simplify.
          * auto.
        + econstructor; simplify; [split;[trivial|]|].
          eapply vars_ordertyping_nth with (n := n) (Gamma := Gamma)
            in H1; eauto.
          unfold enc_ctx;
            erewrite nth_error_app2, map_nth_error; simplify; now auto.
      - intros x H'. unfold enc_const.
        eapply consts_subst_in in H' as [].
        destruct (R' x) eqn: EQ.
        + eapply tight_is_tight in EQ as EQ'; subst x.
          rewrite <-consts_agree. econstructor.
          rewrite consts_agree. eapply typing_constants; eauto.
        + destruct find eqn: H1.
          * eapply find_Some in H1.
            econstructor. rewrite <-O.
            now eapply ord'_in, in_map, H.
            rewrite nth_error_app1; simplify;
              eauto using nth_error_Some_lt.
            erewrite map_nth_error; now auto.
          * exfalso.
            eapply find_not_in in H1; intuition.
        + unfold enc_var in H0. destruct H0. intuition.
          rewrite consts_AppR in H2. simplify in H2.
          unfold Consts in H2; eapply in_flat_map in H2 as [].
          intuition. mapinj. cbn in H3; intuition.
    Qed.

  Lemma inv_term_typing Gamma s A:
    Gamma ⊢(n) s : enc_type C A ->
    Gamma ⊢(n) inv_term C s : A.
  Proof using consts_agree O.
    intros H; unfold inv_term.
    eapply AppR_ordertyping with (L := map (ctype X) C).
    eapply const_ordertyping_list. rewrite O; auto.
    eapply ordertyping_preservation_consts; [auto|].
    intros y ?; rewrite consts_agree.
    econstructor. rewrite <-consts_agree.
    eapply typing_constants; eauto.
  Qed.

  Lemma remove_constants_ordertypingSubst Delta sigma Gamma :
     Delta ⊩(n) sigma : Gamma ->
    (forall x c, c ∈ consts (sigma x) -> R' c = None -> c ∈ C) ->
    enc_ctx C Delta ⊩(n) enc_subst C sigma : enc_ctx C Gamma.
  Proof using consts_agree O.
    intros ?????. unfold enc_ctx in H1. rewrite nth_error_map_option in H1.
    destruct nth eqn: EQ; try discriminate; injection H1 as <-.
    eapply remove_constants_ordertyping; eauto.
  Qed.

  Lemma inv_subst_typing Delta sigma Gamma:
     Delta ⊩(n) sigma : enc_ctx C Gamma ->
     Delta ⊩(n) inv_subst C sigma : Gamma.
  Proof using consts_agree O.
    intros ????. eapply inv_term_typing, H.
    unfold enc_ctx; erewrite map_nth_error; auto.
  Qed.

  (* maybe a setoid bug *)
  #[local] Unset Default Proof Using.
  #[export] Instance enc_proper:
    Proper (equiv (@step X) ++> equiv (@step Y)) (enc_term C).
  Proof.
    intros ?? H; unfold enc_term; now rewrite H.
  Qed.
  #[local] Set Default Proof Using "Type".

  #[export] Instance inv_proper:
    Proper (equiv (@step Y) ++> equiv (@step X)) (inv_term C).
  Proof.
    intros ?? H; unfold inv_term; now rewrite H.
  Qed.

  Lemma subst_consts_subst Z (s: exp X) sigma tau theta zeta (kappa: X -> exp Z):
    (forall x, x ∈ vars s -> sigma • subst_consts zeta (tau x) >* subst_consts kappa (theta x)) ->
    (forall x, x ∈ consts s -> sigma • zeta x >* kappa x) ->
    sigma • subst_consts zeta (tau • s) >* subst_consts kappa (theta • s).
  Proof using n RE C.
    induction s in sigma, zeta, tau, kappa, theta |-*.
    - cbn; intros; eapply H; now econstructor.
    - cbn; intros; eapply H0; auto.
    - cbn -[vars]; intros.
      rewrite IHs with (kappa := kappa >> ren shift) (theta := up theta); [easy|..].
      + intros []; cbn; [easy|].
        unfold funcomp at 2.
        rewrite ren_subst_consts_commute.
        unfold funcomp at 2. rewrite ren_subst_consts_commute.
        unfold up. asimpl.
        erewrite <-compSubstSubst_exp; try reflexivity.
        intros; eapply subst_steps, H. auto.
      + intros x. unfold funcomp.
        asimpl. erewrite <-compSubstSubst_exp; try reflexivity.
        intros; eapply subst_steps, H0; auto.
    - intros; cbn; rewrite IHs1, IHs2; try reflexivity.
      1, 3: intros; eapply H; auto.
      all: intros; eapply H0; cbn; simplify; intuition.
  Qed.

  Lemma enc_subst_term_reduce tau s:
    (forall x c, c ∈ consts (tau x) -> R' c = None -> c ∈ C) ->
    (forall x, x ∈ consts s -> R' x = None -> x ∈ C) ->
    enc_subst C tau • enc_term C s >* enc_term C (tau • s).
  Proof using n.
    intros H1 H2; unfold enc_term. asimpl. eapply Lambda_steps_proper.
    rewrite subst_consts_subst; trivial.
    - intros x ?. unfold funcomp at 1.
      unfold enc_var.
      rewrite !subst_consts_AppR, AppR_subst; cbn.
      rewrite it_up_ge; simplify; trivial.
      rewrite map_id_list; cbn.
      rewrite map_map; cbn. change (fun x => @var Y x) with (@var Y).
      unfold enc_subst at 1, enc_term. rewrite Lambda_ren.
      rewrite AppR_Lambda'; simplify; trivial.
      asimpl. rewrite subst_consts_subst; trivial.
      + intros ? ?; unfold funcomp.
        unfold enc_var. rewrite idSubst_exp; trivial.
        intros y; cbn.
        destruct (le_lt_dec (length C) y).
        rewrite it_up_ren_ge, (Nat.add_comm (| C |)), (Nat.add_comm (| C |)), Nat.sub_add, sapp_ge_in; simplify; trivial.
        erewrite it_up_ren_lt, nth_error_sapp; trivial.
        erewrite map_nth_error; auto using nth_nats.
      + unfold enc_const; intros c; destruct (R' c) eqn: ?; cbn; trivial.
        intros [m H'] % H1 % find_in; trivial; rewrite H'.
        eapply find_Some, nth_error_Some_lt in H'.
        cbn; unfold funcomp; erewrite it_up_ren_lt, nth_error_sapp; trivial.
        erewrite map_nth_error; auto using nth_nats.
      + intros ? ?; mapinj; mapinj; cbn; rewrite it_up_lt; auto using nats_lt.
    - unfold enc_const; intros c; destruct (R' c) eqn: ?; cbn; trivial.
      intros [m H'] % H2 % find_in; trivial; rewrite H'.
      eapply find_Some, nth_error_Some_lt in H'.
      now cbn; erewrite it_up_lt.
  Qed.

  Lemma enc_term_app sigma s:
    (forall x, x ∈ consts s -> R' x = None -> x ∈ C) ->
    inv_term C (sigma • enc_term C s) >* inv_subst C sigma • s.
  Proof using n.
    intros H. unfold enc_term, inv_term.
    asimpl. rewrite subst_consts_Lambda.
    rewrite AppR_Lambda'; simplify; trivial.
    replace (ι >> _) with ι by (fext; intros ?; reflexivity).
    pose (theta x := AppR
              (subst_consts ι (ren (plus (length C)) (sigma x)))
              (map var (nats (length C)))).
    erewrite subst_consts_subst with (kappa := enc_const C) (theta := theta).
    - rewrite subst_consts_comp.
      rewrite subst_consts_subst with (kappa := const) (theta := inv_subst C sigma) .
      rewrite subst_consts_ident; auto.
      + intros x V. unfold theta, inv_subst.
        rewrite subst_consts_AppR, subst_consts_comp.
        rewrite map_id_list.
        2: intros ??; mapinj; reflexivity.
        rewrite subst_consts_ident; trivial.
        replace (ι >> _) with (ι >> ren (plus (length C))).
        2: fext; intros c; unfold funcomp, enc_const, R';
          cbn; now rewrite tight_retr.
        rewrite ren_subst_consts_commute. unfold inv_term. asimpl.
        eapply refl_star. f_equal.
        * eapply idSubst_exp. intros y; unfold funcomp.
          erewrite sapp_ge_in; simplify; auto.
        * clear theta V. eapply list_pointwise_eq.
          intros m; rewrite !nth_error_map_option.
          destruct (le_lt_dec (length C) m) as [H1|H1].
          -- edestruct nth_error_None as [_ ->].
             edestruct nth_error_None as [_ ->].
             all: cbn; simplify; auto.
          -- rewrite nth_nats; trivial; cbn.
             destruct (nth_error_lt_Some _ m C) as [c H3]; trivial.
             rewrite H3; cbn. erewrite nth_error_sapp; trivial.
             erewrite map_nth_error; auto.
      + intros ??. unfold funcomp.
        unfold enc_const.
        destruct (R' x) eqn: ?. cbn.
        eapply tight_is_tight in Heqo; now subst.
        eapply H in H0; trivial.
        eapply find_in in H0 as [m H0]; rewrite H0.
        cbn. erewrite nth_error_sapp; trivial.
        erewrite map_nth_error; trivial.
        eapply find_Some; auto.
    - intros; unfold enc_var, theta.
      rewrite subst_consts_AppR; cbn.
      rewrite AppR_subst; cbn; rewrite it_up_ge; trivial; simplify.
      rewrite subst_consts_AppR, subst_consts_comp, subst_consts_ident.
      2: intros ?; unfold funcomp, enc_const, R'; cbn; now rewrite tight_retr.
      eapply refl_star. f_equal.
      rewrite map_id_list; trivial.
      intros ??; mapinj; mapinj; cbn.
      rewrite it_up_lt; auto using nats_lt.
    - intros. unfold enc_const. destruct (R' x) eqn: ?. cbn.
      eapply tight_is_tight in Heqo; now subst.
      eapply H in H0; trivial.
      eapply find_in in H0 as [m H0]; rewrite H0.
       eapply find_Some, nth_error_Some_lt in H0.
      cbn; erewrite it_up_lt; auto.
  Qed.

  Lemma enc_inv_motivation s:
    (forall x, x ∈ consts s -> R' x = None -> x ∈ C) ->
    inv_term C (enc_term C s) >* (fun x => AppR (var x) (map const C)) • s.
  Proof using n.
    intros H. replace (enc_term C s) with (var • enc_term C s) by now asimpl.
    rewrite enc_term_app; auto.
  Qed.

  End EncodingLemmas.

  Definition iConsts {n} (I: orduni n X) :=
    filter (fun x => if R' x == None then true else false)
           (Consts [s₀; t₀]).

  Program Instance remove_constants n (I: orduni n X)
          (H: ord' (map (ctype X) (iConsts I)) < n) : orduni n Y :=
    {
      s₀ := enc_term (iConsts I) s₀;
      t₀ := enc_term (iConsts I) t₀;
      A₀ := enc_type (iConsts I) A₀;
      Gamma₀ := enc_ctx (iConsts I) Gamma₀;
    }.
  Next Obligation.
    eapply remove_constants_ordertyping; trivial using H1₀.
    cbn; simplify; intuition.
    eapply filter_In; destruct eq_dec; intuition (auto with datatypes).
  Qed.
  Next Obligation.
    eapply remove_constants_ordertyping; trivial using H2₀.
    cbn; simplify; intuition.
    eapply filter_In; destruct eq_dec; intuition (auto with datatypes).
  Qed.

  Lemma remove_constants_forward n (I: orduni n X)
        (H: ord' (map (ctype X) (iConsts I)) < n):
    OU n X I -> OU n Y (remove_constants n I H).
  Proof.
    assert (1 <= n) as L by lia.
    destruct I as [Gamma s t A H1 H2]; intros (Delta & tau' & T' & E'); cbn in *.
    eapply downcast_constants_ordered in T'
      as (Sigma & tau & T & E & _ & Cs); [|eauto..]; clear tau' E'.
    pose (C := filter (fun x => if R' x == None then true else false)
          (Consts [s; t])).
    exists (enc_ctx C (Delta ++ Sigma)).
    exists (enc_subst C tau). split.
    - eapply remove_constants_ordertypingSubst; trivial.
      intros ? ? ? % Cs. intros ?; cbn; eapply filter_In.
      intuition. destruct eq_dec; intuition.
    - cbn [s₀ t₀ remove_constants iConsts Consts flat_map];
        simplify; unfold C.
      cbn in Cs; simplify in Cs.
      rewrite !enc_subst_term_reduce; trivial; intuition trivial.
      now rewrite E.
      all: eapply filter_In; destruct eq_dec; cbn; intuition (auto with datatypes).
      all: rewrite app_nil_r; eauto.
  Qed.

  Lemma remove_constants_backward n (I: orduni n X)
        (H: ord' (map (ctype X) (iConsts I)) < n):
    OU n Y (remove_constants n I H) -> OU n X I.
  Proof.
    pose (C := iConsts I).
    destruct I as [Gamma s t A H1 H2]; intros (Delta & sigma & T & EQ).
    exists Delta. exists (inv_subst C sigma). split; [auto using inv_subst_typing|].
    rewrite <-!enc_term_app. cbn [s₀ t₀ remove_constants] in EQ.
    unfold C; now rewrite EQ. 1,3: auto.
    all: intros; eapply filter_In; cbn; (intuition (auto with datatypes)); destruct eq_dec; intuition (auto with datatypes).
  Qed.

  Lemma remove_constants_reduction n:
    1 <= n ->
    (forall x, tight RE x = None -> ord (ctype X x) < n) -> OU n X ⪯ OU n Y.
  Proof using consts_agree.
    intros L ?.
    assert (forall I: orduni n X, ord' (map (ctype X) (iConsts I)) < n) as O.
    - intros ?; destruct n; try lia.
      eapply le_n_S, ord'_elements.
      intros; mapinj. cbn in H2; simplify in H2.
      eapply filter_In in H2 as [].
      destruct (R' x == None); try discriminate.
      now eapply le_S_n, H.
    - exists (fun I => remove_constants n I (O I)).
      intros I; split.
      eapply remove_constants_forward.
      eapply remove_constants_backward.
  Qed.

End RemoveConstants.