Require Import Bool.
Require Import Arith.
Require Import Compare_dec.
Require Import Peano_dec.
Require Import General.
Require Import MyList.
Require Import MyRelations.

Require Export Main.

Section SortsOfECC.

  Inductive srt_ecc : Set :=
    | Sprop : srt_ecc
    | Stype : nat -> srt_ecc.

  Inductive axiom_ecc : srt_ecc -> srt_ecc -> Prop :=
    | ax_prop : forall (n : nat), axiom_ecc Sprop (Stype n)
    | ax_type : forall (n m : nat), n < m -> axiom_ecc (Stype n) (Stype m).

  Inductive rules_ecc : srt_ecc -> srt_ecc -> srt_ecc -> Prop :=
    | rule_prop_l : forall (s : srt_ecc), rules_ecc Sprop s s
    | rule_prop_r : forall (s : srt_ecc), rules_ecc s Sprop Sprop
    | rule_type :
        forall (n m p : nat),
        n <= p -> m <= p -> rules_ecc (Stype n) (Stype m) (Stype p).

  Inductive univ_ecc : srt_ecc -> srt_ecc -> Prop :=
      univ_type :
        forall (n m : nat),
        n <= m -> univ_ecc (Stype n) (Stype m).

  Definition univ : relation srt_ecc := clos_refl_trans _ univ_ecc.

  Hint Resolve ax_prop ax_type rule_prop_l rule_prop_r rule_type univ_type:
    pts.
  Hint Unfold univ: pts.

  (* Inversion et Decidabilite de l'inclusion entre sortes *)

  Let univ_trans : forall x y z : srt_ecc, univ x y -> univ y z -> univ x z.
Proof rt_trans srt_ecc univ_ecc.

  Inductive inv_univ : srt_ecc -> srt_ecc -> Prop :=
    | iu_prop : inv_univ Sprop Sprop
    | iu_type :
        forall (n m : nat),
        n <= m -> inv_univ (Stype n) (Stype m).

  Hint Resolve iu_prop iu_type: pts.

  Lemma inv_univ_trans :
   forall x y z : srt_ecc, inv_univ x y -> inv_univ y z -> inv_univ x z.
simple induction 1; intros; auto with arith pts.
inversion_clear H1.
apply iu_type.
apply le_trans with m; auto with arith pts.
Qed.

  Lemma univ_inv :
   forall s s' : srt_ecc,
   univ s s' -> forall P : Prop, (inv_univ s s' -> P) -> P.
simple induction 1.
simple induction 1; auto with arith pts.

simple destruct x; auto with arith pts.

intros.
apply H4.
apply inv_univ_trans with y.
apply H1; auto with arith pts.

apply H3; auto with arith pts.
Qed.

  Lemma ecc_sort_dec : forall s s' : srt_ecc, decide (s = s').
simple destruct s; simple destruct s'; intros; try (right; discriminate).
left; auto with arith pts.

elim eq_nat_dec with n n0; intros.
left; elim a; auto with arith pts.

right; red in |- *; intros H; apply b; injection H; auto with arith pts.
Qed.

  Lemma univ_ecc_dec : forall s s' : srt_ecc, decide (univ s s').
refine
 (fun s s' : srt_ecc =>
  match s, s' return (decide (univ s s')) with
  | Sprop, Sprop => _
  | Stype n, Stype n' => _
  | _, _ => right _ _
  end).
left; auto with arith pts.

red in |- *; intros.
apply univ_inv with Sprop (Stype n); intros; auto with arith pts.
inversion_clear H0.

red in |- *; intros.
apply univ_inv with (Stype n) Sprop; intros; auto with arith pts.
inversion_clear H0.

case (le_gt_dec n n'); [ left | right ].
auto with pts.

red in |- *; intros.
apply univ_inv with (Stype n) (Stype n'); intros; auto with arith pts.
inversion_clear H0.
absurd (n <= n'); auto with arith pts.
Qed.

  (* Inference des axiomes et regles *)

  Lemma ecc_inf_axiom :
   forall s : srt_ecc, {sp : srt_ecc | ppal (axiom_ecc s) univ sp}.
refine
 (fun s : srt_ecc =>
  match s return {sp : srt_ecc | ppal (axiom_ecc s) univ sp} with
  | Sprop => exist _ (Stype 0) _
  | Stype n => exist _ (Stype (S n)) _
  end).
split; intros; auto with arith pts.
inversion_clear H; auto with arith pts.

split; intros; auto with arith pts.
inversion_clear H; auto with arith pts.
Qed.

  Lemma ecc_inf_rule :
   forall x1 x2 : srt_ecc,
   {x3 : srt_ecc | rules_ecc x1 x2 x3 &
   forall s1 s2 s3 : srt_ecc,
   rules_ecc s1 s2 s3 -> univ x1 s1 -> univ x2 s2 -> univ x3 s3}.
refine
 (fun x1 x2 : srt_ecc =>
  match
    x1, x2
    return
      {x3 : srt_ecc | rules_ecc x1 x2 x3 &
      forall s1 s2 s3 : srt_ecc,
      rules_ecc s1 s2 s3 -> univ x1 s1 -> univ x2 s2 -> univ x3 s3}
  with
  | Sprop, _ => exist2 _ _ x2 _ _
  | Stype n, Sprop => exist2 _ _ Sprop _ _
  | Stype n, Stype n' => exist2 _ _ (Stype (max_nat n n')) _ _
  end).
auto with pts.

simple induction 1; intros; auto with arith pts.
apply univ_trans with (Stype m); auto with arith pts.

auto with pts.

intros.
apply univ_inv with Sprop s2; intros.
auto with arith pts.

generalize H.
inversion_clear H2; intros.
inversion_clear H2; auto with arith pts.

unfold max_nat in |- *.
elim (le_gt_dec n n'); auto with arith pts.

intros.
apply univ_inv with (Stype n) s1; intros; auto with arith pts.
apply univ_inv with (Stype n') s2; intros; auto with arith pts.
generalize H.
inversion_clear H2.
inversion_clear H3; intros.
inversion_clear H3.
cut (max_nat n n' <= p); auto with arith pts.
apply least_upper_bound_max_nat.
apply le_trans with m; auto with arith pts.

apply le_trans with m0; auto with arith pts.
Qed.

End SortsOfECC.

Definition term := term srt_ecc.
Definition env := env srt_ecc.

  (* Construction du CTS *)

Definition ecc : CTS_spec srt_ecc :=
  Build_CTS_spec _ axiom_ecc rules_ecc univ_ecc (beta_delta_rule _).

  (* Construction du PTS issu du CTS *)

Definition ecc_pts : PTS_sub_spec srt_ecc := cts_pts_functor _ ecc.
Definition le_type : red_rule srt_ecc :=
  Rule _ (Le_type _ (pts_le_type _ ecc_pts)).

Definition typ : env -> term -> term -> Prop := typ _ ecc_pts.
Definition typ_ppal : env -> term -> term -> Prop := typ_ppal _ ecc_pts.
Definition wft : env -> term -> Prop := wf_type _ ecc_pts.
Definition wf : env -> Prop := wf _ ecc_pts.
Definition sn := sn srt_ecc (ctxt _ (Rule _ (head_reduct _ ecc))).
Definition red := red _ (Rule _ (beta_delta_rule srt_ecc)).
Definition conv := conv _ (Rule _ (beta_delta_rule srt_ecc)).

  Hint Unfold le_type typ wft wf sn: pts.

  (* Algorithme de mise en forme normale de tete
     Decidabilite du sous-typage pour les types bien formes *)

  Lemma whnf :
   forall (e : env) (t : term),
   sn e t ->
   {u : term | red _ (beta_delta _) e t u &
   head_normal _ (beta_delta _) e u}.
Proof beta_delta_whnf srt_ecc.

  Lemma bd_conv_hnf :
   forall (e : env) (x y : term),
   sn e x ->
   sn e y -> decide (conv_hn_inv _ (beta_delta_rule _) e x y).
Proof
  CR_WHNF_convert_hn srt_ecc ecc_sort_dec (beta_delta_rule srt_ecc)
    (church_rosser_beta_delta srt_ecc) whnf.

  Theorem ecc_is_subtype_dec : subtype_dec_CTS _ ecc.
apply Build_subtype_dec_CTS.
exact (church_rosser_beta_delta srt_ecc).

exact (bd_hn_sort srt_ecc).

exact (bd_hn_prod srt_ecc).

exact whnf.

exact bd_conv_hnf.

exact univ_ecc_dec.
Qed.

  (* Subject-Reduction *)

  Lemma sound_ecc_bd : rule_sound _ ecc_pts (beta_delta _).
unfold beta_delta in |- *.
simpl in |- *.
unfold union in |- *.
apply union_sound.
apply beta_sound; auto with arith pts.
simpl in |- *.
apply cumul_inv_prod.
exact ecc_is_subtype_dec.

apply delta_sound.
Qed.

Definition least_nat (P:nat->Prop) (n:nat) : Prop :=
  P n /\ forall m, P m -> n <= m.

Definition greatest_nat (P:nat->Prop) (n:nat) : Prop :=
  P n /\ forall m, P m -> m <= n.

Definition sort_of_level n :=
  match n with
    0 => Sprop
  | S k => Stype k
  end.

Definition level_of_sort s :=
  match s with
    Sprop => 0
  | Stype k => S k
  end.

Definition level e t :=
  least_nat
    (fun n => exists2 u, conv e t u & typ e u (Srt _ (sort_of_level n))).

Section ECCn.

  Variable N : nat.

  Section Degree.

  Variable j : nat.

  (* quasi nf for all levels i > j *)
  Variable quasi_nf_up : env -> term -> Prop.

  (* degree of types of level i *)

  Fixpoint base_term (t:term) : Prop :=
    match t with
      Ref _ => True
    | App u v => base_term u
    | _ => False
    end.

  (* TODO: enforce reduct is a quasi-nf ? *)
  Inductive degree : env -> term -> nat -> Prop :=
    deg_other : forall e t j, ~ level e t j -> degree e t 0
  | deg_base : forall e t u, red e t u -> base_term u -> degree e t 1
  | deg_sort : forall e t, red e t (Srt _ (sort_of_level j)) -> degree e t 1
  | deg_prod : forall e t A B n m,
      red e t (Prod _ A B) ->
      degree e A n ->
      degree (Ax _ A::e) B m ->
      degree e t (S (max_nat n m)).

  Definition major_term (t:term) :=
    match t with
      App M N => M
    | _ => t
    end.

  Definition measure_delta e t n :=
    exists2 t', beta _ e t t' &
    exists2 u, typ_ppal e (major_term t) u & degree e u n.

  Definition measure_gamma e t :=
    greatest_nat (fun n => exists2 v, clos_refl_trans _ (subterm _) v (e,t) &
                           measure_delta (fst v) (snd v) n).

  Definition quasi_normal e t := measure_gamma e t 0.

  End Degree.

End ECCn..

  (* L'axiome:  ECC est fortement normalisant *)

  Axiom
    ecc_normalise :
      forall (e : env) (t T : term), typ_ecc e t T -> ecc_sn e t.


Module Type Memory.

Parameter adr : Set.

Parameter first : adr.
Parameter next : adr -> adr.

Parameter Mem : Type.

Parameter empty : Mem.
Parameter get : adr -> Mem -> nat.
Parameter set : adr -> nat -> Mem -> Mem.
Parameter free : adr -> Mem -> Mem.
Parameter isFreeFrom : adr -> Mem -> Prop.

Axiom isFreeFrom_free : forall (r : adr) (m : Mem) (n : nat), isFreeFrom r m -> free r (set r n m) = m.

Axiom isFreeFrom_set : forall (r : adr) (m : Mem) (n : nat), isFreeFrom r m  ->  isFreeFrom (next r) (set r n m).

Axiom get_set : forall (r : adr) (m : Mem) (n : nat), get r (set r n m) = n.

Axiom isFreeFrom_first : isFreeFrom first empty.

End Memory.

Inductive lta T n (r : T) : T -> Prop :=
| lea_self : lta T n r (n r)
| lea_next r' : lta T n r r' -> lta T n r (n r').

(* Extended memory model with additional axioms that are only used for
compiling variables. *)

Module Type MemoryExt.
Include Memory.

Axiom get_set' : forall (r : adr) (r' : adr) (m : Mem) (n : nat),
    r <> r' -> get r (set r' n m) = get r m.

Infix "<" := (lta adr next).
Hint Constructors lta.

Axiom next_fresh : forall (r r' : adr), r < r' -> r <> r'.

End MemoryExt.


Load LFindLoad.
From lfind Require Import LFind.

                    From adtind Require Import goal28.

 Require Import Extraction.
 Extract Inductive nat => nat [ "(O)" "S" ].
 Extract Inductive list => list [ "Nil" "Cons" ].
Definition lfind_example_1  := ( Cons (Succ Zero) (Cons Zero Nil)).
Definition lfind_example_2  := ( Cons Zero (Cons (Succ (Succ Zero)) (Cons Zero Nil))).
Definition lfind_example_3  := ( Cons Zero (Cons (Succ (Succ Zero)) Nil)).
Definition lfind_example_4  := ( Cons Zero (Cons (Succ (Succ Zero)) (Cons Zero Nil))).
Definition lfind_example_5  := ( Cons (Succ (Succ (Succ Zero)))         (Cons (Succ (Succ Zero))            (Cons (Succ (Succ Zero))               (Cons Zero                  (Cons (Succ (Succ Zero))                     (Cons Zero                        (Cons Zero                           (Cons (Succ (Succ (Succ Zero)))                              (Cons Zero                                 (Cons Zero                                    (Cons Zero                                       (Cons (Succ (Succ (Succ (Succ Zero))))                                          Nil)))))))))))).
Definition lfind_example_6  := ( Cons (Succ (Succ (Succ (Succ (Succ Zero)))))         (Cons Zero            (Cons (Succ (Succ (Succ Zero)))               (Cons (Succ (Succ (Succ (Succ Zero)))) (Cons (Succ Zero) Nil))))).
Definition lfind_example_7  := ( Cons Zero (Cons Zero Nil)).
Definition lfind_example_8  := ( Cons Zero Nil).
Definition lfind_example_9  := ( Cons Zero Nil).
Definition lfind_example_10  := ( Cons Zero (Cons (Succ (Succ Zero)) Nil)).
Definition lfind_example_11  := ( Cons Zero (Cons (Succ (Succ Zero)) Nil)).
Definition lfind_example_12  := ( Cons (Succ (Succ (Succ Zero))) Nil).
Definition lfind_example_13  := ( Cons (Succ Zero) (Cons Zero Nil)).
Definition lfind_example_14  := ( Cons Zero         (Cons Zero (Cons Zero (Cons (Succ (Succ Zero)) (Cons Zero Nil))))).
Definition lfind_example_15  := ( Cons (Succ Zero) Nil).
Definition lfind_example_16  := ( Cons (Succ (Succ (Succ Zero)))         (Cons Zero            (Cons Zero               (Cons Zero                  (Cons Zero                     (Cons Zero                        (Cons (Succ Zero)                           (Cons Zero (Cons (Succ (Succ Zero)) Nil))))))))).
Definition lfind_example_17  := ( Cons Zero (Cons (Succ (Succ Zero)) (Cons Zero (Cons (Succ Zero) Nil)))).
Definition lfind_example_18  := ( Cons Zero         (Cons (Succ (Succ Zero))            (Cons Zero (Cons Zero (Cons (Succ (Succ (Succ Zero))) Nil))))).
Definition lfind_example_19  := ( Cons Zero (Cons (Succ Zero) Nil)).
Definition lfind_example_20  := ( Cons (Succ (Succ Zero)) Nil).
Definition lfind_example_21  := ( Cons Zero         (Cons Zero            (Cons Zero               (Cons (Succ (Succ (Succ Zero)))                  (Cons Zero (Cons (Succ (Succ Zero)) (Cons Zero Nil))))))).
Definition lfind_example_22  := ( Cons (Succ Zero)         (Cons Zero            (Cons (Succ Zero)               (Cons (Succ (Succ Zero)) (Cons (Succ Zero) Nil))))).
Definition lfind_example_23  := ( Cons Zero (Cons Zero (Cons (Succ Zero) Nil))).
Definition lfind_example_24  := ( Cons (Succ (Succ Zero)) Nil).
Definition lfind_example_25  := ( Cons (Succ Zero) (Cons (Succ Zero) Nil)).
Definition lfind_example_26  := ( Cons (Succ Zero) Nil).
Definition lfind_example_27  := ( Cons (Succ Zero) (Cons Zero (Cons Zero Nil))).
Definition lfind_example_28  := ( Cons Zero         (Cons Zero (Cons Zero (Cons (Succ (Succ (Succ (Succ Zero)))) Nil)))).
Definition lfind_example_29  := ( Cons (Succ (Succ Zero)) (Cons Zero Nil)).
Definition lfind_example_30  := ( Cons (Succ (Succ Zero)) Nil).
Definition lfind_example_31  := ( Cons (Succ Zero) Nil).
Definition lfind_example_32  := ( Cons (Succ (Succ Zero))         (Cons Zero (Cons (Succ Zero) (Cons (Succ Zero) Nil)))).
Definition lfind_example_33  := ( Cons (Succ (Succ (Succ Zero)))         (Cons (Succ (Succ Zero)) (Cons (Succ Zero) (Cons (Succ Zero) Nil)))).
Definition lfind_example_34  := ( Cons Zero (Cons (Succ (Succ Zero)) Nil)).
Definition lfind_example_35  := ( Cons (Succ (Succ (Succ Zero)))         (Cons (Succ (Succ Zero)) (Cons Zero Nil))).
Definition lfind_example_36  := ( Cons (Succ Zero) (Cons Zero (Cons (Succ Zero) (Cons (Succ Zero) Nil)))).
Definition lfind_example_37  := ( Cons Zero (Cons (Succ Zero) Nil)).
Definition lfind_example_38  := ( Cons Zero         (Cons (Succ (Succ Zero))            (Cons (Succ (Succ Zero)) (Cons Zero (Cons Zero Nil))))).
Definition lfind_example_39  := ( Cons Zero (Cons (Succ Zero) (Cons Zero Nil))).
Definition lfind_example_40  := ( Cons (Succ (Succ Zero)) (Cons (Succ Zero) Nil)).
Definition lfind_example_41  := ( Cons (Succ Zero) Nil).
Definition lfind_example_42  := ( Cons (Succ (Succ (Succ (Succ (Succ (Succ Zero))))))         (Cons (Succ Zero) (Cons (Succ Zero) Nil))).
Definition lfind_example_43  := ( Cons Zero Nil).

                    Extraction "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal28_qrevflat_append_62_append_assoc/lfind_extraction.ml" lfind_example_1 lfind_example_2 lfind_example_3 lfind_example_4 lfind_example_5 lfind_example_6 lfind_example_7 lfind_example_8 lfind_example_9 lfind_example_10 lfind_example_11 lfind_example_12 lfind_example_13 lfind_example_14 lfind_example_15 lfind_example_16 lfind_example_17 lfind_example_18 lfind_example_19 lfind_example_20 lfind_example_21 lfind_example_22 lfind_example_23 lfind_example_24 lfind_example_25 lfind_example_26 lfind_example_27 lfind_example_28 lfind_example_29 lfind_example_30 lfind_example_31 lfind_example_32 lfind_example_33 lfind_example_34 lfind_example_35 lfind_example_36 lfind_example_37 lfind_example_38 lfind_example_39 lfind_example_40 lfind_example_41 lfind_example_42 lfind_example_43 .


(* A check that sort-polymorphic product is not set too low *)

Inductive prod (A B:Type) : Type := pair : A -> B -> prod A B.
Fail Check (fun (A:Type) (B:Prop) => (prod A B : Prop)).
Fail Check (fun (A:Prop) (B:Type) => (prod A B : Prop)).

(* Check that the nested inductive types positivity check avoids recursively
   non uniform parameters (at least if these parameters break positivity) *)

Inductive t (A:Type) : Type := c : t (A -> A) -> t A.
Fail Inductive u : Type := d : u | e : t u -> u.

(* This used to succeed in versions 8.1 to 8.3 *)

Require Import Logic.
Require Hurkens.
Definition Ti := Type.
Inductive prod2 (X Y:Ti) := pair2 : X -> Y -> prod2 X Y.
Fail Definition B : Prop := let F := prod2 True in F Prop. (* Aie! *)
(*Definition p2b (P:Prop) : B := pair2 True Prop I P.
Definition b2p (b:B) : Prop := match b with pair2 _ P => P end.
Lemma L1 : forall A : Prop, b2p (p2b A) -> A.
Proof (fun A x => x).
Lemma L2 : forall A : Prop, A -> b2p (p2b A).
Proof (fun A x => x).
Check Hurkens.paradox B p2b b2p L1 L2.*)


Require Import Arith Coq.Lists.List Setoid Coq.Lists.SetoidList Omega.
Require Import Infra.Option EqDec AutoIndTac Util LengthEq.

Set Implicit Arguments.

(** * Positional membership in a list *)

Inductive getT (X:Type) : list X -> nat -> X -> Type :=
| getTLB xl x : getT (x::xl) 0 x
| getTLS n xl x x' : getT xl n x -> getT (x'::xl) (S n) x.

Inductive get (X:Type) : list X -> nat -> X -> Prop :=
| getLB xl x : get (x::xl) 0 x
| getLS n xl x x' : get xl n x -> get (x'::xl) (S n) x.

Ltac isabsurd :=
  try match goal with
  | [ H : ?x = None, H' : ?x = Some _ |- _ ] => exfalso; rewrite H in H'; inv H'
  | [ H : get ?L ?n _, H' : (forall _, get ?L ?n _ -> False) |- _ ] => exfalso; eapply H'; eapply H
  | [ H : get nil _ _ |- _ ] => exfalso; inv H
(*  | [ H : _ < _ |- _ ] => try now exfalso; inv H *)
  | _ =>
    try now (hnf; intros;
              match goal with
                [ H : _ |- _ ] => exfalso; inversion H; try subst; simpl in *; try congruence
              end)
  end.

Smpl Add 100
     match goal with
     | [ H : get ?L ?n _, H' : (forall _, get ?L ?n _ -> False) |- _ ] =>
       exfalso; eapply H'; eapply H
     | [ H : get nil _ _ |- _ ] => exfalso; inv H
     | [ H : get _ 0 _ |- _ ] => invc H
     | [ H : get (_ :: _) (S _) _ |- _ ] => invc H
     end : inv_trivial.

(** Get is informative anyway. *)

Lemma get_getT X (x:X) n L
  : get L n x -> getT L n x.
Proof.
  revert n x L. fix 1; intros.
  destruct n, L. exfalso. inv H.
  assert (x0 = x). inv H; eauto. subst. econstructor.
  exfalso. inv H.
  econstructor. eapply get_getT. inv H. eauto.
Qed.

Lemma getT_get X (x:X) n L
  : getT L n x -> get L n x.
Proof.
  intros. general induction X0; eauto using get.
Qed.

Lemma get_S_inv X L n (x y:X)
  : get (y :: L) (S n) x
    -> get L n x.
Proof.
  intros; clear_trivial_eqs; eauto.
Qed.

Hint Immediate get_S_inv.

(** * Properties of get *)

Lemma get_functional X (xl:list X) n (x x':X) :
  get xl n x -> get xl n x' -> x = x'.
Proof.
  induction 1; inversion 1; subst; eauto.
Qed.

Lemma get_shift X (L:list X) k L1 blk :
  get L k blk -> get (L1 ++ L) (length L1+k) blk.
Proof.
  intros. induction L1; simpl; eauto using get.
Qed.

Lemma shift_get X (L:list X) k L1 blk :
  get (L1 ++ L) (length L1+k) blk -> get L k blk.
Proof.
  intros. induction L1; simpl; eauto using get.
Qed.

Lemma get_app X (L L':list X) k x
  : get L k x -> get (L ++ L') k x.
Proof.
  revert k.
  general induction L.
  intros; simpl; inv H; eauto using get.
Qed.

Lemma get_nth_default {X:Type} L n m (default:X):
get L n m -> nth n L default = m.
induction 1; auto. Qed.

Lemma get_length {X:Type} L n (s:X)
(getl : get L n s) :
n < length L.
induction getl; simpl; omega.
Qed.

Lemma get_nth X L n m (d:X) :
get L n m -> nth n L d = m.
induction 1; auto. Qed.

Lemma nth_default_nil X (v : X) x : nth_default v nil x = v.
Proof.
  destruct x; reflexivity.
Qed.

Lemma get_nth_error X (L : list X) k x :
  get L k x -> nth_error L k = Some x.
Proof.
  induction 1; auto.
Qed.

Lemma nth_error_nth X (L:list X) d x n
  : nth_error L n = Some x -> nth n L d = x.
Proof.
  revert x n. induction L; intros. destruct n; inv H.
  destruct n; simpl in *. inv H; eauto.
  eauto.
Qed.

Lemma nth_get {X:Type} L n s {default:X}
(lt : n < length L)
(nthL : nth n L default = s):
get L n s.
Proof.
revert n s default lt nthL. induction L; intros.
 exfalso; inv lt.
 destruct n.
  subst. simpl. constructor.
 constructor. eapply IHL; auto.
  simpl in lt. omega.
  simpl in nthL. eauto.
Qed.

Lemma nth_get_neq {X:Type} L n s {default:X}
(neq:s <> default)
(nthL : nth n L default = s):
get L n s.
Proof.
revert n s default neq nthL. induction L; intros.
 simpl in nthL; destruct n; congruence.
 destruct n.
  subst. simpl. constructor.
 constructor. eapply IHL; auto.
  eassumption.
  simpl in nthL. eauto.
Qed.

Lemma nth_error_get X (L : list X) k x :
  nth_error L k = Some x -> get L k x.
Proof.
  revert k; induction L; destruct k; simpl; intros; try discriminate.
    injection H. intros. subst. econstructor.
    constructor. apply IHL; auto.
Qed.

Lemma nth_error_app X (L L':list X) k x
 : nth_error L k = Some x -> nth_error (L++L') k = Some x.
Proof.
  revert k; induction L; simpl; intros k A. destruct k; inversion A.
  destruct k; simpl; eauto.
Qed.

Lemma nth_error_shift X (L L':list X) x
  : nth_error (L++(x::L')) (length L) = Some x.
Proof.
  induction L; simpl; eauto.
Qed.

Lemma nth_app_shift X (L L':list X) x d
  : x < length L -> nth x (L++L') d = nth x L d.
Proof.
  revert x. induction L; intros. inv H.
  destruct x. reflexivity.
  simpl in *. eapply IHL; eauto; omega.
Qed.

Ltac get_functional :=
  match goal with
  | [ H : get ?XL ?n ?x, H' : get ?XL ?n ?y |- _ ] =>
    let EQ := fresh "EQ" in
    pose proof (get_functional H H') as EQ;
    first [ is_var y; subst y; clear H'
          | is_var x; subst x; clear H'
          | simplify_eq EQ; intros; clear H'; clear_trivial_eqs ]
  | _ => fail "no matching get assumptions"
  end.

Ltac eval_nth_get :=
  match goal with
    | [ H : get ?XL ?n _ |- (bind (nth_error ?XL ?n) _) = _ ] =>
        rewrite (get_nth_error H); simpl
    | _ => fail "no matching get assumptions"
  end.

Lemma get_dec {X} (L:list X) n
      : { x | get L n x } + { forall x, get L n x -> False }.
Proof.
  case_eq (nth_error L n); intros. eapply nth_error_get in H.
  left; eauto.
  right; intros. eapply get_nth_error in H0. congruence.
Defined.

Create HintDb get.
Hint Constructors get       : get.
Hint Resolve get_functional : get.
Hint Resolve get_shift      : get.
Hint Resolve nth_error_get  : get.

Ltac simplify_get := try repeat get_functional; repeat eval_nth_get; eauto with get.

Lemma nth_shift X x (L L':list X) d
  : nth (length L+x) (L++L') d = nth x L' d.
Proof.
  induction L; intros; simpl; eauto.
Qed.

Lemma get_range X (L:list X) n v
  : get L n v -> n < length L.
Proof.
  revert n. induction L; intros. inv H.
  simpl. destruct n. omega.
  inv H.
  pose proof (IHL n H4). omega.
Qed.

Hint Resolve get_range : len.
Hint Immediate get_range.

Lemma get_range_le (X : Type) (L : 〔X〕) (n : nat) (v : X)
  : get L n v -> n <= ❬L❭.
Proof.
  intros. eapply get_range in H. omega.
Qed.

Hint Resolve get_range_le : len.
Hint Immediate get_range_le.

Lemma get_in_range X (L:list X) n
  : n < length L -> { x:X & get L n x }.
Proof.
  general induction n; destruct L; try now(simpl in *; exfalso; omega).
  eauto using get.
  edestruct IHn. instantiate (1:=L). simpl in *; omega.
  eauto using get.
Qed.

Lemma nth_in X L x (d:X)
  : x < length L -> In (nth x L d) L.
Proof.
  revert x. induction L; intros. inv H.
  destruct x; simpl. eauto.
  right. apply IHL. simpl in *. omega.
Qed.

(** In and get *)

Lemma in_get X `{EqDec X eq} (xl : list X) (x : X) :
  In x xl -> { n : nat & get xl n x }.
Proof.
  induction xl; simpl; intros. inv H0.
  decide (x=a); subst.
  exists 0. constructor.
  edestruct (IHxl). destruct H0; eauto; congruence.
  exists (S x0). constructor. assumption.
Qed.

Lemma get_in X `{EqDec X eq} (xl : list X) (x : X) n :
  get xl n x -> In x xl.
Proof.
  revert n. induction xl; simpl; intros; inv H0; firstorder.
Qed.

(** Some helpful tactics *)

Lemma list_map_eq X Y Z (f:X->Z) g (L:list X) (L':list Y) n x
  : List.map f L = List.map g L'
    -> get L n x -> exists y, get L' n y /\ f x = g y.
Proof.
  intros. general induction H0; simpl in *.
  destruct L'; inv H. eexists y; eauto using get.
  destruct L'; inv H.
  edestruct IHget; eauto; dcr.
  eexists x0; split; eauto using get.
Qed.

Lemma map_get_1 X Y (L:list X) (f:X -> Y) n x
  : get L n x -> get (List.map f L) n (f x).
Proof.
  intros. general induction H; simpl in *; eauto using get.
Qed.

Hint Resolve map_get_1.

Lemma map_get_eq X Y (L:list X) (f:X -> Y) n x y
  : get L n x -> f x = y -> get (List.map f L) n y.
Proof.
  intros. general induction H; simpl in *; eauto using get.
Qed.

Lemma map_get_2 X Y (L:list X) (f:X -> Y) n x
  : get (List.map f L) n x -> exists x' : X, get L n x'.
Proof.
  intros. general induction H; simpl in *;
  destruct L; simpl in *; inv Heql; try now (econstructor; eauto using get).
  edestruct IHget; eauto using get.
Qed.

Lemma map_get_3 X Y (L:list X) (f:X -> Y) n x
  : getT (List.map f L) n x -> { x' : X & (getT L n x' * (f x' = x))%type }.
Proof.
  intros. general induction X0; simpl in *;
          destruct L; simpl in *; inv Heql;
          try now (econstructor; eauto using getT).
  edestruct IHX0; dcr; eauto using getT.
Qed.

Lemma map_get_4 X Y (L:list X) (f:X -> Y) n x
  : get (List.map f L) n x -> { x' : X | get L n x' /\ f x' = x }.
Proof.
  intros. eapply get_getT in H. eapply map_get_3 in H; dcr.
  eexists; eauto using getT_get.
Qed.

Lemma map_get X Y (L:list X) (f:X -> Y) n blk Z
  : get L n blk
  -> get (List.map f L) n Z
  -> Z = f blk.
Proof.
  intros. general induction H; simpl in *; eauto.
Qed.

Lemma get_length_eq X Y (L:list X) (L':list Y) n x
  : get L n x -> length L = length L' -> exists y, get L' n y.
Proof.
  intros. eapply length_length_eq in H0.
  general induction H0; inv H; eauto using get.
  edestruct IHlength_eq; eauto using get.
Qed.

Require Compare_dec.

Lemma get_in_range_app X L L' n (x:X)
  : n < length L -> get (L ++ L') n x -> get L n x.
Proof.
  intros. general induction L; simpl in *; eauto; try omega.
  inv H0; eauto using get. econstructor. eapply IHL; eauto. omega.
Qed.

Lemma get_subst X (L L':list X) x x' n
  : get (L ++ x :: L') n x'
    -> get L n x'
       \/ (x = x' /\ n = length L)
       \/ (get L' (n - S (length L)) x' /\ n > length L).
Proof.
  destruct (Compare_dec.lt_eq_lt_dec n (length L)) as [ [A|A] | A]; intros.
  left. eapply get_in_range_app; eauto.
  right. left. orewrite (n = length L + 0) in H.
  eapply shift_get in H. inv H; eauto.
  right. right. split; try omega.
  orewrite (n = (length L + S (n - S (length L)))) in H.
  eapply shift_get in H. inv H. eauto.
Qed.

Lemma get_app_cases X (L L':list X) x' n
  : get (L ++ L') n x'
    -> get L n x'
       \/ (get L' (n - length L) x' /\ n >= length L).
Proof.
  destruct (Compare_dec.le_lt_dec (S n) (length L)) as [ A | A]; intros.
  left. eapply get_in_range_app; eauto.
  right. split; try omega.
  orewrite (n = (length L + (n - length L))) in H.
  eapply shift_get in H. eauto.
Qed.

Lemma get_app_right X  (L L':list X) n n' x
  : n' = (length L' + n) -> get L n x -> get (L' ++ L) n' x.
Proof.
  intros; subst. eapply get_shift; eauto.
Qed.

Lemma get_length_app X (L L':list X) x
  : get (L ++ x :: L') (length L) x.
Proof.
  orewrite (length L = length L + 0). eapply get_shift. constructor.
Qed.

Lemma get_length_app_eq X (L L':list X) x y l
  : l = length L -> get (L ++ x :: L') l y -> x = y.
Proof.
  orewrite (length L = length L + 0). intros; subst.
  eapply shift_get in H0. inv H0. eauto.
Qed.

Lemma get_app_lt X (L L':list X) n x (LE:n < length L)
  : get (L ++ L') n x <-> get L n x.
Proof.
  revert L L' x LE.
  induction n; intros.
  - split; intros H; inv H.
    + destruct L; isabsurd.
      injection H1; intros; subst. eauto using get.
    + econstructor.
  - split; intros H; inv H.
    + destruct L; isabsurd. injection H0; intros; subst.
      econstructor. eapply IHn; eauto. simpl in *. omega.
    + simpl. econstructor. eapply IHn; eauto.
Qed.

Lemma get_app_lt_1 X (L L':list X) n x (LE:n < length L)
  : get (L ++ L') n x -> get L n x.
Proof.
  eapply get_app_lt; eauto.
Qed.

Lemma get_app_ge X (L L':list X) n x (LE:length L <= n)
  : get (L ++ L') n x <-> get L' (n - length L) x.
Proof.
  revert n L' x LE.
  induction L; intros; simpl in *.
  - orewrite (n - 0 = n). reflexivity.
  - destruct n; [ exfalso; omega|]; simpl.
    rewrite <- (IHL n L' x); try omega.
    split; intros; [ inv H|]; eauto using get.
Qed.

Lemma tl_map X Y L (f:X -> Y)
  : List.map f (tl L) = tl (List.map f L).
Proof.
  general induction L; simpl; eauto.
Qed.

(** Some further helpful lemmata *)
Lemma nth_error_default {X:Type} v E a (x : X) : Some v = nth_error E a -> v = nth_default x E a.
Proof.
intros. revert a H. induction E; intros a' H. destruct a'; inv H.
destruct a'. simpl in H. invc H. reflexivity.
simpl in H. specialize (IHE _ H). subst. reflexivity.
Qed.

Lemma get_rev X (L:list X) n x
: get (rev L) n x ->
  get L (length L - S n) x.
Proof.
  intros.
  general induction L; simpl in *; isabsurd.
  edestruct get_app_cases; eauto; dcr.
  - exploit @get_length; eauto.
    rewrite rev_length in H1; simpl in *.
    orewrite (length L - n = S (length L - S n)).
    eauto using get.
  - rewrite rev_length in H2. orewrite (length L - n = 0).
    inv H1; isabsurd; eauto using get.
Qed.

Lemma get_app_right_ge X L L' n (x:X)
  : n >= length L -> get (L ++ L') n x -> get L' (n - length L) x.
Proof.
  intros. general induction L; simpl in *; eauto; try omega.
  - orewrite (n - 0 = n); eauto.
  - inv H0; simpl.
    + exfalso; omega.
    + eapply IHL; eauto. omega.
Qed.

Lemma get_length_right A (L1 L2:list A) n (x y:A)
  : n > length L1
    -> get (L1 ++ x :: L2) n y
    -> get L2 (n - S (length L1)) y.
Proof.
  intros. general induction L1.
  - simpl in *. inv H0; try omega; simpl.
    orewrite (n0 - 0 = n0); eauto.
  - simpl in *. inv H0. omega. simpl in *.
    eapply IHL1; eauto. omega.
Qed.

Hint Extern 5 =>
match goal with
| [ H : ❬?A❭ = ❬?B❭, H' : ❬?C❭ = ❬?B❭, H'' : get ?A ?n _  |- ?n < ❬?C❭]
  => rewrite H'; rewrite <- H; eapply (get_range H'')
end : len.

Lemma not_get_nth_default A (L:list A) n d
  : (forall x, get L n x -> False)
    -> nth n L d = d.
Proof.
  intros. general induction n; destruct L; simpl; eauto using get.
  exfalso; eauto using get.
Qed.

Lemma get_singleton X (x y:X) n
  : get (x::nil) n y -> x = y.
Proof.
  intros. inv H; isabsurd; eauto.
Qed.

Lemma map_eq_ext_get X (L L':list X) (Len:❬L❭=❬L'❭)
      (EQ:forall n x x', get L n x -> get L' n x' -> x = x')
  : L = L'.
Proof.
  general induction Len; f_equal; eauto using get.
Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(*                      Evgeny Makarov, INRIA, 2007                     *)
(************************************************************************)

Require Import ZAxioms ZProperties BinInt Zcompare Zorder ZArith_dec
 Zbool Zeven Zsqrt_def Zpow_def Zlog_def Zgcd_def Zdiv_def Zdigits_def.

Local Open Scope Z_scope.

(** Bi-directional induction for Z. *)

Theorem Z_bi_induction :
  forall A : Z -> Prop, Proper (eq ==> iff) A ->
    A 0 -> (forall n : Z, A n <-> A (Zsucc n)) -> forall n : Z, A n.
Proof.
intros A A_wd A0 AS n; apply Zind; clear n.
assumption.
intros; rewrite <- Zsucc_succ'. now apply -> AS.
intros n H. rewrite <- Zpred_pred'. rewrite Zsucc_pred in H. now apply AS.
Qed.

(** * Implementation of [ZAxiomsMiniSig] by [BinInt.Z] *)

Module Z
 <: ZAxiomsSig <: UsualOrderedTypeFull <: TotalOrder
 <: UsualDecidableTypeFull.

Definition t := Z.
Definition eqb := Zeq_bool.
Definition zero := 0.
Definition one := 1.
Definition two := 2.
Definition succ := Zsucc.
Definition pred := Zpred.
Definition add := Zplus.
Definition sub := Zminus.
Definition mul := Zmult.
Definition lt := Zlt.
Definition le := Zle.
Definition compare := Zcompare.
Definition min := Zmin.
Definition max := Zmax.
Definition opp := Zopp.
Definition abs := Zabs.
Definition sgn := Zsgn.

Definition eq_dec := Z_eq_dec.

Definition bi_induction := Z_bi_induction.

(** Basic operations. *)

Definition eq_equiv : Equivalence (@eq Z) := eq_equivalence.
Local Obligation Tactic := simpl_relation.
Program Instance succ_wd : Proper (eq==>eq) Zsucc.
Program Instance pred_wd : Proper (eq==>eq) Zpred.
Program Instance add_wd : Proper (eq==>eq==>eq) Zplus.
Program Instance sub_wd : Proper (eq==>eq==>eq) Zminus.
Program Instance mul_wd : Proper (eq==>eq==>eq) Zmult.

Definition pred_succ n := eq_sym (Zpred_succ n).
Definition add_0_l := Zplus_0_l.
Definition add_succ_l := Zplus_succ_l.
Definition sub_0_r := Zminus_0_r.
Definition sub_succ_r := Zminus_succ_r.
Definition mul_0_l := Zmult_0_l.
Definition mul_succ_l := Zmult_succ_l.

Lemma one_succ : 1 = Zsucc 0.
Proof.
reflexivity.
Qed.

Lemma two_succ : 2 = Zsucc 1.
Proof.
reflexivity.
Qed.

(** Boolean Equality *)

Definition eqb_eq x y := iff_sym (Zeq_is_eq_bool x y).

(** Order *)

Program Instance lt_wd : Proper (eq==>eq==>iff) Zlt.

Definition lt_eq_cases := Zle_lt_or_eq_iff.
Definition lt_irrefl := Zlt_irrefl.
Definition lt_succ_r := Zlt_succ_r.

(** Comparison *)

Definition compare_spec := Zcompare_spec.

(** Minimum and maximum *)

Definition min_l := Zmin_l.
Definition min_r := Zmin_r.
Definition max_l := Zmax_l.
Definition max_r := Zmax_r.

(** Properties specific to integers, not natural numbers. *)

Program Instance opp_wd : Proper (eq==>eq) Zopp.

Definition succ_pred n := eq_sym (Zsucc_pred n).
Definition opp_0 := Zopp_0.
Definition opp_succ := Zopp_succ.

(** Absolute value and sign *)

Definition abs_eq := Zabs_eq.
Definition abs_neq := Zabs_non_eq.

Definition sgn_null := Zsgn_0.
Definition sgn_pos := Zsgn_1.
Definition sgn_neg := Zsgn_m1.

(** Even and Odd *)

Definition Even n := exists m, n=2*m.
Definition Odd n := exists m, n=2*m+1.

Lemma even_spec n : Zeven_bool n = true <-> Even n.
Proof. rewrite Zeven_bool_iff. exact (Zeven_ex_iff n). Qed.

Lemma odd_spec n : Zodd_bool n = true <-> Odd n.
Proof. rewrite Zodd_bool_iff. exact (Zodd_ex_iff n). Qed.

Definition even := Zeven_bool.
Definition odd := Zodd_bool.

(** Power *)

Program Instance pow_wd : Proper (eq==>eq==>eq) Zpower.

Definition pow_0_r := Zpower_0_r.
Definition pow_succ_r := Zpower_succ_r.
Definition pow_neg_r := Zpower_neg_r.
Definition pow := Zpower.

(** Sqrt *)

(** NB : we use a new Zsqrt defined in Zsqrt_def, the previous
   module Zsqrt.v is now Zsqrt_compat.v *)

Definition sqrt_spec := Zsqrt_spec.
Definition sqrt_neg := Zsqrt_neg.
Definition sqrt := Zsqrt.

(** Log2 *)

Definition log2_spec := Zlog2_spec.
Definition log2_nonpos := Zlog2_nonpos.
Definition log2 := Zlog2.

(** Gcd *)

Definition gcd_divide_l := Zgcd_divide_l.
Definition gcd_divide_r := Zgcd_divide_r.
Definition gcd_greatest := Zgcd_greatest.
Definition gcd_nonneg := Zgcd_nonneg.
Definition divide := Zdivide'.
Definition gcd := Zgcd.

(** Div / Mod / Quot / Rem *)

Program Instance div_wd : Proper (eq==>eq==>eq) Zdiv.
Program Instance mod_wd : Proper (eq==>eq==>eq) Zmod.
Program Instance quot_wd : Proper (eq==>eq==>eq) Zquot.
Program Instance rem_wd : Proper (eq==>eq==>eq) Zrem.

Definition div_mod := Z_div_mod_eq_full.
Definition mod_pos_bound := Zmod_pos_bound.
Definition mod_neg_bound := Zmod_neg_bound.
Definition mod_bound_pos := fun a b (_:0<=a) => Zmod_pos_bound a b.
Definition div := Zdiv.
Definition modulo := Zmod.

Definition quot_rem := fun a b (_:b<>0) => Z_quot_rem_eq a b.
Definition rem_bound_pos := Zrem_bound.
Definition rem_opp_l := fun a b (_:b<>0) => Zrem_opp_l a b.
Definition rem_opp_r := fun a b (_:b<>0) => Zrem_opp_r a b.
Definition quot := Zquot.
Definition rem := Zrem.

(** Bitwise operations *)

Program Instance testbit_wd : Proper (eq==>eq==>Logic.eq) Ztestbit.
Definition testbit_odd_0 := Ztestbit_odd_0.
Definition testbit_even_0 := Ztestbit_even_0.
Definition testbit_odd_succ := Ztestbit_odd_succ.
Definition testbit_even_succ := Ztestbit_even_succ.
Definition testbit_neg_r := Ztestbit_neg_r.
Definition shiftr_spec := Zshiftr_spec.
Definition shiftl_spec_low := Zshiftl_spec_low.
Definition shiftl_spec_high := Zshiftl_spec_high.
Definition land_spec := Zand_spec.
Definition lor_spec := Zor_spec.
Definition ldiff_spec := Zdiff_spec.
Definition lxor_spec := Zxor_spec.
Definition div2_spec := Zdiv2_spec.

Definition testbit := Ztestbit.
Definition shiftl := Zshiftl.
Definition shiftr := Zshiftr.
Definition land := Zand.
Definition lor := Zor.
Definition ldiff := Zdiff.
Definition lxor := Zxor.
Definition div2 := Zdiv2.

(** We define [eq] only here to avoid refering to this [eq] above. *)

Definition eq := (@eq Z).

(** Now the generic properties. *)

Include ZProp
 <+ UsualMinMaxLogicalProperties <+ UsualMinMaxDecProperties.

End Z.

(** * An [order] tactic for integers *)

Ltac z_order := Z.order.

(** Note that [z_order] is domain-agnostic: it will not prove
    [1<=2] or [x<=x+x], but rather things like [x<=y -> y<=x -> x=y]. *)

Section TestOrder.
 Let test : forall x y, x<=y -> y<=x -> x=y.
 Proof.
 z_order.
 Qed.
End TestOrder.

(** Z forms a ring *)

(*Lemma Zring : ring_theory 0 1 NZadd NZmul NZsub Zopp NZeq.
Proof.
constructor.
exact Zadd_0_l.
exact Zadd_comm.
exact Zadd_assoc.
exact Zmul_1_l.
exact Zmul_comm.
exact Zmul_assoc.
exact Zmul_add_distr_r.
intros; now rewrite Zadd_opp_minus.
exact Zadd_opp_r.
Qed.

Add Ring ZR : Zring.*)


(* Require Import floyd.proofauto. (* TODO *) *)

(* Import ListNotations. *)
(* Local Open Scope logic. *)
Require Import SHA256.
(* Require Import sha.spec_sha. *)
Require Import sha_lemmas.
Require Import HMAC_functional_prog.

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 omega; auto.
apply IHn; omega.
Qed.

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. omega.
  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. omega.
  destruct p; simpl in *. trivial.
  rewrite IHn. trivial. omega.
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 first64_sixtyfour {A} (a:A):
      firstn 64 (HMAC_SHA256.sixtyfour a) = HMAC_SHA256.sixtyfour a.
Proof. apply firstn_precise. simpl. reflexivity. Qed.

Lemma length_Nlist {A} (i:A): forall n, length (HMAC_SHA256.Nlist i n) = n.
Proof. induction n; simpl; auto. Qed.

Lemma length_SF {A} (x:A): length (HMAC_SHA256.sixtyfour x) = 64%nat.
Proof. unfold HMAC_SHA256.sixtyfour. rewrite length_Nlist; trivial. Qed.

Lemma str_to_Z_length: forall k,
      String.length k = length (str_to_Z k).
Proof. intros. induction k; simpl; auto. Qed.

Lemma Zlength_mkArgZ k pad: Zlength (HMAC_SHA256.mkArgZ k pad) = Z.of_nat (min (length k) 64).
Proof. intros. repeat rewrite Zlength_correct.
   unfold HMAC_SHA256.mkArgZ, HMAC_SHA256.mkArg, HMAC_SHA256.sixtyfour.
   repeat rewrite map_length.
   rewrite combine_length, length_Nlist. trivial.
Qed.

Lemma In_Nlist {A:Type}: forall (n:A) l x, In x (HMAC_SHA256.Nlist n l) -> x=n.
Proof. intros n l.
  induction l; simpl; intros. contradiction.
  destruct H; eauto.
Qed.
Lemma zeropad_isbyteZ: forall l, Forall isbyteZ l -> Forall isbyteZ (HMAC_SHA256.zeroPad l).
Proof. unfold isbyteZ, HMAC_SHA256.zeroPad; intros.
  rewrite Forall_forall in *. intros.
  apply in_app_or in H0.
  destruct H0. apply (H _ H0).
  apply In_Nlist in H0. subst; omega.
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 unsigned_Brepr_isbyte z: isbyteZ z -> Byte.unsigned (Byte.repr z) = z.
Proof. intros.
      unfold isbyteZ in H. apply Byte.unsigned_repr.
      unfold Byte.max_unsigned, Byte.modulus. simpl. omega.
Qed.

Lemma map_unsigned_Brepr_isbyte: forall l, Forall isbyteZ l ->
      map Byte.unsigned (map Byte.repr l) = l.
Proof. intros. induction l; simpl in *. trivial.
   rewrite IHl. rewrite Forall_forall in H.
   assert (In a (a::l)). left. trivial.
   specialize (H _ H0); clear H0.
   rewrite unsigned_Brepr_isbyte; trivial.
   rewrite Forall_forall in *. intros. apply H. right; trivial.
Qed.

Lemma Ztest_Bytetest:
 forall a, Z.testbit (Byte.unsigned a) = Byte.testbit a.
Proof. reflexivity. Qed.
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 *. omega.
      exists a; split. left; trivial. split; trivial.
    destruct l; simpl in *. omega.
    destruct (IHn l d fx dd) as [? [? [? ?]]]. omega. trivial.
    exists x; eauto.
Qed.

Lemma sepcon_fold: forall Frame P rho,
Frame = cons `(P) nil ->
P |-- fold_right
      (fun (P Q : environ -> mpred) (rho0 : environ) => P rho0 * Q rho0)
      `emp Frame rho.
Proof. intros. subst. simpl. entailer. Qed.

Lemma nth_mapVint: forall i (l:list Z) (Hi: (0 <= i < length l)%nat),
  exists n, nth i (map Vint (map Int.repr l)) Vundef = Vint n.
Proof. intros i.
  induction i; simpl; intros.
    destruct l; simpl in *. omega. eexists; reflexivity.
    destruct l; simpl in *. omega.
      destruct (IHi l). omega. rewrite H. eexists; reflexivity.
Qed.

Lemma nth_mapVint' {z}: forall i (l:list Z)
  (Hi: (0 <= i < length l)%nat),
  nth i (map Vint (map Int.repr l)) Vundef =
  Vint (Int.repr (nth i l z)).
Proof. intros i.
  induction i; simpl; intros.
    destruct l; simpl in *. omega. trivial.
    destruct l; simpl in *. omega.
      rewrite (IHi l). trivial. omega.
Qed.

Lemma nth_mapVintZ: forall i (l:list Z) (Hi: 0 <= i < Zlength l),
  exists n, nth (Z.to_nat i) (map Vint (map Int.repr l)) Vundef = Vint n.
Proof. intros.
  eapply nth_mapVint. rewrite Zlength_correct in Hi.
  destruct Hi; split.   omega.
unfold Z.of_nat in H0. unfold Z.to_nat.
destruct l; simpl in *. omega.
destruct i; try omega.
rewrite <- SuccNat2Pos.id_succ.
apply Pos2Nat.inj_lt.
apply H0.
Qed.

Lemma nth_Nlist {A}: forall (a d:A) k i (Hik: (i <k)%nat),
      nth i (HMAC_SHA256.Nlist a k) d = a.
Proof. intros a d k.
  induction k; simpl.
    intros. omega.
  intros. destruct i; simpl. trivial.
   apply IHk. omega.
Qed.

Lemma map_Nlist: forall {A B} a (f:A -> B) n,
                 map f (HMAC_SHA256.Nlist a n) = HMAC_SHA256.Nlist (f a) n.
Proof. intros. induction n; simpl; trivial. rewrite IHn. trivial. 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 *. omega. 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 isByte_ByteUnsigned b: isbyteZ (Byte.unsigned b).
Proof.
  unfold Byte.unsigned, Byte.intval. destruct b.
  unfold Byte.modulus, Byte.wordsize, Wordsize_8.wordsize in intrange.
  rewrite two_power_nat_correct in intrange.
  unfold Zpower_nat in intrange. simpl in intrange. unfold isbyteZ. omega.
Qed.

Lemma nth_zeropad_left {d d'}: forall l i (I: 0<= i < Zlength l),
      nth (Z.to_nat i) (HMAC_SHA256.zeroPad l) d = nth (Z.to_nat i) l d'.
Proof. unfold HMAC_SHA256.zeroPad. intros.
  destruct I.
  apply Z2Nat.inj_lt in H0; try omega.
  rewrite Zlength_correct, Nat2Z.id in H0.
  rewrite app_nth1; trivial.
  apply nth_indep; trivial.
Qed.

Lemma mkKey_left {d d'}: forall l (L: false = (Zlength l >? 64))
        i (I: 0<= i < Zlength l),
      nth (Z.to_nat i) (HMAC_SHA256.mkKey l) d = nth (Z.to_nat i) l d'.
Proof.
  unfold HMAC_SHA256.mkKey. intros. simpl. rewrite <- L.
  apply nth_zeropad_left; trivial.
Qed.
Lemma nth_zeropad_right {d}: forall l i (I: Zlength l <= i < 64),
      nth (Z.to_nat i) (HMAC_SHA256.zeroPad l) d = Z0.
Proof. unfold HMAC_SHA256.zeroPad. intros.
  rewrite app_nth2. rewrite nth_Nlist. trivial.
  apply minus_lt_compat_r. destruct I. apply Z2Nat.inj_lt in H0. apply H0.
  specialize (initial_world.zlength_nonneg _ l). omega.
  omega.
  destruct I. apply Z2Nat.inj_le in H. rewrite Zlength_correct, Nat2Z.id in H. apply H.
  apply(initial_world.zlength_nonneg _ l).
  specialize (initial_world.zlength_nonneg _ l). omega.
  destruct I. apply Z2Nat.inj_le in H. rewrite Zlength_correct, Nat2Z.id in H. apply H.
  apply(initial_world.zlength_nonneg _ l).
  specialize (initial_world.zlength_nonneg _ l). omega.
Qed.
Lemma mkKey_right {d}: forall l (L: false = (Zlength l >? 64))
        i (I: Zlength l <= i < 64),
      nth (Z.to_nat i) (HMAC_SHA256.mkKey l) d = Z0.
Proof.
  unfold HMAC_SHA256.mkKey. intros. simpl. rewrite <- L.
  apply nth_zeropad_right; trivial.
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 isbyte_map_ByteUnsigned l: Forall isbyteZ (map Byte.unsigned l).
Proof.
  rewrite Forall_forall. intros.
  apply list_in_map_inv in H. destruct H as [b [B1 _]]. subst x.
  apply isByte_ByteUnsigned.
Qed.

(*Same proof as semax_loadstore_array*)
Lemma NEWsemax_loadstore_array:
  forall {Espec: OracleKind},
 forall n k vi lo hi t1 (contents: Z -> reptype t1) v1 v2 (Delta: tycontext) e1 ei e2 sh P Q R,
  (*H0*) reptype t1 = val ->
  (*H1*) type_is_by_value t1 ->
  (*H2*) legal_alignas_type t1 = true ->
  (*H3*) typeof e1 = tarray t1 k->
  (*H4*) typeof ei = tint ->
  (*H8*) PROPx P (LOCALx Q (SEPx R)) |--  rel_expr e1 v1 && rel_expr ei (Vint (Int.repr vi))
           && rel_expr (Ecast e2 t1) v2 ->
  (*H7*) nth_error R n = Some (`(array_at t1 sh contents lo hi v1)) ->
  (*H *) writable_share sh ->
  (*H5*) tc_val t1 v2 ->
  (*H6*) in_range lo hi vi ->
   @semax Espec Delta (|> PROPx P (LOCALx Q (SEPx R))) (Sassign (Ederef (Ebinop Oadd e1 ei (tptr t1)) t1) e2)
          (normal_ret_assert
           (PROPx P (LOCALx Q (SEPx
            (replace_nth n R `(array_at t1 sh (upd contents vi (valinject _ v2)) lo hi v1)))))).
Proof.
intros until R.
intros H0 H1 H2 H3 H4 H8 H7 H H5 H6.
eapply semax_post_flipped'.
apply semax_loadstore_array'; eauto.
apply derives_trans with (!! isptr v1 && PROPx P (LOCALx Q (SEPx R))).
rewrite (SEP_nth_isolate _ _ _ H7).
repeat rewrite <- insert_SEP.
rewrite array_at_isptr. normalize.
normalize.
destruct v1; try contradiction.
instantiate (2:=v1).
simpl eval_binop. rewrite mul_repr.
apply andp_right; auto.
eapply derives_trans; [ apply H8 |].
intro rho. simpl.
repeat apply andp_right.
apply rel_lvalue_deref.
eapply rel_expr_binop.
repeat apply andp_left1. apply derives_refl.
apply andp_left1. apply andp_left2. apply derives_refl.
intro; rewrite H4; simpl. rewrite H3; simpl.
  unfold Cop.sem_add; simpl. rewrite mul_repr. auto.
 apply andp_left2. auto.
rewrite (SEP_nth_isolate _ _ _ H7).
repeat rewrite <- insert_SEP.
apply derives_refl.
rewrite (SEP_replace_nth_isolate _ _ _ `(array_at t1 sh (upd contents vi (valinject t1 v2)) lo hi v1) H7).
rewrite insert_SEP.
auto.
Qed.

Lemma array_at_local_facts':
  forall (t : type) (sh : Share.t) (f : Z -> reptype t) (lo hi : Z) (v : val),
  array_at t sh f lo hi v |-- array_at t sh f lo hi v && !!isptr v && !!offset_in_range (sizeof t * lo) v &&
!!offset_in_range (sizeof t * hi) v && !!align_compatible t v.
Proof. intros. unfold array_at. entailer. Qed.

Lemma split_offset_array_at_: forall (ty : type) (sh : Share.t)
         (z lo hi : Z) (v : val),
       z <= lo <= hi ->
       sizeof ty > 0 ->
       legal_alignas_type ty = true ->
       array_at_ ty sh z hi v =
       !! offset_in_range (sizeof ty * z) v &&
       !! offset_in_range (sizeof ty * hi) v &&
       array_at_ ty sh z lo v *
       array_at_ ty sh 0 (hi - lo)
       (offset_val (Int.repr (sizeof ty * lo)) v).
Proof.
  intros. unfold array_at_.
  rewrite <- split_offset_array_at; trivial.
Qed.
Lemma offset_val_array_at0:
 forall t sh f lo hi v,
  sizeof t > 0 -> hi >= 0 ->
  legal_alignas_type t = true ->
  array_at t sh (fun i => f (i-lo)%Z) lo (lo + hi) v
  |--
  array_at t sh f 0 hi (offset_val (Int.repr (sizeof t * lo)) v).
Proof.
  intros.
  rewrite (split_offset_array_at t _ _ lo lo); trivial.
  rewrite array_at_emp.
  entailer. rewrite Zplus_comm. rewrite Z.add_simpl_r.
  apply array_lemmas.array_at_ext'. intros. rewrite Z.add_simpl_r. trivial.
  omega.
Qed.

Lemma offset_val_array_at1:
 forall t sh f g k lo hi ofs v,
    sizeof t > 0 -> hi >= 0 ->
    legal_alignas_type t = true ->
    k = lo + hi ->
    g = (fun i => f (i-lo)%Z) ->
    ofs = Int.repr (sizeof t * lo) ->
  array_at t sh g lo k v |--
  array_at t sh f 0 hi ((offset_val ofs) v).
Proof.
  intros. subst. apply offset_val_array_at0; trivial.
Qed.

Lemma split_memory_block p hi v sh:
      0 <= p <= hi -> isptr v ->
      memory_block sh (Int.repr hi) v =
      !!offset_in_range (sizeof tuchar * 0) v &&
      !!offset_in_range (sizeof tuchar * hi) v &&
      memory_block sh (Int.repr p) v * memory_block sh (Int.repr (hi-p)) (offset_val (Int.repr p) v).
Proof. intros.
rewrite memory_block_array_tuchar'; try omega; trivial.
rewrite memory_block_array_tuchar'; try omega; trivial.
rewrite memory_block_array_tuchar'; try omega.
rewrite (split_offset_array_at_ _ _ _ p).
   assert (K: (sizeof tuchar * p = p)%Z).
      assert (sizeof tuchar =1 ). reflexivity.
  rewrite H1. omega.
  rewrite K; trivial.
 assumption. simpl; omega. reflexivity. apply isptr_offset_val'; trivial.
Qed.

Lemma zeroPad_BlockSize: forall k, (length k <= SHA256.BlockSize)%nat ->
  length (HMAC_SHA256.zeroPad k) = SHA256.BlockSize%nat.
Proof. unfold HMAC_SHA256.zeroPad. intros. rewrite app_length, length_Nlist. omega.
Qed.

Lemma length_SHA256': forall l,
  length (functional_prog.SHA_256' l) = SHA256.DigestLength.
Proof. intros. unfold functional_prog.SHA_256'. simpl.
  rewrite length_intlist_to_Zlist, functional_prog.length_process_msg. reflexivity.
Qed.

(* TODO: move relevant lemmas into a new file *)

Lemma mkKey_length l: length (HMAC_SHA256.mkKey l) = SHA256.BlockSize.
Proof. intros. unfold HMAC_SHA256.mkKey.
  remember (Zlength l >? Z.of_nat SHA256.BlockSize) as z.
  destruct z. apply zeroPad_BlockSize.
    rewrite length_SHA256'.
    apply Nat2Z.inj_le. simpl. omega.
  apply zeroPad_BlockSize.
    rewrite Zlength_correct in Heqz.
    apply Nat2Z.inj_le.
    specialize (Zgt_cases (Z.of_nat (Datatypes.length l)) (Z.of_nat SHA256.BlockSize)). rewrite <- Heqz. trivial.
Qed.

Lemma mkKey_atBlockSize s: length s = SHA256.BlockSize%nat ->
      HMAC_SHA256.mkKey s = s.
Proof. unfold HMAC_SHA256.mkKey. rewrite Zlength_correct.
  intros. rewrite H.
  simpl. unfold HMAC_SHA256.zeroPad. rewrite H. simpl.
  apply app_nil_r.
Qed.

Lemma isptrD v: isptr v -> exists b ofs, v = Vptr b ofs.
Proof. intros. destruct v; try contradiction. exists b, i; trivial. Qed.

Lemma isbyte_sha x: Forall isbyteZ (functional_prog.SHA_256' x).
Proof. apply isbyte_intlist_to_Zlist. Qed.

Lemma updAbs_len: forall L s t, update_abs L s t -> s256a_len t = s256a_len s + Zlength L * 8.
Proof. intros. inversion H; clear H.
  unfold s256a_len. simpl.
  rewrite Zlength_app. subst.
  repeat rewrite Z.mul_add_distr_r.
  repeat rewrite <- Z.add_assoc.
  assert (Zlength blocks * WORD * 8 + Zlength newfrag * 8 =
          Zlength oldfrag * 8 + Zlength L * 8).
    assert (Zlength (oldfrag ++ L) = Zlength (SHA256.intlist_to_Zlist blocks ++ newfrag)).
      rewrite H4; trivial.
    clear H4. rewrite Zlength_app in H.
              rewrite <- (Z.mul_add_distr_r (Zlength oldfrag)), H. clear H.
              rewrite Zlength_app, Zlength_intlist_to_Zlist.
              rewrite (Z.mul_comm WORD). rewrite Z.mul_add_distr_r. trivial.
  rewrite H; trivial.
Qed.

Lemma Zlength_max_zero: forall {A:Type} (l:list A), Z.max 0 (Zlength l) = Zlength l.
Proof. intros.
       rewrite Z.max_r. trivial.
       apply (initial_world.zlength_nonneg _ l).
Qed.

Lemma HMAC_length d k: length (HMAC_SHA256.HMAC d k) = 32%nat.
Proof.
  unfold HMAC_SHA256.HMAC, HMAC_SHA256.OUTER.
  apply length_SHA256'.
Qed.
Lemma HMAC_Zlength d k: Zlength (HMAC_SHA256.HMAC d k) = 32.
Proof.
  rewrite Zlength_correct, HMAC_length. reflexivity.
Qed.


Require Export XR_R.
Require Export XR_R0.
Require Export XR_Rmult.
Require Export XR_Rmult_assoc.
Require Export XR_Rmult_1_l.
Require Export XR_Rmult_eq_compat_l.
Require Export XR_Rinv_l.

Local Open Scope R_scope.
Implicit Type r : R.

Lemma Rmult_eq_reg_l : forall r r1 r2, r * r1 = r * r2 -> r <> R0 -> r1 = r2.
Proof.
  intros x y z.
  intro heq.
  intro hneq.
  pattern y ; rewrite <- Rmult_1_l.
  pattern z ; rewrite <- Rmult_1_l.
  rewrite <- Rinv_l with x.
  {
    repeat rewrite Rmult_assoc.
    apply Rmult_eq_compat_l.
    exact heq.
  }
  { exact hneq. }
Qed.


(** * Classification of the [×] Type *)
(** In this file, we classify the basic structure of [×] types ([prod]
    in Coq).  In particular, we classify equalities of non-dependent
    pairs (inhabitants of [×] types), so that when we have an equality
    between two such pairs, or when we want such an equality, we have
    a systematic way of reducing such equalities to equalities at
    simpler types. *)
Require Import Fiat.Common.Equality.
Local Unset Implicit Arguments.

Local Arguments fst {_ _} _.
Local Arguments snd {_ _} _.
Local Arguments f_equal {_ _} _ {_ _} _.

Scheme Equality for prod.

(** ** Equality for [prod] *)
Section prod.
  (** *** Projecting an equality of a pair to equality of the first components *)
  Definition fst_path {A B} {u v : prod A B} (p : u = v)
  : fst u = fst v
    := f_equal fst p.

  (** *** Projecting an equality of a pair to equality of the second components *)
  Definition snd_path {A B} {u v : prod A B} (p : u = v)
  : snd u = snd v
    := f_equal snd p.

  (** *** Equality of [prod] is itself a [prod] *)
  Definition path_prod_uncurried {A B : Type} (u v : prod A B)
             (pq : prod (fst u = fst v) (snd u = snd v))
    : u = v.
  Proof.
    destruct u as [u1 u2], v as [v1 v2]; simpl in *.
    destruct pq as [p q].
    destruct p, q; simpl in *.
    reflexivity.
  Defined.

  (** *** Curried version of proving equality of sigma types *)
  Definition path_prod {A B : Type} (u v : prod A B)
             (p : fst u = fst v) (q : snd u = snd v)
    : u = v
    := path_prod_uncurried u v (pair p q).

  (** *** Equivalence of equality of [prod] with a [prod] of equality *)
  (** We could actually use [IsIso] here, but for simplicity, we
      don't.  If we wanted to deal with proofs of equality of × types
      in dependent positions, we'd need it. *)
  Definition path_prod_uncurried_iff {A B}
             (u v : @prod A B)
    : u = v <-> (prod (fst u = fst v) (snd u = snd v)).
  Proof.
    split; [ intro; subst; split; reflexivity | apply path_prod_uncurried ].
  Defined.

  Definition prod_and_iff {A B : Prop}
    : A /\ B <-> (A * B).
  Proof. split; intros [? ?]; split; assumption. Defined.

  (** *** Eta-expansion of [@eq (prod _ _)] *)
  Definition path_prod_eta {A B} {u v : @prod A B} (p : u = v)
    : p = path_prod_uncurried u v (fst_path p, snd_path p).
  Proof. destruct u, p; reflexivity. Defined.

  (** *** Induction principle for [@eq (prod _ _)] *)
  Definition path_prod_rect {A B} {u v : @prod A B} (P : u = v -> Type)
             (f : forall p q, P (path_prod_uncurried u v (p, q)))
    : forall p, P p.
  Proof. intro p; specialize (f (fst_path p) (snd_path p)); destruct u, p; exact f. Defined.
  Definition path_prod_rec {A B u v} (P : u = v :> @prod A B -> Set) := path_prod_rect P.
  Definition path_prod_ind {A B u v} (P : u = v :> @prod A B -> Prop) := path_prod_rec P.
End prod.

(** ** Useful Tactics *)
(** *** [inversion_prod] *)
Ltac simpl_proj_pair_in H :=
  repeat match type of H with
         | context G[fst (pair ?x ?p)]
           => let G' := context G[x] in change G' in H
         | context G[snd (pair ?x ?p)]
           => let G' := context G[p] in change G' in H
         end.
Ltac induction_path_prod H :=
  let H0 := fresh H in
  let H1 := fresh H in
  induction H as [H0 H1] using path_prod_rect;
  simpl_proj_pair_in H0;
  simpl_proj_pair_in H1.
Ltac inversion_prod_step :=
  match goal with
  | [ H : _ = pair _ _ |- _ ]
    => induction_path_prod H
  | [ H : pair _ _ = _ |- _ ]
    => induction_path_prod H
  end.
Ltac inversion_prod := repeat inversion_prod_step.


Require Import Coq.ZArith.ZArith.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e216m2e108m1_4limbs.Synthesis.
Local Open Scope Z_scope.

(* TODO : change this to field once field isomorphism happens *)
Definition nonzero :
  { nonzero : feBW_small -> BoundedWord.BoundedWord 1 adjusted_bitwidth bound1
  | forall a, (BoundedWord.BoundedWordToZ _ _ _ (nonzero a) =? 0) = (if Decidable.dec (phiM_small a = F.of_Z m 0) then true else false) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_nonzero ().
  Show Ltac Profile.
Time Defined.

Print Assumptions nonzero.


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

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


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

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


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

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


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

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Require Import FP.CoreClasses.Setoid.
Require Import FP.CoreClasses.Eqv.

Class Bijection T U `{! Eqv T ,! Eqv U } :=
  { bij_to : T -> U
  ; bij_from : U -> T
  ; bij_from_to_eqv : forall x, eqv x x -> eqv (bij_from (bij_to x)) x
  ; bij_to_from_eqv : forall y, eqv y y -> eqv (bij_to (bij_from y)) y
  }.

Instance :
  forall T T' U U'
    `{! Eqv T ,! PER_WF T
     ,! Eqv T' ,! PER_WF T'
     ,! Eqv U ,! PER_WF U
     ,! Eqv U' ,! PER_WF U'
     ,! Bijection T T' ,! Bijection U U'
     },
  Bijection (T -> U) (T' -> U').
Proof.
  intros.
  refine(
    {| bij_to f x := bij_to (f (bij_from x))
     ; bij_from f x := bij_from (f (bij_to x))
     ; bij_from_to_eqv := _
     ; bij_to_from_eqv := _
    |})
  ; intros f fwf ; logical_eqv.
  - rewrite bij_from_to_eqv.
    + logical_eqv ; rewrite bij_from_to_eqv ; logical_eqv.
    + logical_eqv_elim_once ; auto.
      transitivity x ; [|symmetry] ; apply bij_from_to_eqv ; logical_eqv.
  - rewrite bij_to_from_eqv.
    + logical_eqv ; rewrite bij_to_from_eqv ; logical_eqv.
    + logical_eqv_elim_once ; auto.
      transitivity x ; [|symmetry] ; apply bij_to_from_eqv ; logical_eqv.
Qed.


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

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


From mathcomp Require Import all_ssreflect all_algebra finmap.
From Equations Require Import Equations.

Require Import wf_finset.

Import GRing.Theory Num.Theory Order.Theory.

Open Scope ring_scope.

Section parameters.

Variable R : realDomainType.

Variable P : finType.

Variable E : finType.

Variable T : finType.

Variable edge_in : E -> T -> bool.

Definition triangulation := {set T}.

Variable is_Delaunay : triangulation -> bool.

Section walk_parameters.

Variable tr : triangulation.

Variable target_point : P.

Hypothesis tr_is_Delaunay : is_Delaunay tr.

Variable opposite_edge : E -> E.

Hypothesis involution_opposite_edge :
  forall (e : E), opposite_edge (opposite_edge e) = e.

Variable separating_edge : T -> option E.

Definition target_in (t : T) :=
  separating_edge t == None.

Hypothesis separating_edge_in_triangle :
  forall (e : E) (t : T),
  separating_edge t = Some e -> edge_in e t.

Variable find_triangle_of_edge : E -> option T.

Hypothesis correction_find_triangle :
  forall (e : E) (t : T),
  find_triangle_of_edge e = Some t <-> (edge_in e t) /\ (t \in enum tr).

Lemma invariant_find_triangle_of_edge : forall (e : E) (t : T),
   find_triangle_of_edge e = Some t -> t \in enum tr.
Proof.
move => e t.
have aux : (edge_in e t) /\ (t \in enum tr) -> t \in enum tr.
  by move => [H1 H2].
move => h.
apply: aux.
by apply (correction_find_triangle e t).
Qed.

Lemma edge_in_find_triangle_of_edge : forall (e : E) (t : T),
   t \in enum tr ->
   (edge_in e t -> find_triangle_of_edge e = Some t).
Proof.
move => e t h1 h2.
by apply (correction_find_triangle e t).
Qed.

Variable triangle_measure : T -> R.

Definition walk_lt (t1 t2 : T) : Prop :=
  triangle_measure t1 < triangle_measure t2.

Definition walk_lt' (t1 t2 : {t : T | t \in enum tr}) : Prop :=
  triangle_measure (proj1_sig t1) < triangle_measure (proj1_sig t2).

Lemma walk_lt_trans :
  forall (t1 t2 t3 : T),
  walk_lt t1 t2 -> walk_lt t2 t3 -> walk_lt t1 t3.
Proof.
rewrite /walk_lt.
move => t1 t2 t3.
by apply: lt_trans.
Qed.

Lemma walk_lt_anti_refl :
  forall (t : T), ~ (walk_lt t t).
Proof.
rewrite /walk_lt.
move => t.
by rewrite ltxx.
Qed.

Lemma walk_lt_well_founded : well_founded walk_lt.
Proof.
apply: wf_rel.
apply: walk_lt_trans.
by apply: walk_lt_anti_refl.
Qed.

Instance walk_lt_wf : WellFounded walk_lt.
Proof.
rewrite /WellFounded; apply walk_lt_well_founded.
Qed.

Instance walk'_lt_wf : WellFounded walk_lt'.
Proof.
rewrite /WellFounded.
apply (Inverse_Image.wf_inverse_image _ T walk_lt).
apply walk_lt_well_founded.
Qed.

Hypothesis decrease_condition :
  forall (e : E) (t t' : T),
  t \in enum tr ->
  separating_edge t = Some e ->
    find_triangle_of_edge (opposite_edge e) = Some t' -> walk_lt t' t.

Definition separating_inspect (t : T) :
  {e' : option E | separating_edge t = e'} :=
 exist _ (separating_edge t) erefl.

Definition find_triangle_inspect (e : E) :
  {t' : option T | find_triangle_of_edge e = t'} :=
  exist _ (find_triangle_of_edge e) erefl.

Equations walk (current_triangle : {t : T | t \in enum tr})
   : T + E by wf (current_triangle) walk_lt' :=
walk current_triangle with
    separating_inspect (proj1_sig current_triangle) => {
     | exist _ (Some edge) eq1
       with find_triangle_inspect (opposite_edge edge) => {
          | exist _ (Some new_triangle) eq2 :=
            walk
              (exist _ new_triangle
                 (invariant_find_triangle_of_edge _ _ eq2));
          | exist _ None eq2 := inr (opposite_edge edge)};
     | exist _ None eq1 := inl (proj1_sig (current_triangle))}.
Next Obligation.
rewrite /walk_lt' /=; apply: (decrease_condition edge) => //.
Qed.

Lemma walk_result_edge :
  forall (e : E) (t : {t : T | t \in enum tr}),
  walk t = inr e -> (exists (t1 : T), edge_in (opposite_edge e) t1) /\
    (forall (t2 : T), t2 \in enum tr -> ~~ edge_in e t2).
Proof.
move => e t h; funelim (walk t); rewrite h in Heqcall.
    by [].
  move: Heqcall.
  by apply: (H e1).
move: Heqcall=> [heq].
split.
  rewrite -heq involution_opposite_edge.
  exists (proj1_sig current_triangle).
  by apply: separating_edge_in_triangle e.
move => t2 h2.
apply /negP => /(edge_in_find_triangle_of_edge e1 t2 h2).
by rewrite -heq e0.
Qed.

Lemma walk_result_triangle :
  forall (t1 : {t : T | t \in enum tr}) (t2 : T),
  walk t1 = inl t2 -> target_in t2.
Proof.
move => t1 t2 h; funelim (walk t1); rewrite h in Heqcall.
    move: Heqcall => [heq].
    rewrite -heq /target_in.
    apply/eqP.
    by apply: e.
  by apply: H Heqcall.
by [].
Qed.

End walk_parameters.

End parameters.


(* Internal import(s). *)
Require Import Basics.Identifier.
Require Import Basics.Map.

Inductive exp: Type :=
  (* Primitives. *)
  | ENat  (x: nat)
  | EBool (x: bool)
  | EId   (x: identifier)
  (* Arithmetic operators. *)
  | EAdd (e e': exp)
  | ESub (e e': exp)
  | EMul (e e': exp)
  | EDiv (e e': exp)
  (* Logical operators. *)
  | EEq  (e e': exp)
  | ELt  (e e': exp)
  | ENot (e   : exp)
  | EAnd (e e': exp)
  (* Imperative commands. *)
  | ESkip
  | ESeq   (e e'    : exp)
  | EAss   (x       : identifier) (e: exp)
  | EWhile (e e'    : exp)
  | EIte   (e e' e'': exp)
  (* Lambdas. *)
  | EAbs (x   : identifier) (e: exp)
  | EFix (x   : identifier) (e: exp)
  | EApp (e e': exp)
  (* Hole. *)
  | EHole.

(* Stack type. *)
Inductive stack: Type :=
  | EmptyStack
  | Stack      (e: exp) (s:stack).

(* Configuration/env type. *)
Inductive cfg: Type :=
  Cfg (s: stack) (m: map_id_nat).
Definition emptyCfg := Cfg EmptyStack map_id_nat_empty.
Definition getStackOfCfg (config:cfg): stack :=
  match config with
  | Cfg s _ => s
  end.
Definition getEnvOfCfg (config:cfg): map_id_nat :=
  match config with
  | Cfg _ e => e
  end.

(* Notations and whatnot. *)
Coercion ENat : nat        >-> exp.
Coercion EBool: bool       >-> exp.
Coercion EId  : identifier >-> exp.
Infix "+"      := EAdd (at level 50, left associativity).
Infix "-"      := ESub (at level 50, left associativity).
Infix "*"      := EMul (at level 40, left associativity).
Infix "/"      := EDiv (at level 40, left associativity).
Infix "==?"    := EEq  (at level 55, left associativity).
Infix "<?"     := ELt  (at level 54, left associativity).
Infix "&"      := EAnd (at level 56, left associativity).
Notation "! b" := (ENot b)   (at level 30, right associativity).

Notation "'SKIP'"    :=
  (ESkip).
Notation "c1 ; c2"   :=
  (ESeq c1 c2)
  (at level 70, right associativity).
Notation "x '::=' e" :=
  (EAss x e)
  (at level 60).
Notation "'WHILE' b 'DO' c 'END'" :=
  (EWhile b c)
  (at level 70, right associativity).
Notation "'ITE' b 'THEN' c1 'ELSE' c2 'ETI'" :=
  (EIte b c1 c2)
  (at level 70, right associativity).

Notation "e '~>' st" := (Stack e st) (at level 80, right associativity).
Notation "[ s | m ]" := (Cfg s m)    (at level 90).