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.


(* 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 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).