Add LoadPath "somePath".

Require Export sound.

(*----------complete cons----------*)

Lemma conj_distribute_prv_tree : forall E:BES, forall G:propVar_relation, forall f g:propForm,
  conj_propForm f -> DNF_propForm g -> prv_tree E (stmt G (f /\p g) (distribute f g)).
Proof.
intros.
induction H0 using DNF_ind.
destruct f;simpl in *;try apply REF.
inversion H.
destruct f;simpl in *;try apply REF.
inversion H.
destruct f;simpl in *;try apply REF.
inversion H.
destruct f;simpl in *;try apply REF.
inversion H.

apply (TRA _ _ ((f /\p f0) \/p (f /\p g))).
apply DS3.
apply (TRA _ _ ((f /\p f0) \/p (distribute f (f0 \/p g)))).
destruct (exists_unused (f /\p f0)).
apply (TRA _ _ ((f /\p f0) \/p distribute f g)).
specialize (CTX E (f /\p g) (distribute f g) ((f /\p f0) \/p var x) x G IHDNF_propForm2).
simpl;intro.
assert (~uses f x).
intro.
apply H0.
left;auto.
rewrite (unused_no_rewrite _ _ _ H2) in H1.
rewrite (unused_no_rewrite _ _ _ H2) in H1.
assert (~uses f0 x).
intro.
apply H0.
right;auto.
rewrite (unused_no_rewrite _ _ _ H3) in H1.
rewrite (unused_no_rewrite _ _ _ H3) in H1.
rewrite <- (beq_nat_refl _) in H1.
assumption.
assert (prv_tree E (G |- distribute f g --> distribute f (f0 \/p g))).
clear IHDNF_propForm1 IHDNF_propForm2.
destruct f;simpl.
remember ((fix distribute1 (g0 : propForm) : propForm :=
         match g0 with
         | top => top /\p g0
         | bot => top /\p g0
         | var _ => top /\p g0
         | g1 \/p g2 => distribute1 g1 \/p distribute1 g2
         | _ /\p _ => top /\p g0
         end) g) as gd.
remember ((fix distribute1 (g0 : propForm) : propForm :=
         match g0 with
         | top => top /\p g0
         | bot => top /\p g0
         | var _ => top /\p g0
         | g1 \/p g2 => distribute1 g1 \/p distribute1 g2
         | _ /\p _ => top /\p g0
         end) f0) as f0d.
apply (TRA _ _ (gd \/p f0d)).
apply SUP.
apply COM2.
remember ((fix distribute1 (g0 : propForm) : propForm :=
         match g0 with
         | top => bot /\p g0
         | bot => bot /\p g0
         | var _ => bot /\p g0
         | g1 \/p g2 => distribute1 g1 \/p distribute1 g2
         | _ /\p _ => bot /\p g0
         end) g) as gd.
remember ((fix distribute1 (g0 : propForm) : propForm :=
         match g0 with
         | top => bot /\p g0
         | bot => bot /\p g0
         | var _ => bot /\p g0
         | g1 \/p g2 => distribute1 g1 \/p distribute1 g2
         | _ /\p _ => bot /\p g0
         end) f0) as f0d.
apply (TRA _ _ (gd \/p f0d)).
apply SUP.
apply COM2.
remember ((fix distribute1 (g0 : propForm) : propForm :=
         match g0 with
         | top => var p /\p g0
         | bot => var p /\p g0
         | var _ => var p /\p g0
         | g1 \/p g2 => distribute1 g1 \/p distribute1 g2
         | _ /\p _ => var p /\p g0
         end) g) as gd.
remember ((fix distribute1 (g0 : propForm) : propForm :=
         match g0 with
         | top => var p /\p g0
         | bot => var p /\p g0
         | var _ => var p /\p g0
         | g1 \/p g2 => distribute1 g1 \/p distribute1 g2
         | _ /\p _ => var p /\p g0
         end) f0) as f0d.
apply (TRA _ _ (gd \/p f0d)).
apply SUP.
apply COM2.
inversion H.
remember ((fix distribute1 (g0 : propForm) : propForm :=
         match g0 with
         | top => (f1 /\p f2) /\p g0
         | bot => (f1 /\p f2) /\p g0
         | var _ => (f1 /\p f2) /\p g0
         | g1 \/p g2 => distribute1 g1 \/p distribute1 g2
         | _ /\p _ => (f1 /\p f2) /\p g0
         end) g) as gd.
remember ((fix distribute1 (g0 : propForm) : propForm :=
         match g0 with
         | top => (f1 /\p f2) /\p g0
         | bot => (f1 /\p f2) /\p g0
         | var _ => (f1 /\p f2) /\p g0
         | g1 \/p g2 => distribute1 g1 \/p distribute1 g2
         | _ /\p _ => (f1 /\p f2) /\p g0
         end) f0) as f0d.
apply (TRA _ _ (gd \/p f0d)).
apply SUP.
apply COM2.
specialize (CTX E (distribute f g) (distribute f (f0 \/p g)) ((f /\p f0) \/p var x) x G H1).
simpl;intro.
assert (~uses f x).
intro.
apply H0.
left;auto.
assert (~uses f0 x).
intro.
apply H0.
right;auto.
rewrite (unused_no_rewrite _ _ _ H3) in H2.
rewrite (unused_no_rewrite _ _ _ H3) in H2.
rewrite (unused_no_rewrite _ _ _ H4) in H2.
rewrite (unused_no_rewrite _ _ _ H4) in H2.
rewrite <- (beq_nat_refl _) in H2.
assumption.
apply (TRA _ _ (distribute f (f0 \/p g) \/p distribute f (f0 \/p g))).
destruct (exists_unused (distribute f (f0 \/p g))).
assert (prv_tree E (G |- f /\p f0 --> distribute f (f0 \/p g))).
apply (TRA _ _ (distribute f f0));auto.
clear - H H0_ H0_0.
destruct f;simpl;try apply SUP.
inversion H.
specialize (CTX E (f /\p f0) (distribute f (f0 \/p g)) (var x \/p distribute f (f0 \/p g)) x G H1).
simpl;intro.
rewrite (unused_no_rewrite _ _ _ H0) in H2.
rewrite (unused_no_rewrite _ _ _ H0) in H2.
rewrite <- (beq_nat_refl x) in H2.
assumption.
apply ID2.
Qed.

Lemma complete_to_bot : forall E:BES, forall G:propVar_relation, forall f:propForm,
  propForm_cons f bot -> prv_tree E (stmt G f bot).
Proof.
intros.
unfold propForm_cons in H.
specialize (propForm_eqv_bot f).
intro.
induction f;simpl in *.
exfalso.
apply (H empty_environment).
auto.
apply (REF).
specialize (H full_environment).
exfalso;apply H;auto.
unfold not in H0.
destruct H0.
specialize (H0 H).
assert (forall theta : environment, [[f1]]theta -> False).
intros.
apply (H theta).
left;assumption.
assert (forall theta : environment, [[f2]]theta -> False).
intros.
apply (H theta).
right;assumption.
specialize (IHf1 H2).
specialize (IHf2 H3).
specialize (IHf1 (propForm_eqv_bot f1)).
specialize (IHf2 (propForm_eqv_bot f2)).
apply (TRA _ _ (f1 \/p bot) _).
destruct (exists_unused f1) as [x Hn].
specialize (CTX E f2 bot (f1 \/p var x) x G IHf2).
intro.
simpl in H4.
rewrite<- (beq_nat_refl x) in *.
rewrite (unused_no_rewrite f1 f2 x Hn) in H4.
rewrite (unused_no_rewrite f1 bot x Hn) in H4.
assumption.
apply (TRA E (f1 \/p bot) (bot \/p bot) bot).
apply (TRA E _ (bot \/p f1) _).
exact (COM2 E f1 bot G).
specialize (CTX E f1 bot (bot \/p var 0) 0 G).
intros.
simpl in H4.
apply H4.
assumption.
exact (ID2 E bot G).

cut ((forall theta : environment, ~[[f1]]theta) \/ (forall theta:environment, ~[[f2]]theta)).
intros.
destruct H1.
apply (TRA _ _ (f2 /\p bot) _).
destruct (exists_unused f2) as [x Hn].
specialize (IHf1 H1).
specialize (IHf1 (propForm_eqv_bot f1)).
apply (TRA _ _ (f2 /\p f1) _).
apply COM1.
specialize (CTX E f1 bot (f2 /\p var x) x G IHf1).
intros.
simpl in H2.
rewrite<- (beq_nat_refl x) in *.
rewrite (unused_no_rewrite f2 f1 x Hn) in H2.
rewrite (unused_no_rewrite f2 bot x Hn) in H2.
assumption.
apply (TRA _ _ (bot /\p f2) _).
apply (COM1).
apply INF.
apply (TRA _ _ (f1 /\p bot) _).
destruct (exists_unused f1) as [x Hn].
assert (forall theta : environment, [[f2]]theta -> False).
intros.
apply (H1 theta).
assumption.
specialize (IHf2 H1).
specialize (IHf2 (propForm_eqv_bot f2)).
specialize (CTX E f2 bot (f1 /\p var x) x G IHf2).
intros.
simpl in H3.
rewrite<- (beq_nat_refl x) in *.
rewrite (unused_no_rewrite f1 f2 x Hn) in H3.
rewrite (unused_no_rewrite f1 bot x Hn) in H3.
assumption.
apply (TRA _ _ (bot /\p f1) _).
apply (COM1).
apply INF.

unfold propForm_eqv in H0.
simpl in H0.
destruct H0.
specialize (H0 H).
destruct (eqv_bot_dec f1).
left;assumption.
destruct (eqv_bot_dec f2).
right;assumption.
destruct H2 as [theta1 H2].
destruct H3 as [theta2 H3].
specialize (H (environment_union theta1 theta2)).
exfalso.
apply H.
apply (environment_union_distributes).
auto.
Qed.

Lemma complete_from_top : forall E:BES, forall G:propVar_relation, forall f:propForm,
  propForm_cons top f -> prv_tree E (stmt G top f).
Proof.
intros.
unfold propForm_cons in H.
destruct (propForm_eqv_top f).
induction f;simpl in *.
apply (REF).

exfalso.
apply (H empty_environment).
auto.

specialize (H empty_environment).
assert false;unfold empty_environment in H.
  apply H;auto.
inversion H2.

assert (forall theta:environment, [[f1]]theta \/ [[f2]]theta).
  intros;auto.
specialize (H0 H2).
assert (propForm_eqv f1 top \/ propForm_eqv f2 top).
  clear IHf1 IHf2.
  destruct (eqv_top_decidable f1).
  left;assumption.
  destruct (eqv_top_decidable f2).
  right;assumption.
  exfalso.
  assert True;auto.
  destruct (H empty_environment H5).
  apply H3.
  apply empty_true_eqv_top;auto.
  apply H4.
  apply empty_true_eqv_top;auto.
destruct H3.
clear IHf2.
assert (forall theta : environment, True -> [[f1]]theta).
  intros;apply H3;simpl;auto.
specialize (IHf1 H4).
assert ((forall theta : environment, [[f1]]theta) -> propForm_eqv f1 top).
  intros;auto.
specialize (IHf1 H5).
assert (propForm_eqv f1 top -> forall theta : environment, [[f1]]theta).
  intros;auto.
specialize (IHf1 H6).
clear - IHf1.
apply (TRA _ _ (f2 \/p top)).
apply (TRA _ _ (top \/p f2)).
apply SUP.
apply COM2.
apply (TRA _ _ (f2 \/p f1)).
destruct (exists_unused f2) as [x H].
specialize (CTX E top f1 (f2 \/p (var x)) x G IHf1).
intro.
simpl in H0.
rewrite<- (beq_nat_refl x) in H0.
rewrite (unused_no_rewrite f2 top x H) in H0.
rewrite (unused_no_rewrite f2 f1 x H) in H0.
assumption.
apply COM2.
clear IHf1.
assert (forall theta : environment, True -> [[f2]]theta).
  intros;apply H3;simpl;auto.
specialize (IHf2 H4).
  assert ((forall theta : environment, [[f2]]theta) -> propForm_eqv f2 top).
intros;auto.
specialize (IHf2 H5).
assert (propForm_eqv f2 top -> forall theta : environment, [[f2]]theta).
  intros;auto.
specialize (IHf2 H6).
clear - IHf2.
apply (TRA _ _ (f1 \/p top)).
apply (TRA _ _ (top \/p f1)).
apply SUP.
apply COM2.
destruct (exists_unused f1) as [x H].
specialize (CTX E top f2 (f1 \/p (var x)) x G IHf2).
intro.
simpl in H0.
rewrite<- (beq_nat_refl x) in H0.
rewrite (unused_no_rewrite f1 top x H) in H0.
rewrite (unused_no_rewrite f1 f2 x H) in H0.
assumption.

assert (forall theta : environment, True -> [[f1]]theta).
intros;apply H;auto.
assert ((forall theta : environment, [[f1]]theta) -> propForm_eqv f1 top).
intros;split;intro;intros;simpl;auto.
assert (propForm_eqv f1 top -> forall theta : environment, [[f1]]theta).
intros;auto.
specialize (IHf1 H2 H3 H4).
assert (forall theta : environment, True -> [[f2]]theta).
intros;apply H;auto.
assert ((forall theta : environment, [[f2]]theta) -> propForm_eqv f2 top).
intros;split;intro;intros;simpl;auto.
assert (propForm_eqv f2 top -> forall theta : environment, [[f2]]theta).
intros;auto.
specialize (IHf2 H5 H6 H7).
clear - IHf1 IHf2.
apply (TRA _ _ (top /\p f1)).
apply (TRA _ _ (top /\p top)).
apply ID1.
destruct (exists_unused top) as [x H].
specialize (CTX E top f1 (top /\p (var x)) x G IHf1).
intro.
simpl in H0.
rewrite<- (beq_nat_refl x) in H0.
assumption.
apply (TRA _ _ (f1 /\p top)).
apply COM1.
destruct (exists_unused f1) as [x H].
specialize (CTX E top f2 (f1 /\p (var x)) x G IHf2).
intro.
simpl in H0.
rewrite<- (beq_nat_refl x) in H0.
rewrite (unused_no_rewrite f1 top x H) in H0.
rewrite (unused_no_rewrite f1 f2 x H) in H0.
assumption.
Qed.

Lemma complete_from_var : forall E:BES, forall G:propVar_relation, forall f:propForm, forall x:propVar,
  propForm_cons (var x) f -> prv_tree E (stmt G (var x) f).
Proof.
intros.
induction f;simpl in *.

apply (TRA _ _ ((var x) /\p top)).
apply TOP.
apply (TRA _ _ (top /\p (var x))).
apply COM1.
apply INF.

exfalso.
specialize (H full_environment).
apply H.
simpl;auto.

unfold propForm_cons in H.
simpl in H.
destruct (eq_nat_decide p x).
rewrite (eq_nat_eq p x e).
apply REF.
destruct (beq_nat_false_iff x p).
assert (x<>p).
intro.
rewrite H2 in n.
specialize (eq_nat_refl p).
intro.
contradiction.
specialize (H1 H2).
specialize (H (environment_point x)).
assert false.
unfold environment_point in H.
rewrite<- (beq_nat_refl x) in H.
rewrite H1 in H.
apply H.
auto.
inversion H3.

cut (propForm_cons (var x) f1 \/ propForm_cons (var x) f2).
intro.
destruct H0.
specialize (IHf1 H0).
apply (TRA _ _ (var x \/p f2)).
apply SUP.
destruct (exists_unused f2) as [fx Hn].
specialize (CTX E (var x) f1 (var fx \/p f2) fx G IHf1).
intro.
simpl in H1.
rewrite (unused_no_rewrite f2 f1 fx Hn) in H1.
rewrite (unused_no_rewrite f2 (var x) fx Hn) in H1.
rewrite<- (beq_nat_refl fx) in H1.
assumption.
specialize (IHf2 H0).
apply (TRA _ _ (f1 \/p var x)).
apply (TRA _ _ (var x \/p f1)).
apply SUP.
apply COM2.
destruct (exists_unused f1) as [fx Hn].
specialize (CTX E (var x) f2 (f1 \/p var fx) fx G IHf2).
intro.
simpl in H1.
rewrite (unused_no_rewrite f1 f2 fx Hn) in H1.
rewrite (unused_no_rewrite f1 (var x) fx Hn) in H1.
rewrite<- (beq_nat_refl fx) in H1.
assumption.
destruct (cons_var_propForm f1 x).
left;assumption.
destruct (cons_var_propForm f2 x).
right;assumption.
destruct H0 as [theta1 H0].
destruct H1 as [theta2 H1].
destruct H0.
destruct H1.
specialize (environment_point_minimal f1 x theta1 H0 H2).
specialize (environment_point_minimal f2 x theta2 H1 H3).
intros.
assert (environment_point x x).
unfold environment_point.
rewrite<- (beq_nat_refl x).
auto.
destruct (H (environment_point x) H6);contradiction.

unfold propForm_cons in H.
assert (propForm_cons (var x) f1 /\ propForm_cons (var x) f2).
split.
intro.
intro.
apply (H theta).
auto.
intro;intro.
apply H;auto.
destruct H0.
specialize (IHf1 H0).
specialize (IHf2 H1).
apply (TRA _ _ (f1 /\p (var x))).
apply (TRA _ _ (var x /\p var x)).
apply ID1;auto.
destruct (exists_unused (var x)) as [fx Hn].
specialize (CTX E (var x) f1 (var fx /\p var x) fx G).
intros.
simpl in H2.
rewrite<- (beq_nat_refl fx) in H2.
assert (beq_nat fx x=false).
apply beq_nat_false_iff.
auto.
rewrite H3 in H2.
apply H2;auto.
destruct (exists_unused f1) as [fx Hn].
specialize (CTX E (var x) f2 (f1 /\p var fx) fx G IHf2).
intro.
simpl in H2.
rewrite<- (beq_nat_refl fx) in *.
rewrite (unused_no_rewrite f1 f2 fx Hn) in H2.
rewrite (unused_no_rewrite f1 (var x) fx Hn) in H2.
assumption.
Qed.

Lemma complete_to_var : forall E:BES, forall G:propVar_relation, forall f:propForm, forall x:propVar,
  propForm_cons f (var x) -> prv_tree E (stmt G f (var x)).
Proof.
intros.
intros.
induction f;simpl in *.
exfalso.
apply (neq_var_top x).
split.
intro;simpl;auto.
intro;apply (H theta);assumption.

unfold propForm_cons in H.
specialize (neq_var_bot x).
intro.
unfold propForm_eqv in H0.
apply (TRA _ _ ((var x) \/p bot) _).
apply (TRA _ _ (bot \/p (var x)) _).
apply SUP.
apply (COM2).
apply BOT.

unfold propForm_cons in H.
simpl in H.
destruct (eq_nat_decide p x).
rewrite (eq_nat_eq p x e).
apply REF.
destruct (beq_nat_false_iff p x).
assert (p<>x).
intro.
destruct (eq_nat_is_eq p x).
specialize (H4 H2).
contradiction.
specialize (H (environment_point p)).
assert false.
unfold environment_point in H.
rewrite<- (beq_nat_refl p) in H.
rewrite (H1 H2) in H.
apply H.
auto.
inversion H3.

unfold propForm_cons in H.
assert (propForm_cons f1 (var x) /\ propForm_cons f2 (var x)).
split.
intro.
intro.
apply (H theta).
left;auto.
intro.
intro.
apply (H theta).
right;auto.
simpl in *.
destruct H0.
specialize (IHf1 H0).
specialize (IHf2 H1).
apply (TRA _ _ (f1 \/p (var x)) _).
destruct (exists_unused f1) as [fx Hn].
specialize (CTX E f2 (var x) (f1 \/p var fx) fx G IHf2).
intro.
simpl in H2.
rewrite<- (beq_nat_refl fx) in *.
rewrite (unused_no_rewrite f1 f2 fx Hn) in H2.
rewrite (unused_no_rewrite f1 (var x) fx Hn) in H2.
assumption.
apply (TRA _ _ (var x \/p var x) _).
apply (TRA _ _ (var x \/p f1) _).
apply COM2.
specialize (CTX E f1 (var x) (var x \/p var (S x)) (S x) G IHf1).
intros.
simpl in H2.
destruct x.
rewrite<- (beq_nat_refl 0) in H2.
assumption.
rewrite<- (beq_nat_refl (S x)) in H2.
cut (beq_nat (S x) x=false).
intro.
rewrite H3 in H2.
assumption.
apply (beq_nat_false_iff).
auto.
apply ID2.

cut (propForm_cons f1 (var x) \/ propForm_cons f2 (var x)).
intro.
destruct H0.
specialize (IHf1 H0).
apply (TRA _ _ (f2 /\p var x)).
apply (TRA _ _ (f2 /\p f1)).
apply COM1.
destruct (exists_unused f2) as [fx Hn].
specialize (CTX E f1 (var x) (f2 /\p var fx) fx G IHf1).
intro.
simpl in H1.
rewrite (unused_no_rewrite f2 f1 fx Hn) in H1.
rewrite (unused_no_rewrite f2 (var x) fx Hn) in H1.
rewrite<- (beq_nat_refl fx) in H1.
assumption.
apply (TRA _ _ (var x /\p f2)).
apply COM1.
apply INF.
specialize (IHf2 H0).
apply (TRA _ _ (f1 /\p var x)).
destruct (exists_unused f1) as [fx Hn].
specialize (CTX E f2 (var x) (f1 /\p var fx) fx G IHf2).
intro.
simpl in H1.
rewrite (unused_no_rewrite f1 f2 fx Hn) in H1.
rewrite (unused_no_rewrite f1 (var x) fx Hn) in H1.
rewrite<- (beq_nat_refl fx) in H1.
assumption.
apply (TRA _ _ (var x /\p f1)).
apply COM1.
apply INF.

destruct (cons_propForm_var f1 x).
left;auto.
destruct (cons_propForm_var f2 x).
right;auto.
destruct H0 as [theta1 H0].
destruct H1 as [theta2 H1].
destruct H0.
destruct H1.
specialize (H (environment_union theta1 theta2)).
simpl in H.
exfalso.
assert (~environment_union theta1 theta2 x).
intro.
unfold environment_union in H4.
destruct (orb_prop (theta1 x) (theta2 x) H4).
rewrite H5 in H2.
apply H2.
auto.
rewrite H5 in H3.
apply H3.
auto.
assert (environment_union theta1 theta2 x).
apply H.
apply (environment_union_distributes).
auto.
contradiction.
Qed.

Lemma cSPLIT : forall E:BES, forall G:propVar_relation, forall f g1 g2:propForm,
  prv_tree E (stmt G f g1) -> prv_tree E (stmt G f g2) -> prv_tree E (stmt G f (g1 /\p g2)).
Proof.
intros.
apply (TRA _ _ (f /\p g2)).
apply (TRA _ _ (f /\p f)).
apply ID1.
destruct (exists_unused f) as [fx Hx].
specialize (CTX _ f g2 (f /\p var fx) fx _ H0);auto;intro.
simpl in H1.
rewrite <- beq_nat_refl in H1.
rewrite unused_no_rewrite in H1;auto.
rewrite unused_no_rewrite in H1;auto.
destruct (exists_unused g2) as [gx Hx].
specialize (CTX _ f g1 (var gx /\p g2) gx _ H);intro.
simpl in H1.
rewrite <- beq_nat_refl in H1.
rewrite unused_no_rewrite in H1;auto.
rewrite unused_no_rewrite in H1;auto.
Qed.

Lemma cGROW_L : forall E:BES, forall G:propVar_relation, forall f g1 g2:propForm,
  prv_tree E (stmt G f g1) -> prv_tree E (stmt G f (g1 \/p g2)).
Proof.
intros.
apply (TRA _ _ (f \/p g2)).
apply SUP.
destruct (exists_unused g2) as [gx Hx].
specialize (CTX _ f g1 (var gx \/p g2) gx _ H);intro.
simpl in H0.
rewrite <- beq_nat_refl in H0.
rewrite unused_no_rewrite in H0;auto.
rewrite unused_no_rewrite in H0;auto.
Qed.

Lemma cGROW_R : forall E:BES, forall G:propVar_relation, forall f g1 g2:propForm,
  prv_tree E (stmt G f g2) -> prv_tree E (stmt G f (g1 \/p g2)).
Proof.
intros.
apply (TRA _ _ (g2 \/p g1)).
apply cGROW_L;auto.
apply COM2.
Qed.

Lemma aSPLIT : forall E:BES, forall G:propVar_relation, forall f1 f2 g:propForm,
  prv_tree E (stmt G f1 g) -> prv_tree E (stmt G f2 g) -> prv_tree E (stmt G (f1 \/p f2) g).
Proof.
intros.
apply (TRA _ _ (f1 \/p g)).
destruct (exists_unused f1) as [fx Hx].
specialize (CTX _ f2 g (f1 \/p var fx) fx _ H0);intro.
simpl in H1.
rewrite <- beq_nat_refl in H1.
rewrite unused_no_rewrite in H1;auto.
rewrite unused_no_rewrite in H1;auto.
apply (TRA _ _ (g \/p g)).
destruct (exists_unused g) as [gx Hx].
specialize (CTX _ f1 g (var gx \/p g) gx _ H);intro.
simpl in H1.
rewrite <- beq_nat_refl in H1.
rewrite unused_no_rewrite in H1;auto.
rewrite unused_no_rewrite in H1;auto.
apply ID2.
Qed.

Lemma aGROW_L : forall E:BES, forall G:propVar_relation, forall f1 f2 g:propForm,
  prv_tree E (stmt G f1 g) -> prv_tree E (stmt G (f1 /\p f2) g).
Proof.
intros.
apply (TRA _ _ (g /\p f2)).
destruct (exists_unused f2) as [fx Hx].
specialize (CTX _ f1 g (var fx /\p f2) fx _ H);intro.
simpl in H0.
rewrite <- beq_nat_refl in H0.
rewrite unused_no_rewrite in H0;auto.
rewrite unused_no_rewrite in H0;auto.
apply INF.
Qed.

Lemma aGROW_R : forall E:BES, forall G:propVar_relation, forall f1 f2 g:propForm,
  prv_tree E (stmt G f2 g) -> prv_tree E (stmt G (f1 /\p f2) g).
Proof.
intros.
apply (TRA _ _ (f2 /\p f1)).
apply COM1.
apply aGROW_L;auto.
Qed.

Lemma distribute_prv_tree : forall E:BES, forall G:propVar_relation, forall g:propForm,
  DNF_propForm g -> forall f:propForm, DNF_propForm f -> prv_tree E (stmt G (f /\p g) (distribute f g)).
Proof.
intros E G g H.
induction H using DNF_ind;intros.
apply (TRA _ _ (top /\p f)).
apply COM1.
induction H using DNF_ind;simpl in *.
  apply REF.
  apply COM1.
  apply COM1.
  apply COM1.
  apply (TRA _ _ ((top /\p f) \/p (top /\p g))).
  apply DS3.
  apply aSPLIT.
  apply cGROW_L;auto.
  apply cGROW_R;auto.

apply (TRA _ _ (bot /\p f)).
apply COM1.
induction H using DNF_ind;simpl.
  apply COM1.
  apply REF.
  apply COM1.
  apply COM1.
  apply (TRA _ _ ((bot /\p f) \/p (bot /\p g))).
  apply DS3.
  apply aSPLIT.
  apply cGROW_L;auto.
  apply cGROW_R;auto.

apply (TRA _ _ (var x /\p f)).
apply COM1.
induction H using DNF_ind;simpl.
  apply COM1.
  apply COM1.
  apply COM1.
  apply COM1.
  apply (TRA _ _ ((var x /\p f) \/p (var x /\p g))).
  apply DS3.
  apply aSPLIT.
  apply cGROW_L;auto.
  apply cGROW_R;auto.

apply (TRA _ _ ((f /\p g) /\p f0)).
apply COM1.
induction H1 using DNF_ind;simpl.
  apply COM1.
  apply COM1.
  apply COM1.
  apply COM1.
  apply (TRA _ _ (((f /\p g) /\p f0) \/p ((f /\p g) /\p g0))).
  apply DS3.
  apply aSPLIT.
  apply cGROW_L;auto.
  apply cGROW_R;auto.

apply (TRA _ _ ((f0 /\p f) \/p (f0 /\p g))).
apply DS3.
apply aSPLIT.
induction H1 using DNF_ind.
  apply cGROW_L;apply IHDNF_propForm1;simpl;auto.
  apply cGROW_L;apply IHDNF_propForm1;simpl;auto.
  apply cGROW_L;apply IHDNF_propForm1;simpl;auto.
  apply cGROW_L;apply IHDNF_propForm1;simpl;auto.
  apply (TRA _ _ ((f /\p f0) \/p (f /\p g0))).
  apply (TRA _ _ (f /\p (f0 \/p g0))).
  apply COM1.
  apply DS3.
  apply aSPLIT.
  apply cGROW_L.
  apply (TRA _ _ (f0 /\p f));auto.
  apply COM1.
  apply cGROW_R.
  apply (TRA _ _ (g0 /\p f));auto.
  apply COM1.
induction H1 using DNF_ind.
  apply cGROW_R;apply IHDNF_propForm2;simpl;auto.
  apply cGROW_R;apply IHDNF_propForm2;simpl;auto.
  apply cGROW_R;apply IHDNF_propForm2;simpl;auto.
  apply cGROW_R;apply IHDNF_propForm2;simpl;auto.
  apply (TRA _ _ ((g /\p f0) \/p (g /\p g0))).
  apply (TRA _ _ (g /\p (f0 \/p g0))).
  apply COM1.
  apply DS3.
  apply aSPLIT.
  apply cGROW_L.
  apply (TRA _ _ (f0 /\p g));auto.
  apply COM1.
  apply cGROW_R;auto.
  apply (TRA _ _ (g0 /\p g));auto.
  apply COM1.
Qed.

Lemma complete_propForm_cons_DNF : forall E:BES, forall G:propVar_relation, forall f:propForm,
  prv_tree E (stmt G f (toDNF f)).
Proof.
intros.
induction f;simpl in *;auto.
apply REF.
apply REF.
apply REF.

apply aSPLIT;auto.
apply cGROW_L;auto.
apply cGROW_R;auto.

apply (TRA _ _ (toDNF f1 /\p toDNF f2)).
apply cSPLIT.
apply aGROW_L;auto.
apply aGROW_R;auto.
apply distribute_prv_tree;apply DNF_toDNF.
Qed.

Lemma generalized_complete_from_conj_propForm : forall E:BES, forall G:propVar_relation, forall f g:propForm,
  conj_propForm f ->
    propForm_cons f g -> prv_tree E (stmt G f g).
Proof.
intros.
induction g;simpl in *;auto.
(*g=top*)
apply (TRA _ _ (f /\p top)).
apply TOP.
apply (TRA _ _ (top /\p f)).
apply COM1.
apply INF.

(*g=bot*)
apply (complete_to_bot _ _ _ H0).

(*g=X*)
apply (complete_to_var _ _ _ _ H0).

(*g=a \/p b*)
destruct (conj_cons_disj_decide f g1 g2 H H0).
specialize (IHg1 H1).
apply (TRA _ _ (f \/p g2)).
apply SUP.
destruct (exists_unused g2) as [x Hx].
specialize (CTX E f g1 (var x \/p g2) x G IHg1).
intro.
simpl in H2.
rewrite (unused_no_rewrite g2 f x Hx) in H2.
rewrite (unused_no_rewrite g2 g1 x Hx) in H2.
rewrite<- (beq_nat_refl x) in H2.
assumption.

specialize (IHg2 H1).
apply (TRA _ _ (g1 \/p f)).
apply (TRA _ _ (f \/p g1)).
apply SUP.
apply COM2.
destruct (exists_unused g1) as [x Hx].
specialize (CTX E f g2 (g1 \/p var x) x G IHg2).
intro.
simpl in H2.
rewrite (unused_no_rewrite g1 f x Hx) in H2.
rewrite (unused_no_rewrite g1 g2 x Hx) in H2.
rewrite<- (beq_nat_refl x) in H2.
assumption.

(*g=a /\p b*)
assert (propForm_cons f g1).
intro;intro.
apply H0;auto.
assert (propForm_cons f g2).
intro;intro.
apply H0;auto.
specialize (IHg1 H1).
specialize (IHg2 H2).
apply (TRA _ _ (f /\p g2)).
apply (TRA _ _ (f /\p f)).
apply ID1.
destruct (exists_unused f) as [x Hx].
specialize (CTX E f g2 (f /\p (var x)) x G IHg2).
intro.
simpl in H3.
rewrite (unused_no_rewrite f f x Hx) in H3.
rewrite (unused_no_rewrite f g2 x Hx) in H3.
rewrite<- (beq_nat_refl x) in H3.
assumption.
destruct (exists_unused g2) as [x Hx].
specialize (CTX E f g1 ((var x) /\p g2) x G IHg1).
intro.
simpl in H3.
rewrite (unused_no_rewrite g2 f x Hx) in H3.
rewrite (unused_no_rewrite g2 g1 x Hx) in H3.
rewrite<- (beq_nat_refl x) in H3.
assumption.
Qed.

Lemma complete_DNF_cons_propForm : forall E:BES, forall G:propVar_relation, forall g f:propForm, DNF_propForm f ->
  propForm_cons f g -> prv_tree E (stmt G f g).
Proof.
intros.
induction H using DNF_ind;simpl in *;auto.

apply complete_from_top;auto.

apply (TRA _ _ (g \/p bot)).
apply (TRA _ _ (bot \/p g)).
apply SUP.
apply COM2.
apply BOT.

apply complete_from_var;auto.

apply generalized_complete_from_conj_propForm;auto.
split;auto.

assert (propForm_cons f g).
intro;intro;apply H0;left;auto.
assert (propForm_cons g0 g).
intro;intro;apply H0;right;auto.
specialize (IHDNF_propForm1 H2).
specialize (IHDNF_propForm2 H3).
apply (TRA _ _ (f \/p g)).
destruct (exists_unused f) as [x Hx].
specialize (CTX E g0 g (f \/p (var x)) x G IHDNF_propForm2).
intro.
simpl in H4.
rewrite (unused_no_rewrite f g0 x Hx) in H4.
rewrite (unused_no_rewrite f g x Hx) in H4.
rewrite<- (beq_nat_refl x) in H4.
assumption.
apply (TRA _ _ (g \/p g)).
destruct (exists_unused g) as [x Hx].
specialize (CTX E f g ((var x) \/p g) x G IHDNF_propForm1).
intro.
simpl in H4.
rewrite (unused_no_rewrite g g x Hx) in H4.
rewrite (unused_no_rewrite g f x Hx) in H4.
rewrite<- (beq_nat_refl x) in H4.
assumption.
apply ID2.
Qed.

Lemma complete_cons : forall E:BES, forall G:propVar_relation, forall g f:propForm,
  propForm_cons f g -> prv_tree E (stmt G f g).
Proof.
intros.
apply (TRA _ _ (toDNF f)).
apply complete_propForm_cons_DNF.
apply (TRA _ _ (toDNF g)).
apply complete_DNF_cons_propForm.
apply DNF_toDNF.
intro;intro.
apply cons_toDNF.
apply H.
apply toDNF_cons.
assumption.
apply complete_DNF_cons_propForm.
apply DNF_toDNF.
intro;intro.
apply toDNF_cons;auto.
Qed.


Set Implicit Arguments.
Require Import RelationClasses Morphisms List Lia
      Arith Lia Init.Nat Setoid.
From Undecidability.HOU Require Import std.std calculus.calculus third_order.pcp.
Import ListNotations.

Set Default Proof Using "Type".

(* * Third-Order Encoding *)
Section Encoding.

  Context {X: Const}.
  Variable  (u v: nat).
  Hypothesis (u_neq_v: u <> v).

  (* Encoding of symbols *)
  Definition encb (b: symbol) : exp X :=
    var (if b then u else v).

  (* Encoding of words *)
  Definition enc (w: word) : exp X :=
    lambda (AppL (renL shift (map encb w)) (var 0)).

  (* Encoding of words *)
  Notation Enc := (map enc).

  (* ** Encoding Typing *)
  Section Typing.

    Lemma encb_typing (Gamma: ctx) b:
      (Gamma ⊢(3) @var X u : alpha → alpha) ->
      (Gamma ⊢(3) @var X v : alpha → alpha) ->
      Gamma ⊢(3) encb b : (alpha → alpha).
    Proof.
      intros H1 H2. destruct b; (eauto 2).
    Qed.

    Lemma enc_typing (Gamma: ctx) w:
      (Gamma ⊢(3) @var X u : alpha → alpha) ->
      (Gamma ⊢(3) @var X v : alpha → alpha) ->
      Gamma ⊢(3) enc w : alpha → alpha.
    Proof.
      intros.
      econstructor; (eauto 2). inv H; inv H0.
      eapply AppL_ordertyping_repeated;eauto.
      eapply orderlisttyping_preservation_under_renaming.
      eapply repeated_ordertyping; simplify.
      intros; mapinj. eapply encb_typing. all: eauto.
      intros ??; cbn; (eauto 2).
    Qed.

    Lemma Enc_typing (Gamma: ctx) W:
      (Gamma ⊢(3) @var X u : alpha → alpha) ->
      (Gamma ⊢(3) @var X v : alpha → alpha) ->
      Gamma ⊢₊(3) Enc W : repeat (alpha → alpha) (length W).
    Proof.
      intros. eapply repeated_ordertyping; simplify; (eauto 2).
      intros; mapinj. eapply enc_typing; (eauto 2).
    Qed.
  End Typing.

  (* ** Encoding Properities *)

  (* *** Reduction *)
  Section Reduction.

    Lemma enc_nil s: enc [] s ≡ s.
    Proof.
      unfold enc; cbn.
      rewrite stepBeta; asimpl; cbn; (eauto 2).
    Qed.

    Lemma enc_cons b w s: enc (b :: w) s ≡ encb b (enc w s).
    Proof.
      unfold enc. eapply equiv_join; rewrite stepBeta; asimpl;  eauto.
      rewrite map_map, map_id_list. rewrite map_map, map_id_list. eauto.
      all: intros; now asimpl.
    Qed.

    Hint Rewrite enc_nil enc_cons : simplify.

    Lemma enc_app w1 w2 s:
      enc (w1 ++ w2) s ≡ enc w1 (enc w2 s).
    Proof.
      induction w1; cbn; simplify; (eauto 2).
      now rewrite IHw1.
    Qed.

    Hint Rewrite enc_app : simplify.

    Lemma enc_concat W s:
      AppL (Enc W) s ≡ enc (concat W) s.
    Proof.
      induction W; cbn; simplify; (eauto 2).
      now rewrite IHW.
    Qed.
  End Reduction.

  Hint Rewrite enc_nil enc_cons enc_app : simplify.

  (* *** Substitution *)
  Section Substitution.

    Lemma encb_subst_id a (sigma: fin -> exp X):
      sigma u = var u -> sigma v = var v -> sigma • encb a = encb a.
    Proof.
      intros; unfold encb; cbn; destruct a; (eauto 2).
    Qed.

    Lemma enc_subst_id (sigma: fin -> exp X) w:
      sigma u = var u -> sigma v = var v ->  sigma • (enc w) = enc w.
    Proof.
      unfold enc.
      intros H1 H2. cbn. f_equal.
      asimpl. f_equal. rewrite map_id_list; (eauto 2).
      intros x ?; mapinj; mapinj. asimpl.
      rewrite <-compComp_exp, encb_subst_id; (eauto 2).
    Qed.

    Lemma Enc_subst_id (sigma: fin -> exp X) W:
      sigma u = var u -> sigma v = var v ->  sigma •₊ Enc W = Enc W.
    Proof.
      intros. eapply map_id_list.
      intros; mapinj;eapply enc_subst_id; (eauto 2).
    Qed.

  End Substitution.

  (* *** Injectivity *)

  Definition nostring (t: exp X) :=
    forall s, ~ t ≡ var u s /\  ~ t ≡ var v s.

  Section Injectivity.
    Lemma encb_eq a b:
      encb a ≡ encb b -> a = b.
    Proof using u u_neq_v.
      intros H % equiv_head_equal; cbn in *; (eauto 2).
      injection H; destruct a, b; intros; (eauto 1); exfalso; eapply u_neq_v; (eauto 2).
    Qed.

    Lemma enc_eq w1 w2 s t:
      enc w1 s ≡ enc w2 t -> nostring s -> nostring t ->
      w1 = w2 /\ s ≡ t.
    Proof using u_neq_v.
      simplify. intros. induction w1 in w2, H |-*; destruct w2; cbn in *; (eauto 2).
      - simplify in H; intuition.
      - simplify in H. destruct b; firstorder.
      - simplify in H; symmetry in H; destruct a; firstorder.
      - simplify in H; Injection H.
        eapply IHw1 in H3 as [-> ->].
        now rewrite encb_eq with (a := a) (b := b).
    Qed.
  End Injectivity.

  Section EquivalenceInversion.

    Variables  (s t: exp X) (x: nat) (sigma: fin -> exp X) (S: list (exp X)).
    Hypothesis (H1: forall y, isVar (sigma y) /\ sigma y <> var x).
    Hypothesis (N: normal s).
    Hypothesis (EQ: S .+ sigma • s ≡ (var x) t).

    Lemma end_head_var:
      exists (h: nat) T s', s = AppR (var h) T /\ nth S h = Some s'.
    Proof using x v u_neq_v t sigma N H1 EQ.
      eapply normal_nf in N as N'. inv N'. destruct k; cbn in *; (eauto 5); [|Discriminate].
      destruct (s0); cbn in H; intuition idtac; clear H.
      - assert(f < |S| \/ f >= |S|) as [] by lia; (eauto 5).
        eapply nth_error_lt_Some in H as H2; destruct H2; (eauto 5).
        asimpl in EQ; rewrite sapp_ge_in in EQ; (eauto 2).
        specialize (H1 (f - |S|)). intuition.
        eapply equiv_head_equal in EQ; cbn; simplify; (eauto 3). simplify in EQ; cbn in EQ; (eauto 1).
        destruct (sigma (f - (|S|))); cbn in *; intuition.
      - eauto. asimpl in EQ.
        eapply equiv_head_equal in EQ; cbn; simplify in *; (eauto 2).
        cbn in EQ; discriminate.
    Qed.

    Lemma end_is_var_typed Gamma A C:
      S = Enc C ->
      (repeat (alpha → alpha) (|S|) ++ Gamma ⊢(3) s : A) ->
      exists i e, i < |S| /\ s = var i e.
    Proof using x u_neq_v t sigma N H1 EQ.
      intros H2 H4; destruct end_head_var as (h' & T & s' & H5); intuition idtac; subst.
      destruct T as [| t1 [| t2 T]].
      + cbn in EQ. erewrite nth_error_sapp in EQ; (eauto 2).
        rewrite nth_error_map_option in H0; destruct nth; try discriminate.
        cbn in H0; injection H0 as <-.
        unfold enc in EQ; Discriminate.
      + exists h'. exists t1. intuition. now eapply nth_error_Some_lt in H0.
      + eapply AppR_ordertyping_inv in H4.
        destruct H4 as [L]; intuition.
        inv H3. rewrite nth_error_app1, nth_error_repeated in H5; simplify in *; (eauto 2).
        inv H2. inv H8. cbn in H5; injection H5 as ?.
        rewrite !Arr_app in H; cbn in H. eapply (f_equal arity) in H.
        rewrite arity_Arr in H; cbn in H. lia.
        all: eapply nth_error_Some_lt in H0; simplify in H0; (eauto 2).
    Qed.

  End EquivalenceInversion.

  Lemma AppL_decomposition (s: exp X) (n: nat):
    { '(I, u) | I ⊆ nats n /\ s = AppL (map var I) u /\ forall x v, u = var x v -> ~ x < n }.
  Proof.
    destruct (@AppL_largest _ (fun s => match s with var x => x < n | _ => False end) s)
      as (S & t & H2 & H3 & H4). intros []; intuition; now right.
    subst. induction S.
    - exists (nil, t). cbn; intuition. eapply H4; (eauto 2).
    - edestruct IHS as [[I s'] (H1 & H3 & H5)].
      intros; eapply H2; intuition.
      specialize (H2 a); mp H2; lauto; destruct a; intuition.
      exists (f :: I, s'); cbn; intuition try congruence.
      eapply lt_nats in H2; lauto.
  Qed.

  Section MainLemma.

    Variable (Gamma : ctx) (s: exp X) (n: nat).

    Hypothesis (Ts: Gamma ⊢(3) s : Arr (repeat (alpha → alpha) n) alpha).
    Hypothesis (Vu: ~ u ∈ vars s) (Vv: ~ v ∈ vars s).

    Lemma main_lemma:
      exists I, I ⊆ nats n /\ forall W, |W| = n -> exists t,
        AppR s (Enc W) ≡ AppL (select I (Enc W)) t /\ nostring t.
    Proof using u_neq_v Vv Vu Ts Gamma.
      pose (mv := fun x => match x == u, x == v with right _,right _ => x | _,_ => S(u + v + x) end).
      assert (forall x, mv x >= x) as GE.
      { eauto; intros; unfold funcomp; intuition idtac; unfold mv in *.
        eauto; intros; edestruct eq_dec; [lia|]; destruct eq_dec; (eauto 3).
      }
      assert (forall x, var (mv x) <> @var X u) as Nu.
      { intros x H; injection H; unfold mv; destruct eq_dec; [lia|]; destruct eq_dec; [lia|].
        intros; subst; (eauto 2).
      }
      assert (forall x, var (mv x) <> @var X v) as Nv.
      { intros x H; injection H; unfold mv; destruct eq_dec; [lia|]; destruct eq_dec; [lia|].
        intros; subst; (eauto 2).
      }
      replace s with (ren mv s).
      2: { asimpl; erewrite subst_extensional with (tau := var); asimpl; (eauto 2).
        intros; unfold funcomp, mv; destruct eq_dec; subst; [exfalso; eapply Vu; eauto|].
        destruct eq_dec; subst; [exfalso; eapply Vv; eauto|eauto].
      }
      eapply ordertyping_termination_steps in Ts as N; destruct N as [t [E N]].
      eapply normal_nf in N as N2. destruct N2 as [k a ? T _ isA ->].
      eapply ordertyping_preservation_under_steps in Ts as Tv; (eauto 2).
      eapply Lambda_ordertyping_inv in Tv as (L & B & H0 & H1 & <-).
      destruct (Nat.lt_total n (|L|)) as [?|[?|?]].
      - exfalso. eapply (f_equal arity) in H1; simplify in H1; lia.
      - destruct (AppL_decomposition (AppR a T) n) as [[I v''] (H2&H3&H4)].
        exists I. intuition. exists (Enc W .+ mv >> var • v'').
        split.
        + rewrite E.
          rewrite Lambda_ren, AppR_Lambda'; simplify; try congruence.
          rewrite it_up_var_sapp, H3, AppL_subst, select_variables_subst; simplify; (eauto 2).
          all: rewrite ?H5; (eauto 2).
        + eapply Arr_inversion in H1 as [[] [H1 H6]]; simplify; try lia.
          2: discriminate. cbn in H1, H6. simplify in H1. subst.
          rewrite H3 in H0; eapply AppL_ordertyping_inv in H0 as (?&?&?&?).
          split; intros EQ; eapply end_is_var_typed in EQ  as (? & ? & ? & ?).
          1, 6: eapply H4; simplify in H6; (eauto 1);
            rewrite <-H5; (eauto 2). 3, 7: eauto.
          1, 4: intros; unfold funcomp; intuition eauto.
          1, 3: rewrite H3 in N; eapply normal_AppL_right, normal_Lambda, N.
          all: simplify; rewrite H1 in H0; simplify in H0; rewrite <-H5 in H0; (eauto 2).
      - remember mv as delta. exists nil; intuition; cbn; simplify. eexists. rewrite E. intuition eauto.
        edestruct (@list_decompose_alt (length L) _ W) as (W1&W2&?&?);
          subst; (eauto 2).
        simplify. rewrite !AppR_app, !Lambda_ren. split; rewrite !AppR_Lambda'; simplify; (eauto 2).
        all: rewrite !it_up_var_sapp; simplify; (eauto 1); rewrite AppR_subst.
        all: intros EQ.
        all: destruct a as [y| d | |]; cbn in isA;
          intuition; [destruct (le_lt_dec (length W2) y)|].
        all: revert EQ.
        (* a constant *)
        3, 6: cbn; intros EQ' % equiv_head_equal; cbn; simplify; cbn; auto 1.
        3, 4: simplify in EQ'; cbn in EQ'; subst; discriminate.
        (* x like constant *)
        1, 3: cbn; rewrite sapp_ge_in; simplify; (eauto 2).
        1, 2: intros EQ' % equiv_head_equal; cbn; simplify; cbn; auto 1.
        1, 2: simplify in EQ'; cbn in EQ'; subst; (eauto 2).
        (* x is x_i *)
        all: eapply AppR_ordertyping_inv in H0 as [? [_ T2]]; intuition idtac; inv T2.
        all: symmetry in H1; eapply Arr_inversion in H1 as H6; simplify; try lia.
        all: destruct H6 as (?&?&?); eapply repeated_app_inv in H0.
        all: intuition; subst; rewrite H0 in *; simplify in H4; simplify in H3; rewrite H4 in l.
        all: eapply id in H3 as HH;
          rewrite nth_error_app1, nth_error_repeated in HH; simplify; (eauto 2).
        all: injection HH as HH; destruct x0; simplify in H6; simplify in H3.
        all: simplify in H; try lia; cbn in H8; injection H8 as ->.
        all: eapply (f_equal ord) in HH; simplify in HH.
        all: symmetry in HH; eapply Nat.eq_le_incl in HH; simplify in HH.
        all: intuition; cbn [ord'] in H9.
        all: cbn [add] in H9; rewrite Max.succ_max_distr in H9.
        all: eapply Nat.max_lub_l in H9; cbn in H9; lia.
    Qed.
  End MainLemma.

End Encoding.

Global Hint Rewrite @enc_app @enc_nil: simplify.
Notation Enc u v := (map (enc u v)).

Section ReductionEncodings.

  Context {X: Const}.

  Definition finst I n := Lambda n (AppL (map var I) (@var X n)).

  Lemma finst_typing I n :
    I ⊆ nats n ->
    [alpha] ⊢(3) finst I n : Arr (repeat (alpha → alpha) n) alpha.
  Proof.
    intros H; eapply Lambda_ordertyping; simplify; (eauto 1).
    eapply AppL_ordertyping_repeated.
    eapply repeated_ordertyping; simplify; (eauto 1).
    intros; mapinj.
    econstructor; simplify; cbn; (eauto 4).
    rewrite nth_error_app1; simplify; (eauto 1).
    eapply nth_error_repeated; (eauto 1).
    1 - 2: eapply nats_lt, H, H2.
    econstructor; simplify; (eauto 2).
    rewrite nth_error_app2; simplify; (eauto 1).
  Qed.

  Lemma finst_equivalence u v I W delta:
    I ⊆ nats (length W) ->
    AppR (ren delta (finst I (length W))) (Enc u v W) ≡ enc u v (concat (select I W)) (var (delta 0)).
  Proof.
    intros. unfold finst. rewrite !Lambda_ren, !AppL_ren.
    rewrite !map_id_list.
    2: intros ? ?; mapinj; cbn; eapply H, nats_lt in H2; now rewrite it_up_ren_lt.
    cbn; rewrite it_up_ren_ge; (eauto 2); simplify.
    rewrite !AppR_Lambda'; simplify; (eauto 2). asimpl.
    rewrite !sapp_ge_in; simplify; (eauto 2).
    rewrite !select_variables_subst; [|simplify; (eauto 2)..].
    now rewrite <-!select_map, enc_concat.
  Qed.

End ReductionEncodings.