(** * Lógica em Coq *)

Set Warnings "-notation-overridden,-parsing".
Require Export aula08_taticas.

(* ############################################### *)
(** * Lógica em Coq *)

(** Em Coq, toda expressão possui um tipo.
    Afirmações lógicas são odo tipo [Prop]. *)

Check 3 = 3.
(* ===> Prop *)

Check forall n m : nat, n + m = m + n.
(* ===> Prop *)

(** Ser uma proposição, não quer dizer que
    a afirmação pode ser provada verdadeira. *)

Check 2 = 2.
(* ===> Prop *)

Check forall n : nat, n = 2.
(* ===> Prop *)

Check 3 = 4.
(* ===> Prop *)

(** Proposições são _first-class objects_; logo,
    podem ser manipuladas como outras entidades
    de Coq. *)

Definition plus_fact : Prop := 2 + 2 = 4.
Check plus_fact.
(* ===> plus_fact : Prop *)

Theorem plus_fact_is_true :
  plus_fact.
Proof. reflexivity.  Qed.

(** É possível definir proposições parametrizadas. *)

Definition is_three (n : nat) : Prop :=
  n = 3.
Check is_three.
(* ===> nat -> Prop *)

(** Em Coq, funções que retornam proposições
    são tidas como definições de propriedades
    sobre seus argumentos. *)

Definition injective {A B} (f : A -> B) :=
  forall x y : A, f x = f y -> x = y.

Lemma succ_inj : injective S.
Proof.
  intros n m H. inversion H. reflexivity.
Qed.

(** O operador [=] é uma função que retorna [Prop].
    Escrever [n = m] é um açúcar sintático para
    [eq n m]. *)

Check @eq.
(* ===> forall A : Type, A -> A -> Prop *)

(* ############################################### *)
(** * Conectivos lógicos: conjunção *)

(** Se escreve [A /\ B] para representar que [A] e
    [B] são afirmações verdadeiras. Na prova de
    tais afirmações, usa-se a tática split. *)

Example and_example : 3 + 4 = 7 /\ 2 * 2 = 4.
Proof.
  split.
  - (* 3 + 4 = 7 *) reflexivity.
  - (* 2 + 2 = 4 *) reflexivity.
Qed.

Lemma and_intro : forall A B : Prop, A -> B -> A /\ B.
Proof.
  intros A B HA HB. split.
  - apply HA.
  - apply HB.
Qed.

(** Observe que [apply and_intro] tem o mesmo efeito
    de [split]. *)

Example and_example' : 3 + 4 = 7 /\ 2 * 2 = 4.
Proof.
  apply and_intro.
  - (* 3 + 4 = 7 *) reflexivity.
  - (* 2 + 2 = 4 *) reflexivity.
Qed.

(** **** Exercise: (and_exercise)  *)
Example and_exercise :
  forall n m : nat,
    n + m = 0 -> n = 0 /\ m = 0.
Proof.
  intros n m. intros eq. split.
  - destruct n.
    + reflexivity.
    + inversion eq.
  - destruct m.
    + reflexivity.
    + Search "plus_n_Sm". rewrite <- plus_n_Sm in eq.
      inversion eq.
Qed.

(** Se no contexto temos [A /\ B], escrever
    [destruct H as [HA HB]] irá remover H e adicionar
    duas novas hipóteses HA e HB. *)

Lemma and_example2 :
  forall n m : nat,
    n = 0 /\ m = 0 -> n + m = 0.
Proof.
  intros n m H.
  destruct H as [Hn Hm].
  rewrite Hn. rewrite Hm.
  reflexivity.
Qed.

(** É comum em algumas situações se saber que [A /\ B],
    mas precisarmos somente de [A] (ou [B]) para concluir
    a prova. *)

Lemma proj1 : forall P Q : Prop,
  P /\ Q -> P.
Proof.
  intros P Q [HP HQ].
  apply HP.
Qed.

(** **** Exercise: (proj2)  *)
Lemma proj2 : forall P Q : Prop,
  P /\ Q -> Q.
Proof.
  intros P Q [HP HQ].
  apply HQ.
Qed.

(** Os próximos teoremas provam a comutatividade
    e associatividade da conjunção. *)

Theorem and_commut : forall P Q : Prop,
  P /\ Q -> Q /\ P.
Proof.
  intros P Q [HP HQ].
  split.
    - (* left *) apply HQ.
    - (* right *) apply HP.
Qed.

(** **** Exercise: (and_assoc)  *)
(** Dica: É possível usar um padrão de destruct
    _aninhado_; ou seja, [destruct H as [HP [HQ HR]]]. *)

Theorem and_assoc : forall P Q R : Prop,
  P /\ (Q /\ R) -> (P /\ Q) /\ R.
Proof.
  intros P Q R [HP [HQ HR]]. split.
  - split. apply HP. apply HQ.
  - apply HR.
Qed.

(* ############################################### *)
(** * Conectivos lógicos: disjunção *)

(** Em Coq, escrevemos [A \/ B], e podemos usar as
    táticas [destruct] ou [intros]. *)

Lemma or_example :
  forall n m : nat,
    n = 0 \/ m = 0 -> n * m = 0.
Proof.
  (* Análise de casos em n = 0 \/ m = 0] *)
  intros n m [Hn | Hm].
  - (* [n = 0] *)
    rewrite Hn. reflexivity.
  - (* [m = 0] *)
    rewrite Hm. rewrite <- mult_n_O.
    reflexivity.
Qed.

(** Quando a disjunção está no objetivo,
    podemos usar as táticas [left] e [right]. *)

Lemma or_intro : forall A B : Prop,
  A -> A \/ B.
Proof.
  intros A B HA.
  left.
  apply HA.
Qed.

Lemma zero_or_succ :
  forall n : nat, n = 0 \/ n = S (pred n).
Proof.
  intros [|n].
  - left. reflexivity.
  - right. reflexivity.
Qed.

(** **** Exercise: (mult_eq_0)  *)
Lemma mult_eq_0 :
  forall n m,
    n * m = 0 -> n = 0 \/ m = 0.
Proof.
  intros n m H0. destruct n as [|n'].
  - left. reflexivity.
  - right. simpl in H0. Search "and_exercise".
    apply and_exercise in H0. apply proj1 in H0. apply H0.
Qed.

(** **** Exercise: (or_commut)  *)
Theorem or_commut : forall P Q : Prop,
  P \/ Q  -> Q \/ P.
Proof.
  intros P Q [HP | HQ].
  - right. apply HP.
  - left. apply HQ.
Qed.

(* ############################################### *)
(** * Conectivos lógicos: negação *)

(** Sintaxe em Coq: [~]. Em Coq, [~ P] é definido
    como [P -> False]; onde [False] é uma proposição
    básica contraditória. *)

Module MyNot.

Definition not (P:Prop) := P -> False.

Notation "~ x" := (not x) : type_scope.

Check not.
(* ===> Prop -> Prop *)

End MyNot.

(** Como [False] é uma contradição, se ele aparecer
    no contexto, também podemos usar [inversion]
    para concluir a prova. *)

Theorem ex_falso_quodlibet : forall (P:Prop),
  False -> P.
Proof.
  intros P contra.
  inversion contra.
Qed.

(** Em Latim, ex falso quodlibet significa,
    literalmente, "from falsehood follows
    whatever you like"; outro nome para o
    princípio da explosão. *)

(** **** Exercise: (not_implies_our_not)  *)
Fact not_implies_our_not : forall (P:Prop),
  ~ P -> (forall (Q:Prop), P -> Q).
Proof.
  intros P. intros NP. intros Q. intros HP. apply NP in HP.
  apply ex_falso_quodlibet. apply HP.
Qed.

(** Usamos a seguinte notação para representar
    o fato que dois naturais são diferentes. *)

Theorem zero_not_one : ~(0 = 1).
Proof.
  intros contra. inversion contra.
Qed.

(** Sintaxe alternativa. *)

Check (0 <> 1).
(* ===> Prop *)

Theorem zero_not_one' : 0 <> 1.
Proof.
  unfold not. intros H. inversion H.
Qed.

(** É necessário um pouco de prática para
    se acostumar com o uso da negação em Coq. *)

Theorem not_False :
  ~ False.
Proof.
  unfold not. intros H. destruct H.
Qed.

Theorem contradiction_implies_anything :
  forall P Q : Prop,
    (P /\ ~P) -> Q.
Proof.
  intros P Q [HP HNA]. unfold not in HNA.
  apply HNA in HP. destruct HP.
Qed.

Theorem double_neg : forall P : Prop,
  P -> ~~P.
Proof.
  intros P H. unfold not. intros G.
  apply G. apply H.
Qed.

(** **** Exercise: (contrapositive)  *)
Theorem contrapositive : forall (P Q : Prop),
  (P -> Q) -> (~Q -> ~P).
Proof.
  intros P Q PQ. unfold not. intros QF. intros HP.
  apply QF. apply PQ. apply HP.
Qed.

(** **** Exercise: (not_both_true_and_false)  *)
Theorem not_both_true_and_false : forall P : Prop,
  ~ (P /\ ~P).
Proof.
  intros P. unfold not. intros [HP PF]. apply PF. apply HP.
Qed.

(** Como desigualdades usam negação, é preciso prática
    para se acostumar com o seu uso em Coq. Ao tentar
    provar algo claramente absurdo (e.g., [false = true]),
    aplique [ex_falso_quodlibet] para mudar o objetivo
    da prova para [False]. *)

Theorem not_true_is_false : forall b : bool,
  b <> true -> b = false.
Proof.
  intros [] H.
  - (* b = true *)
    unfold not in H.
    apply ex_falso_quodlibet.
    apply H. reflexivity.
  - (* b = false *)
    reflexivity.
Qed.

(** Como uso de [ex_falso_quodlibet] é comum,
    há uma tática específica em Coq chamada
    [exfalso]. *)

Theorem not_true_is_false' : forall b : bool,
  b <> true -> b = false.
Proof.
  intros [] H.
  - (* b = false *)
    unfold not in H.
    exfalso. apply H. reflexivity.
  - (* b = true *) reflexivity.
Qed.

(** Em Coq, [True] define uma proposição básica
    que é trivialmente verdadeira. Para prová-la,
    usamos a constante predefinida [I : True]. *)

Lemma True_is_true : True.
Proof. apply I. Qed.

(* ############################################### *)
(** * Equivalência lógica *)

(** Em Coq, o "se e somente se" é representado
    como a conjunção de duas implicações. *)

Module MyIff.

Definition iff (P Q : Prop) := (P -> Q) /\ (Q -> P).

Notation "P <-> Q" := (iff P Q)
                      (at level 95, no associativity)
                      : type_scope.

End MyIff.

Theorem iff_sym : forall P Q : Prop,
  (P <-> Q) -> (Q <-> P).
Proof.
  intros P Q [HAB HBA].
  unfold iff. split.
  - (* -> *) apply HBA.
  - (* <- *) apply HAB.  Qed.

Lemma not_true_iff_false : forall b,
  b <> true <-> b = false.
Proof.
  intros b. split.
  - (* -> *)
    apply not_true_is_false.
  - (* <- *)
    intros H. rewrite H. intros H'.
    inversion H'.
Qed.

(** **** Exercise: (iff_properties)  *)
Theorem iff_refl : forall P : Prop,
  P <-> P.
Proof.
  intros P. split.
  - intros HP. apply HP.
  - auto.
Qed.

Theorem iff_trans : forall P Q R : Prop,
  (P <-> Q) -> (Q <-> R) -> (P <-> R).
Proof.
  intros P Q R iffPQ iffQR.
  split.
  - Search (?E /\ _ -> ?E). apply proj1 in iffPQ. apply proj1 in iffQR.
    intros HP. apply iffQR. apply iffPQ. apply HP.
  - apply proj2 in iffPQ. apply proj2 in iffQR.
    intros HR. apply iffPQ. apply iffQR. apply HR.
Qed.

(** **** Exercise: (or_distributes_over_and)  *)
Theorem or_distributes_over_and : forall P Q R : Prop,
  P \/ (Q /\ R) <-> (P \/ Q) /\ (P \/ R).
Proof.
  intros P Q R. split.
  {
    intros [HP | [HQ HR]].
    {
      split.
      - left. apply HP.
      - auto.
    }
    {
      split.
      - right. apply HQ.
      - auto.
    }
  }
  {
    intros [[HP | HQ] [HP' | HR]].
    - left. apply HP.
    - auto.
    - auto.
    - auto.
  }
Qed.

(** As táticas [rewrite] e [reflexivity] podem
    ser usadas com afirmações se e somente se,
    não somente com igualdades. Isto é suportado
    pela biblioteca Setoid. *)

Require Import Coq.Setoids.Setoid.

(** Primeiro, provando algumas equivalências. *)

Lemma mult_0 : forall n m,
  n * m = 0 <-> n = 0 \/ m = 0.
Proof.
  split.
  - apply mult_eq_0.
  - apply or_example.
Qed.

Lemma or_assoc :
  forall P Q R : Prop,
    P \/ (Q \/ R) <-> (P \/ Q) \/ R.
Proof.
  intros P Q R. split.
  - intros [H | [H | H]].
    + left. left. apply H.
    + left. right. apply H.
    + right. apply H.
  - intros [[H | H] | H].
    + left. apply H.
    + right. left. apply H.
    + right. right. apply H.
Qed.

(** Agora, podemos usar [rewrite] e [reflexivity]
    com as equivalências antes provadas. *)

Lemma mult_0_3 :
  forall n m p,
    n * m * p = 0 <-> n = 0 \/ m = 0 \/ p = 0.
Proof.
  intros n m p.
  rewrite mult_0. rewrite mult_0.
  rewrite or_assoc. reflexivity.
Qed.

(** A tática [apply] também pode ser usada com [<->].
    Nesses casos, a tática tenta advinhar qual
    lado da equivalência usar. *)

Lemma apply_iff_example :
  forall n m : nat,
    n * m = 0 -> n = 0 \/ m = 0.
Proof.
  intros n m H. apply mult_0. apply H.
Qed.

(* ############################################### *)
(** ** Quantificação existencial *)

(** Em Coq, escrevemos [exists x : T, P]. Assim como
    o [forall], a anotação [: T] pode ser omitida
    se Coq tiver como inferir o tipo de [x].

    Para provar uma afirmação usando [exists x], primeiro
    precisamos explicitamente dizer a Coq qual
    testemunha (witness) [t] deve ser usada para [x].
    Para tanto, usamos a tática [exists t].

    Em seguida, devemos provar que a afirmação é verdadeira
    com toda ocorrência de [x] substituída por [t]. *)

Lemma four_is_even :
  exists n : nat, 4 = n + n.
Proof.
  exists 2. reflexivity.
Qed.

(** Se o [exists x] estiver no contexto, podemos
    destruir para obter uma testemunha [x] e
    uma hipótese afirmando que [P] é verdade. *)

Theorem exists_example_2 : forall n,
  (exists m, n = 4 + m) ->
  (exists o, n = 2 + o).
Proof.
  intro n. intro H. destruct H as [m Hm].
  exists (2 + m).
  apply Hm.
Qed.

(** **** Exercise: (dist_not_exists)  *)
Theorem dist_not_exists : forall (X:Type) (P : X -> Prop),
  (forall x, P x) -> ~ (exists x, ~ P x).
Proof.
  intros X P. intros H. unfold not. intros contra.
  destruct contra as [x' contra']. apply contra'. apply H.
Qed.

(** **** Exercise: (dist_exists_or)  *)
Theorem dist_exists_or : forall (X:Type) (P Q : X -> Prop),
  (exists x, P x \/ Q x) <->
  (exists x, P x) \/ (exists x, Q x).
Proof.
  intros X P Q. split.
  - intros [x [HP | HQ]].
    + left. exists x. apply HP.
    + right. exists x. apply HQ.
  - intros [HP | HQ].
    + destruct HP as [x HP].
      exists x. left. apply HP.
    + destruct HQ as [x HQ].
      exists x. right. apply HQ.
Qed.

(* ############################################### *)
(** ** Programando com proposições *)

(** Podemos definir proposições complexas a partir
    de outras proposições simples. *)

Fixpoint In {A : Type} (x : A) (l : list A) : Prop :=
  match l with
  | [] => False
  | x' :: l' => x' = x \/ In x l'
  end.

(** Quando [In] é aplicado a uma lista concreta,
    sua aplicação expande para uma sequência de
    disjunções aninhadas. *)

Example In_example_1 : In 4 [1; 2; 3; 4; 5].
Proof.
  simpl. right. right. right. left. reflexivity.
Qed.

(** No exemplo a seguir, observe o uso do
    padrão vazio: []. *)

Example In_example_2 :
  forall n, In n [2; 4] ->
  exists n', n = 2 * n'.
Proof.
  simpl.
  intros n [H | [H | []]].
  - exists 1. rewrite <- H. reflexivity.
  - exists 2. rewrite <- H. reflexivity.
Qed.

(** Podemos definir e provar afirmações mais gerais.
    Observe que, inicialmente, [In] é aplicado a uma
    variável e só é expandido ao fazer análise
    de casos sobre esta variável. *)

Lemma In_map :
  forall (A B : Type) (f : A -> B) (l : list A) (x : A),
    In x l ->
    In (f x) (map f l).
Proof.
  intros A B f l x.
  induction l as [|x' l' IHl'].
  - (* l = nil, contradição *)
    simpl. intros [].
  - (* l = x' :: l' *)
    simpl. intros [H | H].
    + rewrite H. left. reflexivity.
    + right. apply IHl'. apply H.
Qed.

(** Esta maneira de definir proposições recursivamente,
    apesar de conveniente, está sujeita à limitação
    de definição de funções recursivas em Coq. *)

(** **** Exercise: (In_map_iff)  *)
Lemma In_map_iff :
  forall (A B : Type) (f : A -> B) (l : list A) (y : B),
    In y (map f l) <->
    exists x, f x = y /\ In x l.
Proof.
  intros A B f l. induction l as [|x l' IHl'].
  - simpl. intros y. split.
    + intros F. inversion F.
    + intros [x H]. apply proj2 in H. apply H.
  - intros y. split.
    + intros [H | H].
      * exists x. split. apply H. left. reflexivity.
      * simpl. apply IHl' in H. destruct H as [x' H].
        exists x'. split.
          { apply proj1 in H. apply H. }
          { destruct H as [H1 H2]. right. apply H2. }
    + intros He. simpl.
      destruct He as [x' H]. destruct H as [H1 H2]. simpl in H2.
        destruct H2 as [H2 | H2].
      * left. rewrite H2. apply H1.
      * right. apply IHl'. exists x'. split.
        { apply H1. }
        { apply H2. }
Qed.

(** **** Exercise: (In_app_iff)  *)
Lemma In_app_iff : forall A l l' (a:A),
  In a (l++l') <-> In a l \/ In a l'.
Proof.
  intros A l l'. induction l as [| a' l1 IHl1].
  - split.
    + simpl. intros H. right. apply H.
    + simpl. intros [contra | H].
      * inversion contra.
      * apply H.
  - split.
    + simpl. intros [H | H].
      * left. left. apply H.
      * apply IHl1 in H. destruct H as [H | H].
        { left. right. apply H. }
        { right. apply H. }
    + intros [H | H].
      * simpl in H. simpl. destruct H as [H | H].
        { left. apply H. }
        { right. apply IHl1. left. apply H. }
      * simpl. right. apply IHl1. right. apply H.
Qed.

(** **** Exercise: (All)  *)
(** Defina uma função recursiva [All] que retorna uma
    proposição afirmando que uma propriedade [P] é
    satisfeita por todos os elementos da lista. Em seguida,
    para provar que sua definição é correta, prove o
    lemma [All_In]. *)

Fixpoint All {T : Type} (P : T -> Prop) (l : list T) : Prop :=
  match l with
  | [] => True
  | (x :: l') => P x /\ All P l'
  end.

Lemma All_In :
  forall T (P : T -> Prop) (l : list T),
    (forall x, In x l -> P x) <-> All P l.
Proof.
  intros T P l. induction l as [| t l' IHl'].
  - split.
    + simpl. intros H. apply I.
    + simpl. intros H. intros x. intros false. inversion false.
  - split.
    + simpl. intros H. split.
      * apply H. left. reflexivity.
      * apply IHl'. intros x. intros Hin.
        apply H. right. apply Hin.
    + simpl. intros [H1 H2]. intros x.
      intros H.
      rewrite <- IHl' in H2.
      destruct H as [H | H].
      * rewrite <- H. apply H1.
      * apply H2. apply H.
Qed.

(* ############################################### *)
(** * Aplicando teoremas a argumentos *)

(** Em Coq, _provas_ são também "first-class objects".
    Mais informações em:
    https://softwarefoundations.cis.upenn.edu/lf-current/IndProp.html
    https://softwarefoundations.cis.upenn.edu/lf-current/ProofObjects.html

    Veja o exemplo a seguir. *)

Lemma plus_comm3 :
  forall x y z, x + (y + z) = (z + y) + x.
Proof.
  intros x y z.
  rewrite plus_comm.
  rewrite plus_comm.
  (* voltamos ao ponto inicial *)
Abort.

(** Uma alternativa é criar uma versão
    especializada de [plus_comm] usando [assert]. *)

Lemma plus_comm3_take2 :
  forall x y z, x + (y + z) = (z + y) + x.
Proof.
  intros x y z.
  rewrite plus_comm.
  assert (H : y + z = z + y).
  { rewrite plus_comm. reflexivity. }
  rewrite H.
  reflexivity.
Qed.

(** Ou, de forma mais elegante, aplicar [plus_comm]
    diretamente aos argumentos para os quais
    desejamos instanciar a prova [plus_comm]. *)

Lemma plus_comm3_take3 :
  forall x y z, x + (y + z) = (z + y) + x.
Proof.
  intros x y z.
  rewrite plus_comm.
  rewrite (plus_comm y z).
  reflexivity.
Qed.

(** Logo, é possível usar teoremas como funções! *)

Example lemma_application_ex :
  forall {n : nat} {ns : list nat},
    In n (map (fun m => m * 0) ns) ->
    n = 0.
Proof.
  intros n ns H.
  Print proj1.
  Print In_map_iff.
  Search "In_map_iff".
  Compute (proj1 _ _).
  destruct (proj1 _ _ (In_map_iff _ _ _ _ _) H)
           as [m [Hm _]].
  rewrite mult_0_r in Hm.
  rewrite <- Hm. reflexivity.
Qed.

(**
In_map_iff:
  forall (A B : Type) (f : A -> B) (l : list A) (y : B), In y (map f l) <-> (exists x : A, f x = y /\ In x l)

In_map_iff:
  f = fun m => m * 0
  y = n
  l = ns
result:
  In n (map (fun m => m * 0) ns) <-> (exists x: nat, x * 0 = n /\ In x ns)
result rewriten:
  In n (map (fun m => m * 0) ns) -> (exists x: nat, x * 0 = n /\ In x ns)
  /\ In n (map (fun m => m * 0) ns) <-> (exists x: nat, x * 0 = n /\ In x ns)

proj1 _ _ result:
  In n (map (fun m => m * 0) ns) -> (exists x: nat, x * 0 = n /\ In x ns)
applied to H:
  (exists x: nat, x * 0 = n /\ In x ns)
**)

(* ############################################### *)
(** * Coq vs. Teoria dos conjuntos *)

(** O core lógico de Coq é baseado no _Calculus of
    Inductive Constructions_, que, por sua vez,
    difere de outros sistemas formais como
    a teoria de conjuntos de Zermelo-Fraenkel (ZFC).

    Por exemplo, em ZFC, um elemento pode ser membro
    de vários conjuntos. Em Coq, um termo é membro
    de no máximo um tipo. Logo, no lugar de dizer
    que um número natural [n] pertence ao conjunto
    dos números pares, em Coq, dizemos que a
    afirmação [ev n] é verdadeira, onde
    [ev : nat -> Prop].

    Contudo, há casos em que expressar uma certa
    afirmação em Coq não é algo direto, às vezes,
    nem possível, exceto se enriquecermos a lógica
    suportada por Coq com axiomas adicionais. *)

(** ** Functional Extensionality *)

(** Duas funções [f] e [g] são consideradas iguais
    se elas produzem a mesma saída para toda
    entrada possível.

    (forall x, f x = g x) -> f = g

    Esta definição é conhecida como o princípio
    da _functional extensionality_, e ela não faz
    parte dos axiomas básicos definidos em Coq.
    Logo, proposições envolvendo este conceito
    não podem ser provadas. *)

Example function_equality_ex2 :
  (fun x => plus x 1) = (fun x => plus 1 x).
Proof.
   (* Stuck *)
Abort.

(** Contudo, podemos axiomatizar esta definição
    usando o comando [Axiom]. *)

Axiom functional_extensionality :
  forall {X Y: Type} {f g : X -> Y},
    (forall (x:X), f x = g x) -> f = g.

(** O efeito de [Axiom] é o mesmo de definir um
    Teorema e não prová-lo, através do uso
    de [Admitted]. Contudo, aqui, não existe
    a intenção de provar posteriormente a afirmação. *)

Example function_equality_ex2 :
  (fun x => plus x 1) = (fun x => plus 1 x).
Proof.
  apply functional_extensionality. intros x.
  apply plus_comm.
Qed.

(** É preciso ter cuidado ao adicionar novos
    axiomas para não introduzir inconsistências.
    Não é simples, em linhas gerais, provar
    a consistência lógica de um conjunto de axiomas.

    No caso particular do functional extensionality,
    este é consistente com o core lógico de Coq.

    O comando [Print Assumptions] imprime que
    axiomas adicionais foram utilizados em uma
    certa prova. *)

Print Assumptions function_equality_ex2.
(* ===>
     Axioms:
     functional_extensionality :
         forall (X Y : Type) (f g : X -> Y),
                (forall x : X, f x = g x) -> f = g *)

(** ** Proposições e Booleanos *)

(** Podemos definir fatos lógicos usando _booleanos_
    ou _proposições_. Por exemplo, dizer que [n] é
    par, pode ser representado dizendo que

    (1) [evenb n] retorna [true] ou
    (2) que existe um [k] tal que [n = double k]

    Estas duas definições são equivalentes. *)

(** Definindo lemmas auxiliares. *)

Theorem evenb_S :
  forall n : nat, evenb (S n) = negb (evenb n).
Proof.
  intro n. induction n as [| n'].
  - simpl. reflexivity.
  - rewrite IHn'. simpl.
    Search (negb (negb _)).
    rewrite negb_involutive.
    reflexivity.
Qed.

Theorem evenb_double :
  forall k, evenb (double k) = true.
Proof.
  intros k. induction k as [|k' IHk'].
  - reflexivity.
  - simpl. apply IHk'.
Qed.

(** **** Exercise: (evenb_double_conv)  *)
Theorem evenb_double_conv : forall n,
  exists k, n = if evenb n then double k
                else S (double k).
Proof.
  intros n. induction n as [| n'].
  - simpl. exists 0. reflexivity.
  - destruct IHn' as [k H].
    rewrite -> evenb_S. unfold negb.
    destruct (evenb n') eqn: H1.
    + exists k. rewrite H. reflexivity.
    + exists (S k). simpl. rewrite H. reflexivity.
Qed.

Theorem even_bool_prop : forall n,
  evenb n = true <-> exists k, n = double k.
Proof.
  induction n as [| n'].
  - simpl. split.
    + intros eq. exists 0. reflexivity.
    + intros ex. reflexivity.
  - split.
    + intros H. Compute (evenb_double_conv _).
      destruct (evenb_double_conv (S n')) as [k H0].
      rewrite H in H0. exists k. apply H0.
    + intros [k H0]. rewrite H0. apply evenb_double.
Qed.

(** Dizemos, portanto, que a computação de
    [evenb n] _reflete_ a proposição lógica
    [exists k, n = double k]. Veja outro exemplo
    a seguir. *)

Theorem beq_nat_refl : forall n : nat,
  true = beq_nat n n.
Proof.
  intro n. induction n as [| n'].
  - reflexivity.
  - simpl. rewrite IHn'.
    reflexivity.
Qed.

Theorem beq_nat_true_iff : forall n1 n2 : nat,
  beq_nat n1 n2 = true <-> n1 = n2.
Proof.
  intros n1 n2. split.
  - apply beq_nat_true.
  - intros H. rewrite H.
    rewrite <- beq_nat_refl.
    reflexivity.
Qed.

(** Em algumas situações, a definição proposicional
    é mais útil do que a booleana. Por exemplo,
    saber que [beqnat n m = true] pode não ser tão
    útil quanto saber que [n = m]; uma vez que,
    a segunda opção permite realizar reescrita.

    Contudo, em outras situações, a definição
    booleana é mais útil. Por exemplo, Coq
    não permite testar se uma proposição
    qualquer é verdadeira ou falsa na definição
    de uma função. Veja que o código abaixo
    não é aceito. *)

Fail Definition is_even_prime n :=
  if n = 2 then true
  else false.

(** Coq reclama que [n = 2] tem tipo [Prop],
    quando ele espera outro tipo indutivo com
    dois elementos (construtores). Isto está
    associado com o fato que em Coq toda função
    é total e precisa ser computável (em particular,
    para permitir a extração de código executável.

    Se fosse permitir usar [Prop] em uma análise
    de casos, seria possível escrever funções
    não computáveis.

    Em alguns casos, mesmo tendo uma propriedade
    computável, é mais fácil defini-la usando
    [Prop], uma vez que funções em Coq possuem
    restrições significativas na sua definição.

    Por outro lado, um ponto positivo em definir
    fatos de forma computável é permitir certa
    automação através da computação de termos em
    Coq. Esta é uma técnica conhecida como _proof
    by reflection_. Veja o exemplo a seguir. *)

Example even_1000 : exists k, 1000 = double k.
Proof. exists 500. reflexivity. Qed.

Example even_1000' : evenb 1000 = true.
Proof. simpl. reflexivity. Qed.

Example even_1000'' : exists k, 1000 = double k.
Proof.
  Print even_bool_prop.
  apply even_bool_prop.
  reflexivity.
Qed.

(** **** Exercise: (logical_connectives)  *)
(** Os próximos lemmas relacionam conectivos lógicos
    com as respectivas operações booleanas. *)

Lemma andb_true_iff : forall b1 b2:bool,
  b1 && b2 = true <-> b1 = true /\ b2 = true.
Proof.
  intros b1 b2.
  split.
  - simpl. intros H. destruct b1.
    + destruct b2.
      * auto.
      * auto.
    + simpl in H. rewrite H. destruct b2.
      * auto.
      * auto.
  - intros [H1 H2]. rewrite H1. rewrite H2. simpl. reflexivity.
Qed.

Lemma orb_true_iff : forall b1 b2,
  b1 || b2 = true <-> b1 = true \/ b2 = true.
Proof.
  intros b1 b2. split.
  - intros H. destruct b1.
    + left. reflexivity.
    + destruct b2.
      * right. reflexivity.
      * simpl in H. rewrite H. left. reflexivity.
  - intros [H | H].
    + rewrite H. simpl. reflexivity.
    + rewrite H. destruct b1.
      * reflexivity.
      * reflexivity.
Qed.

(** ** Lógica clássica vs. construtivas *)

(** Anteriormente, vimos que não é possível
    verificar se uma proposição [P] é verdadeira
    ou não dentro da definição de uma função
    em Coq. O mesmo se aplica para provas.
    O seguinte princípio não é possível derivar
    a partir dos axiomas definidos em Coq. *)

Definition excluded_middle :=
  forall P : Prop, P \/ ~ P.

(** Ao provar objetivos na prova [_ \/ _],
    usamos [left] ou [right] que, implicitamente,
    requer saber qual lado da disjunção é
    verdadeiro. Contudo, neste caso, nada se
    sabe sobre [P]. No entanto, se [P] for
    refletido em algum termo booleano [b],
    é possível realizar a prova; basta checar
    o valor de [b]. *)

Theorem restricted_excluded_middle : forall P b,
  (P <-> b = true) -> P \/ ~ P.
Proof.
  intros P b H. destruct b.
  - left. rewrite H. reflexivity.
  - right. rewrite H. unfold not.
    intros contra. inversion contra.
Qed.

(** Em particular, a propriedade de _excluded middle_
    é válida para equações [n = m] entre números
    naturais [n] e [m]. *)

Theorem restricted_excluded_middle_eq :
  forall (n m : nat), n = m \/ n <> m.
Proof.
  intros n m.
  apply (restricted_excluded_middle (n = m) (beq_nat n m)).
  symmetry. apply beq_nat_true_iff.
Qed.

(** Como consequência de não assumir o _excluded middle_,
    se existe uma prova para [exists x, P x], então é
    possível explicitar um valor para [x] tal que
    [P x] é verdade; em outras palavras, toda prova
    de existência é _construtiva_. Lógicas como ZFC
    são tidas como lógicas clássicas. *)

(* ############################################### *)
(** * Leitura sugerida *)

(** Software Foundations: volume 1
  - Logic in Coq
  https://softwarefoundations.cis.upenn.edu/lf-current/Logic.html
*)


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

Require Import Arith Lia List Bool Eqdep_dec .

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

Set Implicit Arguments.

Set Default Proof Using "Type".

Local Reserved Notation " '[|' f '|]' " (at level 0).
Local Reserved Notation "'⟦' f '⟧'".

Section Recursive_algorithms.

  Unset Elimination Schemes.

  Inductive recalg : nat -> Type :=
    | ra_cst  : nat -> recalg 0
    | ra_zero : recalg 1
    | ra_succ : recalg 1
    | ra_proj : forall k, pos k -> recalg k
    | ra_comp : forall k i, recalg k -> vec (recalg i) k -> recalg i
    | ra_rec  : forall k, recalg k -> recalg (S (S k)) -> recalg (S k)
    | ra_min  : forall k, recalg (S k) -> recalg k
    .

  Set Elimination Schemes.

  Section recalg_rect.

    Variable P : forall k, recalg k -> Type.

    Hypothesis Pcst  : forall n, P (ra_cst n).
    Hypothesis Pzero : P ra_zero.
    Hypothesis Psucc : P ra_succ.
    Hypothesis Pproj : forall k p, P (@ra_proj k p).
    Hypothesis Pcomp : forall k i f gj, P f -> (forall p, @P i (@vec_pos _ k gj p))
                                     -> P (ra_comp f gj).
    Hypothesis Prec  : forall k f g, @P k f -> P g -> P (ra_rec f g).
    Hypothesis Pmin  : forall k f, @P (S k) f -> P (ra_min f).

    Fixpoint recalg_rect k f { struct f } : @P k f :=
      match f with
        | ra_cst n     => Pcst n
        | ra_zero      => Pzero
        | ra_succ      => Psucc
        | ra_proj p    => Pproj p
        | ra_comp f gj => Pcomp _ [|f|] (fun p => [|vec_pos gj p|])
        | ra_rec f g   => Prec [|f|] [|g|]
        | ra_min f     => Pmin [|f|]
      end
    where "[| f |]" := (@recalg_rect _ f).

  End recalg_rect.

  Definition recalg_rec (P : forall k, recalg k -> Set) := recalg_rect P.
  Definition recalg_ind (P : forall k, recalg k -> Prop) := recalg_rect P.

  Section recalg_rec_type.

    Variables (X : Type) (P : nat -> Type).
    Hypothesis Pcst  : P 0.
    Hypothesis Pzero : P 1.
    Hypothesis Psucc : P 1.
    Hypothesis Pproj : forall k (p : pos k), P k.
    Hypothesis Pcomp : forall k i, P k -> vec (P i) k -> P i.
    Hypothesis Prec  : forall k, P k -> P (S (S k)) -> P (S k).
    Hypothesis Pmin  : forall k, P (S k) -> P k.

    Fixpoint recalg_rec_type k (f : recalg k) { struct f } : P k :=
      match f in recalg i return P i with
        | ra_cst n     => Pcst
        | ra_zero      => Pzero
        | ra_succ      => Psucc
        | ra_proj p    => Pproj p
        | ra_comp f gj => Pcomp [|f|] (vec_map (fun f => @recalg_rec_type _ f) gj)
        | ra_rec f g   => Prec [|f|] [|g|]
        | ra_min f     => Pmin [|f|]
      end
    where "[| f |]" := (@recalg_rec_type _ f).

  End recalg_rec_type.

  Definition ra_size k : recalg k -> nat.
  Proof.
    induction 1 as [ | | | | k i Hf Hg | k Hf Hg | k Hf ]
      using recalg_rec_type.
    + exact 1.
    + exact 1.
    + exact 1.
    + exact 1.
    + exact (1+Hf+vec_sum Hg).
    + exact (1+Hf+Hg).
    + exact (1+Hf).
  Defined.

  Section recalg_inj.

    (* Injectivity is not a given for dependently typed constructors but it holds
       when the dependent parameter is from a set (ie a Type with decidable equality *)

    Let nat_dep_inj (P : nat -> Type) n x y : existT P n x = existT P n y -> x = y.
    Proof. apply inj_pair2_eq_dec, eq_nat_dec. Qed.

    Local Ltac inj := let H := fresh in intros H; injection H; clear H; auto.

    Local Ltac diauto :=
      repeat match goal with
        H: existT _ _ _ = existT _ _ _ |- _ => apply nat_dep_inj in H
      end; auto.

    Fact ra_cst_inj n m : ra_cst n = ra_cst m -> n = m.
    Proof. inj. Qed.

    Fact ra_proj_inj k (p q : pos k) : ra_proj p = ra_proj q -> p = q.
    Proof. inj. Qed.

    (* This one is more subtle and requires type casts *)

    Fact ra_comp_inj k k' i f f' gj gj' :
         @ra_comp k i f gj = @ra_comp k' i f' gj'
      -> exists H : k = k', eq_rect _ _ f _ H = f'
                         /\ eq_rect _ _ gj _ H = gj'.
    Proof.
      inj; intros ? ? H; exists H; subst; simpl; diauto.
    Qed.

    Fact ra_rec_inj k f g f' g' : @ra_rec k f g = ra_rec f' g' -> f = f' /\ g = g'.
    Proof.
      inj; intros; diauto.
    Qed.

    Fact ra_min_inj k f f' : @ra_min k f = ra_min f' -> f = f'.
    Proof.
      inj; intros; diauto.
    Qed.

  End recalg_inj.

End Recursive_algorithms.

Definition functional X Y (f : X -> Y -> Prop) := forall x y1 y2, f x y1 -> f x y2 -> y1 = y2.
Definition total X Y (f : X -> Y -> Prop) := forall x, exists y, f x y.

Section recursor.

  Variables (F : nat -> Prop) (G : nat -> nat -> nat -> Prop).

  Fixpoint μ_rec n :=
    match n with
      | 0   => F
      | S n => fun x => exists y, μ_rec n y /\ G n y x
      end.

  Fact μ_rec_inv n x : μ_rec n x -> exists s, F (s 0)
                                           /\ s n = x
                                           /\ forall i, i < n -> G i (s i) (s (S i)).
  Proof.
    revert x; induction n as [ | n IHn ]; intros x; simpl.
    + exists (fun _ => x); msplit 2; auto; intros; lia.
    + intros (y & H1 & H2).
      destruct (IHn _ H1) as (s & H3 & H4 & H5).
      exists (fun i => if le_lt_dec (S n) i then x else s i); msplit 2; auto.
      * destruct (le_lt_dec (S n) (S n)); auto; lia.
      * intros i Hi.
        destruct (le_lt_dec (S n) i); destruct (le_lt_dec (S n) (S i)); auto; try lia.
        - replace i with n by lia.
          rewrite H4; auto.
        - apply H5; lia.
  Qed.

  Theorem μ_rec_eq n x : μ_rec n x <-> exists s, F (s 0)
                                              /\ s n = x
                                              /\ forall i, i < n -> G i (s i) (s (S i)).
  Proof.
    split.
    + apply μ_rec_inv.
    + intros (s & H1 & H2 & H3).
      rewrite <- H2; clear x H2.
      revert s H1 H3.
      induction n as [ | n IHn ]; intros s H1 H2; simpl; auto.
      exists (s n); split; auto.
  Qed.

  Hypothesis (Ffun : forall n m, F n -> F m -> n = m)
             (Gfun : forall x y n m, G x y n -> G x y m -> n = m).

  Fact μ_rec_fun : functional μ_rec.
  Proof using Ffun Gfun.
    intros n; induction n as [ | n IHn ]; simpl; auto.
    intros x y (a & H1 & H2) (b & H3 & H4).
    specialize (IHn _ _ H1 H3); subst b.
    revert H2 H4; apply Gfun.
  Qed.

End recursor.

Section minimization.

  Variables (R : nat -> nat -> Prop)
            (Rfun : forall n u v, R n u -> R n v -> u = v).

  Definition μ_min n := R n 0 /\ forall i, i < n -> exists u, R i (S u).

  Fact μ_min_eq n : μ_min n <-> R n 0 /\ exists s, forall i, i < n -> R i (S (s i)).
  Proof.
    unfold μ_min; split; intros [ H0 H ]; split; auto.
    + apply fin_reif_nat with (1 := H).
    + clear H0; destruct H as (s & Hs).
      intros i ?; exists (s i); auto.
  Qed.

  Fact μ_min_fun n m : μ_min n -> μ_min m -> n = m.
  Proof using Rfun.
    intros (H1 & H2) (H3 & H4).
    destruct (lt_eq_lt_dec n m) as [ [ H | ] | H ]; auto;
      [ apply H4 in H | apply H2 in H ]; destruct H as (u & Hu);
      [ generalize (Rfun H1 Hu) | generalize (Rfun H3 Hu) ]; discriminate.
  Qed.

  Hypothesis HR : forall x, exists y, R x y.

  Fact μ_min_of_total : (exists n, μ_min n) <-> exists x, R x 0.
  Proof using Rfun HR.
    split.
    + intros (n & ? & _); exists n; auto.
    + intros H.
      destruct first_which_ni with (2 := H) as (n & H1 & H2).
      * intros n; destruct (HR n) as ([ | k] & Hk); auto.
        right; intros C; generalize (Rfun Hk C); discriminate.
      * exists n; split; auto.
        intros i Hi; apply H2 in Hi.
        destruct (HR i) as ([ | k] & Hk); try tauto.
        exists k; auto.
  Qed.

End minimization.

Section relational_semantics.

  (* Recursive functions can be interpreted in Coq as (functional) relations *)

  Notation natfun := (fun k => vec nat k -> nat -> Prop).

  Section defs.

    Definition s_cst c : natfun 0 := fun _ x => x=c.
    Definition s_zero  : natfun 1 := fun _ x => x=0.
    Definition s_succ  : natfun 1 := fun v x => x=S (vec_head v).
    Definition s_proj k (p : pos k) : natfun k := fun v x => vec_pos v p = x.

    Variable k i : nat.

    Implicit Types (f : natfun k) (g : natfun (S k)) (h : natfun (S (S k))) (gj : vec (natfun i) k).

    Definition s_comp f gj : natfun i := fun v x => exists gl, f gl x /\ forall p, vec_pos gj p v (vec_pos gl p).

    (* the recursor s_rec_r f h n v x
                 <-> exists x0,...,xn,  f      v  x0,
                                        h (0##x0##v) x1,
                                        h (1##x1##v) x2,
                                        ...
                                        h (.##..##v) xn,
                                    and xn = x
    **)

    Definition s_rec f h v := μ_rec (f (vec_tail v)) (fun x y => h (x##y##vec_tail v)) (vec_head v).

    Theorem s_rec_eq f h v x : s_rec f h v x <-> exists s, f (vec_tail v) (s 0)
                                                        /\ s (vec_head v) = x
                                                        /\ forall i, i < vec_head v -> h (i##s i##vec_tail v) (s (S i)).
    Proof. vec split v with n; apply μ_rec_eq. Qed.

    Definition s_min g v := μ_min (fun n => g (n##v)).

  End defs.

  (* we define the semantics of a recursive algorithm of arity k
      which is a relation vec nat k -> nat -> Prop, obviously functional (see below)
      We interpret the constants ra_* with the corresponding s_* operator on relations
   **)

  Definition ra_rel : forall k, recalg k -> natfun k.
  Proof.
    apply recalg_rect with (P := fun k _ => natfun k).
    exact s_cst.
    exact s_zero.
    exact s_succ.
    exact s_proj.
    intros ? ? ? ? hf hgj; exact (s_comp hf (vec_set_pos hgj)).
    intros ? ? ? hf hg; exact (s_rec hf hg).
    intros ? ? hf; exact (s_min hf).
  Defined.

  Notation "[| f |]" := (@ra_rel _ f) (at level 0).

  Fact ra_rel_fix_cst i :         [| ra_cst i     |]      = s_cst i.                   Proof. reflexivity. Qed.
  Fact ra_rel_fix_zero :          [| ra_zero      |]      = s_zero.                    Proof. reflexivity. Qed.
  Fact ra_rel_fix_succ :          [| ra_succ      |]      = s_succ.                    Proof. reflexivity. Qed.
  Fact ra_rel_fix_proj k p :      [| @ra_proj k p |]      = s_proj p.                  Proof. reflexivity. Qed.
  Fact ra_rel_fix_rec k f g :     [| @ra_rec k f g |]     = s_rec [|f|] [|g|].         Proof. reflexivity. Qed.
  Fact ra_rel_fix_min k f :       [| @ra_min k f |]       = s_min [|f|].               Proof. reflexivity. Qed.
  Fact ra_rel_fix_comp k i f gj : [| @ra_comp k i f gj |] = s_comp [|f|] (vec_map (fun x => [|x|]) gj).
  Proof.
    simpl ra_rel; f_equal.
    apply vec_pos_ext; intros p.
    rewrite vec_pos_set, vec_pos_map; trivial.
  Qed.

  Section functional.

    Lemma s_cst_fun c : functional (s_cst c).
    Proof. intros v x y Hx Hy; rewrite Hy; trivial. Qed.

    Lemma s_zero_fun : functional s_zero.
    Proof. intros v x y Hx Hy; rewrite Hy; trivial. Qed.

    Lemma s_succ_fun : functional s_succ.
    Proof. intros v x y Hx Hy; rewrite Hy; trivial. Qed.

    Lemma s_proj_fun k p : functional (@s_proj k p).
    Proof.
      intros v x y Hx Hy.
      red in Hx, Hy.
      rewrite <- Hx.
      trivial.
    Qed.

    Variable k i : nat.
    Implicit Types (f : natfun k) (gj : vec (natfun i) k) (g : natfun (S k)) (h : natfun (S (S k))).

    Lemma s_comp_fun f gj : functional f -> (forall p, functional (vec_pos gj p)) -> functional (s_comp f gj).
    Proof.
      intros f_fun gj_fun v x y [ gx [ Hx1 Hx2 ] ] [ gy [ Hy1 Hy2 ] ].
      replace gx with gy in Hx1.
      + apply (@f_fun gy); trivial.
      + apply vec_pos_ext.
        intros p; apply (gj_fun p v); auto.
    Qed.

    Lemma s_rec_fun f h : functional f -> functional h -> functional (s_rec f h).
    Proof.
      intros Hf Hh ? ? ?.
      apply μ_rec_fun.
      + apply Hf.
      + intros ? ? ? ? ?; apply Hh; auto.
    Qed.

    Lemma s_min_fun g : functional g -> functional (s_min g).
    Proof.
      intros Hg ? ? ?; apply μ_min_fun.
      intros ? ? ?; apply Hg.
    Qed.

  End functional.

  Hint Resolve s_cst_fun s_zero_fun s_succ_fun s_proj_fun s_rec_fun s_min_fun : core.

  (* [| f |] is a functional/deterministic relation *)

  Theorem ra_rel_fun k (f : recalg k) v x y : [|f|] v x -> [|f|] v y -> x = y.
  Proof.
    revert v x y; change (functional [|f|]).
    induction f; try (simpl; auto; fail).
    rewrite ra_rel_fix_comp.
    apply s_comp_fun; auto.
    intro; rewrite vec_pos_map; auto.
  Qed.

  Section total.

    Fact ra_cst_tot n : total [| ra_cst n |].
    Proof. intros ?; exists n; simpl; red; auto. Qed.

    Fact ra_zero_tot : total [| ra_zero |].
    Proof. intros ?; exists 0; simpl; red; auto. Qed.

    Fact ra_succ_tot : total [| ra_succ |].
    Proof. intros v; exists (S (vec_head v)); simpl; red; auto. Qed.

    Fact ra_proj_tot n p : total [| @ra_proj n p |].
    Proof. intros v; exists (vec_pos v p); simpl; red; auto. Qed.

    Fact ra_rec_tot n f g : total [|f|] -> total [|g|] -> total [|@ra_rec n f g|].
    Proof.
      intros Hf Hg v; vec split v with x.
      simpl; induction x as [ | x IHx ]; simpl.
      + destruct (Hf v) as (y & Hy).
        exists y; red; simpl; auto.
      + destruct IHx as (y & Hy).
        destruct (Hg (x##y##v)) as (z & Hz).
        exists z, y; simpl; split; auto.
    Qed.

    Variables (k i : nat) (f : recalg k) (g : vec (recalg i) k)
              (Hf : total [|f|]) (Hg : forall p, total [|vec_pos g p|]).

    Fact ra_comp_tot : total [|ra_comp f g|].
    Proof using Hf Hg.
      intros v.
      assert (H1 : forall p, exists x, [|vec_pos g p|] v x) by (intro; apply Hg).
      apply vec_reif in H1; destruct H1 as (w & Hw).
      destruct (Hf w) as (y & Hy).
      exists y, w; split; auto.
      intro; rewrite vec_pos_set; auto.
    Qed.

  End total.

  Section prim_rec.

    Definition prim_rec : forall n, recalg n -> Prop.
    Proof.
      apply recalg_rect.
      + intros; exact True.
      + exact True.
      + exact True.
      + intros; exact True.
      + intros k i _ _ H1 H2; exact (H1 /\ forall p, H2 p).
      + intros k _ _ H1 H2; exact (H1 /\ H2).
      + intros; exact False.
    Defined.

    Definition prim_rec_bool : forall n, recalg n -> bool.
    Proof.
      apply recalg_rect.
      + intros; exact true.
      + exact true.
      + exact true.
      + intros; exact true.
      + intros k i _ _ H1 H2.
        exact (andb H1 (fold_right andb true (map H2 (pos_list _)))).
      + intros k _ _ H1 H2; exact (andb H1 H2).
      + intros; exact false.
    Defined.

    Let fold_right_andb l : fold_right andb true l = true <-> forall x, In x l -> x = true.
    Proof.
      induction l as [ | x l IHl ]; simpl; try tauto.
      rewrite andb_true_iff, IHl; firstorder; subst; auto.
    Qed.

    Fact prim_rec_bool_spec n f : @prim_rec_bool n f = true <-> prim_rec f.
    Proof.
      induction f as [ x | | | n p | n i f g Hf Hg | n f g Hf Hg | n f Hf ]; simpl; try tauto.
      + rewrite andb_true_iff, fold_right_andb, <- Forall_forall.
        rewrite Forall_map, Forall_forall, Hf.
        split; intros (? & H); split; auto.
        * intros p; apply Hg, H, pos_list_prop.
        * intros x Hx; apply Hg, H.
      + rewrite andb_true_iff, Hf, Hg; tauto.
      + split; try tauto; discriminate.
    Qed.

    Hint Resolve ra_cst_tot ra_zero_tot ra_succ_tot ra_proj_tot ra_rec_tot : core.

    Fact prim_rec_tot k f : @prim_rec k f -> total [|f|].
    Proof.
      induction f as [ x | | | n p | n i f g Hf Hg | n f g Hf Hg | n f Hf ]; intros H; simpl in H; auto.
      + apply ra_comp_tot; try tauto; intros; apply Hg, H.
      + apply ra_rec_tot; tauto.
      + tauto.
    Qed.

  End prim_rec.

End relational_semantics.

Arguments s_zero v x /.
Arguments s_cst c v x /.
Arguments s_proj {k} p v x /.
Arguments s_succ v x /.

Definition MUREC_PROBLEM := recalg 0.
Definition MUREC_HALTING : MUREC_PROBLEM -> Prop.
Proof. intros f; exact (ex (ra_rel f vec_nil)). Defined.


(* --------------------------------------------------------------------
 * (c) Copyright 2014--2015 INRIA.
 *
 * You may distribute this file under the terms of the CeCILL-B license
 * -------------------------------------------------------------------- *)

Require Import Reals Rtrigo1.
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice.
From mathcomp Require Import fintype div finfun bigop finset ssralg poly ssrnum.
From mathcomp Require Import ssrint rat polydiv mxpoly intdiv.
From mathcomp Require Import fieldext separable algC polyorder complex.
From Lindemann Require Import archi Rstruct.

Import GRing.Theory Num.Def Num.Theory complex ComplexField Archi.Theory.

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

Open Scope ring_scope.

(* Definition des complexes sur les réels de Coq *)

Definition complexR := R[i].

Canonical complexR_eqType := [eqType of complexR].
Canonical complexR_choiceType := [choiceType of complexR].
Canonical complexR_zmodType := [zmodType of complexR].
Canonical complexR_lmodType := Eval hnf in [lmodType R of complexR].
Canonical complexR_ringType := [ringType of complexR].
Canonical complexR_comRingType := [comRingType of complexR].

Section complexR_algebraType.

Lemma complexR_scaleAl (k : R) (x y : complexR) :
  k *: (x * y) = k *: x * y.
Proof. by move: x y=> [xR xI] [yR yI]; simpc; rewrite mulrBr mulrDr !mulrA. Qed.

Lemma complexR_scaleAr (k : R) (x y : complexR) :
  k *: (x * y)  = x * (k *: y).
Proof.
move: x y=> [xR xI] [yR yI]; simpc.
by rewrite mulrBr mulrDr ![k * (_ * _)]mulrCA.
Qed.

End complexR_algebraType.

Canonical complexR_lalgType := LalgType R complexR complexR_scaleAl.
Canonical complexR_algType := AlgType R complexR complexR_scaleAr.
Canonical complexR_unitRingType := [unitRingType of complexR].
Canonical complexR_comUnitRingType := [comUnitRingType of complexR].
Canonical complexR_unitAlgType := Eval hnf in [unitAlgType R of complexR].
Canonical complexR_idomainType := [idomainType of complexR].
Canonical complexR_fieldType := [fieldType of complexR].
Canonical complexR_decDieldType := [decFieldType of complexR].
Canonical complexR_closedFieldType := [closedFieldType of complexR].
Canonical complexR_numDomainType := [numDomainType of complexR].
Canonical complexR_numFieldType := [numFieldType of complexR].
Canonical complexR_numClosedFieldType := [numClosedFieldType of complexR].
Canonical complexR_archiNumDomainType := [archiNumDomainType of complexR].
Canonical complexR_archiNumFieldType := [archiNumFieldType of complexR].
Canonical complexR_archiNumClosedFieldType := [archiNumClosedFieldType of complexR].

(* Récupération des notations *)

Notation Creal := (@Num.Def.Rreal complexR_numDomainType).
Notation Cint := (@Cint complexR_archiNumDomainType).
Notation Cnat := (@Cnat complexR_archiNumDomainType).

(* Injections *)

Notation QtoC := (ratr : rat -> complexR).
Notation ZtoQ := (intr : int -> rat).

Notation ZtoC := (intr : int -> complexR).

Definition ZtoCE :=
  let CnF := complexR_numFieldType in
  let ZtoCm := intmul1_rmorphism CnF in
  ((rmorph0 ZtoCm, rmorph1 ZtoCm, rmorphMn ZtoCm, rmorphN ZtoCm, rmorphD ZtoCm),
   (rmorphM ZtoCm, rmorphX ZtoCm),
   (rmorphMz ZtoCm, @intr_norm CnF, @intr_sg CnF, @intr_eq0 CnF),
   =^~ (@ler_int CnF, @ltr_int CnF, (inj_eq (@intr_inj CnF)))).

(* retour à R depuis les complexes *)
Notation norm_R := ComplexField.normc.
(*
Canonical Re_R_additive := [additive of Re_R].
Canonical Im_R_additive := [additive of Im_R].*)

Ltac RtoC_simpl :=
  rewrite -?complexRe -?complexIm -?[`| _ |]/(((norm_R _)%:C)%C) -?[((_)%:C)%C]/(_%:A) /=.

Notation RtoC := (real_complex R : R -> complexR).

Lemma RtoC_inj : injective RtoC.
Proof. by move => x y /eqP; rewrite eq_complex /= eq_refl andbT => /eqP. Qed.

Lemma RtoC_norm x : RtoC `|x| = `|RtoC x|.
Proof.
rewrite normc_def; RtoC_simpl; apply/eqP; rewrite (inj_eq RtoC_inj); apply/eqP.
by rewrite expr0n /= addr0 sqrtr_sqr.
Qed.

Lemma ler_RtoC x y : (RtoC x <= RtoC y) = (x <= y).
Proof. by rewrite -lecR; RtoC_simpl. Qed.

Lemma ltr_RtoC x y : (RtoC x < RtoC y) = (x < y).
Proof. by rewrite -ltcR; RtoC_simpl. Qed.

Definition RtoCE :=
  let CnF := R_rcfType in
  let RtoCm := real_complex_rmorphism CnF in
  ((rmorph0 RtoCm, rmorph1 RtoCm, rmorphMn RtoCm, rmorphN RtoCm, rmorphD RtoCm),
   (rmorphM RtoCm, rmorphX RtoCm),
   (rmorphMz RtoCm, RtoC_norm),
   =^~ (ler_RtoC, ltr_RtoC, (inj_eq RtoC_inj))).

(* tactiques *)
Definition C_simpl :=
  (addr0, add0r, subr0, mulr0, mul0r, mulr1, mul1r, mulr0n, mulrS, expr0, exprS).

(* complex exponential *)

Definition Cexp (z : complexR) : complexR :=
  RtoC (exp(Re z)) * (RtoC (cos (Im z)) + 'i * RtoC (sin (Im z))).

Lemma Cexp_exp x :
  x \in Creal -> Cexp(x) = RtoC (exp(Re x)).
Proof.
move=> /Creal_ImP; RtoC_simpl; rewrite /Cexp => /eqP.
rewrite /eqP fmorph_eq0 => /eqP ->; rewrite sin_0 cos_0 /=.
by rewrite !RtoCE !C_simpl.
Qed.

Lemma Cexp0 :
  Cexp(0) = 1.
Proof. by rewrite /Cexp /= sin_0 cos_0 !RtoCE !C_simpl expR0. Qed.

Lemma CexpRD x y :
  Cexp(x) * Cexp(y) = Cexp(x + y).
Proof.
rewrite /Cexp mulrA [X in X *_ = _]mulrC mulrA -rmorphM /= expRD -mulrA.
congr (_ * _); first by rewrite !raddfD addrC RplusE //=.
rewrite !raddfD /= mulC_rect -!rmorphM -rmorphD -rmorphB /= cosD sinD.
by congr (_ + _ * _); rewrite addrC mulrC.
Qed.

Lemma Cexp_morph : {morph Cexp : x y / x + y >-> x * y}.
Proof. by move=> x y; rewrite CexpRD. Qed.

Lemma CexpRX x :
  forall n : nat,
    Cexp(x) ^+ n = Cexp(x *+ n).
Proof.
elim => [|n Ihn]; rewrite !C_simpl; first by rewrite Cexp0.
by rewrite Ihn Cexp_morph.
Qed.

Lemma CscaleE (x : R) (y : complexR) :
  x *: y = RtoC x * y.
Proof. by case: y => [yr yi]; rewrite /GRing.scale /= /RtoC; simpc. Qed.

Section MinPoly.

Local Notation "x 'is_algebraic'" := (algebraicOver QtoC x)
  (at level 55).
 (*
Lemma poly_caract_root (F E : fieldType) (f : {rmorphism F -> E}) x :
    algebraicOver f x -> x != 0 ->
    {p : {poly F} | [&& p \is monic, root (map_poly f p) x & p`_0 != 0]}.
Proof.
move=> /integral_algebraic /sig2W[p pmonic proot] xneq0.
wlog p_0: p proot pmonic / p`_0 != 0=> [hwlog|]; last by exists p; apply/and3P.
have pneq0 : p != 0 by rewrite monic_neq0.
About multiplicity_XsubC.
have [n ] := multiplicity_XsubC p 0
/implyP /(_ pneq0) rootqN0 p_eq]] := multiplicity_XsubC p 0.
move: pneq0 proot pmonic.
rewrite p_eq rmorphM rootM rmorphX rmorphB rmorph0 /= map_polyX => pn0 pr pm.
have qmonic : q \is monic by move: pm; rewrite monicMr ?monic_exp ?monicXsubC.
have qn : q`_0 != 0 by rewrite -horner_coef0.
have qr : root (map_poly f q) x.
  move: pr; case: {p_eq pn0 pm} n => [|n] .
    by rewrite expr0 rootC oner_eq0 orbF.
  by rewrite rmorph0 root_exp_XsubC (negPf xneq0) orbF.
exact: (hwlog q).
Qed.*)

Lemma separable_polyZ (R : idomainType) (p : {poly R}) (a : R) :
    a != 0 -> separable_poly (a *: p) = separable_poly p.
Proof.
by move=> an0; rewrite /separable_poly derivZ coprimep_scalel ?coprimep_scaler.
Qed.

Definition psep (R : idomainType) (p : {poly R}) :=
  let p_ := gcdp p (deriv p) in
    (lead_coef p_) *: (p %/ p_).

Lemma psep_separable (R : idomainType) (p : {poly R}) :
  p != 0 -> separable_poly (psep p).
Proof.
move=> p_neq0; rewrite /psep separable_polyZ ?make_separable //.
by rewrite lead_coef_eq0 gcdp_eq0 negb_and p_neq0.
Qed.

Lemma psep_neq0 (R : idomainType) (p : {poly R}) :
  p != 0 -> psep p != 0.
Proof.
move=> p_neq0; pose p_ := gcdp p (deriv p).
have lc_neq0 : lead_coef p_ != 0.
  by rewrite lead_coef_eq0 gcdp_eq0 negb_and p_neq0.
by rewrite /psep scale_poly_eq0 negb_or lc_neq0 andTb dvdp_div_eq0 ?dvdp_gcdl.
Qed.

(*
Lemma psep_monic (R : fieldType) (p : {poly R}) :
  p \is monic -> psep p \is monic.
Proof.
move=> monic_p; pose p_ := gcdp p (deriv p).
have lc_neq0 : lead_coef p_ != 0.
  by rewrite lead_coef_eq0 gcdp_eq0 negb_and monic_neq0.
have p_monic : (lead_coef p_)^-1 *: p_ \is monic.
  by apply/monicP; rewrite lead_coefZ mulrC mulfV.
rewrite -(monicMr _ p_monic) /psep -/p_ -scalerCA scalerA mulrC mulfV //.
by rewrite scale1r divpK // /p_ dvdp_gcdl.
Qed.*)

(* TODO : these 3 next lemmas should be modified in real_closed/polyorder *)
Lemma size_deriv (R : numDomainType) (p : {poly R}) : size p^`() = (size p).-1.
Proof.
have [lep1|lt1p] := leqP (size p) 1.
  by rewrite {1}[p]size1_polyC // derivC size_poly0 -subn1 (eqnP lep1).
rewrite size_poly_eq // mulrn_eq0 -subn2 -subSn // subn2.
by rewrite lead_coef_eq0 -size_poly_eq0 -(subnKC lt1p).
Qed.

Lemma mu_deriv (R : numDomainType) x (p : {poly R}) : root p x ->
  \mu_x (p^`()) = (\mu_x p - 1)%N.
Proof.
move=> px0; have [-> | nz_p] := eqVneq p 0; first by rewrite derivC mu0.
have [q nz_qx Dp] := mu_spec x nz_p.
case Dm: (\mu_x p) => [|m]; first by rewrite Dp Dm mulr1 (negPf nz_qx) in px0.
rewrite subn1 Dp Dm !derivCE exprS mul1r mulrnAr -mulrnAl mulrA -mulrDl.
rewrite cofactor_XsubC_mu // rootE !(hornerE, hornerMn) subrr mulr0 add0r.
by rewrite mulrn_eq0.
Qed.

Lemma mu_deriv_root (R : numDomainType) x (p : {poly R}) : p != 0 -> root p x ->
  \mu_x p  = (\mu_x (p^`()) + 1)%N.
Proof.
by move=> p0 rpx; rewrite mu_deriv // subn1 addn1 prednK // mu_gt0.
Qed.

Lemma psep_root (F E : numFieldType) (f : {rmorphism F -> E}) (p : {poly F}) (x : E) :
  p != 0 -> root (map_poly f p) x -> root (map_poly f (psep p)) x.
Proof.
move=> p_neq0 root_p; pose p_ := gcdp p (deriv p).
have lc_neq0 : lead_coef p_ != 0.
  by rewrite lead_coef_eq0 gcdp_eq0 negb_and p_neq0.
rewrite map_polyZ /=; apply/rootP/eqP.
rewrite hornerZ mulf_eq0; apply/orP; right; apply/eqP/rootP.
move: (divpK (dvdp_gcdl p (deriv p))); rewrite -/p_ => eq_p.
rewrite -mu_gt0; last first.
  rewrite map_poly_eq0; apply/negP => /eqP H; rewrite H mul0r in eq_p.
  by rewrite -eq_p eq_refl in p_neq0.
have fp_neq0 : (map_poly f (p %/ p_)) * (map_poly f p_) != 0.
  by rewrite -rmorphM eq_p map_poly_eq0.
rewrite -(ltn_add2r (\mu_x (map_poly f p_))) add0n -mu_mul //.
rewrite -rmorphM /= divpK ?dvdp_gcdl //.
rewrite (mu_deriv_root _ root_p) ?map_poly_eq0 // addn1 ltnS /p_ /=.
rewrite gcdp_map deriv_map /=.
have H := (divpK (dvdp_gcdr (map_poly f p) (map_poly f p^`()))).
rewrite -{2}H mu_mul ?leq_addl // H -size_poly_eq0 -deriv_map size_deriv.
rewrite -lt0n -ltnS prednK; last by rewrite lt0n size_poly_eq0 map_poly_eq0.
by apply: (root_size_gt1 _ root_p); rewrite map_poly_eq0.
Qed.

Section MinPoly_byalgC.

Lemma poly_caract_byalgC x : x is_algebraic ->
  {p | [/\ (p \is monic), separable_poly p, irreducible_poly p &
    forall q, root (map_poly QtoC q) x = (p %| q)]}.
Proof.
move=> /integral_algebraic /sig2W[p pmonic proot].
move H : (size p) => n.
case: n H.
  by move/eqP; move/monic_neq0: pmonic; rewrite -size_poly_eq0 => /negbTE ->.
case => [size_p | n eq_n].
  move/(root_size_gt1 _): proot; rewrite map_poly_eq0 => H.
  by move/monic_neq0: pmonic; move/H; rewrite size_map_poly size_p.
elim: n {-2}n (leqnn n) p pmonic proot eq_n => [n /= |].
  rewrite leqn0 => /eqP -> p pmonic proot_x size_p.
  exists p; split => // [||q].
  + move/eqP: (size_deriv p); rewrite size_p /= => /size_poly1P[a a_neq0 eq_p'].
    by rewrite /separable_poly eq_p' -alg_polyC coprimep_scaler ?coprimep1.
  + rewrite /irreducible_poly size_p.
    split => // q size_q div_q; rewrite -dvdp_size_eqp // eqn_leq.
    apply/andP; split; first by apply/dvdp_leq; first apply/monic_neq0.
    rewrite size_p ltn_neqAle eq_sym size_q /= lt0n size_poly_eq0.
    by apply/(dvdpN0 div_q (monic_neq0 pmonic)).
  + move: proot_x; rewrite !root_factor_theorem => /dvdp_size_eqp.
    rewrite size_XsubC size_map_poly size_p eq_refl => /esym H.
    rewrite -(dvdp_map (ratr_rmorphism complexR_numFieldType)) /=.
    by apply/eqp_dvdl.
move=> n ihn np lenp p pmonic proot_x size_p.
have [s_root eq_s] := (closed_field_poly_normal
                                    (map_poly (ratr_rmorphism algCnumField) p)).
pose xC := nth 0 s_root 0.
have proot_xC : root (map_poly ratr p) xC.
  apply/rootP/eqP; rewrite eq_s hornerZ mulf_eq0 lead_coef_eq0 map_poly_eq0.
  rewrite (negbTE (monic_neq0 _)) //= horner_prod prodf_seq_eq0.
  apply/hasP; exists xC; last by rewrite andTb hornerXsubC subrr.
  rewrite /xC mem_nth //.
  have -> : size s_root = (size p).-1.
    rewrite -(size_map_poly (ratr_rmorphism algCnumField)) /= eq_s size_scale.
      by rewrite size_prod_XsubC.
    by rewrite lead_coef_eq0 map_poly_eq0 monic_neq0 ?pmonic.
  by rewrite size_p /=.
have isQ := algebraics_fundamentals.rat_algebraic_decidable
                                 Algebraics.Implementation.algebraic.
have [q [qmonic root_qxC irr_q]] :=
     algebraics_fundamentals.minPoly_decidable_closure isQ
                                    (Algebraics.Implementation.algebraic xC).
have size_q : (1 < size q)%N.
  rewrite -(size_map_poly (ratr_rmorphism algCnumField)).
  by rewrite (@root_size_gt1 _ xC) ?map_poly_eq0 ?monic_neq0.
case: (boolP (root (map_poly ratr q) x)) => [qroot_x | q_notroot].
  exists q; do? split => //.
    suff -> : q = psep q by rewrite psep_separable ?monic_neq0.
    move/(irredp_XsubCP irr_q): (dvdp_gcdl q q^`()) => [].
      rewrite /psep; move/eqp_eq; rewrite lead_coef1 scale1r => ->.
      set z := lead_coef (gcdp _ _); rewrite alg_polyC lead_coefC -mul_polyC.
      rewrite divpKC //; apply/modp_eq0P; rewrite modpC // /z lead_coef_eq0.
      rewrite gcdp_eq0 negb_and -size_poly_eq0 -lt0n.
      by apply/orP; left; rewrite (ltn_trans _ size_q).
    move/eqp_size/esym/eq_leq; have := (@leq_gcdpr _ q q^`()) .
    rewrite -size_poly_eq0 size_deriv -lt0n -(ltn_add2r 1) ?addn1 prednK //.
      move/(_ size_q) => legcdp_1 le_q_gcdp.
      move: (leq_trans le_q_gcdp legcdp_1).
      by rewrite -ltnS prednK ?ltnn // (ltn_trans _ size_q).
    by rewrite (ltn_trans _ size_q).
  move=> q0; apply/idP/idP=> [q0root_x | /dvdpP[r ->]]; last first.
    by rewrite rmorphM rootM qroot_x orbT.
  suffices /eqp_dvdl <-: gcdp q q0 %= q by apply: dvdp_gcdr.
  rewrite irr_q ?dvdp_gcdl ?gtn_eqF // -(size_map_poly (ratr_rmorphism complexR_numFieldType)).
  rewrite gcdp_map /= (@root_size_gt1 _ x) ?root_gcd ?q0root_x ?qroot_x //.
  by rewrite gcdp_eq0 negb_and map_poly_eq0 monic_neq0.
have: (q %| p).
  suffices /eqp_dvdl <-: gcdp q p %= q by apply: dvdp_gcdr.
  rewrite irr_q ?dvdp_gcdl ?gtn_eqF //.
  rewrite -(size_map_poly (ratr_rmorphism algCnumField)) gcdp_map /=.
  rewrite (@root_size_gt1 _ xC) ?root_gcd ?px0 //.
    by rewrite gcdp_eq0 negb_and map_poly_eq0 monic_neq0.
  by rewrite proot_xC root_qxC.
rewrite dvdp_eq; set r := _ %/ _ => /eqP eq_p.
have rmonic : r \is monic.
  by move/(monicMr r): qmonic; rewrite -eq_p pmonic.
have root_r : root (map_poly ratr r) x.
  by move: proot_x; rewrite eq_p rmorphM /= rootM (negbTE q_notroot) orbF.
have size_r : (1 < size r)%N.
  rewrite -(size_map_poly (ratr_rmorphism complexR_numFieldType)).
  by rewrite (@root_size_gt1 _ x) ?map_poly_eq0 ?monic_neq0.
have Hsize : ((size r).-2 <= n)%N.
  rewrite -(leq_add2r 1) !addn1.
  apply: (leq_trans _ lenp); rewrite -(leq_add2r 2) !addn2.
  rewrite -size_p prednK ?prednK //; first last.
  + by rewrite -(ltn_add2r 1) ?addn1 prednK // (ltn_trans _ size_r).
  + by rewrite (ltn_trans _ size_r).
  + rewrite eq_p size_monicM ?monic_neq0 //.
    rewrite -subn1 -addnBA ?subn1 ?(ltn_trans _ size_q) //.
    rewrite -[X in (X < _)%N]addn0 ltn_add2l.
    by rewrite -(ltn_add2r 1) ?addn1 prednK // (ltn_trans _ size_q).
apply: (ihn (size r).-2 Hsize r rmonic root_r).
rewrite prednK ?prednK //.
  by rewrite (ltn_trans _ size_r).
by rewrite -(ltn_add2r 1) ?addn1 prednK // (ltn_trans _ size_r).
Qed.

End MinPoly_byalgC.

(*
Lemma psep_coef0 (R : fieldType) (p : {poly R}) :
  p`_0 != 0 -> (psep p)`_0 != 0.
Proof.
move=> p0.
rewrite coefZ mulf_eq0 negb_or; apply/andP; split.
  rewrite lead_coef_eq0 gcdp_eq0 negb_and; apply/orP; left.
  by apply/negP => /eqP p_eq0; rewrite p_eq0 coef0 eq_refl in p0.
apply/negP => /eqP eqr; move/negP : p0; apply.
rewrite -(divpK (dvdp_gcdl p (deriv p))) coefM big1 // => i _.
have -> : nat_of_ord i = 0%N by apply/eqP; rewrite -leqn0 -ltnS.
by rewrite eqr mul0r.
Qed.
*)
(*
Lemma poly_sep (F E : numFieldType) (f : {rmorphism F -> E})
  (n : nat) (P : {ffun 'I_n -> {poly F}}) (x : {ffun 'I_n -> E}) :
  (forall i, root (map_poly f (P i)) (x i)) ->
  (forall i, P i \is monic) -> exists p : {poly F},
  [&& p \is monic, [forall i, root (map_poly f p) (x i)] & separable_poly p].
Proof.
move=> root_p monic_p.
pose r := \prod_(i < n) P i.
have r_neq0 : r != 0 by apply/prodf_neq0 => i _; rewrite monic_neq0.
have monic_r : r \is monic by apply: monic_prod.
have root_r i : root (map_poly f r) (x i).
  apply/rootPt; rewrite rmorph_prod horner_prod; apply/prodf_eq0.
  by exists i; rewrite //= (rootP (root_p i)).
pose p_ := gcdp r (deriv r); pose lc_ := (lead_coef p_).
have lc_neq0 : lc_ != 0.
  by rewrite /lc_ lead_coef_eq0 gcdp_eq0 negb_and r_neq0.
have lc_p_monic : lc_^-1 *: p_ \is monic.
  by apply/monicP; rewrite lead_coefZ mulrC mulfV.
exists (lc_ *: (r %/ p_)); apply/and3P; split.
+ rewrite -(monicMr _ lc_p_monic) -scalerCA scalerA mulrC mulfV //.
  by rewrite scale1r divpK // /p_ dvdp_gcdl.
+ apply/forallP => i; rewrite map_polyZ; apply/rootP/eqP.
  rewrite hornerZ mulf_eq0; apply/orP; right; apply/eqP/rootP.
  move: (divpK (dvdp_gcdl r (deriv r))); rewrite -/p_ => eq_p.
  rewrite -mu_gt0; last first.
    rewrite map_poly_eq0; apply/negP => /eqP H; rewrite H mul0r in eq_p.
    by rewrite -eq_p eq_refl in r_neq0.
  have rp_neq0 : (map_poly f (r %/ p_)) * (map_poly f p_) != 0.
    by rewrite -rmorphM eq_p map_poly_eq0.
  rewrite -(ltn_add2r (\mu_(x i) (map_poly f p_))) add0n -mu_mul //.
  rewrite -rmorphM /= divpK ?dvdp_gcdl //.
  rewrite (mu_deriv_root _ (root_r i)) ?map_poly_eq0 // addn1 ltnS /p_ /=.
  rewrite gcdp_map deriv_map /=.
  have H := (divpK (dvdp_gcdr (map_poly f r) (map_poly f r^`()))).
  rewrite -{2}H mu_mul ?leq_addl // H -size_poly_eq0 -deriv_map size_deriv.
  rewrite -lt0n -ltnS prednK; last by rewrite lt0n size_poly_eq0 map_poly_eq0.
  by apply: (root_size_gt1 _ (root_r i)); rewrite map_poly_eq0.
+ by rewrite separable_polyZ ?make_separable.
Qed.
*)

Lemma ratr_eq0 (x : rat) : ((QtoC x) == (0: complexR)) = (x == 0).
Proof.
by rewrite -numq_eq0 mulf_eq0 invr_eq0 !intr_eq0 (negbTE (denq_neq0 x)) orbF.
Qed.

Lemma polyZ_algebraic (x : complexR) (p : {poly int}) :
  p != 0 -> root (map_poly ZtoC p) x -> x is_algebraic.
Proof.
move=> p_neq0 rootpx; rewrite /algebraicOver.
exists (map_poly intr p).
  by rewrite map_poly_eq0_id0 // intr_eq0 lead_coef_eq0.
have ZtoQtoC : QtoC \o intr =1 ZtoC by move=> y /=; rewrite ratr_int.
by rewrite -map_poly_comp (eq_map_poly ZtoQtoC).
Qed.

Lemma poly_algebraic (x : complexR) (p : {poly complexR}) :
  p != 0 -> root p x -> p \is a polyOver Cint -> x is_algebraic.
Proof.
move=> p_neq0 rootpx /floorCpP[q eq_p_q]; rewrite /algebraicOver.
have ZtoQtoC : QtoC \o intr =1 ZtoC by move=> y /=; rewrite ratr_int.
exists (map_poly intr q).
  move: p_neq0; rewrite eq_p_q -(eq_map_poly ZtoQtoC) map_poly_comp.
  by rewrite map_poly_eq0.
by rewrite -map_poly_comp (eq_map_poly ZtoQtoC) -eq_p_q.
Qed.

Lemma poly_caract_int (x : complexR) : x is_algebraic ->
    {p : {poly int} | [/\ (zcontents p = 1),
      irreducible_poly p, separable_poly (map_poly ZtoC p)
      & forall q : {poly int}, root (map_poly ZtoC q) x = (p %| q)]}.
Proof.
move=> algebraic_x.
have [r [mon_r sep_r [irr_r div_r] root_r]] := (poly_caract_byalgC algebraic_x).
have [q [a a_neq0 r_eq]] := (rat_poly_scale r).
have q_neq0 : q != 0.
  apply/negP => /eqP q_eq0; move: r_eq; rewrite q_eq0 map_poly0 scaler0.
  by apply/eqP/monic_neq0.
have eq_qz : map_poly ZtoQ (zprimitive q) = ((zcontents q)%:~R^-1 * a%:~R) *: r.
  rewrite r_eq -scalerA [X in _ *: X]scalerA mulfV ?intr_eq0 ?a_neq0 // scale1r.
  rewrite [X in _ *: map_poly _ X]zpolyEprim map_polyZ scalerA mulrC.
  by rewrite mulfV ?scale1r // intr_eq0 zcontents_eq0 q_neq0.
have ZtoQtoC : QtoC \o intr =1 ZtoC by move=> y /=; rewrite ratr_int.
exists (zprimitive q); split.
+ by rewrite zcontents_primitive q_neq0.
+ split.
    rewrite -size_rat_int_poly eq_qz size_scale //.
    by rewrite mulf_neq0 ?invr_neq0 ?intr_eq0 ?zcontents_eq0.
  move=> p; rewrite -size_rat_int_poly.
  move=> size_p; rewrite -dvdp_rat_int eq_qz dvdp_scaler; last first.
    by rewrite mulf_neq0 ?invr_neq0 ?intr_eq0 ?zcontents_eq0.
  move/(div_r _ size_p)/eqpP => [[b1 b2]] /= /andP[b1_n0 b2_n0] eq_b.
  rewrite -dvdp_size_eqp.
    rewrite size_zprimitive -size_rat_int_poly -(size_scale _ b1_n0) eq_b.
    rewrite (size_scale _ b2_n0) r_eq size_scale ?invr_eq0 ?intr_eq0 //.
    by rewrite size_rat_int_poly.
  rewrite -dvdp_rat_int eq_qz; apply/dvdpP.
  set u := (_ * _).
  exists (u * b2^-1 * b1)%:P.
  rewrite mul_polyC -[in RHS]scalerA -[in RHS]scalerA eq_b.
  by congr (u *: _); rewrite scalerA mulrC mulfV ?scale1r.
+ rewrite -(eq_map_poly ZtoQtoC) map_poly_comp eq_qz /= map_polyZ /=.
  rewrite separable_polyZ ?separable_map //.
  by rewrite ratr_eq0 mulf_neq0 ?invr_eq0 ?intr_eq0 ?zcontents_eq0.
+ move=> p; rewrite -(eq_map_poly ZtoQtoC) map_poly_comp root_r r_eq.
  rewrite dvdp_scalel ?invr_eq0 ?intr_eq0 //.
  by rewrite dvdp_rat_int [q in LHS]zpolyEprim dvdp_scalel ?zcontents_eq0.
Qed.

(*
Lemma poly_caract_int (x : complexR) : x is_algebraic -> x != 0 ->
    exists p : {poly int}, [&& (p != 0), root (map_poly ZtoC p) x,
    (p`_0 != 0), (0 < lead_coef p) & separable_poly (map_poly ZtoC p)].
Proof.
move => algebraic_x xn0.
have [r /andP[monr /andP[rootr r0_neq0]]] := (poly_caract_root algebraic_x xn0).
have monp := (psep_monic monr).
have rootp := (psep_root (monic_neq0 monr) rootr).
have p0_neq0 := (psep_coef0 r0_neq0).
have sepp := (psep_separable (monic_neq0 monr)).
have : {q : {poly int} & {a : int_ZmodType | (0 < a)
     & psep r = a%:~R^-1 *: map_poly (intr : int -> rat) q}}.
  have [p_ [a /negbTE a_neq0 eq_p_p_]] := rat_poly_scale (psep r).
  have [a_gt0 | a_le0 | /eqP] := (ltrgt0P a); last by rewrite a_neq0.
    by exists p_; exists a.
  exists (- p_); exists (- a); rewrite ?oppr_gt0 //.
  by rewrite !rmorphN invrN /= scaleNr scalerN opprK.
move=> [p_ [a a_gt0 eq_p_p_]].
have a_neq0 : ratr a%:~R != 0 :> complexR.
  by rewrite ratr_int intr_eq0 lt0r_neq0.
have p_0_neq0 : p_`_0 != 0.
  apply/negP => /eqP p_eq0; move/negP: p0_neq0; apply.
  by rewrite eq_p_p_ coefZ coef_map p_eq0 mulr0.
have p__neq0 : p_ != 0.
  by apply/negP => /eqP p__eq0; move/negP: p_0_neq0; rewrite p__eq0 coef0.
have eq_p__p : (map_poly intr p_) = a%:~R *: (psep r).
  by rewrite eq_p_p_ scalerA mulfV ?scale1r // intr_eq0; apply: lt0r_neq0.
have lc_p_gt0 : (0 < (lead_coef p_)).
  have H : (lead_coef p_)%:~R = a%:~R * lead_coef (psep r).
    rewrite eq_p_p_ lead_coefZ lead_coef_map_eq ?intr_eq0 ?lead_coef_eq0 //.
    by rewrite mulrA mulfV ?mul1r // intr_eq0; apply: (lt0r_neq0 a_gt0).
  by rewrite -(ltr0z rat_numDomainType) H (monicP monp) mulr1 ltr0z.
have ZtoQtoC : QtoC \o intr =1 ZtoC by move=> y /=; rewrite ratr_int.
have root_map_p : root (map_poly intr p_) x.
  by rewrite -(eq_map_poly ZtoQtoC) map_poly_comp eq_p__p map_polyZ /= rootZ.
exists p_; apply/and5P; split; rewrite //.
rewrite -(eq_map_poly ZtoQtoC) map_poly_comp eq_p__p map_polyZ /=.
by rewrite (separable_polyZ _ a_neq0) separable_map.
Qed.*)
(*
Lemma polyMinZ_subproof (x : complexR) : x is_algebraic -> x != 0 ->
    {p : {poly int} | [&& (p != 0), root (map_poly ZtoC p) x,
    (p`_0 != 0), (0 < lead_coef p) & separable_poly (map_poly ZtoC p)]}.
Proof.
move => x_alg x_neq0.
have [p /and5P] := (sigW (poly_caract_int x_alg x_neq0)).
move => [p_neq0 rootp p0_neq0 lc_gt0 p_sep].
exists p; apply/and5P; split; rewrite ?p_sep ?andbT //.
Qed.

Definition polyMinZ (x : complexR) (H : x is_algebraic) :=
  match Sumbool.sumbool_of_bool(x != 0) with
  |right _ => 'X
  |left toto => sval(polyMinZ_subproof H toto)
  end.
*)

Definition polyMinZ (x : complexR) (H : x is_algebraic) :=
  sval (poly_caract_int H).

Definition polyMin (x : complexR) (H : x is_algebraic) :=
  map_poly ZtoC (polyMinZ H).

(*
+ by rewrite map_poly_eq0_id0 ?intr_eq0 ?(lt0r_neq0 lc_gt0).
+ by apply/polyOverP => i; rewrite coef_map /= Cint_int.
+ by rewrite coef_map intr_eq0.
by rewrite lead_coef_map_eq ?intr_eq0 ?ltr0z ?lt0r_neq0.
Qed.
*)

Lemma polyMinZ_zcontents (x : complexR) (H : x is_algebraic) :
    zcontents (polyMinZ H) = 1.
Proof. by move: (svalP (poly_caract_int H)) => [->]. Qed.

Lemma polyMinZ_neq0 (x : complexR) (H : x is_algebraic) : (polyMinZ H) != 0.
Proof. by rewrite -zcontents_eq0 polyMinZ_zcontents. Qed.

Lemma polyMin_neq0 (x : complexR) (H : x is_algebraic) : (polyMin H) != 0.
Proof.
by rewrite map_poly_eq0_id0 ?intr_eq0 ?lead_coef_eq0 polyMinZ_neq0.
Qed.

Lemma polyMinZ_irr (x : complexR) (H : x is_algebraic) :
  irreducible_poly (polyMinZ H).
Proof. by move: (svalP (poly_caract_int H)) => []. Qed.

Lemma polyMinZ_root (x : complexR) (H : x is_algebraic) :
  root (map_poly ZtoC (polyMinZ H)) x.
Proof.
move: (svalP (poly_caract_int H)) => [_ _ _ ->].
by rewrite dvdpp.
Qed.

Lemma polyMin_root (x : complexR) (H : x is_algebraic) :
  root (polyMin H) x.
Proof. by rewrite polyMinZ_root. Qed.

Lemma polyMinZ_dvdp (x : complexR) (H : x is_algebraic) (q : {poly int}) :
    root (map_poly ZtoC q) x = ((polyMinZ H) %| q).
Proof. by move: (svalP (poly_caract_int H)) => []. Qed.

Lemma polyMin_dvdp (x : complexR) (H : x is_algebraic) (q : {poly complexR}):
  q \is a polyOver Cint -> root q x = ((polyMin H) %| q).
Proof.
move/floorCpP => [r ->]; rewrite polyMinZ_dvdp -dvdp_rat_int /polyMin.
rewrite -(dvdp_map (ratr_rmorphism complexR_numFieldType)) -!map_poly_comp /=.
by congr ( _ %| _); apply: eq_map_poly => y /=; rewrite ratr_int.
Qed.

Lemma polyMinZ_lcoef_gt0 (x : complexR) (H : x is_algebraic) :
  0 < lead_coef (polyMinZ H).
Proof.
rewrite -sgz_gt0 -sgz_contents.
move: (svalP (poly_caract_int H)) => [-> _ _ _].
by rewrite sgz1.
Qed.

Lemma polyMin_lcoef_gt0 (x : complexR) (H : x is_algebraic) :
  0 < lead_coef (polyMin H).
Proof.
by rewrite lead_coef_map_eq ?intr_eq0 ?ltr0z ?lt0r_neq0 // polyMinZ_lcoef_gt0.
Qed.

Lemma polyMinZ_separable (x : complexR) (H : x is_algebraic) :
  separable_poly (map_poly ZtoC (polyMinZ H)).
Proof. by move: (svalP (poly_caract_int H)) => []. Qed.

Lemma polyMin_separable (x : complexR) (H : x is_algebraic) :
  separable_poly (polyMin H).
Proof. by rewrite polyMinZ_separable. Qed.

Lemma polyMin_over (x : complexR) (H : x is_algebraic) :
  polyMin H \is a polyOver Cint.
Proof.
by rewrite /polyMin; apply/polyOverP => i; rewrite coef_map Cint_int.
Qed.

(*
Lemma polyMinZ_coef0_neq0 (x : complexR) (H : x is_algebraic) :
  ((polyMinZ H)`_0 == 0) = (x == 0).
Proof.
rewrite /polyMinZ.
case : ((Sumbool.sumbool_of_bool (x != 0))) => [a | /eqP ->]; last first.
  by rewrite coefX eq_refl.
move: (svalP (polyMinZ_subproof H a)) => /and5P[_ _ /negbTE -> _ _].
by apply: esym; apply/negP /negP.
Qed.

Lemma polyMin_coef0_neq0 (x : complexR) (H : x is_algebraic) :
  ((polyMin H)`_0 == 0) = (x == 0).
Proof.
by rewrite coef_map intr_eq0 polyMinZ_coef0_neq0.
Qed.
*)

(*
Print coprimep.
Pdiv.CommonIdomain.eqp_dvdl:
  forall (R : idomainType) (d2 d1 p : {poly R}), d1 %= d2 -> (d1 %| p) = (d2 %| p)

dvdp_rat_int: forall p q : {poly int_Ring}, (map_poly ZtoQ p %| map_poly ZtoQ q) = (p %| q)
Search _ gcdp.
Search _ size 1%N.
mul_polyC: forall (R : ringType) (a : R) (p : {poly R}), a%:P * p = a *: p
size1_polyC: forall (R : ringType) (p : {poly R}), (size p <= 1)%N -> p = (p`_0)%:P
dvdp_gcd_idr: forall (R : idomainType) (m n : {poly R}), n %| m -> gcdp m n %= n
leq_gcdpr: forall (R : idomainType) (p q : {poly R}), q != 0 -> (size (gcdp p q) <= size q)%N
separable_root:
  forall (R : idomainType) (p : {poly R}) (x : R),
  separable_poly (p * ('X - x%:P)) = separable_poly p && ~~ root p x

irredp_XsubC: forall (R : idomainType) (x : R), irreducible_poly ('X - x%:P)
poly2_root: forall (F : fieldType) (p : {poly F}), size p = 2 -> {r : F | root p r}

About poly_caract_int.

About algebraic0.
About sigW.
Check (sigW (poly_caract_int (algebraic0 (ratr_rmorphism complexR_numFieldType)))).
*)

Lemma polyMinseq (n : nat) (f : {ffun 'I_n -> complexR}) :
  (forall i : 'I_n, f i is_algebraic) ->
  {p : {poly complexR} | [&& [forall i, root p (f i)],
  separable_poly p, p != 0, p \is a polyOver Cint & (0 < lead_coef p)]}.
Proof.
move=> f_alg; pose p i := polyMinZ (f_alg i); pose Pp := \prod_(i < n) p i.
have Pp_neq0 : Pp != 0 by apply/prodf_neq0 => i _; rewrite /p polyMinZ_neq0.
pose P := psep (map_poly ZtoQ Pp).
have ZtoQtoC : QtoC \o intr =1 ZtoC by move=> y /=; rewrite ratr_int.
have rootP i : root (map_poly QtoC P) (f i).
  apply: psep_root; rewrite ?map_poly_eq0_id0 ?intr_eq0 ?lead_coef_eq0 //.
  rewrite -map_poly_comp (eq_map_poly ZtoQtoC) rmorph_prod /=.
  apply/rootPt; rewrite horner_prod; apply/prodf_eq0; exists i => //.
  by apply/rootPt /polyMinZ_root.
have Psep : separable_poly (map_poly QtoC P).
  rewrite separable_map psep_separable ?map_poly_eq0_id0 //.
  by rewrite intr_eq0 lead_coef_eq0.
have P_neq0 : P != 0.
  by rewrite psep_neq0 // map_poly_eq0_id0 ?intr_eq0 ?lead_coef_eq0.
have : {q : {poly int} & {a : int_ZmodType | (0 < lead_coef q)
       & P = a%:~R^-1 *: map_poly ZtoQ q}}.
  have [p_ [a /negbTE a_neq0 eq_p_p_]] := rat_poly_scale P.
  have lc_p_ : lead_coef p_ != 0.
    rewrite lead_coef_eq0; apply/negP => /eqP p__eq0.
    rewrite p__eq0 map_poly0 scaler0 in eq_p_p_.
    by rewrite eq_p_p_ eq_refl in P_neq0.
  exists ((sgr (lead_coef p_)) *: p_); exists ((sgr (lead_coef p_)) * a).
    by rewrite lead_coefZ -normrEsg normr_gt0.
  rewrite eq_p_p_ map_polyZ rmorphM invfM /=; set x := (sgr _)%:~R.
  by rewrite scalerA mulrC mulrA mulfV ?mul1r ?intr_eq0 ?sgr_eq0.
move=> [p_ [a a_gt0 eq_P_p_]].
have a_neq0 : QtoC a%:~R != 0.
  rewrite ratr_eq0; apply/negP => /eqP a_eq0.
  by rewrite a_eq0 invr0 scale0r in eq_P_p_; rewrite eq_P_p_ eq_refl in P_neq0.
have eq_p__P : map_poly ZtoC p_ = map_poly QtoC (a%:~R *: P).
  rewrite eq_P_p_ scalerA mulfV -?ratr_eq0 // scale1r -map_poly_comp.
  by apply: eq_map_poly.
exists ((ratr a%:~R) *: (map_poly QtoC P)); apply/and5P; split.
+ by apply/forallP => i; rewrite rootZ.
+ by rewrite separable_polyZ.
+ by rewrite scale_poly_eq0 negb_or a_neq0 andTb map_poly_eq0.
+ rewrite -map_polyZ -eq_p__P;
  by apply/polyOverP => i; rewrite coef_map Cint_int.
+ rewrite -map_polyZ -eq_p__P lead_coef_map_eq ?ltr0z //.
  rewrite intr_eq0 lead_coef_eq0; apply/negP => /eqP eq_p_.
by rewrite eq_p_ map_poly0 scaler0 in eq_P_p_; rewrite eq_P_p_ eq_refl in P_neq0.
Qed.

(*
Lemma polyMin_subproof (x : complexR) : x is_algebraic -> x != 0 ->
    {p : {poly int} | [&& (p != 0), root (map_poly ZtoC p) x,
    (p`_0 != 0), (0 < lead_coef p) & separable_poly (map_poly ZtoC p)]}.
Proof.
move => x_alg x_neq0.
have [p /and5P] := (sigW (poly_caract_int x_alg x_neq0)).
move => [p_neq0 rootp p0_neq0 lc_gt0 p_sep].
by exists p; rewrite p_neq0 rootp p0_neq0 lc_gt0 p_sep.
Qed.

Definition polyMin (x : complexR) (H : x is_algebraic) :=
  match Sumbool.sumbool_of_bool(x != 0) with
  |right _ => 'X
  |left toto => sval(polyMin_subproof H toto)
  end.

Lemma polyMin_neq0 (x : complexR) (H : x is_algebraic) : (polyMin H) != 0.
Proof.
rewrite /polyMin.
case : ((Sumbool.sumbool_of_bool (x != 0))) => [a | _]; last first.
  by rewrite polyX_eq0.
by move: (svalP (polyMin_subproof H a)) => /and5P[].
Qed.

Lemma polyMin_root (x : complexR) (H : x is_algebraic) :
  root (map_poly ZtoC (polyMin H)) x.
Proof.
rewrite /polyMin.
case : ((Sumbool.sumbool_of_bool (x != 0))) => [a | /eqP ->]; last first.
  by rewrite map_polyX rootX.
by move: (svalP (polyMin_subproof H a)) => /and5P[].
Qed.

Lemma polyMin_lcoef_gt0 (x : complexR) (H : x is_algebraic) :
  0 < lead_coef (polyMin H).
Proof.
rewrite /polyMin.
case : ((Sumbool.sumbool_of_bool (x != 0))) => [a | _]; last first.
  by rewrite lead_coefX.
by move: (svalP (polyMin_subproof H a)) => /and5P[].
Qed.

Lemma polyMin_coef0_neq0 (x : complexR) (H : x is_algebraic) :
  ((polyMin H)`_0 == 0) = (x == 0).
Proof.
rewrite /polyMin.
case : ((Sumbool.sumbool_of_bool (x != 0))) => [a | /eqP ->]; last first.
  by rewrite coefX eq_refl.
move: (svalP (polyMin_subproof H a)) => /and5P[_ _ /negbTE -> _ _].
by apply/eqP; rewrite eq_sym; apply/eqP/negbTE; rewrite a.
Qed.

Lemma polyMin_separable (x : complexR) (H : x is_algebraic) :
  separable_poly (map_poly ZtoC (polyMin H)).
Proof.
rewrite /polyMin.
case : ((Sumbool.sumbool_of_bool (x != 0))) => [a | _]; last first.
  by rewrite /separable_poly deriv_map derivX rmorph1 coprimep1.
by move: (svalP (polyMin_subproof H a)) => /and5P[].
Qed.

*)

End MinPoly.

(* Inutile ici ?
Lemma Euler :
  1 + Cexp (PI%:C * 'i) = 0.
Proof.
rewrite /Cexp ImiRe ReiNIm -complexr0 /= cos_PI sin_PI !complexr0.
rewrite oppr0 exp_0 mul1r; apply/eqP.
by rewrite eq_complex /= addr0 addrN eq_refl.
Qed. *)

(* Utile ?
Lemma ReM (x : complexR) y :
  Re_R (x * (RtoC y)) = (Re_R x) * y.
Proof. by rewrite real_complexE; case: x => r i /=; rewrite !C_simpl. Qed.

Lemma ImM (x : complexR) y :
  Im (x * y%:C) = (Im x) * y.
Proof.
rewrite real_complexE; case: x => r i.
by rewrite mulcalc /= mulr0 add0r.
Qed.

Lemma ReX (y : R) n :
  Re (y%:C ^+ n) = y ^+ n.
Proof.
elim: n => [| n Ihn].
  by rewrite !expr0 /=.
by rewrite !exprS mulrC ReM Ihn mulrC.
Qed.

Lemma ImX (y : R) n :
  Im (y%:C ^+ n) = 0.
Proof.
elim: n => [| n Ihn].
  by rewrite !expr0 /=.
by rewrite !exprS mulrC ImM Ihn mul0r.
Qed. *)


(** * Reasoning about least fixed points *)

Require Import Coq.Program.Basics.
Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Classes.Morphisms.
Require Export Combinators.
Open Scope code_scope.

(** ** Suprema of sequences *)

Fixpoint power {Var : Set} (f : Code Var) (n : nat) : Code Var :=
  match n with
  | 0 => I
  | Succ n' => f o (power f n')
  end.

Notation "f ^ n" := (power f n) : code_scope.

Lemma power_0 (Var : Set) (f x : Code Var) : f ^ 0 * x == x.
Proof.
  simpl; beta_simpl; auto.
Qed.

Lemma power_1 (Var : Set) (f x : Code Var) : f ^ 1 * x == f * x.
Proof.
  simpl; beta_simpl; auto.
Qed.

Lemma power_2 (Var : Set) (f x : Code Var) : f ^ 2 * x == f * (f * x).
Proof.
  simpl; beta_simpl; auto.
Qed.

Lemma power_0' (Var : Set) (f : Code Var) : f ^ 0 == I.
Proof.
  beta_eta.
Qed.

Lemma power_1' (Var : Set) (f : Code Var) : f ^ 1 == f.
Proof.
  simpl; beta_eta.
Qed.

Hint Rewrite power_0 power_1 power_0' power_1' : code_simpl.

Lemma power_commute_1 (Var : Set) (f x : Code Var) (n : nat) :
  f * (f^n * x) == f^n * (f * x).
Proof.
  induction n; simpl; code_simpl; auto.
Qed.

Lemma power_commute_1' (Var : Set) (f : Code Var) (n : nat) :
  f o f^n == f^n o f.
Proof.
  induction n; simpl; code_simpl; auto.
Qed.

Lemma power_add (Var : Set) (f x : Code Var) (m n : nat) :
  f^(m + n) * x == f^m * (f^n * x).
Proof.
  induction m; induction n; simpl; code_simpl; auto.
  - replace (m + 0) with m; auto.
  - rewrite IHm; simpl; code_simpl; auto.
Qed.

Lemma power_add' (Var : Set) (f : Code Var) (m n : nat) :
  f^(m + n) == f^m o f^n.
Proof.
  eta_expand as x; beta_simpl; apply power_add.
Qed.

Definition limit_le_code {Var : Set} (f : nat -> Code Var) (x : Code Var) :=
  forall n, f n [= x.

Definition limit_eq_code {Var : Set} (f : nat -> Code Var) (x : Code Var) :=
  limit_le_code f x /\ forall y, limit_le_code f y -> x [= y.

(** ** Applications of limits *)

Lemma Y_limit_ub (Var : Set) (f : Code Var) (n : nat) : f ^ n * BOT [= Y * f.
Proof.
  induction n.
    simpl; beta_simpl; auto.
  unfold power; fold (@power Var); rewrite beta_b.
  rewrite code_eq_y; monotonicity.
Qed.

Lemma Y_limit_lb
  (Var : Set) (f : Code Var)
  (Var' : Set) (c : Code Var') (b : Var -> Code Var') :
  code_conv (c * (Y * f @ b)) -> exists n, code_conv (c * (f ^ n * BOT @ b)).
Proof.
  (* sketch: prove the only beta path from [Y * f] to [f ...] is [code_eq_y]. *)
Admitted.

Lemma Y_limit_lub (Var : Set) (f x : Code Var) :
  (forall n : nat, f ^ n * BOT [= x) -> Y * f [= x.
Proof.
  unfold code_le; intros Hl Var' c b Hc.
  apply Y_limit_lb in Hc as [n Hn]; eauto.
Qed.

Lemma Y1_as_limit (Var : Set) (f : Code Var) :
  limit_eq_code (fun n => f ^ n * BOT) (Y * f).
Proof.
  split; unfold limit_le_code.
    apply Y_limit_ub.
  apply Y_limit_lub.
Qed.

Lemma Y_lfp (Var : Set) (f x : Code Var) : f * x [= x -> Y * f [= x.
Proof.
  intro Hl.
  assert (forall n : nat, f ^ n * BOT [= x).
    induction n.
      simpl; beta_simpl; auto.
    unfold power; fold (@power Var); rewrite beta_b.
    rewrite <- Hl; monotonicity.
  apply Y_limit_lub; auto.
Qed.

Lemma Y1_idem (Var : Set) (f : Code Var) : Y * (f o f) = Y * f.
Proof.
Admitted.

Lemma Y_S_right (Var : Set) (f g : Code Var) :
  Y * (S * f * g) = Y * (C * f * (Y * (S * f * g))).
Proof.
Admitted.

Lemma Y_S_left (Var : Set) (f g : Code Var) :
  Y * (S * f * g) = Y * (B * (Y * (S * f * g)) * g).
Proof.
Admitted.

Lemma Y_ub (Var : Set) (f b : Code Var) :
  (forall x, x [= b -> f * x [= b) -> Y * f [= b.
Proof.
Admitted.

Lemma Y_ident (Var : Set) (y : Code Var) : y == S * I * y -> y = Y.
Proof.
Admitted.

Lemma V_as_limit (Var : Set) (f : Code Var):
  limit_eq_code (fun n => f ^ n) (V * f).
Proof.
  split; unfold limit_le_code.
    induction n; simpl.
      rewrite code_eq_v; rewrite pi_j_left; auto.
    rewrite code_eq_v; rewrite pi_j_right.
    rewrite IHn; auto.
  intros y Hy.
Admitted.

Lemma V1_as_limit (Var : Set) (f x : Code Var):
  limit_eq_code (fun n => f ^ n * x) (V * f * x).
Proof.
  split; unfold limit_le_code.
    induction n; simpl.
      rewrite code_eq_v; rewrite pi_j_left; auto.
    rewrite code_eq_v; rewrite pi_j_right.
    beta_simpl; monotonicity.
  intros y Hy.
Admitted.


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

Require Import ZAxioms ZMulOrder ZSgnAbs ZGcd ZDivTrunc ZDivFloor.

(** * Least Common Multiple *)

(** Unlike other functions around, we will define lcm below instead of
  axiomatizing it. Indeed, there is no "prior art" about lcm in the
  standard library to be compliant with, and the generic definition
  of lcm via gcd is quite reasonable.

  By the way, we also state here some combined properties of div/mod
  and quot/rem and gcd.
*)

Module Type ZLcmProp
 (Import A : ZAxiomsSig')
 (Import B : ZMulOrderProp A)
 (Import C : ZSgnAbsProp A B)
 (Import D : ZDivProp A B C)
 (Import E : ZQuotProp A B C)
 (Import F : ZGcdProp A B C).

(** The two notions of division are equal on non-negative numbers *)

Lemma quot_div_nonneg : forall a b, 0<=a -> 0<b -> a÷b == a/b.
Proof.
 intros. apply div_unique_pos with (a rem b).
 now apply rem_bound_pos.
 apply quot_rem. order.
Qed.

Lemma rem_mod_nonneg : forall a b, 0<=a -> 0<b -> a rem b == a mod b.
Proof.
 intros. apply mod_unique_pos with (a÷b).
 now apply rem_bound_pos.
 apply quot_rem. order.
Qed.

(** We can use the sign rule to have an relation between divisions. *)

Lemma quot_div : forall a b, b~=0 ->
 a÷b == (sgn a)*(sgn b)*(abs a / abs b).
Proof.
 assert (AUX : forall a b, 0<b -> a÷b == (sgn a)*(sgn b)*(abs a / abs b)).
  intros a b Hb. rewrite (sgn_pos b), (abs_eq b), mul_1_r by order.
  destruct (lt_trichotomy 0 a) as [Ha|[Ha|Ha]].
  rewrite sgn_pos, abs_eq, mul_1_l, quot_div_nonneg; order.
  rewrite <- Ha, abs_0, sgn_0, quot_0_l, div_0_l, mul_0_l; order.
  rewrite sgn_neg, abs_neq, mul_opp_l, mul_1_l, eq_opp_r, <-quot_opp_l
    by order.
   apply quot_div_nonneg; trivial. apply opp_nonneg_nonpos; order.
 (* main *)
 intros a b Hb.
 apply neg_pos_cases in Hb. destruct Hb as [Hb|Hb]; [|now apply AUX].
 rewrite <- (opp_involutive b) at 1. rewrite quot_opp_r.
 rewrite AUX, abs_opp, sgn_opp, mul_opp_r, mul_opp_l, opp_involutive.
 reflexivity.
 now apply opp_pos_neg.
 rewrite eq_opp_l, opp_0; order.
Qed.

Lemma rem_mod : forall a b, b~=0 ->
 a rem b == (sgn a) * ((abs a) mod (abs b)).
Proof.
 intros a b Hb.
 rewrite <- rem_abs_r by trivial.
 assert (Hb' := proj2 (abs_pos b) Hb).
 destruct (lt_trichotomy 0 a) as [Ha|[Ha|Ha]].
 rewrite (abs_eq a), sgn_pos, mul_1_l, rem_mod_nonneg; order.
 rewrite <- Ha, abs_0, sgn_0, mod_0_l, rem_0_l, mul_0_l; order.
 rewrite sgn_neg, (abs_neq a), mul_opp_l, mul_1_l, eq_opp_r, <-rem_opp_l
    by order.
  apply rem_mod_nonneg; trivial. apply opp_nonneg_nonpos; order.
Qed.

(** Modulo and remainder are null at the same place,
    and this correspond to the divisibility relation. *)

Lemma mod_divide : forall a b, b~=0 -> (a mod b == 0 <-> (b|a)).
Proof.
 intros a b Hb. split.
 intros Hab. exists (a/b). rewrite mul_comm.
 rewrite (div_mod a b Hb) at 1. rewrite Hab; now nzsimpl.
 intros (c,Hc). rewrite Hc. now apply mod_mul.
Qed.

Lemma rem_divide : forall a b, b~=0 -> (a rem b == 0 <-> (b|a)).
Proof.
 intros a b Hb. split.
 intros Hab. exists (a÷b). rewrite mul_comm.
 rewrite (quot_rem a b Hb) at 1. rewrite Hab; now nzsimpl.
 intros (c,Hc). rewrite Hc. now apply rem_mul.
Qed.

Lemma rem_mod_eq_0 : forall a b, b~=0 -> (a rem b == 0 <-> a mod b == 0).
Proof.
 intros a b Hb. now rewrite mod_divide, rem_divide.
Qed.

(** When division is exact, div and quot agree *)

Lemma quot_div_exact : forall a b, b~=0 -> (b|a) -> a÷b == a/b.
Proof.
 intros a b Hb H.
 apply mul_cancel_l with b; trivial.
 assert (H':=H).
 apply rem_divide, quot_exact in H; trivial.
 apply mod_divide, div_exact in H'; trivial.
 now rewrite <-H,<-H'.
Qed.

Lemma divide_div_mul_exact : forall a b c, b~=0 -> (b|a) ->
 (c*a)/b == c*(a/b).
Proof.
 intros a b c Hb H.
 apply mul_cancel_l with b; trivial.
 rewrite mul_assoc, mul_shuffle0.
 assert (H':=H). apply mod_divide, div_exact in H'; trivial.
 rewrite <- H', (mul_comm a c).
 symmetry. apply div_exact; trivial.
 apply mod_divide; trivial.
 now apply divide_mul_r.
Qed.

Lemma divide_quot_mul_exact : forall a b c, b~=0 -> (b|a) ->
 (c*a)÷b == c*(a÷b).
Proof.
 intros a b c Hb H.
 rewrite 2 quot_div_exact; trivial.
 apply divide_div_mul_exact; trivial.
 now apply divide_mul_r.
Qed.

(** Gcd of divided elements, for exact divisions *)

Lemma gcd_div_factor : forall a b c, 0<c -> (c|a) -> (c|b) ->
 gcd (a/c) (b/c) == (gcd a b)/c.
Proof.
 intros a b c Hc Ha Hb.
 apply mul_cancel_l with c; try order.
 assert (H:=gcd_greatest _ _ _ Ha Hb).
 apply mod_divide, div_exact in H; try order.
 rewrite <- H.
 rewrite <- gcd_mul_mono_l_nonneg; try order.
 f_equiv; symmetry; apply div_exact; try order;
  apply mod_divide; trivial; try order.
Qed.

Lemma gcd_quot_factor : forall a b c, 0<c -> (c|a) -> (c|b) ->
 gcd (a÷c) (b÷c) == (gcd a b)÷c.
Proof.
 intros a b c Hc Ha Hb. rewrite !quot_div_exact; trivial; try order.
 now apply gcd_div_factor. now apply gcd_greatest.
Qed.

Lemma gcd_div_gcd : forall a b g, g~=0 -> g == gcd a b ->
 gcd (a/g) (b/g) == 1.
Proof.
 intros a b g NZ EQ. rewrite gcd_div_factor.
 now rewrite <- EQ, div_same.
 generalize (gcd_nonneg a b); order.
 rewrite EQ; apply gcd_divide_l.
 rewrite EQ; apply gcd_divide_r.
Qed.

Lemma gcd_quot_gcd : forall a b g, g~=0 -> g == gcd a b ->
 gcd (a÷g) (b÷g) == 1.
Proof.
 intros a b g NZ EQ. rewrite !quot_div_exact; trivial.
 now apply gcd_div_gcd.
 rewrite EQ; apply gcd_divide_r.
 rewrite EQ; apply gcd_divide_l.
Qed.

(** The following equality is crucial for Euclid algorithm *)

Lemma gcd_mod : forall a b, b~=0 -> gcd (a mod b) b == gcd b a.
Proof.
 intros a b Hb. rewrite mod_eq; trivial.
 rewrite <- add_opp_r, mul_comm, <- mul_opp_l.
 rewrite (gcd_comm _ b).
 apply gcd_add_mult_diag_r.
Qed.

Lemma gcd_rem : forall a b, b~=0 -> gcd (a rem b) b == gcd b a.
Proof.
 intros a b Hb. rewrite rem_eq; trivial.
 rewrite <- add_opp_r, mul_comm, <- mul_opp_l.
 rewrite (gcd_comm _ b).
 apply gcd_add_mult_diag_r.
Qed.

(** We now define lcm thanks to gcd:

    lcm a b = a * (b / gcd a b)
            = (a / gcd a b) * b
            = (a*b) / gcd a b

   We had an abs in order to have an always-nonnegative lcm,
   in the spirit of gcd. Nota: [lcm 0 0] should be 0, which
   isn't garantee with the third equation above.
*)

Definition lcm a b := abs (a*(b/gcd a b)).

Instance lcm_wd : Proper (eq==>eq==>eq) lcm.
Proof. unfold lcm. solve_proper. Qed.

Lemma lcm_equiv1 : forall a b, gcd a b ~= 0 ->
  a * (b / gcd a b) == (a*b)/gcd a b.
Proof.
 intros a b H. rewrite divide_div_mul_exact; try easy. apply gcd_divide_r.
Qed.

Lemma lcm_equiv2 : forall a b, gcd a b ~= 0 ->
  (a / gcd a b) * b == (a*b)/gcd a b.
Proof.
 intros a b H. rewrite 2 (mul_comm _ b).
 rewrite divide_div_mul_exact; try easy. apply gcd_divide_l.
Qed.

Lemma gcd_div_swap : forall a b,
 (a / gcd a b) * b == a * (b / gcd a b).
Proof.
 intros a b. destruct (eq_decidable (gcd a b) 0) as [EQ|NEQ].
 apply gcd_eq_0 in EQ. destruct EQ as (EQ,EQ'). rewrite EQ, EQ'. now nzsimpl.
 now rewrite lcm_equiv1, <-lcm_equiv2.
Qed.

Lemma divide_lcm_l : forall a b, (a | lcm a b).
Proof.
 unfold lcm. intros a b. apply divide_abs_r, divide_factor_l.
Qed.

Lemma divide_lcm_r : forall a b, (b | lcm a b).
Proof.
 unfold lcm. intros a b. apply divide_abs_r. rewrite <- gcd_div_swap.
 apply divide_factor_r.
Qed.

Lemma divide_div : forall a b c, a~=0 -> (a|b) -> (b|c) -> (b/a|c/a).
Proof.
 intros a b c Ha Hb (c',Hc). exists c'.
 now rewrite <- divide_div_mul_exact, <- Hc.
Qed.

Lemma lcm_least : forall a b c,
 (a | c) -> (b | c) -> (lcm a b | c).
Proof.
 intros a b c Ha Hb. unfold lcm. apply divide_abs_l.
 destruct (eq_decidable (gcd a b) 0) as [EQ|NEQ].
 apply gcd_eq_0 in EQ. destruct EQ as (EQ,EQ'). rewrite EQ in *. now nzsimpl.
 assert (Ga := gcd_divide_l a b).
 assert (Gb := gcd_divide_r a b).
 set (g:=gcd a b) in *.
 assert (Ha' := divide_div g a c NEQ Ga Ha).
 assert (Hb' := divide_div g b c NEQ Gb Hb).
 destruct Ha' as (a',Ha'). rewrite Ha', mul_comm in Hb'.
 apply gauss in Hb'; [|apply gcd_div_gcd; unfold g; trivial using gcd_comm].
 destruct Hb' as (b',Hb').
 exists b'.
 rewrite mul_shuffle3, <- Hb'.
 rewrite (proj2 (div_exact c g NEQ)).
 rewrite Ha', mul_shuffle3, (mul_comm a a'). f_equiv.
 symmetry. apply div_exact; trivial.
 apply mod_divide; trivial.
 apply mod_divide; trivial. transitivity a; trivial.
Qed.

Lemma lcm_nonneg : forall a b, 0 <= lcm a b.
Proof.
 intros a b. unfold lcm. apply abs_nonneg.
Qed.

Lemma lcm_comm : forall a b, lcm a b == lcm b a.
Proof.
 intros a b. unfold lcm. rewrite (gcd_comm b), (mul_comm b).
 now rewrite <- gcd_div_swap.
Qed.

Lemma lcm_divide_iff : forall n m p,
  (lcm n m | p) <-> (n | p) /\ (m | p).
Proof.
 intros. split. split.
 transitivity (lcm n m); trivial using divide_lcm_l.
 transitivity (lcm n m); trivial using divide_lcm_r.
 intros (H,H'). now apply lcm_least.
Qed.

Lemma lcm_unique : forall n m p,
 0<=p -> (n|p) -> (m|p) ->
 (forall q, (n|q) -> (m|q) -> (p|q)) ->
 lcm n m == p.
Proof.
 intros n m p Hp Hn Hm H.
 apply divide_antisym_nonneg; trivial. apply lcm_nonneg.
 now apply lcm_least.
 apply H. apply divide_lcm_l. apply divide_lcm_r.
Qed.

Lemma lcm_unique_alt : forall n m p, 0<=p ->
 (forall q, (p|q) <-> (n|q) /\ (m|q)) ->
 lcm n m == p.
Proof.
 intros n m p Hp H.
 apply lcm_unique; trivial.
 apply H, divide_refl.
 apply H, divide_refl.
 intros. apply H. now split.
Qed.

Lemma lcm_assoc : forall n m p, lcm n (lcm m p) == lcm (lcm n m) p.
Proof.
 intros. apply lcm_unique_alt; try apply lcm_nonneg.
 intros. now rewrite !lcm_divide_iff, and_assoc.
Qed.

Lemma lcm_0_l : forall n, lcm 0 n == 0.
Proof.
 intros. apply lcm_unique; trivial. order.
 apply divide_refl.
 apply divide_0_r.
Qed.

Lemma lcm_0_r : forall n, lcm n 0 == 0.
Proof.
 intros. now rewrite lcm_comm, lcm_0_l.
Qed.

Lemma lcm_1_l_nonneg : forall n, 0<=n -> lcm 1 n == n.
Proof.
 intros. apply lcm_unique; trivial using divide_1_l, le_0_1, divide_refl.
Qed.

Lemma lcm_1_r_nonneg : forall n, 0<=n -> lcm n 1 == n.
Proof.
 intros. now rewrite lcm_comm, lcm_1_l_nonneg.
Qed.

Lemma lcm_diag_nonneg : forall n, 0<=n -> lcm n n == n.
Proof.
 intros. apply lcm_unique; trivial using divide_refl.
Qed.

Lemma lcm_eq_0 : forall n m, lcm n m == 0 <-> n == 0 \/ m == 0.
Proof.
 intros. split.
 intros EQ.
 apply eq_mul_0.
 apply divide_0_l. rewrite <- EQ. apply lcm_least.
  apply divide_factor_l. apply divide_factor_r.
 destruct 1 as [EQ|EQ]; rewrite EQ. apply lcm_0_l. apply lcm_0_r.
Qed.

Lemma divide_lcm_eq_r : forall n m, 0<=m -> (n|m) -> lcm n m == m.
Proof.
 intros n m Hm H. apply lcm_unique_alt; trivial.
 intros q. split. split; trivial. now transitivity m.
 now destruct 1.
Qed.

Lemma divide_lcm_iff : forall n m, 0<=m -> ((n|m) <-> lcm n m == m).
Proof.
 intros n m Hn. split. now apply divide_lcm_eq_r.
 intros EQ. rewrite <- EQ. apply divide_lcm_l.
Qed.

Lemma lcm_opp_l : forall n m, lcm (-n) m == lcm n m.
Proof.
 intros. apply lcm_unique_alt; try apply lcm_nonneg.
 intros. rewrite divide_opp_l. apply lcm_divide_iff.
Qed.

Lemma lcm_opp_r : forall n m, lcm n (-m) == lcm n m.
Proof.
 intros. now rewrite lcm_comm, lcm_opp_l, lcm_comm.
Qed.

Lemma lcm_abs_l : forall n m, lcm (abs n) m == lcm n m.
Proof.
 intros. destruct (abs_eq_or_opp n) as [H|H]; rewrite H.
 easy. apply lcm_opp_l.
Qed.

Lemma lcm_abs_r : forall n m, lcm n (abs m) == lcm n m.
Proof.
 intros. now rewrite lcm_comm, lcm_abs_l, lcm_comm.
Qed.

Lemma lcm_1_l : forall n, lcm 1 n == abs n.
Proof.
 intros. rewrite <- lcm_abs_r. apply lcm_1_l_nonneg, abs_nonneg.
Qed.

Lemma lcm_1_r : forall n, lcm n 1 == abs n.
Proof.
 intros. now rewrite lcm_comm, lcm_1_l.
Qed.

Lemma lcm_diag : forall n, lcm n n == abs n.
Proof.
 intros. rewrite <- lcm_abs_l, <- lcm_abs_r.
 apply lcm_diag_nonneg, abs_nonneg.
Qed.

Lemma lcm_mul_mono_l :
  forall n m p, lcm (p * n) (p * m) == abs p * lcm n m.
Proof.
 intros n m p.
 destruct (eq_decidable p 0) as [Hp|Hp].
  rewrite Hp. nzsimpl. rewrite lcm_0_l, abs_0. now nzsimpl.
 destruct (eq_decidable (gcd n m) 0) as [Hg|Hg].
  apply gcd_eq_0 in Hg. destruct Hg as (Hn,Hm); rewrite Hn, Hm.
  nzsimpl. rewrite lcm_0_l. now nzsimpl.
 unfold lcm.
 rewrite gcd_mul_mono_l.
 rewrite !abs_mul, mul_assoc. f_equiv.
 rewrite <- (abs_sgn p) at 1. rewrite <- mul_assoc.
 rewrite div_mul_cancel_l; trivial.
 rewrite divide_div_mul_exact; trivial. rewrite abs_mul.
 rewrite <- (sgn_abs (sgn p)), sgn_sgn.
 destruct (sgn_spec p) as [(_,EQ)|[(EQ,_)|(_,EQ)]].
  rewrite EQ. now nzsimpl. order.
  rewrite EQ. rewrite mul_opp_l, mul_opp_r, opp_involutive. now nzsimpl.
 apply gcd_divide_r.
 contradict Hp. now apply abs_0_iff.
Qed.

Lemma lcm_mul_mono_l_nonneg :
 forall n m p, 0<=p -> lcm (p*n) (p*m) == p * lcm n m.
Proof.
 intros. rewrite <- (abs_eq p) at 3; trivial. apply lcm_mul_mono_l.
Qed.

Lemma lcm_mul_mono_r :
 forall n m p, lcm (n * p) (m * p) == lcm n m * abs p.
Proof.
 intros n m p. now rewrite !(mul_comm _ p), lcm_mul_mono_l, mul_comm.
Qed.

Lemma lcm_mul_mono_r_nonneg :
 forall n m p, 0<=p -> lcm (n*p) (m*p) == lcm n m * p.
Proof.
 intros. rewrite <- (abs_eq p) at 3; trivial. apply lcm_mul_mono_r.
Qed.

Lemma gcd_1_lcm_mul : forall n m, n~=0 -> m~=0 ->
 (gcd n m == 1 <-> lcm n m == abs (n*m)).
Proof.
 intros n m Hn Hm. split; intros H.
 unfold lcm. rewrite H. now rewrite div_1_r.
 unfold lcm in *.
 rewrite !abs_mul in H. apply mul_cancel_l in H; [|now rewrite abs_0_iff].
 assert (H' := gcd_divide_r n m).
 assert (Hg : gcd n m ~= 0) by (red; rewrite gcd_eq_0; destruct 1; order).
 apply mod_divide in H'; trivial. apply div_exact in H'; trivial.
 assert (m / gcd n m ~=0) by (contradict Hm; rewrite H', Hm; now nzsimpl).
 rewrite <- (mul_1_l (abs (_/_))) in H.
 rewrite H' in H at 3. rewrite abs_mul in H.
 apply mul_cancel_r in H; [|now rewrite abs_0_iff].
 rewrite abs_eq in H. order. apply gcd_nonneg.
Qed.

End ZLcmProp.


(** Coq coding by choukh, Sep 2021 **)

Require Import BBST.Axiom.Meta.
Require Import BBST.Axiom.Extensionality.
Require Import BBST.Axiom.Separation.

Axiom 至少有 : 集合 → 集合 → 集合.
Axiom 配对公理 : ∀ a b, a ∈ 至少有 a b ∧ b ∈ 至少有 a b.

Definition 配对 := λ a b, {x ∊ 至少有 a b | x = a ∨ x = b}.
Notation "{ a , b }" := (配对 a b) : 集合域.

Lemma 左配对介入 : ∀ a b, a ∈ {a, b}.
Proof. intros. apply 分离介入. apply 配对公理. now left. Qed.

Lemma 右配对介入 : ∀ a b, b ∈ {a, b}.
Proof. intros. apply 分离介入. apply 配对公理. now right. Qed.

Lemma 配对除去 : ∀ a b, ∀x ∈ {a, b}, x = a ∨ x = b.
Proof. intros. now apply 分离之条件 in H. Qed.

Global Opaque 配对.

Global Hint Immediate 左配对介入 右配对介入 : core.

Lemma 配对与顺序无关 : ∀ a b, {a, b} = {b, a}.
Proof.
  intros. 外延;
  apply 配对除去 in H as []; rewrite H; auto.
Qed.