Require Import List Nat Arith.
Import ListNotations.
Require Import Mmx.ast_instructions.

Check (1,2).
Check pair nat nat.
Definition tag_opcode_assoc :=
  list (tag * nat).

Scheme Equality for list.
Check list_beq.

(* actually this is a good name for this function :p *)
Fixpoint lookup (t : tag) (l : tag_opcode_assoc) : option nat :=
  match l with
    | [] => None
    | (t',n) :: tl => if tag_beq t t'
                      then Some n
                      else lookup t tl
  end.
(* actually this is a good name for this function :p *)
Fixpoint lookdown (n : nat) (l : tag_opcode_assoc) : option tag :=
  match l with
    | [] => None
    | (t,n') :: tl => if  eqb n n'
                      then Some t
                      else lookdown n tl
  end.

(* this table is an association list of type tag_opcode_assoc with every associations that can be made in our langage *)
Definition encdec : tag_opcode_assoc :=
[(tag_t_n(ADD),0);
(tag_t_n(SUB),1);
(tag_t_n(MUL),2);
(tag_t_n(DIV),3);
(tag_t_n(ADDU),4);
(tag_t_n(SUBU),5);
(tag_t_n(MULU),6);
(tag_t_n(DIVU),7);
(tag_t_n(CMP),8);
(tag_t_n(CMPU),9);
(tag_t_n(FADD),10);
(tag_t_n(FSUB),11);
(tag_t_n(FMUL),12);
(tag_t_n(FDIV),13);
(tag_t_n(FREM),14);
(tag_t_n(FSQRT),15);
(tag_t_n(FINT),16);
(tag_t_n(FCMP),17);
(tag_t_n(FEQL),18);
(tag_t_n(FUN),19);
(tag_t_n(FCMPE),20);
(tag_t_n(FEQLE),21);
(tag_t_n(FUNE),22);
(tag_t_n(AND),23);
(tag_t_n(OR),24);
(tag_t_n(XOR),25);
(tag_t_n(ANDN),26);
(tag_t_n(ORN),27);
(tag_t_n(NAND),28);
(tag_t_n(NOR),29);
(tag_t_n(NXOR),30);
(tag_t_n(SL),31);
(tag_t_n(SLU),32);
(tag_t_n(SR),33);
(tag_t_n(SRU),34);
(tag_t_n(MOR),35);
(tag_t_n(MXOR),36);
(tag_t_n(BDIF),37);
(tag_t_n(WDIF),38);
(tag_t_n(TDIF),39);
(tag_t_n(ODIF),40);
(tag_t_n(SADD),41);
(tag_t_n(MUX),42);
(tag_t_n(ADDU2),43);
(tag_t_n(ADDU4),44);
(tag_t_n(ADDU8),45);
(tag_t_n(ADDU16),46);
(tag_t_n(LDB),47);
(tag_t_n(LDW),48);
(tag_t_n(LDT),49);
(tag_t_n(LDO),50);
(tag_t_n(STB),51);
(tag_t_n(STW),52);
(tag_t_n(STT),53);
(tag_t_n(STO),54);
(tag_t_n(LDBU),55);
(tag_t_n(LDWU),56);
(tag_t_n(LDTU),57);
(tag_t_n(LDOU),58);
(tag_t_n(STBU),59);
(tag_t_n(STWU),60);
(tag_t_n(STTU),61);
(tag_t_n(STOU),62);
(tag_t_n(LDTH),63);
(tag_t_n(STHT),64);
(tag_t_n(LDSF),65);
(tag_t_n(STSF),66);
(tag_t_n(GO),67);
(tag_t_n(CSZ),68);
(tag_t_n(CSNZ),69);
(tag_t_n(CSN),70);
(tag_t_n(CSNN),71);
(tag_t_n(CSP),72);
(tag_t_n(CSNP),73);
(tag_t_n(CSOD),74);
(tag_t_n(CSEV),75);
(tag_t_n(ZSZ),76);
(tag_t_n(ZSNZ),77);
(tag_t_n(ZSN),78);
(tag_t_n(ZSNN),79);
(tag_t_n(ZSP),80);
(tag_t_n(ZSNP),81);
(tag_t_n(ZSOD),82);
(tag_t_n(ZSEV),83);
(tag_t_n(CSWAP),84);
(tag_t_n(LDUNC),85);
(tag_t_n(STUNC),86);
(tag_t_n(PREST),87);
(tag_t_n(LDTVS),88);
(* end tag_t_n *)

(tag_t_i(ADD_I),89);
(tag_t_i(SUB_I),90);
(tag_t_i(MUL_I),91);
(tag_t_i(DIV_I),92);
(tag_t_i(ADDU_I),93);
(tag_t_i(SUBU_I),94);
(tag_t_i(MULU_I),95);
(tag_t_i(DIVU_I),96);
(tag_t_i(CMP_I),97);
(tag_t_i(CMPU_I),98);
(tag_t_i(AND_I),99);
(tag_t_i(OR_I),100);
(tag_t_i(XOR_I),101);
(tag_t_i(ANDN_I),102);
(tag_t_i(ORN_I),103);
(tag_t_i(NAND_I),104);
(tag_t_i(NOR_I),105);
(tag_t_i(NXOR_I),106);
(tag_t_i(SL_I),107);
(tag_t_i(SLU_I),108);
(tag_t_i(SR_I),109);
(tag_t_i(SRU_I),110);
(tag_t_i(BDIF_I),111);
(tag_t_i(WDIF_I),112);
(tag_t_i(TDIF_I),113);
(tag_t_i(ODIF_I),114);
(tag_t_i(LDA_I),115);
(tag_t_i(GETA_I),116);
(tag_t_i(ADDU2_I),117);
(tag_t_i(ADDU4_I),118);
(tag_t_i(ADDU8_I),119);
(tag_t_i(ADDU16_I),120);
(tag_t_i(LDB_I),121);
(tag_t_i(LDW_I),122);
(tag_t_i(LDT_I),123);
(tag_t_i(LDO_I),124);
(tag_t_i(STB_I),125);
(tag_t_i(STW_I),126);
(tag_t_i(STT_I),127);
(tag_t_i(STO_I),128);
(tag_t_i(LDBU_I),129);
(tag_t_i(LDWU_I),130);
(tag_t_i(LDTU_I),131);
(tag_t_i(LDOU_I),132);
(tag_t_i(STBU_I),133);
(tag_t_i(STWU_I),134);
(tag_t_i(STTU_I),135);
(tag_t_i(STOU_I),136);
(tag_t_i(LDTH_I),137);
(tag_t_i(STHT_I),138);
(tag_t_i(LDSF_I),139);
(tag_t_i(STSF_I),140);
(tag_t_i(GO_I),141);
(tag_t_i(CSZ_I),142);
(tag_t_i(CSNZ_I),143);
(tag_t_i(CSN_I),144);
(tag_t_i(CSNN_I),145);
(tag_t_i(CSP_I),146);
(tag_t_i(CSNP_I),147);
(tag_t_i(CSOD_I),148);
(tag_t_i(CSEV_I),149);
(tag_t_i(ZSZ_I),150);
(tag_t_i(ZSNZ_I),151);
(tag_t_i(ZSN_I),152);
(tag_t_i(ZSNN_I),153);
(tag_t_i(ZSP_I),154);
(tag_t_i(ZSNP_I),155);
(tag_t_i(ZSOD_I),156);
(tag_t_i(ZSEV_I),157);
(tag_t_i(PUSHJ_I),158);
(tag_t_i(PUSHGO_I),159);
(tag_t_i(LDTVS_I),160);
  (* end tag_t_i *)

(tag_t_i2(NEG),161);
(tag_t_i2(NEGU),162);
(* end tag_t_i2( *)

(tag_t_i3(PRELD),163);
(tag_t_i3(PREGO),164);
(tag_t_i3(SYNCID),165);
(tag_t_i3(SYNCD),166);
(tag_t_i3(STCO),167);
(* end tag_t_i3 *)

(tag_t_i4(NEG_I),168);
(tag_t_i4(NEGU_I),169);
(* end tag_t_i4 *)

(tag_t_i5(TRIP),170);
(tag_t_i5(TRAP),171);
(tag_t_i5(SWYM),172);
(* end tag_t_i5 *)

(tag_t_i6(STCO_I2),173);
(tag_t_i6(STCO_I),174);
(* end tag_t_i6 *)

(tag_d_i(FLOT_I),175);
(tag_d_i(FLOTU_I),176);
(tag_d_i(SFLOT_I),177);
(tag_d_i(SFLOTU_I),178);
(tag_d_i(ORH_I),179);
(tag_d_i(ORMH_I),180);
(tag_d_i(ORML_I),181);
(tag_d_i(ORL_I),182);
(tag_d_i(ANDNH_I),183);
(tag_d_i(ANDNMH_I),184);
(tag_d_i(ANDNML_I),185);
(tag_d_i(ANDNL_I),186);
(tag_d_i(SETH_i),187);
(tag_d_i(SETMH_i),188);
(tag_d_i(SETML_i),189);
(tag_d_i(SETL_i),190);
(tag_d_i(INCH_i),191);
(tag_d_i(INCMH_i),192);
(tag_d_i(INCML_i),193);
(tag_d_i(INCL_i),194);
(tag_d_i(BZ_i),195);
(tag_d_i(BNZ_i),196);
(tag_d_i(BN_i),197);
(tag_d_i(BNN_i),198);
(tag_d_i(BP_i),199);
(tag_d_i(BNP_i),200);
(tag_d_i(BOD_i),201);
(tag_d_i(BEV_i),202);
(tag_d_i(PBZ_i),203);
(tag_d_i(PBNZ_i),204);
(tag_d_i(PBN_i),205);
(tag_d_i(PBNN_i),206);
(tag_d_i(PBP_i),207);
(tag_d_i(PBNP_i),208);
(tag_d_i(PBOD_i),209);
(tag_d_i(PBEV_i),210);
(tag_d_i(GET_i),211);
  (* end (tag_d_i *)

(tag_d_i2(PUT_I),212);
(tag_d_i2(PUT_I2),213);
(* end (tag_d_i2 *)

(tag_d_i3(POP),214);
(tag_d_i3(PUT_II),215);
(* end (tag_d_i3 *)

(tag_d_n(FLOT),216);
(tag_d_n(FLOTU),217);
(tag_d_n(FIX),218);
(tag_d_n(FIXU),219);
(tag_d_n(SFLOT),220);
(tag_d_n(SFLOTU),221);
(* end (tag_d_n( *)

(tag_u(JMP),222);
(tag_u(SAVE),223);
(tag_u(UNSAVE),224);
(tag_u(RESUME),225);
(tag_u(SYNC),226)
].

Theorem lookup_encdec : forall (t : tag), exists n,
                          lookup t encdec = Some n.
Proof.
  destruct t.
  -destruct t;
     simpl; eexists; auto.
  -destruct t;
     simpl; eexists; auto.
  -destruct t;
     simpl; eexists; auto.
  -destruct t;
     simpl; eexists; auto.
  -destruct t;
     simpl; eexists; auto.
  -destruct t;
     simpl; eexists; auto.
  -destruct t;
     simpl; eexists; auto.
  -destruct t;
     simpl; eexists; auto.
  -destruct t;
     simpl; eexists; auto.
  -destruct t;
     simpl; eexists; auto.
  -destruct t;
     simpl; eexists; auto.
  -destruct t;
     simpl; eexists; auto.
Qed.

Require Import Bool.

Print tag.

Definition forall_tag_ter_n (p : tag_ter_normal -> bool): bool :=
(p ADD) &&
(p SUB) &&
(p MUL) &&
(p DIV) &&
(p ADDU) &&
(p SUBU) &&
(p MULU) &&
(p DIVU) &&
(p CMP) &&
(p CMPU) &&
(p FADD) &&
(p FSUB) &&
(p FMUL) &&
(p FDIV) &&
(p FREM) &&
(p FSQRT) &&
(p FINT) &&
(p FCMP) &&
(p FEQL) &&
(p FUN) &&
(p FCMPE) &&
(p FEQLE) &&
(p FUNE) &&
(p AND) &&
(p OR) &&
(p XOR) &&
(p ANDN) &&
(p ORN) &&
(p NAND) &&
(p NOR) &&
(p NXOR) &&
(p SL) &&
(p SLU) &&
(p SR) &&
(p SRU) &&
(p MOR) &&
(p MXOR) &&
(p BDIF) &&
(p WDIF) &&
(p TDIF) &&
(p ODIF) &&
(p SADD) &&
(p MUX) &&
(p ADDU2) &&
(p ADDU4) &&
(p ADDU8) &&
(p ADDU16) &&
(p LDB) &&
(p LDW) &&
(p LDT) &&
(p LDO) &&
(p STB) &&
(p STW) &&
(p STT) &&
(p STO) &&
(p LDBU) &&
(p LDWU) &&
(p LDTU) &&
(p LDOU) &&
(p STBU) &&
(p STWU) &&
(p STTU) &&
(p STOU) &&
(p LDTH) &&
(p STHT) &&
(p LDSF) &&
(p STSF) &&
(p GO) &&
(p CSZ) &&
(p CSNZ) &&
(p CSN) &&
(p CSNN) &&
(p CSP) &&
(p CSNP) &&
(p CSOD) &&
(p CSEV) &&
(p ZSZ) &&
(p ZSNZ) &&
(p ZSN) &&
(p ZSNN) &&
(p ZSP) &&
(p ZSNP) &&
(p ZSOD) &&
(p ZSEV) &&
(p CSWAP) &&
(p LDUNC) &&
(p STUNC) &&
(p PREST) &&
(p LDTVS).

Definition forall_tag_ter_i (p : tag_ter_immediate -> bool): bool :=
(p ADD_I) &&
(p SUB_I) &&
(p MUL_I) &&
(p DIV_I) &&
(p ADDU_I) &&
(p SUBU_I) &&
(p MULU_I) &&
(p DIVU_I) &&
(p CMP_I) &&
(p CMPU_I) &&
(p AND_I) &&
(p OR_I) &&
(p XOR_I) &&
(p ANDN_I) &&
(p ORN_I) &&
(p NAND_I) &&
(p NOR_I) &&
(p NXOR_I) &&
(p SL_I) &&
(p SLU_I) &&
(p SR_I) &&
(p SRU_I) &&
(p BDIF_I) &&
(p WDIF_I) &&
(p TDIF_I) &&
(p ODIF_I) &&
(p LDA_I) &&
(p GETA_I) &&
(p ADDU2_I) &&
(p ADDU4_I) &&
(p ADDU8_I) &&
(p ADDU16_I) &&
(p LDB_I) &&
(p LDW_I) &&
(p LDT_I) &&
(p LDO_I) &&
(p STB_I) &&
(p STW_I) &&
(p STT_I) &&
(p STO_I) &&
(p LDBU_I) &&
(p LDWU_I) &&
(p LDTU_I) &&
(p LDOU_I) &&
(p STBU_I) &&
(p STWU_I) &&
(p STTU_I) &&
(p STOU_I) &&
(p LDTH_I) &&
(p STHT_I) &&
(p LDSF_I) &&
(p STSF_I) &&
(p GO_I) &&
(p CSZ_I) &&
(p CSNZ_I) &&
(p CSN_I) &&
(p CSNN_I) &&
(p CSP_I) &&
(p CSNP_I) &&
(p CSOD_I) &&
(p CSEV_I) &&
(p ZSZ_I) &&
(p ZSNZ_I) &&
(p ZSN_I) &&
(p ZSNN_I) &&
(p ZSP_I) &&
(p ZSNP_I) &&
(p ZSOD_I) &&
(p ZSEV_I) &&
(p PUSHJ_I) &&
(p PUSHGO_I) &&
(p LDTVS_I).

Definition forall_tag_ter_i2 (p : tag_ter_immediate2 -> bool): bool :=
  (p NEG) && (p NEGU).

Definition forall_tag_ter_i3 (p : tag_ter_immediate3 -> bool): bool :=
  (p PRELD) && (p PREGO) && (p SYNCID) && (p SYNCD) && (p STCO).

Definition forall_tag_ter_i4 (p : tag_ter_immediate4 -> bool): bool :=
  (p NEG_I) && (p NEGU_I).

Definition forall_tag_ter_i5 (p : tag_ter_immediate5 -> bool): bool :=
  (p TRIP) && (p TRAP) && (p SWYM).

Definition forall_tag_ter_i6 (p : tag_ter_immediate6 -> bool): bool :=
  (p STCO_I2) && (p STCO_I).

Definition forall_tag_duo_i (p : tag_duo_immediate -> bool): bool :=
(p FLOT_I) &&
(p FLOTU_I) &&
(p SFLOT_I) &&
(p SFLOTU_I) &&
(p ORH_I) &&
(p ORMH_I) &&
(p ORML_I) &&
(p ORL_I) &&
(p ANDNH_I) &&
(p ANDNMH_I) &&
(p ANDNML_I) &&
(p ANDNL_I) &&
(p SETH_i) &&
(p SETMH_i) &&
(p SETML_i) &&
(p SETL_i) &&
(p INCH_i) &&
(p INCMH_i) &&
(p INCML_i) &&
(p INCL_i) &&
(p BZ_i) &&
(p BNZ_i) &&
(p BN_i) &&
(p BNN_i) &&
(p BP_i) &&
(p BNP_i) &&
(p BOD_i) &&
(p BEV_i) &&
(p PBZ_i) &&
(p PBNZ_i) &&
(p PBN_i) &&
(p PBNN_i) &&
(p PBP_i) &&
(p PBNP_i) &&
(p PBOD_i) &&
(p PBEV_i) &&
(p GET_i).

Definition forall_tag_duo_i2 (p : tag_duo_immediate2 -> bool): bool :=
  (p PUT_I) && (p PUT_I2).

Definition forall_tag_duo_i3 (p : tag_duo_immediate3 -> bool): bool :=
  (p POP) && (p PUT_II).

Definition forall_tag_duo_n (p : tag_duo_normal -> bool): bool :=
(p FLOT) &&
(p FLOTU) &&
(p FIX) &&
(p FIXU) &&
(p SFLOT) &&
(p SFLOTU).

Definition forall_tag_uno (p : tag_uno -> bool): bool :=
  (p JMP) &&
  (p SAVE) &&
  (p UNSAVE) &&
  (p RESUME) &&
  (p SYNC).

Definition forall_tag (p : tag -> bool): bool :=
  (forall_tag_ter_n (fun x => p (tag_t_n x))) &&
                                              (forall_tag_ter_i (fun x => p (tag_t_i x))) &&
                                              (forall_tag_ter_i2 (fun x => p (tag_t_i2 x))) &&
                                              (forall_tag_ter_i3 (fun x => p (tag_t_i3 x))) &&
                                              (forall_tag_ter_i4 (fun x => p (tag_t_i4 x))) &&
                                              (forall_tag_ter_i5 (fun x => p (tag_t_i5 x))) &&
                                              (forall_tag_ter_i6 (fun x => p (tag_t_i6 x))) &&
                                              (forall_tag_duo_n (fun x => p (tag_d_n x))) &&
                                              (forall_tag_duo_i (fun x => p (tag_d_i x))) &&
                                              (forall_tag_duo_i2 (fun x => p (tag_d_i2 x))) &&
                                              (forall_tag_duo_i3 (fun x => p (tag_d_i3 x))) &&
                                              (forall_tag_uno (fun x => p (tag_u x))).

Print reflect.

Definition propP := forall x : nat, x = x.
Check propP.

Lemma test_reflect : True -> reflect True true.
Proof.
  exact (ReflectT True).
Qed.

Lemma helpBefore1 : forall (f : tag -> bool), forall_tag f = true -> (forall (t: tag), f t = true).
Proof.
  intros f.
  unfold forall_tag.
  intros H.
  repeat (apply andb_prop in H; destruct H).
  repeat (apply andb_prop in H10; destruct H10).
  repeat (apply andb_prop in H9; destruct H9).
  repeat (apply andb_prop in H8; destruct H8).
  repeat (apply andb_prop in H7; destruct H7).
  repeat (apply andb_prop in H6; destruct H6).
  repeat (apply andb_prop in H5; destruct H5).
  repeat (apply andb_prop in H4; destruct H4).
  repeat (apply andb_prop in H3; destruct H3).
  repeat (apply andb_prop in H2; destruct H2).
  repeat (apply andb_prop in H1; destruct H1).
  repeat (apply andb_prop in H0; destruct H0).
  destruct t; destruct t; auto.
Qed.

Lemma helpBefore2 : forall (f : tag -> bool), (forall (t: tag), f t = true) -> forall_tag f = true.
Proof.
  intros f H.
  unfold forall_tag.
  Search (_ && _ = true).
  repeat (apply andb_true_intro ; split ; auto).
Qed.

Lemma forall_tagP: forall (P : tag -> Prop)(f : tag -> bool),
    (forall (t : tag), reflect (P t) (f t)) ->
    reflect (forall t, P t) (forall_tag f).
Proof.
  intros P f H.
  Search reflect.
  apply iff_reflect.
  apply iff_to_and.
  split.
  -Search forall_tag.
   intros.
   rewrite helpBefore2.
   +reflexivity.
   +intros t.
    specialize (H t).
    Search forall_tag.
    apply reflect_iff in H.
    inversion H.
    specialize (H0 t).
    apply H1.
    exact H0.
    (* this part is ok !!! ;) *)
  -intros.
   specialize (H t).
   rewrite helpBefore1 in H.
   inversion H.
   +exact H1.
   +exact H0.
Qed.

SearchAbout leb.
(* the first nat is the maximum we wan't to have in this bounded nat interval *)
Fixpoint forall_bounded (n : nat) (f : nat -> bool) : bool :=
  match n with
  | 0 => f 0
  | S n => f (S n) && forall_bounded n f
  end.

Lemma help_forall_findP1 : forall (f : nat -> bool) (k : nat), (forall (n: nat), n <= k -> f n = true) -> forall_bounded k f = true.
Proof.
  intros.
  induction k.
  -apply H.
   reflexivity.
  -simpl.
   Search (_ && _ = true).
   apply andb_true_intro.
   split.
   +apply H.
    reflexivity.
   +apply IHk.
    intros n.
    specialize (H n).
    intros.
    apply H.
    Search (_ <= S _).
    apply le_S in H0.
    exact H0.
Qed.

Lemma help_forall_findP2 :
  forall (k : nat) (f : nat -> bool), forall_bounded k f = true -> (forall (n: nat), n <= k -> f n = true).
Proof.
  induction k.
  -simpl.
   intros.
   Search (_ <= 0).
   apply le_n_0_eq in H0.
   rewrite <- H0.
   exact H.
  -destruct n.
   +intros.
    apply IHk.
    simpl in H.
    Search (_ && _ = true).
    apply andb_prop in H.
    destruct H.
    exact H1.
    apply Peano.le_0_n.
   +apply andb_prop in H.
    fold forall_bounded in H.
    destruct H.
    intros.
    change (f (S n) = true) with ((fun n => f (S n)) n = true).
    apply IHk.
    {(* c'est donner par H0 et H mais faut trouver un théoreme pour reussir a exprimer ça *)
      assert (forall (k' : nat) (f' : nat -> bool) , f' (S k') = true -> forall_bounded k' f' = true -> forall_bounded k' (fun n0 : nat => f' (S n0)) = true).
      {
        induction k'.
        -intros.
         simpl.
         auto.
        -intros.
         simpl.
         rewrite H2.
         simpl.
         apply IHk'.
         +unfold forall_bounded in H3.
          fold forall_bounded in H3.
          apply andb_true_iff in H3.
          destruct H3.
          auto.
         +unfold forall_bounded in H3.
          fold forall_bounded in H3.
          apply andb_true_iff in H3.
          destruct H3.
          auto.
      }
      auto.
    }
    {
      Search (S _ <= S _).
      apply le_S_n in H1.
      exact H1.
    }
Qed.

Lemma forall_finP: forall (P : nat -> Prop)(f : nat -> bool) (k : nat),
    (forall (n : nat), reflect (P n) (f n)) ->
    reflect (forall n, n <= k -> P n) (forall_bounded k f).
Proof.
  intros P f k H.
  apply iff_reflect.
  apply iff_to_and.
  split.
  -intros.
   Check help_forall_findP1.
   apply help_forall_findP1.
   intros.
   specialize (H n).
   apply reflect_iff in H.
   inversion H.
   apply H2.
   apply H0.
   exact H1.
  -intros.
   Check help_forall_findP2.
   eapply help_forall_findP2 in H0.
   specialize (H n).
   rewrite H0 in H.
   inversion H.
   exact H2.
   exact H1.
Qed.

Definition imply (a b : bool): bool := if a then b else true.

Lemma implyP: forall A B a b, reflect A a -> reflect B b -> reflect (A -> B) (imply a b).
Proof.
  intros.
  apply reflect_iff in H.
  inversion H.
  apply reflect_iff in H0.
  inversion H0.
  apply iff_reflect.
  apply iff_to_and.
  unfold imply.
  split.
  -intros.
   destruct a.
   +apply H3.
    apply H5.
    apply H2.
    reflexivity.
   +reflexivity.
  -intros.
   destruct b.
   +apply H4.
    reflexivity.
   +destruct a.
    {
      discriminate.
    }
    {
      apply H4.
      apply H1.
      exact H6.
    }
Qed.

SearchAbout beq_nat.

Definition eq_mtag (t1 t2: option tag): bool :=
  match t1,t2 with
  | Some t1', Some t2' => tag_beq t1' t2'
  | _,_ => false
  end.

Lemma eq_mtag_equiv : forall (t1 t2 : option tag), eq_mtag t1 t2 = true -> t1 = t2.
Proof.
  destruct t1.
  -destruct t2.
   +simpl.
   intros.
   apply tag_beq_different in H.
   rewrite H.
   reflexivity.
   +discriminate.
  -discriminate.
Qed.

Definition eq_mnat (t1 t2: option nat): bool :=
  match t1,t2 with
  | Some n1,Some n2 => beq_nat n1 n2
  | _,_ => false
  end.

Lemma eq_mnat_equiv : forall (n1 n2 : option nat), eq_mnat n1 n2 = true -> n1 = n2.
Proof.
  destruct n1.
  -destruct n2.
   +simpl.
    intros.
    Search (_ =? _ = true).
    apply beq_nat_true in H.
    rewrite H.
    reflexivity.
   +discriminate.
  -discriminate.
Qed.

Definition lookdown_encdecP : bool :=
  forall_bounded 226 (fun n =>
                      forall_tag (fun t => imply (eq_mtag (lookdown n encdec) (Some t))
                                                 (eq_mnat (lookup t encdec) (Some n)))).
Definition lookdown_encdecP' : bool :=
  forall_bounded 226 (fun n =>
                      forall_tag (fun t => imply (eq_mnat (lookup t encdec) (Some n))
                                                 (eq_mtag (lookdown n encdec) (Some t)))).

Lemma lookdown_n_inf_7 : forall (n : nat) (t : tag), lookdown n encdec = Some t -> n <=226.
Proof.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
    destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  destruct n. intros. repeat (apply le_n_S). apply Peano.le_0_n.
  intros. simpl in H. discriminate.
Qed.

Theorem lookdown_encdec : forall (n : nat) (t : tag), lookdown n encdec = Some t -> lookup t encdec = Some n.
Proof.
  SearchAbout (_ < _ \/ _).
  assert (reflect (forall (n : nat), n <= 226 -> forall
                       (t : tag), lookdown n encdec = Some t -> lookup t encdec = Some n)
                  lookdown_encdecP).
  {
    unfold lookdown_encdecP.
    SearchAbout forall_bounded.
    Check forall_finP.
    apply forall_finP.
    intro n.
    Check forall_tag.
    apply forall_tagP.
    SearchAbout imply.
    intros t.
    apply implyP.
    -assert (reflect (lookdown n encdec = Some t) (eq_mtag (lookdown n encdec) (Some t))).
    {
      apply iff_reflect.
      apply iff_to_and.
      split.
      +intros.
       rewrite H.
       simpl.
       rewrite tag_beq_reflexivity.
       reflexivity.
      +intros.
       apply eq_mtag_equiv in H.
       exact H.
    }
    exact H.
    -assert (reflect (lookup t encdec = Some n) (eq_mnat (lookup t encdec) (Some n))).
    {
      apply iff_reflect.
      apply iff_to_and.
      split.
      -intros.
      rewrite H.
      simpl.
      Search (_ =? _).
      rewrite <- beq_nat_refl.
      reflexivity.
      -intros.
       apply eq_mnat_equiv in H.
       exact H.
    }
    exact H.
  }
  (* i admit this only because computing is too long *)
  assert (H': lookdown_encdecP = true) by admit.
  rewrite H' in H.
  inversion H.
  intros n.
  Search (_ <= _ \/ _).
  Check Nat.le_gt_cases.
  specialize (Nat.le_gt_cases n 226).
  intros.
  destruct H1.
  -apply H0.
   exact H1.
   exact H2.
  -assert (exists m, n = 227 + m).
   {
     (* not that simple *)
     Search (_ < _).
     admit.
   }
   destruct H3.
   subst n.
   simpl in H2.
   discriminate.
  Admitted.

(* need to find how to refactor the proof *)
Lemma lookup_val : forall (n : nat) (t : tag), lookup t encdec = Some n -> n <= 226.
Proof.
Admitted.

Theorem lookup_encdecP : forall (n : nat) (t : tag) , lookup t encdec = Some n -> lookdown n encdec = Some t.
Proof.
  SearchAbout reflect.
  assert (reflect (forall (n : nat), n <= 226 -> forall (t : tag), lookup t encdec = Some n -> lookdown n encdec = Some t) lookdown_encdecP').
  {
    unfold lookdown_encdecP.
    SearchAbout reflect.
    Check forall_finP.
    apply forall_finP.
    Check forall_tagP.
    intros n.
    apply forall_tagP.
    SearchAbout reflect.
    Check implyP.
    intros t.
    apply implyP.
    -assert (reflect (lookup t encdec = Some n) (eq_mnat (lookup t encdec) (Some n))).
     {
       apply iff_reflect.
       apply iff_to_and.
       split.
       +intros.
        rewrite H.
        simpl.
        apply Nat.eqb_refl.
       +intros.
        apply eq_mnat_equiv in H.
        exact H.
     }
     exact H.
    -assert (reflect (lookdown n encdec = Some t) (eq_mtag (lookdown n encdec) (Some t))).
     {
       apply iff_reflect.
       apply iff_to_and.
       split.
       +intros.
        rewrite H.
        simpl.
        apply tag_beq_reflexivity.
       +intros.
        apply eq_mtag_equiv in H.
        exact H.
     }
     exact H.
  }
  (* same as previously *)
  assert (lookdown_encdecP' = true) by admit.
  rewrite H0 in H.
  inversion H.
  intros n.
  Search (_ <= _ \/ _).
  Check Nat.le_gt_cases.
  specialize (Nat.le_gt_cases n 226).
  intros.
  destruct H2.
  -apply H1.
   exact H2.
   exact H3.
  -assert (exists m, n = 227 + m).
   {
     admit.
   }
   destruct H4.
   subst n.
   apply lookup_val in H3.
   simpl in H3.
   Search (S _ <= _).
   repeat apply le_S_n in H3.
   Search (S _ <= 0).
   apply Nat.nle_succ_0 in H3.
   inversion H3.
Admitted.


Require Import Coq.Program.Equality.
Require Import Coq.Program.Tactics.
Require Export Needle.

Local Set Asymmetric Patterns.

Section Namespace.
  Inductive Namespace : Type :=
    | tm .
  Lemma eq_namespace_dec (a : Namespace) (b : Namespace) :
    (sumbool (a = b) (not (a = b))).
  Proof.
    decide equality .
  Defined.
End Namespace.

Section HVarlist.
  Inductive Hvl : Type :=
    | H0
    | HS (a : Namespace) (k : Hvl).

  Fixpoint appendHvl (k : Hvl) (k0 : Hvl) {struct k0} :
  Hvl :=
    match k0 with
      | (H0) => k
      | (HS a k0) => (HS a (appendHvl k k0))
    end.

  Lemma appendHvl_assoc  :
    (forall (k : Hvl) (k0 : Hvl) (k1 : Hvl) ,
      ((appendHvl (appendHvl k k0) k1) = (appendHvl k (appendHvl k0 k1)))).
  Proof.
    needleGenericWeakenAppend .
  Qed.
End HVarlist.

Section Index.
  Inductive Index (a : Namespace) : Type :=
    | I0
    | IS : (Index a) -> (Index a).

  Global Arguments I0 [a] .
  Global Arguments IS [a] _ .

  Lemma eq_index_dec {a : Namespace} (i : (Index a)) (j : (Index a)) :
    (sumbool (i = j) (not (i = j))).
  Proof.
    decide equality .
  Qed.

  Fixpoint weakenIndextm (x3 : (Index tm)) (k : Hvl) {struct k} :
  (Index tm) :=
    match k with
      | (H0) => x3
      | (HS a k) => match a with
        | (tm) => (IS (weakenIndextm x3 k))
      end
    end.
  Lemma weakenIndextm_append  :
    (forall (x3 : (Index tm)) (k : Hvl) (k0 : Hvl) ,
      ((weakenIndextm (weakenIndextm x3 k) k0) = (weakenIndextm x3 (appendHvl k k0)))).
  Proof.
    needleGenericWeakenAppend .
  Qed.
End Index.

Section Terms.
  Inductive Tm : Set :=
    | var (x : (Index tm))
    | abs (t : Tm)
    | app (t1 : Tm) (t2 : Tm).
  Scheme ind_Tm := Induction for Tm Sort Prop.
End Terms.

Section Functions.

End Functions.

Section Shift.
  Inductive Cutoff (a : Namespace) : Type :=
    | C0
    | CS : (Cutoff a) -> (Cutoff a).

  Global Arguments C0 {a} .
  Global Arguments CS {a} _ .
  Fixpoint weakenCutofftm (c : (Cutoff tm)) (k : Hvl) {struct k} :
  (Cutoff tm) :=
    match k with
      | (H0) => c
      | (HS a k) => match a with
        | (tm) => (CS (weakenCutofftm c k))
      end
    end.

  Lemma weakenCutofftm_append  :
    (forall (c : (Cutoff tm)) (k : Hvl) (k0 : Hvl) ,
      ((weakenCutofftm (weakenCutofftm c k) k0) = (weakenCutofftm c (appendHvl k k0)))).
  Proof.
    needleGenericWeakenAppend .
  Qed.
  Fixpoint shiftIndex (c : (Cutoff tm)) (x3 : (Index tm)) {struct c} :
  (Index tm) :=
    match c with
      | (C0) => (IS x3)
      | (CS c) => match x3 with
        | (I0) => I0
        | (IS x3) => (IS (shiftIndex c x3))
      end
    end.
  Fixpoint shiftTm (c : (Cutoff tm)) (s : Tm) {struct s} :
  Tm :=
    match s with
      | (var x3) => (var (shiftIndex c x3))
      | (abs t0) => (abs (shiftTm (CS c) t0))
      | (app t3 t4) => (app (shiftTm c t3) (shiftTm c t4))
    end.
End Shift.

Section Weaken.
  Fixpoint weakenTm (s : Tm) (k : Hvl) {struct k} :
  Tm :=
    match k with
      | (H0) => s
      | (HS tm k) => (shiftTm C0 (weakenTm s k))
    end.
End Weaken.

Section Subst.
  Inductive Trace (a : Namespace) : Type :=
    | X0
    | XS (b : Namespace)
        (T : (Trace a)).

  Global Arguments X0 [a] .
  Global Arguments XS [a] b _ .
  Fixpoint weakenTrace {a : Namespace} (x3 : (Trace a)) (k : Hvl) {struct k} :
  (Trace a) :=
    match k with
      | (H0) => x3
      | (HS b k) => (XS b (weakenTrace x3 k))
    end.
  Lemma weakenTrace_append (a : Namespace) :
    (forall (x3 : (Trace a)) (k : Hvl) (k0 : Hvl) ,
      ((weakenTrace (weakenTrace x3 k) k0) = (weakenTrace x3 (appendHvl k k0)))).
  Proof.
    needleGenericWeakenAppend .
  Qed.
  Fixpoint substIndex (d : (Trace tm)) (s : Tm) (x3 : (Index tm)) {struct d} :
  Tm :=
    match d with
      | (X0) => match x3 with
        | (I0) => s
        | (IS x3) => (var x3)
      end
      | (XS tm d) => match x3 with
        | (I0) => (var I0)
        | (IS x3) => (shiftTm C0 (substIndex d s x3))
      end
    end.
  Fixpoint substTm (d : (Trace tm)) (s : Tm) (s0 : Tm) {struct s0} :
  Tm :=
    match s0 with
      | (var x3) => (substIndex d s x3)
      | (abs t0) => (abs (substTm (weakenTrace d (HS tm H0)) s t0))
      | (app t3 t4) => (app (substTm d s t3) (substTm d s t4))
    end.
End Subst.

Global Hint Resolve (f_equal (shiftTm C0)) : cong_shift0.
 Hint Rewrite weakenCutofftm_append : weakencutoff_append.
 Hint Rewrite weakenTrace_append : weakentrace_append.
Section SubstShiftReflection.
  Lemma substIndex0_shiftIndex0_reflection_ind (s : Tm) :
    (forall (k : Hvl) (x3 : (Index tm)) ,
      ((substIndex (weakenTrace X0 k) s (shiftIndex (weakenCutofftm C0 k) x3)) = (var x3))).
  Proof.
    needleGenericSubstIndexShiftIndexReflectionInd .
  Qed.
  Fixpoint subst0_shift0_Tm_reflection_ind (s0 : Tm) (k : Hvl) (s : Tm) {struct s0} :
  ((substTm (weakenTrace X0 k) s (shiftTm (weakenCutofftm C0 k) s0)) = s0) :=
    match s0 return ((substTm (weakenTrace X0 k) s (shiftTm (weakenCutofftm C0 k) s0)) = s0) with
      | (var x3) => (substIndex0_shiftIndex0_reflection_ind s k x3)
      | (abs t0) => (f_equal abs (eq_trans (f_equal3 substTm (weakenTrace_append tm X0 k (HS tm H0)) eq_refl eq_refl) (subst0_shift0_Tm_reflection_ind t0 (HS tm k) s)))
      | (app t3 t4) => (f_equal2 app (subst0_shift0_Tm_reflection_ind t3 k s) (subst0_shift0_Tm_reflection_ind t4 k s))
    end.
  Definition substTm0_shiftTm0_reflection (s0 : Tm) : (forall (s : Tm) ,
    ((substTm X0 s (shiftTm C0 s0)) = s0)) := (subst0_shift0_Tm_reflection_ind s0 H0).
End SubstShiftReflection.
Section ShiftInteraction.
  Section ShiftIndexCommInd.
    Lemma shiftIndex_shiftIndex0_comm_ind  :
      (forall (k : Hvl) (c : (Cutoff tm)) (x3 : (Index tm)) ,
        ((shiftIndex (weakenCutofftm (CS c) k) (shiftIndex (weakenCutofftm C0 k) x3)) = (shiftIndex (weakenCutofftm C0 k) (shiftIndex (weakenCutofftm c k) x3)))).
    Proof.
      needleGenericShiftIndexCommInd .
    Qed.
  End ShiftIndexCommInd.
  Section ShiftCommInd.
    Fixpoint shift_shift0_Tm_comm_ind (s : Tm) (k : Hvl) (c : (Cutoff tm)) {struct s} :
    ((shiftTm (weakenCutofftm (CS c) k) (shiftTm (weakenCutofftm C0 k) s)) = (shiftTm (weakenCutofftm C0 k) (shiftTm (weakenCutofftm c k) s))) :=
      match s return ((shiftTm (weakenCutofftm (CS c) k) (shiftTm (weakenCutofftm C0 k) s)) = (shiftTm (weakenCutofftm C0 k) (shiftTm (weakenCutofftm c k) s))) with
        | (var x3) => (f_equal var (shiftIndex_shiftIndex0_comm_ind k c x3))
        | (abs t0) => (f_equal abs (shift_shift0_Tm_comm_ind t0 (HS tm k) c))
        | (app t3 t4) => (f_equal2 app (shift_shift0_Tm_comm_ind t3 k c) (shift_shift0_Tm_comm_ind t4 k c))
      end.
  End ShiftCommInd.
  Section ShiftComm.
    Definition shift_shift0_Tm_comm (s : Tm) : (forall (c : (Cutoff tm)) ,
      ((shiftTm (CS c) (shiftTm C0 s)) = (shiftTm C0 (shiftTm c s)))) := (shift_shift0_Tm_comm_ind s H0).
  End ShiftComm.
End ShiftInteraction.
 Hint Rewrite shift_shift0_Tm_comm : interaction.
 Hint Rewrite shift_shift0_Tm_comm : shift_shift0.
Section WeakenShift.
  Lemma weakenTm_shiftTm  :
    (forall (k : Hvl) (c : (Cutoff tm)) (s : Tm) ,
      ((weakenTm (shiftTm c s) k) = (shiftTm (weakenCutofftm c k) (weakenTm s k)))).
  Proof.
    needleGenericWeakenShift .
  Qed.
End WeakenShift.
Section ShiftSubstInteraction.
  Section ShiftSubstIndexCommInd.
    Lemma shiftTm_substIndex0_comm_ind (c : (Cutoff tm)) (s : Tm) :
      (forall (k : Hvl) (x3 : (Index tm)) ,
        ((shiftTm (weakenCutofftm c k) (substIndex (weakenTrace X0 k) s x3)) = (substIndex (weakenTrace X0 k) (shiftTm c s) (shiftIndex (weakenCutofftm (CS c) k) x3)))).
    Proof.
      needleGenericShiftSubstIndexCommInd .
    Qed.
  End ShiftSubstIndexCommInd.
  Section ShiftSubstCommInd.
    Fixpoint shift_subst0_Tm_comm_ind (s0 : Tm) (k : Hvl) (c : (Cutoff tm)) (s : Tm) {struct s0} :
    ((shiftTm (weakenCutofftm c k) (substTm (weakenTrace X0 k) s s0)) = (substTm (weakenTrace X0 k) (shiftTm c s) (shiftTm (weakenCutofftm (CS c) k) s0))) :=
      match s0 return ((shiftTm (weakenCutofftm c k) (substTm (weakenTrace X0 k) s s0)) = (substTm (weakenTrace X0 k) (shiftTm c s) (shiftTm (weakenCutofftm (CS c) k) s0))) with
        | (var x3) => (shiftTm_substIndex0_comm_ind c s k x3)
        | (abs t0) => (f_equal abs (eq_trans (f_equal2 shiftTm eq_refl (f_equal3 substTm (weakenTrace_append tm X0 k (HS tm H0)) eq_refl eq_refl)) (eq_trans (shift_subst0_Tm_comm_ind t0 (HS tm k) c s) (f_equal3 substTm (eq_sym (weakenTrace_append tm X0 k (HS tm H0))) eq_refl eq_refl))))
        | (app t3 t4) => (f_equal2 app (shift_subst0_Tm_comm_ind t3 k c s) (shift_subst0_Tm_comm_ind t4 k c s))
      end.
  End ShiftSubstCommInd.
  Section ShiftSubstComm.
    Definition shiftTm_substTm0_comm (s0 : Tm) : (forall (c : (Cutoff tm)) (s : Tm) ,
      ((shiftTm c (substTm X0 s s0)) = (substTm X0 (shiftTm c s) (shiftTm (CS c) s0)))) := (shift_subst0_Tm_comm_ind s0 H0).
  End ShiftSubstComm.
  Section SubstShiftIndexCommInd.
    Lemma substIndex_shiftTm0_comm_ind (d : (Trace tm)) (s : Tm) :
      (forall (k : Hvl) (x3 : (Index tm)) ,
        ((substIndex (weakenTrace (XS tm d) k) s (shiftIndex (weakenCutofftm C0 k) x3)) = (shiftTm (weakenCutofftm C0 k) (substIndex (weakenTrace d k) s x3)))).
    Proof.
      needleGenericShiftSubstIndexCommInd .
    Qed.
  End SubstShiftIndexCommInd.
  Section SubstShiftCommInd.
    Fixpoint subst_shift0_Tm_comm_ind (s0 : Tm) (k : Hvl) (d : (Trace tm)) (s : Tm) {struct s0} :
    ((substTm (weakenTrace (XS tm d) k) s (shiftTm (weakenCutofftm C0 k) s0)) = (shiftTm (weakenCutofftm C0 k) (substTm (weakenTrace d k) s s0))) :=
      match s0 return ((substTm (weakenTrace (XS tm d) k) s (shiftTm (weakenCutofftm C0 k) s0)) = (shiftTm (weakenCutofftm C0 k) (substTm (weakenTrace d k) s s0))) with
        | (var x3) => (substIndex_shiftTm0_comm_ind d s k x3)
        | (abs t0) => (f_equal abs (eq_trans (f_equal3 substTm (weakenTrace_append tm (XS tm d) k (HS tm H0)) eq_refl eq_refl) (eq_trans (subst_shift0_Tm_comm_ind t0 (HS tm k) d s) (f_equal2 shiftTm eq_refl (f_equal3 substTm (eq_sym (weakenTrace_append tm d k (HS tm H0))) eq_refl eq_refl)))))
        | (app t3 t4) => (f_equal2 app (subst_shift0_Tm_comm_ind t3 k d s) (subst_shift0_Tm_comm_ind t4 k d s))
      end.
  End SubstShiftCommInd.
  Section SubstShiftComm.
    Definition substTm_shiftTm0_comm (s0 : Tm) : (forall (d : (Trace tm)) (s : Tm) ,
      ((substTm (XS tm d) s (shiftTm C0 s0)) = (shiftTm C0 (substTm d s s0)))) := (subst_shift0_Tm_comm_ind s0 H0).
  End SubstShiftComm.
  Section SubstSubordInd.

  End SubstSubordInd.
  Section SubstSubord.

  End SubstSubord.
End ShiftSubstInteraction.
 Hint Rewrite substTm0_shiftTm0_reflection : interaction.
 Hint Rewrite substTm0_shiftTm0_reflection : reflection.
 Hint Rewrite substTm_shiftTm0_comm : interaction.
 Hint Rewrite substTm_shiftTm0_comm : subst_shift0.
 Hint Rewrite shiftTm_substTm0_comm : interaction.
 Hint Rewrite shiftTm_substTm0_comm : shift_subst0.
Section SubstSubstInteraction.
  Section SubstSubstIndexCommInd.
    Lemma substTm_substIndex0_commright_ind (d : (Trace tm)) (s : Tm) (s0 : Tm) :
      (forall (k : Hvl) (x3 : (Index tm)) ,
        ((substTm (weakenTrace d k) s (substIndex (weakenTrace X0 k) s0 x3)) = (substTm (weakenTrace X0 k) (substTm d s s0) (substIndex (weakenTrace (XS tm d) k) s x3)))).
    Proof.
      needleGenericSubstSubstIndexCommInd .
    Qed.
  End SubstSubstIndexCommInd.
  Section SubstSubstCommInd.
    Fixpoint subst_subst0_Tm_comm_ind (s1 : Tm) (k : Hvl) (d : (Trace tm)) (s : Tm) (s0 : Tm) {struct s1} :
    ((substTm (weakenTrace d k) s (substTm (weakenTrace X0 k) s0 s1)) = (substTm (weakenTrace X0 k) (substTm d s s0) (substTm (weakenTrace (XS tm d) k) s s1))) :=
      match s1 return ((substTm (weakenTrace d k) s (substTm (weakenTrace X0 k) s0 s1)) = (substTm (weakenTrace X0 k) (substTm d s s0) (substTm (weakenTrace (XS tm d) k) s s1))) with
        | (var x3) => (substTm_substIndex0_commright_ind d s s0 k x3)
        | (abs t0) => (f_equal abs (eq_trans (f_equal3 substTm (weakenTrace_append tm d k (HS tm H0)) eq_refl (f_equal3 substTm (weakenTrace_append tm X0 k (HS tm H0)) eq_refl eq_refl)) (eq_trans (subst_subst0_Tm_comm_ind t0 (HS tm k) d s s0) (f_equal3 substTm (eq_sym (weakenTrace_append tm X0 k (HS tm H0))) eq_refl (f_equal3 substTm (eq_sym (weakenTrace_append tm (XS tm d) k (HS tm H0))) eq_refl eq_refl)))))
        | (app t3 t4) => (f_equal2 app (subst_subst0_Tm_comm_ind t3 k d s s0) (subst_subst0_Tm_comm_ind t4 k d s s0))
      end.
  End SubstSubstCommInd.
  Section SubstSubstComm.
    Definition substTm_substTm0_comm (s1 : Tm) : (forall (d : (Trace tm)) (s : Tm) (s0 : Tm) ,
      ((substTm d s (substTm X0 s0 s1)) = (substTm X0 (substTm d s s0) (substTm (XS tm d) s s1)))) := (subst_subst0_Tm_comm_ind s1 H0).
  End SubstSubstComm.
  Section WeakenSubst.
    Lemma weakenTm_substTm  :
      (forall (k : Hvl) (d : (Trace tm)) (s : Tm) (s0 : Tm) ,
        ((weakenTm (substTm d s s0) k) = (substTm (weakenTrace d k) s (weakenTm s0 k)))).
    Proof.
      needleGenericWeakenSubst .
    Qed.
  End WeakenSubst.
End SubstSubstInteraction.
 Hint Rewrite substTm_substTm0_comm : interaction.
 Hint Rewrite substTm_substTm0_comm : subst_subst0.
 Hint Rewrite weakenTm_shiftTm : weaken_shift.
 Hint Rewrite weakenTm_substTm : weaken_subst.
Section WellFormed.
  Fixpoint wfindex {a : Namespace} (k : Hvl) (i : (Index a)) {struct k} :
  Prop :=
    match k with
      | (H0) => False
      | (HS b k) => match (eq_namespace_dec a b) with
        | (left e) => match i with
          | (I0) => True
          | (IS i) => (wfindex k i)
        end
        | (right n) => (wfindex k i)
      end
    end.
  Inductive wfTm (k : Hvl) : Tm -> Prop :=
    | wfTm_var (x3 : (Index tm))
        (wfi : (wfindex k x3)) :
        (wfTm k (var x3))
    | wfTm_abs {t0 : Tm}
        (wf : (wfTm (HS tm k) t0)) :
        (wfTm k (abs t0))
    | wfTm_app {t3 : Tm}
        (wf : (wfTm k t3)) {t4 : Tm}
        (wf0 : (wfTm k t4)) :
        (wfTm k (app t3 t4)).
  Definition inversion_wfTm_var_1 (k : Hvl) (x : (Index tm)) (H5 : (wfTm k (var x))) : (wfindex k x) := match H5 in (wfTm _ s) return match s return Prop with
    | (var x) => (wfindex k x)
    | _ => True
  end with
    | (wfTm_var x H1) => H1
    | _ => I
  end.
  Definition inversion_wfTm_abs_1 (k0 : Hvl) (t : Tm) (H6 : (wfTm k0 (abs t))) : (wfTm (HS tm k0) t) := match H6 in (wfTm _ s0) return match s0 return Prop with
    | (abs t) => (wfTm (HS tm k0) t)
    | _ => True
  end with
    | (wfTm_abs t H2) => H2
    | _ => I
  end.
  Definition inversion_wfTm_app_0 (k1 : Hvl) (t1 : Tm) (t2 : Tm) (H7 : (wfTm k1 (app t1 t2))) : (wfTm k1 t1) := match H7 in (wfTm _ s1) return match s1 return Prop with
    | (app t1 t2) => (wfTm k1 t1)
    | _ => True
  end with
    | (wfTm_app t1 H3 t2 H4) => H3
    | _ => I
  end.
  Definition inversion_wfTm_app_1 (k1 : Hvl) (t1 : Tm) (t2 : Tm) (H7 : (wfTm k1 (app t1 t2))) : (wfTm k1 t2) := match H7 in (wfTm _ s1) return match s1 return Prop with
    | (app t1 t2) => (wfTm k1 t2)
    | _ => True
  end with
    | (wfTm_app t1 H3 t2 H4) => H4
    | _ => I
  end.
  Scheme ind_wfTm := Induction for wfTm Sort Prop.
End WellFormed.
Section ShiftWellFormed.
  Inductive shifthvl_tm : (forall (c : (Cutoff tm)) (k2 : Hvl) (k3 : Hvl) ,
    Prop) :=
    | shifthvl_tm_here (k2 : Hvl)
        : (shifthvl_tm C0 k2 (HS tm k2))
    | shifthvl_tm_there_tm
        (c : (Cutoff tm)) (k2 : Hvl)
        (k3 : Hvl) :
        (shifthvl_tm c k2 k3) -> (shifthvl_tm (CS c) (HS tm k2) (HS tm k3)).
  Lemma weaken_shifthvl_tm  :
    (forall (k2 : Hvl) {c : (Cutoff tm)} {k3 : Hvl} {k4 : Hvl} ,
      (shifthvl_tm c k3 k4) -> (shifthvl_tm (weakenCutofftm c k2) (appendHvl k3 k2) (appendHvl k4 k2))).
  Proof.
    needleGenericWeakenHVarlistInsert .
  Qed.
  Lemma shift_wfindex_tm  :
    (forall (c : (Cutoff tm)) (k2 : Hvl) (k3 : Hvl) (ins : (shifthvl_tm c k2 k3)) (x3 : (Index tm)) ,
      (wfindex k2 x3) -> (wfindex k3 (shiftIndex c x3))).
  Proof.
    needleGenericShiftWellFormedIndex .
  Qed.
  Definition shift_wfTm : (forall (k2 : Hvl) ,
    (forall (s2 : Tm) (wf : (wfTm k2 s2)) ,
      (forall (c : (Cutoff tm)) (k3 : Hvl) ,
        (shifthvl_tm c k2 k3) -> (wfTm k3 (shiftTm c s2))))) := (ind_wfTm (fun (k2 : Hvl) (s2 : Tm) (wf : (wfTm k2 s2)) =>
    (forall (c : (Cutoff tm)) (k3 : Hvl) ,
      (shifthvl_tm c k2 k3) -> (wfTm k3 (shiftTm c s2)))) (fun (k2 : Hvl) (x3 : (Index tm)) (wfi : (wfindex k2 x3)) (c : (Cutoff tm)) (k3 : Hvl) (ins : (shifthvl_tm c k2 k3)) =>
    (wfTm_var k3 _ (shift_wfindex_tm c k2 k3 ins x3 wfi))) (fun (k2 : Hvl) (t : Tm) (wf : (wfTm (HS tm k2) t)) IHt (c : (Cutoff tm)) (k3 : Hvl) (ins : (shifthvl_tm c k2 k3)) =>
    (wfTm_abs k3 (IHt (CS c) (HS tm k3) (weaken_shifthvl_tm (HS tm H0) ins)))) (fun (k2 : Hvl) (t1 : Tm) (wf : (wfTm k2 t1)) IHt1 (t2 : Tm) (wf0 : (wfTm k2 t2)) IHt2 (c : (Cutoff tm)) (k3 : Hvl) (ins : (shifthvl_tm c k2 k3)) =>
    (wfTm_app k3 (IHt1 c k3 (weaken_shifthvl_tm H0 ins)) (IHt2 c k3 (weaken_shifthvl_tm H0 ins))))).
  Fixpoint weaken_wfTm (k2 : Hvl) {struct k2} :
  (forall (k3 : Hvl) (s2 : Tm) (wf : (wfTm k3 s2)) ,
    (wfTm (appendHvl k3 k2) (weakenTm s2 k2))) :=
    match k2 return (forall (k3 : Hvl) (s2 : Tm) (wf : (wfTm k3 s2)) ,
      (wfTm (appendHvl k3 k2) (weakenTm s2 k2))) with
      | (H0) => (fun (k3 : Hvl) (s2 : Tm) (wf : (wfTm k3 s2)) =>
        wf)
      | (HS tm k2) => (fun (k3 : Hvl) (s2 : Tm) (wf : (wfTm k3 s2)) =>
        (shift_wfTm (appendHvl k3 k2) (weakenTm s2 k2) (weaken_wfTm k2 k3 s2 wf) C0 (HS tm (appendHvl k3 k2)) (shifthvl_tm_here (appendHvl k3 k2))))
    end.
End ShiftWellFormed.
Lemma wfTm_cast  :
  (forall (k2 : Hvl) (s2 : Tm) (k3 : Hvl) (s3 : Tm) ,
    (k2 = k3) -> (s2 = s3) -> (wfTm k2 s2) -> (wfTm k3 s3)).
Proof.
  congruence .
Qed.
 Hint Resolve shift_wfindex_tm : infra.
 Hint Resolve shift_wfindex_tm : shift.
 Hint Resolve shift_wfindex_tm : shift_wf.
 Hint Resolve shift_wfindex_tm : wf.
 Hint Resolve shift_wfTm : infra.
 Hint Resolve shift_wfTm : shift.
 Hint Resolve shift_wfTm : shift_wf.
 Hint Resolve shift_wfTm : wf.
 Hint Constructors shifthvl_tm : infra.
 Hint Constructors shifthvl_tm : shift.
 Hint Constructors shifthvl_tm : shift_wf.
 Hint Constructors shifthvl_tm : wf.
 Hint Resolve weaken_shifthvl_tm : infra.
 Hint Resolve weaken_shifthvl_tm : shift.
 Hint Resolve weaken_shifthvl_tm : shift_wf.
 Hint Resolve weaken_shifthvl_tm : weaken.
 Hint Resolve weaken_shifthvl_tm : wf.
Section SubstWellFormed.
  Inductive substhvl_tm (k2 : Hvl) : (forall (d : (Trace tm)) (k3 : Hvl) (k4 : Hvl) ,
    Prop) :=
    | substhvl_tm_here :
        (substhvl_tm k2 X0 (HS tm k2) k2)
    | substhvl_tm_there_tm
        {d : (Trace tm)} {k3 : Hvl}
        {k4 : Hvl} :
        (substhvl_tm k2 d k3 k4) -> (substhvl_tm k2 (XS tm d) (HS tm k3) (HS tm k4)).
  Lemma weaken_substhvl_tm  :
    (forall {k3 : Hvl} (k2 : Hvl) {d : (Trace tm)} {k4 : Hvl} {k5 : Hvl} ,
      (substhvl_tm k3 d k4 k5) -> (substhvl_tm k3 (weakenTrace d k2) (appendHvl k4 k2) (appendHvl k5 k2))).
  Proof.
    needleGenericWeakenSubstHvl .
  Qed.
  Lemma substhvl_tm_wfindex_tm {k2 : Hvl} {s2 : Tm} (wft : (wfTm k2 s2)) :
    (forall {d : (Trace tm)} {k3 : Hvl} {k4 : Hvl} ,
      (substhvl_tm k2 d k3 k4) -> (forall {x3 : (Index tm)} ,
        (wfindex k3 x3) -> (wfTm k4 (substIndex d s2 x3)))).
  Proof.
    needleGenericSubstHvlWfIndexHom .
  Qed.
  Definition substhvl_tm_wfTm {k2 : Hvl} {s2 : Tm} (wf : (wfTm k2 s2)) : (forall (k3 : Hvl) ,
    (forall (s3 : Tm) (wf0 : (wfTm k3 s3)) ,
      (forall {d : (Trace tm)} {k4 : Hvl} ,
        (substhvl_tm k2 d k3 k4) -> (wfTm k4 (substTm d s2 s3))))) := (ind_wfTm (fun (k3 : Hvl) (s3 : Tm) (wf0 : (wfTm k3 s3)) =>
    (forall {d : (Trace tm)} {k4 : Hvl} ,
      (substhvl_tm k2 d k3 k4) -> (wfTm k4 (substTm d s2 s3)))) (fun (k3 : Hvl) {x3 : (Index tm)} (wfi : (wfindex k3 x3)) {d : (Trace tm)} {k4 : Hvl} (del : (substhvl_tm k2 d k3 k4)) =>
    (substhvl_tm_wfindex_tm wf del wfi)) (fun (k3 : Hvl) (t : Tm) (wf0 : (wfTm (HS tm k3) t)) IHt {d : (Trace tm)} {k4 : Hvl} (del : (substhvl_tm k2 d k3 k4)) =>
    (wfTm_abs k4 (IHt (weakenTrace d (HS tm H0)) (HS tm k4) (weaken_substhvl_tm (HS tm H0) del)))) (fun (k3 : Hvl) (t1 : Tm) (wf0 : (wfTm k3 t1)) IHt1 (t2 : Tm) (wf1 : (wfTm k3 t2)) IHt2 {d : (Trace tm)} {k4 : Hvl} (del : (substhvl_tm k2 d k3 k4)) =>
    (wfTm_app k4 (IHt1 (weakenTrace d H0) k4 (weaken_substhvl_tm H0 del)) (IHt2 (weakenTrace d H0) k4 (weaken_substhvl_tm H0 del))))).
End SubstWellFormed.
 Hint Resolve substhvl_tm_wfindex_tm : infra.
 Hint Resolve substhvl_tm_wfindex_tm : subst.
 Hint Resolve substhvl_tm_wfindex_tm : subst_wf.
 Hint Resolve substhvl_tm_wfindex_tm : wf.
 Hint Resolve substhvl_tm_wfTm : infra.
 Hint Resolve substhvl_tm_wfTm : subst.
 Hint Resolve substhvl_tm_wfTm : subst_wf.
 Hint Resolve substhvl_tm_wfTm : wf.
 Hint Constructors substhvl_tm : infra.
 Hint Constructors substhvl_tm : subst.
 Hint Constructors substhvl_tm : subst_wf.
 Hint Constructors substhvl_tm : wf.
Section Context.
  Inductive Env : Type :=
    | empty
    | evar (G : Env).
  Fixpoint appendEnv (G : Env) (G0 : Env) :
  Env :=
    match G0 with
      | (empty) => G
      | (evar G1) => (evar (appendEnv G G1))
    end.
  Fixpoint domainEnv (G : Env) :
  Hvl :=
    match G with
      | (empty) => H0
      | (evar G0) => (HS tm (domainEnv G0))
    end.
  Lemma appendEnv_assoc  :
    (forall (G : Env) (G0 : Env) (G1 : Env) ,
      ((appendEnv G (appendEnv G0 G1)) = (appendEnv (appendEnv G G0) G1))).
  Proof.
    needleGenericAppendEnvAssoc .
  Qed.
  Lemma domainEnv_appendEnv  :
    (forall (G : Env) (G0 : Env) ,
      ((domainEnv (appendEnv G G0)) = (appendHvl (domainEnv G) (domainEnv G0)))).
  Proof.
    needleGenericDomainEnvAppendEnv .
  Qed.
  Fixpoint shiftEnv (c : (Cutoff tm)) (G : Env) :
  Env :=
    match G with
      | (empty) => empty
      | (evar G0) => (evar (shiftEnv c G0))
    end.
  Fixpoint weakenEnv (G : Env) (k2 : Hvl) {struct k2} :
  Env :=
    match k2 with
      | (H0) => G
      | (HS tm k2) => (weakenEnv G k2)
    end.
  Fixpoint substEnv (d : (Trace tm)) (s2 : Tm) (G : Env) :
  Env :=
    match G with
      | (empty) => empty
      | (evar G0) => (evar (substEnv d s2 G0))
    end.
  Lemma domainEnv_shiftEnv  :
    (forall (c : (Cutoff tm)) (G : Env) ,
      ((domainEnv (shiftEnv c G)) = (domainEnv G))).
  Proof.
    needleGenericDomainEnvShiftEnv .
  Qed.
  Lemma domainEnv_substEnv  :
    (forall (d : (Trace tm)) (s2 : Tm) (G : Env) ,
      ((domainEnv (substEnv d s2 G)) = (domainEnv G))).
  Proof.
    needleGenericDomainEnvSubstEnv .
  Qed.
End Context.
 Hint Rewrite domainEnv_appendEnv : interaction.
 Hint Rewrite domainEnv_appendEnv : env_domain_append.
Section ContextStuff.
  Section ShiftEnvAppendEnv.
    Lemma shiftEnv_appendEnv  :
      (forall (c : (Cutoff tm)) (G : Env) (G0 : Env) ,
        ((shiftEnv c (appendEnv G G0)) = (appendEnv (shiftEnv c G) (shiftEnv (weakenCutofftm c (domainEnv G)) G0)))).
    Proof.
      needleGenericShiftEnvAppendEnv .
    Qed.
  End ShiftEnvAppendEnv.
  Section SubstEnvAppendEnv.
    Lemma substEnv_appendEnv  :
      (forall (d : (Trace tm)) (s2 : Tm) (G : Env) (G0 : Env) ,
        ((substEnv d s2 (appendEnv G G0)) = (appendEnv (substEnv d s2 G) (substEnv (weakenTrace d (domainEnv G)) s2 G0)))).
    Proof.
      needleGenericSubstEnvAppendEnv .
    Qed.
  End SubstEnvAppendEnv.
  Lemma weakenTm_append  :
    (forall (s2 : Tm) (k2 : Hvl) (k3 : Hvl) ,
      ((weakenTm (weakenTm s2 k2) k3) = (weakenTm s2 (appendHvl k2 k3)))).
  Proof.
    needleGenericWeakenAppend .
  Qed.
  Section Lookups.
    Inductive lookup_evar : Env -> (Index tm) -> Prop :=
      | lookup_evar_here {G : Env} :
          (lookup_evar (evar G) I0)
      | lookup_evar_there_evar
          {G : Env} {x3 : (Index tm)} :
          (lookup_evar G x3) -> (lookup_evar (evar G) (IS x3)).
    Lemma weaken_lookup_evar  :
      (forall {G : Env} (G0 : Env) {x3 : (Index tm)} ,
        (lookup_evar G x3) -> (lookup_evar (appendEnv G G0) (weakenIndextm x3 (domainEnv G0)))).
    Proof.
      needleGenericWeakenLookup .
    Qed.
    Lemma lookup_evar_wfindex  :
      (forall {G : Env} {x3 : (Index tm)} ,
        (lookup_evar G x3) -> (wfindex (domainEnv G) x3)).
    Proof.
      needleGenericLookupWellformedIndex .
    Qed.
  End Lookups.
  Inductive shift_evar : (Cutoff tm) -> Env -> Env -> Prop :=
    | shift_evar_here {G : Env} :
        (shift_evar C0 G (evar G))
    | shiftevar_there_evar
        {c : (Cutoff tm)} {G : Env}
        {G0 : Env} :
        (shift_evar c G G0) -> (shift_evar (CS c) (evar G) (evar G0)).
  Lemma weaken_shift_evar  :
    (forall (G : Env) {c : (Cutoff tm)} {G0 : Env} {G1 : Env} ,
      (shift_evar c G0 G1) -> (shift_evar (weakenCutofftm c (domainEnv G)) (appendEnv G0 G) (appendEnv G1 G))).
  Proof.
    needleGenericWeakenInsertEnv .
  Qed.
  Lemma shift_evar_shifthvl_tm  :
    (forall {c : (Cutoff tm)} {G : Env} {G0 : Env} ,
      (shift_evar c G G0) -> (shifthvl_tm c (domainEnv G) (domainEnv G0))).
  Proof.
    needleGenericInsertEnvInsertHvl .
  Qed.
  Inductive subst_evar (G : Env) (s2 : Tm) : (Trace tm) -> Env -> Env -> Prop :=
    | subst_evar_here :
        (subst_evar G s2 X0 (evar G) G)
    | subst_evar_there_evar
        {d : (Trace tm)} {G0 : Env}
        {G1 : Env} :
        (subst_evar G s2 d G0 G1) -> (subst_evar G s2 (XS tm d) (evar G0) (evar G1)).
  Lemma weaken_subst_evar {G : Env} {s2 : Tm} :
    (forall (G0 : Env) {d : (Trace tm)} {G1 : Env} {G2 : Env} ,
      (subst_evar G s2 d G1 G2) -> (subst_evar G s2 (weakenTrace d (domainEnv G0)) (appendEnv G1 G0) (appendEnv G2 G0))).
  Proof.
    needleGenericWeakenSubstEnv .
  Qed.
  Lemma subst_evar_substhvl_tm {G : Env} {s2 : Tm} :
    (forall {d : (Trace tm)} {G0 : Env} {G1 : Env} ,
      (subst_evar G s2 d G0 G1) -> (substhvl_tm (domainEnv G) d (domainEnv G0) (domainEnv G1))).
  Proof.
    needleGenericSubstEnvSubstHvl .
  Qed.
End ContextStuff.
 Hint Constructors lookup_evar : infra.
 Hint Constructors lookup_evar : lookup.
 Hint Constructors lookup_evar : shift.
 Hint Constructors lookup_evar : subst.
 Hint Resolve weaken_lookup_evar : infra.
 Hint Resolve weaken_lookup_evar : lookup.
 Hint Resolve weaken_lookup_evar : shift.
 Hint Resolve weaken_lookup_evar : weaken.
Lemma weaken_lookup_evar_here  :
  (forall {G : Env} (G0 : Env) ,
    (lookup_evar (appendEnv (evar G) G0) (weakenIndextm I0 (domainEnv G0)))).
Proof.
  eauto with lookup .
Qed.
 Hint Constructors wfTm : infra.
 Hint Constructors wfTm : wf.
 Hint Extern 10 ((wfTm _ _)) => autorewrite with env_domain_append in *  : infra wf.
 Hint Extern 2 ((wfTm _ _)) => match goal with
  | H8 : (wfTm _ (var _)) |- _ => inversion H8; subst; clear H8
  | H8 : (wfTm _ (abs _)) |- _ => inversion H8; subst; clear H8
  | H8 : (wfTm _ (app _ _)) |- _ => inversion H8; subst; clear H8
end : infra wf.
 Hint Resolve lookup_evar_wfindex : infra.
 Hint Resolve lookup_evar_wfindex : lookup.
 Hint Resolve lookup_evar_wfindex : wf.
 Hint Constructors shift_evar : infra.
 Hint Constructors shift_evar : shift.
 Hint Constructors shift_evar : subst.
 Hint Resolve weaken_shift_evar : infra.
 Hint Resolve weaken_shift_evar : shift.
 Hint Resolve shift_evar_shifthvl_tm : infra.
 Hint Resolve shift_evar_shifthvl_tm : shift.
 Hint Resolve shift_evar_shifthvl_tm : shift_wf.
 Hint Resolve shift_evar_shifthvl_tm : wf.
 Hint Constructors subst_evar : infra.
 Hint Constructors subst_evar : subst.
 Hint Resolve weaken_subst_evar : infra.
 Hint Resolve weaken_subst_evar : subst.
 Hint Resolve subst_evar_substhvl_tm : infra.
 Hint Resolve subst_evar_substhvl_tm : subst.
 Hint Resolve subst_evar_substhvl_tm : subst_wf.
 Hint Resolve subst_evar_substhvl_tm : wf.
 Hint Resolve subst_evar_substhvl_tm : substenv_substhvl.
Lemma shift_evar_lookup_evar  :
  (forall {c : (Cutoff tm)} {G : Env} {G0 : Env} (ins : (shift_evar c G G0)) {x3 : (Index tm)} ,
    (lookup_evar G x3) -> (lookup_evar G0 (shiftIndex c x3))).
Proof.
  needleGenericInsertLookup .
Qed.
 Hint Resolve shift_evar_lookup_evar : infra.
 Hint Resolve shift_evar_lookup_evar : lookup.
 Hint Resolve shift_evar_lookup_evar : shift.
Fixpoint size_Tm (s : Tm) {struct s} :
nat :=
  match s with
    | (var x3) => 1
    | (abs t0) => (plus 1 (size_Tm t0))
    | (app t3 t4) => (plus 1 (plus (size_Tm t3) (size_Tm t4)))
  end.
Fixpoint shift_size_Tm (s : Tm) (c : (Cutoff tm)) {struct s} :
((size_Tm (shiftTm c s)) = (size_Tm s)) :=
  match s return ((size_Tm (shiftTm c s)) = (size_Tm s)) with
    | (var _) => eq_refl
    | (abs t) => (f_equal2 plus eq_refl (shift_size_Tm t (CS c)))
    | (app t1 t2) => (f_equal2 plus eq_refl (f_equal2 plus (shift_size_Tm t1 c) (shift_size_Tm t2 c)))
  end.
 Hint Rewrite shift_size_Tm : interaction.
 Hint Rewrite shift_size_Tm : shift_size.
Lemma weaken_size_Tm  :
  (forall (k : Hvl) (s : Tm) ,
    ((size_Tm (weakenTm s k)) = (size_Tm s))).
Proof.
  needleGenericWeakenSize .
Qed.
 Hint Rewrite weaken_size_Tm : interaction.
 Hint Rewrite weaken_size_Tm : weaken_size.
 Hint Rewrite appendEnv_assoc : interaction.
 Hint Rewrite <- weakenCutofftm_append weakenTrace_append weakenTm_append appendHvl_assoc : interaction.


Require Import ssreflect ssrnat ssrbool seq eqtype Ring Group.
Import Ring.RingFacts.

Lemma swap_neq {i j : nat}: i != j -> j != i. by rewrite eq_sym. Qed.

Axiom fresh2: forall (i j : nat), exists k, k!=i /\ k!=j.
Axiom fresh3: forall (i j k : nat), exists l, l!=i /\ l!=j /\ l!=k.

Parameter ZZZ : Type.
Parameter X : forall {i j : nat} (ij : i!=j) (x : R), ZZZ.

(* Custom 'pseudo'-conjugation *)
Parameter conj1 : ZZ -> ZZZ -> ZZ.
Axiom forward_rule: forall h1 h2 g, conj1 (h1 .* h2) g = (conj1 h1 g) .* (conj1 h2 g).
Axiom identity_rule: forall h, conj1 Id h = Id.

Notation "h ^^ g" := (conj1 h g) (at level 11, left associativity).
Parameter Z': forall {i j : nat} (p : i != j) (a r : R), ZZ.
Definition X' {i j : nat} (p : i != j) r := Z' p r (0).

Section Main.
Context (i j k l : nat) (a a1 a2 b c : R).

Axiom ZC1: forall (ij : i!=j) (jk : j!=k) (ik : i!=k) (ji : j!=i) (kj : k!=j) (ki : k!=i),
     Z' ij a b ^^ X ij c =
     X' ki (a * b) .*
     X' kj (a * (b * c + 1)) .*
     X' kj (- (a * (b * c + 1))) ^^ X jk (- b) ^^ X ik (c * b + 1) .*
     X' ki (- (a * b))           ^^ X jk (- b) ^^ X ik (c * b + 1).

Axiom ZC2: forall (ij : i != j) (ji : j != i),
      (Z' ij a b) ^^ (X ji c) = Z' ij a (b + c).

Axiom ZC3: forall (ij : i != j) (jk : j != k) (ik : i != k) (ki : k != i) (ik : i != k),
      (Z' ij a b) ^^ (X jk c) = X' jk (- (b * a * c)) .* X' ik (a * c) .* Z' ij a b.

(* Unsure about this one *)
Axiom ZC3': forall (ij : i != j) (ik : i != k) (ki : k != i) (kj: k != j),
      (Z' ij a b) ^^ (X ki c) = X' ki (- (c * a * b)) .* X' kj (-(c * a)) .* Z' ij a b.

Axiom ZC4: forall (ij : i!=j) (kj : k!=j) (ki : k!=i),
      (Z' ij a b) ^^ (X kj c) = X' ki (c * b * a * b) .* X' kj (c * b * a) .* Z' ij a b.

Axiom ZC4': forall (ij : i!=j) (jk : j!=k) (ik : i!=k),
      (Z' ij a b) ^^ (X ik c) = X' jk (- (b * a * b * c)) .* X' ik (a * b * c) .* Z' ij a b.

Axiom ZC5: forall (ij : i!=j) (jk : j!=k) (ik : i!=k) (il : i!=l) (jl : j!=l) (kl : k!=l),
      (Z' ij a b) ^^ (X kl c) = Z' ij a b.

(* Identites for Relative Steinberg group *)

Axiom Z0: forall (ij : i!=j), Z' ij (a1 + a2) b = Z' ij a1 b .* Z' ij a2 b.

Axiom Z1: forall (ij : i!=j) (ji : j!=i),
      X' ji (- a2) .* Z' ij a1 b ^^ X ij c .* X' ij a2 = Z' ij a1 b ^^ (X ij (c+a2)).

Axiom Z2: forall (ij : i!=j) (ji : j!=i),
      Z' ji (- a2) c .* Z' ij a1 b ^^ X ij c .* Z' ji a2 c = Z' ij a1 (b + a2) ^^ X ij c.

Axiom Z3: forall (ij : i!=j) (kj : k!=j) (jk : j!=k) (ik : i!=k),
      X' jk (- a2) .* Z' ij a1 b .* X' jk a2 = Z' ij a1 b ^^ X jk a2.

Axiom Z3': forall (ij : i!=j) (jk : j!=k) (ik : i!=k) (ki : k!=i),
      X' ki (- a2) .* Z' ij a1 b .* X' ki a2 = Z' ij a1 b ^^ X ki a2.

Axiom Z4: forall (ij : i!=j) (kj : k!=j) (ik : i!=k),
      X' kj (- a2) .* Z' ij a1 b .* X' kj a2 = Z' ij a1 b ^^ X kj a2.

Axiom Z4': forall (ij : i!=j) (kj : k!=j) (ik : i!=k),
      X' ik (- a2) .* Z' ij a1 b .* X' ik a2= Z' ij a1 b ^^ X ik a2.

Axiom Z5: forall (ij : i!=j) (kl : k!=l), i!=k -> i!=l -> j!=k -> j!=l ->
      Z' kl a1 b .* Z' ij a2 c = Z' ij a2 c .* Z' kl a1 b.

Axiom PR: forall (ij : i!=j) (ji : j!=i) (kj : k!=j) (jk : j!=k) (ik : i!=k) (ki : k!=i),
       (X' kj a ^^ X ik (- b)) ^^ X ji c =
      ((X' kj a ^^ X ji c) ^^ X ik (- b)) ^^ X jk (c * b).

End Main.

Section BasicCorollaries.

Context (i j : nat) (a : R) (ij : i!=j).

Lemma Z'zero: forall b, Z' ij 0 b = Id.
intros. apply (GCr (Z' ij 0 b)).
Proof. rewrite -Z0. by rewrite IdG; rsimpl. Qed.

Lemma Z'Inv: forall b, Z' ij (-a) b = (Z' ij a b)^-1.
Proof. intros. apply (GCr (Z' ij a b)). by rewrite -Z0 inv_l IG Z'zero. Qed.

Lemma X'def: Z' ij a 0 = X' ij a.
Proof. done. Qed.

Lemma X'zero: X' ij 0 = Id.
Proof. by rewrite /X' Z'zero. Qed.

Lemma X'Inv: X' ij (-a) = (X' ij a)^-1.
Proof. by rewrite /X' Z'Inv. Qed.

End BasicCorollaries.

Ltac simplify0 := rsimpl; rewrite ?X'zero ?X'def ?forward_rule ?identity_rule -?GA; cancel.

Section XC_Corollaries.
(* Computation rules for simpler generators X_ij *)
Ltac XC E := rewrite /X' E; simplify0.

Context (i j k l : nat)
        {ij : i != j} {ji : j != i}
        {ik : i != k} {jk : j != k} {ki : k != i} {kj : k != j}
        {kl : k != l} {il : i != l} {jl : j != l} {lk : l != k} {li : l != i} {lj : l != j}.

Lemma X0' a1 a2 g: g .* X' ij (a1 + a2) = g .* X' ij a1 .* X' ij a2 .
Lemma X0  a1 a2: X' ij (a1 + a2) = X' ij a1 .* X' ij a2 .

Lemma XC2 a b: X' ij a ^^ X ji b = Z' ij a b.
Lemma XC3 a c: (X' ij a) ^^ (X jk c) = X' ik (a * c) .* X' ij a.
Lemma XC3' a c: (X' ij a) ^^ (X ki c) = X' kj (-(c * a)) .* X' ij a.
Lemma XC4  a c: (X' ij a) ^^ (X kj c) = X' ij a.
Lemma XC4' a c: (X' ij a) ^^ (X ik c) = X' ij a.
Lemma XC5  a c: (X' ij a) ^^ (X kl c) = X' ij a.

by XC ZC5. Qed. by XC ZC4'. Qed.
by XC ZC4. Qed. by XC ZC3'. Qed.
by XC ZC3. Qed. by XC (@ZC2 i j a 0 b ij ji). Qed.
by XC Z0. Qed. by rewrite GA X0. Qed.
End XC_Corollaries.

Lemma XC1 i j (ij : i!=j) a c: X' ij a ^^ X ij c  = X' ij a.
move: (fresh2 i j) => [] m [] mi mj.
move: (swap_neq mi) (swap_neq mj) (swap_neq ij) => im jm ji.
rewrite /X' (ZC1 i j m) //; simplify0.
rewrite ZC2 plus_0_r X'def ZC3' //; simplify0.
move: (@Z4 i j m a (-a) 0 ij mj im); simplify0.
by rewrite XC4. Qed.

Module ZC_tactic.
Ltac Z_guard :=
  match goal with
    | [ |- is_true (negb (eq_op ?X ?X)) ] => fail 1
    | [ |- is_true (negb (eq_op ?X ?Y)) ] => done
    | [ |- _ ] => idtac
  end.

Ltac safe_rw E := try (rewrite E; Z_guard).

 Tactic Notation "safe_rw4"
  reference(F1) "," reference(F2) "," reference(F3) "," reference(F4) :=
  safe_rw F1; safe_rw F2; safe_rw F3; safe_rw F4.

 Ltac ZC := safe_rw4 XC2,  ZC2,  XC3, ZC3;
            safe_rw4 XC3', ZC3', XC4, ZC4;
            safe_rw4 XC4', ZC4', XC5, ZC5;
            safe_rw XC1; rewrite ?forward_rule ?identity_rule; rsimpl; cancel.

 Ltac ZCR := repeat ZC.
End ZC_tactic.

Section AxiomsExpanded. Import ZC_tactic.

Context (i j k l : nat) (a a1 a2 b c : R)
        {ij : i != j} {ji : j != i}
        {ik : i != k} {jk : j != k} {ki : k != i} {kj : k != j}
        {kl : k != l} {il : i != l} {jl : j != l} {lk : l != k} {li : l != i} {lj : l != j}.

Lemma PRFS:
Z' ij (b * a) c .* X' ki (a * c) .* X' kj a =
X' jk (c * b * a * c * b) .* X' ji (- (c * b * a * c)) .* Z' ki (a * c) (- b)
.* X' ik (b * a * c * b) .* X' ij (b * a) .* Z' kj a (c * b).
(* move: (PR i j k a b c ij ji kj jk ik ki). by ZCR; simplify0. Qed. *) Admitted.

Lemma Z3FS:
 X' jk (- a2) .* Z' ij a1 b .* X' jk a2 =
 X' jk (- (b * a1 * a2)) .* X' ik (a1 * a2) .* Z' ij a1 b.
move: (Z3 i j k a1 a2 b ij kj jk ik). by ZCR; simplify0. Qed.

Lemma Z3'FS:
 X' ki (- a2) .* Z' ij a1 b .* X' ki a2 =
 X' ki (- (a2 * a1 * b)) .* X' kj (- (a2 * a1)) .* Z' ij a1 b.
move: (Z3' i j k a1 a2 b ij jk ik ki). by ZCR; simplify0. Qed.

Lemma Z4FS:
 X' kj (- a2) .* Z' ij a1 b .* X' kj a2 =
 X' ki (a2 * b * a1 * b) .* X' kj (a2 * b * a1) .* Z' ij a1 b.
move: (Z4 i j k a1 a2 b ij kj ik). by ZCR; simplify0. Qed.

Lemma Z4'FS:
 X' ik (- a2) .* Z' ij a1 b .* X' ik a2 =
 X' jk (- (b * a1 * b * a2)) .* X' ik (a1 * b * a2) .* Z' ij a1 b.
move: (Z4' i j k a1 a2 b ij kj ik). by ZCR; simplify0. Qed.

End AxiomsExpanded.

Section Swap. Import ZC_tactic.

Corollary Z4_swap i j k a a1 b {ij : i != j} {ji : j != i} {ik : i != k} {jk : j != k} {ki : k != i} {kj : k != j}:
Z' ij a b .* X' kj a1 = X' kj a1 .* X' ki (a1 * b * a * b) .* X' kj (a1 * b * a) .* Z' ij a b.
by move: (@Z4 i j k a a1 b ij kj ik); ZCR; simplify0; move /(GCl' (X' kj a1)); rewrite -?GA X'Inv GI IdG. Qed.

Corollary Z4'_swap i j k a a1 b {ij : i != j} {ji : j != i} {ik : i != k} {jk : j != k} {ki : k != i} {kj : k != j}:
Z' ij a b .* X' ik a1 = X' ik (a1 + a * b * a1) .* X' jk (-(b * a * b * a1)) .* Z' ij a b.
move: (@Z4' i j k a a1 b ij kj ik); ZCR; simplify0; move /(GCl' (X' ik a1)); rewrite -?GA X'Inv GI IdG X0 => ->.
by bite; rewrite Z4_swap //; simplify0. Qed.

Corollary Z3_swap i j k a a1 b {ij : i != j} {ji : j != i} {ik : i != k} {jk : j != k} {ki : k != i} {kj : k != j}:
Z' ij a b .* X' jk (a1) = X' jk ((1 - b * a) * a1) .* X' ik ((a * a1)) .* Z' ij a b.
move: (@Z3 i j k a (a1) b ij kj jk ik); ZCR; simplify0.
move /(GCl' (X' jk (a1))). rewrite X'Inv -?GA GI IdG -X0 dist_r. by rsimpl. Qed.

Corollary Z3_swap_l i j k (a a1 b : R) {ij : i != j} {ji : j != i} {ik : i != k} {jk : j != k} {ki : k != i} {kj : k != j}:
X' jk (a1) .* Z' ij a b = Z' ij a b .* X' ik (- (a * a1)) .* X' jk ((1 + b * a) * a1).
move: (@Z3_swap i j k (-a) (-a1) b ij ji ik jk ki kj).
rewrite ?inv_mul ?mul_inv ?Z'Inv ?X'Inv -?GIM => /eqI; rsimpl.
by rewrite -?X'Inv -?Z'Inv -?GA. Qed.

Corollary Z3'_swap i j k a a1 b {ij : i != j} {ji : j != i} {ik : i != k} {jk : j != k} {ki : k != i} {kj : k != j}:
Z' ij a b .* X' ki a1 = X' ki (a1 * (1 - a * b)) .* X' kj (- (a1 * a)) .* Z' ij a b.
move: (@Z3' i j k a a1 b ij jk ik ki). ZCR; simplify0.
move /(GCl' (X' ki a1)). by rewrite X'Inv -?GA GI IdG -X0 dist_l; rsimpl. Qed.

Context (i j k l : nat) (a a1 a2 b c : R)
        {ij : i != j} {ji : j != i}
        {ik : i != k} {jk : j != k} {ki : k != i} {kj : k != j}
        {kl : k != l} {il : i != l} {jl : j != l} {lk : l != k} {li : l != i} {lj : l != j}.

Corollary X4_swap: (X' ij a1) .* (X' kj a) = (X' kj a) .* (X' ij a1).
by rewrite Z4_swap //; simplify0. Qed.

Corollary X4'_swap: (X' ij a1) .* (X' ik a2) = (X' ik a2) .* (X' ij a1).
by rewrite Z4'_swap //; simplify0. Qed.

Corollary X5_swap: (X' ij a1) .* (X' kl a2) =  (X' kl a2) .* (X' ij a1).
by rewrite Z5. Qed.

(* Prime corollaries *)

Corollary X4_swap' g: g.* X' ij a1 .* X' kj a = g .* X' kj a .* X' ij a1.
by rewrite GA X4_swap -?GA. Qed.

Corollary X4'_swap' g: g .* X' ij a1 .* X' ik a2 = g .* X' ik a2 .* X' ij a1.
by rewrite GA X4'_swap -?GA. Qed.

Corollary X5_swap' g: g .* X' ij a1 .* X' kl a2 = g .* X' kl a2 .* X' ij a1.
by rewrite GA X5_swap -?GA. Qed.

Corollary Z3_swap' g:
g .* Z' ij a b .* X' jk a1 = g .* X' jk ((1 - b * a) * a1) .* X' ik ((a * a1)) .* Z' ij a b.
by rewrite GA Z3_swap -?GA. Qed.

Corollary Z3_swap'_l g:
g .* X' jk (a1) .* Z' ij a b = g .* Z' ij a b .* X' ik (- (a * a1)) .* X' jk ((1 + b * a) * a1).
by rewrite GA Z3_swap_l -?GA. Qed.

Corollary Z3'_swap' g:
g .* Z' ij a b .* X' ki a1 = g .* X' ki (a1 * (1 - a * b)) .* X' kj (- (a1 * a)) .* Z' ij a b.
by rewrite GA Z3'_swap -?GA. Qed.

Corollary Z4_swap' g:
 g .* Z' ij a b .* X' kj a1 =
 g .* X' kj a1 .* X' ki (a1 * b * a * b) .* X' kj (a1 * b * a) .* Z' ij a b.
by rewrite GA Z4_swap -?GA. Qed.

Corollary Z4'_swap' g:
 g .* Z' ij a b .* X' ik a1 =
 g .* X' ik (a1 + a * b * a1) .* X' jk (-(b * a * b * a1)) .* Z' ij a b.
by rewrite GA Z4'_swap -?GA. Qed.

Corollary Z5' g: g.* Z' kl a1 b .* Z' ij a2 c = g .* Z' ij a2 c .* Z' kl a1 b.
by rewrite 2!GA Z5. Qed.

End Swap.

Section Z5_Untangle. Import ZC_tactic.

(* Z5_02_01 Uses assumption rkФ >= 4*)

Context (i j k l m n : nat) (a1 a2 b c d : R)
        {ij : i != j} {ji : j != i}
        {ik : i != k} {jk : j != k} {ki : k != i} {kj : k != j}
        {kl : k != l} {il : i != l} {jl : j != l} {lk : l != k} {li : l != i} {lj : l != j}

        {mi : m != i}  {mj : m != j} {mk : m != k} {ml : m != l}
        {im : i != m}  {jm : j != m} {km : k != m} {lm : l != m}

        {ni : n != i}  {nj : n != j} {nk : n != k} {nl : n != l} {nm : n != m}
        {in' : i != n} {jn : j != n} {kn : k != n} {ln : l != n} {mn : m != n}.

Lemma Z5_00_1: (Z' kl a1 b .* Z' ij a2 c) ^^ (X mn d)  = (Z' ij a2 c .* Z' kl a1 b) ^^ (X mn d).
ZCR. by rewrite Z5. Qed.

Lemma Z5_01_1: (Z' kl a1 b .* Z' ij a2 c) ^^ (X mi d)  = (Z' ij a2 c .* Z' kl a1 b) ^^ (X mi d).
ZCR. simplify0. rewrite -(Z5' i j k l) //; bite.
rewrite Z5 //; simplify0. bite. by rewrite Z5 //; simplify0. Qed.

Lemma Z5_01_2: (Z' kl a1 b .* Z' ij a2 c) ^^ (X mj d)  = (Z' ij a2 c .* Z' kl a1 b) ^^ (X mj d).
ZCR. do 2 (rewrite -?GA -(Z5 k l) //; simplify0; bite). by rewrite Z5. Qed.

Lemma Z5_01_3: (Z' kl a1 b .* Z' ij a2 c) ^^ (X im d)  = (Z' ij a2 c .* Z' kl a1 b) ^^ (X im d).
ZCR. do 2 (rewrite -?GA -(Z5 k l) //; simplify0; bite). by rewrite Z5. Qed.

Lemma Z5_01_4: (Z' kl a1 b .* Z' ij a2 c) ^^ (X jm d)  = (Z' ij a2 c .* Z' kl a1 b) ^^ (X jm d).
ZCR. do 2 (rewrite -?GA -(Z5 k l) //; simplify0; bite). by rewrite Z5. Qed.

Lemma Z5_02_1: (Z' kl a1 b .* Z' ij a2 c) ^^ (X ij d)  = (Z' ij a2 c .* Z' kl a1 b) ^^ (X ij d).
ZCR. rewrite (ZC1 _ _ m) //. ZCR. rewrite -?GA.
rewrite Z5 //; simplify0; repeat (rewrite -(Z5' k l) //; simplify0). Qed.

Lemma Z5_02_2: (Z' kl a1 b .* Z' ij a2 c) ^^ (X ji d)  = (Z' ij a2 c .* Z' kl a1 b) ^^ (X ji d).
ZCR. by rewrite Z5. Qed.

Lemma Z5_02_3: (Z' kl a1 b .* Z' ij a2 c) ^^ (X ik d)  = (Z' ij a2 c .* Z' kl a1 b) ^^ (X ik d).
ZCR. rewrite -?GA. rewrite Z3'_swap' // Z3'_swap' // Z5' //; simplify0. bite.
do 2 rewrite (@Z4'_swap' i j) //; simplify0; bite.
rewrite -?X0' (X5_swap' j l i k) // (X4_swap' j l i) // (X5_swap' i l j k) //
X4_swap // (X4'_swap' i k l) // (X4_swap' i k j) // -?X0' (X4'_swap' i l k) // -?X0' -?X0.
rexpand. rsimpl. bite. by rewrite -?plus_assoc (plus_comm (- _)). Qed.

Lemma Z5_02_4: (Z' kl a1 b .* Z' ij a2 c) ^^ (X il d)  = (Z' ij a2 c .* Z' kl a1 b) ^^ (X il d).
ZCR. rewrite -?GA. do 2 rewrite Z4'_swap' //. do 2 rewrite (Z4_swap' k l) //.
rewrite -(Z5' i j) //; bite.
rewrite (X4_swap' j l i) // (X5_swap' j l) // (X4_swap' j l) //; rsimpl; bite.
rewrite (X4'_swap' i l k) // -?X0' (X4_swap' i l j) // (X4'_swap' i l k) //.
do 2 rewrite (X5_swap' i l j k) //.
rewrite (X4'_swap' i l k) // -?X0' -?plus_assoc (plus_comm (a2 * c * d)).
by rewrite (X4_swap' j k i) // X5_swap // -X0'. Qed.

Lemma Z5_02_5: (Z' kl a1 b .* Z' ij a2 c) ^^ (X jk d)  = (Z' ij a2 c .* Z' kl a1 b) ^^ (X jk d).
ZCR. rewrite -?GA. do 2 rewrite Z3'_swap' //. do 2 rewrite Z3_swap' //.
rewrite (Z5' k l i j) //; bite.
rewrite (X4'_swap' j l k) // (X4_swap' i k j) // -?X0.
rexpand; rsimpl; rewrite -?plus_assoc (plus_comm (-(c * a2 * d))). bite.
by rewrite -2!X0 X5_swap. Qed.

Lemma Z5_02_6: (Z' kl a1 b .* Z' ij a2 c) ^^ (X jl d)  = (Z' ij a2 c .* Z' kl a1 b) ^^ (X jl d).
ZCR. rewrite -?GA. rewrite Z3_swap' // Z3_swap' // (Z4_swap') // (Z4_swap' k l i) // Z5' //; rsimpl; bite.
rewrite (X5_swap' i l j k) // ?(X4'_swap' i l k) // (X4_swap' i l j) //
        -X0' plus_comm X0' (X4'_swap j k l) // (X5_swap' i k j l) //; bite.
by rewrite (X4'_swap' j l k) // -X0' -X0; rexpand; rsimpl. Qed.

End Z5_Untangle.

Section ChicagoBuilding. Import ZC_tactic.

Context (i j k l m n : nat) (a1 a2 b d : R)
        {ij : i != j} {ji : j != i}
        {ik : i != k} {jk : j != k} {ki : k != i} {kj : k != j}
        {kl : k != l} {il : i != l} {jl : j != l} {lk : l != k} {li : l != i} {lj : l != j}.

Lemma L01: (X' il a2 .* X' jk a1 .* X' il (-a2) .* X' jk (-a1)) ^^ X ki b ^^ X li d = Id.
ZCR; simplify0. rewrite ?X'zero ?GId.
rewrite (Z3'_swap' i l j a2) // (Z5' j k i l) // X'def
        (Z3'_swap' i l k a2) // (Z4_swap' i l k) // Z'Inv; cancel.
rewrite (X4'_swap' k i l) // -?X0'.
rewrite (plus_comm (b*a2)) -plus_assoc inv_l plus_0_l.
rewrite (X4'_swap' k i l) // -?X0' ?dist_l plus_assoc; rsimpl.
rewrite inv_l plus_0_r (X4_swap' k i j) // (X5_swap' k l j i) //.
rewrite (X4'_swap' j k i) // (X4'_swap' j l i) // plus_comm -X0'
        plus_assoc inv_r plus_0_r (Z3_swap' j k l) // X'def; rsimpl.
rewrite (X4_swap' j l k) // -X0' inv_l X'zero GId
        (Z3_swap' j k i) // X'def; rsimpl.
rewrite -X0' inv_r X'zero GId
        (X5_swap' k l j i) // -X0' inv_l X'zero GId
        (X4_swap' j i k) // -X0' -X0 ?inv_l ?X'zero GId //. Qed.
Lemma L02: (X' ik a1 .* X' jl a2 .* X' ik (-a1) .* X' jl (-a2)) ^^ X ki b ^^ X li d = Id.
ZCR; simplify0.
rewrite (Z3'_swap' i k j a1) // (Z5' j l i k) // X'def
        (Z3'_swap' i k l a1) // (Z4_swap' i k l) // Z'Inv; cancel.
rewrite (X4'_swap' l i k) // -?X0' (plus_comm (d*a1)) -plus_assoc inv_l plus_0_l
        (X4'_swap' l k i) // -X0' ?dist_l plus_assoc; rsimpl.
rewrite inv_l plus_0_r
        (Z3_swap' j l i) // X'def; rsimpl.
rewrite (Z3_swap' j l k) // X'def; rsimpl.
rewrite (X4'_swap' j l i) // -X0' inv_r X'zero GId
        (X4'_swap' j k i) // (X5_swap' l k j i) // -X0'
        (X4_swap' l i j) // (X4'_swap' j k i) // -X0'
        plus_assoc -(plus_assoc _ _ (-(a2 * d)))inv_l plus_0_l inv_r X'zero GId.
rewrite (X5_swap' j k l i) // (X4_swap' j k l) // -X0' inv_l X'zero GId
        (X4'_swap' l k i) // -X0' -X0 ?inv_l ?X'zero GId //. Qed.

Lemma L03: (X' jk a1 .* X' jl a2 .* X' jk (-a1) .* X' jl (-a2)) ^^ X ki b ^^ X li d = Id.
ZCR; simplify0. rewrite ?X'zero ?GId.
rewrite (X4'_swap j i k) // -X0'
        (X4'_swap' j k i) // -X0'
        (X4'_swap' j i l) // -X0' -inv_plus inv_r X'zero GId
        (X4'_swap' j k l) // -?X0' inv_r X'zero GId -X0 inv_r X'zero //. Qed.

Lemma L04: (X' jk a1 ^^ X ij (-(1)) .* X' jk (-a1)) ^^ X ki b ^^ X li d = Z' ik a1 b ^^ X li d.
ZCR; simplify0. rewrite ?X'zero ?GId. bite.
rewrite (X4'_swap' j i k) // -X0' inv_r X'zero GId -X0' inv_r X'zero GId //. Qed.

Lemma L05: (X' jl a2 ^^ X ij (-(1)) .* X' jl (-a2)) ^^ X ki b ^^ X li d = X' il a2 ^^ X ki b ^^ X li d.
ZCR; simplify0. rewrite ?X'zero ?GId. bite.
rewrite (X4'_swap' j i l) //; do 2 rewrite -X0' inv_r X'zero GId //. Qed.

End ChicagoBuilding.

Section Z4_Untangle. Import ZC_tactic.

Context (i j k l m n : nat) (a1 a2 b d : R)
        {ij : i != j} {ji : j != i}
        {ik : i != k} {jk : j != k} {ki : k != i} {kj : k != j}
        {kl : k != l} {il : i != l} {jl : j != l} {lk : l != k} {li : l != i} {lj : l != j}.

(* Formula with 4 Z's *)
Lemma Z4_01: (X' ik a1 .* X' il a2 .* X' ik (-a1) .* X' il (-a2)) ^^ X ki b ^^ X li d = Id.
rewrite ?forward_rule ?XC2.
Check

(* Lemma Z4_01: (X' kj (- a1) .* Z' ij a2 b .* X' kj a1) ^^ (X im d) = (Z' ij a2 b ^^ X kj a1) ^^ (X im d).
ZCR. rewrite ?X'def ?X'zero -?GA; cancel.
rewrite Z4_swap' //.
rewrite (X5_swap' i m k j) // (Z3'_swap' i m k) // X'def (X5_swap' i m k j) //
        (Z3'_swap' j m k) // X'def (X5_swap' j m k i) //
        (Z3_swap' k j m) // -X0.
simplify0. rewrite inv_l. by simplify0. Qed. *)

End Z4_Untangle.

Section Z3_Untangle. Import ZC_tactic.
Context (i j k l m n : nat) (a a1 a2 b c d : R)
        {ij : i != j} {ji : j != i}
        {ik : i != k} {jk : j != k} {ki : k != i} {kj : k != j}
        {kl : k != l} {il : i != l} {jl : j != l} {lk : l != k} {li : l != i} {lj : l != j}

        {mi : m != i}  {mj : m != j} {mk : m != k} {ml : m != l}
        {im : i != m}  {jm : j != m} {km : k != m} {lm : l != m}.

(* a, c in I *)

(* Formula with 5 Z's *)

Lemma Z3_01: (X' ij a .* X' jl c .* X' ij (-a) .* X' jl (-c)) ^^ X ji b ^^ X lj d =
             (X' il (a*c)) ^^ X ji b ^^ X lj d.
ZCR; simplify0. Abort.

(* not obvious, but only 1 Z*)
Lemma Z3_02: (X' ik a1 .* X' kl a2 .* X' ik (-a1) .* X' kl (-a2)) ^^ X ji b ^^ X lj d =
             (X' il (a1*a2)) ^^ X ji b ^^ X lj d.
ZCR; simplify0. rewrite X'zero GId. Abort.

(* this is obvious *)
Lemma Z3_03: (X' il (a*c) ^^ X jk 1 .* X' il (-(a*c))) ^^ X ji b ^^ X lj d = Id.
ZCR; simplify0. Admitted.

(* this should involve only Z?_swap type equations *)
Lemma Z3_04: (X' ij a .* (X' ij (-a) ^^ X jk 1)) ^^ X ji b ^^ X lj d =
             (X' ik a) ^^ X ji b ^^ X lj d.
ZCR; simplify0. Admitted.

(* this is obvious *)
Lemma Z3_05: (X' kl c ^^ X jk (-(1)) .* X' kl (-c) ) ^^ X ji b ^^ X lj d =
             (X' jl c) ^^ X ji b ^^ X lj d.
ZCR; simplify0. Admitted.

(* this should involve only Z?_swap type equations *)
Lemma Z3_06: (X' ij (a) .* X' kl c .* X' ij (-a) .* X' kl (-c)) ^^ X ji b ^^ X lj d = Id.
ZCR; simplify0. Admitted.

End Z3_Untangle.


Require Export Coq.Unicode.Utf8.
Require Import Coq.Program.Equality.
Require Import Coq.Program.Tactics.
Require Import Specification.
Require Import Restrictions.
Require Import Substitutions.

Fixpoint Value (t: Tm) : Prop :=
  match t with
    | var       => False
    | abs _ _   => True
    | app _ _ _ => False
  end.

Reserved Notation "t₁ --> t₂" (at level 40).
Inductive red : Tm → Tm → Prop :=
  | red_abs {a t t'} :
      t --> t' →
      abs a t --> abs a t'
  | red_app₁ {p t1 t1' t2} :
      t1 --> t1' → app p t1 t2 --> app p t1' t2
  | red_app2 {p t1 t2 t2'} :
      t2 --> t2' → app p t1 t2 --> app p t1 t2'
  | red_beta {p a t1 t2} :
      app p (abs a t1) t2 --> subTm (subBeta t2 p) t1
where "t1 --> t2" := (red t1 t2).
Hint Constructors red : infra.

Lemma red_beta' {p a t₁ t₂ t'} :
  t' = subTm (subBeta t₂ p) t₁ →
  app p (abs a t₁) t₂ --> t'.
Proof.
  intros; subst; constructor.
Qed.

Section TypeSafety.

  Lemma can_form_tarr {Γ t a b}
    (v: Value t) (wt: ⟪ Γ ⊢ t : tarr a b ⟫) :
      ∃ t₂, t = abs a t₂.
  Proof. depind wt; try contradiction; eauto. Qed.

  Lemma progress {t a} (wt: ⟪ empty ⊢ t : a ⟫) :
    Value t ∨ ∃ t', t --> t'.
  Proof with crush.
    depind wt; simpl; auto.
    inversion H; subst.
    destruct IHwt1 as [v1|[t1' r1]]...
    destruct IHwt2 as [v2|[t2' r2]]...
    destruct (can_form_tarr v1 wt1)...
  Qed.

  Lemma preservation {Γ t a} (wt: ⟪ Γ ⊢ t : a ⟫) :
    ∀ {t'}, t --> t' → ⟪ Γ ⊢ t' : a ⟫.
  Proof.
    induction wt.
    - inversion 1.
    - intros t' r; inversion r; subst.
      econstructor; eauto.
    - intros t' r; inversion r; subst.
      + econstructor; eauto.
      + econstructor; eauto.
      + inversion wt1; subst; crush.
  Qed.

End TypeSafety.

Section StrongNormalization.

  Hint Resolve preservation : infra.

  Lemma red_subst {t t'} (r: t --> t') :
    ∀ a ζ Γ Δ,
      ⟪ Γ ⊢ t : a ⟫ → ⟪ ζ : Γ => Δ ⟫ →
      subTm ζ t --> subTm ζ t'.
  Proof.
    induction r; inversion 1; crush.
    - inversion H6; clear H H6; subst.
      eapply red_beta'.
      erewrite subTmComp; eauto with infra.
      erewrite subTmComp; eauto with infra.
      erewrite subBetaComm; crush.
  Qed.

  Definition Cand := Tm → Prop.
  Definition Neutral : Cand :=
    fun t =>
      match t with
        | abs _ _ => False
        | _       => True
      end.

  Inductive SN (t: Tm) : Prop :=
    | SNi : (∀ t', t --> t' → SN t') → SN t.

  Lemma SNd {t} (sn_t: SN t) : ∀ t', t --> t' → SN t'.
  Proof. destruct sn_t; auto. Qed.

  Lemma SNappl pΓ {t1} t2 :
    SN (app pΓ t1 t2) → SN t1.
  Proof.
    intro sn; depind sn; constructor; crush.
  Qed.

  Lemma SNvar {pΓa Γa Γ a t b} (peΓa: ⟪ pΓa ⊢ Γa = Γ ∘ (ε ▻ a) ⟫)
    (wt: ⟪ Γ ▻ a ⊢ t : b ⟫) (sn: SN (subTm (subBeta var pΓa) t)) : SN t.
  Proof.
    depind sn; constructor.
    - intros.
      eapply H0; eauto.
      eapply red_subst; eauto.
      eapply wtSubBeta; eauto.
      constructor.
      eapply preservation; eauto.
  Qed.

  (* Definition of reducibility candidates. *)
  Record CR (Γ: Env) (a: Ty) (P: Cand) : Prop :=
    { cr_sn : ∀ t, P t → SN t;
      cr_cl : ∀ t, P t → ∀ t', t --> t' → P t';
      cr_nt : ∀ t, (∀ t', t --> t' → P t') →
                   (* Linearity instead of typing should be enough. *)
                   ⟪ Γ ⊢ t : a ⟫ → Neutral t → P t
    }.
  Arguments cr_sn [_ _ _] _ [_] _.
  Arguments cr_cl [_ _ _] _ [_] _ [_] _.
  Arguments cr_nt [_ _ _] _ [_] _ _ _.

  Lemma CR_var {a P} (crP : CR [a] a P) : P var.
  Proof.
    intros; apply (cr_nt crP); simpl; auto; intros.
    - inversion H.
    - constructor.
  Qed.

  Lemma CR_SN : ∀ Γ a, CR Γ a SN.
  Proof. constructor; eauto using SNi, SNd. Qed.

  Definition ARR (a b: Ty) (P R: Env → Cand) : Env → Cand :=
    fun (Γ: Env) (t1: Tm) =>
      ∀ pΓΔ ΓΔ Δ t2,
        ⟪ pΓΔ ⊢ ΓΔ = Γ ∘ Δ ⟫ →
        ⟪ Δ ⊢ t2 : a ⟫ →
        P Δ t2 → R ΓΔ (app pΓΔ t1 t2).

  Lemma CR_ARR {a b P R} (CR_P: ∀ Δ, CR Δ a (P Δ)) (CR_R: ∀ ΓΔ, CR ΓΔ b (R ΓΔ)) Γ :
    CR Γ (tarr a b) (ARR a b P R Γ).
  Proof with simpl; eauto using red.
    constructor.
    - intros t ARR_t.
      (* This is soo ugly. *)
      eapply (SNappl (pright (plefts (dom Γ))) var).
      eapply (cr_sn (CR_R (Γ ▻ a))).
      eapply ARR_t; crush.
      eapply CR_var; eauto.
    - intros t ARR_t t' r.
      intros pΓΔ ΓΔ Δ t2 peΓΔ wt2 P_t2.
      eapply (cr_cl (CR_R ΓΔ))...
    - intros t1 Hyp wt1 neutral_t1.
      intros pΓΔ ΓΔ Δ t2 peΓΔ wt2 P_t2.
      assert (wt12: ⟪ ΓΔ ⊢ app pΓΔ t1 t2 : b ⟫)
        by (econstructor; eauto).
      apply (cr_nt (CR_R ΓΔ))...
      generalize (cr_sn (CR_P Δ) P_t2).
      induction 1 as [t2]; intros t12' r.
      inversion r; subst.
      * eapply Hyp...
      * apply (cr_nt (CR_R ΓΔ)); crush.
        eapply H0; crush.
        eapply (cr_cl (CR_P Δ))...
      * destruct neutral_t1.
  Qed.

  Lemma ARR_beta_exp {a b P R}
    (CR_P: ∀ Δ, CR Δ a (P Δ)) (CR_R: ∀ ΓΔ, CR ΓΔ b (R ΓΔ)) Γ :
    ∀ t1,
      ⟪ (Γ ▻ a) ⊢ t1 : b ⟫ →
      (∀ {pΓΔ ΓΔ Δ t2},
         ⟪ pΓΔ ⊢ ΓΔ = Γ ∘ Δ ⟫ →
         ⟪ Δ ⊢ t2 : a ⟫ →
         P Δ t2 → R ΓΔ (subTm (subBeta t2 pΓΔ) t1)) →
      ARR a b P R Γ (abs a t1).
  Proof.
    intros t1 wt1 H.
    assert (sn_t1: SN t1).
      apply (@SNvar (pright (plefts (dom Γ))) (Γ ▻ a) Γ a t1 b); crush.
      eapply (cr_sn (CR_R (Γ ▻ a))).
      apply (H (pright (plefts (dom Γ))) (Γ ▻ a) (ε ▻ a) var); crush.
      eapply CR_var; eauto.
    revert H.
    induction sn_t1; intro Hyp.
    intros pΓΔ ΓΔ Δ t2 peΓΔ wt2 P_t2.
    assert (SN_t2: SN t2)
      by (apply (cr_sn (CR_P Δ)); eauto).
    revert pΓΔ ΓΔ peΓΔ.
    induction SN_t2; intros.
    apply (cr_nt (CR_R ΓΔ)); simpl; auto.
    + intros ? r.
      depind r.
      * dependent destruction r; eauto.
        unfold ARR in *.
        eapply H0; eauto using preservation.
        intros.
        eapply (cr_cl (CR_R _)); eauto.
        eapply red_subst; crush.
      * eauto using (cr_cl (CR_P _)) with infra.
      * eapply Hyp; crush.
    + repeat econstructor; eauto.
  Qed.

  (* Type interpretation *)
  Fixpoint Int (a: Ty) (Γ: Env) : Cand :=
    fun t =>
      ⟪ Γ ⊢ t : a ⟫ ∧
      match a with
        | tbase    => SN t
        | tarr a b => ARR a b (Int a) (Int b) Γ t
      end.

  Lemma CR_Int (a: Ty) : ∀ Γ, CR Γ a (Int a Γ).
  Proof with simpl; eauto.
    induction a; simpl; intros;
      [ pose proof (CR_SN Γ tbase) as cr
      | pose proof (CR_ARR IHa1 IHa2 Γ) as cr
      ]; constructor; intros; destruct_conjs; split;
         eauto using (cr_sn cr), (cr_cl cr), preservation.
    - eapply (cr_nt cr); eauto.
      eapply H.
    - eapply (cr_nt cr); eauto.
      eapply H.
  Qed.

  Inductive IntSub : Sub → Env → Env → Prop :=
    | IntEmpty :
        IntSub snil ε ε
    | IntSnoc {ζ Γ pΔ Δ Δ₁ Δ₂ t a} :
        ⟪ pΔ ⊢ Δ = Δ₁ ∘ Δ₂ ⟫ →
        ⟪ Δ₂ ⊢ t : a ⟫ →
        IntSub ζ Γ Δ₁ → Int a Δ₂ t →
        IntSub (snoc pΔ ζ t) (Γ ▻ a) Δ.

  Lemma IntSub_wt {ζ Γ Δ} (iζ: IntSub ζ Γ Δ) :
    ⟪ ζ : Γ => Δ ⟫.
  Proof. induction iζ; crush. Qed.
  Hint Resolve IntSub_wt : infra.

  Lemma Int_splitSubLeft {ζ Γ Δ} (iζ: IntSub ζ Γ Δ) :
    ∀ pΓ Γ₁ Γ₂, ⟪ pΓ ⊢ Γ = Γ₁ ∘ Γ₂ ⟫ →
      IntSub (splitSubLeft pΓ ζ) Γ₁ (splitSubEnvLeft pΓ Δ ζ).
  Proof. induction iζ; crush; econstructor; crush. Qed.
  Hint Resolve Int_splitSubLeft : infra.

  Lemma Int_splitSubRight {ζ Γ Δ} (iζ : IntSub ζ Γ Δ) :
    ∀ pΓ Γ₁ Γ₂, ⟪ pΓ ⊢ Γ = Γ₁ ∘ Γ₂ ⟫ →
      IntSub (splitSubRight pΓ ζ) Γ₂ (splitSubEnvRight pΓ Δ ζ).
  Proof. induction iζ; crush; econstructor; crush. Qed.
  Hint Resolve Int_splitSubRight : infra.

  Lemma IntSub_subId Γ :
    IntSub (subId (dom Γ)) Γ Γ.
  Proof.
    induction Γ; simpl; econstructor; crush.
    - eapply CR_var, CR_Int.
  Qed.

  Lemma fundamental {Γ t a} (wt: ⟪ Γ ⊢ t : a ⟫) :
    ∀ ζ Δ, IntSub ζ Γ Δ → Int a Δ (subTm ζ t).
  Proof.
    induction wt; intros ζ Δ iζ; simpl; auto.
    - inversion iζ; clear iζ; crush.
      inversion H4; clear H4; crush.
    - assert (⟪ ζ : Γ => Δ ⟫) by crush.
      split. econstructor; crush.
      apply ARR_beta_exp; crush; eauto using CR_Int.
      erewrite subTmComp; crush.
      erewrite splitSubPart_subId; crush.
      erewrite splitSubLeft_subId; crush.
      erewrite restrictLeftRightPart_part_plefts; crush.
      erewrite subCompIdRight; crush.
      apply IHwt; simpl; eauto.
      econstructor; eauto.
    - simpl in *; unfold ARR in *.
      eapply IHwt1; crush.
  Qed.

  Lemma fundamental_id {Γ t a} (wt: ⟪ Γ ⊢ t : a ⟫) : Int a Γ t.
  Proof.
    erewrite <- subTmId; eauto.
    apply (fundamental wt), IntSub_subId.
  Qed.

  Theorem strong_normalization {Γ t a} (wt: ⟪ Γ ⊢ t : a ⟫) : SN t.
  Proof.
    eauto using (cr_sn (CR_Int a Γ)), fundamental_id.
  Qed.

End StrongNormalization.