Require Import Coqlib.
Require Import Maps.
Require Import maps_ext.
Require Import syntax.
Require Import infrastructure_props.
Require Import Metatheory.
Require Import Program.Tactics.
Require Import dom_tree.
Require Import push_iter.

(* This file proves that creating dominator trees based on list gives
   well-formed dom-trees. *)

(* res is a map from node to dominators, computed by push_iter. So, the
   dominators of each node are sorted by idom. *)
Fixpoint compute_sdom_chains_aux (res: positive -> LDoms.t)
  (bd: list positive) (acc: list (positive * list positive))
  : list (positive * list positive) :=
match bd with
| nil => acc
| l0 :: bd' =>
    match res l0 with
    | Some dts0 =>
        compute_sdom_chains_aux res bd' ((l0, (rev (l0 :: dts0)))::acc)
    | None => compute_sdom_chains_aux res bd' acc
    end
end.

Definition compute_sdom_chains (res: positive -> LDoms.t) rd
  : list (positive * list positive) :=
compute_sdom_chains_aux res rd nil.

Definition create_dtree (pe:positive) (rd:list positive)
  (res: positive -> LDoms.t) : DTree :=
let chains := compute_sdom_chains res rd in
create_dtree_from_chains positive_eq_dec pe chains.

Lemma create_dtree__wf_dtree_aux: forall pe rd res dt,
  create_dtree pe rd res = dt ->
  let chains := compute_sdom_chains res rd in
  forall p0 ch0,
    (is_dtree_edge positive_eq_dec dt p0 ch0 = true ->
      exists l0, exists chain0,
      List.In (l0, chain0) chains /\ is_chain_edge chain0 p0 ch0) /\
    ((exists l0, exists chain0,
      List.In (l0, chain0) chains /\
      chain_connects_dtree (DT_node pe DT_nil) chain0 /\
     is_chain_edge chain0 p0 ch0) ->
     is_dtree_edge positive_eq_dec dt p0 ch0 = true).
Proof.
  unfold create_dtree.
  intros. subst.
  apply create_dtree_from_chains__is_dtree_edge__is_chain_edge.
Qed.

Lemma compute_sdom_chains_aux_spec: forall
  res l0 chain0 bd acc
  (H1: forall l0 chain0
       (Hin: List.In (l0, chain0) acc),
       exists dts0,
         res l0 = Some dts0 /\
         chain0 = rev (l0 :: dts0))
  (H2: In (l0, chain0) (compute_sdom_chains_aux res bd acc)),
  (exists dts0,
    res l0 = Some dts0 /\
    chain0 = rev (l0 :: dts0)) /\ (In l0 bd \/ In (l0, chain0) acc).
Proof.
  induction bd; intros; eauto.
    simpl in H2.
    remember (res a) as R.
    destruct R.
    Case "1".
      apply IHbd in H2.
      SCase "1.1".
        destruct H2 as [J1 J2].
        split; auto.
          simpl.
          destruct J2 as [J2 | J2]; auto.
          destruct_in J2; auto.
          inv J2. auto.
      SCase "1.s".
        intros.
        destruct_in Hin; eauto.
        inv Hin.
        exists l. split; auto.
    Case "2".
      apply IHbd in H2; auto.
      destruct H2 as [J1 J2].
      split; auto.
        simpl.
        destruct J2 as [J2 | J2]; auto.
Qed.

Lemma compute_sdom_chains_spec: forall res rd l0 chain,
  In (l0, chain) (compute_sdom_chains res rd) ->
  (exists dts0,
    res l0 = Some dts0 /\
    chain = rev (l0 :: dts0)) /\ In l0 rd.
Proof.
  intros.
  unfold compute_sdom_chains in H.
  apply compute_sdom_chains_aux_spec in H.
    destruct H as [H1 [H2 | H2]]; tauto.
    simpl. intros. tauto.
Qed.

Lemma compute_sdom_chains_aux_spec': forall res l0 dts0 rd acc
  (Hin: (res l0 = Some dts0 /\ In l0 rd) \/ In (l0, rev (l0 :: dts0)) acc),
  In (l0, rev (l0 :: dts0)) (compute_sdom_chains_aux res rd acc).
Proof.
  induction rd; simpl; intros.
    tauto.

    destruct Hin as [[Hsome [EQ | Hin]] | Hin]; subst.
      rewrite Hsome.
      apply IHrd; simpl; auto.

      destruct (res a); apply IHrd; simpl; auto.
      destruct (res a); apply IHrd; simpl; auto.
Qed.

Lemma compute_sdom_chains_spec': forall res rd l0 dts0,
  res l0 = Some dts0 -> In l0 rd ->
  In (l0, rev (l0 :: dts0)) (compute_sdom_chains res rd).
Proof.
  unfold compute_sdom_chains.
  intros.
  apply compute_sdom_chains_aux_spec'; auto.
Qed.

Lemma create_dtree__disjoint_children_dtree: forall pe rd res,
  disjoint_children_dtree positive_eq_dec (create_dtree pe rd res).
Proof.
  unfold create_dtree. intros.
  apply create_dtree_from_chains__disjoint_children_dtree.
Qed.

Require Import cfg.

(* An edge is in dtree iff the edge represents an idom-relation. *)
Section create_dtree__wf_dtree.

Variable dts: PMap.t LDoms.t.
Variable psuccs: PTree.t (list positive).
Variable pe ni: positive.
Hypothesis Hanalyze: pdom_analyze psuccs pe ni = dts.
Variable res: positive -> LDoms.t.
Hypothesis Hquery: res = fun p:positive => PMap.get p dts.
Variable rd: list positive.
Hypothesis Hreach: forall p, PCfg.reachable psuccs pe p <-> List.In p rd.
Variable dt: @DTree positive.
Hypothesis Hdtree: create_dtree pe rd res = dt.
Hypothesis wf_entrypoints: in_cfg psuccs pe.
Definition entrypoints := (pe, LDoms.top) :: nil.
Definition predecessors := XPTree.make_predecessors psuccs.
Hypothesis wf_order: forall n (Hneq: n <> pe)
  (Hincfg: XPTree.in_cfg psuccs n),
  exists p, In p (predecessors ??? n) /\ (p > n)%positive.
Hypothesis Hok: (ni >= Termination.num_iters psuccs)%positive.
Hypothesis Hnopred: (XPTree.make_predecessors psuccs) ??? pe = nil.

Lemma dtree_edge_iff_idom: forall p0 ch0,
  is_dtree_edge positive_eq_dec dt p0 ch0 = true <->
    (PCfg.imm_domination psuccs pe p0 ch0 /\ PCfg.reachable psuccs pe ch0).
Proof.
  intros.
  assert (J:=Hdtree).
  apply create_dtree__wf_dtree_aux with (p0:=p0)(ch0:=ch0) in J; auto.
  destruct J as [Hdtree1 Hdtree2].
  split; intro J.
  Case "1".
    apply Hdtree1 in J.
    destruct J as [l0 [chain0 [Hin Hedge]]].
    apply compute_sdom_chains_spec in Hin.
    destruct Hin as [[dts0 [Hin Heq]] ?]; subst chain0.
    assert (Sorted (PCfg.imm_domination psuccs pe) (rev (l0::dts0)))
      as Hsort.
      subst. eapply IdomSorted.dom__imm_sorted; eauto.
    split.
    SCase "1.1".
      eapply chain_edge_sorted; eauto.
    SCase "1.2".
      simpl in Hedge.
      apply is_chain_edge__inv in Hedge.
      destruct Hedge as [Hin1 [Hin2 Hnnil]].
      apply rev_non_nil in Hnnil.
      subst dts res.
      assert (Hreach0:=Hin).
      apply PDomProps.nonempty_is_reachable in Hreach0; auto.
      destruct_in Hin2.
        apply in_rev in Hin2.
        eapply PDomProps.in_dom__reachable; eauto.

        destruct_in Hin2.
  Case "2".
    apply Hdtree2.
    destruct J as [J1 J2].
    eapply IdomSorted.imm_dom__at_head in J1; eauto.
    destruct J1 as [dts0 J1].
    rewrite Hanalyze in J1.
    exists ch0. exists (rev (ch0::p0::dts0)).
    split.
    SCase "2.1".
      apply compute_sdom_chains_spec'; subst; auto.
        apply Hreach; auto.
    split.
    SCase "2.2".
      subst dts.
      apply IdomSorted.entry__at_last in J1; try congruence; auto.
      destruct J1 as [dts' J1].
      unfold PTree.elt in *.
      rewrite J1.
      rewrite_env ((ch0 :: dts') ++ pe :: nil).
      rewrite rev_unit.
      simpl.
      case_eq (rev dts' ++ ch0 :: nil); auto.
        intro J. contradict J. auto with datatypes.
    SCase "2.3".
      simpl. simpl_env.
      apply is_chain_edge_tail; simpl; auto.
Qed.

Lemma create_dtree___reachable_dtree:
  PDProps.reachable_dtree psuccs pe dt.
Proof.
  subst dt.
  unfold create_dtree.
  apply PDProps.create_dtree_from_chains__reachable_dtree; auto.
    apply Forall_forall.
    intros [x xs] Hinx.
    apply compute_sdom_chains_spec in Hinx.
    destruct Hinx as [[dts0 [Hget Heq]] Hinrd].
    simpl.
    intros p Hinp. subst.
    simpl in Hinp.
    destruct_in Hinp.
      apply in_rev in Hinp.
      eapply PDomProps.in_dom__reachable; eauto.

      destruct_in Hinp.
      apply Hreach; auto.
Qed.

Lemma create_dtree__wf_dtree: PDProps.wf_dtree psuccs pe positive_eq_dec dt.
Proof.
  apply PDProps.create_dtree__wf_dtree; eauto using XPTree.no_preds__notin_succs.
  Case "1".
    intros p ch Hedge.
    assert (J:=Hdtree).
    apply create_dtree__wf_dtree_aux with (p0:=p)(ch0:=ch) in J; auto.
    destruct J as [Hdtree1 _].
    apply_clear Hdtree1 in Hedge.
    destruct Hedge as [l0 [chain0 [Hin Hedge]]].
    exists chain0.
    split; auto.
      apply compute_sdom_chains_spec in Hin.
      destruct Hin as [[dts0 [Hin Heq]] ?]; subst chain0.
      subst. eapply IdomSorted.dom__imm_sorted; eauto.
  Case "2".
    subst dt. apply create_dtree__disjoint_children_dtree.
  Case "3".
    apply create_dtree___reachable_dtree.
Qed.

End create_dtree__wf_dtree.


(*
Copyright © 2006 Russell O’Connor

Permission is hereby granted, free of charge, to any person obtaining a copy of
this proof and associated documentation files (the "Proof"), to deal in
the Proof without restriction, including without limitation the rights to
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
the Proof, and to permit persons to whom the Proof is furnished to do so,
subject to the following conditions:

The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Proof.

THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF.
*)

Require Import Integration.
Require Import AbstractIntegration.
Require SimpleIntegration.
(*Require SimpsonIntegration.*)
Require Import CRtrans.
Require QnonNeg.
Import QnonNeg.notations.

(* The answer function returns an approximation of r within 10^-n.
Take the resulting integer and divide by 10^n to get the actual rational approximation.
answer is useful for because it displays a familar list of digits rather
than an unfamiliar fraction that approximate would return *)

Definition answer (n:positive) (r:CR) : Z :=
 let m := (iter_pos n _ (Pmult 10) 1%positive) in
 let (a,b) := (approximate r (1#m)%Qpos)*m in
 Zdiv a b.

(* This file illustrates how to use the computational integration *)
(* Please review RealFast.v for examples on how to compute with CR *)

(* Integrate01 requires that we integrate uniformly continuous functions.
   Therefore we cannot integerate (sin : CR -> CR), we must instead
   integrate the UniformlyContinuousFunction (sin_uc : Q --> CR). *)

Time Eval vm_compute in answer 3 (Integrate sin_uc 3 (1#2)).
(*Time Eval vm_compute in answer 3 (SimpleIntegration.integrate sin_uc 3 (1#2)%Qnn).*)
(* 1 is a bound for the absolute value of sin's fourth derivative *)
(*Time Eval vm_compute in answer 10 (SimpsonIntegration.integrate sin_uc 1 3 (1#2)%Qnn).*)

(* Integrate01 the x^2 function
Time Eval vm_compute in answer 3 (Integrate01 (uc_compose (CRpower_positive_bounded 2 (1#1)) Cunit)).
Time Eval vm_compute in answer 4 (Integrate01 (uc_compose (CRpower_positive_bounded 2 (1#1)) Cunit)).
*)
(* find the supremum of cos on [0,1] *)
Time Eval vm_compute in answer 3 (ContinuousSup01 cos_uc).

(* find the supremum of id on [0,1] *)
Time Eval vm_compute in answer 3 (ContinuousSup01 Cunit).

(* An example of an elliptic integral that cannot be solved symbolically
\int_0^1  (1-\fract{1}{4}\sin^2\phi)^{-\fract{1}{2}} d\phi *)

Definition sinsquare:= (uc_compose (CRpower_positive_bounded 2 (1#1)) sin_uc).
Definition quartersinsquare:=(uc_compose (scale (1#4)) sinsquare).
Definition body:=(uc_compose (translate 1) quartersinsquare).
Definition rootbody:=(uc_compose CRsqrt body).
Time Eval vm_compute in answer 1 (Integrate01 rootbody).


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Import Notations.
Require Import Logic.
Require Import Specif.

(** * Useful tactics *)

(** Ex falso quodlibet : a tactic for proving False instead of the current goal.
    This is just a nicer name for tactics such as [elimtype False]
    and other [cut False]. *)

Ltac exfalso := elimtype False.

(** A tactic for proof by contradiction. With contradict H,
    -   H:~A |-  B    gives       |-  A
    -   H:~A |- ~B    gives  H: B |-  A
    -   H: A |-  B    gives       |- ~A
    -   H: A |- ~B    gives  H: B |- ~A
    -   H:False leads to a resolved subgoal.
   Moreover, negations may be in unfolded forms,
   and A or B may live in Type *)

Ltac contradict H :=
  let save tac H := let x:=fresh in intro x; tac H; rename x into H
  in
  let negpos H := case H; clear H
  in
  let negneg H := save negpos H
  in
  let pospos H :=
    let A := type of H in (exfalso; revert H; try fold (~A))
  in
  let posneg H := save pospos H
  in
  let neg H := match goal with
   | |- (~_) => negneg H
   | |- (_->False) => negneg H
   | |- _ => negpos H
  end in
  let pos H := match goal with
   | |- (~_) => posneg H
   | |- (_->False) => posneg H
   | |- _ => pospos H
  end in
  match type of H with
   | (~_) => neg H
   | (_->False) => neg H
   | _ => (elim H;fail) || pos H
  end.

(* To contradict an hypothesis without copying its type. *)

Ltac absurd_hyp H :=
  idtac "absurd_hyp is OBSOLETE: use contradict instead.";
  let T := type of H in
  absurd T.

(* A useful complement to contradict. Here H:A while G allows concluding ~A *)

Ltac false_hyp H G :=
  let T := type of H in absurd T; [ apply G | assumption ].

(* A case with no loss of information. *)

Ltac case_eq x := generalize (eq_refl x); pattern x at -1; case x.

(* use either discriminate or injection on a hypothesis *)

Ltac destr_eq H := discriminate H || (try (injection H as H)).

(* Similar variants of destruct *)

Tactic Notation "destruct_with_eqn" constr(x) :=
  destruct x eqn:?.
Tactic Notation "destruct_with_eqn" ident(n) :=
  try intros until n; destruct n eqn:?.
Tactic Notation "destruct_with_eqn" ":" ident(H) constr(x) :=
  destruct x eqn:H.
Tactic Notation "destruct_with_eqn" ":" ident(H) ident(n) :=
  try intros until n; destruct n eqn:H.

(** Break every hypothesis of a certain type *)

Ltac destruct_all t :=
 match goal with
  | x : t |- _ => destruct x; destruct_all t
  | _ => idtac
 end.

(* Rewriting in all hypothesis several times everywhere *)

Tactic Notation "rewrite_all" constr(eq) := repeat rewrite eq in *.
Tactic Notation "rewrite_all" "<-" constr(eq) := repeat rewrite <- eq in *.

(** Tactics for applying equivalences.

The following code provides tactics "apply -> t", "apply <- t",
"apply -> t in H" and "apply <- t in H". Here t is a term whose type
consists of nested dependent and nondependent products with an
equivalence A <-> B as the conclusion. The tactics with "->" in their
names apply A -> B while those with "<-" in the name apply B -> A. *)

(* The idea of the tactics is to first provide a term in the context
whose type is the implication (in one of the directions), and then
apply it. The first idea is to produce a statement "forall ..., A ->
B" (call this type T) and then do "assert (H : T)" for a fresh H.
Thus, T can be proved from the original equivalence and then used to
perform the application. However, currently in Ltac it is difficult
to produce such T from the original formula.

Therefore, we first pose the original equivalence as H. If the type of
H is a dependent product, we create an existential variable and apply
H to this variable. If the type of H has the form C -> D, then we do a
cut on C. Once we eliminate all products, we split (i.e., destruct)
the conjunction into two parts and apply the relevant one. *)

Ltac find_equiv H :=
let T := type of H in
lazymatch T with
| ?A -> ?B =>
  let H1 := fresh in
  let H2 := fresh in
  cut A;
  [intro H1; pose proof (H H1) as H2; clear H H1;
   rename H2 into H; find_equiv H |
   clear H]
| forall x : ?t, _ =>
  let a := fresh "a" with
      H1 := fresh "H" in
    evar (a : t); pose proof (H a) as H1; unfold a in H1;
    clear a; clear H; rename H1 into H; find_equiv H
| ?A <-> ?B => idtac
| _ => fail "The given statement does not seem to end with an equivalence."
end.

Ltac bapply lemma todo :=
let H := fresh in
  pose proof lemma as H;
  find_equiv H; [todo H; clear H | .. ].

Tactic Notation "apply" "->" constr(lemma) :=
bapply lemma ltac:(fun H => destruct H as [H _]; apply H).

Tactic Notation "apply" "<-" constr(lemma) :=
bapply lemma ltac:(fun H => destruct H as [_ H]; apply H).

Tactic Notation "apply" "->" constr(lemma) "in" hyp(J) :=
bapply lemma ltac:(fun H => destruct H as [H _]; apply H in J).

Tactic Notation "apply" "<-" constr(lemma) "in" hyp(J) :=
bapply lemma ltac:(fun H => destruct H as [_ H]; apply H in J).

(** An experimental tactic simpler than auto that is useful for ending
    proofs "in one step" *)

Ltac easy :=
  let rec use_hyp H :=
    match type of H with
    | _ /\ _ => exact H || destruct_hyp H
    | _ => try solve [inversion H]
    end
  with do_intro := let H := fresh in intro H; use_hyp H
  with destruct_hyp H := case H; clear H; do_intro; do_intro in
  let rec use_hyps :=
    match goal with
    | H : _ /\ _ |- _  => exact H || (destruct_hyp H; use_hyps)
    | H : _ |- _ => solve [inversion H]
    | _ => idtac
    end in
  let do_atom :=
    solve [ trivial with eq_true | reflexivity | symmetry; trivial | contradiction ] in
  let rec do_ccl :=
    try do_atom;
    repeat (do_intro; try do_atom);
    solve [ split; do_ccl ] in
  solve [ do_atom | use_hyps; do_ccl ] ||
  fail "Cannot solve this goal".

Tactic Notation "now" tactic(t) := t; easy.

(** Slightly more than [easy]*)

Ltac easy' := repeat split; simpl; easy || now destruct 1.

(** A tactic to document or check what is proved at some point of a script *)

Ltac now_show c := change c.

(** Support for rewriting decidability statements *)

Set Implicit Arguments.

Lemma decide_left : forall (C:Prop) (decide:{C}+{~C}),
  C -> forall P:{C}+{~C}->Prop, (forall H:C, P (left _ H)) -> P decide.
Proof.
intros; destruct decide. apply H0. contradiction.
Qed.

Lemma decide_right : forall (C:Prop) (decide:{C}+{~C}),
  ~C -> forall P:{C}+{~C}->Prop, (forall H:~C, P (right _ H)) -> P decide.
Proof.
intros; destruct decide. contradiction. apply H0.
Qed.

Tactic Notation "decide" constr(lemma) "with" constr(H) :=
  let try_to_merge_hyps H :=
     try (clear H; intro H) ||
     (let H' := fresh H "bis" in intro H'; try clear H') ||
     (let H' := fresh in intro H'; try clear H') in
  match type of H with
  | ~ ?C => apply (decide_right lemma H); try_to_merge_hyps H
  | ?C -> False => apply (decide_right lemma H); try_to_merge_hyps H
  | _ => apply (decide_left lemma H); try_to_merge_hyps H
  end.

(** Clear an hypothesis and its dependencies *)

Tactic Notation "clear" "dependent" hyp(h) :=
 let rec depclear h :=
  clear h ||
  match goal with
   | H : context [ h ] |- _ => depclear H; depclear h
  end ||
  fail "hypothesis to clear is used in the conclusion (maybe indirectly)"
 in depclear h.

(** Revert an hypothesis and its dependencies :
    this is actually generalize dependent... *)

Tactic Notation "revert" "dependent" hyp(h) :=
 generalize dependent h.

(** Provide an error message for dependent induction that reports an import is
required to use it. Importing Coq.Program.Equality will shadow this notation
with the actual [dependent induction] tactic. *)

Tactic Notation "dependent" "induction" ident(H) :=
  fail "To use dependent induction, first [Require Import Coq.Program.Equality.]".

(** *** [inversion_sigma] *)
(** The built-in [inversion] will frequently leave equalities of
    dependent pairs.  When the first type in the pair is an hProp or
    otherwise simplifies, [inversion_sigma] is useful; it will replace
    the equality of pairs with a pair of equalities, one involving a
    term casted along the other.  This might also prove useful for
    writing a version of [inversion] / [dependent destruction] which
    does not lose information, i.e., does not turn a goal which is
    provable into one which requires axiom K / UIP.  *)

Ltac simpl_proj_exist_in H :=
  repeat match type of H with
         | context G[proj1_sig (exist _ ?x ?p)]
           => let G' := context G[x] in change G' in H
         | context G[proj2_sig (exist _ ?x ?p)]
           => let G' := context G[p] in change G' in H
         | context G[projT1 (existT _ ?x ?p)]
           => let G' := context G[x] in change G' in H
         | context G[projT2 (existT _ ?x ?p)]
           => let G' := context G[p] in change G' in H
         | context G[proj3_sig (exist2 _ _ ?x ?p ?q)]
           => let G' := context G[q] in change G' in H
         | context G[projT3 (existT2 _ _ ?x ?p ?q)]
           => let G' := context G[q] in change G' in H
         | context G[sig_of_sig2 (@exist2 ?A ?P ?Q ?x ?p ?q)]
           => let G' := context G[@exist A P x p] in change G' in H
         | context G[sigT_of_sigT2 (@existT2 ?A ?P ?Q ?x ?p ?q)]
           => let G' := context G[@existT A P x p] in change G' in H
         end.
Ltac induction_sigma_in_using H rect :=
  let H0 := fresh H in
  let H1 := fresh H in
  induction H as [H0 H1] using (rect _ _ _ _);
  simpl_proj_exist_in H0;
  simpl_proj_exist_in H1.
Ltac induction_sigma2_in_using H rect :=
  let H0 := fresh H in
  let H1 := fresh H in
  let H2 := fresh H in
  induction H as [H0 H1 H2] using (rect _ _ _ _ _);
  simpl_proj_exist_in H0;
  simpl_proj_exist_in H1;
  simpl_proj_exist_in H2.
Ltac inversion_sigma_step :=
  match goal with
  | [ H : _ = exist _ _ _ |- _ ]
    => induction_sigma_in_using H @eq_sig_rect
  | [ H : _ = existT _ _ _ |- _ ]
    => induction_sigma_in_using H @eq_sigT_rect
  | [ H : exist _ _ _ = _ |- _ ]
    => induction_sigma_in_using H @eq_sig_rect
  | [ H : existT _ _ _ = _ |- _ ]
    => induction_sigma_in_using H @eq_sigT_rect
  | [ H : _ = exist2 _ _ _ _ _ |- _ ]
    => induction_sigma2_in_using H @eq_sig2_rect
  | [ H : _ = existT2 _ _ _ _ _ |- _ ]
    => induction_sigma2_in_using H @eq_sigT2_rect
  | [ H : exist2 _ _ _ _ _ = _ |- _ ]
    => induction_sigma_in_using H @eq_sig2_rect
  | [ H : existT2 _ _ _ _ _ = _ |- _ ]
    => induction_sigma_in_using H @eq_sigT2_rect
  end.
Ltac inversion_sigma := repeat inversion_sigma_step.

(** A version of [time] that works for constrs *)

Ltac time_constr tac :=
  let eval_early := match goal with _ => restart_timer end in
  let ret := tac () in
  let eval_early := match goal with _ => finish_timing ( "Tactic evaluation" ) end in
  ret.

(** Useful combinators *)

Ltac assert_fails tac :=
  tryif tac then fail 0 tac "succeeds" else idtac.
Ltac assert_succeeds tac :=
  tryif (assert_fails tac) then fail 0 tac "fails" else idtac.
Tactic Notation "assert_succeeds" tactic3(tac) :=
  assert_succeeds tac.
Tactic Notation "assert_fails" tactic3(tac) :=
  assert_fails tac.


From Coq Require Export Ascii String NArith.
From Coq Require Import List Arith.

Import ListNotations.

Set Implicit Arguments.

#[global] Open Scope string_scope.

Infix "::" := String.String.

Fixpoint _rev_string (r s : string) : string :=
  match s with
  | "" => r
  | c :: s => _rev_string (c :: r) s
  end.

Definition rev_string : string -> string := _rev_string "".

Definition is_empty (w : string) : bool :=
  match w with
  | "" => true
  | _ => false
  end.

Fixpoint _split_on (c0 : ascii) (w s : string) : list string :=
  match s with
  | "" => if is_empty w then [] else [rev_string w]
  | c :: s =>
    if Ascii.eqb c0 c then
      if is_empty w then _split_on c0 w s else rev_string w :: _split_on c0 "" s
    else
      _split_on c0 (c :: w) s
  end.

(* Drops empty words! *)
Definition split_on (c0 : ascii) : string -> list string := _split_on c0 "".

Definition words : string -> list string := split_on " ".
Definition lines : string -> list string := split_on "010".

Definition input : string -> list string := lines.

Definition example := input
"[({(<(())[]>[[{[]{<()<>>
[(()[<>])]({[<{<<[]>>(
{([(<{}[<>[]}>{[]{[(<()>
(((({<>}<{<{<>}{[]{[]{}
[[<[([]))<([[{}[[()]]]
[{[{({}]{}}([{[{{{}}([]
{<[[]]>}<{[{[{[]{()[[[]
[<(<(<(<{}))><([]([]()
<{([([[(<>()){}]>(<<{{
<{([{{}}[<[[[<>{}]]]>[]]".

Inductive Result : Type :=
| Illegal (c : ascii)
| Valid (z : list ascii)
.

Definition bra_cket (bra : ascii) : ascii :=
  (if bra =? "(" then ")"
   else if bra =? "[" then "]"
   else if bra =? "{" then "}"
   else if bra =? "<" then ">"
   else "?")%char.

Definition cket_bra (cket : ascii) : ascii :=
  (if cket =? ")" then "("
   else if cket =? "]" then "["
   else if cket =? "}" then "{"
   else if cket =? ">" then "<"
  else "?")%char.

Fixpoint _check (z : list ascii) (s : string) : Result :=
  match s with
  | "" => Valid z
  | c :: s =>
    if ((c =? "(") || (c =? "[") || (c =? "{") || (c =? "<"))%char%bool then
      _check (c :: z) s
    else
      match z with
      | (cz :: z)%list => if (cket_bra c =? cz)%char then _check z s else Illegal c
      | _ => Illegal c
      end
  end.

Definition check := _check [].

Definition sum_with {A} (f : A -> N) : list A -> N :=
  fold_right (fun x => N.add (f x)) 0%N.

Definition score (r : Result) : N :=
  match r with
  | Valid _ => 0
  | Illegal c =>
    if c =? ")" then 3
    else if c =? "]" then 57
    else if c =? "}" then 1197
    else if c =? ">" then 25137
    else 0 (* Should not happen *)
  end%char%N.

Definition solve : list string -> N :=
  sum_with (fun l => score (check l)).

(* Compute solve example. *)

Definition score2 (z : list ascii) : N :=
  fold_left (fun a c =>
    5 * a
    + if c =? "(" then 1
      else if c =? "[" then 2
      else if c =? "{" then 3
      else if c =? "<" then 4
      else 0)%char%N z 0%N.

Fixpoint minimum1 (x : N) (xs : list N) : N :=
  match xs with
  | [] => x
  | y :: xs => minimum1 (if (x <=? y)%N then x else y) xs
  end%list.

Definition minimum (xs : list N) : option N :=
  match xs with
  | [] => None
  | x :: xs => Some (minimum1 x xs)
  end%list.

Fixpoint _split (x : N) (l r xs : list N) : list N * list N :=
  match xs with
  | [] => (l, r)
  | y :: xs =>
    if (y <=? x)%N then _split x (y :: l) r xs else _split x l (y :: r) xs
  end%list.

Definition split (x : N) (xs : list N) := _split x [] [] xs.

Fixpoint kth (fuel : list N) (k : nat) (xs : list N) : option N :=
  match fuel with
  | [] => None
  | _ :: fuel =>
    match xs with
    | [] => None
    | x :: xs =>
      let '(l, r) := split x xs in
      let nl := length l in
      match Nat.compare k nl with
      | Eq => Some x
      | Lt => kth fuel k l
      | Gt => kth fuel (k - nl - 1) r
      end
    end
  end%list.

Definition median (xs : list N) : option N :=
  kth xs (Nat.div2 (length xs)) xs.

Definition dummydefault (x : option N) : N :=
  match x with
  | Some x => x
  | None => 0
  end.

Fixpoint map_filter {A B} (f : A -> option B) (xs : list A) : list B :=
  match xs with
  | [] => []
  | x :: xs =>
    match f x with
    | None => map_filter f xs
    | Some y => y :: map_filter f xs
    end
  end%list.

Definition unValid (r : Result) : option (list ascii) :=
  match r with
  | Illegal _ => None
  | Valid z => Some z
  end.

Definition solve2 (xs : list string) : N :=
  dummydefault (median (map score2 (map_filter (fun l => unValid (check l)) xs))).

(* Compute solve2 example. *)

(* [solve12] factors the common logic of [check] in [solve] and [solve2]. *)
Definition solve12 (xs : list string) : N * N :=
  let xs := map check xs in
  (sum_with score xs, dummydefault (median (map score2 (map_filter unValid xs)))).

(**)

Lemma sum_with_map {A B} (f : A -> B) (g : B -> N) xs
  : sum_with g (map f xs) = sum_with (fun x => g (f x)) xs.
Proof.
  unfold sum_with; generalize 0%N.
  induction xs; intros; cbn; congruence.
Qed.

Lemma map_filter_map {A B C} (f : A -> B) (g : B -> option C) xs
  : map_filter g (map f xs) = map_filter (fun x => g (f x)) xs.
Proof.
  induction xs as [ | x xs IH ]; cbn; [ | destruct (g (f x))]; cbn; congruence.
Qed.

Lemma solve12Correct xs : solve12 xs = (solve xs, solve2 xs).
Proof.
  unfold solve12; cbn. rewrite sum_with_map, map_filter_map. reflexivity.
Qed.

(**)

(* Correctness of [check] *)

(*
Soundness and completeness.

Soundness: If [check s] returns [Valid z], then the input [s] can be completed
into a well-bracketed string, using the stack [z], [s ++ destack z].

Theorem check_sound s z : check s = Valid z -> wellbracketed (s ++ destack z).

Completeness: If [check s] returns [Illegal c], then [c] is the earliest character of [s]
such that the prefix before [c] is still completeable to a well-bracketed string, but not any
completion after [c] (including [s] itself).

Theorem check_complete s c
  : check s = Illegal c ->
    exists t u, s = t ++ c :: u
      /\ (exists v, wellbracketed (t ++ v))
      /\ forall u', ~wellbracketed (t ++ c :: u').
*)

Lemma append_assoc (s t u : string) : (s ++ t) ++ u = s ++ (t ++ u).
Proof.
  induction s; cbn; congruence.
Qed.

Lemma append_empty_r (s : string) : (s ++ "") = s.
Proof.
  induction s; cbn; congruence.
Qed.

Lemma append_cons_r (s : string) (c : ascii) (t : string) : (s ++ c :: "") ++ t = (s ++ c :: t).
Proof.
  induction s; cbn; congruence.
Qed.

Create HintDb wb.

Inductive brackets : ascii -> ascii -> Prop :=
| brackets_Par : brackets "(" ")"
| brackets_Squ : brackets "[" "]"
| brackets_Bra : brackets "{" "}"
| brackets_Ang : brackets "<" ">"
.
#[global] Hint Constructors brackets : wb.

Inductive wellbracketed : string -> Prop :=
| wellbracketed_empty : wellbracketed ""
| wellbracketed_step bra cket s t
  : brackets bra cket -> wellbracketed s -> wellbracketed t -> wellbracketed (bra :: s ++ cket :: t)
.
#[global] Hint Constructors wellbracketed : wb.

Lemma wellbracketed_app s t : wellbracketed s -> wellbracketed t -> wellbracketed (s ++ t).
Proof.
  revert t; induction 1; intros; cbn; auto.
  rewrite append_assoc; constructor; auto.
Qed.
#[export] Hint Resolve wellbracketed_app : wb.

Ltac spliteq :=
  lazymatch goal with
  | [ |- context [ (?lhs =? ?rhs)%char ] ] => destruct (Ascii.eqb_spec lhs rhs)
  end.

Lemma _check_adequate s : wellbracketed s -> forall t z, _check z (s ++ t) = _check z t.
Proof.
  induction 1.
  - reflexivity.
  - cbn [_check]; intros; cbn; destruct H; cbn.
    all: rewrite append_assoc; cbn.
    all: rewrite IHwellbracketed1; cbn.
    all: apply IHwellbracketed2.
Qed.

Theorem check_adequate s : wellbracketed s -> check s = Valid [].
Proof.
  rewrite <- (append_empty_r s) at 2.
  exact (fun H => _check_adequate H _ _).
Qed.

Inductive unstack : list ascii -> string -> Prop :=
| unstack_nil s : wellbracketed s -> unstack [] s
| unstack_cons bra cket z t s
  : brackets bra cket -> unstack z t -> wellbracketed s -> unstack (bra :: z) (t ++ bra :: s)
.
#[export] Hint Constructors unstack : wb.

Lemma extend_unstack z t s : unstack z t -> wellbracketed s -> unstack z (t ++ s).
Proof.
  intros [].
  - constructor. apply wellbracketed_app; auto.
  - rewrite append_assoc. cbn; econstructor; eauto. apply wellbracketed_app; auto.
Qed.

Lemma cket_bra_cket bra cket
  : cket_bra cket = bra -> bra <> "?"%char -> bra_cket bra = cket.
Proof.
  unfold cket_bra; repeat (spliteq; cbn); intros; subst; reflexivity + contradiction.
Qed.

Lemma _check_sound z z' t s : unstack z t -> _check z s = Valid z' -> unstack z' (t ++ s).
Proof.
  revert z t.
  induction s; intros z t Hz.
  - rewrite append_empty_r; cbn; congruence.
  - cbn [_check]; repeat (spliteq; cbn [orb]); subst.
    1,2,3,4: rewrite <- append_cons_r; apply IHs.
    1,2,3,4: econstructor; eauto with wb.
    all: destruct Hz; try discriminate.
    all: destruct H; cbn; spliteq; cbn; try discriminate.
    all: apply cket_bra_cket in e; [ subst | discriminate ].
    all: rewrite <- append_cons_r; apply IHs.
    all: rewrite append_assoc; cbn.
    all: apply extend_unstack; eauto with wb.
Qed.

Fixpoint destack (z : list ascii) : string :=
  match z with
  | nil => ""
  | (c :: z)%list => bra_cket c :: destack z
  end.

Definition destack_unstack z t : unstack z t -> forall s, wellbracketed s -> wellbracketed (t ++ s ++ destack z).
Proof.
  induction 1; cbn; intros.
  - rewrite append_empty_r; apply wellbracketed_app; auto.
  - rewrite append_assoc; destruct H; cbn.
    all: rewrite <- (append_assoc s), <- (append_cons_r (s ++ _)); change (?c :: ?s ++ ?t) with ((c :: s) ++ t).
    all: apply IHunstack.
    all: eauto with wb.
Qed.

Theorem check_sound s z : check s = Valid z -> wellbracketed (s ++ destack z).
Proof.
  intros H; eapply destack_unstack with (s := "").
  - eapply _check_sound with (t := ""); eauto with wb.
  - eauto with wb.
Qed.

Lemma check_prefix s t z : check (s ++ t) = Valid z -> exists z', check s = Valid z'.
Proof.
  unfold check; generalize (@nil ascii).
  induction s; cbn [check _check String.append]; [ eauto | ].
  repeat (spliteq; cbn [orb]); subst; try auto.
  intros []; [ discriminate | ].
  spliteq; [ | discriminate].
  apply IHs.
Qed.

Lemma ex_f {A B} (f : A -> B) (P : B -> Prop) : ex (fun x => P (f x)) -> ex P.
Proof.
  intros [x H]; exists (f x); exact H.
Qed.

Lemma _check_legit z s c
  : _check z s = Illegal c ->
    exists t u, s = t ++ c :: u /\ _check z (t ++ c :: "") = Illegal c /\ exists z', _check z t = Valid z'.
Proof.
  revert z; induction s as [ | cs s IH ]; cbn; [ discriminate | ].
  intros z Hz.
  lazymatch goal with
  | [ |- ex ?P ] =>
    let P' := match eval pattern c in P with
      | (?P' _) => P'
      end in
    enough (HH : (exists t, P (cs :: t)) \/ (c = cs /\ P' cs ""))
      by (destruct HH as [[t HH] | [-> HH]]; [exists (cs :: t) | exists ""]; exact HH)
  end.
  cbn. revert Hz.
  repeat (spliteq; cbn [orb]).
  1,2,3,4: left; specialize (IH _ Hz); destruct IH as (t & u & ? & ?); exists t, u; split; congruence.
  destruct z.
  - injection 1; intros <-; right; eauto 6.
  - spliteq; [ | injection 1; intros <-; right; eauto 6 ].
    left; specialize (IH _ Hz).
    destruct IH as (t & u & ? & ?). exists t, u; split; congruence.
Qed.

Lemma check_legit s c
  : check s = Illegal c ->
    exists t u, s = t ++ c :: u /\ check (t ++ c :: "") = Illegal c /\ exists z', check t = Valid z'.
Proof.
  apply _check_legit.
Qed.

Theorem check_complete s c
  : check s = Illegal c ->
    exists t u, s = t ++ c :: u
      /\ (exists v, wellbracketed (t ++ v))
      /\ forall u', ~wellbracketed (t ++ c :: u').
Proof.
  intros H; destruct (check_legit _ H) as (t & u & Hs & Ht & z' & Hz').
  exists t, u; split; [exact Hs | split ].
  - eexists; revert Hz'; apply check_sound.
  - intros u' H'.
    apply check_adequate in H'.
    rewrite <- append_cons_r in H'.
    apply check_prefix in H'.
    destruct H' as [? H']; congruence.
Qed.


Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import Coq.ZArith.ZArith.
Require Import Coq.NArith.NArith.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Program.Program.
Require Import Coq.Numbers.Natural.Peano.NPeano Util.NatUtil.
Require Import Coq.micromega.Psatz.
Require Import Coq.Bool.Bool.

Require Import Crypto.Util.Bool.
Require Import Crypto.Util.NatUtil.
Require Import Crypto.Util.ZUtil.
Require Import Crypto.Util.Tactics.
Require Import Crypto.Util.Sigma.

Require Import Bedrock.Word.
Require Import Bedrock.Nomega.

Require Import Crypto.Util.FixCoqMistakes.

Local Open Scope nat_scope.

Create HintDb pull_wordToN discriminated.
Create HintDb push_wordToN discriminated.
Create HintDb pull_ZToWord discriminated.
Create HintDb push_ZToWord discriminated.

Hint Extern 1 => autorewrite with pull_wordToN in * : pull_wordToN.
Hint Extern 1 => autorewrite with push_wordToN in * : push_wordToN.
Hint Extern 1 => autorewrite with pull_ZToWord in * : pull_ZToWord.
Hint Extern 1 => autorewrite with push_ZToWord in * : push_ZToWord.

Module Word.
  Fixpoint weqb_hetero sz1 sz2 (x : word sz1) (y : word sz2) : bool :=
    match x, y with
    | WO, WO => true
    | WO, _ => false
    | WS b _ x', WS b' _ y'
      => eqb b b' && @weqb_hetero _ _ x' y'
    | WS _ _ _, _
      => false
    end%bool.
  Global Arguments weqb_hetero {_ _} _ _.
  Theorem weqb_hetero_true_iff : forall sz1 x sz2 y,
      @weqb_hetero sz1 sz2 x y = true <-> exists pf : sz1 = sz2, eq_rect _ word x _ pf = y.
  Proof.
    induction x; intros sz2 y; (split; [ destruct y | ]);
      repeat first [ progress simpl
                   | intro
                   | congruence
                   | exists eq_refl
                   | progress destruct_head ex
                   | progress destruct_head bool
                   | progress subst
                   | progress split_andb
                   | match goal with
                     | [ IHx : forall sz2 y, weqb_hetero _ y = true <-> _, H : weqb_hetero _ _ = true |- _ ]
                       => apply IHx in H
                     | [ IHx : forall sz2 y, weqb_hetero _ y = true <-> _ |- weqb_hetero ?x ?x = true ]
                       => apply IHx
                     end ].
  Defined.
  (* oh, the hoops I jump through to make this transparent... *)
  Theorem weqb_hetero_homo_true_iff : forall sz x y,
      @weqb_hetero sz sz x y = true <-> x = y.
  Proof.
    etransitivity; [ apply weqb_hetero_true_iff | ].
    split; [ intros [pf H] | intro ]; try (subst y; exists eq_refl; reflexivity).
    revert y H; induction x as [|b n x IHx]; intros.
    { subst y;
        refine match pf in (_ = z)
                     return match z return 0 = z -> Prop with
                            | 0 => fun pf => WO = eq_rect 0 word WO 0 pf
                            | _ => fun pf => True
                            end pf
               with
               | eq_refl => eq_refl
               end. }
    { revert x y H IHx.
      refine (match pf in _ = Sn
                    return match Sn return S n = Sn -> Prop with
                           | 0 => fun _ => True
                           | S n' => fun pf =>
                                       forall (pfn : n = n')
                                              (x : word n)
                                              (y : word (S n'))
                                              (H : eq_rect (S n) word (WS b x) (S n') pf = y)
                                              (IHx : forall (pf : n = n') (y : word n'), eq_rect n word x n' pf = y -> eq_rect n word x n' pfn = y),
                                         WS b (eq_rect n word x n' pfn) = y
                           end pf
              with
              | eq_refl
                => fun pfn x y H IHx
                   => eq_trans
                        (f_equal2 (fun b => @WS b _)
                                  (f_equal (@whd _) H)
                                  (IHx eq_refl (wtl y) (f_equal (@wtl _) H)))
                        _
              end eq_refl).
      refine match y in word Sn return match Sn return word Sn -> Prop with
                                       | 0 => fun _ => True
                                       | S n => fun y => WS (whd y) (wtl y) = y
                                       end y
             with
             | WS _ _ _ => eq_refl
             | _ => I
             end. }
  Defined.
End Word.

(* Utility Tactics *)

Ltac word_util_arith := omega.

Ltac destruct_min :=
  match goal with
  | [|- context[Z.min ?a ?b]] =>
    let g := fresh in
    destruct (Z.min_dec a b) as [g|g]; rewrite g; clear g
  end.

Ltac destruct_max :=
  match goal with
  | [|- context[Z.max ?a ?b]] =>
    let g := fresh in
    destruct (Z.max_dec a b) as [g|g]; rewrite g; clear g
  end.

Ltac shatter a :=
  let H := fresh in
  pose proof (shatter_word a) as H; simpl in H;
    try rewrite H in *; clear H.

Section Natural.
  Definition Nge_dec (x y: N): {N.ge x y} + {N.lt x y}.
    refine (
      let c := (x ?= y)%N in
      match c as c' return c = c' -> _ with
      | Lt => fun _ => right _
      | _ => fun _ => left _
      end eq_refl); abstract (
        unfold c in *; unfold N.lt, N.ge;
        repeat match goal with
        | [ H: (_ ?= _)%N = _ |- _] =>
          rewrite H; intuition; try inversion H
        | [ H: Eq = _ |- _] => inversion H
        | [ H: Gt = _ |- _] => inversion H
        | [ H: Lt = _ |- _] => inversion H
        end).
  Defined.

  Lemma N_ge_0: forall x: N, (0 <= x)%N.
  Proof.
    intro x0; unfold N.le.
    pose proof (N.compare_0_r x0) as H.
    rewrite N.compare_antisym in H.
    induction x0; simpl in *;
      intro V; inversion V.
  Qed.

  Lemma of_nat_lt: forall x b, (x < b)%nat <-> (N.of_nat x < N.of_nat b)%N.
  Proof.
    intros x b; split; intro H.

    - unfold N.lt; rewrite N2Nat.inj_compare.
      repeat rewrite Nat2N.id.
      apply nat_compare_lt in H.
      intuition.

    - unfold N.lt in H; rewrite N2Nat.inj_compare in H.
      repeat rewrite Nat2N.id in H.
      apply nat_compare_lt in H.
      intuition.
  Qed.
End Natural.

Section Pow2.
  Lemma pow2_id : forall n, pow2 n = 2 ^ n.
  Proof.
    induction n; intros; simpl; auto.
  Qed.

  Lemma Zpow_pow2 : forall n, pow2 n = Z.to_nat (2 ^ (Z.of_nat n)).
  Proof.
    induction n; intros; auto.
    simpl pow2.
    rewrite Nat2Z.inj_succ.
    rewrite Z.pow_succ_r by apply Zle_0_nat.
    rewrite untimes2.
    rewrite Z2Nat.inj_mul by (try apply Z.pow_nonneg; omega).
    rewrite <- IHn.
    auto.
  Qed.

  Lemma Npow2_gt0 : forall x, (0 < Npow2 x)%N.
  Proof.
    intros; induction x.

    - simpl; apply N.lt_1_r; intuition.

    - replace (Npow2 (S x)) with (2 * (Npow2 x))%N by intuition.
        apply (N.lt_0_mul 2 (Npow2 x)); left; split; apply N.neq_0_lt_0.

        + intuition; inversion H.

        + apply N.neq_0_lt_0 in IHx; intuition.
  Qed.

  Lemma Npow2_ge1 : forall x, (1 <= Npow2 x)%N.
  Proof.
    intro x.
    pose proof (Npow2_gt0 x) as Z.
    apply N.lt_pred_le; simpl.
    assumption.
  Qed.

  Lemma Npow2_N: forall n, Npow2 n = (2 ^ N.of_nat n)%N.
  Proof.
    induction n.

    - simpl; intuition.

    - rewrite Nat2N.inj_succ.
      rewrite N.pow_succ_r; [|apply N_ge_0].
      rewrite <- IHn.
      simpl; intuition.
  Qed.

  Lemma Npow2_Zlog2 : forall x n,
      (Z.log2 (Z.of_N x) < Z.of_nat n)%Z
   -> (x < Npow2 n)%N.
  Proof.
    intros.
    apply N2Z.inj_lt.
    rewrite Npow2_N, N2Z.inj_pow, nat_N_Z.
    destruct (N.eq_dec x 0%N) as [e|e].

    - rewrite e.
        apply Z.pow_pos_nonneg; [cbv; reflexivity|apply Nat2Z.is_nonneg].

    - apply Z.log2_lt_pow2; [|assumption].
        apply N.neq_0_lt_0, N2Z.inj_lt in e.
        assumption.
  Qed.

  Lemma Npow2_ordered: forall n m, (n <= m)%nat -> (Npow2 n <= Npow2 m)%N.
  Proof.
    induction n; intros m H; try rewrite Npow2_succ.

    - simpl; apply Npow2_ge1.

    - induction m; try rewrite Npow2_succ.

      + inversion H.

      + assert (n <= m)%nat as H0 by omega.
        apply IHn in H0.
        apply N.mul_le_mono_l.
        assumption.
  Qed.
End Pow2.

Section WordToN.
  Lemma wordToN_NToWord_idempotent : forall sz n, (n < Npow2 sz)%N ->
    wordToN (NToWord sz n) = n.
  Proof.
    intros.
    rewrite wordToN_nat, NToWord_nat.
    rewrite wordToNat_natToWord_idempotent; rewrite Nnat.N2Nat.id; auto.
  Qed.

  Lemma NToWord_wordToN : forall sz w, NToWord sz (wordToN w) = w.
  Proof.
    intros.
    rewrite wordToN_nat, NToWord_nat, Nnat.Nat2N.id.
    apply natToWord_wordToNat.
  Qed.

  Lemma wordToN_zero: forall w, wordToN (wzero w) = 0%N.
  Proof.
    intros.
    unfold wzero; rewrite wordToN_nat.
    rewrite wordToNat_natToWord_idempotent; simpl; intuition.
    apply Npow2_gt0.
  Qed.

  Fixpoint wbit {n} (x: word n) (k: nat): bool :=
    match n as n' return word n' -> bool with
    | O => fun _ => false
    | S m => fun x' =>
      match k with
      | O => (whd x')
      | S k' => wbit (wtl x') k'
      end
    end x.

  Lemma wbit_large {n} (x: word n) (k: nat)
    : n <= k -> wbit x k = false.
  Proof.
    revert k; induction x, k; intro H; simpl; try reflexivity; try omega.
    apply IHx; omega.
  Qed.

  Lemma wbit_inj_iff {n} (x y : word n)
    : (forall k, wbit x k = wbit y k) <-> x = y.
  Proof.
    split; intro H; subst; try reflexivity.
    induction x.
    { revert dependent y.
      let G := match goal with |- forall y, @?G y => G end in
      intro y;
        refine (match y in word n return match n with
                                         | 0 => G
                                         | _ => fun _ => True
                                         end y
                with
                | WO => fun _ => eq_refl
                | _ => I
                end). }
    { move y at top; revert dependent n.
      let G := match goal with |- forall n y, @?G n y => G end in
      intros n y;
        refine (match y in word n return match n with
                                         | 0 => fun _ => True
                                         | S n' => G n'
                                         end y
                with
                | WO => I
                | _ => _
                end).
      intros x H IH.
      pose proof (H 0) as H0; simpl in H0; subst; f_equal.
      apply IH; intro k; specialize (H (S k)); apply H. }
  Qed.

  Lemma wbit_inj_iff_lt {n} (x y : word n)
    : (forall k, k < n -> wbit x k = wbit y k) <-> x = y.
  Proof.
    rewrite <- wbit_inj_iff.
    split; intros H k; specialize (H k);
      destruct (le_lt_dec n k);
      rewrite ?wbit_large by assumption;
      auto.
  Qed.

  Lemma wordToN_testbit: forall {n} (x: word n) k,
    N.testbit (wordToN x) k = wbit x (N.to_nat k).
  Proof.
    assert (forall x: N, match x with
            | 0%N => 0%N
            | N.pos q => N.pos (q~0)%positive
            end = N.double x) as kill_match by (
      induction x; simpl; intuition).

    induction n; intros.

    - shatter x; simpl; intuition.

    - revert IHn; rewrite <- (N2Nat.id k).
      generalize (N.to_nat k) as k'; intros; clear k.
      rewrite Nat2N.id in *.

      induction k'.

      + clear IHn; induction x; simpl; intuition.
        destruct (wordToN x), b; simpl; intuition.

      + clear IHk'.
        shatter x; simpl.

        rewrite N.succ_double_spec; simpl.

        rewrite kill_match.
        replace (N.pos (Pos.of_succ_nat k'))
           with (N.succ (N.of_nat k'))
             by (rewrite <- Nat2N.inj_succ;
                 simpl; intuition).

        rewrite N.double_spec.
        replace (N.succ (2 * wordToN (wtl x)))
           with (2 * wordToN (wtl x) + 1)%N
             by nomega.

        destruct (whd x);
          try rewrite N.testbit_odd_succ;
          try rewrite N.testbit_even_succ;
          try abstract (
            unfold N.le; simpl;
            induction (N.of_nat k'); intuition;
            try inversion H);
          rewrite IHn;
          rewrite Nat2N.id;
          reflexivity.
  Qed.

  Lemma wbit_NToWord {sz} k v
    : wbit (NToWord sz v) k = if Nat.ltb k sz
                              then N.testbit v (N.of_nat k)
                              else false.
  Proof.
    revert k v; induction sz, k; intros; try reflexivity.
    { destruct v as [|p]; simpl; try reflexivity.
      destruct p; simpl; reflexivity. }
    { pose proof (fun v k => IHsz k (Npos v)) as IHszp.
      pose proof (fun k => IHsz k 0%N) as IHsz0.
      destruct v as [|p]; simpl in *.
      { rewrite IHsz0; break_match; reflexivity. }
      { destruct p; simpl in *; try (rewrite IHsz0; break_match; reflexivity);
          rewrite IHszp, N.pos_pred_spec;
          change (N.pos (Pos.of_succ_nat k)) with (N.of_nat (S k));
          rewrite <- Nat2N.inj_pred; simpl;
            reflexivity. } }
  Qed.

  Lemma NToWord_wordToN_NToWord : forall sz1 sz2 w,
      sz2 <= sz1 -> NToWord sz2 (wordToN (NToWord sz1 w)) = NToWord sz2 w.
  Proof.
    intros.
    apply wbit_inj_iff_lt; intros k Hlt.
    rewrite !wbit_NToWord, wordToN_testbit, wbit_NToWord, Nat2N.id.
    break_match; try reflexivity;
      repeat match goal with
             | [ H : (_ <? _) = true |- _ ] => apply Nat.ltb_lt in H
             | [ H : (_ <? _) = false |- _ ] => apply Nat.ltb_ge in H
             | _ => omega
             end.
  Qed.

  Lemma wordToN_NToWord_wordToN : forall sz1 sz2 w, (sz1 <= sz2)%nat -> wordToN (NToWord sz2 (@wordToN sz1 w)) = wordToN w.
  Proof.
    intros sz1 sz2 w H.
    apply N.bits_inj; intro k.
    rewrite !wordToN_testbit, !wbit_NToWord, wordToN_testbit, N2Nat.id.
    destruct (N.to_nat k <? sz2) eqn:H'; try reflexivity.
    apply Nat.ltb_ge in H'.
    rewrite wbit_large by omega.
    reflexivity.
  Qed.

  Lemma wordToN_split1: forall {n m} x,
    wordToN (@split1 n m x) = N.land (wordToN x) (wordToN (wones n)).
  Proof.
    intros.

    pose proof (Word.combine_split _ _ x) as C; revert C.
    generalize (split1 n m x) as a, (split2 n m x) as b.
    intros a b C; rewrite <- C; clear C x.

    apply N.bits_inj_iff; unfold N.eqf; intro x.
    rewrite N.land_spec.
    repeat rewrite wordToN_testbit.
    revert x a b.

    induction n, m; intros;
      shatter a; shatter b;
      induction (N.to_nat x) as [|n0];
      try rewrite <- (Nat2N.id n0);
      try rewrite andb_false_r;
      try rewrite andb_true_r;
      simpl; intuition.
  Qed.

  Lemma wordToN_split2: forall {n m} x,
    wordToN (@split2 n m x) = N.shiftr (wordToN x) (N.of_nat n).
  Proof.
    intros.

    pose proof (Word.combine_split _ _ x) as C; revert C.
    generalize (split1 n m x) as a, (split2 n m x) as b.
    intros a b C.
    rewrite <- C; clear C x.

    apply N.bits_inj_iff; unfold N.eqf; intro x;
      rewrite N.shiftr_spec;
      repeat rewrite wordToN_testbit;
      try apply N_ge_0.

    revert x a b.
    induction n, m; intros;
      shatter a;
      try apply N_ge_0.

    - simpl; intuition.

    - replace (x + N.of_nat 0)%N with x by nomega.
      simpl; intuition.

    - rewrite (IHn x (wtl a) b).
      rewrite <- (N2Nat.id x).
      repeat rewrite <- Nat2N.inj_add.
      repeat rewrite Nat2N.id; simpl.
      replace (N.to_nat x + S n) with (S (N.to_nat x + n)) by omega.
      reflexivity.

    - rewrite (IHn x (wtl a) b).
      rewrite <- (N2Nat.id x).
      repeat rewrite <- Nat2N.inj_add.
      repeat rewrite Nat2N.id; simpl.
      replace (N.to_nat x + S n) with (S (N.to_nat x + n)) by omega.
      reflexivity.
  Qed.

  Lemma wordToN_wones: forall x, wordToN (wones x) = N.ones (N.of_nat x).
  Proof.
    induction x.

    - simpl; intuition.

    - rewrite Nat2N.inj_succ.
      replace (wordToN (wones (S x))) with (2 * wordToN (wones x) + N.b2n true)%N
        by (simpl; rewrite ?N.succ_double_spec; simpl; nomega).
      replace (N.ones (N.succ _))
         with (2 * N.ones (N.of_nat x) + N.b2n true)%N.

      + rewrite IHx; nomega.

      + replace (N.succ (N.of_nat x)) with (1 + (N.of_nat x))%N by (
          rewrite N.add_comm; nomega).
        rewrite N.ones_add.
        replace (N.ones 1) with 1%N by (
          unfold N.ones; simpl; intuition).
        simpl.
        reflexivity.
  Qed.

  Tactic Notation "replaceAt1" constr(x) "with" constr(y) "by" tactic(tac) :=
    let tmp := fresh in
    set (tmp := x) at 1;
    replace tmp with y by (unfold tmp; tac);
    clear tmp.

  Lemma wordToN_combine: forall {n m} a b,
    wordToN (@Word.combine n a m b)
      = N.lxor (N.shiftl (wordToN b) (N.of_nat n)) (wordToN a).
  Proof.
    intros; symmetry.

    replaceAt1 a with (Word.split1 _ _ (Word.combine a b))
      by (apply Word.split1_combine).

    replaceAt1 b with (Word.split2 _ _ (Word.combine a b))
      by (apply Word.split2_combine).

    generalize (Word.combine a b); intro x; clear a b.

    rewrite wordToN_split1, wordToN_split2, wordToN_wones.
    generalize (wordToN x); clear x; intro x.
    apply N.bits_inj_iff; unfold N.eqf; intro k.
    rewrite N.lxor_spec.

    destruct (Nge_dec k (N.of_nat n)).

    - rewrite N.shiftl_spec_high; try apply N_ge_0;
        [|apply N.ge_le; assumption].
      rewrite N.shiftr_spec; try apply N_ge_0.
      replace (k - N.of_nat n + N.of_nat n)%N with k by nomega.
      rewrite N.land_spec, N.ones_spec_high; [|apply N.ge_le; assumption].
      induction (N.testbit x k); cbv; reflexivity.

    - rewrite N.shiftl_spec_low; try assumption; try apply N_ge_0.
      rewrite N.land_spec, N.ones_spec_low; [|nomega].
      induction (N.testbit x k); cbv; reflexivity.
  Qed.

  Lemma NToWord_equal: forall n (x y: word n),
      wordToN x = wordToN y -> x = y.
  Proof.
    intros.
    rewrite <- (NToWord_wordToN _ x).
    rewrite <- (NToWord_wordToN _ y).
    rewrite H; reflexivity.
  Qed.

  Lemma Npow2_ignore: forall {n} (x: word n),
    x = NToWord _ (wordToN x + Npow2 n).
  Proof.
    intros.
    rewrite <- (NToWord_wordToN n x) at 1.
    repeat rewrite NToWord_nat.
    rewrite N2Nat.inj_add.
    rewrite Npow2_nat.
    replace (N.to_nat (wordToN x))
       with ((N.to_nat (wordToN x) + pow2 n) - 1 * pow2 n)
         by omega.
    rewrite drop_sub; f_equal; nomega.
  Qed.
End WordToN.

Section WordBounds.
  Lemma word_size_bound : forall {n} (w: word n), (wordToN w < Npow2 n)%N.
  Proof.
    intros; pose proof (wordToNat_bound w) as B;
      rewrite of_nat_lt in B;
      rewrite <- Npow2_nat in B;
      rewrite N2Nat.id in B;
      rewrite <- wordToN_nat in B;
      assumption.
  Qed.

  Lemma wordize_plus: forall {n} (x y: word n),
       (wordToN x + wordToN y < Npow2 n)%N
    -> (wordToN x + wordToN y)%N = wordToN (x ^+ y).
  Proof.
    intros n x y H.
    pose proof (word_size_bound x) as Hbx.
    pose proof (word_size_bound y) as Hby.

    unfold wplus, wordBin.
    rewrite wordToN_NToWord_idempotent; intuition.
  Qed.

  Lemma wordize_minus: forall {n} (x y: word n),
       (wordToN x >= wordToN y)%N
    -> (wordToN x - wordToN y)%N = wordToN (x ^- y).
  Proof.
    intros n x y H.

    destruct (Nge_dec 0%N (wordToN y)). {
      unfold wminus, wneg.
      replace (wordToN y) with 0%N in * by nomega.
      replace (Npow2 n - 0)%N with (wordToN (wzero n) + Npow2 n)%N
        by (rewrite wordToN_zero; nomega).
      rewrite <- Npow2_ignore.
      rewrite wplus_comm.
      rewrite wplus_unit.
      nomega.
    }

    assert (wordToN x - wordToN y < Npow2 n)%N. {
      transitivity (wordToN x);
        try apply word_size_bound;
        apply N.sub_lt;
        [apply N.ge_le|]; assumption.
    }

    assert (wordToN x - wordToN y + wordToN y < Npow2 n)%N. {
      replace (wordToN x - wordToN y + wordToN y)%N
        with (wordToN x) by nomega;
        apply word_size_bound.
    }

    assert (x = NToWord n (wordToN x - wordToN y) ^+ y) as Hv. {
      apply NToWord_equal.
      rewrite <- wordize_plus; rewrite wordToN_NToWord_idempotent; try assumption.
      nomega.
    }

    symmetry.
    rewrite Hv at 1.
    unfold wminus.
    repeat rewrite <- wplus_assoc.
    rewrite wminus_inv.
    rewrite wplus_comm.
    rewrite wplus_unit.
    rewrite wordToN_NToWord_idempotent; try assumption.
    reflexivity.
  Qed.

  Lemma wordize_mult: forall {n} (x y: word n),
      (wordToN x * wordToN y < Npow2 n)%N
    -> (wordToN x * wordToN y)%N = wordToN (x ^* y).
  Proof.
    intros n x y H.
    pose proof (word_size_bound x) as Hbx.
    pose proof (word_size_bound y) as Hby.

    unfold wmult, wordBin.
    rewrite wordToN_NToWord_idempotent; intuition.
  Qed.

  Lemma wordize_and: forall {n} (x y: word n),
    wordToN (wand x y) = N.land (wordToN x) (wordToN y).
  Proof.
    intros.
    apply N.bits_inj_iff; unfold N.eqf; intro k.
    rewrite N.land_spec.
    repeat rewrite wordToN_testbit.
    revert x y.
    generalize (N.to_nat k) as k'.
    induction n; intros; shatter x; shatter y; simpl; [reflexivity|].
    induction k'; [reflexivity|].
    fold wand.
    rewrite IHn.
    reflexivity.
  Qed.

  Lemma wordize_or: forall {n} (x y: word n),
    wordToN (wor x y) = N.lor (wordToN x) (wordToN y).
  Proof.
    intros.
    apply N.bits_inj_iff; unfold N.eqf; intro k.
    rewrite N.lor_spec.
    repeat rewrite wordToN_testbit.
    revert x y.
    generalize (N.to_nat k) as k'; clear k.
    induction n; intros; shatter x; shatter y; simpl; [reflexivity|].
    induction k'; [reflexivity|].
    rewrite IHn.
    reflexivity.
  Qed.
End WordBounds.

Hint Rewrite NToWord_wordToN : pull_wordToN.

Lemma bound_check_nat_N : forall x n, (Z.to_nat x < 2 ^ n)%nat -> (Z.to_N x < Npow2 n)%N.
Proof.
  intros x n bound_nat.
  rewrite <- Nnat.N2Nat.id, Npow2_nat.
  replace (Z.to_N x) with (N.of_nat (Z.to_nat x)) by apply Z_nat_N.
  apply (Nat2N_inj_lt _ (pow2 n)).
  rewrite pow2_id; assumption.
Qed.

Lemma weqb_false_iff : forall sz (x y : word sz), weqb x y = false <-> x <> y.
Proof.
  split; intros.
  + intro eq_xy; apply weqb_true_iff in eq_xy; congruence.
  + case_eq (weqb x y); intros weqb_xy; auto.
    apply weqb_true_iff in weqb_xy.
    congruence.
Qed.

Definition wfirstn n {m} (w : Word.word m) {H : n <= m} : Word.word n.
  refine (Word.split1 n (m - n) (match _ in _ = N return Word.word N with
                            | eq_refl => w
                            end)); abstract omega. Defined.

Lemma combine_eq_iff {a b} (A:word a) (B:word b) C :
  combine A B = C <-> A = split1 a b C /\ B = split2 a b C.
Proof. intuition; subst; auto using split1_combine, split2_combine, combine_split. Qed.

Class wordsize_eq (x y : nat) := wordsize_eq_to_eq : x = y.
Ltac wordsize_eq_tac := cbv beta delta [wordsize_eq] in *; omega*.
Ltac gt84_abstract t := t. (* TODO: when we drop Coq 8.4, use [abstract] here *)
Hint Extern 100 (wordsize_eq _ _) => gt84_abstract wordsize_eq_tac : typeclass_instances.

Fixpoint correct_wordsize_eq (x y : nat) : wordsize_eq x y -> x = y
  := match x, y with
     | O, O => fun _ => eq_refl
     | S x', S y' => fun pf => f_equal S (correct_wordsize_eq x' y' (f_equal pred pf))
     | _, _ => fun x => x
     end.

Lemma correct_wordsize_eq_refl n pf : correct_wordsize_eq n n pf = eq_refl.
Proof.
  induction n; [ reflexivity | simpl ].
  rewrite IHn; reflexivity.
Qed.

Definition cast_word {n m} {pf:wordsize_eq n m} : word n -> word m :=
  match correct_wordsize_eq n m pf in _ = y return word n -> word y with
  | eq_refl => fun w => w
  end.

Lemma cast_word_refl {n} pf (w:word n) : @cast_word n n pf w = w.
Proof. unfold cast_word; rewrite correct_wordsize_eq_refl; reflexivity. Qed.

Lemma wordToNat_cast_word {n} (w:word n) m pf :
  wordToNat (@cast_word n m pf w) = wordToNat w.
Proof. destruct pf; rewrite cast_word_refl; trivial. Qed.

Lemma wordToN_cast_word {n} (w:word n) m pf :
  wordToN (@cast_word n m pf w) = wordToN w.
Proof. destruct pf; rewrite cast_word_refl; trivial. Qed.
Hint Rewrite @wordToN_cast_word : push_wordToN.

Import NPeano Nat.
Local Infix "++" := combine.

Definition zext_ge n {m} {pf:m <= n} (w:word m) : word n :=
  cast_word (w ++ wzero (n - m)).

Definition keeplow {b} n (w:word b) : word b :=
  wand (cast_word( wones (min b n) ++ wzero (b-n) )) w.

Definition clearlow {b} n (w:word b) : word b :=
  wand (cast_word( wzero (min b n) ++ wones (b-n) )) w.

Definition setbit {b} n {H:n < b} (w:word b) : word b :=
  wor (cast_word( wzero n ++ wones 1 ++ wzero (b-n-1) )) w.

Definition clearbit {b} n {H:n < b} (w:word b) : word b :=
  wand (cast_word( wones n ++ wzero 1 ++ wones (b-n-1) )) w.

Lemma wordToNat_wzero {n} : wordToNat (wzero n) = 0.
Proof.
  unfold wzero; induction n; simpl; try rewrite_hyp!*; omega.
Qed.

Lemma wordToNat_combine : forall {a} (wa:word a) {b} (wb:word b),
  wordToNat (wa ++ wb) = wordToNat wa + 2^a * wordToNat wb.
Proof.
  induction wa; intros; simpl; rewrite ?IHwa; break_match; nia.
Qed.

Lemma wordToNat_zext_ge {n m pf} (w:word m) : wordToNat (@zext_ge n m pf w) = wordToNat w.
Proof.
  unfold zext_ge.
  rewrite wordToNat_cast_word, wordToNat_combine, wordToNat_wzero; nia.
Qed.

Lemma bitwp_combine {a b} f (x x' : word a) (y y' : word b)
  : bitwp f x x' ++ bitwp f y y' = bitwp f (x ++ y) (x' ++ y').
Proof.
  revert x' y y'.
  induction x as [|b' n x IHx]; simpl.
  { intro x'; intros.
    refine match x' with
           | WO => _
           | _ => I
           end.
    reflexivity. }
  { intros; rewrite IHx; clear IHx; revert x.
    refine match x' in word Sn return match Sn return word Sn -> _ with
                                      | 0 => fun _ => True
                                      | S _ => fun x' => forall x, WS (f b' (whd x')) (bitwp f (x ++ y) (wtl x' ++ y')) = WS (f b' (whd (x' ++ y'))) (bitwp f (x ++ y) (wtl (x' ++ y')))
                                      end x'
           with
           | WO => I
           | WS _ _ _ => fun _ => Logic.eq_refl
           end. }
Qed.

Lemma wand_combine {a b} (x : word a) (y : word b) (z : word (a + b))
  : (x ++ y) ^& z = ((x ^& split1 _ _ z) ++ (y ^& split2 _ _ z)).
Proof.
  rewrite <- (combine_split _ _ z) at 1.
  unfold wand.
  rewrite bitwp_combine.
  reflexivity.
Qed.

Lemma wordToNat_clearlow {b} (c : nat) (x : Word.word b) :
  wordToNat (clearlow c x) = wordToNat x - (wordToNat x) mod (2^c).
Proof.
  assert (2^c <> 0) by auto with arith.
  unfold clearlow.
  match goal with
  | [ |- context[@cast_word _ _ ?pf ?w] ]
    => generalize pf
  end.
  intro H'; revert x; destruct H'; intro x; rewrite cast_word_refl.
  rewrite <- (combine_split _ _ x) at 2 3.
  rewrite wand_combine, !wordToNat_combine, wand_kill, wand_unit, wordToNat_wzero.
  repeat match goal with H := _ |- _ => subst H end. (* only needed in 8.4 *)
  let min := match type of x with word (?min _ _ + _) => min end in
  repeat match goal with
         | [ |- context[?min' b c] ]
           => progress change min' with min
         end.
  generalize (split1 _ _ x); generalize (split2 _ _ x); clear x; simpl.
  apply Min.min_case_strong; intros Hbc x0 x1;
    pose proof (wordToNat_bound x0); pose proof (wordToNat_bound x1);
      rewrite pow2_id in *.
  { assert (b - c = 0) by omega.
    assert (2^b <= 2^c) by auto using pow_le_mono_r with arith.
    generalize dependent (b - c); intros; destruct x0; try omega; [].
    simpl; rewrite mul_0_r, add_0_r.
    rewrite mod_small by omega.
    omega. }
  { rewrite !(mul_comm (2^c)), mod_add, mod_small by omega.
    lia. }
Qed.

Lemma wordToNat_keeplow {b} (c : nat) (x : Word.word b) :
  wordToNat (keeplow c x) = (wordToNat x) mod (2^c).
Proof.
  assert (2^c <> 0) by auto with arith.
  unfold keeplow.
  match goal with
  | [ |- context[@cast_word _ _ ?pf ?w] ]
    => generalize pf
  end.
  intro H'; revert x; destruct H'; intro x; rewrite cast_word_refl.
  repeat match goal with H := _ |- _ => subst H end. (* only needed in 8.4 *)
  let min := match type of x with word (?min _ _ + _) => min end in
  repeat match goal with
         | [ |- context[?min' b c] ]
           => progress change min' with min
         end.
  rewrite <- (combine_split _ _ x) at 2 3.
  rewrite wand_combine, !wordToNat_combine, wand_kill, wand_unit, wordToNat_wzero.
  generalize (split1 _ _ x); generalize (split2 _ _ x); clear x; simpl.
  apply Min.min_case_strong; intros Hbc x0 x1;
    pose proof (wordToNat_bound x0); pose proof (wordToNat_bound x1);
      rewrite pow2_id in *.
  { assert (b - c = 0) by omega.
    assert (2^b <= 2^c) by auto using pow_le_mono_r with arith.
    generalize dependent (b - c); intros; destruct x0; try omega.
    simpl; rewrite mul_0_r, add_0_r.
    rewrite mod_small by omega.
    omega. }
  { rewrite !(mul_comm (2^c)), mod_add, mod_small by omega.
    lia. }
Qed.

Lemma wordToNat_split1 : forall a b w, wordToNat (split1 a b w) = (wordToNat w) mod (2^a).
Proof.
  intro a; induction a.
  { reflexivity. }
  { simpl; intros; rewrite IHa; clear IHa.
    rewrite (shatter_word w); simpl.
    change (2^a + (2^a + 0)) with (2 * 2^a).
    rewrite (mul_comm 2 (2^a)).
    assert (2^a <> 0) by auto with arith.
    destruct (whd w); try rewrite S_mod; try rewrite mul_mod_distr_r; omega. }
Qed.

Lemma wordToNat_wfirstn : forall a b w H, wordToNat (@wfirstn a b w H) = (wordToNat w) mod (2^a).
Proof.
  unfold wfirstn.
  intros; rewrite wordToNat_split1.
  match goal with |- appcontext[match ?x with _ => _ end] => generalize x end.
  intro H'; destruct H'.
  reflexivity.
Qed.

Lemma wordeqb_Zeqb {sz} (x y : word sz) : (Z.of_N (wordToN x) =? Z.of_N (wordToN y))%Z = weqb x y.
Proof.
  match goal with |- ?LHS = ?RHS => destruct LHS eqn:HL, RHS eqn:HR end;
    repeat match goal with
           | _ => reflexivity
           | _ => progress unfold not in *
           | [ H : Z.eqb _ _ = true |- _ ] => apply Z.eqb_eq in H
           | [ |- Z.eqb _ _ = true ] => apply Z.eqb_eq
           | [ H : context[Z.of_N _ = Z.of_N _] |- _ ] => rewrite N2Z.inj_iff in H
           | [ H : wordToN _ = wordToN _ |- _ ] => apply wordToN_inj in H
           | [ H : x = y :> word _ |- _ ] => apply weqb_true_iff in H
           | [ H : ?x = false |- _ ] => progress rewrite <- H; clear H
           | _ => congruence
           | [ H : weqb _ _ = true |- _ ] => apply weqb_true_iff in H; subst
           end.
Qed.

Section Bounds.
  Local Notation bounds_2statement wop Zop := (forall {sz} (x y : word sz),
     (0 <= Zop (Z.of_N (wordToN x)) (Z.of_N (wordToN y))
  -> (Z.log2 (Zop (Z.of_N (wordToN x)) (Z.of_N (wordToN y))) < Z.of_nat sz)
  -> (Z.of_N (wordToN (wop x y)) = (Zop (Z.of_N (wordToN x)) (Z.of_N (wordToN y)))))%Z).

  Lemma wordToN_wplus : bounds_2statement (@wplus _) Z.add.
  Proof.
    intros.
    rewrite <- wordize_plus; [rewrite N2Z.inj_add; reflexivity|].
    destruct (N.eq_dec (wordToN x + wordToN y) 0%N) as [e|e];
        [rewrite e; apply Npow2_gt0|].
    apply N.neq_0_lt_0 in e.
    apply N2Z.inj_lt in e.
    apply N2Z.inj_lt.
    rewrite N2Z.inj_add in *.
    rewrite Npow2_N.
    rewrite N2Z.inj_pow.
    replace (Z.of_N 2%N) with 2%Z by auto.
    apply Z.log2_lt_pow2; [auto|].
    rewrite nat_N_Z.
    assumption.
  Qed.

  Lemma wordToN_wminus : bounds_2statement (@wminus _) Z.sub.
  Proof.
    intros sz x y H ?.
    assert (wordToN y <= wordToN x)%N. {
        apply N2Z.inj_le.
        rewrite <- (Z.add_0_l (Z.of_N (wordToN y))).
        apply Z.le_add_le_sub_r; assumption.
    }

    rewrite <- N2Z.inj_sub; [|assumption].
    rewrite <- wordize_minus; [reflexivity|apply N.le_ge; assumption].
  Qed.

  Lemma wordToN_wmult : bounds_2statement (@wmult _) Z.mul.
  Proof.
    intros.
    rewrite <- wordize_mult; [rewrite N2Z.inj_mul; reflexivity|].
    destruct (N.eq_dec (wordToN x * wordToN y) 0%N) as [e|e];
        [rewrite e; apply Npow2_gt0|].
    apply N.neq_0_lt_0 in e.
    apply N2Z.inj_lt in e.
    apply N2Z.inj_lt.
    rewrite N2Z.inj_mul in *.
    rewrite Npow2_N.
    rewrite N2Z.inj_pow.
    replace (Z.of_N 2%N) with 2%Z by auto.
    apply Z.log2_lt_pow2; [auto|].
    rewrite nat_N_Z.
    assumption.
  Qed.

  Lemma wordToN_wand : bounds_2statement (@wand _) Z.land.
  Proof.
    intros.
    rewrite wordize_and.
    apply Z.bits_inj_iff'; intros k Hpos; apply Z.le_ge in Hpos.
    rewrite Z.land_spec.
    rewrite Z2N.inj_testbit; [|apply Z.ge_le; assumption].
    rewrite N.land_spec.
    repeat (rewrite <- Z2N.inj_testbit; [|apply Z.ge_le; assumption]).
    reflexivity.
  Qed.

  Lemma wordToN_wor : bounds_2statement (@wor _) Z.lor.
  Proof.
    intros.
    rewrite wordize_or.
    apply Z.bits_inj_iff'; intros k Hpos; apply Z.le_ge in Hpos.
    rewrite Z.lor_spec.
    rewrite Z2N.inj_testbit; [|apply Z.ge_le; assumption].
    rewrite N.lor_spec.
    repeat (rewrite <- Z2N.inj_testbit; [|apply Z.ge_le; assumption]).
    reflexivity.
  Qed.
End Bounds.

Hint Rewrite @wordToN_wplus using word_util_arith : push_wordToN.
Hint Rewrite <- @wordToN_wplus using word_util_arith : pull_wordToN.

Hint Rewrite @wordToN_wminus using word_util_arith : push_wordToN.
Hint Rewrite <- @wordToN_wminus using word_util_arith : pull_wordToN.

Hint Rewrite @wordToN_wmult using word_util_arith : push_wordToN.
Hint Rewrite <- @wordToN_wmult using word_util_arith : pull_wordToN.

Hint Rewrite @wordToN_wand using word_util_arith : push_wordToN.
Hint Rewrite <- @wordToN_wand using word_util_arith : pull_wordToN.

Hint Rewrite @wordToN_wor using word_util_arith : push_wordToN.
Hint Rewrite <- @wordToN_wor using word_util_arith : pull_wordToN.

Section Updates.
  Local Notation bound n lower value upper := (
       (0 <= lower)%Z
    /\ (lower <= Z.of_N (@wordToN n value))%Z
    /\ (Z.of_N (@wordToN n value) <= upper)%Z
    /\ (Z.log2 upper < Z.of_nat n)%Z).

  Definition valid_update n lowerF valueF upperF : Prop :=
    forall lower0 value0 upper0
          lower1 value1 upper1,

       bound n lower0 value0 upper0
    -> bound n lower1 value1 upper1
    -> (0 <= lowerF lower0 upper0 lower1 upper1)%Z
    -> (Z.log2 (upperF lower0 upper0 lower1 upper1) < Z.of_nat n)%Z
    -> bound n (lowerF lower0 upper0 lower1 upper1)
                (valueF value0 value1)
                (upperF lower0 upper0 lower1 upper1).

  Local Ltac add_mono :=
    etransitivity; [| apply Z.add_le_mono_r; eassumption]; omega.

  Lemma add_valid_update: forall n,
    valid_update n
        (fun l0 u0 l1 u1 => l0 + l1)%Z
        (@wplus n)
        (fun l0 u0 l1 u1 => u0 + u1)%Z.
  Proof.
    unfold valid_update; intros until upper1; intros B0 B1 H0 H1.
    do 2 destruct B0 as [? B0], B1 as [? B1]; destruct B0, B1.
    repeat split; [add_mono| | |assumption]; (
        rewrite wordToN_wplus; [add_mono|add_mono|];
        eapply Z.le_lt_trans; [| eassumption];
        apply Z.log2_le_mono; add_mono).
  Qed.

  Local Ltac sub_mono :=
    etransitivity;
    [| apply Z.sub_le_mono_r]; eauto;
    first [ reflexivity
            | apply Z.sub_le_mono_l; assumption
            | apply Z.le_add_le_sub_l; etransitivity; [|eassumption];
            repeat rewrite Z.add_0_r; assumption].

  Lemma sub_valid_update: forall n,
    valid_update n
        (fun l0 u0 l1 u1 => l0 - u1)%Z
        (@wminus n)
        (fun l0 u0 l1 u1 => u0 - l1)%Z.
  Proof.
    unfold valid_update; intros until upper1; intros B0 B1.
    do 2 destruct B0 as [? B0], B1 as [? B1]; destruct B0, B1.
    repeat split; [sub_mono| | |assumption]; (
    rewrite wordToN_wminus; [sub_mono|omega|];
    eapply Z.le_lt_trans; [apply Z.log2_le_mono|eassumption]; sub_mono).
  Qed.

  Local Ltac mul_mono :=
    etransitivity; [|apply Z.mul_le_mono_nonneg_r];
    repeat (instantiate; first
    [ eassumption
    | reflexivity
    | apply Z.mul_le_mono_nonneg_l
    | rewrite Z.mul_0_l
    | omega]).

  Lemma mul_valid_update: forall n,
    valid_update n
        (fun l0 u0 l1 u1 => l0 * l1)%Z
        (@wmult n)
        (fun l0 u0 l1 u1 => u0 * u1)%Z.
  Proof.
    unfold valid_update; intros until upper1; intros B0 B1.
    do 2 destruct B0 as [? B0], B1 as [? B1]; destruct B0, B1.
    repeat split; [mul_mono| | |assumption]; (
        rewrite wordToN_wmult; [mul_mono|mul_mono|];
        eapply Z.le_lt_trans; [| eassumption];
        apply Z.log2_le_mono; mul_mono).
  Qed.

  Local Ltac solve_land_ge0 :=
    apply Z.land_nonneg; left; etransitivity; [|eassumption]; assumption.

  Local Ltac land_mono :=
    first [assumption | etransitivity; [|eassumption]; assumption].

  Lemma land_valid_update: forall n,
    valid_update n
        (fun l0 u0 l1 u1 => 0)%Z
        (@wand n)
        (fun l0 u0 l1 u1 => Z.min u0 u1)%Z.
  Proof.
    unfold valid_update; intros until upper1; intros B0 B1.
    do 2 destruct B0 as [? B0], B1 as [? B1]; destruct B0, B1; intros.
    repeat split; [reflexivity|apply N2Z.is_nonneg| |assumption].
    rewrite wordToN_wand; [|solve_land_ge0|].

    - destruct_min;
        (etransitivity; [|eassumption]); [|rewrite Z.land_comm];
        (apply Z.land_le; land_mono).

    - eapply Z.le_lt_trans; [apply Z.log2_land; land_mono|destruct_min]; (
        eapply Z.le_lt_trans; [apply Z.log2_le_mono; eassumption|];
        assumption).
  Qed.

  Local Ltac lor_mono :=
    first [assumption | etransitivity; [|eassumption]; assumption].

  Local Ltac lor_trans :=
    destruct_max; (
        eapply Z.le_lt_trans; [apply Z.log2_le_mono; eassumption|];
        assumption).

  Lemma lor_valid_update: forall n,
    valid_update n
        (fun l0 u0 l1 u1 => Z.max l0 l1)%Z
        (@wor n)
        (fun l0 u0 l1 u1 => 2^(Z.max (Z.log2_up (u0+1)) (Z.log2_up (u1+1))) - 1)%Z.
  Proof.
    unfold valid_update; intros until upper1; intros B0 B1.
    do 2 destruct B0 as [? B0], B1 as [? B1]; destruct B0, B1; intros.
    repeat split; [destruct_max; assumption| | |assumption].

    - rewrite wordToN_wor;
        [ destruct_max; [|rewrite Z.lor_comm];
            (etransitivity; [|apply Z.lor_lower]; lor_mono)
        | apply Z.lor_nonneg; split; lor_mono|].

        rewrite Z.log2_lor; [lor_trans|lor_mono|lor_mono].

    - rewrite wordToN_wor; [
        | apply Z.lor_nonneg; split; lor_mono
        | rewrite Z.log2_lor; [lor_trans|lor_mono|lor_mono]].

        destruct (Z_ge_dec upper0 upper1) as [g|g].

        + apply Z.ge_le in g; pose proof g as g'.
        apply -> (Z.add_le_mono_r upper1 upper0 1) in g'.
        apply Z.log2_up_le_mono, Z.max_l in g'.
        rewrite g'; clear g'.

        destruct (Z.le_ge_cases (Z.of_N (wordToN value0)) (Z.of_N (wordToN value1)));
            [|rewrite Z.lor_comm];
            apply Z.lor_le; lor_mono.

        + assert (upper1 >= upper0)%Z as g'' by omega; clear g.
        pose proof g'' as g; pose proof g'' as g'; clear g''.
        apply Z.ge_le in g; apply Z.ge_le in g'.
        apply -> (Z.add_le_mono_r upper0 upper1 1) in g'.
        apply Z.log2_up_le_mono, Z.max_r in g'.
        rewrite g'; clear g'.

        destruct (Z.le_ge_cases (Z.of_N (wordToN value0)) (Z.of_N (wordToN value1)));
            [|rewrite Z.lor_comm];
            apply Z.lor_le; lor_mono.
  Qed.

  Local Ltac shift_mono := repeat progress first
    [ eassumption
    | etransitivity; [|eassumption]].

  Lemma shr_valid_update: forall n,
    valid_update n
        (fun l0 u0 l1 u1 => Z.shiftr l0 u1)%Z
        (@wordBin N.shiftr n)
        (fun l0 u0 l1 u1 => Z.shiftr u0 l1)%Z.
  Proof.
    unfold valid_update, wordBin; intros until upper1; intros B0 B1.
    do 2 destruct B0 as [? B0], B1 as [? B1]; destruct B0, B1; intros.

    repeat split; [assumption| | |assumption];
        (rewrite wordToN_NToWord_idempotent; [|apply Npow2_Zlog2]; rewrite N2Z.inj_shiftr);
        [ | eapply Z.le_lt_trans; [apply Z.log2_le_mono|eassumption]
        | | eapply Z.le_lt_trans; [apply Z.log2_le_mono|eassumption]];
        apply Z.shiftr_le_mono; shift_mono.
  Qed.

  Lemma shl_valid_update: forall n,
    valid_update n
        (fun l0 u0 l1 u1 => Z.shiftl l0 l1)%Z
        (@wordBin N.shiftl n)
        (fun l0 u0 l1 u1 => Z.shiftl u0 u1)%Z.
  Proof.
    unfold valid_update, wordBin; intros until upper1; intros B0 B1.
    do 2 destruct B0 as [? B0], B1 as [? B1]; destruct B0, B1; intros.

    repeat split; [assumption| | |assumption];
        (rewrite wordToN_NToWord_idempotent; [|apply Npow2_Zlog2]; rewrite N2Z.inj_shiftl);
        [ | eapply Z.le_lt_trans; [apply Z.log2_le_mono|eassumption]
        | | eapply Z.le_lt_trans; [apply Z.log2_le_mono|eassumption]];
        apply Z.shiftl_le_mono; shift_mono.
  Qed.
End Updates.

Definition winit {sz} (x: word (sz + 1)): word sz :=
  split1 sz 1 x.

Definition wlast {sz} (x: word (sz + 1)): bool :=
  whd (split2 sz 1 x).

Arguments winit {_} _.
Arguments wlast {_} _.

Lemma combine_winit_wlast : forall {sz} a b (c:word (sz+1)),
    @combine sz a 1 b = c <-> a = winit c /\ b = (WS (wlast c) WO).
Proof.
  intros; split; unfold winit, wlast; intro H.

  - rewrite <- H.
    rewrite split1_combine, split2_combine.
    split; [reflexivity|].
    shatter b; simpl; f_equal.
    generalize (wtl b) as b'; intro;
      shatter b'; reflexivity.

  - destruct H as [H0 H1]; rewrite H0.
    replace b with (split2 sz 1 c); [apply combine_split|].
    rewrite H1.
    generalize (split2 sz 1 c) as b'; intro.
    shatter b'.
    generalize (wtl b') as b''; intro;
      shatter b''; reflexivity.
Qed.

Lemma winit_combine : forall sz a b, @winit sz (combine a b) = a.
Proof.
  intros; unfold winit; rewrite split1_combine; reflexivity.
Qed.

Lemma wlast_combine : forall sz a b, @wlast sz (combine a (WS b WO)) = b.
Proof.
  intros; unfold wlast; rewrite split2_combine; cbv; reflexivity.
Qed.

(* TODO : automate *)
Lemma WordNZ_split1 : forall {n m} w,
    Z.of_N (Word.wordToN (Word.split1 n m w)) = ZUtil.Z.pow2_mod (Z.of_N (Word.wordToN w)) (Z.of_nat n).
Proof.
  intros; unfold ZUtil.Z.pow2_mod.
  rewrite wordToN_split1.
  apply Z.bits_inj_iff'; intros k Hpos.
  rewrite Z.land_spec.
  repeat (rewrite Z2N.inj_testbit; [|assumption]).
  rewrite N.land_spec; f_equal.
  rewrite wordToN_wones.

  destruct (Nge_dec (Z.to_N k) (N.of_nat n)).

  - rewrite Z.ones_spec_high, N.ones_spec_high;
      [reflexivity|apply N.ge_le; assumption|split; [omega|]].
    apply Z2N.inj_le; [apply Nat2Z.is_nonneg|assumption|].
    etransitivity; [|apply N.ge_le; eassumption].
    apply N.eq_le_incl.
    induction n; simpl; reflexivity.

  - rewrite Z.ones_spec_low, N.ones_spec_low;
      [reflexivity|assumption|split; [omega|]].
    apply Z2N.inj_lt; [assumption|apply Nat2Z.is_nonneg|].
    eapply N.lt_le_trans; [eassumption|].
    apply N.eq_le_incl.
    induction n; simpl; reflexivity.
Qed.

(* TODO : automate *)
Lemma WordNZ_split2 : forall {n m} w,
    Z.of_N (Word.wordToN (Word.split2 n m w)) = Z.shiftr (Z.of_N (Word.wordToN w)) (Z.of_nat n).
Proof.
  intros; unfold ZUtil.Z.pow2_mod.
  rewrite wordToN_split2.
  apply Z.bits_inj_iff'; intros k Hpos.
  rewrite Z2N.inj_testbit; [|assumption].
  rewrite Z.shiftr_spec, N.shiftr_spec; [|apply N2Z.inj_le; rewrite Z2N.id|]; try assumption.
  rewrite Z2N.inj_testbit; [f_equal|omega].
  rewrite Z2N.inj_add; [f_equal|assumption|apply Nat2Z.is_nonneg].
  induction n; simpl; reflexivity.
Qed.

Lemma WordNZ_range : forall {n} B w,
  (2 ^ Z.of_nat n <= B)%Z ->
  (0 <= Z.of_N (@Word.wordToN n w) < B)%Z.
Proof.
  intros n B w H.
  split; [apply N2Z.is_nonneg|].
  eapply Z.lt_le_trans; [apply N2Z.inj_lt; apply word_size_bound|].
  rewrite Npow2_N, N2Z.inj_pow, nat_N_Z.
  assumption.
Qed.

Lemma WordNZ_range_mono : forall {n} m w,
  (Z.of_nat n <= m)%Z ->
  (0 <= Z.of_N (@Word.wordToN n w) < 2 ^ m)%Z.
Proof.
  intros n m w H.
  split; [apply N2Z.is_nonneg|].
  eapply Z.lt_le_trans; [apply N2Z.inj_lt; apply word_size_bound|].
  rewrite Npow2_N, N2Z.inj_pow, nat_N_Z.
  apply Z.pow_le_mono; [|assumption].
  split; simpl; omega.
Qed.


(* infotheo (c) AIST. R. Affeldt, M. Hagiwara, J. Senizergues. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq path.
From mathcomp Require Import div choice fintype tuple finfun bigop prime.
From mathcomp Require Import binomial ssralg finset fingroup finalg matrix.
Require Import Reals Fourier.
Require Import ssrR Reals_ext ssr_ext ssralg_ext logb Rbigop ln_facts.
Require Import num_occ proba entropy channel divergence types jtypes.

(** * Conditional divergence *)

Reserved Notation "P '|-' V '<<' W" (at level 5, V, W at next level).
Reserved Notation "P '|-' V '<<b' W" (at level 5, V, W at next level).
Reserved Notation "'D(' V '||' W '|' P ')'"
  (at level 50, V, W, P at next level).

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Local Open Scope reals_ext_scope.
Local Open Scope proba_scope.
Local Open Scope entropy_scope.
Local Open Scope channel_scope.
Local Open Scope divergence_scope.
Local Open Scope num_occ_scope.
Local Open Scope types_scope.

Section condition_equivalence.

Variables (A B : finType) (V W : `Ch_1(A, B)) (P : dist A).

Definition cdom_by := forall a, P a != 0 -> (V a) << (W a).

Lemma condition_equivalence : (`J(P , V) << `J(P , W)) <-> cdom_by.
Proof.
rewrite /dom_by; split=> H.
- move=> a p_not_0 b; move: (H (a, b)).
  rewrite JointDist.dE /= => H0 H1.
  move: H0; rewrite H1 mul0R => /(_ erefl)/eqP.
  by rewrite JointDist.dE mulR_eq0 /= (negbTE p_not_0) orbF => /eqP.
- case=> a p_not_0 b; move: {H}(H a) => H.
  rewrite JointDist.dE /=.
  case/boolP : (P a == 0) => [/eqP -> | H1]; first by rewrite mulR0.
  move: {H}(H H1) => ->; first by rewrite mul0R.
  move/eqP : b; by rewrite JointDist.dE mulR_eq0 /= (negbTE H1) orbF => /eqP.
Qed.

End condition_equivalence.

Notation "P '|-' V '<<' W" := (cdom_by V W P) : divergence_scope.

Notation "P '|-' V '<<b' W" := ([forall a, (P a != 0) ==> (V a) <<b (W a)])
  : divergence_scope.

Section joint_dom_sect.

Variable A B : finType.
Variables V W : `Ch_1(A, B).
Variable P : dist A.

Lemma joint_dom : P |- V << W -> dom_by (`J(P, V)) (`J(P, W)) (*NB: notation issue*).
Proof.
move => V_dom_by_W => ab /= Hab.
case: (Rle_lt_or_eq_dec _ _ (dist_ge0 P ab.1)) => Hab1.
- rewrite JointDist.dE in Hab.
  rewrite JointDist.dE V_dom_by_W ?mul0R //.
  + exact/eqP/gtR_eqF.
  + move/eqP : Hab; rewrite mulR_eq0 /= => /orP[/eqP//|/eqP].
    by move: (gtR_eqF _ _ Hab1).
- by rewrite JointDist.dE -Hab1 mulR0.
Qed.

End joint_dom_sect.

Section conditional_divergence_def.

Variables A B : finType.
Variables V W : `Ch_1(A, B).
Variable P : dist A.

Definition cdiv := \rsum_(a : A) P a * D(V a || W a).

End conditional_divergence_def.

Notation "'D(' V '||' W '|' P ')'" := (cdiv V W P) : divergence_scope.

Section conditional_divergence_prop.

Variables A B : finType.
Variables V W : `Ch_1(A, B).
Variable P : dist A.

Hypothesis V_dom_by_W : P |- V << W.

Lemma cdiv_is_div_joint_dist : D(V || W | P) =  D(`J(P , V) || `J(P , W)).
Proof.
rewrite (_ : D(V || W | P) =
  \rsum_(a : A) (\rsum_(b | b \in B) V a b * (log (V a b) - log (W a b)) * P a)); last first.
  apply eq_bigr => a _.
  by rewrite -(big_morph _ (morph_mulRDl _) (mul0R _)) mulRC.
rewrite pair_bigA big_mkcond /=.
apply eq_bigr; case => [] a b /= _.
rewrite JointDist.dE /=.
case/boolP : (P a == 0) => [/eqP -> | Pneq0]; first by rewrite !mulR0 mul0R.
case/boolP : (V a b == 0) => [/eqP -> | Vneq0]; first by rewrite !mul0R.
case/boolP : (W a b == 0) => [/eqP Weq0| Wneq0].
  contradict Vneq0.
  apply/negP. rewrite negbK. apply/eqP. by apply V_dom_by_W.
rewrite JointDist.dE /= /log !LogM; first field;
  apply/ltRP; rewrite lt0R; apply/andP; split => //; exact/leRP/dist_ge0.
Qed.

Lemma leq0cdiv : 0 <= D(V || W | P).
Proof.
rewrite cdiv_is_div_joint_dist //; apply leq0div.
case=> a b; rewrite 2!JointDist.dE /=.
case/boolP : (P a == 0); first by move/eqP => ->; rewrite 2!mulR0.
move=> H1 H2.
suff -> : (V a b) = 0 by rewrite mul0R.
apply V_dom_by_W => //.
by move/eqP : H2; rewrite mulR_eq0 (negbTE H1) orbF => /eqP.
Qed.

Lemma eq0cdiv : D(V || W | P) = 0 <-> `J(P, V) = `J(P, W).
Proof.
rewrite cdiv_is_div_joint_dist.
apply eq0div; case=> a b /eqP.
rewrite 2!JointDist.dE /= mulR_eq0 => /orP[|/eqP ->]; last by rewrite mulR0.
case/boolP : (P a == 0) => [/eqP ->|Pa0]; first by rewrite mulR0.
move/eqP/V_dom_by_W => /(_ Pa0) ->; by rewrite mul0R.
Qed.

End conditional_divergence_prop.

Section dmc_cdiv_cond_entropy_sect.

Variable A B : finType.
Variables W : `Ch_1(A, B).
Variable n : nat.
Variable P : P_ n ( A ).
Variable V : P_ n ( A , B ).
Variable x : 'rV[A]_n.
Variable y : 'rV[B]_n.

Local Open Scope vec_ext_scope.

Lemma dmc_cdiv_cond_entropy_aux : W ``(y | x) =
  \rprod_(a : A) \rprod_(b : B) W a b ^ N(a, b | tuple_of_row x, tuple_of_row y).
Proof.
transitivity (\rprod_(a : A) \rprod_(b : B) \rprod_(i < n)
  if (a == x ``_ i) && (b == y ``_ i) then W `(y ``_ i | x ``_ i) else 1).
  rewrite pair_big exchange_big /= DMCE.
  apply eq_bigr => i _.
  rewrite (bigD1 (x ``_ i, y ``_ i)) //= 2!eqxx andbT.
  rewrite big1; first by rewrite mulR1.
  case=> a b /=.
  rewrite xpair_eqE negb_and.
  case/orP.
  - by move/negbTE => ->.
  - move/negbTE => ->; by rewrite andbF.
apply eq_bigr => a _; apply eq_bigr => b _.
rewrite num_co_occ_alt -sum1_card.
rewrite (@big_morph _ _ (fun x => W a b ^ x) 1 Rmult O addn) //; last first.
  move=> * /=; by rewrite -pow_add.
rewrite [in RHS]big_mkcond.
apply eq_bigr => i _.
case: ifP.
  case/andP => /eqP Ha /eqP Hb.
  by rewrite inE 2!tnth_mktuple -Ha -Hb 2!eqxx /= mulR1.
move/negbT.
rewrite negb_and inE 2!tnth_mktuple.
case/orP => /negbTE.
  by rewrite eq_sym => ->.
by rewrite andbC eq_sym => ->.
Qed.

Local Close Scope tuple_ext_scope.

Hypothesis W0_V0 : P |- V << W.
Hypothesis Hx : tuple_of_row x \in T_{P}.
Hypothesis HV : V \in \nu^{B}(P).
Hypothesis Hy : tuple_of_row y \in V.-shell (tuple_of_row x).
Hypothesis Hn : n != O.

(** Expression of the probability transition matrix of a DMC using
   the conditional divergence and the condition entropy *)

Lemma dmc_cdiv_cond_entropy :
  W ``(y | x) = exp2 (- INR n * (D(V || W | P) + `H(V | P))).
Proof.
rewrite dmc_cdiv_cond_entropy_aux cond_entropy_single_sum.
rewrite /cdiv /entropy -big_split /=.
rewrite (big_morph _ (morph_mulRDr _) (mulR0 _)) (big_morph _ morph_exp2_plus exp2_0).
apply eq_bigr => a _.
rewrite (big_morph _ morph_Ropp oppR0).
rewrite /div /= -mulRDr mulRA -big_split /=.
rewrite (big_morph _ (morph_mulRDr _) (mulR0 _)) (big_morph _ morph_exp2_plus exp2_0).
apply eq_bigr => b _.
case/boolP : (W a b == 0) => Wab0.
- move/eqP in Wab0; rewrite Wab0.
  case/boolP : (P a == 0) => Pa0.
  - move/eqP in Pa0; rewrite Pa0.
    rewrite mulR0 mul0R exp2_0 -(pow_O 0).
    f_equal.
    move: Hy; rewrite in_set => /forallP/(_ a)/forallP/(_ b)/eqP => ->.
    move: (HV).
    rewrite in_set.
    move/cond_type_equiv/(_ _ Hx a).
    move: Hx; rewrite in_set => /forallP/(_ a)/eqP => Htmp Htmp'.
    rewrite -Htmp' Pa0 in Htmp.
    move/esym/eqP : Htmp.
    rewrite mulR_eq0 => /orP[|]; last first.
      by move/invR_eq0; rewrite INR_eq0' (negbTE Hn).
    rewrite INR_eq0' sum_nat_eq0 => /forall_inP/(_ b) => H; apply/eqP; by move: H => ->.
  - move: (W0_V0 Pa0 Wab0) => nullV.
    rewrite nullV.
    suff : N(a, b| tuple_of_row x, tuple_of_row y) = 0%nat.
      move=> ->; by rewrite 2!mul0R oppR0 addR0 mulR0 exp2_0.
    move: Hy; rewrite in_set => /forallP/(_ a)/forallP/(_ b)/eqP => ->.
    by rewrite jtype_0_jtypef.
- rewrite -{1}(@logK (W a b)); last first.
    apply/ltRP; rewrite lt0R Wab0; exact/leRP/dist_ge0.
  rewrite -exp2_pow.
  f_equal.
  rewrite -mulRN -mulRDr mulRA addRC addRA (addRC _ (log (V a b))) -/(Rminus (log (V a b)) _) subRR add0R mulRN -3!mulNR oppRK.
  f_equal.
  move: Hy; rewrite in_set => /forallP/(_ a)/forallP/(_ b)/eqP => ->.
  move: (HV).
  rewrite in_set.
  move/cond_type_equiv => /(_ _ Hx a).
  move=> Htmp'.
  move: Hx; rewrite in_set => /forallP/(_ a)/eqP => Htmp.
  rewrite (jtype.c_f V) /=.
  case: ifP.
  - move/eqP => HP.
    rewrite Htmp -Htmp' HP div0R mulR0 mul0R.
    move/eqP : HP.
    rewrite sum_nat_eq0.
    move/forallP.
    by move/(_ b)/implyP/(_ Logic.eq_refl)/eqP => ->.
  - move/negP/negP => HP.
    rewrite Htmp -Htmp' (mulRCA (INR n)) mulRV ?INR_eq0' // mulR1.
    by rewrite mulRCA mulRV ?mulR1 // INR_eq0'.
Qed.

End dmc_cdiv_cond_entropy_sect.

Section cdiv_spec.

Variables A B : finType.
Variable n : nat.
Variable P : P_ n ( A ).
Variable V : P_ n ( A , B ).
Variable W : `Ch_1*(A, B).

Definition exp_cdiv :=
  if P |- V <<b W
  then exp2 (- INR n * D(V || W | P))
  else 0.

Lemma exp_cdiv_left (H : P |- V << W) : exp_cdiv = exp2 (-INR n * D(V || W | P)).
Proof.
rewrite /exp_cdiv.
suff : P |- V <<b W by move=> ->.
apply/forallP => a.
apply/implyP => Pa0.
apply/forall_inP => b /eqP Wab.
apply/eqP.
by apply H.
Qed.

End cdiv_spec.

Section dmc_cdiv_cond_entropy_spec_sect.

Variables A B : finType.
Variable W : `Ch_1*(A, B).
Variable n' : nat.
Let n := n'.+1.
Variable P : P_ n ( A ).
Variable V : P_ n ( A , B ).
Variable x : 'rV[A]_n.
Variable y : 'rV[B]_n.

Hypothesis Hta : tuple_of_row x \in T_{P}.
Hypothesis Vctyp : V \in \nu^{B}(P).
Hypothesis Htb : tuple_of_row y \in V.-shell (tuple_of_row x).

Lemma dmc_exp_cdiv_cond_entropy :
  W ``(y | x) = exp_cdiv P V W * exp2 (- INR n * `H(V | P)).
Proof.
rewrite /exp_cdiv.
case : ifP => Hcase.
- rewrite -ExpD -mulRDr.
  apply dmc_cdiv_cond_entropy => // a Pa b /eqP Wab.
  by move: Hcase => /forallP/(_ a)/implyP/(_ Pa)/forallP/(_ b)/implyP/(_ Wab)/eqP.
- rewrite mul0R.
  move: Hcase => /negbT; rewrite negb_forall; case/existsP => a.
  rewrite negb_imply.
  case/andP => Pa.
  rewrite negb_forall_in ; move/existsP ; case => b.
  case/andP=> Wab H.
  rewrite dmc_cdiv_cond_entropy_aux.
  rewrite pair_big /= (bigD1 (a, b)) //=.
  apply Rmult_eq_0_compat_r.
  move/eqP in Wab; rewrite Wab.
  apply pow_i.
  apply/ltP.
  rewrite lt0n.
  move: Htb ; rewrite in_set => /forallP/(_ a)/forallP/(_ b)/eqP ->.
  move: H => /=.
  rewrite (jtype.c_f V) /=.
  move: (Vctyp).
  rewrite in_set.
  move/cond_type_equiv => /(_ _ Hta a) ->.
  move: Hta; rewrite in_set => /forallP/(_ a)/eqP => Htmp.
  case: ifP => Hcase.
    exfalso.
    move/eqP : Pa; apply.
    rewrite Htmp.
    move/eqP : Hcase => ->.
    by rewrite div0R.
  apply: contra => /eqP ->; by rewrite div0R.
Qed.

End dmc_cdiv_cond_entropy_spec_sect.