Require Import LibTactics.
Require Import Metalib.Metatheory.

Require Import
        syntax_ott
        rules_inf
        Infrastructure
        Deterministic
        Typing.

Require Import List. Import ListNotations.
Require Import Arith Omega.
Require Import Strings.String.

Lemma value_decidable: forall v,
   lc_exp v -> value v \/ not (value v).
Proof.
  introv lc. inductions v; eauto;
  try solve [right; unfold not; intros nt; inverts nt].
  - inverts lc. forwards*: IHv. inverts H.
    + inverts H1;try solve [right; unfold not; intros nt; inverts nt].
    + inductions v; eauto;
      try solve [right; unfold not; intros nt; inverts nt].
  - inverts lc. forwards*: IHv. inverts H.
    + inverts H1;try solve [right; unfold not; intros nt; inverts nt].
      right. unfold not;intros. inverts H. inverts H2.
      right. unfold not;intros. inverts H1. inverts H3.
      right. unfold not;intros. inverts H1. inverts H3.
    + inductions v; eauto;
      try solve [right; unfold not; intros nt; inverts nt; inverts H2].
Qed.

Lemma sim_decidable:forall A B,
sim A B \/ ~ (sim A B).
Proof.
  introv.
  gen A.
  inductions B; intros; eauto.
  - inductions A; eauto. right. unfold not;  intros. inverts* H.
  - inductions A; eauto. right. unfold not; intros.
    inverts* H.
    forwards*: IHB1 A1. forwards*: IHB2 A2.
    destruct H.  destruct H0. left.  eauto. right.
    unfold not; intros. inverts* H1. destruct H0.
    right. unfold not; intros. inverts* H1.
    right. unfold not; intros. inverts* H1.
Qed.

Lemma eq_type: forall A,
 (A = t_dyn) \/ ~(A = t_dyn).
Proof.
  introv.
  inductions A;
  try solve[left;
  reflexivity];
  try solve[right;
  unfold not; intros H;
  inverts* H].
Qed.

Lemma TypedReduce_trans : forall v v1 v2 A B,
    value v -> TypedReduce v A (Expr v1) -> TypedReduce v1 B (Expr v2) -> TypedReduce v B (Expr v2).
Proof.
  introv Val Red1 Red2.
  lets Lc: value_lc Val.
  gen B v2.
  inductions Red1;
    introv Red2; eauto.
  - inverts* Red2.
  - inverts* Red2.
  - inverts* Red2.
  - inverts* Red2.
Qed.

Lemma TypedReduce_prv_value: forall v A v',
    value v -> TypedReduce v A (Expr v') -> value v'.
Proof.
  intros v A v' Val Red.
  inductions Red; eauto.
  - inverts* Val.
  - inverts Val.
    inverts H1.
    eapply value_abs; auto.
  - inverts* Val.
Qed.

Lemma principle_inf2: forall v A,
  value v -> Typing nil v Inf A -> (principal_type v) = A .
Proof.
  introv Val Typ.
  gen A.
  induction Val; introv  Typ; try solve [inverts* Typ].
Qed.

Lemma TypedReduce_preservation: forall v A v' B,
    value v -> TypedReduce v A (Expr v') -> Typing nil v Chk B -> Typing nil v' Inf A.
Proof with auto.
  introv Val Red Typ'.
  gen B.
  lets Red': Red.
  inductions Red; introv Typ;
  lets Lc : Typing_regular_1 Typ;
  try solve [constructor*].
  + inverts* Typ. inverts H1. inverts H5.
    eapply Typ_anno; eauto.
    inverts Val.
    inverts H1. inverts H0.
    eapply Typ_sim; eauto.
    eapply Typ_sim; eauto.
    forwards*: principle_inf H1.
    rewrite H4 in H0.
    eapply Typ_sim; eauto.
  + inverts* Typ.
    inverts* H2. inverts H6.
    eapply Typ_save; eauto.
    forwards*: principle_inf H2.
    rewrite H5 in H1. auto.
  + inverts* Val.
    inverts Typ. inverts H0.
    eapply Typ_anno; eauto.
    eapply Typ_sim; eauto.
    forwards*: principle_inf H9.
    rewrite H0 in H. auto.
  + inverts* Typ.
    inverts* H0.
    eapply Typ_save; eauto.
    forwards*: principle_inf H7.
    rewrite H0 in H. auto.
Qed.

Lemma BA_AB: forall B A,
  sim A B -> sim B A.
Proof.
  introv H.
  induction* H.
Qed.

Lemma TypeLists_preservation3: forall v A1 A2 v' B,
value v -> TypeLists v (cons A2 (cons t_dyn (cons A1 nil))) (Expr v')
     -> Typing nil v Chk B -> Typing nil v' Inf A1.
Proof with auto.
  introv Val Red Typ'.
  gen B.
  lets Red': Red.
  inductions Red; introv Typ;
  lets Lc : Typing_regular_1 Typ;
  try solve [constructor*].
  - inverts Red.
    inverts H7.
    forwards*: TypedReduce_preservation H0.
    forwards*: TypedReduce_prv_value H0.
    forwards*: TypedReduce_preservation H5.
    forwards*: TypedReduce_prv_value H5.
    forwards*: TypedReduce_preservation H8.
    inverts H10.
Qed.

Lemma TypeLists_preservation2: forall v A1 A2 v' B,
value v -> TypeLists v (cons A2 (cons A1 nil)) (Expr v')
     -> Typing nil v Chk B -> Typing nil v' Inf A1.
Proof with auto.
  introv Val Red Typ'.
  gen B.
  lets Red': Red.
  inductions Red; introv Typ;
  lets Lc : Typing_regular_1 Typ;
  try solve [constructor*].
  - inverts Red.
    forwards*: TypedReduce_preservation H0.
    forwards*: TypedReduce_prv_value H0.
    forwards*: TypedReduce_preservation H5.
    inverts H7.
Qed.

Theorem preservation : forall e e' dir A,
    Typing nil e dir A ->
    step e (Expr e') ->
    Typing nil e' dir A.
Proof.
  introv Typ. gen e'.
  lets Typ' : Typ.
  inductions Typ;
    try solve [introv J; inverts* J]; introv J.
  - inverts J.
    apply Typ_anno; eauto.
    destruct E; unfold simpl_fill in H0; inverts H0.
  - inverts H0.
  - inverts* J.
    + eapply Typ_anno; eauto.
      eapply Typ_sim; eauto.
      apply sim_refl.
    + destruct E; unfold simpl_fill in H1; inverts H1.
  - Case "typing_app".
    inverts* J.
    + destruct E; unfold simpl_fill in *; inverts H.
      forwards*: IHTyp1 Typ1.
      forwards*: IHTyp2 Typ2.
    + inverts Typ1.
      inverts* H6.
      inverts* H.
      pick fresh x.
      rewrite (subst_exp_intro x); eauto.
      forwards*: H9.
      inverts H.
      eapply Typ_anno.
      eapply Typ_sim.
      eapply Typ_anno.
      eapply Typ_sim.
      eapply typing_c_subst_simpl; eauto.
      forwards*: TypeLists_preservation2 H4.
      auto.
      inverts* H0.
    + inverts Typ1.
      inverts* H10.
      pick fresh x.
      rewrite (subst_exp_intro x); eauto.
      forwards*: H7.
      inverts H.
      eapply Typ_anno.
      eapply Typ_sim.
      eapply Typ_anno.
      eapply Typ_sim.
      eapply Typ_anno.
      eapply Typ_sim.
      eapply typing_c_subst_simpl; eauto.
      forwards*: TypeLists_preservation3 H4.
      auto. eauto. eauto.
  - Case "typing_anno".
    inverts* J.
    + destruct E; unfold simpl_fill in *; inverts H.
    + eapply TypedReduce_preservation; eauto.
  - inverts* J.
    destruct E; unfold simpl_fill in *; inverts H.
    forwards*: IHTyp1 Typ1.
    forwards*: IHTyp2 Typ2.
  - inverts* J.
    destruct E; unfold simpl_fill in H2; inverts H2.
Qed.

Theorem preservation_multi_step : forall e e' dir  T,
    Typing nil e dir T ->
    e ->* (Expr e') ->
    Typing nil e' dir T.
Proof.
  introv Typ Red.
  inductions Red; eauto.
  lets*: preservation Typ H.
Qed.

Lemma sfill_appl : forall e1 e2,
  (e_app e1 e2) = (simpl_fill (sappCtxL e2) e1).
Proof.
  intros. eauto.
Qed.

Lemma sfill_appr : forall e1 e2,
  (e_app e1 e2) = (simpl_fill (sappCtxR e1) e2).
Proof.
  intros. eauto.
Qed.

Lemma sfill_addl : forall e1 e2,
  (e_add e1 e2) = (simpl_fill (saddCtxL e2) e1).
Proof.
  intros. eauto.
Qed.

Lemma sfill_addr : forall e1 e2,
  (e_add e1 e2) = (simpl_fill (saddCtxR e1) e2).
Proof.
  intros. eauto.
Qed.

Lemma TypedReduce_progress: forall v A,
    value v -> Typing [] v Chk A -> exists r, TypedReduce v A r.
Proof.
  intros v A Val Typ. gen A.
  inductions Val; intros.
  - inverts Typ. inverts H. inverts H3. inverts H.
    destruct (sim_decidable t_int  A0).
    exists.
    apply TReduce_sim; eauto.
    exists.
    apply TReduce_i; eauto.
  - inverts Typ. inverts H0. inverts H4. inverts H0.
    destruct (sim_decidable (t_arrow A B)  A0).
    exists.
    apply TReduce_sim; eauto.
    destruct A0.
    exists.
    apply TReduce_p; eauto.
    exists.
    apply TReduce_simp; eauto.
    exfalso. apply H0. eauto.
  - inverts Typ. inverts H0.
    inverts H1.
    forwards*: principle_inf H8.
    destruct (sim_decidable C  (t_arrow C0 D)).
    exists.
    apply TReduce_savep; eauto.
    rewrite H0. auto.
    exists.
    apply TReduce_save; eauto.
    rewrite H0. auto.
    forwards*: principle_inf H8.
Qed.

(* Lemma TypeLists_progress: forall v B (A: typ),
    value v -> Typing [] v Chk A ->
    exists r, TypeLists v (cons B (cons A nil)) r.
Proof.
  introv Val Typ.
  inductions Val; intros.
  - inverts Typ. inverts H. inverts H3. inverts H.
    destruct (sim_decidable t_int  B).
    destruct (sim_decidable t_int A).
    exists.
    eapply TLists_cons; eauto.
    apply TLists_base; eauto.
    exists Blame.
    eapply TLists_cons; eauto.
    apply TLists_baseb; eauto.
    exists.
    eapply TLists_consb; eauto.
  - inverts Typ. inverts H0. inverts H4. inverts H0.
    destruct (sim_decidable (t_arrow A B)  B).
    exists.
    apply TReduce_sim; eauto.
    destruct A0.
    exists.
    apply TReduce_p; eauto.
    exists.
    apply TReduce_simp; eauto.
    exfalso. apply H0. eauto.
  - inverts Typ. inverts H0.
    inverts H1.
    forwards*: principle_inf H8.
    destruct (sim_decidable C  (t_arrow C0 D)).
    exists.
    apply TReduce_savep; eauto.
    rewrite H0. auto.
    exists.
    apply TReduce_save; eauto.
    rewrite H0. auto.
    forwards*: principle_inf H8.
Qed. *)

Lemma vval_dec: forall v,
  value v ->
  (vvalue v) \/ ~(vvalue v).
Proof.
  introv val.
  inductions val; eauto.
  right. unfold not; intros.
  inverts* H0.
Qed.

Theorem progress : forall e dir T,
    Typing nil e dir T ->
    value e \/ (exists r, step e r).
Proof.
  introv Typ. lets Typ': Typ.
  inductions Typ;
      lets Lc  : Typing_regular_1 Typ';
      try solve [left*];
      try solve [right*].
  - Case "var".
    inverts* H0.
  - right. inverts Lc.
    lets* [Val1 | [e1' Red1]]: IHTyp1.
    lets* [Val2 | [e2' Red2]]: IHTyp2.
    inverts* Typ1;
    try solve [ inverts Val1 ].
    + inverts* Val1; inverts* H.
      inverts* H0; inverts* H3. inverts* H0; inverts* H4.
      forwards*: TypedReduce_progress Typ2. inverts H.
      destruct x.
      forwards*: TypedReduce_preservation H0.
      forwards*: TypedReduce_prv_value H0.
      assert([] ⊢ e ⇐ A0). eapply Typ_sim; eauto. apply BA_AB; auto.
      forwards*: TypedReduce_progress H4. inverts H7.
      destruct x.
      exists. apply Step_beta; eauto.
      eapply TLists_cons; eauto. eapply TLists_base; eauto.
      forwards*: value_lc H4.
      exists. apply Step_betap; eauto.
      eapply TLists_cons; eauto. eapply TLists_consb; eauto.
      forwards*: value_lc H4.
      exists. apply Step_betap; eauto.
    + inverts H4.
      inverts* H7.
      forwards*: TypedReduce_progress Typ2. inverts H0.
      destruct x.
      forwards*: TypedReduce_preservation H4.
      forwards*: TypedReduce_prv_value H4.
      assert([] ⊢ e ⇐ t_dyn). eapply Typ_sim; eauto.
      forwards*: TypedReduce_progress H6. inverts H7.
      destruct x.
      forwards*: TypedReduce_preservation H9.
      forwards*: TypedReduce_prv_value H9.
      assert([] ⊢ e1 ⇐ A0).  eapply Typ_sim; eauto.
      forwards*: TypedReduce_progress H12. inverts H13.
      forwards*: value_lc H11. forwards*: value_lc H5.
      destruct x.
      exists. apply Step_appv; eauto.
      exists. apply Step_appvp; eauto.
      forwards*: value_lc H5.
      exists. apply Step_appvp; eauto.
    +
      rewrite sfill_appr.  destruct e2'. exists.
      apply do_step; eauto. exists. apply blame_step; eauto.
    + rewrite sfill_appl. destruct e1'. exists.
      apply do_step; eauto. exists. apply blame_step; eauto.
  -  Case "anno".
    inverts* Lc.
    destruct~ IHTyp as [ Val | [t' Red]].
    + SCase "e_anno v A".
      forwards*: TypedReduce_progress Val.
      inverts H.
      right.
      exists. apply Step_annov; eauto.
    + assert (lc_exp (e_anno e A)); eauto.
      forwards*: value_decidable H. inverts H1.
      left. auto.
      right. inductions t'.
      exists. apply Step_anno; eauto.
      exists. apply Step_annob; eauto.
  - right. inverts Lc.
    lets* [Val1 | [e1' Red1]]: IHTyp1.
    lets* [Val2 | [e2' Red2]]: IHTyp2.
    inverts* Typ1;
    try solve [ inverts Val1 ].
    + inverts Typ2.
      inverts Val1; inverts H; inverts* H0.
      inverts Val2; inverts H3; inverts* H4.
      inverts Val2; inverts H3; inverts* H4.
    + rewrite sfill_addr.  destruct e2'. exists.
      apply do_step; eauto. exists. apply blame_step; eauto.
    + rewrite sfill_addl. destruct e1'. exists.
      apply do_step; eauto. exists. apply blame_step; eauto.
  - forwards*: IHTyp Typ.
Qed.


Require Import Kami Puar.Processor Puar.Useful.

Set Implicit Arguments.
Set Asymmetric Patterns.

Open Scope string.
Notation fst := "fst".
Notation snd := "snd".
Close Scope string.

Definition Pair (A B: Kind) := STRUCT { fst :: A ; snd :: B }.

Section RV32.
  Definition XlenBytes := 4.
  Definition VAddrSz := 32.
  Variable PAddrSz: nat.

  Definition RIndexSz := 5.

  Definition VAddr := Bit VAddrSz.
  Definition PAddr := Bit PAddrSz.
  Definition Inst := Bit 32.

  Definition Mode := Bit 2.

  Definition BtbSz := 10.
  Definition BpSz := 20.

  Definition BtbTagSz := VAddrSz - (BtbSz + 2).
  Definition BtbDataSz := VAddrSz - 2.
  Definition BtbData := Bit BtbDataSz.

  Definition BtbState := Vector (optT (Struct (Pair (Bit BtbTagSz) BtbData))) BtbSz.
  Definition BpState := Vector (Bit 2) BpSz.

  Variable PcInit: ConstT VAddr.
  Definition RegFileInit := getDefaultConst (Vector (Data XlenBytes) RIndexSz).
  Definition BtbInit := getDefaultConst BtbState.
  Definition BpInit := getDefaultConst BpState.

  Definition Data := ltac:(let y := eval simpl in (Bit (8 * XlenBytes)) in exact y).

  Open Scope string.
  Notation bInstAddr := "bInstAddr".
  Notation bAddr := "bAddr".
  Notation extF := "extF".
  Notation extM := "extM".
  Notation ext64 := "ext64".
  Notation extC := "extC".
  Notation other := "other".
  Close Scope string.

  Variable FpuException : Kind.

  Definition ExecException :=
    STRUCT {
        bInstAddr :: Bool ;
        bAddr :: Bool ;
        extF :: Bool ;
        ext64 :: Bool ;
        extC :: Bool ;
        other :: Bool }.

  Notation Exec := (Exec XlenBytes VAddr (Struct ExecException)).

  Notation "a $[ i :>: j ]@ w":=
    (UniBit
       (ConstExtract
          j
          (* (ltac:(let y := eval cbv in (i + 1 - j)%nat in exact y)) *)
          (i + 1 - j)%nat
          (* (ltac:(let y := eval cbv in (31 - i)%nat in exact y)) *)
          (w - 1 - i)%nat
       ) a) (at level 12).

  Notation "{ a , b }" := (BinBit (Concat _ _) a b).

  Open Scope kami_expr.
  Definition opcode ty (inst: ty Inst) :=
    #inst$[6 :>: 0]@32.

  Definition op1_0 ty (inst: ty Inst) :=
    #inst$[1 :>: 0]@32.

  Definition op4_2 ty (inst: ty Inst) :=
    #inst$[4 :>: 2]@32.

  Definition op6_5 ty (inst: ty Inst) :=
    #inst$[6 :>: 5]@32.

  Definition funct3 ty (inst: ty Inst) :=
    #inst$[14 :>: 12]@32.

  Definition funct7 ty (inst: ty Inst) :=
    #inst$[31 :>: 25]@32.

  Definition rd ty (inst: ty Inst) :=
    #inst$[11 :>: 7]@32.

  Definition rs1 ty (inst: ty Inst) :=
    #inst$[19 :>: 15]@32.

  Definition rs2 ty (inst: ty Inst) :=
    #inst$[24 :>: 20]@32.

  Definition iImm ty (inst: ty Inst) :=
    UniBit (SignExtendTrunc _ 32) {#inst$[31 :>: 31]@32,
                                   {#inst$[30 :>: 25]@32,
                                    {#inst$[24 :>: 21]@32,
                                     #inst$[20 :>: 20]@32}}}.

  Definition sImm ty (inst: ty Inst) :=
    UniBit (SignExtendTrunc _ 32) {#inst$[31 :>: 31]@32,
                                   {#inst$[30 :>: 25]@32,
                                    {#inst$[11 :>: 8]@32,
                                     #inst$[7 :>: 7]@32}}}.

  Definition bImm ty (inst: ty Inst) :=
    UniBit (SignExtendTrunc _ 32) {{#inst$[31 :>: 31]@32,
                                    #inst$[7 :>: 7]@32},
                                   {#inst$[30 :>: 25]@32,
                                    {#inst$[11 :>: 8]@32,
                                     #inst$[7 :>: 7]@32}}}.

  Definition uImm ty (inst: ty Inst): (Bit 32) @ ty :=
    {#inst$[31 :>: 31]@32,
     {#inst$[30 :>: 20]@32,
      {#inst$[19 :>: 12]@32,
       ($ 0: (Bit 12) @ ty) }}}.

  Definition jImm ty (inst: ty Inst) :=
    UniBit (SignExtendTrunc _ 32) {{#inst$[31 :>: 31]@32,
                                    {#inst$[19 :>: 12]@32,
                                     #inst$[20 :>: 20]@32}},
                                   {#inst$[30 :>: 25]@32,
                                    {#inst$[24 :>: 21]@32,
                                     ($ 0: (Bit 1) @ ty)}}}.

  Definition alu ty (d1 d2: Data @ ty) (f3: (Bit 3) @ ty) (f7: Bool @ ty) :=
    (IF (f3 == $ 0)
     then (IF f7
           then d1 + d2
           else d1 - d2)
     else (IF (f3 == $ 1)
           then (d1 << (d2$[4 :>: 0]@32))
           else (IF (f3 == $ 2)
                 then (IF (d1 < d2) then $ 1 else $ 0)
                 else (IF (f3 == $ 3)
                       then (IF (BinBitBool (Slt _) d1 d2) then $ 1 else $ 0)
                       else (IF (f3 == $ 4)
                             then d1 ~+ d2
                             else (IF (f3 == $ 5)
                                   then (IF f7
                                         then d1 >> (d2$[4 :>: 0]@32)
                                         else d1 ~>> (d2$[4 :>: 0]@32))
                                   else (IF (f3 == $ 6)
                                         then d1 ~| d2
                                         else (IF (f3 == $ 7)
                                               then d1 ~& d2
                                               else $ 0)))))))).

  Local Definition getExecException ty (pc: ty VAddr) (inst: ty Inst) (nextPcVal: VAddr @ ty) :=
    STRUCT {
        bInstAddr ::= #pc$[1 :>: 0]@32 != $ 0 ;
        bAddr ::= nextPcVal$[1 :>: 0]@32 != $ 0 ;
        extF ::= ((op4_2 _ inst == $ 1 && (op6_5 _ inst)$[1 :>: 1]@2 == $ 0) ||
                  (op4_2 _ inst == $ 4 && op6_5 _ inst == $ 2) ||
                  ((op4_2 _ inst)$[2 :>: 2]@3 == $ 0 && op6_5 _ inst == $ 2)) ;
        ext64 ::= op4_2 _ inst == $ 6 && op6_5 _ inst$[1 :>: 1]@2 == $ 0 ;
        extC ::= op1_0 _ inst != $ 3 ;
        other ::= ((op4_2 _ inst == $ 2 && op6_5 _ inst != $ 2)
                     ||
                     (((op4_2 _ inst)$[2 :>: 2]@3 == $ 1)
                        && ((((op4_2 _ inst)$[1 :>: 1]@3 == $ 1)
                               || ((op4_2 _ inst)$[0 :>: 0]@3 == $ 1))
                              && (op6_5 _ inst)$[1 :>: 1]@2 == $ 1)) ||
                     op4_2 _ inst == $ 7) }.

  (*
    OP-IMM: 00, 100
    OP:     01, 100, funct7[5]
    AUIPC:  00, 101
    LUI:    01, 101
    JALR:   11, 001
    JAL:    11, 011
    Branch: 11, 000
    LoadS:  00, 000, funct3[2] 0
    LoadU:  00, 000, funct3[2] 1
    Store:  01, 000
    AMO:    01, 011
   *)
  Definition execNotLongLatFn ty (pc: ty VAddr) (inst: ty Inst) (src1 src2: ty Data)
    : ((Struct Exec) @ ty) :=
    let nextPcVal :=
        (#pc +
         (IF (op4_2 _ inst)$[1 :>: 0]@3 == $ 0
          then (IF ((funct3 _ inst == $ 0 && #src1 == #src2) ||
                    (funct3 _ inst == $ 1 && #src1 != #src2) ||
                    (funct3 _ inst == $ 4 && BinBitBool (Slt _) #src1 #src2) ||
                    (funct3 _ inst == $ 5 &&
                                        !(BinBitBool (Slt _) #src2 #src1)) ||
                    (funct3 _ inst == $ 6 && (#src1 < #src2)) ||
                    (funct3 _ inst == $ 7 && (#src1 >= #src2)))
                then bImm _ inst
                else$ 4)
          else (IF (op4_2 _ inst)$[1 :>: 1]@3 == $ 0
                then #src1 + iImm _ inst
                else jImm _ inst)
        )) in
        STRUCT {
          (*
            ALU operations:
            OP-IMM: src1 op iImm, 00, 100
            OP: src1 op src2,     01, 100
            AUIPC: pc + uImm,     00, 101
            LUI: uImm,            01, 101
            JAL, JALR: pc + 4,    11, 0x1
           *)
        data ::=
             alu
             (IF (op4_2 _ inst)$[0 :>: 0]@3 == $ 1
              then (IF (op6_5 _ inst)$[0 :>: 0]@2 == (op6_5 _ inst)$[1 :>: 1]@2
                    then #pc
                    else $ 0)
              else #src1)
             (IF (op4_2 _ inst)$[0 :>: 0]@3 == $ 0
              then (IF (op6_5 _ inst)$[0 :>: 0]@2 == $ 0
                    then iImm _ inst
                    else #src2)
              else (IF (op6_5 _ inst)$[1 :>: 1]@2 == $ 0
                    then uImm _ inst
                    else $ 4))
             (funct3 _ inst)
             ((funct7 _ inst)$[5 :>: 5]@7 == $ 0) ;

        (*
          Memory operations:
          Load (signed), Store: src1 + iImm, 0x, 000, funct3[2] 0
          Load (unsigned): src1 + sImm,      00, 000, funct3[2] 1
          AMO: src1,                         01, 011
         *)
        memVAddr ::=
             (#src1 + (IF (op4_2 _ inst)$[0 :>: 0]@3 == $ 0
                       then (IF (funct3 _ inst)$[2 :>: 2]@2 == $ 0
                             then sImm _ inst
                             else iImm _ inst)
                       else $ 0)) ;

        (*
          Exception:
          JAL, JALR: instruction address misaligned
          AMO: misaligned address
          _: illegal instruction
         *)
        exception ::= getExecException pc inst nextPcVal ;

        (*
          Branch operations:
          Branch: pc + bImm,      11, 000
          JALR: pc + src1 + iImm, 11, 001
          JAL: pc + jImm,         11, 011
         *)
        nextPc ::= nextPcVal
        }.

  Local Definition isLongLat ty (pc: ty VAddr) (inst: ty Inst) (nextPcVal: VAddr @ ty) :=
    ((getExecException pc inst nextPcVal)!ExecException@.extF).

  Definition isNotLongLat ty (pc: ty VAddr) (inst: ty Inst) (nextPcVal: VAddr @ ty) :=
    ! (isLongLat pc inst nextPcVal).

  Definition execLongLatFn ty (pc: ty VAddr) (inst: ty Inst) (src1 src2: ty Data)
    : ((Struct Exec) @ ty) :=
    STRUCT {
        data ::= $$ Default ;
        memVAddr ::= $$ Default ;
        exception ::= getExecException pc inst ($$ Default) ;
        nextPc ::= $$ Default }.

  Definition useSrc1 ty (inst: ty Inst) :=
    (op4_2 _ inst == $ 0 && op6_5 _ inst != $ 2)
    || (op4_2 _ inst == $ 1 && op6_5 _ inst == $ 3)
    || (op4_2 _ inst == $ 4 && op6_5 _ inst == $ 3 && (funct3 _ inst)$[2 :>: 2]@3 == $ 0).

  Definition useSrc2 ty (inst: ty Inst) :=
    (op4_2 _ inst == $ 0 && (op6_5 _ inst)$[0 :>: 0]@2 != $ 1)
    || (op4_2 _ inst == $ 4 && op6_5 _ inst == $ 1).

  Definition useDst ty (inst: ty Inst) :=
    (rd _ inst != $ 0)
      && ((op4_2 _ inst == $ 0 && op6_5 _ inst == $ 0)
          || (op4_2 _ inst == $ 1 && op6_5 _ inst == $ 3)
          || (op4_2 _ inst == $ 3 && op6_5 _ inst == $ 3)
          || (op4_2 _ inst == $ 4 && op6_5 _ inst != $ 2)
          || (op4_2 _ inst == $ 5 && (op6_5 _ inst)$[1 :>: 1]@2 == $ 0)).

  Definition isLd ty (inst: ty Inst) := op4_2 _ inst == $ 0 && op6_5 _ inst == $ 0.
  Definition isSt ty (inst: ty Inst) := op4_2 _ inst == $ 0 && op6_5 _ inst == $ 1.

  Definition next ty (pc: ty VAddr) := #pc + $ 4.

  (* Definition getNextBtb ty (btbState: ty BtbState) (pc: ty VAddr) := *)
  (*   let btbIndex := UniBit (Trunc BtbSz 2) *)
  (*                          (UniBit (Trunc (BtbSz + 2) (VAddrSz - (BtbSz + 2))) #pc) in *)
  (*   (IF #btbState@[btbIndex]!(opt (Struct (Pair (Bit BtbTagSz) BtbData)))@.valid && *)
  (*       (#btbState@[btbIndex]!(opt (Struct (Pair (Bit BtbTagSz) BtbData)))@.data! *)
  (*         (Pair (Bit BtbTagSz) BtbData)@.fst == *)
  (*        (UniBit (TruncLsb (BtbSz + 2) (VAddrSz - (BtbSz + 2))) #pc)) *)
  (*    then {#btbState@[btbIndex]!(opt (Struct (Pair (Bit BtbTagSz) BtbData)))@.data! *)
  (*           (Pair (Bit BtbTagSz) BtbData)@.snd, ($$ Default) : (Bit 2) @ ty } *)
  (*    else #pc + $ 4). *)

  (* Definition updBtb ty (btbState: ty BtbState) (pc: ty VAddr) (isException: ty Bool) *)
  (*            (nextPcVal: ty VAddr) := *)
  (*   let btbIndex := UniBit (Trunc BtbSz 2) *)
  (*                          (UniBit (Trunc (BtbSz + 2) (VAddrSz - (BtbSz + 2))) #pc) in *)
  (*   #btbState@[btbIndex <- *)
  (*                       (IF (#nextPcVal != (#pc + $ 4)) *)
  (*                        then STRUCT { *)
  (*                                 valid ::= $$ true; *)
  (*                                 data ::= STRUCT { *)
  (*                                        fst ::= UniBit (TruncLsb (BtbSz + 2) *)
  (*                                                                 (VAddrSz - (BtbSz + 2))) #pc; *)
  (*                                        snd ::= UniBit (TruncLsb 2 BtbDataSz) #nextPcVal } *)
  (*                               } *)
  (*                        else STRUCT { *)
  (*                                 valid ::= $$ false; *)
  (*                                 data ::= $$ Default *)
  (*                               } *)
  (*             )]. *)

  (* Definition getNextBp ty (bpState: ty BpState) (pc: ty VAddr) := *)
  (*   let bpIndex := UniBit (Trunc BpSz 2) *)
  (*                          (UniBit (Trunc (BpSz + 2) (VAddrSz - (BpSz + 2))) #pc) in *)
  (*   (IF #bpState@[bpIndex]!(opt (Struct (Pair (Bit BpTagSz) BpData)))@.valid && *)
  (*       (#bpState@[bpIndex]!(opt (Struct (Pair (Bit BpTagSz) BpData)))@.data! *)
  (*         (Pair (Bit BpTagSz) BpData)@.fst == *)
  (*        (UniBit (TruncLsb (BpSz + 2) (VAddrSz - (BpSz + 2))) #pc)) *)
  (*    then {#bpState@[bpIndex]!(opt (Struct (Pair (Bit BpTagSz) BpData)))@.data! *)
  (*           (Pair (Bit BpTagSz) BpData)@.snd, ($$ Default) : (Bit 2) @ ty } *)
  (*    else #pc + $ 4). *)

  (* Definition updBp ty (bpState: ty BpState) (pc: ty VAddr) (isException: ty Bool) *)
  (*            (nextPcVal: ty VAddr) := *)
  (*   let bpIndex := UniBit (Trunc BpSz 2) *)
  (*                          (UniBit (Trunc (BpSz + 2) (VAddrSz - (BpSz + 2))) #pc) in *)
  (*   #bpState@[bpIndex <- *)
  (*                       (IF (#nextPcVal != (#pc + $ 4)) *)
  (*                        then STRUCT { *)
  (*                                 valid ::= $$ true; *)
  (*                                 data ::= STRUCT { *)
  (*                                        fst ::= UniBit (TruncLsb (BpSz + 2) *)
  (*                                                                 (VAddrSz - (BpSz + 2))) #pc; *)
  (*                                        snd ::= UniBit (TruncLsb 2 BpDataSz) #nextPcVal } *)
  (*                               } *)
  (*                        else STRUCT { *)
  (*                                 valid ::= $$ false; *)
  (*                                 data ::= $$ Default *)
  (*                               } *)
  (*             )]. *)
  Close Scope kami_expr.
End RV32.


Set Implicit Arguments.
Require Import Metalib.Metatheory.
Require Import Program.Equality.
Require Export Backward.

Lemma maps_subst_tb_free: forall E X U,
    X \notin fv_env E ->
    map (subst_tb X U) E = E.
Proof with auto.
  induction E;intros...
  destruct a.
  destruct b.
  -
    simpl in *.
    f_equal...
    f_equal...
    f_equal...
    rewrite <- subst_tt_fresh...
  -
    simpl in *.
    f_equal...
    f_equal...
    f_equal...
    rewrite <- subst_tt_fresh...
Qed.

Lemma binds_map_free_sub: forall E1 E2 X Y U S Q,
    Y \notin {{X}}  ->
    wf_env (E1 ++ (Y, bind_sub Q) :: E2) ->
    binds X (bind_sub U) (E1 ++ (Y, bind_sub Q) :: E2) ->
    binds X (bind_sub (subst_tt Y S U)) (map (subst_tb Y S) E1 ++  E2).
Proof with auto.
  intros.
  analyze_binds H1...
  -
    unfold binds in *.
    apply In_lemmaL.
    apply binds_map_free...
  -
    unfold binds in *.
    apply In_lemmaR.
    rewrite <- maps_subst_tb_free with (X:=Y) (U:=S)...
    apply binds_map_free...
    apply notin_from_wf_env in H0...
Qed.

Fixpoint subst_tl (Z X: atom)  (T : typ) {struct T} : typ :=
  match T with
  | typ_top => typ_top
  | typ_nat => typ_nat
  | typ_bvar J => typ_bvar J
  | typ_fvar X =>  (typ_fvar X)
  | typ_arrow T1 T2 => typ_arrow (subst_tl Z X T1) (subst_tl Z X T2)
  | typ_mu T => typ_mu (subst_tl Z X T)
  | typ_label l T => if (l==Z) then typ_label X (subst_tl Z X T) else typ_label l (subst_tl Z  X T)
  | typ_all T1 T2 => typ_all (subst_tl Z X T1) (subst_tl Z X T2)
  | typ_rcd_nil => typ_rcd_nil
  | typ_rcd_cons i T1 T2 => typ_rcd_cons i (subst_tl Z X T1) (subst_tl Z X T2)
  end.

Lemma subst_tl_open_tt_var: forall T X X0 Y,
    X0 \notin {{X}} ->
    (open_tt (subst_tl X Y T) X0) = subst_tl X Y (open_tt T X0).
Proof with auto.
  unfold open_tt.
  intro T.
  generalize 0.
  induction T;intros;simpl in *;try f_equal...
  -
    destruct (n0==n)...
  -
    destruct (a==X);subst...
    simpl...
    f_equal...
    simpl...
    f_equal...
Qed.

Lemma subst_tl_open_tt: forall T X U Y,
    (open_tt (subst_tl X Y T) (subst_tl X Y U)) = subst_tl X Y (open_tt T U).
Proof with auto.
  unfold open_tt.
  intro T.
  generalize 0.
  induction T;intros;simpl in *;try f_equal...
  -
    destruct (n0==n)...
  -
    destruct (a==X);subst...
    simpl...
    f_equal...
    simpl...
    f_equal...
Qed.

Lemma subst_tl_open_tt_twice: forall  X X0 Y A,
    X0 \notin {{X}} ->
    open_tt (subst_tl X Y A) (typ_label X0 (open_tt (subst_tl X Y A) X0))
= subst_tl X Y (open_tt A (typ_label X0 (open_tt A X0))).
Proof with auto.
  intros.
  rewrite <- subst_tl_open_tt.
  f_equal...
  simpl...
  destruct (X0==X);subst...
  apply test_solve_notin_7 in H...
  destruct H.
  f_equal.
  rewrite subst_tl_open_tt_var...
Qed.

Lemma subst_tl_rt_type: forall E X Y T,
WF E T->
rt_type T ->
rt_type (subst_tl X Y T).
Proof with auto.
  intros. induction H;try solve [inversion H0]...
  simpl...
Qed.

Lemma subst_tl_collect: forall T E i X A,
    i `notin` collectLabel T ->
    rt_type T ->
    WF E T ->
    i `notin` collectLabel (subst_tl X A T).
Proof with auto.
  intros.
  induction H1;try solve [inversion H0]...
  simpl in *.
  apply notin_union in H.
  destruct H.
  apply notin_union.
  split...
Qed.

Lemma subst_tl_collect2: forall T E i X A,
    i `in` collectLabel T ->
    rt_type T ->
    WF E T ->
    i `in` collectLabel (subst_tl X A T).
Proof with auto.
  intros.
  induction H1;try solve [inversion H0]...
  simpl in *.
  apply union_iff in H. apply union_iff.
  destruct H...
Qed.

Lemma subst_tl_collect3: forall T E i X A,
    i `in` collectLabel (subst_tl X A T) ->
    rt_type T ->
    WF E T ->
    i `in` collectLabel T.
Proof with auto.
  intros.
  induction H1;try solve [inversion H0]...
  simpl in *.
  apply union_iff in H. apply union_iff.
  destruct H...
Qed.

Lemma WF_renaming_tl: forall E A  X Y,
    WF E A ->
    WF E (subst_tl X Y A).
Proof with eauto.
  intros.
  induction H;simpl...
  -
    apply WF_all with (L:=L \u {{X}});intros...
    rewrite subst_tl_open_tt_var...
    add_nil.
    apply WF_narrowing with (V:=T1)...
  -
    apply WF_rec with (L:=L \u {{X}});intros...
    rewrite subst_tl_open_tt_var...
    rewrite subst_tl_open_tt_twice...
  -
    destruct (X0==X)...
  -
    apply WF_rcd_cons...
    { apply subst_tl_rt_type with (E:=E)... }
    { apply subst_tl_collect with (E:=E)... }
Qed.

Lemma subst_tl_fresh: forall A X Y,
    X \notin fl_tt A ->
    subst_tl X Y A = A.
Proof with auto.
  induction A;intros;simpl in *;try f_equal...
  destruct (a==X);subst...
  apply notin_union in H.
  destruct H.
  apply test_solve_notin_7 in H.
  destruct H.
  f_equal...
Qed.

Lemma label_transform: forall A B X Y,
    X \notin fl_tt A \u fl_tt B ->
    subst_tl X Y (open_tt A (typ_label X B)) = open_tt A (typ_label Y B).
Proof with auto.
  intros.
  rewrite <- subst_tl_open_tt...
  rewrite subst_tl_fresh...
  f_equal...
  simpl...
  destruct (X==X)...
  f_equal...
  rewrite subst_tl_fresh...
  destruct n...
Qed.

Lemma WF_renaming_unfolding: forall  E2 X Y Q A,
    WF ( X ~ bind_sub Q ++ E2) (open_tt A (typ_label X (open_tt A X))) ->
    Y \notin {{X}} \u fv_tt A \u fl_tt A ->
    X \notin fv_tt A \u fl_tt A ->
    WF ( Y ~ bind_sub Q ++ E2) (open_tt A (typ_label Y (open_tt A Y))).
Proof with auto.
  intros.
  rewrite_env (nil ++ X ~ bind_sub Q ++ E2) in H.
  apply WF_renaming with (Y:=Y) in H...
  simpl in H.
  rewrite subst_tt_open_tt in H...
  rewrite <- subst_tt_fresh in H...
  simpl in H.
  rewrite <- subst_tt_intro in H...
  apply WF_renaming_tl with (X:=X) (Y:=Y) in H...
  rewrite label_transform in H...
  solve_notin.
  solve_notin.
Qed.

Lemma label_transform3: forall A (X X0 Y : atom),
    X <> X0 ->
    (subst_tt X Y (open_tt A (typ_label X0 (open_tt A X0)))) =
(open_tt (subst_tt X Y A) (typ_label X0 (open_tt (subst_tt X Y A) X0))).
Proof with auto.
  intros.
  rewrite  subst_tt_open_tt...
  f_equal...
  simpl.
  f_equal...
  rewrite  subst_tt_open_tt_var...
Qed.

Lemma WF_replacing: forall E1 E2 T U (X Y:atom),
    WF ( E1 ++ X ~ bind_sub U ++E2) T ->
    Y <> X ->
    WF (map (subst_tb X Y) E1 ++ Y ~ bind_sub U ++E2) (subst_tt X Y T).
Proof with auto.
  intros.
  dependent induction H;intros;simpl;try solve [rewrite_alist (map (subst_tb X Y) E1  ++ Y ~ bind_sub U ++ E2);constructor;auto]...
  -
    destruct (X0==X)...
    { subst. apply WF_var with (U:=U)... }
    { apply binds_app_iff in H. destruct H.
      + apply WF_var with (U:=(subst_tt X Y U0))...
        apply binds_app_iff. left.
        apply binds_map_free...
      + apply WF_var with (U:=U0)...
        simpl. analyze_binds H. }
  - apply WF_all with (L:= L \u {{X}});intros...
    + apply IHWF...
    + rewrite_alist ((map (subst_tb X Y) ((X0 ~ bind_sub T1) ++ E1)) ++ Y ~ bind_sub U ++ E2).
      rewrite  subst_tt_open_tt_var...
  -
    apply WF_rec with (L:=L \u {{X}});intros.
    rewrite_alist ((map (subst_tb X Y) ((X0 ~ bind_sub typ_top) ++ E1)) ++ Y ~ bind_sub U ++ E2).
    rewrite  subst_tt_open_tt_var...
    rewrite_alist ((map (subst_tb X Y) ((X0 ~ bind_sub typ_top) ++ E1)) ++ Y ~ bind_sub U ++ E2).
    rewrite <- label_transform3...
  -
    rewrite_alist (map (subst_tb X Y) E1  ++ Y ~ bind_sub U ++ E2).
    apply WF_rcd_cons...
    { apply subst_tt_rt_type with (E:= (E1 ++ X ~ bind_sub U) ++ Y ~ bind_sub typ_top ++ E2)...
      * apply WF_var with (U:=typ_top)...
      * apply WF_weakening... rewrite app_assoc...
    }
    { apply subst_tt_collect with (E:= E1 ++ X ~ bind_sub U ++ E2)... }
Qed.

Lemma WF_replacing': forall E T U (X Y:atom),
    WF ( X ~ bind_sub U ++E) T ->
    Y <> X ->
    WF ( Y ~ bind_sub U ++E) (subst_tt X Y T).
Proof with auto.
  intros.
  rewrite_alist (map (subst_tb X Y) nil ++ [(Y, bind_sub U)] ++ E).
  apply WF_replacing...
Qed.

Lemma WF_replacing_var: forall E U T X Y,
    WF (X ~ bind_sub U ++E) (open_tt T X) ->
    X \notin fv_tt T \u {{Y}} ->
    WF (Y ~ bind_sub U ++E) (open_tt T Y).
Proof with auto.
  intros.
  rewrite_alist (map (subst_tb X Y) nil ++ [(Y, bind_sub U)] ++ E).
  rewrite subst_tt_intro with (X:=X)...
  apply WF_replacing...
Qed.

Lemma Tlookup_subst: forall E A i X C T,
    WF E A ->
    rt_type A ->
    Tlookup i (subst_tt X C A) = Some T ->
    exists S,
      Tlookup i (subst_tt X C A) = Some (subst_tt X C S) /\ (subst_tt X C S) = T
/\ Tlookup i A = Some S.
Proof with auto.
  intros.
  induction H;try solve [inversion H0]...
  -
    simpl in H1.
    inversion H1.
  -
    simpl in *.
    destruct (i0==i)...
    subst.
    inversion H1...
    exists T1...
Qed.

Lemma Tlookup_subst_tl: forall E A i X C T,
    WF E A ->
    rt_type A ->
    Tlookup i (subst_tl X C A) = Some T ->
    exists S,
      Tlookup i (subst_tl X C A) = Some (subst_tl X C S) /\ (subst_tl X C S) = T
/\ Tlookup i A = Some S.
Proof with auto.
  intros.
  induction H;try solve [inversion H0]...
  -
    simpl in H1.
    inversion H1.
  -
    simpl in *.
    destruct (i0==i)...
    subst.
    inversion H1...
    exists T1...
Qed.

Lemma sub_replacing: forall E1 E2 A B U X Y,
    sub (E1++ X ~ bind_sub U ++E2) A B ->
    X <> Y ->
    wf_env (map (subst_tb X Y)  E1 ++ Y ~ bind_sub U ++ E2) ->
    sub (map (subst_tb X Y) E1 ++ Y ~ bind_sub U ++E2) (subst_tt X Y A) (subst_tt X Y B).
Proof with auto.
  intros.
  generalize dependent Y.
  dependent induction H;intros;simpl;try solve [rewrite_alist (map (subst_tb X Y) E1 ++ [(Y, bind_sub U)] ++ E2);constructor;auto;apply WF_replacing;auto]...
  -
    destruct (X0==X)...
    constructor... apply WF_var with (U:=U)...
    constructor...
    dependent destruction H0.
    apply binds_map_free_sub with (S:=Y) in H0...
    apply WF_var with (U:=(subst_tt X Y U0))...
    analyze_binds H0.
  -
    destruct (X0==X);subst...
    +
      apply sa_trans_tvar with (U:=subst_tt X Y U0)...
      analyze_binds_uniq H...
      apply uniq_from_wf_env...
      get_well_form...
      inversion BindsTacVal;subst.
      get_well_form.
      apply notin_from_wf_env in H0.
      rewrite <- subst_tt_fresh...
      apply IHsub...
    +
      apply sa_trans_tvar with (U:=subst_tt X Y U0)...
      analyze_binds H.
      *
        unfold binds in *.
        apply In_lemmaL.
        apply binds_map_free...
      *
        assert (Ht:=BindsTac0).
        apply WF_from_binds_typ in Ht...
        apply WF_imply_dom in Ht.
        get_well_form.
        apply notin_from_wf_env in H.
        rewrite <- subst_tt_fresh...
        apply notin_partial with (E2:=dom E2)...
        apply wf_env_cons in H2.
        apply wf_env_cons in H2...
      *
        apply IHsub...
  -
    apply sa_all with (L:=L \u {{X}} \u dom (map (subst_tb X Y) E1 ++ (Y, bind_sub U) :: E2));intros...
    apply IHsub1...
    apply IHsub2...
    rewrite_env (map (subst_tb X Y) (X0~bind_sub S2 ++ E1) ++ (Y, bind_sub U) :: E2).
    rewrite subst_tt_open_tt_var...
    rewrite subst_tt_open_tt_var...
    apply H2...
    simpl...
    constructor...
    apply WF_replacing...
    get_well_form...
  -
    apply sa_rec with (L:=L \u {{X}} \u dom (map (subst_tb X Y) E1 ++ (Y, bind_sub U) :: E2));intros...
    +
      rewrite_env (map (subst_tb X Y) (X0~bind_sub typ_top ++ E1) ++ (Y, bind_sub U) :: E2).
      rewrite subst_tt_open_tt_var...
      apply WF_replacing...
      simpl...
      apply H...
    +
      rewrite_env (map (subst_tb X Y) (X0~bind_sub typ_top ++ E1) ++ (Y, bind_sub U) :: E2).
      rewrite subst_tt_open_tt_var...
      apply WF_replacing...
      simpl...
      apply H0...
    +
      rewrite_env (map (subst_tb X Y) (X0~bind_sub typ_top ++ E1) ++ (Y, bind_sub U) :: E2).
      rewrite <- subst_tt_open_tt_twice...
      rewrite <- subst_tt_open_tt_twice...
      apply H2...
      simpl...
      constructor...
  - apply sa_rcd...
    + apply subst_tt_rt_type with (E:= (E1 ++ X ~ bind_sub U) ++ Y ~ bind_sub typ_top ++ E2)...
      * apply WF_var with (U:=typ_top)...
      * apply WF_weakening... rewrite app_assoc...
    + apply subst_tt_rt_type with (E:= (E1 ++ X ~ bind_sub U) ++ Y ~ bind_sub typ_top ++ E2)...
      * apply WF_var with (U:=typ_top)...
      * apply WF_weakening... rewrite app_assoc...
    + intro x. intros. specialize (H2 x).
      apply subst_tt_collect2 with (E:= E1 ++ X ~ bind_sub U ++ E2)...
      apply H2.
      apply subst_tt_collect3 with (E:= E1 ++ X ~ bind_sub U ++ E2) in H9...
    + rewrite_alist (map (subst_tb X Y) E1 ++ [(Y, bind_sub U)] ++ E2).
      apply WF_replacing...
    + rewrite_alist (map (subst_tb X Y) E1 ++ [(Y, bind_sub U)] ++ E2).
      apply WF_replacing...
    + intros.
      apply Tlookup_subst with (E:=(E1 ++ X ~ bind_sub U ++ E2)) in H9...
      apply Tlookup_subst with (E:=(E1 ++ X ~ bind_sub U ++ E2)) in H10...
      destruct H9 as [t1'], H10 as [t2']. destruct_hypos. subst.
      apply H6 with (i:=i)...
Qed.

Lemma sub_replacing': forall E T1 T2 U (X Y:atom),
    sub ( X ~ bind_sub U ++E) T1 T2 ->
    Y <> X ->
    wf_env (Y ~ bind_sub U ++ E) ->
    sub ( Y ~ bind_sub U ++E) (subst_tt X Y T1) (subst_tt X Y T2).
Proof with auto.
  intros.
  rewrite_alist (map (subst_tb X Y) nil ++ [(Y, bind_sub U)] ++ E).
  apply sub_replacing...
Qed.

Lemma sub_replacing_var: forall E2 A B U X Y,
    sub (X ~ bind_sub U ++E2) (open_tt A X) (open_tt B X) ->
    X \notin fv_tt A \u fv_tt B \u {{Y}} ->
    wf_env (Y ~ bind_sub U ++ E2) ->
    sub (Y ~ bind_sub U ++E2) (open_tt A Y) (open_tt B Y).
Proof with auto.
  intros.
  rewrite_alist (map (subst_tb X Y) nil ++ [(Y, bind_sub U)] ++ E2).
  rewrite subst_tt_intro with (X:=X) (T2:=A)...
  rewrite subst_tt_intro with (X:=X) (T2:=B)...
  apply sub_replacing...
Qed.

Lemma label_transform1 : forall X (Y:atom) A Z,
    X \notin fv_tt A ->
    (subst_tt X Y (open_tt A (typ_label Z (open_tt A X)))) =
    (open_tt A (typ_label Z (open_tt A Y))).
Proof with auto.
  intros.
  rewrite  subst_tt_open_tt...
  f_equal...
  rewrite <- subst_tt_fresh...
  simpl.
  f_equal...
  rewrite <- subst_tt_intro...
Qed.

Definition subst_tlb (Z P : atom)  (b : binding) : binding :=
  match b with
  | bind_sub T => bind_sub (subst_tl Z P T)
  | bind_typ T => bind_typ (subst_tl Z P T)
  end.

Lemma WF_from_binds: forall E U X0 X Y,
    binds X0 (bind_sub U) E ->
    WF (map (subst_tlb X Y) E) X0.
Proof with auto.
  induction E;intros...
  analyze_binds H.
  simpl in *.
  destruct a.
  analyze_binds H...
  simpl...
  apply WF_var with (U:=(subst_tl X Y U))...
  rewrite_env (nil ++(a~ subst_tlb X Y b) ++ map (subst_tlb X Y) E).
  apply WF_weakening...
  apply IHE with (U:=U)...
Qed.

Lemma WF_renaming_tlb: forall E A  X Y,
    WF E A ->
    WF (map (subst_tlb X Y) E) (subst_tl X Y A).
Proof with eauto.
  intros.
  induction H;simpl...
  -
    apply WF_from_binds with (U:=U)...
  -
    apply WF_all with (L:=L \u {{X}});intros...
    rewrite subst_tl_open_tt_var...
    apply H1...
  -
    apply WF_rec with (L:=L \u {{X}});intros...
    rewrite subst_tl_open_tt_var...
    apply H0...
    rewrite subst_tl_open_tt_twice...
    apply H2...
  -
    destruct (X0==X)...
  -
    apply WF_rcd_cons...
    + apply subst_tl_rt_type with (E:=E)...
    + apply subst_tl_collect with (E:=E)...
Qed.

Lemma wf_env_tlb: forall E X Y,
    wf_env E ->
    wf_env (map (subst_tlb X Y) E).
Proof with auto.
  induction E;intros...
  destruct a.
  simpl in *...
  destruct b.
  -
    dependent destruction H.
    constructor...
    apply WF_renaming_tlb...
  -
    dependent destruction H.
    constructor...
    apply WF_renaming_tlb...
Qed.

Lemma binds_map_free_fl_env: forall E X0 U X Y,
    binds X0 (bind_sub U) E ->
    binds X0 (bind_sub (subst_tl X Y U)) (map (subst_tlb X Y) E).
Proof with auto.
  induction E;intros...
  destruct a.
  simpl in *.
  analyze_binds H...
Qed.

Lemma sub_renaming_tl: forall E A B X Y,
    sub E A B ->
    sub (map (subst_tlb X Y) E) (subst_tl X Y A) (subst_tl X Y B).
Proof with eauto.
  intros.
  dependent induction H;simpl in *...
  -
    constructor...
    apply wf_env_tlb...
  -
    constructor...
    apply wf_env_tlb...
    dependent destruction H0.
    apply WF_from_binds with (U:=U)...
  -
    constructor...
    apply wf_env_tlb...
    apply WF_renaming_tlb...
  -
    apply sa_trans_tvar with (U:=subst_tl X Y U)...
    apply binds_map_free_fl_env...
  -
    apply sa_all with (L:=L \u {{X}});intros...
    rewrite subst_tl_open_tt_var...
    rewrite subst_tl_open_tt_var...
    apply H2...
  -
    apply sa_rec with (L:=L \u {{X}});intros...
    +
      rewrite subst_tl_open_tt_var...
      rewrite_env (map (subst_tlb X Y) (X0 ~ bind_sub typ_top ++ E)).
      apply WF_renaming_tlb...
      apply H...
    +

      rewrite subst_tl_open_tt_var...
      rewrite_env (map (subst_tlb X Y) (X0 ~ bind_sub typ_top ++ E)).
      apply WF_renaming_tlb...
      apply H0...
    +
      rewrite subst_tl_open_tt_twice...
      rewrite subst_tl_open_tt_twice...
      rewrite_env (map (subst_tlb X Y) (X0 ~ bind_sub typ_top ++ E)).
      apply H2...
  -
    destruct (X0==X);subst...
  -
    apply sa_rcd...
    + apply wf_env_tlb...
    + apply subst_tl_rt_type with (E:=E)...
    + apply subst_tl_rt_type with (E:=E)...
    + intro x. intros. specialize (H2 x).
      apply subst_tl_collect2 with (E:=E)...
      apply H2. apply subst_tl_collect3 with (E:=E) in H7...
    + apply WF_renaming_tlb...
    + apply WF_renaming_tlb...
    + intros.
      apply Tlookup_subst_tl with (E:=E) in H7...
      apply Tlookup_subst_tl with (E:=E) in H8...
      destruct H7 as [t1'], H8 as [t2']. destruct_hypos.
      subst. apply H6 with (i:=i)...
Qed.

Lemma label_transform4: forall X Y A U,
    X \notin fl_tt A \u fl_tt U ->
    (subst_tl X Y (open_tt A (typ_label X U))) =
    (open_tt A (typ_label Y U)).
Proof with auto.
  intros.
  rewrite <- subst_tl_open_tt...
  f_equal...
  rewrite  subst_tl_fresh...
  simpl.
  destruct (X==X)...
  f_equal.
  rewrite  subst_tl_fresh...
  destruct n...
Qed.

Lemma subst_tlb_fresh : forall E X Y,
    X \notin fl_env E ->
    E = map (subst_tlb X Y) E.
Proof with auto.
  induction E;intros...
  simpl in *.
  destruct a.
  f_equal...
  f_equal...
  destruct b;simpl;f_equal;
  rewrite subst_tl_fresh...
  apply IHE...
  destruct b...
Qed.

Lemma sub_renaming_unfolding: forall  E2 X Y Q A B,
    sub ( X ~ bind_sub Q ++ E2) (open_tt A (typ_label X (open_tt A X))) (open_tt B (typ_label X (open_tt B X))) ->
    Y \notin {{X}} \u fv_tt A \u fl_tt A \u fv_tt B \u fl_tt B ->
    X \notin fv_tt A \u fl_tt A \u fv_tt B \u fl_tt B \u fl_tt Q \u fl_env E2 ->
    wf_env (Y ~ bind_sub Q ++ E2) ->
    sub ( Y ~ bind_sub Q ++ E2) (open_tt A (typ_label Y (open_tt A Y))) (open_tt B (typ_label Y (open_tt B Y))).
Proof with auto.
  intros.
  apply sub_replacing' with (Y:=Y) in H...
  rewrite label_transform1 in H...
  rewrite label_transform1 in H...
  apply sub_renaming_tl with (X:=X) (Y:=Y) in H...
  assert (Q = subst_tl X Y Q).
  rewrite subst_tl_fresh...
  rewrite H3.
  rewrite subst_tlb_fresh with (X:=X) (Y:=Y) (E:=E2)...
  rewrite label_transform4 in H...
  rewrite label_transform4 in H...
  solve_notin.
  solve_notin.
Qed.


Require Import aes.api_specs.
Require Import aes.bitfiddling.
Require Import aes.encryption_LL_round_step_eqs.
Require Import aes.verif_encryption_LL_loop_body.
Require Import aes.verif_encryption_LL_after_loop.
Open Scope Z.

Lemma body_aes_encrypt: semax_body Vprog Gprog f_mbedtls_aes_encrypt encryption_spec_ll.
Proof.
  idtac "Starting body_aes_encrypt".
  start_function.
  Opaque list_repeat.
  simpl.
  Transparent list_repeat.
  reassoc_seq.

  (* RK = ctx->rk; *)
  forward.
  assert_PROP (field_compatible t_struct_aesctx [StructField _buf] ctx) as Fctx. entailer!.
  assert ((field_address t_struct_aesctx [StructField _buf] ctx)
        = (field_address t_struct_aesctx [ArraySubsc 0; StructField _buf] ctx)) as Eq. {
    do 2 rewrite field_compatible_field_address by auto with field_compatible.
    reflexivity.
  }
  rewrite Eq in *. clear Eq.
  remember (exp_key ++ list_repeat 8 0) as buf.
  (* TODO floyd: This is important for automatic rewriting of (Znth (map Vint ...)), and if
     it's not done, the tactics might become very slow, especially if they try to simplify complex
     terms that they would never attempt to simplify if the rewriting had succeeded.
     How should the user be told to put prove such assertions before continuing? *)
  assert (Zlength buf = 68) as LenBuf. {
    subst. rewrite Zlength_app. rewrite H0. reflexivity.
  }

  assert_PROP (forall i, 0 <= i < 60 -> force_val (sem_add_ptr_int tuint Signed
       (field_address t_struct_aesctx [ArraySubsc  i   ; StructField _buf] ctx) (Vint (Int.repr 1)))
     = (field_address t_struct_aesctx [ArraySubsc (i+1); StructField _buf] ctx)) as Eq. {
    entailer!. intros.
    do 2 rewrite field_compatible_field_address by auto with field_compatible.
    simpl. destruct ctx; inversion PNctx; try reflexivity.
    simpl. f_equal. rewrite Ptrofs.add_assoc.
    change (Ptrofs.mul (Ptrofs.repr 4) (Ptrofs.of_ints (Int.repr 1))) with (Ptrofs.repr 4).
    rewrite ptrofs_add_repr. f_equal. f_equal.  clear; omega.
  }

  (* GET_UINT32_LE( X0, input,  0 ); X0 ^= *RK++;
     GET_UINT32_LE( X1, input,  4 ); X1 ^= *RK++;
     GET_UINT32_LE( X2, input,  8 ); X2 ^= *RK++;
     GET_UINT32_LE( X3, input, 12 ); X3 ^= *RK++; *)
  do 9 (forward; simpl); rewrite Eq by computable; simpl. deadvars!.
  do 9 (forward; simpl); rewrite Eq by computable; simpl. deadvars!.
  do 9 (forward; simpl); rewrite Eq by computable; simpl. deadvars!.
  do 9 (forward; simpl); rewrite Eq by computable; simpl. deadvars!.

  pose (S0 := mbed_tls_initial_add_round_key plaintext buf).
  match goal with |- context [temp _X0 (Vint ?E)] => change E with (col 0 S0) end.
  match goal with |- context [temp _X1 (Vint ?E)] => change E with (col 1 S0) end.
  match goal with |- context [temp _X2 (Vint ?E)] => change E with (col 2 S0) end.
  match goal with |- context [temp _X3 (Vint ?E)] => change E with (col 3 S0) end.

  forward.
  (* ugly hack to avoid type mismatch between
   "(val * (val * list val))%type" and "reptype t_struct_aesctx" *)
  assert (exists (v: reptype t_struct_aesctx), v =
       (Vint (Int.repr Nr),
          (field_address t_struct_aesctx [ArraySubsc 0; StructField _buf] ctx,
          map Vint (map Int.repr buf))))
  as EE by (eexists; reflexivity).

  destruct EE as [vv EE].
  remember (mbed_tls_enc_rounds 12 S0 buf 4) as S12.

  forward_for
  (* Loop Invariant *)
  (fun i:Z => PROP (
     0 <= i <= 6
   ) LOCAL (
     temp _i (Vint (Int.repr i));
     temp _RK (field_address t_struct_aesctx [ArraySubsc (52 - i*8); StructField _buf] ctx);
     temp _X3 (Vint (col 3 (mbed_tls_enc_rounds (12 - 2 * (Z.to_nat i)) S0 buf 4)));
     temp _X2 (Vint (col 2 (mbed_tls_enc_rounds (12 - 2 * (Z.to_nat i)) S0 buf 4)));
     temp _X1 (Vint (col 1 (mbed_tls_enc_rounds (12 - 2 * (Z.to_nat i)) S0 buf 4)));
     temp _X0 (Vint (col 0 (mbed_tls_enc_rounds (12 - 2 * (Z.to_nat i)) S0 buf 4)));
     temp _output output;
     gvars gv
  ) SEP (
     data_at_ out_sh (tarray tuchar 16) output;
     tables_initialized (gv _tables);
     data_at in_sh (tarray tuchar 16) (map Vint (map Int.repr plaintext)) input;
     data_at ctx_sh t_struct_aesctx vv ctx
  ))
  continue: (* PreInc invariant *)
   (fun i: Z => PROP (
     0 < i <= 6
  ) LOCAL (
     temp _i (Vint (Int.repr i));
     temp _RK (field_address t_struct_aesctx [ArraySubsc (52 - (i-1)*8); StructField _buf] ctx);
     temp _X3 (Vint (col 3 (mbed_tls_enc_rounds (12 - 2 * (Z.to_nat (i-1))) S0 buf 4)));
     temp _X2 (Vint (col 2 (mbed_tls_enc_rounds (12 - 2 * (Z.to_nat (i-1))) S0 buf 4)));
     temp _X1 (Vint (col 1 (mbed_tls_enc_rounds (12 - 2 * (Z.to_nat (i-1))) S0 buf 4)));
     temp _X0 (Vint (col 0 (mbed_tls_enc_rounds (12 - 2 * (Z.to_nat (i-1))) S0 buf 4)));
     temp _output output;
     gvars gv
  ) SEP (
     data_at_ out_sh (tarray tuchar 16) output;
     tables_initialized (gv _tables);
     data_at in_sh (tarray tuchar 16) (map Vint (map Int.repr plaintext)) input;
     data_at ctx_sh t_struct_aesctx vv ctx
  ))
  break: (* Loop postcondition *)
   (PROP() LOCAL (
     temp _RK (field_address t_struct_aesctx [ArraySubsc 52; StructField _buf] ctx);
     temp _X3 (Vint (col 3 S12));
     temp _X2 (Vint (col 2 S12));
     temp _X1 (Vint (col 1 S12));
     temp _X0 (Vint (col 0 S12));
     temp _output output;
     gvars gv
  ) SEP (
     data_at_ out_sh (tarray tuchar 16) output;
     tables_initialized (gv _tables);
     data_at in_sh (tarray tuchar 16) (map Vint (map Int.repr plaintext)) input;
     data_at ctx_sh t_struct_aesctx vv ctx
  )).
* (* initializer establishes loop invariant *)
 forward. Exists 6. entailer!.
* (* loop-test typechecks *)
 entailer!.
* (*  loop body *)
  rename a into i.
  assert (0 < i <= 6) by (clear - H1 H2; omega).
  unfold tables_initialized. subst vv.
  reassoc_seq.
  eapply encryption_loop_body_proof; eauto.
  (* the next few lines should not be necessary if the statement
    of encryption_loop_body_proof is adjusted.
  clear.
  intros. match goal with |-
     context [loop1_ret_assert ?PP (normal_ret_assert ?QQ)] =>
     set (P:=PP); set (Q := QQ)
   end.
  apply andp_left2.
  unfold loop1_ret_assert, normal_ret_assert, overridePost; destruct ek; auto.
  rewrite if_true by auto. rewrite !prop_true_andp by auto.
  subst Q. solve [auto].
  apply derives_extract_prop; intro Hx; inv Hx.*)
* (* loop decr *)
  rename a into i. forward. Exists (i-1). entailer!.
* (* after the loop, entailment *)
 assert (a=0) by omega. clear H1 H2; subst a.
 change (12 - 2 * Z.to_nat 0)%nat with 12%nat.
 rewrite <- HeqS12.
 change (52 - 0 * 8) with 52.
 clear. entailer!.
* (** AFTER THE LOOP **)
subst vv.
eapply encryption_after_loop_proof; eassumption.
Time Qed. (* 9.2 secs on Andrew's machine *)

(* TODO floyd: sc_new_instantiate: distinguish between errors caused because the tactic is trying th
   wrong thing and errors because of user type errors such as "tuint does not equal t_struct_aesctx" *)

(* TODO floyd: compute_nested_efield should not fail silently *)

(* TODO floyd: if field_address is given a gfs which doesn't match t, it should not fail silently,
   or at least, the tactics should warn.
   And same for nested_field_offset. *)

(* TODO floyd: I want "omega" for int instead of Z
   maybe "autorewrite with entailer_rewrite in *"
*)

(* TODO floyd: when load_tac should tell that it cannot handle memory access in subexpressions *)

(* TODO floyd: for each tactic, test how it fails when variables are missing in Pre *)

(*
Note:
field_compatible/0 -> legal_nested_field/0 -> legal_field/0:
  legal_field0 allows an array index to point 1 past the last array cell, legal_field disallows this
*)


(** Authoritative CMRA of append-only lists, where the fragment represents a
  snap-shot of the list, and the authoritative element can only grow by
  appending. *)
From iris.algebra Require Export auth dfrac max_prefix_list.
From iris.algebra Require Import updates local_updates proofmode_classes.
From iris.prelude Require Import options.

Definition mono_listR (A : ofe) : cmra  := authR (max_prefix_listUR A).
Definition mono_listUR (A : ofe) : ucmra  := authUR (max_prefix_listUR A).

Definition mono_list_auth {A : ofe} (q : dfrac) (l : list A) : mono_listR A :=
  ●{q} (to_max_prefix_list l) ⋅ ◯ (to_max_prefix_list l).
Definition mono_list_lb {A : ofe} (l : list A) : mono_listR A :=
  ◯ (to_max_prefix_list l).
Global Instance: Params (@mono_list_auth) 2 := {}.
Global Instance: Params (@mono_list_lb) 1 := {}.
Typeclasses Opaque mono_list_auth mono_list_lb.

Notation "●ML dq l" := (mono_list_auth dq l)
  (at level 20, dq custom dfrac at level 1, format "●ML dq  l").
Notation "◯ML l" := (mono_list_lb l) (at level 20).

Section mono_list_props.
  Context {A : ofe}.
  Implicit Types l : list A.
  Implicit Types q : frac.
  Implicit Types dq : dfrac.

  (** Setoid properties *)
  Global Instance mono_list_auth_ne dq : NonExpansive (@mono_list_auth A dq).
  Proof. solve_proper. Qed.
  Global Instance mono_list_auth_proper dq : Proper ((≡) ==> (≡)) (@mono_list_auth A dq).
  Proof. solve_proper. Qed.
  Global Instance mono_list_lb_ne : NonExpansive (@mono_list_lb A).
  Proof. solve_proper. Qed.
  Global Instance mono_list_lb_proper : Proper ((≡) ==> (≡)) (@mono_list_lb A).
  Proof. solve_proper. Qed.

  Global Instance mono_list_lb_dist_inj n : Inj (dist n) (dist n) (@mono_list_lb A).
  Proof. rewrite /mono_list_lb. by intros ?? ?%(inj _)%(inj _). Qed.
  Global Instance mono_list_lb_inj : Inj (≡) (≡) (@mono_list_lb A).
  Proof. rewrite /mono_list_lb. by intros ?? ?%(inj _)%(inj _). Qed.

  (** * Operation *)
  Global Instance mono_list_lb_core_id l : CoreId (◯ML l).
  Proof. rewrite /mono_list_lb. apply _. Qed.
  Global Instance mono_list_auth_core_id l : CoreId (●ML□ l).
  Proof. rewrite /mono_list_auth. apply _. Qed.

  Lemma mono_list_auth_dfrac_op dq1 dq2 l :
    ●ML{dq1 ⋅ dq2} l ≡ ●ML{dq1} l ⋅ ●ML{dq2} l.
  Proof.
    rewrite /mono_list_auth auth_auth_dfrac_op.
    rewrite (comm _ (●{dq2} _)) -!assoc (assoc _ (◯ _)).
    by rewrite -core_id_dup (comm _ (◯ _)).
  Qed.

  Lemma mono_list_lb_op_l l1 l2 : l1 `prefix_of` l2 → ◯ML l1 ⋅ ◯ML l2 ≡ ◯ML l2.
  Proof. intros ?. by rewrite /mono_list_lb -auth_frag_op to_max_prefix_list_op_l. Qed.
  Lemma mono_list_lb_op_r l1 l2 : l1 `prefix_of` l2 → ◯ML l2 ⋅ ◯ML l1 ≡ ◯ML l2.
  Proof. intros ?. by rewrite /mono_list_lb -auth_frag_op to_max_prefix_list_op_r. Qed.
  Lemma mono_list_auth_lb_op dq l : ●ML{dq} l ≡ ●ML{dq} l ⋅ ◯ML l.
  Proof.
    by rewrite /mono_list_auth /mono_list_lb -!assoc -auth_frag_op -core_id_dup.
  Qed.

  Global Instance mono_list_auth_dfrac_is_op dq dq1 dq2 l :
    IsOp dq dq1 dq2 → IsOp' (●ML{dq} l) (●ML{dq1} l) (●ML{dq2} l).
  Proof. rewrite /IsOp' /IsOp=> ->. rewrite mono_list_auth_dfrac_op //. Qed.

  (** * Validity *)
  Lemma mono_list_auth_dfrac_validN n dq l : ✓{n} (●ML{dq} l) ↔ ✓ dq.
  Proof.
    rewrite /mono_list_auth auth_both_dfrac_validN.
    naive_solver apply to_max_prefix_list_validN.
  Qed.
  Lemma mono_list_auth_validN n l : ✓{n} (●ML l).
  Proof. by apply mono_list_auth_dfrac_validN. Qed.

  Lemma mono_list_auth_dfrac_valid dq l : ✓ (●ML{dq} l) ↔ ✓ dq.
  Proof.
    rewrite /mono_list_auth auth_both_dfrac_valid.
    naive_solver apply to_max_prefix_list_valid.
  Qed.
  Lemma mono_list_auth_valid l : ✓ (●ML l).
  Proof. by apply mono_list_auth_dfrac_valid. Qed.

  Lemma mono_list_auth_dfrac_op_validN n dq1 dq2 l1 l2 :
    ✓{n} (●ML{dq1} l1 ⋅ ●ML{dq2} l2) ↔ ✓ (dq1 ⋅ dq2) ∧ l1 ≡{n}≡ l2.
  Proof.
    rewrite /mono_list_auth (comm _ (●{dq2} _)) -!assoc (assoc _ (◯ _)).
    rewrite -auth_frag_op (comm _ (◯ _)) assoc. split.
    - move=> /cmra_validN_op_l /auth_auth_dfrac_op_validN.
      rewrite (inj_iff to_max_prefix_list). naive_solver.
    - intros [? ->]. rewrite -core_id_dup -auth_auth_dfrac_op auth_both_dfrac_validN.
      naive_solver apply to_max_prefix_list_validN.
  Qed.
  Lemma mono_list_auth_op_validN n l1 l2 : ✓{n} (●ML l1 ⋅ ●ML l2) ↔ False.
  Proof. rewrite mono_list_auth_dfrac_op_validN. naive_solver. Qed.

  Lemma mono_list_auth_dfrac_op_valid dq1 dq2 l1 l2 :
    ✓ (●ML{dq1} l1 ⋅ ●ML{dq2} l2) ↔ ✓ (dq1 ⋅ dq2) ∧ l1 ≡ l2.
  Proof.
    rewrite cmra_valid_validN equiv_dist.
    setoid_rewrite mono_list_auth_dfrac_op_validN. naive_solver eauto using O.
  Qed.
  Lemma mono_list_auth_op_valid l1 l2 : ✓ (●ML l1 ⋅ ●ML l2) ↔ False.
  Proof. rewrite mono_list_auth_dfrac_op_valid. naive_solver. Qed.

  Lemma mono_list_auth_dfrac_op_valid_L `{!LeibnizEquiv A} dq1 dq2 l1 l2 :
    ✓ (●ML{dq1} l1 ⋅ ●ML{dq2} l2) ↔ ✓ (dq1 ⋅ dq2) ∧ l1 = l2.
  Proof. unfold_leibniz. apply mono_list_auth_dfrac_op_valid. Qed.

  Lemma mono_list_both_dfrac_validN n dq l1 l2 :
    ✓{n} (●ML{dq} l1 ⋅ ◯ML l2) ↔ ✓ dq ∧ ∃ l, l1 ≡{n}≡ l2 ++ l.
  Proof.
    rewrite /mono_list_auth /mono_list_lb -assoc
      -auth_frag_op auth_both_dfrac_validN -to_max_prefix_list_includedN.
    f_equiv; split.
    - intros [Hincl _]. etrans; [apply: cmra_includedN_r|done].
    - intros. split; [|by apply to_max_prefix_list_validN].
      rewrite {2}(core_id_dup (to_max_prefix_list l1)). by f_equiv.
  Qed.
  Lemma mono_list_both_validN n l1 l2 :
    ✓{n} (●ML l1 ⋅ ◯ML l2) ↔ ∃ l, l1 ≡{n}≡ l2 ++ l.
  Proof. rewrite mono_list_both_dfrac_validN. split; [naive_solver|done]. Qed.

  Lemma mono_list_both_dfrac_valid dq l1 l2 :
    ✓ (●ML{dq} l1 ⋅ ◯ML l2) ↔ ✓ dq ∧ ∃ l, l1 ≡ l2 ++ l.
  Proof.
    rewrite /mono_list_auth /mono_list_lb -assoc -auth_frag_op
      auth_both_dfrac_valid -max_prefix_list_included_includedN
      -to_max_prefix_list_included.
    f_equiv; split.
    - intros [Hincl _]. etrans; [apply: cmra_included_r|done].
    - intros. split; [|by apply to_max_prefix_list_valid].
      rewrite {2}(core_id_dup (to_max_prefix_list l1)). by f_equiv.
  Qed.
  Lemma mono_list_both_valid l1 l2 :
    ✓ (●ML l1 ⋅ ◯ML l2) ↔ ∃ l, l1 ≡ l2 ++ l.
  Proof. rewrite mono_list_both_dfrac_valid. split; [naive_solver|done]. Qed.

  Lemma mono_list_both_dfrac_valid_L `{!LeibnizEquiv A} dq l1 l2 :
    ✓ (●ML{dq} l1 ⋅ ◯ML l2) ↔ ✓ dq ∧ l2 `prefix_of` l1.
  Proof. rewrite /prefix. rewrite mono_list_both_dfrac_valid. naive_solver. Qed.
  Lemma mono_list_both_valid_L `{!LeibnizEquiv A} l1 l2 :
    ✓ (●ML l1 ⋅ ◯ML l2) ↔ l2 `prefix_of` l1.
  Proof. rewrite /prefix. rewrite mono_list_both_valid. naive_solver. Qed.

  Lemma mono_list_lb_op_validN n l1 l2 :
    ✓{n} (◯ML l1 ⋅ ◯ML l2) ↔ (∃ l, l2 ≡{n}≡ l1 ++ l) ∨ (∃ l, l1 ≡{n}≡ l2 ++ l).
  Proof. by rewrite auth_frag_op_validN to_max_prefix_list_op_validN. Qed.
  Lemma mono_list_lb_op_valid l1 l2 :
    ✓ (◯ML l1 ⋅ ◯ML l2) ↔ (∃ l, l2 ≡ l1 ++ l) ∨ (∃ l, l1 ≡ l2 ++ l).
  Proof. by rewrite auth_frag_op_valid to_max_prefix_list_op_valid. Qed.
  Lemma mono_list_lb_op_valid_L `{!LeibnizEquiv A} l1 l2 :
    ✓ (◯ML l1 ⋅ ◯ML l2) ↔ l1 `prefix_of` l2 ∨ l2 `prefix_of` l1.
  Proof. rewrite mono_list_lb_op_valid / prefix. naive_solver. Qed.

  Lemma mono_list_lb_op_valid_1_L `{!LeibnizEquiv A} l1 l2 :
    ✓ (◯ML l1 ⋅ ◯ML l2) → l1 `prefix_of` l2 ∨ l2 `prefix_of` l1.
  Proof. by apply mono_list_lb_op_valid_L. Qed.
  Lemma mono_list_lb_op_valid_2_L `{!LeibnizEquiv A} l1 l2 :
    l1 `prefix_of` l2 ∨ l2 `prefix_of` l1 → ✓ (◯ML l1 ⋅ ◯ML l2).
  Proof. by apply mono_list_lb_op_valid_L. Qed.

  Lemma mono_list_lb_mono l1 l2 : l1 `prefix_of` l2 → ◯ML l1 ≼ ◯ML l2.
  Proof. intros. exists (◯ML l2). by rewrite mono_list_lb_op_l. Qed.

  Lemma mono_list_included dq l : ◯ML l ≼ ●ML{dq} l.
  Proof. apply cmra_included_r. Qed.

  (** * Update *)
  Lemma mono_list_update {l1} l2 : l1 `prefix_of` l2 → ●ML l1 ~~> ●ML l2.
  Proof. intros ?. by apply auth_update, max_prefix_list_local_update. Qed.
  Lemma mono_list_auth_persist dq l : ●ML{dq} l ~~> ●ML□ l.
  Proof.
    rewrite /mono_list_auth. apply cmra_update_op; [|done].
    by apply auth_update_auth_persist.
  Qed.
End mono_list_props.

Definition mono_listURF (F : oFunctor) : urFunctor :=
  authURF (max_prefix_listURF F).

Global Instance mono_listURF_contractive F :
  oFunctorContractive F → urFunctorContractive (mono_listURF F).
Proof. apply _. Qed.

Definition mono_listRF (F : oFunctor) : rFunctor :=
  authRF (max_prefix_listURF F).

Global Instance mono_listRF_contractive F :
  oFunctorContractive F → rFunctorContractive (mono_listRF F).
Proof. apply _. Qed.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^255 - 19
Base: 25.5
***)

Definition curve : CurveParameters :=
  {|
    sz := 10%nat;
    base := 25 + 1/2;
    bitwidth := 32;
    s := 2^255;
    c := [(1, 19)];
    carry_chains := Some [seq 0 (pred 10); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


Require Import Coq.Strings.String Coq.Strings.Ascii.
Require Import Fiat.Parsers.Reflective.Syntax Fiat.Parsers.Reflective.ParserSyntax.
Require Import Fiat.Parsers.Reflective.Semantics.
Require Import Fiat.Parsers.Splitters.RDPList.
Require Import Fiat.Parsers.GenericRecognizer.
Require Import Fiat.Common.NatFacts.
Require Import Fiat.Common.BoolFacts.
Require Import Fiat.Common.List.Operations.
Require Import Fiat.Common.Wf Fiat.Common.Wf2.
Set Implicit Arguments.

Definition step_option_rec
           {T}
           (is_valid_nonterminal : list nat -> nat -> bool)
           (len0 valid_len0 : nat)
           (parse_nt : forall len0' valid_len : nat,
               Wf.prod_relation lt lt (len0', valid_len) (len0, valid_len0) ->
               list nat -> nat -> forall len : nat, len <= len0' -> nat -> T)
           (G_length : nat)
           (up_to_G_length : list nat)
           (valids : list nat) (offset len : nat)
           (nt : nat)
  : option (nat -> nat -> nat -> T).
Proof.
  refine (sumbool_rect (fun _ => option (nat -> nat -> nat -> T))
                       (fun pf =>
                          Some
                            (fun offset' len0_minus_len'
                             => parse_nt len G_length
                                         (or_introl pf)
                                         up_to_G_length
                                         offset'
                                         (len - len0_minus_len') (Minus.le_minus len len0_minus_len')))
                       (fun _
                        => _)
                       (Compare_dec.lt_dec len len0)).
  refine (sumbool_rect
            (fun _ => option (nat -> nat -> nat -> T))
            (fun is_valid
             => _)
            (fun _ => None)
            (Sumbool.sumbool_of_bool (negb (EqNat.beq_nat valid_len0 0) && is_valid_nonterminal valids nt))%bool).
  refine (Some
            (fun offset' len0_minus_len' =>
               parse_nt len0 (pred valid_len0)
                        (or_intror (conj eq_refl (GenericRecognizer.pred_lt_beq _)))
                        (RDPList.filter_out_eq nt valids) offset'
                        (len0 - len0_minus_len') (Minus.le_minus len0 len0_minus_len'))).
  apply (proj1 (proj1 (Bool.andb_true_iff _ _) is_valid)).
Defined.

Definition interp_has_parse_term'
           {T}
           (interp_Term : forall {T}, Term interp_TypeCode T -> interp_TypeCode T)
           (is_valid_nonterminal : list nat -> nat -> bool)
           (strlen : nat)
           (char_at_matches_interp : nat -> Reflective.RCharExpr Ascii.ascii -> bool)
           (split_string_for_production : nat * (nat * nat) -> nat -> nat -> list nat)
           (t : has_parse_term interp_TypeCode T) : interp_TypeCode T
  := match t with
     | RFix2 G_length up_to_G_length f default valid_len valids nt_idx
       => Wf2.Fix2
            (Wf.well_founded_prod_relation Wf_nat.lt_wf Wf_nat.lt_wf)
            (fun aa' : nat * nat =>
               list nat -> nat -> forall a1 : nat, a1 <= fst aa' -> nat -> interp_TypeCode T)
            (fun (len0 valid_len0 : nat)
                 (parse_nt : forall len0' valid_len : nat,
                     Wf.prod_relation lt lt (len0', valid_len) (len0, valid_len0) ->
                     list nat -> nat -> forall len : nat, len <= len0' -> nat -> interp_TypeCode T)
                 (valids : list nat) (offset len : nat)
                 (pf : len <= len0)
                 (nt : nat)
             => option_rect
                  (fun _ : option (interp_TypeCode (cnat --> cnat --> cnat --> T)) => interp_TypeCode T)
                  (fun parse_nt
                   => interp_Term
                        f
                        (fun n : interp_TypeCode cnat => char_at_matches_interp n (*str*))
                        (fun n : interp_TypeCode (cnat * (cnat * cnat)) => split_string_for_production n (*str*))
                        len0 valid_len parse_nt valids offset len nt)
                  (interp_Term default)
                  (@step_option_rec (interp_TypeCode T) is_valid_nonterminal len0 valid_len0 parse_nt G_length up_to_G_length valids offset len nt))
            strlen
            valid_len
            valids
            0
            strlen
            (le_n _)
            nt_idx
     end.

Definition interp_has_parse_term {T}
  := Eval cbv [interp_has_parse_term'] in @interp_has_parse_term' T (@interp_Term).


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^383 - 421
Base: 54 + 5/7
***)

Definition curve : CurveParameters :=
  {|
    sz := 7%nat;
    base := 54 + 5/7;
    bitwidth := 64;
    s := 2^383;
    c := [(1, 421)];
    carry_chains := Some [seq 0 (pred 7); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^141 - 9
Base: 35.25
***)

Definition curve : CurveParameters :=
  {|
    sz := 4%nat;
    base := 35 + 1/4;
    bitwidth := 64;
    s := 2^141;
    c := [(1, 9)];
    carry_chains := Some [seq 0 (pred 4); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^413 - 21
Base: 51.625
***)

Definition curve : CurveParameters :=
  {|
    sz := 8%nat;
    base := 51 + 5/8;
    bitwidth := 64;
    s := 2^413;
    c := [(1, 21)];
    carry_chains := Some [seq 0 (pred 8); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^137 - 13
Base: 22 + 5/6
***)

Definition curve : CurveParameters :=
  {|
    sz := 6%nat;
    base := 22 + 5/6;
    bitwidth := 32;
    s := 2^137;
    c := [(1, 13)];
    carry_chains := Some [seq 0 (pred 6); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^196 - 15
Base: 49
***)

Definition curve : CurveParameters :=
  {|
    sz := 4%nat;
    base := 49;
    bitwidth := 64;
    s := 2^196;
    c := [(1, 15)];
    carry_chains := Some [seq 0 (pred 4); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


(** Sharpened ADT for an expression grammar with parentheses *)
Require Import Coq.Init.Wf Coq.Arith.Wf_nat.
Require Import Coq.Lists.List Coq.Strings.String.
Require Import Coq.omega.Omega.
Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import Fiat.Parsers.ContextFreeGrammar.Core.
Require Import Fiat.Parsers.ContextFreeGrammar.PreNotations.
Require Import Fiat.Parsers.StringLike.Core.
Require Import Fiat.Parsers.StringLike.Properties.
Require Import Coq.Program.Equality.
Require Import Fiat.Common.
Require Import Fiat.Common.StringFacts.
Require Import Fiat.Common.Wf.
Require Import Fiat.Parsers.Splitters.RDPList.
Require Import Fiat.Parsers.BaseTypes.

Set Implicit Arguments.

Inductive length_result := same_length (n : nat) | different_lengths | cyclic_length | not_yet_handled_empty_rule.

Coercion collapse_length_result (l : length_result) : option nat
  := match l with
       | same_length n => Some n
       | _ => None
     end.

Fixpoint length_of_any_production' {Char} (length_of_any_nt : String.string -> length_result)
         (its : production Char) : length_result
  := match its with
       | nil => same_length 0
       | (Terminal _)::xs => match length_of_any_production' length_of_any_nt xs with
                               | same_length n => same_length (S n)
                               | different_lengths => different_lengths
                               | cyclic_length => cyclic_length
                               | not_yet_handled_empty_rule => not_yet_handled_empty_rule
                             end
       | (NonTerminal nt)::xs => match length_of_any_nt nt, length_of_any_production' length_of_any_nt xs with
                                   | same_length n1, same_length n2 => same_length (n1 + n2)
                                   | cyclic_length, _ => cyclic_length
                                   | _, cyclic_length => cyclic_length
                                   | different_lengths, _ => different_lengths
                                   | _, different_lengths => different_lengths
                                   | not_yet_handled_empty_rule, _ => not_yet_handled_empty_rule
                                   | _, not_yet_handled_empty_rule => not_yet_handled_empty_rule
                                 end
     end.

Lemma length_of_any_production'_ext {Char}
      f g
      (ext : forall b, f b = g b)
      b
: @length_of_any_production' Char f b = length_of_any_production' g b.
Proof.
  induction b as [ | x ]; try reflexivity; simpl.
  destruct x; rewrite ?IHb, ?ext; reflexivity.
Qed.

Definition length_of_any_productions'_f
  := (fun x1 x2
      => match x1, x2 with
           | same_length n1, same_length n2 => if EqNat.beq_nat n1 n2 then same_length n1 else different_lengths
           | cyclic_length, _ => cyclic_length
           | _, cyclic_length => cyclic_length
           | _, different_lengths => different_lengths
           | different_lengths, _ => different_lengths
           | not_yet_handled_empty_rule, _ => not_yet_handled_empty_rule
           | _, not_yet_handled_empty_rule => not_yet_handled_empty_rule
         end).

Arguments length_of_any_productions'_f !_ !_ / .

Lemma length_of_any_productions'_f_same_length {n x1 x2}
: length_of_any_productions'_f x1 x2 = same_length n
  <-> (x1 = same_length n /\ x2 = same_length n).
Proof.
  destruct x1, x2; simpl in *;
  repeat match goal with
           | _ => reflexivity
           | [ H : context[if EqNat.beq_nat ?x ?y then _ else _] |- _ ] => destruct (EqNat.beq_nat x y) eqn:?
           | [ |- context[EqNat.beq_nat ?x ?y] ] => destruct (EqNat.beq_nat x y) eqn:?
           | [ H : beq_nat _ _ = true |- _ ] => apply beq_nat_true in H
           | [ H : context[beq_nat ?n ?n] |- _ ] => rewrite <- beq_nat_refl in H
           | _ => progress subst
           | [ H : same_length _ = same_length _ |- _ ] => inversion H; clear H
           | _ => intro
           | [ H : _ /\ _ |- _ ] => destruct H
           | [ |- _ /\ _ ] => split
           | [ |- _ <-> _ ] => split
           | _ => congruence
           | _ => tauto
         end.
Qed.

Lemma length_of_any_productions'_f_same_length_fold_right {n x1 x2}
: fold_right length_of_any_productions'_f x1 x2 = same_length n
  <-> (x1 = same_length n /\ fold_right and True (map (fun k => k = same_length n) x2)).
Proof.
  induction x2; simpl in *; eauto; try tauto.
  rewrite length_of_any_productions'_f_same_length.
  rewrite IHx2.
  tauto.
Qed.

Definition length_of_any_productions' {Char} (length_of_any_nt : String.string -> length_result)
           (prods : productions Char)
: length_result
  := match prods with
       | nil => not_yet_handled_empty_rule
       | p::ps => fold_right
                    length_of_any_productions'_f
                    (length_of_any_production' length_of_any_nt p)
                    (map (length_of_any_production' length_of_any_nt) ps)
     end.

Lemma length_of_any_productions'_ext {Char}
      f g
      (ext : forall b, f b = g b)
      b
: @length_of_any_productions' Char f b = length_of_any_productions' g b.
Proof.
  unfold length_of_any_productions'.
  destruct b as [ | ? b]; trivial; [].
  induction b; try reflexivity; simpl;
  erewrite length_of_any_production'_ext by eassumption; trivial; [].
  edestruct (length_of_any_production' g);
    rewrite IHb; reflexivity.
Qed.

Definition length_of_any_nt_step
           {Char} (G : pregrammar Char)
           (predata := @rdp_list_predata _ G)
           (valid0_len : nat)
           (length_of_any_nt : forall (*valid0_len : nat*) (valid0 : nonterminals_listT),
                                 String.string -> length_result)
           (valid0 : nonterminals_listT)
           (nt : String.string)
: length_result
  := match valid0_len with
       | 0 => different_lengths
       | S valid0_len'
         => if Sumbool.sumbool_of_bool (is_valid_nonterminal valid0 (of_nonterminal nt))
            then length_of_any_productions'
                   (@length_of_any_nt (*valid0_len'*) (remove_nonterminal valid0 (of_nonterminal nt)))
                   (Lookup G nt)
            else different_lengths
     end.

Lemma length_of_any_nt_step_ext {Char G}
      x0 x1 f g
      (ext : forall p b, f p b = g p b)
      b
: @length_of_any_nt_step Char G x0 f x1 b = length_of_any_nt_step x0 g x1 b.
Proof.
  unfold length_of_any_nt_step.
  edestruct Sumbool.sumbool_of_bool; trivial.
  destruct x0; trivial.
  apply length_of_any_productions'_ext; eauto.
Qed.

Definition length_of_any_nt'
           {Char} (G : pregrammar Char)
           (valid0_len : nat)
  : forall (valid0 : nonterminals_listT)
           (nt : String.string),
    length_result
  := nat_rect
       (fun _ => forall (valid0 : nonterminals_listT)
                        (nt : String.string),
            length_result)
       (fun _ _ => different_lengths)
       (@length_of_any_nt_step Char G)
       valid0_len.

Global Arguments length_of_any_nt' _ _ !_ _ _ / .

Definition length_of_any_nt {Char} (G : pregrammar Char)
           initial
: String.string -> length_result
  := @length_of_any_nt' Char G (nonterminals_length initial) initial.

Definition length_of_any {Char} (G : pregrammar Char)
: String.string -> length_result
  := @length_of_any_nt Char G initial_nonterminals_data.

Definition length_of_any_productions {Char} G := @length_of_any_productions' Char (@length_of_any Char G).

Lemma has_only_terminals_parse_of_production_length
      {HSLM : StringLikeMin Ascii.ascii}
      {HSL : StringLike Ascii.ascii}
      {HSLP : StringLikeProperties Ascii.ascii}
      (G : grammar Ascii.ascii) {n}
      f pat
      (H_f : forall nt str n', f nt = same_length n' -> parse_of G str (Lookup G nt) -> length str = n')
      (H : length_of_any_production' f pat = same_length n)
      str
      (p : parse_of_production G str pat)
: length str = n.
Proof.
  revert n H; induction p; simpl in *.
  { congruence. }
  { edestruct (_ : item _).
    { match goal with
        | [ H : context[length_of_any_production' ?f ?p] |- _ ] => revert H; case_eq (length_of_any_production' f p); intros
      end;
      repeat match goal with
               | [ H : ?x = ?x |- _ ] => clear H
               | [ H : ?x = _ :> length_result, H' : context[?x] |- _ ] => rewrite H in H'
               | _ => exfalso; discriminate
               | [ H : same_length _ = same_length _ |- _ ] => inversion H; clear H
               | _ => progress subst
               | [ H : parse_of_item _ _ (Terminal _) |- _ ] => inversion p; clear p
               | [ H : is_true (_ ~= [ _ ])%string_like |- _ ] => apply length_singleton in H
               | [ H : _ |- _ ] => progress rewrite ?take_length, ?drop_length, ?substring_length, ?Plus.plus_0_r, ?NPeano.Nat.sub_0_r, ?NPeano.Nat.add_sub in H
               | [ H : context[min ?x (?y + ?z) - ?z] |- _ ] => rewrite <- (@NPeano.Nat.sub_min_distr_r x (y + z) z) in H
               | [ H : context[min ?x ?y], H' : ?x <= ?y |- _ ] => rewrite (@Min.min_l x y) in H by assumption
               | [ H : context[min ?x ?y], H' : ?y <= ?x |- _ ] => rewrite (@Min.min_r x y) in H by assumption
               | [ H : context[min (?x - ?y) ?x] |- _ ] => rewrite (@Min.min_l (x - y) x) in H by (clear; omega)
               | [ H : forall n, same_length _ = same_length n -> _ |- _ ] => specialize (H _ eq_refl)
               | [ H : context[min _ _] |- _ ] => revert H; apply Min.min_case_strong; intros; omega
             end. }
    { intros.
      match goal with
        | [ H : context[f ?x] |- _ ] => revert H; case_eq (f x); intros
      end;
        match goal with
          | [ H : context[length_of_any_production' ?f ?p] |- _ ] => revert H; case_eq (length_of_any_production' f p); intros
        end;
        repeat match goal with
                 | [ H : ?x = ?x |- _ ] => clear H
                 | [ H : ?x = _ :> length_result, H' : context[?x] |- _ ] => rewrite H in H'
                 | _ => exfalso; discriminate
                 | [ H : same_length _ = same_length _ |- _ ] => inversion H; clear H
                 | _ => progress subst
                 | [ H : forall n, same_length _ = same_length n -> _ |- _ ] => specialize (H _ eq_refl)
                 | _ => progress rewrite ?take_length, ?drop_length, ?substring_length, ?Plus.plus_0_r, ?NPeano.Nat.sub_0_r, ?NPeano.Nat.add_sub
                 | [ |- context[min ?x (?y + ?z) - ?z] ] => rewrite <- (@NPeano.Nat.sub_min_distr_r x (y + z) z)
                 | [ |- context[min (?x - ?y) ?x] ] => rewrite (@Min.min_l (x - y) x) by (clear; omega)
                 | [ H : parse_of_item _ _ (Terminal _) |- _ ] => let p := fresh in rename H into p; dependent destruction p
                 | [ H : parse_of_item _ _ (NonTerminal _) |- _ ] => let p := fresh in rename H into p; dependent destruction p
                 | [ H : parse_of _ _ _ |- _ ] => eapply H_f in H; [ | eassumption.. ]
                 | _ => apply Min.min_case_strong; omega
               end. } }
Qed.

Lemma has_only_terminals_parse_of_length
      {HSLM : StringLikeMin Ascii.ascii}
      {HSL : StringLike Ascii.ascii}
      {HSLP : StringLikeProperties Ascii.ascii}
      (G : pregrammar Ascii.ascii) {n}
      (predata := @rdp_list_predata _ G)
      nt
      (H : length_of_any G nt = same_length n)
      str
      (p : parse_of G str (Lookup G nt))
: length str = n.
Proof.
  unfold length_of_any, length_of_any_nt in H.
  revert nt str n H p.
  match goal with
    | [ |- context[nonterminals_length ?ls] ]
      => set (len := nonterminals_length ls);
        generalize (reflexivity _ : nonterminals_length ls <= len);
        clearbody len;
        generalize ls
  end.
  induction len as [|len IHlen];
    [ intros [|??]; simpl; intros; congruence
    | ].
  intro valid.
  unfold length_of_any_nt'; fold @length_of_any_nt'.
  intros H' nt.
  specialize (IHlen (remove_nonterminal valid (of_nonterminal nt))).
  pose proof (rdp_list_remove_nonterminal_dec valid (of_nonterminal nt)) as H''.
  unfold rdp_list_nonterminals_listT_R, ltof, lt in H''.
  pose proof (fun pf => le_S_n _ _ (transitivity (H'' pf) H')) as H; clear H' H''.
  specialize (fun pf => IHlen (H pf)); clear H.
  unfold length_of_any_nt' in *.
  simpl nat_rect; unfold length_of_any_nt_step at 1; cbv beta zeta.
  edestruct dec; simpl in *;
    [ specialize_by assumption
    | solve [ destruct len; intros; discriminate ] ].
  destruct len; [ solve [ intros; discriminate ] | ].
  generalize dependent (Lookup_string G nt).
  intros.
  unfold length_of_any_productions' in *.
  let p := match goal with H : parse_of _ _ _ |- _ => constr:(H) end in
  let H := fresh in
  rename p into H;
    induction H; simpl in *.
  { match goal with
      | [ H : context[length_of_any_production' ?f ?p] |- _ ] => revert H; case_eq (length_of_any_production' f p); intros
    end;
    repeat match goal with
             | [ H' : rdp_list_is_valid_nonterminal ?x ?nt = true,
                      H : forall y, rdp_list_nonterminals_listT_R y ?x -> _ |- _ ]
               => specialize (fun nt' str0 n' H0 => H _ (@rdp_list_remove_nonterminal_dec _ nt H') n' nt' H0 str0)
             | [ H' : rdp_list_is_valid_nonterminal ?x ?nt = true,
                      H : forall y, nonterminals_listT_R y ?x -> _ |- _ ]
               => specialize (H _ (@rdp_list_remove_nonterminal_dec _ nt H'));
                 let H'' := fresh in
                 rename H into H'';
                   specialize (fun nt' str0 n' H0 => H'' n' nt' H0 str0)
             | [ H : length_of_any_production' _ _ = same_length _ |- _ ] => eapply has_only_terminals_parse_of_production_length in H; [ | eassumption'.. ]
             | _ => reflexivity
             | _ => discriminate
             | _ => progress subst
             | [ H : length_of_any_productions'_f _ _ = same_length _ |- _ ] => apply length_of_any_productions'_f_same_length in H
             | [ H : same_length _ = same_length _ |- _ ] => inversion H; clear H
             | [ H : _ /\ _ |- _ ] => destruct H
             | [ H : _ \/ _ |- _ ] => destruct H; [ (discriminate || congruence) | ]
             | [ H : _ \/ _ |- _ ] => destruct H; [ | (discriminate || congruence) ]
             | [ H : ?x = same_length _, H' : context[?x] |- _ ] => rewrite H in H'
             | [ H : fold_right length_of_any_productions'_f _ _ = same_length _ |- _ ] => apply length_of_any_productions'_f_same_length_fold_right in H
           end. }
  { edestruct (_ : productions _).
    { match goal with
        | [ H : parse_of _ _ [] |- _ ] => inversion H
      end. }
    { repeat match goal with
               | _ => progress simpl in *
               | [ H : length_of_any_productions'_f _ _ = same_length _ |- _ ] => apply length_of_any_productions'_f_same_length in H
               | [ H : _ /\ _ |- _ ] => destruct H
               | [ H : fold_right length_of_any_productions'_f _ _ = same_length _ |- _ ] => apply length_of_any_productions'_f_same_length_fold_right in H
               | [ H : fold_right length_of_any_productions'_f _ _ = same_length _ -> _ |- _ ]
                 => specialize (fun H' => H (proj2 length_of_any_productions'_f_same_length_fold_right H'))
               | _ => progress eauto
             end. } }
Qed.

Lemma has_only_terminals_parse_of_item_length
      {HSLM : StringLikeMin Ascii.ascii}
      {HSL : StringLike Ascii.ascii}
      {HSLP : StringLikeProperties Ascii.ascii}
      (G : pregrammar Ascii.ascii) {n}
      nt
      (H : length_of_any G nt = same_length n)
      str
      (p : parse_of_item G str (NonTerminal nt))
: length str = n.
Proof.
  dependent destruction p.
  eapply has_only_terminals_parse_of_length; eassumption.
Qed.


From Tweetnacl.Libs Require Import Export.
From Tweetnacl.ListsOp Require Import Export.
From stdpp Require Import list.
Require Import ssreflect.

From Tweetnacl.Gen Require Import AMZubSqSel.
From Tweetnacl.Gen Require Import AMZubSqSel_Prop.
From Tweetnacl.Gen Require Import AMZubSqSel_List.
From Tweetnacl.Gen Require Import Get_abcdef.
From Tweetnacl.Gen Require Import abstract_fn_rev.
From Tweetnacl.Gen Require Import ABCDEF.
From Tweetnacl.Low Require Import List16.
From Tweetnacl.Gen Require Import abstract_fn_rev_eq.
From Tweetnacl.Gen Require Import abstract_fn_rev_abcdef.
From Tweetnacl.Low Require Import Constant.
From Tweetnacl.Low Require Import AMZubSqSel_Correct.
From Tweetnacl.Mid Require Import Crypto_Scalarmult.
From Tweetnacl.Low Require Import ScalarMult_rev.
From Tweetnacl.Low Require Import Crypto_Scalarmult_lemmas_Z_List16.
From Tweetnacl.Low Require Import Crypto_Scalarmult_lemmas_List_List16.
From Tweetnacl.Low Require Import Unpack25519.
From Tweetnacl.Low Require Import Pack25519.
From Tweetnacl.Low Require Import Inv25519.
From Tweetnacl.Low Require Import Prep_n.
From Tweetnacl.Low Require Import GetBit.
From Tweetnacl.Mid Require Import Unpack25519.
From Tweetnacl.Mid Require Import Pack25519.
From Tweetnacl.Mid Require Import Inv25519.
From Tweetnacl.Mid Require Import Prep_n.

Open Scope Z.

Section Crypto_Scalarmult_Eq_ac_List.

Context (Mod : Z -> Z).
Context (Z_Ops            : (Ops Z Z) Mod).
Context (List_Z_Ops       : Ops (list Z) (list Z) id).
Context (List_Z_Ops_Prop          : @Ops_List List_Z_Ops).
Context (List_Z_Ops_Prop_Correct  : @Ops_Prop_List_Z Mod List_Z_Ops Z_Ops).
Local Instance List16_Ops         : (Ops (@List16 Z) (List32B) id) := {}.
Proof.
apply A_List16.
apply M_List16.
apply Zub_List16.
apply Sq_List16.
apply C_0_List16.
apply C_1_List16.
apply C_121665_List16.
apply Sel25519_List16.
apply getbit_List32B.
simpl ; reflexivity.
simpl ; reflexivity.
simpl ; reflexivity.
simpl ; reflexivity.
simpl ; reflexivity.
simpl ; reflexivity.
Defined.
Local Instance List16_Z_Eq      : @Ops_Mod_P (@List16 Z) (List32B) Z Mod id List16_Ops Z_Ops := {
P l := (ZofList 16 (List16_to_List l));
P' l := (ZofList 8 (List32_to_List l));
}.
Proof.
- intros [a Ha] [b Hb] ; simpl List16_to_List; rewrite -A_correct; reflexivity.
- intros [a Ha] [b Hb] ; simpl List16_to_List.
  apply mult_GF_Zlengh ; assumption.
- intros [a Ha] [b Hb] ; simpl ; f_equal ; rewrite -Zub_correct; reflexivity.
- intros [a Ha] ; simpl List16_to_List ; apply Sq_GF_Zlengh ; try assumption.
- simpl List16_to_List ; f_equal; rewrite -C_121665_correct ; reflexivity.
- simpl List16_to_List ; f_equal; rewrite -C_0_correct ; reflexivity.
- simpl List16_to_List ; f_equal; rewrite -C_1_correct ; reflexivity.
- intros b [p Hp] [q Hq] ; simpl List16_to_List ; f_equal ; rewrite -Sel25519_correct ; reflexivity.
- intros b [p Hp] ; simpl ; symmetry ; rewrite GetBit_correct ; try assumption ; reflexivity.
Defined.
Local Instance List16_List_Z_Eq : @Ops_Mod_P (List16 Z) (List32B) (list Z) id id List16_Ops List_Z_Ops := {
P := List16_to_List;
P' := List32_to_List
}.
Proof.
intros [] [] ; reflexivity.
intros [] [] ; reflexivity.
intros [] [] ; reflexivity.
intros [] ; reflexivity.
reflexivity.
reflexivity.
reflexivity.
intros b [] [] ; reflexivity.
intros i [] ; reflexivity.
Defined.
Local Lemma abstract_fn_rev_eq_a_Z_List : ∀ (m p : ℤ) (CN : List32B) (L16ONE L16NUL L16UP : List16 ℤ) (Cn Up:list Z) (n u:Z),
  0 ≤ m →
  List16_to_List L16ONE = Low.C_1 ->
  List16_to_List L16NUL = Low.C_0 ->
  List16_to_List L16UP = Up ->
  List32_to_List CN = Cn ->
  ZofList 16 Up = u ->
  ZofList 8 Cn = n ->

  Mod (ZofList 16 (get_a (abstract_fn_rev m p Cn Low.C_1 Up Low.C_0 Low.C_1 Low.C_0 Low.C_0 Up))) =
  Mod (get_a (abstract_fn_rev m p n 1 u 0 1 0 0 u)).
Proof.
  intros m p CN L16ONE L16NUL L16UP Cn Up n u.
  intros Hm.
  intros HL16ONE HL16NUL HL16UP HL32CN.
  intros Hu Hn.
  assert(Heq1:= abstract_fn_rev_eq_a_list List_Z_Ops List_Z_Ops_Prop m p CN L16ONE L16NUL L16UP Cn Up Hm HL16ONE HL16NUL HL16UP HL32CN).
  assert(Heq2:= abstract_fn_rev_eq_a_Z Mod Z_Ops List_Z_Ops List_Z_Ops_Prop
List_Z_Ops_Prop_Correct m p CN L16ONE L16NUL L16UP Cn Up n u Hm HL16ONE HL16NUL HL16UP HL32CN Hu Hn).
  rewrite -Heq1.
  rewrite -Heq2.
  remember (get_a (abstract_fn_rev m p CN L16ONE L16UP L16NUL L16ONE L16NUL L16NUL L16UP)) as K.
  destruct K.
  reflexivity.
Qed.

Local Lemma abstract_fn_rev_eq_c_Z_List : ∀ (m p : ℤ) (CN : List32B) (L16ONE L16NUL L16UP : List16 ℤ) (Cn Up:list Z) (n u:Z),
  0 ≤ m →
  List16_to_List L16ONE = Low.C_1 ->
  List16_to_List L16NUL = Low.C_0 ->
  List16_to_List L16UP = Up ->
  List32_to_List CN = Cn ->
  ZofList 16 Up = u ->
  ZofList 8 Cn = n ->

  Mod (ZofList 16 (get_c (abstract_fn_rev m p Cn Low.C_1 Up Low.C_0 Low.C_1 Low.C_0 Low.C_0 Up))) =
  Mod (get_c (abstract_fn_rev m p n 1 u 0 1 0 0 u)).
Proof.
  intros m p CN L16ONE L16NUL L16UP Cn Up n u.
  intros Hm.
  intros HL16ONE HL16NUL HL16UP HL32CN.
  intros Hu Hn.
  assert(Heq1:= abstract_fn_rev_eq_c_list List_Z_Ops List_Z_Ops_Prop m p CN L16ONE L16NUL L16UP Cn Up Hm HL16ONE HL16NUL HL16UP HL32CN).
  assert(Heq2:= abstract_fn_rev_eq_c_Z Mod Z_Ops List_Z_Ops List_Z_Ops_Prop
List_Z_Ops_Prop_Correct m p CN L16ONE L16NUL L16UP Cn Up n u Hm HL16ONE HL16NUL HL16UP HL32CN Hu Hn).
  rewrite -Heq1.
  rewrite -Heq2.
  remember (get_a (abstract_fn_rev m p CN L16ONE L16UP L16NUL L16ONE L16NUL L16NUL L16UP)) as K.
  destruct K.
  reflexivity.
Qed.

Lemma abstract_fn_rev_eq_List_Z_a: ∀ (m p : ℤ) Cn Up,
  0 ≤ m →
  Zlength Up = 16 ->
  Forall (fun x => 0 <= x < 2^8) Cn ->
  Mod (ZofList 16 (get_a (abstract_fn_rev m p Cn Low.C_1 Up Low.C_0 Low.C_1 Low.C_0 Low.C_0 Up))) =
  Mod (get_a (abstract_fn_rev m p (ZofList 8 Cn) 1 (ZofList 16 Up) 0 1 0 0 (ZofList 16 Up))).
Proof.
  intros m p Cn Up Hm HUp HCn.
  erewrite <- abstract_fn_rev_eq_a_Z_List.
  reflexivity.
  assumption.
  pose(x := Len Low.C_1 Zlength_C_1).
  assert( List16_to_List x = Low.C_1) by reflexivity.
  eassumption.
  pose(x := Len Low.C_0 Zlength_C_0).
  assert( List16_to_List x = Low.C_0) by reflexivity.
  eassumption.
  pose(x := Len Up HUp).
  assert( List16_to_List x = Up) by reflexivity.
  eassumption.
  pose(x := L32B Cn HCn).
  assert( List32_to_List x = Cn) by reflexivity.
  eassumption.
  reflexivity.
  reflexivity.
Qed.

Lemma abstract_fn_rev_eq_List_Z_c: ∀ (m p : ℤ) Cn Up,
  0 ≤ m →
  Zlength Up = 16 ->
  Forall (fun x => 0 <= x < 2^8) Cn ->
  Mod (ZofList 16 (get_c (abstract_fn_rev m p Cn Low.C_1 Up Low.C_0 Low.C_1 Low.C_0 Low.C_0 Up))) =
  Mod (get_c (abstract_fn_rev m p (ZofList 8 Cn) 1 (ZofList 16 Up) 0 1 0 0 (ZofList 16 Up))).
Proof.
  intros m p Cn Up Hm HUp HCn.
  erewrite <- abstract_fn_rev_eq_c_Z_List.
  reflexivity.
  assumption.
  pose(x := Len Low.C_1 Zlength_C_1).
  assert( List16_to_List x = Low.C_1) by reflexivity.
  eassumption.
  pose(x := Len Low.C_0 Zlength_C_0).
  assert( List16_to_List x = Low.C_0) by reflexivity.
  eassumption.
  pose(x := Len Up HUp).
  assert( List16_to_List x = Up) by reflexivity.
  eassumption.
  pose(x := L32B Cn HCn).
  assert( List32_to_List x = Cn) by reflexivity.
  eassumption.
  reflexivity.
  reflexivity.
Qed.

End Crypto_Scalarmult_Eq_ac_List.