Require Import HoTT.
Require Import type_over.
Require Import finite_lemmas.
Require Import pointed_lemmas.
Require Import type_over.
Require Import pushout_lemmas.

Definition embedding (X Y : Type) := {f : X -> Y & IsEmbedding f}.
Definition embedding_to_arrow {X Y : Type} :
  embedding X Y -> (X -> Y) := pr1.
Coercion embedding_to_arrow : embedding >-> Funclass.

Section Functor_prod.
  Definition functor_prod_fin {A B : Finite_Types} {X : A -> pType} (f : embedding B A) :
    (forall b : B, X (f b)) -> (forall a : A, X a).
  Proof.
    (* intro x. *)
    (* apply (equiv_ind (split_range _ _ f _)^-1 _). *)
    (* intros [[a [b []]] | [a n]]; cbn. *)
    (* - exact (x b). *)
    (* - exact (point ( X a)). *)
    destruct f as [f emb].
    intros x a.
    destruct (detachable_image_finite f a) as [[b p] | nhitA].
    - exact (transport X p (x b)).
    - exact (point (X a)).
  Defined.

  (* Definition functor_exp {X : pType} {A B : Finite_Types} (f : embedding B A)  : *)
  (*   (B -> X) -> (A -> X). *)
  (* Proof. *)
  (*   intro x. intro a. *)
  (*   destruct f as [f emb]. *)
  (*   destruct (detachable_image_finite f a) as [[b p] | nhitA]. *)
  (*   - exact (x b). *)
  (*   - exact (point X). *)
  (* Defined. *)

  Definition issect_functor_prod_fin {A B : Finite_Types} {X : A -> pType} (f : embedding B A) (x : forall b : B, X (f b)) :
    forall b : B, (functor_prod_fin f x (f b) = x b).
  Proof.
    intro b.
    unfold functor_prod_fin. destruct f as [f emb]. cbn.
    destruct (detachable_image_finite f (f b)) as [[b' p] | ].
    - set (g := retract_of_embedding B A f _ b).
      set (H := (issect_embedding B A f _ b) : g o f == idmap).
      cut ({q : b' = b & ap f q = p}).
      + intros [q h]. destruct h. destruct q. reflexivity.
      + exists ((H b')^ @ ap g p @ (H b)).
        apply (isset_Finite A). exact _.
    - apply Empty_rec. apply n. exists b. reflexivity.
  Defined.
End Functor_prod.

Definition base_to_sum (A : Type) (X : A -> pType) : A -> {a : A & X a} := fun a => (a; point (X a)).

Definition Wedge {A : Type} (X : A -> pType) : Type
  := pushout (const tt) (base_to_sum A X).

(* uncurry constructors *)
Definition pt {A : Type} {X : A -> pType} : Wedge X := push_fl _ _ tt.
Definition wsummand {A : Type} {X : A -> pType} (a : A)
  : X a -> Wedge X
  := fun x => push_fr _ _ (a;x).
Definition wp {A : Type} {X : A -> pType} (a : A)
  : pt = (wsummand a (point (X a)))
  := pp (f:= const tt) (g := base_to_sum A X) a.

Definition wedge_ind {A : Type} (X : A -> pType)
           (P : Wedge X -> Type)
           (pt' : P pt)
           (wsummand' : forall (a : A) (x : X a), P (wsummand a x))
           (wp' : forall (a : A), transport P (wp a) pt' = wsummand' a (point (X a)))
  : forall x : Wedge X, P x.
Proof.
  srapply @pushout_ind'. intros []. exact pt'.
  intros [a x]. exact (wsummand' a x).
  exact wp'.
Defined.

Definition wedge_rec {A : Type} (X : A -> pType)
           (P : Type)
           (pt' : P)
           (wsummand' : forall (a : A), X a -> P)
           (wp' : forall (a : A), pt' = wsummand' a (point (X a)))
  : Wedge X -> P.
Proof.
  srapply @pushout_rec'. intros []. exact pt'.
  intros [a x]. exact (wsummand' a x).
  exact wp'.
Defined.

Definition functor_wedge_summand {A : Type} (X : A -> pType) (B : Type) (f : B -> A) :
  forall b : B, X (f b) -> {a : A & X a}.
Proof.
  intros b x. exact (f b; x).
Defined.

Definition functor_wedge {A : Type} (X : A -> pType) (B : Type) (f : B -> A) :
           Wedge (fun b : B => X (f b)) -> Wedge X.
Proof.
  srapply @functor_pushout. exact f. exact idmap.
  - simpl. intros [b x]. apply (functor_wedge_summand X B f b x).
  - intro b. reflexivity.
  - intro b. reflexivity.
Defined.

Definition functor_wedge_compose {A : Type} (X : A -> pType) (B : Type) (f : B -> A) (C : Type) (g : C -> B) :
  functor_wedge X C (f o g) == functor_wedge X B f o functor_wedge (fun b : B => X (f b)) C g.
Proof.
  intro x.
  refine (_ @ functor_pushout_compose _ _ _ _ _ _ _ _ _ _ x). reflexivity.
Defined.

Definition wedge_eta_homot {A : Type} {X : A -> pType} {P : Wedge X -> Type}
           (f : forall x : Wedge X, P x) :
  f == wedge_ind X P (f pt) (fun (a : A) (x : (X a)) => f (wsummand a x)) (fun a : A => apD f (wp a)).
Proof.
  srapply @wedge_ind; try reflexivity.
  - intro a.
    refine (transport_paths_FlFr_D
              (f := f)
              (g := wedge_ind X P (f pt) (fun (a0 : A) (x0 : X a0) => f (wsummand a0 x0)) (fun a0 : A => apD f (wp a0)))
              (wp a) idpath @ _).
    simpl. apply moveR_Mp.
    refine (pushout_ind_beta_pp P _ _ _ @ _).
    cut (forall q : transport P (wp a) (f pt) = f (wsummand a (point (X a))), q = ((q^@1)^@1)).
    intro H. apply H.
    intros []. reflexivity.
Defined.

Definition wedge_rec_eta_homot {A : Type} {X : A -> pType} {P : Type}
           (f : Wedge X -> P)
  : f == wedge_rec X P (f pt) (fun a => f o (wsummand a)) (fun a => ap f (wp a)).
Proof.
  unfold pointwise_paths.
  srapply @wedge_ind; try reflexivity.
  intro a.
  refine (transport_paths_FlFr
            (f := f)
            (wp a) idpath @ _).
  apply moveR_Mp. refine (pushout_rec_beta_pp P _ _ _ @ _).
  cut (forall q : f pt = f (wsummand a (point (X a))), q = ((q^ @ 1)^ @ 1)).
  intro H. apply H. intros []. reflexivity.
Defined.

Definition path_wedge_arrow {A : Type} (X : A -> pType) (Y : Type) (f g : Wedge X -> Y)
           (eq_pt : f pt = g pt)
           (eq_summand : forall (a : A) (x : X a), f (wsummand a x) = g (wsummand a x))
           (eq_wp : forall a : A,
              eq_pt^ @ (ap f (wp a)) @ (eq_summand a (point (X a))) = ap g (wp a))
  : f = g.
Proof.
  apply path_forall. srapply @wedge_ind.
  - exact eq_pt.
  - exact eq_summand.
  - intro a.
    refine (transport_paths_FlFr (wp a) eq_pt @ _).
    refine (concat_pp_p _ _ _ @ _). apply moveR_Vp. apply moveR_Mp. apply inverse.
    refine (concat_p_pp _ _ _ @ _). exact (eq_wp a).
Defined.

Definition wedge_to_prod_summand {A : Finite_Types} (X : A -> pType)
           : forall (a : A), (X a) -> forall a : A, X a.
Proof.
  intros a x.
  intro a'.
  destruct (decidablepaths_finite A a a').
  + destruct p. exact x.
  + exact (point (X a')).
Defined.

Definition wedge_to_prod_wp  {A : Finite_Types} (X : A -> pType) (a : A) :
  ((fun a' : A => point (X a')) = wedge_to_prod_summand X a (point (X a))).
Proof.
  apply path_forall. intro a'.
  unfold wedge_to_prod_summand.
  destruct (decidablepaths_finite A a a').
  + cbn. destruct p. reflexivity.
  + reflexivity.
Defined.

Definition wedge_to_prod {A : Finite_Types} (X : A -> pType)
  : Wedge X -> (forall a : A, X a).
Proof.
  srapply @wedge_rec.
  - intro a. exact (point (X a)).
  - apply wedge_to_prod_summand.
  - apply wedge_to_prod_wp.
Defined.

(* Wedge_to_prod is natural *)
Definition natural_wedge_to_prod_summand {A : Finite_Types} (X : A -> pType) (B : Finite_Types) (f : embedding B A) :
    forall (b : B) (x : X (f b)),
      wedge_to_prod_summand (A := A) X (f b) x = functor_prod_fin f (wedge_to_prod_summand (X o f) b x).
Proof.
  intros b x. unfold wedge_to_prod_summand. unfold functor_prod_fin.
  destruct f as [f emb]. simpl in *. apply path_forall. intro a.
  destruct (detachable_image_finite f a) as [[b' p']|];
  destruct (decidablepaths_finite A (f b) a) as [p|];
  try destruct (decidablepaths_finite B b b') as [q|].
  - destruct q.
  cut (p = p').
  { intros []. reflexivity. }
  apply (isset_Finite A). exact _.
  - destruct p'. apply Empty_rec. apply n. apply (isinj_embedding f). exact _. exact p.
  - unfold transport. destruct p'. destruct q. apply Empty_rec. apply n. reflexivity.
  - destruct p'. unfold transport. reflexivity.
  - destruct p. apply Empty_rec. apply n.
    exact (b; idpath).
  - reflexivity.
Defined.

Definition natural_wedge_to_prod {A : Finite_Types} (X : A -> pType) (B : Finite_Types) (f : embedding B A)
  : wedge_to_prod X o (functor_wedge X B f) = (functor_prod_fin f) o (wedge_to_prod (fun b : B => X (f b))).
Proof.
  srapply @path_wedge_arrow.
  - apply path_forall. intro a. simpl.
    destruct f as [f emb].
    unfold functor_prod_fin.
    destruct
      (detachable_image_finite f a) as [[b p]|]. destruct p. reflexivity. reflexivity.
  - exact (natural_wedge_to_prod_summand X B f).
  - intro b. destruct f as [f emb]. simpl.

  apply path_arrow.
  (* refine ((wedge_rec_eta_homot ((wedge_to_prod X) o (functor_wedge X B f)) x) *)
  (*           @ _ @ *)
  (*         (wedge_rec_eta_homot ((functor_prod_fin f) o (wedge_to_prod (fun b : B => X (f b)))) x)^). *)
  (* simpl. *)

  (* -  *)

  srapply @wedge_ind.
  - apply path_forall. intro a. simpl.
    destruct f as [f emb].
    unfold functor_prod_fin.
    destruct
      (detachable_image_finite f a) as [[b p]|]. destruct p. reflexivity. reflexivity.
  - exact (natural_wedge_to_prod_summand X B f).
  - simpl. intro b.
    refine (transport_paths_FlFr (wp b) _ @ _). destruct f as [f emb]. simpl.
    cut (ap (fun x : Wedge (fun b : B => X (f b)) => wedge_to_prod X (functor_wedge X B f x)) (wp a)
         = wedge_to_prod_wp X

    destruct (detachable_image_finite f a) as [[b' p']|].
    destruct (decidablepaths_finite A (f b) a) as [p|].
    destruct (decidablepaths_finite B b b') as [q|].

    destruct p.

    destruct p. destruct q.

    change (functor_wedge X B f (wsummand b x)) with (wsummand
    apply path_forall. intro a.
    (* destruct (decidablepaths_finite A (f b) a) as [[]|]. *) simpl in x.

    rewrite transport_

    reflexivity. reflexivity.
    destruct (decidablepaths_finite B b a').
    +

    unfold wedge_to_prod. unfold functor_prod_fin. simpl.

  intro x.
  refine ((pushout_rec_eta_homot ((wedge_to_prod X) o (functor_wedge X B f)) x)
            @ _ @
          (pushout_rec_eta_homot ((functor_prod_fin f) o (wedge_to_prod (fun b : B => X (f b)))) x)^).
  simpl.
  revert x.
  srapply @wedge_ind.
  - simpl. apply path_forall. intro a. unfold functor_prod_fin.

    destruct
      (detachable_image_finite f a) as [[b p]|]. destruct p. reflexivity. reflexivity.
  - intros a x. simpl. unfold functor_prod_fin.

  apply (srapply @path_pushout_rec'.).

  cbn.

(* The set {1,...,n} *)
Definition one_to (n : nat) := Fin n.
(* Definition pred_one_to {n : nat} : one_to n -> Unit + one_to n. *)
(* Proof. *)
(*   intro k.  *)

Context (X : pType).
Context (n : nat).
Context (U : one_to n -> Finite_Types -> pType).
Context (i : forall (k : one_to n) (A: Finite_Types),
            U k A -> (A -> X)).
Context (l : forall (k : one_to n) {A B : Finite_Types} (f : embedding B A),
            U k B -> U k A).
Context (natl : forall (k : one_to n) {A B : Finite_Types} (f : embedding B A),
            (i k A) o (l k A B f) = (functor_exp f) o (i k B)).

(* l_compose, U k is pushout, i, l, natl given by pushout induction *)

(* -------------------------------------------------------------- *)

Context (X : pType).

(* Want to define the union over all (B -> X) where B are finite subtypes of A *)
(* Filter finite subtypes of A by cardinality *)

Definition functor_exp (A : Finite_Types) (B : Finite_Subsets A)  :
  (B -> X) -> (A -> X).
Proof.
  destruct B as [B [f emb]]. cbn.
  intro x. intro a.
  destruct (detachable_image_finite f a) as [[b p] | nhitA].
  - exact (x b).
  - exact (point X).
Defined.

Definition type_over_of_subset {A : Finite_Types} : (Finite_Subsets A) -> Type_Over (A -> X).
Proof.
  intro B.
  apply (Build_Type_Over (B -> X)). apply functor_exp.
Defined.

(* The intersection between a type over X^A and X^B *)
Definition intersect_with_power {A : Finite_Types} (B : Finite_Subsets A) (Y : Type_Over (A -> X)) : Type
  := { xy : (B -> X) * Y &
               forall b : B, (fst xy) b = arrow_of_over Y (snd xy) (B.2.1 b) }.

Definition intersection_to_left {A : Finite_Types} (n : nat) (Y : Type_Over (A -> X)) :
  {B : finite_subset_component A n & intersect_with_power B Y} -> {B : finite_subset_component A n & (B -> X)}.
Proof.
  intros [B [[x y] p]]. exists B. exact x.
Defined.

Definition intersection_to_right {A : Finite_Types} (n : nat) (Y : Type_Over (A -> X)) :
  {B : finite_subset_component A n & intersect_with_power B Y} -> Y.
Proof.
  intros [B [[x y] p]]. exact y.
Defined.

Definition glue_prod {A : Finite_Types} (n : nat) (Y : Type_Over (A -> X)) :=
  pushout (intersection_to_left n Y) (intersection_to_right n Y).

(* Think of Y as the base that we glue products X^B to. *)

Definition prod_in {A : Finite_Types} {n : nat} (Y : Type_Over (A -> X))
           {B : finite_subset_component A n} :
  (B -> X) -> glue_prod n Y.
Proof.
  intro x. apply (push o inl). exact (B; x).
Defined.

Definition base {A : Finite_Types} (n : nat) {Y : Type_Over (A -> X)}
  : Y -> glue_prod n Y
  := push o inr.

Definition gp {A : Finite_Types} {n : nat} {Y : Type_Over (A -> X)}
           {B : finite_subset_component A n}
           (x : B -> X) (y : Y)
           (eq_under_B : forall b : B, x b = arrow_of_over Y y (B.2.1 b))
  : prod_in Y x = base n y
  := (pp (B; ((x,y); eq_under_B))).

Definition glue_prod_ind {A : Finite_Types} {n : nat} (Y : Type_Over (A -> X))
           (P : glue_prod n Y -> Type)
           (prod_in' : forall (B : finite_subset_component A n) (x : B -> X),
               P (prod_in Y x))
           (base' : forall y : Y, P (base n y))
           (gp' : forall (B : finite_subset_component A n) (x : B -> X) (y : Y) (eq_under_B : forall b : B, x b = arrow_of_over Y y (B.2.1 b)),
               transport P (gp x y eq_under_B) (prod_in' B x) = base' y)
  : forall x : glue_prod n Y, P x.
Proof.
  unfold glue_prod. srapply @pushout_ind.
  - intros [[B x] | y].
    + apply prod_in'.
    + apply base'.
  - intros [B [[x y] eq_over_B]]. apply gp'.
Defined.

Definition glue_prod_ind_beta_gp {A : Finite_Types} (n : nat) (Y : Type_Over (A -> X))
           (P : glue_prod n Y -> Type)
           (prod_in' : forall (B : finite_subset_component A n) (x : B -> X),
               P (prod_in Y x))
           (base' : forall y : Y, P (base n y))
           (gp' : forall (B : finite_subset_component A n) (x : B -> X) (y : Y) (eq_under_B : forall b : B, x b = arrow_of_over Y y (B.2.1 b)),
               transport P (gp x y eq_under_B) (prod_in' B x) = base' y)
           {B : finite_subset_component A n}
           (x : B -> X) (y : Y)
           (eq_under_B : forall b : B, x b = arrow_of_over Y y (B.2.1 b)) :
  apD (glue_prod_ind Y P prod_in' base' gp') (gp x y eq_under_B) = gp' B x y eq_under_B.
Proof.
  srapply @pushout_ind_beta_pp.
Defined.

Definition glue_prod_rec {A : Finite_Types} {n : nat} (Y : Type_Over (A -> X))
           (P : Type)
           (prod_in' : forall (B : finite_subset_component A n),
               (B -> X) -> P)
           (base' : Y -> P)
           (gp' : forall (B : finite_subset_component A n) (x : B -> X) (y : Y) (eq_under_B : forall b : B, x b = arrow_of_over Y y (B.2.1 b)),
               prod_in' B x = base' y)
  : glue_prod n Y -> P.
Proof.
  srapply @pushout_rec.
  - intros [[B x] | y].
    + exact (prod_in' B x).
    + exact (base' y).
  - intros [B [[x y] eq_over_B]]. apply gp'. cbn. apply eq_over_B.
Defined.

Definition glue_prod_rec_beta_gp {A : Finite_Types} {n : nat} (Y : Type_Over (A -> X))
           (P : Type)
           (prod_in' : forall (B : finite_subset_component A n),
               (B -> X) -> P)
           (base' : Y -> P)
           (gp' : forall (B : finite_subset_component A n) (x : B -> X) (y : Y) (eq_under_B : forall b : B, x b = arrow_of_over Y y (B.2.1 b)),
               prod_in' B x = base' y)
           {B : finite_subset_component A n}
           (x : B -> X) (y : Y)
           (eq_under_B : forall b : B, x b = arrow_of_over Y y (B.2.1 b)) :
  ap (glue_prod_rec Y P prod_in' base' gp') (gp x y eq_under_B) = gp' B x y eq_under_B.
Proof.
  srapply @pushout_rec_beta_pp.
Defined.

Definition glue_prod_to_prod {A : Finite_Types} {n : nat} (Y : Type_Over (A -> X)) :
  glue_prod n Y -> (A -> X).
Proof.
  srapply @glue_prod_rec.
  - intro B.
    apply (functor_exp A B).
  - apply (arrow_of_over Y).
  - intros B x y eq_over_B.
    cbn.
    apply path_arrow. destruct B as [B [f emb]].
    intro a. unfold functor_exp. cbn.
    recall (detachable_image_finite f a) as d eqn:q. destruct d as [[b p] | not_inb].
    + rewrite q. destruct p. apply eq_over_B.
    + rewrite q. clear q.

    destruct  as [ | ]. cbn.
    + destruct p.
      refine (_ @ eq_over_B b).

      admit.
    +                           (* doesn't work *)
Abort.

Definition union_of_products {A : Finite_Types} (n : nat) : Type_Over (A -> X).
Proof.
  induction n.
  (* n is 0 *)
  - apply (Build_Type_Over Unit). intro t. exact (const (point X)).
  - apply (Build_Type_Over (glue_prod n.+1 IHn)).

Define gp, glue_prod_ind, glue_prod_ind_beta_gp


(** ** Variadic Preservation *)

Require Export ARS Program.Equality.
Require Import core fintype.
Import ScopedNotations.
From Chapter6 Require Export variadic_fin.
Set Implicit Arguments.
Unset Strict Implicit.

Ltac inv H := dependent destruction H.
Hint Constructors star.

(** *** Single-step reduction *)
Inductive step {n} : tm n -> tm n -> Prop :=
| step_beta p b (t: fin p -> tm n) : step (app _ (lam p b) t) (b[scons_p p t ids])
| step_abs  p b1 b2 : @step (p + n) b1 b2 -> step (lam p b1) (lam p b2)
| step_appL p s1 s2 t : step s1 s2 -> step (app p s1 t) (app _ s2 t).

Hint Constructors step.

Lemma step_beta' n p b (t: fin p -> tm n) t':
  t' = b[scons_p p t ids] -> step (app _ (lam p b) t) t'.
Proof. intros ->. now constructor. Qed.

(** *** Substitutivity *)

Lemma step_inst {m n} (f : fin m -> tm n) (s t : tm m) :
  step s t -> step (subst_tm f s) (subst_tm f t).
Proof.
  intros st. revert n f.  induction st; intros; cbn.
  - apply step_beta'. now asimpl.
  - apply step_abs. eapply IHst.
  - apply step_appL, IHst.
Qed.

Lemma mstep_inst m n (f : fin m -> tm n) (s t : tm m) :
  star step s t -> star step (s[f]) (t[f]).
Proof. induction 1; eauto using step_inst. Qed.

(** *** Variadic typing *)

Inductive ty  : Type :=
  | Base : ty
  | arr p : (fin p -> ty)  -> ty  -> ty .

Definition ctx n := fin n -> ty.

Inductive has_type {n} (Gamma : ctx n) : tm n -> ty -> Prop :=
| ty_var (x : fin n) :
    has_type Gamma (var_tm x) (Gamma x)
| ty_abs p (S1 : fin p -> ty) ( S2 : ty) (M : tm (p + n)) :
    @has_type (p + n) (scons_p p S1 Gamma) M S2 ->
    has_type Gamma (lam p M) (arr S1 S2)
| ty_app p (T : fin p -> ty) ( S : ty) (M  : tm n) N :
    has_type Gamma M (arr T S) ->
    (forall x, has_type Gamma (N x) (T x)) ->
    has_type Gamma (app p M N) S.
Notation "Gamma |- M : T" := (has_type Gamma M T) (at level 20, M at level 99).

Lemma ty_var' n  (x : fin n) A Gamma:
  A = Gamma x ->  has_type Gamma (var_tm x) A.
Proof. intros. subst. constructor. Qed.

Definition ltc {k k'} (Gamma: ctx k) (Delta: ctx k') rho := forall x, Delta (rho x) = Gamma x.

Lemma typing_ren n k (Gamma: ctx n) (Delta: ctx k) (rho: fin n -> fin k) (M: tm n) T :
  ltc Gamma Delta rho  -> Gamma |- M : T ->  Delta |- (M⟨rho⟩) : T.
Proof.
  intros C H. revert k Delta rho C. induction H; intros; asimpl; eauto using has_type.
  - unfold ltc in C. rewrite <- C. constructor.
  - constructor. apply IHhas_type. intros x.
    destruct (destruct_fin x) as [(?&->)|(?&->)]; eauto; asimpl; unfold upRen_p; asimpl. cbn. eauto.
    + now asimpl.
  - econstructor; eauto.
Qed.

Lemma typing_inst n k (Gamma: ctx n) (Delta: ctx k) (sigma: fin n -> tm k) (M: tm n) T :
  (forall x, Delta |- sigma x : Gamma x) -> Gamma |- M : T ->  Delta |- (M[sigma]) : T.
Proof.
Proof.
  intros C H. revert k Delta sigma C. induction H; intros; asimpl; eauto using has_type.
  - unfold ltc in C. apply C.
  - constructor. apply IHhas_type. intros x.
    destruct (destruct_fin x) as [(?&->)|(?&->)]; asimpl.
    + apply ty_var'. now asimpl.
    + eapply typing_ren; eauto. intros x. now asimpl.
 - econstructor; eauto.
Qed.

(** *** Preservation *)

Lemma step_typing k (Gamma: ctx k) M T :
  Gamma |- M : T -> forall M', step M M' -> Gamma |- M' : T.
Proof.
  induction 1; intros; cbn.
  - inv H.
  - inv H0. econstructor. now apply IHhas_type.
  - inv H2.
    + inv H. eapply typing_inst; try eassumption.
      intros x. destruct (destruct_fin x) as [(?&->)|(?&->)]; asimpl; eauto.
      * apply ty_var'; eauto.
    + eapply ty_app; eauto.
Qed.


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

Require Export Relation_Definitions.
Require Export Relation_Operators.
Require Export Operators_Properties.

Lemma inverse_image_of_equivalence :
  forall (A B:Type) (f:A -> B) (r:relation B),
    equivalence B r -> equivalence A (fun x y:A => r (f x) (f y)).
Proof.
  intros; split; elim H; red; auto.
  intros _ equiv_trans _ x y z H0 H1; apply equiv_trans with (f y); assumption.
Qed.

Lemma inverse_image_of_eq :
  forall (A B:Type) (f:A -> B), equivalence A (fun x y:A => f x = f y).
Proof.
  split; red;
    [  (* reflexivity *) reflexivity
      |  (* transitivity *) intros; transitivity (f y); assumption
      |  (* symmetry *) intros; symmetry ; assumption ].
Qed.


Require Export Iron.Language.Calc.Ty.
Require Export Iron.Language.Calc.Eval.

(* If some term m has type t,
   then when we evaluate it the result also has type t *)
Lemma soundness
  : forall m t
  , TYPE m t -> (exists v, EVAL m v /\ TYPE (MVal v) t).
Proof.
 intro m.
 induction m; intros.

 (* value *)
 - exists v;   auto.

 (* add *)
 - inversion H; subst.

   eapply IHm1 in H2; destruct H2 as [v1']; rip.
   assert (exists n1', v1' = VNat n1') as N1.
    apply canonical_value_nat; auto.
   destruct N1 as [n1']. subst.

   eapply IHm2 in H4; destruct H4 as [v2']; rip.
   assert (exists n2', v2' = VNat n2') as N2.
    apply canonical_value_nat; auto.
   destruct N2 as [n2']. subst.

   exists (VNat (n1' + n2')); rip.
   + eapply EvAdd; auto.
   + eapply TyNat.

 (* less *)
 - inversion H; subst.

   eapply IHm1 in H2; destruct H2 as [v1']; rip.
   assert (exists n1', v1' = VNat n1') as N1.
    apply canonical_value_nat; auto.
   destruct N1 as [n1']. subst.

   eapply IHm2 in H4; destruct H4 as [v2']; rip.
   assert (exists n2', v2' = VNat n2') as N2.
    apply canonical_value_nat; auto.
   destruct N2 as [n2']. subst.

   exists (VBool (blt_nat n1' n2')); rip.
   + eapply EvLess; auto.
   + eapply TyBool.

 (* and *)
 - inversion H; subst.

   eapply IHm1 in H2; destruct H2 as [v1']; rip.
   assert (exists b1', v1' = VBool b1') as B1.
    apply canonical_value_bool; auto.
   destruct B1 as [b1']. subst.

   eapply IHm2 in H4; destruct H4 as [v2']; rip.
   assert (exists b2', v2' = VBool b2') as B2.
    apply canonical_value_bool; auto.
   destruct B2 as [b2']. subst.

   exists (VBool (andb b1' b2')); rip.
   + eapply EvAnd; auto.
   + eapply TyBool.

 (* if *)
 - inversion H; subst.

   (* eval the scrutinee *)
   eapply IHm1 in H3. destruct H3 as [v1']; rip.
   assert (exists b1', v1' = VBool b1') as B1.
    apply canonical_value_bool; auto.
   destruct B1 as [b1']. subst.
   destruct b1'.

   (* scrutinee is true *)
   + eapply IHm2 in H5. destruct H5 as [v2']; rip.
     exists v2'; auto.

   (* scrutinee is false *)
   + eapply IHm3 in H6. destruct H6 as [v3']; rip.
     exists v3'; auto.
Qed.


(****************************************************************************)
(* Copyright 2020 The Project Oak Authors                                   *)
(*                                                                          *)
(* Licensed under the Apache License, Version 2.0 (the "License")           *)
(* you may not use this file except in compliance with the License.         *)
(* You may obtain a copy of the License at                                  *)
(*                                                                          *)
(*     http://www.apache.org/licenses/LICENSE-2.0                           *)
(*                                                                          *)
(* Unless required by applicable law or agreed to in writing, software      *)
(* distributed under the License is distributed on an "AS IS" BASIS,        *)
(* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *)
(* See the License for the specific language governing permissions and      *)
(* limitations under the License.                                           *)
(****************************************************************************)

Require Import Coq.Arith.PeanoNat.
Require Import Coq.Bool.Bvector.
Require Import Coq.Lists.List.
Require Import Coq.NArith.NArith.
Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Lia.
Require Import Coq.Vectors.Vector.
Require Import Cava.Util.BitArithmetic.
Require Import Cava.Util.Nat.
Require Import Cava.Util.List.
Require Import Cava.Util.Tactics.
Require Import Cava.Util.Vector.
Import ListNotations.
Local Open Scope N_scope.

(* Destructs into cases for all possible values of a constant-length bit
   vector *)
Ltac constant_bitvec_cases vec :=
  lazymatch type of vec with
  | Vector.t bool (S ?n) =>
      let v' := fresh "v" in
      rewrite (Vector.eta vec); set (v' := Vector.tl vec);
      cbv beta in v'; constant_bitvec_cases v';
      destruct (Vector.hd vec)
  | Vector.t bool 0 => eapply Vector.case0 with (v := vec)
  end.

Lemma to_list_bits_sized_size : forall (size :  nat) (v : N), size = N.size_nat v ->
      N.to_list_bits_sized size v = N.to_list_bits v.
Proof.
  intros.
  induction v.
  - unfold N.to_list_bits. unfold N.to_list_bits_sized.
    cbn [N2Bv_sized].
    rewrite H.  simpl. reflexivity.
  - rewrite H.
    unfold N.to_list_bits_sized.
    rewrite N2Bv_sized_Nsize.
    unfold N.to_list_bits.
    reflexivity.
Qed.

(******************************************************************************)
(* Prove that an unsigned bit-vector b::bs represents the same number         *)
(* as b + 2 * bs i.e. the low bit represented as a number plus 2 times the    *)
(* the rest of the bit-vector.                                                *)
(******************************************************************************)

Lemma N_of_list_bits_cons b bs :
  N.of_list_bits (b :: bs) = N.b2n b + 2 * N.of_list_bits bs.
Proof.
  (* Unfold the definition of list_bits_to_nat to get an expression
     in terms of BvN. *)
  unfold N.of_list_bits.
  (* We now have:
       Bv2N (of_list (b :: bs)) = N.b2n b + 2 * Bv2N (of_list bs)
     Bv2N (of_list (b :: bs)) converts the list b::bs to a Bvector (Vector bool)
     which is converted by Bv2N to the natural type N. Unfold one application
     of the of_list function which converts a list to a vector. *)
  cbn [of_list Bv2N].
  (* We now have:
       (if b
         then N.succ_double (Bv2N (of_list bs))
         else N.double (Bv2N (of_list bs))) = N.b2n b + 2 * Bv2N (of_list bs)
     Let's take apart the if statement by destructing on its conditional
     value b. In each branch let's also unfold the N.b2n function that converts
     a bool value to a value of the natural type N. *)
  destruct b; unfold N.b2n.
  (* We now have:
     1/2
     N.succ_double (Bv2N (of_list bs)) = 1 + 2 * Bv2N (of_list bs)
     2/2
    N.double (Bv2N (of_list bs)) = 0 + 2 * Bv2N (of_list bs) *)
  - (* 1/2: Let's use the following lemma:
       Lemma succ_double_spec n : succ_double n = 2 * n + 1.
       This says that succ_dobule of n is the same as doubling n and adding 1.
       This gives:
         2 * Bv2N (of_list bs) + 1 = 1 + 2 * Bv2N (of_list bs)
       which can be proved bu the lia hammer. *)
    rewrite N.succ_double_spec. lia.
  - (* 2/2: Let's use the lemma:
       Lemma double_spec n : double n = 2 * n.
       This says the double n is the same as 2 * b.
       This gives:
         2 * Bv2N (of_list bs) = 0 + 2 * Bv2N (of_list bs)
       which can be solved by the lia hammer. *)
    rewrite N.double_spec. lia.
Qed.

Lemma N_of_list_bits_zero n : N.of_list_bits (repeat false n) = 0%N.
Proof.
  induction n; [ reflexivity | ].
  cbn [repeat]; rewrite N_of_list_bits_cons, IHn.
  cbn [N.b2n]. lia.
Qed.

Lemma N_of_list_bits_nil : N.of_list_bits [] = 0%N.
Proof. reflexivity. Qed.

Lemma N_of_list_bits_app l1 l2 :
  N.of_list_bits (l1 ++ l2)
  = (N.of_list_bits l1 + 2 ^ (N.of_nat (length l1)) * N.of_list_bits l2)%N.
Proof.
  revert l2; induction l1; intros; cbn [app length].
  { destruct l2; [ reflexivity | ].
    change (2 ^ (N.of_nat 0))%N with 1%N.
    rewrite !N_of_list_bits_cons, !N_of_list_bits_nil.
    lia. }
  { rewrite !N_of_list_bits_cons, IHl1.
    rewrite Nat2N.inj_succ, N.pow_succ_r by lia.
    lia. }
Qed.

Local Close Scope N_scope.

Lemma bits_of_nat_sized: forall n bv, nat_to_bitvec_sized n (bitvec_to_nat bv) = bv.
Proof.
  intros.
  unfold nat_to_bitvec_sized.
  unfold bitvec_to_nat.
  rewrite N2Nat.id.
  rewrite N2Bv_sized_Bv2N.
  reflexivity.
Qed.

Lemma nat_of_bits: forall v, bitvec_to_nat (nat_to_bitvec v) = v.
Proof.
  intros.
  unfold nat_to_bitvec.
  unfold bitvec_to_nat.
  rewrite Bv2N_N2Bv.
  rewrite Nat2N.id.
  reflexivity.
Qed.

Lemma nat_of_bits_sized: forall (v : nat),
      bitvec_to_nat (nat_to_bitvec_sized (N.size_nat (N.of_nat v)) v) = v.
Proof.
  intros.
  unfold nat_to_bitvec_sized.
  unfold bitvec_to_nat.
  rewrite N2Bv_sized_Nsize.
  rewrite Bv2N_N2Bv.
  rewrite Nat2N.id.
  reflexivity.
Qed.

Lemma Pos_size_nat_nonzero (p : positive) : 0 < Pos.size_nat p.
Proof. destruct p; cbn; lia. Qed.

Lemma N_size_nat_le0 (x : N) : N.size_nat x = 0 -> x = 0%N.
Proof.
  destruct x as [|p]; [ reflexivity | ].
  pose proof (Pos_size_nat_nonzero p).
  cbn [N.size_nat]. lia.
Qed.

Lemma P2Bv_nonzero (n : nat) (p : positive) :
  (Pos.size_nat p <= n) ->
  P2Bv_sized n p <> Bvector.Bvect_false n.
Proof.
  pose proof (Pos_size_nat_nonzero p).
  revert dependent p; induction n; destruct p; intros;
    cbn in *; try congruence; try lia; [ ].
  let Heq := fresh in
  intro Heq; apply cons_inj in Heq; destruct Heq.
  eapply IHn; eauto using Pos_size_nat_nonzero; [ ].
  lia.
Qed.

Lemma P2Bv_sized_eq_iff (n : nat) (x y : positive) :
  (Pos.size_nat x <= n) ->
  (Pos.size_nat y <= n) ->
  (P2Bv_sized n x = P2Bv_sized n y) <-> x = y.
Proof.
  revert x y; induction n; intros.
  { pose proof (Pos_size_nat_nonzero x).
    pose proof (Pos_size_nat_nonzero y).
    split; [ intros; lia | reflexivity]. }
  { split; try congruence; [ ].
    cbn [P2Bv_sized].
    destruct x, y; try congruence; [ | | | ].
    all:cbn [Pos.size_nat] in *.
    all:let H := fresh in
        intro H; apply cons_inj in H; destruct H.
    all:lazymatch goal with
        | H : P2Bv_sized _ _ = P2Bv_sized _ _ |- _ =>
          rewrite IHn in H by lia; subst
        | H : P2Bv_sized _ _ = Bvector.Bvect_false _ |- _ =>
          apply P2Bv_nonzero in H; [ | lia ]
        | H : Bvector.Bvect_false _ = P2Bv_sized _ _ |- _ =>
          symmetry in H; apply P2Bv_nonzero in H; [ | lia ]
        end.
    all:tauto. }
Qed.

Lemma N2Bv_sized_eq_iff (n : nat) (x y : N) :
  (N.size_nat x <= n) ->
  (N.size_nat y <= n) ->
  (N2Bv_sized n x = N2Bv_sized n y) <-> x = y.
Proof.
  destruct x, y; cbn [N.size_nat N2Bv_sized]; intros; split; intros.
  all:try lazymatch goal with
          | H : P2Bv_sized _ _ = P2Bv_sized _ _ |- _ =>
            rewrite P2Bv_sized_eq_iff in H by lia; subst
          | H : P2Bv_sized _ _ = Bvector.Bvect_false _ |- _ =>
            apply P2Bv_nonzero in H; [ | lia ]
          | H : Bvector.Bvect_false _ = P2Bv_sized _ _ |- _ =>
            symmetry in H; apply P2Bv_nonzero in H; [ | lia ]
          end.
  all:(tauto || congruence).
Qed.

Lemma Bv2N_append {n m} (v1 : Bvector.Bvector n) (v2 : Bvector.Bvector m) :
  Bv2N (v1 ++ v2)%vector = (Bv2N v1 + N.shiftl (Bv2N v2) (N.of_nat n))%N.
Proof.
  revert v1 v2; induction n.
  { intros v1 ?; eapply case0 with (v:=v1).
    simpl. rewrite N.shiftl_0_r. reflexivity. }
  { intros v1 ?. rewrite (eta v1).
    rewrite <-append_comm_cons. cbn [Bv2N].
    rewrite IHn. rewrite !N.succ_double_add, !N.double_add.
    rewrite Nat2N.inj_succ, N.shiftl_succ_r.
    rewrite !N.succ_double_spec, !N.double_spec.
    repeat lazymatch goal with
           | |- context [N.double ?n] => rewrite (N.double_spec n)
           end.
    destruct (Vector.hd v1); lia. }
Qed.

Lemma Bv2N_Bvect_false n : Bv2N (Bvector.Bvect_false n) = 0%N.
Proof.
  induction n; [ reflexivity | ]. simpl. rewrite IHn. reflexivity.
Qed.

Lemma Bv2N_N2Bv_sized sz n :
  (n < 2 ^ N.of_nat sz)%N -> Bv2N (N2Bv_sized sz n) = n.
Proof.
  intros. pose proof (N.size_nat_le _ _ ltac:(eauto)).
  replace sz with (N.size_nat n + (sz - N.size_nat n)) by lia.
  rewrite N2Bv_N2Bv_sized_above. rewrite Bv2N_append, Bv2N_Bvect_false.
  rewrite N.shiftl_0_l, N.add_0_r. apply Bv2N_N2Bv.
Qed.

Lemma nat_to_bitvec_to_nat sz n :
  n < 2 ^ sz ->
  N.to_nat (Bv2N (nat_to_bitvec_sized sz n)) = n.
Proof.
  intros. cbv [nat_to_bitvec_sized].
  rewrite Bv2N_N2Bv_sized; [ solve [apply Nat2N.id] | ].
  change 2%N with (N.of_nat 2). rewrite Nat2N.inj_pow.
  lia.
Qed.

Lemma N2Bv_sized_succ_double sz n :
  N2Bv_sized (S sz) (N.succ_double n) = (true :: N2Bv_sized sz n)%vector.
Proof. destruct n; reflexivity. Qed.

Lemma N2Bv_sized_double sz n :
  N2Bv_sized (S sz) (N.double n) = (false :: N2Bv_sized sz n)%vector.
Proof. destruct n; reflexivity. Qed.

Lemma Bv2N_cons {n : nat} (b : bool) (v : Bvector.Bvector n) :
  Bv2N (b :: v)%vector = (if b then N.succ_double (Bv2N v) else N.double (Bv2N v))%N.
Proof. reflexivity. Qed.

Lemma Bv2N_snoc {n : nat} (b : bool) (v : Bvector.Bvector n) :
  Bv2N (v ++ [b])%vector = ((if b then 2 ^ N.of_nat n else 0) + Bv2N v)%N.
Proof.
  induction n; [ apply case0 with (v:=v); cbn; lia | ].
  rewrite (eta v). rewrite <-append_comm_cons.
  cbn [Nat.add]. rewrite !Bv2N_cons, IHn.
  rewrite !N.succ_double_spec.
  repeat lazymatch goal with
         | |- context [N.double ?x] => change (N.double x) with (2 * x)%N
         end.
  rewrite !Nat2N.inj_succ, N.pow_succ_r'.
  destruct b, (Vector.hd v); lia.
Qed.

Lemma Bv2N_inj {n} (x y : Bvector.Bvector n) : Bv2N x = Bv2N y -> x = y.
Proof.
  cbv [Bvector.Bvector] in *.
  revert x y; induction n; intros x y ?; [ apply nil_eq | ].
  rewrite (eta x), (eta y) in *. cbn [Bv2N] in *.
  destruct (Vector.hd x), (Vector.hd y);
    repeat lazymatch goal with
           | H : N.succ_double _ = N.succ_double _  |- _ =>
             apply N.succ_double_inj in H
           | H : N.double _ = N.double _  |- _ =>
             apply N.double_inj in H
           | H : N.succ_double _ = N.double _  |- _ =>
             apply N.succ_double_double_neq in H; tauto
           | H : N.double _ = N.succ_double _ |- _ => symmetry in H
           end; [ | ].
  all:rewrite (IHn (Vector.tl x) (Vector.tl y)) by auto.
  all:reflexivity.
Qed.

Hint Rewrite @Bv2N_N2Bv @Bv2N_cons @Bv2N_Bvect_false @Bv2N_append @Bv2N_snoc
     using solve [eauto] : push_Bv2N.
Hint Rewrite @Bv2N_N2Bv_sized using lia : push_Bv2N.

Hint Rewrite @N2Bv_sized_double @N2Bv_sized_succ_double @N2Bv_sized_Nsize
     using solve [eauto] : push_N2Bv_sized.

Lemma Bv2N_N2Bv_sized_testbit sz n i :
  N.testbit (Bv2N (N2Bv_sized sz n)) i = if (i <? N.of_nat sz)%N
                                         then N.testbit n i else false.
Proof.
  revert i sz; induction n using N.binary_ind; intros;
    (destruct sz; [ |  pose proof (N.pow_gt_1 2 (N.of_nat (S sz)) ltac:(lia) ltac:(lia)) ]);
    repeat match goal with
           | |- context [N2Bv_sized 0 ?n] => eapply case0 with (v:=N2Bv_sized 0 n)
           | |- context [N.ltb ?a ?b] => case_eq (N.ltb a b);
                                         [ rewrite N.ltb_lt | rewrite N.ltb_ge ];
                                         intros
           | |- context [N.eqb ?a ?b] => case_eq (N.eqb a b);
                                         [ rewrite N.eqb_eq | rewrite N.eqb_neq ];
                                         intros
           | _ => first [ rewrite IHn
                       | progress autorewrite with push_Bv2N push_N2Bv_sized push_Ntestbit
                       | reflexivity
                       | lia ]
           end.
Qed.
Hint Rewrite Bv2N_N2Bv_sized_testbit using solve [eauto] : push_Ntestbit.

Lemma Bv2N_N2Bv_sized_modulo sz n :
  Bv2N (N2Bv_sized sz n) = (n mod 2 ^ (N.of_nat sz))%N.
Proof.
  apply N.bits_inj; intro. autorewrite with push_Ntestbit. reflexivity.
Qed.

Lemma N2Bv_sized_ones_step sz :
  N2Bv_sized (S sz) (N.ones (N.of_nat (S sz)))
  = (true :: N2Bv_sized sz (N.ones (N.of_nat sz)))%vector.
Proof.
  rewrite N.ones_succ. autorewrite with push_N2Bv_sized.
  reflexivity.
Qed.
Hint Rewrite N2Bv_sized_ones_step using solve [eauto] : push_N2Bv_sized.

Lemma byte_to_bitvec_to_byte b :
  bitvec_to_byte (byte_to_bitvec b) = b.
Proof. destruct b; reflexivity. Qed.

Lemma bitvec_to_byte_to_bitvec v :
  byte_to_bitvec (bitvec_to_byte v) = v.
Proof.
  cbv [bitvec_to_byte byte_to_bitvec].
  constant_vector_simpl v.
  autorewrite with vsimpl.
  match goal with
  | |- context [Byte.of_bits (?b0, (?b1, (?b2, (?b3, (?b4, (?b5, (?b6, ?b7)))))))] =>
    destruct b0, b1, b2, b3, b4, b5, b6, b7; reflexivity
  end.
Qed.

Lemma bytevec_to_bitvec_to_bytevec n v :
  bitvec_to_bytevec n (bytevec_to_bitvec n v) = v.
Proof.
  cbv [bitvec_to_bytevec bytevec_to_bitvec].
  autorewrite with vsimpl. rewrite map_map.
  apply map_id_ext; intros.
  apply byte_to_bitvec_to_byte.
Qed.

Lemma bitvec_to_bytevec_to_bitvec n v :
  bytevec_to_bitvec n (bitvec_to_bytevec n v) = v.
Proof.
  cbv [bitvec_to_bytevec bytevec_to_bitvec].
  rewrite map_map, map_id_ext by (intros; apply bitvec_to_byte_to_bitvec).
  autorewrite with vsimpl; reflexivity.
Qed.

Lemma P2Bv_sized_cons n p :
  P2Bv_sized (S n) p = (match p with
                        | (p0~1)%positive => true :: P2Bv_sized n p0
                        | (p0~0)%positive => false :: P2Bv_sized n p0
                        | 1%positive => true :: Bvector.Bvect_false n
                        end)%vector.
Proof. reflexivity. Qed.

Lemma P2Bv_sized_shiftout n p :
  Vector.shiftout (P2Bv_sized (S n) p) = P2Bv_sized n p.
Proof.
  revert p; induction n; [ destruct p; reflexivity | ].
  intros. destruct p.
  all:rewrite P2Bv_sized_cons with (n:=S n).
  all:cbv [Bvector.Bvect_false].
  all:rewrite !shiftout_cons, ?shiftout_const.
  all:rewrite ?IHn.
  all:reflexivity.
Qed.

Lemma N2Bv_sized_shiftout n x :
  Vector.shiftout (N2Bv_sized (S n) x) = N2Bv_sized n x.
Proof.
  destruct x; [ apply shiftout_const | ].
  apply P2Bv_sized_shiftout.
Qed.

Lemma shiftout_N2Bv_sized_Bv2N n (v : Vector.t bool (S n)) :
  shiftout v = N2Bv_sized n (Bv2N v).
Proof.
  induction n; [ apply nil_eq | ].
  rewrite (eta v). cbn [shiftout rectS].
  rewrite IHn. autorewrite with push_Bv2N.
  destruct (Vector.hd v);
    autorewrite with push_N2Bv_sized;
    reflexivity.
Qed.

Lemma shiftout_cons0 n (input : Vector.t bool n) :
  shiftout (false :: input) = N2Bv_sized n (2 * Bv2N input).
Proof.
  rewrite shiftout_N2Bv_sized_Bv2N, Bv2N_cons. reflexivity.
Qed.

Lemma P2Bv_sized_last n p :
  Vector.last (P2Bv_sized (S n) p) = Pos.testbit_nat p n.
Proof.
  revert p; induction n; [ destruct p; reflexivity | ].
  intros. rewrite P2Bv_sized_cons with (n:=S n).
  destruct p.
  all:cbv [Bvector.Bvect_false].
  all:rewrite !last_cons, ?last_const.
  all:rewrite ?IHn.
  all:reflexivity.
Qed.

Lemma N2Bv_sized_last n x :
  Vector.last (N2Bv_sized (S n) x) = N.testbit_nat x n.
Proof.
  destruct x; [ apply last_const | ].
  apply P2Bv_sized_last.
Qed.

Hint Rewrite @N2Bv_sized_Bv2N using solve [eauto] : push_N2Bv_sized.
Hint Rewrite @N2Bv_sized_Bv2N using solve [eauto] : pull_N2Bv_sized.

Ltac bitvec_to_N :=
  apply Bv2N_inj; rewrite ?Bv2N_N2Bv_sized_modulo.

Lemma N2Bv_sized_add_idemp_r sz x y :
  N2Bv_sized sz (x + Bv2N (N2Bv_sized sz y)) = N2Bv_sized sz (x + y).
Proof.
  bitvec_to_N.
  rewrite N.add_mod_idemp_r by (apply N.pow_nonzero; lia).
  reflexivity.
Qed.
Hint Rewrite @N2Bv_sized_add_idemp_r using solve [eauto] : pull_N2Bv_sized.

Lemma N2Bv_sized_add_idemp_l sz x y :
  N2Bv_sized sz (Bv2N (N2Bv_sized sz x) + y) = N2Bv_sized sz (x + y).
Proof.
  bitvec_to_N.
  rewrite N.add_mod_idemp_l by (apply N.pow_nonzero; lia).
  reflexivity.
Qed.
Hint Rewrite @N2Bv_sized_add_idemp_l using solve [eauto] : pull_N2Bv_sized.

Lemma N2Bv_sized_mul_idemp_l sz x y :
  N2Bv_sized sz (Bv2N (N2Bv_sized sz x) * y) = N2Bv_sized sz (x * y).
Proof.
  bitvec_to_N. rewrite N.mul_mod_idemp_l by (apply N.pow_nonzero; lia).
  reflexivity.
Qed.
Hint Rewrite @N2Bv_sized_mul_idemp_l using solve [eauto] : pull_N2Bv_sized.

Lemma N2Bv_sized_mul_idemp_r sz x y :
  N2Bv_sized sz (x * Bv2N (N2Bv_sized sz y)) = N2Bv_sized sz (x * y).
Proof.
  bitvec_to_N. rewrite N.mul_mod_idemp_r by (apply N.pow_nonzero; lia).
  reflexivity.
Qed.
Hint Rewrite @N2Bv_sized_mul_idemp_r using solve [eauto] : pull_N2Bv_sized.

Lemma N2Bv_sized_pow_idemp_l sz x y :
  N2Bv_sized sz (Bv2N (N2Bv_sized sz x) ^ y) = N2Bv_sized sz (x ^ y).
Proof.
  revert x; induction y using N.peano_ind; intros;
    [ rewrite !N.pow_0_r; reflexivity | ].
  rewrite !N.pow_succ_r by lia.
  rewrite <-N2Bv_sized_mul_idemp_r, IHy.
  rewrite N2Bv_sized_mul_idemp_l, N2Bv_sized_mul_idemp_r.
  reflexivity.
Qed.
Hint Rewrite @N2Bv_sized_pow_idemp_l using solve [eauto] : pull_N2Bv_sized.

Theorem Bv_span {n} (a : Vector.t bool n) :
  InV a (Vector.map (fun k => N2Bv_sized n (N.of_nat k)) (vseq 0 (2 ^ n))).
Proof.
  apply InV_map_iff.
  induction a; [ | ].
  { apply ex_intro with (x:=0).
    split; [trivial | ].
    left. trivial. }
  { inversion IHa as [ x H ].
    destruct h; [ | ].
    { apply ex_intro with (x:=S(2*x)).
      split; destruct H as [H0]; [ | ].
      { rewrite Nat2N.inj_succ_double.
        rewrite N2Bv_sized_succ_double.
        rewrite H0.  trivial. }
      { apply InV_seq. apply InV_seq in H.
        cbn in H. cbn. lia. }
    }
    { apply ex_intro with (x:=2*x).
      split; destruct H ; [ | ].
      { rewrite Nat2N.inj_double.
        rewrite N2Bv_sized_double.
        rewrite H. trivial. }
      { apply InV_seq. apply InV_seq in H0.
        cbn. lia. }
    }
  }
Qed.

Theorem Bv_orthonormal {n} i j :
  (i < 2^ (N.of_nat n))%N ->
  (j < 2^ (N.of_nat n))%N ->
  (N2Bv_sized n i) = (N2Bv_sized n j)
  <-> i = j.
Proof.
  split; [ | ].
  { intros vec_eq.
    apply f_equal with (f:=Bv2N) in vec_eq.
    rewrite Bv2N_N2Bv_sized in vec_eq; [ | assumption ].
    rewrite Bv2N_N2Bv_sized in vec_eq; [ assumption | assumption ].
  }
  { intros. apply f_equal. assumption. }
Qed.


Lemma not_iff : forall p q, p <-> q -> ~ p <-> ~ q.
Proof.
  intros.
  destruct H.
  split.
  - intro. intro. apply H0 in H2. contradiction.
  - intro. intro. apply H in H2. contradiction.
  Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable triangle_ : Universe -> Universe -> Universe -> Prop.
Variable onCirc_ : Universe -> Universe -> Prop.
Variable inCirc_ : Universe -> Universe -> Prop.
Variable equilateral_ : Universe -> Universe -> Universe -> Prop.
Variable cong_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.
Variable cI_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable proposition_01_1 : (forall A B : Universe, (exists X : Universe, (A <> B -> (equilateral_ A B X /\ triangle_ A B X)))).
Variable defequilateral_2 : (forall A B C : Universe, (equilateral_ A B C -> (cong_ A B B C /\ cong_ B C C A))).
Variable defequilateral2_3 : (forall A B C : Universe, ((cong_ A B B C /\ cong_ B C C A) -> equilateral_ A B C)).
Variable lemma_congruencesymmetric_4 : (forall A B C D : Universe, (cong_ B C A D -> cong_ A D B C)).
Variable lemma_congruenceflip_5 : (forall A B C D : Universe, (cong_ A B C D -> (cong_ B A D C /\ (cong_ B A C D /\ cong_ A B D C)))).
Variable deftriangle_6 : (forall A B C : Universe, (triangle_ A B C -> ~(col_ A B C))).
Variable deftriangle2_7 : (forall A B C : Universe, (~(col_ A B C) -> triangle_ A B C)).
Variable postulate_Euclid3_8 : (forall A B : Universe, (exists X : Universe, (A <> B -> cI_ X A A B))).
Variable definside_9 : (forall P J : Universe, (exists X Y U V W : Universe, (inCirc_ P J -> ((cI_ J U V W /\ P = U) \/ (cI_ J U V W /\ (betS_ U Y X /\ (cong_ U X V W /\ cong_ U P U Y))))))).
Variable definside2a_10 : (forall P J X Y U V W : Universe, ((cI_ J U V W /\ P = U) -> inCirc_ P J)).
Variable definside2b_11 : (forall P J X Y U V W : Universe, ((cI_ J U V W /\ (betS_ U Y X /\ (cong_ U X V W /\ cong_ U P U Y))) -> inCirc_ P J)).
Variable lemma_NCdistinct_12 : (forall A B C : Universe, (~(col_ A B C) -> (A <> B /\ (B <> C /\ (A <> C /\ (B <> A /\ (C <> B /\ C <> A))))))).
Variable postulate_line_circle_13 : (forall A B C K P Q : Universe, (exists X Y : Universe, ((cI_ K C P Q /\ (inCirc_ B K /\ A <> B)) -> (col_ A B X /\ (betS_ A B Y /\ (onCirc_ X K /\ (onCirc_ Y K /\ betS_ X B Y))))))).
Variable lemma_betweennotequal_14 : (forall A B C : Universe, (betS_ A B C -> (B <> C /\ (A <> B /\ A <> C)))).
Variable axiom_circle_center_radius_15 : (forall A B C J P : Universe, ((cI_ J A B C /\ onCirc_ P J) -> cong_ A P B C)).
Variable cn_congruencereflexive_16 : (forall A B : Universe, cong_ A B A B).
Variable lemma_differenceofparts_17 : (forall A B C Xa Xb Xc : Universe, ((cong_ A B Xa Xb /\ (cong_ A C Xa Xc /\ (betS_ A B C /\ betS_ Xa Xb Xc))) -> cong_ B C Xb Xc)).
Variable cn_congruencetransitive_18 : (forall B C D E P Q : Universe, ((cong_ P Q B C /\ cong_ P Q D E) -> cong_ B C D E)).

Theorem proposition_02_19 : (forall A B C : Universe, (exists X : Universe, ((A <> B /\ B <> C) -> cong_ A X B C))).
Proof.
  time tac.
Qed.

End FOFProblem.


(* Copyright 2021 Joshua M. Cohen

Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License.
You may obtain a copy of the License at
    http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License.
*)

From mathcomp Require Import all_ssreflect.
Require Import mathcomp.algebra.ssralg.
Require Import mathcomp.algebra.poly.
Require Import mathcomp.algebra.polydiv.
Require Import mathcomp.algebra.finalg.
Require Import mathcomp.ssreflect.tuple.
Require Import mathcomp.field.finfield.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Set Bullet Behavior "Strict Subproofs".

(* Construction of finite fields via irreducible polynomials *)

Section FieldConstr.

Local Open Scope ring_scope.

(*Some needed results about the Poly constructor - not general-purpose*)
Section MorePoly.

Variable R: ringType.

Lemma Poly_nil (s: seq R):
  (all (eq_op^~0) s) = (polyseq (Poly s) == nil).
Proof.
elim: s => [/=| h t /= IHs].
  by rewrite polyseq0.
rewrite polyseq_cons.
have->: nilp (Poly t) = (polyseq (Poly t) == [::])
  by apply /nilP; case : (polyseq (Poly t) == [::]) /eqP.
rewrite -IHs.
case Allt: (all (eq_op^~ 0) t) =>/=; last by rewrite andbF.
case: (h == 0) /eqP => [ eq_h0 | /eqP neq_h0].
  by rewrite eq_h0 polyseqC eq_refl.
by rewrite polyseqC/= neq_h0.
Qed.

Lemma Poly_split (s: seq R):
  ~~(all (eq_op^~ 0) s) ->
  exists s1, (s == Poly s ++ s1) && (all (eq_op^~ 0) s1).
Proof.
elim: s => [//| h t/= IHs].
case Allt: (all (eq_op^~ 0) t) =>/=.
  move=> /nandP[eq_h0 | //]; exists t.
  rewrite polyseq_cons polyseqC eq_h0.
  move: Allt; rewrite Poly_nil => /eqP->/=.
  by rewrite eq_refl.
move=> _. rewrite polyseq_cons.
have->/=: nilp (Poly t) = false
  by apply /nilP /eqP; rewrite -Poly_nil Allt.
apply negbT, IHs in Allt.
case: Allt => [s1 /andP[/eqP t_eq all_s1]].
exists s1.
by rewrite {1}t_eq all_s1 eq_refl.
Qed.

Lemma Poly_cat (s1 s2 : seq R):
  all (eq_op^~0) s2 ->
  Poly (s1 ++ s2) = Poly s1.
Proof.
elim: s1 => [/= all_s2| h t /= IHs all_s2].
  by apply poly_inj; rewrite polyseq0; apply /eqP; rewrite -Poly_nil.
by move: IHs => /(_ all_s2) ->.
Qed.

End MorePoly.

(* We require that the type is finite so that the resulting field is finite. *)
(* We need an integral domain for [irreducible_poly].                        *)
(* Every finite integral domain is a (finite) field.                         *)
Variable F : finFieldType.

Variable p : {poly F}.
Variable p_irred: irreducible_poly p.

(*A polynomial quotiented by p*)
Inductive qpoly : predArgType := Qpoly (qp : {poly F}) of (size qp < size p).

Coercion qp (q: qpoly) : {poly F} := let: Qpoly x _ := q in x.
Definition qsz (q: qpoly) : size q < size p := let: Qpoly _ x := q in x.

Canonical qpoly_subType := [subType for qp].
Definition qpoly_eqMixin := Eval hnf in [eqMixin of qpoly by <:].
Canonical qpoly_eqType := Eval hnf in EqType qpoly qpoly_eqMixin.

Definition qpoly_choiceMixin := [choiceMixin of qpoly by <:].
Canonical qpoly_choiceType := Eval hnf in ChoiceType qpoly qpoly_choiceMixin.

Definition qpoly_countMixin := [countMixin of qpoly by <:].
Canonical qpoly_countType := Eval hnf in CountType qpoly qpoly_countMixin.
Canonical qpoly_subCountType := [subCountType of qpoly].

Lemma qpoly_inj: injective qp. Proof. exact: val_inj. Qed.

(* Size of the Finite Field *)

(* We prove the cardinality of this set by giving a mapping from qpolys to    *)
(* tuples of length (size).-1                                                 *)

Definition qpoly_seq (q: qpoly) : seq F :=
  q ++ nseq ((size p).-1 - size q) 0.

Lemma p_gt_0: 0 < size p.
Proof.
have lt_01 : 0 < 1 by [].
apply (ltn_trans lt_01).
by apply p_irred.
Qed.

Lemma leq_predR m n :
  0 < n ->
  (m <= n.-1) = (m < n).
Proof. by case : n => [//|n/= _]; rewrite ltnS. Qed.

Lemma qpoly_seq_size q: size (qpoly_seq q) == (size p).-1.
Proof.
apply /eqP; rewrite /qpoly_seq size_cat size_nseq subnKC //.
case : q => [x Szx /=].
by rewrite leq_predR // p_gt_0.
Qed.

Definition qpoly_tuple q : ((size p).-1).-tuple F := Tuple (qpoly_seq_size q).

Definition tuple_poly (t: ((size p).-1).-tuple F) : {poly F} := Poly t.

Lemma tuple_poly_size t:
  size (tuple_poly t) < size p.
Proof.
have szt: size t = ((size p).-1) by apply size_tuple.
have lt_tp: size t < size p by rewrite szt ltn_predL p_gt_0.
by apply (leq_ltn_trans (size_Poly t)).
Qed.

Definition tuple_qpoly (t: ((size p).-1).-tuple F) : qpoly :=
  Qpoly (tuple_poly_size t).

Lemma tuple_qpoly_cancel: cancel tuple_qpoly qpoly_tuple.
Proof.
move=> [t sz_t]; rewrite /qpoly_tuple /tuple_qpoly/=.
apply val_inj=>/=.
rewrite /tuple_poly/qpoly_seq/=.
move: sz_t => /eqP sz_t.
case Allt: (all (eq_op^~0) t).
  have nseqt:=Allt; move: Allt.
  rewrite Poly_nil => /eqP->/=.
  symmetry; rewrite subn0 -sz_t; apply /all_pred1P.
  exact: nseqt.
apply negbT, Poly_split in Allt.
case : Allt => [tl /andP[/eqP t_eq tl_all]].
rewrite {3}t_eq; f_equal.
have <-: size tl = ((size p).-1 - size (Poly t))%N
  by rewrite -sz_t {1}t_eq size_cat -addnBAC // subnn.
by symmetry; apply /all_pred1P.
Qed.

Lemma qpoly_tuple_cancel: cancel qpoly_tuple tuple_qpoly.
Proof.
move=> [q q_sz]; rewrite /qpoly_tuple /tuple_qpoly/=.
apply val_inj=>/=.
rewrite /tuple_poly /qpoly_seq /=.
rewrite Poly_cat //; first by apply polyseqK.
by apply /all_pred1P; rewrite size_nseq.
Qed.

Lemma qpoly_tuple_bij: bijective qpoly_tuple.
Proof.
  apply (Bijective qpoly_tuple_cancel tuple_qpoly_cancel).
Qed.

Definition qpoly_finMixin := CanFinMixin qpoly_tuple_cancel.
Canonical qpoly_finType := Eval hnf in FinType qpoly qpoly_finMixin.

Lemma qpoly_size: #|qpoly| = (#|F|^((size p).-1))%N.
Proof.
by rewrite (bij_eq_card qpoly_tuple_bij) card_tuple.
Qed.

(* Algebraic Structures*)

(* Z Module *)

Lemma q0_size: size (0 : {poly F}) < size p.
Proof.
by rewrite size_poly0 p_gt_0.
Qed.

Lemma q1_size : size (1 : {poly F}) < size p.
Proof.
by rewrite size_poly1 p_irred.
Qed.

Definition q0 : qpoly := Qpoly q0_size.
Definition q1 : qpoly := Qpoly q1_size.

Lemma qadd_size (q1 q2: qpoly) : size (val q1 + val q2) < size p.
Proof.
apply (leq_ltn_trans (size_add q1 q2)).
rewrite gtn_max.
by apply /andP; split; apply qsz.
Qed.

Definition qadd (q1 q2: qpoly) : qpoly := Qpoly (qadd_size q1 q2).

Lemma qopp_size (q: qpoly) : size (-(val q)) < size p.
Proof.
by rewrite size_opp; apply qsz.
Qed.

Definition qopp (q: qpoly) := Qpoly (qopp_size q).

Lemma qaddA : associative qadd.
Proof.
move=> q1 q2 q3; rewrite /qadd; apply qpoly_inj=>/=.
by rewrite GRing.addrA.
Qed.

Lemma qaddC : commutative qadd.
Proof.
move=> q1 q2; rewrite /qadd; apply qpoly_inj=>/=.
by rewrite GRing.addrC.
Qed.

Lemma qaddFq : left_id q0 qadd.
Proof.
move=> q; rewrite /qadd /q0; apply qpoly_inj=>/=.
by rewrite GRing.add0r.
Qed.

Lemma qaddqq : left_inverse q0 qopp qadd.
Proof.
move=> q; rewrite /qadd /qopp /q0; apply qpoly_inj=>/=.
by rewrite GRing.addrC GRing.subrr.
Qed.

Definition qpoly_zmodMixin := ZmodMixin qaddA qaddC qaddFq qaddqq.
Canonical qpoly_zmodType := ZmodType qpoly qpoly_zmodMixin.

(* Ring *)

Lemma qmul_size (p1 p2: {poly F}) : size ((p1 * p2) %% p) < size p.
Proof.
by rewrite ltn_modp; apply irredp_neq0.
Qed.

Definition qmul (q1 q2 : qpoly) : qpoly := Qpoly (qmul_size q1 q2).

Lemma qpoly_mulA : associative qmul.
Proof.
move=> q1 q2 q3; rewrite /qmul; apply qpoly_inj=>/=.
by rewrite (GRing.mulrC ((qp q1 * qp q2) %% p)) !modp_mul
  (GRing.mulrC _ (qp q1 * qp q2)) GRing.mulrA.
Qed.

Lemma qpoly_mulC: commutative qmul.
Proof.
move=> q1 q2; rewrite /qmul; apply qpoly_inj=>/=.
by rewrite GRing.mulrC.
Qed.

Lemma qpoly_mul1q: left_id q1 qmul.
Proof.
move=> q. rewrite /qmul /q1; apply qpoly_inj=>/=.
by rewrite GRing.mul1r modp_small //; apply qsz.
Qed.

Lemma qpoly_mulD : left_distributive qmul qadd.
Proof.
move=>q1 q2 q3; rewrite /qmul /qadd; apply qpoly_inj=>/=.
by rewrite -modpD GRing.mulrDl.
Qed.

Lemma qpoly_1not0: q1 != q0.
Proof.
case: (q1 == q0) /eqP => //.
rewrite /q0 /q1 /= => [[eq_1_0]].
have neq_1_0:=(GRing.oner_neq0 (poly_ringType F)).
move: neq_1_0.
by rewrite eq_1_0 eq_refl.
Qed.

Definition qpoly_comRingMixin := ComRingMixin
  qpoly_mulA qpoly_mulC qpoly_mul1q qpoly_mulD qpoly_1not0.
Canonical qpoly_ringType := RingType qpoly qpoly_comRingMixin.
Canonical qpoly_comRingType := ComRingType qpoly qpoly_mulC.

(* Now we want to show that inverses exist and are computable. *)
(* We do this in several steps                                 *)
Definition prime_poly (p: {poly F}) : Prop :=
  forall (q r : {poly F}), p %| (q * r) -> (p %| q) || (p %| r).

Lemma irred_is_prime (r : {poly F}):
  irreducible_poly r -> prime_poly r.
Proof.
move=> r_irred s t r_div_st.
have [[u v]/= bez] := (Bezoutp r s).
case r_div_s: (r %| s) =>//=.
have rs_coprime: size (gcdp r s) == 1%N; last by
  rewrite -(Gauss_dvdpr _ rs_coprime).
case gcd_sz: (size (gcdp r s) == 1%N) => //.
have gcd_div := (dvdp_gcdl r s).
apply r_irred in gcd_div; last by apply negbT.
move: gcd_div.
by rewrite /eqp dvdp_gcd r_div_s !andbF.
Qed.

Lemma qpoly_zero (q: qpoly) : (q == 0) = (qp q %% p == 0).
Proof.
case: q => [q q_sz]/=.
have->: 0 = q0 by [].
by rewrite /q0 modp_small.
Qed.

(* The following actually shows that any finite integral domain is a field *)
Lemma qpoly_mulf_eq0 (q1 q2: qpoly) : (q1 * q2) = 0 -> (q1 == 0) || (q2 == 0).
Proof.
have->:(q1 * q2) = qmul q1 q2 by [].
have->:0 = q0 by [].
rewrite /qmul /= => [[/ modp_eq0P p_div_q12]].
rewrite !qpoly_zero.
by apply irred_is_prime.
Qed.

Lemma qpoly_cancel (q1 q2 q3: qpoly): q1 != 0 -> q1 * q2 = q1 * q3 -> q2 = q3.
Proof.
move=> q1_neq0 q12_13.
have q1_sub_q23: q1 * (q2 - q3) = 0 by rewrite GRing.mulrBr q12_13 GRing.subrr.
apply qpoly_mulf_eq0 in q1_sub_q23.
move: q1_sub_q23 => /orP[ /eqP q1_eq0 | /eqP eq_q23].
  by move: q1_neq0; rewrite q1_eq0 eq_refl.
by apply GRing.subr0_eq.
Qed.

(* To show that inverses exist, we define the map f_q(x) = q * x and we show *)
(* that this is injective (and thus bijective since the set is finite)       *)
(* if q != 0 *)
Definition qmul_map (q: qpoly) := qmul q.

Lemma qmul_map_inj (q: qpoly) :
  q != 0 ->
  injective (qmul_map q).
Proof.
move=> q_neq_0 q1 q2.
by apply qpoly_cancel.
Qed.

Lemma mul_map_bij (q: qpoly):
  q != 0 ->
  bijective (qmul_map q).
Proof.
move=> q_neq_0.
by apply injF_bij, qmul_map_inj.
Qed.

Lemma qpoly_inv_exist (q: qpoly):
  q != 0 ->
  exists (inv: qpoly), inv * q = 1.
Proof.
move=> q_neq_0. apply mul_map_bij in q_neq_0.
case : q_neq_0 => g can1 can2.
exists (g 1).
move: can2 => /( _ 1).
by rewrite GRing.mulrC.
Qed.

(* A (slow) computable inverse function from the above *)
Definition qinv (q: qpoly) :=
  nth q0 (enum qpoly) (find (fun x => x * q == 1) (enum qpoly)).

Lemma qinv_correct (q: qpoly):
  q != 0 ->
  (qinv q) * q = 1.
Proof.
move=>q_neq_0.
apply /eqP; rewrite /qinv.
have has_inv: has (fun x => x * q == 1) (enum qpoly);
  last by apply (nth_find q0) in has_inv.
apply /hasP.
apply qpoly_inv_exist in q_neq_0.
case: q_neq_0 => [inv inv_correct].
exists inv; last by apply /eqP.
have inv_count: count_mem inv (enum qpoly) = 1%N
  by rewrite enumT; apply enumP.
apply /count_memPn.
by rewrite inv_count.
Qed.

Lemma qinv_zero: qinv 0 = 0.
Proof.
have not_has: ~~ has (fun x => x * 0 == 1) (enum qpoly).
  apply /hasP.
  by move=>[r _ ]; rewrite GRing.mulr0 eq_sym GRing.oner_eq0.
by rewrite /qinv hasNfind // nth_default.
Qed.

(* The rest of the algebraic structures: *)

(* ComUnitRing *)

Definition qunit : pred qpoly :=
  fun x => x != q0.

Lemma qpoly_mulVr : {in qunit, left_inverse q1 qinv qmul}.
Proof.
move=> q q_in.
by apply qinv_correct.
Qed.

Lemma qpoly_mulrV : {in qunit, right_inverse q1 qinv qmul}.
Proof.
move=>q q_in.
by rewrite qpoly_mulC; apply qpoly_mulVr.
Qed.

Lemma qpoly_unitP (q1 q2: qpoly): (q2 * q1) = 1 /\ (q1 * q2) = 1 -> qunit q1.
Proof.
move=> [q21_1 q12_1].
rewrite /qunit; apply /eqP => q1_eq_0.
move: q12_1; rewrite q1_eq_0.
by rewrite GRing.mul0r => /eqP; rewrite eq_sym GRing.oner_eq0.
Qed.

Lemma qpoly_inv0id : {in [predC qunit], qinv =1 id}.
Proof.
move=>q q_unit.
have: ~~ (q != 0) by [].
rewrite negbK => /eqP->.
by rewrite qinv_zero.
Qed.

Definition qpoly_unitringmixin :=
  UnitRingMixin qpoly_mulVr qpoly_mulrV qpoly_unitP qpoly_inv0id.
Canonical qpoly_unitringtype := UnitRingType qpoly qpoly_unitringmixin.
Canonical qpoly_comunitring := [comUnitRingType of qpoly].

(*Integral Domain *)

Canonical qpoly_idomaintype := IdomainType qpoly qpoly_mulf_eq0.

(* Field *)

Lemma qpoly_mulVf : GRing.Field.axiom qinv.
Proof.
move=> q q_neq_0.
by apply qpoly_mulVr.
Qed.

Lemma qpoly_inv0: qinv 0%R = 0%R.
Proof.
exact: qinv_zero.
Qed.

Definition qpoly_fieldmixin := FieldMixin qpoly_mulVf qpoly_inv0.
Canonical qpoly_fieldType := FieldType qpoly qpoly_fieldmixin.
Canonical qpoly_finFieldType := Eval hnf in [finFieldType of qpoly].

(* Fields over primitive polynomials *)

Section Primitive.

Definition primitive_poly (p: {poly F}) : Prop :=
  irreducible_poly p /\ p %| 'X^((#|F|^((size p).-1)).-1) - 1 /\
  (forall n, p %| 'X^n - 1 -> (n == 0%N) || (((#|F|^((size p).-1)).-1) <= n)).

Variable p_prim: primitive_poly p.

(* We want to prove that discrete logs exist for all nonzero elements.   *)
(* We do not consider the trivial case where p = cx for constant c.      *)
(* This case is not very interesting, since F[X]/(x) is isomorphic to F. *)

Variable p_notx: 2 < size p.

Lemma qx_size: size (polyX F) < size p.
Proof.
by rewrite size_polyX.
Qed.

(* The primitive element x *)
Definition qx : qpoly := Qpoly qx_size.

Lemma qx_exp (n: nat): qp (qx ^+ n) = ('X^n) %% p.
Proof.
elim: n => [/= | n /= IHn].
  by rewrite GRing.expr0 modp_small // size_poly1; apply p_irred.
rewrite !GRing.exprSr.
have->: qx ^+ n * qx = qmul (qx ^+ n) qx by [].
by rewrite /qmul/= IHn GRing.mulrC modp_mul GRing.mulrC.
Qed.

(* To show that discrete logs exist, we use the following map and show that is *)
(* is bijective.                                                               *)

Section DlogEx.

Lemma qx_neq0: qx != 0.
Proof.
have->: 0 = q0 by [].
rewrite /qx/q0/=.
case: (Qpoly qx_size == Qpoly q0_size) /eqP => // [[/eqP eq_x0]].
by rewrite polyX_eq0 in eq_x0.
Qed.

Lemma qxn_neq0 (n: nat): qx ^+ n != 0.
Proof.
by apply GRing.expf_neq0, qx_neq0.
Qed.

Definition dlog_ord := 'I_((#|F|^((size p).-1)).-1).

(*Logs only exist for nonzero (or unit) qpolys*)
Inductive qpolyNZ : predArgType := Qnz (qq: qpoly) of (qunit qq).
Coercion qq (q: qpolyNZ) : qpoly := let: Qnz x _ := q in x.
Definition qun (q: qpolyNZ) : qunit q := let: Qnz _ x := q in x.

Canonical qpolyNZ_subType := [subType for qq].

Definition qpolyNZ_eqMixin := Eval hnf in [eqMixin of qpolyNZ by <:].
Canonical qpolyNZ_eqType := Eval hnf in EqType qpolyNZ qpolyNZ_eqMixin.
Definition qpolyNZ_choiceMixin := [choiceMixin of qpolyNZ by <:].
Canonical qpolyNZ_choiceType := Eval hnf in ChoiceType qpolyNZ qpolyNZ_choiceMixin.
Definition qpolyNZ_countMixin := [countMixin of qpolyNZ by <:].
Canonical qpolyNZ_countType := Eval hnf in CountType qpolyNZ qpolyNZ_countMixin.
Canonical qpolyNZ_subCountType := [subCountType of qpolyNZ].

Definition qpolyNZ_finMixin := Eval hnf in [finMixin of qpolyNZ by <:].
Canonical qpolyNZ_finType := Eval hnf in FinType qpolyNZ qpolyNZ_finMixin.
Canonical subFinType := [subFinType of qpolyNZ].

Lemma qpolyNZ_card: #|qpolyNZ| = #|qpoly|.-1.
Proof.
have uniq_sz:=(card_finField_unit qpoly_finFieldType).
move: uniq_sz; rewrite cardsT/= => <-.
by rewrite !card_sub.
Qed.

Lemma qx_unit : qunit qx.
Proof.
by rewrite /qunit qx_neq0.
Qed.

Lemma qpow_unit (n: nat) : qunit (qx ^+ n).
Proof.
by rewrite /qunit qxn_neq0.
Qed.

Definition qpow_map (i: dlog_ord) : qpolyNZ :=
  Qnz (qpow_unit i).

(* We need to know that p does not divide x^n for any n *)
Lemma irred_dvdn_Xn (r: {poly F}) (n: nat):
  irreducible_poly r ->
  2 < size r ->
  ~~ (r %| 'X^n).
Proof.
move=> r_irred r_size.
elim: n => [| n /= IHn].
  rewrite GRing.expr0 dvdp1.
  by apply /eqP => r_eq_1; rewrite r_eq_1 in r_size.
rewrite GRing.exprS.
case r_div: (r %| 'X * 'X^n) => //.
apply (irred_is_prime r_irred) in r_div.
move: r_div => /orP[r_divx | r_divxn]; last by rewrite r_divxn in IHn.
apply dvdp_leq in r_divx; last by rewrite polyX_eq0.
by move: r_divx; rewrite size_polyX leqNgt r_size.
Qed.

(* A weaker lemma than [modpD] *)
Lemma modpD_wk (d q r : {poly F}):
  d != 0 -> (q + r) %% d = (q %% d + r %% d) %% d.
Proof.
move=> d_neq0; rewrite modpD.
by rewrite (@modp_small _ (_ + _)) // -modpD ltn_modp.
Qed.

Lemma qpow_map_bij: bijective qpow_map.
Proof.
apply inj_card_bij; last by rewrite qpolyNZ_card qpoly_size card_ord leqnn.
move=> n1 n2; rewrite /qpow_map/= => [[]].
wlog: n1 n2 / (n1 <= n2).
  move=> all_eq.
  case: (orP (leq_total n1 n2)) => [n1_leqn2 | n2_leqn1].
    by apply all_eq.
  by move=> qx_n12; symmetry; apply all_eq.
move=> n1_leqn2 qx_n12.
have: (qx ^+ n2 - qx ^+ n1 = 0) by rewrite qx_n12 GRing.subrr.
rewrite -(subnKC n1_leqn2) GRing.exprD.
rewrite -{2}(GRing.mulr1 (qx ^+ n1)) -GRing.mulrBr.
move=> /eqP; rewrite GRing.mulf_eq0 => /orP[/eqP xn_eq0|].
  by have /eqP qn1_x := (negbTE (qxn_neq0 n1)).
rewrite qpoly_zero/= qx_exp GRing.addrC modpD_wk; last by apply irredp_neq0.
rewrite modp_mod GRing.addrC -modpD modp_mod => n21_div_p.
apply p_prim in n21_div_p.
move: n21_div_p => /orP[| n12_big].
  rewrite subn_eq0 => n2_leqn1; apply ord_inj; apply /eqP; rewrite eqn_leq.
  by rewrite n1_leqn2 n2_leqn1.
have n2_bound: n2 < (#|F| ^ (size p).-1).-1 by [].
have n12_bound: n2 - n1 <= n2 by rewrite leq_subr.
have lt_contra:= (leq_ltn_trans (leq_trans n12_big n12_bound) n2_bound).
by rewrite ltnn in lt_contra.
Qed.

(* The inverse map (discrete log)*)

Lemma field_gt0:
  0 < (#|F|^((size p).-1)).-1.
Proof.
rewrite -qpoly_size -qpolyNZ_card; apply /card_gt0P.
by exists (Qnz qx_unit).
Qed.

Definition dlog_map (q : qpolyNZ) : dlog_ord :=
  nth (Ordinal field_gt0) (enum dlog_ord)
    (find (fun i => (qx ^+ (nat_of_ord i) == q)) (enum dlog_ord)).

Lemma dlog_map_exist (q: qpolyNZ):
  exists (i: dlog_ord), (qx ^+ i == q).
Proof.
case: (qpow_map_bij) => g canqg cangq.
exists (g q).
move: cangq => /(_ q)/=; rewrite /qpow_map => q_eq.
apply (f_equal val) in q_eq.
by move: q_eq =>/=->; rewrite eq_refl.
Qed.

Lemma dlog_map_correct (q: qpolyNZ):
  (qx ^+ (dlog_map q) = q).
Proof.
rewrite /dlog_map.
have has_dlog: has
  (fun i =>(qx ^+ (nat_of_ord i) == q))
  (enum dlog_ord);
  last by apply /eqP; apply (nth_find (Ordinal field_gt0)) in has_dlog.
apply /hasP.
have [n n_log]:=(dlog_map_exist q).
exists n => //.
have n_count: count_mem n (enum dlog_ord) = 1%N
  by rewrite enumT; apply enumP.
apply /count_memPn.
by rewrite n_count.
Qed.

Lemma dlog_map_can: cancel dlog_map qpow_map.
Proof.
move=> q; rewrite /qpow_map; apply val_inj=>/=.
by rewrite dlog_map_correct.
Qed.

Lemma qpow_map_can: cancel qpow_map dlog_map.
Proof.
rewrite -bij_can_sym.
  exact: dlog_map_can.
exact: qpow_map_bij.
Qed.

Lemma dlog_map_bij: bijective dlog_map.
Proof.
exact: (bij_can_bij qpow_map_bij qpow_map_can).
Qed.

Lemma dlog_map_inj: injective dlog_map.
Proof.
exact: (bij_inj dlog_map_bij).
Qed.

End DlogEx.

(* The full discrete log function, with dlog(0) = 0 *)

Definition dlog (q: qpoly) : dlog_ord :=
(match (qunit q) as u return (qunit q = u -> dlog_ord) with
| true => fun q_unit => dlog_map (Qnz q_unit)
| false => fun _ => (Ordinal field_gt0)
end) erefl.

Lemma exp_dlog (q: qpoly):
  q != 0 ->
  qx ^+ (dlog q) = q.
Proof.
move=> q_neq0.
have q_unit: qunit q by [].
rewrite /dlog; move: erefl.
case: {2 3}(qunit q); last by rewrite q_unit.
by move=> q_unit'/=; rewrite dlog_map_correct.
Qed.

Lemma dlog0: nat_of_ord (dlog 0) = 0%N.
Proof.
rewrite /dlog; move: erefl.
have unit_zero: qunit 0 = false by rewrite /qunit eq_refl.
case: {2 3}(qunit 0) => //.
move=> zero_unit.
have: qunit 0 = true by [].
by rewrite unit_zero.
Qed.

Lemma dlog_exp (i: dlog_ord):
  dlog(qx ^+ i) = i.
Proof.
have->:qx ^+ i = qpow_map i by [].
have->: dlog (qpow_map i) = dlog_map (qpow_map i);
  last by rewrite qpow_map_can.
rewrite /dlog; move: erefl.
case: {2 3}(qunit (qpow_map i)) => //.
move=> qpow_nunit.
have: qunit (qpow_map i) = true by apply qun.
by rewrite {1}qpow_nunit.
Qed.

(* From definition of primitive poly *)
Lemma qx_field_sz1: qx ^+ (#|F| ^ (size p).-1).-1 = 1.
Proof.
apply qpoly_inj =>/=; rewrite qx_exp.
case p_prim => [_ [p_div _]].
move: p_div.
rewrite /dvdp modpD modNp (@modp_small _ 1);
  last by rewrite size_poly1 (ltn_trans _ p_notx).
by rewrite GRing.subr_eq0 => /eqP.
Qed.

Lemma qpoly_exp_modn (m n: nat) :
  m = n %[mod (#|F| ^ (size p).-1).-1] ->
  qx ^+ m = qx ^+ n.
Proof.
move=> mn_eqmod.
rewrite (divn_eq m (#|F| ^ (size p).-1).-1)
  (divn_eq n (#|F| ^ (size p).-1).-1).
rewrite !GRing.exprD !(mulnC _ ((#|F| ^ (size p).-1).-1)).
rewrite !GRing.exprM !qx_field_sz1 !GRing.expr1n !GRing.mul1r.
by rewrite mn_eqmod.
Qed.

End Primitive.

End FieldConstr.