Require Import List.
Require Import Peano_dec.
Require Import Compare_dec.
Require Import Lt Le Gt.
Require Import Sorts. Import withoutProp.

(** * Term definition for PTS and de Bruijn manipulation . *)
(** * Usual Term syntax .*)

(** Term syntax:*)
Inductive Term : Set :=
| Var : Vars -> Term
| Sort : Sorts -> Term
| Π : Term -> Term -> Term
| λ : Term -> Term -> Term
| App : Term -> Term -> Term
| Σ : Term -> Term -> Term
| Pair : Term -> Term -> Term
| π1 : Term -> Term
| π2 : Term -> Term
| Bool : Term
| true : Term
| false : Term
| If : forall (P true' false' b : Term), Term
| Eq : forall (A M N : Term), Term
| refle : Term -> Term
| J : forall (A P M1 N M2 p : Term), Term
.

Notation "# v" := (Var v) (at level 1) : UT_scope.
Notation "! s" := (Sort s) (at level 1) : UT_scope.
Notation "x · y" := (App x y) (at level 15, left associativity) : UT_scope.
Notation "⟨ A , B ⟩" := (Pair A B) (at level 4) : UT_scope.
Delimit Scope UT_scope with UT.
Open Scope UT_scope.

Reserved Notation " t ↑ x # n " (at level 5, x at level 0, left associativity).

(** In order to deal with variable bindings and captures, we need a lift
function to deal with free and bounded variables.
[M ↑ n # k recursivly add [n] to all variables that are
 above [k] in [M]. *)
Fixpoint lift_rec (n:nat) (k:nat) (T:Term) {struct T}
  := match T with
     | # x =>  if le_gt_dec k x then Var (n+x) else Var x
     | ! s => !s
     | M · N =>  App (M ↑ n # k) (N ↑ n # k)
     | Π  A B => Π  (A ↑ n # k) (B ↑ n # (S k))
     | λ A M => λ (A ↑ n # k) (M ↑ n # (S k))
     | Σ A B => Σ (A ↑ n # k) (B ↑ n # (S k))
     | ⟨ M , N ⟩ => ⟨ (M ↑ n # k) , (N ↑ n # k) ⟩
     | π1 M => π1 (M ↑ n # k)
     | π2 M => π2 (M ↑ n # k)
     | Bool => Bool
     | true => true
     | false => false
     | If P M N b => If (P ↑ n # (S k)) (M ↑ n # k) (N ↑ n # k) (b ↑ n # k)
     | Eq A t1 t2 => Eq (A ↑ n # k) (t1 ↑ n # k) (t2 ↑ n # k)
     | refle t => refle (t ↑ n # k)
     | J A P t1 u t2 p => J (A ↑ n # k) (P ↑ n # (S k)) (t1 ↑ n # k)
                           (u ↑ n # k) (t2 ↑ n # k) (p ↑ n # k)
     end
where "t ↑ n # k" := (lift_rec n k t) : UT_scope.

Notation " t ↑ n " := (lift_rec n 0 t) (at level 5, n at level 0, left associativity) : UT_scope.
Notation " t ↑ " := (lift_rec 1 0 t) (at level 5, left associativity) : UT_scope.

(** We will consider the usual implicit substitution without variable capture
(this is where the lift operator comes in handy).
  [ M [ n ← N ] ] replace the variable [n] in [M] by the term [N].
 *)
Reserved Notation "t [ x ← u ]" (at level 5, x at level 0, left associativity).

Fixpoint subst_rec u t n {struct t} :=
  match t with
  | # x => match (lt_eq_lt_dec x n) with
          | inleft (left _) => # x (* x < n *)
          | inleft (right _) => u ↑ n  (* x = n *)
          | inright _ => # (x - 1) (* x > n *)
          end
  | ! s => ! s
  | M · N => (M [ n ← u ]) · ( N [ n ← u ])
  | Π  A B => Π ( A [ n ← u ] ) (B [ S n ← u ])
  | λ  A M => λ (A [ n ← u ]) (M [ S n ← u ])
  | Σ  A B => Σ ( A [ n ← u ] ) (B [ S n ← u ])
  | ⟨ M , N ⟩ => ⟨ (M [ n ← u ]) , (N [ n ← u ]) ⟩
  | π1 M => π1 (M [ n ← u ])
  | π2 M => π2 (M [ n ← u ])
  | Bool => Bool
  | true => true
  | false => false
  | If P M N b => If (P [ S n ← u ]) (M [ n ← u ]) (N [ n ← u ]) (b [ n ← u ])
  | Eq A t1 t2 => Eq (A [ n ← u ]) (t1 [ n ← u ]) (t2 [ n ← u ])
  | refle t => refle (t [ n ← u ])
  | J A P t1 u t2 p => J (A [ n ← u ]) (P [ S n ← u ]) (t1 [ n ← u ])
                        (u [ n ← u ]) (t2 [ n ← u ]) (p [ n ← u ])
  end
where " t [ n ← u ] " := (subst_rec u t n) : UT_scope.

Notation " t [ ← u ] " := (subst_rec u t 0) (at level 5) : UT_scope.

(** Since we use de Bruijn indexes, Environment (or Context) are
simply lists of terms:  Γ(x:A) is encoded as  [A::Γ]. *)

Definition Env := list Term.

Set Implicit Arguments.

Inductive item (A:Type) (x:A): list A -> nat -> Prop :=
| item_hd: forall Γ :list A, (item x (cons x Γ) O)
| item_tl: forall (Γ:list A)(n:nat)(y:A), item x Γ n -> item x (cons y Γ) (S n).

Hint Constructors item.

(** In the list [Γ], the [n]th item is syntacticaly [x]. *)
Notation " x ↓ n ∈ Γ " := (item x Γ n) (at level 80, no associativity) : UT_scope.

(** In the list [Γ], [t] is  [n]th element correctly lifted according to [Γ]:
e.g.: if t ↓ n ⊂ Γ and we insert something in Γ, then
we can still speak about t without think of the lift hidden by the insertion. *)

Definition item_lift (t:Term) (Γ:Env) (n:nat) :=
  exists u ,  t= u ↑ (S n) /\  u ↓ n ∈ Γ .

Hint Unfold item_lift.
Notation " t ↓ n ⊂ Γ " := (item_lift t Γ n) (at level 80, no associativity): UT_scope.

(** ** Usual Beta-reduction:
 - one step
 - multi step (reflexive, transitive closure)
 - converesion (reflexive, symetric, transitive closure)
 *)
Reserved Notation " A → B " (at level 80).

Inductive Beta : Term -> Term -> Prop :=
| Beta_head  : forall A M N, (λ A M) · N → M [← N]
| Beta_eq    : forall A P M N, J A P M N M (refle M) → N
| Beta_prod1 : forall M N, π1 ⟨M, N⟩ → M
| Beta_prod2 : forall M N, π2 ⟨M, N⟩ → N
| Beta_prod_eta : forall M, ⟨π1 M, π2 M⟩ → M
| Beta_Bool1 : forall A M N , If A true M N → M
| Beta_Bool2 : forall A M N , If A false M N → N
(* Congruence rules *)
| Beta_Π1    : forall A A' B , A → A' -> Π A B → Π A' B
| Beta_Π2    : forall A B  B', B → B' -> Π A B → Π A  B'
| Beta_λ1    : forall A A' M , A → A' -> λ A M → λ A' M
| Beta_λ2    : forall A M  M', M → M' -> λ A M → λ A  M'
| Beta_App1  : forall M M' N , M → M' -> M · N  → M' · N
| Beta_App2  : forall M N  N', N → N' -> M · N  → M · N'
| Beta_Eq1   : forall A A' M N, A → A' -> Eq A M N → Eq A' M N
| Beta_Eq2   : forall A M M' N, M → M' -> Eq A M N → Eq A M' N
| Beta_Eq3   : forall A M N N', N → N' -> Eq A M N → Eq A M N'
| Beta_refle : forall M M' , M → M' -> refle M  → refle M'
| Beta_J1     : forall A A' P M1 N M2 p, A → A' -> J A P M1 N M2 p → J A' P M1 N M2 p
| Beta_J2     : forall A P P' M1 N M2 p, P → P' -> J A P M1 N M2 p → J A P' M1 N M2 p
| Beta_J3     : forall A P M1 M1' N M2 p, M1 → M1' -> J A P M1 N M2 p → J A P M1' N M2 p
| Beta_J4     : forall A P M1 N N' M2 p, N → N' -> J A P M1 N M2 p → J A P M1 N' M2 p
| Beta_J5     : forall A P M1 N M2 M2' p, M2 → M2' -> J A P M1 N M2 p → J A P M1 N M2' p
| Beta_J6     : forall A P M1 N M2 p p', p → p' -> J A P M1 N M2 p → J A P M1 N M2 p'
| Beta_Σ1    : forall A A' B , A → A' -> Σ A B → Σ A' B
| Beta_Σ2    : forall A B  B', B → B' -> Σ A B → Σ A  B'
| Beta_Pair1 : forall M M' N, M → M' -> ⟨ M , N ⟩  → ⟨ M' , N ⟩
| Beta_Pair2 : forall M N N', N → N' -> ⟨ M , N ⟩  → ⟨ M , N' ⟩
| Beta_π1    : forall M M', M → M' -> π1 M  → π1 M'
| Beta_π2    : forall M M', M → M' -> π2 M  → π2 M'
| Beta_If1   : forall A A' b M N, A → A' -> If A b M N → If A' b M N
| Beta_If2   : forall A b b' M N, b → b' -> If A b M N → If A b' M N
| Beta_If3   : forall A b M M' N, M → M' -> If A b M N → If A b M' N
| Beta_If4   : forall A b M N N', N → N' -> If A b M N → If A b M N'
where "M → N" := (Beta M N) : UT_scope.

Reserved Notation " A →→ B " (at level 80).

Inductive Betas : Term -> Term -> Prop :=
| Betas_refl  : forall M    , M →→ M
| Betas_Beta  : forall M N  , M → N  -> M →→ N
| Betas_trans : forall M N P, M →→ N -> N →→ P -> M →→ P
where  " A →→ B " := (Betas A B) : UT_scope.

Reserved Notation " A ≡ B " (at level 80).

Inductive Betac : Term -> Term -> Prop :=
| Betac_Betas : forall M N  , M →→ N -> M ≡ N
| Betac_sym   : forall M N  , M ≡ N  -> N ≡ M
| Betac_trans : forall M N P, M ≡ N  -> N ≡ P -> M ≡ P
where " A ≡ B " := (Betac A B)  : UT_scope.

Hint Constructors Beta.
Hint Constructors Betas.
Hint Constructors Betac.

(** Typing judgements:*)
Reserved Notation "Γ ⊢ t : T" (at level 80, t, T at level 30, no associativity) .
Reserved Notation "Γ ⊣ " (at level 80, no associativity).

Notation "A ⇒ B" := (Π A (B ↑)) (at level 20, right associativity).
Definition empty := Π !(U 0) #0.
Notation "⊥" := empty.

Inductive wf : Env -> Prop :=
| wf_nil   : nil ⊣
| wf_cons : forall Γ A s, Γ ⊢ A : !s -> A::Γ ⊣
where "Γ ⊣" := (wf Γ) : UT_scope
with
typ : Env -> Term -> Term -> Prop :=
| cVar  : forall Γ A v, Γ ⊣ -> A ↓ v  ⊂ Γ -> Γ ⊢ #v : A
| cSort : forall Γ s s', Γ ⊣ -> Ax s s' -> Γ  ⊢ !s : !s'
| cΠ   : forall Γ A B s s' s''  , Rel s s' s'' -> Γ ⊢ A : !s -> A::Γ ⊢ B : !s' -> Γ ⊢  Π  A B : !s''
| cλ   : forall Γ A B s s' s'' M, Rel s s' s'' -> Γ ⊢ A : !s -> A::Γ ⊢ B : !s' -> A::Γ ⊢ M : B
               -> Γ ⊢ λ A M : Π  A B
| cApp  : forall Γ M N A B , Γ ⊢ M : Π A B -> Γ ⊢ N : A -> Γ ⊢ M · N : B[←N]
| cΣ : forall Γ A B i j, Γ ⊢ A : !(U i) -> A::Γ ⊢ B : !(U j) -> Γ ⊢ Σ A B : !(U (max i j))
| cPair : forall Γ M N A B, Γ ⊢ M : A -> Γ ⊢ N : B [←M] -> Γ ⊢ ⟨M,N⟩ : Σ A B
| cπ1 : forall Γ M A B, Γ ⊢ M : Σ A B -> Γ ⊢ π1 M : A
| cπ2 : forall Γ M A B, Γ ⊢ M : Σ A B -> Γ ⊢ π2 M : B[← π1 M]
| cBool : forall Γ i, Γ ⊣ -> Γ ⊢ Bool : !(U i)
| cTrue : forall Γ, Γ ⊣ -> Γ ⊢ true : Bool
| cFalse : forall Γ, Γ ⊣ -> Γ ⊢ false : Bool
| cIf : forall Γ P M N b s, Bool :: Γ ⊢ P : !s -> Γ ⊢ M : P[←true] -> Γ ⊢ N : P[←false]
                                   -> Γ ⊢ b : Bool -> Γ ⊢ (If P b M N) : P[←b]
| cEq : forall Γ A t1 t2 s, Γ ⊢ A : !s -> Γ ⊢ t1 : A -> Γ ⊢ t2 : A -> Γ ⊢ Eq A t1 t2 : !s
| crefle : forall Γ t A, Γ ⊢ t : A -> Γ ⊢ refle t : Eq A t t
| cJ : forall Γ A P t1 u t2 p s, A :: Γ ⊢ P : !s -> Γ ⊢ u : P[←t1] -> Γ ⊢ p : Eq A t1 t2
                                -> Γ ⊢ J A P t1 u t2 p : P[←t2]
| Cnv   : forall Γ M A B s, A ≡ B  -> Γ ⊢ M : A -> Γ ⊢ B : !s -> Γ ⊢ M : B
where "Γ ⊢ t : T" := (typ Γ t T) : UT_scope.

Hint Constructors wf typ.
Open Scope UT_scope.

Scheme typ_ind' := Induction for typ Sort Prop
with wf_ind' := Induction for wf Sort Prop.
Combined Scheme typ_induc from typ_ind', wf_ind'.

Lemma wf_typ : forall Γ t T, Γ ⊢ t : T -> Γ ⊣.
induction 1; eauto.
Qed.


From hahn Require Import Hahn.
From imm Require Import Events.
From imm Require Import Prog.
From imm Require Import ProgToExecution.

Require Import Action.
Require Import Formula.
Import Formula.Properties.
Import Formula.Syntax.
Require Import PredTransformer.
Require Import AuxDef.
Require Import AuxRel.
Require Import Language.
Require Import Events.
Require Import Coq.Program.Basics.

Open Scope program_scope.

Set Implicit Arguments.

(** * Pomsets with Predicate Transformers

    In this file we define Pomsets with Predicate Transformers (PwT)
    (corresponding to Definition 4.4).

    The definition comprises three parts:
    - [Record pomset] defines _components_ of PwTs.
    - [Record wf] (well-formedness) defines _properties_ of PwTs.
    - [Record complete] defines properties making a PwT _complete_
*)

(** Defines _components_ of PwT as a tuple (𝐸,𝜆,𝜅,𝜏,✓,⊴). *)
Record pomset := {
  (* M1 *)
  events : list Event.t;

  (* M2 *)
  λ : Event.t -> action;

  (* M3 *)
  κ : Event.t -> Formula.t;

  (* M4 *)
  τ : (Event.t -> Prop) -> Formula.t -> Formula.t;

  (* M5 *)
  (* Termination condition ✓ *)
  term   : Formula.t;

  (* M6 *)
  (* Dependency order ⊴ *)
  dep    : relation Event.t;
  }.

Definition events_set P := lset (events P).

Section PomsetRelations.
Local Open Scope formula_scope.

Variable P : pomset.
Variable P' : pomset.

Let E  := (events_set P ).
Let E' := (events_set P').
Let Tid_ t := (fun x => α (λ P x) = t).
Let Tid_' t := (fun x => α (λ P' x) = t).

Record pomset_equiv :=
  {
  events_equiv  : E ≡₁ E';
  labels_equiv  : func_equiv (λ P) (λ P');
  κ_equiv       : forall e, κ P e ⇔ κ P' e;
  pt_equiv      : forall (e_set : Event.t -> Prop) (φ : Formula.t),
                             (τ P) e_set φ ⇔ (τ P') e_set φ;
  term_equiv    : term P ⇔ term P';
  dep_equiv     : dep    P ≡ dep    P';
  }.

Record pomset_superset :=
  {
  sup_acts_set : E' ⊆₁ E ;
  sup_λ        : forall e (EE : E' e), λ P' e = λ P e;
  sup_κ        : forall e (EE : E' e), κ P' e = κ P e;

  sup_τ        : forall e_set φ, e_set ⊆₁ E' -> τ P' φ = τ P φ;
  sup_dep      : dep P' ⊆ dep P;
  }.

Record thread_restricted_pomset (α : thread_id) :=
  {
  tr_acts_set : E' ≡₁ E ∩₁ Tid_ α;
  tr_superset : pomset_superset
  }.

End PomsetRelations.

Add Morphism events_set with signature
    pomset_equiv ==> eq ==> iff as events_set_more.
Proof. intros x y HH e. by split; ins; apply HH. Qed.

Lemma pomset_equiv_reflexive : reflexive pomset_equiv.
Proof.
  intro P.
  split; auto.
  1: ins.
  all: by split; apply entails_refl.
Qed.

Ltac pomset_equiv_rewrite :=
  repeat match goal with
         | EQ : pomset_equiv _ _ |- _ =>
           rewrite (events_equiv EQ); auto
         | EQ : pomset_equiv _ _ |- _ =>
           rewrite (labels_equiv EQ); auto
         | EQ : pomset_equiv _ _ |- _ =>
           rewrite (pt_equiv EQ); auto
         | EQ : pomset_equiv _ _ |- _ =>
           rewrite (term_equiv EQ)
         | EQ : pomset_equiv _ _ |- _ =>
           rewrite (dep_equiv EQ)
         | EQ : pomset_equiv _ _ |- _ =>
           rewrite (κ_equiv EQ)
         end.

Lemma pomset_equiv_symmetric : symmetric pomset_equiv.
Proof.
  red. ins.
  constructor; unfold func_equiv; ins; pomset_equiv_rewrite; reflexivity.
Qed.

Lemma pomset_equiv_transitive : transitive pomset_equiv.
Proof.
  red. intros x y z XY YZ. constructor.
  all: try by etransitivity; [by apply XY|]; apply YZ.
  unfold func_equiv; ins; pomset_equiv_rewrite; reflexivity.
Qed.

Add Relation pomset pomset_equiv
    reflexivity  proved by pomset_equiv_reflexive
    symmetry     proved by pomset_equiv_symmetric
    transitivity proved by pomset_equiv_transitive
      as pomset_equiv_rel.

Section Pomset.
Local Open Scope formula_scope.
(* Local Open Scope auxdef_scope. *)

Variable P : pomset.

Notation "'E'" := (events_set P).

Notation "'λ'" := (λ P).
Notation "'τ'" := (τ P).
Notation "'κ'" := (κ P).
Notation "'term'" := (term P).

Notation "'dep'" := (dep P).

Notation "e1 ⊴ e2" := (dep e1 e2) (at level 14).

Notation "'R'" := (fun a => is_r' (λ a)).
Notation "'W'" := (fun a => is_w' (λ a)).

Definition θ' := List.fold_left
                  (fun ψ e => match imm_lbl (λ e) with
                           | Aload _ _ _ v =>
                             Formula.eqEE (Expr.ereg e) (Expr.val v) ∧ ψ
                           | _ => ψ
                           end)
                  (events P)
                  Formula.tt.

Definition θ (events_l : list Event.t) lbl := List.flat_map
                               (fun e => match imm_lbl (lbl e) with
                                      | Aload _ _ _ v => [(e, v)]
                                      | _ => []
                                      end)
                               events_l.

Definition lconsistent φ :=
  Formula.satisfiable (Formula.subst_ereg_val_list φ (θ (events P) λ)).

Lemma tautology_lconsistent φ
      (TAUT : Formula.tautology φ) :
  lconsistent φ.
Proof.
  by apply taut_satisfiable, taut_subst_ereg_val_list.
Qed.

Lemma lconsistent_disj φ ψ (LCONS : lconsistent φ \/ lconsistent ψ) :
  lconsistent (φ ∨ ψ).
Proof using.
  red. rewrite subst_ereg_val_list_alt.
  apply sat_disj, LCONS.
Qed.

Lemma q_lconsistent x :
  lconsistent (Formula.q x).
Proof.
  unfold lconsistent.
  rewrite subst_ereg_val_list_alt.
  apply sat_q.
Qed.

Lemma theta_func_list events_l lbl:
  func_list (θ events_l lbl).
Proof.
  unfold θ. red; ins.
  apply in_flat_map in IN, IN'.
  desf; ins; desf; ins; subst.
  congruence.
Qed.

Lemma theta_app l l' lbl :
  θ (l ++ l') lbl = θ l lbl ++ θ l' lbl.
Proof.
  unfold θ. by rewrite flat_map_app.
Qed.

Open Scope list_additional_scope.

Lemma theta_list_minus l l' lbl :
  θ (l -- l') lbl = θ l lbl -- θ l' lbl.
Proof using.
  generalize dependent l'. induction l; ins.
  destruct (classic (In a l')) as [IN|NIN].
  { rewrite list_minus_cons_in; auto. desf. unfold app.
    rewrite list_minus_cons_in; auto.
    unfold θ. apply in_flat_map. eexists. splits; eauto.
    desf. }
  rewrite list_minus_cons_nin; auto. desf; ins; desf; ins.
  rewrite list_minus_cons_nin; auto.
  { by rewrite IHl. }
  intros HH. apply in_flat_map in HH. desf. inv HH0.
Qed.

Lemma theta_lbl_eqdom l lbl lbl'
      (EQDOM : eq_dom (lset l) lbl lbl') :
  θ l lbl = θ l lbl'.
Proof using.
  unfold θ.
  rewrite !flat_map_concat_map.
  erewrite map_eq_dom; eauto.
  unfold eq_dom in *; ins; desf.
  all: rewrite EQDOM in Heq; eauto; rewrite Heq in Heq0; basic_solver.
Qed.

Lemma theta_map_fst l lbl :
  map fst (θ l lbl) = filter (is_r (imm_lbl ∘ lbl)) l.
Proof.
  induction l; ins; desf.
  { rewrite map_app; ins.
    rewrite IHl; auto. }
  all: by unfold compose, is_r in Heq0; ins; desf.
Qed.

(** Defines _properties_ of PwT. It shadows Definitions 4.4 and A.2. *)
Record wf :=
  {
    (* M4 with 𝜆-consistency (see Definition A.2) *)
    wf_pt : forall D,  predTransformer (τ D);
    wf_lpt : forall D φ (CONS : lconsistent (τ D φ)), lconsistent φ;

    wf_pt_se_indep : forall φ e_ext v D (NOTINE : ~ (events_set P e_ext)),
        Formula.subst_ereg_val (τ D φ) e_ext v
        ⇔
        τ D (Formula.subst_ereg_val φ e_ext v);

    wf_pt_family : forall D C (CED : (C ∩₁ E) ⊆₁ D) ψ, τ C ψ ⊨ τ D ψ;

    (* M5a *)
    wf_term : term ⊨ τ E (Formula.tt);

    (* M6 *)
    wf_dep_pord    : strict_partial_order dep;
    wf_depE        : dep ≡ ⦗E⦘ ⨾ dep ⨾ ⦗E⦘;

    (* In COQ, functions are total.
       As such, λ κ must be defined outside E as well. *)
    wf_ninEλ : forall e (NIN : ~ E e), λ e = def_action;
    wf_ninEκ : forall e (NIN : ~ E e), κ e ⇔ Formula.tt;
  }.

Lemma wf_pt_family_subset (WF : wf) D C (EQ : C ⊆₁ D) ψ: τ C ψ ⊨ τ D ψ.
Proof using.
  apply wf_pt_family; auto; generalize EQ; basic_solver.
Qed.

Lemma wf_pt_family_equiv (WF : wf) D C (EQ : C ≡₁ D) ψ: τ C ψ ⇔ τ D ψ.
Proof using.
  by split; apply wf_pt_family_subset, EQ.
Qed.

Lemma wf_pt_family_equiv_on_E (WF : wf) D C ψ
      (EQ : C ∩₁ E ≡₁ D ∩₁ E):
  τ C ψ ⇔ τ D ψ.
Proof using.

  split; apply wf_pt_family; auto.
  { rewrite EQ; basic_solver. }
 rewrite <- EQ; basic_solver.
Qed.

Lemma wf_pt_se_indep_list φ l D
      (WF : wf)
      (NOTINE : set_disjoint (lset (map fst l)) (events_set P)) :
  Formula.subst_ereg_val_list (τ D φ) l
  ⇔
  τ D (Formula.subst_ereg_val_list φ l).
Proof.
  ins.
  induction l; ins; desf.
  { reflexivity. }
  rewrite IHl, wf_pt_se_indep; auto.
  { reflexivity. }
  { intros HH. eapply NOTINE; [|by apply HH].
    red. by constructor. }
  red; ins. eapply NOTINE; eauto.
  red. by constructor.
Qed.

(** Defines a complete pomset, shadowing Definition 4.4 *)
Record complete :=
  { comp_wf : wf;

    (* C3 *)
    comp_precondition : forall e, E e -> Formula.tautology (κ e);

    (* C5 *)
    comp_termination : Formula.tautology term;
  }.

End Pomset.

Definition init_pomset : pomset :=
  {| events := nil;
     λ := fun _ => def_action;
     κ := fun _ => Formula.tt;
     τ := fun _ φ => φ;
     term   := Formula.tt;
     dep    := ∅₂;
  |}.

Lemma wf_init_pomset : wf init_pomset.
Proof.
  unfold init_pomset.
  constructor; ins; try reflexivity.
  all: try by apply strict_partial_order_empty.
  all: try basic_solver 1.
  constructor; ins; reflexivity.
Qed.

Definition local_initialized_pomset (regs : list Reg.t) : pomset :=
  {|  events := nil;
      λ := fun _ => mk_action (Afence Opln) tid_init;
      κ := fun _ => Formula.tt;
      τ := fun _ φ => List.fold_left
                        (fun ψ r => Formula.subst_reg ψ r (Expr.val 0)) regs φ;
      term   := Formula.ff;
      dep    := ∅₂;
  |}.

Add Morphism lconsistent with signature
  eq ==> Formula.equiv ==> iff as lconsistent_more.
Proof.
  ins; desf.
  unfold lconsistent. apply satisfiable_more.
  apply subst_ereg_val_list_more; auto.
Qed.

Add Morphism lconsistent with signature
  eq ==> Formula.entails ==> Basics.impl as lconsistent_mori.
Proof.
  ins; desf.
  unfold lconsistent. apply satisfiable_mori.
  apply subst_ereg_val_list_mori; auto.
Qed.

Lemma pomset_equiv_lset_θ x y (EQ : pomset_equiv x y) :
  lset (θ (events x) (λ x)) ≡₁ lset (θ (events y) (λ y)).
Proof.
  set (QE := pomset_equiv_symmetric EQ).
  unfold lset, θ. split; intros p HH; apply in_flat_map.
  all: apply in_flat_map in HH; destruct HH as [q [IN LL]].
  all: exists q; split; desf.
  all: try by apply (events_equiv QE).
  all: try by rewrite (labels_equiv EQ) in *;
    match goal with
    | H : imm_lbl (λ _ _) = _,
      N : imm_lbl (λ _ _) = _ |- _ => rewrite H in N; inv H
    end.
Qed.

Lemma generalized_lconsistent_more x y ϕ ψ
      (EQ : pomset_equiv x y)
      (EQF : Formula.equiv ϕ ψ) :
  lconsistent x ϕ <-> lconsistent y ψ.
Proof.
  ins; desf.
  unfold lconsistent. apply satisfiable_more.
  erewrite subst_ereg_val_list_eqv_func_lists with (l' := θ (events y) (λ y)).
  { rewrite EQF. reflexivity. }
  { apply theta_func_list. }
    by apply pomset_equiv_lset_θ.
Qed.

Lemma pomset_equiv_pt x y (EQ : pomset_equiv x y) D:
    predTransformer (τ x D) <-> predTransformer (τ y D).
Proof.
  enough (forall x y (EQ : pomset_equiv y x)
                 (HH : predTransformer (τ x D)),
             predTransformer (τ y D)) as AA.
  { split; apply AA; auto. by apply pomset_equiv_symmetric. }
  clear. ins. constructor; ins.
  all: by pomset_equiv_rewrite; apply HH.
Qed.

Add Morphism wf with signature
  pomset_equiv ==> iff as wf_more.
Proof.
  enough (forall x y (EQ : pomset_equiv y x) (WF : wf x), wf y) as AA.
  { split; intros HH; eapply AA in HH; eauto. by symmetry. }
  ins.

  assert (forall r, (λ y ⋄ r) ≡ (λ x ⋄ r)) as OL.
  { ins. unfolder. split; ins; pomset_equiv_rewrite.
    symmetry in EQ. pomset_equiv_rewrite. }

  constructor; ins; pomset_equiv_rewrite; try apply WF.

  all: try by (rewrite OL; apply WF).
  all: try by match goal with
              | |- strict_partial_order _ =>
                unfold strict_partial_order; pomset_equiv_rewrite; apply WF
              end.

  { by eapply pomset_equiv_pt; try apply WF. }
  2: by intro AA; apply NOTINE, EQ.

  4-5: by intros AA; apply NIN; apply EQ.
  3: { etransitivity; [by apply WF|].
       apply wf_pt_family; auto.
       pomset_equiv_rewrite. basic_solver. }
  2: by rewrite <- events_equiv; eauto.

  eapply generalized_lconsistent_more; eauto.
  { reflexivity. }
  eapply WF.
  eapply generalized_lconsistent_more; eauto.
  { eby symmetry. }
  symmetry. apply EQ.
Qed.


From Hammer Require Import Hammer.

Require Import Coq.Bool.Bool.

Set Implicit Arguments.
Set Strict Implicit.

Hint Rewrite negb_orb negb_andb negb_involutive if_negb : bool_rw.

Lemma negb_true : forall a, negb a = true -> a = false.
Proof. hammer_hook "BoolTac" "BoolTac.negb_true".
destruct a; auto.
Qed.

Lemma negb_false : forall a, negb a = false -> a = true.
Proof. hammer_hook "BoolTac" "BoolTac.negb_false".
destruct a; auto.
Qed.

Ltac do_bool' runner :=
( autorewrite with bool_rw in * );
repeat match goal with
| [ H : negb _ = true |- _ ] => apply negb_true in H
| [ H : negb _ = false |- _ ] => apply negb_false in H
| [ H : andb _ _ = true |- _ ] =>
apply andb_true_iff in H; destruct H
| [ H : orb _ _ = false |- _ ] =>
apply orb_false_iff in H; destruct H
| [ H : true = andb _ _ |- _ ] =>
symmetry in H; apply andb_true_iff in H; destruct H
| [ H : false = orb _ _ |- _ ] =>
symmetry in H; apply orb_false_iff in H; destruct H
| [ H : andb _ _ = false |- _ ] =>
apply andb_false_iff in H; runner H
| [ H : orb _ _ = true |- _ ] =>
apply orb_true_iff in H; runner H
| [ H : false = andb _ _ |- _ ] =>
symmetry in H; apply andb_false_iff in H; runner H
| [ H : true = orb _ _ |- _ ] =>
symmetry in H; apply orb_true_iff in H; runner H
end.

Ltac do_bool_case :=
let t H := (destruct H) in do_bool' t.

Ltac do_bool :=
let t _ := idtac in do_bool' t.


(** This files implements the type [coPset] of efficient finite/cofinite sets
of positive binary naturals [positive]. These sets are:

- Closed under union, intersection and set complement.
- Closed under splitting of cofinite sets.

Also, they enjoy various nice properties, such as decidable equality and set
membership, as well as extensional equality (i.e. [X = Y ↔ ∀ x, x ∈ X ↔ x ∈ Y]).

Since [positive]s are bitstrings, we encode [coPset]s as trees that correspond
to the decision function that map bitstrings to bools. *)
From stdpp Require Export sets.
From stdpp Require Import pmap gmap mapset.
From stdpp Require Import options.
Local Open Scope positive_scope.

(** * The tree data structure *)
Inductive coPset_raw :=
  | coPLeaf : bool → coPset_raw
  | coPNode : bool → coPset_raw → coPset_raw → coPset_raw.
Global Instance coPset_raw_eq_dec : EqDecision coPset_raw.
Proof. solve_decision. Defined.

Fixpoint coPset_wf (t : coPset_raw) : bool :=
  match t with
  | coPLeaf _ => true
  | coPNode true (coPLeaf true) (coPLeaf true) => false
  | coPNode false (coPLeaf false) (coPLeaf false) => false
  | coPNode _ l r => coPset_wf l && coPset_wf r
  end.
Global Arguments coPset_wf !_ / : simpl nomatch, assert.

Lemma coPNode_wf_l b l r : coPset_wf (coPNode b l r) → coPset_wf l.
Proof. destruct b, l as [[]|],r as [[]|]; simpl; rewrite ?andb_True; tauto. Qed.
Lemma coPNode_wf_r b l r : coPset_wf (coPNode b l r) → coPset_wf r.
Proof. destruct b, l as [[]|],r as [[]|]; simpl; rewrite ?andb_True; tauto. Qed.
Local Hint Immediate coPNode_wf_l coPNode_wf_r : core.

Definition coPNode' (b : bool) (l r : coPset_raw) : coPset_raw :=
  match b, l, r with
  | true, coPLeaf true, coPLeaf true => coPLeaf true
  | false, coPLeaf false, coPLeaf false => coPLeaf false
  | _, _, _ => coPNode b l r
  end.
Global Arguments coPNode' : simpl never.
Lemma coPNode_wf b l r : coPset_wf l → coPset_wf r → coPset_wf (coPNode' b l r).
Proof. destruct b, l as [[]|], r as [[]|]; simpl; auto. Qed.
Global Hint Resolve coPNode_wf : core.

Fixpoint coPset_elem_of_raw (p : positive) (t : coPset_raw) {struct t} : bool :=
  match t, p with
  | coPLeaf b, _ => b
  | coPNode b l r, 1 => b
  | coPNode _ l _, p~0 => coPset_elem_of_raw p l
  | coPNode _ _ r, p~1 => coPset_elem_of_raw p r
  end.
Local Notation e_of := coPset_elem_of_raw.
Global Arguments coPset_elem_of_raw _ !_ / : simpl nomatch, assert.
Lemma coPset_elem_of_node b l r p :
  e_of p (coPNode' b l r) = e_of p (coPNode b l r).
Proof. by destruct p, b, l as [[]|], r as [[]|]. Qed.

Lemma coPLeaf_wf t b : (∀ p, e_of p t = b) → coPset_wf t → t = coPLeaf b.
Proof.
  induction t as [b'|b' l IHl r IHr]; intros Ht ?; [f_equal; apply (Ht 1)|].
  assert (b' = b) by (apply (Ht 1)); subst.
  assert (l = coPLeaf b) as -> by (apply IHl; try apply (λ p, Ht (p~0)); eauto).
  assert (r = coPLeaf b) as -> by (apply IHr; try apply (λ p, Ht (p~1)); eauto).
  by destruct b.
Qed.
Lemma coPset_eq t1 t2 :
  (∀ p, e_of p t1 = e_of p t2) → coPset_wf t1 → coPset_wf t2 → t1 = t2.
Proof.
  revert t2.
  induction t1 as [b1|b1 l1 IHl r1 IHr]; intros [b2|b2 l2 r2] Ht ??; simpl in *.
  - f_equal; apply (Ht 1).
  - by discriminate (coPLeaf_wf (coPNode b2 l2 r2) b1).
  - by discriminate (coPLeaf_wf (coPNode b1 l1 r1) b2).
  - f_equal; [apply (Ht 1)| |].
    + apply IHl; try apply (λ x, Ht (x~0)); eauto.
    + apply IHr; try apply (λ x, Ht (x~1)); eauto.
Qed.

Fixpoint coPset_singleton_raw (p : positive) : coPset_raw :=
  match p with
  | 1 => coPNode true (coPLeaf false) (coPLeaf false)
  | p~0 => coPNode' false (coPset_singleton_raw p) (coPLeaf false)
  | p~1 => coPNode' false (coPLeaf false) (coPset_singleton_raw p)
  end.
Global Instance coPset_union_raw : Union coPset_raw :=
  fix go t1 t2 := let _ : Union _ := @go in
  match t1, t2 with
  | coPLeaf false, coPLeaf false => coPLeaf false
  | _, coPLeaf true => coPLeaf true
  | coPLeaf true, _ => coPLeaf true
  | coPNode b l r, coPLeaf false => coPNode b l r
  | coPLeaf false, coPNode b l r => coPNode b l r
  | coPNode b1 l1 r1, coPNode b2 l2 r2 => coPNode' (b1||b2) (l1 ∪ l2) (r1 ∪ r2)
  end.
Local Arguments union _ _!_ !_ / : assert.
Global Instance coPset_intersection_raw : Intersection coPset_raw :=
  fix go t1 t2 := let _ : Intersection _ := @go in
  match t1, t2 with
  | coPLeaf true, coPLeaf true => coPLeaf true
  | _, coPLeaf false => coPLeaf false
  | coPLeaf false, _ => coPLeaf false
  | coPNode b l r, coPLeaf true => coPNode b l r
  | coPLeaf true, coPNode b l r => coPNode b l r
  | coPNode b1 l1 r1, coPNode b2 l2 r2 => coPNode' (b1&&b2) (l1 ∩ l2) (r1 ∩ r2)
  end.
Local Arguments intersection _ _!_ !_ / : assert.
Fixpoint coPset_opp_raw (t : coPset_raw) : coPset_raw :=
  match t with
  | coPLeaf b => coPLeaf (negb b)
  | coPNode b l r => coPNode' (negb b) (coPset_opp_raw l) (coPset_opp_raw r)
  end.

Lemma coPset_singleton_wf p : coPset_wf (coPset_singleton_raw p).
Proof. induction p; simpl; eauto. Qed.
Lemma coPset_union_wf t1 t2 : coPset_wf t1 → coPset_wf t2 → coPset_wf (t1 ∪ t2).
Proof. revert t2; induction t1 as [[]|[]]; intros [[]|[] ??]; simpl; eauto. Qed.
Lemma coPset_intersection_wf t1 t2 :
  coPset_wf t1 → coPset_wf t2 → coPset_wf (t1 ∩ t2).
Proof. revert t2; induction t1 as [[]|[]]; intros [[]|[] ??]; simpl; eauto. Qed.
Lemma coPset_opp_wf t : coPset_wf (coPset_opp_raw t).
Proof. induction t as [[]|[]]; simpl; eauto. Qed.
Lemma coPset_elem_of_singleton p q : e_of p (coPset_singleton_raw q) ↔ p = q.
Proof.
  split; [|by intros <-; induction p; simpl; rewrite ?coPset_elem_of_node].
  by revert q; induction p; intros [?|?|]; simpl;
    rewrite ?coPset_elem_of_node; intros; f_equal/=; auto.
Qed.
Lemma coPset_elem_of_union t1 t2 p : e_of p (t1 ∪ t2) = e_of p t1 || e_of p t2.
Proof.
  by revert t2 p; induction t1 as [[]|[]]; intros [[]|[] ??] [?|?|]; simpl;
    rewrite ?coPset_elem_of_node; simpl;
    rewrite ?orb_true_l, ?orb_false_l, ?orb_true_r, ?orb_false_r.
Qed.
Lemma coPset_elem_of_intersection t1 t2 p :
  e_of p (t1 ∩ t2) = e_of p t1 && e_of p t2.
Proof.
  by revert t2 p; induction t1 as [[]|[]]; intros [[]|[] ??] [?|?|]; simpl;
    rewrite ?coPset_elem_of_node; simpl;
    rewrite ?andb_true_l, ?andb_false_l, ?andb_true_r, ?andb_false_r.
Qed.
Lemma coPset_elem_of_opp t p : e_of p (coPset_opp_raw t) = negb (e_of p t).
Proof.
  by revert p; induction t as [[]|[]]; intros [?|?|]; simpl;
    rewrite ?coPset_elem_of_node; simpl.
Qed.

(** * Packed together + set operations *)
Definition coPset := { t | coPset_wf t }.

Global Instance coPset_singleton : Singleton positive coPset := λ p,
  coPset_singleton_raw p ↾ coPset_singleton_wf _.
Global Instance coPset_elem_of : ElemOf positive coPset := λ p X, e_of p (`X).
Global Instance coPset_empty : Empty coPset := coPLeaf false ↾ I.
Global Instance coPset_top : Top coPset := coPLeaf true ↾ I.
Global Instance coPset_union : Union coPset := λ X Y,
  let (t1,Ht1) := X in let (t2,Ht2) := Y in
  (t1 ∪ t2) ↾ coPset_union_wf _ _ Ht1 Ht2.
Global Instance coPset_intersection : Intersection coPset := λ X Y,
  let (t1,Ht1) := X in let (t2,Ht2) := Y in
  (t1 ∩ t2) ↾ coPset_intersection_wf _ _ Ht1 Ht2.
Global Instance coPset_difference : Difference coPset := λ X Y,
  let (t1,Ht1) := X in let (t2,Ht2) := Y in
  (t1 ∩ coPset_opp_raw t2) ↾ coPset_intersection_wf _ _ Ht1 (coPset_opp_wf _).

Global Instance coPset_top_set : TopSet positive coPset.
Proof.
  split; [split; [split| |]|].
  - by intros ??.
  - intros p q. apply coPset_elem_of_singleton.
  - intros [t] [t'] p; unfold elem_of, coPset_elem_of, coPset_union; simpl.
    by rewrite coPset_elem_of_union, orb_True.
  - intros [t] [t'] p; unfold elem_of,coPset_elem_of,coPset_intersection; simpl.
    by rewrite coPset_elem_of_intersection, andb_True.
  - intros [t] [t'] p; unfold elem_of, coPset_elem_of, coPset_difference; simpl.
    by rewrite coPset_elem_of_intersection,
      coPset_elem_of_opp, andb_True, negb_True.
  - done.
Qed.

(** Iris and specifically [solve_ndisj] heavily rely on this hint. *)
Local Definition coPset_top_subseteq := top_subseteq (C:=coPset).
Global Hint Resolve coPset_top_subseteq : core.

Global Instance coPset_leibniz : LeibnizEquiv coPset.
Proof.
  intros X Y; rewrite set_equiv; intros HXY.
  apply (sig_eq_pi _), coPset_eq; try apply @proj2_sig.
  intros p; apply eq_bool_prop_intro, (HXY p).
Qed.

Global Instance coPset_elem_of_dec : RelDecision (∈@{coPset}).
Proof. solve_decision. Defined.
Global Instance coPset_equiv_dec : RelDecision (≡@{coPset}).
Proof. refine (λ X Y, cast_if (decide (X = Y))); abstract (by fold_leibniz). Defined.
Global Instance mapset_disjoint_dec : RelDecision (##@{coPset}).
Proof.
 refine (λ X Y, cast_if (decide (X ∩ Y = ∅)));
  abstract (by rewrite disjoint_intersection_L).
Defined.
Global Instance mapset_subseteq_dec : RelDecision (⊆@{coPset}).
Proof.
 refine (λ X Y, cast_if (decide (X ∪ Y = Y))); abstract (by rewrite subseteq_union_L).
Defined.

(** * Finite sets *)
Fixpoint coPset_finite (t : coPset_raw) : bool :=
  match t with
  | coPLeaf b => negb b | coPNode b l r => coPset_finite l && coPset_finite r
  end.
Lemma coPset_finite_node b l r :
  coPset_finite (coPNode' b l r) = coPset_finite l && coPset_finite r.
Proof. by destruct b, l as [[]|], r as [[]|]. Qed.
Lemma coPset_finite_spec X : set_finite X ↔ coPset_finite (`X).
Proof.
  destruct X as [t Ht].
  unfold set_finite, elem_of at 1, coPset_elem_of; simpl; clear Ht; split.
  - induction t as [b|b l IHl r IHr]; simpl.
    { destruct b; simpl; [intros [l Hl]|done].
      by apply (is_fresh (list_to_set l : Pset)), elem_of_list_to_set, Hl. }
    intros [ll Hll]; rewrite andb_True; split.
    + apply IHl; exists (omap (maybe (~0)) ll); intros i.
      rewrite elem_of_list_omap; intros; exists (i~0); auto.
    + apply IHr; exists (omap (maybe (~1)) ll); intros i.
      rewrite elem_of_list_omap; intros; exists (i~1); auto.
  - induction t as [b|b l IHl r IHr]; simpl; [by exists []; destruct b|].
    rewrite andb_True; intros [??]; destruct IHl as [ll ?], IHr as [rl ?]; auto.
    exists ([1] ++ ((~0) <$> ll) ++ ((~1) <$> rl))%list; intros [i|i|]; simpl;
      rewrite elem_of_cons, elem_of_app, !elem_of_list_fmap; naive_solver.
Qed.
Global Instance coPset_finite_dec (X : coPset) : Decision (set_finite X).
Proof.
  refine (cast_if (decide (coPset_finite (`X)))); by rewrite coPset_finite_spec.
Defined.

(** * Pick element from infinite sets *)
(* The function [coPpick X] gives an element that is in the set [X], provided
that the set [X] is infinite. Note that [coPpick] function is implemented by
depth-first search, so using it repeatedly to obtain elements [x], and
inserting these elements [x] into the set [X], will give rise to a very
unbalanced tree. *)
Fixpoint coPpick_raw (t : coPset_raw) : option positive :=
  match t with
  | coPLeaf true | coPNode true _ _ => Some 1
  | coPLeaf false => None
  | coPNode false l r =>
     match coPpick_raw l with
     | Some i => Some (i~0) | None => (~1) <$> coPpick_raw r
     end
  end.
Definition coPpick (X : coPset) : positive := default 1 (coPpick_raw (`X)).

Lemma coPpick_raw_elem_of t i : coPpick_raw t = Some i → e_of i t.
Proof.
  revert i; induction t as [[]|[] l ? r]; intros i ?; simplify_eq/=; auto.
  destruct (coPpick_raw l); simplify_option_eq; auto.
Qed.
Lemma coPpick_raw_None t : coPpick_raw t = None → coPset_finite t.
Proof.
  induction t as [[]|[] l ? r]; intros i; simplify_eq/=; auto.
  destruct (coPpick_raw l); simplify_option_eq; auto.
Qed.
Lemma coPpick_elem_of X : ¬set_finite X → coPpick X ∈ X.
Proof.
  destruct X as [t ?]; unfold coPpick; destruct (coPpick_raw _) as [j|] eqn:?.
  - by intros; apply coPpick_raw_elem_of.
  - by intros []; apply coPset_finite_spec, coPpick_raw_None.
Qed.

(** * Conversion to psets *)
Fixpoint coPset_to_Pset_raw (t : coPset_raw) : Pmap_raw () :=
  match t with
  | coPLeaf _ => PLeaf
  | coPNode false l r => PNode' None (coPset_to_Pset_raw l) (coPset_to_Pset_raw r)
  | coPNode true l r => PNode (Some ()) (coPset_to_Pset_raw l) (coPset_to_Pset_raw r)
  end.
Lemma coPset_to_Pset_wf t : coPset_wf t → Pmap_wf (coPset_to_Pset_raw t).
Proof. induction t as [|[]]; simpl; eauto using PNode_wf. Qed.
Definition coPset_to_Pset (X : coPset) : Pset :=
  let (t,Ht) := X in Mapset (PMap (coPset_to_Pset_raw t) (coPset_to_Pset_wf _ Ht)).
Lemma elem_of_coPset_to_Pset X i : set_finite X → i ∈ coPset_to_Pset X ↔ i ∈ X.
Proof.
  rewrite coPset_finite_spec; destruct X as [t Ht].
  change (coPset_finite t → coPset_to_Pset_raw t !! i = Some () ↔ e_of i t).
  clear Ht; revert i; induction t as [[]|[] l IHl r IHr]; intros [i|i|];
    simpl; rewrite ?andb_True, ?PNode_lookup; naive_solver.
Qed.

(** * Conversion from psets *)
Fixpoint Pset_to_coPset_raw (t : Pmap_raw ()) : coPset_raw :=
  match t with
  | PLeaf => coPLeaf false
  | PNode None l r => coPNode false (Pset_to_coPset_raw l) (Pset_to_coPset_raw r)
  | PNode (Some _) l r => coPNode true (Pset_to_coPset_raw l) (Pset_to_coPset_raw r)
  end.
Lemma Pset_to_coPset_wf t : Pmap_wf t → coPset_wf (Pset_to_coPset_raw t).
Proof.
  induction t as [|[] l IHl r IHr]; simpl; rewrite ?andb_True; auto.
  - intros [??]; destruct l as [|[]], r as [|[]]; simpl in *; auto.
  - destruct l as [|[]], r as [|[]]; simpl in *; rewrite ?andb_true_r;
      rewrite ?andb_True; rewrite ?andb_True in IHl, IHr; intuition.
Qed.
Lemma elem_of_Pset_to_coPset_raw i t : e_of i (Pset_to_coPset_raw t) ↔ t !! i = Some ().
Proof. by revert i; induction t as [|[[]|]]; intros []; simpl; auto; split. Qed.
Lemma Pset_to_coPset_raw_finite t : coPset_finite (Pset_to_coPset_raw t).
Proof. induction t as [|[[]|]]; simpl; rewrite ?andb_True; auto. Qed.

Definition Pset_to_coPset (X : Pset) : coPset :=
  let 'Mapset (PMap t Ht) := X in Pset_to_coPset_raw t ↾ Pset_to_coPset_wf _ Ht.
Lemma elem_of_Pset_to_coPset X i : i ∈ Pset_to_coPset X ↔ i ∈ X.
Proof. destruct X as [[t ?]]; apply elem_of_Pset_to_coPset_raw. Qed.
Lemma Pset_to_coPset_finite X : set_finite (Pset_to_coPset X).
Proof.
  apply coPset_finite_spec; destruct X as [[t ?]]; apply Pset_to_coPset_raw_finite.
Qed.

(** * Conversion to and from gsets of positives *)
Lemma coPset_to_gset_wf (m : Pmap ()) : gmap_wf positive m.
Proof. unfold gmap_wf. by rewrite bool_decide_spec. Qed.
Definition coPset_to_gset (X : coPset) : gset positive :=
  let 'Mapset m := coPset_to_Pset X in
  Mapset (GMap m (coPset_to_gset_wf m)).

Definition gset_to_coPset (X : gset positive) : coPset :=
  let 'Mapset (GMap (PMap t Ht) _) := X in Pset_to_coPset_raw t ↾ Pset_to_coPset_wf _ Ht.

Lemma elem_of_coPset_to_gset X i : set_finite X → i ∈ coPset_to_gset X ↔ i ∈ X.
Proof.
  intros ?. rewrite <-elem_of_coPset_to_Pset by done.
  unfold coPset_to_gset. by destruct (coPset_to_Pset X).
Qed.

Lemma elem_of_gset_to_coPset X i : i ∈ gset_to_coPset X ↔ i ∈ X.
Proof. destruct X as [[[t ?]]]; apply elem_of_Pset_to_coPset_raw. Qed.
Lemma gset_to_coPset_finite X : set_finite (gset_to_coPset X).
Proof.
  apply coPset_finite_spec; destruct X as [[[t ?]]]; apply Pset_to_coPset_raw_finite.
Qed.

(** * Infinite sets *)
Lemma coPset_infinite_finite (X : coPset) : set_infinite X ↔ ¬set_finite X.
Proof.
  split; [intros ??; by apply (set_not_infinite_finite X)|].
  intros Hfin xs. exists (coPpick (X ∖ list_to_set xs)).
  cut (coPpick (X ∖ list_to_set xs) ∈ X ∖ list_to_set xs); [set_solver|].
  apply coPpick_elem_of; intros Hfin'.
  apply Hfin, (difference_finite_inv _ (list_to_set xs)), Hfin'.
  apply list_to_set_finite.
Qed.
Lemma coPset_finite_infinite (X : coPset) : set_finite X ↔ ¬set_infinite X.
Proof. rewrite coPset_infinite_finite. split; [tauto|apply dec_stable]. Qed.
Global Instance coPset_infinite_dec (X : coPset) : Decision (set_infinite X).
Proof.
  refine (cast_if (decide (¬set_finite X))); by rewrite coPset_infinite_finite.
Defined.

(** * Suffix sets *)
Fixpoint coPset_suffixes_raw (p : positive) : coPset_raw :=
  match p with
  | 1 => coPLeaf true
  | p~0 => coPNode' false (coPset_suffixes_raw p) (coPLeaf false)
  | p~1 => coPNode' false (coPLeaf false) (coPset_suffixes_raw p)
  end.
Lemma coPset_suffixes_wf p : coPset_wf (coPset_suffixes_raw p).
Proof. induction p; simpl; eauto. Qed.
Definition coPset_suffixes (p : positive) : coPset :=
  coPset_suffixes_raw p ↾ coPset_suffixes_wf _.
Lemma elem_coPset_suffixes p q : p ∈ coPset_suffixes q ↔ ∃ q', p = q' ++ q.
Proof.
  unfold elem_of, coPset_elem_of; simpl; split.
  - revert p; induction q; intros [?|?|]; simpl;
      rewrite ?coPset_elem_of_node; naive_solver.
  - by intros [q' ->]; induction q; simpl; rewrite ?coPset_elem_of_node.
Qed.
Lemma coPset_suffixes_infinite p : ¬set_finite (coPset_suffixes p).
Proof.
  rewrite coPset_finite_spec; simpl.
  induction p; simpl; rewrite ?coPset_finite_node, ?andb_True; naive_solver.
Qed.

(** * Splitting of infinite sets *)
Fixpoint coPset_l_raw (t : coPset_raw) : coPset_raw :=
  match t with
  | coPLeaf false => coPLeaf false
  | coPLeaf true => coPNode true (coPLeaf true) (coPLeaf false)
  | coPNode b l r => coPNode' b (coPset_l_raw l) (coPset_l_raw r)
  end.
Fixpoint coPset_r_raw (t : coPset_raw) : coPset_raw :=
  match t with
  | coPLeaf false => coPLeaf false
  | coPLeaf true => coPNode false (coPLeaf false) (coPLeaf true)
  | coPNode b l r => coPNode' false (coPset_r_raw l) (coPset_r_raw r)
  end.

Lemma coPset_l_wf t : coPset_wf (coPset_l_raw t).
Proof. induction t as [[]|]; simpl; auto. Qed.
Lemma coPset_r_wf t : coPset_wf (coPset_r_raw t).
Proof. induction t as [[]|]; simpl; auto. Qed.
Definition coPset_l (X : coPset) : coPset :=
  let (t,Ht) := X in coPset_l_raw t ↾ coPset_l_wf _.
Definition coPset_r (X : coPset) : coPset :=
  let (t,Ht) := X in coPset_r_raw t ↾ coPset_r_wf _.

Lemma coPset_lr_disjoint X : coPset_l X ∩ coPset_r X = ∅.
Proof.
  apply elem_of_equiv_empty_L; intros p; apply Is_true_false.
  destruct X as [t Ht]; simpl; clear Ht; rewrite coPset_elem_of_intersection.
  revert p; induction t as [[]|[]]; intros [?|?|]; simpl;
    rewrite ?coPset_elem_of_node; simpl;
    rewrite ?orb_true_l, ?orb_false_l, ?orb_true_r, ?orb_false_r; auto.
Qed.
Lemma coPset_lr_union X : coPset_l X ∪ coPset_r X = X.
Proof.
  apply set_eq; intros p; apply eq_bool_prop_elim.
  destruct X as [t Ht]; simpl; clear Ht; rewrite coPset_elem_of_union.
  revert p; induction t as [[]|[]]; intros [?|?|]; simpl;
    rewrite ?coPset_elem_of_node; simpl;
    rewrite ?orb_true_l, ?orb_false_l, ?orb_true_r, ?orb_false_r; auto.
Qed.
Lemma coPset_l_finite X : set_finite (coPset_l X) → set_finite X.
Proof.
  rewrite !coPset_finite_spec; destruct X as [t Ht]; simpl; clear Ht.
  induction t as [[]|]; simpl; rewrite ?coPset_finite_node, ?andb_True; tauto.
Qed.
Lemma coPset_r_finite X : set_finite (coPset_r X) → set_finite X.
Proof.
  rewrite !coPset_finite_spec; destruct X as [t Ht]; simpl; clear Ht.
  induction t as [[]|]; simpl; rewrite ?coPset_finite_node, ?andb_True; tauto.
Qed.
Lemma coPset_split (X : coPset) :
  ¬set_finite X →
  ∃ X1 X2, X = X1 ∪ X2 ∧ X1 ∩ X2 = ∅ ∧ ¬set_finite X1 ∧ ¬set_finite X2.
Proof.
  exists (coPset_l X), (coPset_r X); eauto 10 using coPset_lr_union,
    coPset_lr_disjoint, coPset_l_finite, coPset_r_finite.
Qed.
Lemma coPset_split_infinite (X : coPset) :
  set_infinite X →
  ∃ X1 X2, X = X1 ∪ X2 ∧ X1 ∩ X2 = ∅ ∧ set_infinite X1 ∧ set_infinite X2.
Proof.
  setoid_rewrite coPset_infinite_finite.
  eapply coPset_split.
Qed.


From Tealeaves Require Export
  Classes.Functor
  Data.Strength
  Functors.Identity
  Functors.Compose.
From Tealeaves Require Import
  Classes.Kleisli.Monad.

Export Kleisli.Monad (Return, ret).

Import Functor.Notations.

#[local] Generalizable Variables W T A.

(** * Monads *)
(******************************************************************************)

(** ** Operations *)
(******************************************************************************)
Section monad_operations.

  Context
    (T : Type -> Type).

  Class Join := join : T ∘ T ⇒ T.

End monad_operations.

(** ** Monads *)
(******************************************************************************)
Section monad_class.

  Context
    (T : Type -> Type)
   `{Fmap T} `{Return T} `{Join T}.

  Class Monad :=
    { mon_functor :> Functor T;
      mon_ret_natural :> Natural (@ret T _);
      mon_join_natural :> Natural (join T);
      mon_join_ret : (* left unit law *)
      `(join T A ∘ ret T (A := T A) = @id (T A));
      mon_join_fmap_ret : (* right unit law *)
      `(join T A ∘ fmap T (ret T (A := A)) = @id (T A));
      mon_join_join : (* associativity *)
      `(join T A ∘ join T (T A) =
          join T A ∘ fmap T (join T _));
    }.

End monad_class.

#[global] Arguments join _%function_scope {Join} {A}%type_scope.
#[global] Arguments ret _%function_scope {Return} {A}%type_scope.

(** * Monad homomorphisms *)
(******************************************************************************)
Section monad_homomorphism.

  Context
    (T : Type -> Type)
    (U : Type -> Type)
    `{Monad T}
    `{Monad U}.

  Class Monad_Hom (ϕ : T ⇒ U) :=
    { mhom_domain : Monad T;
      mhom_codomain : Monad U;
      mhom_natural : Natural ϕ;
      mhom_ret :
        `(ϕ A ∘ ret T = ret U);
      mhom_join :
        `(ϕ A ∘ join T = join U ∘ ϕ (U A) ∘ fmap T (ϕ A));
    }.

End monad_homomorphism.

(** * Algebraic monad to Kleisli monad *)
(******************************************************************************)

Module ToKleisli.

  Export Kleisli.Monad.
  Import Kleisli.Monad.Notations.

  Generalizable All Variables.

  Section operation.

    Context
      (T : Type -> Type)
      `{Fmap T} `{Join T}.

    #[export] Instance Bind_join : Bind T T :=
      fun {A B} (f : A -> T B) => join T ∘ fmap T f.

  End operation.

  Section with_monad.

    Context
      (T : Type -> Type)
      `{Classes.Monad.Monad T}.

    (** *** Identity law *)
    (******************************************************************************)
    Lemma mon_bind_id :
      `(bind T (ret T) = @id (T A)).
    Proof.
      intros. unfold_ops @Bind_join.
      now rewrite (mon_join_fmap_ret T).
    Qed.

    (** *** Composition law *)
    (******************************************************************************)
    Lemma mon_bind_bind : forall `(g : B -> T C) `(f : A -> T B),
        bind T g ∘ bind T f = bind T (g ⋆ f).
    Proof.
      introv. unfold transparent tcs.
      unfold kcompose.
      unfold_ops @Bind_join.
      rewrite <- 2(fun_fmap_fmap T).
      reassociate <- on right.
      change (fmap ?T (fmap ?T g)) with (fmap (T ∘ T) g).
      reassociate <- on right.
      rewrite <- (mon_join_join T).
      reassociate -> near (fmap (T ∘ T) g).
      now rewrite <- (natural (ϕ := @join T _)).
    Qed.

    (** *** Unit law *)
    (******************************************************************************)
    Lemma mon_bind_comp_ret : forall (A B : Type) (f : A -> T B),
        bind T f ∘ ret T = f.
    Proof.
      intros. unfold transparent tcs.
      reassociate -> on left.
      unfold_compose_in_compose; (* these rewrites are not visible *)
        change (@compose A) with (@compose ((fun A => A) A)).
      rewrite natural.
      reassociate <- on left.
      now rewrite (mon_join_ret T).
    Qed.

    #[export] Instance Kleisli_Monad : Kleisli.Monad.Monad T :=
      {| kmon_bind0 := @mon_bind_comp_ret;
        kmon_bind1 := @mon_bind_id;
        kmon_bind2 := @mon_bind_bind;
      |}.

  End with_monad.

End ToKleisli.

(** ** Derived laws *)
(******************************************************************************)
Section ToKleisli_laws.

  Context
    (T : Type -> Type)
   `{Monad T}.

  Generalizable All Variables.
  Import Kleisli.Monad.Notations.
  Import ToKleisli.

  Lemma fmap_to_bind : forall `(f : A -> B),
      fmap T f = bind T (ret T ∘ f).
  Proof.
    intros. unfold_ops @Bind_join.
    rewrite <- (fun_fmap_fmap T).
    reassociate <-.
    rewrite (mon_join_fmap_ret T).
    reflexivity.
  Qed.

  Corollary bind_fmap : forall `(g : B -> T C) `(f : A -> B),
      bind T g ∘ fmap T f = bind T (g ∘ f).
  Proof.
    intros. unfold transparent tcs.
    now rewrite <- (fun_fmap_fmap T).
  Qed.

  Corollary fmap_bind : forall `(g : B -> C) `(f : A -> T B),
      fmap T g ∘ bind T f = bind T (fmap T g ∘ f).
  Proof.
    intros. unfold transparent tcs.
    reassociate <- on left.
    rewrite (natural). unfold_ops @Fmap_compose.
    now rewrite <- (fun_fmap_fmap T).
  Qed.

  (** ** Left identity law *)
  Theorem kleisli_id_l : forall `(f : A -> T B),
      (@ret T _ B) ⋆ f = f.
  Proof.
    intros. unfold kcompose. now rewrite (kmon_bind1 T).
  Qed.

  (** ** Right identity law *)
  Theorem kleisli_id_r : forall `(g : B -> T C),
      g ⋆ (@ret T _ B) = g.
  Proof.
    intros. unfold kcompose. now rewrite (kmon_bind0 T).
  Qed.

  (** ** Associativity law *)
  Theorem kleisli_assoc : forall `(h : C -> T D) `(g : B -> T C) `(f : A -> T B),
      h ⋆ (g ⋆ f) = (h ⋆ g) ⋆ f.
  Proof.
    intros. unfold kcompose at 3.
    now rewrite <- (kmon_bind2 T).
  Qed.

End ToKleisli_laws.

(** * Notations *)
(******************************************************************************)
Module Notations.
  Notation "'μ'" := (join) : tealeaves_scope.
  Notation "'η'" := (ret) : tealeaves_scope.
End Notations.

(** * The identity monad *)
(******************************************************************************)
#[export] Instance Return_I : Return (fun A => A) := (fun A (a : A) => a).

#[export] Instance Join_I : Join (fun A => A) := (fun A (a : A) => a).

#[export, program] Instance Monad_I : Monad (fun A => A).

Solve All Obligations with
  (constructor; try typeclasses eauto; intros; now ext t).

(** * Miscellaneous properties *)
(******************************************************************************)
Section tensor_laws.

  Context
    `{Monad T}
    {W : Type}.

  Theorem strength_return  {A B} (a : A) (b : B) :
    strength T (b, ret T a) = ret T (b, a).
  Proof.
    unfold strength. compose near a on left.
    change (@compose ?B) with (@compose ((fun A => A) B)).
    now rewrite natural.
  Qed.

End tensor_laws.

From Tealeaves Require Import Classes.Applicative.

(** * Monadic applicative functors *)
(******************************************************************************)
Section Applicative_Monad.

  Context
    `{Monad T}.

  Import Monad.ToKleisli.
  Import Applicative.Notations.
  Import Data.Product.Notations.

  #[global] Instance Pure_Monad : Pure T := @ret T _.

  #[global] Instance Mult_Monad : Mult T :=
    fun A B (p : T A * T B) =>
      match p with (ta, tb) =>
                   bind T (fun a => strength T (a, tb)) ta
      end.

  Theorem app_pure_natural_Monad : forall (A B : Type) (f : A -> B) (x : A),
      fmap T f (pure T x) = pure T (f x).
  Proof.
    intros. unfold_ops @Pure_Monad.
    compose near x. now rewrite (natural (ϕ := @ret T _)).
  Qed.

  Theorem app_mult_natural_Monad : forall (A B C D : Type) (f : A -> C) (g : B -> D) (x : T A) (y : T B),
      fmap T f x ⊗ fmap T g y = fmap T (map_tensor f g) (x ⊗ y).
  Proof.
    intros. unfold_ops @Mult_Monad.
    compose near x.
    rewrite (bind_fmap T), (fmap_bind T).
    fequal. ext c; unfold compose; cbn. compose near y.
    now rewrite 2(fun_fmap_fmap T).
  Qed.

  Theorem app_assoc_Monad : forall (A B C : Type) (x : T A) (y : T B) (z : T C),
      fmap T α ((x ⊗ y) ⊗ z) = x ⊗ (y ⊗ z).
  Proof.
    intros. unfold_ops @Mult_Monad.
    compose near x on left. rewrite (kmon_bind2 T).
    compose near x on left. rewrite (fmap_bind T).
    fequal. ext a; unfold compose; cbn.
    compose near y on right. rewrite (fmap_bind T).
    unfold compose; cbn. compose near z on right.
    unfold kcompose. unfold compose; cbn.
    compose near y on left.
    rewrite (bind_fmap T). compose near y on left.
    rewrite (fmap_bind T). fequal. ext b. unfold compose; cbn.
    compose near z. now do 2 (rewrite (fun_fmap_fmap T)).
  Qed.

  Theorem app_unital_l_Monad : forall (A : Type) (x : T A),
      fmap T left_unitor (pure T tt ⊗ x) = x.
  Proof.
    intros. unfold_ops @Mult_Monad @Pure_Monad.
    compose near tt. rewrite (mon_bind_comp_ret T).
    unfold strength. compose near x.
    rewrite (fun_fmap_fmap T). change (left_unitor ∘ pair tt) with (@id A).
    now rewrite (fun_fmap_id T).
  Qed.

  Theorem app_unital_r_Monad : forall (A : Type) (x : T A),
      fmap T right_unitor (x ⊗ pure T tt) = x.
  Proof.
    intros. unfold_ops @Mult_Monad @Pure_Monad.
    compose near x. rewrite (fmap_bind T).
    replace (fmap T right_unitor ∘ (fun a : A => strength T (a, ret T tt)))
      with (ret T (A := A)).
    now rewrite (mon_bind_id T).
    ext a; unfold compose; cbn. compose near (ret T tt).
    rewrite (fun_fmap_fmap T). compose near tt.
    rewrite (natural (ϕ := @ret T _ )). now unfold compose; cbn.
  Qed.

  Theorem app_mult_pure_Monad : forall (A B : Type) (a : A) (b : B),
      pure T a ⊗ pure T b = pure T (a, b).
  Proof.
    intros. intros. unfold_ops @Mult_Monad @Pure_Monad.
    compose near a. rewrite (mon_bind_comp_ret T).
    now rewrite (strength_return).
  Qed.

  #[global] Instance Applicative_Monad : Applicative T :=
  { app_mult_pure := app_mult_pure_Monad;
    app_pure_natural := app_pure_natural_Monad;
    app_mult_natural := app_mult_natural_Monad;
    app_assoc := app_assoc_Monad;
    app_unital_l := app_unital_l_Monad;
    app_unital_r := app_unital_r_Monad;
  }.

End Applicative_Monad.


(*
 * Copyright (c) 2009-2011, Andrew Appel, Robert Dockins and Aquinas Hobor.
 *
 *)

(* This file contains the class of decidable equality and associated theory
    of updateable functions. *)

Require Import VST.msl.base.

(* Class of decidable equality *)
Class EqDec (A : Type) : Type :=
  eq_dec : forall a a' : A, {a = a'} + {a <> a'}.

Instance EqDec_nat : EqDec nat := Peano_dec.eq_nat_dec.

(* Theory of updateable functions, defined over decideable domain *)
Definition upd {A} `{EqDec A} (B : Type) (f : A -> B) (a : A) (b : B) : A -> B :=
  fun a' => if eq_dec a a' then b else f a'.
Arguments upd [A H B] _ _ _ _.

Lemma upd_eq {A} `{EqDec A} : forall B (f : A -> B) a b,
  upd f a b a = b.
Proof with auto.
  intros.
  unfold upd.
  case (eq_dec a a)...
  intro.
  destruct n...
Qed.
Arguments upd_eq [A H B] _ _ _.

Lemma upd_eq' {A} `{EqDec A} : forall B (f : A -> B) a b a',
  a = a' ->
  upd f a b a' = b.
Proof.
  intros. subst a'. apply upd_eq.
Qed.
Arguments upd_eq' [A H B] _ _ _ _ _.

Lemma upd_neq {A} `{EqDec A} : forall B (f : A -> B) a b a',
  a <> a' ->
  upd f a b a' = f a'.
Proof with auto.
  intros.
  unfold upd.
  case (eq_dec a a')...
  intros.
  subst a'.
  destruct H0...
Qed.
Arguments upd_neq [A H B] _ _ _ _ _.

Instance nat_eq_dec: EqDec nat.
Proof.
  repeat intro.
 destruct (Compare_dec.lt_eq_lt_dec a a') as [[?|?]| ?]; auto;
  right; intro; subst; eapply Lt.lt_irrefl; eauto.
Defined.

Instance EqDec_prod (A: Type) (EA: EqDec A) (B: Type) (EB: EqDec B) : EqDec (A*B).
Proof.
 hnf. decide equality; try apply eq_dec.
Defined.

Instance EqDec_list (A: Type) (EA: EqDec A) : EqDec (list A).
Proof.
 hnf. apply list_eq_dec; intros; apply EA.
Defined.

Instance EqDec_option (A: Type) (EA: EqDec A) : EqDec (option A).
Proof.
  hnf; decide equality.
Defined.


Require Recdef.
Require Import Bitoychain.Integers.
Require Coq.Strings.String.
Require Coq.Strings.Ascii.
Require Import Bitoychain.Coqlib.
Require Import Bitoychain.Coqlib2.
Require Import Bitoychain.coqlib3.
Require Import Bitoychain.sublist.
Require Import List. Import ListNotations.
Require Import Bitoychain.general_lemmas.
Require Import Bitoychain.SHA256.

(* FAST FUNCTIONAL VERSION OF SHA256 *)
Function zeros (n : Z) {measure Z.to_nat n} : list Int.int :=
 if Z.gtb n 0 then Int.zero :: zeros (n-1) else nil.
Proof.
   intros. rewrite Z2Nat.inj_sub by omega.
   apply Zgt_is_gt_bool in teq.
   assert (0 < n) by omega. apply Z2Nat.inj_lt in H; try omega.
   simpl in H. change (Z.to_nat 1) with 1%nat. omega.
Defined.

Definition padlen (n: Z) : list Int.int :=
    let p := n/4+3 (* number of words with trailing 128-byte,
                                                      up to 3 zero bytes, and 2 length words *)
    in let q := (p+15)/16*16 - p   (* number of zero-pad words *)
      in zeros q ++ [Int.repr (n * 8 / Int.modulus); Int.repr (n * 8)].

Fixpoint generate_and_pad' (n: list Z) len : list Int.int :=
  match n with
  | nil => Z_to_Int 128 0 0 0 :: padlen len
  | [h1]=> Z_to_Int h1 128 0 0 :: padlen (len+1)
  | [h1; h2] => Z_to_Int h1 h2 128 0 :: padlen (len+2)
  | [h1; h2; h3] => Z_to_Int h1 h2 h3 128 :: padlen (len+3)
  | h1::h2::h3::h4::t => Z_to_Int h1 h2 h3 h4 :: generate_and_pad' t (len+4)
  end.

Definition generate_and_pad_alt (n: list Z) : list Int.int :=
   generate_and_pad' n 0.

Definition Wnext (msg : list int) : int :=
 match msg with
 | x1::x2::x3::x4::x5::x6::x7::x8::x9::x10::x11::x12::x13::x14::x15::x16::_ =>
   (Int.add (Int.add (sigma_1 x2) x7) (Int.add (sigma_0 x15) x16))
 | _ => Int.zero  (* impossible *)
 end.

(*generating 64 words for the given message block imput*)
Fixpoint generate_word (msg : list int) (n : nat) {struct n}: list int :=
  match n with
  |O   => msg
  |S n' => generate_word (Wnext msg :: msg) n'
  end.
Arguments generate_word msg n : simpl never.
Global Opaque generate_word. (* for some reason the Arguments...simpl-never
   command does not do the job *)

(*execute round function for 64 rounds*)
Fixpoint rnd_64 (x: registers) (k w : list int) : registers :=
  match k, w with
  | k1::k', w1::w' => rnd_64 (rnd_function x k1 w1) k' w'
  | _ , _ => x
  end.
Arguments rnd_64  x k w : simpl never.  (* blows up otherwise *)

Definition process_block (r: registers) (block: list int) : registers :=
       (map2 Int.add r (rnd_64 r K256 (rev(generate_word block 48)))).

Fixpoint grab_and_process_block (n: nat) (r: registers) (firstrev msg: list int) : registers * list int :=
 match n, msg with
  | O, _ => (process_block r firstrev, msg)
  | S n', m1::msg' => grab_and_process_block n' r (m1::firstrev) msg'
  | _, nil => (r,nil) (* impossible *)
 end.

(*iterate through all the message blocks; this could have been done with just a Fixpoint
  if we incorporated grab_and_process_block into process_msg, but I wanted to
  modularize a bit more. *)
Function process_msg  (r: registers) (msg : list int) {measure length msg}  : registers :=
 match msg with
 | nil => r
 | _ => let (r', msg') := grab_and_process_block 16 r nil msg
             in process_msg r' msg'
 end.
Proof.
  intros; subst.
  simpl.
  assert (Datatypes.length msg' <= Datatypes.length l)%nat; [ | omega].
  simpl in teq0.
  do 16 (destruct l; [inv teq0; solve [simpl; auto 50] | ]).
  unfold process_block in teq0.
  assert (i15::l = msg') by congruence.
  subst msg'.
  simpl.
  omega.
Defined.

Definition SHA_256' (str : list Z) : list Z :=
    intlist_to_Zlist (process_msg init_registers (generate_and_pad_alt str)).

(*EXAMPLES*)

Fixpoint listZ_eq (al bl: list Z) : bool :=
 match al, bl with
 | nil, nil => true
 | a::al', b::bl' => Z.eqb a b && listZ_eq al' bl'
 | _, _ => false
  end.

Definition hexdigit(a: Z) : Z :=
 if Z.leb 48 a && Z.ltb a 58 then Z.sub a 48
 else if Z.leb 65 a && Z.ltb a 71 then Z.sub a 55
 else if Z.leb 97 a && Z.ltb a 103 then Z.sub a 87
 else 0%Z.

Fixpoint hexstring_to_Zlist (s: String.string): list Z  :=
 match s with
 | String.String a (String.String b r) =>  (hexdigit (Z.of_N (Ascii.N_of_ascii a)) * 16
                                         + hexdigit (Z.of_N (Ascii.N_of_ascii b)))
                                          :: hexstring_to_Zlist r
 | _ => nil
 end.

Section CHECKS.
Import String.
Definition check m h :=
  listZ_eq (SHA_256' (str_to_Z m)) (hexstring_to_Zlist h) = true.

(*This input message is 344 bits long, which would have one message block after padding*)
Goal  check   "The quick brown fox jumps over the lazy dog"
  "d7a8fbb307d7809469ca9abcb0082e4f8d5651e46d3cdb762d02d0bf37c9e592".
Proof. vm_compute; auto. Qed.

(*This input message would have four message blocks after padding*)
Goal check "The Secure Hash Algorithm is a family of cryptographic hash functions published by the National Institute of Standards and Technology (NIST) as a U.S. Federal Information Processing Standard (FIPS)"
 "27c3971526f07a22decc4dc01340c6c4b972ba6d31b74fb1fbb2edf2bce5fea6".
Proof. vm_compute; auto. Qed.
End CHECKS.

(* PROOF OF EQUIVALENCE OF FAST FUNCTIONAL PROGRAM WITH
    FUNCTIONAL SPECIFICATION *)

Require Import Bitoychain.common_lemmas.
Require Import Bitoychain.Coqlib2.

Local Open Scope nat.

Lemma length_rnd_64:
  forall r k w, length r = 8 -> length (rnd_64 r k w) = 8.
Proof.
intros.
revert r H w; induction k; simpl; intros; auto.
unfold rnd_64; fold rnd_64.
destruct w; auto.
rename H into H0.
repeat  (destruct r as [ | ? r]; rename H0 into H2; inv H2).
apply IHk.
reflexivity.
Qed.

Lemma length_rnd_64_inv:
  forall r k w, length (rnd_64 r k w) = 8 -> length r = 8.
Proof.
intros.
revert w r H; induction k; simpl; intros.
unfold rnd_64 in H; auto.
unfold rnd_64 in H; fold rnd_64 in H.
destruct w; inv H; auto.
rewrite H1.
apply IHk in H1.
clear - H1.
unfold rnd_function in H1.
rename H1 into H0.
destruct r; inv H0. destruct r; inv H1.
destruct r; inv H0. destruct r; inv H1.
destruct r; inv H0. destruct r; inv H1.
destruct r; inv H0. destruct r; inv H1.
destruct r; inv H0.
simpl.
auto.
Qed.

Lemma length_process_block:
  forall r b, length r = 8 -> length (process_block r b) = 8.
Proof.
 intros. unfold process_block.
 apply length_map2; auto.
 apply length_rnd_64; auto.
Qed.

Lemma length_map2_add_rnd_64:
 forall regs w,
  length regs = 8 ->
  length (map2 Int.add regs (rnd_64 regs K256 w)) = 8.
Proof.
 intros.
 apply length_map2; auto.
 apply length_rnd_64; auto.
Qed.

Lemma grab_and_process_block_length:
 forall n r firstr msg r' m',
    length r = 8 ->
    length msg >= n ->
    grab_and_process_block n r firstr msg  = (r',m') ->
    length r' = 8.
Proof.
 induction n; intros.
 inv H1.
 apply length_process_block; auto.
 destruct msg.
 inv H0.
 simpl in H0.
 apply IHn in H1; auto.
 omega.
Qed.

Lemma length_process_msg:
  forall b, length (process_msg init_registers b) = 8.
Proof.
 intros.
 assert (length init_registers = 8%nat) by reflexivity.
 forget init_registers as regs.
 assert (exists n, n >= length b)%nat by eauto.
 destruct H0 as [n H0].
 revert regs b H H0; induction n; intros; rewrite process_msg_equation.
 destruct b; auto.
 inv H0.
 unfold grab_and_process_block.
 repeat (destruct b; [apply H | ]).
 apply IHn.
 apply length_process_block; auto.
 simpl in H0.
 omega.
Qed.

Lemma process_msg_eq2:
 forall regs hashed b,
  length b = 16 ->
 process_msg regs (b++hashed) =
  process_msg (process_block regs (rev b)) hashed.
Proof.
intros.
rewrite process_msg_equation.
destruct (b++hashed) eqn:?.
destruct b; inv H. inv Heql.
rewrite <- Heql; clear i l Heql.
unfold grab_and_process_block.
rename H into H0.
repeat (destruct b as [ | ?x b]; inv H0; rename H1 into H0).
destruct b; inv H0.
simpl. auto.
Qed.

Lemma rnd_64_S:
  forall regs i b k w,
    nth_error K256 i = Some k ->
    nth_error b i = Some w ->
    rnd_64 regs K256 (firstn (S i) b) =
    rnd_function (rnd_64 regs K256 (firstn i b)) k w.
Proof.
intros.
forget K256 as K'.
assert (firstn (S i) b = firstn i b++[w]).
clear - H0.
revert b w H0; induction i; destruct b; simpl; intros; inv H0; auto.
rewrite <- (IHi _ _ H1).
reflexivity.
rewrite H1.
clear H1.
pose proof (firstn_length i b).
rewrite min_l in H1.
Focus 2.
clear - H0; revert b H0; induction i; destruct b; simpl; intros; inv H0; try omega.
specialize (IHi _ H1). omega.
rewrite <- H1 in H.
clear H0 H1.
revert K' k H regs; induction (firstn i b); destruct K'; simpl; intros; inv H.
unfold rnd_64; simpl; fold rnd_64.
destruct K'; reflexivity.
specialize (IHl _ _ H1).
unfold rnd_64; simpl; fold rnd_64.
apply IHl.
Qed.

Lemma Zlength_zeros:
    forall n, (n>=0)%Z -> Zlength (zeros n) = n.
Proof.
intros.
rewrite <- (Z2Nat.id n) in * by omega.
clear H.
induction (Z.to_nat n).
reflexivity.
rewrite inj_S.
rewrite zeros_equation.
pose proof (Zgt_cases (Z.succ (Z.of_nat n0)) 0).
destruct (Z.succ (Z.of_nat n0) >? 0); try omega.
rewrite Zlength_cons.
f_equal.  rewrite <- IHn0.
f_equal. f_equal. omega.
Qed.

Lemma length_zeros: forall n:Z, length (zeros n) = Z.to_nat n.
Proof.
intros. destruct (zlt n 0).
rewrite zeros_equation.
pose proof (Zgt_cases n 0).
destruct (n>?0). omega.
destruct n. inv l. inv l. simpl. reflexivity.
rename g into H.
pose proof (Zlength_zeros n H).
rewrite Zlength_correct in H0.
rewrite <- H0 at 2.
rewrite Nat2Z.id. auto.
Qed.

Hint Rewrite length_zeros : norm.

Local Open Scope Z.

Lemma Zlength_padlen:
 forall n,
  n>=0 ->
  Zlength (padlen n) = roundup (n/4+3) 16 - n/4 - 1.
Proof.
intros.
unfold padlen.
rewrite Zlength_app.
rewrite Zlength_zeros.
repeat rewrite Zlength_cons; rewrite Zlength_nil.
change (Z.succ (Z.succ 0)) with 2.
unfold roundup.
change (16-1) with 15; omega.
assert (n/4 >= 0).
apply Z_div_ge0; omega.
assert (n/4+3>0) by omega.
forget (n/4+3) as d.
clear - H1.
replace (d+15) with ((1*16)+ (d-1)) by (simpl Z.mul; omega).
rewrite Z_div_plus_full_l by omega.
rewrite Z.mul_add_distr_r.
change (1*16) with 16.
assert ((d-1)/16*16 + 15 >= d-1); [ | omega].
assert (d-1>=0) by omega.
forget (d-1) as e.
clear - H.
pattern e at 2; rewrite (Z_div_mod_eq e 16) by omega.
rewrite Z.mul_comm.
 assert (15 >= e mod 16); [| omega].
destruct (Z.mod_pos_bound e 16); omega.
Qed.

Lemma zeros_app:
  forall n m, (n >= 0 -> m >=0 -> zeros n ++ zeros m = zeros (n+m))%Z.
Proof.
intro.
intros ? ?.
rewrite <- (Z2Nat.id n).
induction (Z.to_nat n); intros; try reflexivity.
rewrite inj_S. unfold Z.succ.
rewrite zeros_equation; symmetry; rewrite zeros_equation; symmetry.
replace ( Z.of_nat n0 + 1 + m >? 0) with true.
replace (Z.of_nat n0 + 1 >? 0) with true.
simpl.
f_equal.
rewrite Z.add_simpl_r.
rewrite IHn0; auto.
f_equal; omega.
symmetry; apply Z.gtb_lt; auto; omega.
symmetry; apply Z.gtb_lt; auto; omega.
omega.
Qed.

Lemma zeros_Zsucc:
 forall n, n >= 0 -> zeros (Z.succ n) = Int.repr 0 :: zeros n.
Proof.
intros.
rewrite zeros_equation.
replace (Z.succ n >? 0) with true.
f_equal. f_equal. omega.
symmetry.
apply Z.gtb_lt; omega.
Qed.

Lemma intlist_to_Zlist_zeros:
  forall n:Z, intlist_to_Zlist (zeros n) = map Int.unsigned (zeros (4*n))%Z.
Proof.
intro.
destruct (zlt n 0).
destruct n; try omega. inv l. reflexivity.
rewrite <- (Z2Nat.id n) by omega.
induction (Z.to_nat n).
simpl; auto.
rewrite inj_S.
rewrite zeros_Zsucc by omega.
unfold intlist_to_Zlist; fold intlist_to_Zlist.
unfold Z.succ.
rewrite Z.add_comm.
rewrite Z.mul_add_distr_l.
replace (4 * 1 + 4 * Z.of_nat n0) with (Z.succ (Z.succ (Z.succ (Z.succ (4 * Z.of_nat n0))))) by omega.
repeat rewrite zeros_Zsucc by omega.
rewrite IHn0.
reflexivity.
Qed.

Definition padlen' (n: Z) : list Int.int :=
     let q := (n+8)/64*16 + 15 - (n+8)/4   (* number of zero-pad words *)
      in zeros q ++ [Int.repr (n * 8 / Int.modulus); Int.repr (n * 8)].

Lemma padlen_eq: padlen=padlen'.
Proof.
extensionality n.
unfold padlen,padlen'; simpl.
f_equal. f_equal.
assert ((n+12)/4 = n/4+3).
intros.
replace (n+12) with (3*4+n) by omega.
 rewrite Z_div_plus_full_l by omega. omega.
rewrite <- H.
replace ((n+12)/4) with ((n+8)/4+1).
rewrite <- Z.add_assoc.
change (1+15) with (1*16).
rewrite <- (Z.add_comm (1*16)).
 rewrite Z_div_plus_full_l by omega.
rewrite Z.mul_add_distr_r.
rewrite Z.div_div by omega.
change (4*16) with 64.
omega.
replace (n+12) with (1*4+(n+8)) by omega.
 rewrite Z_div_plus_full_l by omega.
omega.
Qed.

Lemma length_generate_and_pad'':
  forall (l: list Z) (k: Z),
     k >= 0 ->
     k + Zlength (generate_and_pad' l (k*4)) = roundup (((k*4+Zlength l)+12)/4) 16.
Proof.
intro l.
remember (S (length l)) as L.
assert (length l < L)%nat by omega.
clear HeqL; revert l H; clear; induction L; intros.
inversion H.
destruct l.
simpl; repeat rewrite Zlength_cons; repeat rewrite Zlength_nil.
rewrite Zlength_padlen
  by (apply Z.le_ge; apply Z.mul_nonneg_nonneg; omega).
unfold Z.succ.
replace (k*4+0+12) with (k*4+4+8) by omega.
change 8 with (2*4).
rewrite Z_div_plus_full by omega.
replace ((k*4+4)/4)%Z with (k+1)%Z
 by (replace ((k*4+4)/4)%Z with (k*4/4 + 1)%Z
         by (symmetry; apply (Z_div_plus (k*4) 1 4); omega);
      rewrite Z_div_mult by omega; auto).
rewrite Z.sub_add.
rewrite Z.div_mul by congruence.
replace (k+1+2) with (k+3) by omega.
omega.
assert (k*4 >= 0).
apply Z.le_ge; apply Z.mul_nonneg_nonneg; omega.
destruct l.
simpl; repeat rewrite Zlength_cons; repeat rewrite Zlength_nil.
rewrite Zlength_padlen by omega.
unfold Z.succ. rewrite Z.sub_add.
replace (k*4+(0+1)+12) with (k*4+1+4+8) by omega.
change 8 with (2*4).
rewrite Z_div_plus_full by omega.
change (k * 4 + 1 + 4) with (k * 4 + 1 + 1*4).
rewrite (Z_div_plus (k*4+1) 1 4) by omega.
rewrite (Z.add_comm (k*4)).
rewrite Z_div_plus by omega.
change (1/4) with 0.
rewrite Z.add_0_l.
replace (k+1+2) with (k+3) by omega.
omega.
destruct l.
simpl; repeat rewrite Zlength_cons; repeat rewrite Zlength_nil.
rewrite Zlength_padlen by omega.
unfold Z.succ. rewrite Z.sub_add.
replace (k*4+(0+1+1)+12) with (k*4+2+4+8) by omega.
change 8 with (2*4).
rewrite Z_div_plus_full by omega.
change (k * 4 + 2 + 4) with (k * 4 + 2 + 1*4).
rewrite (Z_div_plus (k*4+2) 1 4) by omega.
rewrite (Z.add_comm (k*4)).
rewrite Z_div_plus by omega.
change (2/4) with 0.
rewrite Z.add_0_l.
replace (k+1+2) with (k+3) by omega.
omega.
destruct l.
simpl; repeat rewrite Zlength_cons; repeat rewrite Zlength_nil.
rewrite Zlength_padlen by omega.
unfold Z.succ. rewrite Z.sub_add.
replace (k*4+(0+1+1+1)+12) with (k*4+3+4+8) by omega.
change 8 with (2*4).
rewrite Z_div_plus_full by omega.
change (k * 4 + 3 + 4) with (k * 4 + 3 + 1*4).
rewrite (Z_div_plus (k*4+3) 1 4) by omega.
rewrite (Z.add_comm (k*4)).
rewrite Z_div_plus by omega.
change (3/4) with 0.
rewrite Z.add_0_l.
replace (k+1+2) with (k+3) by omega.
omega.
simpl; repeat rewrite Zlength_cons; repeat rewrite Zlength_nil.
unfold Z.succ.
transitivity (k+1 + (Zlength (generate_and_pad' l ((k+1) * 4)))).
rewrite Z.mul_add_distr_r.
change (1*4) with 4.
omega.
simpl in H.
rewrite IHL; try omega.
f_equal.
f_equal.
omega.
Qed.

Lemma length_generate_and_pad':
  forall (l: list Z),
     Zlength (generate_and_pad' l 0) = roundup ((Zlength l +12)/4) 16.
Proof.
intros.
transitivity (0 + Zlength (generate_and_pad' l (0*4))).
rewrite Z.add_0_l.
reflexivity.
apply length_generate_and_pad''.
omega.
Qed.

Lemma roundup_ge:
 forall a b,  b > 0 -> roundup a b >= a.
Proof.
intros.
assert (roundup a b - a >= 0); [ | omega].
rewrite roundup_minus by auto.
pose proof (Z.mod_pos_bound (-a) b); omega.
Qed.

Lemma generate_and_pad'_eq:
 generate_and_pad = generate_and_pad_alt.
Proof.
extensionality msg.
unfold generate_and_pad,  generate_and_pad_alt.
match goal with |- context [Zlist_to_intlist ?A] =>
  remember A as PADDED eqn:HP
end.
assert (Nat.divide 4 (length PADDED)). {
subst PADDED.
pose proof (roundup_ge (Zlength msg + 9) 64).
 spec H; [ omega | ].
assert (Zlength msg >= 0) by (rewrite Zlength_correct; omega).
exists (Z.to_nat (roundup (Zlength msg+9) 64 / 4 - 2)).
repeat rewrite app_length.
rewrite length_list_repeat.
simpl length.
symmetry.
transitivity (Z.to_nat (roundup (Zlength msg + 9) 64 / 4 - 2) * Z.to_nat 4)%nat; [reflexivity |].
rewrite <- Z2Nat.inj_mul; try omega.
Focus 2. {
assert (roundup (Zlength msg + 9) 64 / 4 >= (Zlength msg + 9) / 4)
 by (apply Z_div_ge; omega).
assert ((Zlength msg + 9) / 4 = (Zlength msg + 1)/4 + 2).
replace (Zlength msg + 9) with (Zlength msg + 1 + 2*4) by omega.
rewrite Z_div_plus_full by omega.
auto.
assert (0 <= (Zlength msg + 1)/4).
apply Z.div_pos;  omega.
omega. } Unfocus.
rewrite Z.mul_sub_distr_r.
replace (roundup (Zlength msg + 9) 64 / 4 * 4) with
  (roundup (Zlength msg + 9) 64).
Focus 2.
unfold roundup.
forget ((Zlength msg + 9 + (64 - 1)) / 64 ) as N.
change 64 with (16 * 4).
rewrite Z.mul_assoc.
rewrite Z_div_mult_full by omega.
auto.
rewrite <- roundup_minus by omega.
change 64 with 64.
forget (roundup (Zlength msg + 9) 64) as N.
clear H0.
rewrite Zlength_correct in *.
forget (length msg) as L.
transitivity (Z.to_nat (Z.of_nat L + (1 + (N - (Z.of_nat L + 9))))).
f_equal. omega.
rewrite Z2Nat.inj_add  by omega.
rewrite Nat2Z.id.
f_equal.
rewrite Z2Nat.inj_add by omega.
f_equal.
}
remember (Z.to_nat (Zlength msg / 4)) as n.
change PADDED with (skipn 0 PADDED).
change msg with (skipn 0 msg) at 3.
change 0 with (Z.of_nat 0).
replace 0%nat with ((Z.to_nat (Zlength msg / 4) - n)*4)%nat
 by (rewrite Heqn, minus_diag; reflexivity).
assert (H88: (n * 4 <= length msg)%nat). {
 subst n.
 apply Nat2Z.inj_le.
 rewrite <- Zlength_correct. rewrite Nat2Z.inj_mul.
 rewrite Z2Nat.id.
 rewrite (Z_div_mod_eq (Zlength msg) 4) at 2 by omega.
 change (Z.of_nat 4) with 4. rewrite <- Z.mul_comm.
 pose proof (Z.mod_pos_bound (Zlength msg) 4); omega.
 apply Z.div_pos; try rewrite Zlength_correct; omega.
}
clear Heqn.
revert H88; induction n; intros.
* (* base case for n *)
clear H88.
rewrite Nat.sub_0_r.
rewrite Nat2Z.inj_mul.
assert (0 <= Zlength msg) by (rewrite Zlength_correct; omega).
assert (0 <= Zlength msg / 4) by (apply Z.div_pos; omega).
pose proof (Z_div_mod_eq (Zlength msg) 4). spec H2; [omega|].
assert (H99: (Z.to_nat (Zlength msg / 4) * 4 <= length msg)%nat).
apply Nat2Z.inj_le.
rewrite <- Zlength_correct.
rewrite Nat2Z.inj_mul.
rewrite Z2Nat.id by auto.
change (Z.of_nat 4) with 4.
destruct (Z.mod_pos_bound (Zlength msg) 4); omega.
rewrite Z2Nat.id by omega.
change (Z.of_nat 4) with 4.
rewrite Z.mul_comm in H2.
assert (length (skipn (Z.to_nat (Zlength msg / 4) * 4) msg) < 4)%nat.
rewrite skipn_length.
apply Nat2Z.inj_lt.
rewrite Nat2Z.inj_sub. rewrite <- Zlength_correct.
rewrite Nat2Z.inj_mul. change (Z.of_nat 4) with 4.
rewrite Z2Nat.id by auto.
destruct (Z.mod_pos_bound (Zlength msg) 4); omega.
omega.
rewrite HP.
rewrite skipn_app1 by omega.
remember (skipn (Z.to_nat (Zlength msg / 4) * 4) msg) as ccc.
assert (HQ: (Zlength msg + 8) / 64 * 16 + 15 - (Zlength msg + 8) / 4 >= 0). {
clear - H0.
assert (0 <= Zlength msg + 8) by omega.
clear H0. forget (Zlength msg + 8) as a.
pose proof (Z_div_mod_eq a 64); spec H0; [omega|].
rewrite H0 at 2.
rewrite (Z.mul_comm 64).
change 64 with (16*4) at 3.
rewrite Z.mul_assoc.
rewrite Z_div_plus_full_l by omega.
assert (a mod 64 / 4 < 16).
apply Z.div_lt_upper_bound. omega. apply Z.mod_pos_bound; omega.
omega.
}
assert (- (Zlength msg + 9) mod 64 =
           (3 - Zlength ccc) + 4* ((Zlength msg+8)/64 * 16 + 15 - (Zlength msg + 8) / 4)). {
assert (LL: length ccc = length (skipn (Z.to_nat (Zlength msg / 4) * 4) msg))
 by congruence.
rewrite skipn_length in LL.
assert (LL': Zlength msg = Zlength ccc + (Zlength msg/4)*4).
rewrite Zlength_correct at 1.
rewrite Zlength_correct at 1.
 rewrite LL.
rewrite Nat2Z.inj_sub.
rewrite Nat2Z.inj_mul.
rewrite Z2Nat.id by auto.
change (Z.of_nat 4) with 4; omega.
rewrite Nat2Z.inj_le.
rewrite Nat2Z.inj_mul.
rewrite Z2Nat.id by auto.
rewrite <- Zlength_correct.
change (Z.of_nat 4) with 4.
assert (0 <= Zlength msg mod 4)
 by (apply Z.mod_pos_bound; omega).
omega.
replace (Zlength ccc) with (Zlength msg - Zlength msg / 4 * 4) by omega.
clear LL LL'.
clear - H0 HQ. forget (Zlength msg) as a.
 rewrite <- roundup_minus by omega; unfold roundup.
replace (a  + 9 + (64-1)) with (a + 8 + 1*64) by omega.
rewrite Z_div_plus_full by omega.
rewrite Z.mul_add_distr_r.
rewrite (Z.mul_comm 4).
rewrite Z.mul_sub_distr_r.
rewrite Z.mul_add_distr_r.
change (15*4) with (64-4).
rewrite <- Z.mul_assoc.
change (16*4) with 64.
assert (0 =8+ a / 4 * 4 - (a + 8) / 4 * 4);  [ | omega].
change 8 with (2*4) at 2.
rewrite Z_div_plus_full by omega.
rewrite Z.mul_add_distr_r.
omega.
}
rewrite H4.
assert (0 <= Zlength ccc < 4)
 by (clear - H3; rewrite Zlength_correct; omega).
rewrite Z2Nat.inj_add by omega.
rewrite <- list_repeat_app.
replace (Zlength msg / 4 * 4) with (Zlength msg - Zlength ccc).
Focus 2. {
rewrite Heqccc.
rewrite (Zlength_correct (skipn _ _)).
rewrite skipn_length by omega.
rewrite Nat2Z.inj_sub by omega.
rewrite <- Zlength_correct.
rewrite Nat2Z.inj_mul. change (Z.of_nat 4) with 4.
rewrite Z2Nat.id  by omega.
 omega.
} Unfocus.
match goal with |- context [_ ++ list_repeat (Z.to_nat (4 * ?qq)) 0] =>
 assert (Zlist_to_intlist (list_repeat (Z.to_nat (4 * qq)) 0) =
  zeros ((Zlength msg + 8) / 64 * 16 + 15 - (Zlength msg + 8) / 4));
  set (Q := qq) in *
end. {
 rewrite Z2Nat.inj_mul by omega. change (Z.to_nat 4) with 4%nat.
 rewrite <- Z2Nat.id at 2 by omega.
 induction (Z.to_nat Q). reflexivity.
 rewrite inj_S. rewrite zeros_equation.
 assert (0 < Z.succ (Z.of_nat n)) by omega.
 apply Z.gtb_lt in H6; rewrite H6.
 replace (Z.succ (Z.of_nat n) - 1) with (Z.of_nat n) by omega.
 rewrite <- IHn.
 replace (4 * S n)%nat with (S (S (S (S (4*n)))))%nat.
 reflexivity. omega.
}
set (Q4 := Z.to_nat (4 * Q)) in *.
destruct ccc as [|a [|b [|c [|]]]]; simpl in H3; try omega; clear H3;
 unfold generate_and_pad'; rewrite padlen_eq; unfold padlen';
 simpl;
repeat rewrite Zlength_cons; rewrite Zlength_nil.
+ (* ccc = [] *)
  rewrite Z.sub_0_r. rewrite H6. reflexivity.
+ (* ccc = [a] *)
   change (Z.succ 0) with 1; rewrite Z.sub_add. rewrite H6. reflexivity.
+ (* ccc = [a,b] *)
   change (Z.succ (Z.succ 0)) with 2; rewrite Z.sub_add.
   rewrite H6. reflexivity.
+ (* ccc = [a,b,c] *)
   change (Z.succ (Z.succ (Z.succ 0))) with 3; rewrite Z.sub_add.
   rewrite H6. reflexivity.
* (* inductive case for n *)
replace (S n * 4)%nat with (4 + n*4)%nat in H88 by omega.
assert ((Z.to_nat (Zlength msg / 4) - S n) * 4 = ((Z.to_nat (Zlength msg / 4) - n) * 4) - 4)%nat
  by omega.
rewrite H0. clear H0.
spec IHn; [omega |].
set (Q := ((Z.to_nat (Zlength msg / 4) - n) * 4)%nat) in *.
assert (Hyy : 0 <= Zlength msg) by (rewrite Zlength_correct; omega).
assert (Hzz:=Zmod_eq (Zlength msg) 4); spec Hzz; [omega|].
destruct (Z.mod_pos_bound (Zlength msg) 4); try  omega.
apply Nat2Z.inj_le in H88.
rewrite Nat2Z.inj_add, Nat2Z.inj_mul in H88.
rewrite <- Zlength_correct in H88.
change (Z.of_nat 4) with 4 in *.
assert (Huu:= Z.div_pos (Zlength msg) 4 Hyy); spec Huu; [omega|].
assert (Q >= 4)%nat. {
 clear - H88 Hyy Hzz H0 H1 Huu; unfold Q; clear Q.
apply Nat2Z.inj_ge. rewrite Nat2Z.inj_mul.
change (Z.of_nat 4) with 4 in *.
rewrite Nat2Z.inj_sub
 by (apply Nat2Z.inj_le; rewrite Z2Nat.id by auto;
       apply Zmult_le_reg_r with 4; omega).
 rewrite Z2Nat.id by auto.
change 4 with (1*4) at 3.
apply Zmult_ge_reg_r with 4; omega.
}
rewrite <- (firstn_skipn 4 (skipn (Q-4) PADDED)), skipn_drop.
rewrite <- (firstn_skipn 4 (skipn (Q-4) msg)), skipn_drop.
replace (4 + (Q-4))%nat with Q by omega.
rewrite HP at 1.
assert (QL: (Q <= length msg)%nat). {
apply Nat2Z.inj_le.
rewrite <- Zlength_correct.
unfold Q.
rewrite Nat2Z.inj_mul.
rewrite Nat2Z.inj_sub.
 rewrite Z2Nat.id by auto.
change (Z.of_nat 4) with 4 in *.
 rewrite Z.mul_sub_distr_r.
omega.
apply Nat2Z.inj_le.
 rewrite Z2Nat.id by auto.
omega.
}
rewrite skipn_app1 by omega.
rewrite firstn_app1
 by (rewrite skipn_length by omega; omega).
assert (length (firstn 4 (skipn (Q - 4) msg)) = 4)%nat.
rewrite firstn_length. rewrite skipn_length by omega.
apply min_l. omega.
destruct (firstn 4 (skipn (Q - 4) msg))
 as [ | z0 [| z1 [| z2 [|z3 [|]]]]];inv H3.
unfold app at 2. unfold app at 4.
unfold generate_and_pad'; fold generate_and_pad'.
unfold Zlist_to_intlist; fold Zlist_to_intlist.
replace (Z.of_nat (Q-4) + 4) with (Z.of_nat Q)
 by (rewrite Nat2Z.inj_sub by omega;
       change (Z.of_nat 4) with 4; omega).
rewrite <- IHn.
reflexivity.
Qed.

Lemma roundup_divide:
 forall a b, b > 0 ->  (b | roundup a b).
Proof.
intros.
unfold roundup.
apply Z.divide_factor_r.
Qed.

Lemma length_generate_and_pad:
  forall (l: list Z),
     Zlength (generate_and_pad l) = roundup ((Zlength l +12)/4) 16.
Proof.
intros.
rewrite generate_and_pad'_eq.
unfold generate_and_pad_alt.
apply length_generate_and_pad'.
Qed.

Transparent generate_word.

Lemma generate_word_lemma1:
  forall b n, length b = 16%nat ->
   firstn 16 (rev (generate_word (rev b) n)) = b.
Proof.
intros.
change (rev b) with (nil ++ rev b).
forget (@nil int) as a.
revert a; induction n; intro.
unfold generate_word.
rewrite rev_app_distr.
rewrite rev_involutive.
rewrite firstn_app1 by omega.
rewrite firstn_same; auto; omega.
unfold generate_word; fold generate_word.
change (Wnext (a ++ rev b) :: a ++ rev b) with
      ((Wnext (a ++ rev b) ::a) ++ rev b).
apply IHn.
Qed.

Lemma length_generate_word: forall b n,
  length (generate_word b n) = (length b + n)%nat.
Proof.
intros.
revert b; induction n; intros; simpl.
unfold generate_word; fold generate_word.
omega.
unfold generate_word; fold generate_word.
rewrite IHn.
simpl. omega.
Qed.

Lemma nth_generate_word_S:
  forall k i n b',
   nth (i+k) (generate_word b' (n+k)) = nth i (generate_word b' n).
Proof.
induction k; intros.
repeat rewrite plus_0_r. auto.
replace (n + S k)%nat with (S (n + k))%nat by omega.
unfold generate_word; fold generate_word.
replace (i + S k)%nat with (S i + k)%nat by omega.
rewrite IHk by (simpl; omega).
clear IHk.
revert i b' ; induction n; intros.
unfold generate_word; fold generate_word.
extensionality d; reflexivity.
unfold generate_word; fold generate_word.
apply IHn.
Qed.

Lemma generate_word_small:
  forall i b n,
           length b = 16%nat ->
           (i < length b)%nat ->
           nth i (rev (generate_word (rev b) n)) = nth i b.
Proof.
intros.
extensionality d.
rewrite <- (nth_firstn_low _ _ 16).
rewrite (generate_word_lemma1 b n H).
auto.
rewrite rev_length, length_generate_word, rev_length, H.
omega.
Qed.

Lemma generate_word_plus:
  forall msg a b, (16 <= length msg)%nat ->
         generate_word msg (a+b) = generate_word (generate_word msg a) b.
Proof.
intros msg a b.
revert msg b; induction a; simpl; intros.
unfold generate_word; fold generate_word.
auto.
unfold generate_word; fold generate_word.
rewrite IHa by (simpl; omega).
auto.
Qed.

Definition nthB (b: list int) (i: nat) (n: Z) :=
  nth (Z.to_nat (Z.of_nat i - 16 + n)) (rev (generate_word (rev b) 48)) Int.zero.

Lemma nth_rev_generate_word:
 forall i b,
   length b = 16%nat ->
   (16 <= i < 64)%nat ->
    nth i (rev (generate_word (rev b) 48)) Int.zero =
  Int.add (nthB b i 0)
    (Int.add (Int.add (sigma_0 (nthB b i 1)) (sigma_1 (nthB b i 14)))
       (nthB b i 9)).
Proof.
intros.
unfold nthB.
rewrite <- rev_length in H.
forget (rev b) as b'.
clear b.
assert (length (generate_word b' 48) = 64)%nat
 by (rewrite length_generate_word, H; reflexivity).
rewrite rev_nth by omega.
repeat rewrite rev_nth
 by (rewrite H1; change 64%nat with (Z.to_nat 64); apply Z2Nat.inj_lt; omega).
rewrite H1.
rewrite <- (plus_0_l (64 - S i)).
assert (48 = (i - 16) + 1 + (64 - S i))%nat by (clear - H0; omega).
rewrite H2 at 2.
rewrite nth_generate_word_S.
rewrite generate_word_plus by omega.
unfold generate_word at 1.
unfold nth at 1.
assert (forall n:nat, (n < 16) ->
    ((64 - S (Z.to_nat (Z.of_nat i - 16 + Z.of_nat n))) =
      (16-n) + (48 - S (Z.to_nat (Z.of_nat i - 16)))))%nat.
clear - H0.
intros.
rewrite Z2Nat.inj_add by omega.
rewrite Nat2Z.id.
rewrite Z2Nat.inj_sub by omega.
rewrite Nat2Z.id.
change (Z.to_nat 16) with 16%nat.
omega.
change 0%Z with (Z.of_nat 0); rewrite H3 by (clear; omega).
change 1%Z with (Z.of_nat 1); rewrite H3 by (clear; omega).
change 14%Z with (Z.of_nat 14); rewrite H3 by (clear; omega).
change 9%Z with (Z.of_nat 9); rewrite H3 by (clear; omega).
clear H3.
assert (48 = S (Z.to_nat (Z.of_nat i - 16)) + (48 - S (Z.to_nat (Z.of_nat i - 16))))%nat.
clear - H0.
rewrite Z2Nat.inj_sub by omega.
rewrite Nat2Z.id.
change (Z.to_nat 16) with 16%nat.
omega.
pattern (generate_word b' 48).
rewrite H3 at 1.
repeat rewrite nth_generate_word_S.
rewrite Z2Nat.inj_sub by omega.
rewrite Nat2Z.id.
change (Z.to_nat 16) with 16%nat.
simpl.
change (nth 16) with (@nth int (15+1)).
change (nth 15) with (@nth int (14+1)).
change (nth 2) with (@nth int (1+1)).
change (nth 7) with (@nth int (6+1)).
replace (S (i-16)) with ((i-16)+1)%nat by omega.
repeat rewrite nth_generate_word_S.
assert (length (generate_word b' (i-16)) >= 16)%nat.
rewrite length_generate_word, H; omega.
clear - H4.
forget (generate_word b' (i-16)) as s.
rename H4 into H.
do 16 (destruct s; [simpl in H; omega | ]).
simpl.
rewrite <- Int.add_assoc.
rewrite Int.add_commut.
f_equal.
rewrite Int.add_commut.
rewrite <- Int.add_assoc.
auto.
Qed.

Opaque generate_word.

Definition c48 := 48%nat. Opaque c48.

Lemma generate_word_W:
 forall block n
 (LB: length block = 16%nat),
  0 <= n < 64 ->
  nthi (rev (generate_word (rev block) 48)) n =
  W (nthi block) n.
Proof.
intros.
assert (forall i, (i <= Z.to_nat 64)%nat ->
              forall n, 0 <= n < Z.of_nat i ->
 nthi (rev (generate_word (rev block) 48)) n = W (nthi block) n).
Focus 2. {
apply (H0 (S (Z.to_nat n))).
apply Nat2Z.inj_le. rewrite inj_S.
repeat rewrite Z2Nat.id by omega. omega.
rewrite inj_S.
rewrite Z2Nat.id by omega. omega.
} Unfocus.
clear H n.
induction i; intros.
change (Z.of_nat 0) with 0 in H0; omega.
spec IHi; [ omega | ].
unfold nthi at 1.
destruct (zlt n 16).
rewrite generate_word_small; auto.
Focus 2.
rewrite LB.
apply Nat2Z.inj_lt. rewrite Z2Nat.id by omega. apply l.
rewrite W_equation.
rewrite if_true by auto.
reflexivity.
rewrite nth_rev_generate_word; auto.
Focus 2. {
split.
apply Nat2Z.inj_le. change (Z.of_nat 16) with 16.
rewrite Z2Nat.id by omega. omega.
apply Nat2Z.inj_lt.
rewrite Z2Nat.id by omega.
change (Z.of_nat 64) with 64.
apply Nat2Z.inj_le in H.
rewrite Z2Nat.id in H by omega.
omega.
} Unfocus.
rewrite W_equation.
rewrite if_false by omega.
rewrite inj_S in H0.
rewrite <- IHi by omega.
rewrite <- IHi by omega.
rewrite <- IHi by omega.
rewrite <- IHi by omega.
unfold nthB.
rewrite Z2Nat.id by omega.
replace (n - 16 + 14) with (n-2) by omega.
replace (n - 16 + 9) with (n - 7) by omega.
replace (n - 16 + 0) with (n-16) by omega.
replace (n - 16 + 1) with (n - 15) by omega.
unfold nthi.
forget (nth (Z.to_nat (n - 16)) (rev (generate_word (rev block) 48)) Int.zero)
  as A.
forget (sigma_1
        (nth (Z.to_nat (n - 2)) (rev (generate_word (rev block) 48)) Int.zero))
  as B.
forget  (sigma_0
           (nth (Z.to_nat (n - 15)) (rev (generate_word (rev block) 48))
              Int.zero))
  as C.
forget (nth (Z.to_nat (n - 7)) (rev (generate_word (rev block) 48)) Int.zero)
  as D.
rewrite Int.add_commut.
repeat rewrite <- Int.add_assoc.
f_equal.
rewrite <- (Int.add_commut D).
rewrite <- (Int.add_commut D).
rewrite Int.add_assoc.
f_equal.
apply Int.add_commut.
Qed.

Lemma process_block_hash_block:
 forall regs block,
   length regs = 8%nat ->
   length block = 16%nat ->
   process_block regs (rev block) = hash_block regs block.
Proof.
intros.
unfold process_block.
unfold hash_block.
f_equal.
rewrite <- (firstn_same _ 64 (rev (generate_word _ _)))
 by (rewrite rev_length, length_generate_word, rev_length; omega).
change 64%nat with (48+16)%nat.
change 63%Z with (Z.of_nat (48+16)-1).
assert (48 <= 48)%nat by omega.
remember 48%nat as n.
rewrite Heqn at 2.
rewrite Heqn in H1 at 2.
clear Heqn. rename H1 into H7.
revert regs H H7; induction n; intros.
simpl plus.
change 48%nat with c48 in H7 |- *.
remember 16%nat as n.
rewrite Heqn in H0.
assert (n <= 16)%nat by omega.
clear Heqn H7.
revert H1; induction n; intros.
* (* n=0 *)
simpl.
rewrite Round_equation.
rewrite if_true by omega.
reflexivity.
* (*0 < n <= 16 *)
rewrite Round_equation.
rewrite inj_S.
rewrite if_false by omega.
replace (Z.succ (Z.of_nat n) - 1) with (Z.of_nat n) by omega.
rewrite <- IHn by omega. clear IHn.
rewrite (rnd_64_S _ _ _
    (nthi K256 (Z.of_nat n))
    (nthi block (Z.of_nat n))).
2: (unfold nthi; rewrite Nat2Z.id; apply nth_error_nth; simpl; omega).
Focus 2.
unfold nthi; rewrite Nat2Z.id.
rewrite (nth_error_nth _ Int.zero n).
2: rewrite rev_length, length_generate_word, rev_length, H0;
  change c48 with 48%nat; omega.
f_equal.
rewrite generate_word_small by omega.
auto.
unfold rnd_function.
destruct (rnd_64 regs K256 (firstn n (rev (generate_word (rev block) c48))))
  as [ | a [ | b [ | c [ | d [ | e [ | f [ | g [ | h [ | ]]]]]]]]]; auto.
rewrite W_equation.
rewrite if_true; auto.
omega.
* (* 16 <= n < 64 *)
change (S n + 16)%nat with (S (n + 16)).
rewrite inj_S.
unfold Z.succ.
rewrite Z.add_simpl_r.
rewrite (rnd_64_S _ _ _
    (nthi K256 (Z.of_nat (n+16)))
    (nthi (rev (generate_word (rev block) c48)) (Z.of_nat (n+16)))).
2: (unfold nthi; rewrite Nat2Z.id; apply nth_error_nth; simpl; omega).
Focus 2.
unfold nthi; rewrite Nat2Z.id.
apply (nth_error_nth _ Int.zero (n+16)).
rewrite rev_length, length_generate_word, rev_length, H0;
  change c48 with 48%nat; omega.
rewrite Round_equation.
rewrite <- IHn by omega.
rewrite if_false by omega.
forget (rnd_64 regs K256 (firstn (n + 16) (rev (generate_word (rev block) 48))))
   as regs'.
unfold rnd_function.
destruct regs'
  as [ | a [ | b [ | c [ | d [ | e [ | f [ | g [ | h [ | ]]]]]]]]]; auto.
replace (W (nthi block) (Z.of_nat (n + 16)))
  with  (nthi (rev (generate_word (rev block) c48)) (Z.of_nat (n + 16)));
auto.
change c48 with 48%nat.
apply generate_word_W; auto.
rewrite Nat2Z.inj_add. change (Z.of_nat 16) with 16.
omega.
Qed.

Lemma process_msg_hash_blocks:
  forall regs blocks,
    (16 | Zlength blocks) ->
    length regs = 8%nat ->
    process_msg regs blocks = hash_blocks regs blocks.
Proof.
intros.
destruct H as [n ?].
rewrite Zlength_correct in H.
assert (0 <= n).
 apply Zmult_le_0_reg_r with 16; auto. omega.
 omega.
rewrite <- (Z2Nat.id n) in H by omega.
change 16 with (Z.of_nat 16) in H.
rewrite <- Nat2Z.inj_mul in H.
apply Nat2Z.inj in H.
clear H1.
revert blocks H regs H0; induction (Z.to_nat n); intros.
destruct blocks; inv H.
rewrite process_msg_equation, hash_blocks_equation.
reflexivity.
assert (length (firstn 16 blocks) = 16)%nat
 by (rewrite firstn_length, H; simpl; omega).
rewrite hash_blocks_equation.
destruct blocks; [ inv H | ].
forget (i::blocks) as bb.
clear n i blocks; rename bb into blocks.
rewrite <- (firstn_skipn 16 blocks) at 1.
rewrite process_msg_eq2 by auto.
rewrite process_block_hash_block; auto.
apply IHn0.
rewrite skipn_length; omega.
apply length_hash_block; auto.
Qed.

Lemma SHA_256'_eq:  SHA_256' = SHA_256.
Proof.
extensionality msg.
unfold SHA_256', SHA_256.
f_equal.
rewrite <- generate_and_pad'_eq.
assert (16 | Zlength (generate_and_pad msg)).
rewrite (length_generate_and_pad msg).
apply roundup_divide; omega.
assert (length init_registers = 8%nat) by reflexivity.
forget init_registers as regs.
forget (generate_and_pad msg) as blocks.
apply process_msg_hash_blocks; auto.
Qed.