(* ###################################################################### *)
(** * Lists

    We will now shift gears and study more interesting functional
    programs; namely, programs that manipulate _lists_. *)

Module List.

(** Here's a polymorphic definition of a [list] type in Coq: *)

Inductive list (T : Type) :=
| nil : list T
| cons : T -> list T -> list T.

(** In Coq, polymorphism is _explicit_, which means that we need to
    supply type arguments when using polymorphic functions. *)

Definition singleton_list (T : Type) (x : T) :=
  cons T x (nil T).

(** Fortunately, we can avoid providing arguments when Coq has enough
    information to figure them out. In the example below, since [x]
    has type [T], Coq can infer that the type argument for [cons] and
    [nil] must be [T] too. Hence, we can just write a wildcard "_"
    instead of [T], which has the effect of asking Coq to figure out
    what to put there on its own: *)

Definition singleton_list' (T : Type) (x : T) :=
  cons _ x (nil _).

(* We can also instruct Coq once and for all to try to infer arguments
   on its own. This feature is called _implicit arguments_.

   We use "Arguments" to say which arguments of a definition are
   implicit (by surrounding them with curly braces {...}). We can also
   declare them as implicit at definition time: *)

Arguments nil {T}.
Arguments cons {T} _ _.
Definition singleton_list'' {T} (x : T) :=
  cons x nil.

Check (singleton_list'' 3).

(** Finally, we can turn off implicit argument inference for a
    definition locally, by prepending its name with a "@" sign: *)

Check (@singleton_list'' nat).

(** In Coq, polymorphism appears on the type of programs as a
    universal quantifier [forall]: *)

Check @singleton_list''.
Check @nil.

Notation "h :: t" := (cons h t) (at level 60, right associativity).
Notation "[ ]" := (nil).
Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).

(* Exercise: Define "snoc", which adds an element to the end of a list. *)

Fixpoint snoc {T} (l : list T) (x : T) : list T :=
  [] (* Fill in here *).

Fixpoint app {T} (l1 l2 : list T) : list T :=
  match l1 with
  | [] => l2
  | h :: l1' => h :: (app l1' l2)
  end.

Notation "l1 ++ l2" := (app l1 l2) (at level 60, right associativity).

(** Let us prove some simple facts about lists. To perform an
    inductive proof on a list, we also use the [induction] tactic;
    this has the effect of giving us an inductive hypothesis about the
    tail of the list. Notice that in the proof below we have to give
    names both to the head and to the tail of [l1] *)

Lemma app_assoc :
  forall T (l1 l2 l3 : list T),
    l1 ++ (l2 ++ l3) = (l1 ++ l2) ++ l3.
Proof.
  intros T l1 l2 l3.
  induction l1 as [|h1 t1 IH].
  - (* [] *)
    simpl.
    reflexivity.
  - (* h1 :: t1 *)
    simpl.
    rewrite IH.
    reflexivity.
Qed.

(* Exercise *)

Lemma snoc_app :
  forall T (l : list T) (x : T),
    snoc l x = l ++ [x].
Proof.
  (* Fill in here *)
Admitted.

End List.

(** Lists, of course, are also defined in the standard library. *)

Require Import Coq.Lists.List.
Import ListNotations.

(** Notice that the definition of rev (list reversal) given in the
    standard library runs in quadratic time. *)

Print rev. (* [C-c C-a C-p] in Proof General *)

(** This is a tail-recursive equivalent that runs in linear time. *)

Fixpoint tr_rev_aux {T} (l acc : list T) : list T :=
  match l with
  | [] => acc
  | x :: l => tr_rev_aux l (x :: acc)
  end.

Definition tr_rev {T} (l: list T) := tr_rev_aux l [].

(** Here, [acc] is an accumulator argument that holds the portion of
    the list that we have reversed so far. Let's prove that [tr_rev]
    is equivalent to [rev]. For this we will need another tactic:

    New Tactic
    ----------

    - [unfold]: Calling [unfold foo] expands the definition of [foo]
      in the goal.
*)

Lemma tr_rev_correct_try_one :
  forall T (l : list T),
    tr_rev l = rev l.
Proof.
  intros T l.
  unfold tr_rev.
  induction l as [| h t IH].
  + simpl.
    reflexivity.
  + simpl.
    (* and now we're stuck... *)
Abort.

(** The problem is that the result we are trying to prove is not
    general enough. We will need the following auxiliary lemma: *)

Lemma tr_rev_aux_correct :
  forall T (l1 l2 : list T),
    tr_rev_aux l1 l2 = rev l1 ++ l2.
Proof.
  intros T l1 l2.
  induction l1 as [|x l1 IH].
  - simpl. reflexivity.
  - simpl.

(** Our inductive hypothesis is too weak to proceed. We want
    [tr_rev_aux l1 l2 = rev l1 ++ l2] for all [l2]. Let's try again
    from the start. *)

Restart.
  intros T l1. (* Now we don't introduce l2, leaving it general. *)
  induction l1 as [|x l1 IH].
  - intros l2. simpl. reflexivity.
  - intros l2. (* Behold our induction hypothesis! *)
    simpl.
    rewrite IH.

(** We can use the [SearchAbout] command to look up lemmas that can be
    used with certain expressions ([C-c C-a C-a] in Proof General). *)

    SearchAbout (_ ++ _ ++ _).
    rewrite <- app_assoc.
    simpl.
    reflexivity.
Qed.

(** Our result follows easily: *)

Lemma tr_rev_correct :
  forall T (l : list T),
    tr_rev l = rev l.
Proof.
  intros T l.
  unfold tr_rev.
  rewrite tr_rev_aux_correct.
  SearchAbout (_ ++ []).
  apply app_nil_r.
Qed.

(* ###################################################################### *)
(** * Dependently Typed Programming *)

Definition stack := list.

Definition push {T} (x:T) (s : stack T) : stack T  := x :: s.

Fail Definition pop {T} (s : stack T) : T * stack T :=
  match s with
  | h :: t => (h, t)
  (* What do we do for an empty stack? *)
  end.

(** Traditional approach: Use an [option] type. *)

Definition pop {T} (s : stack T) : option T * stack T :=
  match s with
  | nil => (None, s)
  | h :: t => (Some h, t)
  end.

(* We can avoid having to use (and check) option types by defining a
   size-indexed stack. *)

Inductive istack (T : Type) : nat -> Type :=
  | empty : istack T O
  | add :  forall n, T -> istack T n -> istack T (S n).

Arguments empty {T}.
Arguments add {T} {n} _ _.

Definition ipush {T} {n:nat} (x:T) (s : istack T n) : istack T (S n) := add x s.

Check add.

Definition ipop {T} {n} (s : istack T (S n)) : T * istack T n :=
  match s with
  | add _ top bottom => (top, bottom)
  end.

Fixpoint combine {T} {n1} {n2} (s1 : istack T n1) (s2 : istack T n2) :
  istack T (n1 + n2) :=
    match s1 with
    | empty => s2
    | add _ x s1' => add x (combine s1' s2)
    end.

(* Exercise: Write a snoc function to add an element to the bottom of
   an indexed stack. Do not use the combine function (in this case, it will make
   life difficult.) *)


Lemma not_true_eq_false : forall (b:bool), b <> true -> b = false.
Proof.
 destruct b;intros;trivial.
 elim H.
 exact (refl_equal true).
Qed.

Section BUG.

 Variable b : bool.
 Hypothesis H  : b <> true.
 Hypothesis H0 : b = true.
 Hypothesis H1 : b <> true.

 Goal False.
  rewrite (not_true_eq_false _ H) in * |-.
  contradiction.
 Qed.

End BUG.


Require Import HoTT.
Require Import FSets lattice_interface.

Section interface.
  Context `{Univalence}.
  Variable (T : Type -> Type)
           (f : forall A, T A -> FSet A).
  Context `{forall A, hasMembership (T A) A
          , forall A, hasEmpty (T A)
          , forall A, hasSingleton (T A) A
          , forall A, hasUnion (T A)
          , forall A, hasComprehension (T A) A}.

  Class sets :=
    {
      f_empty : forall A, f A ∅ = ∅ ;
      f_singleton : forall A a, f A (singleton a) = {|a|};
      f_union : forall A X Y, f A (union X Y) = (f A X) ∪ (f A Y);
      f_filter : forall A φ X, f A (filter φ X) = {| f A X & φ |};
      f_member : forall A a X, member a X = a ∈ (f A X)
    }.

  Global Instance f_surjective A `{sets} : IsSurjection (f A).
  Proof.
    unfold IsSurjection.
    hinduction ; try (intros ; apply path_ishprop).
    - simple refine (BuildContr _ _ _).
      * refine (tr(∅;_)).
        apply f_empty.
      * intros ; apply path_ishprop.
    - intro a.
      simple refine (BuildContr _ _ _).
      * refine (tr({|a|};_)).
        apply f_singleton.
      * intros ; apply path_ishprop.
    - intros Y1 Y2 [X1' ?] [X2' ?].
      simple refine (BuildContr _ _ _).
      * simple refine (Trunc_rec _ X1') ; intros [X1 fX1].
        simple refine (Trunc_rec _ X2') ; intros [X2 fX2].
        refine (tr(X1 ∪ X2;_)).
        rewrite f_union, fX1, fX2.
        reflexivity.
      * intros ; apply path_ishprop.
  Defined.

End interface.

Section quotient_surjection.
  Variable (A B : Type)
           (f : A -> B)
           (H : IsSurjection f).
  Context `{IsHSet B} `{Univalence}.

  Definition f_eq : relation A := fun a1 a2 => f a1 = f a2.
  Definition quotientB : Type := quotient f_eq.

  Global Instance quotientB_recursion : HitRecursion quotientB :=
    {
      indTy := _;
      recTy :=
        forall (P : Type) (HP: IsHSet P) (u : A -> P),
          (forall x y : A, f_eq x y -> u x = u y) -> quotientB -> P;
      H_inductor := quotient_ind f_eq ;
      H_recursor := @quotient_rec _ f_eq _
    }.

  Global Instance R_refl : Reflexive f_eq.
  Proof.
    intro.
    reflexivity.
  Defined.

  Global Instance R_sym : Symmetric f_eq.
  Proof.
    intros a b Hab.
    apply (Hab^).
  Defined.

  Global Instance R_trans : Transitive f_eq.
  Proof.
    intros a b c Hab Hbc.
    apply (Hab @ Hbc).
  Defined.

  Definition quotientB_to_B : quotientB -> B.
  Proof.
    hrecursion.
    - apply f.
    - done.
  Defined.

  Instance quotientB_emb : IsEmbedding (quotientB_to_B).
  Proof.
    apply isembedding_isinj_hset.
    unfold isinj.
    hrecursion ; [ | intros; apply path_ishprop ].
    intro.
    hrecursion ; [ | intros; apply path_ishprop ].
    intros.
      by apply related_classes_eq.
  Defined.

  Instance quotientB_surj : IsSurjection (quotientB_to_B).
  Proof.
    apply BuildIsSurjection.
    intros Y.
    destruct (H Y).
    simple refine (Trunc_rec _ center) ; intros [a fa].
    apply (tr(class_of _ a;fa)).
  Defined.

  Definition quotient_iso : quotientB <~> B.
  Proof.
    refine (BuildEquiv _ _ quotientB_to_B _).
    apply isequiv_surj_emb ; apply _.
  Defined.

  Definition reflect_eq : forall (X Y : A),
      f X = f Y -> f_eq X Y.
  Proof.
    done.
  Defined.

  Lemma same_class : forall (X Y : A),
      class_of f_eq X = class_of f_eq Y -> f_eq X Y.
  Proof.
    intros.
    simple refine (classes_eq_related _ _ _ _) ; assumption.
  Defined.

End quotient_surjection.

Arguments quotient_iso {_} {_} _ {_} {_} {_}.

Ltac reduce T :=
  intros ;
  repeat (rewrite (f_empty T _)
          || rewrite (f_singleton T _)
          || rewrite (f_union T _)
          || rewrite (f_filter T _)
          || rewrite (f_member T _)).

Section quotient_properties.
  Variable (T : Type -> Type).
  Variable (f : forall {A : Type}, T A -> FSet A).
  Context `{sets T f}.

  Definition set_eq A := f_eq (T A) (FSet A) (f A).
  Definition View A : Type := quotientB (T A) (FSet A) (f A).

  Instance f_is_surjective A : IsSurjection (f A).
  Proof.
    apply (f_surjective T f A).
  Defined.

  Global Instance view_union (A : Type) : hasUnion (View A).
  Proof.
    intros X Y.
    apply (quotient_iso _)^-1.
    simple refine (union _ _).
    - simple refine (quotient_iso (f A) X).
    - simple refine (quotient_iso (f A) Y).
  Defined.

  Definition well_defined_union (A : Type) (X Y : T A) :
    (class_of _ X) ∪ (class_of _ Y) = class_of _ (X ∪ Y).
  Proof.
    rewrite <- (eissect (quotient_iso _)).
    simpl.
    rewrite (f_union T _).
    reflexivity.
  Defined.

  Global Instance view_comprehension (A : Type) : hasComprehension (View A) A.
  Proof.
    intros ϕ X.
    apply (quotient_iso _)^-1.
    simple refine ({|_ & ϕ|}).
    apply (quotient_iso (f A) X).
  Defined.

  Definition well_defined_filter (A : Type) (ϕ : A -> Bool) (X : T A) :
    {|class_of _ X & ϕ|} = class_of _ {|X & ϕ|}.
  Proof.
    rewrite <- (eissect (quotient_iso _)).
    simpl.
    rewrite (f_filter T _).
    reflexivity.
  Defined.

  Global Instance View_empty A : hasEmpty (View A).
  Proof.
    apply ((quotient_iso _)^-1 ∅).
  Defined.

  Definition well_defined_empty A : ∅ = class_of (set_eq A) ∅.
  Proof.
    rewrite <- (eissect (quotient_iso _)).
    simpl.
    rewrite (f_empty T _).
    reflexivity.
  Defined.

  Global Instance View_singleton A: hasSingleton (View A) A.
  Proof.
    intro a ; apply ((quotient_iso _)^-1 {|a|}).
  Defined.

  Definition well_defined_sungleton A (a : A) : {|a|} = class_of _ {|a|}.
  Proof.
    rewrite <- (eissect (quotient_iso _)).
    simpl.
    rewrite (f_singleton T _).
    reflexivity.
  Defined.

  Global Instance View_member A : hasMembership (View A) A.
  Proof.
    intros a ; unfold View.
    hrecursion.
    - apply (member a).
    - intros X Y HXY.
      reduce T.
      apply (ap _ HXY).
  Defined.

  Instance View_max A : maximum (View A).
  Proof.
    apply view_union.
  Defined.

  Hint Unfold Commutative Associative Idempotent NeutralL NeutralR View_max view_union.

  Instance bottom_view A : bottom (View A).
  Proof.
    apply View_empty.
  Defined.

  Ltac sq1 := autounfold ; intros ; try f_ap
                         ; rewrite ?(eisretr (quotient_iso _))
                         ; eauto with lattice_hints typeclass_instances.

  Ltac sq2 := autounfold ; intros
              ; rewrite <- (eissect (quotient_iso _)), ?(eisretr (quotient_iso _))
              ; f_ap ; simpl
              ; reduce T ; eauto with lattice_hints typeclass_instances.

  Global Instance view_lattice A : JoinSemiLattice (View A).
  Proof.
    split ; try sq1 ; try sq2.
  Defined.

End quotient_properties.

Arguments set_eq {_} _ {_} _ _.

Section properties.
  Variable (T : Type -> Type) (f : forall A, T A -> FSet A).
  Context `{sets T f}.

  Definition set_subset : forall A, T A -> T A -> hProp :=
    fun A X Y => (f A X) ⊆ (f A Y).

  Definition empty_isIn : forall (A : Type) (a : A),
    a ∈ ∅ = False_hp.
  Proof.
    by (reduce T).
  Defined.

  Definition singleton_isIn : forall (A : Type) (a b : A),
    a ∈ {|b|} = merely (a = b).
  Proof.
    by (reduce T).
  Defined.

  Definition union_isIn : forall (A : Type) (a : A) (X Y : T A),
    a ∈ (X ∪ Y) = lor (a ∈ X) (a ∈ Y).
  Proof.
    by (reduce T).
  Defined.

  Definition filter_isIn : forall (A : Type) (a : A) (ϕ : A -> Bool) (X : T A),
    member a (filter ϕ X) = if ϕ a then member a X else False_hp.
  Proof.
    reduce T.
    apply properties.comprehension_isIn.
  Defined.

  Definition reflect_f_eq : forall (A : Type) (X Y : T A),
      class_of (set_eq f) X = class_of (set_eq f) Y -> set_eq f X Y.
  Proof.
    intros.
    refine (same_class _ _ _ _ _ _) ; assumption.
  Defined.

  Global Instance test (A : Type) (X Y : T A)
    : IsHProp  (forall a : A, a ∈ X = a ∈ Y).
  Proof.
    apply _.
  Defined.

  Lemma f_eq_ext (A : Type) (X Y : T A) :
    (forall a : A, a ∈ X = a ∈ Y) <~> set_eq f X Y.
  Proof.
    eapply equiv_iff_hprop_uncurried ; split.
    - intros HX.
      unfold set_eq, f_eq.
      apply fset_ext.
      intros a.
      rewrite <- ?(f_member T _).
      apply HX.
    - intros HX a.
      rewrite ?(f_member T _).
      f_ap.
  Defined.

  Ltac via_quotient := intros ; apply reflect_f_eq ; simpl
                       ; rewrite <- ?(well_defined_union T _), <- ?(well_defined_empty T _)
                       ; eauto with lattice_hints typeclass_instances.

  Lemma union_comm : forall A (X Y : T A),
      set_eq f (X ∪ Y) (Y ∪ X).
  Proof.
    via_quotient.
  Defined.

  Lemma union_assoc : forall A (X Y Z : T A),
    set_eq f ((X ∪ Y) ∪ Z) (X ∪ (Y ∪ Z)).
  Proof.
    via_quotient.
  Defined.

  Lemma union_idem : forall A (X : T A),
    set_eq f (X ∪ X) X.
  Proof.
    via_quotient.
  Defined.

  Lemma union_neutralL : forall A (X : T A),
    set_eq f (∅ ∪ X) X.
  Proof.
    via_quotient.
  Defined.

  Lemma union_neutralR : forall A (X : T A),
    set_eq f (X ∪ ∅) X.
  Proof.
    via_quotient.
  Defined.

End properties.

Section refinement.
  Variable (T S : Type -> Type).
  Variable (f : forall {A : Type}, T A -> FSet A).
  Variable (g : forall {A : Type}, S A -> FSet A).
  Context `{sets T f} `{sets S g}.

  Theorem transfer
          {A B : Type}
          `{IsHSet B}
          (h : T A -> B)
          (hresp : forall x y : T A, set_eq f x y -> h x = h y)
    : S A -> B.
  Proof.
    intros X.
    simple refine (@quotient_rec (T A) (set_eq f) _ _ _ h hresp _).
    pose (quotient_iso (f A))^-1.
    apply q.
    apply (quotient_iso (g A) (class_of _ X)).
  Defined.

  Definition refinement
          {A B : Type}
          `{IsHSet B}
          (h : FSet A -> B)
    : T A -> B
  := fun X => h(quotient_iso (f A) (class_of _ X)).
End refinement.


From mathcomp
Require Import all_ssreflect all_algebra all_field all_fingroup.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Lemma f2p_monic (p : {poly 'F_2}) :
  (p != 0)%R -> p \is monic.
Proof.
  move=> /negPf p0; apply/eqP.
  case lp0: (lead_coef p == 0)%R.
   by rewrite lead_coef_eq0 p0 in lp0.
  case: (lead_coef p) lp0 => [][]//[]// *.
  by apply/val_inj.
Qed.

Lemma f2eqp_eq (p q : {poly 'F_2}) : (p %= q)%R = (p == q).
Proof.
  case q0: (q == 0%R).
   by move/eqP: q0 => ->; rewrite eqp0.
  case p0: (p == 0%R).
   by move/eqP: p0 => ->; rewrite eq_sym -eqp0 eqp_sym.
  rewrite eqp_monic // f2p_monic //.
  + by move/negP/negP: p0.
  + by move/negP/negP: q0.
Qed.

Lemma lem1 q n : prime q -> (n < q -> n.+1 != n %[mod q])%N.
Proof.
  move=> Hq nq.
  case n0: (n == 0)%N.
   move/eqP: n0 => ->.
   rewrite mod0n modn_small //.
   by case: q Hq nq => []//[].
  case nsq: (n.+1 == q).
   move/eqP: nsq => <-.
   by rewrite modnn modn_small // eq_sym n0.
  have nsq': (n.+1 < q)%N
   by rewrite ltn_neqAle nq nsq.
  rewrite !modn_small //.
  by elim n.
Qed.

Lemma exp2_dvd a b :
  2^(a * b) - 1 = (2^a - 1) * \sum_(i < b) 2 ^ (a * (b - i.+1)).
Proof.
elim: b => [|b IHb]; first by rewrite muln0 expn0 subn1 big_ord0 muln0.
rewrite big_ord_recl mulnDr -IHb mulnBl !subn1 -mulnBl mulnS expnD.
have H: forall a, 2 ^ a = 2 ^ a - 1 + 1 by move=> *; rewrite subnK // expn_gt0.
by rewrite [in LHS]H mulnDl mul1n [X in _ + X]H addn1 !addnS !subn1.
Qed.

Lemma m_is_prime m : prime (2 ^ m - 1) -> prime m.
Proof.
apply: contraLR => /primePn []; first by case: m => []//[].
case => a aH /dvdnP[] b mba; move: mba aH => -> mba.
rewrite exp2_dvd; apply/primePn; right.
exists (2 ^ b - 1); rewrite ?dvdn_mulr //.
have? : 1 < 2 ^ b - 1.
 case: b mba => [|[|b _]].
  by rewrite mul0n ltn0 andbF.
  by rewrite mul1n ltnn andbF.
 have: 2 ^ b > 0 by rewrite expn_gt0.
 rewrite subn1 !expnS !mul2n.
 by case: (2 ^ b).
apply/andP; split => //; apply/ltn_Pmulr/ltnW => //.
case: a mba => []//[]// a mba.
rewrite !big_ord_recr /= subnn muln0 expn0 -[X in X < _]add0n ltn_add2r.
by rewrite subSnn muln1 ltn_addl // expn_gt0.
Qed.

Section iter_lin.
Variable K : fieldType.
Variable R : vectType K.
Variable f : {linear R -> R}%R.
Lemma iter_linear m : linear (iter m f).
Proof.
  elim: m => // m IHm a x y.
  by rewrite !iterSr !GRing.linearP IHm.
Qed.
Canonical iter_linearType m := Linear (iter_linear m).
End iter_lin.

Section Quotient.
Variable phi : {poly 'F_2}.
Variable phi_gt1 : size phi > 1.
Local Open Scope ring_scope.
Import GRing.Theory.
Import Pdiv.Ring.
Import Pdiv.RingMonic.

Lemma ltn_phi_pred : ((size phi).-1 < size phi)%nat.
Proof. by case: (size phi) phi_gt1. Qed.

Lemma phi_neq0 : phi != 0.
Proof.
  rewrite -size_poly_eq0.
  by case: (size phi) phi_gt1.
Qed.

Lemma phi_is_monic : phi \is monic.
Proof. by apply f2p_monic; rewrite -size_poly_gt0 ltnW. Qed.

Hint Resolve phi_is_monic phi_neq0 ltn_phi_pred : core.

Definition phiI := rdvdp phi.
Fact phiI_key : pred_key phiI. Proof. by []. Qed.

Canonical keyd_phiI : keyed_pred phiI_key.
by apply (@PackKeyedPred _ _ phiI_key (rdvdp phi)).
Defined.

Lemma phiI_addr_closed: addr_closed phiI.
Proof.
  split => [|??].
  * by rewrite unfold_in; apply/eqP/rmod0p.
  * rewrite !unfold_in rmodp_add // => /eqP ->.
    by rewrite add0r.
Qed.

Lemma phiI_oppr_closed: oppr_closed phiI.
Proof.
  move=> x.
  rewrite !unfold_in -mulN1r -rmodp_mulmr // => /eqP ->.
  by rewrite mulr0 rmod0p.
Qed.

Lemma phiI_proper_ideal : proper_ideal phiI.
Proof.
  split => [|??].
  * by rewrite unfold_in rmodp_small ?size_polyC ?size_p oner_neq0.
  * rewrite !unfold_in -rmodp_mulmr ?f2p_monic // => /eqP ->.
    by rewrite mulr0 rmod0p.
Qed.

Canonical phiI_addrPred := AddrPred phiI_addr_closed.
Canonical phiI_zmodPred := ZmodPred phiI_oppr_closed.
Canonical phiI_idealr := MkIdeal phiI_zmodPred phiI_proper_ideal.

Local Open Scope quotient_scope.

Definition QphiI := {ideal_quot keyd_phiI}.

Definition QphiI_rV (x : QphiI) : 'rV['F_2]_(size phi).-1 :=
  poly_rV (rmodp (generic_quotient.repr x) phi).
Definition rVQphiI : 'rV['F_2]_(size phi).-1 -> QphiI :=
  \pi \o rVpoly.

Lemma QphiI_rV_K : cancel QphiI_rV rVQphiI.
Proof.
move=> x.
rewrite /rVQphiI /QphiI_rV /= poly_rV_K;
last by case: (size phi) (ltn_rmodpN0 (generic_quotient.repr x) phi_neq0) phi_gt1.
rewrite -[x in RHS]reprK !piE /=.
apply/eqP.
by rewrite -Quotient.idealrBE /= unfold_in rmodp_add //
           rmodp_small ?ltn_rmodp // -rmodp_add // subrr rmod0p.
Qed.

Lemma rVQphiIK : cancel rVQphiI QphiI_rV.
Proof.
move=> x.
rewrite /rVQphiI /QphiI_rV /= -[RHS]rVpolyK; congr (poly_rV _).
case: piP => y /eqP.
rewrite -Quotient.idealrBE unfold_in rmodp_add // addr_eq0
        -!Pdiv.IdomainMonic.modpE // modp_opp opprK => /eqP <-.
rewrite modp_small //.
by apply(leq_ltn_trans (size_poly _ _)).
Qed.

Hint Resolve QphiI_rV_K rVQphiIK : core.

Canonical QphiI_finMixin := CanFinMixin QphiI_rV_K.
Canonical QphiI_finType := FinType QphiI QphiI_finMixin.
Canonical Quotient.rquot_comRingType.
Canonical QphiI_unitRingMixin :=
  Eval hnf in FinRing.Ring.UnitMixin [finRingType of QphiI].
Canonical QphiI_unitRingType := UnitRingType QphiI QphiI_unitRingMixin.
Canonical QphiI_comUnitRingType := Eval hnf in [comUnitRingType of QphiI].
Canonical QphiI_finComUnitRingType := Eval hnf in [finComUnitRingType of QphiI].
Canonical QphiI_finUnitRingType := Eval hnf in [finUnitRingType of QphiI].
Canonical QphiI_zmodType := Eval hnf in [zmodType of QphiI].

Lemma QphiI_rV_D A B : QphiI_rV (A + B) = QphiI_rV A + QphiI_rV B.
Proof.
  rewrite -linearD -rmodp_add //; congr (poly_rV _).
  rewrite -[A]reprK -[B]reprK.
  case: piP => a ->; case: piP => b ->.
  rewrite -rmorphD; case: piP => ab /eqP.
  by rewrite -Quotient.idealrBE unfold_in -!Pdiv.IdomainMonic.modpE //
             modp_add modp_opp subr_eq0 eq_sym => /eqP.
Qed.

Local Definition scale a v := rVQphiI (scalemx a (QphiI_rV v)).
Local Fact scale1x A : scale 1 A = A.
Proof. by rewrite /scale scale1mx QphiI_rV_K. Qed.
Local Fact scaleA x y A : scale x (scale y A) = scale (x * y) A.
Proof. by rewrite /scale rVQphiIK scalemxA. Qed.
Local Fact scalexDl A x y : scale (x + y) A = scale x A + scale y A.
Proof. by rewrite /scale scalemxDl -rmorphD -linearD. Qed.
Local Fact scalexDr x A B : scale x (A + B) = scale x A + scale x B.
Proof. by rewrite /scale -rmorphD -linearD -scalemxDr QphiI_rV_D. Qed.
Definition QphiI_lmodMixin := LmodMixin scaleA scale1x scalexDr scalexDl.
Canonical QphiI_lmodType :=
  Eval hnf in LmodType 'F_2 QphiI QphiI_lmodMixin.

Lemma QphiI_rV_scaler a A : QphiI_rV (a *: A) = a *: QphiI_rV A.
Proof.
case: a => [][|[]]// i.
* have->: Ordinal i = 0 by apply/val_inj.
  rewrite !scale0r /QphiI_rV -pi_zeror.
  case: piP => x /eqP.
  rewrite -Quotient.idealrBE sub0r unfold_in -!Pdiv.IdomainMonic.modpE //
          modp_opp oppr_char2
          ?(GRing.rmorph_char (polyC_rmorphism [ringType of 'F_2])) // => /eqP ->.
  by rewrite linear0.
* have->: Ordinal i = 1 by apply/val_inj.
  by rewrite !scale1r.
Qed.

Lemma QphiI_vect_axiom : Vector.axiom (size phi).-1 QphiI.
Proof.
by exists QphiI_rV; [move=> ???; rewrite QphiI_rV_D QphiI_rV_scaler|exists rVQphiI].
Qed.

Definition QphiI_vect_mixin := VectMixin QphiI_vect_axiom.
Canonical QphiI_vect_type := VectType 'F_2 QphiI QphiI_vect_mixin.

Lemma pi_phi0 : \pi phi = 0 :> QphiI.
Proof.
have->: 0 = \pi 0 :> QphiI by rewrite pi_zeror.
apply/eqP.
by rewrite -Quotient.idealrBE subr0 unfold_in rmodpp.
Qed.

Lemma pi1 : \pi 1 = 1 :> QphiI.
Proof. by rewrite -pi_oner. Qed.

Lemma piM p q : \pi_QphiI (p * q) = (\pi p : QphiI) * \pi q.
Proof. by rewrite -rmorphM. Qed.

Lemma piD p q : \pi_QphiI (p + q) = (\pi p : QphiI) + \pi q.
Proof.
by rewrite (rmorphD (pi_rmorphism (Quotient.rquot_ringQuotType keyd_phiI))).
Qed.

Lemma piB p q : \pi_QphiI (p - q) = (\pi p : QphiI) - (\pi q : QphiI).
Proof.
by rewrite (rmorphB (pi_rmorphism (Quotient.rquot_ringQuotType keyd_phiI))).
Qed.

Lemma card_QphiI : (#|[finType of QphiI]| = 2 ^ (size phi).-1)%N.
Proof.
have<-: (#|'rV['F_2]_(size phi).-1| = 2 ^ (size phi).-1)%nat
 by rewrite card_matrix mul1n card_ord.
apply/eqP; rewrite eqn_leq; apply/andP; split.
* move: (@card_in_image _ _ QphiI_rV predT) <- => [|????];
   last by apply (can_inj QphiI_rV_K).
  by apply/subset_leq_card/subsetP.
* move: (@card_in_image _ _ rVQphiI predT) <- => [|????];
   last by apply (can_inj rVQphiIK).
  by apply/subset_leq_card/subsetP.
Qed.

Definition QphiIX : (size phi).-1.-tuple QphiI_lmodType
  := [tuple \pi 'X^i | i < (size phi).-1].

Lemma QphiIXE (i : 'I_(size phi).-1) : QphiIX`_i = \pi 'X^i.
Proof. by rewrite nth_mktuple. Qed.

Lemma pi_linear : linear (\pi : _ -> [lmodType 'F_2 of QphiI]).
Proof.
  move=> a x y.
  case: a => [][|[]//] i.
    have->: Ordinal i = 0 by apply/val_inj.
    by rewrite !scale0r !add0r.
   have->: Ordinal i = 1 by apply/val_inj.
   by rewrite !scale1r -rmorphD.
Qed.
Canonical pi_linearType := Linear pi_linear.

Lemma QphiIX_free : free QphiIX.
Proof.
apply/freeP => k.
set T := \sum__ _; have->: T = \sum_(i < (size phi).-1) \pi_QphiI (k i *: 'X^i).
 apply/eq_bigr => j _.
 by rewrite QphiIXE -[k j *: 'X^j]addr0 linearP /= pi_zeror addr0.
rewrite -linear_sum -pi_zeror => /eqP.
rewrite -Quotient.idealrBE unfold_in subr0 rmodp_small; last first.
* apply/(leq_ltn_trans (size_sum _ _ _))/leq_trans/ltn_phi_pred/bigmax_leqP=> i _.
  by apply/(leq_trans (size_scale_leq _ _)); rewrite size_polyXn.
* move: k {T}; elim: (size phi).-1 => [?? [] //|n IHn k].
  rewrite big_ord_recr /=.
  case k0: (k ord_max == 0).
   rewrite (eqP k0) scale0r addr0 => /IHn H i.
   case: (splitP (cast_ord (esym (addn1 _)) i)) => j ji.
    move/H: (j) <-; congr (k _); apply/ord_inj.
    by rewrite /= -ji.
   suff->: i = ord_max by apply/eqP.
   case: j ji => [][|[]//] ?.
   rewrite /= addn0 => ?.
   by apply/ord_inj.
  case: (k ord_max) k0 => [][|[]]// i; have->: Ordinal i = 1 by apply/ord_inj.
  rewrite scale1r addr_eq0 => _ /eqP/(f_equal (size : {poly 'F_2} -> _)).
  rewrite size_opp size_polyXn => C.
  suff: (n.+1 < n.+1)%nat by rewrite ltnn.
  rewrite -[X in (X < _)%nat]C.
  apply/(leq_ltn_trans (size_sum _ _ _))/bigmax_leqP => j _.
  by apply/(leq_trans (size_scale_leq _ _)); rewrite size_polyXn.
Qed.

Lemma dim_QphiI : \dim (fullv : {vspace QphiI}) = (size phi).-1.
Proof. by rewrite [LHS]mxrank_gen mxrank1. Qed.

Lemma QphiIX_full : basis_of fullv QphiIX.
Proof.
by rewrite basisEfree QphiIX_free subvf size_map size_enum_ord dim_QphiI /=.
Qed.

Section Field.
Variable ip : irreducible_poly phi.
Definition QphiI_inv (q : QphiI) :=
  if q == 0 then 0
  else \pi_QphiI ((egcdp phi (generic_quotient.repr q)).2 %% phi).

Lemma QphiI_field : GRing.Field.axiom QphiI_inv.
Proof.
  move=> p /negPf i.
  rewrite /QphiI_inv i -[p in _ * p]reprK -piM -pi1.
  apply/eqP.
  set P := (generic_quotient.repr p).
  rewrite -Quotient.idealrBE unfold_in rmodp_add //
          [rmodp (-1) _]rmodp_small ?size_opp ?size_polyC //
          subr_eq0 -f2eqp_eq // -Pdiv.IdomainMonic.modpE //
          mulrC modp_mul mulrC.
  have<-: (((egcdp phi P).1 * phi + (egcdp phi P).2 * P)) %% phi =
          ((egcdp phi P).2 * P) %% phi
   by rewrite modp_add -modp_mul modpp mulr0 mod0p add0r.
  have->: ((egcdp phi P).1 * phi + (egcdp phi P).2 * P) = gcdp phi P
   by apply/esym/eqP; rewrite -f2eqp_eq // egcdpE.
  suff: gcdp phi P %= 1.
   rewrite !f2eqp_eq => /eqP ->.
   by rewrite modp_small // size_polyC.
  rewrite eqp_sym; apply/eqp_trans/gcdp_modr; rewrite eqp_sym.
  rewrite -size_poly_eq1; apply/eqP; rewrite coprimep_size_gcd //.
  apply/coprimepP => d.
  case d0: (size d == 0)%nat.
   rewrite size_poly_eq0 in d0.
   rewrite (eqP d0) dvd0p => /negPn.
   by rewrite phi_neq0.
  case d1: (size d == 1)%nat.
   case: d d0 d1 => [][|[]]//[|[]]// i0 []//= *.
   set T := Polynomial _; have->: T = 1.
    apply/val_inj; rewrite /= polyseq1.
    congr (_ :: _); apply/val_inj.
    by rewrite /= modn_small //.
   by rewrite eqpxx.
  case: (ip) => _ H1 H2.
  move/H1: H2; rewrite d1 => /implyP /=.
  rewrite f2eqp_eq => /eqP -> /dvdp_leq.
  rewrite leqNgt ltn_modp phi_neq0 => C.
  suff: false by []; apply/C.
  rewrite -[p]reprK -pi_zeror -Quotient.idealrBE subr0 unfold_in
             -Pdiv.IdomainMonic.modpE // in i.
  by rewrite i.
Qed.

Lemma QphiI_inv0 : QphiI_inv 0 = 0.
Proof. by rewrite /QphiI_inv eqxx. Qed.

Definition QphiI_fieldMixin :=
  @FieldMixin [comRingType of QphiI] QphiI_inv QphiI_field QphiI_inv0.
Definition QphiI_fieldType :=
  Eval hnf in FieldType _ QphiI_fieldMixin.

End Field.
End Quotient.

Section Irreducible.
Variable phi : {poly 'F_2}.
Local Notation m := (size phi).-1.
Hypothesis pm : prime (2 ^ m - 1).
Local Notation m_is_prime := (m_is_prime pm).

Lemma phi_gt1 : 1 < size phi.
Proof. by case: (size phi) m_is_prime => []//[]. Qed.

Lemma phi_gt2 : 2 < size phi.
Proof. by case: (size phi) m_is_prime => []//[]//[]. Qed.

Lemma phi_gt0 : 0 < size phi.
Proof. by case: (size phi) m_is_prime. Qed.

Lemma power_gt0 : 0 < 2 ^ m.
Proof. by case: (2 ^ m) pm. Qed.

Lemma predpower_gt0 : 0 < 2 ^ m - 1.
Proof. by case: (2 ^ m - 1) pm. Qed.

Lemma predpower_neq0 : 0 != 2 ^ m - 1.
Proof. by case: (2 ^ m - 1) pm. Qed.

Lemma predpower_gt_succpower : (2 ^ m).-1 < (2 ^ m).+1.
Proof. by case: (2 ^ m) pm. Qed.

Lemma phi_gtb (b : bool) : b < size phi.
Proof. by case: b; rewrite ?phi_gt1 ?phi_gt0. Qed.

Lemma predphi_neq0 : m != 0.
Proof. by case: m m_is_prime. Qed.

Lemma predphi_gt1 : 1 < m.
Proof. by case: m m_is_prime => []//[]. Qed.

Lemma predpredpower_power : (2 ^ m - 1).-1 < 2 ^ m - 1.
Proof. by case: (2 ^ m - 1) pm. Qed.

Lemma predpredpower_gt0 : 0 < (2 ^ m - 1).-1.
Proof. by case: (2 ^ m - 1) pm => []//[]. Qed.

Lemma p_ord_prf : (2 ^ m - 1 < (2 ^ m).+1)%N.
Proof. by rewrite subn1 predpower_gt_succpower. Qed.

Lemma predphi_geq1 : 1 <= m.
Proof. by case: m m_is_prime => []//[]. Qed.

Local Open Scope ring_scope.
Local Open Scope quotient_scope.
Import GRing.Theory.
Import Pdiv.Ring.
Import Pdiv.RingMonic.

Hint Resolve (phi_is_monic phi_gt1) (phi_neq0 phi_gt1)
     phi_gt1 phi_gt2 phi_gt0
     phi_gtb predphi_neq0 predphi_gt1 predpredpower_power
     predpredpower_gt0 p_ord_prf predphi_geq1
     predpower_gt_succpower
     power_gt0 predpower_gt0 predpower_neq0 : core.

Section Order.
(*
based on:
 http://www.math.sci.hiroshima-u.ac.jp/~m-mat/TEACH/0407-2.pdf
 P. 27
*)
Definition stab (a : QphiI phi_gt1) n := (a ^+ n * a == a) && (n > 0)%nat.

Variable x : QphiI phi_gt1.
Variable H1 : (x ^ 2 != x)%R.
Variable H2 : (x ^ (2 ^ m)%N == x)%R.

Lemma exstab : stab x (2 ^ m - 1)%nat.
Proof. by rewrite /stab -exprSr subn1 prednK // H2 -subn1. Qed.

Definition minstab := ex_minn (@ex_intro _ (stab x) _ exstab).

Lemma minstab_cond : stab x minstab.
Proof.
  rewrite /minstab.
  by case: (ex_minnP (@ex_intro _ (stab x) _ exstab)).
Qed.

Lemma minstab_exp y : x ^+ minstab ^+ y * x = x.
 elim: y => [|n IH].
  by rewrite GRing.expr0 GRing.mul1r.
 rewrite GRing.exprSr -GRing.mulrA.
 by case/andP: minstab_cond => /eqP -> _.
Qed.

Lemma minstab_dvd : forall y, stab x y -> (minstab %| y)%nat.
Proof.
move=> y.
rewrite /stab (divn_eq y minstab) addnC GRing.exprD mulnC GRing.exprM
 => /andP[] H3.
have H4: x ^+ minstab ^+ (y %/ minstab)%nat * x = x.
 by rewrite minstab_exp.
rewrite -GRing.mulrA H4 in H3.
case ym: (y %% minstab)%nat => *.
 by rewrite add0n dvdn_mulr.
have H5: stab x (y %% minstab)%N.
 by rewrite /stab H3 ym.
move: H5; rewrite /minstab.
case: (ex_minnP (@ex_intro _ (stab x) _ exstab)) => m /andP [] ?? H /H.
by rewrite leqNgt ltn_pmod.
Qed.

Lemma minstabE : minstab = (2 ^ m - 1)%nat.
Proof.
  case/primeP: pm => _ /(_ _ (minstab_dvd exstab))/orP [|/eqP []//].
  rewrite /minstab.
  case: (ex_minnP (@ex_intro _ (stab x) _ exstab)) => [][]//[]// /andP [].
  rewrite -exprSr => H3.
  by move/negP: H1; rewrite H3.
Qed.

Lemma minstab_attain :
forall l k : nat, x ^+ l * x = x ^+ k * x -> (k = l %[mod 2 ^ m - 1])%nat.
Proof.
move: minstabE => /eqP H3.
have base: forall l, (0 < l < 2 ^ m - 1)%N -> x ^+ l * x != x.
 move/eqP: H3 => H l /andP [] Hl0 Hl; apply/negP => /eqP C.
  move: H; rewrite /minstab.
  case: (ex_minnP (@ex_intro _ (stab x) _ exstab)) => m ? H5 H4.
  have/H5 : stab x l by rewrite /stab C Hl0 eqxx.
  by rewrite leqNgt H4 Hl.
have base1:
  forall l k, (l < 2 ^ m - 1 -> 0 < k < 2 ^ m - 1 ->
  (x ^+ l * x = x ^+ k * x)%R -> k = l)%N.
 move=> l k.
 case kl: (k == l %[mod (2 ^ m - 1)])%N.
  move: kl => + Hl1 /andP [] Hk1 Hk2.
  by rewrite !modn_small // => /eqP ->.
 move=> Hl Hk2.
 case kl': (k > l)%N.
  have: (0 < l + (2 ^ m - 1 - k) < 2 ^ m - 1)%N.
   apply/andP; split.
    rewrite lt0n addn_eq0; apply/negP => /andP [] /eqP l0 mk.
    move: l0 mk kl => ->.
    rewrite subn_eq0 leqNgt.
    by case/andP: Hk2 => ? ->.
   case/andP: Hk2 => ? Hk2.
   rewrite addnBA; last by apply ltnW.
   rewrite addnC -subnBA ?ltn_subr //; last by apply ltnW.
   case: (2 ^ m - 1)%nat Hk2 => // ??.
   by rewrite /leq subSS -subnDA addnC subnDA subSn // subnn subnBA
             ?add1n ?subn_eq0 // ltnW.
  move/base => + lk.
  rewrite addnC GRing.exprD -GRing.mulrA lk GRing.mulrA -GRing.exprD subnK.
   by rewrite ?subn1 -GRing.exprSr prednK // H2.
  by case/andP: Hk2 => ??; rewrite ltnW.
 move/negP/negP: kl'; rewrite -ltnNge ltnS leq_eqVlt => /orP [/eqP ->|] // kl'.
 have: (0 < k + (2 ^ m - 1 - l) < 2 ^ m - 1)%N.
  apply/andP; split.
   rewrite lt0n addn_eq0; apply/negP => /andP [] /eqP l0 mk.
   move: l0 mk kl => ->.
   by rewrite subn_eq0 leqNgt Hl.
  rewrite addnBA; last by apply ltnW.
  rewrite addnC -subnBA ?ltn_subr //; last by apply ltnW.
  case/andP: Hk2 => ? Hk2.
   case: (2 ^ m - 1)%nat Hk2 => // ??.
   by rewrite /leq subSS -subnDA addnC subnDA subSn // subnn subnBA
             ?add1n ?subn_eq0 // ltnW.
 move/base => + lk.
 rewrite addnC GRing.exprD -GRing.mulrA -lk GRing.mulrA -GRing.exprD subnK //.
  by rewrite subn1 -GRing.exprSr prednK // H2.
 by rewrite ltnW.
have base2:
  forall l k : nat, (0 < k < 2 ^ m - 1)%N ->
  x ^+ l * x = x ^+ k * x -> (k = l %% (2 ^ m - 1))%N.
  move=> l k /base1 b.
  rewrite [X in (_ ^+ X * _)%R](divn_eq l (2 ^ m - 1)) addnC GRing.exprD
          -GRing.mulrA mulnC exprM -(eqP H3) minstab_exp.
  apply/b.
  by rewrite minstabE ltn_pmod //.
move=> l k.
rewrite (divn_eq k (2 ^ m - 1)) addnC GRing.exprD -GRing.mulrA
        mulnC exprM -(eqP H3) minstab_exp addnC mulnC modnMDl.
case k0: (k %% minstab)%N.
 rewrite expr0 mul1r.
 case l0: (l %% minstab)%N; first by rewrite mod0n.
 rewrite (divn_eq l minstab) addnC exprD -mulrA mulnC exprM minstab_exp => /eqP C.
 move: (base (l %% minstab)%nat).
 by rewrite !minstabE ltn_pmod // -!minstabE l0 /= -l0 C => /implyP.
move/base2 => /=.
rewrite -k0 !minstabE ltn_pmod // -!minstabE => C.
by rewrite modn_mod C.
Qed.

Lemma map_pi_inj :
injective (fun (i : 'Z_(2 ^ m - 1)) => x ^+ i * x).
Proof.
  move=> y z /eqP.
  rewrite eqE /= => /eqP /minstab_attain.
  case: y => y yH.
  case: z => z zH.
  rewrite !modn_small //=.
  by move=> yx; apply/val_inj.
  apply: (leq_trans yH); by rewrite prednK.
  apply: (leq_trans zH); by rewrite prednK.
Qed.

Lemma map_pi_card :
#|image (fun (i : 'Z_(2 ^ m - 1)) => x ^ i * x) 'Z_(2 ^ m - 1)| = (2 ^ m - 1)%N.
Proof.
  have Hc : #|'Z_(2 ^ m - 1)| = (2 ^ m - 1)%nat.
   rewrite card_ord.
   by case: (2 ^ m - 1)%nat pm => [][].
  rewrite -[RHS]Hc.
  apply/eqP/image_injP => [][] y Hy1 [] z Hz1 _ _ /minstab_attain /esym H;
   apply/ord_inj.
  rewrite /= ?modn_small // in H.
  move: (Hy1) (Hz1) => ??.
  rewrite /= /Zp_trunc /= ?prednK // in Hy1, Hz1.
  rewrite /= /Zp_trunc /= ?prednK // in Hy1, Hz1.
Qed.

Lemma Xn_phi_neq0 (a : nat) : x ^+ a * x != 0.
Proof.
  move: minstab_attain => H0; apply/negP => /eqP Hc.
  move: (H0 a a.+1).
  rewrite GRing.exprS -GRing.mulrA Hc GRing.mulr0 => /(_ erefl)/eqP.
  rewrite (divn_eq a (2 ^ m - 1)) -addnS !modnMDl.
  by apply/negP/lem1 => //; rewrite ltn_mod.
Qed.

Lemma map_piE :
image (fun (i : 'Z_(2 ^ m - 1)) => x ^ i * x) 'Z_(2 ^ m - 1)
=i (finset [finComRingType of QphiI phi_gt1] :\ 0%R).
Proof.
 have H3: [seq x ^ i * x | i : 'Z_(2 ^ (size phi).-1 - 1)] \subset
          [set x | [finComRingType of QphiI phi_gt1] x] :\ 0.
  suff: codom (fun (i : 'Z_(2 ^ m - 1)) => x ^ i * x)
        \subset (finset [finComRingType of QphiI phi_gt1] :\ 0%R).
   by apply/subset_trans/subsetP/image_codom.
  apply/subsetP => y.
  rewrite codomE !inE /=.
  elim: (enum 'Z_(2 ^ m - 1)) => // a l IH.
  rewrite in_cons => /orP [/eqP ->|/IH -> //].
  by move: (Xn_phi_neq0 a) => ->.
 apply/subset_cardP => //.
 by rewrite !cardsDS /= ?sub1set ?inE // !cardsT !map_pi_card cards1 card_QphiI.
Qed.

Lemma map_piP q :
reflect (exists (r : 'Z_(2 ^ m - 1)), x ^ r * x = q)
(q \in (image (fun (i : 'Z_(2 ^ m - 1)) => x ^ i * x) 'Z_(2 ^ m - 1))).
Proof.
move: map_pi_inj => inj.
apply/(iffP idP).
* rewrite /image_mem.
  elim: (enum 'Z_(2 ^ m - 1)) => // a l IH.
  rewrite in_cons => /orP [/eqP ->|/IH //]; by exists a.
* case => q0 <-.
  set T := (fun (i : 'Z_(2 ^ (size phi).-1 - 1)) => x ^ i * x).
  set S := x ^ q0 * x.
  have->: S = T q0 by [].
  by rewrite mem_map // mem_enum.
Qed.

Lemma irreducibleP_direct : irreducible_poly phi.
Proof.
  split => // q q1 /dvdpP [] qq /eqP.
  case q0: (size q == 0)%nat.
   move/negPn.
   rewrite size_poly_eq0 in q0.
   by rewrite (eqP q0) mulr0 phi_neq0.
  case qq0: (size qq == 0)%nat.
   move/negPn.
   rewrite size_poly_eq0 in qq0.
   by rewrite (eqP qq0) mul0r phi_neq0.
  case qq1: (size qq == 1)%nat.
   case: qq qq0 qq1 => [][]// + []//=.
   case => [][|[]] //= i ?  _ _.
   set T := Polynomial _; have->: T = 1.
    apply/val_inj; rewrite /= polyseq1.
    congr (_ :: _); apply/val_inj.
    by rewrite /= modn_small //.
   rewrite mul1r => /eqP ->.
   by rewrite eqpxx.
  case x0: (x == 0).
   move/eqP: x0 H1 => ->.
   by rewrite -exprnP expr0n eqxx.
  move/eqP => pqq.
  have: \pi q \in (finset [finComRingType of QphiI phi_gt1] :\ 0%R).
   apply/setD1P; split.
    rewrite -pi_zeror -Quotient.idealrBE subr0 unfold_in rmodp_small.
     by rewrite -size_poly_eq0 q0.
    rewrite pqq size_mul ?(esym (size_poly_eq0 _)) ?qq0 ?q0 //.
    case: (size qq) qq0 qq1 => []//[]// *.
    by rewrite !addSn /= ltnS leq_addl.
   by rewrite inE.
  have: \pi qq \in (finset [finComRingType of QphiI phi_gt1] :\ 0%R).
   apply/setD1P; split.
    rewrite -pi_zeror -Quotient.idealrBE subr0 unfold_in rmodp_small.
     by rewrite -size_poly_eq0 qq0.
    rewrite pqq size_mul ?(esym (size_poly_eq0 _)) ?qq0 ?q0 //.
    case: (size q) q0 q1 => []//[]// *.
    by rewrite !addnS /= ltnS leq_addr.
   by rewrite inE.
  rewrite -!map_piE => /map_piP [] r rE /map_piP [] i iE.
  move: (f_equal (\pi : _ -> QphiI phi_gt1) pqq).
  rewrite pi_phi0 piM -rE -iE.
  case: r {rE} => /= r _; case: i {iE} => /= i _.
  rewrite -!exprSr -exprD addSn exprSr (divn_eq (r + i.+1) (2 ^ (size phi).-1 - 1))
          addnC exprD mulnC exprM -minstabE -mulrA minstab_exp minstabE => /esym C.
  have j: ((r + i.+1) %% (2 ^ (size phi).-1 - 1) < (Zp_trunc (2 ^ (size phi).-1 - 1)).+2)%nat
   by rewrite !prednK // (ltn_pmod (r + i.+1) predpower_gt0).
  have: (0 \in (image (fun (i : 'Z_(2 ^ m - 1)) => x ^ i * x) 'Z_(2 ^ m - 1)))
   by apply/map_piP; exists (Ordinal j).
  rewrite map_piE => /setD1P/andP.
  by rewrite eqxx.
Qed.
End Order.

Section Inverse.
(*
   This direction is trivial.
   Because the statement just says that the galois group is nontrivial.
*)
Variable ip : irreducible_poly phi.

Lemma piX_neq0 : \pi_(QphiI phi_gt1) 'X%R != 0%R.
Proof.
  by rewrite -pi_zeror -Quotient.idealrBE subr0 unfold_in
          rmodp_small ?size_polyX // -size_poly_eq0 size_polyX.
Qed.

Definition Xu: ((\pi 'X : QphiI_fieldType phi_gt1 ip) \is a GRing.unit)%R.
  by rewrite unitfE piX_neq0.
Defined.

Local Hint Resolve Xu : core.

Lemma piX2X : (\pi_(QphiI phi_gt1) ('X ^ 2) != \pi 'X)%R.
Proof.
  rewrite -Quotient.idealrBE unfold_in; apply/negP => /rdvdpP.
  rewrite phi_is_monic // => [][]// x.
  case x0: (x == 0).
   move/eqP: x0 => -> /eqP.
   rewrite mul0r subr_eq0 => /eqP/(f_equal (size : {poly 'F_2} -> _)).
   by rewrite size_polyXn size_polyX.
  case x1: (size x == 1)%nat.
   case: x x0 x1 => [][]// [][|[]//] i []// ???.
   set T := Polynomial _; have->: T = 1.
    apply/val_inj; rewrite /= polyseq1.
    congr (_ :: _); apply/val_inj.
    by rewrite /= modn_small //.
   rewrite mul1r => x2xp.
   move: x2xp ip => <- [] _ /(_ 'X).
   have->: 'X %| 'X ^ 2 - 'X.
    move=> t.
    by rewrite -exprnP exprS expr1 -[X in _ - X]mulr1 -mulrBr dvdp_mulr //.
   rewrite size_polyX /= => C.
   have/(f_equal (size : {poly 'F_2} -> _)): 'X = 'X ^ 2 - 'X :> {poly 'F_2}
    by apply/eqP; rewrite -f2eqp_eq C.
   by rewrite size_addl ?size_opp ?size_polyXn ?size_polyX.
  move/negP/negP: x0 => x0 /(f_equal (size : {poly 'F_2} -> _)).
  rewrite size_mul // size_addl ?size_polyXn ?size_opp ?size_polyX //.
  rewrite -size_poly_eq0 in x0.
  case: (size x) x0 x1 => []//[]// sx _ _.
  rewrite !addSn /= => [][] C.
  suff: (2 < 2)%nat by [].
  rewrite [X in (_ < X)%nat]C.
  by apply/leq_trans/leq_addl.
Qed.

Canonical QphiI_fieldType_ip := QphiI_fieldType phi_gt1 ip.
Definition piX := FinRing.unit [finFieldType of QphiI_fieldType_ip] Xu.

Lemma piX_order : #[piX]%g = (2 ^ m - 1)%nat.
Proof.
  have/cyclic.order_dvdG: piX \in
      [group of [set: {unit [finFieldType of QphiI_fieldType_ip]}]]
    by rewrite inE.
  rewrite card_finField_unit card_QphiI.
  case/primeP: pm => _.
  rewrite !subn1 => H /H {H} /orP [|/eqP] //.
  rewrite order_eq1 => /eqP piX1.
  move: piX2X.
  rewrite -exprnP exprS piM expr1 /=.
  set T := \pi 'X; have<-: val piX = T by [].
  by rewrite piX1 /= mul1r eqxx.
Qed.

Lemma val_piX_expE p : val (piX ^+ p)%g = \pi_(QphiI phi_gt1) ('X ^+ p)%R.
Proof.
  elim: p => [|p IHp]; first by rewrite expr0 pi1.
  by rewrite !GRing.exprS piM expgS /= IHp.
Qed.

Lemma X2mp_eq1 : (\pi_(QphiI_fieldType_ip) ('X ^+ (2 ^ m - 1)) = \pi 1)%R.
Proof.
  suff/(f_equal val): (piX ^+ (2 ^ m - 1))%g = 1%g.
   rewrite val_piX_expE /= => ->.
   by rewrite pi1.
  suff<-: #[piX]%g = (2 ^ m - 1)%nat by rewrite expg_order.
  by rewrite piX_order.
Qed.

Lemma XnE q :
  ('X ^ q %% phi == 'X %% phi) = (\pi_(QphiI phi_gt1) ('X ^ q) == \pi 'X)%R.
Proof.
  by rewrite -Quotient.idealrBE unfold_in rmodp_add //
             addr_eq0 -!Pdiv.IdomainMonic.modpE // modp_opp opprK.
Qed.

Lemma XnpE q :
  (q > 0)%nat ->
  (\pi_(QphiI phi_gt1) ('X ^ q.-1) == \pi 1)%R
  = (\pi_(QphiI phi_gt1) ('X ^ q) == \pi 'X)%R.
Proof.
  case: q => // q _; rewrite /= -!exprnP exprS piM.
  set T := _ == _.
  case Te: T.
   move/eqP: Te ->.
   set S := \pi 1; have->: S = 1 :> QphiI phi_gt1 by rewrite -pi_oner.
   by rewrite mulr1 eqxx.
  apply/negP; case: ifP => //.
  set S := \pi_(QphiI phi_gt1) 'X.
  rewrite -[X in _ == X](mulr1 (S : [ringType of QphiI phi_gt1]))
          => /eqP/(mulrI Xu)/eqP.
  by rewrite -pi_oner -/T Te.
Qed.

Lemma irreducibleP_inverse :
(('X ^ 2 %% phi != 'X %% phi) && ('X ^ (2 ^ m)%N %% phi == 'X %% phi))%R.
Proof.
rewrite !XnE piX2X /=.
have->: (2 ^ m = (2 ^ m - 1).+1)%nat by rewrite subn1 prednK.
by rewrite -exprnP exprS piM X2mp_eq1 pi1 mulr1.
Qed.

Lemma char2_phi : 2 \in [char QphiI phi_gt1]%R.
Proof.
by apply/(GRing.rmorph_char
         (pi_rmorphism (Quotient.rquot_ringQuotType (keyd_phiI phi))))
        /(GRing.rmorph_char (polyC_rmorphism [ringType of 'F_2])).
Qed.

Definition F :
  [lmodType 'F_2 of QphiI phi_gt1] -> [lmodType 'F_2 of QphiI phi_gt1]
  := Frobenius_aut char2_phi.

Lemma linearF : linear F.
Proof.
move=> a x y.
case: a => [][|[]//] i; set T := Ordinal i.
 have->: T = 0%R by apply/val_inj.
 by rewrite !GRing.scale0r !GRing.add0r.
have->: T = 1%R by apply/val_inj.
by rewrite !GRing.scale1r /F GRing.Frobenius_autD_comm // /GRing.comm GRing.mulrC.
Qed.

Canonical linearType_F := Eval hnf in Linear linearF.

Lemma expXpE p x : iter p F x = (x ^+ (2 ^ p))%R.
Proof.
  elim: p x => [x|p IH x].
   by rewrite /= expn0 GRing.expr1.
  by rewrite iterS IH /F GRing.Frobenius_autE
             !GRing.exprS GRing.expr0 GRing.mulr1
             -GRing.exprD addnn expnS mul2n.
Qed.

Lemma expandF q :
  reflect (iter q F =1 id) ('X^(2 ^ q) %% phi == 'X %% phi)%R.
Proof.
pose rmorphX :=
    (rmorphX (pi_rmorphism (Quotient.rquot_ringQuotType (keyd_phiI phi)))).
rewrite exprnP XnE rmorphX.
apply/(iffP idP) => [/eqP H0 x|/(_ (\pi 'X))].
* rewrite (coord_basis (QphiIX_full _) (memvf x)).
  rewrite linear_sum; apply/eq_big => // i _.
  set e0 := QphiIX _.
  by rewrite linearZ_LR /= expXpE !QphiIXE rmorphX -exprM mulnC exprM H0.
* by rewrite expXpE => ->.
Qed.

Lemma cycleF_dvdP p :
  reflect (iter p F =1 id) (2 ^ m - 1 %| 2 ^ p - 1)%nat.
Proof.
pose rmorphX :=
  (rmorphX (pi_rmorphism (Quotient.rquot_ringQuotType (keyd_phiI phi)))).
case/andP: irreducibleP_inverse => _ H0.
apply/(iffP idP).
* case/dvdnP => q H1.
  rewrite XnE -XnpE // in H0.
  apply/expandF.
  rewrite exprnP XnE -XnpE; last first.
   elim: p {H1} => // n IH.
   apply/(leq_trans IH).
   by rewrite -[(2 ^ n)%nat]mul1n expnS leq_mul2r orbT.
  by rewrite -subn1 H1 mulnC -exprnP exprM rmorphX !subn1 /= (eqP H0) pi1 expr1n.
* move/(_ (\pi 'X)).
  rewrite XnE in H0.
  rewrite expXpE -rmorphX /= -(eqP H0) -!val_piX_expE => /val_inj/eqP.
  rewrite cyclic.eq_expg_mod_order piX_order.
  have H2: (2 ^ (size phi).-1 = ((2 ^ (size phi).-1) - 1) + 1)%nat
   by rewrite addn1 subn1 prednK.
  have H3: (1 = 0 + 1)%nat by rewrite add0n.
  case p0: (p > 0)%nat; last first.
   rewrite lt0n in p0.
   by move/negP/negP/eqP: p0 ->.
  have H4: ((2 ^ p) = ((2 ^ p) - 1) + 1)%nat.
   rewrite subn1 addn1 prednK //.
   elim: p p0 => // [][] // p IH _.
   have->: (0 = 2 * 0)%nat by [].
   by rewrite expnS ltn_mul2l /= muln0 IH.
  by rewrite [X in (_ == X %[mod _])%nat]H2 modnDl [X in (_ == X %[mod _])%nat]H3
             [X in (X == _ %[mod _])%nat]H4 eqn_modDr mod0n.
Qed.
End Inverse.

Lemma irreducibleP :
reflect (irreducible_poly phi)
(('X ^ 2 %% phi != 'X %% phi) && ('X ^ (2 ^ m)%N %% phi == 'X %% phi))%R.
Proof.
pose rmorphX :=
  (rmorphX (pi_rmorphism (Quotient.rquot_ringQuotType (keyd_phiI phi)))).
apply/(iffP idP); last by apply irreducibleP_inverse.
case/andP; rewrite !XnE -!exprnP !rmorphX.
by apply irreducibleP_direct.
Qed.

Definition H := (@QphiI_rV _ _) \o F \o (@rVQphiI _ _).

Lemma iterHE s :
   iter s H =1 (@QphiI_rV _ _) \o iter s F \o (@rVQphiI _ _).
Proof.
  elim: s => [?|s IH x].
   by rewrite /= rVQphiIK.
  by rewrite iterS IH /H /= QphiI_rV_K.
Qed.

Lemma irreducibleP1 :
  reflect (irreducible_poly phi)
  [exists x, (H x != x) && (iter (size phi).-1 H x == x)%R].
Proof.
pose rmorphX :=
  (rmorphX (pi_rmorphism (Quotient.rquot_ringQuotType (keyd_phiI phi)))).
apply/(iffP idP).
* case/existsP => x /andP [].
  rewrite iterHE /H /= => H1' H2'.
  have H1: (F (rVQphiI phi_gt1 x)) != rVQphiI phi_gt1 x.
   move: H1'; apply/contra => /eqP ->.
   by rewrite rVQphiIK.
  have H2: (iter (size phi).-1 F (rVQphiI phi_gt1 x))
           == (rVQphiI phi_gt1 x)
   by apply/eqP/canRL/(eqP H2')/QphiI_rV_K.
  rewrite expXpE in H2.
  rewrite /F Frobenius_autE in H1.
  by apply (irreducibleP_direct H1 H2).
* case/irreducibleP/andP.
  rewrite !XnE => H1 H2; apply/existsP; exists (QphiI_rV (\pi_(QphiI phi_gt1) 'X)).
  apply/andP; split.
   rewrite /H /= QphiI_rV_K /F Frobenius_autE.
   move: H1; apply/contra => /eqP/(can_inj (@QphiI_rV_K _ _))/eqP.
   by rewrite rmorphX.
  rewrite -!exprnP !rmorphX -!expXpE in H2.
  by rewrite iterHE /= QphiI_rV_K (eqP H2).
Qed.

Lemma irreducibleP2 x :
  H x != x ->
  reflect (irreducible_poly phi) (iter (size phi).-1 H x == x)%R.
Proof.
move=> Hxx.
apply/(iffP idP) => [iHxx|].
* apply/irreducibleP1/existsP.
  by exists x; rewrite Hxx iHxx.
* case/irreducibleP/andP => ? /expandF/(_ (rVQphiI _ x)).
  rewrite iterHE /= => ->.
  by rewrite rVQphiIK.
Qed.
End Irreducible.


From Coq Require Import ZArith.
From Coq Require Import Lia.
From Coq Require Import List.

Require Import FutharkUtils.
Require Import FutharkUnsized.
Require Import MssUtils.
Require Import MssUnsizedDefinition.

Import FutharkImpl.

Import ListNotations.

Open Scope Z.

(** From this point we prove functional correctness of the [mss] function*)
Inductive Segment {A : Type} : list A -> list A -> Type :=
| HeadSegment  : forall seg tail, Segment seg (seg ++ tail)
| InnerSegment : forall prefix seg lst, Segment seg lst -> Segment seg (prefix ++ lst).

Definition sum (l : list Z) : Z :=
  reduce (fun x y => x + y) 0 l.

Lemma sum_nil:
  sum [] = 0.
Proof.
  intros; unfold sum; mauto.
Qed.
Hint Rewrite sum_nil : mss.

Lemma sum_cons:
  forall (a : Z) (l : list Z), sum (a :: l) = a + sum l.
Proof.
  intros; unfold sum; mauto.
Qed.
Hint Rewrite sum_cons : mss.

Lemma sum_app:
  forall l1 l2 : list Z,
    sum (l1 ++ l2) = sum l1 + sum l2.
Proof.
  intros; unfold sum; mauto.
Qed.
Hint Rewrite sum_app : mss.

Lemma mss_core_nil:
  mss_core [] = X__unit.
Proof.
  intros; unfold mss_core; mauto.
Qed.
Hint Rewrite mss_core_nil : mss.

Lemma mss_core_cons:
  forall (h : Z) (t : list Z),
    mss_core (h :: t) = redOp (mapOp h) (mss_core t).
Proof.
  intros; unfold mss_core; mauto.
Qed.
Hint Rewrite mss_core_cons : mss.

Lemma mss_core_app:
  forall l1 l2 : list Z,
    mss_core (l1 ++ l2) = redOp (mss_core l1) (mss_core l2).
Proof.
  intros; unfold mss_core; mauto.
Qed.
Hint Rewrite mss_core_app : mss.

Ltac destruct_mss_core l :=
  let x := fresh "x" in
  let eq := fresh "Eqx" in
  remember (mss_core l) as x eqn:eq;
  apply (f_equal proj1_sig) in eq;
  simpl in eq;
  destruct_X x.

Ltac destruct_mss_cores :=
  repeat (let l := fresh "l" in
          match goal with
          | |- context[mss_core ?l]
            => let x := fresh "x" in
              let eq := fresh "Eqx" in
              remember (mss_core l) as x eqn:eq;
              apply (f_equal proj1_sig) in eq
          end);
  destruct_Xs.

Ltac solve_for_mss_cores :=
  unfold mss in *;
  repeat (rewrite mss_core_nil + rewrite mss_core_cons + rewrite mss_core_app);
  destruct_mss_cores;
  max_equiv_tac;
  lia.

Lemma mss_pos:
  forall l : list Z, 0 <= mss l.
Proof.
  intros; solve_for_mss_cores.
Qed.

Lemma mss_app_right:
  forall (n : Z) (l1 l2 : list Z),  n <= mss l1 -> n <= mss (l1 ++ l2).
Proof.
  intros n [] l2; solve_for_mss_cores.
Qed.

Lemma mss_app_left:
  forall (n : Z) (l1 l2 : list Z),  n <= mss l2 -> n <= mss (l1 ++ l2).
Proof.
  intros n [] l2; solve_for_mss_cores.
Qed.

Lemma mss_core_sum:
  forall l : list Z,
    let '(_, _, _, s) := proj1_sig (mss_core l) in
    s = sum l.
Proof.
  intros l; induction l; mauto; solve_for_mss_cores.
Qed.

Hint Rewrite Z.add_0_r : mss.

Lemma mss_core_left:
  forall l : list Z,
    let '(_, x2, _, _) := proj1_sig (mss_core l) in
    exists l1 l2 : list Z, l = l1 ++ l2 /\ sum l1 = x2.
Proof.
  intros l; induction l; mauto.
  * simpl; exists []; exists []; mauto.
  * destruct_mss_core l;
    (* We split up into tree case and solve these separately *)
    match goal with
    | |- context[max (max ?head 0) (?head + ?x4)]
      => (* First we assert that we are in one of these cases *)
        remember (max (max head 0) (head + x4)) as M eqn:EqM;
        assert (M_CASES : M = 0 \/ M = head \/ M = head + x4) by (max_equiv_tac; lia);
        clear EqM;
        (* Them we split up into these cases *)
        destruct_ors M_CASES;
        subst
    end.
    + (* CASE M = 0 *)
        exists []; exists (a :: l); mauto.
    + (* CASE M = a *)
      exists [a]; exists l; simpl; mauto.
    + (* CASE M = a + e3 *)
      specialize IHl as [l1 [l2 [Happend Hsum]]].
      exists (a :: l1); exists l2; subst; mauto.
Qed.

Hint Rewrite Z.add_max_distr_r : mss.
Hint Rewrite Z.add_max_distr_l : mss.

Lemma mss_core_inner:
  forall l : list Z,
    let '(x1, _, _, _) := proj1_sig (mss_core l) in
    exists l1 l2 l3 : list Z, l = l1 ++ l2 ++ l3 /\ sum l2 = x1.
Proof.
  intros l; induction l as [|? ? IHl]; mauto.
  * exists []; exists []; exists []; mauto.
  * specialize (mss_core_left l) as Hleft;
    destruct_mss_core l;
    specialize IHl as [l1 [l2 [l3 [? ?]]]].
    rewrite max_add_right;
    simpl;
    (* We split up into tree case and solve these separately *)
    match goal with
    | |- context[max (max ?head 0) (max ?x1 (max (?head + ?x4) ?x4))]
      => (* First we assert that we are in one of these cases *)
        remember (max (max head 0) (max x1 (max (head + x4) x4))) as M eqn:EqM;
        assert (M_CASES : M = e \/ M = a \/ M = a + e3) by (max_equiv_tac; lia);
        clear EqM;
        (* Them we split up into these cases *)
        destruct_ors M_CASES;
        subst
    end.
    + (* CASE M = e *)
      exists (a :: l1); exists l2; exists l3; mauto.
    + (* CASE M = a *)
      exists []; exists [a]; exists (l1 ++ l2 ++ l3); mauto.
    + (* CASE M = a + e3 *)
      specialize Hleft as [l1' [l2' [Happend ?]]].
      exists []; exists (a :: l1'); exists l2'; subst; rewrite Happend; mauto.
Qed.

Lemma sum_vs_mss:
  forall l, sum l <= mss l.
Proof.
  intros l; specialize (mss_core_sum l); solve_for_mss_cores.
Qed.

Hint Resolve mss_pos : mss.
Hint Resolve sum_vs_mss : mss.
Hint Resolve mss_app_left : mss.
Hint Resolve mss_app_right : mss.

Theorem mss_bound:
  forall (s l : list Z), Segment s l -> sum s <= mss l.
Proof. induction 1; simpl; mauto. Qed.

Theorem mss_attain:
  forall l : list Z, exists (s : list Z) (pf : Segment s l),  sum s = mss l.
Proof.
  intros l;
  pose proof (mss_core_inner l) as H;
  unfold mss;
  destruct_mss_core l;
  specialize H as [? [s [? [? ?]]]];
  subst;
  exists s;
  exists (InnerSegment _ _ _ (HeadSegment _ _));
  reflexivity.
Qed.


From EnTree Require Import Basics.HeterogeneousRelations.

From Coq Require Import
     Logic.FunctionalExtensionality
     Lists.List.

(*** In this module, we define the notion of a "quantifiable type", which is a
type that can be quantified over by quantifying over all elements of some type
in a set encoding ***)

(* An encoding of an easy-to-define collection of types *)
Inductive QuantEnc : Type :=
| QEnc_nat
| QEnc_prop (P:Prop)
| QEnc_sum (k1 k2:QuantEnc)
| QEnc_pair (k1 k2:QuantEnc)
| QEnc_fun (k1 k2:QuantEnc).

Fixpoint encodes_QuantEnc (k: QuantEnc) : Type :=
  match k with
  | QEnc_nat => nat
  | QEnc_prop P => P
  | QEnc_sum k1 k2 => encodes_QuantEnc k1 + encodes_QuantEnc k2
  | QEnc_pair k1 k2 => encodes_QuantEnc k1 * encodes_QuantEnc k2
  | QEnc_fun k1 k2 => encodes_QuantEnc k1 -> encodes_QuantEnc k2
  end.
Global Instance EncodingType_QuantEnc : EncodingType QuantEnc :=
  encodes_QuantEnc.

(* A type whose elements can be enumerated by a function from a QuantEnc that is
constructively surjective, i.e., where we can constructively find an input that
maps to any element of the output type *)
Class QuantType (A:Type) : Type :=
  { quantEnc : QuantEnc;
    quantEnum : encodes quantEnc -> A;
    quantEnumInv : A -> encodes quantEnc;
    quantEnumSurjective : forall a:A, quantEnum (quantEnumInv a) = a }.

Program Global Instance QuantType_unit : QuantType unit :=
  { quantEnc := QEnc_prop True;
    quantEnum := fun _ => tt;
    quantEnumInv := fun _ => I; }.
Next Obligation.
  destruct a. reflexivity.
Defined.

Program Global Instance QuantType_bool : QuantType bool :=
  { quantEnc := QEnc_nat;
    quantEnum := fun n => Nat.eqb n 0;
    quantEnumInv := fun b => if b then 0 else 1; }.
Next Obligation.
  destruct a; reflexivity.
Defined.

Global Instance QuantType_Prop (P:Prop) : QuantType P :=
  { quantEnc := QEnc_prop P;
    quantEnum := fun pf => pf;
    quantEnumInv := fun pf => pf;
    quantEnumSurjective := fun pf => eq_refl pf }.

Global Instance QuantType_nat : QuantType nat :=
  { quantEnc := QEnc_nat;
    quantEnum := fun n => n;
    quantEnumInv := fun n => n;
    quantEnumSurjective := fun n => eq_refl n }.

Program Global Instance QuantType_sum (A B:Type) `{QuantType A} `{QuantType B} : QuantType (A + B) :=
  { quantEnc := QEnc_sum (quantEnc (A:=A)) (quantEnc (A:=B));
    quantEnum := fun s => match s with
                          | inl x => inl (quantEnum x)
                          | inr x => inr (quantEnum x)
                          end;
    quantEnumInv := fun s => match s with
                          | inl x => inl (quantEnumInv x)
                          | inr x => inr (quantEnumInv x)
                          end; }.
Next Obligation.
  destruct a; rewrite quantEnumSurjective; reflexivity.
Defined.

Program Global Instance QuantType_pair (A B:Type) `{QuantType A} `{QuantType B} : QuantType (A * B) :=
  { quantEnc := QEnc_pair (quantEnc (A:=A)) (quantEnc (A:=B));
    quantEnum := fun p => (quantEnum (fst p), quantEnum (snd p));
    quantEnumInv := fun p => (quantEnumInv (fst p), quantEnumInv (snd p)) }.
Next Obligation.
  repeat rewrite quantEnumSurjective. reflexivity.
Defined.

Program Global Instance QuantType_fun (A B:Type) `{QuantType A} `{QuantType B} : QuantType (A -> B) :=
  { quantEnc := QEnc_fun (quantEnc (A:=A)) (quantEnc (A:=B));
    quantEnum := fun f x => quantEnum (f (quantEnumInv x));
    quantEnumInv := fun f x => quantEnumInv (f (quantEnum x)) }.
Next Obligation.
  apply functional_extensionality. intro x.
  repeat rewrite quantEnumSurjective. reflexivity.
Defined.

(* A list can be quantified by quantifying over unit + (len, nat -> A); the
unit+ is needed in case A is not inhabited *)

Definition build_list (A:Type) len (f : nat -> A) : list A :=
  map f (seq 0 len).

Program Global Instance QuantType_list (A:Type) `{QuantType A} : QuantType (list A) :=
  { quantEnc :=
      QEnc_sum (QEnc_prop True) (QEnc_pair
                                   QEnc_nat (QEnc_fun QEnc_nat (quantEnc (A:=A))));
    quantEnum :=
      fun s => match s with
               | inl _ => nil
               | inr (len, f) => build_list A len (fun x => quantEnum (f x))
               end;
    quantEnumInv :=
      fun l => match l with
               | nil => inl I
               | def::_ => inr (length l, fun i => quantEnumInv (nth _ l def))
               end }.
Next Obligation.
  destruct a; [ reflexivity | ].
  unfold QuantType_list_obligation_1.
  set (l:= a :: a0).
  transitivity (build_list A (length l) (fun x => nth x l a));
    unfold build_list; [ apply map_ext; intro; apply quantEnumSurjective | ].
  apply (nth_ext _ _ a a);
    rewrite map_length; rewrite seq_length; [ reflexivity | ].
  intros.
  etransitivity; [ apply (map_nth (fun x : nat => nth x l a) _ 0 n) | ].
  rewrite seq_nth; [ | assumption ]. f_equal.
Defined.


Require Import Coq.Bool.Bool.
Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Lia.

Require Import Crypto.Util.ZUtil.Definitions.
Require Import Crypto.Util.ZUtil.Notations.
Require Import Crypto.Util.ZUtil.Land.
Require Import Crypto.Util.ZUtil.Lor.
Require Import Crypto.Util.ZUtil.Testbit.
Require Import Crypto.Util.ZUtil.Div.
Require Import Crypto.Util.ZUtil.LandLorShiftBounds.
Require Import Crypto.Util.ZUtil.Zselect.
Require Import Crypto.Util.ZUtil.Ones.
Require Import Crypto.Util.ZUtil.OnesFrom.
Require Import Crypto.Util.ZUtil.Pow.
Require Import Crypto.Util.ZUtil.TruncatingShiftl.
Require Import Crypto.Util.ZUtil.SignBit.
Require Import Crypto.Util.ZUtil.TwosComplement.

Require Import Crypto.Util.Decidable.
Require Import Crypto.Util.LetIn.
Require Import Crypto.Util.ListUtil.
Require Import Crypto.Util.ZUtil.Tactics.SolveRange.
Require Import Crypto.Util.ZUtil.Tactics.SolveTestbit.

Local Open Scope Z_scope.

Module Z.
  Lemma arithmetic_shiftr1_testbit_spec_full m a i
        (Hm : 0 < m)
        (Ha : 0 <= a < 2 ^ m) :
    Z.testbit (Z.arithmetic_shiftr1 m a) i =
    if (i <? 0) then false else if i =? (m - 1) then Z.testbit a (m - 1) else Z.testbit a (i + 1).
  Proof. unfold Z.arithmetic_shiftr1; Z.solve_testbit. Qed.

#[global]
  Hint Rewrite arithmetic_shiftr1_testbit_spec_full : testbit_rewrite.

  Lemma arithmetic_shiftr1_bound m a (Ha : 0 <= a < 2 ^ m) :
    0 <= Z.arithmetic_shiftr1 m a < 2 ^ m.
  Proof. unfold Z.arithmetic_shiftr1; Z.solve_range. Qed.

#[global]
  Hint Resolve arithmetic_shiftr1_bound : zarith.

  Lemma arithmetic_shiftr1_spec m a
        (Hm : 0 < m)
        (Ha : 0 <= a < 2 ^ m) :
    Z.twos_complement m (Z.arithmetic_shiftr1 m a) = (Z.twos_complement m a) / 2.
  Proof. Z.solve_using_testbit. Qed.

  Lemma arithmetic_shiftr_bound m a k
        (Hm : 0 <= m)
        (Ha : 0 <= a < 2 ^ m)
        (Hk : 0 <= k) :
    0 <= Z.arithmetic_shiftr m a k < 2 ^ m.
  Proof.
    unfold Z.arithmetic_shiftr; rewrite unfold_Let_In, Zselect.Z.zselect_correct.
    destruct (dec (Z.sign_bit m a = 0)); [Z.solve_range|].
    destruct (dec (m - k <= 0)); Z.solve_range. Qed.

#[global]
  Hint Resolve arithmetic_shiftr_bound : zarith.

  Lemma arithmetic_shiftr_testbit_spec m a k i
        (Hm : 0 < m)
        (Hk : 0 <= k)
        (Ha : 0 <= a < 2 ^ m) :
    Z.testbit (Z.arithmetic_shiftr m a k) i =
    if (i <? 0) then false else if (m - k <=? i) && ((i <? m) || (k <? 0)) then Z.testbit a (m - 1) else Z.testbit a (i + k).
  Proof.
    unfold Z.arithmetic_shiftr; rewrite unfold_Let_In, Zselect.Z.zselect_correct.
    rewrite (Z.testbit_b2z a), Z.sign_bit_testbit by lia.
    destruct (Z.testbit a (m - 1)); Z.solve_testbit. Qed.

#[global]
  Hint Rewrite arithmetic_shiftr_testbit_spec : testbit_rewrite.

  Lemma arithmetic_shiftr_1 m a
        (Hm : 0 < m)
        (Ha : 0 <= a < 2 ^ m) :
    Z.arithmetic_shiftr m a 1 = Z.arithmetic_shiftr1 m a.
  Proof. Z.solve_using_testbit. Qed.

  Lemma arithmetic_shiftr_0 m a
        (Hm : 0 < m)
        (Ha : 0 <= a < 2 ^ m) :
    Z.arithmetic_shiftr m a 0 = a.
  Proof. Z.solve_using_testbit. Qed.

  Lemma ones_lor_shift n m k
        (Hn : 0 <= n)
        (Hm : 0 <= m)
        (Hk : 0 <= k) :
    Z.ones n << k |' Z.ones m << (k - m) = Z.ones (n + m) << (k - m).
  Proof. Z.solve_using_testbit. Qed.

  Lemma arithmetic_shiftr_sign_bit m a k
        (Hm : 0 < m)
        (Ha : 0 <= a < 2 ^ m)
        (Hk : 0 <= k) :
    Z.sign_bit m (Z.arithmetic_shiftr m a k) = Z.sign_bit m a.
  Proof.
    rewrite !Z.sign_bit_testbit
      by (try apply arithmetic_shiftr_bound; lia). apply f_equal; Z.solve_testbit. Qed.

  Lemma arithmetic_shiftr_arithmetic_shiftr m a p q
        (Hm : 0 < m)
        (Ha : 0 <= a < 2 ^ m)
        (Hp : 0 <= p)
        (Hq : 0 <= q) :
    Z.arithmetic_shiftr m (Z.arithmetic_shiftr m a p) q =
    Z.arithmetic_shiftr m a (p + q).
  Proof. Z.solve_using_testbit. Qed.

  Lemma arithmetic_shiftr_arithmetic_shiftr1 m a k
        (Hm : 0 < m)
        (Ha : 0 <= a < 2 ^ m)
        (Hk : 0 <= k) :
    Z.arithmetic_shiftr m (Z.arithmetic_shiftr1 m a) k =
    Z.arithmetic_shiftr m a (k + 1).
  Proof. Z.solve_using_testbit. Qed.

  Lemma arithmetic_shiftr_spec m a k
        (Hm : 0 < m)
        (Ha : 0 <= a < 2 ^ m)
        (Hk : 0 <= k) :
    Z.twos_complement m (Z.arithmetic_shiftr m a k) = (Z.twos_complement m a) / 2 ^ k.
  Proof. Z.solve_using_testbit. Qed.
End Z.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect.
Require Import ssrbool.
Require Import funs.
Require Import dataset.
Require Export Arith.

Delimit Scope dnat_scope with dnat.
Open Scope dnat_scope.
Bind Scope dnat_scope with nat.
Arguments Scope S [dnat_scope].
Arguments Scope pred [dnat_scope].
Arguments Scope plus [dnat_scope dnat_scope].
Arguments Scope minus [dnat_scope dnat_scope].
Arguments Scope mult [dnat_scope dnat_scope].
Arguments Scope le [dnat_scope dnat_scope].
Arguments Scope lt [dnat_scope dnat_scope].
Arguments Scope ge [dnat_scope dnat_scope].
Arguments Scope gt [dnat_scope dnat_scope].
Arguments Scope iter [type_scope dnat_scope _ _].

Notation plus := plus.
Notation minus := minus.

(*   A "reflected" version of Arith, with an emphasis on boolean predicates *)
(* and rewriting; this includes a canonical dataSet for nat, as well as     *)
(* reflected predicates, leq and ltn for comparison (ltn m n) is actually a *)
(* syntactic definition for the expansion of (leq (S m) n)),  hidden by the *)
(* pretty-printer. This has one serious advantage : reduction happen in the *)
(* same way in leq and ltn, and one drawback: rewrites that match leq will  *)
(* also match ltn.                                                          *)
(*   Also leq and ltn are defined so that they do NOT Simpl'ify; instead,   *)
(* rewrite rules are provided for cases where it is useful to do such       *)
(* simplifications (also, leq may be Unfold'ed to get reduction to true or  *)
(* false, should that be needed). This makes the manipulation of assertions *)
(* much more stable, while still allowing conversion for trivial uses.      *)
(*   Stable versions of plus and minus, addn and subn, respectively, are    *)
(* provided for the same reasons, and the standard arithmetic lemmas are    *)
(* replicated (however, this is not done for mult).                         *)
(*   Also included are replacements for the div2 lemmas, that fit better    *)
(* with the rest of the theory.                                             *)

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

(* Canonical comparison and DataSet for nat.                                *)

Fixpoint eqn (m n : nat) {struct m} : bool :=
  match m, n with
  | 0, 0 => true
  | S m', S n' => eqn m' n'
  | _, _ => false
  end.

Lemma eqnPx : reflect_eq eqn.
Proof.
move=> n m; apply: (iffP idP) => [|<-]; last by elim n.
by elim: n m => [|n Hrec] [|m]; auto.
Qed.

Notation eqnP := (eqnPx _ _).

Canonical Structure natData := DataSet eqnPx.

Lemma eqnE : eqn = @eqd _. Proof. done. Qed.

Lemma eqdSS : forall m n, (S m =d S n) = (m =d n). Proof. done. Qed.

Lemma nat_eqT : forall (x y : nat) (E E' : x = y), E = E'.
Proof. apply: data_eqT. Qed.

(* Protected addition, with a more systematic set of lemmas.                *)

Definition addn := nosimpl plus.

Lemma addnI : plus = addn. Proof. done. Qed.

Notation "x + y" := (addn x y) : dnat_scope.

Lemma add0n : forall n, 0 + n = n. Proof. done. Qed.
Lemma addSn : forall m n, S m + n = S (m + n). Proof. done. Qed.
Lemma add1n : forall n, 1 + n = S n. Proof. done. Qed.

Lemma addn0 : forall n, n + 0 = n.
Proof. by move=> n; apply: eqP; elim: n. Qed.

Lemma addnS : forall m n, m + S n = S (m + n).
Proof. by move=> m n; elim: m. Qed.

Lemma addSnnS : forall m n, S m + n = m + S n.
Proof. move=> *; rewrite addnS; apply addSn. Qed.

Lemma addnCA : forall m n p, m + (n + p) = n + (m + p).
Proof. by move=> m n; elim: m => [|m Hrec] p; rewrite ?addSnnS -?addnS. Qed.

Lemma addnC : forall m n, m + n = n + m.
Proof. by move=> m n; rewrite -{1}[n]addn0 addnCA addn0. Qed.

Lemma addn1 : forall n, n + 1 = S n.
Proof. by move=> *; rewrite addnC. Qed.

Lemma addnA : forall m n p, m + (n + p) = m + n + p.
Proof. by move=> m n *; rewrite (addnC n) addnCA addnC. Qed.

Lemma eqn_add0 : forall m n, (m + n =d 0) = (m =d 0) && (n =d 0).
Proof. by do 2 case. Qed.

Lemma eqn_addl : forall p m n, (p + m =d p + n) = (m =d n).
Proof. by move=> p *; elim p. Qed.

Lemma eqn_addr : forall p m n, (m + p =d n + p) = (m =d n).
Proof. by move=> p *; rewrite -!(addnC p) eqn_addl. Qed.

Lemma addn_injl : forall p, injective (addn p).
Proof. by move=> p m n Heq; apply: eqP; rewrite -(eqn_addl p) Heq set11. Qed.

Lemma addn_injr : forall p, injective (fun m => m + p).
Proof. move=> p m n; rewrite -!(addnC p); apply addn_injl. Qed.

(* Part of funs.v, delayed so that it uses the new definition of "+".  *)

Lemma iter_addn : forall n m A f (x : A), iter (n + m) f x = iter n f (iter m f x).
Proof. by move=> n m A f x; elim: n => [|n Hrec] //; congr f. Qed.

(* Protected substraction, and basic lemmas. Further properties depend on *)
(* ordering conditions.                                                   *)

Definition subn := nosimpl minus.
Notation "m - n" := (subn m n) : dnat_scope.

Lemma subnI : minus = subn. Proof. done. Qed.
Lemma sub0n : forall n, 0 - n = 0. Proof. done. Qed.
Lemma subn0 : forall n, n - 0 = n. Proof. by case. Qed.
Lemma subnn : forall n, n - n = 0. Proof. by elim. Qed.
Lemma subSS : forall n m, S m - S n = m - n. Proof. done. Qed.
Lemma subn1 : forall n, n - 1 = pred n. Proof. by case; try case. Qed.

Lemma subn_add2l : forall p m n, (p + m) - (p + n) = m - n.
Proof. by move=> p *; elim p. Qed.

Lemma subn_add2r : forall p m n, (m + p) - (n + p) = m - n.
Proof. by move=> p *; rewrite -!(addnC p) subn_add2l. Qed.

Lemma subn_addr : forall n m, (n + m) - n = m.
Proof. by move=> n *; rewrite -{2}[n]addn0 subn_add2l subn0. Qed.

Lemma subn_addl : forall n m, (m + n) - n = m.
Proof. by move=> n m; rewrite (addnC m) subn_addr. Qed.

Lemma subSnn : forall n, (S n) - n = 1.
Proof. move=> n; exact (subn_addl n 1). Qed.

Lemma subn_sub : forall m n p, (n - m) - p = n - (m + p).
Proof. by move=> m n p; elim: m n => [|m Hrec] [|n]; try exact (Hrec n). Qed.

(* Integer ordering, and its interaction with the other operations.       *)

Definition leq m n := m - n =d 0.

Notation "'ltn' m n" := (leq (S m) n) (at level 10, m, n at level 8, only parsing).

Notation "m <= n" := (leq m n) : dnat_scope.
Notation "m < n" := (ltn m n) : dnat_scope.
Notation "m >= n" := (leq n m) (only parsing) : dnat_scope.
Notation "m > n" := (ltn n m) (only parsing) : dnat_scope.

Lemma lePx : forall m n, reflect (m <= n)%nat (m <= n).
Proof.
move=> m n; elim: m n => [|m Hrec] [|n]; try (constructor; auto with arith).
apply: (iffP (Hrec _)); auto with arith.
Qed.

Notation leP := (lePx _ _).

Lemma le_eqT : forall m n (H H' : (m <= n)%nat), H = H'.
Proof.
move=> m n; elim: {n}(S n) {-2}n (erefl (S n)) => [|n Hrec] _ // [->].
move=> H; rewrite -[H]/(eq_ind _ _ H _ (erefl n)).
case: {1 2 6}n / H (erefl n) => [|n' H] Dn H'.
  case: H' Dn => [|n'' H'] Dn; first by rewrite (eqP_K Dn).
  by case (lt_irrefl n''); rewrite /lt -Dn.
  case: H' Dn {Hrec}(Hrec _ Dn H) => [|n'' H'] Dn Hrec.
  by case: (lt_irrefl n'); rewrite /lt Dn.
by case: Dn (Dn) H' => <- Dn H'; rewrite (eqP_K Dn) (Hrec H').
Qed.

Lemma ltPx : forall m n, reflect (m < n)%nat (m < n).
Proof. move=> *; exact leP. Qed.

Notation ltP := (ltPx _ _).

Lemma lt_eqT : forall m n (H H' : (m < n)%nat), H = H'.
Proof. exact (fun m => le_eqT (m := S m)). Qed.

Lemma leqNgt : forall m n, (m <= n) = negb (n < m).
Proof. by elim=> [|m Hrec] [|n]; try exact (Hrec n). Qed.

Lemma ltnNge : forall m n, (m < n) = negb (n <= m).
Proof. by move=> *; rewrite leqNgt. Qed.

Lemma leqnn : forall n, n <= n.
Proof. by elim. Qed.

Lemma eq_leq : forall m n, m = n -> m <= n.
Proof. by move=> m n <-; apply leqnn. Qed.

Lemma ltnn : forall n, n < n = false.
Proof. by move=> *; rewrite ltnNge leqnn. Qed.

Lemma leqnSn : forall n, n <= S n.
Proof. by elim. Qed.

Lemma ltnSn : forall n, n < S n.
Proof. exact leqnn. Qed.

Lemma ltnS : forall m n, (m < S n) = (m <= n).
Proof. done. Qed.

Lemma leq0n : forall n, 0 <= n.
Proof. done. Qed.

Lemma ltn0Sn : forall n, 0 < S n.
Proof. done. Qed.

Lemma ltn0 : forall n, n < 0 = false.
Proof. done. Qed.

Inductive leq_xor_gtn (m n : nat) : bool -> bool -> Set :=
  | LeqNotGtn : m <= n -> leq_xor_gtn m n true false
  | GtnNotLeq : n < m -> leq_xor_gtn m n false true.

Lemma leqP : forall m n, leq_xor_gtn m n (m <= n) (n < m).
Proof.
move=> m n; rewrite ltnNge; case Hmn: (m <= n); constructor; auto.
by rewrite ltnNge Hmn.
Qed.

Inductive ltn_xor_geq (m n : nat) : bool -> bool -> Set :=
  | LtnNotGeq : m < n -> ltn_xor_geq m n true false
  | GeqNotLtn : n <= m -> ltn_xor_geq m n false true.

Lemma ltnP : forall m n, ltn_xor_geq m n (m < n) (n <= m).
Proof. by move=> m n; rewrite -(ltnS n); case (leqP (S m) n); constructor. Qed.

Lemma ltnSpred : forall n m, m < n -> S (pred n) = n.
Proof. by move=> [|n]. Qed.

Lemma leq_eqVlt : forall m n, (m <= n) = (m =d n) || (m < n).
Proof. by elim=> [|m Hrec] [|n]; try exact (Hrec n). Qed.

Lemma ltn_neqAle : forall m n, (m < n) = negb (m =d n) && (m <= n).
Proof. by elim=> [|m Hrec] [|n]; try exact (Hrec n). Qed.

Lemma leq_trans : forall n m p, m <= n -> n <= p -> m <= p.
Proof. by elim=> [|m Hrec] [|n] [|p]; try exact (Hrec n p). Qed.

Lemma leqW : forall m n, m <= n -> m <= S n.
Proof. move=> m n; exact (leq_trans (p := S n) (leqnSn m)). Qed.

Lemma ltnW : forall m n, m < n -> m <= n.
Proof. by move=> m n; move/leqW. Qed.

Lemma ltn_trans : forall n m p, m < n -> n < p -> m < p.
Proof. move=> n m p; move/leqW; apply: leq_trans. Qed.

Lemma leq_add2l : forall p m n, (p + m <= p + n) = (m <= n).
Proof. by move=> p *; elim p. Qed.

Lemma leq_add2r : forall p m n, (m + p <= n + p) = (m <= n).
Proof. move=> p *; rewrite -!(addnC p); apply leq_add2l. Qed.

Lemma leq_add2 : forall m1 m2 n1 n2, m1 <= m2 -> n1 <= n2 -> m1 + n1 <= m2 + n2.
Proof.
move=> m1 m2 n1 n2 Hm Hn.
by apply (leq_trans (n := m2 + n1)); rewrite ?leq_add2l ?leq_add2r.
Qed.

Lemma leq_addr : forall m n, n <= n + m.
Proof. by move=> m n; rewrite -{1}[n]addn0 leq_add2l. Qed.

Lemma leq_addl : forall m n, n <= m + n.
Proof. move=> *; rewrite addnC; apply leq_addr. Qed.

Lemma eqn_leq : forall m n, (m =d n) = (m <= n) && (n <= m).
Proof. by elim=> [|m Hrec] [|n]; try exact (Hrec n). Qed.

Lemma leqn0 : forall n, (n <= 0) = (n =d 0).
Proof. by move=> *; rewrite eqd_sym eqn_leq /=. Qed.

Lemma ltn_lt0sub : forall m n, (m < n) = (0 < n - m).
Proof. by elim=> [|m Hrec] [|n]; try exact (Hrec n). Qed.

Lemma eqn_sub0 : forall m n, (m - n =d 0) = (m <= n).
Proof. done. Qed.

Lemma leq_sub_add : forall m n p, (m - n <= p) = (m <= n + p).
Proof. by move=> *; rewrite /leq subn_sub. Qed.

Lemma leq_subr : forall m n, n - m <= n.
Proof. by move=> *; rewrite leq_sub_add leq_addl. Qed.

Lemma leq_add_sub : forall m n, m <= n -> m + (n - m) = n.
Proof. by elim=> [|m Hrec] [|n] // Hmn; congr S; apply: Hrec. Qed.

Lemma leq_sub_sub : forall m n, m <= n -> n - (n - m) = m.
Proof. by move=> m n Hmn; rewrite -{1}[n](leq_add_sub Hmn) subn_addl. Qed.

Lemma leq_subS : forall m n, m <= n -> S n - m = S (n - m).
Proof. by elim=> [|m Hrec] [|n]; try exact (Hrec n). Qed.

Lemma ltn_subS : forall m n, m < n -> n - m = S (n - S m).
Proof. exact (fun m => leq_subS (m := S m)). Qed.

Lemma leq_sub2r : forall p m n, m <= n -> m - p <= n - p.
Proof.
move=> p m n Hmn; rewrite leq_sub_add; apply: (leq_trans Hmn).
by rewrite -leq_sub_add leqnn.
Qed.

Lemma leq_sub2l : forall p m n, m <= n -> p - n <= p - m.
Proof.
move=> p m n; rewrite -(leq_add2r (p - m)) leq_sub_add.
by apply: leq_trans; rewrite -leq_sub_add leqnn.
Qed.

Lemma leq_sub2 :  forall m1 m2 n1 n2,
  m1 <= m2 -> n2 <= n1 -> m1 - n1 <= m2 - n2.
Proof.
move=> m1 m2 n1 n2 Hm Hn; exact: leq_trans (leq_sub2l _ Hn) (leq_sub2r _ Hm).
Qed.

(* Multiplication. *)

Definition muln m n := iter m (addn n) 0.
Notation "m * n" := (muln m n) : dnat_scope.

Lemma mulnI : mult =2 muln.
Proof. by elim=> // m Hrec n /=; congr addn. Qed.

Lemma mul0n : forall n, 0 * n = 0. Proof. done. Qed.
Lemma muln0 : forall n, n * 0 = 0. Proof. by elim. Qed.
Lemma mul1n : forall n, 1 * n = n. Proof. exact: addn0. Qed.
Lemma muln1 : forall n, n * 1 = n. Proof. by elim=> //= n ->. Qed.

Lemma mulnC : forall m n, m * n = n * m.
Proof.
move=> m n; elim: m => /= [|m ->]; elim: n => //= n <-; congr S; exact: addnCA.
Qed.

Lemma muln_addl : forall m1 m2 n, (m1 + m2) * n = m1 * n + m2 * n.
Proof. by move=> m1 m2 n; elim: m1 => //= m1 Hrec; rewrite -addnA -Hrec. Qed.

Lemma muln_addr : forall m n1 n2, m * (n1 + n2) = m * n1 + m * n2.
Proof. by move=> m *; rewrite !(mulnC m) muln_addl. Qed.

Lemma mulnA : forall m n p, m * (n * p) = m * n * p.
Proof. by move=> m n p; elim: m => //= m ->; rewrite muln_addl. Qed.

Lemma mulnCA : forall m n p, m * (n * p) = n * (m * p).
Proof. by move=> m *; rewrite !mulnA (mulnC m). Qed.

Lemma eqn_mul0 : forall m n, (m * n =d 0) = (m =d 0) || (n =d 0).
Proof. by case=> // m [|n] //=; rewrite muln0. Qed.

Lemma muln_subl : forall m1 m2 n, (m1 - m2) * n = m1 * n - m2 * n.
Proof.
move=> m1 m2 n; elim: m1 m2 => //= m1 Hrec [|m2] /=; first by rewrite subn0.
by rewrite subn_add2l -Hrec.
Qed.

Lemma muln_subr : forall m n1 n2, m * (n1 - n2) = m * n1 - m * n2.
Proof. by move=> m *; rewrite !(mulnC m) muln_subl. Qed.

Lemma leq_mul2l : forall m n1 n2, (m * n1 <= m * n2) = (m =d 0) || (n1 <= n2).
Proof. by move=> m n1 n2; rewrite {1}/leq -muln_subr eqn_mul0. Qed.

Lemma leq_mul2r : forall m1 m2 n, (m1 * n <= m2 * n) = (m1 <= m2) || (n =d 0).
Proof. by move=> m1 m2 n; rewrite {1}/leq -muln_subl eqn_mul0. Qed.

Lemma leq_mul : forall m1 m2 n1 n2, m1 <= n1 -> m2 <= n2 -> m1 * m2 <= n1 * n2.
Proof.
move=> m1 m2 n1 n2 Hmn1 Hmn2; apply (@leq_trans (m1 * n2)).
  by rewrite leq_mul2l Hmn2 orbT.
by rewrite leq_mul2r Hmn1.
Qed.

(* Parity and bits. *)

Coercion nat_of_bool (b : bool) := if b then 1 else 0.

Lemma addn_negb : forall b : bool, negb b + b = 1.
Proof. by case. Qed.

Fixpoint odd (n : nat) : bool :=
  if n is S n' then negb (odd n') else false.

Lemma odd_addn : forall m n, odd (m + n) = odd m +b odd n.
Proof.
move=> m n; elim: m => [|m Hrec] //=.
by rewrite -addTb addnI Hrec addbA addTb.
Qed.

Lemma odd_subn : forall m n, n <= m -> odd (m - n) = odd m +b odd n.
Proof.
move=> m n Hnm; apply addb_movelr.
rewrite -odd_addn; exact (congr1 odd (leq_add_sub Hnm)).
Qed.

(* Doubling. *)

Fixpoint double_rec (n : nat) : nat :=
  if n is S n' then S (S (double_rec n')) else 0.

Definition double := nosimpl double_rec.

Lemma doubleI : double_rec = double. Proof. done. Qed.

Lemma double0 : double 0 = 0. Proof. done. Qed.

Lemma doubleS : forall n, double (S n) = S (S (double n)).
Proof. done. Qed.

Lemma double_addnn : forall n, double n = addn n n.
Proof. by move=> n; apply: eqP; elim: n => *; rewrite ?addnS. Qed.

Lemma double_mul2 : forall n, double n = 2 * n.
Proof. by move=> n; rewrite double_addnn /= addn0. Qed.

Lemma double_add : forall m n, double (m + n) = double m + double n.
Proof. by move=> m n; rewrite !double_addnn -!addnA (addnCA n). Qed.

Lemma double_sub : forall m n, double (m - n) = double m - double n.
Proof. by elim=> [|m Hrec] [|n]; try exact (Hrec n). Qed.

Lemma leq_double : forall m n, (double m <= double n) = (m <= n).
Proof. by move=> m n; rewrite /leq -double_sub; case (m - n). Qed.

Lemma ltn_double : forall m n, (double m < double n) = (m < n).
Proof. by move=> *; rewrite !ltnNge leq_double. Qed.

Lemma ltn_Sdouble : forall m n, (S (double m) < double n) = (m < n).
Proof. by move=> *; rewrite -doubleS leq_double. Qed.

Lemma leq_Sdouble : forall m n, (double m <= S (double n)) = (m <= n).
Proof. by move=> *; rewrite leqNgt ltn_Sdouble -leqNgt. Qed.

Lemma odd_double : forall n, odd (double n) = false.
Proof. by move=> *; rewrite double_addnn odd_addn addbb. Qed.

(* Halving. *)

Fixpoint half (n : nat) : nat := if n is S n' then uphalf n'   else 0
with   uphalf (n : nat) : nat := if n is S n' then S (half n') else 0.

Lemma half_double : forall n, half (double n) = n.
Proof. by elim=> [|n Hrec] //=; congr S. Qed.

Lemma uphalf_double : forall n, uphalf (double n) = n.
Proof. by elim=> [|n Hrec] //=; congr S. Qed.

Lemma uphalf_half : forall n, uphalf n = odd n + half n.
Proof. by elim=> [|n Hrec] //=; rewrite Hrec addnA addn_negb. Qed.

Lemma odd_double_half : forall n, odd n + double (half n) = n.
Proof.
by elim=> [|n Hrec] //=; rewrite -{3}Hrec uphalf_half double_add; case (odd n).
Qed.

Lemma half_bit_double : forall n (b : bool), half (b + (double n)) = n.
Proof. move=> n [|]; [ exact (uphalf_double n) | exact (half_double n) ]. Qed.

Lemma half_add : forall m n, half (m + n) = (odd m && odd n) + (half m + half n).
Proof.
move=> m n; rewrite -{1}[n]odd_double_half addnCA -{1}[m]odd_double_half.
rewrite -addnA -double_add.
by case (odd n); case (odd m); rewrite /= ?add0n ?half_double ?uphalf_double.
Qed.

Lemma half_leq : forall m n, m <= n -> half m <= half n.
Proof.
move=> m n; rewrite -{1}[m]odd_double_half -{1}[n]odd_double_half.
case (odd m); case (odd n); rewrite /addn /= ?add0n ?ltnS;
 by rewrite ?leq_double ?ltn_double ?leq_Sdouble; try apply: leqW.
Qed.

(* A congruence tactic, similar to the boolean one, along with an S/addn *)
(* normalization tactic.                                                 *)

Definition natNorm1 := 1.
Lemma addnNorm1 : forall n, S n = natNorm1 + n. Proof. done. Qed.

Ltac NatNorm :=
  rewrite ?add0n ?addn0;
   rewrite -/natNorm1 ?addnNorm1 -?addnA -?addnNorm1 /natNorm1 ?addnS ?addn0.

Ltac NatCongr := first
 [ refine (congr1 S _)
 | refine (congr1 pred _)
 | refine (congr1 (addn _) _)
 | refine (congr1 (subn _) _)
 | refine (congr1 (fun n => n + _) _)
 | match goal with |- (addn ?X1 ?X2 = ?X3) =>
     symmetry;
     rewrite -1?(addnC X1) -?(addnCA X1);
     refine (congr1 (addn X1) _);
     symmetry
   end ].

Unset Implicit Arguments.


(* Ancien bug signale par Laurent Thery sur la condition de garde *)

Require Import Bool.
Require Import ZArith.

Definition rNat := positive.

Inductive rBoolOp : Set :=
  | rAnd : rBoolOp
  | rEq : rBoolOp.

Definition rlt (a b : rNat) : Prop :=
  (a ?= b)%positive Datatypes.Eq = Datatypes.Lt.

Definition rltDec : forall m n : rNat, {rlt m n} + {rlt n m \/ m = n}.
intros n m; generalize (nat_of_P_lt_Lt_compare_morphism n m);
 generalize (nat_of_P_gt_Gt_compare_morphism n m);
 generalize (Pcompare_Eq_eq n m); case ((n ?= m)%positive Datatypes.Eq).
intros H' H'0 H'1; right; right; auto.
intros H' H'0 H'1; left; unfold rlt in |- *.
apply nat_of_P_lt_Lt_compare_complement_morphism; auto.
intros H' H'0 H'1; right; left; unfold rlt in |- *.
apply nat_of_P_lt_Lt_compare_complement_morphism; auto.
apply H'0; auto.
Defined.

Definition rmax : rNat -> rNat -> rNat.
intros n m; case (rltDec n m); intros Rlt0.
exact m.
exact n.
Defined.

Inductive rExpr : Set :=
  | rV : rNat -> rExpr
  | rN : rExpr -> rExpr
  | rNode : rBoolOp -> rExpr -> rExpr -> rExpr.

Fixpoint maxVar (e : rExpr) : rNat :=
  match e with
  | rV n => n
  | rN p => maxVar p
  | rNode n p q => rmax (maxVar p) (maxVar q)
  end.

(* Check bug #1491 *)

Require Import Streams.

Definition decomp (s:Stream nat) : Stream nat :=
  match s with Cons _ s => s end.

CoFixpoint bx0 : Stream nat := Cons 0 bx1
with bx1 : Stream nat := Cons 1 bx0.

Lemma bx0bx : decomp bx0 = bx1.
simpl. (* used to return bx0 in V8.1 and before instead of bx1 *)
reflexivity.
Qed.

(* Check mutually inductive statements *)

Require Import ZArith_base Omega.
Open Scope Z_scope.

Inductive even: Z -> Prop :=
| even_base: even 0
| even_succ: forall n, odd (n - 1) -> even n
with odd: Z -> Prop :=
| odd_succ: forall n, even (n - 1) -> odd n.

Lemma even_pos_odd_pos: forall n, even n -> n >= 0
with odd_pos_even_pos : forall n, odd n -> n >= 1.
Proof.
 intros.
 destruct H.
   omega.
   apply odd_pos_even_pos in H.
   omega.
 intros.
 destruct H.
  apply even_pos_odd_pos in H.
  omega.
Qed.

CoInductive a : Prop := acons : b -> a
with b : Prop := bcons : a -> b.

Lemma a1 : a
with b1 : b.
Proof.
apply acons.
assumption.

apply bcons.
assumption.
Qed.


Require Import String.
From AC Require Import nvalue.
From AC Require Import value_tree.
Require Import Bool.

Check (some nat (default nat 5) (cons (some bool (default bool true) nil) nil)).

(*Returns first value tree in the list*)
Compute (pi 0 (empty (cons (some bool (default bool true) nil) (cons (some bool (default bool false) nil)
(cons (some nat (default nat 5) nil) nil))))).

(*Returns second value tree in the list*)
Compute (pi 1 (empty (cons (some bool (default bool true) nil) (cons (some bool (default bool false) nil)
(cons (some nat (default nat 5) nil) nil))))).

(*Returns third value tree in the list*)
Compute (pi 2 (empty (cons (some bool (default bool true) nil) (cons (some bool (default bool false) nil)
(cons (some nat (default nat 5) nil) nil))))).

(*Returns empty value tree*)
Compute (pi 3 (empty (cons (some bool (default bool true) nil) (cons (some bool (default bool false) nil)
(cons (some nat (default nat 5) nil) nil))))).

Definition vt_0: value_tree := empty (cons (some bool (default bool true) nil) (cons (some bool (default bool false) nil)
(cons (some nat (default nat 5) nil) nil))).

Definition vt_1: value_tree := empty (cons (some bool (default bool false) nil) (cons (some bool (default bool true) nil)
(cons (some nat (default nat 6) nil) nil))).

(*VALUE-TREE ENV*)

Check
(
vt_el 0 ( vt_0 ) (
vt_el 1 ( vt_1)
(vt_end)
)
).

Definition vt_env_0: value_tree_env :=  vt_el 0 ( vt_0 ) ( vt_el 1 ( vt_1) (vt_end)).

Compute (pi_env 0 vt_env_0).

Compute (pi_env 1 vt_env_0).

Compute (pi_env 2 vt_env_0).

Compute (pi_env 3 vt_env_0).


Require Import Coq.Lists.List.
Require Export Coq.Sets.Ensembles.
Require Import Coq.Sorting.Permutation.
Require Import Fiat.Common.
Require Import Fiat.Common.List.PermutationFacts.

Definition EnsembleListEquivalence
           {A}
           (ensemble : Ensemble A)
           (seq : list A) :=
  NoDup seq /\
  forall x, Ensembles.In _ ensemble x <-> List.In x seq.

Local Ltac perm_t :=
  repeat match goal with
           | _ => intro
           | _ => progress destruct_head_hnf and
           | _ => progress destruct_head_hnf or
           | _ => progress destruct_head_hnf Singleton
           | _ => progress split_iff
           | _ => split
           | [ H : NoDup (_::_) |- _ ] => inversion H; clear H; subst
           | [ H : ~Ensembles.In _ (Singleton _ ?a) ?x |- _ ]
             => assert (a <> x) by (intro; subst; apply H; constructor);
               clear H
           | _ => solve [ eauto ]
           | _ => congruence
         end.

Lemma Permutation_pull_to_front {T} (a : T) ls
      (H : List.In a ls)
: exists ls' : _, Permutation ls (a::ls').
Proof.
  induction ls; simpl in *; destruct_head False.
  destruct_head_hnf or; subst.
  { exists ls; reflexivity. }
  { specialize (IHls H).
    destruct IHls as [ls' H'].
    eexists (_::ls').
    etransitivity; [ apply perm_skip; exact H' | ].
    apply perm_swap. }
Qed.

Lemma EnsembleListEquivalence_Same_set U (A B : Ensemble U)
      ls
      (H : EnsembleListEquivalence A ls)
: EnsembleListEquivalence B ls <-> Same_set _ A B.
Proof.
  induction ls;
  repeat match goal with
           | _ => split
           | _ => intro
           | _ => progress destruct_head_hnf and
           | _ => progress split_iff
           | _ => progress simpl in *
           | _ => solve [ eauto ]
         end.
  Grab Existential Variables.
  assumption.
Qed.

Lemma EnsembleListEquivalence_Permutation U (A : Ensemble U)
      ls ls'
      (H : EnsembleListEquivalence A ls) (H' : EnsembleListEquivalence A ls')
: Permutation ls ls'.
Proof.
  revert A ls' H H'.
  induction ls; intros A ls' H H'.
  { destruct_head_hnf and; split_iff.
    destruct ls'; simpl in *; auto.
    specialize_all_ways.
    intuition. }
  { let H := fresh in
    let H' := fresh in
    let t := destruct_head_hnf and; split_iff; intuition in
    lazymatch goal with
      | [ |- Permutation (?a::?ls) ?ls' ]
        => assert (H : List.In a ls') by t;
          assert (H' : ~List.In a ls)
             by (intro; t; instantiate;
                 match goal with
                   | [ H'' : NoDup (_::_) |- _ ]
                     => solve [ inversion H''; subst; intuition ]
                 end)
    end;
      hnf in H.
    destruct (Permutation_pull_to_front _ _ H0) as [ls'' H''].
    symmetry in H''.
    etransitivity; [ | exact H'' ].
    apply perm_skip.
    apply (IHls (Subtract _ A a)).
    { perm_t;
      specialize_all_ways;
      perm_t. }
    { pose proof (fun x => @Permutation_in _ _ _ x H'').
      symmetry in H''.
      pose proof (fun x => @Permutation_in _ _ _ x H'').
      let H := fresh in
      assert (H : NoDup (a::ls'')) by
          (eapply PermutationFacts.NoDup_Permutation_rewrite;
           try solve [ destruct_head_hnf and; eassumption ]);
        inversion H; subst; clear H.
      perm_t; specialize_all_ways; perm_t. } }
Qed.

Lemma EnsembleListEquivalence_slice :
  forall {A} a b c (ens: Ensemble A),
    EnsembleListEquivalence ens (a ++ b ++ c) ->
    EnsembleListEquivalence (fun x => ens x /\ ~ List.In x b) (a ++ c).
Proof.
  unfold EnsembleListEquivalence, Ensembles.In; simpl;
  repeat setoid_rewrite in_app_iff; intros *.
  split.
  - intros. intuition.
    eauto using NoDup_slice.
  - intros; intuition.
    + rewrite H1 in H2; intuition.
    + rewrite H1; intuition.
    + eapply NoDup_app_inv'; eauto.
    + rewrite H1; intuition.
    + eapply NoDup_app_inv'; eauto.
Qed.

Lemma ensemble_list_equivalence_set_eq_morphism {A : Type} {ens1 ens2 : A -> Prop} :
  (forall x, Ensembles.In _ ens1 x <-> Ensembles.In _ ens2 x) ->
  forall (seq : list A),
    (EnsembleListEquivalence ens1 seq <-> EnsembleListEquivalence ens2 seq).
Proof.
  intros * equiv *;
  unfold EnsembleListEquivalence, In in *;
  setoid_rewrite equiv; reflexivity.
Qed.

Lemma EnsembleListEquivalence_lift_property {TItem: Type} {P: TItem -> Prop} :
  forall (sequence: list TItem) (ensemble: TItem -> Prop),
    EnsembleListEquivalence ensemble sequence ->
    ((forall item,
        List.In item sequence -> P item) <->
     (forall item,
        Ensembles.In _ ensemble item -> P item)).
Proof.
  intros * equiv;
  destruct equiv as [NoDup_l equiv];
  setoid_rewrite equiv;
  reflexivity.
Qed.