Require Import Rpos.
Require Import riesz_logic_List_more.
Require Import RL.hr.term.
Require Import RL.hr.semantic.
Require Import RL.hr.hseq.
Require Import RL.hr.hr.

Require Import CMorphisms.
Require Import Lra.
Require Import Lia.

Require Import RL.OLlibs.List_more.
Require Import RL.OLlibs.List_Type.
Require Import RL.OLlibs.Permutation_Type.
Require Import RL.OLlibs.Permutation_Type_more.
Require Import RL.OLlibs.Permutation_Type_solve.

Local Open Scope R_scope.

(** Basic operation concerning Option Rpos (the None constructor corresponds to 0) *)
Definition oadd_Rpos o1 o2 :=
  match o1, o2 with
  | None, o2 => o2
  | o1, None => o1
  | Some r1, Some r2 => Some (plus_pos r1 r2)
  end.

Definition mul_Rpos_oRpos r o :=
  match o with
  | None => None
  | Some r1 => Some (time_pos r r1)
  end.

(** Conversion from nat to Option Rpos *)
Definition nat_oRpos n :=
  match n with
  | 0 => None
  | S n => Some (INRpos n)
  end.

(** The hypersequent obtained by multiplying (or copying) every sequent by the corresponding element of L and then using the S rule until only one sequent remain *)
Fixpoint concat_with_coeff_mul G L :=
  match G, L with
  | _, nil => nil
  | nil, _ => nil
  | T :: G , (Some r) :: L => seq_mul r T ++ concat_with_coeff_mul G L
  | T :: G , None :: L => concat_with_coeff_mul G L
  end.

Fixpoint concat_with_coeff_copy G L :=
  match G, L with
  | _, nil => nil
  | nil, _ => nil
  | T :: G , n :: L => copy_seq n T ++ concat_with_coeff_copy G L
  end.

Lemma concat_with_coeff_mul_all_0 : forall G L,
    Forall_inf (fun x => x = None) L ->
    concat_with_coeff_mul G L = nil.
Proof.
  intros G L; revert G; induction L; intros G Ha0; destruct G; simpl; auto.
  inversion Ha0; subst.
  apply IHL; assumption.
Qed.

(** point-wise operation on list of (Option Rpos) or nat *)
Fixpoint oadd_Rpos_list L1 L2 :=
  match L1,L2 with
  | nil, _ => nil
  | _, nil => nil
  | o1 :: L1 , o2 :: L2 => (oadd_Rpos o1 o2) :: (oadd_Rpos_list L1 L2)
  end.

Fixpoint add_nat_list L1 L2 :=
  match L1,L2 with
  | nil, _ => nil
  | _, nil => nil
  | n1 :: L1 , n2 :: L2 => ((n1 + n2)%nat) :: (add_nat_list L1 L2)
  end.

Lemma oadd_Rpos_list_length : forall L1 L2,
    length L1 = length L2 ->
    length (oadd_Rpos_list L1 L2) = (length L1).
Proof.
  induction L1; intros L2; try reflexivity.
  intros Heq.
  destruct L2; inversion Heq.
  specialize (IHL1 L2 H0).
  destruct a; destruct o; simpl; rewrite IHL1; reflexivity.
Qed.

Lemma add_nat_list_length : forall L1 L2,
    length L1 = length L2 ->
    length (add_nat_list L1 L2) = (length L1).
Proof.
  induction L1; intros L2; try reflexivity.
  intros Heq.
  destruct L2; inversion Heq.
  specialize (IHL1 L2 H0).
  simpl; rewrite IHL1; reflexivity.
Qed.

Lemma concat_with_coeff_mul_omul_Rpos_list : forall G L1 r,
    concat_with_coeff_mul G (map (mul_Rpos_oRpos r) L1) = seq_mul r (concat_with_coeff_mul G L1).
Proof.
  induction G; intros L1 r; [ destruct L1; try destruct o; reflexivity | ].
  destruct L1 ; [ reflexivity | ].
  specialize (IHG L1 r).
  destruct o; simpl; rewrite IHG; try reflexivity.
  rewrite <- seq_mul_twice; rewrite seq_mul_app.
  reflexivity.
Qed.

Lemma concat_with_coeff_copy_add_nat_list_perm : forall G L1 L2,
    length L1 = length L2 ->
    Permutation_Type (concat_with_coeff_copy G (add_nat_list L1 L2)) (concat_with_coeff_copy G L1 ++ concat_with_coeff_copy G L2).
Proof.
  intros G L1; revert G; induction L1; intros G L2 Hlen; destruct L2; inversion Hlen ; [ destruct G; simpl; apply Permutation_Type_nil_nil | ].
  destruct G ; [ apply Permutation_Type_nil_nil | ].
  simpl add_nat_list; simpl concat_with_coeff_copy.
  transitivity ((copy_seq a s ++ copy_seq n s) ++ (concat_with_coeff_copy G L1 ++ concat_with_coeff_copy G L2)) ; [ | Permutation_Type_solve].
  apply Permutation_Type_app ; [ | apply IHL1]; try assumption.
  rewrite copy_seq_plus; reflexivity.
Qed.

Lemma concat_with_coeff_copy_mul_nat_list : forall G L1 n,
    Permutation_Type (concat_with_coeff_copy G (map (Nat.mul n) L1)) (copy_seq n (concat_with_coeff_copy G L1)).
Proof.
  induction G; intros L1 n.
  - destruct L1; simpl; rewrite copy_seq_nil; apply Permutation_Type_nil_nil.
  - destruct L1; simpl ; [ rewrite copy_seq_nil; apply Permutation_Type_nil_nil | ].
    etransitivity ; [ | symmetry; apply copy_seq_app].
    apply Permutation_Type_app ; [ | apply IHG].
    rewrite copy_seq_twice; reflexivity.
Qed.

(** Sufficient conditions for derivability of a basic hypersequent *)
Lemma atomic_proof_all_eq P : forall H T,
    seq_is_atomic T ->
    hseq_is_atomic H ->
    (forall n, sum_weight_var n (T :: H) = 0) ->
    HR P (T :: H).
Proof.
  induction H; intros T.
  - intros Hb _; revert Hb.
    remember (length T).
    revert T Heqn.
    apply (lt_wf_rect n (fun n => forall T : sequent,
                             n = length T ->
                             seq_is_atomic T ->
                             (forall n0 : term.V, sum_weight_var n0 (T :: nil) = 0) ->
                             HR P (T :: nil))).
    clear n.
    intros n IHn T Hlen Hat Hsum.
    destruct (seq_atomic_decomp_decr T Hat) as [[[[[n0 r] s] D] [Hr [Hperm Hdlen]]] | Hnil].
    + eapply hrr_ex_seq ; [ symmetry; apply Hperm | ].
      apply hrr_ID.
      { specialize (Hsum n0); simpl in Hsum.
        nra. }
      apply IHn with (length D).
      * lia.
      * reflexivity.
      * apply seq_atomic_perm with _ (vec s (RS_covar n0) ++ vec r (RS_var n0) ++ D) in Hat; try assumption.
        apply seq_atomic_app_inv_r in Hat.
        apply seq_atomic_app_inv_r in Hat.
        apply Hat.
      * intros n1.
        specialize (Hsum n0) as Hrs.
        specialize (Hsum n1).
        simpl in Hsum; rewrite (sum_weight_var_seq_perm _ _ _ Hperm) in Hsum.
        rewrite ? sum_weight_var_seq_app in Hsum.
        simpl.
        case_eq (term.V_eq n0 n1); intros H01 He.
        -- subst.
           rewrite sum_weight_var_seq_vec_covar_eq in Hsum; rewrite sum_weight_var_seq_vec_var_eq in Hsum.
           simpl in Hrs.
           nra.
        -- rewrite sum_weight_var_seq_vec_neq in Hsum; [ | intros H'; inversion H'; now auto | intros H'; inversion H'; now auto].
           rewrite sum_weight_var_seq_vec_neq in Hsum; [ | intros H'; inversion H'; now auto | intros H'; inversion H'; now auto].
           nra.
    + destruct T.
      { apply hrr_INIT. }
      destruct p as [a A].
      inversion Hat; subst.
      destruct A; try (now inversion X); exfalso; apply Hnil with v;
        [ left | right ]; left; reflexivity.
  - intros HatT HatH Hsum.
    apply hrr_S.
    apply IHlist.
    + inversion HatH; subst.
      apply seq_atomic_app; assumption.
    + inversion HatH; assumption.
    + intros n.
      specialize (Hsum n).
      simpl in *.
      rewrite sum_weight_var_seq_app.
      nra.
Qed.

(** ** sum_weight_(co)var_with_coeff *)
Fixpoint sum_weight_var_with_coeff n G (L : list (option Rpos)) :=
  match G, L with
  | _, nil => 0
  | nil, _ => 0
  | T :: G , None :: L => sum_weight_var_with_coeff n G L
  | T :: G , (Some r) :: L => ((projT1 r) * sum_weight_var_seq n T) + sum_weight_var_with_coeff n G L
  end.

Lemma sum_weight_var_with_coeff_app1 : forall n G1 G2 L,
    (length L <= length G1)%nat ->
    sum_weight_var_with_coeff n (G1 ++ G2) L = sum_weight_var_with_coeff n G1 L.
Proof.
  intros n; induction G1; intros G2 L Hlen; destruct L; try (now inversion Hlen); [destruct G2 | ]; auto.
  simpl; rewrite IHG1; auto.
  simpl in Hlen; lia.
Qed.

Lemma sum_weight_var_with_coeff_app2 : forall n G1 G2 L1 L2,
    (length L1 = length G1) ->
    sum_weight_var_with_coeff n (G1 ++ G2) (L1 ++ L2) = sum_weight_var_with_coeff n G1 L1 + sum_weight_var_with_coeff n G2 L2.
Proof.
  intros n; induction G1; intros G2 L1 L2 Hlen; destruct L1; try (now inversion Hlen); [destruct L2 ; destruct G2 | ]; simpl; try lra.
  simpl in *; rewrite IHG1; auto.
  destruct o ; lra.
Qed.

Lemma sum_weight_var_with_coeff_app3 : forall n G L1 L2,
    (length G <= length L1)%nat ->
    sum_weight_var_with_coeff n G (L1 ++ L2) = sum_weight_var_with_coeff n G L1.
Proof.
  intros n; induction G; intros L1 L2 Hlen; destruct L1; try (now inversion Hlen); [now destruct L2 | ].
  simpl; rewrite IHG; auto.
  simpl in Hlen; lia.
Qed.

Lemma concat_with_coeff_copy_all_0 : forall G L,
    Forall_inf (fun x => x = 0%nat) L ->
    concat_with_coeff_copy G L = nil.
Proof.
  intros G L; revert G; induction L; intros G Ha0; destruct G; simpl; auto.
  inversion Ha0; subst.
  apply IHL; assumption.
Qed.

Lemma sum_weight_var_with_coeff_oadd_Rpos_list : forall n G L1 L2,
    length L1 = length L2 ->
    sum_weight_var_with_coeff n G (oadd_Rpos_list L1 L2) = sum_weight_var_with_coeff n G L1 + sum_weight_var_with_coeff n G L2.
Proof.
  intros n G L1; revert G; induction L1; intros G L2 Hlen; destruct L2; try (now inversion Hlen); [ destruct G; simpl; nra | ].
  destruct G; [ simpl ; nra | ].
  inversion Hlen.
  specialize (IHL1 G L2 H0).
  destruct a; destruct o; try destruct r; try destruct r0; simpl; nra.
Qed.

Lemma sum_weight_var_with_coeff_omul_Rpos_list : forall n G L1 r,
    sum_weight_var_with_coeff n G (map (mul_Rpos_oRpos r) L1) = (projT1 r) * sum_weight_var_with_coeff n G L1.
Proof.
  intros n G L1; revert G; induction L1; intros G r ; [ destruct G; simpl; nra | ].
  destruct G; [ destruct a; simpl ; nra | ].
  specialize (IHL1 G r).
  destruct a; try destruct r; try destruct r0; simpl in *; nra.
Qed.

Lemma sum_weight_var_with_coeff_add_nat_list : forall n G L1 L2,
    length L1 = length L2 ->
    sum_weight_var_with_coeff n G (map nat_oRpos (add_nat_list L1 L2)) = sum_weight_var_with_coeff n G (map nat_oRpos L1) + sum_weight_var_with_coeff n G (map nat_oRpos L2).
Proof.
  intros n G L1; revert G; induction L1; intros G L2 Hlen; destruct L2; try (now inversion Hlen); [ destruct G; simpl; nra | ].
  destruct G; [ simpl ; nra | ].
  inversion Hlen.
  specialize (IHL1 G L2 H0).
  simpl add_nat_list.
  destruct a; destruct n0; simpl map; simpl sum_weight_var_with_coeff; try nra.
  - change (match (a + 0)%nat with
             | 0%nat => 1
             | S _ => INR (a + 0) + 1
            end) with (INR (S a + 0)).
    change (match a with
            | 0%nat => 1
            | S _ => INR a + 1
            end) with (INR (S a)).
    rewrite Nat.add_0_r; nra.
  - change (match (a + S n0)%nat with
             | 0%nat => 1
             | S _ => INR (a + S n0) + 1
            end) with (INR (S a + S n0)).
    change (match a with
            | 0%nat => 1
            | S _ => INR a + 1
            end) with (INR (S a)).
    change (match n0 with
            | 0%nat => 1
            | S _ => INR n0 + 1
            end) with (INR (S n0)).
    rewrite plus_INR; nra.
Qed.

Lemma sum_weight_var_with_coeff_mul_nat_list : forall n G L1 n',
    sum_weight_var_with_coeff n G (map nat_oRpos (map (Nat.mul (S n')) L1)) = (INR (S n')) * sum_weight_var_with_coeff n G (map nat_oRpos L1).
Proof.
  intros n G L1; revert G; induction L1; intros G n' ; [ destruct G; simpl; nra | ].
  destruct G; [ destruct a; simpl ; nra | ].
  specialize (IHL1 G n').
  destruct a; simpl map.
  - rewrite Nat.mul_0_r; apply IHL1.
  - simpl sum_weight_var_with_coeff.
    change (match (a + n' * S a)%nat with
           | 0%nat => 1
           | S _ => INR (a + n' * S a) + 1
            end) with (INR (S n' * S a)).
    change (match a with
            | 0%nat => 1
            | S _ => INR a + 1
            end) with (INR (S a)).
    change (fun m : nat => (m + n' * m)%nat) with (Nat.mul (S n')).
    rewrite mult_INR; nra.
Qed.

Lemma sum_weight_var_with_coeff_perm_r : forall G H L,
    Permutation_Type G H ->
    length L = length G ->
    { L' &
      prod (Permutation_Type L L')
           ((forall n, sum_weight_var_with_coeff n G L = sum_weight_var_with_coeff n H L'))}.
Proof.
  intros G H L Hperm.
  revert L; induction Hperm; intros L Hlen.
  - destruct L; inversion Hlen.
    split with nil.
    repeat split; auto.
  - destruct L; inversion Hlen.
    destruct (IHHperm L H0) as [L' [Hperm' Hsum]].
    split with (o :: L').
    repeat split; auto.
    + intros n; simpl;rewrite (Hsum n); reflexivity.
  - destruct L ;  [ | destruct L] ; inversion Hlen.
    split with (o0 :: o :: L).
    repeat split.
    + apply Permutation_Type_swap.
    + intros n; destruct o; destruct o0; simpl; nra.
  - destruct (IHHperm1 L Hlen) as [L' [Hperm' Hsum]].
    destruct (IHHperm2 L') as [L2' [Hperm2' Hsum2]].
    { apply Permutation_Type_length in Hperm1.
      apply Permutation_Type_length in Hperm2.
      apply Permutation_Type_length in Hperm'.
      etransitivity;  [ symmetry ; apply Hperm' | ].
      etransitivity ; [ | apply Hperm1].
      apply Hlen. }
    split with L2'.
    repeat split; [ Permutation_Type_solve |  ].
    intros n.
    etransitivity ; [ apply (Hsum n) | apply (Hsum2 n)].
Qed.

Lemma sum_weight_var_with_coeff_perm_l : forall G L L',
    Permutation_Type L L' ->
    length L = length G ->
    { H &
      prod (Permutation_Type G H)
           ((forall n, sum_weight_var_with_coeff n G L = sum_weight_var_with_coeff n H L') )}.
Proof.
  intros G L L' Hperm.
  revert G; induction Hperm; intros G Hlen.
  - destruct G; inversion Hlen.
    split with nil.
    auto.
  - destruct G; inversion Hlen.
    destruct (IHHperm G H0) as [H [Hperm' Hsum]].
    split with (s :: H).
    repeat split; auto.
    intros n; simpl;rewrite (Hsum n); reflexivity.
  - destruct G ;  [ | destruct G] ; inversion Hlen.
    split with (s0 :: s :: G).
    repeat split.
    + apply Permutation_Type_swap.
    + intros n; destruct y; destruct x; simpl; nra.
  - destruct (IHHperm1 G Hlen) as [H [Hperm' Hsum]].
    destruct (IHHperm2 H) as [H2 [Hperm2' Hsum2]].
    { apply Permutation_Type_length in Hperm1.
      apply Permutation_Type_length in Hperm2.
      apply Permutation_Type_length in Hperm'.
      etransitivity;  [ | apply Hperm' ].
      etransitivity ; [ symmetry ; apply Hperm1 | ].
      apply Hlen. }
    split with H2.
    repeat split.
    + Permutation_Type_solve.
    + intros n.
      etransitivity ; [ apply (Hsum n) | apply (Hsum2 n)].
Qed.

Lemma sum_weight_var_with_coeff_perm_r_int : forall G H L,
    Permutation_Type G H ->
    length L = length G ->
    { L' &
      prod (Permutation_Type L L')
           (forall n, sum_weight_var_with_coeff n G (map nat_oRpos L) = sum_weight_var_with_coeff n H (map nat_oRpos L'))}.
Proof.
  intros G H L Hperm.
  revert L; induction Hperm; intros L Hlen.
  - destruct L; inversion Hlen.
    split with nil.
    repeat split; auto.
  - destruct L; inversion Hlen.
    destruct (IHHperm L H0) as [L' [Hperm' Hsum]].
    split with (n :: L').
    repeat split; auto.
    + intros n'; simpl;rewrite (Hsum n'); reflexivity.
  - destruct L ;  [ | destruct L] ; inversion Hlen.
    split with (n0 :: n :: L).
    repeat split.
    + apply Permutation_Type_swap.
    + intros n'; destruct n; destruct n0; simpl in *; nra.
  - destruct (IHHperm1 L Hlen) as [L' [Hperm' Hsum]].
    destruct (IHHperm2 L') as [L2' [Hperm2' Hsum2]].
    { apply Permutation_Type_length in Hperm1.
      apply Permutation_Type_length in Hperm2.
      apply Permutation_Type_length in Hperm'.
      etransitivity;  [ symmetry ; apply Hperm' | ].
      etransitivity ; [ | apply Hperm1].
      apply Hlen. }
    split with L2'.
    repeat split; [ Permutation_Type_solve |  ].
    intros n.
    etransitivity ; [ apply (Hsum n) | apply (Hsum2 n)].
Qed.

Lemma sum_weight_var_with_coeff_perm_l_int : forall G L L',
    Permutation_Type L L' ->
    length L = length G ->
    { H &
      prod (Permutation_Type G H)
           (forall n, sum_weight_var_with_coeff n G (map nat_oRpos L) = sum_weight_var_with_coeff n H (map nat_oRpos L'))}.
Proof.
  intros G L L' Hperm.
  revert G; induction Hperm; intros G Hlen.
  - destruct G; inversion Hlen.
    split with nil.
    auto.
  - destruct G; inversion Hlen.
    destruct (IHHperm G H0) as [H [Hperm' Hsum]].
    split with (s :: H).
    repeat split; auto.
    + intros n; simpl;rewrite (Hsum n); reflexivity.
  - destruct G ;  [ | destruct G] ; inversion Hlen.
    split with (s0 :: s :: G).
    repeat split.
    + apply Permutation_Type_swap.
    + intros n; destruct y; destruct x; simpl; nra.
  - destruct (IHHperm1 G Hlen) as [H [Hperm' Hsum]].
    destruct (IHHperm2 H) as [H2 [Hperm2' Hsum2]].
    { apply Permutation_Type_length in Hperm1.
      apply Permutation_Type_length in Hperm2.
      apply Permutation_Type_length in Hperm'.
      etransitivity;  [ | apply Hperm' ].
      etransitivity ; [ symmetry ; apply Hperm1 | ].
      apply Hlen. }
    split with H2.
    repeat split.
    + Permutation_Type_solve.
    + intros n.
      etransitivity ; [ apply (Hsum n) | apply (Hsum2 n)].
Qed.

Lemma sum_weight_var_with_coeff_all_0 :
  forall G L n,
    Forall_inf (fun x => x = None) L ->
    sum_weight_var_with_coeff n G L = 0.
Proof.
  intros G L; revert G; induction L; intros G n Hall; destruct G; try reflexivity.
  inversion Hall; subst.
  specialize (IHL G n X).
  simpl; apply IHL.
Qed.


(* Banach-Tarski paradox. *)

Require Import Utf8 List Relations NPeano Wf_nat.
Import ListNotations.
Require Import Misc Words.

Fixpoint norm_list el :=
  match el with
  | nil => nil
  | e₁ :: el₁ =>
      match norm_list el₁ with
      | nil => e₁ :: nil
      | e₂ :: el₂ => if letter_opp_dec e₁ e₂ then el₂ else e₁ :: e₂ :: el₂
      end
  end.

Theorem norm_list_no_consec : ∀ e el el₁ el₂,
  norm_list el ≠ el₁ ++ e :: negf e :: el₂.
Proof.
intros e el el₁ el₂.
revert el₁.
induction el as [| e₁]; intros; [ intros H; now destruct el₁ | ].
simpl; remember (norm_list el) as nl eqn:Hnl; symmetry in Hnl.
destruct nl as [| e₂].
 clear; intros H.
 destruct el₁ as [| e₂]; intros; [ easy | simpl in H ].
 injection H; clear H; intros; subst e₂.
 now destruct el₁.

 destruct (letter_opp_dec e₁ e₂) as [H₁| H₁].
  intros H; subst nl.
  pose proof IHel (e₂ :: el₁) as H₂; simpl in H₂.
  now apply H₂.

  unfold letter_opp in H₁.
  destruct e₁ as (x₁, d₁).
  destruct e₂ as (x₂, d₂).
  destruct (letter_dec x₁ x₂) as [H₂| H₂].
   subst x₂.
   destruct (Bool.bool_dec d₁ d₂) as [H₂| H₂].
    clear H₁; subst d₂.
    destruct el₁ as [| e₁].
     simpl; intros H.
     injection H; clear H; intros H₁ H₂ H₃; subst e.
     simpl in H₂.
     injection H₂; clear H₂; intros H.
     symmetry in H; revert H; apply Bool.no_fixpoint_negb.

     simpl; intros H.
     injection H; clear H; intros H₁ H₂; subst e₁.
     eapply IHel, H₁.

    exfalso; apply H₁; constructor.

   clear H₁.
   destruct el₁ as [| e₁].
    simpl; intros H.
    injection H; clear H; intros H₁ H₃ H₄; subst e.
    simpl in H₃.
    injection H₃; clear H₃; intros; subst x₂ d₂.
    now apply H₂.

    simpl; intros H.
    injection H; clear H; intros H₁ H₃.
    eapply IHel, H₁.
Qed.

Theorem norm_list_no_consec2 : ∀ e el el₁ el₂,
  norm_list el ≠ el₁ ++ negf e :: e :: el₂.
Proof.
intros e el el₁ el₂.
pose proof norm_list_no_consec (negf e) el el₁ el₂ as H.
now rewrite negf_involutive in H.
Qed.

Theorem norm_list_no_start : ∀ e el el₂,
  norm_list el ≠ e :: negf e :: el₂.
Proof.
intros e el el₂.
apply norm_list_no_consec with (el₁ := []).
Qed.

Theorem norm_list_no_start2 : ∀ e el el₂,
  norm_list el ≠ negf e :: e :: el₂.
Proof.
intros e el el₂.
apply norm_list_no_consec2 with (el₁ := []).
Qed.

Theorem norm_list_cancel : ∀ el e,
  norm_list (e :: negf e :: el) = norm_list el.
Proof.
intros el (t, d).
revert t d.
induction el as [| (t₁, d₁)]; intros.
 simpl; now rewrite letter_dec_diag, bool_dec_negb_r.

 remember (FE t₁ d₁ :: el) as el₁ eqn:Hel₁.
 symmetry in Hel₁; simpl.
 remember (norm_list el₁) as el₂ eqn:Hel₂.
 symmetry in Hel₂; simpl.
 destruct el₂ as [| (t₂, d₂)].
  now rewrite letter_dec_diag, bool_dec_negb_r.

  subst el₁.
  destruct (letter_dec t t₂) as [H₁| H₁].
   subst t₂.
   destruct (Bool.bool_dec (negb d) d₂) as [H₁| H₁].
    subst d₂.
    now rewrite letter_dec_diag, bool_dec_negb_r.

    apply negb_neq in H₁; subst d₂.
    destruct el₂ as [| (t₂, d₂)]; [ easy | ].
    destruct (letter_dec t t₂) as [H₁| H₁]; [ | easy ].
    subst t₂.
    destruct (Bool.bool_dec d d₂) as [H₁| H₁]; [ easy | ].
    apply not_eq_sym, neq_negb in H₁; subst d₂.
    exfalso; revert Hel₂; apply norm_list_no_start.

   now rewrite letter_dec_diag, bool_dec_negb_r.
Qed.

Theorem norm_list_cancel_in : ∀ el₁ el₂ e,
  norm_list (el₁ ++ e :: negf e :: el₂) =
  norm_list (el₁ ++ el₂).
Proof.
intros.
revert el₂ e.
induction el₁ as [| e₁]; intros.
 do 2 rewrite app_nil_l.
 apply norm_list_cancel.

 simpl; now rewrite IHel₁.
Qed.

Theorem norm_list_cancel_in2 : ∀ el₁ el₂ e,
  norm_list (el₁ ++ negf e :: e :: el₂) =
  norm_list (el₁ ++ el₂).
Proof.
intros.
pose proof norm_list_cancel_in el₁ el₂ (negf e) as H.
now rewrite negf_involutive in H.
Qed.

Theorem is_normal : ∀ el₁ el₂ el₃,
  norm_list (el₁ ++ norm_list el₂ ++ el₃) =
  norm_list (el₁ ++ el₂ ++ el₃).
Proof.
intros.
revert el₁ el₃.
induction el₂ as [| e₂]; intros; [ easy | simpl ].
remember (norm_list el₂) as el eqn:Hel₂; symmetry in Hel₂.
destruct el as [| e].
 simpl in IHel₂; simpl.
 rewrite cons_comm_app, app_assoc.
 now rewrite IHel₂, <- app_assoc.

 destruct (letter_opp_dec e₂ e) as [H₁| H₁].
  apply letter_opp_negf in H₁; subst e₂.
  rewrite cons_comm_app.
  do 2 rewrite app_assoc.
  rewrite <- IHel₂.
  do 2 rewrite <- app_assoc; simpl.
  rewrite norm_list_cancel_in2.
  easy.

  rewrite cons_comm_app.
  do 2 rewrite app_assoc.
  rewrite <- IHel₂.
  do 2 rewrite <- app_assoc.
  easy.
Qed.

Theorem norm_list_normal_l : ∀ el₁ el₂,
  norm_list (el₁ ++ el₂) = norm_list (norm_list el₁ ++ el₂).
Proof.
intros.
replace el₁ with ([] ++ el₁) by easy.
rewrite <- app_assoc.
now rewrite <- is_normal.
Qed.

Theorem norm_list_normal_r : ∀ el₁ el₂,
  norm_list (el₁ ++ el₂) = norm_list (el₁ ++ norm_list el₂).
Proof.
intros.
replace el₂ with (el₂ ++ []) by apply app_nil_r.
rewrite <- is_normal.
now do 2 rewrite app_nil_r.
Qed.

Theorem norm_list_idemp : ∀ el, norm_list (norm_list el) = norm_list el.
Proof.
intros el.
pose proof is_normal [] el [] as H.
simpl in H; do 2 rewrite app_nil_r in H.
easy.
Qed.

Theorem norm_list_cons : ∀ el e,
  norm_list (e :: el) = e :: el
  → norm_list el = el.
Proof.
intros el e Hn.
revert e Hn.
induction el as [| e₁]; intros; [ easy | ].
remember (e₁ :: el) as el₁ eqn:Hel.
simpl in Hn.
remember (norm_list el₁) as el₂ eqn:Hel₁; symmetry in Hel₁.
destruct el₂ as [| e₂].
 injection Hn; clear Hn; intros; now subst.

 destruct (letter_opp_dec e e₂) as [H₁| H₁].
  apply letter_opp_negf in H₁; subst e el₂.
  exfalso; revert Hel₁; apply norm_list_no_start.

  injection Hn; clear Hn; intros; subst el₁.
  easy.
Qed.

Theorem norm_list_app_diag : ∀ el₁ el₂,
  norm_list (el₁ ++ el₂) = el₁ ++ el₂ → norm_list el₁ = el₁.
Proof.
intros el₁ el₂ Hn.
revert el₂ Hn.
induction el₁ as [| e₁]; intros; [ easy | simpl ].
generalize Hn; intros Hn₁.
rewrite <- app_comm_cons in Hn₁.
apply norm_list_cons, IHel₁ in Hn₁.
rewrite Hn₁.
destruct el₁ as [| e₂]; [ easy | ].
destruct (letter_opp_dec e₁ e₂) as [H₁| H₁]; [ exfalso | easy ].
apply letter_opp_negf in H₁; subst e₁.
revert Hn; apply norm_list_no_start2.
Qed.

Theorem norm_list_dec : ∀ el,
  { norm_list el = el } +
  { ∃ el₁ t d el₂, el = el₁ ++ FE t d :: FE t (negb d) :: el₂ }.
Proof.
intros el.
induction el as [| e]; [ now left | ].
destruct IHel as [IHel| IHel].
 simpl.
 rewrite IHel.
 destruct el as [| e₁]; [ now left | ].
 destruct (letter_opp_dec e e₁) as [H₁| H₁]; [ right | now left ].
 apply letter_opp_sym, letter_opp_negf in H₁; subst e₁.
 destruct e as (t, d).
 exists [], t, d, el.
 easy.

 right.
 destruct IHel as (el₁, (t, (d, (el₂, IHel)))).
 exists (e :: el₁), t, d, el₂; subst el.
 easy.
Qed.

Theorem norm_list_repeat : ∀ e n, norm_list (repeat e n) = repeat e n.
Proof.
intros e n.
induction n; [ easy | simpl ].
rewrite IHn.
remember (repeat e n) as el eqn:Hel.
symmetry in Hel.
destruct el as [| e₁]; [ easy | ].
destruct (letter_opp_dec e e₁) as [H| H]; [ | easy ].
apply letter_opp_negf in H; subst e.
exfalso.
destruct n; [ easy | ].
injection Hel; clear Hel; intros Hel H.
revert H; apply no_fixpoint_negf.
Qed.

Theorem norm_list_is_cons : ∀ el e el₁,
  norm_list el = e :: el₁ → norm_list el₁ = el₁.
Proof.
intros * H.
destruct (norm_list_dec el₁) as [H₁| H₁]; [ easy | ].
destruct H₁ as (el₂ & t & d & el₃ & H₁).
subst el₁.
exfalso; revert H.
replace (FE t (negb d)) with (negf (FE t d)) by easy.
rewrite app_comm_cons.
apply norm_list_no_consec.
Qed.

Theorem norm_list_app_split : ∀ el₁ el₂ el₃ el₄ e,
  norm_list el₁ ++ norm_list el₂ = el₃ ++ e :: negf e :: el₄
  → norm_list el₁ = el₃ ++ [e] ∧ norm_list el₂ = negf e :: el₄.
Proof.
intros el₁ el₂ el₃ el₄ e Hn.
apply split_app_eq in Hn.
destruct Hn as [(el, (H₁, H₂))| (el, (H₁, H₂))].
 exfalso; revert H₂; apply norm_list_no_consec.

 rewrite app_of_cons in H₂.
 apply split_app_eq in H₂.
 destruct H₂ as [(el', (H₂, H₃))| (el', (H₂, H₃))].
  subst el.
  destruct el' as [| e'].
   rewrite app_nil_r in H₁.
   rewrite app_nil_l in H₃; symmetry in H₃.
   now split.

   simpl in H₃.
   injection H₃; clear H₃; intros H₂ H₃; subst e'.
   exfalso; revert H₁; apply norm_list_no_consec.

  destruct el as [| e₁].
   simpl in H₂; subst el'.
   exfalso; revert H₃; apply norm_list_no_start.

   simpl in H₂.
   injection H₂; clear H₂; intros H₂ H₄; subst e₁.
   symmetry in H₂.
   apply app_eq_nil in H₂.
   destruct H₂; subst el el'.
   now split.
Qed.


(** * Pointed types *)
(** A pointed type is a type [T] together with an inhabitant of [T].
    The "pointed" terminology comes from the homotopy type theoretic
    practice of thinking of types as ∞-groupoids or topological
    spaces. *)
Require Import Ssreflect.ssreflect.
Require Import Coq.Setoids.Setoid Coq.Classes.RelationClasses.

Set Implicit Arguments.
Generalizable All Variables.

Class IsPointed (T : Type) := point : T.
Arguments point T {_}.

Instance IsPointed_True : IsPointed True := I.
Instance IsPointed_unit : IsPointed unit := tt.
Instance IsPointed_prod `{IsPointed A, IsPointed B} : IsPointed (A * B) := (point A, point B).
Instance IsPointed_and {A B : Prop} `{IsPointed A, IsPointed B} : IsPointed (A /\ B) := conj (point A) (point B).
Instance IsPointed_sigT `{IsPointed A, IsPointed (P (point A))} : IsPointed (sigT P) := existT P _ (point (P (point A))).
Instance IsPointed_sig {A} {P : A -> Prop} `{IsPointed A, IsPointed (P (point A))} : IsPointed (sig P) := exist P _ (point (P (point A))).
Instance IsPointed_ex {A} {P : A -> Prop} `{IsPointed A, IsPointed (P (point A))} : IsPointed (ex P) := ex_intro P _ (point (P (point A))).
Instance IsPointed_sigT2 `{IsPointed A, IsPointed (P (point A)), IsPointed (Q (point A))} : IsPointed (sigT2 P Q)
  := existT2 P Q (point A) (point _) (point _).
Instance IsPointed_sig2 {A} {P Q : A -> Prop} `{IsPointed A, IsPointed (P (point A)), IsPointed (Q (point A))} : IsPointed (sig2 P Q)
  := exist2 P Q (point A) (point _) (point _).
Instance IsPointed_ex2 {A} {P Q : A -> Prop} `{IsPointed A, IsPointed (P (point A)), IsPointed (Q (point A))} : IsPointed (ex2 P Q)
  := ex_intro2 P Q (point A) (point _) (point _).
Instance IsPointed_forall {A B} `{forall a : A, IsPointed (B a)} : IsPointed (forall a : A, B a) := fun a => point (B a).
Instance IsPointed_refl {T a} : IsPointed (a = a :> T) := eq_refl.
Instance IsPointed_reflexive `{@Reflexive T R} {a} : IsPointed (R a a) := reflexivity _.

(** TODO(t-jagro): Should this be an instance? *)
Instance IsPointed_list {A} : IsPointed (list A) := nil.
Instance IsPointed_nat : IsPointed nat := 0.

(** We don't make the [or] versions instances, because they're not unique *)
Definition IsPointed_sum_inl {A B} `{IsPointed A} : IsPointed (A + B) := inl (point A).
Definition IsPointed_sum_inr {A B} `{IsPointed B} : IsPointed (A + B) := inr (point B).
Definition IsPointed_or_introl {A B : Prop} `{IsPointed A} : IsPointed (A \/ B) := or_introl (point A).
Definition IsPointed_or_intror {A B : Prop} `{IsPointed B} : IsPointed (A \/ B) := or_intror (point B).

Instance IsPointed_if b {A B} `{IsPointed A, IsPointed B}
: IsPointed (if b then A else B)
  := if b as b return IsPointed (if b then A else B) then _ else _.


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

(* ************************************************************************

          Buchberger : multiplication over polynomials, definition of smult

          Laurent Thery March 98 (revised Avril 01)

   ************************************************************************ *)

From Buchberger Require Export Pmults.

Set Default Proof Using "Type".

Section Pmult.
Load hCoefStructure.
Load hOrderStructure.
Load hMults.

Fixpoint multpf (p : list (Term A n)) : list (Term A n) -> list (Term A n) :=
  fun q : list (Term A n) =>
  match p with
  | nil => pO A n
  | a :: p' =>
      pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
        (mults (A:=A) multA (n:=n) a q) (multpf p' q)
  end.

Theorem canonical_multpf :
 forall l1 l2 : list (Term A n),
 canonical A0 eqA ltM l1 ->
 canonical A0 eqA ltM l2 -> canonical A0 eqA ltM (multpf l1 l2).
Proof using os minusA invA divA cs A1.
intros l1; elim l1; simpl in |- *; auto.
intros a l H' l2 H'0 H'1; try assumption.
apply canonical_pluspf; auto.
apply canonical_mults with (1 := cs); auto.
apply canonical_nzeroP with (ltM := ltM) (p := l); auto.
apply H'; auto.
apply canonical_imp_canonical with (a := a); auto.
Qed.

Local Hint Resolve canonical_multpf : core.

Theorem pluspf_pX :
 forall (p : list (Term A n)) (a : Term A n),
 canonical A0 eqA ltM (pX a p) ->
 eqP A eqA n (pX a p)
   (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
      (pX a (pO A n)) p).
Proof using os multA minusA invA divA cs A1.
intros p; case p; clear p; auto.
intros a H;
 change
   (eqP A eqA n (pX a (pO A n))
      (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
         (pX a (pO A n)) (pO A n))) in |- *.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
intros a1 p a0 H'.
cut (canonical A0 eqA ltM (pX a1 p));
 [ intros Op0 | apply canonical_imp_canonical with (a := a0) ];
 auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pX a0
            (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec (pO A n) (pX a1 p))); auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
change
  (eqP A eqA n
     (pX a0
        (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
           (pO A n) (pX a1 p)))
     (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
        (pX a0 (pO A n)) (pX a1 p))) in |- *; auto.
apply pluspf_inv1 with (1 := cs); auto.
apply (canonical_pX_order _ A0 eqA) with (l := p); auto.
Qed.

Theorem multpf_disr_pX :
 forall (p q : list (Term A n)) (a : Term A n),
 canonical A0 eqA ltM p ->
 canonical A0 eqA ltM (pX a q) ->
 eqP A eqA n (multpf p (pX a q))
   (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
      (mults (A:=A) multA (n:=n) a p) (multpf p q)).
Proof using os minusA invA divA cs A1.
intros p; elim p; clear p; simpl in |- *; auto.
intros; apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
intros b p Rec q a Op0 Op1.
cut (canonical A0 eqA ltM q);
 [ intros Op2 | apply canonical_imp_canonical with (a := a) ];
 auto.
cut (canonical A0 eqA ltM p);
 [ intros Op3 | apply canonical_imp_canonical with (a := b) ];
 auto.
cut (~ zeroP (A:=A) A0 eqA (n:=n) a);
 [ intros nZ0 | apply canonical_nzeroP with (ltM := ltM) (p := q) ];
 auto.
cut (~ zeroP (A:=A) A0 eqA (n:=n) b);
 [ intros nZ1 | apply canonical_nzeroP with (ltM := ltM) (p := p) ];
 auto.
cut (~ zeroP (A:=A) A0 eqA (n:=n) (multTerm (A:=A) multA (n:=n) b a));
 [ intros nZ2 | idtac ]; auto.
cut (~ zeroP (A:=A) A0 eqA (n:=n) (multTerm (A:=A) multA (n:=n) a b));
 [ intros nZ3 | idtac ]; auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (pX (multTerm (A:=A) multA (n:=n) b a)
               (mults (A:=A) multA (n:=n) b q))
            (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec (mults (A:=A) multA (n:=n) a p)
               (multpf p q))); auto.
apply eqp_pluspf_com with (1 := cs); auto.
change (canonical A0 eqA ltM (mults (A:=A) multA (n:=n) b (pX a q))) in |- *;
 auto.
change (canonical A0 eqA ltM (mults (A:=A) multA (n:=n) b (pX a q))) in |- *;
 auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec (pX (multTerm (A:=A) multA (n:=n) b a) (pO A n))
               (mults (A:=A) multA (n:=n) b q))
            (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec (mults (A:=A) multA (n:=n) a p)
               (multpf p q))); auto.
cut
 (canonical A0 eqA ltM
    (pX (multTerm (A:=A) multA (n:=n) b a) (mults (A:=A) multA (n:=n) b q)));
 [ intros Op4 | idtac ]; auto.
apply eqp_pluspf_com with (1 := cs); auto.
apply pluspf_pX; auto.
change (canonical A0 eqA ltM (mults (A:=A) multA (n:=n) b (pX a q))) in |- *;
 auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (pX (multTerm (A:=A) multA (n:=n) b a) (pO A n))
            (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec (mults (A:=A) multA (n:=n) b q)
               (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
                  ltM_dec (mults (A:=A) multA (n:=n) a p)
                  (multpf p q)))); auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (pX (multTerm (A:=A) multA (n:=n) b a) (pO A n))
            (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec (mults (A:=A) multA (n:=n) b q)
               (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
                  ltM_dec (multpf p q) (mults (A:=A) multA (n:=n) a p))));
 auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (pX (multTerm (A:=A) multA (n:=n) b a) (pO A n))
            (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec
               (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
                  ltM_dec (mults (A:=A) multA (n:=n) b q)
                  (multpf p q)) (mults (A:=A) multA (n:=n) a p)));
 auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (pX (multTerm (A:=A) multA (n:=n) b a) (pO A n))
            (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec (mults (A:=A) multA (n:=n) a p)
               (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
                  ltM_dec (mults (A:=A) multA (n:=n) b q)
                  (multpf p q)))); auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec (pX (multTerm (A:=A) multA (n:=n) b a) (pO A n))
               (mults (A:=A) multA (n:=n) a p))
            (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec (mults (A:=A) multA (n:=n) b q)
               (multpf p q))); auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply eqp_pluspf_com with (1 := cs); auto.
change (canonical A0 eqA ltM (mults (A:=A) multA (n:=n) a (pX b p))) in |- *;
 auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (pX (multTerm (A:=A) multA (n:=n) a b) (pO A n))
            (mults (A:=A) multA (n:=n) a p)); auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply pluspf_pX; auto.
change (canonical A0 eqA ltM (mults (A:=A) multA (n:=n) a (pX b p))) in |- *;
 auto.
Qed.

Theorem multpf_head :
 forall (p q : list (Term A n)) (a b : Term A n),
 canonical A0 eqA ltM (pX a p) ->
 canonical A0 eqA ltM (pX b q) ->
 exists c : list (Term A n),
   multpf (pX a p) (pX b q) = pX (multTerm (A:=A) multA (n:=n) a b) c.
Proof using os.
intros p; elim p; clear p; auto.
simpl in |- *; intros q a b H' H'0.
cut (canonical A0 eqA ltM q);
 [ intros Op0 | apply canonical_imp_canonical with (a := b) ];
 auto.
exists (mults (A:=A) multA (n:=n) a q); simpl in |- *; auto.
rewrite <- pO_pluspf_inv2; auto.
intros a1 p H' q a0 b H'0 H'1; auto.
elim (H' q a1 b); simpl in |- *; [ intros c E | idtac | idtac ]; auto.
2: apply canonical_imp_canonical with (a := a0); auto.
rewrite E.
exists
 (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
    (mults (A:=A) multA (n:=n) a0 q)
    (pX (multTerm (A:=A) multA (n:=n) a1 b) c)); auto.
rewrite <- pluspf_inv1_eq; auto.
apply multTerm_ltT_r; auto.
apply (canonical_pX_order _ A0 eqA) with (l := p); auto.
Qed.

Theorem in_multpf_head :
 forall (p q : list (Term A n)) (a b : Term A n),
 canonical A0 eqA ltM (pX a p) ->
 canonical A0 eqA ltM (pX b q) ->
 In (multTerm (A:=A) multA (n:=n) a b) (multpf (pX a p) (pX b q)).
Proof using os.
intros p q a b H' H'0.
elim (multpf_head p q a b); [ intros c E; rewrite E | idtac | idtac ];
 simpl in |- *; auto.
Qed.

Theorem multpf_comp :
 forall p r : list (Term A n),
 eqP A eqA n p r ->
 forall q s : list (Term A n),
 canonical A0 eqA ltM p ->
 canonical A0 eqA ltM q ->
 canonical A0 eqA ltM r ->
 canonical A0 eqA ltM s ->
 eqP A eqA n q s -> eqP A eqA n (multpf p q) (multpf r s).
Proof using os minusA invA divA cs A1.
intros p r H'; elim H'; simpl in |- *; auto.
intros ma mb p0 q H'0 H'1 H'2 q0 s H'3 H'4 H'5 H'6 H'7.
cut (canonical A0 eqA ltM p0);
 [ intros Op0 | apply canonical_imp_canonical with (a := ma); auto ].
cut (canonical A0 eqA ltM q);
 [ intros Op1 | apply canonical_imp_canonical with (a := mb); auto ].
cut (~ zeroP (A:=A) A0 eqA (n:=n) ma);
 [ intros Z0 | apply canonical_nzeroP with (ltM := ltM) (p := p0); auto ].
cut (~ zeroP (A:=A) A0 eqA (n:=n) mb);
 [ intros Z1 | apply canonical_nzeroP with (ltM := ltM) (p := q) ];
 auto.
Qed.

Theorem multpf_com :
 forall p q : list (Term A n),
 canonical A0 eqA ltM p ->
 canonical A0 eqA ltM q -> eqP A eqA n (multpf p q) (multpf q p).
Proof using os minusA invA divA cs A1.
intros p; elim p; simpl in |- *; auto.
intros q; elim q; simpl in |- *; auto.
intros a l H' H'0 H'1.
cut (canonical A0 eqA ltM l);
 [ intros Op0 | apply canonical_imp_canonical with (a := a) ];
 auto.
cut (~ zeroP (A:=A) A0 eqA (n:=n) a);
 [ intros Z0 | apply canonical_nzeroP with (ltM := ltM) (p := l) ];
 auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (pO A n) (pO A n)); auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
intros a l H' q H'0 H'1.
cut (canonical A0 eqA ltM l);
 [ intros Op0 | apply canonical_imp_canonical with (a := a) ];
 auto.
cut (~ zeroP (A:=A) A0 eqA (n:=n) a);
 [ intros Z0 | apply canonical_nzeroP with (ltM := ltM) (p := l) ];
 auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (mults (A:=A) multA (n:=n) a q) (multpf q l));
 auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
change
  (eqP A eqA n (multpf q (pX a l))
     (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
        (mults (A:=A) multA (n:=n) a q) (multpf q l)))
 in |- *.
apply multpf_disr_pX; auto.
Qed.

Theorem multpf_dist_plusr :
 forall (p q r : list (Term A n)) (a : Term A n),
 canonical A0 eqA ltM p ->
 canonical A0 eqA ltM q ->
 canonical A0 eqA ltM r ->
 eqP A eqA n
   (multpf
      (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec p
         q) r)
   (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
      (multpf p r) (multpf q r)).
Proof using os minusA invA divA cs A1.
intros p q r; elim r.
intros H' H'0 H'1 H'2.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := multpf (pO A n)
            (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec p q)); auto.
apply multpf_com; auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (multpf (pO A n) p) (multpf (pO A n) q));
 auto.
simpl in |- *; apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply eqp_pluspf_com with (1 := cs); auto; apply multpf_com; auto.
intros a l H' H'0 H'1 H'2 H'3.
cut (~ zeroP (A:=A) A0 eqA (n:=n) a);
 [ intros nZ0 | apply canonical_nzeroP with (ltM := ltM) (p := l) ];
 auto.
cut (canonical A0 eqA ltM l);
 [ intros Op0 | apply canonical_imp_canonical with (a := a) ];
 auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (mults (A:=A) multA (n:=n) a
               (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
                  ltM_dec p q))
            (multpf
               (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
                  ltM_dec p q) l)); auto.
change
  (eqP A eqA n
     (multpf
        (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
           p q) (pX a l))
     (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
        (mults (A:=A) multA (n:=n) a
           (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
              ltM_dec p q))
        (multpf
           (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
              ltM_dec p q) l))) in |- *.
apply multpf_disr_pX; auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec (mults (A:=A) multA (n:=n) a p)
               (mults (A:=A) multA (n:=n) a q))
            (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec (multpf p l) (multpf q l)));
 auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (mults (A:=A) multA (n:=n) a p)
            (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec (mults (A:=A) multA (n:=n) a q)
               (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
                  ltM_dec (multpf p l) (multpf q l))));
 auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (mults (A:=A) multA (n:=n) a p)
            (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec
               (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
                  ltM_dec (mults (A:=A) multA (n:=n) a q)
                  (multpf p l)) (multpf q l))); auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (mults (A:=A) multA (n:=n) a p)
            (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec
               (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
                  ltM_dec (multpf p l) (mults (A:=A) multA (n:=n) a q))
               (multpf q l))); auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (mults (A:=A) multA (n:=n) a p)
            (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec (multpf p l)
               (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
                  ltM_dec (mults (A:=A) multA (n:=n) a q)
                  (multpf q l)))); auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec (mults (A:=A) multA (n:=n) a p)
               (multpf p l))
            (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec (mults (A:=A) multA (n:=n) a q)
               (multpf q l))); auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply eqp_pluspf_com with (1 := cs); auto.
change
  (eqP A eqA n
     (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
        (mults (A:=A) multA (n:=n) a p) (multpf p l))
     (multpf p (pX a l))) in |- *.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); apply multpf_disr_pX; auto.
change
  (eqP A eqA n
     (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
        (mults (A:=A) multA (n:=n) a q) (multpf q l))
     (multpf q (pX a l))) in |- *.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); apply multpf_disr_pX; auto.
Qed.

Theorem multpf_dist_plusl :
 forall (p q r : list (Term A n)) (a : Term A n),
 canonical A0 eqA ltM p ->
 canonical A0 eqA ltM q ->
 canonical A0 eqA ltM r ->
 eqP A eqA n
   (multpf p
      (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec q
         r))
   (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
      (multpf p q) (multpf p r)).
Proof using os minusA invA divA cs A1.
intros p q r H' H'0 H'1 H'2.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := multpf
            (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec q r) p); auto.
apply multpf_com; auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (multpf q p) (multpf r p)); auto.
apply multpf_dist_plusr; auto.
apply eqp_pluspf_com with (1 := cs); auto.
apply multpf_com; auto.
apply multpf_com; auto.
Qed.

Theorem multpf_smultm_assoc :
 forall (p q : list (Term A n)) (a : Term A n),
 canonical A0 eqA ltM p ->
 canonical A0 eqA ltM q ->
 ~ zeroP (A:=A) A0 eqA (n:=n) a ->
 eqP A eqA n (mults (A:=A) multA (n:=n) a (multpf p q))
   (multpf (mults (A:=A) multA (n:=n) a p) q).
Proof using os minusA invA divA cs A1.
intros p q a; elim p; simpl in |- *; auto.
intros a0 l H' H'0 H'1 H'2.
cut (~ zeroP (A:=A) A0 eqA (n:=n) a0);
 [ intros nZ0 | apply canonical_nzeroP with (ltM := ltM) (p := l) ];
 auto.
cut (canonical A0 eqA ltM l);
 [ intros Op0 | apply canonical_imp_canonical with (a := a0) ];
 auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (mults (A:=A) multA (n:=n) a (mults (A:=A) multA (n:=n) a0 q))
            (mults (A:=A) multA (n:=n) a (multpf l q)));
 auto.
apply eqp_pluspf_com with (1 := cs); auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
Qed.

Theorem multpf_assoc :
 forall p q r : list (Term A n),
 canonical A0 eqA ltM p ->
 canonical A0 eqA ltM q ->
 canonical A0 eqA ltM r ->
 eqP A eqA n (multpf p (multpf q r)) (multpf (multpf p q) r).
Proof using os minusA invA divA cs A1.
intros p q r; elim p; simpl in |- *; auto.
intros a l H' H'0 H'1 H'2.
cut (~ zeroP (A:=A) A0 eqA (n:=n) a);
 [ intros nZ0 | apply canonical_nzeroP with (ltM := ltM) (p := l) ];
 auto.
cut (canonical A0 eqA ltM l);
 [ intros Op0 | apply canonical_imp_canonical with (a := a) ];
 auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (multpf (mults (A:=A) multA (n:=n) a q) r)
            (multpf (multpf l q) r)); auto.
apply eqp_pluspf_com with (1 := cs); auto.
apply multpf_smultm_assoc; auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply multpf_dist_plusr; auto.
Qed.

Definition smult : poly A0 eqA ltM -> poly A0 eqA ltM -> poly A0 eqA ltM.
intros sp1 sp2.
case sp1; case sp2.
intros p1 H'1 p2 H'2; exists (multpf p1 p2); auto.
Defined.

End Pmult.


(*************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(*************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(*************************************************************)

Require Import List Arith Bool Lia Eqdep_dec.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils_tac utils_list utils_nat finite.

From Undecidability.Shared.Libs.DLW.Vec
  Require Import pos vec.

From Undecidability.TRAKHTENBROT
  Require Import notations fol_ops fo_sig utils fo_terms fo_logic fo_sat.

Import fol_notations.

Require Import Undecidability.Shared.ListAutomation.

Set Implicit Arguments.

(* * Converting functions symbols into relations symbols *)

Local Notation ø := vec_nil.

Section Sig_remove_symbols.

  Variable (Σ : fo_signature).

  (* map every term symbol to a relation symbols of +1 arity
      and add an (interpreted) equality *)

  Definition Σnosyms : fo_signature.
  Proof.
    exists Empty_set (unit + (syms Σ + rels Σ))%type.
    + intros [].
    + intros [ | [ s | r ] ].
      * exact 2.
      * exact (S (ar_syms _ s)).
      * exact (ar_rels _ r).
  Defined.

  Notation Σ' := Σnosyms.

  Let e : rels Σ' := inl tt.

  Local Definition fom_nosyms X : fo_model Σ X -> fo_model Σ' X.
  Proof.
    intros (F,R); split.
    + intros [].
    + intros [|[s|r]].
      * exact (rel2_on_vec eq).
      * exact (fun v => vec_head v = F _ (vec_tail v)).
      * exact (R r).
  Defined.

  Notation 𝕋 := (fol_term Σ).
  Notation 𝔽 := (fol_form Σ).

  Notation 𝕋' := (fol_term Σ').
  Notation 𝔽' := (fol_form Σ').

  Section removing_symbols_from_terms.

    Let f k (p : pos k) n : 𝕋' := match n with 0 => £ (pos2nat p) | S n => £ (n+1+k) end.

    Local Fixpoint fot_rem_syms (t : 𝕋) : 𝔽' :=
      match t with
        | in_var n   => @fol_atom Σ' e (£0##£(S n)##ø)
        | in_fot s v =>
            let A  := @fol_atom Σ' (inr (inl s)) (£(ar_syms _ s)##vec_set_pos (fun p => £ (pos2nat p))) in
            let wB := vec_set_pos (fun p => (fot_rem_syms (vec_pos v p))⦃f p⦄)
            in fol_mquant fol_ex (ar_syms _ s) (A ⟑ fol_vec_fa wB)
      end.

    Local Fact fot_rem_syms_fix0 n : fot_rem_syms (in_var n) = fol_atom e (£0##£(S n)##ø).
    Proof. trivial. Qed.

    Local Fact fot_rem_syms_fix1 s v :
                 fot_rem_syms (in_fot s v)
               = let A  := @fol_atom Σ' (inr (inl s)) (£(ar_syms _ s)##vec_set_pos (fun p => £ (pos2nat p))) in
                 let wB := vec_set_pos (fun p => (fot_rem_syms (vec_pos v p))⦃f p⦄)
                 in fol_mquant fol_ex (ar_syms _ s) (A ⟑ fol_vec_fa wB).
    Proof. trivial. Qed.

    Opaque fo_term_syms.

    Local Fact fot_rem_syms_rels t : incl (fol_rels (fot_rem_syms t)) (e::map (fun x => inr (inl x)) (fo_term_syms t)).
    Proof.
      induction t as [ n | s v IHv ].
      + rewrite fot_rem_syms_fix0; cbv; tauto.
      + rewrite fot_rem_syms_fix1; simpl.
        rewrite fol_rels_mquant; simpl.
        unfold fol_vec_fa.
        rewrite fol_rels_bigop.
        intros r; simpl.
        rewrite in_app_iff, in_map_iff, in_flat_map.
        intros [ <- | [ H | [] ] ]; auto.
        { right; exists s; auto; rew fot; simpl; auto. }
        revert H; intros (A & H1 & H2); revert H2.
        apply vec_list_inv in H1.
        destruct H1 as (p & ->); rew vec.
        rewrite fol_rels_subst.
        intros H; apply IHv in H; revert H.
        simpl; rewrite in_map_iff.
        intros [ <- | (s' & <- & Hs') ]; auto.
        right; exists s'; split; auto; rew fot.
        right; rewrite in_flat_map.
        exists (vec_pos v p); split; auto.
        apply in_vec_list, in_vec_pos.
    Qed.

    Local Fact fot_rem_syms_spec t X M φ ψ :
            (forall n, φ n = ψ (S n))
         -> ψ 0 = fo_term_sem M φ t
        <-> fol_sem (@fom_nosyms X M) ψ (fot_rem_syms t).
    Proof.
      revert X M φ ψ.
      induction t as [ n | s v IHv ]; intros X M phi psi H2.
      + destruct M as (re,sy); simpl; rewrite <- H2; tauto.
      + specialize (fun p => IHv p X M).
        rewrite fot_rem_syms_fix1.
        rewrite fol_sem_mexists.
        split.
        * intros H3.
          exists (vec_set_pos (fun p => fo_term_sem M phi (vec_pos v p))).
          destruct M as (sy,re); simpl; split.
          - simpl.
            replace (ar_syms _ s) with (0+ar_syms _ s) at 3 by lia.
            rewrite env_vlift_fix1; simpl; f_equal; rewrite H3; simpl; f_equal.
            apply vec_pos_ext; intros p; rew vec; rew fot.
            rewrite env_vlift_fix0; rew vec.
          - simpl.
            rewrite fol_sem_vec_fa; intros p.
            rew vec.
            rewrite fol_sem_subst.
            rewrite <- IHv; auto.
            2: reflexivity.
            simpl; rew fot.
            rewrite env_vlift_fix0; rew vec.
            apply fo_term_sem_ext; intros n Hn.
            replace (n+1+ar_syms _ s) with ((S n)+ar_syms _ s) by lia.
            rewrite env_vlift_fix1; auto.
        * intros (w & Hw1 & Hw2).
          destruct M as (sy,re); simpl.
          simpl in Hw1.
          replace (ar_syms _ s) with (0+ar_syms _ s) in Hw1 at 2 by lia.
          rewrite env_vlift_fix1 in Hw1.
          rewrite Hw1; clear Hw1.
          simpl; f_equal.
          apply vec_pos_ext; intros p; rew vec.
          rew fot.
          rewrite fol_sem_vec_fa in Hw2.
          specialize (Hw2 p); revert Hw2; rew vec; intros Hw2.
          rewrite fol_sem_subst in Hw2.
          rewrite <- IHv with (φ := phi) in Hw2; auto.
          intros n; simpl.
          replace (n+1+ar_syms _ s) with ((S n)+ar_syms _ s) by lia.
          rewrite env_vlift_fix1; auto.
    Qed.

  End removing_symbols_from_terms.

  Section and_now_from_formulas.

    Let f k (p : pos k) n : 𝕋' := match n with 0 => £ (pos2nat p) | S n => £ (n+k) end.

    Local Fixpoint fol_rem_syms A : 𝔽' :=
      match A with
        | ⊥               => ⊥
        | fol_atom r v    => let A  := @fol_atom Σ' (inr (inr r)) (vec_set_pos (fun p => £ (pos2nat p))) in
                             let wB := vec_set_pos (fun p => (fot_rem_syms (vec_pos v p))⦃f p⦄)
                             in  fol_mquant fol_ex (ar_rels _ r) (A ⟑ fol_vec_fa wB)
        | fol_bin c A B   => fol_bin c (fol_rem_syms A) (fol_rem_syms B)
        | fol_quant q A   => fol_quant q (fol_rem_syms A)
      end.

    Local Fact fol_rem_syms_rels A :
         incl (fol_rels (fol_rem_syms A))
              (e :: map (fun r => inr (inl r)) (fol_syms A)
                 ++ map (fun r => inr (inr r)) (fol_rels A)).
    Proof.
      induction A as [ | r v | b A IHA B IHB | q A IHA ].
      + cbv; tauto.
      + simpl.
        rewrite fol_rels_mquant; simpl.
        unfold fol_vec_fa.
        rewrite fol_rels_bigop.
        intros s; simpl; rewrite in_app_iff, in_flat_map, in_app_iff.
        intros [ <- | [ (A & H1 & H2) | [] ] ]; simpl; auto; revert H2.
        apply vec_list_inv in H1; destruct H1 as (p & ->); rew vec; intros H1.
        rewrite fol_rels_subst in H1.
        apply fot_rem_syms_rels in H1; simpl in H1.
        rewrite in_map_iff in H1.
        destruct H1 as [ | (s' & <- & H1) ]; auto.
        right; left; apply in_map_iff.
        exists s'; split; auto.
        apply in_flat_map.
        exists (vec_pos v p); split; auto.
        apply in_vec_list, in_vec_pos.
      + intros r; simpl.
        repeat rewrite map_app.
        repeat rewrite in_app_iff.
        intros [ H | H ].
        * apply IHA in H; revert H; simpl.
          rewrite in_app_iff; tauto.
        * apply IHB in H; revert H; simpl.
          rewrite in_app_iff; tauto.
      + intros r; simpl.
        repeat rewrite map_app.
        repeat rewrite in_app_iff.
        intros H; apply IHA in H; revert H.
        simpl; rewrite in_app_iff; tauto.
    Qed.

    Local Fact fol_rem_syms_spec A X M φ :
           fol_sem M φ A
       <-> fol_sem (@fom_nosyms X M) φ (fol_rem_syms A).
    Proof.
      revert φ.
      induction A as [ | r v | b A IHA B IHB | q A IHA ]; intros phi.
      + simpl; tauto.
      + simpl; rewrite fol_sem_mexists; split.
        * intros H; simpl in H |- *.
          exists (vec_map (fo_term_sem M phi) v); split.
          - revert H; apply fol_equiv_ext.
            unfold fom_nosyms; destruct M as (re,sy); simpl; f_equal.
            apply vec_pos_ext; intros p; rew vec; rew fot.
            rewrite env_vlift_fix0; rew vec.
          - rewrite fol_sem_vec_fa; intros p; rew vec.
            rewrite fol_sem_subst; simpl.
            rewrite <- fot_rem_syms_spec; auto.
            2: intro; reflexivity.
            simpl.
            rewrite env_vlift_fix0; rew vec.
            apply fo_term_sem_ext.
            intros; rewrite env_vlift_fix1; auto.
        * intros (w & Hw1 & Hw2); revert Hw1.
          simpl; apply fol_equiv_ext.
          unfold fom_nosyms; destruct M as (re,sy); simpl; f_equal.
          apply vec_pos_ext; intros p; rew vec; rew fot.
          rewrite env_vlift_fix0.
          rewrite fol_sem_vec_fa in Hw2.
          specialize (Hw2 p); revert Hw2; rew vec.
          rewrite fol_sem_subst, <- fot_rem_syms_spec; auto.
          2: intro; reflexivity.
          simpl; rewrite env_vlift_fix0.
          intros ->; apply fo_term_sem_ext.
          intros; rewrite env_vlift_fix1; auto.
      + simpl; apply fol_bin_sem_ext; auto.
      + simpl; apply fol_quant_sem_ext.
        intro; auto.
    Qed.

  End and_now_from_formulas.

  Variable (X : Type) (M : fo_model Σ' X)
           (HM : forall x y, fom_rels M e (x##y##ø) <-> x = y)  (* e is an interpreted equality *)
           .

  Local Definition fol_rel_fun (s : syms Σ) : 𝔽' :=
       let n := ar_syms _ s
       in ∀∀  fol_mquant fol_fa n (
             @fol_atom Σ' (inr (inl s)) (£(S n)##vec_set_pos (fun p => £(pos2nat p)))
                     ⤑ @fol_atom Σ' (inr (inl s)) (£n##vec_set_pos (fun p => £(pos2nat p)))
                     ⤑ @fol_atom Σ' e (£(S n)##£n##ø) ).

  Local Fact fol_rel_fun_spec s φ :
             fol_sem M φ (fol_rel_fun s)
         <-> graph_fun (fun v x => fom_rels M (inr (inl s)) (x##v)).
  Proof.
    unfold fol_rel_fun; simpl; split.
    + intros H v x y H1 H2.
      specialize (H x y).
      rewrite fol_sem_mforall in H.
      specialize (H v); simpl fol_sem in H.
      rewrite env_vlift_fix1 with (k := 1) in H.
      rewrite env_vlift_fix1 with (k := 0) in H.
      rewrite HM in H; simpl in H.
      apply H.
      * revert H1; apply fol_equiv_ext; do 2 f_equal.
        apply vec_pos_ext; intros p; rew vec; rew fot.
        rewrite env_vlift_fix0; auto.
      * revert H2; apply fol_equiv_ext; do 2 f_equal.
        apply vec_pos_ext; intros p; rew vec; rew fot.
        rewrite env_vlift_fix0; auto.
    + intros H x y.
      rewrite fol_sem_mforall; intros v.
      specialize (H v x y); simpl in H.
      simpl.
      rewrite env_vlift_fix1 with (k := 1).
      rewrite env_vlift_fix1 with (k := 0).
      rewrite HM; simpl.
      intros H1 H2; apply H.
      * revert H1; apply fol_equiv_ext; do 2 f_equal.
        apply vec_pos_ext; intros p; rew vec; rew fot.
        rewrite env_vlift_fix0; auto.
      * revert H2; apply fol_equiv_ext; do 2 f_equal.
        apply vec_pos_ext; intros p; rew vec; rew fot.
        rewrite env_vlift_fix0; auto.
  Qed.

  Local Definition fol_rel_tot (s : syms Σ) : 𝔽' :=
        let n := ar_syms _ s
        in fol_mquant fol_fa n (∃ @fol_atom Σ' (inr (inl s)) (£0##vec_set_pos (fun p => £(1+pos2nat p)))).

  Local Fact fol_rel_tot_spec s φ :
             fol_sem M φ (fol_rel_tot s)
         <-> graph_tot (fun v x => fom_rels M (inr (inl s)) (x##v)).
  Proof.
    unfold fol_rel_tot.
    rewrite fol_sem_mforall.
    apply forall_equiv; intros v; simpl.
    apply exists_equiv; intros x.
    apply fol_equiv_ext; do 2 f_equal.
    apply vec_pos_ext; intros p; rew vec; rew fot.
    simpl; rewrite env_vlift_fix0; auto.
  Qed.

  Local Definition fol_rels_are_functions ls :=
        fol_lconj (map (fun s => fol_rel_fun s ⟑ fol_rel_tot s) ls).

  Local Fact fol_rels_are_functions_spec ls φ :
             fol_sem M φ (fol_rels_are_functions ls)
         <-> forall s, In s ls -> is_graph_function (fun v x => fom_rels M (inr (inl s)) (x##v)).
  Proof.
    unfold fol_rels_are_functions.
    rewrite fol_sem_lconj; split.
    + intros H s Hs; red.
      rewrite <- fol_rel_tot_spec with (φ := φ).
      rewrite <- fol_rel_fun_spec with (φ := φ).
      apply (H (fol_rel_fun s ⟑ fol_rel_tot s)), in_map_iff.
      exists s; auto.
    + intros H B; rewrite in_map_iff.
      intros (s & <- & Hs); split.
      * apply fol_rel_fun_spec, H; auto.
      * apply fol_rel_tot_spec, H; auto.
  Qed.

  Definition Σsyms_Σnosyms ls A := fol_rels_are_functions ls ⟑ fol_rem_syms A.

End Sig_remove_symbols.

(* And now the reduction soundness and completeness results for Σsyms_Σnosyms
    The reduction is from FIN_DEC_DISCR_SAT to FIN_DEC_EQ_SAT *)

(* Soundess of Σsyms_Σnosyms *)

Theorem Σsyms_Σnosyms_sound Σ ls A X :
             fo_form_fin_discr_dec_SAT_in A X
          -> @fo_form_fin_dec_eq_SAT_in (Σnosyms Σ) (inl tt) eq_refl (Σsyms_Σnosyms ls A) X.
Proof.
  intros (H0 & M & H1 & H2 & phi & H3).
  exists (fom_nosyms M), H1; destruct M as (sy,re).
  exists.
  { intros [[]|[s|r]]; simpl.
    + intros; apply H0.
    + intros; apply H0.
    + intros; apply H2. }
  exists.
  { intros x y; cbv; tauto. }
  exists phi.
  unfold Σsyms_Σnosyms; split.
  + apply fol_rels_are_functions_spec; auto; simpl; try tauto.
    intros s Hs; split.
    * intros v x y; simpl; intros; subst; auto.
    * intros v; exists (sy s v); simpl; auto.
  + revert H3; apply fol_rem_syms_spec.
Qed.

(* Completeness of Σsyms_Σnosyms *)

Section completeness.

  Variable (Σ : fo_signature) (ls : list (syms Σ)) (A : fol_form Σ)
           (Hls : forall s, { In s ls } + { ~ In s ls })
           (HAls : incl (fol_syms A) ls).

  Notation Σ' := (Σnosyms Σ).

  Let e : rels Σ' := inl tt.

  Variable (X : Type).

  Section nested.

    Variable (M : fo_model Σ' X)
             (Xfin : finite_t X)
             (Mdec : fo_model_dec M)
             (He : forall x y, fom_rels M e (x##y##ø) <-> x = y)
             (φ : nat -> X)
             (HM : fol_sem M φ (Σsyms_Σnosyms ls A)).

    Let HF : forall s, In s ls -> is_graph_function (fun v x => fom_rels M (inr (inl s)) (x##v)).
    Proof.
      simpl in HM; apply proj1 in HM.
      rewrite fol_rels_are_functions_spec in HM; auto.
    Qed.

    Let HA : fol_sem M φ (fol_rem_syms A).
    Proof. simpl in HM; apply proj2 in HM; auto. Qed.

    Let F (s : syms Σ) : In s ls -> { f | forall v x, fom_rels M (inr (inl s)) (x##v) <-> x = f v }.
    Proof. intro; apply graph_tot_reif; auto. Qed.

    Local Definition Σsyms_Σnosyms_rev_model : fo_model Σ X.
    Proof.
      split.
      + intros s.
        destruct (Hls s) as [ H | H ].
        * exact (proj1_sig (F s H)).
        * exact (fun _ => φ 0).
      + intros r.
        exact (fom_rels M (inr (inr r))).
    Defined.

    Local Fact Σsyms_Σnosyms_complete_nested : fol_sem Σsyms_Σnosyms_rev_model φ A.
    Proof.
      apply fol_rem_syms_spec.
      revert HA.
      apply fo_model_projection' with (i := fun x => x) (j := fun x => x) (ls := nil)
             (lr := e :: map (fun r => inr (inl r)) (fol_syms A)
                      ++ map (fun r => inr (inr r)) (fol_rels A)); auto.
      + intros r v; simpl In; rewrite in_app_iff, in_map_iff, in_map_iff.
        intros [ <- | [ (s & <- & Hs) | (r' & <- & Hr') ] ]; simpl.
        * vec split v with x; vec split v with y; vec nil v; simpl.
          fold e; rewrite He; tauto.
        * destruct (Hls s) as [ H | H ]; try tauto.
          vec split v with x; simpl.
          rewrite <- (proj2_sig (F s H) v x).
          apply fol_equiv_ext; f_equal; f_equal.
          apply vec_pos_ext; intro; rew vec.
          destruct H; revert Hs; apply HAls.
        * apply fol_equiv_ext; f_equal; f_equal.
          apply vec_pos_ext; simpl; intros; rew vec.
          rewrite vec_pos_map; auto.
      + intros [].
      + apply fol_rem_syms_rels.
    Qed.

  End nested.

  Theorem Σsyms_Σnosyms_complete :
          @fo_form_fin_dec_eq_SAT_in (Σnosyms Σ) e eq_refl (Σsyms_Σnosyms ls A) X
       -> fo_form_fin_discr_dec_SAT_in A X.
  Proof.
    intros (M & H1 & H2 & H3 & phi & H5).
    cbn in H3.
    exists.
    { intros x y.
      generalize (H2 e (x##y##ø)).
      intros []; [ left | right ]; try red;
        rewrite <- H3; auto. }
    exists (Σsyms_Σnosyms_rev_model H1 H2 H3 H5).
    exists H1.
    exists. { intros r v; simpl; apply H2. }
    exists phi.
    apply Σsyms_Σnosyms_complete_nested.
  Qed.

End completeness.


(* Copyright 2006, 2008 Andrew W. Appel, Robert Dockins and Xavier Leroy
 * This file is part of the List-machine Benchmark.
 * The List-machine Benchmark is licensed under GPLv3; see LICENSE.
 *)

Require Import Maps.

(*** Machine specification ***)

(** Abstract syntax of machine code **)

Definition var: Set := positive.
Definition var_eq: forall (v1 v2: var), {v1=v2} + {v1<>v2} := peq.
Definition V (n: nat) : var := P_of_succ_nat n.

Definition label: Set := positive.
Definition label_eq: forall (l1 l2: label), {l1=l2} + {l1<>l2} := peq.
Definition L (n: nat) : label := P_of_succ_nat n.

Inductive instr: Set :=
  | instr_jump: var -> instr
  | instr_getlabel: label -> var -> instr
  | instr_branch_if_nil: var -> label -> instr
  | instr_fetch_field: var -> nat -> var -> instr
  | instr_cons: var -> var -> var -> instr
  | instr_halt: instr
  | instr_seq: instr -> instr -> instr.

Infix ";;" := instr_seq (at level 60, right associativity).

Definition program := map instr.

(** Run-time values and environments **)

Inductive value: Set :=
  | value_label: label -> value
  | value_cons: value -> value -> value.

Definition store := map value.
Definition store_empty : store := empty value.

(** Execution of machine code **)

Inductive step: program -> store -> instr -> store -> instr -> Prop :=

  | step_seq: forall p r i1 i2 i3,
    (*----------------------------------------------------*)
      step p r ((i1 ;; i2) ;; i3) r (i1 ;; i2 ;; i3)

  | step_fetch_field_0: forall p r v1 v2 i a0 a1,
      r#v1 = Some (value_cons a0 a1) ->
    (*----------------------------------------------------*)
      step p r (instr_fetch_field v1 0 v2 ;; i) (r#v2 <- a0) i

  | step_fetch_field_1: forall p r v1 v2 i a0 a1,
      r#v1 = Some (value_cons a0 a1) ->
    (*----------------------------------------------------*)
      step p r (instr_fetch_field v1 1 v2 ;; i) (r#v2 <- a1) i

  | step_cons: forall p r v1 v2 v3 i a1 a2,
      r#v1 = Some a1 ->
      r#v2 = Some a2 ->
    (*----------------------------------------------------*)
      step p r (instr_cons v1 v2 v3 ;; i) (r#v3 <- (value_cons a1 a2)) i

  | step_branch_not_taken: forall p r v l i a1 a2,
      r#v = Some (value_cons a1 a2) ->
    (*----------------------------------------------------*)
      step p r (instr_branch_if_nil v l ;; i) r i

  | step_branch_taken: forall p r v l i i',
      r#v = Some (value_label (L 0)) ->
      p#l = Some i' ->
    (*----------------------------------------------------*)
      step p r (instr_branch_if_nil v l ;; i) r i'

  | step_jump: forall p r v l i',
      r#v = Some (value_label l) ->
      p#l = Some i' ->
    (*----------------------------------------------------*)
      step p r (instr_jump v) r i'

   | step_getlabel: forall p r l v i,
    (*----------------------------------------------------*)
      step p r (instr_getlabel l v ;; i) (r#v <- (value_label l)) i.

(* Safety property *)

Definition entry_label := L 0.

Definition start_state (p: program) (s: store) (i: instr) :=
         p#entry_label = Some i.

Inductive stepstar (p: program) : store -> instr -> store -> instr ->  Prop :=
 | stepstar_O: forall s i, stepstar p s i s i
 | stepstar_S: forall s i s' i' s'' i'',
              step p s i s' i' -> stepstar p s' i' s'' i'' -> stepstar p s i s'' i''.

Inductive step_or_halt: program -> store -> instr -> Prop :=
  | step_or_halt_step: forall p r i r' i',
      step p r i r' i' -> step_or_halt p r i
  | step_or_halt_halt: forall p r,
      step_or_halt p r instr_halt.

Definition safe (p: program) (s: store) (i: instr) :=
   forall s' i', stepstar p s i s' i' -> step_or_halt p s' i'.

Definition safe_prog (p: program) := forall s i, start_state p s i -> safe p s i.

Inductive stepN (p: program) : nat -> store -> instr -> store -> instr ->  Prop :=
 | stepN_O: forall s i, stepN p O s i s i
 | stepN_S: forall n s i s' i' s'' i'',
              step p s i s' i' -> stepN p n s' i' s'' i'' -> stepN p (S n) s i s'' i''.

Lemma stepstar_stepN : forall p s i s' i',
  stepstar p s i s' i' ->
  exists n, stepN p n s i s' i'.

  intros p s i s' i' H; induction H.
  exists 0; apply stepN_O.
  destruct IHstepstar as [n Hn].
  exists (S n).
  eapply stepN_S.
  apply H.
  apply Hn.
 Qed.

Lemma stepN_stepstar : forall p n s i s' i',
  stepN p n s i s' i' ->
  stepstar p s i s' i'.

  intros p n s i s' i' H; induction H.
  apply stepstar_O.
  eapply stepstar_S.
  apply H.
  apply IHstepN.
 Qed.

Lemma step_deterministic : forall p s i s1 s2 i1 i2,
  step p s i s1 i1 ->
  step p s i s2 i2 ->
  s1 = s2 /\ i1 = i2.

  intros p s i s1 s2 i1 i2 H1 H2.
  inversion H1; subst; inversion H2; subst;
     intuition congruence.
 Qed.

Lemma step_confluent : forall p n s s1 s2 s' i i1 i2 i',
  step p s i s1 i1 ->
  step p s i s2 i2 ->
  stepN p n s1 i1 s' i' ->
  stepN p n s2 i2 s' i'.

 intros p n s s1 s2 s' i i1 i2 i' H1 H2 H3.
 generalize (step_deterministic _ _ _ _ _ _ _ H1 H2).
 intuition; subst; auto.
 Qed.

Lemma step_triangle : forall p n1 n2 s s1 s2 i i1 i2,
  n1 <= n2 ->
  stepN p n1 s i s1 i1 ->
  stepN p n2 s i s2 i2 ->
  stepN p (n2 - n1) s1 i1 s2 i2.

  intros p n1; induction n1; simpl; intros.
  inversion H0; subst; clear H0.
  replace (n2 -0) with n2; [ auto | omega ].
  inversion H0; subst; clear H0.
  destruct n2; simpl in *.
  inversion H.
  eapply IHn1.
  omega.
  apply H4.
  inversion H1; subst; clear H1.
  destruct (step_deterministic p s i s' s'0 i' i'0); auto.
  rewrite H0; rewrite H1; auto.
 Qed.


(* The prebicategory of types, functions and homotopy *)
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.DisplayedCatToBicat.

Require Import Integers.Prebicategories.DispPrebicat.

Local Open Scope cat.
Local Open Scope bicategory_scope.
Local Open Scope mor_disp_scope.

Definition type_prebicat_data : prebicat_data.
Proof.
  use build_prebicat_data.
  - exact Type.
  - exact (λ X Y, X → Y).
  - exact (λ A B f g, f ~ g).
  - exact idfun.
  - exact (λ A B Z, funcomp).
  - exact (λ A B f, homotrefl f).
  - exact (λ A B f g h θ γ, homotcomp θ γ).
  - exact (λ A B C f g h θ, funhomotsec f θ).
  - exact (λ A B C f g h θ, homotfun θ h).
  - exact (λ A B f x, idpath (f x)).
  - exact (λ A B f x, idpath (f x)).
  - exact (λ A B f x, idpath (f x)).
  - exact (λ A B f x, idpath (f x)).
  - exact (λ A B C D f g h x, idpath (h (g (f x)))).
  - exact (λ A B C D f g h x, idpath (h (g (f x)))).
Defined.

Definition type_prebicat_laws : prebicat_laws type_prebicat_data.
Proof.
  repeat (use tpair).
  - exact (λ A B f g θ, idpath θ).
  - intros A B f g θ.
    apply funextsec.
    exact (λ x, pathscomp0rid (θ x)).
  - intros A B f g h k θ γ τ.
    apply funextsec.
    exact (λ x, path_assoc (θ x) (γ x) (τ x)).
  - exact (λ A B C f g, idpath _).
  - exact (λ A B C f g, idpath _).
  - intros A B C f g h k θ γ.
    apply funextsec.
    exact (λ x, idpath (θ (f x) @ γ (f x))).
  - intros A B C f g h k θ γ.
    apply funextsec.
    exact (λ x, !maponpathscomp0 k (θ x) (γ x)).
  - intros A B f g θ.
    apply funextsec.
    exact (λ x, pathscomp0rid (θ x)).
  - intros A B f g θ.
    apply funextsec.
    exact (λ x, pathscomp0rid _ @ maponpathsidfun _).
  - intros A B C D f g h i θ.
    apply funextsec.
    exact (λ x, pathscomp0rid (θ (g (f x)))).
  - intros A B C D f g h i θ.
    apply funextsec.
    exact (λ x, pathscomp0rid _).
  - intros A B C D f g h i θ.
    apply funextsec.
    exact (λ x, maponpathscomp h _ _ @ ! pathscomp0rid _).
  - intros A B C f g h i θ γ.
    apply funextsec.
    exact (λ x, homotsec_natural γ (θ x)).
  - exact (λ A B f, idpath _).
  - exact (λ A B f, idpath _).
  - exact (λ A B f, idpath _).
  - exact (λ A B f, idpath _).
  - exact (λ A B C D f g h, idpath _).
  - exact (λ A B C D f g h, idpath _).
  - exact (λ A B C f g, idpath _).
  - exact (λ A B C D E f g h i, idpath _).
Qed.

Definition type_prebicat : prebicat
  := type_prebicat_data,, type_prebicat_laws.

Definition type_prebicat_invertible_2cell
      {A B : type_prebicat}
      {f g : A --> B}
      {θ : f ==> g}
  : is_invertible_2cell θ
  := invhomot θ,, funextsec _ _ _ (λ x, pathsinv0r (θ x)),, funextsec _ _ _ (λ x, pathsinv0l (θ x)).


(* (c) Copyright 2006-2016 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq path.
From mathcomp Require Import div choice fintype tuple finfun bigop prime.
From mathcomp Require Import ssralg poly finset fingroup finalg zmodp cyclic.
From mathcomp Require Import ssrnum ssrint polydiv rat intdiv mxpoly.
From mathcomp Require Import vector falgebra fieldext separable galois algC.

(******************************************************************************)
(* This file provides few basic properties of cyclotomic polynomials.         *)
(* We define:                                                                 *)
(*   cyclotomic z n == the factorization of the nth cyclotomic polynomial in  *)
(*                     a ring R in which z is an nth primitive root of unity. *)
(*           'Phi_n == the nth cyclotomic polynomial in int.                  *)
(* This library is quite limited, and should be extended in the future. In    *)
(* particular the irreducibity of 'Phi_n is only stated indirectly, as the    *)
(* fact that its embedding in the algebraics (algC) is the minimal polynomial *)
(* of an nth primitive root of unity.                                         *)
(******************************************************************************)

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

Import GRing.Theory Num.Theory.
Local Open Scope ring_scope.

Section CyclotomicPoly.

Section Ring.

Variable R : ringType.

Definition cyclotomic (z : R) n :=
  \prod_(k < n | coprime k n) ('X - (z ^+ k)%:P).

Lemma cyclotomic_monic z n : cyclotomic z n \is monic.
Proof. exact: monic_prod_XsubC. Qed.

Lemma size_cyclotomic z n : size (cyclotomic z n) = (totient n).+1.
Proof.
rewrite /cyclotomic -big_filter size_prod_XsubC; congr _.+1.
case: big_enumP => _ _ _ [_ ->].
rewrite totient_count_coprime -big_mkcond big_mkord -sum1_card.
by apply: eq_bigl => k; rewrite coprime_sym.
Qed.

End Ring.

Lemma separable_Xn_sub_1 (R : idomainType) n :
  n%:R != 0 :> R -> @separable_poly R ('X^n - 1).
Proof.
case: n => [/eqP// | n nz_n]; rewrite /separable_poly linearB /= derivC subr0.
rewrite derivXn -scaler_nat coprimepZr //= exprS -scaleN1r coprimep_sym.
by rewrite coprimep_addl_mul coprimepZr ?coprimep1 // (signr_eq0 _ 1).
Qed.

Section Field.

Variables (F : fieldType) (n : nat) (z : F).
Hypothesis prim_z : n.-primitive_root z.
Let n_gt0 := prim_order_gt0 prim_z.

Lemma root_cyclotomic x : root (cyclotomic z n) x = n.-primitive_root x.
Proof.
transitivity (x \in [seq z ^+ i | i : 'I_n in [pred i : 'I_n | coprime i n]]).
  by rewrite -root_prod_XsubC big_image.
apply/imageP/idP=> [[k co_k_n ->] | prim_x].
  by rewrite prim_root_exp_coprime.
have [k Dx] := prim_rootP prim_z (prim_expr_order prim_x).
exists (Ordinal (ltn_pmod k n_gt0)) => /=; last by rewrite prim_expr_mod.
by rewrite inE coprime_modl -(prim_root_exp_coprime k prim_z) -Dx.
Qed.

Lemma prod_cyclotomic :
  'X^n - 1 = \prod_(d <- divisors n) cyclotomic (z ^+ (n %/ d)) d.
Proof.
have in_d d: (d %| n)%N -> val (@inord n d) = d by move/dvdn_leq/inordK=> /= ->.
have dv_n k: (n %/ gcdn k n %| n)%N.
  by rewrite -{3}(divnK (dvdn_gcdr k n)) dvdn_mulr.
have [uDn _ inDn] := divisors_correct n_gt0.
have defDn: divisors n = map val (map (@inord n) (divisors n)).
  by rewrite -map_comp map_id_in // => d; rewrite inDn => /in_d.
rewrite defDn big_map big_uniq /=; last first.
  by rewrite -(map_inj_uniq val_inj) -defDn.
pose h (k : 'I_n) : 'I_n.+1 := inord (n %/ gcdn k n).
rewrite -(factor_Xn_sub_1 prim_z) big_mkord.
rewrite (partition_big h (dvdn^~ n)) /= => [|k _]; last by rewrite in_d ?dv_n.
apply: eq_big => d; first by rewrite -(mem_map val_inj) -defDn inDn.
set q := (n %/ d)%N => d_dv_n.
have [q_gt0 d_gt0]: (0 < q /\ 0 < d)%N by apply/andP; rewrite -muln_gt0 divnK.
have fP (k : 'I_d): (q * k < n)%N by rewrite divn_mulAC ?ltn_divLR ?ltn_pmul2l.
rewrite (reindex (fun k => Ordinal (fP k))); last first.
  have f'P (k : 'I_n): (k %/ q < d)%N by rewrite ltn_divLR // mulnC divnK.
  exists (fun k => Ordinal (f'P k)) => [k _ | k /eqnP/=].
    by apply: val_inj; rewrite /= mulKn.
  rewrite in_d // => Dd; apply: val_inj; rewrite /= mulnC divnK // /q -Dd.
  by rewrite divnA ?mulKn ?dvdn_gcdl ?dvdn_gcdr.
apply: eq_big => k; rewrite ?exprM // -val_eqE in_d //=.
rewrite -eqn_mul ?dvdn_gcdr ?gcdn_gt0 ?n_gt0 ?orbT //.
rewrite -[n in gcdn _ n](divnK d_dv_n) -muln_gcdr mulnCA mulnA divnK //.
by rewrite mulnC eqn_mul // divnn n_gt0 eq_sym.
Qed.

End Field.

End CyclotomicPoly.

Local Notation ZtoQ := (intr : int -> rat).
Local Notation ZtoC := (intr : int -> algC).
Local Notation QtoC := (ratr : rat -> algC).

Local Notation intrp := (map_poly intr).
Local Notation pZtoQ := (map_poly ZtoQ).
Local Notation pZtoC := (map_poly ZtoC).
Local Notation pQtoC := (map_poly ratr).

Local Definition algC_intr_inj := @intr_inj [numDomainType of algC].
#[local] Hint Resolve algC_intr_inj : core.
Local Notation QtoC_M := (ratr_rmorphism [numFieldType of algC]).

Lemma C_prim_root_exists n : (n > 0)%N -> {z : algC | n.-primitive_root z}.
Proof.
pose p : {poly algC} := 'X^n - 1; have [r Dp] := closed_field_poly_normal p.
move=> n_gt0; apply/sigW; rewrite (monicP _) ?monic_Xn_sub_1 // scale1r in Dp.
have rn1: all n.-unity_root r by apply/allP=> z; rewrite -root_prod_XsubC -Dp.
have sz_r: (n < (size r).+1)%N.
  by rewrite -(size_prod_XsubC r id) -Dp size_Xn_sub_1.
have [|z] := hasP (has_prim_root n_gt0 rn1 _ sz_r); last by exists z.
by rewrite -separable_prod_XsubC -Dp separable_Xn_sub_1 // pnatr_eq0 -lt0n.
Qed.

(* (Integral) Cyclotomic polynomials. *)

Definition Cyclotomic n : {poly int} :=
  let: exist z _ := C_prim_root_exists (ltn0Sn n.-1) in
  map_poly floorC (cyclotomic z n).

Notation "''Phi_' n" := (Cyclotomic n)
  (at level 8, n at level 2, format "''Phi_' n").

Lemma Cyclotomic_monic n : 'Phi_n \is monic.
Proof.
rewrite /'Phi_n; case: (C_prim_root_exists _) => z /= _.
rewrite monicE lead_coefE coef_map_id0 ?(int_algC_K 0) ?getCint0 //.
by rewrite size_poly_eq -lead_coefE (monicP (cyclotomic_monic _ _)) (intCK 1).
Qed.

Lemma Cintr_Cyclotomic n z :
  n.-primitive_root z -> pZtoC 'Phi_n = cyclotomic z n.
Proof.
elim/ltn_ind: n z => n IHn z0 prim_z0.
rewrite /'Phi_n; case: (C_prim_root_exists _) => z /=.
have n_gt0 := prim_order_gt0 prim_z0; rewrite prednK // => prim_z.
have [uDn _ inDn] := divisors_correct n_gt0.
pose q := \prod_(d <- rem n (divisors n)) 'Phi_d.
have mon_q: q \is monic by apply: monic_prod => d _; apply: Cyclotomic_monic.
have defXn1: cyclotomic z n * pZtoC q = 'X^n - 1.
  rewrite (prod_cyclotomic prim_z) (big_rem n) ?inDn //=.
  rewrite divnn n_gt0 rmorph_prod /=; congr (_ * _).
  apply: eq_big_seq => d; rewrite mem_rem_uniq ?inE //= inDn => /andP[n'd ddvn].
  by rewrite -IHn ?dvdn_prim_root // ltn_neqAle n'd dvdn_leq.
have mapXn1 (R1 R2 : ringType) (f : {rmorphism R1 -> R2}):
  map_poly f ('X^n - 1) = 'X^n - 1.
- by rewrite rmorphB /= rmorph1 map_polyXn.
have nz_q: pZtoC q != 0.
  by rewrite -size_poly_eq0 size_map_inj_poly // size_poly_eq0 monic_neq0.
have [r def_zn]: exists r, cyclotomic z n = pZtoC r.
  have defZtoC: ZtoC =1 QtoC \o ZtoQ by move=> a; rewrite /= rmorph_int.
  have /dvdpP[r0 Dr0]: map_poly ZtoQ q %| 'X^n - 1.
    rewrite -(dvdp_map QtoC_M) mapXn1 -map_poly_comp.
    by rewrite -(eq_map_poly defZtoC) -defXn1 dvdp_mull.
  have [r [a nz_a Dr]] := rat_poly_scale r0.
  exists (zprimitive r); apply: (mulIf nz_q); rewrite defXn1.
  rewrite -rmorphM -(zprimitive_monic mon_q) -zprimitiveM /=.
  have ->: r * q = a *: ('X^n - 1).
    apply: (map_inj_poly (intr_inj : injective ZtoQ)) => //.
    rewrite map_polyZ mapXn1 Dr0 Dr -scalerAl scalerKV ?intr_eq0 //.
    by rewrite rmorphM.
  by rewrite zprimitiveZ // zprimitive_monic ?monic_Xn_sub_1 ?mapXn1.
rewrite floorCpK; last by apply/polyOverP=> i; rewrite def_zn coef_map Cint_int.
pose f e (k : 'I_n) := Ordinal (ltn_pmod (k * e) n_gt0).
have [e Dz0] := prim_rootP prim_z (prim_expr_order prim_z0).
have co_e_n: coprime e n by rewrite -(prim_root_exp_coprime e prim_z) -Dz0.
have injf: injective (f e).
  apply: can_inj (f (egcdn e n).1) _ => k; apply: val_inj => /=.
  rewrite modnMml -mulnA -modnMmr -{1}(mul1n e).
  by rewrite (chinese_modr co_e_n 0) modnMmr muln1 modn_small.
rewrite [_ n](reindex_inj injf); apply: eq_big => k /=.
  by rewrite coprime_modl coprimeMl co_e_n andbT.
by rewrite prim_expr_mod // mulnC exprM -Dz0.
Qed.

Lemma prod_Cyclotomic n :
  (n > 0)%N -> \prod_(d <- divisors n) 'Phi_d = 'X^n - 1.
Proof.
move=> n_gt0; have [z prim_z] := C_prim_root_exists n_gt0.
apply: (map_inj_poly (intr_inj : injective ZtoC)) => //.
rewrite rmorphB rmorph1 rmorph_prod /= map_polyXn (prod_cyclotomic prim_z).
apply: eq_big_seq => d; rewrite -dvdn_divisors // => d_dv_n.
by rewrite -Cintr_Cyclotomic ?dvdn_prim_root.
Qed.

Lemma Cyclotomic0 : 'Phi_0 = 1.
Proof.
rewrite /'Phi_0; case: (C_prim_root_exists _) => z /= _.
by rewrite -[1]polyseqK /cyclotomic big_ord0 map_polyE !polyseq1 /= (intCK 1).
Qed.

Lemma size_Cyclotomic n : size 'Phi_n = (totient n).+1.
Proof.
have [-> | n_gt0] := posnP n; first by rewrite Cyclotomic0 polyseq1.
have [z prim_z] := C_prim_root_exists n_gt0.
rewrite -(size_map_inj_poly (can_inj intCK)) //.
by rewrite (Cintr_Cyclotomic prim_z) size_cyclotomic.
Qed.

Lemma minCpoly_cyclotomic n z :
  n.-primitive_root z -> minCpoly z = cyclotomic z n.
Proof.
move=> prim_z; have n_gt0 := prim_order_gt0 prim_z.
have Dpz := Cintr_Cyclotomic prim_z; set pz := cyclotomic z n in Dpz *.
have mon_pz: pz \is monic by apply: cyclotomic_monic.
have pz0: root pz z by rewrite root_cyclotomic.
have [pf [Dpf mon_pf] dv_pf] := minCpolyP z.
have /dvdpP_rat_int[f [af nz_af Df] [g /esym Dfg]]: pf %| pZtoQ 'Phi_n.
  rewrite -dv_pf; congr (root _ z): pz0; rewrite -Dpz -map_poly_comp.
  by apply: eq_map_poly => b; rewrite /= rmorph_int.
without loss{nz_af} [mon_f mon_g]: af f g Df Dfg / f \is monic /\ g \is monic.
  move=> IH; pose cf := lead_coef f; pose cg := lead_coef g.
  have cfg1: cf * cg = 1.
    by rewrite -lead_coefM Dfg (monicP (Cyclotomic_monic n)).
  apply: (IH (af *~ cf) (f *~ cg) (g *~ cf)).
  - by rewrite rmorphMz -scalerMzr scalerMzl -mulrzA cfg1.
  - by rewrite mulrzAl mulrzAr -mulrzA cfg1.
  by rewrite !(intz, =^~ scaler_int) !monicE !lead_coefZ mulrC cfg1.
have{af} Df: pQtoC pf = pZtoC f.
  have:= congr1 lead_coef Df.
  rewrite lead_coefZ lead_coef_map_inj //; last exact: intr_inj.
  rewrite !(monicP _) // mulr1 Df => <-; rewrite scale1r -map_poly_comp.
  by apply: eq_map_poly => b; rewrite /= rmorph_int.
have [/size1_polyC Dg | g_gt1] := leqP (size g) 1.
  rewrite monicE Dg lead_coefC in mon_g.
  by rewrite -Dpz -Dfg Dg (eqP mon_g) mulr1 Dpf.
have [zk gzk0]: exists zk, root (pZtoC g) zk.
  have [rg] := closed_field_poly_normal (pZtoC g).
  rewrite lead_coef_map_inj // (monicP mon_g) scale1r => Dg.
  rewrite -(size_map_inj_poly (can_inj intCK)) // Dg in g_gt1.
  rewrite size_prod_XsubC in g_gt1.
  by exists rg`_0; rewrite Dg root_prod_XsubC mem_nth.
have [k cokn Dzk]: exists2 k, coprime k n & zk = z ^+ k.
  have: root pz zk by rewrite -Dpz -Dfg rmorphM rootM gzk0 orbT.
  rewrite -[pz](big_image _ _ _ (fun r => 'X - r%:P)) root_prod_XsubC.
  by case/imageP=> k; exists k.
have co_fg (R : idomainType): n%:R != 0 :> R -> @coprimep R (intrp f) (intrp g).
  move=> nz_n; have: separable_poly (intrp ('X^n - 1) : {poly R}).
    by rewrite rmorphB rmorph1 /= map_polyXn separable_Xn_sub_1.
  rewrite -prod_Cyclotomic // (big_rem n) -?dvdn_divisors //= -Dfg.
  by rewrite !rmorphM /= !separable_mul => /and3P[] /and3P[].
suffices fzk0: root (pZtoC f) zk.
  have [] // := negP (coprimep_root (co_fg _ _) fzk0).
  by rewrite pnatr_eq0 -lt0n.
move: gzk0 cokn; rewrite {zk}Dzk; elim/ltn_ind: k => k IHk gzk0 cokn.
have [|k_gt1] := leqP k 1; last have [p p_pr /dvdnP[k1 Dk]] := pdivP k_gt1.
  rewrite -[leq k 1](mem_iota 0 2) !inE => /pred2P[k0 | ->]; last first.
    by rewrite -Df dv_pf.
  have /eqP := size_Cyclotomic n; rewrite -Dfg size_Mmonic ?monic_neq0 //.
  rewrite k0 /coprime gcd0n in cokn; rewrite (eqP cokn).
  rewrite -(size_map_inj_poly (can_inj intCK)) // -Df -Dpf.
  by rewrite -(subnKC g_gt1) -(subnKC (size_minCpoly z)) !addnS.
move: cokn; rewrite Dk coprimeMl => /andP[cok1n].
rewrite prime_coprime // (dvdn_charf (char_Fp p_pr)) => /co_fg {co_fg}.
have charFpX: p \in [char {poly 'F_p}].
  by rewrite (rmorph_char (polyC_rmorphism _)) ?char_Fp.
rewrite -(coprimep_pexpr _ _ (prime_gt0 p_pr)) -(Frobenius_autE charFpX).
rewrite -[g]comp_polyXr map_comp_poly -horner_map /= Frobenius_autE -rmorphX.
rewrite -!map_poly_comp (@eq_map_poly _ _ _ (polyC \o *~%R 1)); last first.
  by move=> a; rewrite /= !rmorph_int.
rewrite map_poly_comp -[_.[_]]map_comp_poly /= => co_fg.
suffices: coprimep (pZtoC f) (pZtoC (g \Po 'X^p)).
  move/coprimep_root=> /=/(_ (z ^+ k1))/implyP.
  rewrite map_comp_poly map_polyXn horner_comp hornerXn.
  rewrite -exprM -Dk [_ == 0]gzk0 implybF => /negP[].
  have: root pz (z ^+ k1).
    by rewrite root_cyclotomic // prim_root_exp_coprime.
  rewrite -Dpz -Dfg rmorphM rootM => /orP[] //= /IHk-> //.
  rewrite -[k1]muln1 Dk ltn_pmul2l ?prime_gt1 //.
  by have:= ltnW k_gt1; rewrite Dk muln_gt0 => /andP[].
suffices: coprimep f (g \Po 'X^p).
  case/Bezout_coprimepP=> [[u v]]; rewrite -size_poly_eq1.
  rewrite -(size_map_inj_poly (can_inj intCK)) // rmorphD !rmorphM /=.
  rewrite size_poly_eq1 => {}co_fg; apply/Bezout_coprimepP.
  by exists (pZtoC u, pZtoC v).
apply: contraLR co_fg => /coprimepPn[|d]; first exact: monic_neq0.
rewrite andbC -size_poly_eq1 dvdp_gcd => /and3P[sz_d].
pose d1 := zprimitive d.
have d_dv_mon h: d %| h -> h \is monic -> exists h1, h = d1 * h1.
  case/Pdiv.Idomain.dvdpP=> [[c h1] /= nz_c Dh] mon_h; exists (zprimitive h1).
  by rewrite -zprimitiveM mulrC -Dh zprimitiveZ ?zprimitive_monic.
case/d_dv_mon=> // f1 Df1 /d_dv_mon[|f2 ->].
  rewrite monicE lead_coefE size_comp_poly size_polyXn /=.
  rewrite comp_polyE coef_sum polySpred ?monic_neq0 //= mulnC.
  rewrite big_ord_recr /= -lead_coefE (monicP mon_g) scale1r.
  rewrite -exprM coefXn eqxx big1 ?add0r // => i _.
  rewrite coefZ -exprM coefXn eqn_pmul2l ?prime_gt0 //.
  by rewrite eqn_leq leqNgt ltn_ord mulr0.
have monFp h: h \is monic -> size (map_poly intr h) = size h.
  by move=> mon_h; rewrite size_poly_eq // -lead_coefE (monicP mon_h) oner_eq0.
apply/coprimepPn; last exists (map_poly intr d1).
  by rewrite -size_poly_eq0 monFp // size_poly_eq0 monic_neq0.
rewrite Df1 !rmorphM dvdp_gcd !dvdp_mulr //= -size_poly_eq1.
rewrite monFp ?size_zprimitive //.
rewrite monicE [_ d1]intEsg sgz_lead_primitive -zprimitive_eq0 -/d1.
rewrite -lead_coef_eq0 -absz_eq0.
have/esym/eqP := congr1 (absz \o lead_coef) Df1.
by rewrite /= (monicP mon_f) lead_coefM abszM muln_eq1 => /andP[/eqP-> _].
Qed.