Require Import Arith Lia.
Require Import List Bool.
Require Import FunInd.

Require Import TPPMark2019.Value.
Require Import TPPMark2019.Tape.
Require Import TPPMark2019.CTM.
Require Import TPPMark2019.Util.
Require Import TPPMark2019.Clearer.

Set Implicit Arguments.

Ltac easy_lia := easy || lia.

Section Clear.
  Variable V : Type.
  Context `{ValueClass: Value.class V}.
  Variable T : Type.
  Context `{TapeOps: Tape.ops T V}.
  Context `{TapeSpec: Tape.spec T V}.
  Local Notation clearer := (@clearer V _ _).

  Definition measure (tms :CTM.TMState State T) : nat :=
    Tape.size (CTM.tape tms) -
    List.count_occ Value.eq_dec (Tape.to_list (CTM.tape tms)) Value.zero.

  Definition NthCondition {A} (P : nat -> A -> Prop) (l : list A) := forall i v, List.nth_error l i = Some v -> P i v.

  Lemma NthCondition_elem {A} : forall (P : nat -> A -> Prop) (l : list A),
      NthCondition P l -> forall i, i < length l -> exists v, List.nth_error l i = Some v /\ P i v.
  Proof.
    intros P l HNC i Hlt.
    destruct (nth_error l i) as [v|] eqn: Heqv.
    - exists v.
      split; auto.
    - rewrite List.nth_error_None in Heqv.
      lia.
  Qed.

  Lemma NthCondition' {A} (P : nat -> A -> Prop) (l : list A) :
    (forall i v, i < length l -> List.nth_error l i = Some v -> P i v) -> NthCondition P l.
  Proof.
    intro Hi.
    intros i v Heq.
    apply Hi; auto.
    apply List.nth_error_Some.
    congruence.
  Qed.

  Definition zero_except_ix1 : list V -> Prop :=
    NthCondition
      (fun i v =>
         if i =? 1
         then v = Value.one
         else v = Value.zero).

  Definition HeadPreCondition (state : option State) (h : nat) :=
    match state with
    | Some Init0 => h = 0
    | Some Init1 => h = 1
    | Some Clear => h <> 1
    | Some Back => h <> 0
    | Some Look => h = 0
    | Some Skip => h = 1
    | Some Finish => h = 1
    | None => True
    end.

  Definition TapePreCondition (state : option State) (tape : T) :=
    let l := Tape.to_list tape in
    match state with
    | Some Init0 => True
    | Some Init1 =>
      NthCondition (fun i v => if i =? 0 then v = Value.one else True) l
    | Some Clear =>
      NthCondition (fun i v =>
                      if (i =? 0) || (i =? 1)
                      then v = Value.one
                      else if (Tape.head tape =? 0) || (i <? Tape.head tape)
                           then v = Value.zero
                           else True) l
    | Some Back =>
      (NthCondition
         (fun i v =>
            if (i =? 0) || (i =? 1)
            then v = Value.one
            else if i <=? Tape.head tape
                 then v = Value.zero
                 else True) l \/
       zero_except_ix1 l)
    | Some Look =>
      (NthCondition
         (fun i v =>
            if (i =? 0) || (i =? 1)
            then v = Value.one
            else True) l \/ zero_except_ix1 l)
    | Some Skip =>
      NthCondition
        (fun i v =>
           if (i =? 0) || (i =? 1)
           then v = Value.one
           else True) l
    | Some Finish =>
      zero_except_ix1 l
    | None =>
      forall v, In v l -> v = Value.zero
    end.

  Definition PostCondition (tms tms': CTM.TMState State T) : Prop :=
    match CTM.state tms with
    | Some Init0 => True
    | Some Init1 => True
    | Some Clear =>
      match CTM.state tms' with
      | Some Back => measure tms' < measure tms
      | _ => measure tms' <= measure tms
      end
    | Some Back =>
      measure tms' = measure tms
    | Some Look =>
      measure tms' = measure tms
    | Some Skip =>
      measure tms' = measure tms
    | Some Finish => True
    | None => True
    end.

  Definition Valid (tms : CTM.TMState State T) :=
    let tape := CTM.tape tms in
    let state := CTM.state tms in
    1 < Tape.size tape /\ HeadPreCondition state (Tape.head tape) /\ TapePreCondition state tape.

  Hint Rewrite
       Tape.read_spec Tape.write_head
       Tape.move_right_list Tape.move_right_head
       Tape.move_left_list Tape.move_left_head
       Tape.write_size Tape.move_left_size Tape.move_right_size
       Tape.write_spec
    : tape.

  Lemma start_Valid : forall tape,
      1 < Tape.size tape -> Tape.head tape = 0 -> Valid (CTM.start clearer tape).
  Proof.
    intros.
    unfold Valid, CTM.start.
    simpl.
    auto.
  Qed.

  Lemma mod0_large : forall n m, n <> 0 -> m <> 0 -> n mod m = 0 -> m <= n.
  Proof.
    intros n m Hn Hm Hmod.
    rewrite Nat.mod_divide in Hmod; auto.
    destruct Hmod as [k ->].
    assert (k <> 0); subst; nia.
  Qed.

  Lemma mod_S_inj : forall n m x, 1 < m -> S n mod m = S x -> n mod m = x.
  Proof.
    intros n m x Hne Heq.
    replace (S n) with (1 + n) in Heq; auto.
    rewrite Nat.add_mod in Heq; auto with zarith.
    rewrite Nat.mod_1_l in *; auto.
    rewrite Nat.mod_small in Heq; auto.
    pose proof (Nat.mod_upper_bound n m) as Hub.
    cut (1 + (n mod m) <> m); try easy_lia.
    intro Heq'.
    rewrite Heq' in *.
    rewrite Nat.mod_same in *; easy_lia.
  Qed.

  Lemma step_HeadPreCondition : forall tms tms',
      tms' = CTM.step clearer tms ->
      Valid tms -> HeadPreCondition (CTM.state tms') (Tape.head (CTM.tape tms')).
  Proof.
    intros tms tms' Heq_tms' HValid.
    destruct HValid as (Hsize & HHPC & HTPC).
    destruct tms as [tape state] eqn: Heq_tms.
    simpl in *.
    assert (Tape.size tape <> 0) as Htnonempty; try easy_lia.
    destruct state as [state | ]; simpl in Heq_tms'; [| rewrite Heq_tms'; simpl; auto].
    remember (Tape.read tape) as v eqn: Hdef_v.
    pose proof (Tape.read_spec tape Htnonempty) as Hread.
    functional induction (clearer_trans state v); rewrite Heq_tms'; simpl.
    all: unfold HeadPreCondition, TapePreCondition, zero_except_ix1 in *.
    all: repeat autorewrite with tape; auto.
    all: try rewrite HHPC.
    all: destruct_cmpbs.
    all: destruct (Tape.head tape) as [|h] eqn:Heqh; try easy_lia.
    - apply HTPC in Hread.
      congruence.
    - intro. subst.
      apply Value.zero_ne_one.
      destruct HTPC as [HTPC | HTPC]; apply HTPC in Hread; congruence.
    - destruct h as [|h]; auto.
      destruct HTPC as [HTPC | HTPC]; apply HTPC in Hread; simpl in Hread; try congruence.
      rewrite Nat.leb_refl in Hread.
      congruence.
  Qed.

  Lemma step_TapePreCondition : forall tms tms',
      tms' = CTM.step clearer tms ->
      Valid tms -> TapePreCondition (CTM.state tms') (CTM.tape tms').
  Proof.
    intros tms tms' Heq_tms' HValid.
    pose proof (@step_HeadPreCondition tms tms' Heq_tms' HValid) as Hhead.
    destruct HValid as (Hsize & HHPC & HTPC).
    destruct tms as [tape state] eqn: Heq_tms.

    simpl in Hsize.
    assert (Tape.size tape <> 0) as Htnonempty; try solve [simpl in *; easy_lia].
    pose proof (Tape.read_spec tape Htnonempty) as Hread.
    revert Hhead.
    pose proof Heq_tms' as Hdef_tms'.
    destruct state as [state | ]; simpl in Heq_tms'; [| rewrite Heq_tms'; simpl; auto].
    remember (Tape.read tape) as v eqn: Hdef_v.
    pose proof (CTM.step_tape_size clearer tms) as Hsize'.
    rewrite Heq_tms, <- Hdef_tms' in Hsize'.
    simpl in Hsize'.
    cut_hyp Hsize'; auto.
    rewrite <- Heq_tms in Hdef_tms'.
    functional induction (clearer_trans state v).
    all: rewrite Heq_tms' in Hsize' |- *.
    all: unfold HeadPreCondition, TapePreCondition, zero_except_ix1 in *; simpl in *.
    all: try apply HTPC in Hread.
    all: repeat autorewrite with tape; auto.
    all: intro Hhead.
    all: try rewrite (Tape.read_write_id tape Htnonempty eq_refl).
    - intros i v. autorewrite with tape; auto.
      destruct_cmpbs; congruence.
    - rewrite HHPC in *.
      intros i v Hread'.
      autorewrite with tape in Hread'; auto.
      rewrite HHPC in Hread'.
      destruct (Nat.eqb_spec i 0), (Nat.eqb_spec i 1); try congruence.
      + simpl in *.
        apply HTPC in Hread'.
        now subst.
      + pose proof (HTPC _ _ Hread') as Hread''.
        destruct (Nat.eqb_spec i 0); try congruence.
        destruct (Nat.eqb_spec 2 (Tape.size tape)) as [Heq|]; simpl in *; auto.
        * apply Tape.nth_error_Some in Hread'; auto.
          easy_lia.
        * destruct (Nat.ltb_spec i 2); easy_lia.
    - destruct (Tape.head tape) as [|h] eqn: Heqh; [right | left];
        intros i v; autorewrite with tape; auto; destruct_cmpbs; simpl in *; try easy_lia;
          intros Hread'%HTPC; subst; simpl in Hread'; destruct_cmpbs; easy_lia.
    - intros i v Hread'.
      pose proof (Tape.nth_error_Some _ _ Hread') as Hlti.
      autorewrite with tape in Hread', Hlti; auto.
      destruct (Nat.eqb_spec i (Tape.head tape)) as [Heqi |].
      + rewrite <- Heqi in *.
        destruct (i =? 0), (i =? 1); simpl in Hread; simpl; try congruence.
        destruct_cmpbs; simpl; auto.
      + apply HTPC in Hread'.
        destruct (i =? 0), (i =? 1); simpl in Hread'; auto.
        destruct_cmpbs; simpl in *; easy_lia.
    - destruct HTPC as [HTPC | HTPC]; [left | right]; auto.
      intros i v Hread'.
      apply HTPC in Hread'.
      destruct_cmpbs; simpl in *; auto.
      destruct (Tape.head tape); try easy_lia.
    - destruct HTPC as [HTPC | HTPC]; [left | right]; auto.
      intros i v Hread'.
      apply HTPC in Hread'.
      destruct orb; auto.
    - destruct HTPC as [HTPC | HTPC]; auto.
      exfalso.
      pose proof (Tape.read_spec tape) as Hread'.
      apply HTPC in Hread'; auto.
      rewrite HHPC, Nat.eqb_refl in Hread'.
      simpl in Hread'.
      pose proof (Value.zero_ne_one); congruence.
    - destruct HTPC as [HTPC | HTPC]; auto.
      pose proof (Tape.read_spec tape) as Hread'.
      rewrite HHPC in Hread'.
      apply HTPC in Hread'; congruence.
    - intros i v Hread'.
      pose proof (Tape.nth_error_Some _ _ Hread') as Hlti.
      apply HTPC in Hread'.
      destruct_cmpbs; simpl in *; easy_lia.
    - intros v (i & Hread')%In_nth_error.
      autorewrite with tape in Hread'; auto.
      destruct_cmpbs.
      apply HTPC in Hread'.
      destruct_cmpbs.
  Qed.

  Lemma step_Valid : forall tms, Valid tms -> Valid (CTM.step clearer tms).
  Proof.
    intros tms HValid.
    split.
    - destruct HValid as [Hsize _].
      rewrite CTM.step_tape_size; auto with zarith.
    - eauto using step_HeadPreCondition, step_TapePreCondition.
  Qed.

  Lemma steps_Valid : forall n tms, Valid tms -> Valid (CTM.steps n clearer tms).
  Proof.
    induction n; intros; simpl; auto using step_Valid.
  Qed.

  Lemma sub_mono : forall x y z, y < z <= x -> x - z < x - y.
  Proof.
    intros.
    easy_lia.
  Qed.

  Lemma count_occ_length : forall A dec (xs : list A) a, count_occ dec xs a <= length xs.
  Proof.
    intros.
    induction xs; simpl; auto.
    destruct dec; subst; auto.
    easy_lia.
  Qed.

  Lemma step_PostCondition : forall tms, Valid tms -> PostCondition tms (CTM.step clearer tms).
  Proof.
    intros [tape state] HV.
    unfold Valid in *.
    assert (Tape.size tape <> 0) as Hnonempty. {
      simpl in *.
      auto with zarith.
    }

    destruct HV as [Hsz HPC].
    simpl in *.
    destruct state eqn: Hstate; [|simpl in *; auto]; try solve [intuition].
    remember (Tape.read tape) as v.
    functional induction (clearer_trans s v); unfold PostCondition in *; simpl in *; auto; unfold measure; simpl;
      try solve [repeat autorewrite with tape; auto; rewrite Tape.read_write_id; auto].
    - repeat autorewrite with tape; auto.
      pose proof (@Tape.write_count_occ_gt T V _ _ _ Value.eq_dec tape Value.zero) as Hgt.
      cut_hyp Hgt.
      + apply sub_mono.
        split.
        * apply Hgt.
          pose proof Value.zero_ne_one; congruence.
        * rewrite <- Tape.write_size with (v := Value.zero) (tape := tape); auto.
          rewrite Tape.to_list_size.
          apply count_occ_length.
      + pose proof Value.zero_ne_one.
        congruence.
    - repeat autorewrite with tape; auto.
      pose proof (Tape.write_count_occ_ge Value.eq_dec tape Value.zero).
      easy_lia.
  Qed.

  Lemma look_unreachable_from_finish_halt :
    forall n tms,
      CTM.state (CTM.steps n clearer tms) = Some Look ->
      match CTM.state tms with
      | Some Finish | None => False
      | _ => True
      end.
  Proof.
    induction n.
    - simpl.
      now intros tms ->.
    - intros tms.
      simpl.
      intro Hstate.
      remember (CTM.step clearer tms) as tms' eqn: Heqtms'.
      destruct tms as [tape state].
      simpl in *.
      destruct state.
      + functional induction (clearer_trans s (Tape.read tape)); auto.
        specialize (IHn tms' Hstate).
        now subst.
      + specialize (IHn tms' Hstate).
        now subst.
  Qed.

  Definition Trans1 (s : State) (s' : option State) : Prop :=
    exists v,
      let '(_, _, s'') := clearer_trans s v in
      s' = s''.

  Ltac solve_trans1 :=
    pose proof Value.zero_ne_one;
    unfold Trans1; (exists Value.zero) + (exists Value.one); simpl; try destruct Value.eq_dec; congruence.

  Definition Trans1_dec : forall s s', {Trans1 s s'} + {~Trans1 s s'}.
    intros.
    destruct s' as [s' |].
    - destruct s, s';
        try solve [left; solve_trans1];
        try solve[
              right; unfold Trans1; intros [v Hv]; simpl in Hv; repeat destruct Value.eq_dec in Hv; congruence
            ].
    - destruct s;
        try solve [left; solve_trans1];
        try solve[
              right; unfold Trans1; intros [v Hv]; simpl in Hv; repeat destruct Value.eq_dec in Hv; congruence
            ].
  Defined.

  Ltac solve_trans v :=
    match goal with
    | |- exists _, Trans1 _ _ /\ Some (?x) = _ /\ _ <> _ =>
      exists (Some x); split;
      [solve_trans1|]; split; try congruence
                                              (*[unfold Trans1; exists v; auto|]; split; try congruence*)
    | |- exists _, Trans1 _ _ /\ None = _ /\ _ <> _ => exists None;
                                    split; [unfold Trans1; exists v; auto|]; split; try congruence

    end.

  Lemma state_escape :
    forall tms,
      Valid tms ->
      match CTM.state tms with
      | Some s => exists n s', Trans1 s s' /\ CTM.state (CTM.steps n clearer tms) = s' /\ s' <> CTM.state tms
      | _ => True
      end.
  Proof.
    pose proof Value.zero_ne_one as Hzneo.
    intros tms HValid.
    destruct tms as [tape state].
    assert (Tape.size tape <> 0) as Hnonempty. {
      unfold Valid in *. simpl in *. auto with zarith.
    }
    simpl in *.
    destruct state as [state | ]; auto.
    destruct state; try solve [ exists 1; simpl; solve_trans Value.zero].
    - remember (Tape.head tape) as h eqn: Heqh.
      remember (Tape.size tape) as sz eqn: Heqsz.
      revert tape HValid Heqh Heqsz.
      induction h as [h IH] using (well_founded_induction (Nat.gt_wf sz)).
      intros tape HValid Heqh Heqsz.
      remember {| CTM.tape := tape; CTM.state := Some Clear |} as tms eqn: Heqtms.
      remember (CTM.step clearer tms) as tms' eqn: Heqtms'def.
      pose proof Heqtms'def as Heqtms'.
      rewrite Heqtms in Heqtms'.
      simpl in Heqtms'.
      destruct Value.eq_dec in Heqtms'.
      + exists 1, (Some Back).
        rewrite CTM.steps_1, <- Heqtms'def, Heqtms'. simpl.
        repeat split; try congruence. solve_trans1.
      + pose proof (step_Valid HValid) as HValid'.
        unfold Valid, HeadPreCondition, TapePreCondition in HValid;
          rewrite Heqtms in HValid; simpl in *.
        destruct HValid as (Hsize & Hhead & Hi).
        destruct (Nat.eq_dec h (sz - 1)).
        * specialize (IH 0).
          exists 2.
          simpl. rewrite <- Heqtms'def, Heqtms'. simpl.
          destruct Value.eq_dec; simpl; try discriminate.
          -- exists (Some Back).
             repeat split; try congruence. solve_trans1.
          -- exfalso.
             pose proof (Tape.read_spec (Tape.move_right (Tape.write Value.zero tape))) as Hread'.
             autorewrite with tape in Hread'; autorewrite with tape; try congruence.
             destruct_cmpbs.
             apply Hi in Hread'; congruence.
        * assert (Tape.head (CTM.tape tms') = S h) as Hheadeq. {
            rewrite Heqtms'.
            simpl.
            repeat autorewrite with tape; auto with zarith.
            destruct_cmpbs.
          }
          specialize (IH (S h)).
          cut_hyp IH.
          -- specialize (IH (CTM.tape tms')).
             destruct IH as [k IHk]; auto.
             ++ rewrite <- Heqtms'def in HValid'.
                clear Heqtms'def. subst. simpl in *.
                assumption.
             ++ subst. simpl. destruct Value.eq_dec; try congruence. simpl.
                repeat autorewrite with tape; auto with zarith.
             ++ exists (S k).
                simpl. rewrite <- Heqtms'def. clear Heqtms'def. subst. simpl in *.
                assumption.
          -- split; auto.
             rewrite <- Hheadeq, Heqtms'. simpl. subst.
             repeat autorewrite with tape; auto with zarith.
             destruct_cmpbs.
             apply Nat.lt_le_incl.
             pose proof (Tape.head_spec tape).
             auto with zarith.
    - remember (Tape.head tape) as h.
      revert tape Hnonempty HValid Heqh.
      induction h as [|h]; intros tape Hnonempty HValid Heqh.
      + unfold Valid, HeadPreCondition, TapePreCondition in HValid; simpl in HValid.
        exists 1, (Some Look).
        easy_lia.
      + remember {| CTM.tape := tape; CTM.state := Some Back |} as tms eqn: Htms.
        remember (CTM.step clearer tms) as tms'.
        specialize (IHh (CTM.tape tms')).
        destruct h.
        * exists 1.
          simpl.
          rewrite Htms.
          simpl.
          destruct Value.eq_dec; simpl; try congruence.
          -- exfalso.
             unfold Valid, HeadPreCondition, TapePreCondition in HValid; rewrite Htms in *;
               simpl in HValid.
             unfold zero_except_ix1 in HValid.
             pose proof Value.zero_ne_one.
             pose proof (Tape.read_spec tape) as Hread.
             destruct HValid as (_ & _ & [HNC | HNC]); apply HNC in Hread; auto;
               rewrite <- Heqh, Nat.eqb_refl, ?orb_true_r in Hread; congruence.
          -- exists (Some Look).
             repeat split; try congruence || solve_trans1.
        * pose proof (step_Valid HValid) as HValid'.
          rewrite <- Heqtms' in HValid'.
          rewrite Htms in *.
          simpl in Heqtms'.
          destruct Value.eq_dec.
          -- destruct IHh as [n Hn].
             ++ subst. simpl. now autorewrite with tape.
             ++ subst. now simpl.
             ++ subst. simpl CTM.tape. rewrite Tape.move_left_head.
                ** rewrite Tape.write_head.
                   now rewrite <- Heqh.
                ** unfold Valid in HValid.
                   simpl in HValid.
                   rewrite Tape.write_size; auto with zarith.
             ++ exists (S n).
                rewrite <- Htms. simpl CTM.steps. rewrite Htms. simpl.
                destruct Value.eq_dec; try congruence.
                subst. assumption.
          -- unfold Valid, HeadPreCondition, TapePreCondition in HValid; simpl in HValid.
             cut (Tape.read tape = Value.zero); try congruence.
             pose proof (Tape.read_spec tape) as Hread.
             cut_hyp Hread; auto with zarith.
             rewrite <- Heqh in *.
             destruct HValid as (_ & _ & [Hi | Hi]); apply Hi in Hread; auto.
             destruct_cmpbs. easy_lia.
    - exists 1.
      simpl.
      destruct Value.eq_dec; simpl.
      + exists (Some Finish).
        repeat split; congruence || solve_trans1.
      + exists (Some Skip).
        repeat split; congruence || solve_trans1.
  Qed.

  Definition StateOrder (s' s : option State) :=
    match s with
    | None => False
    | Some s =>
      match s' with
      | Some Look => False
      | _ => Trans1 s s' /\ s' <> Some s
      end
    end.

  Lemma StateOrder_dec : forall s' s, {StateOrder s' s} + {~StateOrder s' s}.
  Proof.
    intros.
    destruct s as [s|]; auto.
    remember (Trans1_dec s s') as dec.
    destruct s' as [s' |].
    - unfold StateOrder.
      destruct s, s'.
      all: destruct dec; try congruence.
      all: try solve [right; destruct 1; auto; congruence].
      all: left; split; try congruence; tauto.
    - simpl.
      destruct s.
      all: destruct dec; try congruence.
      all: try solve [right; destruct 1; auto; congruence].
      all: left; split; try congruence; tauto.
  Defined.

  Ltac solve_SO_acc :=
    match goal with
    | |- Acc StateOrder ?s =>
      let y := fresh in
      constructor;
      intro y;
      remember (StateOrder_dec y s) as dec eqn:Heqdec;
      destruct y as [y|]; try tauto;
      destruct y; simpl in Heqdec; destruct dec; try congruence
    end.

  Lemma wf_StateOrder : well_founded StateOrder.
  Proof.
    unfold well_founded.
    intros s.
    assert (Acc StateOrder None). {
      constructor.
      simpl.
      tauto.
    }
    assert (Acc StateOrder (Some Finish)). {
      solve_SO_acc.
    }
    assert (Acc StateOrder (Some Back)). {
      solve_SO_acc.
    }
    assert (Acc StateOrder (Some Clear)). {
      solve_SO_acc.
    }
    assert (Acc StateOrder (Some Skip)). {
      solve_SO_acc.
    }
    assert (Acc StateOrder (Some Look)). {
      solve_SO_acc.
    }
    assert (Acc StateOrder (Some Init1)). {
      solve_SO_acc.
    }
    assert (Acc StateOrder (Some Init0)). {
      solve_SO_acc.
    }
    destruct s as [s|]; auto.
    destruct s; auto.
  Qed.

  Lemma look_or_halt :
    forall tms, Valid tms -> exists n,
        match CTM.state (CTM.steps (S n) clearer tms) with
        | None | Some Look => True
        | _ => False
        end.
  Proof.
    intro tms.
    remember (CTM.state tms) as state eqn: Heqstate.
    revert tms Heqstate.
    induction state as [state IH] using (well_founded_induction wf_StateOrder).
    intros tms Heqstate HValid.
    destruct tms as [tape state'] eqn: Htms_def. rewrite <- Htms_def in *.
    pose proof state_escape as He.
    specialize (He tms HValid). rewrite <- Heqstate in He.
    destruct state as [state|].
    {
      destruct He as (n & s' & HT & Heq & Hneq).
      destruct n as [| n].
      - simpl in Heq.
        congruence.
      - destruct s' as [s' |].
        + destruct (State_eq_dec s' Look).
          * exists n.
            rewrite Heq.
            now subst.
          * specialize (IH (Some s')).
            cut_hyp IH.
            -- specialize (IH (CTM.steps (S n) clearer tms)).
               cut_hyp IH; auto.
               cut_hyp IH; auto using steps_Valid.
               destruct IH as [m IH].
               rewrite CTM.steps_add in IH.
               simpl in IH.
               exists (m + S n).
               assumption.
            -- unfold StateOrder.
               destruct s'; auto.
        + exists n.
          now rewrite Heq.
    } {
      exists 0.
      subst. simpl in *.
      now subst.
    }
  Qed.

  Lemma measure_decrease :
    forall n tms tms',
      Valid tms ->
      tms' = CTM.steps (S n) clearer tms ->
      CTM.state tms' = Some Look ->
      match CTM.state tms with
      | Some Look | Some Skip | Some Clear => measure tms' < measure tms
      | Some Back => measure tms' <= measure tms
      | _ => True
      end.
  Proof.
    induction n; intros tms tms' HValid Htms' Hstate.
    {
      pose proof (step_PostCondition HValid) as HPost.
      simpl in *.
      rewrite <- Htms' in *.
      destruct tms as [tape state].
      simpl in *.
      remember (Tape.read tape) as v eqn: Heqnv.
      destruct state as [state|]; auto.
      functional induction (clearer_trans state v);
        rewrite Htms' in *; clear tms' Htms'; simpl in *; try discriminate; auto.
      apply Nat.eq_le_incl.
      auto.
    } {
      pose proof (step_PostCondition HValid) as HPost.
      simpl in Htms'.
      simpl in *.
      specialize (IHn (CTM.step clearer tms) tms').
      repeat (cut_hyp IHn; auto using step_Valid).
      remember (CTM.step clearer tms) as tms_next eqn: Hnext in *.
      destruct tms as [tape state].
      simpl in *.
      remember (Tape.read tape) as v eqn: Heqnv.
      destruct state as [state|]; auto.
      functional induction (clearer_trans state v); auto.
      all: rewrite Hnext in IHn; simpl in IHn.
      all: try rewrite <- Hnext in IHn.
      all: rewrite Hnext in HPost; unfold PostCondition in HPost; simpl in HPost.
      all: rewrite <- Hnext in HPost.
      all: auto with zarith.
      exfalso.
      pose proof (look_unreachable_from_finish_halt (S n) tms_next) as Hur.
      cut_hyp Hur; simpl.
      - now subst.
      - congruence.
    }
  Qed.

  Lemma look_halts : forall tms,
      Valid tms ->
      CTM.state tms = Some Look ->
      CTM.Halts clearer tms.
  Proof.
    induction tms as [tms IH] using (induction_ltof1 _ measure).
    intros HValid HLook.
    destruct (look_or_halt HValid) as [n Hn].
    remember (CTM.steps (S n) clearer tms) as tms' eqn: Hdeftms'.
    specialize (IH tms').
    destruct tms' as [tape' state'] eqn: Heqtms'. rewrite <- Heqtms' in *.
    rewrite Heqtms' in Hn.
    destruct state' as [state' |].
    - destruct state'; simpl in Hn; try tauto.
      cut_hyp IH.
      + rewrite CTM.Halts_steps in *.
        destruct IH as [m Hm].
        * rewrite Hdeftms'.
          apply steps_Valid.
          assumption.
        * now subst.
        * rewrite Hdeftms', CTM.steps_add in Hm.
          eauto.
      + pose proof (@measure_decrease n tms tms' HValid Hdeftms') as Hlt.
        cut_hyp Hlt.
        * now rewrite HLook in Hlt.
        * subst; auto.
    - rewrite CTM.Halts_steps.
      exists (S n).
      now rewrite <- Hdeftms', Heqtms'.
  Qed.

  Lemma valid_clearer_halt : forall tms,
      Valid tms ->
      CTM.Halts clearer tms.
  Proof.
    intros tms HValid.
    destruct (look_or_halt HValid) as [n Hn].
    destruct (CTM.state (CTM.steps (S n) clearer tms)) as [state|] eqn: Hstate.
    - destruct state; try tauto.
      pose proof (@look_halts (CTM.steps (S n) clearer tms)) as HHalt.
      cut_hyp HHalt; auto using steps_Valid.
      rewrite CTM.Halts_steps in *.
      destruct HHalt as [m Hm]; auto.
      rewrite CTM.steps_add in Hm.
      eauto.
    - rewrite CTM.Halts_steps.
      eauto.
  Qed.

  Theorem clear_and_halt :
    forall tape : T,
      1 < Tape.size tape -> Tape.head tape = 0 ->
      exists tape', CTM.HaltWith clearer tape tape' /\ (forall v, In v (Tape.to_list tape') -> v = Value.zero).
  Proof.
    intro tape.
    intros Hsize Hhead.
    pose proof (start_Valid _ Hsize Hhead) as HValid.
    pose proof (valid_clearer_halt HValid) as HHalt.
    rewrite <- CTM.HaltWith_Halts in HHalt.
    destruct HHalt as [tape' Htape'].
    exists tape'.
    split; auto.
    intros v Hv.
    unfold CTM.HaltWith in Htape'.
    destruct Htape' as [n Hn].
    pose proof (steps_Valid n HValid) as HValid'.
    rewrite Hn in HValid'.
    unfold Valid, HeadPreCondition, TapePreCondition in HValid'; simpl in HValid'.
    intuition.
  Qed.
End Clear.


From Coq Require Import
  Lia Nat VectorDef VectorEq ProofIrrelevance FunctionalExtensionality.
Import VectorNotations.
From TinyRAM.Utils Require Import
  Vectors BitVectors Fin Arith.
Import PeanoNat.Nat(log2_up, ltb_lt).
From TinyRAM.Machine Require Import
  Parameters Words.

Module TinyRAMCoding (Params : TinyRAMParameters).
  Module TRWords := TinyRAMWords Params.
  Import TRWords.
  Export TRWords.

  Definition paddingSize := wordSize - 6 - 2 * log2_up registerCount.

  Theorem interpSplitLemLeft :
    wordSize =
      5 + 1 + (log2_up registerCount) + (log2_up registerCount) +
      paddingSize.
    assert (6 + 2 * log2_up registerCount <= wordSize).
    { apply encodingAxiom. }
    unfold paddingSize; lia.
  Qed.

  Lemma interpSplitLemRight :
    wordSize =
    5 + (1 + ((log2_up registerCount) + ((log2_up registerCount) + paddingSize))).
  Proof.
    rewrite interpSplitLemLeft.
    lia.
  Qed.

  Definition interpSplit : Word ->
    (*"""
    Field #1. This field stores the instruction's opcode,
              which consists of 5 = (log2_up 29) bits.
    """*)
    t bool 5 *
    (*"""
    Field #2. This field is a bit that is 0 if A is a
              register name and 1 if A is an immediate value.
    """*)
    bool *
    (*"""
    Field #3. This field stores a register name operand, which consists
              of (log2_up [registerCount]) bits. It is all 0's when not
              used. This is the name of the instruction's destination
              register (i.e. the one to be modified) if any.
    """*)
    t bool (log2_up registerCount) *
    (*"""
    Field #4. This field stores a register name operand, which consists
              of (log2_up [registerCount]) bits. It is all 0's when not
              used. This is the name of a register operand (if any) that
              will *not* be modified by the instruction.
    """*)
    t bool (log2_up registerCount) *
    (*"""
    Field #5. This field consists of padding with any sequence of
              W - 6 - 2|K| bits, so that the first five fields fit exactly
              in a string of W bits.
    """*)
    t bool paddingSize.
    intro w.
    unfold Word in w.
    rewrite interpSplitLemLeft in w.
    apply VectorDef.splitat in w; destruct w as [w f5].
    split. 2: { exact f5. }
    apply VectorDef.splitat in w; destruct w as [w f4].
    split. 2: { exact f4. }
    apply VectorDef.splitat in w; destruct w as [w f3].
    split. 2: { exact f3. }
    apply VectorDef.splitat in w; destruct w as [f1 f2].
    split. { exact f1. }
    destruct (vector_cons_split f2) as [b _].
    exact b.
  Defined.

  Theorem interpSplit_eval :
    forall (code : t bool 5)
           (b : bool)
           (ri rj : t bool (log2_up registerCount))
           (padding : t bool paddingSize),
    interpSplit (cast (code ++ [b] ++ ri ++ rj ++ padding
    ) (eq_sym interpSplitLemRight)) = (code, b, ri, rj, padding).
  Proof.
    intros code b ri rj padding.
    unfold interpSplit.
    replace (eq_rect _ _ _ _ _)
        with ((((code ++ [b]) ++ ri) ++ rj) ++ padding).
    { repeat rewrite VectorSpec.splitat_append; reflexivity. }
    rewrite <- cast_rew.
    rewrite cast_trans.
    vector_simp.
    f_equal; apply proof_irrelevance.
  Qed.

  Variant InstructionI : Type :=
  | andI : regId -> regId -> InstructionI
  | orI : regId -> regId -> InstructionI
  | xorI : regId -> regId -> InstructionI
  | notI : regId -> InstructionI
  | addI : regId -> regId -> InstructionI
  | subI : regId -> regId -> InstructionI
  | mullI : regId -> regId -> InstructionI
  | umulhI : regId -> regId -> InstructionI
  | smulhI : regId -> regId -> InstructionI
  | udivI : regId -> regId -> InstructionI
  | umodI : regId -> regId -> InstructionI
  | shlI : regId -> regId -> InstructionI
  | shrI : regId -> regId -> InstructionI
  | cmpeI : regId -> InstructionI
  | cmpaI : regId -> InstructionI
  | cmpaeI : regId -> InstructionI
  | cmpgI : regId -> InstructionI
  | cmpgeI : regId -> InstructionI
  | movI : regId -> InstructionI
  | cmovI : regId -> InstructionI
  | jmpI : InstructionI
  | cjmpI : InstructionI
  | cnjmpI : InstructionI
  | store_bI : regId -> InstructionI
  | load_bI : regId -> InstructionI
  | store_wI : regId -> InstructionI
  | load_wI : regId -> InstructionI
  | readI : regId -> InstructionI
  | answerI : InstructionI.

  Definition operand : Type := Word + regId.

  Definition Instruction : Type := InstructionI * operand.

  Definition ijTr (con : regId -> regId -> InstructionI)
                   (ri rj : regId) (A : operand) : Instruction := (con ri rj, A).

  Definition iTr (con : regId -> InstructionI)
                   (ri : regId) (A : operand) : Instruction := (con ri, A).

  Definition Tr (con : InstructionI) (A : operand) : Instruction := (con, A).

  Definition oreg {n} (v : t bool n) : option regId.
    destruct (bitvector_fin_big v).
    destruct (x <? registerCount) eqn:xlt.
    - apply Some.
      exists x.
      rewrite ltb_lt in xlt.
      assumption.
    - apply None.
  Defined.

  Definition reg2pow :
    2 ^ log2_up registerCount = registerCount ->
    t bool (log2_up registerCount) ->
    regId.
    intros eq v.
    destruct (bitvector_fin_big v).
    rewrite eq in l.
    exists x.
    exact l.
  Defined.

  Lemma reg2powProp_lem :
    forall {B} {P : B -> Prop}
      (e : bool) (el : B) (f : e = true -> P el) (f' : P el),
    e = true ->
    ( if e as b
      return (e = b -> option {x : B | P x})
      then fun xlt : e = true =>
        Some (exist (fun x : B => P x) el (f xlt))
      else fun _ : e = false => None )
    = fun _ => Some (exist (fun x : B => P x) el f').
  Proof.
    intros B P e el f f' etru.
    apply functional_extensionality.
    intro ee.
    destruct e.
    - f_equal.
      apply subset_eq_compat.
      reflexivity.
    - discriminate etru.
  Qed.

  Theorem oreg2powProp : forall
    (eq: 2 ^ log2_up registerCount = registerCount)
    (v: t bool (log2_up registerCount)),
    oreg v = Some (reg2pow eq v).
  Proof.
    intros eq v.
    unfold oreg, reg2pow.
    destruct (bitvector_fin_big v) as [bfv bfvProp].
    assert (bfv < registerCount) as bfvRC.
    { rewrite <- eq. assumption. }
    unfold regId, fin.
    rewrite (reg2powProp_lem (bfv <? registerCount) bfv _ bfvRC).
    2: { rewrite ltb_lt. assumption. }
    f_equal.
    apply subset_eq_compat.
    reflexivity.
  Qed.

  Definition regFit :
    forall {n} (v : t bool n),
    proj1_sig (bitvector_fin_big v) < registerCount ->
    regId.
    intros n v ft.
    exists (proj1_sig (bitvector_fin_big v)).
    exact ft.
  Defined.

  Theorem regFitProp :
    forall {n} (v : t bool n)
    (lt : proj1_sig (bitvector_fin_big v) < registerCount),
    oreg v = Some (regFit v lt).
  Proof.
    intros n v lt.
    unfold oreg, regFit.
    destruct (bitvector_fin_big v) as [bfv bfvProp].
    simpl; simpl in lt.
    unfold regId, fin.
    rewrite (reg2powProp_lem (bfv <? registerCount) bfv _ lt);
      [ reflexivity | ].
    rewrite ltb_lt.
    exact lt.
  Qed.

  Definition answer1 : Instruction.
    split.
    - apply answerI.
    - apply inl, fin_bitvector_big.
      exists 1.
      transitivity wordSize.
      2: { apply PeanoNat.Nat.pow_gt_lin_r. lia. }
      assert (5 < wordSize). { apply wordSizeMin5. }
      lia.
  Defined.

  (* Important Note: The TinyRAM 2.000 spec does not seem to
     clearify what should be done if a register address is too
     big. I've made the opcode answer1 in this case, but this
     may not be intended behaviour.

     Such a situation is impossible if registerCount is a
     power of 2 (see oreg2powProp above), except for decoding
     a word into a register address, which may be too big
     anyway.
  *)
  Definition InstructionDecodeA : forall
    (code : operand -> Instruction)
    (isReg : bool) (w2: Word) (w2reg: option regId),
    Instruction.
    intros code isReg w2 w2reg.
    destruct isReg.
    + exact (code (inl w2)).
    + destruct w2reg as [w2reg|]. 2: { exact answer1. }
      exact (code (inr w2reg)).
  Defined.

  Definition InstructionDecodeRiA : forall
    (code : regId -> operand -> Instruction)
    (isReg : bool) (ri : option regId)
    (w2: Word) (w2reg: option regId),
    Instruction.
    intros code isReg ri w2 w2reg.
    destruct ri as [ri|]. 2: { exact answer1. }
    destruct isReg.
    + exact (code ri (inl w2)).
    + destruct w2reg as [w2reg|]. 2: { exact answer1. }
      exact (code ri (inr w2reg)).
  Defined.

  Definition InstructionDecodeRiRjA : forall
    (code : regId -> regId -> operand -> Instruction)
    (isReg : bool) (ri rj : option regId)
    (w2: Word) (w2reg: option regId),
    Instruction.
    intros code isReg ri rj w2 w2reg.
    destruct ri as [ri|]. 2: { exact answer1. }
    destruct rj as [rj|]. 2: { exact answer1. }
    destruct isReg.
    + exact (code ri rj (inl w2)).
    + destruct w2reg as [w2reg|]. 2: { exact answer1. }
      exact (code ri rj (inr w2reg)).
  Defined.

 (*"""
  the instruction is thus encoded using 2W bits
  """

  """
    Field #6. This is either the name of another register (which is not
              modified by the instruction) or an immediate value, as
              determined by field #2. The length of this field is W bits
              (which is the maximum between the length of a register name
              and of an immediate value).
  """*)
  Definition InstructionDecode (w1 w2 : Word) : Instruction :=
    match interpSplit w1 with
    | (op, isReg, pri, prj, _) =>
      let ri := oreg pri in
      let rj := oreg prj in
      let ow := oreg w2 in
      match proj1_sig (bitvector_fin_big op) with
      | 0 =>  InstructionDecodeRiRjA (ijTr andI  ) isReg ri rj w2 ow
      | 1 =>  InstructionDecodeRiRjA (ijTr orI   ) isReg ri rj w2 ow
      | 2 =>  InstructionDecodeRiRjA (ijTr xorI  ) isReg ri rj w2 ow
      | 3 =>  InstructionDecodeRiA   (iTr  notI  ) isReg ri w2 ow
      | 4 =>  InstructionDecodeRiRjA (ijTr addI  ) isReg ri rj w2 ow
      | 5 =>  InstructionDecodeRiRjA (ijTr subI  ) isReg ri rj w2 ow
      | 6 =>  InstructionDecodeRiRjA (ijTr mullI ) isReg ri rj w2 ow
      | 7 =>  InstructionDecodeRiRjA (ijTr umulhI) isReg ri rj w2 ow
      | 8 =>  InstructionDecodeRiRjA (ijTr smulhI) isReg ri rj w2 ow
      | 9 =>  InstructionDecodeRiRjA (ijTr udivI ) isReg ri rj w2 ow
      | 10 => InstructionDecodeRiRjA (ijTr umodI ) isReg ri rj w2 ow
      | 11 => InstructionDecodeRiRjA (ijTr shlI  ) isReg ri rj w2 ow
      | 12 => InstructionDecodeRiRjA (ijTr shrI  ) isReg ri rj w2 ow
      | 13 => InstructionDecodeRiA   (iTr  cmpeI ) isReg rj w2 ow
      | 14 => InstructionDecodeRiA   (iTr  cmpaI ) isReg rj w2 ow
      | 15 => InstructionDecodeRiA   (iTr  cmpaeI) isReg rj w2 ow
      | 16 => InstructionDecodeRiA   (iTr  cmpgI ) isReg rj w2 ow
      | 17 => InstructionDecodeRiA   (iTr  cmpgeI) isReg rj w2 ow
      | 18 => InstructionDecodeRiA   (iTr  movI  ) isReg ri w2 ow
      | 19 => InstructionDecodeRiA   (iTr  cmovI ) isReg ri w2 ow
      | 20 => InstructionDecodeA     (Tr   jmpI  ) isReg w2 ow
      | 21 => InstructionDecodeA     (Tr   cjmpI ) isReg w2 ow
      | 22 => InstructionDecodeA     (Tr   cnjmpI) isReg w2 ow
      | 23 => answer1
      | 24 => answer1
      | 25 => answer1
      | 26 => InstructionDecodeRiA (iTr   store_bI) isReg ri w2 ow
      | 27 => InstructionDecodeRiA (iTr   load_bI ) isReg ri w2 ow
      | 28 => InstructionDecodeRiA (iTr   store_wI) isReg ri w2 ow
      | 29 => InstructionDecodeRiA (iTr   load_wI ) isReg ri w2 ow
      | 30 => InstructionDecodeRiA (iTr   readI   ) isReg ri w2 ow
      | 31 => InstructionDecodeA   (Tr    answerI ) isReg w2 ow
      | _ => answer1
      end
    end.

  (***
    This section is based on Table 2 of pg. 16 in spec.
  ***)

  Ltac rirjAProof_register :=
    intros ri rj lti ltj A ltA padding;
    unfold InstructionDecode; rewrite interpSplit_eval;
    unfold bitvector_fin_big; vector_simp; simpl;
    rewrite (regFitProp ri lti), (regFitProp rj ltj), (regFitProp A ltA);
    reflexivity.

  Ltac rirjAProof_word :=
    intros ri rj lti ltj A padding;
    unfold InstructionDecode; rewrite interpSplit_eval;
    unfold bitvector_fin_big; vector_simp; simpl;
    rewrite (regFitProp ri lti), (regFitProp rj ltj);
    reflexivity.

  Ltac riAProof_register :=
    intros ri pad lti A ltA padding;
    unfold InstructionDecode; rewrite interpSplit_eval;
    unfold bitvector_fin_big; vector_simp; simpl;
    rewrite (regFitProp ri lti), (regFitProp A ltA);
    reflexivity.

  Ltac riAProof_word :=
    intros ri pad lti A padding;
    unfold InstructionDecode; rewrite interpSplit_eval;
    unfold bitvector_fin_big; vector_simp; simpl;
    rewrite (regFitProp ri lti);
    reflexivity.

  Ltac rjAProof_register :=
    intros pad ri lti A ltA padding;
    unfold InstructionDecode; rewrite interpSplit_eval;
    unfold bitvector_fin_big; vector_simp; simpl;
    rewrite (regFitProp ri lti), (regFitProp A ltA);
    reflexivity.

  Ltac rjAProof_word :=
    intros pad ri lti A padding;
    unfold InstructionDecode; rewrite interpSplit_eval;
    unfold bitvector_fin_big; vector_simp; simpl;
    rewrite (regFitProp ri lti);
    reflexivity.

  Ltac AProof_register :=
    intros pad1 pad2 A ltA padding;
    unfold InstructionDecode; rewrite interpSplit_eval;
    unfold bitvector_fin_big; vector_simp; simpl;
    rewrite (regFitProp A ltA);
    reflexivity.

  Ltac AProof_word :=
    intros pad1 pad2 A padding;
    unfold InstructionDecode; rewrite interpSplit_eval;
    unfold bitvector_fin_big; vector_simp; simpl;
    reflexivity.

  Definition and_code := [b0; b0; b0; b0; b0].

  Theorem and_decode_register_correct :
    forall (ri rj : t bool (log2_up registerCount))
           (lti : proj1_sig (bitvector_fin_big ri) < registerCount)
           (ltj : proj1_sig (bitvector_fin_big rj) < registerCount)
           (A : Word)
           (ltA : proj1_sig (bitvector_fin_big A) < registerCount)
           (padding : t bool paddingSize),
    InstructionDecode (cast (and_code ++ [b0] ++ ri ++ rj ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (andI (regFit ri lti) (regFit rj ltj), inr (regFit A ltA)).
  Proof. unfold and_code. rirjAProof_register. Qed.

  Theorem and_decode_word_correct :
    forall (ri rj : t bool (log2_up registerCount))
           (lti : proj1_sig (bitvector_fin_big ri) < registerCount)
           (ltj : proj1_sig (bitvector_fin_big rj) < registerCount)
           (A : Word)
           (padding : t bool paddingSize),
    InstructionDecode (cast (and_code ++ [b1] ++ ri ++ rj ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (andI (regFit ri lti) (regFit rj ltj), inl A).
  Proof. unfold and_code. rirjAProof_word. Qed.

Definition or_code := [b0; b0; b0; b0; b1].

Theorem or_decode_register_correct :
    forall (ri rj : t bool (log2_up registerCount))
           (lti : proj1_sig (bitvector_fin_big ri) < registerCount)
           (ltj : proj1_sig (bitvector_fin_big rj) < registerCount)
           (A : Word)
           (ltA : proj1_sig (bitvector_fin_big A) < registerCount)
           (padding : t bool paddingSize),
    InstructionDecode (cast (or_code ++ [b0] ++ ri ++ rj ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (orI (regFit ri lti) (regFit rj ltj), inr (regFit A ltA)).
  Proof. unfold or_code. rirjAProof_register. Qed.

  Theorem or_decode_word_correct :
    forall (ri rj : t bool (log2_up registerCount))
           (lti : proj1_sig (bitvector_fin_big ri) < registerCount)
           (ltj : proj1_sig (bitvector_fin_big rj) < registerCount)
           (A : Word)
           (padding : t bool paddingSize),
    InstructionDecode (cast (or_code ++ [b1] ++ ri ++ rj ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (orI (regFit ri lti) (regFit rj ltj), inl A).
  Proof. unfold or_code. rirjAProof_word. Qed.

  Definition xor_code := [b0; b0; b0; b1; b0].

  Theorem xor_decode_register_correct :
    forall (ri rj : t bool (log2_up registerCount))
           (lti : proj1_sig (bitvector_fin_big ri) < registerCount)
           (ltj : proj1_sig (bitvector_fin_big rj) < registerCount)
           (A : Word)
           (ltA : proj1_sig (bitvector_fin_big A) < registerCount)
           (padding : t bool paddingSize),
    InstructionDecode (cast (xor_code ++ [b0] ++ ri ++ rj ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (xorI (regFit ri lti) (regFit rj ltj), inr (regFit A ltA)).
  Proof. unfold xor_code. rirjAProof_register. Qed.

  Theorem xor_decode_word_correct :
    forall (ri rj : t bool (log2_up registerCount))
           (lti : proj1_sig (bitvector_fin_big ri) < registerCount)
           (ltj : proj1_sig (bitvector_fin_big rj) < registerCount)
           (A : Word)
           (padding : t bool paddingSize),
    InstructionDecode (cast (xor_code ++ [b1] ++ ri ++ rj ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (xorI (regFit ri lti) (regFit rj ltj), inl A).
  Proof. unfold xor_code. rirjAProof_word. Qed.

  Definition not_code := [b0; b0; b0; b1; b1].

  Theorem not_decode_register_correct :
    forall (ri pad : t bool (log2_up registerCount))
           (lti : proj1_sig (bitvector_fin_big ri) < registerCount)
           (A : Word)
           (ltA : proj1_sig (bitvector_fin_big A) < registerCount)
           (padding : t bool paddingSize),
    InstructionDecode (cast (not_code ++ [b0] ++ ri ++ pad ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (notI (regFit ri lti), inr (regFit A ltA)).
  Proof. unfold not_code. riAProof_register. Qed.

  Theorem not_decode_word_correct :
    forall (ri pad : t bool (log2_up registerCount))
           (lti : proj1_sig (bitvector_fin_big ri) < registerCount)
           (A : Word)
           (padding : t bool paddingSize),
    InstructionDecode (cast (not_code ++ [b1] ++ ri ++ pad ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (notI (regFit ri lti), inl A).
  Proof. unfold not_code. riAProof_word. Qed.

  Definition add_code := [b0; b0; b1; b0; b0].

  Theorem add_decode_register_correct :
    forall (ri rj : t bool (log2_up registerCount))
           (lti : proj1_sig (bitvector_fin_big ri) < registerCount)
           (ltj : proj1_sig (bitvector_fin_big rj) < registerCount)
           (A : Word)
           (ltA : proj1_sig (bitvector_fin_big A) < registerCount)
           (padding : t bool paddingSize),
    InstructionDecode (cast (add_code ++ [b0] ++ ri ++ rj ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (addI (regFit ri lti) (regFit rj ltj), inr (regFit A ltA)).
  Proof. unfold add_code. rirjAProof_register. Qed.

  Theorem add_decode_word_correct :
    forall (ri rj : t bool (log2_up registerCount))
           (lti : proj1_sig (bitvector_fin_big ri) < registerCount)
           (ltj : proj1_sig (bitvector_fin_big rj) < registerCount)
           (A : Word)
           (padding : t bool paddingSize),
    InstructionDecode (cast (add_code ++ [b1] ++ ri ++ rj ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (addI (regFit ri lti) (regFit rj ltj), inl A).
  Proof. unfold add_code. rirjAProof_word. Qed.

  Definition sub_code := [b0; b0; b1; b0; b1].

  Theorem sub_decode_register_correct :
    forall (ri rj : t bool (log2_up registerCount))
           (lti : proj1_sig (bitvector_fin_big ri) < registerCount)
           (ltj : proj1_sig (bitvector_fin_big rj) < registerCount)
           (A : Word)
           (ltA : proj1_sig (bitvector_fin_big A) < registerCount)
           (padding : t bool paddingSize),
    InstructionDecode (cast (sub_code ++ [b0] ++ ri ++ rj ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (subI (regFit ri lti) (regFit rj ltj), inr (regFit A ltA)).
  Proof. unfold sub_code. rirjAProof_register. Qed.

  Theorem sub_decode_word_correct :
    forall (ri rj : t bool (log2_up registerCount))
           (lti : proj1_sig (bitvector_fin_big ri) < registerCount)
           (ltj : proj1_sig (bitvector_fin_big rj) < registerCount)
           (A : Word)
           (padding : t bool paddingSize),
    InstructionDecode (cast (sub_code ++ [b1] ++ ri ++ rj ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (subI (regFit ri lti) (regFit rj ltj), inl A).
  Proof. unfold sub_code. rirjAProof_word. Qed.

  Definition mull_code := [b0; b0; b1; b1; b0].

  Theorem mull_decode_register_correct :
    forall (ri rj : t bool (log2_up registerCount))
           (lti : proj1_sig (bitvector_fin_big ri) < registerCount)
           (ltj : proj1_sig (bitvector_fin_big rj) < registerCount)
           (A : Word)
           (ltA : proj1_sig (bitvector_fin_big A) < registerCount)
           (padding : t bool paddingSize),
    InstructionDecode (cast (mull_code ++ [b0] ++ ri ++ rj ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (mullI (regFit ri lti) (regFit rj ltj), inr (regFit A ltA)).
  Proof. unfold mull_code. rirjAProof_register. Qed.

  Theorem mull_decode_word_correct :
    forall (ri rj : t bool (log2_up registerCount))
           (lti : proj1_sig (bitvector_fin_big ri) < registerCount)
           (ltj : proj1_sig (bitvector_fin_big rj) < registerCount)
           (A : Word)
           (padding : t bool paddingSize),
    InstructionDecode (cast (mull_code ++ [b1] ++ ri ++ rj ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (mullI (regFit ri lti) (regFit rj ltj), inl A).
  Proof. unfold mull_code. rirjAProof_word. Qed.

  Definition umulh_code := [b0; b0; b1; b1; b1].

  Theorem umulh_decode_register_correct :
    forall (ri rj : t bool (log2_up registerCount))
           (lti : proj1_sig (bitvector_fin_big ri) < registerCount)
           (ltj : proj1_sig (bitvector_fin_big rj) < registerCount)
           (A : Word)
           (ltA : proj1_sig (bitvector_fin_big A) < registerCount)
           (padding : t bool paddingSize),
    InstructionDecode (cast (umulh_code ++ [b0] ++ ri ++ rj ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (umulhI (regFit ri lti) (regFit rj ltj), inr (regFit A ltA)).
  Proof. unfold umulh_code. rirjAProof_register. Qed.

  Theorem umulh_decode_word_correct :
    forall (ri rj : t bool (log2_up registerCount))
           (lti : proj1_sig (bitvector_fin_big ri) < registerCount)
           (ltj : proj1_sig (bitvector_fin_big rj) < registerCount)
           (A : Word)
           (padding : t bool paddingSize),
    InstructionDecode (cast (umulh_code ++ [b1] ++ ri ++ rj ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (umulhI (regFit ri lti) (regFit rj ltj), inl A).
  Proof. unfold umulh_code. rirjAProof_word. Qed.

  Definition smulh_code := [b0; b1; b0; b0; b0].

  Theorem smulh_decode_register_correct :
    forall (ri rj : t bool (log2_up registerCount))
           (lti : proj1_sig (bitvector_fin_big ri) < registerCount)
           (ltj : proj1_sig (bitvector_fin_big rj) < registerCount)
           (A : Word)
           (ltA : proj1_sig (bitvector_fin_big A) < registerCount)
           (padding : t bool paddingSize),
    InstructionDecode (cast (smulh_code ++ [b0] ++ ri ++ rj ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (smulhI (regFit ri lti) (regFit rj ltj), inr (regFit A ltA)).
  Proof. unfold smulh_code. rirjAProof_register. Qed.

  Theorem smulh_decode_word_correct :
    forall (ri rj : t bool (log2_up registerCount))
           (lti : proj1_sig (bitvector_fin_big ri) < registerCount)
           (ltj : proj1_sig (bitvector_fin_big rj) < registerCount)
           (A : Word)
           (padding : t bool paddingSize),
    InstructionDecode (cast (smulh_code ++ [b1] ++ ri ++ rj ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (smulhI (regFit ri lti) (regFit rj ltj), inl A).
  Proof. unfold smulh_code. rirjAProof_word. Qed.

  Definition udiv_code := [b0; b1; b0; b0; b1].

  Theorem udiv_decode_register_correct :
    forall (ri rj : t bool (log2_up registerCount))
           (lti : proj1_sig (bitvector_fin_big ri) < registerCount)
           (ltj : proj1_sig (bitvector_fin_big rj) < registerCount)
           (A : Word)
           (ltA : proj1_sig (bitvector_fin_big A) < registerCount)
           (padding : t bool paddingSize),
    InstructionDecode (cast (udiv_code ++ [b0] ++ ri ++ rj ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (udivI (regFit ri lti) (regFit rj ltj), inr (regFit A ltA)).
  Proof. unfold udiv_code. rirjAProof_register. Qed.

  Theorem udiv_decode_word_correct :
    forall (ri rj : t bool (log2_up registerCount))
           (lti : proj1_sig (bitvector_fin_big ri) < registerCount)
           (ltj : proj1_sig (bitvector_fin_big rj) < registerCount)
           (A : Word)
           (padding : t bool paddingSize),
    InstructionDecode (cast (udiv_code ++ [b1] ++ ri ++ rj ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (udivI (regFit ri lti) (regFit rj ltj), inl A).
  Proof. unfold udiv_code. rirjAProof_word. Qed.

  Definition umod_code := [b0; b1; b0; b1; b0].

  Theorem umod_decode_register_correct :
    forall (ri rj : t bool (log2_up registerCount))
           (lti : proj1_sig (bitvector_fin_big ri) < registerCount)
           (ltj : proj1_sig (bitvector_fin_big rj) < registerCount)
           (A : Word)
           (ltA : proj1_sig (bitvector_fin_big A) < registerCount)
           (padding : t bool paddingSize),
    InstructionDecode (cast (umod_code ++ [b0] ++ ri ++ rj ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (umodI (regFit ri lti) (regFit rj ltj), inr (regFit A ltA)).
  Proof. unfold umod_code. rirjAProof_register. Qed.

  Theorem umod_decode_word_correct :
    forall (ri rj : t bool (log2_up registerCount))
           (lti : proj1_sig (bitvector_fin_big ri) < registerCount)
           (ltj : proj1_sig (bitvector_fin_big rj) < registerCount)
           (A : Word)
           (padding : t bool paddingSize),
    InstructionDecode (cast (umod_code ++ [b1] ++ ri ++ rj ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (umodI (regFit ri lti) (regFit rj ltj), inl A).
  Proof. unfold umod_code. rirjAProof_word. Qed.

  Definition shl_code := [b0; b1; b0; b1; b1].

  Theorem shl_decode_register_correct :
    forall (ri rj : t bool (log2_up registerCount))
           (lti : proj1_sig (bitvector_fin_big ri) < registerCount)
           (ltj : proj1_sig (bitvector_fin_big rj) < registerCount)
           (A : Word)
           (ltA : proj1_sig (bitvector_fin_big A) < registerCount)
           (padding : t bool paddingSize),
    InstructionDecode (cast (shl_code ++ [b0] ++ ri ++ rj ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (shlI (regFit ri lti) (regFit rj ltj), inr (regFit A ltA)).
  Proof. unfold shl_code. rirjAProof_register. Qed.

  Theorem shl_decode_word_correct :
    forall (ri rj : t bool (log2_up registerCount))
           (lti : proj1_sig (bitvector_fin_big ri) < registerCount)
           (ltj : proj1_sig (bitvector_fin_big rj) < registerCount)
           (A : Word)
           (padding : t bool paddingSize),
    InstructionDecode (cast (shl_code ++ [b1] ++ ri ++ rj ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (shlI (regFit ri lti) (regFit rj ltj), inl A).
  Proof. unfold shl_code. rirjAProof_word. Qed.

  Definition shr_code := [b0; b1; b1; b0; b0].

  Theorem shr_decode_register_correct :
    forall (ri rj : t bool (log2_up registerCount))
           (lti : proj1_sig (bitvector_fin_big ri) < registerCount)
           (ltj : proj1_sig (bitvector_fin_big rj) < registerCount)
           (A : Word)
           (ltA : proj1_sig (bitvector_fin_big A) < registerCount)
           (padding : t bool paddingSize),
    InstructionDecode (cast (shr_code ++ [b0] ++ ri ++ rj ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (shrI (regFit ri lti) (regFit rj ltj), inr (regFit A ltA)).
  Proof. unfold shr_code. rirjAProof_register. Qed.

  Theorem shr_decode_word_correct :
    forall (ri rj : t bool (log2_up registerCount))
           (lti : proj1_sig (bitvector_fin_big ri) < registerCount)
           (ltj : proj1_sig (bitvector_fin_big rj) < registerCount)
           (A : Word)
           (padding : t bool paddingSize),
    InstructionDecode (cast (shr_code ++ [b1] ++ ri ++ rj ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (shrI (regFit ri lti) (regFit rj ltj), inl A).
  Proof. unfold shr_code. rirjAProof_word. Qed.

  Definition cmpe_code := [b0; b1; b1; b0; b1].

  Theorem cmpe_decode_register_correct :
    forall (pad ri : t bool (log2_up registerCount))
           (lti : proj1_sig (bitvector_fin_big ri) < registerCount)
           (A : Word)
           (ltA : proj1_sig (bitvector_fin_big A) < registerCount)
           (padding : t bool paddingSize),
    InstructionDecode (cast (cmpe_code ++ [b0] ++ pad ++ ri ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (cmpeI (regFit ri lti), inr (regFit A ltA)).
  Proof. unfold cmpe_code. rjAProof_register. Qed.

  Theorem cmpe_decode_word_correct :
    forall (pad ri : t bool (log2_up registerCount))
           (lti : proj1_sig (bitvector_fin_big ri) < registerCount)
           (A : Word)
           (padding : t bool paddingSize),
    InstructionDecode (cast (cmpe_code ++ [b1] ++ pad ++ ri ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (cmpeI (regFit ri lti), inl A).
  Proof. unfold cmpe_code. rjAProof_word. Qed.

  Definition cmpa_code := [b0; b1; b1; b1; b0].

  Theorem cmpa_decode_register_correct :
    forall (pad ri : t bool (log2_up registerCount))
           (lti : proj1_sig (bitvector_fin_big ri) < registerCount)
           (A : Word)
           (ltA : proj1_sig (bitvector_fin_big A) < registerCount)
           (padding : t bool paddingSize),
    InstructionDecode (cast (cmpa_code ++ [b0] ++ pad ++ ri ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (cmpaI (regFit ri lti), inr (regFit A ltA)).
  Proof. unfold cmpa_code. rjAProof_register. Qed.

  Theorem cmpa_decode_word_correct :
    forall (pad ri : t bool (log2_up registerCount))
           (lti : proj1_sig (bitvector_fin_big ri) < registerCount)
           (A : Word)
           (padding : t bool paddingSize),
    InstructionDecode (cast (cmpa_code ++ [b1] ++ pad ++ ri ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (cmpaI (regFit ri lti), inl A).
  Proof. unfold cmpa_code. rjAProof_word. Qed.

  Definition cmpae_code := [b0; b1; b1; b1; b1].

  Theorem cmpae_decode_register_correct :
    forall (pad ri : t bool (log2_up registerCount))
           (lti : proj1_sig (bitvector_fin_big ri) < registerCount)
           (A : Word)
           (ltA : proj1_sig (bitvector_fin_big A) < registerCount)
           (padding : t bool paddingSize),
    InstructionDecode (cast (cmpae_code ++ [b0] ++ pad ++ ri ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (cmpaeI (regFit ri lti), inr (regFit A ltA)).
  Proof. unfold cmpae_code. rjAProof_register. Qed.

  Theorem cmpae_decode_word_correct :
    forall (pad ri : t bool (log2_up registerCount))
           (lti : proj1_sig (bitvector_fin_big ri) < registerCount)
           (A : Word)
           (padding : t bool paddingSize),
    InstructionDecode (cast (cmpae_code ++ [b1] ++ pad ++ ri ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (cmpaeI (regFit ri lti), inl A).
  Proof. unfold cmpae_code. rjAProof_word. Qed.

  Definition cmpg_code := [b1; b0; b0; b0; b0].

  Theorem cmpg_decode_register_correct :
    forall (pad ri : t bool (log2_up registerCount))
           (lti : proj1_sig (bitvector_fin_big ri) < registerCount)
           (A : Word)
           (ltA : proj1_sig (bitvector_fin_big A) < registerCount)
           (padding : t bool paddingSize),
    InstructionDecode (cast (cmpg_code ++ [b0] ++ pad ++ ri ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (cmpgI (regFit ri lti), inr (regFit A ltA)).
  Proof. unfold cmpg_code. rjAProof_register. Qed.

  Theorem cmpg_decode_word_correct :
    forall (pad ri : t bool (log2_up registerCount))
           (lti : proj1_sig (bitvector_fin_big ri) < registerCount)
           (A : Word)
           (padding : t bool paddingSize),
    InstructionDecode (cast (cmpg_code ++ [b1] ++ pad ++ ri ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (cmpgI (regFit ri lti), inl A).
  Proof. unfold cmpg_code. rjAProof_word. Qed.

  Definition cmpge_code := [b1; b0; b0; b0; b1].

  Theorem cmpge_decode_register_correct :
    forall (pad ri : t bool (log2_up registerCount))
           (lti : proj1_sig (bitvector_fin_big ri) < registerCount)
           (A : Word)
           (ltA : proj1_sig (bitvector_fin_big A) < registerCount)
           (padding : t bool paddingSize),
    InstructionDecode (cast (cmpge_code ++ [b0] ++ pad ++ ri ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (cmpgeI (regFit ri lti), inr (regFit A ltA)).
  Proof. unfold cmpge_code. rjAProof_register. Qed.

  Theorem cmpge_decode_word_correct :
    forall (pad ri : t bool (log2_up registerCount))
           (lti : proj1_sig (bitvector_fin_big ri) < registerCount)
           (A : Word)
           (padding : t bool paddingSize),
    InstructionDecode (cast (cmpge_code ++ [b1] ++ pad ++ ri ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (cmpgeI (regFit ri lti), inl A).
  Proof. unfold cmpge_code. rjAProof_word. Qed.

  Definition mov_code := [b1; b0; b0; b1; b0].

  Theorem mov_decode_register_correct :
    forall (ri pad : t bool (log2_up registerCount))
           (lti : proj1_sig (bitvector_fin_big ri) < registerCount)
           (A : Word)
           (ltA : proj1_sig (bitvector_fin_big A) < registerCount)
           (padding : t bool paddingSize),
    InstructionDecode (cast (mov_code ++ [b0] ++ ri ++ pad ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (movI (regFit ri lti), inr (regFit A ltA)).
  Proof. unfold mov_code. riAProof_register. Qed.

  Theorem mov_decode_word_correct :
    forall (ri pad : t bool (log2_up registerCount))
           (lti : proj1_sig (bitvector_fin_big ri) < registerCount)
           (A : Word)
           (padding : t bool paddingSize),
    InstructionDecode (cast (mov_code ++ [b1] ++ ri ++ pad ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (movI (regFit ri lti), inl A).
  Proof. unfold mov_code. riAProof_word. Qed.

  Definition cmov_code := [b1; b0; b0; b1; b1].

  Theorem cmov_decode_register_correct :
    forall (ri pad : t bool (log2_up registerCount))
           (lti : proj1_sig (bitvector_fin_big ri) < registerCount)
           (A : Word)
           (ltA : proj1_sig (bitvector_fin_big A) < registerCount)
           (padding : t bool paddingSize),
    InstructionDecode (cast (cmov_code ++ [b0] ++ ri ++ pad ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (cmovI (regFit ri lti), inr (regFit A ltA)).
  Proof. unfold cmov_code. riAProof_register. Qed.

  Theorem cmov_decode_word_correct :
    forall (ri pad : t bool (log2_up registerCount))
           (lti : proj1_sig (bitvector_fin_big ri) < registerCount)
           (A : Word)
           (padding : t bool paddingSize),
    InstructionDecode (cast (cmov_code ++ [b1] ++ ri ++ pad ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (cmovI (regFit ri lti), inl A).
  Proof. unfold cmov_code. riAProof_word. Qed.

  Definition jmp_code := [b1; b0; b1; b0; b0].

  Theorem jmp_decode_register_correct :
    forall (pad1 pad2 : t bool (log2_up registerCount))
           (A : Word)
           (ltA : proj1_sig (bitvector_fin_big A) < registerCount)
           (padding : t bool paddingSize),
    InstructionDecode (cast (jmp_code ++ [b0] ++ pad1 ++ pad2 ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (jmpI, inr (regFit A ltA)).
  Proof. unfold jmp_code. AProof_register. Qed.

  Theorem jmp_decode_word_correct :
    forall (pad1 pad2 : t bool (log2_up registerCount))
           (A : Word)
           (padding : t bool paddingSize),
    InstructionDecode (cast (jmp_code ++ [b1] ++ pad1 ++ pad2 ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (jmpI, inl A).
  Proof. unfold jmp_code. AProof_word. Qed.

  Definition cjmp_code := [b1; b0; b1; b0; b1].

  Theorem cjmp_decode_register_correct :
    forall (pad1 pad2 : t bool (log2_up registerCount))
           (A : Word)
           (ltA : proj1_sig (bitvector_fin_big A) < registerCount)
           (padding : t bool paddingSize),
    InstructionDecode (cast (cjmp_code ++ [b0] ++ pad1 ++ pad2 ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (cjmpI, inr (regFit A ltA)).
  Proof. unfold cjmp_code. AProof_register. Qed.

  Theorem cjmp_decode_word_correct :
    forall (pad1 pad2 : t bool (log2_up registerCount))
           (A : Word)
           (padding : t bool paddingSize),
    InstructionDecode (cast (cjmp_code ++ [b1] ++ pad1 ++ pad2 ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (cjmpI, inl A).
  Proof. unfold cjmp_code. AProof_word. Qed.

  Definition cnjmp_code := [b1; b0; b1; b1; b0].

  Theorem cnjmp_decode_register_correct :
    forall (pad1 pad2 : t bool (log2_up registerCount))
           (A : Word)
           (ltA : proj1_sig (bitvector_fin_big A) < registerCount)
           (padding : t bool paddingSize),
    InstructionDecode (cast (cnjmp_code ++ [b0] ++ pad1 ++ pad2 ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (cnjmpI, inr (regFit A ltA)).
  Proof. unfold cnjmp_code. AProof_register. Qed.

  Theorem cnjmp_decode_word_correct :
    forall (pad1 pad2 : t bool (log2_up registerCount))
           (A : Word)
           (padding : t bool paddingSize),
    InstructionDecode (cast (cnjmp_code ++ [b1] ++ pad1 ++ pad2 ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (cnjmpI, inl A).
  Proof. unfold cnjmp_code. AProof_word. Qed.

  Definition store_b_code := [b1; b1; b0; b1; b0].

  Theorem store_b_decode_register_correct :
    forall (ri pad : t bool (log2_up registerCount))
           (lti : proj1_sig (bitvector_fin_big ri) < registerCount)
           (A : Word)
           (ltA : proj1_sig (bitvector_fin_big A) < registerCount)
           (padding : t bool paddingSize),
    InstructionDecode (cast (store_b_code ++ [b0] ++ ri ++ pad ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (store_bI (regFit ri lti), inr (regFit A ltA)).
  Proof. unfold store_b_code. riAProof_register. Qed.

  Theorem store_b_decode_word_correct :
    forall (ri pad : t bool (log2_up registerCount))
           (lti : proj1_sig (bitvector_fin_big ri) < registerCount)
           (A : Word)
           (padding : t bool paddingSize),
    InstructionDecode (cast (store_b_code ++ [b1] ++ ri ++ pad ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (store_bI (regFit ri lti), inl A).
  Proof. unfold store_b_code. riAProof_word. Qed.

  Definition load_b_code := [b1; b1; b0; b1; b1].

  Theorem load_b_decode_register_correct :
    forall (ri pad : t bool (log2_up registerCount))
           (lti : proj1_sig (bitvector_fin_big ri) < registerCount)
           (A : Word)
           (ltA : proj1_sig (bitvector_fin_big A) < registerCount)
           (padding : t bool paddingSize),
    InstructionDecode (cast (load_b_code ++ [b0] ++ ri ++ pad ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (load_bI (regFit ri lti), inr (regFit A ltA)).
  Proof. unfold load_b_code. riAProof_register. Qed.

  Theorem load_b_decode_word_correct :
    forall (ri pad : t bool (log2_up registerCount))
           (lti : proj1_sig (bitvector_fin_big ri) < registerCount)
           (A : Word)
           (padding : t bool paddingSize),
    InstructionDecode (cast (load_b_code ++ [b1] ++ ri ++ pad ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (load_bI (regFit ri lti), inl A).
  Proof. unfold load_b_code. riAProof_word. Qed.

  Definition store_w_code := [b1; b1; b1; b0; b0].

  Theorem store_w_decode_register_correct :
    forall (ri pad : t bool (log2_up registerCount))
           (lti : proj1_sig (bitvector_fin_big ri) < registerCount)
           (A : Word)
           (ltA : proj1_sig (bitvector_fin_big A) < registerCount)
           (padding : t bool paddingSize),
    InstructionDecode (cast (store_w_code ++ [b0] ++ ri ++ pad ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (store_wI (regFit ri lti), inr (regFit A ltA)).
  Proof. unfold store_w_code. riAProof_register. Qed.

  Theorem store_w_decode_word_correct :
    forall (ri pad : t bool (log2_up registerCount))
           (lti : proj1_sig (bitvector_fin_big ri) < registerCount)
           (A : Word)
           (padding : t bool paddingSize),
    InstructionDecode (cast (store_w_code ++ [b1] ++ ri ++ pad ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (store_wI (regFit ri lti), inl A).
  Proof. unfold store_w_code. riAProof_word. Qed.

  Definition load_w_code := [b1; b1; b1; b0; b1].

  Theorem load_w_decode_register_correct :
    forall (ri pad : t bool (log2_up registerCount))
           (lti : proj1_sig (bitvector_fin_big ri) < registerCount)
           (A : Word)
           (ltA : proj1_sig (bitvector_fin_big A) < registerCount)
           (padding : t bool paddingSize),
    InstructionDecode (cast (load_w_code ++ [b0] ++ ri ++ pad ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (load_wI (regFit ri lti), inr (regFit A ltA)).
  Proof. unfold load_w_code. riAProof_register. Qed.

  Theorem load_w_decode_word_correct :
    forall (ri pad : t bool (log2_up registerCount))
           (lti : proj1_sig (bitvector_fin_big ri) < registerCount)
           (A : Word)
           (padding : t bool paddingSize),
    InstructionDecode (cast (load_w_code ++ [b1] ++ ri ++ pad ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (load_wI (regFit ri lti), inl A).
  Proof. unfold load_w_code. riAProof_word. Qed.

  Definition read_code := [b1; b1; b1; b1; b0].

  Theorem read_decode_register_correct :
    forall (ri pad : t bool (log2_up registerCount))
           (lti : proj1_sig (bitvector_fin_big ri) < registerCount)
           (A : Word)
           (ltA : proj1_sig (bitvector_fin_big A) < registerCount)
           (padding : t bool paddingSize),
    InstructionDecode (cast (read_code ++ [b0] ++ ri ++ pad ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (readI (regFit ri lti), inr (regFit A ltA)).
  Proof. unfold read_code. riAProof_register. Qed.

  Theorem read_decode_word_correct :
    forall (ri pad : t bool (log2_up registerCount))
           (lti : proj1_sig (bitvector_fin_big ri) < registerCount)
           (A : Word)
           (padding : t bool paddingSize),
    InstructionDecode (cast (read_code ++ [b1] ++ ri ++ pad ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (readI (regFit ri lti), inl A).
  Proof. unfold read_code. riAProof_word. Qed.

  Definition answer_code := [b1; b1; b1; b1; b1].

  Theorem answer_decode_register_correct :
    forall (pad1 pad2 : t bool (log2_up registerCount))
           (A : Word)
           (ltA : proj1_sig (bitvector_fin_big A) < registerCount)
           (padding : t bool paddingSize),
    InstructionDecode (cast (answer_code ++ [b0] ++ pad1 ++ pad2 ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (answerI, inr (regFit A ltA)).
  Proof. unfold answer_code. AProof_register. Qed.

  Theorem answer_decode_word_correct :
    forall (pad1 pad2 : t bool (log2_up registerCount))
           (A : Word)
           (padding : t bool paddingSize),
    InstructionDecode (cast (answer_code ++ [b1] ++ pad1 ++ pad2 ++ padding)
                       (eq_sym interpSplitLemRight)) A =
    (answerI, inl A).
  Proof. unfold answer_code. AProof_word. Qed.

  Definition option_word : operand -> Word.
    intros [w|[rid ridp]].
    - exact w.
    - apply fin_bitvector_big.
      exists rid.
      transitivity registerCount. { assumption. }
      apply registerCount_lt_2powwordSize2.
      lia.
  Defined.

  Definition option_bool (o : operand) : bool :=
    if o then b1 else b0.

  Definition reg_vect : regId -> t bool (log2_up registerCount).
    intros [r rprp].
    apply fin_bitvector_big.
    exists r.
    apply (PeanoNat.Nat.lt_le_trans _ registerCount). { assumption. }
    rewrite PeanoNat.Nat.log2_up_le_pow2; lia.
  Defined.

  Definition InstructionEncode (o : Instruction) : Word * Word :=
    match o with
    | (andI ri rj, op) =>
      (cast (and_code ++ [option_bool op] ++ reg_vect ri ++ reg_vect rj ++ const b0 _)
            (eq_sym interpSplitLemRight),
      option_word op)
    | (orI ri rj, op) =>
      (cast (or_code ++ [option_bool op] ++ reg_vect ri ++ reg_vect rj ++ const b0 _)
            (eq_sym interpSplitLemRight),
      option_word op)
    | (xorI ri rj, op) =>
      (cast (xor_code ++ [option_bool op] ++ reg_vect ri ++ reg_vect rj ++ const b0 _)
            (eq_sym interpSplitLemRight),
      option_word op)
    | (notI ri, op) =>
      (cast (not_code ++ [option_bool op] ++ reg_vect ri ++ const b0 _ ++ const b0 _)
            (eq_sym interpSplitLemRight),
      option_word op)
    | (addI ri rj, op) =>
      (cast (add_code ++ [option_bool op] ++ reg_vect ri ++ reg_vect rj ++ const b0 _)
            (eq_sym interpSplitLemRight),
      option_word op)
    | (subI ri rj, op) =>
      (cast (sub_code ++ [option_bool op] ++ reg_vect ri ++ reg_vect rj ++ const b0 _)
            (eq_sym interpSplitLemRight),
      option_word op)
    | (mullI ri rj, op) =>
      (cast (mull_code ++ [option_bool op] ++ reg_vect ri ++ reg_vect rj ++ const b0 _)
            (eq_sym interpSplitLemRight),
      option_word op)
    | (umulhI ri rj, op) =>
      (cast (umulh_code ++ [option_bool op] ++ reg_vect ri ++ reg_vect rj ++ const b0 _)
            (eq_sym interpSplitLemRight),
      option_word op)
    | (smulhI ri rj, op) =>
      (cast (smulh_code ++ [option_bool op] ++ reg_vect ri ++ reg_vect rj ++ const b0 _)
            (eq_sym interpSplitLemRight),
      option_word op)
    | (udivI ri rj, op) =>
      (cast (udiv_code ++ [option_bool op] ++ reg_vect ri ++ reg_vect rj ++ const b0 _)
            (eq_sym interpSplitLemRight),
      option_word op)
    | (umodI ri rj, op) =>
      (cast (umod_code ++ [option_bool op] ++ reg_vect ri ++ reg_vect rj ++ const b0 _)
            (eq_sym interpSplitLemRight),
      option_word op)
    | (shlI ri rj, op) =>
      (cast (shl_code ++ [option_bool op] ++ reg_vect ri ++ reg_vect rj ++ const b0 _)
            (eq_sym interpSplitLemRight),
      option_word op)
    | (shrI ri rj, op) =>
      (cast (shr_code ++ [option_bool op] ++ reg_vect ri ++ reg_vect rj ++ const b0 _)
            (eq_sym interpSplitLemRight),
      option_word op)
    | (cmpeI ri, op) =>
      (cast (cmpe_code ++ [option_bool op] ++ const b0 _ ++ reg_vect ri ++ const b0 _)
            (eq_sym interpSplitLemRight),
      option_word op)
    | (cmpaI ri, op) =>
      (cast (cmpa_code ++ [option_bool op] ++ const b0 _ ++ reg_vect ri ++ const b0 _)
            (eq_sym interpSplitLemRight),
      option_word op)
    | (cmpaeI ri, op) =>
      (cast (cmpae_code ++ [option_bool op] ++ const b0 _ ++ reg_vect ri ++ const b0 _)
            (eq_sym interpSplitLemRight),
      option_word op)
    | (cmpgI ri, op) =>
      (cast (cmpg_code ++ [option_bool op] ++ const b0 _ ++ reg_vect ri ++ const b0 _)
            (eq_sym interpSplitLemRight),
      option_word op)
    | (cmpgeI ri, op) =>
      (cast (cmpge_code ++ [option_bool op] ++ const b0 _ ++ reg_vect ri ++ const b0 _)
            (eq_sym interpSplitLemRight),
      option_word op)
    | (movI ri, op) =>
      (cast (mov_code ++ [option_bool op] ++ reg_vect ri ++ const b0 _ ++ const b0 _)
            (eq_sym interpSplitLemRight),
      option_word op)
    | (cmovI ri, op) =>
      (cast (cmov_code ++ [option_bool op] ++ reg_vect ri ++ const b0 _ ++ const b0 _)
            (eq_sym interpSplitLemRight),
      option_word op)
    | (jmpI, op) =>
      (cast (jmp_code ++ [option_bool op] ++ const b0 _ ++ const b0 _ ++ const b0 _)
            (eq_sym interpSplitLemRight),
      option_word op)
    | (cjmpI, op) =>
      (cast (cjmp_code ++ [option_bool op] ++ const b0 _ ++ const b0 _ ++ const b0 _)
            (eq_sym interpSplitLemRight),
      option_word op)
    | (cnjmpI, op) =>
      (cast (cnjmp_code ++ [option_bool op] ++ const b0 _ ++ const b0 _ ++ const b0 _)
            (eq_sym interpSplitLemRight),
      option_word op)
    | (store_bI ri, op) =>
      (cast (store_b_code ++ [option_bool op] ++ reg_vect ri ++ const b0 _ ++ const b0 _)
            (eq_sym interpSplitLemRight),
      option_word op)
    | (load_bI ri, op) =>
      (cast (load_b_code ++ [option_bool op] ++ reg_vect ri ++ const b0 _ ++ const b0 _)
            (eq_sym interpSplitLemRight),
      option_word op)
    | (store_wI ri, op) =>
      (cast (store_w_code ++ [option_bool op] ++ reg_vect ri ++ const b0 _ ++ const b0 _)
            (eq_sym interpSplitLemRight),
      option_word op)
    | (load_wI ri, op) =>
      (cast (load_w_code ++ [option_bool op] ++ reg_vect ri ++ const b0 _ ++ const b0 _)
            (eq_sym interpSplitLemRight),
      option_word op)
    | (readI ri, op) =>
      (cast (read_code ++ [option_bool op] ++ reg_vect ri ++ const b0 _ ++ const b0 _)
            (eq_sym interpSplitLemRight),
      option_word op)
    | (answerI, op) =>
      (cast (answer_code ++ [option_bool op] ++ const b0 _ ++ const b0 _ ++ const b0 _)
            (eq_sym interpSplitLemRight),
      option_word op)
    end.

  Theorem reg_vect_bitvector_fin_big_id_sig : forall r,
      proj1_sig (bitvector_fin_big (reg_vect r)) =
      proj1_sig r.
  Proof.
    intros [r rprp].
    unfold reg_vect.
    rewrite fin_bitvector_big_inv.
    reflexivity.
  Qed.

  Theorem reg_vect_bitvector_fin_big_id_lem : forall r,
      proj1_sig (bitvector_fin_big (reg_vect r)) < registerCount.
  Proof.
    intros [r rprp].
    rewrite reg_vect_bitvector_fin_big_id_sig.
    exact rprp.
  Qed.

  (* Cleanup beurocracy at end of each case. *)
  Ltac encode_decode_fin :=
      f_equal; unfold regFit, reg_vect, option_word; f_equal;
      apply subset_eq_compat; rewrite fin_bitvector_big_inv; reflexivity.

  (* try proving that r is in bounds/is a valid register. *)
  Ltac reg_bound r rprp rDef H :=
    assert (proj1_sig (bitvector_fin_big (reg_vect r)) < registerCount) as H;
    try (rewrite reg_vect_bitvector_fin_big_id_sig, rDef; exact rprp);
    rewrite rDef in H.

  (* try proving that the word r is in bounds/is a valid register. *)
  Ltac reg_bound_word r rprp rDef H :=
    assert (proj1_sig (bitvector_fin_big (option_word (inr r))) < registerCount) as H;
    try (rewrite rDef; unfold option_word; rewrite fin_bitvector_big_inv; exact rprp);
    rewrite rDef in H.

  Theorem encode_decode_id : forall o,
    uncurry InstructionDecode (InstructionEncode o) = o.
  Proof.
    intro o; destruct o as [o op]; destruct o;
    unfold InstructionEncode, uncurry;
    destruct op; unfold option_bool;
    try (destruct r as [r' rprp] eqn:rDef);
    try (destruct r0 as [r0' r0prp] eqn:r0Def);
    try (destruct r1 as [r1' r1prp] eqn:r1Def);
    try reg_bound r rprp rDef H;
    try reg_bound r0 r0prp r0Def H0;
    try ( reg_bound_word r1 r1prp r1Def H1 ||
          reg_bound_word r0 r0prp r0Def H1 ||
          reg_bound_word r rprp rDef H1 ).
    - rewrite (and_decode_word_correct _ _ H H0); encode_decode_fin.
    - rewrite (and_decode_register_correct _ _ H H0 _ H1); encode_decode_fin.
    - rewrite (or_decode_word_correct _ _ H H0); encode_decode_fin.
    - rewrite (or_decode_register_correct _ _ H H0 _ H1); encode_decode_fin.
    - rewrite (xor_decode_word_correct _ _ H H0); encode_decode_fin.
    - rewrite (xor_decode_register_correct _ _ H H0 _ H1); encode_decode_fin.
    - rewrite (not_decode_word_correct _ _ H); encode_decode_fin.
    - rewrite (not_decode_register_correct _ _ H _ H1); encode_decode_fin.
    - rewrite (add_decode_word_correct _ _ H H0); encode_decode_fin.
    - rewrite (add_decode_register_correct _ _ H H0 _ H1); encode_decode_fin.
    - rewrite (sub_decode_word_correct _ _ H H0); encode_decode_fin.
    - rewrite (sub_decode_register_correct _ _ H H0 _ H1); encode_decode_fin.
    - rewrite (mull_decode_word_correct _ _ H H0); encode_decode_fin.
    - rewrite (mull_decode_register_correct _ _ H H0 _ H1); encode_decode_fin.
    - rewrite (umulh_decode_word_correct _ _ H H0); encode_decode_fin.
    - rewrite (umulh_decode_register_correct _ _ H H0 _ H1); encode_decode_fin.
    - rewrite (smulh_decode_word_correct _ _ H H0); encode_decode_fin.
    - rewrite (smulh_decode_register_correct _ _ H H0 _ H1); encode_decode_fin.
    - rewrite (udiv_decode_word_correct _ _ H H0); encode_decode_fin.
    - rewrite (udiv_decode_register_correct _ _ H H0 _ H1); encode_decode_fin.
    - rewrite (umod_decode_word_correct _ _ H H0); encode_decode_fin.
    - rewrite (umod_decode_register_correct _ _ H H0 _ H1); encode_decode_fin.
    - rewrite (shl_decode_word_correct _ _ H H0); encode_decode_fin.
    - rewrite (shl_decode_register_correct _ _ H H0 _ H1); encode_decode_fin.
    - rewrite (shr_decode_word_correct _ _ H H0); encode_decode_fin.
    - rewrite (shr_decode_register_correct _ _ H H0 _ H1); encode_decode_fin.
    - rewrite (cmpe_decode_word_correct _ _ H); encode_decode_fin.
    - rewrite (cmpe_decode_register_correct _ _ H _ H1); encode_decode_fin.
    - rewrite (cmpa_decode_word_correct _ _ H); encode_decode_fin.
    - rewrite (cmpa_decode_register_correct _ _ H _ H1); encode_decode_fin.
    - rewrite (cmpae_decode_word_correct _ _ H); encode_decode_fin.
    - rewrite (cmpae_decode_register_correct _ _ H _ H1); encode_decode_fin.
    - rewrite (cmpg_decode_word_correct _ _ H); encode_decode_fin.
    - rewrite (cmpg_decode_register_correct _ _ H _ H1); encode_decode_fin.
    - rewrite (cmpge_decode_word_correct _ _ H); encode_decode_fin.
    - rewrite (cmpge_decode_register_correct _ _ H _ H1); encode_decode_fin.
    - rewrite (mov_decode_word_correct _ _ H); encode_decode_fin.
    - rewrite (mov_decode_register_correct _ _ H _ H1); encode_decode_fin.
    - rewrite (cmov_decode_word_correct _ _ H); encode_decode_fin.
    - rewrite (cmov_decode_register_correct _ _ H _ H1); encode_decode_fin.
    - rewrite jmp_decode_word_correct; encode_decode_fin.
    - rewrite (jmp_decode_register_correct _ _ _ H1); encode_decode_fin.
    - rewrite cjmp_decode_word_correct; encode_decode_fin.
    - rewrite (cjmp_decode_register_correct _ _ _ H1); encode_decode_fin.
    - rewrite cnjmp_decode_word_correct; encode_decode_fin.
    - rewrite (cnjmp_decode_register_correct _ _ _ H1); encode_decode_fin.
    - rewrite (store_b_decode_word_correct _ _ H); encode_decode_fin.
    - rewrite (store_b_decode_register_correct _ _ H _ H1); encode_decode_fin.
    - rewrite (load_b_decode_word_correct _ _ H); encode_decode_fin.
    - rewrite (load_b_decode_register_correct _ _ H _ H1); encode_decode_fin.
    - rewrite (store_w_decode_word_correct _ _ H); encode_decode_fin.
    - rewrite (store_w_decode_register_correct _ _ H _ H1); encode_decode_fin.
    - rewrite (load_w_decode_word_correct _ _ H); encode_decode_fin.
    - rewrite (load_w_decode_register_correct _ _ H _ H1); encode_decode_fin.
    - rewrite (read_decode_word_correct _ _ H); encode_decode_fin.
    - rewrite (read_decode_register_correct _ _ H _ H1); encode_decode_fin.
    - rewrite answer_decode_word_correct; encode_decode_fin.
    - rewrite (answer_decode_register_correct _ _ _ H1); encode_decode_fin.
  Qed.

  Variant RiRjACode : t bool 5 -> Prop :=
  | andRiRjA : RiRjACode and_code
  | orRiRjA : RiRjACode or_code
  | xorRiRjA : RiRjACode xor_code
  | addRiRjA : RiRjACode add_code
  | subRiRjA : RiRjACode sub_code
  | mullRiRjA : RiRjACode mull_code
  | umulhRiRjA : RiRjACode umulh_code
  | smulhRiRjA : RiRjACode smulh_code
  | udivRiRjA : RiRjACode udiv_code
  | umodRiRjA : RiRjACode umod_code
  | shlRiRjA : RiRjACode shl_code
  | shrRiRjA : RiRjACode shr_code.

  Variant RiACode : t bool 5 -> Prop :=
  | notRiA     : RiACode not_code
  | movRiA     : RiACode mov_code
  | cmovRiA    : RiACode cmov_code
  | store_bRiA : RiACode store_b_code
  | load_bRiA  : RiACode load_b_code
  | store_wRiA : RiACode store_w_code
  | load_wRiA  : RiACode load_w_code
  | readRiA    : RiACode read_code.

  Variant RjACode : t bool 5 -> Prop :=
  | cmpeRjA  : RjACode cmpe_code
  | cmpaRjA  : RjACode cmpa_code
  | cmpaeRjA : RjACode cmpae_code
  | cmpgRjA  : RjACode cmpg_code
  | cmpgeRjA : RjACode cmpge_code.

  Variant ACode : t bool 5 -> Prop :=
  | jmpA    : ACode jmp_code
  | cjmpA   : ACode cjmp_code
  | cnjmpA  : ACode cnjmp_code
  | answerA : ACode answer_code.

  Variant CanonicalInstruction : Word * Word -> Prop :=
  | CIRiRjA : forall (code : t bool 5) (b : bool)
                     (ri rj : t bool (log2_up registerCount))
                     (A : t bool wordSize),
              RiRjACode code ->
              proj1_sig (bitvector_fin_big ri) < registerCount ->
              proj1_sig (bitvector_fin_big rj) < registerCount ->
              (b = true \/ (b = false /\ proj1_sig (bitvector_fin_big A) < registerCount)) ->
              CanonicalInstruction (cast
                (code ++ [b] ++ ri ++ rj ++ const b0 _)
                (eq_sym interpSplitLemRight), A)
  | CIRiA   : forall (code : t bool 5) (b : bool)
                     (ri : t bool (log2_up registerCount))
                     (A : t bool wordSize),
              RiACode code ->
              proj1_sig (bitvector_fin_big ri) < registerCount ->
              (b = true \/ (b = false /\ proj1_sig (bitvector_fin_big A) < registerCount)) ->
              CanonicalInstruction (cast
                (code ++ [b] ++ ri ++ const b0 _ ++ const b0 _)
                (eq_sym interpSplitLemRight), A)
  | CIRjA   : forall (code : t bool 5) (b : bool)
                     (rj : t bool (log2_up registerCount))
                     (A : t bool wordSize),
              RjACode code ->
              proj1_sig (bitvector_fin_big rj) < registerCount ->
              (b = true \/ (b = false /\ proj1_sig (bitvector_fin_big A) < registerCount)) ->
              CanonicalInstruction (cast
                (code ++ [b] ++ const b0 _ ++ rj ++ const b0 _)
                (eq_sym interpSplitLemRight), A)
  | CIRA    : forall (code : t bool 5) (b : bool)
                     (A : t bool wordSize),
              ACode code ->
              (b = true \/ (b = false /\ proj1_sig (bitvector_fin_big A) < registerCount)) ->
              CanonicalInstruction (cast
                (code ++ [b] ++ const b0 _ ++ const b0 _ ++ const b0 _)
                (eq_sym interpSplitLemRight), A).

  Lemma reg_vect_fit_inv :
    forall (ri : t bool (log2_up registerCount))
           (H : bitvector_nat_big ri < registerCount),
    reg_vect (regFit ri H) = ri.
  Proof.
    intros.
    unfold reg_vect, fin_bitvector_big, regFit.
    change (proj1_sig _) with (bitvector_nat_big ri).
    apply bitvector_nat_big_inv.
  Qed.

  Ltac WordDischarge :=
        unfold InstructionEncode;
        repeat f_equal; apply reg_vect_fit_inv.

  Ltac RegDischarge :=
        unfold InstructionEncode, option_bool, option_word;
        repeat rewrite reg_vect_fit_inv; repeat f_equal;
        unfold regFit, fin_bitvector_big;
        change (proj1_sig (bitvector_fin_big ?A)) with (bitvector_nat_big A);
        apply bitvector_nat_big_inv.

  Theorem DecodeEncode_Cannon_id :
    forall i,
    CanonicalInstruction i ->
    InstructionEncode (uncurry InstructionDecode i) = i.
  Proof.
    intros i CIw12.
    destruct CIw12; unfold uncurry; destruct b.
    - destruct H.
      + rewrite (and_decode_word_correct _ _ H0 H1); WordDischarge.
      + rewrite (or_decode_word_correct _ _ H0 H1); WordDischarge.
      + rewrite (xor_decode_word_correct _ _ H0 H1); WordDischarge.
      + rewrite (add_decode_word_correct _ _ H0 H1); WordDischarge.
      + rewrite (sub_decode_word_correct _ _ H0 H1); WordDischarge.
      + rewrite (mull_decode_word_correct _ _ H0 H1); WordDischarge.
      + rewrite (umulh_decode_word_correct _ _ H0 H1); WordDischarge.
      + rewrite (smulh_decode_word_correct _ _ H0 H1); WordDischarge.
      + rewrite (udiv_decode_word_correct _ _ H0 H1); WordDischarge.
      + rewrite (umod_decode_word_correct _ _ H0 H1); WordDischarge.
      + rewrite (shl_decode_word_correct _ _ H0 H1); WordDischarge.
      + rewrite (shr_decode_word_correct _ _ H0 H1); WordDischarge.
    - destruct H2 as [H2|[_ H2]]. { discriminate H2. }
      destruct H.
      + rewrite (and_decode_register_correct _ _ H0 H1 _ H2); RegDischarge.
      + rewrite (or_decode_register_correct _ _ H0 H1 _ H2); RegDischarge.
      + rewrite (xor_decode_register_correct _ _ H0 H1 _ H2); RegDischarge.
      + rewrite (add_decode_register_correct _ _ H0 H1 _ H2); RegDischarge.
      + rewrite (sub_decode_register_correct _ _ H0 H1 _ H2); RegDischarge.
      + rewrite (mull_decode_register_correct _ _ H0 H1 _ H2); RegDischarge.
      + rewrite (umulh_decode_register_correct _ _ H0 H1 _ H2); RegDischarge.
      + rewrite (smulh_decode_register_correct _ _ H0 H1 _ H2); RegDischarge.
      + rewrite (udiv_decode_register_correct _ _ H0 H1 _ H2); RegDischarge.
      + rewrite (umod_decode_register_correct _ _ H0 H1 _ H2); RegDischarge.
      + rewrite (shl_decode_register_correct _ _ H0 H1 _ H2); RegDischarge.
      + rewrite (shr_decode_register_correct _ _ H0 H1 _ H2); RegDischarge.
    - destruct H.
      + rewrite (not_decode_word_correct _ _ H0); WordDischarge.
      + rewrite (mov_decode_word_correct _ _ H0); WordDischarge.
      + rewrite (cmov_decode_word_correct _ _ H0); WordDischarge.
      + rewrite (store_b_decode_word_correct _ _ H0); WordDischarge.
      + rewrite (load_b_decode_word_correct _ _ H0); WordDischarge.
      + rewrite (store_w_decode_word_correct _ _ H0); WordDischarge.
      + rewrite (load_w_decode_word_correct _ _ H0); WordDischarge.
      + rewrite (read_decode_word_correct _ _ H0); WordDischarge.
    - destruct H1 as [H1|[_ H1]]. { discriminate H1. }
      destruct H.
      + rewrite (not_decode_register_correct _ _ H0 _ H1); RegDischarge.
      + rewrite (mov_decode_register_correct _ _ H0 _ H1); RegDischarge.
      + rewrite (cmov_decode_register_correct _ _ H0 _ H1); RegDischarge.
      + rewrite (store_b_decode_register_correct _ _ H0 _ H1); RegDischarge.
      + rewrite (load_b_decode_register_correct _ _ H0 _ H1); RegDischarge.
      + rewrite (store_w_decode_register_correct _ _ H0 _ H1); RegDischarge.
      + rewrite (load_w_decode_register_correct _ _ H0 _ H1); RegDischarge.
      + rewrite (read_decode_register_correct _ _ H0 _ H1); RegDischarge.
    - destruct H.
      + rewrite (cmpe_decode_word_correct _ _ H0); WordDischarge.
      + rewrite (cmpa_decode_word_correct _ _ H0); WordDischarge.
      + rewrite (cmpae_decode_word_correct _ _ H0); WordDischarge.
      + rewrite (cmpg_decode_word_correct _ _ H0); WordDischarge.
      + rewrite (cmpge_decode_word_correct _ _ H0); WordDischarge.
    - destruct H1 as [H1|[_ H1]]. { discriminate H1. }
      destruct H.
      + rewrite (cmpe_decode_register_correct _ _ H0 _ H1); RegDischarge.
      + rewrite (cmpa_decode_register_correct _ _ H0 _ H1); RegDischarge.
      + rewrite (cmpae_decode_register_correct _ _ H0 _ H1); RegDischarge.
      + rewrite (cmpg_decode_register_correct _ _ H0 _ H1); RegDischarge.
      + rewrite (cmpge_decode_register_correct _ _ H0 _ H1); RegDischarge.
    - destruct H.
      + rewrite jmp_decode_word_correct; WordDischarge.
      + rewrite cjmp_decode_word_correct; WordDischarge.
      + rewrite cnjmp_decode_word_correct; WordDischarge.
      + rewrite answer_decode_word_correct; WordDischarge.
    - destruct H0 as [H0|[_ H0]]. { discriminate H0. }
      destruct H.
      + rewrite (jmp_decode_register_correct _ _ _ H0); RegDischarge.
      + rewrite (cjmp_decode_register_correct _ _ _ H0); RegDischarge.
      + rewrite (cnjmp_decode_register_correct _ _ _ H0); RegDischarge.
      + rewrite (answer_decode_register_correct _ _ _ H0); RegDischarge.
  Qed.

End TinyRAMCoding.


Require Import Coq.Arith.Arith.
Require Import Coq.Bool.Bool.
Require Import Coq.Strings.String.
Require Import Coq.Logic.FunctionalExtensionality.

Inductive id : Type :=
  | Id : string -> id.

Definition beq_id x y :=
  match x,y with
  | Id n1, Id n2 =>
    if string_dec n1 n2
    then true
    else false
  end.

Theorem beq_id_refl: forall id,
  true = beq_id id id.
Proof.
  intros [n]. simpl. destruct (string_dec n n).
  - reflexivity.
  - destruct n0. reflexivity.
  Qed.

Theorem beq_id_true_iff:forall x y : id,
  beq_id x y = true <-> x = y.
Proof.
  intros [n1] [n2].
  unfold beq_id.
  destruct (string_dec n1 n2).
  - subst. split. reflexivity. reflexivity.
  - split.
    + intros contra. inversion contra.
    + intros H. inversion H. subst. destruct n.
  reflexivity.
  Qed.

Theorem beq_id_false_iff: forall x y : id,
  beq_id x y = false <-> x <> y.
Proof.
  intros [n1] [n2]. unfold not. simpl.
  split.
  - intros eq. destruct (string_dec n1 n2).
    + inversion eq.
    + intros H. inversion H. subst. destruct n.
    reflexivity.
  - intros eq. destruct (string_dec n1 n2).
    + rewrite e in eq. destruct eq.
      * reflexivity.
    + reflexivity.
  Qed.

Theorem false_beq_id: forall x y : id,
  x <> y -> beq_id x y = false.
Proof.
  unfold not. intros x y eq.
  destruct (beq_id x y) eqn:H.
  - apply beq_id_true_iff in H.
  apply eq in H. destruct H.
  - reflexivity.
  Qed.

Definition total_map(A:Type) := id->A.

Definition t_empty{A:Type}(v:A) : total_map A
  := (fun _ => v).

Definition t_update{A:Type}(m:total_map A)
  (x:id)(v:A) :=
  fun x' => if beq_id x x' then v else m x'.

Definition examplemap :=
  t_update (t_update (t_empty false) (Id "foo") false)
          (Id "bar") true.

 Example update_example1 : examplemap (Id "baz") = false.
Proof. reflexivity. Qed.

Example update_example2 : examplemap (Id "foo") = false.
Proof. reflexivity. Qed.

Example update_example3 : examplemap (Id "quux") = false.
Proof. reflexivity. Qed.

Example update_example4 : examplemap (Id "bar") = true.
Proof. reflexivity. Qed.

(* Exercise t_apply_empty *)
Lemma t_apply_empty : forall A x v,
  @t_empty A v x = v.
Proof.
  intros A x v.
  unfold t_empty. reflexivity.
  Qed.

(* Exercise t_update_eq *)
Lemma t_update_eq: forall A (m:total_map A) x v,
  (t_update m x v) x = v.
Proof.
  intros A m x v.
  unfold t_update.
  rewrite <- beq_id_refl. reflexivity.
  Qed.

(* Exercise t_update_neq *)
Theorem t_update_neq: forall (X:Type) v x1 x2
    (m:total_map X),
  x1 <> x2 ->
  (t_update m x1 v) x2 = m x2.
Proof.
  intros X v x1 x2 m eq.
  unfold t_update.
  apply false_beq_id in eq.
  rewrite eq. reflexivity.
  Qed.

(* Exercise t_update_shadow *)
Lemma t_update_shadow: forall A (m:total_map A)
  v1 v2 x,
  t_update (t_update m x v1) x v2
  = t_update m x v2.
Proof.
  intros A m v1 v2 x.
  unfold t_update.
  apply functional_extensionality.
  intros x0.
  destruct (beq_id x x0).
  - reflexivity.
  - reflexivity.
  Qed.

(* Exercise beq_idP *)
Lemma beq_idP: forall x y,
  reflect (x = y) (beq_id x y).
Proof.
  intros x y.
  destruct (beq_id x y) eqn:H.
  - apply beq_id_true_iff in H.
  rewrite H. apply ReflectT. reflexivity.
  - apply beq_id_false_iff in H.
  apply ReflectF. apply H.
  Qed.

(* Exercise t_update_same *)
Theorem t_update_same : forall X x (m:total_map X),
  t_update m x (m x) = m.
Proof.
  intros X x m.
  apply functional_extensionality.
  intros x0.
  unfold t_update.
  destruct (beq_idP x x0).
  - rewrite e. reflexivity.
  - reflexivity.
  Qed.

(* Exercise t_update_permute *)
Theorem t_update_permute: forall (X:Type)
  v1 v2 x1 x2 (m:total_map X),
  x2 <> x1 ->
  (t_update (t_update m x2 v2) x1 v1)
  = (t_update (t_update m x1 v1) x2 v2).
Proof.
  intros X v1 v2 x1 x2 m eq.
  apply functional_extensionality.
  intros x.
  unfold t_update.
  destruct (beq_idP x1 x).
  - destruct (beq_idP x2 x).
    + rewrite <- e0 in e. rewrite e in eq.
    destruct eq.
    reflexivity.
    + reflexivity.
  - destruct (beq_idP x2 x).
    + reflexivity.
    + reflexivity.
  Qed.

Definition partial_map (A:Type) := total_map (option A).

Definition empty {A:Type} : partial_map A :=
  t_empty None.

Definition update {A:Type} (m : partial_map A)
                  (x : id) (v : A) :=
  t_update m x (Some v).

Lemma apply_empty: forall A x, @empty A x = None.
Proof.
  intros A x. unfold empty. unfold t_empty.
  reflexivity.
  Qed.

Lemma update_eq: forall A (m:partial_map A) x v,
  (update m x v) x = Some v.
Proof.
  intros A m x v.
  unfold update. unfold t_update.
  rewrite <- beq_id_refl. reflexivity.
  Qed.

Lemma update_neq: forall (X:Type) v x1 x2
    (m:partial_map X),
  x2 <> x1 ->
  (update m x2 v) x1 = m x1.
Proof.
  intros X v x1 x2 m eq.
  unfold update. unfold t_update.
  apply beq_id_false_iff in eq.
  rewrite eq.
  reflexivity.
  Qed.

Lemma update_shadow: forall A (m:partial_map A)
  v1 v2 x,
  update (update m x v1) x v2 = update m x v2.
Proof.
  intros A m v1 v2 x. unfold update.
  unfold t_update. apply functional_extensionality.
  intros x0.
  destruct (beq_idP x x0).
  - reflexivity.
  - reflexivity.
  Qed.

Theorem update_same: forall X v x (m:partial_map X),
  m x = Some v ->
  update m x v = m.
Proof.
  intros X v x m eq. unfold update.
  unfold t_update. apply functional_extensionality.
  intros x0.
  destruct (beq_idP x x0).
  - rewrite <- eq. rewrite e. reflexivity.
  - reflexivity.
  Qed.

Theorem update_permute: forall (X:Type) v1 v2 x1 x2
  (m:partial_map X),
  x2 <> x1 ->
  (update (update m x2 v2) x1 v1) =
  (update (update m x1 v1) x2 v2).
Proof.
  intros X v1 v2 x1 x2 m eq.
  unfold not. unfold update. unfold t_update.
  apply functional_extensionality.
  intros x.
  destruct (beq_idP x1 x).
  - destruct (beq_idP x2 x).
    + rewrite e in eq. rewrite e0 in eq.
      destruct eq. reflexivity.
    + reflexivity.
  - destruct (beq_idP x2 x).
    + reflexivity.
    + reflexivity.
  Qed.