Require Import
        Eqdep_dec
        Fiat.Common
        Fiat.Computation.Notations
        Fiat.BinEncoders.Env.Common.Specs
        Coq.Numbers.BinNums
        Fiat.BinEncoders.Env.Lib2.WordOpt
        Fiat.BinEncoders.Env.Common.WordFacts
        compcert.lib.Integers.

Unset Implicit Arguments.

Module Make (WS : WORDSIZE).

  Include compcert.lib.Integers.Make(WS).

  Section Int.
    Context {B : Type}.
    Context {cache : Cache}.
    Context {cacheAddNat : CacheAdd cache nat}.
    Context {transformer : Transformer B}.
    Context {transformerUnit : QueueTransformerOpt transformer bool}.

    Definition intToWord (sz : nat) (i : int) : word sz :=
      match intval i with
      | 0%Z => wzero sz
      | Zpos p => posToWord sz p
      | _ => wzero sz
      end.

    Definition wordToInt {sz : nat} (w : word sz) : int :=
      repr (BinInt.Z.of_N (wordToN w)).

    Lemma intToWord_wordToInt
      : forall {sz} w,
        le sz wordsize
        -> intToWord sz (wordToInt w) = w.
    Proof.
      unfold wordToInt, intToWord, repr; simpl.
      intros; rewrite Z_mod_modulus_eq.
      unfold modulus.
      rewrite Coqlib.Zmod_small.
      replace (match BinInt.Z.of_N (wordToN w) with
               | 0%Z => wzero sz
               | Zpos p => posToWord sz p
               | Zneg _ => wzero sz
               end)
      with (match (wordToN w) with
            | 0%N => wzero sz
            | Npos p => posToWord sz p
            end) by (destruct (wordToN w); reflexivity).
      apply wordToN_inj.
      rewrite wordToN_nat at 1.
      destruct (wordToN w) eqn: ?.
      - replace (wordToNat (wzero sz)) with 0.
        reflexivity.
        clear; induction sz; simpl; eauto.
        replace (natToWord sz 0) with (wzero sz).
        rewrite <- IHsz; reflexivity.
        clear; induction sz; simpl; eauto.
      - rewrite posToWord_nat, wordToNat_natToWord_idempotent,
        Znat.positive_nat_N; eauto.
        rewrite Znat.positive_nat_N, <- Heqn.
        apply Nomega.Nlt_in;
          rewrite Npow2_nat, wordToN_nat, Nnat.Nat2N.id.
        apply wordToNat_bound.
      - split.
        + destruct ((wordToN w)); compute; congruence.
        + replace (Zpower.two_power_nat wordsize) with (BinInt.Z.of_N (Npow2 wordsize)).
          * apply Znat.N2Z.inj_lt.
            apply Nomega.Nlt_in;
              rewrite Npow2_nat, wordToN_nat, Nnat.Nat2N.id.
            eapply NPeano.Nat.lt_le_trans.
            apply wordToNat_bound.
            induction H; eauto.
            simpl; omega.
          * clear H;
              rewrite <- Znat.N_nat_Z, Zpower.two_power_nat_correct,
              Npow2_nat.
            induction wordsize; simpl; auto.
            rewrite <- IHn.
            rewrite !Znat.Nat2Z.inj_add.
            simpl.
            destruct (BinInt.Z.of_nat (pow2 n)); simpl.
            reflexivity.
            rewrite BinPos.Pos.add_diag; auto.
            rewrite BinPos.Pos.add_diag; auto.
    Qed.

    Definition encode_int_Spec (sz : nat) (i : int) (ce : CacheEncode) : Comp (B * CacheEncode) := encode_word_Spec (intToWord sz i) ce.

    Definition decode_int (sz : nat) (b : B) (cd : CacheDecode) : option (int * B * CacheDecode) :=
      `(w, b, cd) <- decode_word (sz:=sz) b cd;
        Some (wordToInt w, b, cd).

    Theorem innt_decode_correct
            (sz : nat)
            (sz_OK : le sz wordsize)
            {P : CacheDecode -> Prop}
            (P_OK : cache_inv_Property P (fun P => forall b cd, P cd -> P (addD cd b)))
      : encode_decode_correct_f cache transformer (fun i : int => BinInt.Z.lt (intval i) (BinInt.Z.of_N (Npow2 sz)))
                                (fun _ _ => True) (encode_int_Spec sz) (decode_int sz) P.
  Proof.
    unfold encode_decode_correct_f, encode_int_Spec, decode_int.
    split.
    { intros env xenv xenv' n n' ext ? Eeq Ppred Ppred_rest Penc.
      destruct (proj1 (Word_decode_correct P_OK) _ _ _ _ _ ext env_OK Eeq I I Penc) as [? [? [? xenv_OK] ] ].
      rewrite H; simpl; eexists; intuition eauto.
      repeat f_equal.
      unfold wordToInt, intToWord; destruct n; unfold repr; simpl.
      apply mkint_eq.
      rewrite Z_mod_modulus_eq.
      destruct intval0; simpl in *.
      - replace (wordToN (wzero sz)) with 0%N.
        reflexivity.
          clear; induction sz; simpl; eauto;
            unfold wzero in IHsz; rewrite <- IHsz; eauto.
      - rewrite posToWord_nat, wordToN_nat,
        wordToNat_natToWord_idempotent, Znat.positive_nat_N.
        apply Coqlib.Zmod_small; intuition.
        rewrite Znat.positive_nat_N.
        apply Znat.N2Z.inj_lt; simpl; eauto.
      - destruct intrange0.
        destruct p; compute in l; congruence.
    }
    { intros env xenv xenv' n n' ext Eeq OK_env Penc.
      destruct (decode_word n' xenv) as [ [ [? ? ] ? ] | ] eqn: ? ;
        simpl in *; try discriminate.
      injections.
      eapply (proj2 (Word_decode_correct P_OK)) in Heqo;
        destruct Heqo; destruct_ex; intuition; subst; eauto.
      unfold encode_word_Spec in *; computes_to_inv; injections.
      rewrite intToWord_wordToInt by eauto.
      - repeat eexists; eauto.
        unfold wordToInt; simpl.
        assert (BinInt.Z.lt (BinInt.Z.of_N (wordToN w)) (BinInt.Z.of_N (Npow2 sz))).
        { apply Znat.N2Z.inj_lt; simpl; eauto.
          apply Nomega.Nlt_in.
          rewrite Npow2_nat, wordToN_nat, Nnat.Nat2N.id.
          apply wordToNat_bound.
        }
        rewrite Z_mod_modulus_eq.
        destruct (Coqlib.zlt (BinInt.Z.of_N (wordToN w)) modulus).
        + rewrite Coqlib.Zmod_small; intuition.
          apply (Znat.N2Z.inj_le 0).
          destruct (wordToN w); compute; congruence.
        + etransitivity.
          apply Zdiv.Z_mod_lt.
          reflexivity.
          eapply BinInt.Z.le_lt_trans.
          eapply BinInt.Z.ge_le_iff; eassumption.
          eassumption.
    }
  Qed.

  End Int.

End Make.


From Coq Require Import Arith NArith ZArith String.
From Coq Require Import Lia Bool.
From Coq Require Import Eqdep_dec.
From Coq Require Import Int63.

Require Import Nibble.
Local Open Scope N_scope.

Inductive instruction :=
(* 0x00 *)
| STOP
| ADD
| MUL
| SUB
| DIV
| SDIV
| MOD
| SMOD
| ADDMOD
| MULMOD
| EXP
| SIGNEXTEND

(* 0x10 *)
| LT
| GT
| SLT
| SGT
| EQ
| ISZERO
| AND
| OR
| XOR
| NOT
| BYTE
| SHL
| SHR
| SAR

(* 0x20 *)
| SHA3

(* 0x30 *)
| ADDRESS
| BALANCE
| ORIGIN
| CALLER
| CALLVALUE
| CALLDATALOAD
| CALLDATASIZE
| CALLDATACOPY
| CODESIZE
| CODECOPY
| GASPRICE
| EXTCODESIZE
| EXTCODECOPY
| RETURNDATASIZE
| RETURNDATACOPY
| EXTCODEHASH

(* 0x40 *)
| BLOCKHASH
| COINBASE
| TIMESTAMP
| NUMBER
| DIFFICULTY
| GASLIMIT
| CHAINID (* https://eips.ethereum.org/EIPS/eip-1344 *)
| SELFBALANCE

(* 0x50 *)
| POP
| MLOAD
| MSTORE
| MSTORE8
| SLOAD
| SSTORE
| JUMP
| JUMPI
| PC
| MSIZE
| GAS
| JUMPDEST

(* 0x60 *)
| PUSH (n: N) (ok: andb (0 <? n) (n <=? 32) = true)

(* 0x80 *)
| DUP  (n: N) (ok: andb (0 <? n) (n <=? 16) = true)

(* 0x90 *)
| SWAP (n: N) (ok: andb (0 <? n) (n <=? 16) = true)

(* 0xa0 *)
| LOG (n: N) (ok: n <=? 4 = true)

(* 0xf0 *)
| CREATE
| CALL
| CALLCODE
| RETURN
| DELEGATECALL
| CREATE2
| STATICCALL
| REVERT
| SELFDESTRUCT.

Definition opcode_of_push (n: N) (ok: andb (0 <? n) (n <=? 32) = true)
: byte
:= byte_of_N (N_of_byte (byte_of_hex_digits x6 x0) + N.pred n).

Definition opcode_of_dup (n: N) (ok: andb (0 <? n) (n <=? 16) = true)
: byte
:= byte_of_N (N_of_byte (byte_of_hex_digits x8 x0) + N.pred n).

Definition opcode_of_swap (n: N) (ok: andb (0 <? n) (n <=? 16) = true)
: byte
:= byte_of_N (N_of_byte (byte_of_hex_digits x9 x0) + N.pred n).

Definition opcode_of_log (n: N) (ok: n <=? 4 = true)
: byte
:= byte_of_N (N_of_byte (byte_of_hex_digits xA x0) + n).

Lemma push_helper_0 (d: hex_digit):
  ((0 <? N_of_hex_digit d + 1) && (N_of_hex_digit d + 1 <=? 32))%bool = true.
Proof.
  apply andb_true_intro. split.
  { rewrite N.ltb_lt. apply N.add_pos_r. apply N.lt_0_1. }
  rewrite N.leb_le.
  assert(UB := N_of_hex_digit_ub d).
  (* lia works here but it's too late, here's the manual proof: *)
  apply N.lt_pred_le. rewrite N.add_1_r. rewrite N.pred_succ.
  apply (N.lt_trans _ _ _ UB).
  rewrite<- N.ltb_lt. trivial.
Qed.

Lemma push_helper_16 (d: hex_digit):
  ((0 <? N_of_hex_digit d + 17) && (N_of_hex_digit d + 17 <=? 32))%bool = true.
Proof.
  apply andb_true_intro. split.
  { rewrite N.ltb_lt. apply N.add_pos_r. apply N.lt_0_1. }
  rewrite N.leb_le.
  assert(UB := N_of_hex_digit_ub d).
  remember (N_of_hex_digit d) as n. clear Heqn.
  apply N.lt_le_pred in UB. cbn in UB.
  apply (N.add_le_mono n 15 17 17) in UB.
  { cbn in UB. exact UB. }
  apply N.le_refl.
Qed.

Definition x6_to_push (low: hex_digit)
: instruction
:= PUSH (N_of_hex_digit low + 1) (push_helper_0 low).

Definition x7_to_push (low: hex_digit)
: instruction
:= PUSH (N_of_hex_digit low + 17) (push_helper_16 low).

Lemma dup_swap_helper (d: hex_digit):
  ((0 <? N_of_hex_digit d + 1) && (N_of_hex_digit d + 1 <=? 16))%bool = true.
Proof.
  apply andb_true_intro. split.
  { rewrite N.ltb_lt. apply N.add_pos_r. apply N.lt_0_1. }
  rewrite N.leb_le.
  assert(UB := N_of_hex_digit_ub d).
  apply N.lt_pred_le. rewrite N.add_1_r. rewrite N.pred_succ.
  exact UB.
Qed.

Definition x8_to_dup (low: hex_digit)
: instruction
:= DUP (N_of_hex_digit low + 1) (dup_swap_helper low).

Definition x9_to_swap (low: hex_digit)
: instruction
:= SWAP (N_of_hex_digit low + 1) (dup_swap_helper low).

Definition byte_of_instruction (op: instruction)
: byte
:= let x := byte_of_hex_digits in
   match op with
   (* 0x00 *)
   | STOP       => x x0 x0
   | ADD        => x x0 x1
   | MUL        => x x0 x2
   | SUB        => x x0 x3
   | DIV        => x x0 x4
   | SDIV       => x x0 x5
   | MOD        => x x0 x6
   | SMOD       => x x0 x7
   | ADDMOD     => x x0 x8
   | MULMOD     => x x0 x9
   | EXP        => x x0 xA
   | SIGNEXTEND => x x0 xB

   (* 0x10 *)
   | LT     => x x1 x0
   | GT     => x x1 x1
   | SLT    => x x1 x2
   | SGT    => x x1 x3
   | EQ     => x x1 x4
   | ISZERO => x x1 x5
   | AND    => x x1 x6
   | OR     => x x1 x7
   | XOR    => x x1 x8
   | NOT    => x x1 x9
   | BYTE   => x x1 xA
   | SHL    => x x1 xB
   | SHR    => x x1 xC
   | SAR    => x x1 xD

   (* 0x20 *)
   | SHA3 => x x2 x0

   (* 0x30 *)
   | ADDRESS        => x x3 x0
   | BALANCE        => x x3 x1
   | ORIGIN         => x x3 x2
   | CALLER         => x x3 x3
   | CALLVALUE      => x x3 x4
   | CALLDATALOAD   => x x3 x5
   | CALLDATASIZE   => x x3 x6
   | CALLDATACOPY   => x x3 x7
   | CODESIZE       => x x3 x8
   | CODECOPY       => x x3 x9
   | GASPRICE       => x x3 xA
   | EXTCODESIZE    => x x3 xB
   | EXTCODECOPY    => x x3 xC
   | RETURNDATASIZE => x x3 xD
   | RETURNDATACOPY => x x3 xE
   | EXTCODEHASH    => x x3 xF

   (* 0x40 *)
   | BLOCKHASH   => x x4 x0
   | COINBASE    => x x4 x1
   | TIMESTAMP   => x x4 x2
   | NUMBER      => x x4 x3
   | DIFFICULTY  => x x4 x4
   | GASLIMIT    => x x4 x5
   | CHAINID     => x x4 x6
   | SELFBALANCE => x x4 x7

   (* 0x50 *)
   | POP      => x x5 x0
   | MLOAD    => x x5 x1
   | MSTORE   => x x5 x2
   | MSTORE8  => x x5 x3
   | SLOAD    => x x5 x4
   | SSTORE   => x x5 x5
   | JUMP     => x x5 x6
   | JUMPI    => x x5 x7
   | PC       => x x5 x8
   | MSIZE    => x x5 x9
   | GAS      => x x5 xA
   | JUMPDEST => x x5 xB

   (* 0x60 *)
   | PUSH n ok => opcode_of_push n ok

   (* 0x80 *)
   | DUP n ok => opcode_of_dup n ok

   (* 0x90 *)
   | SWAP n ok => opcode_of_swap n ok

   (* 0xa0 *)
   | LOG n ok => opcode_of_log n ok

   (* 0xf0 *)
   | CREATE       => x xF x0
   | CALL         => x xF x1
   | CALLCODE     => x xF x2
   | RETURN       => x xF x3
   | DELEGATECALL => x xF x4
   | CREATE2      => x xF x5
   | STATICCALL   => x xF xA
   | REVERT       => x xF xD
   | SELFDESTRUCT => x xF xF
   end.

Definition instruction_of_byte (b: byte)
: option instruction
:= let (high, low) := hex_digits_of_byte b in
   match high with
   | x0 =>
      match low with
      | x0 => Some STOP
      | x1 => Some ADD
      | x2 => Some MUL
      | x3 => Some SUB
      | x4 => Some DIV
      | x5 => Some SDIV
      | x6 => Some MOD
      | x7 => Some SMOD
      | x8 => Some ADDMOD
      | x9 => Some MULMOD
      | xA => Some EXP
      | xB => Some SIGNEXTEND
      | _ => None
      end
   | x1 =>
      match low with
      | x0 => Some LT
      | x1 => Some GT
      | x2 => Some SLT
      | x3 => Some SGT
      | x4 => Some EQ
      | x5 => Some ISZERO
      | x6 => Some AND
      | x7 => Some OR
      | x8 => Some XOR
      | x9 => Some NOT
      | xA => Some BYTE
      | xB => Some SHL
      | xC => Some SHR
      | xD => Some SAR
      | _ => None
      end
   | x2 =>
      match low with
      | x0 => Some SHA3
      | _ => None
      end
   | x3 =>
      match low with
      | x0 => Some ADDRESS
      | x1 => Some BALANCE
      | x2 => Some ORIGIN
      | x3 => Some CALLER
      | x4 => Some CALLVALUE
      | x5 => Some CALLDATALOAD
      | x6 => Some CALLDATASIZE
      | x7 => Some CALLDATACOPY
      | x8 => Some CODESIZE
      | x9 => Some CODECOPY
      | xA => Some GASPRICE
      | xB => Some EXTCODESIZE
      | xC => Some EXTCODECOPY
      | xD => Some RETURNDATASIZE
      | xE => Some RETURNDATACOPY
      | xF => Some EXTCODEHASH
      end
    | x4 =>
      match low with
      | x0 => Some BLOCKHASH
      | x1 => Some COINBASE
      | x2 => Some TIMESTAMP
      | x3 => Some NUMBER
      | x4 => Some DIFFICULTY
      | x5 => Some GASLIMIT
      | x6 => Some CHAINID
      | x7 => Some SELFBALANCE
      | _ => None
      end
    | x5 =>
      match low with
      | x0 => Some POP
      | x1 => Some MLOAD
      | x2 => Some MSTORE
      | x3 => Some MSTORE8
      | x4 => Some SLOAD
      | x5 => Some SSTORE
      | x6 => Some JUMP
      | x7 => Some JUMPI
      | x8 => Some PC
      | x9 => Some MSIZE
      | xA => Some GAS
      | xB => Some JUMPDEST
      | _ => None
      end
    | x6 => Some (x6_to_push low)
    | x7 => Some (x7_to_push low)
    | x8 => Some (x8_to_dup low)
    | x9 => Some (x9_to_swap low)
    | xA =>
      match low with
      | x0 => Some (LOG 0 eq_refl)
      | x1 => Some (LOG 1 eq_refl)
      | x2 => Some (LOG 2 eq_refl)
      | x3 => Some (LOG 3 eq_refl)
      | x4 => Some (LOG 4 eq_refl)
      | _ => None
      end
    | xF =>
      match low with
      | x0 => Some CREATE
      | x1 => Some CALL
      | x2 => Some CALLCODE
      | x3 => Some RETURN
      | x4 => Some DELEGATECALL
      | x5 => Some CREATE2
      (* 6-9 => None *)
      | xA => Some STATICCALL
      (* B,C => None *)
      | xD => Some REVERT
      (* E => None *)
      | xF => Some SELFDESTRUCT
      | _ => None
      end
    | _ => None
   end.

Lemma byte_of_instruction_of_byte (b: byte):
  match instruction_of_byte b with
  | Some op => byte_of_instruction op = b
  | None => True
  end.
Proof.
cbn. destruct b.
destruct a7; destruct a6; destruct a5; destruct a4;
destruct a3; destruct a2; destruct a1; destruct a0; easy.
Qed.

Lemma instruction_irrel {bound: N}
                        (OP: forall n: N, (0 <? n) && (n <=? bound) = true -> instruction)
                        {a b: N}
                        (OkA: (0 <? a) && (a <=? bound) = true)
                        (OkB: (0 <? b) && (b <=? bound) = true)
                        (E: a = b):
  OP a OkA = OP b OkB.
Proof.
subst. f_equal. apply eq_proofs_unicity. decide equality.
Qed.

Lemma instruction_of_byte_of_instruction (op: instruction):
  instruction_of_byte (byte_of_instruction op) = Some op.
Proof.
cbn. destruct op; trivial; remember (byte_of_instruction _) as b;
  unfold byte_of_instruction in Heqb;
  try (
    assert (ok' := ok);
    try rewrite andb_true_iff in ok';
    try destruct ok' as (LB, UB);
    try apply N.ltb_lt in LB;
    try apply N.leb_le in UB;
    try apply N.leb_le in ok'
  );
  remember (pop_nibble (N.pred n)) as p;
  assert(Q := pop_nibble_then_push (N.pred n));
  destruct p as (k, nib);
  rewrite<- Heqp in Q; cbn in Q;
  rewrite push_nibble_arith in Q;
  unfold opcode_of_push in Heqb;
  unfold opcode_of_dup in Heqb;
  unfold opcode_of_swap in Heqb;
  unfold opcode_of_log in Heqb;
  rewrite<- Q in Heqp;
  assert (B16 := N_of_nibble_bound nib);
  remember (N_of_nibble nib) as m; clear Heqm;
  subst.
{ (* PUSH *)
  rewrite<- Q.
  replace (N_of_byte (byte_of_hex_digits x6 x0) + (16 * k + m)) with
          (16 * (k + 6) + m).
  2:{
    remember (N_of_byte (byte_of_hex_digits _ _)) as offset.
    cbn in Heqoffset. subst.
    lia.
  }
  rewrite byte_of_N_arith; try assumption. 2:{ lia. }
  rewrite high_nibble_ok. rewrite low_nibble_ok.
  remember (nibble_of_N m) as low.
  assert (M: m = N_of_nibble low).
  { subst. now rewrite N_of_nibble_of_N. }
  clear Heqlow.
  assert (R: n = 16 * k + m + 1). { lia. }
  clear Q.
  assert (K: k <= 1). { lia. }
  destruct k.
  {
    cbn. subst. f_equal.
    unfold x6_to_push.
    apply instruction_irrel.
    destruct low as (a3, a2, a1, a0); destruct a3; destruct a2; destruct a1; destruct a0; easy.
  }
  assert (P: p = 1%positive). { lia. }
  subst. unfold x7_to_push. cbn. f_equal.
  apply instruction_irrel.
  destruct low as (a3, a2, a1, a0); destruct a3; destruct a2; destruct a1; destruct a0; easy.
}
{ (* DUP *)
  assert (K: k = 0). { lia. } subst k. rewrite<- Q in *.
  replace (N_of_byte (byte_of_hex_digits x8 x0) + (16 * 0 + m)) with
          (16 * 8 + m).
  2:{
    remember (N_of_byte (byte_of_hex_digits _ _)) as offset.
    cbn in Heqoffset. subst.
    lia.
  }
  rewrite byte_of_N_arith; try assumption. 2:{ lia. }
  rewrite high_nibble_ok. rewrite low_nibble_ok.
  remember (nibble_of_N m) as low.
  assert (M: m = N_of_nibble low).
  { subst. now rewrite N_of_nibble_of_N. }
  clear Heqlow.
  assert (R: n = m + 1). { lia. }
  cbn. unfold x8_to_dup. f_equal.
  apply instruction_irrel. subst.
  destruct low as (a3, a2, a1, a0); destruct a3; destruct a2; destruct a1; destruct a0; easy.
}
{ (* SWAP *) (* XXX: just copying *)
  assert (K: k = 0). { lia. } subst k. rewrite<- Q in *.
  replace (N_of_byte (byte_of_hex_digits x9 x0) + (16 * 0 + m)) with
          (16 * 9 + m).
  2:{
    remember (N_of_byte (byte_of_hex_digits _ _)) as offset.
    cbn in Heqoffset. subst.
    lia.
  }
  rewrite byte_of_N_arith; try assumption. 2:{ lia. }
  rewrite high_nibble_ok. rewrite low_nibble_ok.
  remember (nibble_of_N m) as low.
  assert (M: m = N_of_nibble low).
  { subst. now rewrite N_of_nibble_of_N. }
  clear Heqlow.
  assert (R: n = m + 1). { lia. }
  cbn. unfold x9_to_swap. f_equal.
  apply instruction_irrel. subst.
  destruct low as (a3, a2, a1, a0); destruct a3; destruct a2; destruct a1; destruct a0; easy.
}
(* LOG *)
clear Heqp Q B16 m nib k.
remember (pop_nibble n) as p.
assert(Q := pop_nibble_then_push n).
destruct p as (k, nib).
rewrite<- Heqp in Q. cbn in Q.
rewrite push_nibble_arith in Q.
unfold opcode_of_log.
rewrite<- Q in Heqp.
assert (B16 := N_of_nibble_bound nib).
remember (N_of_nibble nib) as m; clear Heqm.

assert (K: k = 0). { lia. } subst k.
replace (N_of_byte (byte_of_hex_digits xA x0) + n) with
        (16 * 10 + m).
2:{
  remember (N_of_byte (byte_of_hex_digits _ _)) as offset.
  cbn in Heqoffset. subst.
  lia.
}
rewrite byte_of_N_arith; try assumption. 2:{ lia. }
rewrite high_nibble_ok. rewrite low_nibble_ok.
remember (nibble_of_N m) as low.
assert (M: m = N_of_nibble low).
{ subst. now rewrite N_of_nibble_of_N. }
clear Heqlow.
assert (R: n = m). { lia. } clear Q.
subst. cbn.
destruct low as (a3, a2, a1, a0); destruct a3; destruct a2; destruct a1; destruct a0;
cbn in *; try easy; repeat f_equal; apply eq_proofs_unicity; decide equality.
Qed.

(* This is the deltas and alphas from the instruction set table in Appendix H.2
   and (along with some new instructions) it's also in go-ethereum/core/vm/jump_table.go
   with go-ethereum/core/vm/eips.go.
*)
Definition consume_and_produce_count (op: instruction)
: int * int
:= (match op with
   (* 0x00 *)
   | STOP       => (0, 0)
   | ADD        => (2, 1)
   | MUL        => (2, 1)
   | SUB        => (2, 1)
   | DIV        => (2, 1)
   | SDIV       => (2, 1)
   | MOD        => (2, 1)
   | SMOD       => (2, 1)
   | ADDMOD     => (3, 1)
   | MULMOD     => (3, 1)
   | EXP        => (2, 1)
   | SIGNEXTEND => (2, 1)

   (* 0x10 *)
   | LT     => (2, 1)
   | GT     => (2, 1)
   | SLT    => (2, 1)
   | SGT    => (2, 1)
   | EQ     => (2, 1)
   | ISZERO => (1, 1)
   | AND    => (2, 1)
   | OR     => (2, 1)
   | XOR    => (2, 1)
   | NOT    => (1, 1)
   | BYTE   => (2, 1)
   | SHL    => (2, 1)
   | SHR    => (2, 1)
   | SAR    => (2, 1)

   (* 0x20 *)
   | SHA3 => (2, 1)

   (* 0x30 *)
   | ADDRESS        => (0, 1)
   | BALANCE        => (1, 1)
   | ORIGIN         => (0, 1)
   | CALLER         => (0, 1)
   | CALLVALUE      => (0, 1)
   | CALLDATALOAD   => (1, 1)
   | CALLDATASIZE   => (0, 1)
   | CALLDATACOPY   => (3, 0)
   | CODESIZE       => (0, 1)
   | CODECOPY       => (3, 0)
   | GASPRICE       => (0, 1)
   | EXTCODESIZE    => (1, 1)
   | EXTCODECOPY    => (4, 0)
   | RETURNDATASIZE => (0, 1)
   | RETURNDATACOPY => (3, 0)
   | EXTCODEHASH    => (1, 1)

   (* 0x40 *)
   | BLOCKHASH   => (1, 1)
   | COINBASE    => (0, 1)
   | TIMESTAMP   => (0, 1)
   | NUMBER      => (0, 1)
   | DIFFICULTY  => (0, 1)
   | GASLIMIT    => (0, 1)
   | CHAINID     => (0, 1)
   | SELFBALANCE => (0, 1)

   (* 0x50 *)
   | POP      => (1, 0)
   | MLOAD    => (1, 1)
   | MSTORE   => (2, 0)
   | MSTORE8  => (2, 0)
   | SLOAD    => (1, 1)
   | SSTORE   => (2, 0)
   | JUMP     => (1, 0)
   | JUMPI    => (2, 0)
   | PC       => (0, 1)
   | MSIZE    => (0, 1)
   | GAS      => (0, 1)
   | JUMPDEST => (0, 0)

   (* 0x60 *)
   | PUSH n ok => (0, 1)

   (* 0x80 *)
   | DUP n ok => let k := of_Z (Z.of_N n) in (k, k + 1)

   (* 0x90 *)
   | SWAP n ok => let k := of_Z (Z.of_N n) in (k + 1, k + 1)

   (* 0xa0 *)
   | LOG n ok => let k := of_Z (Z.of_N n) in (k + 2, 0)

   (* 0xf0 *)
   | CREATE       => (3, 1)
   | CALL         => (7, 1)
   | CALLCODE     => (7, 1)
   | RETURN       => (2, 0)
   | DELEGATECALL => (6, 1)
   | CREATE2      => (4, 1)
   | STATICCALL   => (6, 1)
   | REVERT       => (2, 0)
   | SELFDESTRUCT => (1, 0)
   end)%int63.

Definition consume_count (op: instruction) := fst (consume_and_produce_count op).
Definition produce_count (op: instruction) := snd (consume_and_produce_count op).


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e212m29_5limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e129m25_6limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e444m17_9limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


From Coq Require Import Classical ClassicalEpsilon.
From CoindTraces Require Import SsrExport Traces TraceProperties.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(** * Properties of possibly-infinite traces requiring classical logic *)

Section TraceClassicalProperties.

Context {A B : Type}.

Local Notation trace := (@trace A B).
Local Notation propT := (@propT A B).

(** ** Relating finiteness and infiniteness *)

Lemma not_infiniteT_finiteT : forall tr : trace,
 ~ infiniteT tr -> finiteT tr.
Proof.
move => tr Hnot.
case (classic (finiteT tr)) => Hinf //.
case: Hnot.
exact: not_finiteT_infiniteT.
Qed.

Lemma finiteT_infiniteT : forall tr : trace,
 finiteT tr \/ infiniteT tr.
Proof.
move => tr.
case (classic (finiteT tr)) => Hinf; first by left.
right.
exact: not_finiteT_infiniteT.
Qed.

Definition finiteT_infiniteT_dec (tr : trace) : { finiteT tr }+{ infiniteT tr } :=
match excluded_middle_informative (finiteT tr) with
| left Hfin => left Hfin
| right Hfin => right (not_finiteT_infiniteT Hfin)
end.

(** ** Using midpoints to show the right associativity of the append property *)

CoFixpoint midp (p0 p1: trace -> Prop) tr0 tr1 (h: followsT (appendT p0 p1) tr0 tr1) : trace :=
match followsT_dec h with
| inl (existT tr (exist a (conj _ (conj _ H)))) =>
  let: exist x _ := constructive_indefinite_description _ H in x
| inr (existT tr (existT tr' (existT a (exist b (conj _ (conj _ H)))))) =>
  Tcons a b (@midp _ _ _ _ H)
end.

Lemma midpointT_midp : forall (p0 p1: trace -> Prop) tr0 tr1 (h : followsT (appendT p0 p1) tr0 tr1),
 midpointT h (midp h).
Proof.
cofix CIH.
dependent inversion h; subst.
- rewrite [midp _]trace_destr /=.
  case (constructive_indefinite_description _ _) => /=.
  move => x [a1 hm].
  by apply midpointT_nil => //; destruct x.
- rewrite [midp _]trace_destr /=.
  exact: (@midpointT_delay _ _ p0 p1 (Tcons a b tr) (Tcons a b tr') (followsT_delay a b f) tr tr' f a b (midp f)).
Qed.

Lemma appendT_assoc_R: forall p1 p2 p3,
 forall tr : trace, (appendT p1 (appendT p2 p3)) tr -> (appendT (appendT p1 p2)  p3) tr.
Proof.
move => p1 p2 p3 tr0 h1.  move: h1 => [tr1 [h1 h2]].
exists (midp h2). split.
- exists tr1; split => //.
  exact: (midpointT_before (midpointT_midp h2)).
- exact: (midpointT_after (midpointT_midp h2)).
Qed.

Lemma AppendT_assoc_R: forall (p1 p2 p3 : propT), (p1 *** p2 *** p3) =>> (p1 *** p2) *** p3.
Proof.
move => p1 p2 p3 tr0 h1. destruct p1 as [f1 hf1]. destruct p2 as [f2 hf2].
destruct p3 as [f3 hf3]. simpl. simpl in h1. apply appendT_assoc_R. by apply h1.
Qed.

End TraceClassicalProperties.


Require Import
  MathClasses.interfaces.abstract_algebra
  MathClasses.interfaces.universal_algebra MathClasses.theory.ua_homomorphisms
  MathClasses.theory.categories MathClasses.categories.varieties.
Require MathClasses.theory.setoids.

Section algebras.
  Context
    (sig: Signature) (I: Type) (carriers: I → sorts sig → Type)
    `(∀ i s, Equiv (carriers i s))
    `{∀ i, AlgebraOps sig (carriers i)}
    `{∀ i, Algebra sig (carriers i)}.

  Definition carrier: sorts sig → Type := λ sort, ∀ i: I, carriers i sort.

  Fixpoint rec_impl o: (∀ i, op_type (carriers i) o) → op_type carrier o :=
    match o return (∀ i, op_type (carriers i) o) → op_type carrier o with
    | ne_list.one _ => id
    | ne_list.cons _ g => λ X X0, rec_impl g (λ i, X i (X0 i))
    end.

  Instance u (s: sorts sig): Equiv (∀ i : I, carriers i s) := products.dep_prod_equiv _ _.

  Instance rec_impl_proper: ∀ o,
    Proper (@products.dep_prod_equiv I _ (fun _ => op_type_equiv _ _ _) ==> (=)) (rec_impl o).
  Proof with auto.
   induction o; simpl. repeat intro...
   intros ? ? Y x0 y0 ?. apply IHo.
   intros. intro. apply Y. change (x0 i = y0 i)...
  Qed.

  Global Instance product_ops: AlgebraOps sig carrier := λ o, rec_impl (sig o) (λ i, algebra_op o).

  Instance: ∀ o: sig, Proper (=) (algebra_op o: op_type carrier (sig o)).
  Proof. intro. apply rec_impl_proper. intro. apply (algebra_propers _). Qed.

  Instance product_e sort: Equiv (carrier sort) := (=). (* hint; shouldn't be needed *)

  Global Instance product_algebra: Algebra sig carrier := {}.

  Lemma preservation i o: Preservation sig carrier (carriers i) (λ _ v, v i) (algebra_op o) (algebra_op o).
   unfold product_ops, algebra_op.
   set (select_op := λ i0 : I, H0 i0 o).
   replace (H0 i o) with (select_op i) by reflexivity.
   clearbody select_op.
   revert select_op.
   induction (operation_type sig o). simpl. reflexivity.
   intros. intro. apply IHo0.
  Qed.

  Lemma algebra_projection_morphisms i: @HomoMorphism sig carrier (carriers i) _ _ _ _ (λ a v, v i).
  Proof.
   constructor; try apply _.
    intro. rapply (@products.dep_prod_morphism I (λ i, carriers i a) (λ i, _: Equiv (carriers i a))).
    intro. apply _.
   apply preservation.
  Qed.

End algebras.

Section varieties.
  Context
    (et: EquationalTheory)
    (I: Type) (carriers: I → sorts et → Type)
    `(∀ i s, Equiv (carriers i s))
    `(∀ i, AlgebraOps et (carriers i))
    `(∀ i, InVariety et (carriers i)).

  Notation carrier := (carrier et I carriers).
  Instance carrier_e : forall s, Equiv _ := product_e et I carriers _.

  Fixpoint nqe {t}: op_type carrier t → (∀ i, op_type (carriers i) t) → Prop :=
   match t with
   | ne_list.one _ => λ f g, ∀ i, f i = g i
   | ne_list.cons _ _ => λ f g, ∀ tuple, nqe (f tuple) (λ i, g i (tuple i))
   end. (* todo: rename *)

  Instance nqe_proper t: Proper ((=) ==> (λ x y, ∀ i, x i = y i) ==> iff) (@nqe t).
  Proof with auto; try reflexivity.
   induction t; simpl; intros ? ? P ? ? E.
    intuition. rewrite <- (P i), <- E... rewrite (P i), E...
   split; intros U tuple;
    apply (IHt (x tuple) (y tuple) (P tuple tuple (reflexivity _))
      (λ u, x0 u (tuple u)) (λ u, y0 u (tuple u)))...
    intro. apply E...
   intro. apply E...
  Qed.

  Lemma nqe_always {t} (term: Term _ nat t) vars:
    nqe (eval et vars term) (λ i, eval et (λ sort n, vars sort n i) term).
  Proof.
   induction term; simpl in *.
     reflexivity.
    set (k := (λ i : I,
        eval et (λ (sort: sorts et) (n : nat), vars sort n i) term1
          (eval et vars term2 i))).
    cut (nqe (eval et vars term1 (eval et vars term2)) k).
     set (p := λ i : I, eval et (λ (sort : sorts et) (n : nat), vars sort n i) term1
       (eval et (λ (sort : sorts et) (n : nat), vars sort n i) term2)).
     assert (op_type_equiv (sorts et) carrier t
        (eval et vars term1 (eval et vars term2))
        (eval et vars term1 (eval et vars term2))).
      apply sig_type_refl.
       intro. apply _.
      apply eval_proper; try apply _.
       reflexivity.
      reflexivity.
     apply (nqe_proper t (eval et vars term1 (eval et vars term2)) (eval et vars term1 (eval et vars term2)) H2 k p).
     subst p k.
     simpl.
     intro.
     pose proof (eval_proper et _ (λ (sort : sorts et) (n : nat), vars sort n i) (λ (sort : sorts et) (n : nat), vars sort n i) (reflexivity _) term1 term1 eq_refl).
     apply H3.
     apply IHterm2.
    apply IHterm1.
   change (nqe (rec_impl et _ _ (et o) (λ i : I, @algebra_op _ (carriers i) _ o)) (λ i : I, @algebra_op _ (carriers i) _ o)).
   generalize (λ i: I, @algebra_op et (carriers i) _ o).
   induction (et o); simpl. reflexivity.
   intros. apply IHo0.
  Qed.

  Lemma component_equality_to_product t
    (A A': op_type carrier t)
    (B B': ∀ i, op_type (carriers i) t):
    (∀ i, B i = B' i) → nqe A B → nqe A' B' → A = A'.
  Proof with auto.
   induction t; simpl in *; intros BE ABE ABE'.
    intro. rewrite ABE, ABE'...
   intros x y U.
   apply (IHt (A x) (A' y) (λ i, B i (x i)) (λ i, B' i (y i)))...
   intros. apply BE, U.
  Qed.

  Lemma laws_hold s: et_laws et s → ∀ vars, eval_stmt et vars s.
  Proof.
   intros.
   pose proof (λ i, variety_laws s H2 (λ sort n, vars sort n i)). clear H2.
   assert (∀ i : I, eval_stmt (et_sig et)
     (λ (sort : sorts (et_sig et)) (n : nat), vars sort n i)
     (entailment_as_conjunctive_statement (et_sig et) s)).
    intros.
    rewrite <- boring_eval_entailment.
    apply (H3 i).
   clear H3.
   rewrite boring_eval_entailment.
   destruct s.
   simpl in *.
   destruct entailment_conclusion.
   simpl in *.
   destruct i.
   simpl in *.
   intro.
   apply component_equality_to_product with
       (λ i, eval et (λ sort n, vars sort n i) t) (λ i, eval et (λ sort n, vars sort n i) t0).
     intro.
     apply H2. clear H2. simpl.
     induction entailment_premises... simpl in *.
     intuition.
     simpl.
     rewrite <- (nqe_always (fst (projT2 a)) vars i).
     rewrite <- (nqe_always (snd (projT2 a)) vars i).
     intuition.
      apply H3.
     apply IHentailment_premises.
     apply H3.
    apply nqe_always.
   apply nqe_always.
  Qed. (* todo: clean up! also, we shouldn't have to go through boring.. *)

  Global Instance product_variety: InVariety et carrier (e:=carrier_e).
  Proof.
   constructor. apply product_algebra. intro i. apply _.
   apply laws_hold.
  Qed.
End varieties.

Require MathClasses.categories.varieties.

Section categorical.
  Context
    (et: EquationalTheory).

  Global Instance: Producer (varieties.Object et) := λ I carriers,
    {| varieties.variety_carriers := λ s, ∀ i, carriers i s
    ; varieties.variety_proof := product_variety et I _ _ _ (fun H => varieties.variety_proof et (carriers H)) |}.
      (* todo: clean up *)

  Section for_a_given_c.
  Context (I: Type) (c: I → varieties.Object et).

  Global Program Instance: ElimProduct c (product c) := λ i _ c, c i.

  Next Obligation.
   apply (@algebra_projection_morphisms et I c
     (λ x, @varieties.variety_equiv et (c x)) (λ x, varieties.variety_ops et (c x)) ).
   intro. apply _.
  Qed.

  Global Program Instance: IntroProduct c (product c) := λ H h a X i, h i a X.

  Next Obligation. Proof with intuition.
   repeat constructor; try apply _.
     intros ?? E ?. destruct h. simpl. rewrite E...
    intro o.
    pose proof (λ i, @preserves _ _ _ _ _ _ _ _ (proj2_sig (h i)) o) as H0.
    unfold product_ops, algebra_op.
    set (o0 := λ i, varieties.variety_ops et (c i) o).
    set (o1 := varieties.variety_ops et H o) in *.
    change (∀i : I, Preservation et H (c i) (` (h i)) o1 (o0 i)) in H0.
    clearbody o0 o1. revert o0 o1 H0.
    induction (et o); simpl...
   apply (@product_algebra et I c)...
  Qed.

  Global Instance: Product c (product c).
  Proof.
   split; repeat intro. reflexivity.
   symmetry. simpl. apply H.
  Qed.

  End for_a_given_c.

  Global Instance: HasProducts (varieties.Object et) := {}.
End categorical.

(* Todo: Lots of cleanup. *)


Require Import Vector.
Require Import Numbers.Natural.Peano.NPeano.
Require Import Strings.String.
Require Import Strings.Ascii.
Require Import Program.
Require Import List.
Require Import bijections.
Require Import alphabet.
Require Import permutations.
Require Import utils.

(* An enigma machine consists of some of the following:

   - A plugboard (Stecker)
   - Static wheel (ETW)
     + Order keys are connected to this varies by the enigma model.
   - Several rotating wheels
   - Reflector (UKW)

   Rightmost wheel moves first, rotated counter clockwise relative to
   the ETW.

 *)

(* A well formed wheel can't actually have a letter mapped to
itself. Wouldn't make sense in a circuit. *)

(* Probably want a better notion of a permutation.

We do need to invert these, since current is passed back through the
wheels in the opposite direction.

 *)

Definition Bimap := (Vec Alpha 26 * Vec Alpha 26)%type.

Definition in_map (bimap : Bimap) (a : Alpha) : Alpha :=
  match bimap with
    (input, output) =>  VectorDef.nth input a
 end.

Definition out_map (bimap : Bimap) (a : Alpha) : Alpha :=
  match bimap with
    (input, output) =>  VectorDef.nth output a
 end.

(* Bimap, list of notches, index *)
Record Wheel : Type :=
  mkWheel {
      wheel_map : Bimap;
      wheel_notches : list (Fin 26);
      wheel_index : Fin 26
    }.

(* Plugboard is just a permutation *)
Definition Plugboard := Bimap.

(* Reflector is just a permutation *)
Definition Reflector := Bimap.

(* A bimap is well formed if it is an invertible permutation. *)
Definition wf_bimap (bimap : Bimap) : Prop :=
  forall (a : Alpha),
    in_map bimap (out_map bimap a) = a /\ out_map bimap (in_map bimap a) = a.

(* A reflector can not map a letter to itself, and
   must be its own inverse.
 *)
Definition wf_reflector (bimap : Bimap) : Prop :=
  wf_bimap bimap /\
  (forall (a : Alpha), in_map bimap a <> a) /\
  (forall (a : Alpha), in_map bimap (in_map bimap a) = a).

Definition wf_wheel (wheel : Wheel) : Prop :=
  wf_bimap (wheel_map wheel).

Record Enigma : Type :=
  mkEnigma {
      reflector : Reflector;
      plugboard : Plugboard;

      wheels : list Wheel;

      (* Wheels which don't rotate during operation. *)
      right_static_wheels : list Wheel;
      left_static_wheels : list Wheel;

      (* Does this Enigma perform double stepping? *)
      double_stepping : bool
    }.

(* An enigma is well formed if the reflector is well formed, as are
   all the wheels, and the plugboard.
 *)
Definition wf_enigma (enigma : Enigma) : Prop :=
  wf_reflector (reflector enigma) /\
  wf_bimap (plugboard enigma) /\
  Forall wf_wheel (wheels enigma) /\
  Forall wf_wheel (right_static_wheels enigma) /\
  Forall wf_wheel (left_static_wheels enigma).

Definition through_wheels (wheels : list Wheel) (a : Alpha) : Alpha :=
  fold_left (fun a w => in_map w a) (map wheel_map wheels) a.

Definition out_wheels (wheels : list Wheel) (a : Alpha) : Alpha :=
  fold_left (fun a w => out_map w a) (rev (map wheel_map wheels)) a.

(* Run a character through the circuit in the Enigma. This is like
   pressing a key, but without advancing any rotors *)
Definition encipher (enigma : Enigma) (a : Alpha) : Alpha :=
  let all_wheels := right_static_wheels enigma ++ wheels enigma ++ left_static_wheels enigma in
  let the_reflector := reflector enigma in
  let the_plugboard := plugboard enigma in

  out_map the_plugboard (
  out_wheels all_wheels (
  in_map the_reflector (
  through_wheels all_wheels (
  in_map the_plugboard a)))).

(* in_wheels and out_wheels are bijections *)
Theorem out_through_wheels_inverse :
  forall (ws : list Wheel),
  Forall wf_wheel ws ->
  forall a, through_wheels ws (out_wheels ws a) = a.
Proof.
  intros ws H a.
  induction ws as [| w ws'].
  - reflexivity.
  - unfold through_wheels in *.
    unfold out_wheels in *. simpl in *.
    inversion H.
    unfold wf_wheel in H2. unfold wf_bimap in H2.
    pose proof (H2 (fold_left (fun (a0 : Alpha) (w0 : Bimap) => out_map w0 a0) (rev (map wheel_map ws')) a)) as [Hin Hout].
    rewrite fold_left_app. simpl.

    rewrite Hin.
    apply IHws'.
    assumption.
Qed.

Theorem rev_nil :
  forall A (l : list A),
  rev l = nil -> l = nil.
Proof.
  intros A l H.
  destruct l.
  - reflexivity.
  - simpl in H.
    pose proof (app_cons_not_nil (rev l) nil a) as Hnil.
    unfold not in Hnil.

    exfalso.
    apply Hnil.
    symmetry.
    assumption.
Qed.

Theorem forall_app :
forall A (l1 l2 : list A) (P : A -> Prop),
  Forall P l1 ->
  Forall P l2 ->
  Forall P (l1 ++ l2).
Proof.
  intros A l1 l2 P Hl1 Hl2.
  induction Hl1.
  - apply Hl2.
  - simpl. apply Forall_cons; assumption.
Qed.

Theorem forall_rev :
  forall A (l : list A) (P : A -> Prop),
    Forall P l ->
    Forall P (rev l).
Proof.
  intros A l P H.
  induction H.
  - apply Forall_nil.
  - simpl. apply forall_app; auto.
Qed.

Theorem through_out_wheels_inverse :
  forall (ws : list Wheel),
  Forall wf_wheel ws ->
  forall a, out_wheels ws (through_wheels ws a) = a.
Proof.
  intros ws H a.
  induction ws as [| w ws'] using rev_ind.
  - reflexivity.
  - unfold through_wheels in *.
    unfold out_wheels in *. simpl in *.

    apply forall_rev in H.
    rewrite rev_app_distr in H. simpl in H.
    inversion H.

    unfold wf_wheel in H2. unfold wf_bimap in H2.

    rewrite <- map_rev. rewrite rev_app_distr. simpl.

    rewrite map_app.
    rewrite fold_left_app.
    simpl.

    pose proof (H2 (fold_left (fun (a0 : Alpha) (w0 : Bimap) => in_map w0 a0) (map wheel_map ws') a)) as [Hin Hout].

    rewrite Hout.
    rewrite map_rev.
    apply IHws'.

    apply forall_rev in H3.
    rewrite rev_involutive in H3.
    assumption.
Qed.

Theorem through_app :
  forall (ws1 ws2 : list Wheel),
  forall a, through_wheels (ws1 ++ ws2) a = through_wheels ws2 (through_wheels ws1 a).
Proof.
  induction ws1 as [| w' ws1'].
  - reflexivity.
  - intros ws2 b.
    simpl in *.
    unfold through_wheels in *.
    simpl in *.
    rewrite IHws1'.
    reflexivity.
Qed.

Theorem through_wheels_left_inverse :
  forall (ws : list Wheel),
  Forall wf_wheel ws ->
  left_inverse (through_wheels ws).
Proof.
  unfold left_inverse.
  intros ws H.
  exists (out_wheels ws).
  apply through_out_wheels_inverse.
  assumption.
Qed.

Theorem bimap_left_inverse :
  forall (b : Bimap),
  wf_bimap b ->
  left_inverse (in_map b).
Proof.
  intros b H.
  unfold left_inverse.
  exists (out_map b). unfold wf_bimap in H. apply H.
Qed.

(* Going through the plugboard and then wheels is left invertible *)
Theorem plugboard_through_wheels_left_inverse :
  forall (ws : list Wheel) (the_plugboard : Plugboard),
  wf_bimap the_plugboard ->
  Forall wf_wheel ws ->
  forall a, out_map the_plugboard (out_wheels ws (through_wheels ws (in_map the_plugboard a))) = a.
Proof.
  intros ws the_plugboard Hpb Hws a.
  unfold wf_bimap in Hpb.

  pose proof (through_out_wheels_inverse ws) as Hwinv.
  apply Hwinv with (a:=(in_map the_plugboard a)) in Hws.
  rewrite Hws.

  apply Hpb.
Qed.

Theorem out_wheels_plugboard_left_inverse :
  forall (ws : list Wheel) (the_plugboard : Plugboard),
  wf_bimap the_plugboard ->
  Forall wf_wheel ws ->
  forall a, through_wheels ws (in_map the_plugboard (out_map the_plugboard (out_wheels ws a))) = a.
Proof.
  intros ws the_plugboard Hpb Hws a.
  unfold wf_bimap in Hpb.

  pose proof (out_through_wheels_inverse ws) as Hwinv.

  pose proof Hpb (out_wheels ws a) as [Hin _].
  rewrite Hin.

  apply Hwinv.
  assumption.
Qed.

Theorem left_inverse_disruption :
  forall {A B : Type} (f : A -> B) (g : B -> A) (k : B -> B),
  (forall a, g (f a) = a) ->
  (forall b, f (g b) = b) ->
  (forall b, k b <> b) ->
  (forall a, g (k (f a)) <> a).
Proof.
  intros A B f g k Hgf Hfg Hkb a.
  unfold not in *.
  intros Hgkf.

  apply Hkb with (b:=f a).
  pose proof (left_inverse_injective g).
  unfold injective in H.

  apply H.
  - unfold left_inverse.
    exists f. assumption.
  - rewrite Hgf.
    assumption.
Qed.

(* A letter can not be encoded as itself.

   Rough sketch of why this is true:

   Since the reflector can not encode a letter as itself, the circuit
   that the current originally came from can not be retraced, so we
   can't get back to the original letter.

   Sufficies to condense the rest of the enigma machine (everything
   but the reflector) to a bijection.

   Then since this is a bijection we can show that the well-formedness
   property of the reflector, which insists that a value coming in is
   encoded as a different value leads to a different value coming out
   of the bijection.

   You get a different value due to injectivity...

   g (f a) = a

   g is injective, so if I feed it b <> f a, then...

   g (f a) <> g (b)

 *)
Theorem no_self_encoding :
  forall (enigma : Enigma),
    wf_enigma enigma ->
    forall (a : Alpha), encipher enigma a <> a.
Proof.
  intros enigma [Hwf_ref [Hwf_plug [Hwf_wheels [Hwf_right Hwf_left]]]] a.
  unfold encipher.
  unfold wf_reflector in Hwf_ref.
  destruct Hwf_ref as [Hbimap [Hdiff Hblah]].

  set (all_wheels := right_static_wheels enigma ++ wheels enigma ++ left_static_wheels enigma) in *.
  set (ref := reflector enigma) in *.
  set (plug := plugboard enigma) in *.

  apply (left_inverse_disruption (fun a => (through_wheels all_wheels (in_map plug a)))
                                 (fun a => (out_map plug (out_wheels all_wheels a)))
                                 (in_map (reflector enigma))).

  - apply plugboard_through_wheels_left_inverse.
    + assumption.
    + repeat (apply forall_app; try assumption).
  - apply out_wheels_plugboard_left_inverse.
    + assumption.
    + repeat (apply forall_app; try assumption).
  - assumption.
Qed.

(* Enigma messages can be decoded *)
Theorem enigma_decode :
  forall (enigma : Enigma),
    wf_enigma enigma ->
    forall (a : Alpha), encipher enigma (encipher enigma a) = a.
Proof.
  intros enigma [Hwf_ref [Hwf_plug [Hwf_wheels [Hwf_right Hwf_left]]]] a.
  unfold encipher.

  set (all_wheels := right_static_wheels enigma ++ wheels enigma ++ left_static_wheels enigma) in *.
  set (ref := reflector enigma) in *.
  set (plug := plugboard enigma) in *.

  unfold wf_bimap in Hwf_plug.

  pose proof (Hwf_plug (out_wheels all_wheels (in_map ref (through_wheels all_wheels (in_map plug a))))) as [Hin Hout].

  rewrite Hin.

  rewrite out_through_wheels_inverse.
  - unfold wf_reflector in Hwf_ref. destruct Hwf_ref as [Hrefbi [Hrefne Hrefinv]].
    rewrite Hrefinv.
    rewrite through_out_wheels_inverse.
    + apply Hwf_plug.
    + repeat (apply forall_app; try assumption).
  - repeat (apply forall_app; try assumption).
Qed.

Definition step_wheel (w : Wheel) : Wheel :=
  match w with
  | mkWheel m ns i => mkWheel m ns (step_fin i)
  end.

(* Step a wheel if the previous wheel has a notch in the correct position. *)
Definition step_if_notched (prev : Wheel) (w : Wheel) : Wheel :=
  match prev with
  | mkWheel m notches i =>
    if in_dec Fin.eq_dec i notches
    then step_wheel w
    else w
  end.

(* Step a wheel if the previous wheel has a notch in the correct
   position, or the next wheel does. *)
Definition double_step_if_notched (prev : Wheel) (next : Wheel) (w : Wheel) : Wheel :=
  match prev with
  | mkWheel _ notches i =>
    if in_dec Fin.eq_dec i notches
    then step_wheel w
    else match next with
         | mkWheel _ next_notches next_i =>
           if in_dec Fin.eq_dec next_i next_notches
           then step_wheel w
           else w
         end
  end.

(* Step the notched wheels without taking double stepping into account *)
Fixpoint step_carry_wheels (prev : Wheel) (ws : list Wheel) : list Wheel :=
  match ws with
  | nil => nil
  | w :: ws' =>
    step_if_notched prev w :: step_carry_wheels w ws'
  end.

(* Step the notched wheels taking double stepping into account *)
Fixpoint double_step_carry_wheels (prev : Wheel) (ws : list Wheel) : list Wheel :=
  match ws with
  | nil => nil
  | w :: nil => step_if_notched prev w :: nil
  | w :: next :: ws' =>
    double_step_if_notched prev next w :: step_carry_wheels w ws'
  end.

(* 1) Step the first wheel always.
   2) Step all wheel's whose previous wheel has a notch at the current
      index.
   3) If double stepping, then every wheel with a notch at the current
      index must also step as well, unless it's the last wheel.
 *)
Fixpoint step_wheels (ws : list Wheel) : list Wheel :=
  match ws with
  | nil => nil
  | w :: ws' => step_wheel w :: step_carry_wheels w ws'
  end.

Fixpoint double_step_wheels (ws : list Wheel) : list Wheel :=
  match ws with
  | nil => nil
  | w :: ws' => step_wheel w :: double_step_carry_wheels w ws'
  end.

Definition step_enigma (enigma : Enigma) : Enigma :=
  match enigma with
  | mkEnigma ref plug wheels right_ws left_ws double_step =>
    if double_step
    then let new_wheels := double_step_wheels wheels in
         mkEnigma ref plug new_wheels right_ws left_ws double_step
    else let new_wheels := step_wheels wheels in
         mkEnigma ref plug new_wheels right_ws left_ws double_step
  end.

(* Press a key, causing the wheels to rotate, and a letter to light up.

   Return the letter which lights up, and the new state of the enigma machine.
*)
Definition press_key (enigma : Enigma) (a : Alpha) : (Alpha * Enigma) :=
  let enigma' := step_enigma enigma in (encipher enigma' a, enigma').

Fixpoint encipher_message (enigma : Enigma) (message : list Alpha) : (list Alpha) :=
    match message with
    | nil => nil
    | a :: message' =>
      let (o, enigma') := press_key enigma a in
      o :: encipher_message enigma' message'
    end.

Fixpoint vector_find {A} {n} (decA : forall x y : A, {x = y} + {x <> y}) (a : A) (vec : Vec A n) : option (Fin n) :=
  match vec with
  | VectorDef.nil _ => None
  | VectorDef.cons _ x m t =>
    if decA a x
    then Some (Fin.F1)
    else match vector_find decA a t with
         | None => None
         | Some f => Some (Fin.FS f)
         end
  end.

Theorem vector_find_in_list :
  forall A n (decA : forall x y : A, {x = y} + {x <> y}) (a : A) (vec : Vec A n),
    VectorDef.In a vec ->
    vector_find decA a vec <> None.
Proof.
  intros A n decA a vec H.
  unfold not in *.
  induction H.
  - simpl. destruct decA.
    + intros contra.
      inversion contra.
    + contradiction.
  - simpl. destruct decA.
    + intros contra. inversion contra.
    + destruct (vector_find decA a v) eqn:bleh.
      * intros H0. inversion H0.
      * contradiction.
Qed.

Theorem vector_find_in_list' :
  forall {A n} (decA : forall x y : A, {x = y} + {x <> y}) (a : A) (vec : Vec A n),
    VectorDef.In a vec ->
    exists k, vector_find decA a vec = Some k.
Proof.
  intros A n decA a vec Hin.
  induction Hin.
  - simpl. destruct decA.
    + exists Fin.F1. reflexivity.
    + contradiction.
  - simpl. destruct decA.
    + exists Fin.F1. reflexivity.
    + destruct IHHin. rewrite H.
      exists (Fin.FS x0). reflexivity.
Qed.

Theorem vector_find_cons :
  forall A n (decA : forall x y : A, {x = y} + {x <> y}) (a : A) (vec : Vec A n),
    vector_find decA a (Vector.cons A a n vec) = Some Fin.F1.
Proof.
  intros A n decA a vec.
  simpl. destruct decA.
  - reflexivity.
  - contradiction.
Qed.

Definition get_option {A} (a : A) (o : option A) : A :=
  match o with
  | None => a
  | Some v => v
  end.

Definition Permutation := Vec Alpha 26.

(* Want to find the position for each letter *)
Fixpoint invert_permutation (perm : Permutation) : Permutation :=
  VectorDef.map (fun a => get_option Fin.F1 ( vector_find Fin.eq_dec a perm)) alphabet.

Theorem vector_nth_cons :
  forall A n k (a x : A) (vec : Vec A n),
    VectorDef.In a vec ->
    Vector.nth vec k = a ->
    Vector.nth (Vector.cons A x n vec) (Fin.FS k) = a.
Proof.
  auto.
Qed.

Theorem not_in_not_eq :
  forall {A n} (a x : A) (vec : Vec A n),
    VectorDef.In a vec ->
    ~ VectorDef.In x vec ->
    x <> a.
Proof.
  unfold not.
  intros A n a x vec Hin Hnin Hxa.
  invert_existT Hin; contradiction.
Qed.

Theorem match_madness :
  forall n (o : option (Fin n)) k,
    (match o with
    | Some f => Some (Fin.FS f)
    | None => None
    end) = Some (Fin.FS k) ->
    o = Some k.
Proof.
  intros n o k H.
  induction o.
  - invert_existT H. reflexivity.
  - inversion H.
Qed.

Theorem vector_find_cons_neq_weaken :
  forall {A n k} (decA : forall x y : A, {x = y} + {x <> y}) (a x : A) (vec : Vec A n),
    VectorDef.In a vec ->
    a <> x ->
    vector_find decA a (Vector.cons A x n vec) = Some (Fin.FS k) ->
    vector_find decA a vec = Some k.
Proof.
  intros A n k decA a x vec Hin Hnax Hfind.
  induction Hin;
  unfold vector_find in *; destruct decA;
    try contradiction;
    try (destruct decA;
         try (invert_existT Hfind; reflexivity);
         try (apply match_madness in Hfind; apply Hfind)).
Qed.

Theorem vector_find_cons_neq :
  forall {A n} (decA : forall x y : A, {x = y} + {x <> y}) (a x : A) (vec : Vec A n),
    VectorDef.In a vec ->
    a <> x ->
    exists k, vector_find decA a (Vector.cons A x n vec) = Some (Fin.FS k).
Proof.
  intros A n decA a x vec Hin Hneq.
  induction vec.
  - inversion Hin.
  - invert_existT Hin.
    + simpl. destruct decA.
      * contradiction.
      * destruct decA.
        -- exists Fin.F1. reflexivity.
        -- contradiction.
    + simpl. destruct decA.
      * contradiction.
      * simpl in *. subst. apply IHvec in H1.
        destruct decA.
        -- contradiction.
        -- destruct decA.
           ++ subst. exists Fin.F1. reflexivity.
           ++ destruct H1. rewrite H. exists (Fin.FS x0). reflexivity.
Qed.

Theorem neq_sym :
  forall {A} (a x : A),
    a <> x -> x <> a.
Proof.
  unfold not.
  intros A a x Hax Hxa.
  auto.
Qed.

Theorem find_inverse :
  forall A n k (decA : forall x y : A, {x = y} + {x <> y}) (a : A) (vec : Vec A n),
    VectorDef.In a vec ->
    NoDupVec vec ->
    vector_find decA a vec = Some k ->
    Vector.nth vec k = a.
Proof.
  intros A n k decA a vec Hin Hdup Hfind.
  generalize dependent k.
  induction vec; intros k Hfind.
  - inversion Hin.
  - invert_existT Hin.
    + unfold Fin in k. rewrite vector_find_cons in Hfind.
      inversion Hfind.
      reflexivity.
    + invert_existT Hdup.
      pose proof not_in_not_eq a h vec H1 H3.
      apply neq_sym in H.
      pose proof vector_find_cons_neq decA a h vec H1 H.
      destruct H0. rewrite H0 in Hfind. inversion Hfind.
      apply vector_nth_cons; auto.
      apply IHvec; auto.
      pose proof vector_find_in_list' decA a vec H1.
      destruct H2.
      subst.
      apply (vector_find_cons_neq_weaken decA a h vec H1 H H0).
Qed.

Theorem tiny_alpha :
  forall (perm : Vec (Fin 1) 1),
    NoDupVec perm ->
    IsPermutation perm (Vector.cons _ Fin.F1 0 (Vector.nil _)).
Proof.
  intros perm H. simpl.
  repeat dependent destruction perm.
  repeat match goal with
  | H : NoDupVec ?v |- _ => invert_existT H
  end.
  econstructor. eauto.
  simpl in *.
  unfold not in *.

Qed.

Theorem invert_permutation_is_permutatino :
  forall (perm : Permutation),
    NoDupVec perm ->
    IsPermutation perm alphabet.
Proof.
  intros perm H.
  repeat match goal with
  | H : NoDupVec ?v |- _ => invert_existT H
  end.
  econstructor. econstructor.
  econstructor. econstructor.
  econstructor. econstructor.
  econstructor. econstructor.
  econstructor. econstructor.
  econstructor. econstructor.
  econstructor. econstructor.
  econstructor. econstructor.
  econstructor. econstructor.
  econstructor. econstructor.
  econstructor. econstructor.
  econstructor. econstructor.
  econstructor. econstructor.
  econstructor. constructor.

  simpl in *. repeat econstructor; repeat eauto.
  invert_existT H.
  invert_existT H3.
Qed.

Theorem invert_permutation_left :
  forall (perm : Permutation) (a b : Alpha),
    Vector.nth perm a = b ->
    Vector.nth (invert_permutation perm) b = a.
Proof.
  intros perm a b H.
  unfold invert_permutation.
Qed.

(* Transform a new alphabet into a well formed bimap. *)
Definition mkBimap (permutation : Permutation) : Bimap :=
  (permutation, invert_permutation permutation).

Theorem wf_bimap_wf_bimap :
  forall (perm : Permutation),
    wf_permutation perm ->
    wf_bimap (mkBimap perm).
Proof.
  intros perm H.
  unfold wf_permutation in H.
  unfold wf_bimap. unfold mkBimap.
  simpl. unfold invert_permutation. simpl.
  intros a.

  split.
  - unfold Alpha in *. simpl.

    (* Want to say that nth invert_perm a is (vector_find Fin.eq_dec a perm)

       And since vector_find Fin.eq_dec a perm is just going to find
       the occurance of 'a' in perm (which is guaranteed to be
       unique), then nth perm (where-a-is) is going to be a.
     *)
Qed.

Theorem wf_permutation_wf_bimap :
  forall (perm : Vec Alpha 26),
    wf_permutation perm ->
    wf_bimap (mkBimap perm).
Proof.
  intros perm H.
  unfold wf_permutation in H.
  unfold wf_bimap.
  intros a. split.
  unfold out_map.

Qed.
*)

(* Need identical enigma machine to decipher (note: navy one was convertible...)

   Restrict to same set of wheels and such. Same *type* of
   enigma. Then you need identical settings for ALL messages. Some may
   be decoded regardless, if short. E.g., two different settings may
   map a -> k.
*)

(* Pressing the same key multiple times should lead to different
   letters due to wheel rotation.

   Does it ever result in the same letter? It can if other wheels
   turn.

 *)

(* Enigma M4 and M3 / 1 equivalence *)


Require Import Bool Arith List CpdtTactics SfLib LibTactics.
Require Import Coq.Program.Equality.
Require Import Omega.

Set Implicit Arguments.

Require Import Identifier Environment Imperative Types Augmented Bridge.
Require Import WellFormedness LowEq NIexp.
Require Import InductionPrinciple.
Require Import UtilTactics.
Require Import BridgeTactics.
Require Import BridgeProperties.
Require Import HighPCSteps.

Definition NI_idx (n: nat): Prop :=
  forall Γ pc c,
    -{ Γ, pc ⊢ c }- ->
    forall m s ev1 ev2 c2 d2 m2 s2 n',
      state_low_eq Γ m s ->
      〈c, m〉 ↷ ( Γ, ev1, n ) 〈c2, m2〉->
      〈c, s〉 ↷ ( Γ, ev2, n') 〈d2, s2〉->
      state_low_eq Γ m2 s2 /\ c2 = d2 /\
      (low_event Γ Low ev1 <-> low_event Γ Low ev2)
      /\  (low_event Γ Low ev1 -> ev1 = ev2).

Theorem ni_bridge_num:
  forall n, NI_idx (n).
Proof.
  apply strongind.
  (* Base case *)
  {
    unfold NI_idx.
    intros Γ pc c  H; subst.
    cmd_has_type_cases (induction H) Case;
      intros m s ev1 ev2 c_end d_end m_end s_end n' leq H_m H'_s.

    Case "T_Skip".
    {
      forwards H_a: skip_bridge_properties H_m.
      forwards H_b: skip_bridge_properties H'_s.
      destructs H_a.
      destructs H_b.
      subst.
      splits *.
    }
    Case "T_Assign".
    {
      (* clean up; gathering what we know about assignments *)

      repeat
        (match goal with
             | [ H: context [bridge_step_num] |- _ ] =>
               (apply assign_bridge_properties in H; repeat (super_destruct; subst))
             |  [ H: Γ x = Some ?U, H' : Γ x = Some ?V |- _ ] =>
                (assert (U = V) by congruence; subst; clear H)
         end).

      (* use NI for expressions *)
      forwards* low_eq: ni_exp.
      match goal with
          [ _ : Γ x = Some ?ℓ' |- _ ] =>
          (forwards* LE : low_eq_flowsto __ ℓ' low_eq;
           clear low_eq;
           rename ℓ' into ℓ_x)
      end.
      forwards* st_eq: leq_updates.

      splits *.
      (* the main goal is in the hypothesis by now *)

      (* these take care of the last two technical goals *)
      -
        clear st_eq;
        assert (Low ⊑ Low) by auto;
        assert ( ~ High ⊑ Low) by  (unfold not; intros H''; inversion H'').
        destruct ℓ_x; subst.
        + inverts~ LE.
          splits;
          intros;
          repeat specialize_gen; subst;
          eauto.
        + inverts~ LE.
          splits;
          intros;
            repeat specialize_gen; subst;
            unfolds high_event;
            contradiction.
      - intros.
        destruct ℓ_x; subst;
        inverts~ LE;
        assert (Low ⊑ Low) by auto;
        assert ( ~ High ⊑ Low) by  (unfold not; intros H''; inversion H'');
        repeat specialize_gen; subst; eauto;
        unfolds high_event; contradiction.

    }
    Case "T_Seq".
    {
      (* auxiliary Ltac to apply the IH *)
      Ltac apply_seq_comp_base_IH c1 m s IH leq:=
          match goal with
            | [ H : 〈c1, m 〉 ⇨+/(SL, ?Γ , ?ev1, _) 〈?C1, ?M 〉,
                    H_alt : 〈c1, s 〉 ⇨+/(SL, _ , ?ev2, ?n') 〈?C2, ?S 〉 |- _ ]
              => specialize (IH m s ev1 ev2 C1 C2 M S n' leq H H_alt)
          end.

      apply seq_comp_bridge_property in H_m.
      apply seq_comp_bridge_property in H'_s.

      super_destruct; try (solve [omega]).
      (* the above destruct gives us four cases; two are discharged by
         omega; of the remaining two only one is possible *)

      - (* this is the only possible case, we get it from the IH *)

        apply_seq_comp_base_IH c1 m s IHcmd_has_type1 leq.
        super_destruct;
          (splits ~) ;
          compare x STOP;intros;
          repeat (specialize_gens).

      - (* impossible after applying the IH because ev1 is low?  *)
        apply_seq_comp_base_IH c1 m s IHcmd_has_type1 leq.
        super_destruct.
        specialize_gens.

        invert_low_event.
        exfalso.
        eauto.
      }

    (* neither if or while are possible in base case
       we use the following auxiliary ltac to discharge the goals *)

    Ltac discharge_if_while_base H :=
      (inverts H);
      repeat match goal with
        | [ H : context [low_event_step] |- _ ] => invert_low_steps
        | [ H : context [high_event_step] |- _] => (invert_high_steps; subst)
        | [ H: context [is_stop] |-  _ ] => (do 2 unfolds in H; inverts * H)
        | [ H : 〈 _, _  〉 = 〈STOP, _ 〉 |- _] => (inversion H ; contradiction)
        | [ H : 0 >= 1 |- _ ] => omega
      end.

    Case "T_if".
    {
      (* impossible *)
      discharge_if_while_base H_m; crush.
    }
    Case "T_While".
    {
      (* impossible *)
      discharge_if_while_base H_m; crush.
    }
  }
  (* inductive case *)
  {
    intros.
    unfold NI_idx in *.
    intros Γ pc c H_wt.
    (* we proceed by induction on the typing derivation *)
    cmd_has_type_cases (induction H_wt) Case;
      intros m s ev1 ev2 c_end d_end m_end s_end n' leq H_m H_s.
    Case "T_Skip".
    {
      (* impossible *)
      inversion H_m.
      invert_high_steps.
      intros.
      stop_contradiction_alt.
    }
    Case "T_Assign".
    {
      (* impossible *)
      inversion H_m.
      invert_high_steps.
      stop_contradiction_alt.
    }
    Case "T_Seq".
    {

      apply seq_comp_bridge_property in H_m.
      apply seq_comp_bridge_property in H_s.

      super_destruct.
      (* we have four cases based on the side of the chosen existential after destruct:
        LL, RL, LR, RR
        - LL is proven via inner HH;
        - RR is proven via outer HH;
        - RL and LR are impossible
       *)
      {
        (* LL *)
        apply_seq_comp_base_IH c1  m s IHH_wt1 leq.
        super_destruct;
          repeat (split~).
        compare x STOP; intros;
        repeat (specialize_gens).
        (* TODO: this boilerplate is similar to the LL case in the base case of the proof; consider
           generalizing; 2016-07-25; aa *)
      }

Ltac apply_seq_comp_ind_IH H c1 H_leq:=
   do 2 match goal with

          | [ H: context [?X < S ?n] |- _ ]=>
            assert (X <= n) by omega; clear H
          | [ H_m : 〈c1, ?m 〉 ⇨+/(SL, ?Γ , ?ev1, ?X) 〈?C1, ?M 〉,
                    H_s: 〈c1, ?s 〉 ⇨+/(SL, _ , ?ev2, ?n') 〈?C2, ?S 〉,
                         H_wt1 : -{ ?Γ, ?pc ⊢ c1 }-,
                         XX : context [ ?X <= _ ] |- _  ]
            =>
            specialize (H X XX Γ pc c1 H_wt1 m s ev1 ev2  C1 C2 M S n' H_leq H_m H_s)
        end.

      {
        (* RL *)
        (* impossible - show via applying the outer IH *)
        apply_seq_comp_ind_IH H c1 leq.
        super_destruct.
        match goal with [ H: context [ _ <-> _ ] |- _ ] => destruct H end.
        specialize_gen.
        invert_low_event.
        exfalso.
        eauto.
      }
      {
        (* LR *)
        (* impossible - show via applying the inner IH *)
        apply_seq_comp_base_IH c1 m s IHH_wt1 leq.
        super_destruct.
        exfalso.

        match goal with [ H: low_event _ _ _ <-> low_event _ _ _ |- _ ] => destruct H end.

        match goal with [H  : low_event _ _ ev1 -> low_event _ _ _,
                              H' : low_event _ _ ev1 |- _ ] => apply H in H'; inversion H'  end.
        eauto.
      }
      {
        clear IHH_wt1 IHH_wt2.
        (* RR *)
        (* save the outer hypothesis, because it is used twice *)
        assert (IH_outer := H).
        apply_seq_comp_ind_IH H c1 leq.
        destruct H.

        (* applying the induction hypothesis again, this time to c2 *)

        (* transform the indices so they match the patterns *)

        match goal with
          | [ H : context [ S n - ?X - 1] |- _ ] =>
            (assert (n - X <= n) by omega;
             replace (S n - X - 1) with ((n-X))  in * by omega
            )
        end.

        (* apply the IH *)

        match goal with

          | [ H_m : 〈c2, ?m 〉 ⇨+/(SL, ?Γ , ev1, ?X) 〈?C1, ?M 〉,
                    H_s: 〈c2, ?s 〉 ⇨+/(SL, _ , ev2, ?n') 〈?C2, ?S 〉,
                         H_wt : -{ ?Γ, ?pc ⊢ c2 }- ,
                         XX : context [ ?X <= _ ] |- _  ]
            =>specialize (IH_outer X XX Γ pc c2 H_wt m s ev1 ev2 C1 C2 M S n' H H_m H_s)
        end.
        eauto.

        (* TODO: 2016-07-26; the above may be too boilerplate;
           maybe clean up the code for IH application *)
      }
    }

    Case "T_if".
    {
      clear IHH_wt1 IHH_wt2;

      apply if_bridge_properties in H_m;
      apply if_bridge_properties in H_s.

      level_cases (destruct pc') SCase.

      - (* pc' = Low *)
        (* let's destruct and show that both branches evaluate to the same *)
        (* establish ℓ-equivalence of the guard *)

        assert (forall v1 v2,
                  eval e m v1 ->
                  eval  e s v2 ->
                  v1 = v2) as ?g_leq
            by ( intros;
                 assert (val_low_eq ℓ v1 v2) as X by applys* ni_exp;
                 inverts~ X;
                 impossible_flows
               ).

        super_destruct;
          (* 4 sub-goals after destruct; we appeal to low-equivalence of the guard
             to discharge the goals where both branches take separate branches *)
          specializes* g_leq; subst; try omega;
          (* 2 sub-goals remaining that correspond to both runs
             taking the same run; we handle both cases similarly by
             applying the induction hypothesis *)

        match goal with
            |  [ H' : 〈?c_i, s 〉 ⇨+/(SL, _ , ev2, ?X) _   |- _ ]
               =>   forwards* : H (S n - 1) c_i; omega
        end.

      - (* pc' = High *)
        clear H. (* no need for the IH *)
        subst.

        (* rather than dealing with four subcases of which branch is
          taken we extract the useful information about high ifs,
          namely that they take the bridge steps and are high
          themselves, and the rest of the case deals with these
          'abstract' programs c_i, c_j, where c_i that is taken from
          the m-run, and c_j that is taken from the s-run *)

        replace (S n - 1) with n in * by omega.

        assert (exists c_i, 〈c_i, m 〉 ⇨+/(SL, Γ, ev1, n) 〈c_end, m_end 〉
                            /\ ( c_i = c1 \/ c_i = c2  ) /\ -{ Γ, High ⊢ c_i }-) as H_i
            by (super_destruct;
                solve [exists c1; splits~ |  exists c2; split~ ]).

        assert (exists c_j ,〈c_j, s 〉 ⇨+/(SL, Γ, ev2,  (n' - 1) ) 〈d_end, s_end 〉
                            /\ ( c_j = c1 \/ c_j = c2  ) /\ -{ Γ, High ⊢ c_j }- ) as H_j
            by (
                super_destruct;
(*                match goal with  | [ H:〈_, s 〉 ⇨+/(SL, Γ, ev2, n') 〈d_end, s_end 〉|- _ ] =>
                                   replace n' with (S (n' - 1)) in H by omega
                end. *)
                solve[ exists c1; splits~ | exists c2; splits~]
              ).

        clear H_m H_s. (* we don't need these anymore *)
        destruct H_i as [c_i].
        destruct H_j as [c_j].

        super_destruct.

        assert (state_low_eq Γ m m_end /\ c_end = STOP /\ high_event Γ Low ev1)
          by (applys* high_pc_bridge c_i m ev1; inverts~ leq).

        assert (state_low_eq Γ s s_end /\ d_end = STOP /\ high_event Γ Low ev2)
          by (applys* high_pc_bridge c_j s ev2; inverts~ leq).

        super_destruct; subst.
        splits~.
        + apply state_low_eq_trans_square with m s; assumption.
        + split; intros; contradiction.
        + contradiction.
    }

    Case "T_While".
    {
      clear IHH_wt. (* clear unnecessary hyps *)

      apply while_bridge_properties in H_m.
      apply while_bridge_properties in H_s.
      super_destruct.

      replace (S n - 1) with n in * by omega.

      assert ( -{ Γ, pc ⊢ IFB e THEN c;; WHILE e DO c END ELSE SKIP FI }- ).
      {
        apply  T_If with ℓ pc'; auto.
        applys* T_Seq.
        apply T_While with ℓ pc'; auto.
        apply* T_Skip.
      }

      applys* H (IFB e THEN c;; WHILE e DO c END ELSE SKIP FI).
    } (* unfocus T_While *)
  } (* unfocus induction case *)
Qed.


Add LoadPath "../../".
Require Import Coq.Relations.Relations.
Require Import Coq.Arith.EqNat.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Setoids.Setoid.
Require Export Coq.Sorting.PermutSetoid.
Require Export Coq.Sorting.PermutEq.
Require Import Coq.Program.Equality.
Require Import Coq.Logic.FunctionalExtensionality.

Require Export Permutation.
Require Export LL.SequentCalculi.
Require Export LL.StructuralRules.
Require Export LL.Multisets.

Module SLL := SRule NatSet.
Export SLL.

Example test1: |-F- [] ; [] ; UP(F{fun _ x=> atom(a1 1 (var x))} :: E{fun _ x=> perp(a1 1 (var x))} :: nil).
Proof with autoLexp.
  apply tri_fx;intro.
  apply tri_store ...
  apply tri_store ...
  compute.
  eapply tri_dec1 with (F:=fun T : Type => ex (fun x0 : T => perp (a1 1 (var x0)))); eauto ...
  eapply tri_ex .
  compute.
  auto ...
Qed.

Definition p := A0 1.
Definition q := A0 3.
Definition r := A0 5.
Hint Unfold p q r.

Example sequent: |-F- [] ; [] ; UP( [ (p ⁺ & q ⁺) $  ⊥ $ (? p ⁻) $ (? q ⁻) ] ).
Proof with unfold p;unfold q;InvTac.
  NegPhase. (* Negative phase *)
  eapply tri_dec2 with (F:= p ⁻) ...
  eapply tri_dec2 with (F:= q ⁻) ...
Qed.


Require Import HoTT.Types.Universe HoTT.Basics.Decidable.
Require
  HoTT.Classes.theory.integers
  HoTT.Classes.theory.int_abs.
Require Import
  HoTT.Classes.implementations.peano_naturals
  HoTT.Classes.interfaces.abstract_algebra
  HoTT.Classes.interfaces.integers
  HoTT.Classes.interfaces.naturals
  HoTT.Classes.theory.additional_operations
  HoTT.Classes.interfaces.orders
  HoTT.Classes.implementations.natpair_integers
  HoTT.Classes.orders.rings
  HoTT.Classes.theory.rings
  HoTT.Classes.theory.integers.
Require Export
  HoTT.Classes.orders.nat_int.

Import NatPair.Instances.
Generalizable Variables N Z R f.

Section integers.
Context `{Funext} `{Univalence}.
Context `{Integers Z} `{!TrivialApart Z}.

(* Add Ring Z : (rings.stdlib_ring_theory Z). *)
(* Add Ring nat : (rings.stdlib_semiring_theory nat). *)

Lemma induction
  (P: Z -> Type):
  P 0 -> (forall n, 0 ≤ n -> P n -> P (1 + n)) -> (forall n, n ≤ 0 -> P n -> P (n - 1)) ->
  forall n, P n.
Proof.
intros P0 Psuc1 Psuc2 n.
destruct (int_abs_sig Z nat n) as [[a A]|[a A]].
- rewrite <-A. clear A. revert a.
  apply naturals.induction.
  + rewrite rings.preserves_0. trivial.
  + intros m E.
    rewrite rings.preserves_plus, rings.preserves_1.
    apply Psuc1.
    * apply to_semiring_nonneg.
    * trivial.
- rewrite <-(groups.negate_involutive n), <-A.
  clear A. revert a. apply naturals.induction.
  + rewrite rings.preserves_0, rings.negate_0. trivial.
  + intros m E.
    rewrite rings.preserves_plus, rings.preserves_1.
    rewrite rings.negate_plus_distr, commutativity.
    apply Psuc2.
    * apply naturals.negate_to_ring_nonpos.
    * trivial.
Qed.

Lemma induction_nonneg
  (P: Z -> Type):
  P 0 -> (forall n, 0 ≤ n -> P n -> P (1 + n)) -> forall n, 0 ≤ n -> P n.
Proof.
intros P0 PS. refine (induction _ _ _ _); auto.
intros n E1 ? E2.
destruct (rings.is_ne_0 1).
apply (antisymmetry (≤)).
- apply (order_reflecting ((n - 1) +)).
  rewrite <-plus_assoc,plus_negate_l,2!plus_0_r.
  transitivity 0;trivial.
- transitivity (n - 1);trivial.
  apply (order_reflecting (1 +)).
  rewrite plus_comm,<-plus_assoc,plus_negate_l,plus_0_r.
  transitivity 0.
  + trivial.
  + apply le_0_2.
Qed.

Global Instance: Biinduction Z.
Proof.
intros P P0 Psuc. apply induction; trivial.
- intros ??;apply Psuc.
- intros;apply Psuc.
  rewrite plus_comm,<-plus_assoc,plus_negate_l,plus_0_r.
  trivial.
Qed.

Global Instance slow_int_le_dec : forall x y: Z, Decidable (x ≤ y) | 10.
Proof.
intros x y.
(* otherwise Z_le gets defined using peano.nat_ring
   but we only know order_reflecting when using naturals.nat_ring *)
pose (naturals_ring) as E0.
destruct (dec (integers_to_ring _ (NatPair.Z nat) x ≤
    integers_to_ring _ (NatPair.Z nat) y)) as [E|E].
- left. apply (order_reflecting _) in E. trivial.
- right. intro;apply E;apply (order_preserving _);trivial.
Qed.
End integers.


Require Import ILogic ILInsts BILogic ILEmbed ILQuantTac.
Require Import Setoid Morphisms.

Set Implicit Arguments.
Unset Strict Implicit.
Set Maximal Implicit Insertion.

Section Pure.

  Context {A : Type} {ILOPs : ILogicOps A} {BILOps : BILOperators A}.

  Class PureOp := {
    pure : A -> Prop
  }.

  Definition parameter_pure (pure : A -> Prop) (P : A) : Prop :=
    (forall Q, P //\\ Q |-- P ** Q) /\
    (forall Q, pure Q -> P ** Q |-- P //\\ Q) /\
    (forall Q R, (P //\\ Q) ** R -|- P //\\ (Q ** R)) /\
    (forall Q, P -* Q |-- P -->> Q) /\
    (forall Q, pure Q -> P -->> Q |-- P -* Q).

  Class Pure {HP : PureOp} :=
  { pure_axiom : forall p, pure p -> parameter_pure pure p
  ; pure_proper : Proper (lequiv ==> iff) pure
  }.

  Existing Class pure.

  Context (IL : ILogic A) (BIL : BILogic A) (po : PureOp) (p : @Pure po).

  Lemma pureandsc P Q : pure P -> P //\\ Q |-- P ** Q.
  Proof.
    intros. eapply pure_axiom in H. destruct H. intuition.
  Qed.

  Lemma purescand  P Q : pure P -> pure Q -> P ** Q |-- P //\\ Q.
  Proof.
    intros. eapply pure_axiom in H. destruct H. intuition.
  Qed.

  Lemma pureandscD P Q R : pure P -> (P //\\ Q) ** R -|- P //\\ (Q ** R).
  Proof.
    intros. eapply pure_axiom in H; destruct H; intuition.
  Qed.

  Lemma puresiimpl P Q : pure P -> P -* Q |-- P -->> Q.
  Proof.
    intros. eapply pure_axiom in H; destruct H; intuition.
  Qed.

  Lemma pureimplsi P Q : pure P -> pure Q -> P -->> Q |-- P -* Q.
  Proof.
    intros. eapply pure_axiom in H; destruct H; intuition.
  Qed.

(*
  Instance pure_ltrue : pure ltrue.
  Proof.
    eapply pure_axiom.
    repeat constructor.
    { intros. rewrite <- (empSPL (ltrue //\\ Q)).
      etransitivity. 2: eapply bilsep.
      rewrite sepSPC. erewrite (sepSPC _ Q). eapply bilsep.
      eapply landL2. reflexivity. eapply ltrueR. }
    { intros.
      rewrite sepSPC.
      rewrite <- (landtrueR Q) at 1.
      rewrite pureandscD by auto.
      eapply landR. eapply ltrueR. eapply landL1. reflexivity. }
    { eapply landR. eapply ltrueR.
      eapply bilsep. eapply landL2. reflexivity. }
    { eapply landL2. eapply bilsep. eapply landR. eapply ltrueR. reflexivity. }
    { intros. eapply limplAdj. eapply landL1.
      rewrite septrue. eapply wandSPL; auto. }
    { intros. eapply wandSepSPAdj.
      rewrite limplTrue.
      rewrite <- (landtrueR Q) at 1.
      rewrite pureandscD; auto. apply landL1. reflexivity. }
  Qed.

  Instance pure_land x y : pure x -> pure y ->  pure (x //\\ y).
  Proof.
    intros.
    eapply pure_axiom.
    constructor.
    { intros. rewrite landA.
      rewrite pureandscD; auto.
      apply landR. apply landL1. reflexivity.
      apply landL2. apply pureandsc; auto. }
    constructor.
    { intros.
      rewrite pureandscD by auto.
      rewrite landA. apply landR. apply landL1. reflexivity.
      apply landL2. apply purescand; auto. }
    constructor.
    { intros.
      rewrite landA. rewrite pureandscD by auto.
      rewrite landA. rewrite pureandscD by auto.
      reflexivity. }
    constructor.
    { intros.
      eapply limplAdj. rewrite landC.
      rewrite landA.
      rewrite pureandsc by auto.
      rewrite pureandsc by auto.
      rewrite <- sepSPA.
      rewrite (@purescand x y) by auto.
      rewrite sepSPC. apply wandSPL; reflexivity. }
    { intros.
      rewrite landC at 1.
      rewrite curry.
      rewrite pureandsc by auto.
      rewrite wand_curry.
      eapply wandSPAdj.
      rewrite <- pureimplsi by auto.
      apply limplAdj.
      rewrite landC.
      rewrite <- pureandscD by auto.
      eapply sepSPAdj.
      rewrite landC.
      eapply limplL. reflexivity.
      apply landL1.
      eapply pureimplsi; auto. }
  Qed.

  Instance pure_sc x y (Hx : pure x) (Hy : pure y) : pure (x ** y).
  Proof.
    eapply pure_axiom; repeat split; intros.
    + rewrite sepSPA.
      do 2 (etransitivity; [|rewrite <- pureandsc; eauto]).
      rewrite purescand by auto. apply landA.
    + etransitivity; [|rewrite <- pureandsc; eauto].
      rewrite landA. rewrite <- purescand by auto using pure_land.
      rewrite <- purescand by auto.
      apply sepSPA.
    + etransitivity; [rewrite (purescand Hx Hy); reflexivity|].
      etransitivity; [|rewrite <- pureandsc by auto; reflexivity].
      rewrite <- pureandscD by eauto using pure_land. reflexivity.
    + etransitivity; [|rewrite <- (@pureandsc x y) by auto; reflexivity].
      rewrite purescand by auto.
      rewrite pureandscD by auto using pure_land; reflexivity.
    + etransitivity; [|rewrite purescand by auto; reflexivity].
      etransitivity; [rewrite <- pureandsc by auto; reflexivity|].
      rewrite puresiimpl by auto using pure_land; reflexivity.
    + etransitivity; [|rewrite purescand by auto; reflexivity].
      etransitivity; [rewrite <- pureandsc by auto; reflexivity|].
      rewrite pureimplsi by auto using pure_land; reflexivity.
  Qed.

  Instance pure_limpl x y (Hx : pure x) (Hy : pure y) : pure (x -->> y).

  Instance pure_lor x y : pure x -> pure y ->  pure (x \\// y).
*)

End Pure.

Implicit Arguments Pure [[A] [ILOPs] [BILOps]].


(**
  [TypeTheory.RelUniv.RelUniv_Cat_Iso]

  Part of the [TypeTheory] library (Ahrens, Lumsdaine, Voevodsky, 2015–present).
*)

(**
This module establishes an an isomorphism of
categories of "simple" and "full" categories of relative J-universe structures.
The isomorphism follows from the fact that ϕ component is completely determined
by the remaining parts of a morphisms when J is fully faithful.

Main definitions:

- [reluniv_functor] and [reluniv_cat_iso].

*)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import TypeTheory.Auxiliary.CategoryTheoryImports.

Require Import TypeTheory.Auxiliary.Auxiliary.
Require Import TypeTheory.Auxiliary.CategoryTheory.
Require Import TypeTheory.RelUniv.RelativeUniverses.
Require Import TypeTheory.RelUniv.RelUniv_Cat_Simple.
Require Import TypeTheory.RelUniv.RelUniv_Cat.
Require Import UniMath.CategoryTheory.catiso.

Section Cat_Iso.

  Context {C D : category}.
  Context (J : functor C D).
  Context (ff_J : fully_faithful J).

  Definition reluniv_mor_to_reluniv_mor_with_ϕ
             (u1 u2 : relative_universe J)
    : relative_universe_mor _ u1 u2 → reluniv_mor_with_ϕ _ u1 u2.
  Proof.
    intros mor.
    exact (mor ,, reluniv_mor_ϕ_of _ ff_J mor).
  Defined.

  Definition reluniv_mor_with_ϕ_to_reluniv_mor
             (u1 u2 : relative_universe J)
    : reluniv_mor_with_ϕ _ u1 u2 → relative_universe_mor _ u1 u2
    := pr1.

  Definition isweq_reluniv_mor_to_reluniv_mor_with_ϕ
             (u1 u2 : relative_universe J)
    : isweq (reluniv_mor_to_reluniv_mor_with_ϕ u1 u2).
  Proof.
    apply (isweq_iso _ (reluniv_mor_with_ϕ_to_reluniv_mor _ _)).
    - intros mor. apply idpath.
    - intros mor.
      apply reluniv_mor_with_ϕ_eq_faithful.
      + apply idpath.
      + apply idpath.
      + apply fully_faithful_implies_full_and_faithful, ff_J.
  Defined.

  Definition weq_reluniv_mor
             (u1 u2 : relative_universe J)
    : relative_universe_mor _ u1 u2 ≃ reluniv_mor_with_ϕ _ u1 u2
    := (_ ,, isweq_reluniv_mor_to_reluniv_mor_with_ϕ u1 u2).

  Definition reluniv_functor_data
    : functor_data (@reluniv_cat C _ J)
                   (@reluniv_with_ϕ_cat C _ J).
  Proof.
    use make_functor_data.
    - apply idweq.
    - intros u1 u2. apply weq_reluniv_mor.
  Defined.

  Definition reluniv_functor_idax
    : functor_idax reluniv_functor_data.
  Proof.
    intros c.
    use reluniv_mor_with_ϕ_eq_faithful.
    - apply idpath.
    - apply idpath.
    - apply fully_faithful_implies_full_and_faithful, ff_J.
  Defined.

  Definition reluniv_functor_compax
    : functor_compax reluniv_functor_data.
  Proof.
    intros a b c.
    intros f g.

    use reluniv_mor_with_ϕ_eq_faithful.
    - apply idpath.
    - apply idpath.
    - apply fully_faithful_implies_full_and_faithful, ff_J.
  Defined.

  Definition reluniv_is_functor
    : is_functor reluniv_functor_data
    := (reluniv_functor_idax ,, reluniv_functor_compax).

  Definition reluniv_functor
    : functor (reluniv_cat J)
              (reluniv_with_ϕ_cat J).
  Proof.
    use (make_functor reluniv_functor_data).
    apply reluniv_is_functor.
  Defined.

  Definition reluniv_is_catiso : is_catiso reluniv_functor.
  Proof.
    use tpair.
    - unfold fully_faithful.
      intros u1 u2.
      apply weq_reluniv_mor.
    - apply (pr2 (idweq _)).
  Defined.

End Cat_Iso.