From iris.proofmode Require Import tactics.
From iris.program_logic Require Export atomic.
From iris.heap_lang Require Import proofmode notation lang.

Definition getAndSet : val :=
  rec: "getAndSet" "l" "v" :=
    let: "o" := ! "l" in
    if: CAS "l" "o" "v"
    then "o"
    else "getAndSet" "l" "v".

Section getAndSetProof.

Context `{heapG}.

Theorem getAndSet_spec (ℓ: loc) (v: val):
  ⊢ <<< ∀ k, ▷ ℓ ↦ k ∧ ⌜val_is_unboxed k⌝>>>
    getAndSet #ℓ v @ ⊤
  <<< ℓ ↦ v, RET k >>>.
Proof.
  iIntros (Φ) "AU". iLöb as "IH". wp_lam. wp_pures.
  wp_bind (!_)%E. iMod "AU" as (k) "[[Hℓ %] [HClose _]]".
  wp_load. iMod ("HClose" with "[Hℓ]") as "AU"; first by iSplit. iModIntro.
  wp_let. wp_bind (CmpXchg _ _ _)%E. iMod "AU" as (k') "[[Hℓ %] HClose]".
  destruct (decide (k = k')) as [[= ->]|Hx];
    [wp_cmpxchg_suc|wp_cmpxchg_fail];
    [iDestruct "HClose" as "[_ HClose]" | iDestruct "HClose" as "[HClose _]"].
  all: iMod ("HClose" with "[Hℓ]") as "HΦ"; first by auto.
  all: iModIntro; wp_pures; auto.
  by wp_apply "IH".
Qed.

End getAndSetProof.


Require Import Coq.Lists.List.
Require Import Coq.Classes.EquivDec.
Require Import MirrorShard.Heaps.
Require MirrorShard.SepExpr MirrorShard.Expr.
Require Import MirrorShard.Provers.

Set Implicit Arguments.

Module SepExprTests (B : Heap).
  Module ST := SepTheoryX.SepTheoryX (B).
  Module Sep := SepExpr.SepExpr B ST.

  (** Just a test separation logic predicate **)
  Section Tests.
    Variable f : forall a b, nat -> ST.hprop a b nil.
    Variable h : forall a b, nat -> ST.hprop a b nil.
    Variable i : forall a b, nat -> ST.hprop a b nil.
    Variable g : bool -> nat -> nat -> nat.

    Ltac isConst e :=
      match e with
        | true => true
        | false => true
        | O => true
        | S ?e => isConst e
        | _ => false
      end.

    Definition nat_type : Expr.type :=
      {| Expr.Impl := nat
       ; Expr.Eq := fun x y => match equiv_dec x y with
                                 | left pf => Some pf
                                 | _ => None
                               end
       |}.

    Fixpoint star_all a b (f : nat -> ST.hprop a b nil) (n : nat) : ST.hprop a b nil :=
      match n with
        | 0 => f 0
        | S n => ST.star (f (S n)) (star_all f n)
      end.

    Fixpoint star_all_back a b (f : nat -> ST.hprop a b nil) (n m : nat) : ST.hprop a b nil :=
      match n with
        | 0 => f m
        | S n => ST.star (f (m - S n)) (star_all_back f n m)
      end.

    Opaque ST.himp ST.star ST.emp ST.inj ST.ex.

    Import SepExpr Sep Expr ExprUnify DepList.

    Ltac simplifier := cbv beta iota zeta delta [CancelSep sepCancel hash hash' liftSHeap sheapSubstU liftExpr
      SepExpr.FM.add SepExpr.FM.fold SepExpr.FM.map SepExpr.FM.find SepExpr.FM.remove
        SepExpr.FM.empty SepExpr.FM.insert_at_right
        other pures impures star_SHeap SHeap_empty
        unify_remove unify_remove_all exprUnifyArgs exprUnify empty_Subst Subst_lookup env_of_Subst
        Expr.Impl Expr.Eq
        List.map List.length List.app fold_left_2_opt List.fold_right List.nth_error
        starred sheapD exprD
        exprSubstU
        Compare_dec.lt_eq_lt_dec Compare_dec.lt_dec Peano_dec.eq_nat_dec
        nat_rec nat_rect forallEach env exists_subst multimap_join equiv_dec seq_dec
        Domain Range
        EqDec_tvar tvar_rec tvar_rect
        lookupAs sumbool_rec sumbool_rect
        fst snd
        eq_rec_r eq_rec eq_rect Logic.eq_sym f_equal get_Eq value
        nat_eq_eqdec
        eq_summary eq_summarize eq_prove
        sexprD Compare_dec.le_dec Compare_dec.le_gt_dec Compare_dec.le_lt_dec
        Subst_replace plus minus substV

        transitivityEqProverRec groupsOf transitivityEqProver addEquality expr_seq_dec
        applyD
        in_seq_dec eqD_seq groupWith Expr.typeof unifyArgs inSameGroup fold_right
        bool_eqdec Bool.bool_dec bool_rec bool_rect

        nat_type
    ]; fold plus; fold minus.

    Ltac sep := simpl; intros;
      Sep.sep isConst transitivityEqProverRec simplifier (nat_type :: nil); try reflexivity.

    Goal forall a b c x y, @ST.himp a b c (f _ _ (g y (x + x) 1)) (f _ _ 1).
      sep.
    Abort.

    Theorem t1 : forall a b c, @ST.himp a b c (f _ _ 0) (f _ _ 0).
      sep.
    Qed.

    Theorem t2 : forall a b c,
      @ST.himp a b c (ST.star (star_all_back (@h a b) 15 15) (star_all_back (@f a b) 15 15))
                     (ST.star (star_all (@f a b) 15) (star_all (@h a b) 15)).
      sep.
    Qed.

    Theorem t3 : forall a b c, @ST.himp a b c
      (ST.star (f _ _ 2) (f _ _ 1))
      (f _ _ 1).
      sep.
    Abort.

    Theorem t4 : forall a b c, @ST.himp a b c
      (ST.ex (fun y : nat => ST.ex (fun x : bool => ST.star (f _ _ (g x 1 2)) (f _ _ 1) )))
      (f _ _ 1).
      sep.
    Abort.

    Theorem t5 : forall a b c, @ST.himp a b c
      (ST.ex (fun y : nat => f _ _ y))
      (f _ _ 1).
      sep.
    Abort.

    Theorem t6 : forall a b c, @ST.himp a b c
      (f _ _ 1)
      (ST.ex (fun y : nat => f _ _ y)).
      sep.
    Qed.

    Theorem t7 : forall a b c, @ST.himp a b c
      (ST.star (f _ _ (g true 0 1)) (f _ _ (g true 1 2)))
      (ST.ex (fun y : nat => ST.star (f _ _ (g true 0 y)) (ST.ex (fun z : nat => f _ _ (g true 1 z))))).
      sep.
    Qed.

    Theorem t8 : forall a b c, @ST.himp a b c
      (ST.star (f _ _ (g true 0 1)) (f _ _ (g true 1 2)))
      (ST.ex (fun y : nat => ST.star (f _ _ (g true 1 y)) (ST.ex (fun z : nat => f _ _ (g true 0 z))))).
      sep.
    Qed.

    (** ** Test use of transitivity prover in cancellation *)

    Theorem t9 : forall a b c x y, x = y
      -> @ST.himp a b c  (f _ _ x) (f _ _ y).
      sep.
    Qed.

    Theorem t10 : forall a b c x y, x = y
      -> @ST.himp a b c  (f _ _ y) (f _ _ x).
      sep.
    Qed.

    Theorem t11 : forall a b c x y z, x = y
      -> x = z
      -> @ST.himp a b c  (f _ _ x) (f _ _ y).
      sep.
    Qed.

    Theorem t12 : forall a b c x y u v, x = y
      -> u = v
      -> @ST.himp a b c  (ST.star (f _ _ x) (f _ _ v)) (ST.star (f _ _ y) (f _ _ u)).
      sep.
    Qed.

    Theorem t13 : forall a b c x y z u v, x = y
      -> z = y
      -> u = v
      -> @ST.himp a b c  (ST.star (f _ _ x) (f _ _ v)) (ST.star (f _ _ z) (f _ _ u)).
      sep.
    Qed.

  End Tests.

End SepExprTests.


Set Implicit Arguments.

Require Import ADT.

Module Make (Import E : ADT).

  Require Import Semantics.
  Module Import SemanticsMake := Make E.

  Section TopSection.

    Require Import GoodModule.
    Require Import GLabelMap.
    Import GLabelMap.

    Open Scope bool_scope.
    Notation "! b" := (negb b) (at level 35).

    Require Import Compare_dec.

    Definition to_bool A B (b : {A} + {B}) := if b then true else false.

    Notation fst2 := (fun x => @fst _ _ (@fst _ _ x)).

    Require Import ListFacts3.
    Require Import GoodModuleFacts.

    Definition GoodToLink_bool (modules : list GoodModule) (imports : t ForeignFuncSpec) :=
      let imported_module_names := List.map fst2 (elements imports) in
      let module_names := List.map Name modules in
      ! sumbool_to_bool (zerop (length modules)) &&
        NoDup_bool string_bool module_names &&
        forallb (fun s => ! sumbool_to_bool (in_dec string_dec s module_names)) imported_module_names &&
        forallb GoodModuleName_bool imported_module_names.

    Require Import GeneralTactics.
    Require Import ListFacts1.

    Lemma GoodToLink_bool_sound :
      forall modules imports,
        GoodToLink_bool modules imports = true ->
        modules <> nil /\
        List.NoDup (List.map Name modules) /\
        ListFacts1.Disjoint (List.map Name modules) (List.map fst2 (elements imports)) /\
        forall l, In l imports -> IsGoodModuleName (fst l).
    Proof.
      intros.
      unfold GoodToLink_bool in *; simpl in *.
      Require Import GeneralTactics.
      Require Import Bool.
      repeat (eapply andb_true_iff in H; openhyp).
      split.
      eapply negb_true_iff in H.
      unfold sumbool_to_bool in *.
      destruct (zerop _); intuition.
      subst; simpl in *; intuition.
      split.
      eapply NoDup_bool_string_eq_sound; eauto.
      split.
      unfold ListFacts1.Disjoint; intuition.
      eapply forallb_forall in H1; eauto.
      eapply negb_true_iff in H1.
      unfold sumbool_to_bool in *.
      destruct (in_dec _ _ _); intuition.
      intros.
      eapply forallb_forall in H0; eauto.
      eapply GoodModuleName_bool_sound; eauto.
      rewrite <- map_map.
      eapply in_map.
      Require Import GLabelMapFacts.
      eapply In_fst_elements_In; eauto.
    Qed.

  End TopSection.
(*
  Require Import RepInv.

  Module Make (Import M : RepInv E).

    Require Import Link.
    Module Import LinkMake := Make E M.
    Require Import GoodOptimizer.
    Module Import GoodOptimizerMake := Make E.
    Require Import AutoSep.

    Lemma result_ok_2 :
      forall modules imports,
        GoodToLink_bool modules imports = true ->
        forall opt (opt_g: GoodOptimizer opt),
          moduleOk (result modules imports opt_g).
    Proof.
      intros.
      eapply GoodToLink_bool_sound in H.
      Require Import GeneralTactics.
      openhyp.
      eapply result_ok; eauto.
    Qed.

  End Make.
*)
End Make.


(* Distributed under the terms of the MIT license. *)
Require Import ssreflect ssrbool.
Require PeanoNat.
From MetaCoq.Utils Require Import utils.
From MetaCoq.Common Require Import config Reflect.
From MetaCoq.Template Require Import Ast AstUtils Induction UnivSubst WfAst Typing.
From Equations Require Import Equations.

Implicit Types (cf : checker_flags).

Existing Class wf.

(** * Well-formedness of terms and types in typing derivations

  The internal representation of terms is not canonical, so we show
  that only well-formed terms and types can appear in typing derivations
  and the global context.
*)

Lemma All_local_env_wf_decl Σ :
  forall (Γ : context),
    All (wf_decl Σ) Γ -> All_local_env (wf_decl_pred Σ) Γ.
Proof.
  intros Γ X.
  induction Γ in X |- *.
  - constructor; eauto.
  - destruct a as [na [body|] ty].
    + econstructor.
      * apply IHΓ. inv X; eauto.
      * red. inv X. split.
        -- apply X0.
        -- constructor.
      * red. inv X. eauto.
    + econstructor.
      * apply IHΓ. inv X; eauto.
      * red. inv X. split.
        -- apply X0.
        -- constructor.
Qed.

Lemma on_global_decl_impl `{checker_flags} Σ P Q kn d :
  (forall Σ Γ t T, on_global_env cumul_gen P Σ.1 -> P Σ Γ t T -> Q Σ Γ t T) ->
  on_global_env cumul_gen P Σ.1 ->
  on_global_decl cumul_gen P Σ kn d -> on_global_decl cumul_gen Q Σ kn d.
Proof.
  unfold on_global_env.
  intros X X0 o.
  destruct d; simpl.
  - destruct c; simpl. destruct cst_body0; simpl in *.
    red in o |- *. simpl in *. now eapply X.
    red in o |- *. simpl in *. now eapply X.
  - simpl in *.
    destruct o as [onI onP onNP].
    constructor; auto.
    -- eapply Alli_impl. exact onI. eauto. intros.

       refine {| ind_arity_eq := X1.(ind_arity_eq);
                 ind_cunivs := X1.(ind_cunivs) |}.
       --- apply onArity in X1. unfold on_type in *; simpl in *.
           now eapply X.
       --- pose proof X1.(onConstructors) as X11. red in X11.
           eapply All2_impl; eauto.
           simpl. intros. destruct X2 as [? ? ? ?]; unshelve econstructor; eauto.
           * apply X; eauto.
           * clear -X0 X on_cargs. revert on_cargs.
              generalize (cstr_args x0), y.
              induction c; destruct y0; simpl; auto;
              destruct a as [na [b|] ty]; simpl in *; auto;
           split; intuition eauto.
           * clear -X0 X on_cindices.
             revert on_cindices.
             generalize (List.rev (lift_context #|cstr_args x0| 0 (ind_indices x))).
             generalize (cstr_indices x0).
             induction 1; simpl; constructor; auto.
       --- simpl; intros. apply (onProjections X1).
       --- destruct X1. simpl. unfold check_ind_sorts in *.
           destruct Universe.is_prop; auto.
           destruct Universe.is_sprop; auto.
           split. apply ind_sorts. destruct indices_matter; auto.
           eapply type_local_ctx_impl. eapply ind_sorts. auto.
       --- apply (onIndices X1).
    -- red in onP. red.
       eapply All_local_env_impl. eauto.
       intros. now apply X.
Qed.

Lemma on_global_env_impl `{checker_flags} Σ P Q :
  (forall Σ Γ t T, on_global_env cumul_gen P Σ.1 -> P Σ Γ t T -> Q Σ Γ t T) ->
  on_global_env cumul_gen P Σ -> on_global_env cumul_gen Q Σ.
Proof.
  destruct Σ as [univs Σ]; cbn.
  intros X [cu X0]; split => /= //. cbn in *.
  induction X0; try destruct o; constructor; auto; constructor; eauto.
  clear IHX0.
  eapply on_global_decl_impl; tea. split => //.
Qed.

Lemma All_local_env_wf_decl_inv Σ (a : context_decl) (Γ : list context_decl)
         (X : All_local_env (wf_decl_pred Σ) (a :: Γ)) :
    on_local_decl (wf_decl_pred Σ) Γ a * All_local_env (wf_decl_pred Σ) Γ.
Proof.
  inv X; intuition; red; simpl; eauto.
Qed.

Lemma unfold_fix_wf:
  forall Σ (mfix : mfixpoint term) (idx : nat) (narg : nat) (fn : term),
    unfold_fix mfix idx = Some (narg, fn) ->
    WfAst.wf Σ (tFix mfix idx) ->
    WfAst.wf Σ fn.
Proof.
  intros Σ mfix idx narg fn Hf Hwf.
  unfold unfold_fix in Hf. inv Hwf.
  destruct nth_error eqn:eqnth; try congruence.
  pose proof (nth_error_all eqnth X) as [ _ wfd].
  injection Hf. intros <- <-.
  apply wf_subst; auto. clear wfd Hf eqnth.
  assert(forall n, WfAst.wf Σ (tFix mfix n)). constructor; auto.
  unfold fix_subst. generalize #|mfix|; intros. induction n; auto.
Qed.

Lemma unfold_cofix_wf Σ:
  forall (mfix : mfixpoint term) (idx : nat) (narg : nat) (fn : term),
    unfold_cofix mfix idx = Some (narg, fn) ->
    WfAst.wf Σ (tCoFix mfix idx) -> WfAst.wf Σ fn.
Proof.
  intros mfix idx narg fn Hf Hwf.
  unfold unfold_cofix in Hf. inv Hwf.
  destruct nth_error eqn:eqnth; try congruence.
  pose proof (nth_error_all eqnth X) as [_ wfd].
  injection Hf. intros <- <-.
  apply wf_subst; auto. clear wfd Hf eqnth.
  assert(forall n, WfAst.wf Σ (tCoFix mfix n)). constructor; auto.
  unfold cofix_subst. generalize #|mfix|; intros. induction n; auto.
Qed.

Lemma red1_isLambda Σ Γ t u :
  red1 Σ Γ t u -> isLambda t -> isLambda u.
Proof.
  induction 1 using red1_ind_all; simpl; try discriminate; auto.
Qed.

Lemma OnOne2_All_All {A} {P Q} {l l' : list A} :
  OnOne2 P l l' ->
  (forall x y, P x y -> Q x -> Q y) ->
  All Q l -> All Q l'.
Proof. intros Hl H. induction Hl; intros H'; inv H'; constructor; eauto. Qed.

Lemma All_mapi {A B} (P : B -> Type) (l : list A) (f : nat -> A -> B) :
  Alli (fun i x => P (f i x)) 0 l -> All P (mapi f l).
Proof.
  unfold mapi. generalize 0.
  induction 1; constructor; auto.
Qed.

Lemma Alli_id {A} (P : nat -> A -> Type) n (l : list A) :
  (forall n x, P n x) -> Alli P n l.
Proof.
  intros H. induction l in n |- *; constructor; auto.
Qed.

Lemma All_Alli {A} {P : A -> Type} {Q : nat -> A -> Type} {l n} :
  All P l ->
  (forall n x, P x -> Q n x) ->
  Alli Q n l.
Proof. intro H. revert n. induction H; constructor; eauto. Qed.

Ltac wf := intuition try (eauto with wf || congruence || solve [constructor]).
#[global]
Hint Unfold wf_decl vass vdef : wf.
#[global]
Hint Extern 10 => progress simpl : wf.
#[global]
Hint Unfold snoc : wf.
#[global]
Hint Extern 3 => apply wf_lift || apply wf_subst || apply wf_subst_instance : wf.
#[global]
Hint Extern 10 => constructor : wf.
#[global]
Hint Resolve All_skipn : wf.

Lemma on_global_decls_extends_not_fresh {cf} {univs retro} k (Σ : global_declarations) k' (Σ' : global_declarations) P :
  on_global_decls cumul_gen P univs retro ((k :: Σ) ++ [k'] ++ Σ') -> k.1 = k'.1 -> False.
Proof.
  intros H eq.
  depelim H. destruct o as [f ? ? ?].
  eapply Forall_app in f as [_ f].
  depelim f. cbn in *. subst. contradiction.
Qed.

Lemma lookup_env_extends {cf : checker_flags} (Σ : global_env) k d (Σ' : global_env) P :
  on_global_env cumul_gen P Σ' ->
  lookup_env Σ k = Some d ->
  extends Σ Σ' -> lookup_env Σ' k = Some d.
Proof.
  intro H; eapply lookup_env_extends_NoDup, NoDup_on_global_decls, H.
Qed.

Lemma In_lookup_globals k decls : In k (map fst decls) -> #| lookup_globals decls k | >= 1.
Proof.
  induction decls; cbn => //.
  case_eq (k == a.1).
  - intros e _. cbn. lia.
  - intros e [].
   + rewrite H in e. rewrite eqb_refl in e. inversion e.
   + now apply IHdecls.
Qed.

Lemma NoDup_extends (Σ : global_env) (Σ' : global_env) :
        NoDup (map fst (declarations Σ')) -> extends Σ Σ' -> NoDup (map fst (declarations Σ)).
Proof.
  intros Hl [_ Hex _].
  destruct Σ, Σ'; cbn in *. clear - Hl Hex.
  induction declarations0; cbn in *; econstructor.
  - intros H. specialize (Hex a.1). destruct Hex as [decls Hdecls].
    pose proof (NoDup_length_lookup_globals _ Hl a.1).
    rewrite eqb_refl in Hdecls. apply In_lookup_globals in H.
    rewrite Hdecls in H0. rewrite app_length in H0. cbn in H0.
    destruct lookup_global; lia.
  - eapply IHdeclarations0. intros. specialize (Hex c).
    destruct Hex as [decls Hdecls]. case_eq (c == a.1).
    + intros e. exists (decls ++ [a.2]). rewrite Hdecls e.
      now rewrite <- app_assoc.
    + intros e. exists decls. now rewrite Hdecls e.
Qed.

Lemma declared_env_extends {cf : checker_flags} (Σ : global_env) k d (Σ' : global_env) P :
  on_global_env cumul_gen P Σ' ->
  In (k, InductiveDecl d) (declarations Σ) -> extends Σ Σ' -> In (k,InductiveDecl d) (declarations Σ').
Proof.
  intros; apply lookup_global_Some_iff_In_NoDup.
  - destruct X; eapply NoDup_on_global_decls; eauto.
  - eapply lookup_env_extends; eauto.
    destruct X; eapply lookup_global_Some_iff_In_NoDup; eauto.
    eapply NoDup_extends; eauto.
    now eapply NoDup_on_global_decls.
Qed.

Lemma wf_extends {cf} {Σ : global_env} T {Σ' : global_env} P :
  on_global_env cumul_gen P Σ' -> WfAst.wf Σ T -> extends Σ Σ' -> WfAst.wf Σ' T.
Proof.
  intros wfΣ'.
  induction 1 using term_wf_forall_list_ind; try solve [econstructor; eauto; solve_all].
  - intros. destruct H. destruct X0.
    unfold declared_minductive in H.
    eapply declared_env_extends in H; tea.
    econstructor; repeat split; eauto; solve_all.
Qed.

Lemma wf_decl_extends {cf} {Σ : global_env} T {Σ' : global_env} P :
  on_global_env cumul_gen P Σ' -> wf_decl Σ T -> extends Σ Σ' -> wf_decl Σ' T.
Proof.
  intros wf [] ext. red. destruct decl_body; split; eauto using wf_extends.
Qed.

Arguments lookup_on_global_env {H} {Pcmp P Σ c decl}.

Lemma declared_inductive_wf {cf:checker_flags} {Σ : global_env} ind
         (mdecl : mutual_inductive_body) (idecl : one_inductive_body) :
  on_global_env cumul_gen wf_decl_pred Σ ->
  declared_inductive Σ ind mdecl idecl -> WfAst.wf Σ (ind_type idecl).
Proof.
  intros.
  destruct H as [Hmdecl Hidecl]. red in Hmdecl.
  eapply lookup_global_Some_iff_In_NoDup in  Hmdecl; eauto.
  2: destruct X; now eapply NoDup_on_global_decls.
  destruct (lookup_on_global_env X Hmdecl) as [Σ' [wfΣ' [ext prf]]]; eauto.
  apply onInductives in prf.
  eapply nth_error_alli in Hidecl; eauto.
  eapply onArity in Hidecl.
  destruct Hidecl.
  eapply wf_extends in w; tea; typeclasses eauto.
Qed.

Lemma wf_it_mkProd_or_LetIn Σ Γ t
  : WfAst.wf Σ (it_mkProd_or_LetIn Γ t) -> All (wf_decl Σ) Γ * WfAst.wf Σ t.
Proof.
  revert t. induction Γ; [simpl; auto with wf|]. intros t XX.
  destruct a, decl_body; simpl in *.
  apply IHΓ in XX as []. depelim w; simpl in *; split; auto with wf.
  apply IHΓ in XX as []. depelim w. simpl in *.
  split; auto. constructor; auto with wf.
Qed.

Lemma declared_inductive_wf_indices {cf:checker_flags} {Σ : global_env} {ind mdecl idecl} :
  on_global_env cumul_gen wf_decl_pred Σ ->
  declared_inductive Σ ind mdecl idecl -> All (wf_decl Σ) (ind_indices idecl).
Proof.
  intros.
  destruct H as [Hmdecl Hidecl]. red in Hmdecl.
  eapply lookup_global_Some_iff_In_NoDup in  Hmdecl; eauto.
  2: destruct X; now eapply NoDup_on_global_decls.
  destruct (lookup_on_global_env X Hmdecl) as [Σ' [wfΣ' [ext prf]]]; eauto.
  apply onInductives in prf.
  eapply nth_error_alli in Hidecl; eauto.
  pose proof (onArity Hidecl).
  rewrite Hidecl.(ind_arity_eq) in X0.
  destruct X0 as [s Hs]; wf.
  eapply wf_it_mkProd_or_LetIn in s as [? H].
  eapply wf_it_mkProd_or_LetIn in H as [].
  solve_all. eapply wf_decl_extends; tea; typeclasses eauto.
Qed.

Lemma declared_inductive_wf_ctors {cf:checker_flags} {Σ} {ind} {mdecl idecl} :
  on_global_env cumul_gen wf_decl_pred Σ ->
  declared_inductive Σ ind mdecl idecl ->
  All (fun ctor => All (wf_decl Σ) ctor.(cstr_args)) (ind_ctors idecl).
Proof.
  intros.
  destruct H as [Hmdecl Hidecl]. red in Hmdecl.
  eapply lookup_global_Some_iff_In_NoDup in  Hmdecl; eauto.
  2: destruct X; now eapply NoDup_on_global_decls.
  destruct (lookup_on_global_env X Hmdecl) as [Σ' [wfΣ' [ext prf]]]; eauto.
  apply onInductives in prf.
  eapply nth_error_alli in Hidecl; eauto.
  pose proof (onConstructors Hidecl). red in X0.
  solve_all. destruct X0.
  clear -X ext on_cargs.
  induction (cstr_args x) as [|[na [b|] ty] args] in on_cargs, y |- * ;
    try destruct on_cargs;
   constructor; unfold wf_decl in *; cbn in *; intuition eauto using wf_extends; simpl in *.
   destruct b0. intuition eauto using wf_extends with typeclass_instances.
   destruct a. intuition eauto using wf_extends with typeclass_instances.
   destruct y => //. destruct on_cargs. destruct w; eauto using wf_extends with typeclass_instances.
   destruct y => //. eapply IHargs; intuition eauto.
Qed.

Lemma All_local_env_wf_decls Σ ctx :
  TemplateEnvTyping.All_local_env (wf_decl_pred Σ) ctx ->
  All (wf_decl Σ) ctx.
Proof.
  induction 1; constructor; auto.
  destruct t0 as [s Hs]. split; simpl; intuition auto.
Qed.

Lemma on_global_inductive_wf_params {cf:checker_flags} {Σ : global_env_ext} {kn mdecl} :
  on_global_decl cumul_gen (fun Σ : global_env_ext => wf_decl_pred Σ) Σ kn (InductiveDecl mdecl) ->
  All (wf_decl Σ) (ind_params mdecl).
Proof.
  intros prf.
  apply onParams in prf. red in prf.
  apply All_local_env_wf_decls in prf.
  solve_all.
Qed.

Lemma destArity_spec ctx T :
  match destArity ctx T with
  | Some (ctx', s) => it_mkProd_or_LetIn ctx T = it_mkProd_or_LetIn ctx' (tSort s)
  | None => True
  end.
Proof.
  induction T in ctx |- *; simpl; try easy.
  - specialize (IHT2 (ctx,, vass na T1)). now destruct destArity.
  - specialize (IHT3 (ctx,, vdef na T1 T2)). now destruct destArity.
Qed.

Lemma destArity_it_mkProd_or_LetIn ctx ctx' t :
  destArity ctx (it_mkProd_or_LetIn ctx' t) =
  destArity (ctx ,,, ctx') t.
Proof.
  induction ctx' in ctx, t |- *; simpl; auto.
  rewrite IHctx'. destruct a as [na [b|] ty]; reflexivity.
Qed.

Lemma it_mkProd_or_LetIn_inj ctx s ctx' s' :
  it_mkProd_or_LetIn ctx (tSort s) = it_mkProd_or_LetIn ctx' (tSort s') ->
  ctx = ctx' /\ s = s'.
Proof.
  move/(f_equal (destArity [])).
  rewrite !destArity_it_mkProd_or_LetIn /=.
  now rewrite !app_context_nil_l => [= -> ->].
Qed.

(*
Lemma case_predicate_contextP ind mdecl idecl params uinst pctx :
  build_case_predicate_context ind mdecl idecl params uinst = Some pctx <~>
  case_predicate_context ind mdecl idecl params uinst pctx.
Proof.
  unfold build_case_predicate_context.
  unfold instantiate_params.
  destruct instantiate_params_subst as [[ictx p]|] eqn:ipars => /= //.
  2:{ split => //. intros H. depelim H.
      eapply instantiate_params_substP in i.
      rewrite ipars in i. discriminate. }
  move: (destArity_spec [] (subst0 ictx p)).
  destruct destArity as [[idctx inds]|] eqn:da => //.
  simpl. intros eqs.
  split.
  eapply instantiate_params_substP in ipars.
  intros [= <-]. econstructor. eauto. eauto.
  intros H. depelim H. subst sty.
  eapply instantiate_params_substP in i.
  rewrite ipars in i. noconf i. rewrite eqs in e.
  eapply it_mkProd_or_LetIn_inj in e as [<- <-].
  reflexivity.
  split => // [] [] s ty ictxt inds.
  move/instantiate_params_substP.
  rewrite ipars /= => [=] <- <- H.
  rewrite H destArity_it_mkProd_or_LetIn in da.
  noconf da.
Qed.
*)

Lemma wf_subst_context Σ s k Γ : All (wf_decl Σ) Γ -> All (WfAst.wf Σ) s -> All (wf_decl Σ) (subst_context s k Γ).
Proof.
  intros wfΓ. induction wfΓ in s |- *.
  - intros. constructor.
  - rewrite subst_context_snoc. constructor; auto.
    destruct p. destruct x as [? [] ?]; constructor; simpl in *; wf.
Qed.

Lemma wf_smash_context Σ Γ Δ : All (wf_decl Σ) Γ -> All (wf_decl Σ) Δ ->
  All (wf_decl Σ) (smash_context Δ Γ).
Proof.
  intros wfΓ; induction wfΓ in Δ |- *; intros wfΔ; simpl; auto.
  destruct x as [? [] ?]; simpl. apply IHwfΓ.
  eapply wf_subst_context; auto. constructor; auto. apply p.
  eapply IHwfΓ. apply All_app_inv; auto.
Qed.

Section WfAst.
  Context {cf:checker_flags}.
  Context {Σ : global_env}.

  Lemma wf_reln n acc Γ : All (WfAst.wf Σ) acc -> All (WfAst.wf Σ) (reln acc n Γ).
  Proof using Type.
    induction Γ in acc, n |- * => wfacc /= //.
    destruct a as [? [|] ?] => //. now eapply IHΓ.
    eapply IHΓ. constructor; auto. constructor.
  Qed.

  #[local]
  Hint Resolve wf_reln : wf.

  (* Lemma wf_instantiate_params_subst_spec params pars s ty s' ty' :
    instantiate_params_subst_spec params pars s ty s' ty' ->
    All (wf_decl Σ) params ->
    WfAst.wf Σ ty ->
    All (WfAst.wf Σ) pars ->
    All (WfAst.wf Σ) s ->
    All (WfAst.wf Σ) s' * WfAst.wf Σ ty'.
  Proof.
    intros ipars. induction ipars; intros wfparams wfty wfpars wfs => //.
    depelim wfparams. depelim wfpars. depelim wfty.
    apply IHipars; auto.
    depelim wfparams. depelim wfty. destruct H; simpl in *.
    apply IHipars; auto with wf.
  Qed. *)

  Lemma wf_map2_set_binder_name l l' :
    All (wf_decl Σ) l' ->
    All (wf_decl Σ) (map2 set_binder_name l l').
  Proof using Type.
    induction 1 in l |- *; destruct l; simpl; constructor.
    apply p. apply IHX.
  Qed.

  Definition lift_context_snoc0 n k Γ d : lift_context n k (d :: Γ) = lift_context n k Γ ,, lift_decl n (#|Γ| + k) d.
  Proof using Type. unfold lift_context. now rewrite fold_context_k_snoc0. Qed.
  Hint Rewrite lift_context_snoc0 : lift.

  Lemma lift_context_snoc n k Γ d : lift_context n k (Γ ,, d) = lift_context n k Γ ,, lift_decl n (#|Γ| + k) d.
  Proof using Type.
    unfold snoc. apply lift_context_snoc0.
  Qed.
  Hint Rewrite lift_context_snoc : lift.

  Lemma wf_lift_context n k Γ : All (wf_decl Σ) Γ -> All (wf_decl Σ) (lift_context n k Γ).
  Proof using Type.
    intros wfΓ. induction wfΓ in n, k |- *.
    - intros. constructor.
    - rewrite lift_context_snoc0. constructor; auto.
      destruct p. destruct x as [? [] ?]; constructor; simpl in *; wf.
  Qed.

  Lemma wf_subst_instance_context u Γ :
    All (wf_decl Σ) Γ ->
    All (wf_decl Σ) (subst_instance u Γ).
  Proof using Type.
    induction 1; constructor; auto.
    destruct x as [na [b|] ty]; simpl in *.
    destruct p. now split; apply wf_subst_instance.
    destruct p. now split; auto; apply wf_subst_instance.
  Qed.

  Lemma wf_extended_subst Γ n :
    All (wf_decl Σ) Γ ->
    All (WfAst.wf Σ) (extended_subst Γ n).
  Proof using Type.
    induction 1 in n |- *.
    - simpl; constructor.
    - destruct x as [na [b|] ty]; simpl; constructor; auto.
      2:constructor.
      eapply wf_subst; auto.
      eapply wf_lift. apply p.
  Qed.

  Lemma wf_case_predicate_context ind mdecl idecl p :
    declared_inductive Σ ind mdecl idecl ->
    All (wf_decl Σ) mdecl.(ind_params) ->
    All (wf_decl Σ) (ind_indices idecl) ->
    All (WfAst.wf Σ) p.(pparams) ->
    All (wf_decl Σ) (case_predicate_context ind mdecl idecl p).
  Proof using Type.
    intros decl wfparams wfindty wfpars.
    unfold case_predicate_context. destruct p.
    apply wf_map2_set_binder_name.
    unfold pre_case_predicate_context_gen. cbn [Ast.pparams Ast.puinst].
    unfold inst_case_context.
    eapply wf_subst_context => //.
    2:now eapply All_rev.
    apply wf_subst_instance_context.
    rewrite /ind_predicate_context.
    constructor.
    simpl; split; auto. simpl. auto. simpl.
    eapply wf_mkApps. now econstructor.
    apply wf_reln. constructor.
    eapply wf_subst_context.
    now apply wf_lift_context.
    now apply wf_extended_subst.
  Qed.

  Lemma Forall_decls_on_global_wf :
    Forall_decls_typing
      (fun (Σ : global_env_ext) (_ : context) (t T : term) =>
      WfAst.wf Σ t * WfAst.wf Σ T) Σ ->
    on_global_env cumul_gen wf_decl_pred Σ.
  Proof using Type.
    apply on_global_env_impl => Σ' Γ t []; simpl; unfold wf_decl_pred;
    intros; auto. destruct X0 as [s []]; intuition auto.
  Qed.

  (* Hint Resolve on_global_wf_Forall_decls : wf. *)
  Lemma wf_inds mind u mdecl :
    All (WfAst.wf Σ) (inds mind u mdecl.(ind_bodies)).
  Proof using Type.
    unfold inds. induction #|ind_bodies mdecl|; constructor; auto.
    now constructor.
  Qed.

  Hint Resolve wf_inds : wf.

  Lemma on_inductive_wf_params {Σ' : global_env_ext} {kn mdecl} :
      forall (oib : on_inductive cumul_gen wf_decl_pred Σ'  kn mdecl),
      All (wf_decl Σ') (ind_params mdecl).
  Proof using Type.
    intros oib. apply onParams in oib.
    red in oib.
    induction (ind_params mdecl) as [|[? [] ?] ?]; simpl in oib; inv oib; constructor;
      try red in X0; try red in X1; try red; simpl; intuition auto.
  Qed.

  Lemma declared_inductive_wf_params {ind mdecl idecl} :
    on_global_env cumul_gen wf_decl_pred Σ ->
    declared_inductive Σ ind mdecl idecl -> All (wf_decl Σ) (ind_params mdecl).
  Proof using Type.
    intros.
    destruct H as [Hmdecl Hidecl]. red in Hmdecl.
    eapply lookup_global_Some_iff_In_NoDup in  Hmdecl; eauto.
    2: destruct X; now eapply NoDup_on_global_decls.
      destruct (lookup_on_global_env X Hmdecl) as [Σ' [wfΣ' [ext prf]]]; eauto.
    eapply on_global_inductive_wf_params in prf.
    solve_all. eapply wf_decl_extends; tea; typeclasses eauto.
  Qed.

  Lemma declared_constructor_wf
    (ind : inductive) (i : nat) (u : list Level.t)
          (mdecl : mutual_inductive_body) (idecl : one_inductive_body) (cdecl : constructor_body) :
      on_global_env cumul_gen wf_decl_pred Σ ->
      declared_constructor Σ (ind, i) mdecl idecl cdecl ->
      WfAst.wf Σ (cstr_type cdecl).
  Proof using Type.
    intros X isdecl.
    destruct isdecl as [[Hmdecl Hidecl] Hcdecl]. red in Hmdecl.
    eapply lookup_global_Some_iff_In_NoDup in  Hmdecl; eauto.
    2: destruct X; now eapply NoDup_on_global_decls.
      destruct (lookup_on_global_env X Hmdecl) as [Σ' [wfΣ' [ext prf]]]; eauto. red in prf.
    apply onInductives in prf.
    eapply nth_error_alli in Hidecl; eauto. simpl in *.
    pose proof (onConstructors Hidecl) as h. unfold on_constructors in h.
    eapply All2_nth_error_Some in Hcdecl. 2: eassumption.
    destruct Hcdecl as [cs [Hnth [? ? [? ?]]]].
    eapply wf_extends; tea; typeclasses eauto.
  Qed.

  Lemma wf_case_branch_context_gen {ind mdecl idecl cdecl p br} :
    on_global_env cumul_gen wf_decl_pred Σ ->
    declared_constructor Σ ind mdecl idecl cdecl ->
    All (WfAst.wf Σ) (pparams p) ->
    All (fun ctor => All (wf_decl Σ) (cstr_args ctor)) (ind_ctors idecl) ->
    All (wf_decl Σ) (case_branch_context (fst ind) mdecl cdecl p br).
  Proof using Type.
    intros ong decli wfpars.
    intros Hforall.
    destruct decli as [decli hcstr].
    eapply nth_error_all in Hforall; tea. cbn in Hforall.
    unfold case_branch_context, case_branch_context_gen.
    eapply wf_map2_set_binder_name.
    apply wf_subst_context; auto.
    apply wf_subst_instance_context.
    rewrite /cstr_branch_context.
    unfold expand_lets_ctx, expand_lets_k_ctx.
    eapply wf_subst_context.
    eapply wf_lift_context.
    eapply wf_subst_context => //.
    eapply wf_inds.
    apply wf_extended_subst.
    eapply declared_inductive_wf_params in decli => //.
    now eapply All_rev.
  Qed.

  Lemma wf_case_branches_context ind mdecl idecl p brs :
    on_global_env cumul_gen wf_decl_pred Σ ->
    declared_inductive Σ ind mdecl idecl ->
    All (WfAst.wf Σ) (pparams p) ->
    All (fun ctor => All (wf_decl Σ) (cstr_args ctor)) (ind_ctors idecl) ->
    All (fun ctx => All (wf_decl Σ) ctx) (case_branches_contexts ind mdecl idecl p brs).
  Proof using Type.
    intros ong decli wfpars.
    unfold case_branches_contexts.
    intros Hforall.
    induction Hforall in brs |- *; destruct brs; cbn; constructor; auto.
    unfold case_branch_context_gen.
    eapply wf_map2_set_binder_name.
    apply wf_subst_context; auto.
    apply wf_subst_instance_context.
    2:now eapply All_rev.
    rewrite /cstr_branch_context.
    unfold expand_lets_ctx, expand_lets_k_ctx.
    eapply wf_subst_context.
    eapply wf_lift_context.
    eapply wf_subst_context => //.
    eapply wf_inds.
    apply wf_extended_subst.
    now eapply declared_inductive_wf_params in decli.
  Qed.

End WfAst.

Record wf_inductive_body Σ idecl := {
  wf_ind_type : WfAst.wf Σ (ind_type idecl);
  wf_ind_indices : All (WfAst.wf_decl Σ) (ind_indices idecl);
  wf_ind_ctors : All (fun cdecl => WfAst.wf Σ (cstr_type cdecl)) (ind_ctors idecl);
  wf_ind_ctor_args : All (fun cs => All (wf_decl Σ) (cstr_args cs)) idecl.(ind_ctors);
  wf_ind_ctors_indices : All (fun cdecl => All (WfAst.wf Σ) (cstr_indices cdecl)) (ind_ctors idecl);
  wf_ind_projs : All (fun pdecl => WfAst.wf Σ pdecl.(proj_type)) (ind_projs idecl)
}.

Section WfLookup.
  Context {cf:checker_flags}.
  Context {Σ : global_env_ext}.

  Lemma wf_projs ind npars p : All (WfAst.wf Σ) (projs ind npars p).
  Proof using Type.
    unfold projs. induction p; constructor; wf.
  Qed.

  Lemma on_global_inductive_wf_bodies {kn mdecl} :
    on_global_decl cumul_gen wf_decl_pred Σ kn (InductiveDecl mdecl) ->
    All (wf_inductive_body Σ) mdecl.(ind_bodies).
  Proof using Type.
    cbn. intros oni.
    have wfpars : All (wf_decl Σ) (ind_params mdecl).
    { now eapply on_inductive_wf_params in oni. }
    eapply onInductives in oni.
    solve_all.
    induction oni; constructor; auto.
    clear oni IHoni.
    destruct p.

    have wfargs : All (fun cs => All (wf_decl Σ) (cstr_args cs)) hd.(ind_ctors).
    { unfold on_constructors in onConstructors.
      clear -onConstructors.
      induction onConstructors; constructor; auto.
      destruct r.
      clear -on_cargs.
      revert on_cargs. revert y. generalize (cstr_args x).
      induction c as [|[? [] ?] ?]; simpl;
        destruct y; intuition auto;
        constructor;
        try red; simpl; try red in a0, b0; intuition eauto.
        now red in b. }
    split => //.
    - now destruct onArity.
    - rewrite ind_arity_eq in onArity .
      destruct onArity as [ona _].
      eapply wf_it_mkProd_or_LetIn in ona as [_ ona].
      now eapply wf_it_mkProd_or_LetIn in ona as [].
    - unfold on_constructors in onConstructors.
      clear -onConstructors.
      induction onConstructors; constructor; auto.
      destruct r.
      eapply on_ctype.
    - unfold on_constructors in onConstructors.
      clear -onConstructors.
      induction onConstructors; constructor; auto.
      destruct r.
      rewrite cstr_eq in on_ctype.
      destruct on_ctype as [wf _].
      eapply wf_it_mkProd_or_LetIn in wf as [_ wf].
      eapply wf_it_mkProd_or_LetIn in wf as [_ wf].
      rewrite /cstr_concl in wf.
      eapply wf_mkApps_inv in wf.
      now apply All_app in wf as [].
    - rename onProjections into on_projs.
      destruct (ind_projs hd) eqn:eqprojs. constructor.
      destruct (ind_ctors hd) as [|? [|]] eqn:Heq; try contradiction.
      destruct on_projs. rewrite eqprojs in on_projs.
      solve_all. eapply Alli_All; tea.
      intros. red in H.
      destruct (nth_error (smash_context _ _) _) eqn:Heq'; try contradiction.
      simpl in Heq. inv wfargs. clear X0.
      destruct H as [onna ->].
      eapply wf_subst.
      eapply wf_inds. eapply wf_subst.
      eapply wf_projs.
      eapply wf_lift.
      eapply All_app_inv in wfpars; [|eapply X].
      eapply (wf_smash_context _ _ []) in wfpars.
      2:constructor.
      eapply nth_error_all in Heq'; eauto.
      apply Heq'.
  Qed.

End WfLookup.

Lemma OnOne2All_All2_All2 (A B C : Type) (P : B -> A -> A -> Type) (Q : C -> A -> Type)
	(i : list B) (j : list C) (R : B -> Type) (l l' : list A) :
  OnOne2All P i l l' ->
  All2 Q j l ->
  All R i ->
  (forall x y a b, R x -> P x a b -> Q y a -> Q y b) ->
  All2 Q j l'.
Proof.
  induction 1 in j |- *; intros.
  depelim X. depelim X0. constructor; eauto.
  depelim X0. depelim X1.
  constructor; auto.
Qed.

Section WfRed.
  Context {cf:checker_flags}.
  Context {Σ : global_env}.

  Lemma wf_red1 Γ M N :
    on_global_env cumul_gen wf_decl_pred Σ ->
    All (wf_decl Σ) Γ ->
    WfAst.wf Σ M ->
    red1 Σ Γ M N ->
    WfAst.wf Σ N.
  Proof using Type.
    intros wfΣ wfΓ wfM H.
    induction H using red1_ind_all in wfM, wfΓ |- *.
    all: inv wfM.
    all: try solve[ constructor; intuition auto with wf ].
    all:auto.

    - inv X. inv X0.
      eauto with wf.
    - auto with wf.
    - apply wf_lift.
      unfold option_map in H. destruct nth_error eqn:Heq; try discriminate.
      eapply nth_error_all in wfΓ; eauto. unfold wf_decl in *.
      apply some_inj in H; rewrite H in wfΓ; apply wfΓ.
    - unfold iota_red.
      eapply wf_mkApps_inv in X2.
      apply wf_subst. eapply All_rev. now eapply All_skipn.
      rewrite /expand_lets /expand_lets_k.
      apply wf_subst. apply wf_extended_subst. rewrite /bctx.
      eapply (wf_case_branch_context_gen (ind := (ci_ind ci, c))); tea.
      eapply declared_inductive_wf_ctors; tea. apply H0.
      eapply wf_lift. solve_all.
      now eapply All2_nth_error_Some_r in X3 as [cb [? []]]; tea.
    - eapply unfold_fix_wf in H; eauto. eapply wf_mkApps; auto.
    - econstructor; eauto. apply wf_mkApps_napp in X2 as [Hcof Hargs]; auto.
      eapply unfold_cofix_wf in H; eauto.
      apply wf_mkApps; intuition auto.
    - constructor; auto. apply wf_mkApps_napp in X as [Hcof Hargs]; auto.
      eapply unfold_cofix_wf in H; eauto.
      apply wf_mkApps; intuition auto.
    - apply wf_subst_instance.
      unfold declared_constant in H.
      eapply lookup_global_Some_iff_In_NoDup in H; eauto.
      2: destruct wfΣ; now eapply NoDup_on_global_decls.
      eapply lookup_on_global_env in H as [Σ' [onΣ' [ext prf]]]; eauto.
      destruct decl; simpl in *.
      subst cst_body0; simpl in *; unfold on_constant_decl in prf; cbn in prf.
      unfold wf_decl_pred in prf. intuition eauto using wf_extends with typeclass_instances.
    - apply wf_mkApps_inv in X.
      eapply nth_error_all in X; eauto.
    - simpl in *. econstructor; eauto. cbn.
      now rewrite -(OnOne2_length X).
      cbn. clear H1. induction X; constructor; inv X1; intuition auto.
    - econstructor; eauto; simpl in *.
      apply IHred1; eauto.
      apply All_app_inv => //.
      apply wf_case_predicate_context; auto.
      eapply declared_inductive_wf_params in isdecl; eauto.
      eapply declared_inductive_wf_indices; eauto; wf.
    - econstructor; eauto.
    - econstructor; eauto.
      assert (wf := wf_case_branches_context _ _ _ _ brs wfΣ isdecl X1).
      forward wf.
      eapply declared_inductive_wf_ctors; eauto; wf.
      solve_all.
      eapply OnOne2All_All2_All2; tea. cbn. intuition auto.
      now rewrite b0 in a1.
      apply b2 => //.
      apply All_app_inv => //.
    - now eapply wf_mkApps.
    - constructor; auto. induction X; auto; congruence.
      clear H X0 H0. induction X; inv X1; constructor; intuition auto; try congruence.
    - constructor.
      induction X; inv X0; constructor; intuition auto.
    - constructor; auto.
      induction X; inv X0; constructor; intuition auto; congruence.
    - constructor; auto. solve_all.
      pose proof X0 as H'. revert X0.
      apply (OnOne2_All_All X). clear X.
      intros [na bo ty ra] [nb bb tb rb] [[r ih] e] [? ?].
      simpl in *.
      inversion e. subst. clear e.
      intuition eauto.
      eapply ih. 2: assumption.
      solve_all.
      apply All_app_inv. 2: assumption.
      unfold fix_context. apply All_rev. eapply All_mapi.
      eapply All_Alli. 1: exact H'.
      cbn. unfold wf_decl. simpl.
      intros ? [? ? ? ?] ?. simpl in *.
      intuition eauto with wf.
    - constructor; auto.
      induction X; inv X0; constructor; intuition auto; congruence.
    - constructor; auto. solve_all.
      pose proof X0 as H'. revert X0.
      apply (OnOne2_All_All X). clear X.
      intros [na bo ty ra] [nb bb tb rb] [[r ih] e] [? ?].
      simpl in *.
      inversion e. subst. clear e.
      intuition eauto.
      eapply ih. 2: assumption.
      solve_all. apply All_app_inv. 2: assumption.
      unfold fix_context. apply All_rev. eapply All_mapi.
      eapply All_Alli. 1: exact H'.
      cbn. unfold wf_decl. simpl.
      intros ? [? ? ? ?] ?. simpl in *.
      intuition eauto with wf.
  Qed.

  Lemma wf_lift_wf n k t : WfAst.wf Σ (lift n k t) -> WfAst.wf Σ t.
  Proof using Type.
    induction t in n, k |- * using term_forall_list_rect; simpl in *;
      intros Hwf; inv Hwf; try constructor; eauto;
        repeat (unfold snd, on_snd in *; simpl in *; solve_all).

    - destruct t; try reflexivity. discriminate.
    - destruct l; simpl in *; congruence.
    - eapply All2_map_right_inv in X5. econstructor; eauto; solve_all.
      now rewrite map_length in H1.
  Qed.

  Lemma declared_projection_wf (p : projection)
          (mdecl : mutual_inductive_body) (idecl : one_inductive_body) cdecl pdecl :
      declared_projection Σ p mdecl idecl cdecl pdecl ->
      on_global_env cumul_gen wf_decl_pred Σ ->
      WfAst.wf Σ pdecl.(proj_type).
  Proof using Type.
    intros isdecl X.
    destruct isdecl as [[[Hmdecl Hidecl] Hcdecl] Hpdecl].
    eapply lookup_global_Some_iff_In_NoDup in Hmdecl; eauto.
    2: destruct X; now eapply NoDup_on_global_decls.
    destruct (lookup_on_global_env X Hmdecl) as [Σ' [wfΣ' [ext prf]]]; eauto.
    assert (wfpars := on_inductive_wf_params prf).
    eapply on_global_inductive_wf_bodies in prf => //.
    eapply nth_error_all in Hidecl; eauto. intuition auto.
    destruct Hidecl.
    eapply nth_error_all in wf_ind_projs0; eauto. intuition auto.
    eauto using wf_extends with typeclass_instances.
  Qed.

  Lemma declared_constant_wf cst decl :
    on_global_env cumul_gen wf_decl_pred Σ ->
    declared_constant Σ cst decl ->
    WfAst.wf Σ decl.(cst_type) *
    on_some_or_none (WfAst.wf Σ) decl.(cst_body).
  Proof using Type.
    intros wΣ h.
    unfold declared_constant in h.
    eapply lookup_global_Some_iff_In_NoDup in h; eauto.
    2: destruct wΣ; now eapply NoDup_on_global_decls.
    destruct (lookup_on_global_env wΣ h) as [Σ' [wΣ' [ext h']]].
    simpl in h'.
    destruct decl as [ty [bo|]]. all: cbn in *.
    - destruct h'. intuition eauto using wf_extends with typeclass_instances.
    - destruct h'. intuition eauto using wf_extends with typeclass_instances.
  Qed.

  Lemma wf_it_mkProd_or_LetIn_inv (Σ' : global_env_ext) Γ (wfΓ : wf_local Σ' Γ)
    : All_local_env_over typing
    (fun (Σ : global_env_ext) (Γ : context) (_ : wf_local Σ Γ)
      (t T : term) (_ : Σ;;; Γ |- t : T) => WfAst.wf Σ t * WfAst.wf Σ T) Σ'
          Γ wfΓ
  -> forall t, WfAst.wf Σ' t -> WfAst.wf Σ' (it_mkProd_or_LetIn Γ t).
  Proof using Type.
    induction 1; simpl.
    - trivial.
    - intros t0 Ht0. apply IHX. constructor. apply Hs. assumption.
    - intros t0 Ht0. apply IHX. constructor. apply Hc. apply Hc. assumption.
  Qed.

  Lemma wf_Lambda_or_LetIn {d t} :
    wf_decl Σ d ->
    WfAst.wf Σ t ->
    WfAst.wf Σ (mkLambda_or_LetIn d t).
  Proof using Type.
    destruct d as [? [|] ?]; simpl; wf;
    unfold wf_decl, mkLambda_or_LetIn in *; simpl in *.
    constructor; intuition auto.
    constructor; intuition auto.
  Qed.

  Lemma wf_it_mkLambda_or_LetIn {Γ t} :
    All (wf_decl Σ) Γ ->
    WfAst.wf Σ t ->
    WfAst.wf Σ (it_mkLambda_or_LetIn Γ t).
  Proof using Type.
    intros wfΓ wft; induction wfΓ in t, wft |- *; simpl.
    - trivial.
    - apply IHwfΓ. now apply wf_Lambda_or_LetIn.
  Qed.

End WfRed.

#[global]
Hint Resolve wf_extends strictly_extends_decls_extends_decls strictly_extends_decls_extends_strictly_on_decls extends_decls_extends extends_strictly_on_decls_extends : wf.

Lemma All2i_All2 {A B} {P : nat -> A -> B -> Type} {Q : A -> B -> Type} n l l' :
  All2i P n l l' ->
  (forall i x y, P i x y -> Q x y) ->
  All2 Q l l'.
Proof.
  induction 1; constructor; eauto.
Qed.

Lemma cstr_branch_context_length ind mdecl cdecl :
  #|cstr_branch_context ind mdecl cdecl| = #|cdecl.(cstr_args)|.
Proof. rewrite /cstr_branch_context. now len. Qed.

Global Hint Rewrite cstr_branch_context_length : len.

(* Lemma case_branch_context_gen_length ind mdecl p puinst pctx :
  #|case_branch_context_gen ind mdecl p puinst pctx | = #|pctx|. *)

Section TypingWf.
  Context {cf}.

  Ltac specialize_goal :=
    repeat match goal with
    | H : ?P -> _, H' : ?P |- _ => specialize (H H')
    end.

  Lemma typing_wf_gen :
    env_prop
      (fun Σ Γ t T => WfAst.wf Σ t * WfAst.wf Σ T)
      (fun Σ Γ wfΓ => All (wf_decl Σ) Γ).
  Proof using Type.
    apply typing_ind_env; intros; auto with wf;
      specialize_goal;
      try solve [split; try constructor; intuition auto with wf].

    - eapply All_local_env_wf_decls.
      induction X; constructor; auto; red; intuition auto.
    - split; wf. apply wf_lift.
      apply (nth_error_all H X).
    - split. constructor; auto. wf.
      clear -X1.
      induction X1; constructor; now auto.
      destruct X0 as [_ X0].
      clear X H H0.
      induction X1; auto. apply IHX1.
      apply wf_subst. now destruct p0. destruct p. now inv w.
    - split. wf. apply wf_subst_instance. wf.
      eapply lookup_global_Some_iff_In_NoDup in H; eauto.
      2: destruct wfΣ; now eapply NoDup_on_global_decls.
      destruct (lookup_on_global_env X H) as [Σ' [wfΣ' [ext prf]]]; eauto.
      red in prf. destruct decl; destruct cst_body0; red in prf; simpl in *; wf.
      destruct prf as [s []]. wf.

    - split. wf. apply wf_subst_instance.
      eapply declared_inductive_wf; eauto.
      now eapply Forall_decls_on_global_wf.

    - split. wf. unfold type_of_constructor.
      apply wf_subst; auto with wf.
      apply wf_inds.
      apply wf_subst_instance.
      eapply declared_constructor_wf; eauto.
      now eapply Forall_decls_on_global_wf.

    - destruct X3 as [wfret wps].
      destruct X6 as [wfc wfapps].
      eapply wf_mkApps_inv in wfapps.
      eapply All_app in wfapps as [wfp wfindices].
      assert (All (wf_decl Σ) predctx).
      { now apply All_app in X4 as [? ?]. }
      split; [econstructor; simpl; eauto; solve_all|].
      eapply All2i_All2; tea; repeat intuition auto.
      apply wf_mkApps. subst ptm. wf. apply wf_it_mkLambda_or_LetIn; auto.
      apply All_app_inv; auto.
    - split. wf. apply wf_subst. solve_all. constructor. wf.
      apply wf_mkApps_inv in b. apply All_rev. solve_all.
      eapply declared_projection_wf in isdecl; eauto.
      now eapply wf_subst_instance.
      now eapply Forall_decls_on_global_wf.

    - subst types.
      clear H.
      split.
      + constructor.
        solve_all; destruct a, b.
        all: intuition.
      + eapply All_nth_error in X0; eauto.
        destruct X0 as [s ?]; intuition.

    - subst types.
      split.
      + constructor.
        solve_all; destruct a, b.
        all: intuition.
      + eapply All_nth_error in X0; eauto. destruct X0 as [s ?]; intuition.
  Qed.

  Lemma typing_all_wf_decl Σ (wfΣ : wf Σ.1) Γ (wfΓ : wf_local Σ Γ) :
    All (wf_decl Σ.1) Γ.
  Proof using Type.
    eapply (env_prop_wf_local typing_wf_gen); eauto.
  Qed.
  Hint Resolve typing_all_wf_decl : wf.

  Lemma typing_wf_sigma Σ (wfΣ : wf Σ) :
    on_global_env cumul_gen wf_decl_pred Σ.
  Proof using Type.
    intros.
    pose proof (env_prop_sigma typing_wf_gen _ wfΣ). red in X.
    do 2 red in wfΣ.
    eapply on_global_env_impl; eauto; simpl; intros.
    destruct T. red. apply X1. red. destruct X1 as [x [a wfs]]. split; auto.
  Qed.

  Lemma typing_wf Σ (wfΣ : wf Σ.1) Γ t T :
    Σ ;;; Γ |- t : T -> WfAst.wf Σ.1 t * WfAst.wf Σ.1 T.
  Proof using Type.
    intros. eapply typing_wf_gen in X; intuition eauto with wf.
  Qed.

  Lemma declared_minductive_wf {Σ : global_env} {mind mdecl} {wfΣ : wf Σ} :
    declared_minductive Σ mind mdecl ->
    All (wf_decl Σ) (ind_params mdecl) *
    All (@wf_inductive_body Σ) (ind_bodies mdecl).
  Proof using Type.
    intros declm.
    pose proof (typing_wf_gen (Env.empty_ext Σ) wfΣ _ localenv_nil _ _ (type_Prop _)) as [X _].
    eapply Forall_decls_on_global_wf in X.
    eapply lookup_global_Some_iff_In_NoDup in declm; eauto.
    2: destruct X; now eapply NoDup_on_global_decls.
    destruct (lookup_on_global_env X declm) as [? [? [ext ?]]]; eauto.
    split. eapply on_global_inductive_wf_params in o0. solve_all. eauto using wf_decl_extends with typeclass_instances.
    eapply on_global_inductive_wf_bodies in o0. solve_all.
    destruct X0; split; solve_all; eauto using wf_extends, wf_decl_extends with typeclass_instances.
  Qed.

  Lemma declared_inductive_wf_case_predicate_context
     {Σ : global_env} {wfΣ : wf Σ} {ind mdecl idecl p} :
    declared_inductive Σ ind mdecl idecl ->
    All (WfAst.wf Σ) p.(pparams) ->
    All (wf_decl Σ) (case_predicate_context ind mdecl idecl p).
  Proof using Type.
    intros decli.
    destruct (declared_minductive_wf (proj1 decli)) as [wfp wfb].
    intros wfpars.
    eapply wf_case_predicate_context => //.
    destruct decli as [declm hi].
    eapply nth_error_all in wfb; tea. apply wfb.
  Qed.

  Lemma declared_constructor_wf_case_branch_context
    {Σ} {wfΣ : wf Σ} {ind mdecl idecl cdecl p br} :
    declared_constructor Σ ind mdecl idecl cdecl ->
    All (WfAst.wf Σ) (pparams p) ->
    All (wf_decl Σ) (case_branch_context (fst ind) mdecl cdecl p br).
  Proof using Type.
    intros.
    eapply wf_case_branch_context_gen; tea => //.
    now apply typing_wf_sigma.
    destruct (declared_minductive_wf (proj1 (proj1 H))).
    destruct H as [[hm hnth] hnth'].
    eapply nth_error_all in a0; tea.
    now eapply wf_ind_ctor_args.
  Qed.

  Lemma mkApp_ex_wf Σ t u : WfAst.wf Σ (mkApp t u) ->
    exists f args, mkApp t u = tApp f args /\ ~~ isApp f.
  Proof using Type.
    induction t; simpl; try solve [eexists _, _; split; reflexivity].
    intros wf.
    eapply wf_inv in wf as [[[appt _] wft] wfargs].
    eapply All_app in wfargs as [wfargs wfu]. depelim wfu.
    forward IHt. eapply wf_mkApp; intuition auto.
    destruct IHt as [f [ar [eqf isap]]].
    eexists _, _; split; auto. rewrite appt //.
  Qed.

  Lemma decompose_app_mkApp f u :
    (decompose_app (mkApp f u)).2 <> [].
  Proof using Type.
    induction f; simpl; auto; try congruence.
    destruct args; simpl; congruence.
  Qed.

  Lemma mkApps_tApp' f u f' u' :
    ~~ isApp f' ->
    mkApp f u = tApp f' u' -> mkApps f [u] = mkApps f' u'.
  Proof using Type.
    intros.
    rewrite -(mkApp_mkApps f u []).
    simpl. rewrite H0.
    rewrite -(mkApps_tApp f') // ?H //.
    destruct u' => //.
    eapply (f_equal decompose_app) in H0.
    simpl in H0. pose proof (decompose_app_mkApp f u).
    rewrite H0 /= in H1. congruence.
  Qed.

  Lemma eq_decompose_app Σ x y :
    WfAst.wf Σ x -> WfAst.wf Σ y ->
    decompose_app x = decompose_app y -> x = y.
  Proof using Type.
    intros wfx; revert y.
    induction wfx using term_wf_forall_list_ind; intros [] wfy;
    eapply wf_inv in wfy; simpl in wfy; simpl;
    intros [= ?]; try intuition congruence.
  Qed.

  Lemma mkApp_ex t u : ∑ f args, mkApp t u = tApp f args.
  Proof using Type.
    induction t; simpl; try solve [eexists _, _; reflexivity].
  Qed.

  Lemma strip_casts_decompose_app Σ t :
    WfAst.wf Σ t ->
    forall f l, decompose_app t = (f, l) ->
    strip_casts t = mkApps (strip_casts f) (map strip_casts l).
  Proof using Type.
    intros wf.
    induction wf using term_wf_forall_list_ind; simpl; intros; auto; noconf H;
    try noconf H0;
      rewrite ?map_map_compose  ?compose_on_snd ?compose_map_def ?map_length;
        f_equal; solve_all; eauto.
    - now noconf H1.
    - now noconf H1.
    - now noconf H2.
  Qed.

  Lemma mkApps_tApp f args :
    ~~ isApp f ->
    ~~ is_empty args ->
    tApp f args = mkApps f args.
  Proof using Type.
    intros.
    destruct args, f; try discriminate; auto.
  Qed.

  Lemma strip_casts_mkApps_napp_wf Σ f u :
    ~~ isApp f -> WfAst.wf Σ f -> All (WfAst.wf Σ) u ->
    strip_casts (mkApps f u) = mkApps (strip_casts f) (map strip_casts u).
  Proof using Type.
    intros nisapp wf wf'.
    destruct u.
    simpl. auto.
    rewrite -(mkApps_tApp f (t :: u)) //.
  Qed.

  Lemma mkApp_mkApps f u : mkApp f u = mkApps f [u].
  Proof using Type. reflexivity. Qed.

  Lemma decompose_app_inv Σ f l hd args :
    WfAst.wf Σ f ->
    decompose_app (mkApps f l) = (hd, args) ->
    ∑ n, ~~ isApp hd /\ l = skipn n args /\ f = mkApps hd (firstn n args).
  Proof using Type.
    destruct (isApp f) eqn:Heq.
    revert l args hd.
    induction f; try discriminate. intros.
    simpl in X.
    move/wf_inv: X => /= [[[isAppf Hargs] wff] wfargs].
    rewrite mkApps_tApp ?isAppf in H => //. destruct args => //.
    rewrite -mkApps_app in H.
    rewrite decompose_app_mkApps ?isAppf in H; auto. noconf H.
    exists #|args|; split; auto. now rewrite isAppf.
    rewrite skipn_all_app.
    rewrite firstn_app. rewrite firstn_all2. lia.
    rewrite Nat.sub_diag firstn_O app_nil_r. split; auto.
    rewrite mkApps_tApp ?isAppf //. now destruct args.

    intros wff fl.
    rewrite decompose_app_mkApps in fl; auto. now apply negbT.
    inversion fl. subst; exists 0.
    split; auto. now eapply negbT.
  Qed.

  Lemma eq_tip_skipn {A} (x : A) n l : [x] = skipn n l ->
    exists l', l = l' ++ [x] /\ n = #|l'|.
  Proof using Type.
    induction l in n |- *. rewrite skipn_nil //.
    destruct n. simpl. destruct l => //.
    intros eq. noconf eq. exists []; split; auto.
    rewrite skipn_S. intros Hx.
    destruct (IHl _ Hx) as [l' [-> ->]].
    exists (a :: l'); split; reflexivity.
  Qed.

  Lemma strip_casts_mkApp_wf Σ f u :
    WfAst.wf Σ f -> WfAst.wf Σ u ->
    strip_casts (mkApp f u) = mkApp (strip_casts f) (strip_casts u).
  Proof using Type.
    intros wf wf'.
    assert (wfa : WfAst.wf Σ (mkApp f u)). now apply wf_mkApp.
    destruct (mkApp_ex_wf Σ f u wfa) as [f' [args [eq isapp]]].
    eapply (f_equal decompose_app) in eq. simpl in eq.
    epose proof (strip_casts_decompose_app Σ _ wfa _ _ eq).
    rewrite H.
    rewrite mkApp_mkApps in eq.
    destruct (decompose_app_inv Σ _ _ _ _ wf eq) as [n [ng [stripeq stripf]]].
    apply eq_tip_skipn in stripeq. destruct stripeq as [l' [eqargs eqn]].
    subst n args. rewrite firstn_app_left // in stripf. subst f.
    eapply wf_mkApps_napp in wf as [wff' wfl] => //.
    rewrite (strip_casts_mkApps_napp_wf Σ) //.
    now rewrite mkApp_mkApps -mkApps_app map_app.
  Qed.

  Lemma strip_casts_mkApps_wf Σ f u :
    WfAst.wf Σ f -> All (WfAst.wf Σ) u ->
    strip_casts (mkApps f u) = mkApps (strip_casts f) (map strip_casts u).
  Proof using Type.
    intros wf wf'. induction wf' in f, wf |- *.
    simpl. auto.
    rewrite -mkApps_mkApp IHwf'.
    apply wf_mkApp; auto with wf.
    rewrite (strip_casts_mkApp_wf Σ) //.
    now rewrite mkApps_mkApp.
  Qed.
End TypingWf.


Require Import List.
Import ListNotations.

Require Import oeuf.StuartTact.
Require Import StructTact.StructTactics.
Require Import oeuf.ListLemmas.

Require Import Setoid.

Require SHA256_N.

Require Arith.
Require Import ZArith.

Local Open Scope positive.
Set Default Timeout 5.

Fixpoint pos_succ0 (x : positive) {struct x} : positive :=
    match x with
    | x~1 => (pos_succ0 x)~0
    | x~0 => x~1
    | 1 => 2
    end.

Lemma pos_succ0_eq : forall x,
    pos_succ0 x = Pos.succ x.
induction x; simpl; congruence.
Qed.

Definition pos_succ (x : positive) : positive :=
    positive_rect _
        (fun x IHx dummy => (IHx dummy)~0)
        (fun x IHx dummy => x~1)
        (fun dummy => 2)
        x tt.

Lemma pos_succ_eq' : forall x,
    pos_succ x = pos_succ0 x.
induction x; unfold pos_succ; simpl; try fold (pos_succ x); congruence.
Qed.

Lemma pos_succ_eq : forall x,
    pos_succ x = Pos.succ x.
intros. rewrite pos_succ_eq', pos_succ0_eq. auto.
Qed.

Fixpoint pos_add_with_carry0 (x y : positive) (c : bool) {struct x} : positive :=
    match x with
    | x~1 =>
            match y with
            | y~1 =>
                    if c then (pos_add_with_carry0 x y true)~1
                    else (pos_add_with_carry0 x y true)~0
            | y~0 =>
                    if c then (pos_add_with_carry0 x y true)~0
                    else (pos_add_with_carry0 x y false)~1
            | 1 =>
                    if c then (pos_succ x)~1
                    else (pos_succ x)~0
            end
    | x~0 =>
            match y with
            | y~1 =>
                    if c then (pos_add_with_carry0 x y true)~0
                    else (pos_add_with_carry0 x y false)~1
            | y~0 =>
                    if c then (pos_add_with_carry0 x y false)~1
                    else (pos_add_with_carry0 x y false)~0
            | 1 =>
                    if c then (pos_succ x)~0
                    else x~1
            end
    | 1 =>
            match y with
            | y~1 =>
                    if c then (pos_succ y)~1
                    else (pos_succ y)~0
            | y~0 =>
                    if c then (pos_succ y)~0
                    else y~1
            | 1 =>
                    if c then 3
                    else 2
            end
    end.

Lemma pos_add_with_carry0_eq : forall x y,
    pos_add_with_carry0 x y false = Pos.add x y.
fix go 1
with (go_carry x y {struct x} : pos_add_with_carry0 x y true = Pos.add_carry x y).

{
destruct x, y; simpl.
all: repeat rewrite pos_succ_eq.
all: try reflexivity.
- f_equal. apply go_carry.
- f_equal. apply go.
- f_equal. apply go.
- f_equal. apply go.
}

{
destruct x, y; simpl.
all: repeat rewrite pos_succ_eq.
all: try reflexivity.
- f_equal. apply go_carry.
- f_equal. apply go_carry.
- f_equal. apply go_carry.
- f_equal. apply go.
}
Qed.

Definition pos_add_with_carry (x y : positive) (c : bool) : positive :=
    positive_rect _
        (fun x IHx => fun y => positive_rect _
            (fun y IHy => fun c => bool_rect _
                (fun dummy => (IHx y true dummy)~1)
                (fun dummy => (IHx y true dummy)~0)
                c)
            (fun y IHy => fun c => bool_rect _
                (fun dummy => (IHx y true dummy)~0)
                (fun dummy => (IHx y false dummy)~1)
                c)
            (fun c => bool_rect _
                (fun dummy => (pos_succ x)~1)
                (fun dummy => (pos_succ x)~0)
                c)
            y)
        (fun x IHx => fun y => positive_rect _
            (fun y IHy => fun c => bool_rect _
                (fun dummy => (IHx y true dummy)~0)
                (fun dummy => (IHx y false dummy)~1)
                c)
            (fun y IHy => fun c => bool_rect _
                (fun dummy => (IHx y false dummy)~1)
                (fun dummy => (IHx y false dummy)~0)
                c)
            (fun c => bool_rect _
                (fun dummy => (pos_succ x)~0)
                (fun dummy => x~1)
                c)
            y)
        (fun y => positive_rect _
            (fun y IHy => fun c => bool_rect _
                (fun dummy => (pos_succ y)~1)
                (fun dummy => (pos_succ y)~0)
                c)
            (fun y IHy => fun c => bool_rect _
                (fun dummy => (pos_succ y)~0)
                (fun dummy => y~1)
                c)
            (fun c => bool_rect _
                (fun dummy => 3)
                (fun dummy => 2)
                c)
            y)
        x y c tt.

Lemma pos_add_with_carry_eq : forall x y c,
    pos_add_with_carry x y c = pos_add_with_carry0 x y c.
induction x; destruct y; destruct c; simpl.
all: unfold pos_add_with_carry; simpl;
  try fold (pos_add_with_carry x y true);
  try fold (pos_add_with_carry x y false).

all: try rewrite IHx.
all: reflexivity.
Qed.

Definition pos_add (x y : positive) : positive :=
    positive_rect (fun _ => positive -> bool -> unit -> positive)
        (fun x IHx => fun y => positive_rect _
            (fun y IHy => fun c => bool_rect _
                (fun dummy => (IHx y true dummy)~1)
                (fun dummy => (IHx y true dummy)~0)
                c)
            (fun y IHy => fun c => bool_rect _
                (fun dummy => (IHx y true dummy)~0)
                (fun dummy => (IHx y false dummy)~1)
                c)
            (fun c => bool_rect _
                (fun dummy => (pos_succ x)~1)
                (fun dummy => (pos_succ x)~0)
                c)
            y)
        (fun x IHx => fun y => positive_rect _
            (fun y IHy => fun c => bool_rect _
                (fun dummy => (IHx y true dummy)~0)
                (fun dummy => (IHx y false dummy)~1)
                c)
            (fun y IHy => fun c => bool_rect _
                (fun dummy => (IHx y false dummy)~1)
                (fun dummy => (IHx y false dummy)~0)
                c)
            (fun c => bool_rect _
                (fun dummy => (pos_succ x)~0)
                (fun dummy => x~1)
                c)
            y)
        (fun y => positive_rect _
            (fun y IHy => fun c => bool_rect _
                (fun dummy => (pos_succ y)~1)
                (fun dummy => (pos_succ y)~0)
                c)
            (fun y IHy => fun c => bool_rect _
                (fun dummy => (pos_succ y)~0)
                (fun dummy => y~1)
                c)
            (fun c => bool_rect _
                (fun dummy => 3)
                (fun dummy => 2)
                c)
            y)
        x y false tt.

Lemma pos_add_eq' : forall x y,
    pos_add x y = pos_add_with_carry x y false.
intros. reflexivity.
Qed.

Lemma pos_add_eq : forall x y,
    pos_add x y = Pos.add x y.
intros.
rewrite pos_add_eq', pos_add_with_carry_eq, pos_add_with_carry0_eq.
reflexivity.
Qed.

Definition N_add (x y : N) : N :=
    N_rect _
        (fun y => y)
        (fun xp => fun y => N_rect _
            (x)
            (fun yp => N.pos (pos_add xp yp))
            y)
        x y.

Lemma N_add_eq : forall x y,
    N_add x y = N.add x y.
destruct x, y; simpl; try rewrite pos_add_eq; reflexivity.
Qed.

Definition Pos_Ndouble (x : N) : N :=
    N_rect _
        (0%N)
        (fun xp => N.pos xp~0)
        x.

Lemma Pos_Ndouble_eq : forall x,
    Pos_Ndouble x = Pos.Ndouble x.
destruct x; simpl; reflexivity.
Qed.

Definition Pos_Nsucc_double (x : N) : N :=
    N_rect _
        (1%N)
        (fun xp => N.pos xp~1)
        x.

Lemma Pos_Nsucc_double_eq : forall x,
    Pos_Nsucc_double x = Pos.Nsucc_double x.
destruct x; simpl; reflexivity.
Qed.

Definition Pos_land (x y : positive) : N :=
    positive_rect (fun _ => positive -> unit -> N)
        (fun x IHx => fun y => positive_rect (fun _ => unit -> N)
            (fun y IHy => fun dummy => Pos_Nsucc_double (IHx y dummy))
            (fun y IHy => fun dummy => Pos_Ndouble (IHx y dummy))
            (fun dummy => 1%N)
            y)
        (fun x IHx => fun y => positive_rect _
            (fun y IHy => fun dummy => Pos_Ndouble (IHx y dummy))
            (fun y IHy => fun dummy => Pos_Ndouble (IHx y dummy))
            (fun dummy => 0%N)
            y)
        (fun y => positive_rect _
            (fun y IHy => fun dummy => 1%N)
            (fun y IHy => fun dummy => 0%N)
            (fun dummy => 1%N)
            y)
        x y tt.

Lemma Pos_land_eq : forall x y,
    Pos_land x y = Pos.land x y.
induction x; destruct y; simpl; try reflexivity.
- rewrite <- Pos_Nsucc_double_eq, <- IHx. reflexivity.
- rewrite <- Pos_Ndouble_eq, <- IHx. reflexivity.
- rewrite <- Pos_Ndouble_eq, <- IHx. reflexivity.
- rewrite <- Pos_Ndouble_eq, <- IHx. reflexivity.
Qed.

Definition N_land (x y : N) : N :=
    N_rect (fun _ => N -> N)
        (fun y => 0%N)
        (fun xp => fun y => N_rect (fun _ => N)
            (0%N)
            (fun yp => Pos_land xp yp)
            y)
        x y.

Lemma N_land_eq : forall x y,
    N_land x y = N.land x y.
destruct x, y; simpl; try reflexivity.
- rewrite <- Pos_land_eq. reflexivity.
Qed.

Definition Pos_lor (x y : positive) : positive :=
    positive_rect (fun _ => positive -> unit -> positive)
        (fun x IHx => fun y => positive_rect (fun _ => unit -> positive)
            (fun y IHy => fun dummy => (IHx y dummy)~1)
            (fun y IHy => fun dummy => (IHx y dummy)~1)
            (fun dummy => x~1)
            y)
        (fun x IHx => fun y => positive_rect _
            (fun y IHy => fun dummy => (IHx y dummy)~1)
            (fun y IHy => fun dummy => (IHx y dummy)~0)
            (fun dummy => x~1)
            y)
        (fun y => positive_rect _
            (fun y IHy => fun dummy => y~1)
            (fun y IHy => fun dummy => y~1)
            (fun dummy => xH)
            y)
        x y tt.

Lemma Pos_lor_eq : forall x y,
    Pos_lor x y = Pos.lor x y.
induction x; destruct y; simpl; try reflexivity.
- rewrite <- IHx. reflexivity.
- rewrite <- IHx. reflexivity.
- rewrite <- IHx. reflexivity.
- rewrite <- IHx. reflexivity.
Qed.

Definition N_lor (x y : N) : N :=
    N_rect (fun _ => N -> N)
        (fun y => y)
        (fun xp => fun y => N_rect (fun _ => N)
            (x)
            (fun yp => N.pos (Pos_lor xp yp))
            y)
        x y.

Lemma N_lor_eq : forall x y,
    N_lor x y = N.lor x y.
destruct x, y; simpl; try reflexivity.
- rewrite <- Pos_lor_eq. reflexivity.
Qed.

Definition Pos_lxor (x y : positive) : N :=
    positive_rect (fun _ => positive -> unit -> N)
        (fun x IHx => fun y => positive_rect (fun _ => unit -> N)
            (fun y IHy => fun dummy => Pos_Ndouble (IHx y dummy))
            (fun y IHy => fun dummy => Pos_Nsucc_double (IHx y dummy))
            (fun dummy => N.pos x~0)
            y)
        (fun x IHx => fun y => positive_rect _
            (fun y IHy => fun dummy => Pos_Nsucc_double (IHx y dummy))
            (fun y IHy => fun dummy => Pos_Ndouble (IHx y dummy))
            (fun dummy => N.pos x~1)
            y)
        (fun y => positive_rect _
            (fun y IHy => fun dummy => N.pos y~0)
            (fun y IHy => fun dummy => N.pos y~1)
            (fun dummy => 0%N)
            y)
        x y tt.

Lemma Pos_lxor_eq : forall x y,
    Pos_lxor x y = Pos.lxor x y.
induction x; destruct y; simpl; try reflexivity.
- rewrite <- Pos_Ndouble_eq, <- IHx. reflexivity.
- rewrite <- Pos_Nsucc_double_eq, <- IHx. reflexivity.
- rewrite <- Pos_Nsucc_double_eq, <- IHx. reflexivity.
- rewrite <- Pos_Ndouble_eq, <- IHx. reflexivity.
Qed.

Definition N_lxor (x y : N) : N :=
    N_rect (fun _ => N -> N)
        (fun y => y)
        (fun xp => fun y => N_rect (fun _ => N)
            (x)
            (fun yp => Pos_lxor xp yp)
            y)
        x y.

Lemma N_lxor_eq : forall x y,
    N_lxor x y = N.lxor x y.
destruct x, y; simpl; try reflexivity.
- rewrite <- Pos_lxor_eq. reflexivity.
Qed.

Definition Pos_pred_double (x : positive) : positive :=
    positive_rect _
        (fun x IHx => fun dummy => x~0~1)
        (fun x IHx => fun dummy => (IHx dummy)~1)
        (fun dummy => 1)
        x tt.

Lemma Pos_pred_double_eq : forall x,
    Pos_pred_double x = Pos.pred_double x.
induction x; simpl; try reflexivity.
- rewrite <- IHx. reflexivity.
Qed.

Definition Pos_pred_N (x : positive) : N :=
    positive_rect _
        (fun x IHx => fun dummy => N.pos x~0)
        (fun x IHx => fun dummy => N.pos (Pos_pred_double x))
        (fun dummy => 0%N)
        x tt.

Lemma Pos_pred_N_eq : forall x,
    Pos_pred_N x = Pos.pred_N x.
induction x; simpl; try reflexivity.
- rewrite <- Pos_pred_double_eq. reflexivity.
Qed.

Definition N_pred (x : N) : N :=
    N_rect _
        (0%N)
        (fun xp => Pos_pred_N xp)
        x.

Lemma N_pred_eq : forall x,
    N_pred x = N.pred x.
destruct x; simpl; try reflexivity.
- rewrite <- Pos_pred_N_eq. reflexivity.
Qed.

Definition Pos_iter {A} (f : A -> A) (x : A) (n : positive) : A :=
    positive_rect (fun _ => A -> A)
        (fun n' IHn' => fun x => f (IHn' (IHn' x)))
        (fun n' IHn' => fun x => IHn' (IHn' x))
        (f)
        n x.

Lemma Pos_iter_eq : forall {A} (f : A -> A) n x,
    Pos_iter f x n = Pos.iter f x n.
induction n; intros; simpl; try reflexivity.
- rewrite <- 2 IHn. reflexivity.
- rewrite <- 2 IHn. reflexivity.
Qed.

Lemma Pos_iter_ext : forall {A} (f f' : A -> A) n x,
    (forall x, f x = f' x) ->
    Pos_iter f x n = Pos_iter f' x n.
induction n; intros0 Hf; simpl; try reflexivity.
- rewrite <- Hf, <- 2 IHn by auto. reflexivity.
- rewrite <- 2 IHn by auto. reflexivity.
- apply Hf.
Qed.

Definition Pos_shiftl (x : positive) (n : N) : positive :=
    N_rect _
        x
        (fun n' => Pos_iter (fun y => xO y) x n')
        n.

Lemma Pos_shiftl_eq : forall n x,
    Pos_shiftl x n = Pos.shiftl x n.
destruct n; intros; simpl; try reflexivity.
- rewrite <- Pos_iter_eq. reflexivity.
Qed.

Definition N_shiftl (x b : N) : N :=
    N_rect _
        (0%N)
        (fun xp => N.pos (Pos_shiftl xp b))
        x.

Lemma N_shiftl_eq : forall x y,
    N_shiftl x y = N.shiftl x y.
destruct x; intros; simpl; try reflexivity.
- rewrite <- Pos_shiftl_eq. reflexivity.
Qed.

Definition Pos_div2 (x : positive) : positive :=
    positive_rect _
        (fun x IHx => x)
        (fun x IHx => x)
        (1)
        x.

Lemma Pos_div2_eq : forall x,
    Pos_div2 x = Pos.div2 x.
destruct x; simpl; try reflexivity.
Qed.

Definition N_div2 (x : N) : N :=
    N_rect _
        (0%N)
        (fun xp => positive_rect (fun _ => N)
            (fun xp' IHxp' => N.pos xp')
            (fun xp' IHxp' => N.pos xp')
            (0%N)
            xp)
        x.

Lemma N_div2_eq : forall x,
    N_div2 x = N.div2 x.
destruct x; try destruct p; simpl; try reflexivity.
Qed.

Definition Pos_shiftr (x : positive) (n : N) : positive :=
    N_rect _
        x
        (fun n' => Pos_iter Pos_div2 x n')
        n.

Lemma Pos_shiftr_eq : forall n x,
    Pos_shiftr x n = Pos.shiftr x n.
destruct n; intros; simpl; try reflexivity.
- rewrite <- Pos_iter_eq.
  apply Pos_iter_ext. apply Pos_div2_eq.
Qed.

Definition N_shiftr (x b : N) : N :=
    N_rect _
        (x)
        (fun bp => Pos_iter N_div2 x bp)
        b.

Lemma N_shiftr_eq : forall b x,
    N_shiftr x b = N.shiftr x b.
induction b; intros; simpl; try reflexivity.
- rewrite <- Pos_iter_eq.
  apply Pos_iter_ext. apply N_div2_eq.
Qed.

Definition N_ones b := N_pred (N_shiftl 1 b).

Lemma N_ones_eq : forall b,
    N_ones b = N.ones b.
intros. unfold N_ones.
rewrite N_pred_eq, N_shiftl_eq. reflexivity.
Qed.

Definition N_lnot a n := N_lxor a (N_ones n).

Lemma N_lnot_eq : forall a n,
    N_lnot a n = N.lnot a n.
intros. unfold N_lnot.
rewrite N_lxor_eq, N_ones_eq. reflexivity.
Qed.

Definition mask w z := N_land z (N_ones w).

Lemma mask_eq : forall w z,
    mask w z = SHA256_N.mask w z.
intros. unfold mask.
rewrite N_land_eq, N_ones_eq. reflexivity.
Qed.

Definition trunc z := mask 32 z.

Lemma trunc_eq : forall z,
    trunc z = SHA256_N.trunc z.
intros. unfold trunc.
rewrite mask_eq. reflexivity.
Qed.

Definition t_add x y := trunc (N_add x y).

Lemma t_add_eq : forall x y,
    t_add x y = SHA256_N.t_add x y.
intros. unfold t_add.
rewrite trunc_eq, N_add_eq. reflexivity.
Qed.

Definition t_and x y := trunc (N_land x y).
Definition t_or x y := trunc (N_lor x y).
Definition t_xor x y := trunc (N_lxor x y).
Definition t_not x := trunc (N_lnot x 32).

Lemma t_and_eq : forall x y,
    t_and x y = SHA256_N.t_and x y.
intros. unfold t_and.
rewrite trunc_eq, N_land_eq. reflexivity.
Qed.

Lemma t_or_eq : forall x y,
    t_or x y = SHA256_N.t_or x y.
intros. unfold t_or.
rewrite trunc_eq, N_lor_eq. reflexivity.
Qed.

Lemma t_xor_eq : forall x y,
    t_xor x y = SHA256_N.t_xor x y.
intros. unfold t_xor.
rewrite trunc_eq, N_lxor_eq. reflexivity.
Qed.

Lemma t_not_eq : forall x,
    t_not x = SHA256_N.t_not x.
intros. unfold t_not.
rewrite trunc_eq, N_lnot_eq. reflexivity.
Qed.

Definition t_shiftl x b := trunc (N_shiftl x b).
Definition Shr b x := trunc (N_shiftr x b).

Lemma t_shiftl_eq : forall x b,
    t_shiftl x b = SHA256_N.t_shiftl x b.
intros. unfold t_shiftl.
rewrite trunc_eq, N_shiftl_eq. reflexivity.
Qed.

Lemma Shr_eq : forall x b,
    Shr x b = SHA256_N.Shr x b.
intros. unfold Shr.
rewrite trunc_eq, N_shiftr_eq. reflexivity.
Qed.

Definition wordlist_to_bytelist (l : list N) : list N :=
    list_rect (fun _ => list N)
        ([])
        (fun w l IHl =>
            trunc (Shr 24 w) ::
            trunc (t_and (Shr 16 w) 255) ::
            trunc (t_and (Shr 8 w) 255) ::
            trunc (t_and w 255) ::
            IHl)
        l.

Lemma wordlist_to_bytelist_eq : forall l,
    wordlist_to_bytelist l = SHA256_N.wordlist_to_bytelist l.
induction l; cbn [wordlist_to_bytelist list_rect].
- reflexivity.
- fold (wordlist_to_bytelist l). rewrite IHl.
  rewrite 4 trunc_eq, 3 Shr_eq, 3 t_and_eq.
  reflexivity.
Qed.

Definition bytes_to_word (a b c d : N) : N :=
    t_or (t_or (t_or
        (t_shiftl (trunc a) 24)
        (t_shiftl (trunc b) 16))
        (t_shiftl (trunc c) 8))
        (trunc d).

Lemma bytes_to_word_eq : forall a b c d,
    bytes_to_word a b c d = SHA256_N.bytes_to_word a b c d.
intros. unfold bytes_to_word.
rewrite 4 trunc_eq, 3 t_shiftl_eq, 3 t_or_eq. reflexivity.
Qed.

Fixpoint pair_up'0 {A} (l : list A) (first : option A) : list (A * A) :=
    match l with
    | [] => []
    | y :: l' =>
            match first with
            | None => pair_up'0 l' (Some y)
            | Some x => (x, y) :: pair_up'0 l' None
            end
    end.

Definition pair_up0 {A} (l : list A) : list (A * A) :=
    pair_up'0 l None.

Fixpoint bytelist_to_wordlist'0 (l : list ((N * N) * (N * N))) : list N :=
    match l with
    | [] => []
    | ((a, b), (c, d)) :: l =>
            bytes_to_word a b c d :: bytelist_to_wordlist'0 l
    end.

Definition bytelist_to_wordlist0 (l : list N) : list N :=
    bytelist_to_wordlist'0 (pair_up0 (pair_up0 l)).

Lemma bytelist_to_wordlist0_eq : forall l,
    bytelist_to_wordlist0 l = SHA256_N.bytelist_to_wordlist l.
fix go 1.
intros.
destruct l as [| a [| b [| c [| d l ] ] ] ]; simpl; try reflexivity.
cbn [ bytelist_to_wordlist'0 bytelist_to_wordlist0 pair_up0 pair_up'0 ].
rewrite bytes_to_word_eq.
fold (pair_up0 l). fold (pair_up0 (pair_up0 l)).
fold (bytelist_to_wordlist0 l).  rewrite (go l).
reflexivity.
Qed.

Definition pair_up' {A} (l : list A) (first : option A) : list (A * A) :=
    list_rect (fun _ => option A -> unit -> list (A * A))
        (fun first => fun dummy => [])
        (fun y l' IHl => fun first =>
            option_rect (fun _ => unit -> list (A * A))
                (fun x => fun dummy => (x, y) :: IHl None dummy)
                (fun dummy => IHl (Some y) dummy)
                first)
        l first tt.

Lemma pair_up'_eq : forall {A} (l : list A) first,
    pair_up' l first = pair_up'0 l first.
induction l; destruct first; simpl; try reflexivity.
- unfold pair_up'. simpl. fold (pair_up' l None).
  rewrite IHl. reflexivity.
- unfold pair_up'. simpl. fold (pair_up' l (Some a)).
  rewrite IHl. reflexivity.
Qed.

Definition pair_up {A} (l : list A) : list (A * A) :=
    list_rect (fun _ => option A -> unit -> list (A * A))
        (fun first dummy => [])
        (fun y l' IHl => fun first =>
            option_rect (fun _ => unit -> list (A * A))
                (fun x dummy => (x, y) :: IHl None dummy)
                (fun dummy => IHl (Some y) dummy)
                first)
        l None tt.

Lemma pair_up_eq : forall {A} (l : list A),
    pair_up l = pair_up0 l.
intros.
change (pair_up l) with (pair_up' l None).
change (pair_up0 l) with (pair_up'0 l None).
apply pair_up'_eq.
Qed.

Definition bytelist_to_wordlist' (l : list ((N * N) * (N * N))) : list N :=
    list_rect (fun _ => list N)
        ([])
        (fun abcd l IHl =>
            prod_rect (fun _ => list N) (fun ab cd =>
            prod_rect (fun _ => list N) (fun a b =>
            prod_rect (fun _ => list N) (fun c d =>
                bytes_to_word a b c d :: IHl
            ) cd) ab) abcd)
        l.

Lemma bytelist_to_wordlist'_eq : forall l,
    bytelist_to_wordlist' l = bytelist_to_wordlist'0 l.
induction l; simpl; try reflexivity.
Qed.

Definition bytelist_to_wordlist (l : list N) : list N :=
    bytelist_to_wordlist' (pair_up (pair_up l)).

Lemma bytelist_to_wordlist_eq : forall l,
    bytelist_to_wordlist l = SHA256_N.bytelist_to_wordlist l.
induction l; rewrite <- bytelist_to_wordlist0_eq; simpl; try reflexivity.
unfold bytelist_to_wordlist, bytelist_to_wordlist0.
rewrite bytelist_to_wordlist'_eq, 2 pair_up_eq.
reflexivity.
Qed.

Definition Pos_succ (x : positive) : positive :=
    positive_rect _
        (fun x' IHx => IHx~0)
        (fun x' IHx => x'~1)
        (2)
        x.

Lemma Pos_succ_eq : forall x,
    Pos_succ x = Pos.succ x.
induction x; simpl; try rewrite IHx; reflexivity.
Qed.

Definition Pos_of_succ_nat (x : nat) : positive :=
    nat_rect _
        (1)
        (fun x IHx => Pos_succ IHx)
        x.

Lemma Pos_of_succ_nat_eq : forall x,
    Pos_of_succ_nat x = Pos.of_succ_nat x.
induction x; simpl; try reflexivity.
Qed.

Definition N_succ (x : N) : N :=
    N_rect _
        (1%N)
        (fun xp => N.pos (Pos_succ xp))
        x.

Lemma N_succ_eq : forall x,
    N_succ x = N.succ x.
induction x; simpl; try reflexivity.
Qed.

Fixpoint Nlength0 {A} (l : list A) : N :=
    match l with
    | [] => 0%N
    | _ :: l' => N_succ (Nlength0 l')
    end.

Lemma Nlength0_eq : forall {A} (l : list A),
    Nlength0 l = Z.to_N (Zlength l).
induction l; simpl; try reflexivity.
- rewrite N_succ_eq. rewrite IHl.
  rewrite <- Z2N.inj_succ. f_equal.
  rewrite 2 Zlength_correct. rewrite <- Nat2Z.inj_succ. reflexivity.
    { rewrite Zlength_correct. apply Nat2Z.is_nonneg. }
Qed.

Definition Nlength {A} (l : list A) : N :=
    list_rect _
        (0%N)
        (fun x l' IHl => N_succ IHl)
        l.

Lemma Nlength_eq : forall {A} (l : list A),
    Nlength l = Z.to_N (Zlength l).
induction l; intros; try rewrite <- Nlength0_eq; try reflexivity.
- rewrite <- Nlength0_eq in IHl. simpl. congruence.
Qed.

Definition Pos_to_nat (x : positive) : nat :=
    Pos_iter (fun n => S n) 0%nat x.

Lemma Pos_to_nat_eq : forall x,
    Pos_to_nat x = Pos.to_nat x.
induction x using Pos.peano_ind; simpl; try reflexivity.
- unfold Pos_to_nat in *. rewrite Pos_iter_eq. rewrite Pos_iter_eq in IHx.
  rewrite Pos.iter_succ.  rewrite Pos2Nat.inj_succ. congruence.
Qed.

Definition N_to_nat (x : N) : nat :=
    N_rect _
        (0%nat)
        (fun xp => Pos_to_nat xp)
        x.

Lemma N_to_nat_eq : forall x,
    N_to_nat x = N.to_nat x.
destruct x; simpl; try rewrite Pos_to_nat_eq; reflexivity.
Qed.

Definition List_repeat {A} (x : A) (n : nat) : list A :=
    nat_rect _
        ([])
        (fun n' IHn => x :: IHn)
        n.

Lemma List_repeat_eq : forall {A} (x : A) n,
    List_repeat x n = List.repeat x n.
induction n; simpl; congruence.
Qed.

Definition List_app {A} (xs ys : list A) : list A :=
    list_rect _
        (ys)
        (fun x xs IHxs => x :: IHxs)
        xs.

Lemma List_app_eq : forall {A} (xs ys : list A),
    List_app xs ys = List.app xs ys.
induction xs; simpl; congruence.
Qed.

Definition generate_and_pad msg :=
    (fun n =>
    (fun pad_amount =>
    (List_app
        (bytelist_to_wordlist
            (List_app msg
            (List_app [128%N]
                (List_repeat 0%N (N_to_nat pad_amount)))))
        ([trunc (N_shiftr (N_shiftl n 3) 32);
          trunc (N_shiftl n 3)]))
    ) (* pad-amount *) (N_land (N_add 1 (N_lnot (N_land (N_add n 9) 63) 6)) 63)
    ) (* N *) (Nlength msg).

Lemma generate_and_pad_eq : forall msg,
    generate_and_pad msg = SHA256_N.generate_and_pad msg.
intros. unfold generate_and_pad.
rewrite bytelist_to_wordlist_eq, 3 List_app_eq.
rewrite List_repeat_eq, N_to_nat_eq, 2 N_land_eq, 2 N_add_eq, N_lnot_eq, Nlength_eq.
rewrite 2 trunc_eq, N_shiftl_eq, N_shiftr_eq.
rewrite N.shiftl_mul_pow2, N.shiftr_div_pow2.
reflexivity.
Qed.

Lemma generate_and_pad_length : forall msg,
    (length (generate_and_pad msg) mod 16 = 0)%nat.
intros.
rewrite generate_and_pad_eq.
apply SHA256_N.generate_and_pad_length.
Qed.

Definition nthi_test n :=
    (nat_rect _ (fun dummy => 10)
    (fun n _ dummy => nat_rect _ (fun dummy => 20)
    (fun n _ dummy => nat_rect _ (fun dummy => 30)
    (fun n _ dummy => nat_rect _ (fun dummy => 40)

    (fun n _ dummy => 0) n dummy) n dummy) n dummy) n tt)%Z.

(*
Definition nthi_K256 n :=
    (nat_rect _ (fun dummy => 1116352408)
    (fun n _ dummy => nat_rect _ (fun dummy => 1899447441)
    (fun n _ dummy => nat_rect _ (fun dummy => 3049323471)
    (fun n _ dummy => nat_rect _ (fun dummy => 3921009573)

    (fun n _ dummy => nat_rect _ (fun dummy => 961987163)
    (fun n _ dummy => nat_rect _ (fun dummy => 1508970993)
    (fun n _ dummy => nat_rect _ (fun dummy => 2453635748)
    (fun n _ dummy => nat_rect _ (fun dummy => 2870763221)

    (fun n _ dummy => nat_rect _ (fun dummy => 3624381080)
    (fun n _ dummy => nat_rect _ (fun dummy => 310598401)
    (fun n _ dummy => nat_rect _ (fun dummy => 607225278)
    (fun n _ dummy => nat_rect _ (fun dummy => 1426881987)

    (fun n _ dummy => nat_rect _ (fun dummy => 1925078388)
    (fun n _ dummy => nat_rect _ (fun dummy => 2162078206)
    (fun n _ dummy => nat_rect _ (fun dummy => 2614888103)
    (fun n _ dummy => nat_rect _ (fun dummy => 3248222580)

    (fun n _ dummy => nat_rect _ (fun dummy => 3835390401)
    (fun n _ dummy => nat_rect _ (fun dummy => 4022224774)
    (fun n _ dummy => nat_rect _ (fun dummy => 264347078)
    (fun n _ dummy => nat_rect _ (fun dummy => 604807628)

    (fun n _ dummy => nat_rect _ (fun dummy => 770255983)
    (fun n _ dummy => nat_rect _ (fun dummy => 1249150122)
    (fun n _ dummy => nat_rect _ (fun dummy => 1555081692)
    (fun n _ dummy => nat_rect _ (fun dummy => 1996064986)

    (fun n _ dummy => nat_rect _ (fun dummy => 2554220882)
    (fun n _ dummy => nat_rect _ (fun dummy => 2821834349)
    (fun n _ dummy => nat_rect _ (fun dummy => 2952996808)
    (fun n _ dummy => nat_rect _ (fun dummy => 3210313671)

    (fun n _ dummy => nat_rect _ (fun dummy => 3336571891)
    (fun n _ dummy => nat_rect _ (fun dummy => 3584528711)
    (fun n _ dummy => nat_rect _ (fun dummy => 113926993)
    (fun n _ dummy => nat_rect _ (fun dummy => 338241895)

    (fun n _ dummy => nat_rect _ (fun dummy => 666307205)
    (fun n _ dummy => nat_rect _ (fun dummy => 773529912)
    (fun n _ dummy => nat_rect _ (fun dummy => 1294757372)
    (fun n _ dummy => nat_rect _ (fun dummy => 1396182291)

    (fun n _ dummy => nat_rect _ (fun dummy => 1695183700)
    (fun n _ dummy => nat_rect _ (fun dummy => 1986661051)
    (fun n _ dummy => nat_rect _ (fun dummy => 2177026350)
    (fun n _ dummy => nat_rect _ (fun dummy => 2456956037)

    (fun n _ dummy => nat_rect _ (fun dummy => 2730485921)
    (fun n _ dummy => nat_rect _ (fun dummy => 2820302411)
    (fun n _ dummy => nat_rect _ (fun dummy => 3259730800)
    (fun n _ dummy => nat_rect _ (fun dummy => 3345764771)

    (fun n _ dummy => nat_rect _ (fun dummy => 3516065817)
    (fun n _ dummy => nat_rect _ (fun dummy => 3600352804)
    (fun n _ dummy => nat_rect _ (fun dummy => 4094571909)
    (fun n _ dummy => nat_rect _ (fun dummy => 275423344)

    (fun n _ dummy => nat_rect _ (fun dummy => 430227734)
    (fun n _ dummy => nat_rect _ (fun dummy => 506948616)
    (fun n _ dummy => nat_rect _ (fun dummy => 659060556)
    (fun n _ dummy => nat_rect _ (fun dummy => 883997877)

    (fun n _ dummy => nat_rect _ (fun dummy => 958139571)
    (fun n _ dummy => nat_rect _ (fun dummy => 1322822218)
    (fun n _ dummy => nat_rect _ (fun dummy => 1537002063)
    (fun n _ dummy => nat_rect _ (fun dummy => 1747873779)

    (fun n _ dummy => nat_rect _ (fun dummy => 1955562222)
    (fun n _ dummy => nat_rect _ (fun dummy => 2024104815)
    (fun n _ dummy => nat_rect _ (fun dummy => 2227730452)
    (fun n _ dummy => nat_rect _ (fun dummy => 2361852424)

    (fun n _ dummy => nat_rect _ (fun dummy => 2428436474)
    (fun n _ dummy => nat_rect _ (fun dummy => 2756734187)
    (fun n _ dummy => nat_rect _ (fun dummy => 3204031479)
    (fun n _ dummy => nat_rect _ (fun dummy => 3329325298)

    (fun n _ dummy => 0)
    n dummy) n dummy) n dummy) n dummy)  n dummy) n dummy) n dummy) n dummy)
    n dummy) n dummy) n dummy) n dummy)  n dummy) n dummy) n dummy) n dummy)
    n dummy) n dummy) n dummy) n dummy)  n dummy) n dummy) n dummy) n dummy)
    n dummy) n dummy) n dummy) n dummy)  n dummy) n dummy) n dummy) n dummy)
    n dummy) n dummy) n dummy) n dummy)  n dummy) n dummy) n dummy) n dummy)
    n dummy) n dummy) n dummy) n dummy)  n dummy) n dummy) n dummy) n dummy)
    n dummy) n dummy) n dummy) n dummy)  n dummy) n dummy) n dummy) n dummy)
    n dummy) n dummy) n dummy) n dummy)  n dummy) n dummy) n dummy) n tt)%N.

Lemma nthi_K256_eq : forall n,
    nthi_K256 n = SHA256_N.nthi SHA256_N.K256 n.
repeat (destruct n; try reflexivity).
Qed.
*)

Definition nthi (l: list N) (t: nat) :=
    list_rect (fun _ => nat -> unit -> N)
        (fun t dummy => 0%N)
        (fun x l IHl => fun t => nat_rect (fun _ => unit -> N)
            (fun dummy => x)
            (fun x' IHx => fun dummy => IHl x' dummy)
            t)
        l t tt.

Lemma nthi_eq : forall l t,
    nthi l t = SHA256_N.nthi l t.
induction l; destruct t; simpl; try reflexivity.
- unfold nthi. simpl. fold (nthi l t).
  unfold SHA256_N.nthi. simpl. fold (SHA256_N.nthi l t).
  apply IHl.
Qed.

Definition nthi_K256 t :=
    nthi
        [1116352408; 1899447441; 3049323471; 3921009573;
          961987163; 1508970993; 2453635748; 2870763221;
         3624381080;  310598401;  607225278; 1426881987;
         1925078388; 2162078206; 2614888103; 3248222580;
         3835390401; 4022224774;  264347078;  604807628;
          770255983; 1249150122; 1555081692; 1996064986;
         2554220882; 2821834349; 2952996808; 3210313671;
         3336571891; 3584528711;  113926993;  338241895;
          666307205;  773529912; 1294757372; 1396182291;
         1695183700; 1986661051; 2177026350; 2456956037;
         2730485921; 2820302411; 3259730800; 3345764771;
         3516065817; 3600352804; 4094571909;  275423344;
          430227734;  506948616;  659060556;  883997877;
          958139571; 1322822218; 1537002063; 1747873779;
         1955562222; 2024104815; 2227730452; 2361852424;
         2428436474; 2756734187; 3204031479; 3329325298]%N
    t.

Lemma nthi_K256_eq : forall n,
    nthi_K256 n = SHA256_N.nthi SHA256_N.K256 n.
repeat (destruct n; try reflexivity).
Qed.

Definition Ch (x y z : N) : N :=
    t_xor (t_and x y) (t_and (t_not x) z).

Lemma Ch_eq : forall x y z,
    Ch x y z = SHA256_N.Ch x y z.
intros. unfold Ch.
rewrite t_xor_eq, 2 t_and_eq, t_not_eq.
reflexivity.
Qed.

Definition Maj (x y z : N) : N :=
    t_xor (t_xor (t_and x z) (t_and y z)) (t_and x y).

Lemma Maj_eq : forall x y z,
    Maj x y z = SHA256_N.Maj x y z.
intros. unfold Maj.
rewrite 2 t_xor_eq, 3 t_and_eq.
reflexivity.
Qed.

Definition Rotr (b x : N) :=
    trunc (N_lor
        (N_shiftr x b)
        (N_shiftl x (N_add 1 (N_lnot b 5)))).

Lemma Rotr_eq : forall b x,
    (b < 32)%N ->
    Rotr b x = SHA256_N.Rotr b x.
intros. unfold Rotr.
rewrite trunc_eq, N_lor_eq, N_shiftr_eq, N_shiftl_eq, N_add_eq, N_lnot_eq.
unfold SHA256_N.Rotr.
f_equal. f_equal. f_equal.

destruct b; try reflexivity.
do 5 try destruct p; try reflexivity.
all: destruct p; compute in H; try discriminate H.
Qed.

Definition Sigma_0 (x : N) : N :=
    t_xor (t_xor (Rotr 2 x) (Rotr 13 x)) (Rotr 22 x).
Definition Sigma_1 (x : N) : N :=
    t_xor (t_xor (Rotr 6 x) (Rotr 11 x)) (Rotr 25 x).
Definition sigma_0 (x : N) : N :=
    t_xor (t_xor (Rotr 7 x) (Rotr 18 x)) (Shr 3 x).
Definition sigma_1 (x : N) : N :=
    t_xor (t_xor (Rotr 17 x) (Rotr 19 x)) (Shr 10 x).

Lemma Sigma_0_eq : forall x,
    Sigma_0 x = SHA256_N.Sigma_0 x.
intros. unfold Sigma_0.
rewrite 2 t_xor_eq, 3 Rotr_eq by reflexivity.
reflexivity.
Qed.

Lemma Sigma_1_eq : forall x,
    Sigma_1 x = SHA256_N.Sigma_1 x.
intros. unfold Sigma_1.
rewrite 2 t_xor_eq, 3 Rotr_eq by reflexivity.
reflexivity.
Qed.

Lemma sigma_0_eq : forall x,
    sigma_0 x = SHA256_N.sigma_0 x.
intros. unfold sigma_0.
rewrite 2 t_xor_eq, 2 Rotr_eq, Shr_eq by reflexivity.
reflexivity.
Qed.

Lemma sigma_1_eq : forall x,
    sigma_1 x = SHA256_N.sigma_1 x.
intros. unfold sigma_1.
rewrite 2 t_xor_eq, 2 Rotr_eq, Shr_eq by reflexivity.
reflexivity.
Qed.

Definition lt (n m : nat) : bool :=
    nat_rect (fun _ => nat -> unit -> bool)
        (fun m => nat_rect (fun _ => unit -> bool)
            (fun dummy => false)
            (fun m' IHm dummy => true)
            m)
        (fun n' IHn => fun m => nat_rect (fun _ => unit -> bool)
            (fun dummy => false)
            (fun m IHm dummy => IHn m dummy)
            m)
        n m tt.

Lemma lt_correct : forall n m,
    lt n m = true <-> (n < m)%nat.
induction n; destruct m; split; intros; simpl in *.
all: try solve [discriminate | exfalso; omega].
all: try solve [reflexivity].
all: try solve [omega].
- change (lt (S n) (S m)) with (lt n m) in *.
  rewrite IHn in *. omega.
- change (lt (S n) (S m)) with (lt n m).
  rewrite IHn. omega.
Qed.

Definition List_length {A} (l : list A) : nat :=
    list_rect _
        0%nat
        (fun _ _ IHl => S IHl)
        l.

Lemma List_length_eq : forall {A} (l : list A),
    List_length l = List.length l.
induction l; simpl; try congruence.
Qed.

Definition W' (M : nat -> N) (t : nat) : list N :=
    nat_rect _
        ([M 0])%nat
        (fun t' IHt =>
            bool_rect (fun _ => list N)
                (M (S t') :: IHt)
                (t_add (t_add (sigma_1 (nthi IHt 1)) (nthi IHt 6))
                       (t_add (sigma_0 (nthi IHt 14)) (nthi IHt 15))
                    :: IHt)
                (lt (List_length IHt) 16))
        t.

Lemma W'_length : forall M t,
    length (W' M t) = S t.
induction t; simpl; try reflexivity.
destruct (lt _ 16); simpl; congruence.
Qed.

Lemma W'_nthi_S : forall M t i,
    nthi (W' M (S t)) (S i) = nthi (W' M t) i.
intros.
simpl. destruct (lt _ 16); simpl.
all: cbn [nthi list_rect nat_rect].
all: fold (nthi (W' M t) i).
all: reflexivity.
Qed.

Lemma W'_eq : forall M M' t i,
    (i <= t)%nat ->
    (forall t, M t = M' t) ->
    nthi (W' M t) i = SHA256_N.W M' (t - i).
induction t; induction i; intros0 Hi HM.

- simpl. rewrite <- HM. reflexivity.

- exfalso. omega.

- rewrite Nat.sub_0_r.
  destruct (lt_dec (S t) 16) as [Hlt | Hge].

  + rewrite SHA256_N.W_unfold_last by omega.
    rewrite <- lt_correct in Hlt.
    simpl. rewrite W'_length, Hlt. simpl. cbn [nthi list_rect nat_rect].
    eapply HM.

  + replace (S t) with (16 + (S t - 16))%nat at 2 by omega.
    rewrite SHA256_N.W_unfold.
    remember (SHA256_N.t_add _ _) as rhs.

    pose proof Hge as Hge'.
    rewrite <- lt_correct in Hge'. destruct (lt _ _) eqn:Hlt; try congruence.
    simpl. rewrite W'_length, Hlt. simpl.
    cbn [nthi list_rect nat_rect].

    rewrite 4 IHt; auto; try omega.
    subst rhs.
    rewrite 3 t_add_eq, sigma_1_eq, sigma_0_eq.
    f_equal; f_equal; [ f_equal | | f_equal ]; f_equal; omega.

- rewrite W'_nthi_S. replace (S t - S i)%nat with (t - i)%nat by omega.
  eapply IHt. omega. auto.
Qed.

Definition W (M : nat -> N) (t : nat) : N :=
    list_rect (fun _ => N)
        0%N
        (fun x _ _ => x)
        (W' M t).

Lemma W_eq : forall M M' t,
    (forall t, M t = M' t) ->
    W M t = SHA256_N.W M' t.
intros.
replace t with (t - 0)%nat at 2 by omega.
erewrite <- W'_eq with (i := 0%nat); cycle 1.
  { omega. }
  { auto. }
unfold W. destruct (W' M t); simpl; reflexivity.
Qed.

Definition registers := (N * N * N * N * N * N * N * N)%type.

Definition rnd_function (x : registers) (k : N) (w : N) : registers :=
    prod_rect (fun _ => registers) (fun abcdefg h =>
    prod_rect (fun _ => registers) (fun abcdef g =>
    prod_rect (fun _ => registers) (fun abcde f =>
    prod_rect (fun _ => registers) (fun abcd e =>
    prod_rect (fun _ => registers) (fun abc d =>
    prod_rect (fun _ => registers) (fun ab c =>
    prod_rect (fun _ => registers) (fun a b =>
        (t_add (t_add (t_add (t_add (t_add h (Sigma_1 e)) (Ch e f g)) k) w)
               (t_add (Sigma_0 a) (Maj a b c)),
         a, b, c,
         t_add d (t_add (t_add (t_add (t_add h (Sigma_1 e)) (Ch e f g)) k) w),
         e, f, g)
    ) ab) abc) abcd) abcde) abcdef) abcdefg) x.

Lemma rnd_function_eq : forall x k w,
    rnd_function x k w = SHA256_N.rnd_function x k w.
intros.
destruct x as [[[[[[[a b] c] d] e] f] g] h].
simpl.
repeat rewrite t_add_eq.
rewrite Sigma_1_eq, Ch_eq, Sigma_0_eq, Maj_eq.
reflexivity.
Qed.

Definition Round (regs : registers) (M : nat -> N) (t : nat) : registers :=
    nat_rect _
        (rnd_function regs (nthi_K256 0) (W M 0))
        (fun t' IHt => rnd_function IHt (nthi_K256 (S t')) (W M (S t')))
        t.

Lemma Round_eq : forall regs M M' t,
    (forall t, M t = M' t) ->
    Round regs M t = SHA256_N.Round regs M' t.
induction t; intros0 HM; unfold Round; cbn [nat_rect].

- rewrite rnd_function_eq. unfold W; simpl.
  rewrite <- HM. reflexivity.

- fold (Round regs M t). rewrite rnd_function_eq.
  rewrite IHt by auto. rewrite nthi_K256_eq. erewrite W_eq by auto.
  reflexivity.
Qed.

Definition hash_block (r : registers) (block : list N) : registers :=
    prod_rect (fun _ => registers) (fun abcdefg0 h0 =>
    prod_rect (fun _ => registers) (fun abcdef0 g0 =>
    prod_rect (fun _ => registers) (fun abcde0 f0 =>
    prod_rect (fun _ => registers) (fun abcd0 e0 =>
    prod_rect (fun _ => registers) (fun abc0 d0 =>
    prod_rect (fun _ => registers) (fun ab0 c0 =>
    prod_rect (fun _ => registers) (fun a0 b0 =>
    prod_rect (fun _ => registers) (fun abcdefg1 h1 =>
    prod_rect (fun _ => registers) (fun abcdef1 g1 =>
    prod_rect (fun _ => registers) (fun abcde1 f1 =>
    prod_rect (fun _ => registers) (fun abcd1 e1 =>
    prod_rect (fun _ => registers) (fun abc1 d1 =>
    prod_rect (fun _ => registers) (fun ab1 c1 =>
    prod_rect (fun _ => registers) (fun a1 b1 =>
        (t_add a0 a1,
         t_add b0 b1,
         t_add c0 c1,
         t_add d0 d1,
         t_add e0 e1,
         t_add f0 f1,
         t_add g0 g1,
         t_add h0 h1)
    ) ab1) abc1) abcd1) abcde1) abcdef1) abcdefg1) (Round r (nthi block) 63)
    ) ab0) abc0) abcd0) abcde0) abcdef0) abcdefg0) r.

Opaque Round t_add nthi.
Opaque SHA256_N.Round SHA256_N.t_add SHA256_N.nthi.
Lemma hash_block_eq : forall r block,
    hash_block r block = SHA256_N.hash_block r block.
intros.
destruct r as [[[[[[[a0 b0] c0] d0] e0] f0] g0] h0].
compute.
erewrite Round_eq by eapply nthi_eq.
destruct (SHA256_N.Round _ _ _) as [[[[[[[a1 b1] c1] d1] e1] f1] g1] h1].
rewrite 8 t_add_eq. reflexivity.
Qed.
Transparent Round t_add nthi.
Transparent SHA256_N.Round SHA256_N.t_add SHA256_N.nthi.

Definition pairs_to_list_16 x : list N :=
    prod_rect (fun _ => list N) (fun x0 x1 =>

    prod_rect (fun _ => list N) (fun x00 x01 =>
    prod_rect (fun _ => list N) (fun x10 x11 =>

    prod_rect (fun _ => list N) (fun x000 x001 =>
    prod_rect (fun _ => list N) (fun x010 x011 =>
    prod_rect (fun _ => list N) (fun x100 x101 =>
    prod_rect (fun _ => list N) (fun x110 x111 =>

    prod_rect (fun _ => list N) (fun x0000 x0001 =>
    prod_rect (fun _ => list N) (fun x0010 x0011 =>
    prod_rect (fun _ => list N) (fun x0100 x0101 =>
    prod_rect (fun _ => list N) (fun x0110 x0111 =>
    prod_rect (fun _ => list N) (fun x1000 x1001 =>
    prod_rect (fun _ => list N) (fun x1010 x1011 =>
    prod_rect (fun _ => list N) (fun x1100 x1101 =>
    prod_rect (fun _ => list N) (fun x1110 x1111 =>

    [x0000; x0001; x0010; x0011;
     x0100; x0101; x0110; x0111;
     x1000; x1001; x1010; x1011;
     x1100; x1101; x1110; x1111]

    ) x111) x110) x101) x100) x011) x010) x001) x000
    ) x11) x10) x01) x00
    ) x1) x0
    ) x.

(* used for verification only *)
Definition hash_blocks' (r : registers) msg_blocks : registers :=
    list_rect _
        (fun r => r)
        (fun block msg IHmsg => fun r =>
            IHmsg (hash_block r (pairs_to_list_16 block)))
        msg_blocks r.

Definition hash_blocks (r : registers) (msg : list N) : registers :=
    list_rect _
        (fun r => r)
        (fun block msg IHmsg => fun r =>
            IHmsg (hash_block r (pairs_to_list_16 block)))
        (pair_up (pair_up (pair_up (pair_up msg)))) r.

Lemma hash_blocks'_unfold_cons : forall r block blocks,
    hash_blocks' r (block :: blocks) = hash_blocks' (hash_block r (pairs_to_list_16 block)) blocks.
intros. reflexivity.
Qed.

Lemma pair_up_unfold_cons : forall {A} (x1 x2 : A) xs,
    pair_up (x1 :: x2 :: xs) = (x1, x2) :: pair_up xs.
intros. reflexivity.
Qed.

Lemma hash_blocks_eq : forall r msg,
    (length msg mod 16 = 0)%nat ->
    hash_blocks r msg = SHA256_N.hash_blocks r msg.
intros0 Hlen.
unfold hash_blocks. fold (hash_blocks' r (pair_up (pair_up (pair_up (pair_up msg))))).
remember (pair_up _) as msg_p.
revert msg_p msg r Hlen Heqmsg_p. induction msg_p; intros.

- do 16 try destruct msg as [| ?m0 msg ].
  (* empty msg *)
    { reflexivity. }

  (* uneven-length messages *)
    all: try solve [exfalso; simpl in Hlen; discriminate Hlen].

  (* impossible - nil = cons *)
    { exfalso. repeat rewrite pair_up_unfold_cons in Heqmsg_p. discriminate. }

- rewrite hash_blocks'_unfold_cons.

  do 16 try destruct msg as [| ?m0 msg ].
  (* empty msg *)
    { discriminate Heqmsg_p. }
  (* uneven-length messages *)
    all: try solve [exfalso; simpl in Hlen; discriminate Hlen].

  (* remaining case: nonempty message of appropriate length *)
  repeat rewrite pair_up_unfold_cons in Heqmsg_p.
  change (length _) with (16 + length msg)%nat in Hlen.
  invc Heqmsg_p. simpl.
  rewrite hash_block_eq.
  eapply IHmsg_p; eauto.

  + rewrite Nat.add_mod in Hlen by discriminate.
    change (16 mod 16)%nat with (0 mod 16)%nat in Hlen.
    rewrite <- Nat.add_mod in Hlen by discriminate.
    exact Hlen.
Qed.

Definition SHA_256 (str : list N) : list N :=
    prod_rect (fun _ => list N) (fun abcdefg h =>
    prod_rect (fun _ => list N) (fun abcdef g =>
    prod_rect (fun _ => list N) (fun abcde f =>
    prod_rect (fun _ => list N) (fun abcd e =>
    prod_rect (fun _ => list N) (fun abc d =>
    prod_rect (fun _ => list N) (fun ab c =>
    prod_rect (fun _ => list N) (fun a b =>
    wordlist_to_bytelist [a; b; c; d; e; f; g; h]
    ) ab) abc) abcd) abcde) abcdef) abcdefg)
    (hash_blocks
        (* init_registers *)
        (1779033703, 3144134277, 1013904242, 2773480762,
         1359893119, 2600822924,  528734635, 1541459225)%N
     (generate_and_pad str)).

Lemma SHA_256_eq : forall str,
    SHA_256 str = SHA256_N.SHA_256 str.
intros.
unfold SHA_256.
rewrite generate_and_pad_eq.
rewrite hash_blocks_eq.
fold SHA256_N.init_registers.

unfold SHA256_N.SHA_256.
destruct (SHA256_N.hash_blocks _ _) as [[[[[[[a b] c] d] e] f] g] h].
cbn [prod_rect]. apply wordlist_to_bytelist_eq.
apply SHA256_N.generate_and_pad_length.
Qed.