(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2018   --   Inria - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require real.Real.

(* Why3 comment *)
(* from_int is replaced with (BuiltIn.IZR x) by the coq driver *)

(* Why3 goal *)
Lemma Zero :
((BuiltIn.IZR 0%Z) = 0%R).
Proof.
split.
Qed.

(* Why3 goal *)
Lemma One :
((BuiltIn.IZR 1%Z) = 1%R).
Proof.
split.
Qed.

(* Why3 goal *)
Lemma Add :
forall (x:Z) (y:Z),
 ((BuiltIn.IZR (x + y)%Z) = ((BuiltIn.IZR x) + (BuiltIn.IZR y))%R).
Proof.
exact plus_IZR.
Qed.

(* Why3 goal *)
Lemma Sub :
forall (x:Z) (y:Z),
 ((BuiltIn.IZR (x - y)%Z) = ((BuiltIn.IZR x) - (BuiltIn.IZR y))%R).
Proof.
exact minus_IZR.
Qed.

(* Why3 goal *)
Lemma Mul :
forall (x:Z) (y:Z),
 ((BuiltIn.IZR (x * y)%Z) = ((BuiltIn.IZR x) * (BuiltIn.IZR y))%R).
Proof.
exact mult_IZR.
Qed.

(* Why3 goal *)
Lemma Neg :
forall (x:Z), ((BuiltIn.IZR (-x)%Z) = (-(BuiltIn.IZR x))%R).
Proof.
exact opp_IZR.
Qed.

(* Why3 goal *)
Lemma Monotonic :
forall (x:Z) (y:Z), (x <= y)%Z -> ((BuiltIn.IZR x) <= (BuiltIn.IZR y))%R.
Proof.
exact (IZR_le).
Qed.


(** Zainspirowane przez podręcznik
    #
    Modeling and Proving in Computational Type Theory Using the Coq Proof Assistant#
    (rozdział 14). *)

Module Provability.

Axiom Provable : Prop -> Prop.

Definition Unprovable (P : Prop) : Prop :=
  ~ Provable P.

Definition Disprovable (P : Prop) : Prop :=
  Provable (~ P).

Definition Consistent (P : Prop) : Prop :=
  ~ Provable (~ P).

Definition Independent (P : Prop) : Prop :=
  ~ Provable P /\ ~ Provable (~ P).

Lemma Independent2Consistent :
  forall {P : Prop},
    Independent P -> Consistent P.
Proof.
  intros P [_ HC]; assumption.
Qed.

Lemma Consistent2Unprovable :
  forall {P : Prop},
    Consistent P -> Unprovable (~ P).
Proof.
  compute.
  intros P C U.
  apply C. assumption.
Qed.

Definition PMP : Prop :=
  forall P Q : Prop, Provable (P -> Q) -> Provable P -> Provable Q.

Definition PI : Prop :=
  forall P : Prop, Provable (P -> P).

Definition PK : Prop :=
  forall P Q : Prop, Provable Q -> Provable (P -> Q).

Definition PC : Prop :=
  forall P Q Z : Prop, Provable (P -> Q) -> Provable ((Q -> Z) -> P -> Z).

Definition UF : Prop :=
  Unprovable False.

Lemma Provable_contraposition :
  PMP ->
  forall P Q : Prop,
    Provable (P -> Q) -> ~ Provable Q -> ~ Provable P.
(* begin hide *)
Proof.
  intros pmp P Q pq nq p.
  apply nq. eapply pmp; eassumption.
Qed.
(* end hide *)

Lemma Provable_contraposition' :
  PMP ->
  forall P Q : Prop,
    Provable (P -> Q) -> Unprovable Q -> Unprovable P.
(* begin hide *)
Proof.
  compute.
  intros pmp P Q pq nq p.
  apply nq. eapply pmp; eassumption.
Qed.
(* end hide *)

Lemma Provable_Consistent :
  PMP -> PC ->
  forall P Q : Prop,
    Provable (P -> Q) -> Consistent P -> Consistent Q.
(* begin hide *)
Proof.
  unfold PMP, PC.
  intros pmp pc P Q ppq cp dq.
  apply cp.
  specialize (pc _ _ False ppq).
  specialize (pmp _ _ pc).
  apply pmp.
  assumption.
Qed.
(* end hide *)

Lemma sandwich :
  PMP -> PK -> PC ->
  forall P Q Z : Prop,
    Consistent P -> Unprovable Q -> Provable (P -> Z) -> Provable (Z -> Q) -> Independent Z.
(* begin hide *)
Proof.
  unfold PMP, PK, PC (* Consistent, Unprovable, Independent *).
  intros pmp pk pc P Q Z cp uq p2z z2q.
  split.
  - intros pz. apply uq. eapply pmp; eauto.
  - eapply Provable_Consistent; eauto.
Qed.
(* end hide *)

Lemma PropExt_PI_Provable :
  (forall P Q : Prop, (P <-> Q) -> P = Q) ->
  PI ->
  forall P : Prop,
    P -> Provable P.
(* begin hide *)
Proof.
  compute.
  intros PropExt PI P p.
  assert (H : P <-> (P <-> P)) by tauto.
  assert (H' : P = (P -> P)) by firstorder.
  rewrite H'.
  apply PI.
Qed.
(* end hide *)

End Provability.


Require Import Undecidability.Synthetic.Definitions.

(* informative counterparts of (semi-)decidability, enumerability, and many-one reducibility *)

Definition inf_decidable {X} (P : X -> Prop) : Type :=
  { f : X -> bool | decider f P}.

Definition inf_enumerable {X} (P : X -> Prop) : Type :=
  { f : nat -> option X | enumerator f P}.

Definition inf_semi_decidable {X} (P : X -> Prop) : Type :=
  { f : X -> nat -> bool | semi_decider f P}.

Definition inf_reduces {X Y} (P : X -> Prop) (Q : Y -> Prop) :=
  { f : X -> Y | reduction f P Q}.
Infix "⪯ᵢ" := inf_reduces (at level 70).


Require Import Init.Init.
Require Import Relation.Relation_.
Require Import Relation.Function.
Require Import Relation.Function_ctor.
Require Import Relation.Utils.

(* Axiom Choice I *)
Lemma rel_to_fn: ∀ R, rel R → ∃ F, fn F ∧ F ⊆ R ∧ dom(R) = dom(F).
Proof.
  intros R P1.
  pose ({f: 𝒫(R)| fn f}) as A.
  assert (∀ C, C ⊆ A → chain C → ∪C ∈ A) as P2.
  { intros C Q1 Q2.
    pose (sub_t _ _ _ Q1 (sub_e1 _ _)) as Q3.
    apply sub_i.
    + apply power_i.
      intros x Q4.
      destruct (union_e _ _ Q4) as [c [Q5 Q6]].
      pose (power_e _ _ (Q3 _ Q5)) as Q7.
      apply (Q7 _ Q6).
    + split.
      - intros x Q4.
        destruct (union_e _ _ Q4) as [c [Q5 Q6]].
        apply (P1 _ (power_e _ _ (Q3 _ Q5) _ Q6)).
      - intros x y1 y2 Q4 Q5.
        destruct (union_e _ _ Q4) as [c1 [Q6 Q7]].
        destruct (union_e _ _ Q5) as [c2 [Q8 Q9]].
        destruct (Q2 _ _ Q6 Q8) as [Q10 | Q10].
        * destruct (sub_e _ _ _ (Q1 _ Q8)) as [_ [_ Q11]].
          apply (Q11 _ _ _ (Q10 _ Q7) Q9).
        * destruct (sub_e _ _ _ (Q1 _ Q6)) as [_ [_ Q11]].
          apply (Q11 _ _ _ Q7 (Q10 _ Q9)). }
  destruct (zorn _ P2) as [M [P3 P4]].
  exists M.
  split.
  + apply (sub_e _ _ _ P3).
  + split.
    - apply power_e.
      apply (sub_e _ _ _ P3).
    - apply sub_a.
      split.
      * intros x Q1.
        apply nn_e.
        intros Q2.
        destruct (dom_e _ _ Q1) as [y Q3].
        pose (M ∪ `{⟨x, y⟩}) as M'.
        assert (M' ∈ A) as Q4.
        { apply sub_i.
          + apply power_i.
            intros s S1.
            destruct (union2_e _ _ _ S1) as [S2 | S2].
            - destruct (sub_e _ _ _ P3) as [S3 _].
              apply (power_e _ _ S3 _ S2).
            - apply (eq_cl (λ x, x ∈ R) (sing_e _ _ S2) Q3).
          + destruct (sub_e _ _ _ P3) as [_ S1].
            apply (fn_exten _ _ _ S1 Q2). }
        assert (M' ≠ M) as Q5.
        { apply (neq_i _ _ (⟨x, y⟩)).
          + apply union2_ir.
            apply sing_i.
          + intros S1.
            apply Q2.
            apply (dom_i _ _ _ S1). }
        assert (M ⊆ M') as Q6.
        { apply union2_sub_l. }
        destruct (P4 _ Q4) as  [Q7 | Q7].
        ++apply (Q5 Q7).
        ++apply (Q7 Q6).
      * apply sub_dom.
        apply power_e.
        apply (sub_e _ _ _ P3).
Qed.

(* Axiom of Choice II *)
Lemma multiplicative: ∀ H, fn H → (∀ i, i ∈ dom(H) → H[i] ≠ ∅)
  → ∃ f, fn f ∧ dom(f) = dom(H) ∧ (∀ i, i ∈ dom(f) → f[i] ∈ H[i]).
Proof.
  intros H P1 P2.
  pose ({r: dom(H) ⨉ ∪(ran(H))| ∃ i, ∃ y, r = ⟨i, y⟩ ∧ y ∈ H[i]}) as R.
  destruct (rel_to_fn R (cp_sub_rel _ _ _ )) as [F [P3 [P4 P5]]].
  exists F.
  split.
  + apply P3.
  + split.
    - apply (eq_cl (λ x, x = dom(H)) P5).
      apply sub_a.
      split.
      * apply (cp_sub_dom _ _ _ (sub_e1 _ _)).
      * intros i Q1.
        destruct (nempty_ex _ (P2 _ Q1)) as [y Q2].
        apply (dom_i _ _ y).
        apply sub_i.
        ++apply cp_i.
          --apply Q1.
          --apply union_i.
            exists (H[i]).
            split.
            **apply (fval_ran _ _ P1 Q1).
            **apply Q2.
        ++exists i.
          exists y.
          split.
          --apply eq_r.
          --apply Q2.
    - intros i Q1.
      destruct (dom_e _ _ Q1) as [y Q2].
      pose (P4 _ Q2) as Q3.
      destruct (sub_e _ _ _ Q3) as [Q4 [i' [y' [Q5 Q6]]]].
      apply (eq_cr (λ x, F[i] ∈ H[x]) (opair_eq_el _ _ _ _ Q5)).
      apply (eq_cr (λ x, x ∈ H[i']) (fval_i _ _ _ P3 Q2)).
      apply (eq_cr (λ x, x ∈ H[i']) (opair_eq_er _ _ _ _ Q5) Q6).
Qed.

(* Axiom of Choice IV *)
Lemma ax_iv: ∀ A, (∀ a, a ∈ A → a ≠ ∅)
  → (∀ a1, ∀ a2, a1 ∈ A → a2 ∈ A → a1 ≠ a2 → a1 ∩ a2 = ∅)
  → (∃ C, ∀ a, a ∈ A → ∃ x, C ∩ a = `{x}).
Proof.
  intros A P1 P2.
  pose (id A) as H.
  assert (∀ i, i ∈ dom(H) → H[i] ≠ ∅) as P3.
  { intros i Q1 Q2.
    pose (eq_cl (λ x, i ∈ x) (id_dom _) Q1) as Q3.
    pose (eq_cl (λ x, x = ∅) (id_fval _ _ Q3) Q2) as Q4.
    apply (P1 _ Q3).
    apply Q4. }
  destruct (multiplicative _ (id_is_fn _) P3) as [F [P4 [P5 P6]]].
  exists (ran(F)).
  intros a P7.
  pose (eq_t P5 (id_dom _)) as P8.
  pose (eq_cr (λ x, a ∈ x) P8 P7) as P9.
  exists (F[a]).
  apply sub_a.
  split.
  + intros y Q1.
    destruct (inter2_e _ _ _ Q1) as [Q2 Q3].
    destruct (ran_e _ _ Q2) as [x Q4].
    destruct (LEM (x = a)) as [Q5 | Q5].
    - apply sing_i2.
      apply eq_s.
      apply (eq_cl (λ x, F[x] = y) Q5 (fval_i _ _ _ P4 Q4)).
    - assert (x ∈ A) as Q7.
      { apply (eq_cl (λ y, x ∈ y) P8).
        apply (dom_i _ _ _ Q4). }
      assert (x ∩ a ≠ ∅) as Q6.
      { apply ex_nempty.
        exists y.
        apply inter2_i.
        + apply (eq_cl (λ y, y ∈ x) (fval_i _ _ _ P4 Q4)).
          apply (eq_cl (λ y, F[x] ∈ y) (id_fval _ _ Q7)).
          apply (P6 _ (eq_cr (λ y, x ∈ y) P8 Q7)).
        + apply Q3. }
      apply bot_e.
      apply (Q6 (P2 _ _ Q7 P7 Q5)).
  + intros y Q1.
    apply inter2_i.
    - apply (eq_cl (λ x, x ∈ ran(F)) (sing_e _ _ Q1)).
      apply (fval_ran _ _ P4 P9).
    - apply (eq_cl (λ x, x ∈ a) (sing_e _ _ Q1)).
      apply (eq_cl (λ x, F[a] ∈ x) (id_fval _ _ P7)).
      apply (P6 _ P9).
Qed.

(* Axiom of Choice III *)
Lemma choice_fn_ex: ∀ A, ∃ F,
  fn F ∧ dom(F) = 𝒫(A) \ `{∅} ∧ ∀ B, B ≠ ∅ → B ⊆ A → F[B] ∈ B.
Proof.
  intros A.
  pose (𝒫(A) \ `{∅}) as B.
  pose (id B) as H.
  pose (id_is_fn B) as P1.
  assert (∀ i, i ∈ dom(H) → H[i] ≠ ∅) as P2.
  { intros i Q1 Q2.
    pose (eq_cl (λ x, x ∈ ran(id B)) Q2 (fval_ran _ _ P1 Q1)) as Q3.
    pose (eq_cl (λ x, ∅ ∈ x) (id_ran _) Q3) as Q4.
    destruct (compl_e _ _ _ Q4) as [_ Q5].
    apply Q5.
    apply sing_i. }
  destruct (multiplicative _ P1 P2) as [f [P3 [P4 P5]]].
  exists f.
  split.
  + - apply P3.
  + split.
    - apply (eq_cr (λ x, x = 𝒫(A) \ `{∅}) P4).
      apply id_dom.
    - intros A' Q1 Q2.
      assert (A' ∈ B) as Q3.
      { apply compl_i.
        + apply power_i.
          apply Q2.
        + apply nsing_i.
          apply (neq_s Q1). }
      assert (A' ∈ dom(f)) as Q4.
      { apply (eq_cr (λ x, A' ∈ x) (eq_t P4 (id_dom _))).
        apply Q3. }
      apply (eq_cl (λ x, f[A'] ∈ x) (id_fval _ _ Q3)).
      apply (P5 _ Q4).
Qed.


Require Import HoTT.

Open Scope type_scope.
(* NOTE: The reason for this “Open Scope” is that when the HoTT library is imported, [mc_scope] overrides use of notations such as [A + B] for types, or at least, make them require explicit scope annotations.  If there’s a better way to make such notations easily usable (besides this or closing [mc_scope]), we should ue that here instead. *)

Definition is_well_founded {X : Type} (R : Relation X)
  := forall P : X -> Type,
     (forall x : X, (forall y : X, R y x -> P y) -> P x)
     -> (forall x : X, P x).

Record well_founded_order {X : Type}
:= { well_founded_order_lt :> Relation X
   ; well_founded : is_well_founded well_founded_order_lt
   ; transitive : Transitive well_founded_order_lt (* TODO: rename this *)
 }.

Arguments well_founded_order : clear implicits.

Identity Coercion id_relation : Relation >-> Funclass.
(* Required in order to apply [well_founded_order] (or other things coercing to [relation]) to arguments *)

(* An order is well-founded if it embeds into a known well-founded order. *)
Definition well_founded_if_embeds {X Y} (f : X -> Y)
    {RX : Relation X} {RY : Relation Y} (RY_wf : is_well_founded RY)
    (H_f : forall x x', RX x x' -> RY (f x) (f x'))
  : is_well_founded RX.
Proof.
  intros P P_hereditary.
  set (Q := fun y:Y => forall x:X, (f x = y) -> P x).
  assert (H_Q : forall y, Q y).
  { apply RY_wf.
    intros y Q_below_y x e_fx_y.
    destruct e_fx_y. rename Q_below_y into Q_below_fx.
    apply P_hereditary.
    intros x' lt_x'_x.
    simple refine (Q_below_fx (f x') _ _ _).
    + apply H_f; assumption.
    + apply idpath.
  }
  intros x. refine (H_Q (f x) x _). apply idpath.
Defined.

Local Definition pullback {X Y} (f : X -> Y)
  : well_founded_order Y -> well_founded_order X.
Proof.
  intros lt.
  exists (fun x x' => lt (f x) (f x')).
  - apply (well_founded_if_embeds f (well_founded lt)). intros; assumption.
  - intros x x' x'' lt_x_x' lt_x'_x''.
    apply (transitive lt _ (f x')); assumption.
Defined.

Local Definition family_sum
  {X : Type} (lt_X : well_founded_order X)
  {Y : X -> Type} (lt_Y : forall x, well_founded_order (Y x))
  : well_founded_order {x:X & Y x}.
Proof.
  simple refine (Build_well_founded_order _ _ _ _).
  - intros xy xy'.
    refine (lt_X xy.1 xy'.1
            + { e : xy.1 = xy'.1 & lt_Y _ (transport Y e xy.2) xy'.2}).
  - intros P P_hereditary.
    set (PX := fun x => forall y, P (x;y)).
    assert (PX_total : forall x, PX x).
    { apply (well_founded lt_X).
      intros x PX_below_x.
      unfold PX. apply (well_founded (lt_Y x)).
      intros y Px_below_y.
      apply (P_hereditary (x;y)).
      intros [x' y'] [ lt_x_x' | [e lt_y_y'] ].
      + apply PX_below_x, lt_x_x'.
      + simpl in *. destruct e. apply Px_below_y, lt_y_y'.
    }
    intros [x y]; apply PX_total.
  - intros [x y] [x' y'] [x'' y'']
           [ lt_x_x' | e_lt_y_y' ] [ lt_x'_x'' | e_lt_y'_y''].
    + apply inl. apply (transitive lt_X _ x'); assumption.
    + apply inl. destruct (e_lt_y'_y''.1). assumption.
    + apply inl. destruct (e_lt_y_y'.1). assumption.
    + apply inr. cbn in *.
      destruct e_lt_y_y' as [ e lt_y_y']; destruct e.
      destruct e_lt_y'_y'' as [ e' lt_y'_y'']; destruct e'.
      cbn in *. exists (idpath _).
      apply (transitive (lt_Y x) _ y'); assumption.
Defined.

(* If [f : X -> Y] from a well-ordered [X] to a [Y] with a relation reflects
   order then a predicate of the form [P o f] is hereditary. *)
Lemma push_along_embedding
    {X} (lt_X : well_founded_order X)
    {Y} (lt_Y : Relation Y) (f : X -> Y)
    (P : Y -> Type)
  : (forall x x', lt_Y (f x) (f x') -> lt_X x x')
  -> (forall x : X, (forall x', lt_Y (f x') (f x) -> P (f x')) -> P (f x))
  -> (forall x : X, P (f x)).
Proof.
  intro f_embeds.
  intros p x.
  apply (well_founded lt_X (fun x => P (f x))).
  intros y H.
  apply p.
  intros ? ?.
  apply H.
  now apply f_embeds.
Defined.

Local Definition sum {X Y} :
  well_founded_order X -> well_founded_order Y -> well_founded_order (X + Y).
Proof.
  intros lt_X lt_Y.
  pose (lt := fun (u v : X + Y) =>
                match u, v with
                | inl x, inl x' => lt_X x x'
                | inr y, inr y' => lt_Y y y'
                | _, _ => False
                end).
  exists lt.
  - intros P f [x | y].
    + apply (push_along_embedding lt_X lt inl P) ; auto.
      intros ? H.
      apply f.
      intros [? | ?]; [intros ? | intros []].
      now apply H.
    + apply (push_along_embedding lt_Y lt inr P) ; auto.
      intros ? H.
      apply f.
      intros [? | ?]; [intros [] | intros ?].
      now apply H.
  - intros [x1|y1] [x2|y2] [x3|y3] H1 H2;
      try (now destruct H1 || now destruct H2).
    + now apply (transitive _ _ x2).
    + now apply (transitive _ _ y2).
Defined.

Local Definition empty : well_founded_order Empty.
Proof.
  refine {| well_founded_order_lt := (fun _ _ => True) |}.
  - intros _ _ [].
  - intros [].
Defined.

(** Well-founded order on an option type where [None] is the last element. *)
Local Definition linear_option {X} (lt_X : well_founded_order X)
  : well_founded_order (option X).
Proof.
  pose (lt := fun (x y : option X) =>
                       match x, y with
                       | None, _ => False
                       | Some _, None  => True
                       | Some u, Some v => lt_X u v
                       end).
  simple refine {| well_founded_order_lt := lt |}.
  - intros P f [x|].
    + apply (well_founded lt_X (fun z => P (Some z))).
      intros ? H.
      apply f.
      intros [? | ]; [ intros ? | intros []].
      now apply H.
    + apply f.
      intros [? | ]; [ intros ? | intros []].
      apply (well_founded lt_X (fun z => P (Some z))).
      intros ? H.
      apply f.
      intros [? | ]; [ intros ? | intros []].
      now apply H.
  - intros [x|] [y|] [z|] lt_x_y lt_y_z ; try now destruct lt_x_y.
    + now apply (transitive lt_X _ y).
    + constructor.
Defined.

(** Well-founded order on an option type where [None] is incomparable to [Some _]. *)
Local Definition raw_option {X} {lt_X : well_founded_order X}
  : well_founded_order (option X).
Proof.
  pose (lt := fun (x y : option X) =>
                match x, y with
                | None, _ => False
                | _, None => False
                | Some u, Some v => lt_X u v
                end).
  simple refine {| well_founded_order_lt := lt |}.
  - intros P f [x|].
    + apply (well_founded lt_X (fun z => P (Some z))).
      intros ? H.
      apply f.
      intros [? | ]; [ intros ? | intros []].
      now apply H.
    + apply f.
      intros [y|] [].
  - intros [x|] [y|] [z|] lt_x_y lt_y_z ; try now destruct lt_x_y.
    + now apply (transitive lt_X _ y).
    + destruct lt_y_z.
Defined.

(** A tactic that genereates a well-order on the type [option (option (.... empty))]. *)
Ltac use_linear_order :=
  match goal with
  | |- well_founded_order Empty => exact empty
  | |- well_founded_order (option ?T) => apply linear_option ; use_linear_order
  | _ => fail
  end.

(** A tactic that genereates a raw well-order on a combination of +, option and Empty. *)
Ltac use_flat_order :=
  match goal with
  | |- well_founded_order Empty => exact empty
  | |- well_founded_order (option _) => apply linear_option ; use_flat_order
  | |- well_founded_order (Datatypes.sum _ _) => apply sum ; use_flat_order
  | _ => fail
  end.

Local Definition lex_product {X Y}
    (lt_X : well_founded_order X) (lt_Y : well_founded_order Y)
  : well_founded_order (X*Y).
Proof.
  refine (pullback _ (family_sum lt_X (fun x => lt_Y))).
  intros xy. exact (fst xy; snd xy).
Defined.

(* TODO: find better name; see https://mathoverflow.net/questions/296349/ *)
Definition semi_reflexive_product
           {X Y} (lt_X : well_founded_order X) (lt_Y : well_founded_order Y)
  : well_founded_order (X*Y).
Proof.
  exists (fun xy xy' => ((lt_X (fst xy) (fst xy') * lt_Y (snd xy) (snd xy'))
                         + ((fst xy = fst xy') * lt_Y (snd xy) (snd xy'))
                         + (lt_X (fst xy) (fst xy') * (snd xy = snd xy')))).
  - apply (well_founded_if_embeds idmap (well_founded (lex_product lt_X lt_Y))).
    intros [x y] [x' y'] [[[lx ly] | [e ly]] | [lx e]].
    + apply inl; assumption.
    + apply inr. exists e. destruct e; exact ly.
    + apply inl; assumption.
  - intros [x y] [x' y'] [x'' y'']
      [[[l_x_x' l_y_y'] | [e_x_x' l_y_y']] | [l_x_x' e_y_y']]
      [[[l_x'_x'' l_y'_y''] | [e_x'_x'' l_y'_y'']] | [l_x'_x'' e_y'_y'']];
    cbn in *.
    + apply inl, inl. split.
      * eapply transitive; eassumption.
      * eapply transitive; eassumption.
    + apply inl, inl. split.
      * destruct e_x'_x''; assumption.
      * eapply transitive; eassumption.
    + apply inl, inl. split.
      * eapply transitive; eassumption.
      * destruct e_y'_y''; assumption.
    + apply inl, inl. split.
      * destruct e_x_x'; assumption.
      * eapply transitive; eassumption.
    + apply inl, inr. split.
      * destruct e_x_x'; assumption.
      * eapply transitive; eassumption.
    + apply inl, inl. split.
      * destruct e_x_x'; assumption.
      * destruct e_y'_y''; assumption.
    + apply inl, inl. split.
      * eapply transitive; eassumption.
      * destruct e_y_y'; assumption.
    + apply inl, inl. split.
      * destruct e_x'_x''; assumption.
      * destruct e_y_y'; assumption.
    + apply inr. split.
      * eapply transitive; eassumption.
      * destruct e_y_y'; assumption.
Defined.


Require Import Omega.
Require Import QvecArith PerceptronDef.

 (***************************************************************************************************
    inner_perceptron_MCE <-> inner_perceptron. Equivalent w / None Return values
  ***************************************************************************************************)
Theorem inner_perceptron_MCE_inner_perceptron_None : forall {n : nat} T (w0: Qvec (S n)),
  inner_perceptron_MCE T w0 = None <-> inner_perceptron T w0 = None.
Proof.
  split; generalize dependent w0; induction T; intros w0 H.
  reflexivity. destruct a as [f l].
  inversion H. unfold inner_perceptron. destruct (correct_class (Qvec_dot w0 (consb f)) l) eqn: H2.
  fold (inner_perceptron T w0). apply IHT in H1. apply H1.
  destruct (inner_perceptron_MCE T (Qvec_plus w0 (Qvec_mult_class l (consb f)))).  destruct p.
  inversion H1. inversion H1. reflexivity. destruct a as [f l].
  inversion H. unfold inner_perceptron_MCE. destruct (correct_class (Qvec_dot w0 (consb f)) l).
  fold (inner_perceptron_MCE T w0). apply IHT in H1. apply H1.
  destruct (inner_perceptron T (Qvec_plus w0 (Qvec_mult_class l (consb f)))).
  inversion H1. inversion H1. Qed.

Theorem inner_perceptron_MCE_inner_perceptron : forall {n : nat} T (w0 w : Qvec (S n)),
  (exists M, inner_perceptron_MCE T w0 = Some (M, w)) <-> inner_perceptron T w0 = Some w.
Proof.
  split; generalize dependent w0; generalize dependent w;
  induction T; intros; [destruct H as [M H]|destruct H as [M H]| |].
  { inversion H. } (* base case T = nil *)
  destruct a as [f l]. inversion H. unfold inner_perceptron.
  destruct (correct_class (Qvec_dot w0 (consb f)) l) eqn:H2.
  fold (inner_perceptron T w0). apply IHT. exists M. apply H1.
  fold (inner_perceptron T (Qvec_plus w0 (Qvec_mult_class l (consb f)))).
  destruct (inner_perceptron_MCE T (Qvec_plus w0 (Qvec_mult_class l (consb f)))) eqn:H3.
  destruct p as [L w'].
  assert (H4: inner_perceptron T (Qvec_plus w0 (Qvec_mult_class l (consb f))) = Some w').
  apply IHT. exists L. apply H3. rewrite H4. inversion H1; subst; auto.
  apply inner_perceptron_MCE_inner_perceptron_None in H3.
  rewrite H3. inversion H1; subst; auto.
  { inversion H. } (* base case T = nil *)
  destruct a as [f l]. inversion H. unfold inner_perceptron_MCE.
  destruct (correct_class (Qvec_dot w0 (consb f)) l) eqn: H6.
  fold (inner_perceptron_MCE T w0). apply IHT with w w0 in H1. apply H1.
  destruct (inner_perceptron T (Qvec_plus w0 (Qvec_mult_class l (consb f)))) eqn:H2.
  inversion H1; subst. fold (inner_perceptron_MCE T (Qvec_plus w0 (Qvec_mult_class l (consb f)))).
  apply IHT in H2. destruct H2 as [M H2]. rewrite H2. exists (List.cons (f, l) M). auto.
  fold (inner_perceptron_MCE T (Qvec_plus w0 (Qvec_mult_class l (consb f)))).
  apply inner_perceptron_MCE_inner_perceptron_None in H2.
  rewrite H2. exists (List.cons (f,l) List.nil). inversion H1; subst. auto. Qed.

Theorem inner_perceptron_average_None : forall {n : nat} T (w u : Qvec (S n)) c,
  inner_average_perceptron T w u c = None <-> inner_perceptron T w = None.
Proof.
  intros n T; induction T; intros; split; intros; auto.
  + (* -> *) simpl in *. destruct a.
    destruct (correct_class (Qvec_dot w (consb q)) b).
    eapply IHT. apply H.
    destruct (inner_average_perceptron T _ _ (S c)); inversion H.
  + (* <- *) simpl in *. destruct a.
    destruct (correct_class (Qvec_dot w (consb q)) b).
    apply IHT, H.
    destruct (inner_perceptron T _); inversion H.
Qed.

Theorem inner_perceptron_average_Some : forall {n : nat} T (w w' u : Qvec (S n)) c,
  (exists u', inner_average_perceptron T w u c = Some (w', u')) <->
  inner_perceptron T w = Some w'.
Proof.
  intros n T; induction T; intros; split; intros.
  + destruct H as [? H]. inversion H.
  + inversion H.
  + simpl in *. destruct a. destruct (correct_class _ _).
    apply IHT in H. apply H.
    destruct (inner_average_perceptron _ _ _ _) eqn:?H. destruct p.
    rewrite <- H0 in H. apply IHT in H. rewrite H. reflexivity.
    apply inner_perceptron_average_None in H0. rewrite H0.
    destruct H as [? H]. inversion H; subst. reflexivity.
  + simpl in *. destruct a. destruct (correct_class _ _).
    apply IHT, H.
    destruct (inner_perceptron T _) eqn:?H.
    eapply IHT in H0. destruct H0 as [? H0].
    rewrite H0. inversion H; subst. exists x. reflexivity.
    eapply inner_perceptron_average_None in H0.
    rewrite H0. inversion H; subst.
    eexists. reflexivity.
Qed.

 (***************************************************************************************************
    Links return values of MCE, Perceptron_MCE and perceptron.
  ***************************************************************************************************)
Lemma Perceptron_MCE_MCE : forall {n : nat} (E : nat) (T M : list ((Qvec n)*bool)) (w0 w : Qvec (S n)),
  perceptron_MCE E T w0 = Some (M, w) -> MCE E T w0 = M.
Proof.
  intros n E. induction E; intros.
  { inversion H. } (* base case *)
  inversion H. unfold MCE. destruct (inner_perceptron_MCE T w0).
  destruct p as [L w']. fold (MCE E T w'). destruct (perceptron_MCE E T w') eqn:H2.
  destruct p as [L' w'']. apply IHE in H2. rewrite H2.
  inversion H1; subst; clear H1; auto. inversion H1.
  inversion H1; subst; clear H1; auto. Qed.

Theorem perceptron_MCE_perceptron : forall {n : nat} (E : nat) T (w0 w : Qvec (S n)),
  (exists M, perceptron_MCE E T w0 = Some (M, w)) <-> perceptron E T w0 = Some w.
Proof.
  split; generalize dependent T; generalize dependent w0;
  generalize dependent w; induction E; intros;
  [destruct H as [M H]| destruct H as [M H]| |].
  { inversion H. } (* base case E = 0 *)
  inversion H. unfold perceptron. destruct (inner_perceptron_MCE T w0) eqn:H2.
  destruct p as [L w']. assert (H3: inner_perceptron T w0 = Some w').
  apply inner_perceptron_MCE_inner_perceptron. exists L. apply H2. rewrite H3.
  fold (perceptron E T w'). destruct (perceptron_MCE E T w') eqn:H4.
  apply IHE. destruct p as [L' w'']. exists L'. inversion H1; subst.
  apply H4. inversion H1. apply inner_perceptron_MCE_inner_perceptron_None in H2. rewrite H2.
  inversion H1; subst. auto.
  { inversion H. } (* base case E = 0 *)
  inversion H. destruct (inner_perceptron T w0) eqn:H2. apply IHE in H1.
  destruct H1 as [M H1]. unfold perceptron_MCE. apply inner_perceptron_MCE_inner_perceptron in H2.
  destruct H2 as [M' H2]. rewrite H2. fold (perceptron_MCE E T q). rewrite H1. exists (List.app M' M).
  auto. inversion H1; subst; clear H1. apply inner_perceptron_MCE_inner_perceptron_None in H2.
  unfold perceptron_MCE. rewrite H2. exists List.nil. auto. Qed.

Theorem perceptron_average_perceptron_aux: forall (n : nat) (E : nat) (T : list ((Qvec n)*bool))
                                         (w0 w u0 : Qvec (S n)) (c : nat),
  perceptron E T w0 = Some w <-> (exists u c', average_perceptron_aux E T w0 u0 c = Some (w, u, c')).
Proof.
  intros n E; induction E; intros; split; intros.
  + (* E = 0 -> *) inversion H.
  + (* E = 0 <- *) destruct H as [u [c' H]]. inversion H.
  + (* -> *) simpl in *. destruct (inner_perceptron T w0) eqn:?H.
    apply (inner_perceptron_average_Some _ _ _ u0 c) in H0.
    destruct H0 as [? H0]. eapply IHE in H. rewrite H0.
    apply H. inversion H; subst. eapply inner_perceptron_average_None in H0.
    rewrite H0. eexists. eexists. reflexivity.
  + simpl in *. destruct (inner_average_perceptron T _ _ _) eqn:?H.
    destruct p. assert (inner_perceptron T w0 = Some q).
    eapply inner_perceptron_average_Some. exists q0. apply H0.
    rewrite H1. apply IHE in H. apply H.
    apply inner_perceptron_average_None in H0. rewrite H0.
    destruct H as [? [? H]]. inversion H; subst. reflexivity.
Qed.

Theorem perceptron_average_perceptron : forall (n : nat) (E : nat) T (w0 : Qvec (S n)),
  (exists w, perceptron E T w0 = Some w) <-> (exists w, average_perceptron E T w0 = Some w).
Proof.
  intros. split; intros. destruct H as [w H].
  apply (perceptron_average_perceptron_aux _ _ _ _ _ w0 1) in H.
  unfold average_perceptron. destruct H as [u [c' H]].
  rewrite H. eexists. reflexivity.
  destruct H as [w H]. unfold average_perceptron in H.
  destruct (average_perceptron_aux _ _ _ _ _) eqn:?H.
  destruct p. destruct p. exists q. eapply perceptron_average_perceptron_aux.
  exists q0, n0. apply H0. inversion H.
Qed.

(***************************************************************************************************
    Show that w = Sum of Misclassified Errors
  ***************************************************************************************************)
Lemma inner_perceptron_MCE_sum_m_w : forall {n : nat} (T M: (list ((Qvec n)*bool))) (w0 w: Qvec (S n)),
  inner_perceptron_MCE T w0 = Some (M, w) -> w = Qvec_sum_class w0 M.
Proof.
  intros n T. induction T; intros.
  { inversion H. } (* base case T = nil *)
  destruct a as [f l]. inversion H. destruct (correct_class (Qvec_dot w0 (consb f)) l).
  apply IHT in H1. apply H1.
  destruct (inner_perceptron_MCE T (Qvec_plus w0 (Qvec_mult_class l (consb f)))) eqn:H3;
  [destruct p as [M' w']; apply IHT in H3|]; inversion H1; subst; clear H1;
  [rewrite <- H4|]; reflexivity. Qed.

Lemma perceptron_MCE_sum_m_w : forall {n : nat} (E : nat) (T M: (list ((Qvec n)*bool))) (w0 w: Qvec (S n)),
  perceptron_MCE E T w0 = Some (M, w) -> w = Qvec_sum_class w0 M.
Proof.
  intros n E. induction E; intros.
  { inversion H. } (* base case *)
  inversion H. destruct (inner_perceptron_MCE T w0) eqn:H2. destruct p as [M' w'].
  apply inner_perceptron_MCE_sum_m_w in H2. destruct (perceptron_MCE E T w') eqn: H3.
  destruct p as [M'' W'']. inversion H1; subst; clear H1. apply IHE in H3.
  rewrite Qvec_sum_class_append in H3. apply H3. inversion H1.
  inversion H1; subst; clear H1. reflexivity. Qed.

 (***************************************************************************************************
    If Perceptron_MCE E T w0 = Some (M, w) then that is a fix point (ie No amount of additional
    fuel will change the output.
  ***************************************************************************************************)
Theorem perceptron_MCE_S : forall {n : nat} (E : nat) (w w0 : Qvec (S n)) (T M : list ((Qvec n)*bool)),
  perceptron_MCE E T w0 = Some (M, w) -> perceptron_MCE (S E) T w0 = Some (M, w).
Proof.
  intros n E. induction E; intros.
  { inversion H. } (* Base Case E = 0 *)
  simpl in H. simpl.
  destruct (inner_perceptron_MCE T w0). destruct p as [L w'].
  destruct (perceptron_MCE E T w') eqn: H1. destruct p as [L' w''].
  apply IHE in H1. simpl in H1.
  destruct (inner_perceptron_MCE T w'). destruct p as [L'' w'''].
  destruct (perceptron_MCE E T w'''). destruct p as [L''' w''''].
  inversion H1; subst; clear H1. apply H. inversion H1.
  inversion H1; subst; clear H1. apply H. inversion H. apply H. Qed.

Lemma perceptron_MCE_done : forall {n : nat} (E0 E : nat) (w w0 : Qvec (S n)) (T M : list ((Qvec n)*bool)),
  E >= E0 -> perceptron_MCE E0 T w0 = Some (M, w) -> perceptron_MCE E T w0 = Some (M, w).
Proof.
  intros. induction H. apply H0.
  apply perceptron_MCE_S in IHle. apply IHle. Qed.

 (***************************************************************************************************
    inner_perceptron_MCE = Some (List.nil, _) is an invalid state. Useful for Proofs about MCE
  ***************************************************************************************************)
Lemma inner_perceptron_MCE_nil_false : forall {n: nat} (w0 w: Qvec (S n)) (T : list ((Qvec n)*bool)),
  inner_perceptron_MCE T w0 = Some (List.nil, w) -> False.
Proof.
  intros n w0 w T. revert w w0. induction T; intros; inversion H.
  destruct a as [f l].
  destruct (correct_class (Qvec_dot w0 (consb f)) l).
    apply IHT in H1; inversion H1.
    destruct (inner_perceptron_MCE T (Qvec_plus w0 (Qvec_mult_class l (consb f))));
    [destruct p as [L w']| ]; inversion H1. Qed.

 (***************************************************************************************************
    If MCE E T w0 = MCE (S E) T w0 then that is a fix point. (Has Converged to a single value).
  ***************************************************************************************************)
Lemma MCE_S : forall {n : nat} (E : nat) (T : list ((Qvec n)*bool)) (w0 : Qvec (S n)),
  MCE E T w0 = MCE (S E) T w0 -> MCE (S E) T w0 = MCE (S (S E)) T w0.
Proof.
  intros n E. induction E; intros.
  rewrite <- H. simpl. simpl in H.
  destruct (inner_perceptron_MCE T w0) eqn:H0. destruct p as [L w].
    destruct L; [apply inner_perceptron_MCE_nil_false in H0; inversion H0 | inversion H].
    reflexivity.
  unfold MCE in H. destruct (inner_perceptron_MCE T w0) eqn:H1. destruct p as [L w].
  fold (MCE E T w) in H. fold (MCE (S E) T w) in H.
  apply List.app_inv_head in H. apply IHE in H.
  unfold MCE. rewrite H1. fold (MCE (S E) T w). fold (MCE (S (S E)) T w).
  rewrite H. reflexivity.
  simpl. rewrite H1. reflexivity. Qed.

Lemma MCE_done : forall {n : nat} (E0 E : nat) (w0 : Qvec (S n)) (T : list ((Qvec n)*bool)),
  E >= E0 -> MCE E0 T w0 = MCE (S E0) T w0 -> MCE E0 T w0 = MCE E T w0.
Proof.
  intros. revert dependent w0. revert dependent T. induction H; intros.
  reflexivity. assert (H1 := H0).
  apply IHle in H0. rewrite H1.
  simpl. destruct (inner_perceptron_MCE T w0) eqn:H2. destruct p as [L w].
  assert (H3: (MCE E0 T w) = (MCE (S E0) T w)).
    destruct E0. simpl in H1. rewrite H2 in H1.
    destruct L. apply inner_perceptron_MCE_nil_false in H2. inversion H2. inversion H1.
    unfold MCE in H1. rewrite H2 in H1. fold (MCE E0 T w) in H1.
    fold (MCE (S E0) T w) in H1. apply List.app_inv_head in H1.
    apply MCE_S in H1. apply H1.
  apply IHle in H3. rewrite H3. reflexivity. reflexivity. Qed.

 (***************************************************************************************************
    If MCE has reached a fix point then perceptron_MCE on the same arguments will too.
  ***************************************************************************************************)
Lemma MCE_eq_perceptron_MCE : forall {n : nat} (E : nat) (w0 : Qvec (S n)) (T : list ((Qvec n)*bool)),
 MCE E T w0 = MCE (S E) T w0 ->
 perceptron_MCE (S E) T w0 = Some ((MCE E T w0), Qvec_sum_class w0 (MCE E T w0)).
Proof.
  intros n E. induction E; intros.
  simpl in H. destruct (inner_perceptron_MCE T w0) eqn:H1.
    destruct p as [L w']. destruct L.
      apply inner_perceptron_MCE_nil_false in H1; inversion H1.
      inversion H.
    simpl; rewrite H1. auto.
  unfold MCE in H. destruct (inner_perceptron_MCE T w0) eqn:H1.
  destruct p as [L w']. fold (MCE E T w') in H.
  fold (MCE (S E) T w') in H. apply List.app_inv_head in H.
  apply IHE in H. simpl. rewrite H1. simpl in H. rewrite H.
  apply inner_perceptron_MCE_sum_m_w in H1. rewrite H1.
  rewrite Qvec_sum_class_append. auto.
  simpl. rewrite H1. auto. Qed.

 (***************************************************************************************************
    Show that MCE either misclassifies at least E elements after E iterations or is at a fixed point.
  ***************************************************************************************************)
Lemma MCE_eq_length : forall {n : nat} (E1 E2 : nat) (w0 : Qvec (S n)) (T : list ((Qvec n)*bool)),
  length (MCE E1 T w0) = length (MCE E2 T w0) -> (MCE E1 T w0) = (MCE E2 T w0).
Proof.
  intros n E1. induction E1; intros.
{ simpl. simpl in H. destruct (MCE E2 T w0). auto. inversion H. } (* Base Case *)
  simpl in H. destruct (inner_perceptron_MCE T w0) eqn:H1.
  { destruct p as [L w]. destruct E2. simpl in H.
    { destruct L. apply inner_perceptron_MCE_nil_false in H1. inversion H1. inversion H. }
    simpl in H. rewrite H1 in H. rewrite List.app_length in H. rewrite List.app_length in H.
    assert (forall (a b c : nat), a + b = a + c -> b = c). intros. omega.
    apply H0 in H. apply IHE1 in H. simpl. rewrite H1. rewrite H. auto.
  }
  simpl in H. destruct E2; simpl; rewrite H1; auto. Qed.

Lemma MCE_progress : forall {n : nat} (E : nat) (w0 : Qvec (S n)) (T : list ((Qvec n)*bool)),
  length (MCE E T w0) >= E \/ MCE E T w0 = MCE (S E) T w0.
Proof.
  intros n E. induction E; intros.
  { left. auto. }
  assert (H := (IHE w0 T)).
  inversion H.
  { unfold MCE. destruct (inner_perceptron_MCE T w0) eqn:H1. destruct p as [L w].
      fold (MCE E T w). fold (MCE (S E) T w).
      destruct L. apply inner_perceptron_MCE_nil_false in H1; inversion H1.
      assert (H2 := (IHE w T)). inversion H2.
      { left. inversion H3. rewrite List.app_length.
        repeat (rewrite <- H4). simpl. omega.
        rewrite List.app_length. rewrite <- H4. simpl. omega.
      } right. rewrite H3. reflexivity.
    right. reflexivity.
  } right. apply MCE_S in H0. apply H0. Qed.

(*************************************************************************************************
    Show that the average perceptron reaches a fixed point when it terminates
    (i.e. no additional fuel changes it's return value)
 *************************************************************************************************)

Theorem average_perceptron_aux_S : forall {n : nat} (E : nat) T (w0 u0 : Qvec (S n)) p c,
  average_perceptron_aux E T w0 u0 c = Some p -> average_perceptron_aux (S E) T w0 u0 c = Some p.
Proof.
  intros n E; induction E; intros. inversion H.
  unfold average_perceptron_aux in H.
  unfold average_perceptron_aux.
  destruct (inner_average_perceptron T _ _ _). destruct p0.
  fold (average_perceptron_aux E T q q0 (length T + c)) in H.
  apply IHE in H. simpl in H.
  destruct (inner_average_perceptron T _ _ _). destruct p0.
  apply H. apply H. apply H.
Qed.

Theorem average_perceptron_aux_done : forall {n : nat} (E0 E : nat) T (w0 u0 : Qvec (S n)) p c,
  E >= E0 -> average_perceptron_aux E0 T w0 u0 c = Some p ->
  average_perceptron_aux E T w0 u0 c = Some p.
Proof.
  intros. induction H. apply H0. apply average_perceptron_aux_S. apply IHle.
Qed.

Theorem average_perceptron_done : forall {n : nat} (E0 E : nat) T (w0 w : Qvec (S n)),
  E >= E0 -> average_perceptron E0 T w0 = Some w -> average_perceptron E T w0 = Some w.
Proof.
  intros. unfold average_perceptron in *.
  destruct (average_perceptron_aux E0 T w0 w0 1) eqn:?H. destruct p. destruct p.
  apply (average_perceptron_aux_done _ E) in H1.
  rewrite H1. apply H0. apply H. inversion H0.
Qed.


Require Import Coq.Classes.Morphisms.
Require Import Coq.ZArith.ZArith Coq.micromega.Lia.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Tactics.DestructHead.
Require Import Crypto.Util.ZUtil.Definitions.
Require Import Crypto.Util.ZUtil.Hints.PullPush.
Require Import Crypto.Util.ZUtil.ZSimplify.Core.
Require Import Crypto.Util.ZUtil.ZSimplify.Simple.
Require Import Crypto.Util.ZUtil.Tactics.DivModToQuotRem.
Require Import Crypto.Util.ZUtil.Tactics.ZeroBounds.
Require Import Crypto.Util.ZUtil.Tactics.LtbToLt.
Local Open Scope Z_scope.

Module Z.
  Hint Rewrite Z.log2_pow2 Z.pow_1_r using solve [auto using Z.log2_nonneg with zarith] : push_Zpow.

  Lemma cc_m_eq_full : forall s x, Z.cc_m s x = if (s =? 1) then x * 2 else x / (s / 2).
  Proof.
    intros; cbv [Z.cc_m].
    destruct (Decidable.dec (2 < s)).
    { assert (1 <= Z.log2 s) by (rewrite <-Z.log2_2; auto using Z.log2_le_mono with lia).
      break_match; Z.ltb_to_lt; try lia; [].
      match goal with H : _ = s |- _ => rewrite <-H end.
      autorewrite with Zshift_to_pow push_Zpow.
      reflexivity. }
    { assert (s < 0 \/ s = 0 \/ s = 1 \/ s = 2) by lia.
      destruct_head'_or; (subst s || destruct s); try reflexivity; try (cbn; autorewrite with zsimplify_const; lia).
      change (Z.log2 1 - 1) with (-1).
      rewrite (Z.shiftr_opp_r _ 1), Z.shiftl_mul_pow2 by lia.
      reflexivity. }
  Qed.

  Lemma cc_m_eq : forall s x, 2 < s -> Z.cc_m s x = x / (s / 2).
  Proof. intros; rewrite cc_m_eq_full; break_match; Z.ltb_to_lt; lia. Qed.

  Lemma cc_m_small : forall s x, s mod 2 = 0 -> 0 <= x < s -> 0 <= Z.cc_m s x < 2.
  Proof.
    intros. rewrite cc_m_eq_full.
    repeat match goal with
           | _ => break_innermost_match_step
           | _ => progress Z.ltb_to_lt
           | _ => split
           | _ => apply Z.div_lt_upper_bound
           | _ => solve [Z.zero_bounds]
           end.
    Z.div_mod_to_quot_rem_in_goal; lia.
  Qed.

  Lemma cc_m_Proper_le_r_gen s
    : (0 <= s /\ Proper (Z.le ==> Z.le) (Definitions.Z.cc_m s))
      \/ (s < 0 /\ Proper (Basics.flip Z.le ==> Z.le) (Definitions.Z.cc_m s)).
  Proof.
    cbv [Basics.flip].
    destruct (Z_lt_le_dec s 0); [ right | left ]; (split; [ assumption | ]).
    all: intros x0 x1 H; rewrite !cc_m_eq_full; break_innermost_match; Z.ltb_to_lt; [ nia | ].
    all: Z.div_mod_to_quot_rem; nia.
  Qed.
  Hint Resolve cc_m_Proper_le_r_gen : zarith.

  Lemma cc_m_Proper_le_r s
    : Proper (Z.le ==> Z.le) (Definitions.Z.cc_m s)
      \/ Proper (Basics.flip Z.le ==> Z.le) (Definitions.Z.cc_m s).
  Proof. pose proof (cc_m_Proper_le_r_gen s); tauto. Qed.
  Hint Resolve cc_m_Proper_le_r : zarith.

  Lemma cc_m_Proper_le_r_pos s
    : Proper (Z.le ==> Z.le) (Definitions.Z.cc_m (Z.pos s)).
  Proof. pose proof (cc_m_Proper_le_r_gen (Z.pos s)); intuition lia. Qed.
  Hint Resolve cc_m_Proper_le_r_pos : zarith.

  Lemma cc_m_Proper_le_r_neg s
    : Proper (Basics.flip Z.le ==> Z.le) (Definitions.Z.cc_m (Z.neg s)).
  Proof. pose proof (cc_m_Proper_le_r_gen (Z.neg s)); intuition lia. Qed.
  Hint Resolve cc_m_Proper_le_r_neg : zarith.

  Lemma cc_m_Proper_le_r_0
    : Proper (Z.le ==> Z.le) (Definitions.Z.cc_m 0).
  Proof. pose proof (cc_m_Proper_le_r_gen 0); intuition lia. Qed.
  Hint Resolve cc_m_Proper_le_r_0 : zarith.
End Z.


Require Import NArith.NArith.
Require Import ZArith.ZArith.
Require Import Bool.Bool.
Require Import Psatz.

Definition WIDTH : N := 64%N.

Local Infix ".&." := N.land (at level 50, no associativity).
Local Infix ".|." := N.lor (at level 50, no associativity).

Local Definition revNat : N -> N :=
  fun x1 =>
    let 'x2 := ((N.shiftr x1 1) .&.(**) 6148914691236517205) .|.(**)
                 (N.shiftl (x1 .&.(**) 6148914691236517205) 1) in
    let 'x3 := ((N.shiftr x2 2) .&.(**) 3689348814741910323) .|.(**)
                 (N.shiftl (x2 .&.(**) 3689348814741910323) 2) in
    let 'x4 := ((N.shiftr x3 4) .&.(**) 1085102592571150095) .|.(**)
                 (N.shiftl (x3 .&.(**) 1085102592571150095) 4) in
    let 'x5 := ((N.shiftr x4 8) .&.(**) 71777214294589695) .|.(**)
                 (N.shiftl (x4 .&.(**) 71777214294589695) 8) in
    let 'x6 := ((N.shiftr x5 16) .&.(**) 281470681808895) .|.(**)
                 (N.shiftl (x5 .&.(**) 281470681808895) 16) in
    (((N.shiftr x6 32) .|.(**) (N.shiftl x6 32)) mod 2 ^ 64)%N.

Inductive Term :=
  | Input : Term
  | Const : N -> Term
  | LAnd : Term -> Term -> Term
  | LOr : Term -> Term -> Term
  | ShiftL : Term -> N -> Term
  | ShiftR : Term -> N -> Term
  | ModPow2 : Term -> N -> Term.

Fixpoint evalTerm (n : N) (t : Term) : N :=
  match t with
  | Input => n
  | Const n => n
  | LAnd t1 t2 => N.land (evalTerm n t1) (evalTerm n t2)
  | LOr  t1 t2 => N.lor  (evalTerm n t1) (evalTerm n t2)
  | ShiftL t1 s => N.shiftl (evalTerm n t1) s
  | ShiftR t1 s => N.shiftr (evalTerm n t1) s
  | ModPow2 t1 s => (evalTerm n t1 mod 2^s)%N
 end.

Fixpoint checkbit (n : N) (i : N) (t : Term) : bool :=
  match t with
  | Input => N.testbit n i
  | Const c => N.testbit c i
  | LAnd t1 t2 => if checkbit n i t2 then checkbit n i t1 else false
  | LOr  t1 t2 => orb  (checkbit n i t1) (checkbit n i t2)
  | ShiftL t1 s => if (i <? s)%N then false else checkbit n (i - s) t1
  | ShiftR t1 s => checkbit n (i + s) t1
  | ModPow2 t1 s => if (i <? s)%N then checkbit n i t1 else false
 end.

Lemma N_shiftl_spec_eq:
  forall n i j,
  N.testbit (N.shiftl n i) j =
    (if j <? i then false else N.testbit n (j - i))%N.
Proof.
  intros.
  destruct (N.ltb_spec j i).
  * apply N.shiftl_spec_low; assumption.
  * apply N.shiftl_spec_high'; assumption.
Qed.

Lemma checkbit_correct: forall n i t,
  checkbit n i t = N.testbit (evalTerm n t) i.
Proof.
  intros. revert i. induction t; intros i; simpl.
  * reflexivity.
  * reflexivity.
  * rewrite N.land_spec, IHt1, IHt2.
    destruct (N.testbit (evalTerm n t2) i); rewrite ?andb_true_r, ?andb_false_r; reflexivity.
  * rewrite N.lor_spec, IHt1, IHt2. reflexivity.
  * rewrite N_shiftl_spec_eq, IHt. reflexivity.
  * rewrite N.shiftr_spec, IHt. reflexivity. apply N.le_0_l.
  * destruct (N.ltb_spec i n0).
    - rewrite N.mod_pow2_bits_low by assumption.
      rewrite IHt. reflexivity.
    - rewrite N.mod_pow2_bits_high by assumption.
      reflexivity.
Qed.

Lemma revNat_spec:
  forall n i, (i < WIDTH)%N ->
  N.testbit (revNat n) i = N.testbit n (WIDTH - 1 - i)%N.
Proof.
  intros.
  unfold WIDTH in *.
  Ltac next :=
    match goal with [ H : (?i < ?n)%N |- _ ] =>
      let m := eval simpl in (n - 1)%N in
      idtac "Now solving i =" m;
      assert (Hor : (i = m \/ i < m)%N) by lia; clear H; destruct Hor
    end.

  unfold revNat.

  Ltac toTerm n x :=
    let rec go x :=
       match x with
        | (?y mod 2^?k)%N => let t1 := go y in constr:(ModPow2 t1 k)
        | N.land ?e1 ?e2 =>  let t1 := go e1 in let t2 := go e2 in constr:(LAnd t1 t2)
        | N.lor  ?e1 ?e2 =>  let t1 := go e1 in let t2 := go e2 in constr:(LOr t1 t2)
        | N.shiftr ?e1 ?s => let t1 := go e1 in let c := eval simpl in s in constr:(ShiftR t1 c)
        | N.shiftl ?e1 ?s => let t1 := go e1 in let c := eval simpl in s in constr:(ShiftL t1 c)
        | n => constr:(Input)
        | _ => let c := eval simpl in x in constr:(Const c)
       end
     in go x.

  lazymatch goal with |- N.testbit ?exp i = ?rhs =>
    let tm := toTerm n exp in
    change (N.testbit (evalTerm n tm) i = rhs)
   end.
  rewrite <- checkbit_correct.
  do 64 (next; [subst; simpl checkbit; rewrite ?orb_false_r; reflexivity|]).
  apply N.nlt_0_r in H. contradiction.
Qed.

(* Only true due to the edit which adds a [_ % 2^64] at the end *)
Lemma isBitMask0_revNat:
  forall n, (revNat n < 2^WIDTH)%N.
Proof.
  intros.
  apply N.mod_lt.
  intro. inversion H.
Qed.