(* Lemmas that DO NOT depend on CompCert or Verifiable C *)

Require Import compcert.lib.Integers.
Require Import compcert.lib.Coqlib.
Require Import Vector.
Require Import List. Import ListNotations.
Require Import sha.general_lemmas.
Require Import Lia.

Definition Vector_0_is_nil (T : Type) (v : Vector.t T 0) : v = Vector.nil T :=
  match v with Vector.nil => eq_refl end.

Lemma VectorToList_cons A n: forall (a:A) l,
      Vector.to_list (Vector.cons A a n l) =
      List.cons a (Vector.to_list l).
Proof. intros. reflexivity. Qed.

Lemma VectorToList_length {A}: forall n (v: Vector.t A n), length (Vector.to_list v) = n.
Proof.
  apply Vector.t_rec. reflexivity.
  intros. rewrite VectorToList_cons. simpl. rewrite H. trivial.
Qed.

Lemma VectorToList_combine A n: forall (a:A) b v1 v2,
     combine (Vector.to_list (Vector.cons A a n v1))
             (Vector.to_list (Vector.cons A b n v2))
   = (a,b) :: combine (Vector.to_list v1) (Vector.to_list v2).
Proof. intros. simpl. f_equal. Qed.

Theorem VectorToList_append {A}:
        forall (m:nat) (v2:Vector.t A m) (n : nat) (v1 : Vector.t A n),
                   (Vector.to_list v1) ++ (Vector.to_list v2) =
                   Vector.to_list (Vector.append v1 v2).
Proof. intros m v2.
  eapply Vector.t_rec.
  reflexivity.
  intros. simpl. rewrite (VectorToList_cons _ _ h). f_equal. rewrite <- H. f_equal.
Qed.

Lemma Forall2_map {A B} (f:A -> B): forall l m,
      Forall2 (fun x y => y = f x) l m -> map f l = m.
Proof. intros.
  induction H; simpl. reflexivity.
  subst y. f_equal. trivial.
Qed.

Lemma app_inv_length1 {A}: forall (l1 m1 l2 m2:list A),
  l1++l2 = m1++m2 -> length l1 = length m1 -> l1=m1 /\ l2=m2.
Proof.
induction l1; simpl; intros.
{ destruct m1; simpl in *. split; trivial. lia. }
{ destruct m1; simpl in *. discriminate.
  inversion H; clear H; subst a0.
  destruct (IHl1 _ _ _ H3). lia.
  subst. split; trivial. }
Qed.

Lemma app_inv_length2 {A}: forall (l1 m1 l2 m2:list A),
  l1++l2 = m1++m2 -> length l2 = length m2 -> l1=m1 /\ l2=m2.
Proof.
induction l1; simpl; intros.
{ destruct m1; simpl in *. split; trivial.
  assert (length l2 = length (a :: m1 ++ m2)). rewrite <- H; trivial.
  rewrite H1 in H0; clear H H1. simpl in H0. rewrite app_length in H0. lia. }
{ assert (length (a :: l1 ++ l2) = length (m1 ++ m2)). rewrite <- H; trivial.
  simpl in H1. do 2 rewrite app_length in H1. rewrite H0 in H1.
  destruct m1; simpl in *. lia.
  inversion H; clear H. subst a0.
  destruct (IHl1 _ _ _ H4 H0). subst. split; trivial. }
Qed.

Lemma cons_inv {A}: forall (a1 a2:A) t1 t2, a1::t1 = a2::t2 -> a1=a2 /\ t1=t2.
  intros. inversion H; split; trivial. Qed.

Lemma mod_exists a b c: a mod b = c -> b<> 0 -> exists k, k*b+c=a.
Proof. intros. specialize (Zmod_eq_full a b H0). intros.
  exists (a/b). rewrite H in H1; clear H H0. subst c. lia. Qed.

Lemma app_inj1 {A} l2 m2: forall (l1 m1:list A) (H:l1++l2=m1++m2),
      length l1=length m1 -> l1=m1 /\ l2=m2.
Proof. induction l1.
  destruct m1; simpl; intros. split; trivial. discriminate.
  destruct m1; simpl; intros. discriminate.
  inversion H; subst.
  destruct (IHl1 _ H3). lia.
  subst. split; trivial.
Qed.
Lemma max_unsigned_modulus: Int.max_unsigned + 1 = Int.modulus.
Proof. reflexivity. Qed.

Lemma int_max_unsigned_eq: Int.max_unsigned = 4294967295.
Proof. reflexivity. Qed.

Lemma ptrofs_max_unsigned_eq: Ptrofs.max_unsigned = 4294967295.
Proof. reflexivity. Qed.

Lemma IntModulus32: Int.modulus = 2^32. reflexivity. Qed.

Lemma Intsize_monotone a b: 0 <= Int.unsigned (Int.repr a) <= Int.unsigned (Int.repr b) ->
                          Int.size (Int.repr a) <= Int.size (Int.repr b).
Proof. apply Zbits.Zsize_monotone. Qed.

Lemma list_nil {A} l (L:@length A l = 0%nat): l = nil.
Proof. destruct l; simpl in *; eauto. inv L. Qed.

Lemma nth_mapIn {A}: forall i (l:list A) d (Hi: (0 <= i < length l)%nat),
  exists n, nth i l d = n /\ In n l.
Proof. intros i.
  induction i; simpl; intros.
    destruct l; simpl in *. lia. exists a. split; trivial. left; trivial.
    destruct l; simpl in *. lia.
      destruct (IHi l d) as [? [? ?]]. lia. rewrite H. exists x; split; trivial. right; trivial.
Qed.

Lemma skipn_repeat:
   forall A k n (a: A),
     (k <= n)%nat -> skipn k (repeat a n) = repeat a (n-k).
Proof.
 induction k; destruct n; simpl; intros; auto.
 apply IHk; auto. lia.
Qed.

Lemma skipn_length:
  forall {A} n (al: list A),
    (length al >= n)%nat ->
    (length (skipn n al) = length al - n)%nat.
Proof.
 induction n; destruct al; simpl; intros; auto.
 apply IHn. lia.
Qed.

Lemma fold_left_cons {A B} (f: A -> B -> A) l b x:
      fold_left f (x :: l) b = fold_left f l (f b x).
Proof. reflexivity. Qed.

Definition Forall_tl (A : Type) (P : A -> Prop) (a : A) (l : list A)
           (H : Forall P (a :: l)): Forall P l.
Proof. inversion H. assumption. Defined.
(*Now in sublist
Lemma Zlength_length:
  forall A (al: list A) (n: Z),
    0 <= n ->
    (Zlength al = n <-> length al = Z.to_nat n).
Proof.
intros. rewrite Zlength_correct.
split; intro.
rewrite <- (Z2Nat.id n) in H0 by lia.
apply Nat2Z.inj in H0; auto.
rewrite H0.
apply Z2Nat.inj; try lia.
rewrite Nat2Z.id; auto.
Qed.
*)
Lemma firstn_exact :
  forall {A : Type} (l1 l2 : list A) (n : nat),
    (length l1 = n)%nat -> firstn n (l1 ++ l2) = l1.
Proof.
  induction l1; destruct n; intros; simpl; try reflexivity; inversion H.
  * f_equal. apply IHl1. reflexivity.
Qed.

Lemma skipn_exact :
  forall {A : Type} (l1 l2 : list A) (n : nat),
    (length l1 = n)%nat -> skipn n (l1 ++ l2) = l2.
Proof.
  induction l1; destruct n; intros; simpl; try reflexivity; inversion H.
  * apply IHl1. reflexivity.
Qed.

Lemma length_not_emp :
  forall {A B : Type} (l : list A) (z y : B),
    (Datatypes.length l > 0)%nat -> match l with [] => z | _ => y end = y.
Proof.
  intros.
  induction l as [ | x xs].
  - inversion H.
  - reflexivity.
Qed.

Lemma list_splitLength {A}: forall n (l:list A) m,
      length l = (n + m)%nat -> exists l1 l2, l = l1 ++ l2 /\ length l1 = n /\ length l2 = m.
Proof. intros n.
  induction n; simpl; intros.
  exists [], l; eauto.
  destruct l; simpl in H; inversion H. clear H.
  destruct (IHn _ _ H1) as [l1 [l2 [L [L1 L2]]]]. clear IHn H1. subst.
  exists (a :: l1), l2; auto.
Qed.

Lemma skipn_short {A}: forall n (l:list A), (length l <= n)%nat -> skipn n l = nil.
Proof. induction n; simpl; intros.
  destruct l; trivial. simpl in H. lia.
  destruct l; trivial.
  apply IHn. simpl in H. lia.
Qed.

Lemma skipn_app2:
 forall A n (al bl: list A),
  (n >= length al)%nat ->
  skipn n (al++bl) = skipn (n-length al) bl.
Proof.
intros. revert al H;
induction n; destruct al; intros; simpl in *; try lia; auto.
apply IHn; lia.
Qed.
(*now in floyd_sublist
Lemma firstn_app1: forall {A} n (p l: list A),
  (n <= Datatypes.length p)%nat ->
   firstn n (p ++ l) = firstn n p.
Proof. intros A n.
induction n; simpl; intros. trivial.
  destruct p; simpl in H. lia.
  apply le_S_n in H. simpl. f_equal. auto.
Qed.

Lemma firstn_app2: forall {A} n (p l: list A),
  (n > Datatypes.length p)%nat ->
   firstn n (p ++ l) = p ++ (firstn (n-Datatypes.length p) l).
Proof. intros A n.
induction n; simpl; intros.
  destruct p; simpl in *. trivial. lia.
  destruct p; simpl in *. trivial.
  rewrite IHn. trivial. lia.
Qed.  *)

Lemma firstn_map {A B} (f:A -> B): forall n l,
      firstn n (map f l) = map f (firstn n l).
Proof. intros n.
induction n; simpl; intros. trivial.
  destruct l; simpl. trivial.
  rewrite IHn. trivial.
Qed.

Lemma firstn_combine {A}: forall n (l k: list A),
      firstn n (combine l k) = combine (firstn n l) (firstn n k).
Proof. intros n.
induction n; simpl; intros. trivial.
  destruct l; simpl. trivial.
  destruct k; simpl. trivial.
  rewrite IHn. trivial.
Qed.

Lemma firstn_precise {A}: forall n (l:list A), length l = n ->
      firstn n l = l.
Proof. intros n.
  induction n; intros; destruct l; simpl in *; trivial.
    inversion H.
    rewrite IHn; trivial. inversion H; trivial.
Qed.

Lemma mapnth': forall {A B : Type} (f : A -> B) (l : list A) (d : A) (n : nat) fd,
      fd = f d -> nth n (map f l) fd = f (nth n l d).
Proof. intros; subst. apply map_nth. Qed.

Lemma Ztest_Bytetest:
 forall a, Z.testbit (Byte.unsigned a) = Byte.testbit a.
Proof. reflexivity. Qed.
#[export] Hint Rewrite Ztest_Bytetest : testbit.

Lemma nthD_1 {A B}: forall (f: A ->B) n l d fx dd, (n < length l)%nat ->
      nth n (map f l) d = fx ->
      exists x, In x l /\ nth n l dd = x /\ f x = fx.
Proof. intros f n.
  induction n; simpl; intros.
    destruct l; simpl in *. lia.
      exists a; split. left; trivial. split; trivial.
    destruct l; simpl in *. lia.
    destruct (IHn l d fx dd) as [? [? [? ?]]]. lia. trivial.
    exists x; eauto.
Qed.

Lemma nth_repeat' {A}: forall (a d:A) k i (Hik: (i <k)%nat),
      nth i (repeat a k) d = a.
Proof. intros a d k. induction k; simpl; trivial. intros. lia.
 intros. destruct i; simpl; trivial. rewrite IHk. trivial. lia. Qed.

Lemma minus_lt_compat_r: forall n m p : nat,
      (n < m)%nat -> (p <= n)%nat -> (n - p < m - p)%nat.
Proof. intros. unfold lt in *. lia. Qed.

Lemma map_nth_error_inv {A B}: forall n (l:list A) (f: A -> B) fd,
    nth_error (map f l) n = Some fd -> exists d, nth_error l n = Some d /\ fd = f d.
  Proof. intros n.
    induction n; intros l.
     destruct l; simpl; intros. inversion H.
       inversion H. exists a. split; trivial.
     destruct l; simpl; intros. inversion H.
       eapply IHn. apply H.
  Qed.

Lemma nth_error_app {A}: forall n (l:list A) d,
    nth_error l n = Some d -> forall ll, nth_error (l ++ ll) n = Some d.
  Proof. intros n.
    induction n; intros l.
     destruct l; simpl; intros. inversion H. trivial.
     destruct l; simpl; intros. inversion H.
       eapply IHn. apply H.
  Qed.

Lemma Forall_app {A} p (l1 l2: list A): Forall p (l1 ++ l2) <-> (Forall p l1 /\ Forall p l2).
Proof. intros. repeat  rewrite Forall_forall.
  split; intros.
    split; intros; apply H; apply in_or_app. left; trivial. right; trivial.
  apply in_app_or in H0. destruct H. destruct H0; eauto.
Qed.

Lemma Zlength_nonneg {A}: forall (l:list A), 0 <= Zlength l.
Proof.
 intros.
 rewrite Zlength_correct.
 induction l; simpl. lia. rewrite Zpos_P_of_succ_nat. lia.
Qed.

Lemma Zlength_max_zero {A} (l:list A): Z.max 0 (Zlength l) = Zlength l.
Proof. rewrite Z.max_r. trivial. apply Zlength_nonneg. Qed.

Theorem xor_inrange : forall (x y : Z),
                        x = x mod Byte.modulus
                        -> y = y mod Byte.modulus
                        -> Z.lxor x y = (Z.lxor x y) mod Byte.modulus.
Proof.
  intros. symmetry. apply Zbits.equal_same_bits. intros.
  assert (ZZ: Z.lxor x y mod Byte.modulus =
        Z.lxor x y mod two_p (Z.of_nat Byte.wordsize)).
        rewrite Byte.modulus_power. reflexivity.
  rewrite ZZ; clear ZZ.
  rewrite Zbits.Ztestbit_mod_two_p; try lia.
  destruct (zlt i (Z.of_nat Byte.wordsize)); trivial.
  symmetry. rewrite Z.lxor_spec.
  assert (BB: Byte.modulus = two_p (Z.of_nat Byte.wordsize)).
    apply Byte.modulus_power.
  rewrite BB in H, H0.

  rewrite H; clear H; rewrite H0; clear H0 BB.
   rewrite Zbits.Ztestbit_mod_two_p; try lia.
   rewrite Zbits.Ztestbit_mod_two_p; try lia.
   destruct (zlt i (Z.of_nat Byte.wordsize)); trivial. lia.
Qed.

Lemma length_mul_split A k (K:(0<k)%nat) n (N:(0<n)%nat): forall (l:list A), length l = (k * n)%nat ->
      exists l1, exists l2, l=l1++l2 /\ length l1=n /\ length l2 = ((k-1) * n)%nat.
Proof.
  intros.
  assert ((k * n = n + (k-1) * n)%nat) by nia.
  rewrite H0 in H; clear H0.
  apply (list_splitLength _ _ _ H).
Qed.


Set Implicit Arguments.

Require Import List. Import ListNotations.
Require Import Arith.

Require Import HMAC_functional_prog_Z.
Require Import Integers.
Require Import Coqlib.
Require Import sha_padding_lemmas.
Require Import functional_prog.
Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import SHA256.
Require Import ByteBitRelations.
Require Import XorCorrespondence.
Require Import HMAC_functional_prog_Z.
Require Import HMAC_common_defs.
Require Import HMAC_common_lemmas.
Require Import hmac_pure_lemmas.
(* TODO remove useless imports *)

Require Import Coq.Program.Basics. (* for function composition: ∘ *)

Module HMAC_Pad.

Local Open Scope program_scope.

Section HMAC.

(* b = block size
   c = digest (output) size
   p = padding = b - c (fixed) *)
  Variable c p : nat.
  Definition b := (c + p)%nat.

  (* The compression function *)
  Variable h : Blist -> Blist -> Blist.
  (* The initialization vector is part of the spec of the hash function. *)
  Variable iv : Blist.
  (* The iteration of the compression function gives a keyed hash function on lists of words. *)

  Definition h_star k (m : Blist) :=
    hash_blocks_bits h k m.
  (* The composition of the keyed hash function with the IV gives a hash function on lists of words. *)
  Definition hash_words := h_star iv.

  Variable splitAndPad : Blist -> Blist.

  Definition hash_words_padded : Blist -> Blist :=
    hash_words ∘ splitAndPad.

  (* ----- *)

  Hypothesis splitAndPad_1_1 :
    forall b1 b2,
      splitAndPad b1 = splitAndPad b2 ->
      b1 = b2.

  (* constant-length padding. *)
  Variable fpad : Blist.

  Definition app_fpad (x : Blist) : Blist :=
    x ++ fpad.
  Definition h_star_pad k x :=
    app_fpad (h_star k x).

  (* TODO fix this -- not used by HAMC *)
  Definition GNMAC k m :=
    let (k_Out, k_In) := splitList c k in
    h k_Out (h_star_pad k_In m).

  (* The "two-key" version of GHMAC and HMAC. *)
  (* Concatenate (K xor opad) and (K xor ipad) *)
  Definition GHMAC_2K (k : Blist) m :=
    let (k_Out, k_In) := splitList b k in (* concat earlier, then split *)
      let h_in := (hash_words_padded (k_In ++ m)) in
        hash_words_padded (k_Out ++ h_in).

  Definition HMAC_2K (k : Blist) (m : Blist) :=
    (* GHMAC_2K k (splitAndPad m). *)
    GHMAC_2K k m.

(* opad and ipad are constants defined in the HMAC spec. *)
Variable opad ipad : Blist.

Definition GHMAC (k : Blist) :=
  GHMAC_2K (BLxor k opad ++ BLxor k ipad).

Definition HMAC (k : Blist) :=
  HMAC_2K (BLxor k opad ++ BLxor k ipad).

End HMAC.

(* ----------------------------------------------- *)

Definition c:nat := (HMAC_progZ.SHA256_.DigestLength * 8)%nat.
Definition p:=(32 * 8)%nat.

Definition sha_iv : Blist :=
  bytesToBits (SHA256.intlist_to_Zlist SHA256.init_registers).

Definition sha_h (regs : Blist) (block : Blist) : Blist :=
  bytesToBits (SHA256.intlist_to_Zlist
                 (SHA256.hash_block (SHA256.Zlist_to_intlist (bitsToBytes regs))
                                     (SHA256.Zlist_to_intlist (bitsToBytes block))
              )).

Definition sha_splitandpad (msg : Blist) : Blist :=
  bytesToBits (sha_padding_lemmas.pad (bitsToBytes msg)).

Definition convert (l : list int) : list bool :=
  bytesToBits (SHA256.intlist_to_Zlist l).

(* ------------------------------------------------- *)
(* Neat conversion functions (TODO move rest of spec over *)

(*
Definition c := (HMAC_progZ.SHA256_.DigestLength * 8)%nat.
Definition p := (32 * 8)%nat.

Definition intsToBits (l : list int) : list bool :=
  bytesToBits (SHA256.intlist_to_Zlist l).

Definition bitsToInts (l : Blist) : list int :=
  SHA256.Zlist_to_intlist (bitsToBytes l).

Definition sha_iv : Blist :=
  intsToBits SHA256.init_registers.

Definition sha_h (regs : Blist) (block : Blist) : Blist :=
  intsToBits (SHA256.hash_block (bitsToInts regs) (bitsToInts block)).

Definition sha_splitandpad (msg : Blist) : Blist :=
  bytesToBits (sha_padding_lemmas.pad (bitsToBytes msg)).
*)

(* -------------------------------------------------------- LEMMAS *)

(* Lemma 1: ++ equivalence on list *)
(* Lemma 2: xor equivalence on list *)
(* Lemma 3: SHA (iterated hash) equivalence on list *)

Lemma concat_equiv :
  forall (l1 : Blist) (l2 : list Z) (m1 : Blist) (m2 : list Z),
    bytes_bits_lists l1 l2
    -> bytes_bits_lists m1 m2
    -> bytes_bits_lists (l1 ++ m1) (l2 ++ m2).
Proof.
  intros l1 l2 m1 m2.
  intros fst_eq snd_eq.
  generalize dependent m1. generalize dependent m2.
  induction fst_eq; intros.
  - repeat rewrite app_nil_l.
    apply snd_eq.
  - simpl.
    apply eq_cons.
    + apply IHfst_eq.
      apply snd_eq.
    + apply H.
Qed.

(* --------------------------------- *)

(* Lemma 2 *)

(* Prove that the inner xor lemma is true on at least one example *)
Section XOR_Example.

 Definition k:Blist := concat (list_repeat 64 [true; true; false; false; true; false; true; true]).
 Definition K:list Z := list_repeat 64 211.

 Lemma conv : convertByteBits [true; true; false; false; true; false; true; true] 211.
   repeat eexists.
  (* eexists; eexists; eexists; eexists; eexists; eexists; eexists; eexists. *)
  (* split. reflexivity. simpl. reflexivity. *)
 Qed.
 Lemma kKcorrect: bytes_bits_lists k K.
   unfold K, k. simpl.
   repeat constructor; try apply conv.
  Qed.

 Definition ip:Blist := concat (list_repeat 64 [false; true; false; false; true; false; true; true]).
 Definition IP:Z := 210.
 Transparent Byte.repr.

Definition byte_to_64list (byte : byte) : list Z :=
   map Byte.unsigned (HMAC_progZ.HMAC_SHA256.sixtyfour byte).

 Lemma ip_conv : convertByteBits [false; true; false; false; true; false; true; true] 210.
   repeat eexists.
 Qed.
 Lemma ipcorrect: bytes_bits_lists ip (HMAC_progZ.HMAC_SHA256.sixtyfour IP).
   unfold ip, IP. simpl. unfold byte_to_64list, HMAC_progZ.HMAC_SHA256.sixtyfour. simpl.
   repeat constructor; try apply ip_conv.
  Qed.

Lemma ONE: convertByteBits [true; false; false; false; false; false; false; false] 1.
  repeat eexists. Qed.

Lemma inner_fst_equiv_example : exists k (ip  : Blist) K (IP : Z),
                          ((length K) * 8)%nat = (c + p)%nat /\
                          Zlength K = Z.of_nat HMAC_progZ.SHA256_.BlockSize /\
                          (* TODO: first implies this *)
                          bytes_bits_lists k K /\
                          bytes_bits_lists ip (HMAC_progZ.HMAC_SHA256.sixtyfour IP) /\
                          bytes_bits_lists (BLxor k ip)
                                           ((HMAC_progZ.HMAC_SHA256.mkArg (HMAC_progZ.HMAC_SHA256.mkKey K) IP)).

Proof.
  exists k, ip, K, IP. repeat split.
   apply kKcorrect. apply ipcorrect.
  unfold k, K, ip, IP. simpl. unfold BLxor. simpl.
  repeat constructor; apply ONE.
Qed.

End XOR_Example.

(* See XorCorrespondence.v *)

Lemma inner_general_map : forall (ip : Blist) (IP_list : list Z) (k : Blist) (K : list Z),
                            bytes_bits_lists ip IP_list ->
                            bytes_bits_lists k K ->
     bytes_bits_lists (BLxor k ip)
                      (map (fun p0 : Z * Z => Z.lxor (fst p0) (snd p0))
                           (combine K IP_list)).
Proof.
  intros ip IP_list k K ip_eq k_eq.
  unfold BLxor. simpl.
  generalize dependent ip. generalize dependent IP_list.
  induction k_eq; intros.
  - simpl. constructor.
  -
    induction ip_eq.
    +
      simpl. constructor.
    +
      simpl.
      constructor.
      * apply IHk_eq.
        apply ip_eq.
      *
        apply xor_correspondence.
        apply H. apply H0.
Qed.

Lemma xor_equiv_Z : forall (xpad  : Blist) (XPAD : Z)
                                           (k : Blist) (K : list Z),
                          bytes_bits_lists xpad (HMAC_progZ.HMAC_SHA256.sixtyfour XPAD) ->
                          ((length K) * 8)%nat = (c + p)%nat ->
                          Zlength K = Z.of_nat HMAC_progZ.SHA256_.BlockSize ->
                          (* TODO: first implies this *)
                          bytes_bits_lists k K ->
                          bytes_bits_lists (BLxor k xpad)
       (HMAC_progZ.HMAC_SHA256.mkArg (HMAC_progZ.HMAC_SHA256.mkKey K) XPAD).
Proof.
  intros xpad XPAD k K.
  intros xpad_equiv len_k zlen_k k_equiv.
  unfold HMAC_progZ.HMAC_SHA256.mkArg, HMAC_progZ.HMAC_SHA256.mkKey.
  Opaque HMAC_progZ.HMAC_SHA256.sixtyfour.
  simpl. rewrite zlen_k. simpl. unfold HMAC_progZ.HMAC_SHA256.zeroPad.
  assert (byte_key_length_blocksize: length K = 64%nat).
    * unfold p, c in *. simpl in *. omega.
  *
    rewrite byte_key_length_blocksize.  simpl.  rewrite app_nil_r.
    apply inner_general_map.

  - apply xpad_equiv.
  - apply k_equiv.
Qed.

(* ------------------------------------------------------ *)
(* Lemma 3 *)

(* --- abstract version *)

Parameter A B : Type.
Parameter convert_BA : B -> A.
Parameter convert_AB : A -> B.

Fixpoint iterate {A : Type} (n : nat) (f : A -> A) (x : A) :=
  match n with
    | O => x
    | S n' => f (iterate n' f x) (* or [iterate n' f (f x)] *)
  end.

Definition id {X : A} (x : A) : A := x.
Definition wrap (F : B -> B) : A -> A :=
  convert_BA ∘ F ∘ convert_AB.
Definition roundtrip : B -> B :=
  convert_AB ∘ convert_BA.

Lemma roundtrip_id :
  forall (X : B), convert_AB (convert_BA X) = X.
Proof. Admitted. (* Axiom *)

Lemma once_eq :
    forall (x : A) (X : B) (f : A -> A) (F : B -> B),
      x = convert_BA X ->
      f = wrap F ->
      X = roundtrip X ->
      f x = convert_BA (F X).
Proof.
  intros x X f F inputs_eq f_def roundtrip_id.
  unfold roundtrip in *.
  rewrite -> inputs_eq.
  rewrite -> f_def.
  unfold wrap in *.
  change ((convert_BA ∘ F ∘ convert_AB) (convert_BA X)) with
    (convert_BA (F ((convert_AB ∘ convert_BA) X))).
  rewrite <- roundtrip_id.
  reflexivity.
Qed.

(* a simplified version of fold_equiv *)
Lemma iterate_equiv :
  forall (x : A) (X : B) (f : A -> A) (F : B -> B) (n : nat),
    x = convert_BA X ->
    f = wrap F ->
    X = roundtrip X ->
    iterate n f x = convert_BA (iterate n F X).
Proof.
  intros. revert x X f F H H0 H1.
  induction n as [ | n']; intros x X f F input_eq func_wrap roundtrip';
  unfold wrap in *; unfold roundtrip in *.
  -
    simpl. apply input_eq.
  -
    simpl.
    pose proof once_eq as once_eq.
    apply once_eq.
    apply IHn'; assumption.
    * unfold wrap. apply func_wrap.
    * symmetry. apply roundtrip_id.
Qed.

(* ----- concrete version *)

(* Definition of InBlocks in sha_padding_lemmas *)

Lemma bitsToByte_cons: forall bits h t, (h::t) = bitsToBytes bits ->
      exists b0, exists b1, exists b2, exists b3,
      exists b4, exists b5, exists b6, exists b7, exists xs,
      bits = b0 :: b1 :: b2 :: b3 :: b4 :: b5 :: b6 :: b7 :: xs /\
      h = bitsToByte [b0, b1, b2, b3, b4, b5, b6, b7] /\
      t = bitsToBytes xs.
Proof. intros.
  destruct bits. inv H.
  destruct bits. inv H.
  destruct bits. inv H.
  destruct bits. inv H.
  destruct bits. inv H.
  destruct bits. inv H.
  destruct bits. inv H.
  destruct bits; inv H.
  eexists; eexists; eexists; eexists; eexists; eexists; eexists; eexists; eexists.
  split. reflexivity.
  split; reflexivity.
Qed.

(* Lemmas stating that various operations result in bytes in range *)

Lemma bitsToByte_isbyteZ b0 b1 b2 b3 b4 b5 b6 b7:
      isbyteZ (bitsToByte [b0, b1, b2, b3, b4, b5, b6, b7]).
Proof. simpl. unfold asZ, isbyteZ.
  destruct b0; destruct b1; destruct b2; destruct b3;
  destruct b4; destruct b5; destruct b6; destruct b7; simpl; omega.
Qed.

Lemma bitsToBytes_isbyteZ: forall bytes bits,
                             bytes = bitsToBytes bits -> Forall isbyteZ bytes.
Proof. intros bytes.
  induction bytes; simpl; intros.
     constructor.
  apply bitsToByte_cons in H.
  destruct H as [b0 [b1 [b2 [b3 [b4 [b5 [b6 [b7 [xs [BITS [A BYTES]]]]]]]]]]].
  constructor.
     subst. apply bitsToByte_isbyteZ.
     eauto.
Qed.

Lemma convertByteBits_isbyteZ b0 b1 b2 b3 b4 b5 b6 b7 byte:
      convertByteBits [b0, b1, b2, b3, b4, b5, b6, b7] byte ->
      isbyteZ byte.
Proof. intros.
  destruct H as [b8 [b9 [b10 [b11 [b12 [b13 [b14 [b15 [BITS ZZ]]]]]]]]].
  inversion BITS. subst. clear BITS.
  unfold asZ, isbyteZ.
  destruct b8; destruct b9; destruct b10; destruct b11;
  destruct b12; destruct b13; destruct b14; destruct b15; simpl; omega.
Qed.

Lemma bytesBitsLists_isbyteZ bytes bits: bytes_bits_lists bits bytes -> Forall isbyteZ bytes.
Proof. intros.
  induction H. constructor.
  constructor; trivial. eapply convertByteBits_isbyteZ. apply H0.
Qed.

Lemma pad_isbyteZ: forall l, Forall isbyteZ l -> Forall isbyteZ (pad l).
Proof. intros. unfold pad.
  apply pure_lemmas.Forall_app.
  split; trivial.
  apply pure_lemmas.Forall_app.
  split. constructor. unfold isbyteZ; omega. constructor.
  apply pure_lemmas.Forall_app.
  split. apply pure_lemmas.Forall_list_repeat. unfold isbyteZ; omega.
  apply pure_lemmas.isbyte_intlist_to_Zlist.
Qed.

(* --------------------------- end bytes/bits proofs *)

Lemma splitandpad_equiv : forall (bits : Blist) (bytes : list Z),
                            bytes_bits_lists bits bytes ->
                            bytes_bits_lists
                              (sha_splitandpad bits)
                              (sha_padding_lemmas.pad bytes).
Proof.
  intros bits bytes inputs_eq.
  unfold concat.
  unfold sha_splitandpad.
  specialize (bytesBitsLists_isbyteZ inputs_eq). intros isbyteZ_Bytes.

  apply bytes_bits_ind_comp in inputs_eq. 2: apply isbyteZ_Bytes.
  rewrite inputs_eq.
  apply bytes_bits_def_eq.
  rewrite <- inputs_eq. apply pad_isbyteZ. trivial.
Qed.

Lemma hash_block_equiv :
  forall (bits : Blist) (bytes : list Z)
         (regs : Blist) (REGS : SHA256.registers),
    Forall isbyteZ bytes ->
    (length bits)%nat = 512%nat ->
    (length bytes)%nat = 64%nat -> (* removes firstn 16 (Zlist->intlist bytes) *)

    regs = bytesToBits (SHA256.intlist_to_Zlist REGS) ->
    bits = bytesToBits bytes ->

    sha_h regs bits =
    bytesToBits (SHA256.intlist_to_Zlist
                   (SHA256.hash_block REGS
                                      (SHA256.Zlist_to_intlist bytes))).
Proof.
  intros bits bytes regs REGS bytes_inrange bits_blocksize bytes_blocksize regs_eq input_eq.
  unfold sha_h.
  apply f_equal.
  apply f_equal.

  rewrite -> regs_eq.
  rewrite -> input_eq.
  rewrite -> bytes_bits_bytes_id.
  rewrite -> bytes_bits_bytes_id.
  rewrite -> pure_lemmas.intlist_to_Zlist_to_intlist.
  reflexivity.
  * apply bytes_inrange.
  * apply pure_lemmas.isbyte_intlist_to_Zlist.
Qed.

(* Front/back equivalence theorems *)

(*NEW proof*) Lemma front_equiv :
  forall (back : Blist) (BACK : list int) (front : Blist) (FRONT : list int),
    (length front)%nat = 512%nat ->
    (length FRONT)%nat = 16%nat ->
    front ++ back = convert (FRONT ++ BACK) ->
    front = convert FRONT.
Proof.
  intros back BACK front FRONT f_len F_len concat_eq.
  unfold convert in *.
  rewrite -> pure_lemmas.intlist_to_Zlist_app in concat_eq.
  rewrite -> bytesToBits_app in concat_eq.

  assert (back = skipn 512 (front ++ back)).
    rewrite skipn_exact; trivial.
  assert (bytesToBits (intlist_to_Zlist BACK) = skipn 512 (front ++ back)).
    rewrite concat_eq; clear concat_eq.
    rewrite skipn_exact; trivial.
    rewrite bytesToBits_len, pure_lemmas.length_intlist_to_Zlist, F_len; omega.
  rewrite H, H0 in concat_eq; clear H H0.
  eapply app_inv_tail. eassumption.
Qed.

Lemma back_equiv :
  forall (back : Blist) (BACK : list int) (front : Blist) (FRONT : list int),
    (length front)%nat = 512%nat ->
    (length FRONT)%nat = 16%nat ->
    front ++ back = convert (FRONT ++ BACK) ->
    back = convert BACK.
Proof.
  intros back BACK front FRONT f_len F_len concat_eq.
  assert (front ++ back = convert (FRONT ++ BACK)) as concat_eq'. apply concat_eq.
  unfold convert in *.
  rewrite -> pure_lemmas.intlist_to_Zlist_app in concat_eq.
  rewrite -> bytesToBits_app in concat_eq.

  assert (front_eq : front = convert FRONT).
    pose proof front_equiv back BACK front FRONT.
    apply H.
    * assumption.
    * assumption.
    * apply concat_eq'.
    * rewrite -> front_eq in concat_eq.
      unfold convert in *.
      eapply app_inv_head. eassumption.
Qed.

(* --------- *)

(* it's more of an iteration theorem than a fold theorem *)
(* conversion function: bytesToBits @ SHA256.intlist_to_Zlist *)
Lemma fold_equiv_blocks :
  forall (l : Blist) (acc : Blist)
         (L : list int) (ACC : list int),
    (* length assumptions about list *)
      InBlocks 512 l ->
      InBlocks 16 L ->
      l = convert L ->
      acc = convert ACC ->
      hash_blocks_bits sha_h acc l = convert (SHA256.hash_blocks ACC L).
Proof.
  intros l acc L ACC bit_blocks bytes_blocks inputs_eq acc_eq.

  revert acc ACC L inputs_eq acc_eq bytes_blocks.
  induction bit_blocks; intros.
  *
    revert acc ACC inputs_eq acc_eq.
    induction bytes_blocks; intros.

    -                             (* both empty *)
      rewrite -> SHA256.hash_blocks_equation.
      rewrite -> hash_blocks_bits_equation.
      apply acc_eq.

    -
      rewrite -> H0 in *.
      unfold convert in inputs_eq.
      destruct front.
      { inversion H. }
      { simpl in inputs_eq. inversion inputs_eq. }

  *
    revert front back full H H0 bit_blocks IHbit_blocks acc ACC
           inputs_eq acc_eq.
    induction bytes_blocks; intros.
    (* TODO: clear IHbytes_blocks *)

    -
      simpl in inputs_eq.
      rewrite -> H0 in inputs_eq.
      unfold convert in inputs_eq.
      destruct front.
      { inversion H. }
      { simpl in inputs_eq. inversion inputs_eq. }

    -
      rewrite -> SHA256.hash_blocks_equation.
      rewrite -> hash_blocks_bits_equation.
      repeat rewrite -> length_not_emp.

      rewrite -> H0.
      rewrite -> H2.
      (* TODO: generalize these (it's true by hyp) *)
      assert (H_first_512 : firstn 512 (front0 ++ back0) = front0).
        apply firstn_exact. assumption.
      assert (H_skip_512 : skipn 512 (front0 ++ back0) = back0).
        apply skipn_exact. assumption.
      assert (H_first_16 : firstn 16 (front ++ back) = front).
        apply firstn_exact. assumption.
      assert (H_skip_16 : skipn 16 (front ++ back) = back).
        apply skipn_exact. assumption.

      rewrite -> H_first_512.
      rewrite -> H_skip_512.
      rewrite -> H_first_16.
      rewrite -> H_skip_16.

      apply IHbit_blocks; auto; clear IHbytes_blocks IHbit_blocks.
      +
        rewrite -> H0 in inputs_eq.
        rewrite -> H2 in inputs_eq.
        apply (back_equiv back0 back front0 front H1 H inputs_eq).
      +
        pose proof hash_block_equiv as hash_block_equiv.
        specialize (hash_block_equiv front0 (SHA256.intlist_to_Zlist front) acc ACC).
        rewrite -> hash_block_equiv; auto. clear hash_block_equiv.
        rewrite -> pure_lemmas.intlist_to_Zlist_to_intlist.
        reflexivity.
        { apply pure_lemmas.isbyte_intlist_to_Zlist. }
        {
          rewrite -> pure_lemmas.length_intlist_to_Zlist.
          rewrite -> H.
          omega.
        }
        {
          rewrite -> H0 in inputs_eq.
          rewrite -> H2 in inputs_eq.

          (*NEW*) apply (front_equiv back0 back front0 front H1 H inputs_eq).
        }
     +
       rewrite -> H0. rewrite -> app_length. rewrite -> H. omega.
     +
       rewrite -> H2. rewrite -> app_length. rewrite -> H1. omega.
Qed.

Lemma SHA_equiv_pad : forall (bits : Blist) (bytes : list Z),
                    bytes_bits_lists bits bytes ->
                    bytes_bits_lists
                      (hash_words_padded sha_h sha_iv sha_splitandpad bits)
                      (HMAC_progZ.SHA256_.Hash bytes).

Proof.
  intros bits bytes input_eq.
  unfold HMAC_progZ.SHA256_.Hash.
  rewrite -> functional_prog.SHA_256'_eq.
  unfold SHA256.SHA_256.
  unfold hash_words_padded.
  change ((hash_words sha_h sha_iv ∘ sha_splitandpad) bits) with
  (hash_words sha_h sha_iv (sha_splitandpad bits)).

  -
    repeat rewrite <- sha_padding_lemmas.pad_compose_equal in *.
    unfold sha_padding_lemmas.generate_and_pad' in *.
    unfold hash_words.
    unfold h_star.

    pose proof splitandpad_equiv as splitandpad_equiv.
    specialize (splitandpad_equiv bits bytes input_eq).

      apply bytes_bits_comp_ind.
      pose proof fold_equiv_blocks as fold_equiv_blocks.
      apply pure_lemmas.isbyte_intlist_to_Zlist.
      (* TODO: in-range preserved by hash_blocks and intlist_to_Zlist *)
      apply fold_equiv_blocks.
      *                         (* padding -> blocks of 512 *)
        unfold sha_splitandpad in *.
        apply bytes_bits_length in input_eq.
        pose proof pad_len_64_nat (bitsToBytes bits) as pad_len_64.
        apply InBlocks_len.
        rewrite -> bytesToBits_len.
        (* eexists. *)
        destruct pad_len_64.
        rewrite -> H.
        exists x.
        omega.
      *
        pose proof pad_len_64_nat bytes as pad_len_64.
        apply InBlocks_len.
        destruct pad_len_64.

        assert (H' : length (pad bytes) = (Z.to_nat WORD * (16 * x))%nat).
          rewrite -> H.
          assert (Z.to_nat WORD = 4%nat) by reflexivity.
          rewrite -> H0.
          omega.

        apply pure_lemmas.length_Zlist_to_intlist in H'.
        rewrite H'.
        eexists x.
        omega.

      * unfold sha_splitandpad.
        unfold convert.
        rewrite -> pure_lemmas.Zlist_to_intlist_to_Zlist.
        f_equal.
        apply bytes_bits_ind_comp in input_eq.
        rewrite -> input_eq.
        reflexivity.
        +
          eapply bytesBitsLists_isbyteZ. eassumption.
        +
          pose proof pad_len_64_nat bytes as pad_len_64.
          destruct pad_len_64.
          rewrite -> H.
          assert (four : Z.to_nat WORD = 4%nat) by reflexivity.
          rewrite -> four.
          exists (x * 16)%nat.
          omega.
        + apply pad_isbyteZ. eapply bytesBitsLists_isbyteZ. eassumption.

     * unfold sha_iv. reflexivity.
Qed.

(* --------------------------------------- *)

(* MAIN THEOREM *)

(* Relates the HMAC padded spec to the HMAC functional program (version that uses Z) *)

Theorem HMAC_Pad_Concrete_equiv : forall
                            (K M H : list Z) (OP IP : Z)
                            (k m h : Blist) (op ip : Blist),
  ((length K) * 8)%nat = (c + p)%nat ->
  Zlength K = Z.of_nat HMAC_progZ.SHA256_.BlockSize ->
  (* TODO: first implies this *)
  bytes_bits_lists k K ->
  bytes_bits_lists m M ->
  bytes_bits_lists op (HMAC_progZ.HMAC_SHA256.sixtyfour OP) ->
  bytes_bits_lists ip (HMAC_progZ.HMAC_SHA256.sixtyfour IP) ->
  HMAC c p sha_h sha_iv sha_splitandpad op ip k m = h ->
  HMAC_progZ.HMAC_SHA256.HMAC IP OP M K = H ->
  bytes_bits_lists h H.
Proof.
  intros K M H OP IP k m h op ip.
  intros padded_key_len padded_key_len_byte padded_keys_eq msgs_eq ops_eq ips_eq.
  intros HMAC_abstract HMAC_concrete.

  intros.
  unfold p, c in *.
  simpl in *.

  rewrite <- HMAC_abstract. rewrite <- HMAC_concrete.

  unfold HMAC. unfold HMAC_progZ.HMAC_SHA256.HMAC. unfold HMAC_progZ.HMAC_SHA256.OUTER. unfold HMAC_progZ.HMAC_SHA256.INNER.
  unfold HMAC_progZ.HMAC_SHA256.outerArg. unfold HMAC_progZ.HMAC_SHA256.innerArg.

  unfold HMAC_2K. unfold GHMAC_2K. rewrite -> split_append_id.

  simpl.

  (* Major lemmas *)
  apply SHA_equiv_pad.
  apply concat_equiv.
  apply xor_equiv_Z; try assumption.

  *
    apply SHA_equiv_pad.
    apply concat_equiv.

  - apply xor_equiv_Z; try assumption.
  - assumption.
    (* xors preserve length : TODO factor this out*)
    *
      (* Locate padded_keys_eq. *)
      unfold b in *. simpl. unfold BLxor. rewrite -> list_length_map.
      rewrite -> combine_length.
      pose proof bytes_bits_length op (HMAC_progZ.HMAC_SHA256.sixtyfour OP) as ops_len.
      rewrite -> ops_len.
      pose proof bytes_bits_length k K as keys_len.
      rewrite -> keys_len.
      rewrite -> padded_key_len.
      Transparent HMAC_progZ.HMAC_SHA256.sixtyfour.
      unfold HMAC_progZ.HMAC_SHA256.sixtyfour.
      rewrite -> length_list_repeat.
      reflexivity.
      apply padded_keys_eq.     (* given: bytes_bits_lists k K *)
      apply ops_eq.             (* given: bytes_bits_lists op (64 OP) *)

    *
      unfold b in *. simpl. unfold BLxor. rewrite -> list_length_map.
      rewrite -> combine_length.
      pose proof bytes_bits_length ip (HMAC_progZ.HMAC_SHA256.sixtyfour IP) as ips_len.
      rewrite -> ips_len.
      pose proof bytes_bits_length k K as keys_len.
      rewrite -> keys_len.
      rewrite -> padded_key_len.
      unfold HMAC_progZ.HMAC_SHA256.sixtyfour.
      rewrite -> length_list_repeat.
      reflexivity.
      apply padded_keys_eq.
      apply ips_eq.
Qed.

End HMAC_Pad.
(* TODO move this End to the end of the spec definition + rename and recompile things *)


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(* This file is a prerequisite for Tarski.v. Its contents can be
   retrieved in CoC version 1.10. At this time it was part of the file
   Tarski.v (which itself was called Tarski.ml). Rstar.v has been
   separated from Tarski.v in CoC V4.5. At this time it was called
   Relations.v, a name that changed to Rstar.v in Coq V5.10.
*)
(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(*i $Id$ i*)

(** Properties of a binary relation [R] on type [A] *)

Section Rstar.

Variable A : Type.
Variable R : A -> A -> Prop.

(** Definition of the reflexive-transitive closure [R*] of [R] *)
(** Smallest reflexive [P] containing [R o P] *)

Definition Rstar (x y:A) :=
  forall P:A -> A -> Prop,
    (forall u:A, P u u) -> (forall u v w:A, R u v -> P v w -> P u w) -> P x y.

Theorem Rstar_reflexive : forall x:A, Rstar x x.
 Proof
   fun (x:A) (P:A -> A -> Prop) (h1:forall u:A, P u u)
     (h2:forall u v w:A, R u v -> P v w -> P u w) =>
     h1 x.

Theorem Rstar_R : forall x y z:A, R x y -> Rstar y z -> Rstar x z.
 Proof
   fun (x y z:A) (t1:R x y) (t2:Rstar y z) (P:A -> A -> Prop)
     (h1:forall u:A, P u u) (h2:forall u v w:A, R u v -> P v w -> P u w) =>
     h2 x y z t1 (t2 P h1 h2).

(** We conclude with transitivity of [Rstar] : *)

Theorem Rstar_transitive :
 forall x y z:A, Rstar x y -> Rstar y z -> Rstar x z.
 Proof
   fun (x y z:A) (h:Rstar x y) =>
     h (fun u v:A => Rstar v z -> Rstar u z) (fun (u:A) (t:Rstar u z) => t)
       (fun (u v w:A) (t1:R u v) (t2:Rstar w z -> Rstar v z)
          (t3:Rstar w z) => Rstar_R u v z t1 (t2 t3)).

(** Another characterization of [R*] *)
(** Smallest reflexive [P] containing [R o R*] *)

Definition Rstar' (x y:A) :=
  forall P:A -> A -> Prop,
    P x x -> (forall u:A, R x u -> Rstar u y -> P x y) -> P x y.

Theorem Rstar'_reflexive : forall x:A, Rstar' x x.
 Proof
   fun (x:A) (P:A -> A -> Prop) (h:P x x)
     (h':forall u:A, R x u -> Rstar u x -> P x x) => h.

Theorem Rstar'_R : forall x y z:A, R x z -> Rstar z y -> Rstar' x y.
 Proof
   fun (x y z:A) (t1:R x z) (t2:Rstar z y) (P:A -> A -> Prop)
     (h1:P x x) (h2:forall u:A, R x u -> Rstar u y -> P x y) =>
     h2 z t1 t2.

(** Equivalence of the two definitions: *)

Theorem Rstar'_Rstar : forall x y:A, Rstar' x y -> Rstar x y.
 Proof
   fun (x y:A) (h:Rstar' x y) =>
     h Rstar (Rstar_reflexive x) (fun u:A => Rstar_R x u y).

Theorem Rstar_Rstar' : forall x y:A, Rstar x y -> Rstar' x y.
 Proof
   fun (x y:A) (h:Rstar x y) =>
     h Rstar' (fun u:A => Rstar'_reflexive u)
       (fun (u v w:A) (h1:R u v) (h2:Rstar' v w) =>
          Rstar'_R u w v h1 (Rstar'_Rstar v w h2)).

(** Property of Commutativity of two relations *)

Definition commut (A:Set) (R1 R2:A -> A -> Prop) :=
  forall x y:A,
    R1 y x -> forall z:A, R2 z y ->  exists2 y' : A, R2 y' x & R1 z y'.

End Rstar.


From Coq Require Import omega.Omega.
From Coq Require Import Arith.Arith.
Require Import imp maps.

Open Scope imp_scope.
Fixpoint ceval_step1 (st : state) (c : com) : state :=
  match c with
    | SKIP =>
        st
    | l ::= a1 =>
        (l !-> aeval st a1 ; st)
    | c1 ;; c2 =>
        let st' := ceval_step1 st c1 in
        ceval_step1 st' c2
    | TEST b THEN c1 ELSE c2 FI =>
        if (beval st b)
          then ceval_step1 st c1
          else ceval_step1 st c2
    | WHILE b1 DO c1 END =>
        st
  end.
Close Scope imp_scope.

(*| WHILE b1 DO c1 END => if (beval st b1) then ceval_step1 st (c1;; WHILE b1 DO c1 END) else st*)
(*この構文は書けない。終了する保証がないので*)
(*対策：実行時間の指定を入れる*)
Open Scope imp_scope.
Fixpoint ceval_step2 (st : state) (c : com) (i : nat) : state :=
  match i with
  | O => empty_st
  | S i' =>
    match c with
      | SKIP =>
          st
      | l ::= a1 =>
          (l !-> aeval st a1 ; st)
      | c1 ;; c2 =>
          let st' := ceval_step2 st c1 i' in
          ceval_step2 st' c2 i'
      | TEST b THEN c1 ELSE c2 FI =>
          if (beval st b)
            then ceval_step2 st c1 i'
            else ceval_step2 st c2 i'
      | WHILE b1 DO c1 END =>
          if (beval st b1)
          then let st' := ceval_step2 st c1 i' in
               ceval_step2 st' c i'
          else st
    end
  end.
Close Scope imp_scope.

(*上の定義だと終了要因がわからない*)
Open Scope imp_scope.
Fixpoint ceval_step3 (st : state) (c : com) (i : nat)
                    : option state :=
  match i with
  | O => None
  | S i' =>
    match c with
      | SKIP =>
          Some st
      | l ::= a1 =>
          Some (l !-> aeval st a1 ; st)
      | c1 ;; c2 =>
          match (ceval_step3 st c1 i') with
          | Some st' => ceval_step3 st' c2 i'
          | None => None
          end
      | TEST b THEN c1 ELSE c2 FI =>
          if (beval st b)
            then ceval_step3 st c1 i'
            else ceval_step3 st c2 i'
      | WHILE b1 DO c1 END =>
          if (beval st b1)
          then match (ceval_step3 st c1 i') with
               | Some st' => ceval_step3 st' c i'
               | None => None
               end
          else Some st
    end
  end.
Close Scope imp_scope.

Notation "'LETOPT' x <== e1 'IN' e2"
   := (match e1 with
         | Some x => e2
         | None => None
       end)
   (right associativity, at level 60).

(*可読性を高めた*)
Open Scope imp_scope.
Fixpoint ceval_step (st : state) (c : com) (i : nat)
                    : option state :=
  match i with
  | O => None
  | S i' =>
    match c with
      | SKIP =>
          Some st
      | l ::= a1 =>
          Some (l !-> aeval st a1 ; st)
      | c1 ;; c2 =>
          LETOPT st' <== ceval_step st c1 i' IN
          ceval_step st' c2 i'
      | TEST b THEN c1 ELSE c2 FI =>
          if (beval st b)
            then ceval_step st c1 i'
            else ceval_step st c2 i'
      | WHILE b1 DO c1 END =>
          if (beval st b1)
          then LETOPT st' <== ceval_step st c1 i' IN
               ceval_step st' c i'
          else Some st
    end
  end.
Close Scope imp_scope.

Definition test_ceval (st:state) (c:com) :=
  match ceval_step st c 500 with
  | None => None
  | Some st => Some (st X, st Y, st Z)
  end.

Definition  pup_to_n : com :=
  Y ::= ANum 0;;
  WHILE BNot (BEq (AId X) (ANum 0)) DO
    Y ::= APlus (AId X) (AId Y) ;;
    X ::= AMinus (AId X) (ANum 1)
  END.

Example pup_to_n_1 :
  test_ceval (X !-> 5) pup_to_n
  = Some (0, 15, 0).
Proof. reflexivity. Qed.

Definition XisEven : com :=
  Z ::= AId X;;
  WHILE BLe (ANum 2) (AId Z) DO
    Z ::= AMinus (AId Z) (ANum 2)
  END.

Example TestXisEven :
  test_ceval (X !-> 5) XisEven
  = Some (5, 0, 1).
Proof. reflexivity. Qed.

Example TestXisEven2 :
  test_ceval (X !-> 4) XisEven
  = Some (4, 0, 0).
Proof. reflexivity. Qed.

Theorem ceval_step__ceval: forall c st st',
      (exists i, ceval_step st c i = Some st') ->
      st =[ c ]=> st'.
Proof.
  intros c st st' H.
  inversion H as [i E].
  clear H.
  generalize dependent st'.
  generalize dependent st.
  generalize dependent c.
  induction i as [| i' ].

  -
    intros c st st' H. discriminate H.

  -
    intros c st st' H.
    destruct c;
           simpl in H; inversion H; subst; clear H.
      + apply E_Skip.
      + apply E_Ass. reflexivity.

      +
        destruct (ceval_step st c1 i') eqn:Heqr1.
        *
          apply E_Seq with s.
            apply IHi'. rewrite Heqr1. reflexivity.
            apply IHi'. simpl in H1. assumption.
        *
          discriminate H1.

      +
        destruct (beval st b) eqn:Heqr.
        *
          apply E_IfTrue. rewrite Heqr. reflexivity.
          apply IHi'. assumption.
        *
          apply E_IfFalse. rewrite Heqr. reflexivity.
          apply IHi'. assumption.

      + destruct (beval st b) eqn :Heqr.
        *
         destruct (ceval_step st c i') eqn:Heqr1.
         {
           apply E_WhileTrue with s. rewrite Heqr.
           reflexivity.
           apply IHi'. rewrite Heqr1. reflexivity.
           apply IHi'. simpl in H1. assumption. }
         { discriminate H1. }
        *
          injection H1. intros H2. rewrite <- H2.
          apply E_WhileFalse. apply Heqr. Qed.

Theorem ceval_step_more: forall i1 i2 st st' c,
  i1 <= i2 ->
  ceval_step st c i1 = Some st' ->
  ceval_step st c i2 = Some st'.
Proof.
induction i1 as [|i1']; intros i2 st st' c Hle Hceval.
  -
    simpl in Hceval. discriminate Hceval.
  -
    destruct i2 as [|i2']. inversion Hle.
    assert (Hle': i1' <= i2') by omega.
    destruct c.
    +
      simpl in Hceval. inversion Hceval.
      reflexivity.
    +
      simpl in Hceval. inversion Hceval.
      reflexivity.
    +
      simpl in Hceval. simpl.
      destruct (ceval_step st c1 i1') eqn:Heqst1'o.
      *
        apply (IHi1' i2') in Heqst1'o; try assumption.
        rewrite Heqst1'o. simpl. simpl in Hceval.
        apply (IHi1' i2') in Hceval; try assumption.
      *
        discriminate Hceval.

    +
      simpl in Hceval. simpl.
      destruct (beval st b); apply (IHi1' i2') in Hceval;
        assumption.

    +
      simpl in Hceval. simpl.
      destruct (beval st b); try assumption.
      destruct (ceval_step st c i1') eqn: Heqst1'o.
      *
        apply (IHi1' i2') in Heqst1'o; try assumption.
        rewrite -> Heqst1'o. simpl. simpl in Hceval.
        apply (IHi1' i2') in Hceval; try assumption.
      *
        simpl in Hceval. discriminate Hceval. Qed.

Theorem ceval__ceval_step: forall c st st',
      st =[ c ]=> st' ->
      exists i, ceval_step st c i = Some st'.
Proof.
  intros c st st' Hce.
  induction Hce.
  - (*SKIP*)  intros. exists 1. reflexivity.
  - (*x ::= a1*) subst. exists 2. reflexivity.
  - (*c1 ;; c2*) inversion IHHce1. inversion IHHce2.
    simpl.
    induction x. inversion H.
    induction x0. inversion H0.  apply IHx0.
Abort.

Theorem ceval__ceval_step: forall c st st',
      st =[c]=> st' ->
      exists i, ceval_step st c i = Some st'.
Proof.
  intros c st st' Hce.
  induction Hce.
  exists 1. reflexivity.
  exists 1. simpl. rewrite H. reflexivity.
  -
  inversion IHHce1 as [x1 H1].
  inversion IHHce2 as [x2 H2].
  exists (x1 + x2).
  induction x1 as [|x1']. inversion H1.
  induction x2 as [|x2']. inversion H2.
  simpl.
  assert (HH: ceval_step st c1 (S x1' + x2') = Some st').
    apply ceval_step_more with (S x1'). omega. apply H1.
  destruct (ceval_step st c1 (x1' + S x2')) eqn:HE.
  rewrite <-plus_n_Sm in HE. rewrite <-plus_Sn_m in HE.
  rewrite HH in HE. inversion HE. subst.
  rewrite plus_comm.
  apply ceval_step_more with (S x2'). omega.
  assumption.
  rewrite <-plus_n_Sm in HE. rewrite <-plus_Sn_m in HE.
  rewrite HH in HE. inversion HE.

  - (*"E_IfTrue"*)
  inversion IHHce. exists (S x).
  simpl. rewrite H. assumption.

  - (*"E_IfFalse"*)
  inversion IHHce. exists (S x).
  simpl. rewrite H. assumption.

  - (*"E_WhileEnd"*)
  exists 1. simpl. rewrite H. reflexivity.

  - (*"E_WhileLoop".*)
  inversion IHHce1 as [x1 H1].
  inversion IHHce2 as [x2 H2].
  exists (x1 + x2).
  induction x1 as [|x1']. inversion H1.
  induction x2 as [|x2']. inversion H2.
  simpl.
  assert (HH: ceval_step st c (S x1' + x2') = Some st').
    apply ceval_step_more with (S x1'). omega. apply H1.
  destruct (ceval_step st c (x1' + S x2')) eqn:HE.
  rewrite <-plus_n_Sm in HE. rewrite <-plus_Sn_m in HE.
  rewrite HH in HE. inversion HE. subst.
  rewrite plus_comm.
  rewrite H.
  apply ceval_step_more with (S x2'). omega.
  assumption.
  rewrite H.
  rewrite <-plus_n_Sm in HE. rewrite <-plus_Sn_m in HE.
  rewrite HH in HE. inversion HE.
Qed.

Theorem ceval_and_ceval_step_coincide: forall c st st',
      st =[ c ]=> st'
  <-> exists i, ceval_step st c i = Some st'.
Proof.
  intros c st st'.
  split. apply ceval__ceval_step. apply ceval_step__ceval.
Qed.

Theorem ceval_deterministic' : forall c st st1 st2,
     st =[ c ]=> st1 ->
     st =[ c ]=> st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 He1 He2.
  apply ceval__ceval_step in He1.
  apply ceval__ceval_step in He2.
  inversion He1 as [i1 E1].
  inversion He2 as [i2 E2].
  apply ceval_step_more with (i2 := i1 + i2) in E1.
  apply ceval_step_more with (i2 := i1 + i2) in E2.
  rewrite E1 in E2. inversion E2. reflexivity.
  omega. omega. Qed.


Require Import List OrderedType OrderedTypeAlt OrderedTypeEx.
Import ListNotations.

From Verbatim Require Import ltac.

Module UOT_Facts (U : UsualOrderedType).

  Lemma lt_refl_contra :
    forall x,
      ~ U.lt x x.
  Proof.
    intros x hl; eapply U.lt_not_eq; eauto; red; auto.
  Qed.

  Lemma lt_compare_LT :
    forall x y,
      U.lt x y
      -> exists hl, U.compare x y = LT hl.
  Proof.
    intros x y hl.
    destruct (U.compare x y) as [hl' | he | hl']; eauto.
    - exfalso.
      red in he; subst.
      eapply lt_refl_contra; eauto.
    - exfalso.
      eapply U.lt_trans in hl'; eauto.
      eapply lt_refl_contra; eauto.
  Qed.

  Lemma eq_compare_EQ :
    forall x y,
      (exists heq, U.compare x y = EQ heq) <-> x = y.
  Proof.
    unfold U.eq; intros x y; split; [intros hex | intros heq]; subst.
    - destruct hex; auto.
    - destruct (U.compare y y).
      + exfalso; eapply lt_refl_contra; eauto.
      + red in e; subst; eauto.
      + exfalso; eapply lt_refl_contra; eauto.
  Qed.

  Lemma compare_refl :
    forall x,
      (exists heq,
          U.compare x x = EQ heq).
  Proof.
    intros x; apply eq_compare_EQ; auto.
  Qed.

End UOT_Facts.

Module Type UsualComparableType.

  Parameter t : Type.

  Parameter compare : t -> t -> comparison.

  Parameter compare_eq :
    forall x y : t,
      compare x y = Eq <-> x = y.

  Parameter compare_trans :
    forall (c : comparison) (x y z : t),
      compare    x y = c
      -> compare y z = c
      -> compare x z = c.

End UsualComparableType.

Module UOT_from_UCT (C : UsualComparableType) <: UsualOrderedType.

  Definition t := C.t.

  Definition eq       := @eq t.
  Definition eq_refl  := @eq_refl t.
  Definition eq_sym   := @eq_sym t.
  Definition eq_trans := @eq_trans t.

  Definition lt (x y : t) : Prop :=
    match C.compare x y with
    | Lt => True
    | _  => False
    end.

  Lemma lt_trans :
    forall x y z, lt x y -> lt y z -> lt x z.
  Proof.
    unfold lt; intros x y z hlt hlt'.
    destruct (C.compare x y) eqn:hc  ;
      destruct (C.compare y z) eqn:hc' ;
      destruct (C.compare x z) eqn:hc''; auto.
    - eapply C.compare_trans in hc'; eauto; tc.
    - eapply C.compare_trans in hc'; eauto; tc.
  Qed.

  Lemma lt_not_eq :
    forall x y, lt x y -> ~ x = y.
  Proof.
    unfold lt; intros x y hl heq.
    apply C.compare_eq in heq.
    rewrite heq in hl; inv hl.
  Qed.

  Lemma compare_refl :
    forall x, C.compare x x = Eq.
  Proof.
    intros x; apply C.compare_eq; auto.
  Qed.

  Lemma compare_sym :
    forall x y, C.compare x y = CompOpp (C.compare y x).
  Proof.
    intros x y; destruct (C.compare x y) eqn:hc.
    - apply C.compare_eq in hc; subst.
      rewrite compare_refl; auto.
    - destruct (C.compare y x) eqn:hc'; auto.
      + exfalso; apply C.compare_eq in hc'; subst.
        rewrite compare_refl in hc; tc.
      + exfalso; eapply C.compare_trans in hc'; eauto.
        rewrite compare_refl in hc'; tc.
    - destruct (C.compare y x) eqn:hc'; auto.
      + exfalso; apply C.compare_eq in hc'; subst.
        rewrite compare_refl in hc; tc.
      + exfalso; eapply C.compare_trans in hc'; eauto.
        rewrite compare_refl in hc'; tc.
  Qed.

  Definition compare :
    forall x y,
      Compare lt eq x y.
  Proof.
    intros x y; destruct (C.compare x y) eqn:hc.
    - apply EQ; apply C.compare_eq; auto.
    - apply LT; unfold lt; rewrite hc; auto.
    - apply GT; unfold lt; rewrite compare_sym in hc.
      destruct (C.compare y x) eqn:hc'; sis; tc; auto.
  Defined.

  Definition eq_dec :
    forall x y : t,
      {x = y} + {x <> y}.
  Proof.
    intros x y; destruct (C.compare x y) eqn:hc.
    - left; apply C.compare_eq; auto.
    - right; intros heq; apply C.compare_eq in heq; tc.
    - right; intros heq; apply C.compare_eq in heq; tc.
  Defined.

End UOT_from_UCT.

Module Option_as_UOT (E : UsualOrderedType) <: UsualOrderedType.

  Module F := UOT_Facts E.

  Definition t := option E.t.

  Definition eq       := @eq t.
  Definition eq_refl  := @eq_refl t.
  Definition eq_sym   := @eq_sym t.
  Definition eq_trans := @eq_trans t.

  Definition lt o o' :=
    match o, o' with
    | None, None     => False
    | None, Some _   => True
    | Some _, None   => False
    | Some x, Some y => E.lt x y
    end.

  Lemma lt_trans :
    forall x y z, lt x y -> lt y z -> lt x z.
  Proof.
    unfold lt; intros x y z hl hl';
      destruct x as [x |]; destruct y as [y |]; destruct z as [z |];
        try contradiction; auto.
    eapply E.lt_trans; eauto.
  Qed.

  Lemma lt_not_eq :
    forall x y,
      lt x y -> ~ x = y.
  Proof.
    intros x y hl heq; destruct x as [x |]; destruct y as [y |]; tc; auto.
    inv heq; eapply F.lt_refl_contra; eauto.
  Qed.

  Definition compare (x y : t) : Compare lt eq x y.
    refine (match x as x' return x = x' -> _ with
            | None =>
              fun heq =>
                match y as y' return y = y' -> _ with
                | None    => fun heq' => EQ _
                | Some e' => fun heq' => LT _
                end (eq_refl y)
            | Some e =>
              fun heq =>
                match y as y' return y = y' -> _ with
                | None    => fun heq' => GT _
                | Some e' => fun heq' =>
                               match E.compare e e' with
                               | LT hl => LT _
                               | GT hl => GT _
                               | EQ he => EQ _
                               end
                end (eq_refl y)
            end (eq_refl x));
      red; unfold E.eq in *; subst; auto.
  Defined.

  Definition eq_dec (x y : t) : {x = y} + {x <> y}.
    refine (match x as x' return x = x' -> _ with
            | None =>
              fun heq =>
                match y as y' return y = y' -> _ with
                | None    => fun heq' => left _
                | Some e' => fun heq' => right _
                end (eq_refl y)
            | Some e =>
              fun heq =>
                match y as y' return y = y' -> _ with
                | None    => fun heq' => right _
                | Some e' => fun heq' =>
                               match E.eq_dec e e' with
                               | left he => left _
                               | right hn => right _
                               end
                end (eq_refl y)
            end (eq_refl x));
      unfold not, E.eq in *; subst; tc.
  Defined.

End Option_as_UOT.

Module List_as_UOT (E : UsualOrderedType) <: UsualOrderedType.

  Module F := UOT_Facts E.

  Definition t := list E.t.

  Definition eq       := @eq t.
  Definition eq_refl  := @eq_refl t.
  Definition eq_sym   := @eq_sym t.
  Definition eq_trans := @eq_trans t.

  Fixpoint lt xs ys :=
    match xs, ys with
    | [], []             => False
    | [], _ :: _         => True
    | _ :: _, []         => False
    | x :: xs', y :: ys' =>
      match E.compare x y with
      | LT _ => True
      | EQ _ => lt xs' ys'
      | GT _ => False
      end
    end.

  Lemma lt_trans_heads_eq :
    forall x y xs ys zs,
      lt (x :: xs) (y :: ys)
      -> lt (y :: ys) (x :: zs)
      -> y = x.
  Proof.
    intros x y xs ys zs hl hl'; red in hl, hl'.
    destruct (E.compare x y) as [hel | hee | hel];
      destruct (E.compare y x) as [hel' | hee' | hel'];
      try contradiction; auto.
    eapply E.lt_trans in hel'; eauto.
    exfalso; eapply F.lt_refl_contra; eauto.
  Qed.

  Lemma lt_inv_cons :
    forall x xs ys,
      lt (x :: xs) (x :: ys)
      -> lt xs ys.
  Proof.
    intros x xs ys hl; red in hl.
    destruct (E.compare x x); try contradiction; auto.
    exfalso; eapply F.lt_refl_contra; eauto.
  Qed.

  Lemma lt_trans_heads_lt_or_eq :
    forall x y z xs ys zs,
      lt (x :: xs) (y :: ys)
      -> lt (y :: ys) (z :: zs)
      -> E.lt x z \/ z = x.
  Proof.
    intros x y z xs ys zs hl hl'; red in hl, hl'.
    destruct (E.compare x y) as [hel | hee | hel];
      destruct (E.compare y z) as [hel' | hee' | hel'];
      try contradiction; auto.
    - left; eapply E.lt_trans; eauto.
    - left; red in hee'; subst; auto.
    - left; red in hee ; subst; auto.
    - right; red in hee; red in hee'; subst; auto.
  Qed.

  Lemma lt_trans :
    forall xs ys zs,
      lt xs ys -> lt ys zs -> lt xs zs.
  Proof.
    intros xs; induction xs as [| x xs IH];
      intros ys zs hl hl'; destruct ys as [| y ys]; destruct zs as [| z zs]; try contradiction; auto.
    red; destruct (E.compare x z) as [hel | hee | hel]; auto.
    - fold lt; red in hee; subst.
      assert (heq : y = z) by (eapply lt_trans_heads_eq; eauto); subst.
      apply lt_inv_cons in hl; apply lt_inv_cons in hl'; eauto.
    - eapply lt_trans_heads_lt_or_eq in hl'; eauto.
      destruct hl' as [hl' | ?]; subst.
      + eapply E.lt_trans in hl'; eauto.
        eapply E.lt_not_eq; eauto; red; auto.
      + eapply E.lt_not_eq; eauto; red; auto.
  Qed.

  Lemma lt_not_eq :
    forall xs ys,
      lt xs ys -> ~ xs = ys.
  Proof.
    intros xs; induction xs as [| x xs IH];
      intros ys hl heq; destruct ys as [| y ys]; tc; inv heq; auto.
    red in hl; destruct (E.compare y y); tc.
    - eapply E.lt_not_eq; eauto; red; auto.
    - eapply IH; eauto.
  Qed.

  Fixpoint compare (xs ys : list E.t) : Compare lt eq xs ys.
    refine (match xs as xs' return xs = xs' -> _ with
            | [] =>
              fun heq =>
                match ys as ys' return ys = ys' -> _ with
                | []     => fun heq' => EQ _
                | _ :: _ => fun heq' => LT _
                end (eq_refl ys)
            | x :: xs' =>
              fun heq =>
                match ys as ys' return ys = ys' -> _ with
                | []       => fun heq' => GT _
                | y :: ys' => fun heq' =>
                                match E.compare x y with
                                | LT hl => LT _
                                | GT hl => GT _
                                | EQ he =>
                                  match compare xs' ys' with
                                  | LT hl  => LT _
                                  | GT hl  => GT _
                                  | EQ he' => EQ _
                                  end
                                end
                end (eq_refl ys)
            end (eq_refl xs));
      unfold eq, E.eq in *; try red; subst; auto.
    - apply F.lt_compare_LT in hl.
      destruct hl as [hl hc]; rewrite hc; auto.
    - pose proof (F.compare_refl y) as heq.
      destruct heq as [heq hc]; rewrite hc; auto.
    - pose proof (F.compare_refl y) as heq.
      destruct heq as [heq hc]; rewrite hc; auto.
    - apply F.lt_compare_LT in hl.
      destruct hl as [hl hc]; rewrite hc; auto.
  Defined.

  Fixpoint eq_dec (xs ys : t) : {xs = ys} + {xs <> ys}.
    refine (match xs as xs' return xs = xs' -> _ with
            | [] =>
              fun heq =>
                match ys as ys' return ys = ys' -> _ with
                | []     => fun heq' => left _
                | _ :: _ => fun heq' => right _
                end (eq_refl ys)
            | x :: xs' =>
              fun heq =>
                match ys as ys' return ys = ys' -> _ with
                | []       => fun heq' => right _
                | y :: ys' => fun heq' =>
                                match E.eq_dec x y with
                                | left _ =>
                                  match eq_dec xs' ys' with
                                  | left _  => left _
                                  | right _ => right _
                                  end
                                | right _ => right _
                                end
                end (eq_refl ys)
            end (eq_refl xs)); tc.
  Defined.

End List_as_UOT.

Module Pair_as_UOT (A : UsualOrderedType) (B : UsualOrderedType) <: UsualOrderedType.

  Module FA := UOT_Facts A.
  Module FB := UOT_Facts B.

  Definition t := (A.t * B.t)%type.

  Definition eq       := @eq t.
  Definition eq_refl  := @eq_refl t.
  Definition eq_sym   := @eq_sym t.
  Definition eq_trans := @eq_trans t.

  Definition lt x y :=
    match x, y with
    | (a, b), (a', b') =>
      match A.compare a a' with
      | LT _ => True
      | GT _ => False
      | EQ _ =>
        match B.compare b b' with
        | LT _ => True
        | _    => False
        end
      end
    end.

  Lemma lt_trans :
    forall x y z,
      lt x y -> lt y z -> lt x z.
  Proof.
    unfold lt; intros (a, b) (a', b') (a'', b'') hl hl'.
    destruct (A.compare a a') as [ha | ha | ha]; try contradiction.
    - destruct (A.compare a' a'') as [ha' | ha' | ha']; try contradiction.
      + eapply A.lt_trans in ha'; eauto.
        apply FA.lt_compare_LT in ha'.
        destruct ha' as (hl'' & heq); rewrite heq; auto.
      + red in ha'; subst.
        apply FA.lt_compare_LT in ha.
        destruct ha as (hl'' & heq); rewrite heq; auto.
    - red in ha; subst.
      destruct (A.compare a' a'') as [ha' | ha' | ha']; try contradiction; auto.
      destruct (B.compare b b') as [hb | hb | hb]; try contradiction.
      destruct (B.compare b' b'') as [hb' | hb' | hb']; try contradiction.
      eapply B.lt_trans in hb'; eauto.
      apply FB.lt_compare_LT in hb'.
      destruct hb' as (hl'' & heq); rewrite heq; auto.
  Qed.

  Lemma lt_not_eq :
    forall x y,
      lt x y -> ~ x = y.
  Proof.
    unfold lt; intros (a, b) (a', b') hl he; inv he.
    assert (heq  : a' = a') by auto.
    apply FA.eq_compare_EQ in heq.
    destruct heq as (heq & hc); rewrite hc in hl.
    assert (heq'  : b' = b') by auto.
    apply FB.eq_compare_EQ in heq'.
    destruct heq' as (heq' & hc'); rewrite hc' in hl.
    contradiction.
  Qed.

  Definition compare (x y : t) : Compare lt eq x y.
    refine (match x, y with
            | (a, b), (a', b') =>
              match A.compare a a' with
              | LT hl => LT _
              | GT hl => GT _
              | EQ he =>
                match B.compare b b' with
                | LT hl  => LT _
                | GT hl  => GT _
                | EQ he' => EQ _
                end
              end
            end);
      unfold A.eq, B.eq in *; try red; subst; auto.
    - apply FA.lt_compare_LT in hl.
      destruct hl as [hl heq]; rewrite heq; auto.
    - destruct (FA.compare_refl a') as [heq hc]; rewrite hc.
      apply FB.lt_compare_LT in hl.
      destruct hl as [hl hc']; rewrite hc'; auto.
    - destruct (FA.compare_refl a') as [heq hc]; rewrite hc.
      apply FB.lt_compare_LT in hl.
      destruct hl as [hl hc']; rewrite hc'; auto.
    - apply FA.lt_compare_LT in hl.
      destruct hl as [hl hc]; rewrite hc; auto.
  Defined.

  Definition eq_dec (x y : t) : {x = y} + {x <> y}.
    refine (match x, y with
            | (a, b), (a', b') =>
              match A.eq_dec a a' with
              | left _ =>
                match B.eq_dec b b' with
                | left _  => left _
                | right _ => right _
                end
              | right _ => right _
              end
            end);
      unfold A.eq, B.eq in *; tc.
  Defined.

End Pair_as_UOT.

Module Nat_as_OT_Alt <: OrderedTypeAlt := OrderedType_to_Alt Nat_as_OT.


Require Import Arith Lia List.

Ltac inv H := inversion H; subst; clear H.

Ltac invp R :=
  match goal with
  | [ H: R _ |- _] => inv H
  | [ H: R _ _ |- _] => inv H
  | [ H: R _ _ _ |- _] => inv H
  | [ H: R _ _ _ _ |- _] => inv H
  | [ H: R _ _ _ _ _ |- _] => inv H
  | [ H: R _ _ _ _ _ _ |- _] => inv H
  | [ H: R _ _ _ _ _ _ _ |- _] => inv H
  | [ H: R _ _ _ _ _ _ _ _ |- _] => inv H
  | [ H: R _ _ _ _ _ _ _ _ _ |- _] => inv H
  | [ H: R _ _ _ _ _ _ _ _ _  _|- _] => inv H
  end.

(* _Modus Ponens_ - applies to implications,
    will generate a subgoal for the premise of H and then specialize H with the result *)
Ltac mp H :=
let x := fresh "H" in
    match type of H with
    | ?Q -> ?P => assert P as x; [apply H | clear H; assert P as H by exact x; clear x]
    end.

Ltac mapinj :=
  match goal with
  | [H: In _ (map _ _) |-_] =>
    let H1 := fresh "H" in
    eapply in_map_iff in H as H1; destruct H1 as (? & ? & ?); subst
  end.

Ltac dostep := econstructor 2; [ eauto |].

Lemma add_sub' n m : n + m - n = m.
Proof.
  now rewrite Nat.add_comm, Nat.add_sub.
Qed.

#[export] Hint Rewrite
     Nat.sub_0_l Nat.sub_0_r Nat.sub_diag
     Nat.add_sub add_sub' Nat.sub_succ
     Nat.add_0_l Nat.add_0_r : simplify.

Ltac simplify := autorewrite with simplify listdb.
Tactic Notation "simplify" "in" hyp_list(H) := autorewrite with simplify listdb in H.
Tactic Notation "simplify" "in" "*" := autorewrite with simplify listdb in *.


Require Import Eqdep_dec.

From mathcomp Require Import all_ssreflect.
Require Import core_defs.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Require Import PArith.
Open Scope positive_scope.

Section Ind.

  Context (A : Type) (PA : A -> Prop) (P : list A -> Prop).
  Context (A_ind : forall a, PA a) (Hnil : P [::]) (Hcons : forall a l, PA a -> P l -> P (a::l)).

  Fixpoint list_Ind (l : list A) : P l :=
    match l with
    | [::] => Hnil
    | a :: l => Hcons (A_ind a) (list_Ind l)
    end.

End Ind.

Module AUX.

Section Section.
Context {A : Type}.

Definition tag (x : list A) :=
  match x with
  | [::]     => 1
  | _ :: _   => 2
  end.

Definition fields_t (t : positive) : Type :=
  match t with
  | 2 => (A * list A)%type
  | _ => unit
  end.

Definition fields (x : list A) : fields_t (tag x) :=
  match x return fields_t (tag x) with
  | [::] => tt
  | a::l => (a, l)
  end.

Definition construct (t:positive) : fields_t t -> option (list A) :=
  match t with
  | 1 => fun _ => Some [::]
  | 2 => fun p => Some (p.1 :: p.2)
  | _ => fun _ => None
  end.

Lemma constructP x : construct (fields x) = Some x.
Proof. by case: x. Qed.

End Section. End AUX.

Local Instance list_obj (A:Type) : @obj (list A) :=
  {| tag        := AUX.tag
   ; fields_t   := AUX.fields_t
   ; fields     := AUX.fields
   ; construct  := AUX.construct
   ; constructP := AUX.constructP |}.

Section Section.

Context (A:Type) (Aeqb : A -> A -> bool).

Section Fields.

Context (eqb : list A -> list A -> bool).

Definition eqb_fields (t:positive) : fields_t t -> fields_t t -> bool :=
  match t return fields_t t -> fields_t t -> bool with
  | 1 => eq_op
  | 2 => fun p1 p2 => Aeqb p1.1 p2.1 && eqb p1.2 p2.2
  | _ => eq_op
  end.

End Fields.

Fixpoint eqb (x1 x2 : list A) :=
  match x1 with
  | [::] => eqb_body (eqb_fields eqb) (t1:=1) tt x2
  | a::l => eqb_body (eqb_fields eqb) (t1:=2) (a,l) x2
  end.

Lemma eqb_correct_on_nil : eqb_correct_on eqb nil.
Proof.
  rewrite /eqb_correct_on /eqb.
  by apply (@eqb_body_correct _ (list_obj A) (eqb_fields eqb) [::]).
Qed.

Lemma eqb_correct_on_cons a l:
   eqb_correct_on Aeqb a ->
   eqb_correct_on eqb l ->
   eqb_correct_on eqb (a :: l).
Proof.
  rewrite /eqb_correct_on => ha hl.
  apply (@eqb_body_correct _ (list_obj A) (eqb_fields eqb) (a :: l)).
  by move=> a2 /andP[] /= /ha -> /hl ->.
Qed.

Lemma eqb_refl_on_nil : eqb_refl_on eqb [::].
Proof. done. Qed.

Lemma eqb_refl_on_cons a l:
  eqb_refl_on Aeqb a ->
  eqb_refl_on eqb l ->
  eqb_refl_on eqb (a :: l).
Proof.
  rewrite /eqb_refl_on=> ha hl.
  apply (@eqb_body_refl _ (list_obj A) (eqb_fields eqb) (a :: l)).
  by rewrite /eqb_fields_refl_on /= ha hl.
Qed.

End Section.

Section EqType.

Context (A:eqType).

Lemma eqb_correct (x:list A) : eqb_correct_on (eqb eq_op) x.
Proof.
  elim: x => [ | a l hrec].
  + by apply eqb_correct_on_nil.
  by apply eqb_correct_on_cons => // a'; apply /eqP.
Qed.

Lemma eqb_refl (x:list A) : eqb_refl_on (eqb eq_op) x.
Proof.
  elim x => [ | a l hrec].
  + by apply eqb_refl_on_nil.
  apply eqb_refl_on_cons => //; apply /eqxx.
Qed.

Lemma eqbP (x1 x2 : list A) : reflect (x1 = x2) (eqb eq_op x1 x2).
Proof. apply (iffP idP);[ apply eqb_correct | move=> ->; apply eqb_refl]. Qed.

End EqType.