Require Import
  Coq.Program.Program
  Coq.Unicode.Utf8
  Coq.micromega.Lia
  Coq.Classes.CEquivalence
  Coq.Classes.CRelationClasses
  Coq.Classes.CMorphisms
  FunInd
  Stream
  Bool
  LTL
  Model.

Open Scope program_scope.

Generalizable All Variables.
Set Transparent Obligations.
Set Decidable Equality Schemes.

Module LTL (S : StreamType).

Module Import L := StreamLTL S.

(** This data type encodes the syntax of LTL in Positive Normal Form (PNF). *)
Inductive Formula : Type :=
  | Top
  | Bottom
  | Examine       (v   : S.a -> Formula)
  | And           (p q : Formula)
  | Or            (p q : Formula)
  | Next          (p   : Formula)
  | Until         (p q : Formula)
  | Release       (p q : Formula)
  | Always        (p   : Formula)
  | Eventually    (p   : Formula)
  | Wait          (p q : Formula)
  | StrongRelease (p q : Formula).

Fixpoint denote (l : Formula) : L.t :=
  match l with
  | Top               => true
  | Bottom            => false
  | Examine v         => fun s => denote (v (head s)) s
  | And p q           => denote p ∧ denote q
  | Or p q            => denote p ∨ denote q
  | Next p            => ◯ (denote p)
  | Until p q         => (denote p) U (denote q)
  | Release p q       => (denote p) R (denote q)
  | Always p          => □ (denote p)
  | Eventually p      => ◇ (denote p)
  | Wait p q          => (denote p) W (denote q)
  | StrongRelease p q => (denote p) M (denote q)
  end.

Fixpoint size (p : Formula) : nat :=
  match p with
  | Top               => 1
  | Bottom            => 1
  | Examine v         => 1
  | And p q           => 1 + size p + size q
  | Or p q            => 1 + size p + size q
  | Next p            => 1 + size p
  | Until p q         => 1 + size p + size q
  | Release p q       => 1 + size p + size q
  | Always p          => 1 + size p
  | Eventually p      => 1 + size p
  | Wait p q          => 1 + size p + size q
  | StrongRelease p q => 1 + size p + size q
  end.

Function negate (l : Formula) : Formula :=
  match l with
  | Top               => Bottom
  | Bottom            => Top
  | Examine v         => Examine (negate ∘ v)
  | And p q           => Or (negate p) (negate q)
  | Or p q            => And (negate p) (negate q)
  | Next p            => Next (negate p)
  | Until p q         => Release (negate p) (negate q)
  | Release p q       => Until (negate p) (negate q)
  | Always p          => Eventually (negate p)
  | Eventually p      => Always (negate p)
  | Wait p q          => StrongRelease (negate p) (negate q)
  | StrongRelease p q => Wait (negate p) (negate q)
  end.

Fixpoint expand (l : Formula) : Formula :=
  match l with
  | Top               => l
  | Bottom            => l
  | Examine v         => Examine (expand ∘ v)
  | And p q           => And (expand p) (expand q)
  | Or p q            => Or (expand p) (expand q)
  | Next p            => Next (expand p)
  | Until p q         => Or (expand q) (And (expand p) (Next (Until p q)))
  | Release p q       => And (expand q) (Or (expand p) (Next (Release p q)))
  | Always p          => And (expand p) (Next (Always p))
  | Eventually p      => Or (expand p) (Next (Eventually p))
  | Wait p q          => Or (expand q) (And (expand p) (Next (Wait p q)))
  | StrongRelease p q => And (expand q) (Or (expand p) (Next (StrongRelease p q)))
  end.

Definition basic (l : Formula) : Prop :=
  match l with
  | Until p q         => False
  | Release p q       => False
  | Always p          => False
  | Eventually p      => False
  | Wait p q          => False
  | StrongRelease p q => False
  | _                 => True
  end.

Lemma basic_expand : forall l, basic (expand l).
Proof. induction l; simpl; auto. Qed.

Fixpoint shallow (l : Formula) : Prop :=
  match l with
  | Top               => True
  | Bottom            => True
  | Examine v         => True
  | And p q           => shallow p /\ shallow q
  | Or p q            => shallow p /\ shallow q
  | Next p            => True
  | Until p q         => False
  | Always p          => False
  | Eventually p      => False
  | Release p q       => False
  | Wait p q          => False
  | StrongRelease p q => False
  end.

Lemma expand_complete (l : Formula) : shallow (expand l).
Proof. induction l; simpl in *; intuition auto. Qed.

(** Prune out any instances of Top or Bottom *)
Function prune (l : Formula) : Formula :=
  match l with
  | Top       => l
  | Bottom    => l
  | Examine v => l

  | And p q =>
    match prune p with
    | Top => prune q
    | _   =>
      match prune q with
      | Top => prune p
      | _   => And (prune p) (prune q)
      end
    end

  | Or p q =>
    match prune p with
    | Bottom => prune q
    | _      =>
      match prune q with
      | Bottom => prune p
      | _      => Or (prune p) (prune q)
      end
    end

  | Next p            => Next (prune p)
  | Until p q         => Until (prune p) (prune q)
  | Release p q       => Release (prune p) (prune q)
  | Always p          => Always (prune p)
  | Eventually p      => Eventually (prune p)
  | Wait p q          => Wait (prune p) (prune q)
  | StrongRelease p q => StrongRelease (prune p) (prune q)
  end.

CoInductive matches : Formula -> Stream S.a -> Type :=
  | MatchTop s :
      matches Top s
  | MatchExamine v x xs :
      matches (v x) (Cons x xs) -> matches (Examine v) (Cons x xs)
  | MatchAnd p q s :
      matches p s -> matches q s -> matches (And p q) s
  | MatchOrLeft p q s :
      matches p s -> matches (Or p q) s
  | MatchOrRight p q s :
      matches q s -> matches (Or p q) s
  | MatchNext p x xs :
      matches p xs -> matches (Next p) (Cons x xs)
  | MatchUntilTerm p q s :
      matches q s ->
      matches (Until p q) s
  | MatchUntilCont p q x xs :
      matches p (Cons x xs) ->
      matches (Until p q) xs ->
      matches (Until p q) (Cons x xs)
  | MatchAlways p x xs :
      matches p (Cons x xs) ->
      matches (Always p) xs ->
      matches (Always p) (Cons x xs)
  | MatchEventuallyTerm p s :
      matches p s ->
      matches (Eventually p) s
  | MatchEventuallyCont p x xs :
      matches (Eventually p) xs ->
      matches (Eventually p) (Cons x xs)
  | MatchReleaseTerm p q s :
      matches q s ->
      matches p s ->
      matches (Release p q) s
  | MatchReleaseCont p q x xs :
      matches q (Cons x xs) ->
      matches (Release p q) xs ->
      matches (Release p q) (Cons x xs)
  | MatchWaitTerm p q s :
      matches q s ->
      matches (Wait p q) s
  | MatchWaitCont p q x xs :
      matches p (Cons x xs) ->
      matches (Wait p q) xs ->
      matches (Wait p q) (Cons x xs)
  | MatchStrongReleaseTerm p q s :
      matches q s ->
      matches p s ->
      matches (StrongRelease p q) s
  | MatchStrongReleaseCont p q x xs :
      matches q (Cons x xs) ->
      matches (StrongRelease p q) xs ->
      matches (StrongRelease p q) (Cons x xs).

CoInductive Maybe (A : Type) :=
  | Nothing : Maybe A
  | Just    : A -> Maybe A.

Arguments Nothing {A}.
Arguments Just {A} _.

CoFixpoint analyze (l : Formula) (s : Stream S.a) : Maybe (matches l s) :=
  match l with
  | Top    => Just (MatchTop s)
  | Bottom => Nothing

  | Examine v =>
    match s with
    | Cons x xs =>
      match analyze (v x) (Cons x xs) with
      | Just r => Just (MatchExamine v x xs r)
      | Nothing   => Nothing
      end
    end

  | And p q =>
    match analyze p s with
    | Just r =>
      match analyze q s with
      | Just t => Just (MatchAnd p q s r t)
      | Nothing   => Nothing
      end
    | Nothing   => Nothing
    end

  | Or p q  =>
    match analyze p s with
    | Just r => Just (MatchOrLeft p q s r)
    | Nothing   =>
      match analyze q s with
      | Just t => Just (MatchOrRight p q s t)
      | Nothing   => Nothing
      end
    end

  | Next p =>
    match s with
    | Cons x xs =>
      match analyze p xs with
      | Just r => Just (MatchNext p x xs r)
      | Nothing   => Nothing
      end
    end

  | Until p q =>
    let cofix go s : Maybe (matches (Until p q) s) :=
        match analyze q s with
        | Just r  => Just (MatchUntilTerm p q s r)
        | Nothing =>
          match s with
          | Cons x xs =>
            match analyze p (Cons x xs) with
            | Just r =>
              match go xs with
              | Just t  => Just (MatchUntilCont p q x xs r t)
              | Nothing => Nothing
              end
            | Nothing => Nothing
            end
          end
        end in go s

  | Release p q =>
    let cofix go s :=
        match s with
        | Cons _ xs => analyze q s /\ (analyze p s \/ go xs)
        end in go s

  | Always p =>
    let cofix go s :=
        match s with
        | Cons _ xs => analyze p s /\ go xs
        end in go s

  | Eventually p =>
    let cofix go s :=
        match s with
        | Cons _ xs => analyze p s \/ go xs
        end in go s

  | Wait p q =>
    let cofix go s :=
        match s with
        | Cons _ xs => analyze q s \/ (analyze p s /\ go xs)
        end in go s

  | StrongRelease p q =>
    let cofix go s :=
        match s with
        | Cons _ xs => analyze q s /\ (analyze p s \/ go xs)
        end in go s
  end.

Notation "t ⊢ l ⇝ p" := (analyze l t <-> p) (at level 100).

Section matches_coind.

Variable P : Formula -> Stream S.a -> Type.

Hypothesis Bottom_case        : forall s, P Bottom s -> False.
Hypothesis Examine_case       : forall s v, P (Examine v) s -> P (v (head s)) s.
Hypothesis And_case           : forall s p q, P (And p q) s -> P p s * P q s.
Hypothesis Or_case            : forall s p q, P (Or  p q) s -> P p s + P q s.
Hypothesis Next_case          : forall s p, P (Next p) s -> P p (tail s).
Hypothesis Until_case         : forall s p q,
  P (Until p q) s -> P q s + (P p s * P (Until p q) (tail s)).
Hypothesis Release_case       : forall s p q,
  P (Release p q) s -> P q s * (P p s + P (Release p q) (tail s)).
Hypothesis Always_case        : forall s p, P (Always p) s -> P p s * P (Always p) (tail s).
Hypothesis Eventually_case    : forall s p, P (Eventually p) s -> P p s + P (Eventually p) (tail s).
(* Hypothesis Wait_case          : forall s p q, P (Next p) s -> P p (tail s). *)
(* Hypothesis StrongRelease_case : forall s p q, P (Next p) s -> P p (tail s). *)

Theorem matches_coind : forall p s, P p s -> matches p s.
Proof.
  cofix matches_coind.
  destruct p; intros.
  - now constructor.
  - contradiction (Bottom_case _ X).
  - destruct s.
    constructor.
    apply Examine_case in X.
    now apply matches_coind.
  - apply And_case in X.
    destruct X.
    constructor;
    now apply matches_coind.
  - apply Or_case in X.
    destruct X;
    constructor;
    now apply matches_coind.
  - apply Next_case in X.
    destruct s.
    constructor.
    rewrite tail_cons in X.
    now apply matches_coind.
  - apply Until_case in X.
    destruct X.
    + apply MatchUntilTerm.
      now apply matches_coind.
    + destruct p.
      destruct s.
      apply MatchUntilCont;
      now apply matches_coind.
  - apply Release_case in X.
    destruct X.
    destruct s0.
    + apply MatchReleaseTerm;
      now apply matches_coind.
    + destruct s.
      apply MatchReleaseCont;
      now apply matches_coind.
  - apply Always_case in X.
    destruct X.
    destruct s.
    constructor;
    rewrite tail_cons in p1;
    now apply matches_coind.
  - apply Eventually_case in X.
    destruct X.
    + apply MatchEventuallyTerm.
      now apply matches_coind.
    + destruct s.
      apply MatchEventuallyCont.
      now apply matches_coind.
  - admit.
  - admit.
Admitted.

End matches_coind.

Theorem matches_denote p s : matches p s -> denote p s.
Proof.
  intros.
  generalize dependent s.
  induction p; intros.
  + now constructor.
  + inv X.
  + inv X.
    simpl.
    now apply H.
  + inv X.
    now split; intuition.
  + inv X.
    * now left; intuition.
    * now right; intuition.
  + simpl; unfold next.
    inv X.
    simpl.
    now intuition.
  + inv X.
    * exists 0.
      split; auto; lia.
    * admit.
Admitted.

(*
Theorem matches_denote p s : matches p s -> denote p s.
Proof.
  intros.
  induction X; intuition.
  + now constructor.
  + now split.
  + now left.
  + now right.
  + exists 0.
    split; auto; intros.
    lia.
  + inv IHX2.
    destruct H.
    exists (S x0).
    rewrite from_cons.
    split; auto; intros.
    induction i.
    * exact IHX1.
    * rewrite from_cons.
      now intuition.
  + intro.
    generalize dependent xs.
    induction i; intros.
    * exact IHX1.
    * rewrite from_cons.
      now intuition.
  + exists 0.
    exact IHX.
  + destruct IHX.
    exists (S x0).
    now rewrite from_cons.
  + simpl; unfold release, wait.
    right.
    exists 0.
    split.
    * now split.
    * lia.
  + simpl; unfold release, wait.
    clear X1 X2.
    inv IHX2.
    * left.
      intro.
      generalize dependent xs.
      induction i; intros.
      ** exact IHX1.
      ** rewrite from_cons.
         now apply H.
    * right.
      inv H.
      destruct H0.
      inv H.
      exists (S x0).
      rewrite from_cons.
      split.
      ** now split.
      ** generalize dependent xs.
         induction i; intros.
         *** exact IHX1.
         *** rewrite from_cons.
             now apply H0; lia.
  + simpl; unfold wait.
    right.
    exists 0.
    split; auto; intros.
    lia.
  + simpl; unfold wait.
    inv IHX2.
    * left.
      intro.
      generalize dependent xs.
      induction i; intros.
      ** exact IHX1.
      ** rewrite from_cons.
         now apply H.
    * inv H.
      destruct H0.
      right.
      exists (S x0).
      rewrite from_cons.
      split; auto; intros.
      induction i.
      ** exact IHX1.
      ** rewrite from_cons.
         now intuition.
  + simpl; unfold strong_release.
    exists 0.
    split.
    * now split.
    * lia.
  + simpl; unfold strong_release.
    clear X1 X2.
    inv IHX2.
    destruct H.
    inv H.
    exists (S x0).
    rewrite from_cons.
    split; auto; intros.
    * now split.
    * generalize dependent xs.
      induction i; intros.
      ** exact IHX1.
      ** rewrite from_cons.
         now intuition.
Qed.
*)

Definition f_impl (p q : Formula) := forall s, matches p s -> matches q s.

Definition f_eqv (p q : Formula) : Type := f_impl p q * f_impl q p.

Arguments f_impl p q /.
Arguments f_eqv p q /.

Program Instance matches_respects_implies :
  Proper (f_impl ==> stream_eq S.a ==> Basics.arrow) matches.
Next Obligation.
  unfold f_impl.
  repeat intro.
  apply X; clear X.
  generalize dependent y0.
  generalize dependent x0.
  induction x; intros.
  - now constructor.
  - now inv X1.
  - inv X1.
    destruct y0.
    constructor.
    eapply X; eauto.
    now inv X0.
  - inv X1.
    constructor;
    now intuition eauto.
  - inv X1.
    + now constructor; intuition eauto.
    + now constructor; intuition eauto.
  - inv X1.
    destruct y0.
    constructor.
    eapply IHx; eauto.
    now inv X0.
Admitted.

Program Instance matches_respects_equivalent :
  Proper (equivalent ==> eq ==> iff) matches.
Next Obligation.
  split; repeat intro; subst.
  - now apply H.
  - now apply H.
Qed.

(* #[local] Obligation Tactic := induct. *)

Program Instance Examine_respects_implies :
  Proper ((eq ==> implies) ==> implies) Examine.
Next Obligation.
  repeat intro.
  inv H0.
  constructor.
  unfold respectful in H.
  rewrite <- H.

Program Instance Examine_respects_equivalent :
  Proper ((eq ==> equivalent) ==> equivalent) Examine.

Program Instance And_respects_implies :
  Proper (implies ==> implies ==> implies) And.

Program Instance And_respects_equivalent :
  Proper (equivalent ==> equivalent ==> equivalent) And.

Program Instance Or_respects_implies :
  Proper (implies ==> implies ==> implies) Or.

Program Instance Or_respects_equivalent :
  Proper (equivalent ==> equivalent ==> equivalent) Or.

Program Instance Next_respects_implies :
  Proper (implies ==> implies) Next.

Program Instance Next_respects_equivalent :
  Proper (equivalent ==> equivalent) Next.

Program Instance Until_respects_implies :
  Proper (implies ==> implies ==> implies) Until.

Program Instance Until_respects_equivalent :
  Proper (equivalent ==> equivalent ==> equivalent) Until.

Program Instance Release_respects_implies :
  Proper (implies ==> implies ==> implies) Release.

Program Instance Release_respects_equivalent :
  Proper (equivalent ==> equivalent ==> equivalent) Release.

Program Instance Always_respects_implies :
  Proper (implies ==> implies) Always.

Program Instance Always_respects_equivalent :
  Proper (equivalent ==> equivalent) Always.

Program Instance Eventually_respects_implies :
  Proper (implies ==> implies) Eventually.

Program Instance Eventually_respects_equivalent :
  Proper (equivalent ==> equivalent) Eventually.

Program Instance Wait_respects_implies :
  Proper (implies ==> implies ==> implies) Wait.

Program Instance Wait_respects_equivalent :
  Proper (equivalent ==> equivalent ==> equivalent) Wait.

Program Instance StrongRelease_respects_implies :
  Proper (implies ==> implies ==> implies) StrongRelease.

Program Instance StrongRelease_respects_equivalent :
  Proper (equivalent ==> equivalent ==> equivalent) StrongRelease.

Lemma expand_until (φ ψ : Formula) : φ U ψ ≈ ψ ∨ (φ ∧ ◯ (φ U ψ)).
Proof. now induct. Qed.

Lemma expand_release (φ ψ : Formula) : φ R ψ ≈ ψ ∧ (φ ∨ ◯ (φ R ψ)).
Proof. now induct. Qed.

Lemma expand_always (φ : Formula) : □ φ ≈ φ ∧ ◯ □ φ.
Proof. now induct. Qed.

Lemma expand_eventually (φ : Formula) : ◇ φ ≈ φ ∨ ◯ ◇ φ.
Proof. now induct. Qed.

Lemma expand_wait (φ ψ : Formula) : φ W ψ ≈ ψ ∨ (φ ∧ ◯ (φ W ψ)).
Proof. now induct. Qed.

Lemma expand_strong_release (φ ψ : Formula) : φ M ψ ≈ ψ ∧ (φ ∨ ◯ (φ M ψ)).
Proof. now induct. Qed.

Lemma expand_correct l : expand l ≈ l.
Proof.
  induction l; simpl; intuition;
  rewrite ?IHl, ?IHl1, ?IHl2; simpl in *; intuition.
  - unfold Basics.compose.
    apply Examine_respects_equivalent.
    repeat intro; subst.
    now rewrite H.
  - now rewrite <- expand_until.
  - now rewrite <- expand_release.
  - now rewrite <- expand_always.
  - now rewrite <- expand_eventually.
  - now rewrite <- expand_wait.
  - now rewrite <- expand_strong_release.
Qed.

Lemma prune_correct l : prune l ≈ l.
Proof.
  apply prune_ind; simpl; intros; subst; intuition.
  - split; repeat intro; simpl; intuition.
    + rewrite <- H.
      now rewrite e0.
    + now rewrite <- H0.
    + simpl in H1.
      now rewrite H0.
  - split; repeat intro; simpl; intuition.
    + now rewrite <- H.
    + rewrite <- H0.
      now rewrite e1.
    + simpl in H2.
      now rewrite H1.
  - now rewrite H1, H2.
  - split; repeat intro; simpl; intuition.
    + right.
      now rewrite <- H0.
    + simpl in H1.
      destruct H1.
      * rewrite <- H, e0 in H1.
        contradiction.
      * now rewrite H0.
  - split; repeat intro; simpl; intuition.
    + left.
      now rewrite <- H1.
    + simpl in H2.
      destruct H2.
      * now rewrite H1.
      * rewrite <- H0, e1 in H2.
        contradiction.
  - now rewrite H1, H2.
  - now rewrite H.
  - now rewrite H, H0.
  - now rewrite H, H0.
  - now rewrite H.
  - now rewrite H.
  - now rewrite H, H0.
  - now rewrite H, H0.
Qed.

Lemma matches_negate x s : matches (negate x) s <-> ~ matches x s.
Proof.
  split; intro.
  - intro.
    generalize dependent s.
    induction x; intros;
    induction s; simpl in *;
    now firstorder eauto.
  - generalize dependent s.
    induction x; intros;
    try (solve [simpl in *; intuition eauto]).
    + simpl negate.
      unfold Basics.compose.
      induction s;
      now simpl in *; firstorder.
    + simpl in *.
      apply not_and_or in H.
      now intuition.
    + simpl in *.
      now destruct s; intuition.
    + simpl negate.
      induction s.
        now simpl in *; intuition.
      simpl matches in H.
      apply not_or_and in H.
      destruct H.
      apply not_and_or in H0.
      now simpl in *; intuition.
    + simpl negate.
      induction s.
        now simpl in *; intuition.
      simpl matches in H.
      apply not_and_or in H.
      destruct H;
      now simpl in *; intuition.
    + simpl negate.
      induction s.
        now simpl in *; intuition.
      simpl matches in H.
      apply not_and_or in H.
      destruct H;
      now simpl in *; intuition.
    + simpl negate.
      induction s.
        now simpl in *; intuition.
      simpl matches in H.
      apply not_or_and in H.
      destruct H;
      now simpl in *; intuition.
    + simpl negate.
      induction s.
        now simpl in *; intuition.
      simpl matches in H.
      apply not_or_and in H.
      destruct H.
      apply not_and_or in H0.
      now simpl in *; intuition.
    + simpl negate.
      induction s.
        simpl matches in H.
        apply not_and_or in H.
        now simpl in *; intuition.
      simpl matches in H.
      apply not_and_or in H.
      destruct H.
        now simpl in *; intuition.
      apply not_or_and in H.
      now simpl in *; intuition.
Qed.

Lemma negate_negate p : negate (negate p) ≈ p.
Proof.
  split; repeat intro;
  rewrite !matches_negate in *.
  - apply NNPP; intro.
    apply H; clear H; intro.
    apply H0; clear H0.
    generalize dependent s.
    induction p; simpl in *; intros;
    induction s; intuition auto.
  - intro.
    apply H0; clear H0.
    generalize dependent s;
    induction p; simpl in *; intros;
    induction s; intuition auto.
Qed.

Lemma matches_not_false {p s} : matches p s -> matches (¬ p) s -> False.
Proof.
  intros.
  rewrite matches_negate in H0.
  contradiction.
Qed.

Program Instance negate_respects_implies : Proper (implies --> implies) negate | 1.
Next Obligation.
  - apply matches_negate.
    apply matches_negate in H0.
    now firstorder.
  - apply matches_negate.
    apply matches_negate in H0.
    now firstorder.
Qed.

Program Instance not_respects_implies : Proper (implies --> implies) not | 1.
Next Obligation.
  - unfold not in *.
    apply matches_negate.
    apply matches_negate in H0.
    now firstorder.
  - unfold not in *.
    apply matches_negate.
    apply matches_negate in H0.
    now firstorder.
Qed.

Instance and_respects_implies :
  Proper (implies ==> implies ==> implies) and := And_respects_implies.
Instance or_respects_implies :
  Proper (implies ==> implies ==> implies) or := Or_respects_implies.
Instance next_respects_implies :
  Proper (implies ==> implies) next := Next_respects_implies.
Instance until_respects_implies :
  Proper (implies ==> implies ==> implies) until := Until_respects_implies.
Instance eventually_respects_implies :
  Proper (implies ==> implies) eventually := Eventually_respects_implies.
Instance always_respects_implies :
  Proper (implies ==> implies) always := Always_respects_implies.
Instance wait_respects_implies :
  Proper (implies ==> implies ==> implies) wait := Wait_respects_implies.
Instance release_respects_implies :
  Proper (implies ==> implies ==> implies) release := Release_respects_implies.
Instance strong_release_respects_implies :
  Proper (implies ==> implies ==> implies) strong_release :=
  StrongRelease_respects_implies.

Theorem or_inj p q : p ⟹ p ∨ q.
Proof. now induct. Qed.

Theorem true_def p : p ∨ ¬p ≈ ⊤.
Proof.
  split; repeat intro;
  simpl; intuition.
  clear H.
  rewrite matches_negate.
  exact (classic (matches p s)).
Qed.

Theorem false_def p : ¬(p ∨ ¬p) ≈ ⊥.
Proof.
  split; repeat intro;
  simpl; intuition.
  rewrite matches_negate in H.
  apply H.
  rewrite true_def.
  constructor.
Qed.

Theorem or_comm p q : p ∨ q ≈ q ∨ p.
Proof. now induct. Qed.

Theorem or_assoc p q r : (p ∨ q) ∨ r ≈ p ∨ (q ∨ r).
Proof. now induct. Qed.

Theorem and_def p q : p ∧ q ≈ ¬(¬p ∨ ¬q).
Proof.
  unfold and, or, not.
  simpl.
  now rewrite !negate_negate.
Qed.

Theorem huntington p q : ¬(¬p ∨ ¬q) ∨ ¬(¬p ∨ q) ≈ p.
Proof.
  unfold or, not; simpl.
  rewrite !negate_negate.
  split; repeat intro; simpl in *; intuition.
  pose proof (true_def q).
  destruct H0.
  clear H0.
  specialize (H1 s I).
  simpl in H1.
  intuition.
Qed.

Theorem (* 1 *) next_not p : ◯ ¬p ≈ ¬◯ p.
Proof. now auto. Qed.

Theorem (* 2 *) next_impl p q : ◯ (p ⇒ q) ≈ ◯ p ⇒ ◯ q.
Proof. now induct. Qed.

Theorem (* 10 *) until_expand p q : p U q ≈ q ∨ (p ∧ ◯ (p U q)).
Proof. now induct. Qed.

Theorem (* 9 *) next_until p q : ◯ (p U q) ≈ (◯ p) U (◯ q).
Proof.
  unfold next, until.
  split; repeat intro;
  induction s; intuition;
  rewrite until_expand; simpl;
  rewrite until_expand in H; simpl in H;
  now intuition.
Qed.

Theorem (* 11 *) until_false p : p U ⊥ ≈ ⊥.
Proof. now induct. Qed.

Theorem (* NEW *) looped p : ◯ ¬p U p ⟹ p.
Proof.
  induct.
  contradiction (denote_not_false H1 H).
Qed.

Theorem (* 13 *) until_right_or p q r : (p U r) ∨ (q U r) ⟹ (p ∨ q) U r.
Proof. now induct. Qed.

Theorem (* 14 *) until_left_and p q r : p U (q ∧ r) ⟹ (p U q) ∧ (p U r).
Proof. now induct. Qed.

Theorem (* NEW *) until_or_until p q r s : (p ∧ r) U (q ∨ s) ⟹ (p U q) ∨ (r U s).
Proof. now induct. Qed.

Theorem (* NEW *) until_and_until p q r s :
  (p U q) ∧ (r U s) ⟹ (p ∧ r) U ((q ∧ r) ∨ (p ∧ s) ∨ (q ∧ s)).
Proof. now induct. Qed.

Theorem (* 17 *) until_left_or_order p q r : p U (q U r) ⟹ (p ∨ q) U r.
Proof.
  induct.
  right.
  now induct.
Qed.

Lemma matches_top s : matches Top s <-> True.
Proof. reflexivity. Qed.

Lemma matches_bottom s : matches Bottom s <-> False.
Proof. reflexivity. Qed.

Lemma matches_examine_nil v :
  matches (Examine v) nil <-> matches (v None) nil.
Proof. reflexivity. Qed.

Lemma matches_examine_cons x xs v :
  matches (Examine v) (x :: xs) <-> matches (v (Some x)) (x :: xs).
Proof. reflexivity. Qed.

Lemma matches_and s p q : matches (And p q) s <-> matches p s /\ matches q s.
Proof. reflexivity. Qed.

Lemma matches_or s p q : matches (Or p q) s <-> matches p s \/ matches q s.
Proof. reflexivity. Qed.

Lemma matches_next x xs p : matches (Next p) (x :: xs) <-> matches p xs.
Proof. reflexivity. Qed.

Lemma matches_until x xs p q :
  matches (Until p q) (x :: xs) <->
  matches q (x :: xs) \/ (matches p (x :: xs) /\ matches (Until p q) xs).
Proof. reflexivity. Qed.

Lemma matches_release x xs p q :
  matches (Release p q) (x :: xs) <->
  matches q (x :: xs) /\ (matches p (x :: xs) \/ matches (Release p q) xs).
Proof. reflexivity. Qed.

Lemma matches_always x xs p :
  matches (Always p) (x :: xs) <->
  matches p (x :: xs) /\ matches (Always p) xs.
Proof. reflexivity. Qed.

Lemma matches_eventually x xs p :
  matches (Eventually p) (x :: xs) <->
  matches p (x :: xs) \/ matches (Eventually p) xs.
Proof. reflexivity. Qed.

Lemma matches_wait x xs p q :
  matches (Wait p q) (x :: xs) <->
  matches q (x :: xs) \/ (matches p (x :: xs) /\ matches (Wait p q) xs).
Proof. reflexivity. Qed.

Lemma matches_strongrelease x xs p q :
  matches (StrongRelease p q) (x :: xs) <->
  matches q (x :: xs) /\ (matches p (x :: xs) \/ matches (StrongRelease p q) xs).
Proof. reflexivity. Qed.

Theorem (* 18 *) until_right_and_order p q r : p U (q ∧ r) ⟹ (p U q) U r.
Proof.
  unfold until, and.
  repeat intro;
  induction s; intuition.
  - now simpl in *; intuition.
  - rewrite matches_until, matches_and in *.
    firstorder.
    destruct (classic (matches r (a :: s))); auto.
    right; split; auto.
    destruct (classic (matches q (a :: s))); auto.
      now left.
    rewrite matches_until in *.
    right; split; auto.
    clear -H0.
    now induct.
Qed.

Theorem (* 170 *) not_until p q : ⊤ U ¬p ∧ ¬(p U q) ≈ ¬q U (¬p ∧ ¬q).
Proof. now induct. Qed.

Theorem (* 38 *) evn_def p : ◇ p ≈ ⊤ U p.
Proof. now induct. Qed.

Theorem (* 54 *) always_def p : □ p ≈ ¬◇ ¬p.
Proof. induct; rewrite ?negate_negate in *; intuition. Qed.

Theorem (* 169 *) wait_def p q : p W q ≈ □ p ∨ p U q.
Proof. now induct. Qed.

Theorem release_def p q : p R q ≈ ¬(¬p U ¬q).
Proof. induct; rewrite ?negate_negate in *; intuition. Qed.

Theorem strong_release_def p q : p M q ≈ q U (p ∧ q).
Proof. now induct. Qed.

End LTL.

Module LTLCombinators (S : StreamType).

Module Import L := LTL S.

Definition if_then (p : S.a -> bool) (f : S.a -> Formula) :=
  Λ x, match x with
       | Some x => if p x then f x else ⊤
       | None => ⊤
       end.

Fixpoint series (l : list Formula) : Formula :=
  match l with
  | nil => ⊤
  | x :: nil => x
  | x :: xs => x ∧ Next (series xs)
  end.

End LTLCombinators.

Require Import Coq.Arith.PeanoNat.

Module NatStream <: StreamType.

Definition a := nat.

End NatStream.

Module LTLExamples.

Module Import C := LTLCombinators NatStream.
Import C.L.

Definition num (n : nat) :=
  Λ x, match x with
       | Some x => if x =? n then ⊤ else ⊥
       | None => ⊥
       end.

Example ex_match_query  :
  matches (num 1 ∧ ◯ (num 2)) [1; 2].
Proof. simpl; auto. Qed.

Example ex_match_series :
  matches (series [num 1; num 2]) [1; 2].
Proof. simpl; auto. Qed.

Example ex_match_sample1 :
  matches (◇ (num 3 ⇒ ◇ (num 8))) [1; 2; 3; 4; 5; 6; 7; 8; 9].
Proof. simpl; intuition auto. Qed.

Example ex_match_sample2 :
  matches (◇ (if_then (λ n, n =? 3) (λ n, ◇ (num (n + 5)))))
          [1; 2; 3; 4; 5; 6; 7; 8; 9].
Proof. simpl; intuition auto. Qed.

End LTLExamples.


Require Export XR_R.
Require Export XR_R0.
Require Export XR_Rmult.
Require Export XR_Rmult_0_l.
Require Export XR_Rmult_0_r.

Local Open Scope R_scope.
Implicit Type r : R.

Lemma Rmult_neq_0_reg : forall r1 r2, r1 * r2 <> R0 -> r1 <> R0 /\ r2 <> R0.
Proof.
  intros x y.
  intro heq.
  unfold not in heq.
  split.
  {
    unfold not.
    intro heqx.
    subst x.
    apply heq.
    rewrite Rmult_0_l.
    reflexivity.
  }
  {
    unfold not.
    intro heqy.
    subst y.
    apply heq.
    rewrite Rmult_0_r.
    reflexivity.
  }
Qed.


Require Import CSet Util MoreList Take MoreInversion LengthEq NaturalRep ARange.

Set Implicit Arguments.

Lemma x_notin_range V `{NaturalRepresentationSucc V} (x:V) k n
  : x ∉ of_list (range succ k n)
    -> asNat x < asNat k \/ asNat k+n <= asNat x.
Proof.
  general induction n; simpl in *.
  - decide (asNat x < asNat k); omega.
  - decide (asNat x = asNat k);
      cset_tac'.
    + exfalso. eapply asNat_inj in e; eauto.
    + eapply IHn in H4; eauto. destruct H4.
      * nr. omega.
      * nr. omega.
Qed.

Lemma x_in_range V `{NaturalRepresentationSucc V} (x:V) k n
  : asNat x >= asNat k /\ asNat k+n > asNat x -> x ∈ of_list (range succ k n).
Proof.
  revert x k.
  induction n; intros; simpl in *.
  - exfalso; omega.
  - decide (asNat x = asNat k); subst; cset_tac'.
    * rewrite <- asNat_iff in n0. exfalso; eauto.
    * rewrite asNat_iff in n0; eauto.
      eapply IHn; eauto. nr. omega.
Qed.

Lemma in_range_x  V `{NaturalRepresentationSucc V} x k n
  : x ∈ of_list (range succ k n) -> asNat x >= asNat k /\ asNat k+n > asNat x.
Proof.
  general induction n; simpl in *; dcr.
  - cset_tac.
  - decide (x === k); subst; try omega;
      cset_tac'; nr; try omega.
    eapply IHn in H3; nr; omega.
    eapply IHn in H3; nr; omega.
Qed.

Lemma take_range  V `{NaturalRepresentationSucc V} k (n:V) d
  : Take.take k (range succ n d) = range succ n (min k d).
Proof.
  general induction k; simpl; eauto.
  repeat cases; eauto.
  simpl in *. f_equal; eauto.
Qed.

Lemma range_nodup V `{NaturalRepresentationSucc V} i d
  : NoDupA _eq (range succ i d).
Proof.
  general induction d; simpl; eauto using NoDupA.
  econstructor; eauto.
  intro.
  rewrite InA_in in H2.
  eapply in_range_x in H2. nr. omega.
Qed.

Ltac range_get_simpl :=
  match goal with
  | [H : get (range _ ?k ?d) ?n ?x |- _ ] =>
    eapply range_get in H; try (is_var x; subst x)
  end.

Smpl Add range_get_simpl : inv_get.


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

(** Contributed by Laurent Théry (INRIA);
    Adapted to Coq V8 by the Coq Development Team *)

Require Import Arith.
Require Import Ascii.
Declare ML Module "string_syntax_plugin".

(** *** Definition of strings *)

(** Implementation of string as list of ascii characters *)

Inductive string : Set :=
  | EmptyString : string
  | String : ascii -> string -> string.

Delimit Scope string_scope with string.
Bind Scope string_scope with string.
Open Local Scope string_scope.

(** Equality is decidable *)

Definition string_dec : forall s1 s2 : string, {s1 = s2} + {s1 <> s2}.
 decide equality; apply ascii_dec.
Defined.

(** *** Concatenation of strings *)

Reserved Notation "x ++ y" (right associativity, at level 60).

Fixpoint append (s1 s2 : string) : string :=
  match s1 with
  | EmptyString => s2
  | String c s1' => String c (s1' ++ s2)
  end

where "s1 ++ s2" := (append s1 s2) : string_scope.

(******************************)
(** Length                    *)
(******************************)

Fixpoint length (s : string) : nat :=
  match s with
  | EmptyString => 0
  | String c s' => S (length s')
  end.

(******************************)
(** Nth character of a string *)
(******************************)

Fixpoint get (n : nat) (s : string) {struct s} : option ascii :=
  match s with
  | EmptyString => None
  | String c s' => match n with
                   | O => Some c
                   | S n' => get n' s'
                   end
  end.

(** Two lists that are identical through get are syntactically equal *)

Theorem get_correct :
  forall s1 s2 : string, (forall n : nat, get n s1 = get n s2) <-> s1 = s2.
Proof.
intros s1; elim s1; simpl in |- *.
intros s2; case s2; simpl in |- *; split; auto.
intros H; generalize (H 0); intros H1; inversion H1.
intros; discriminate.
intros a s1' Rec s2; case s2; simpl in |- *; split; auto.
intros H; generalize (H 0); intros H1; inversion H1.
intros; discriminate.
intros H; generalize (H 0); simpl in |- *; intros H1; inversion H1.
case (Rec s).
intros H0; rewrite H0; auto.
intros n; exact (H (S n)).
intros H; injection H; intros H1 H2 n; case n; auto.
rewrite H2; trivial.
rewrite H1; auto.
Qed.

(** The first elements of [s1 ++ s2] are the ones of [s1] *)

Theorem append_correct1 :
 forall (s1 s2 : string) (n : nat),
 n < length s1 -> get n s1 = get n (s1 ++ s2).
Proof.
intros s1; elim s1; simpl in |- *; auto.
intros s2 n H; inversion H.
intros a s1' Rec s2 n; case n; simpl in |- *; auto.
intros n0 H; apply Rec; auto.
apply lt_S_n; auto.
Qed.

(** The last elements of [s1 ++ s2] are the ones of [s2] *)

Theorem append_correct2 :
 forall (s1 s2 : string) (n : nat),
 get n s2 = get (n + length s1) (s1 ++ s2).
Proof.
intros s1; elim s1; simpl in |- *; auto.
intros s2 n; rewrite plus_comm; simpl in |- *; auto.
intros a s1' Rec s2 n; case n; simpl in |- *; auto.
generalize (Rec s2 0); simpl in |- *; auto. intros.
rewrite <- Plus.plus_Snm_nSm; auto.
Qed.

(** *** Substrings *)

(** [substring n m s] returns the substring of [s] that starts
    at position [n] and of length [m];
    if this does not make sense it returns [""] *)

Fixpoint substring (n m : nat) (s : string) : string :=
  match n, m, s with
  | 0, 0, _ => EmptyString
  | 0, S m', EmptyString => s
  | 0, S m', String c s' => String c (substring 0 m' s')
  | S n', _, EmptyString => s
  | S n', _, String c s' => substring n' m s'
  end.

(** The substring is included in the initial string *)

Theorem substring_correct1 :
 forall (s : string) (n m p : nat),
 p < m -> get p (substring n m s) = get (p + n) s.
Proof.
intros s; elim s; simpl in |- *; auto.
intros n; case n; simpl in |- *; auto.
intros m; case m; simpl in |- *; auto.
intros a s' Rec; intros n; case n; simpl in |- *; auto.
intros m; case m; simpl in |- *; auto.
intros p H; inversion H.
intros m' p; case p; simpl in |- *; auto.
intros n0 H; apply Rec; simpl in |- *; auto.
apply Lt.lt_S_n; auto.
intros n' m p H; rewrite <- Plus.plus_Snm_nSm; simpl in |- *; auto.
Qed.

(** The substring has at most [m] elements *)

Theorem substring_correct2 :
 forall (s : string) (n m p : nat), m <= p -> get p (substring n m s) = None.
Proof.
intros s; elim s; simpl in |- *; auto.
intros n; case n; simpl in |- *; auto.
intros m; case m; simpl in |- *; auto.
intros a s' Rec; intros n; case n; simpl in |- *; auto.
intros m; case m; simpl in |- *; auto.
intros m' p; case p; simpl in |- *; auto.
intros H; inversion H.
intros n0 H; apply Rec; simpl in |- *; auto.
apply Le.le_S_n; auto.
Qed.

(** *** Test functions *)

(** Test if [s1] is a prefix of [s2] *)

Fixpoint prefix (s1 s2 : string) {struct s2} : bool :=
  match s1 with
  | EmptyString => true
  | String a s1' =>
      match s2 with
      | EmptyString => false
      | String b s2' =>
          match ascii_dec a b with
          | left _ => prefix s1' s2'
          | right _ => false
          end
      end
  end.

(** If [s1] is a prefix of [s2], it is the [substring] of length
    [length s1] starting at position [O] of [s2] *)

Theorem prefix_correct :
 forall s1 s2 : string,
 prefix s1 s2 = true <-> substring 0 (length s1) s2 = s1.
Proof.
intros s1; elim s1; simpl in |- *; auto.
intros s2; case s2; simpl in |- *; split; auto.
intros a s1' Rec s2; case s2; simpl in |- *; auto.
split; intros; discriminate.
intros b s2'; case (ascii_dec a b); simpl in |- *; auto.
intros e; case (Rec s2'); intros H1 H2; split; intros H3; auto.
rewrite e; rewrite H1; auto.
apply H2; injection H3; auto.
intros n; split; intros; try discriminate.
case n; injection H; auto.
Qed.

(** Test if, starting at position [n], [s1] occurs in [s2]; if
    so it returns the position *)

Fixpoint index (n : nat) (s1 s2 : string) : option nat :=
  match s2, n with
  | EmptyString, 0 =>
      match s1 with
      | EmptyString => Some 0
      | String a s1' => None
      end
  | EmptyString, S n' => None
  | String b s2', 0 =>
      if prefix s1 s2 then Some 0
      else
        match index 0 s1 s2' with
        | Some n => Some (S n)
        | None => None
        end
   | String b s2', S n' =>
      match index n' s1 s2' with
      | Some n => Some (S n)
      | None => None
      end
  end.

(* Dirty trick to avoid locally that prefix reduces itself *)
Opaque prefix.

(** If the result of [index] is [Some m], [s1] in [s2] at position [m] *)

Theorem index_correct1 :
 forall (n m : nat) (s1 s2 : string),
 index n s1 s2 = Some m -> substring m (length s1) s2 = s1.
Proof.
intros n m s1 s2; generalize n m s1; clear n m s1; elim s2; simpl in |- *;
 auto.
intros n; case n; simpl in |- *; auto.
intros m s1; case s1; simpl in |- *; auto.
intros H; injection H; intros H1; rewrite <- H1; auto.
intros; discriminate.
intros; discriminate.
intros b s2' Rec n m s1.
case n; simpl in |- *; auto.
generalize (prefix_correct s1 (String b s2'));
 case (prefix s1 (String b s2')).
intros H0 H; injection H; intros H1; rewrite <- H1; auto.
case H0; simpl in |- *; auto.
case m; simpl in |- *; auto.
case (index 0 s1 s2'); intros; discriminate.
intros m'; generalize (Rec 0 m' s1); case (index 0 s1 s2'); auto.
intros x H H0 H1; apply H; injection H1; intros H2; injection H2; auto.
intros; discriminate.
intros n'; case m; simpl in |- *; auto.
case (index n' s1 s2'); intros; discriminate.
intros m'; generalize (Rec n' m' s1); case (index n' s1 s2'); auto.
intros x H H1; apply H; injection H1; intros H2; injection H2; auto.
intros; discriminate.
Qed.

(** If the result of [index] is [Some m],
    [s1] does not occur in [s2] before [m] *)

Theorem index_correct2 :
 forall (n m : nat) (s1 s2 : string),
 index n s1 s2 = Some m ->
 forall p : nat, n <= p -> p < m -> substring p (length s1) s2 <> s1.
Proof.
intros n m s1 s2; generalize n m s1; clear n m s1; elim s2; simpl in |- *;
 auto.
intros n; case n; simpl in |- *; auto.
intros m s1; case s1; simpl in |- *; auto.
intros H; injection H; intros H1; rewrite <- H1.
intros p H0 H2; inversion H2.
intros; discriminate.
intros; discriminate.
intros b s2' Rec n m s1.
case n; simpl in |- *; auto.
generalize (prefix_correct s1 (String b s2'));
 case (prefix s1 (String b s2')).
intros H0 H; injection H; intros H1; rewrite <- H1; auto.
intros p H2 H3; inversion H3.
case m; simpl in |- *; auto.
case (index 0 s1 s2'); intros; discriminate.
intros m'; generalize (Rec 0 m' s1); case (index 0 s1 s2'); auto.
intros x H H0 H1 p; try case p; simpl in |- *; auto.
intros H2 H3; red in |- *; intros H4; case H0.
intros H5 H6; absurd (false = true); auto with bool.
intros n0 H2 H3; apply H; auto.
injection H1; intros H4; injection H4; auto.
apply Le.le_O_n.
apply Lt.lt_S_n; auto.
intros; discriminate.
intros n'; case m; simpl in |- *; auto.
case (index n' s1 s2'); intros; discriminate.
intros m'; generalize (Rec n' m' s1); case (index n' s1 s2'); auto.
intros x H H0 p; case p; simpl in |- *; auto.
intros H1; inversion H1; auto.
intros n0 H1 H2; apply H; auto.
injection H0; intros H3; injection H3; auto.
apply Le.le_S_n; auto.
apply Lt.lt_S_n; auto.
intros; discriminate.
Qed.

(** If the result of [index] is [None], [s1] does not occur in [s2]
    after [n] *)

Theorem index_correct3 :
 forall (n m : nat) (s1 s2 : string),
 index n s1 s2 = None ->
 s1 <> EmptyString -> n <= m -> substring m (length s1) s2 <> s1.
Proof.
intros n m s1 s2; generalize n m s1; clear n m s1; elim s2; simpl in |- *;
 auto.
intros n; case n; simpl in |- *; auto.
intros m s1; case s1; simpl in |- *; auto.
case m; intros; red in |- *; intros; discriminate.
intros n' m; case m; auto.
intros s1; case s1; simpl in |- *; auto.
intros b s2' Rec n m s1.
case n; simpl in |- *; auto.
generalize (prefix_correct s1 (String b s2'));
 case (prefix s1 (String b s2')).
intros; discriminate.
case m; simpl in |- *; auto with bool.
case s1; simpl in |- *; auto.
intros a s H H0 H1 H2; red in |- *; intros H3; case H.
intros H4 H5; absurd (false = true); auto with bool.
case s1; simpl in |- *; auto.
intros a s n0 H H0 H1 H2;
 change (substring n0 (length (String a s)) s2' <> String a s) in |- *;
 apply (Rec 0); auto.
generalize H0; case (index 0 (String a s) s2'); simpl in |- *; auto; intros;
 discriminate.
apply Le.le_O_n.
intros n'; case m; simpl in |- *; auto.
intros H H0 H1; inversion H1.
intros n0 H H0 H1; apply (Rec n'); auto.
generalize H; case (index n' s1 s2'); simpl in |- *; auto; intros;
 discriminate.
apply Le.le_S_n; auto.
Qed.

(* Back to normal for prefix *)
Transparent prefix.

(** If we are searching for the [Empty] string and the answer is no
    this means that [n] is greater than the size of [s] *)

Theorem index_correct4 :
 forall (n : nat) (s : string),
 index n EmptyString s = None -> length s < n.
Proof.
intros n s; generalize n; clear n; elim s; simpl in |- *; auto.
intros n; case n; simpl in |- *; auto.
intros; discriminate.
intros; apply Lt.lt_O_Sn.
intros a s' H n; case n; simpl in |- *; auto.
intros; discriminate.
intros n'; generalize (H n'); case (index n' EmptyString s'); simpl in |- *;
 auto.
intros; discriminate.
intros H0 H1; apply Lt.lt_n_S; auto.
Qed.

(** Same as [index] but with no optional type, we return [0] when it
    does not occur *)

Definition findex n s1 s2 :=
  match index n s1 s2 with
  | Some n => n
  | None => 0
  end.

(** *** Concrete syntax *)

(**
  The concrete syntax for strings in scope string_scope follows the
  Coq convention for strings: all ascii characters of code less than
  128 are litteral to the exception of the character `double quote'
  which must be doubled.

  Strings that involve ascii characters of code >= 128 which are not
  part of a valid utf8 sequence of characters are not representable
  using the Coq string notation (use explicitly the String constructor
  with the ascii codes of the characters).
*)

Example HelloWorld := "	""Hello world!""
".


Require Import msl.msl_standard.
Require Import msl.Coqlib2.
Set Implicit Arguments.

Inductive fold_rel (A: Type) (f: A -> A -> A -> Prop):  A -> list A -> A -> Prop :=
| fold_rel_nil: forall w, fold_rel f w nil w
| fold_rel_cons: forall a l w w1 w2,
            f w a w1 ->
            fold_rel f w1 l w2 ->
            fold_rel f w (a::l) w2.

Inductive list_forall2 {A B} (P: A -> B -> Prop): list A -> list B -> Prop :=
  | list_forall2_nil:
      list_forall2 P nil nil
  | list_forall2_cons:
      forall a1 al b1 bl,
      P a1 b1 ->
      list_forall2 P al bl ->
      list_forall2 P (a1 :: al) (b1 :: bl).

Fixpoint replace (A: Type) (l: list A) (n:nat) (new: A) {struct n} : option (list A) :=
  match (l, n) with
    | (nil, n) => None
    | (x :: xs, O) => Some (new :: xs)
    | (x :: xs, S n) =>
      match (replace xs n new) with
        |  None => None
        |  Some xs => Some (x :: xs)
      end
  end.

Definition list_join {A} {JA: Join A}: A -> list A -> A -> Prop :=
   fold_rel join.

Lemma list_join_assoc1 {A} {JA: Join A}{PA: Perm_alg A}:
 forall {a b cl d e},
   join a b d -> list_join d cl e ->
  exists f, list_join b cl f /\ join a f e.
Proof.
intros.
revert a b H.
induction H0; intros.
exists b. split; auto. constructor.
destruct (join_assoc H1 H) as [ba [? ?]].
destruct (IHfold_rel _ _ H3) as [f [? ?]]; clear IHfold_rel.
exists f; split; auto.
econstructor; eauto.
Qed.

Lemma list_join_assoc2 {A}  {JA: Join A}{PA: Perm_alg A}:
  forall {a b: A} {cl e f},
   list_join b cl f -> join a f e ->
   exists d,  join a b d /\ list_join d cl e.
Proof.
do 3 intro; revert a b; induction cl; intros; inv H.
exists e; split; auto; constructor.
destruct (IHcl _ _ _ _ H6 H0) as [d [? ?]].
destruct (join_assoc (join_comm H4) (join_comm H)) as [g [? ?]].
exists g; split; auto.
constructor 2 with d; auto.
Qed.

Lemma list_join_app {A} {JA: Join A}:
  forall {a: A} {bl c dl e},
   list_join a bl c -> list_join c dl e -> list_join a (bl++dl) e.
Proof.
intros a bl; revert a; induction bl; intros.
inv H.
simpl.
auto.
inv H.
rewrite <- app_comm_cons.
econstructor 2.
apply H4.
eapply IHbl.
apply H6.
auto.
Qed.

Lemma list_join_unapp {A}  {JA: Join A}:
  forall {a:A}  {bl dl e},
  list_join a (bl++dl) e -> exists c, list_join a bl c /\ list_join c dl e.
Proof.
intros a bl; revert a; induction bl; intros.
simpl in H. exists a; split; auto. constructor.
rewrite <- app_comm_cons in H.
inv H.
destruct (IHbl _ _ _ H5) as [c [? ?]]. clear IHbl.
exists c.
split; auto.
econstructor 2; eauto.
Qed.

Lemma list_join_1 {A} {JA: Join A}:
  forall a b c: A, join a b c = list_join a (b::nil) c.
Proof.
intros; apply prop_ext; split; intros.
econstructor 2; eauto.
constructor.
inv H.
inv H5.
auto.
Qed.

Definition age1_list {A} `{ageable A} := list_forall2 age.

Lemma age1_list_join {A} {JA: Join A}{PA: Perm_alg A}{agA: ageable A}{AgeA: Age_alg A}:
  forall l (phi phi' phi2: A),
        age phi phi' ->
        list_join phi l phi2 ->
        exists l', exists phi2', age1_list l l' /\ age phi2 phi2' /\ list_join phi' l' phi2'.
Proof.
induction l; intros; inv H0.
exists (@nil A).
exists phi'.
repeat split; auto; constructor.
rename w1 into phi1.
destruct (age1_join _ H4 H) as [a' [phi1' [? [? ?]]]].
spec IHl phi1 phi1' phi2 H2 H6.
destruct IHl as [l' [phi2' [? [? ?]]]].
exists (a' :: l').
exists phi2'.
repeat split; auto; econstructor 2; eauto.
Qed.

Lemma age1_list_join2 {A} {JA: Join A}{PA: Perm_alg A}{agA: ageable A}{AgeA: Age_alg A}:
  forall (l: list A) phi phi2 phi2',  age1 phi2 = Some phi2' -> list_join phi l phi2 ->
        exists l', exists phi',  age1 phi = Some phi' /\ age1_list l l' /\ list_join phi' l' phi2'.
Proof.
induction l; intros; inv H0.
exists (@nil A).
exists phi2'.
repeat split; auto; constructor.
rename w1 into phi1.
destruct (IHl phi1 phi2 phi2' H H6) as [l' [phi1' [? [? ?]]]].
destruct (age1_join2 _ H4 H0) as [phi' [a' [? [? ?]]]].
exists (a'::l'). exists phi'.
repeat split; auto; econstructor 2; eauto.
Qed.

Lemma list_join_split_nth {A}{JA: Join A}{PA: Perm_alg A}:
 forall n (l: list A) phin phi phia phib phi2,
  nth_error l n = Some phin -> list_join phi l phi2 -> join phib phia phin ->
           exists phic, exists l',
                 replace l n phib = Some l' /\ join phi phia phic /\ list_join phic l' phi2.
Proof.
induction n; intros.
inv H.
destruct l.
discriminate.
inv H3.
inv H0.
simpl.
destruct (join_assoc H1 (join_comm H4))
      as [f [? ?]].
exists f; exists (phib::l).
repeat split; auto.
econstructor 2; eauto.
simpl in H.
destruct l.
inv H.
inv H0.
destruct (IHn _ _ _ _ _ _ H H7 H1) as [phic [l' [? [? ?]]]].
simpl. rewrite H0.
destruct (join_assoc (join_comm H5) H2) as [f [? ?]].
exists f; exists (a::l'); repeat split; auto.
econstructor 2; eauto.
Qed.

Lemma list_join_join_nth {A} {JA: Join A}{PA: Perm_alg A}:
 forall n (l: list A) phin phi phia phib phi2,
  nth_error l n = Some phin -> list_join phi l phi2 -> join phi2 phia phib ->
           exists phic, exists l',
                 join phin phia phic /\ replace l n phic = Some l' /\ list_join phi l' phib.
Proof.
induction n; intros.
inv H.
destruct l; try discriminate.
inv H0.
inv H3.
simpl.
destruct (list_join_assoc2 H7 (join_comm H1)) as [f [? ?]].
destruct (join_assoc H5 (join_comm H)) as [g [? ?]].
exists g; exists (g::l); repeat split; auto.
econstructor 2; eauto.
destruct l; simpl in H.
inv H.
inv H0.
simpl.
destruct (IHn _ _ _ _ _ _ H H7 H1) as [phic  [l' [? [? ?]]]].
exists phic. rewrite H2. exists (a::l').
repeat split; auto.
econstructor 2; eauto.
Qed.

(*****************************)

Lemma list_join_comparable {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
  forall (phi1: A) l phi2, list_join phi1 l phi2 -> comparable phi1 phi2.
Proof.
  intros; revert phi1 phi2 H; induction l; simpl; intros; inv H.
  apply comparable_refl.
  rename w1 into phi0.
  apply comparable_trans with phi0.
  apply join_comparable with a; auto.
  auto.
Qed.

Lemma join_comparable'  {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
  forall phi1 phi2 phi3: A, join phi1 phi2 phi3 -> comparable phi2 phi3.
Proof. intros; apply join_comparable with phi1; apply join_comm; auto. Qed.

Lemma join_comparable2'  {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
  forall phi1 phi2 phi3: A, join phi1 phi2 phi3 -> comparable phi2 phi1.
Proof. intros; apply comparable_sym; eapply join_comparable2; eauto. Qed.

Lemma list_join_comparable'  {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
  forall (phi1: A) l phi2, list_join phi1 l phi2 -> comparable phi2 phi1.
Proof. intros; apply comparable_sym; eapply list_join_comparable; eauto. Qed.

Lemma join_comparable''  {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
  forall phi1 phi2 phi3: A, join phi1 phi2 phi3 -> comparable phi3 phi2.
Proof. intros; apply comparable_sym; eapply join_comparable'; eauto. Qed.

Lemma join_comparable'''  {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
  forall phi1 phi2 phi3: A, join phi1 phi2 phi3 -> comparable phi3 phi1.
Proof. intros; apply comparable_sym; eapply join_comparable; eauto. Qed.

Lemma joins_comparable  {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
  forall phi1 phi2: A, joins phi1 phi2 -> comparable phi1 phi2.
Proof.
  unfold joins; intros.
  destruct H as [phi3 ?].
  eapply join_comparable2; eauto.
Qed.

Lemma joins_comparable2 {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
     forall phi1 phi2: A, joins phi2 phi1 -> comparable phi1 phi2.
Proof.
unfold joins; intros.
destruct H as [phi3 ?].
apply comparable_sym.
eapply join_comparable2; eauto.
Qed.

Lemma join_sub_comparable  {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
  forall phi1 phi2: A, join_sub phi1 phi2 -> comparable phi1 phi2.
Proof.
unfold joins; intros.
destruct H as [phi3 ?].
eapply join_comparable; eauto.
Qed.

Lemma join_sub_comparable2 {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
     forall phi1 phi2: A, join_sub phi2 phi1 -> comparable phi1 phi2.
Proof.
unfold joins; intros.
destruct H as [phi3 ?].
apply comparable_sym.
eapply join_comparable; eauto.
Qed.

Lemma eq_comparable {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
   forall phi1 phi2: A, phi1=phi2 -> comparable phi1 phi2.
Proof.
intros; subst; apply comparable_refl.
Qed.

Lemma eq_comparable2 {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
   forall phi1 phi2: A, phi2=phi1 -> comparable phi1 phi2.
Proof.
intros; subst; apply comparable_refl.
Qed.

Lemma ageN_join {A}  {JA: Join A}{PA: Perm_alg A}{agA: ageable A}{AgeA: Age_alg A}:
  forall n (w1 w2 w3 w1': A),
   join w1 w2 w3 ->
      ageN n w1 = Some w1' ->
      exists w2', exists w3',
        ageN n w2 = Some w2' /\ ageN n w3 = Some w3' /\ join w1' w2' w3'.
Proof.
unfold ageN in *.
induction n; intros; simpl in *.
exists w2; exists w3; repeat split; auto.
inv H0; auto.
case_eq (age1 w1); intros; rewrite H1 in H0; try discriminate.
destruct (age1_join _ H H1) as [w2' [w3' [? [? ?]]]].
destruct (IHn _ _ _ _ H2 H0) as [w2'' [w3'' [? [? ?]]]].
clear IHn.
exists w2''; exists w3''. rewrite H3; rewrite H4.
repeat split; auto.
Qed.

Lemma ageN_join2 {A}  {JA: Join A}{PA: Perm_alg A}{agA: ageable A}{AgeA: Age_alg A}:
  forall n (w1 w2 w3 w3': A),
   join w1 w2 w3 ->
      ageN n w3 = Some w3' ->
      exists w1', exists w2',
        ageN n w1 = Some w1' /\ ageN n w2 = Some w2' /\ join w1' w2' w3'.
Proof.
unfold ageN in *.
induction n; intros; simpl in *.
exists w1; exists w2; repeat split; auto.
inv H0; auto.
case_eq (age1 w3); intros; rewrite H1 in H0; try discriminate.
destruct (age1_join2 _ H H1) as [w1' [w2' [? [? ?]]]].
destruct (IHn _ _ _ _ H2 H0) as [w1'' [w2'' [? [? ?]]]].
clear IHn.
exists w1''; exists w2''. rewrite H3; rewrite H4.
repeat split; auto.
Qed.

Lemma ageN_comparable {A}  {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
  forall n (w1 w2 w1' w2': A),
        ageN n w1 = Some w1' -> ageN n w2 = Some w2' -> comparable w1 w2 -> comparable w1' w2'.
Proof.
unfold ageN in *.
induction n; intros; simpl in *.
inv H; inv H0; auto.
revert H H0; case_eq (age1 w1); case_eq (age1 w2); intros; try discriminate.
eapply IHn; eauto.
eapply age_comparable; eauto.
Qed.

Lemma join_unage  {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
  forall (phi3 phi1' phi2' phi3': A),
    age1 phi3 = Some phi3' ->
    join phi1' phi2' phi3' ->
    exists phi1, exists phi2, join phi1 phi2 phi3 /\
      age1 phi1 = Some phi1' /\ age1 phi2 = Some phi2'.
Proof.
  intros.
  apply (unage_join2 _ H0 H).
Qed.

Lemma join_unage'  {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
    forall phi1 phi1' phi2' phi3' : A,
      age1 phi1 = Some phi1' ->
      join phi1' phi2' phi3' ->
      exists phi2, exists phi3, join phi1 phi2 phi3 /\
        age1 phi2 = Some phi2' /\ age1 phi3 = Some phi3'.
Proof.
   intros. apply (unage_join _ H0 H).
Qed.

Lemma unageN'  {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
  forall n (phi1 phi1' phi2' phi3' : A),
    ageN n phi1 = Some phi1' ->
    join phi1' phi2' phi3' ->
    exists phi2, exists phi3, join phi1 phi2 phi3 /\
      ageN n phi2 = Some phi2' /\ ageN n phi3 = Some phi3'.
Proof.
induction n; intros.
inv H. exists phi2'; exists phi3'; split; auto.
 unfold ageN in H. simpl in H.
 revert H; case_eq (age1 phi1); intros.
  spec IHn a phi1' phi2' phi3' H1; spec IHn H0.
  destruct IHn as [phi2 [phi3 [? [? ?]]]].
  destruct (join_unage' _ _ _ H H2) as [phi4 [phi5 [? [? ?]]]].
  exists phi4; exists phi5. split; auto.
 split; unfold ageN; simpl. rewrite H6; auto. rewrite H7; auto.
 inv H1.
Qed.

Hint Resolve @join_comparable @join_comparable'  @join_comparable'' @join_comparable'''
      @join_comparable2 @join_comparable2'  @list_join_comparable @list_join_comparable'
      @joins_comparable  @joins_comparable2  @join_sub_comparable  @join_sub_comparable2
      @eq_comparable  @eq_comparable2
  : comparable.

Hint Immediate @comparable_refl  @comparable_sym  : comparable.

Ltac Comp1 phi1 phi2 :=
   solve [ eauto 3 with comparable typeclass_instances |
  match goal with
  | H: comparable phi1 ?phi |- _ => Comp2 H phi1 phi phi2
  | H: comparable ?phi phi1 |- _ => Comp2 H phi1 phi phi2
  | H: join phi1 ?phia ?phib |- _ =>  Comp3 H phi1 phia phib phi2
  | H: join ?phia phi1 ?phib |- _ =>   Comp3 H phi1 phia phib phi2
  | H: join ?phia ?phib phi1 |- _ =>   Comp3 H phi1 phia phib phi2
  | H: joins phi1 ?phi |- _ =>  Comp2 H phi1 phi phi2
  | H: joins ?phi phi1 |- _ =>  Comp2 H phi1 phi phi2
  | H: join_sub phi1 ?phi |- _ => Comp2 H phi1 phi phi2
  | H: join_sub ?phi phi1 |- _ => Comp2 H phi1 phi phi2
  | H: list_join phi1 _ ?phi |- _ =>  Comp2 H phi1 phi phi2
  | H: list_join ?phi _ phi1 |- _ =>  Comp2 H phi1 phi phi2
  | H: phi1 = ?phi  |- _ => Comp2 H phi1 phi phi2
  | H: ?phi = phi1  |- _ => Comp2 H phi1 phi phi2
 end]
  with Comp2 H phi1 phi phi2 :=
            solve [apply comparable_trans with phi;
                         [eauto 3 with comparable  typeclass_instances |clear H; Comp1 phi phi2]
                   | clear H; Comp1 phi1 phi2]
  with Comp3 H phi1 phia phib phi2 :=
           solve [apply comparable_trans with phia;
                          [eauto 3 with comparable typeclass_instances |clear H; Comp1 phia phi2]
                  |apply comparable_trans with phib;
                          [eauto 3 with comparable  typeclass_instances | clear H; Comp1 phib phi2]
                   | clear H; Comp1 phi1 phi2].

Ltac Comp := match goal with
                | |- comparable ?phi1 ?phi2 => Comp1 phi1 phi2
                | |-  level ?phi1 = level ?phi2 => apply comparable_fashionR; Comp1 phi1 phi2
(*                | |- level _ = level _ => rewrite comparable_level; Comp *)
                end.

Definition not_any_younger {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A} (phi phi': A)  : Prop :=
     exists phi1, necR phi phi1 /\ comparable phi1 phi'.

Lemma comparable_not_any_younger {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A} :
    forall phi phi' : A , comparable phi phi' -> not_any_younger phi phi'.
Proof.
  intros.
  exists phi; split; auto; apply rt_refl.
Qed.

Lemma necR_not_any_younger {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
  forall phi phi' : A, necR phi phi' -> not_any_younger phi phi'.
Proof. intros; exists phi'; split; auto. apply comparable_refl. Qed.

Lemma not_any_younger_refl {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
 forall phi : A, not_any_younger phi phi.
Proof. intros; exists phi; split; auto. apply comparable_refl. Qed.

Lemma not_any_younger_trans {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
  forall phi1 phi2 phi3, not_any_younger phi1 phi2 -> not_any_younger phi2 phi3 ->
            not_any_younger phi1 phi3.
Proof.
intros.
destruct H as [phi1' [? ?]].
destruct H0 as [phi2' [? ?]].
generalize (comparable_common_unit H1); intros [e1 [? ?]].
generalize (nec_join2 H4 H0); intros [a [b [? [? _]]]].
generalize (nec_join H3 H6); intros [u [v [? [? _]]]].
exists u.
split.
econstructor 3; eauto.
Comp.
Qed.

Lemma not_any_younger_None {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
  forall phi phi', age1 phi = None -> not_any_younger phi phi' -> age1 phi' = None.
Proof.
intros.
destruct H0 as [phi1 [? ?]].
revert phi' H1.
induction H0; intros.
unfold age in H0.
inversion2 H H0.
generalize (comparable_common_unit H1); intros [e1 [? ?]].
case_eq (age1 phi'); [intros w ? | intro]; auto.
elimtype False.
generalize (age1_join2 _ H2 H3); intros [a [b [? [? ?]]]].
generalize (age1_join _ H0 H5); intros [c [d [? [? ?]]]].
unfold age in H8; inversion2 H H8.
assert (x=y).
clear - H0_ H.
induction H0_.
 unfold age in *.
inversion2 H H0.
auto.
rewrite <- IHH0_2; auto.
rewrite <- IHH0_1; auto.
subst y.
auto.
Qed.

Lemma nec_join3 {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}: forall {x x' y' z' : A},
       join x' y' z' ->
       necR x x' ->
       exists y,
         exists z,
           join x y z /\ necR y y' /\ necR z z'.
Proof.
intros.
revert y' z' H.
induction H0; intros.
destruct (unage_join _ H0 H) as [y0 [z0 [? [? ?]]]].
exists y0; exists z0; split; auto.
split; constructor 1; auto.
exists y'; exists z'.
split; auto.
rename z into x'.
rename y into x1.
destruct (IHclos_refl_trans2 _ _ H) as [x'' [y'' [? [? ?]]]].
destruct (IHclos_refl_trans1 _ _ H0) as [x0 [y0 [? [? ?]]]].
exists x0; exists y0.
split; auto.
split; econstructor 3; eauto.
Qed.


Require Import compcert.lib.Coqlib.
Require Import List. Import ListNotations.
Require Import ZArith Lia.
Require Import compcert.lib.Integers.          (* byte *)
Require Import Coq.Numbers.Natural.Peano.NPeano.

Require Import Coq.Strings.Ascii.
Require Import Coq.Program.Tactics.
Require Import sha.XorCorrespondence. (* Blist *)
Require Import sha.Bruteforce.
Require Import sha.general_lemmas.
Require Import sha.hmac_pure_lemmas.

Definition Blist := list bool.
Open Scope Z_scope.

Inductive InBlocks {A : Type} (n : nat) : list A -> Prop :=
  | InBlocks_nil : InBlocks n []
  | InBlocks_block : forall (front back full : list A),
                   length front = n ->
                   full = front ++ back ->
                   InBlocks n back ->
                   InBlocks n full.

Lemma InBlocks_len : forall {A : Type} (l : list A) (n : nat),
                       PeanoNat.Nat.divide (n) (length l) -> InBlocks n l.
Proof.
  intros A l n div.
  destruct div.
  revert A l n H.
  induction x; intros; simpl in *.
  - destruct l; simpl in *. constructor. inversion H.
  - destruct (list_splitLength _ _ _ H) as [l1 [l2 [L [L1 L2]]]]. clear H; subst.
    apply IHx in L2. clear IHx.
    apply (InBlocks_block _ l1 l2); trivial.
Qed.

(* ----- Inductive *)

Inductive bytes_bits_lists : Blist -> list byte -> Prop :=
  | eq_empty : bytes_bits_lists nil nil
  | eq_cons : forall (bits : Blist) (bytes : list byte)
                     (b0 b1 b2 b3 b4 b5 b6 b7 : bool) (b : byte),
                bytes_bits_lists bits bytes ->
                convertByteBits [b0; b1; b2; b3; b4; b5; b6; b7] b ->
                bytes_bits_lists (b0 :: b1 :: b2 :: b3 :: b4 :: b5 :: b6 :: b7 :: bits)
                                 (b :: bytes).

(* ----- Computational *)

(* TODO: assumes Z is positive and in range, does not use Z.positive *)

Definition div_mod (num : Z) (denom : Z) : bool * Z :=
  (Z.gtb (num / denom) 0, num mod denom).

Definition byteToBits (byte : byte) : Blist :=
  let (b7, rem7) := div_mod (Byte.unsigned byte) 128 in
  let (b6, rem6) := div_mod rem7 64 in
  let (b5, rem5) := div_mod rem6 32 in
  let (b4, rem4) := div_mod rem5 16 in
  let (b3, rem3) := div_mod rem4 8 in
  let (b2, rem2) := div_mod rem3 4 in
  let (b1, rem1) := div_mod rem2 2 in
  let (b0, rem0) := div_mod rem1 1 in
  [b0; b1; b2; b3; b4; b5; b6; b7].

Fixpoint bytesToBits (bytes : list byte) : Blist :=
  match bytes with
    | [] => []
    | byte :: xs => byteToBits byte ++ bytesToBits xs
  end.

Definition bitsToByte (bits : Blist) : byte :=
  Byte.repr
  match bits with
    | b0 :: b1 :: b2 :: b3 :: b4 :: b5 :: b6 :: b7 :: nil =>
      (1 * (asZ b0) + 2 * (asZ b1) + 4 * (asZ b2) + 8 * (asZ b3)
      + 16 * (asZ b4) + 32 * (asZ b5) + 64 * (asZ b6) + 128 * (asZ b7))
    | _ => -1                  (* should not happen *)
  end.

Fixpoint bitsToBytes (bits : Blist) : list byte :=
  match bits with
    | b0 :: b1 :: b2 :: b3 :: b4 :: b5 :: b6 :: b7 :: xs =>
      bitsToByte [b0; b1; b2; b3; b4; b5; b6; b7] :: bitsToBytes xs
    | _ => []
  end.

(*
Definition isbyteZ i := (0 <= i < 256)%Z.

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

(* -------------------- Various theorems and lemmas *)

Lemma byteToBits_length bt: length (byteToBits bt) = 8%nat.
Proof. reflexivity. Qed.

Lemma bytes_bits_length : forall (bits : Blist) (bytes : list byte),
  bytes_bits_lists bits bytes -> length bits = (length bytes * 8)%nat.
Proof.
  intros bits bytes corr.
  induction corr.
  - reflexivity.
  - simpl. repeat f_equal. apply IHcorr.
Qed.

Lemma bytesToBits_app : forall (l1 l2 : list byte),
                          bytesToBits (l1 ++ l2) = bytesToBits l1 ++ bytesToBits l2.
Proof.
  induction l1; intros.
  * reflexivity.
  *
    simpl. rewrite -> IHl1. reflexivity.
Qed.

Lemma bytesToBits_len : forall (l : list byte),
                          length (bytesToBits l) = (length l * 8)%nat.
Proof.
  induction l; intros; try reflexivity.
  -
    simpl.
    rewrite -> IHl.
    reflexivity.
Qed.

(* Prove by brute force (test all Z in range) *)
Theorem byte_bit_byte_id : forall (b : byte),
                                bitsToByte (byteToBits b) = b.
Proof.
  intros.
  rewrite <- (Byte.repr_unsigned b) at 2.
  unfold  byteToBits.
  pose proof (Byte.unsigned_range b).
  set (x := Byte.unsigned b)  in *. clearbody x.
  change Byte.modulus with 256 in H.
  unfold bitsToByte. f_equal.
  do_range H reflexivity.
Qed.

Theorem bits_byte_bits_id : forall (b0 b1 b2 b3 b4 b5 b6 b7 : bool),
                              [b0; b1; b2; b3; b4; b5; b6; b7] =
                              byteToBits (bitsToByte [b0; b1; b2; b3; b4; b5; b6; b7]).
Proof.
  intros.
  destruct b0; destruct b1; destruct b2; destruct b3;
  destruct b4; destruct b5; destruct b6; destruct b7;
  reflexivity.
Qed.

Theorem bytes_bits_bytes_id : forall (bytes : list byte),
                                bitsToBytes (bytesToBits bytes) = bytes.
Proof.
  intros bytes.
  induction bytes as [ | byte bytes].
  - reflexivity.
  -
    unfold bytesToBits.
    fold bytesToBits.
    unfold byteToBits.
    unfold bitsToBytes.
    Opaque bitsToByte. Opaque bitsToBytes. Opaque bytesToBits.
    simpl.
    Transparent bitsToBytes. fold bitsToBytes.
    rewrite -> IHbytes.

    Transparent bitsToByte.
    unfold bitsToByte. f_equal.
    apply byte_bit_byte_id.
Qed.

(* ------------------ Theorems relating inductive and computational definitions *)

Theorem bytes_bits_def_eq : forall (bytes : list byte),
                              bytes_bits_lists (bytesToBits bytes) bytes.
Proof.
  intros bytes.
  induction bytes as [ | byte bytes ].
  -
    simpl. apply eq_empty.
  -
    Transparent bytesToBits.
    apply eq_cons.

    *
      apply IHbytes.
    *
      unfold convertByteBits.
      do 8 eexists.
      split.
      +
        reflexivity.
      +
        pose proof (Byte.unsigned_range byte). change Byte.modulus with 256 in H.
        set (b := Byte.unsigned byte) in *. clearbody b.
        do_range H reflexivity.
Qed.

Theorem bytes_bits_comp_ind : forall (bits : Blist) (bytes : list byte),
                               bits = bytesToBits bytes ->
                               bytes_bits_lists bits bytes.
Proof.
  intros bits bytes corr.
  rewrite -> corr.
  apply bytes_bits_def_eq.
Qed.

Theorem bytes_bits_ind_comp : forall (bits : Blist) (bytes : list byte),
                                 bytes_bits_lists bits bytes ->
                                 bytes = bitsToBytes bits.
Proof.
  intros bits bytes corr.
  induction corr.
  - reflexivity.
  - rewrite -> IHcorr; clear IHcorr corr.
    unfold bitsToBytes.
      fold bitsToBytes.
      f_equal. unfold convertByteBits in H.
        destruct H as [b8 [b9 [b10 [b11 [b12 [b13 [b14 [b15 [B BT]]]]]]]]].
        inversion B; clear B. subst.
        rewrite <- (Byte.repr_unsigned b). rewrite BT.
        reflexivity.
Qed.

Theorem bits_bytes_ind_comp : forall (bits : Blist) (bytes : list byte),
                                 bytes_bits_lists bits bytes ->
                                 bits = bytesToBits bytes.
Proof.
  intros bits bytes corr.
  induction corr.
  - reflexivity.
  -
    unfold convertByteBits in H.
    destruct_exists.
    destruct H7.
    rewrite <- (Byte.repr_unsigned b). rewrite H8. clear H8.
    inversion H7.
    subst.
    clear H7.
    unfold bytesToBits.
    fold bytesToBits.
    assert (list_8 : forall {A : Type} (e0 e1 e2 e3 e4 e5 e6 e7 : A) (l : list A),
                       e0 :: e1 :: e2 :: e3 :: e4 :: e5 :: e6 :: e7 :: l =
                       [e0; e1; e2; e3; e4; e5; e6; e7] ++ l).
    reflexivity.
    rewrite -> list_8.
    f_equal.
    apply bits_byte_bits_id.
Qed.

(* ----------------------------- *)
(* Relating bits to bytes *)

Lemma bitsToBytes_app : forall (l m : Blist),
                          InBlocks 8 l ->
                          bitsToBytes (l ++ m) = bitsToBytes l ++ bitsToBytes m.
Proof.
  intros l m len_l. revert m.
  induction len_l.
  * intros. reflexivity.
  *
    intros m.
    rewrite -> H0.
    rewrite <- app_assoc.
    destruct front as [ | x0 [| x1 [ | x2 [ | x3 [ | x4 [ | x5 [ | x6 [ | x7 ]]]]]]]];
      inversion H.
    unfold bitsToBytes.
    Opaque bitsToByte.
    simpl.
    fold bitsToBytes.
    apply list_nil in H2.
    rewrite -> H2.
    simpl.
    rewrite -> IHlen_l.
    reflexivity.
Qed.

Lemma bitsToBytes_len_gen : forall (l : Blist) (n : nat),
                          length l = (n * 8)%nat ->
                          length (bitsToBytes l) = n.
Proof.
  intros l n len.
  assert (blocks : InBlocks 8 l).
    apply InBlocks_len. rewrite -> len. exists n. reflexivity.
  revert n len.
  induction blocks.
  * intros. simpl in *. lia.
  *
    intros n len.
    rewrite -> H0.
    rewrite -> bitsToBytes_app.
    rewrite -> app_length.
    rewrite -> H0 in len.
    rewrite -> app_length in len.
    rewrite -> H in len.

    destruct n as [ | n'].
    (* strange that destruct works here but not after [rewrite -> IHblocks] *)
    - simpl in *.
      inversion len.
    -
      destruct front as [ | x0 [| x1 [ | x2 [ | x3 [ | x4 [ | x5 [ | x6 [ | x7 ]]]]]]]];
      inversion H.

      simpl.
      apply list_nil in H2.
      rewrite -> H2. simpl.
      assert (minus : forall (n m : nat), n = m -> (n - 8)%nat = (m - 8)%nat).
        intros. lia.
      apply minus in len.
      simpl in len.
      assert (min_zero : forall (n : nat), (n - 0)%nat = n). intros. lia.
      repeat rewrite -> min_zero in len.
      clear H2 minus min_zero.
      specialize (IHblocks n').
      rewrite -> IHblocks.
      reflexivity.
      apply len.
      -
        apply InBlocks_len.
        rewrite -> H. unfold PeanoNat.Nat.divide.
        exists 1%nat. reflexivity.
Qed.

Lemma bitsToBytes_len : forall (l : Blist),
                          length l = 512%nat ->
                          Zlength (bitsToBytes l) = 64%Z.
Proof.
  intros l len.
  rewrite -> Zlength_correct.
  pose proof bitsToBytes_len_gen as len_gen.
  specialize (len_gen l 64%nat).
  rewrite -> len_gen.
  - reflexivity.
  - apply len.
Qed.

Lemma bits_bytes_bits_id : forall (l : Blist),
                             InBlocks 8 l ->
                             bytesToBits (bitsToBytes l) = l.
Proof.
  intros l len.
  induction len.
  - reflexivity.
  -
    rewrite -> H0.
    destruct front as [ | x0 [| x1 [ | x2 [ | x3 [ | x4 [ | x5 [ | x6 [ | x7 ]]]]]]]];
      inversion H.
    simpl.
    apply list_nil in H2. rewrite -> H2. simpl.
    rewrite -> IHlen.

    destruct x0; destruct x1; destruct x2; destruct x3;
    destruct x4; destruct x5; destruct x6; destruct x7; reflexivity.
Qed.

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

Lemma bytesToBits_nil_inv l: nil = bytesToBits l -> l = nil.
Proof. destruct l; trivial. simpl; intros. discriminate. Qed.

Lemma bytesToBits_cons b l:
      bytesToBits (b::l) = byteToBits b ++ bytesToBits l.
Proof. reflexivity. Qed.

Lemma byteToBits_injective: forall a b,
      byteToBits a = byteToBits b ->
      a = b.
Proof. intros.
assert (bitsToByte (byteToBits a) = bitsToByte (byteToBits b)).
  rewrite H; trivial.
clear H.
rewrite ?byte_bit_byte_id in H0. trivial.
Qed.

Lemma bytesToBits_injective: forall b1 b2, bytesToBits b1 = bytesToBits b2 ->
       b1=b2.
Proof. induction b1.
  intros; destruct b2; trivial. discriminate.
  destruct b2. discriminate.
  do 2 rewrite bytesToBits_cons.
  intros. destruct (app_inj1 _ _ _ _ H). reflexivity.
  rewrite (IHb1 _ H1).
  rewrite (byteToBits_injective _ _ H0). trivial.
Qed.

Lemma bitsToBytes_injective8 b1 b2 (B: bitsToBytes b1 = bitsToBytes b2)
       (L1: PeanoNat.Nat.divide 8 (length b1))
       (L2: PeanoNat.Nat.divide 8 (length b2)): b1 = b2.
Proof. intros.
  assert (bytesToBits (bitsToBytes b1) = bytesToBits (bitsToBytes b2)).
    rewrite B; trivial.
  rewrite bits_bytes_bits_id in H.
    rewrite bits_bytes_bits_id in H. trivial.
    apply InBlocks_len; assumption.
  apply InBlocks_len; assumption.
Qed.

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

Definition intsToBits (l : list Int.int) : list bool :=
  bytesToBits (intlist_to_bytelist l).

Definition bitsToInts (l : Blist) : list Int.int :=
  bytelist_to_intlist (bitsToBytes l).


Require Export NamelessUTLC.Functor.

Inductive term : Set := var (n: nat) :> term | abs (t: term) | app (fn: term) (arg: term).

Hint Constructors term.

Bind Scope term_scope with term.
Delimit Scope term_scope with term.
Notation "[ 'fun' e ]" := (abs e)
  (at level 0) : term_scope.
Notation "fn @ arg" :=
  (app fn arg)
    (at level 50, arg at next level, left associativity) : term_scope.
Global Open Scope term_scope.

Fixpoint eqt (t1 t2: term) : bool :=
  match t1, t2 with
  | var n1, var n2 => n1 == n2
  | abs t1, abs t2 => eqt t1 t2
  | app fn1 arg1, app fn2 arg2 => eqt fn1 fn2 && eqt arg1 arg2
  | _, _ => false
  end.

Theorem eqtP : Equality.axiom eqt.
Proof. move=> t1 t2. apply: introP.
  - elim: t1 t2 => //=.
    + move=> n. case=> // ?. by move/eqP.
    + move=> ? IH. case=> // ?. by move/IH.
    + move=> ? IHf ? IHa. case=> // ? ?. by move/andP=> [/(IHf _)-> /(IHa _)->].
  - elim: t1 t2 => //=.
    + move=> n. case=> // ?. by move/eqP.
    + move=> ? IH. case=> // ?. by move/IH.
    + move=> ? IHf ? IHa. case=> // ? ?. move/nandP. by case=> [/IHf | /IHa].
Qed.

Definition term_eqMixin := EqMixin eqtP.
Canonical term_eqType := Eval hnf in EqType term term_eqMixin.

Definition bound (t: term) : nat :=
  @term_rec (fun _ => nat)
            (fun n => n.+1)
            (fun _ => predn)
            (fun _ n _ m => maxn n m)
            t.

Inductive bounded (n: nat) : term -> Prop :=
| BoundedVar k (lt: k < n) : bounded n k
| BoundedAbs t (t_bounded: bounded n.+1 t) : bounded n [fun t]
| BoundedApp t1 (t1_bounded: bounded n t1) t2 (t2_bounded: bounded n t2) : bounded n (t1 @ t2).

Hint Constructors bounded.

Lemma invert_bounded n t (H: bounded n t)
  : match t return Prop with
    | var k => k < n
    | abs t => bounded n.+1 t
    | app fn arg => bounded n fn /\ bounded n arg
    end.
Proof. case: t H => *; match goal with
                 | [ H: bounded _ _ |- _ ] => by inversion H
                 end. Qed.

Lemma boundedS : forall t n, bounded n t -> bounded n.+1 t.
Proof. elim; move=> *; match goal with
                 | [H: bounded _ _ |- _] => move: H; by invert
                 end.
Qed.

Hint Resolve boundedS.

Lemma bounded_leq : forall t n, bounded n t -> forall m, n <= m -> bounded m t.
Proof. elim.
  - move=> ? ? /invert_bounded-? ? ?. constructor. by apply: leq_trans; eauto.
  - move=> ? IH ? /invert_bounded-? ? ?. constructor. by apply: IH; eauto.
  - move=> ? IHf ? IHa ? /invert_bounded-[? ?] ? ?. constructor.
    + by apply: IHf; eauto.
    + by apply: IHa; eauto.
Qed.

Hint Resolve bounded_leq.

Lemma maxn_leq_andb n m p : maxn n m <= p = (n <= p) && (m <= p).
Proof. case n_leq_m: (n <= m); move: (n_leq_m).
  * move/maxn_idPl. rewrite maxnC => ->. case m_leq_p: (m <= p).
    -- by move: (leq_trans n_leq_m m_leq_p).
    -- by rewrite andbF.
  * move/negbT. rewrite -ltnNge. move/ltnW/maxn_idPr. rewrite maxnC=> ->.
    case n_leq_p: (n <= p) => //.
    move/negbT: n_leq_m n_leq_p. rewrite -ltnNge.
    move/ltnW=> m_leq_n n_leq_p. by move: (leq_trans m_leq_n n_leq_p).
Qed.

Theorem boundP : forall t n, reflect (forall m, n <= m -> bounded m t) (bound t <= n).
Proof. elim=> /=.
  - move=> n1 n2. apply: introP.
    + constructor. by apply: leq_trans; eauto.
    + rewrite -leqNgt => H. move/(_ n2 (leqnn n2))/invert_bounded.
      rewrite ltn_neqAle. move/andP=> [neq H']. move/andP/anti_leq: (conj H H').
      by move/eqP: neq.
  - move=> t IH n.
    have leq_sub1_add1: forall n m, (n.-1 <= m) = (n <= m.+1) by elim.
    rewrite {}leq_sub1_add1. apply: introP.
    + move=> Hbound m Hm.
      constructor. apply: IH.
      * exact: Hbound.
      * by rewrite ltnS.
    + move/(elimN (IH n.+1))=> {IH} contra. move/(_ n (leqnn _))/invert_bounded => H.
      apply: contra => m lt. by apply: bounded_leq; eauto.
  - move=> f IHf a IHa n.
    rewrite maxn_leq_andb.
    apply: introP.
    + move/andP=> [bf_leq ba_leq] m leq. move/(fun x => leq_trans x leq): bf_leq => ?.
      move/(fun x => leq_trans x leq): ba_leq => {leq} ?.
        by constructor; [apply: IHf | apply: IHa]; eauto.
    + move/nandP=> [/IHf-nbf | /IHa-nba] /(_ n (leqnn _))/invert_bounded-[? ?];
                    [apply: nbf | apply: nba] => ? ?; by apply: bounded_leq; eauto.
Qed.

Lemma boundEqP : forall t n, bound t == n -> forall m, n <= m -> bounded m t.
Proof. move=> t n. rewrite eqn_leq. move/andP=> [H _]. by move/boundP: H. Qed.

Definition shift_over (d: nat) : term -> nat -> term :=
  @term_rec (fun _ => nat -> term)
            (fun n c => if n < c then n else n + d)
            (fun _ rec c => [fun rec c.+1])
            (fun _ rec_f _ rec_a c => rec_f c @ rec_a c).

Definition shift (d: nat) : term -> term := shift_over d ^~ 0.

Lemma bound_shift_over {n t} : bounded n t -> forall {c d}, bounded (n + d) (shift_over d t c).
Proof. elim=> //= {n t}.
  move=> ? k ? c *. constructor. case: (k < c).
  - by apply: ltn_addr.
  - by rewrite ltn_add2r.
Qed.

Theorem bound_shift {n t d} : bounded n t -> bounded (n + d) (shift d t).
Proof. move=> *. by apply: bound_shift_over. Qed.

Definition substitute (substitution: term) (variable: nat) (t: term) : term :=
  @term_rec (fun _ => nat -> term -> term)
           (fun n v s => if n == v then s else n)
           (fun _ rec v s => [fun rec v.+1 (shift 1 s)])
           (fun _ rec_fn _ rec_arg v s => rec_fn v s @ rec_arg v s)
           t variable substitution.

Theorem bound_substitute {n t}
  : bounded n t -> forall s, bounded n s -> forall v, bounded n (substitute s v t).
Proof. elim=> //= {n t}.
  - move=> ? k ? ? ? v. by case: (k == v).
  - move=> ? ? ? IH ? bs ?. constructor.
    move/bound_shift: bs. move/(_ 1). rewrite addn1. by move/IH.
Qed.


Require Import compcert.lib.Integers.
Require Import Recdef.
Require Import Bvector.
Require Import List. Import ListNotations.
Require Import Arith.
Require Import compcert.lib.Coqlib.
Require Import sha.general_lemmas.
Require Import sha.hmac_pure_lemmas.
Require Import sha.XorCorrespondence.
Require Import sha.ByteBitRelations.
Import List.

Definition concat {A : Type} (l : list (list A)) : list A :=
  flat_map id l.

Lemma concat_length {A}: forall L (l:list A), In l L -> (length (concat L) >= length l)%nat.
Proof.  unfold concat. induction L; simpl; intros. contradiction.
  rewrite app_length.
  destruct H; subst. unfold id. omega.
  specialize (IHL _ H). omega.
Qed.

Lemma concat_InBlocks b: forall l (F: Forall (fun x : list bool => length x = b) l),
      InBlocks b (concat l).
induction l; simpl; intros. constructor.
econstructor. 2: reflexivity.
 apply Forall_inv in F; trivial.
 apply IHl. apply Forall_tl in F; trivial.
Qed.

Lemma concat_app {A} (l1 l2:list A): l1 ++ l2 = l1 ++ concat (l2 :: nil).
Proof.
  unfold concat. simpl.
  rewrite -> app_nil_r. reflexivity.
Qed.

(* Replacing splitVector *)
Definition splitList {A : Type} (n : nat) (l : list A) : (list A * list A) :=
  (firstn n l, skipn n l).

Lemma split_append_id : forall {A : Type} (len : nat) (l1 l2 : list A),
                               length l1 = len -> length l2 = len ->
                               splitList len (l1 ++ l2) = (l1, l2).
Proof.
  induction len; intros l1 l2 len1 len2.
  - apply list_nil in len1; apply list_nil in len2.
    subst. reflexivity.
  - unfold splitList.
    rewrite -> firstn_exact. rewrite -> skipn_exact.
    * reflexivity. * assumption. * assumption.
Qed.

(* Replacing BVxor *)
Definition BLxor (xs : Blist) (ys : Blist) :=
  map (fun p => xorb (fst p) (snd p)) (combine xs ys).

Lemma BLxor_length: forall n l1 l2
      (len1: length l1 = n) (len2: length l2 = n), length (BLxor l1 l2) = n.
Proof.
  induction n as [ | n']; intros.
  - apply list_nil in len1. apply list_nil in len2.
    subst. reflexivity.
  - destruct l1; destruct l2; inversion len1; inversion len2.
    simpl.
    rewrite -> map_length.
    rewrite -> combine_length.
    rewrite H0. rewrite H1. simpl.
    f_equal.
    apply min_l.
    omega.
Qed.

Theorem xor_eq : forall (n : nat) (v1 v2 : Bvector.Bvector n),
                   BLxor (Vector.to_list v1) (Vector.to_list v2) =
                   Vector.to_list (Bvector.BVxor n v1 v2).
Proof.
  eapply Vector.rect2.
  reflexivity.
  intros. simpl. rewrite (VectorToList_cons _ _ (xorb a b)).
   rewrite <- H. clear H. unfold BLxor.
   rewrite VectorToList_combine. reflexivity.
Qed.

Lemma inner_general_mapByte : forall (ip : Blist) (IP_list : list byte) (k : Blist) (K : list byte),
                            bytes_bits_lists ip IP_list ->
                            bytes_bits_lists k K ->
     bytes_bits_lists (BLxor k ip)
                          (map (fun p0 : byte * byte => Byte.xor (fst p0) (snd p0))
                                (combine K IP_list)).
Proof.
  intros ip IP_list k K ip_eq k_eq.
  unfold BLxor. simpl.
  generalize dependent IP_list. generalize dependent ip.
  induction k_eq.
  - simpl; intros. constructor.
  - intros. inv ip_eq.
    + constructor.
    + simpl. constructor; auto.
        unfold Byte.xor.
        apply xor_correspondence; auto.
Qed.

Function hash_blocks_bits (b:nat) (B:(0<b)%nat) (hash_block_bit : Blist -> Blist -> Blist) (r: Blist)
         (msg: Blist) {measure length msg} : Blist :=
  match msg with
  | nil => r
  | _ => hash_blocks_bits b B hash_block_bit (hash_block_bit r (firstn b msg)) (skipn b msg)
  end.
Proof. intros.
 destruct (lt_dec (length msg) b).
 rewrite skipn_short. simpl; omega. rewrite <- teq; omega.
 rewrite skipn_length; rewrite <- teq; omega.
Defined.

Lemma add_blocksize_length l n: 0<=n ->
      BinInt.Z.add n (Zcomplements.Zlength l) = Zcomplements.Zlength ((Coqlib.list_repeat (Z.to_nat n) true) ++ l).
Proof. intros. do 2 rewrite Zlength_correct.
  rewrite app_length, length_list_repeat, Nat2Z.inj_add, Z2Nat.id; trivial.
Qed.

Lemma hash_blocks_bits_len c b (B:(0<b)%nat) h
          (HH: forall x y, length x = c -> length y = b -> length (h x y)  = c)
          r l: length r = c ->
      InBlocks b l ->
      length (hash_blocks_bits b B h r l) = c.
Proof.
  apply hash_blocks_bits_ind.
  intros. trivial.
  intros. destruct _x. contradiction. subst msg; clear y.
  inv H1.
  apply H; clear H. rewrite HH. trivial. trivial.
    rewrite H3, firstn_exact; trivial.
    rewrite H3, skipn_exact; trivial.
Qed.


Section EqDec.

  Variable A:Type.

  Variable eq_dec: forall (x y:A), { x = y } + { x <> y }.

  Definition eq_dec_to_bool x y := if eq_dec x y then true else false.

  Lemma eq_dec_inv_true:
    forall x y,
    eq_dec_to_bool x y = true -> x = y.
  Proof.
    intros.
    unfold eq_dec_to_bool in *.
    destruct (eq_dec x y); auto; try inversion H.
  Qed.

  Lemma eq_dec_inv_false:
    forall x y,
    eq_dec_to_bool x y = false -> x <> y.
  Proof.
    intros.
    unfold eq_dec_to_bool in *.
    destruct (eq_dec x y); auto; try inversion H.
  Qed.

  Lemma eq_dec_rw:
    forall x y,
    { eq_dec_to_bool x y = true /\ x = y } +
    { eq_dec_to_bool x y = false /\ x <> y }.
  Proof.
    intros.
    unfold eq_dec_to_bool.
    destruct (eq_dec x y).
    - left; intuition.
    - right; intuition.
  Qed.

  Lemma eq_dec_refl:
    forall x,
    eq_dec_to_bool x x = true.
  Proof.
    intros.
    destruct eq_dec_rw with (x:=x) (y:=x) as [(?,?)|(?,?)].
    - trivial.
    - contradiction H0.
      trivial.
  Qed.

End EqDec.


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

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

Print Assumptions nonzero.