(* (c) Copyright 2006-2016 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp
Require Import ssrbool ssrfun ssrnat eqtype seq choice div fintype.
From mathcomp
Require Import path bigop finset prime ssralg poly polydiv mxpoly.
From mathcomp
Require Import generic_quotient countalg closed_field ssrnum ssrint rat intdiv.
From mathcomp
Require Import algebraics_fundamentals.

(******************************************************************************)
(* This file provides an axiomatic construction of the algebraic numbers.     *)
(* The construction only assumes the existence of an algebraically closed     *)
(* filed with an automorphism of order 2; this amounts to the purely          *)
(* algebraic contents of the Fundamenta Theorem of Algebra.                   *)
(*       algC == the closed, countable field of algebraic numbers.            *)
(*  algCeq, algCring, ..., algCnumField == structures for algC.               *)
(* The ssrnum interfaces are implemented for algC as follows:                 *)
(*     x <= y <=> (y - x) is a nonnegative real                               *)
(*      x < y <=> (y - x) is a (strictly) positive real                       *)
(*       `|z| == the complex norm of z, i.e., sqrtC (z * z^* ).               *)
(*      Creal == the subset of real numbers (:= Num.real for algC).           *)
(*         'i == the imaginary number (:= sqrtC (-1)).                        *)
(*      'Re z == the real component of z.                                     *)
(*      'Im z == the imaginary component of z.                                *)
(*        z^* == the complex conjugate of z (:= conjC z).                     *)
(*    sqrtC z == a nonnegative square root of z, i.e., 0 <= sqrt x if 0 <= x. *)
(*  n.-root z == more generally, for n > 0, an nth root of z, chosen with a   *)
(*               minimal non-negative argument for n > 1 (i.e., with a        *)
(*               maximal real part subject to a nonnegative imaginary part).  *)
(*               Note that n.-root (-1) is a primitive 2nth root of unity,    *)
(*               an thus not equal to -1 for n odd > 1 (this will be shown in *)
(*               file cyclotomic.v).                                          *)
(* In addition, we provide:                                                   *)
(*       Crat == the subset of rational numbers.                              *)
(*       Cint == the subset of integers.                                      *)
(*       Cnat == the subset of natural integers.                              *)
(*  getCrat z == some a : rat such that ratr a = z, provided z \in Crat.      *)
(*   floorC z == for z \in Creal, an m : int s.t. m%:~R <= z < (m + 1)%:~R.   *)
(*   truncC z == for z >= 0, an n : nat s.t. n%:R <= z < n.+1%:R, else 0%N.   *)
(* minCpoly z == the minimal (monic) polynomial over Crat with root z.        *)
(* algC_invaut nu == an inverse of nu : {rmorphism algC -> algC}.             *)
(*         (x %| y)%C <=> y is an integer (Cint) multiple of x; if x or y are *)
(*        (x %| y)%Cx     of type nat or int they are coerced to algC here.   *)
(*                        The (x %| y)%Cx display form is a workaround for    *)
(*                        design limitations of the Coq Notation facilities.  *)
(* (x == y %[mod z])%C <=> x and y differ by an integer (Cint) multiple of z; *)
(*                as above, arguments of type nat or int are cast to algC.    *)
(* (x != y %[mod z])%C <=> x and y do not differ by an integer multiple of z. *)
(* Note that in file algnum we give an alternative definition of divisibility *)
(* based on algebraic integers, overloading the notation in the %A scope.     *)
(******************************************************************************)

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

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

(* The Num mixin for an algebraically closed field with an automorphism of    *)
(* order 2, making it into a field of complex numbers.                        *)
Lemma ComplexNumMixin (L : closedFieldType) (conj : {rmorphism L -> L}) :
    involutive conj -> ~ conj =1 id ->
  {numL | forall x : NumDomainType L numL, `|x| ^+ 2 = x * conj x}.
Proof.
move=> conjK conj_nt.
have nz2: 2%:R != 0 :> L.
  apply/eqP=> char2; apply: conj_nt => e; apply/eqP/idPn=> eJ.
  have opp_id x: - x = x :> L.
    by apply/esym/eqP; rewrite -addr_eq0 -mulr2n -mulr_natl char2 mul0r.
  have{char2} char2: 2 \in [char L] by apply/eqP.
  without loss{eJ} eJ: e / conj e = e + 1.
    move/(_ (e / (e + conj e))); apply.
    rewrite fmorph_div rmorphD conjK -{1}[conj e](addNKr e) mulrDl.
    by rewrite opp_id (addrC e) divff // addr_eq0 opp_id.
  pose a := e * conj e; have aJ: conj a = a by rewrite rmorphM conjK mulrC.
  have [w Dw] := @solve_monicpoly _ 2 (nth 0 [:: e * a; - 1]) isT.
  have{Dw} Dw: w ^+ 2 + w = e * a.
    by rewrite Dw !big_ord_recl big_ord0 /= mulr1 mulN1r addr0 subrK.
  pose b := w + conj w; have bJ: conj b = b by rewrite rmorphD conjK addrC.
  have Db2: b ^+ 2 + b = a.
    rewrite -Frobenius_autE // rmorphD addrACA Dw /= Frobenius_autE -rmorphX.
    by rewrite -rmorphD Dw rmorphM aJ eJ -mulrDl -{1}[e]opp_id addKr mul1r.
  have /eqP[] := oner_eq0 L; apply: (addrI b); rewrite addr0 -{2}bJ.
  have: (b + e) * (b + conj e) == 0.
    rewrite mulrDl 2!mulrDr -/a addrA addr_eq0 opp_id (mulrC e) -addrA.
    by rewrite -mulrDr eJ addrAC -{2}[e]opp_id subrr add0r mulr1 Db2.
  rewrite mulf_eq0 !addr_eq0 !opp_id => /pred2P[] -> //.
  by rewrite {2}eJ rmorphD rmorph1.
have mul2I: injective (fun z : L => z *+ 2).
  by move=> x y; rewrite /= -mulr_natl -(mulr_natl y) => /mulfI->.
pose sqrt x : L := sval (sig_eqW (@solve_monicpoly _ 2 (nth 0 [:: x]) isT)).
have sqrtK x: sqrt x ^+ 2 = x.
  rewrite /sqrt; case: sig_eqW => /= y ->.
  by rewrite !big_ord_recl big_ord0 /= mulr1 mul0r !addr0.
have sqrtE x y: y ^+ 2 = x -> {b : bool | y = (-1) ^+ b * sqrt x}.
  move=> Dx; exists (y != sqrt x); apply/eqP; rewrite mulr_sign if_neg.
  by case: ifPn => //; apply/implyP; rewrite implyNb -eqf_sqr Dx sqrtK.
pose i := sqrt (- 1).
have sqrMi x: (i * x) ^+ 2 = - x ^+ 2 by rewrite exprMn sqrtK mulN1r.
have iJ : conj i = - i.
  have /sqrtE[b]: conj i ^+ 2 = - 1 by rewrite -rmorphX sqrtK rmorphN1.
  rewrite mulr_sign -/i; case: b => // Ri.
  case: conj_nt => z; wlog zJ: z / conj z = - z.
    move/(_ (z - conj z)); rewrite !rmorphB conjK opprB => zJ.
    by apply/mul2I/(canRL (subrK _)); rewrite -addrA zJ // addrC subrK.
  have [-> | nz_z] := eqVneq z 0; first exact: rmorph0.
  have [u Ru [v Rv Dz]]:
    exists2 u, conj u = u & exists2 v, conj v = v & (u + z * v) ^+ 2 = z.
  - pose y := sqrt z; exists ((y + conj y) / 2%:R).
      by rewrite fmorph_div rmorphD conjK addrC rmorph_nat.
    exists ((y - conj y) / (z *+ 2)).
      rewrite fmorph_div rmorphMn zJ mulNrn invrN mulrN -mulNr rmorphB opprB.
      by rewrite conjK.
    rewrite -(mulr_natl z) invfM (mulrC z) !mulrA divfK // -mulrDl addrACA.
    by rewrite subrr addr0 -mulr2n -mulr_natr mulfK ?Neq0 ?sqrtK.
  suffices u0: u = 0 by rewrite -Dz u0 add0r rmorphX rmorphM Rv zJ mulNr sqrrN.
  suffices [b Du]: exists b : bool, u = (-1) ^+ b * i * z * v.
    apply: mul2I; rewrite mul0rn mulr2n -{2}Ru.
    by rewrite Du !rmorphM rmorph_sign Rv Ri zJ !mulrN mulNr subrr.
  have/eqP:= zJ; rewrite -addr_eq0 -{1 2}Dz rmorphX rmorphD rmorphM Ru Rv zJ.
  rewrite mulNr sqrrB sqrrD addrACA (addrACA (u ^+ 2)) addNr addr0 -!mulr2n.
  rewrite -mulrnDl -(mul0rn _ 2) (inj_eq mul2I) /= -[rhs in _ + rhs]opprK.
  rewrite -sqrMi subr_eq0 eqf_sqr -mulNr !mulrA.
  by case/pred2P=> ->; [exists false | exists true]; rewrite mulr_sign.
pose norm x := sqrt x * conj (sqrt x).
have normK x : norm x ^+ 2 = x * conj x by rewrite exprMn -rmorphX sqrtK.
have normE x y : y ^+ 2 = x -> norm x = y * conj y.
  rewrite /norm => /sqrtE[b /(canLR (signrMK b)) <-].
  by rewrite !rmorphM rmorph_sign mulrACA -mulrA signrMK.
have norm_eq0 x : norm x = 0 -> x = 0.
  by move/eqP; rewrite mulf_eq0 fmorph_eq0 -mulf_eq0 -expr2 sqrtK => /eqP.
have normM x y : norm (x * y) = norm x * norm y.
  by rewrite mulrACA -rmorphM; apply: normE; rewrite exprMn !sqrtK.
have normN x : norm (- x) = norm x.
  by rewrite -mulN1r normM {1}/norm iJ mulrN -expr2 sqrtK opprK mul1r.
pose le x y := norm (y - x) == y - x; pose lt x y := (y != x) && le x y.
have posE x: le 0 x = (norm x == x) by rewrite /le subr0.
have leB x y: le x y = le 0 (y - x) by rewrite posE.
have posP x : reflect (exists y, x = y * conj y) (le 0 x).
  rewrite posE; apply: (iffP eqP) => [Dx | [y {x}->]]; first by exists (sqrt x).
  by rewrite (normE _ _ (normK y)) rmorphM conjK (mulrC (conj _)) -expr2 normK.
have posJ x : le 0 x -> conj x = x.
  by case/posP=> {x}u ->; rewrite rmorphM conjK mulrC.
have pos_linear x y : le 0 x -> le 0 y -> le x y || le y x.
  move=> pos_x pos_y; rewrite leB -opprB orbC leB !posE normN -eqf_sqr.
  by rewrite normK rmorphB !posJ ?subrr.
have sposDl x y : lt 0 x -> le 0 y -> lt 0 (x + y).
  have sqrtJ z : le 0 z -> conj (sqrt z) = sqrt z.
    rewrite posE -{2}[z]sqrtK -subr_eq0 -mulrBr mulf_eq0 subr_eq0.
    by case/pred2P=> ->; rewrite ?rmorph0.
  case/andP=> nz_x /sqrtJ uJ /sqrtJ vJ.
  set u := sqrt x in uJ; set v := sqrt y in vJ; pose w := u + i * v.
  have ->: x + y = w * conj w.
    rewrite rmorphD rmorphM iJ uJ vJ mulNr mulrC -subr_sqr sqrMi opprK.
    by rewrite !sqrtK.
  apply/andP; split; last by apply/posP; exists w.
  rewrite -normK expf_eq0 //=; apply: contraNneq nz_x => /norm_eq0 w0.
  rewrite -[x]sqrtK expf_eq0 /= -/u -(inj_eq mul2I) !mulr2n -{2}(rmorph0 conj).
  by rewrite -w0 rmorphD rmorphM iJ uJ vJ mulNr addrACA subrr addr0.
have sposD x y : lt 0 x -> lt 0 y -> lt 0 (x + y).
  by move=> x_gt0 /andP[_]; apply: sposDl.
have normD x y : le (norm (x + y)) (norm x + norm y).
  have sposM u v: lt 0 u -> le 0 (u * v) -> le 0 v.
    by rewrite /lt !posE normM andbC => /andP[/eqP-> /mulfI/inj_eq->].
  have posD u v: le 0 u -> le 0 v -> le 0 (u + v).
    have [-> | nz_u u_ge0 v_ge0] := eqVneq u 0; first by rewrite add0r.
    by have /andP[]: lt 0 (u + v) by rewrite sposDl // /lt nz_u.
  have le_sqr u v: conj u = u -> le 0 v -> le (u ^+ 2) (v ^+ 2) -> le u v.
    move=> Ru v_ge0; have [-> // | nz_u] := eqVneq u 0.
    have [u_gt0 | u_le0 _] := boolP (lt 0 u).
      by rewrite leB (leB u) subr_sqr mulrC addrC; apply: sposM; apply: sposDl.
    rewrite leB posD // posE normN -addr_eq0; apply/eqP.
    rewrite /lt nz_u posE -subr_eq0 in u_le0; apply: (mulfI u_le0).
    by rewrite mulr0 -subr_sqr normK Ru subrr.
  have pos_norm z: le 0 (norm z) by apply/posP; exists (sqrt z).
  rewrite le_sqr ?posJ ?posD // sqrrD !normK -normM rmorphD mulrDl !mulrDr.
  rewrite addrA addrC !addrA -(addrC (y * conj y)) !addrA.
  move: (y * _ + _) => u; rewrite -!addrA leB opprD addrACA {u}subrr add0r -leB.
  rewrite {}le_sqr ?posD //.
    by rewrite rmorphD !rmorphM !conjK addrC mulrC (mulrC y).
  rewrite -mulr2n -mulr_natr exprMn normK -natrX mulr_natr sqrrD mulrACA.
  rewrite -rmorphM (mulrC y x) addrAC leB mulrnA mulr2n opprD addrACA.
  rewrite subrr addr0 {2}(mulrC x) rmorphM mulrACA -opprB addrAC -sqrrB -sqrMi.
  apply/posP; exists (i * (x * conj y - y * conj x)); congr (_ * _).
  rewrite !(rmorphM, rmorphB) iJ !conjK mulNr -mulrN opprB.
  by rewrite (mulrC x) (mulrC y).
by exists (Num.Mixin normD sposD norm_eq0 pos_linear normM (rrefl _) (rrefl _)).
Qed.

Module Algebraics.

Module Type Specification.

Parameter type : Type.

Parameter eqMixin : Equality.class_of type.
Canonical eqType := EqType type eqMixin.

Parameter choiceMixin : Choice.mixin_of type.
Canonical choiceType := ChoiceType type choiceMixin.

Parameter countMixin : Countable.mixin_of type.
Canonical countType := CountType type countMixin.

Parameter zmodMixin : GRing.Zmodule.mixin_of type.
Canonical zmodType := ZmodType type zmodMixin.
Canonical countZmodType := [countZmodType of type].

Parameter ringMixin : GRing.Ring.mixin_of zmodType.
Canonical ringType := RingType type ringMixin.
Canonical countRingType := [countRingType of type].

Parameter unitRingMixin : GRing.UnitRing.mixin_of ringType.
Canonical unitRingType := UnitRingType type unitRingMixin.

Axiom mulC : @commutative ringType ringType *%R.
Canonical comRingType := ComRingType type mulC.
Canonical comUnitRingType := [comUnitRingType of type].

Axiom idomainAxiom : GRing.IntegralDomain.axiom ringType.
Canonical idomainType := IdomainType type idomainAxiom.

Axiom fieldMixin : GRing.Field.mixin_of unitRingType.
Canonical fieldType := FieldType type fieldMixin.

Parameter decFieldMixin : GRing.DecidableField.mixin_of unitRingType.
Canonical decFieldType := DecFieldType type decFieldMixin.

Axiom closedFieldAxiom : GRing.ClosedField.axiom ringType.
Canonical closedFieldType := ClosedFieldType type closedFieldAxiom.

Parameter numMixin : Num.mixin_of ringType.
Canonical numDomainType := NumDomainType type numMixin.
Canonical numFieldType := [numFieldType of type].

Parameter conjMixin : Num.ClosedField.imaginary_mixin_of numDomainType.
Canonical numClosedFieldType := NumClosedFieldType type conjMixin.

Axiom algebraic : integralRange (@ratr unitRingType).

End Specification.

Module Implementation : Specification.

Definition L := tag Fundamental_Theorem_of_Algebraics.

Definition conjL : {rmorphism L -> L} :=
  s2val (tagged Fundamental_Theorem_of_Algebraics).

Fact conjL_K : involutive conjL.
Proof. exact: s2valP (tagged Fundamental_Theorem_of_Algebraics). Qed.

Fact conjL_nt : ~ conjL =1 id.
Proof. exact: s2valP' (tagged Fundamental_Theorem_of_Algebraics). Qed.

Definition LnumMixin := ComplexNumMixin conjL_K conjL_nt.
Definition Lnum := NumDomainType L (sval LnumMixin).

Definition QtoL := [rmorphism of @ratr [numFieldType of Lnum]].
Notation pQtoL := (map_poly QtoL).

Definition rootQtoL p_j :=
  if p_j.1 == 0 then 0 else
  (sval (closed_field_poly_normal (pQtoL p_j.1)))`_p_j.2.

Definition eq_root p_j q_k := rootQtoL p_j == rootQtoL q_k.
Fact eq_root_is_equiv : equiv_class_of eq_root.
Proof. by rewrite /eq_root; split=> [ ? | ? ? | ? ? ? ] // /eqP->. Qed.
Canonical eq_root_equiv := EquivRelPack eq_root_is_equiv.
Definition type : Type := {eq_quot eq_root}%qT.

Definition eqMixin : Equality.class_of type := EquivQuot.eqMixin _.
Canonical eqType := EqType type eqMixin.

Definition choiceMixin : Choice.mixin_of type := EquivQuot.choiceMixin _.
Canonical choiceType := ChoiceType type choiceMixin.

Definition countMixin : Countable.mixin_of type := CanCountMixin reprK.
Canonical countType := CountType type countMixin.

Definition CtoL (u : type) := rootQtoL (repr u).

Fact CtoL_inj : injective CtoL.
Proof. by move=> u v /eqP eq_uv; rewrite -[u]reprK -[v]reprK; apply/eqmodP. Qed.

Fact CtoL_P u : integralOver QtoL (CtoL u).
Proof.
rewrite /CtoL /rootQtoL; case: (repr u) => p j /=.
case: (closed_field_poly_normal _) => r Dp /=.
case: ifPn => [_ | nz_p]; first exact: integral0.
have [/(nth_default 0)-> | lt_j_r] := leqP (size r) j; first exact: integral0.
apply/integral_algebraic; exists p; rewrite // Dp -mul_polyC rootM orbC.
by rewrite root_prod_XsubC mem_nth.
Qed.

Fact LtoC_subproof z : integralOver QtoL z -> {u | CtoL u = z}.
Proof.
case/sig2_eqW=> p mon_p pz0; rewrite /CtoL.
pose j := index z (sval (closed_field_poly_normal (pQtoL p))).
pose u := \pi_type%qT (p, j); exists u; have /eqmodP/eqP-> := reprK u.
rewrite /rootQtoL -if_neg monic_neq0 //; apply: nth_index => /=.
case: (closed_field_poly_normal _) => r /= Dp.
by rewrite Dp (monicP _) ?(monic_map QtoL) // scale1r root_prod_XsubC in pz0.
Qed.

Definition LtoC z Az := sval (@LtoC_subproof z Az).
Fact LtoC_K z Az : CtoL (@LtoC z Az) = z.
Proof. exact: (svalP (LtoC_subproof Az)). Qed.

Fact CtoL_K u : LtoC (CtoL_P u) = u.
Proof. by apply: CtoL_inj; rewrite LtoC_K. Qed.

Definition zero := LtoC (integral0 _).
Definition add u v := LtoC (integral_add (CtoL_P u) (CtoL_P v)).
Definition opp u := LtoC (integral_opp (CtoL_P u)).

Fact addA : associative add.
Proof. by move=> u v w; apply: CtoL_inj; rewrite !LtoC_K addrA. Qed.

Fact addC : commutative add.
Proof. by move=> u v; apply: CtoL_inj; rewrite !LtoC_K addrC. Qed.

Fact add0 : left_id zero add.
Proof. by move=> u; apply: CtoL_inj; rewrite !LtoC_K add0r. Qed.

Fact addN : left_inverse zero opp add.
Proof. by move=> u; apply: CtoL_inj; rewrite !LtoC_K addNr. Qed.

Definition zmodMixin := ZmodMixin addA addC add0 addN.
Canonical zmodType := ZmodType type zmodMixin.
Canonical countZmodType := [countZmodType of type].

Fact CtoL_is_additive : additive CtoL.
Proof. by move=> u v; rewrite !LtoC_K. Qed.
Canonical CtoL_additive := Additive CtoL_is_additive.

Definition one := LtoC (integral1 _).
Definition mul u v := LtoC (integral_mul (CtoL_P u) (CtoL_P v)).
Definition inv u := LtoC (integral_inv (CtoL_P u)).

Fact mulA : associative mul.
Proof. by move=> u v w; apply: CtoL_inj; rewrite !LtoC_K mulrA. Qed.

Fact mulC : commutative mul.
Proof. by move=> u v; apply: CtoL_inj; rewrite !LtoC_K mulrC. Qed.

Fact mul1 : left_id one mul.
Proof. by move=> u; apply: CtoL_inj; rewrite !LtoC_K mul1r. Qed.

Fact mulD : left_distributive mul +%R.
Proof. by move=> u v w; apply: CtoL_inj; rewrite !LtoC_K mulrDl. Qed.

Fact one_nz : one != 0 :> type.
Proof. by rewrite -(inj_eq CtoL_inj) !LtoC_K oner_eq0. Qed.

Definition ringMixin := ComRingMixin mulA mulC mul1 mulD one_nz.
Canonical ringType := RingType type ringMixin.
Canonical comRingType := ComRingType type mulC.
Canonical countRingType := [countRingType of type].

Fact CtoL_is_multiplicative : multiplicative CtoL.
Proof. by split=> [u v|]; rewrite !LtoC_K. Qed.
Canonical CtoL_rmorphism := AddRMorphism CtoL_is_multiplicative.

Fact mulVf : GRing.Field.axiom inv.
Proof.
move=> u; rewrite -(inj_eq CtoL_inj) rmorph0 => nz_u.
by apply: CtoL_inj; rewrite !LtoC_K mulVf.
Qed.
Fact inv0 : inv 0 = 0. Proof. by apply: CtoL_inj; rewrite !LtoC_K invr0. Qed.

Definition unitRingMixin := FieldUnitMixin mulVf inv0.
Canonical unitRingType := UnitRingType type unitRingMixin.
Canonical comUnitRingType := [comUnitRingType of type].

Definition fieldMixin := FieldMixin mulVf inv0.
Definition idomainAxiom := FieldIdomainMixin fieldMixin.
Canonical idomainType := IdomainType type idomainAxiom.
Canonical fieldType := FieldType type fieldMixin.

Fact closedFieldAxiom : GRing.ClosedField.axiom ringType.
Proof.
move=> n a n_gt0; pose p := 'X^n - \poly_(i < n) CtoL (a i).
have Ap: {in p : seq L, integralRange QtoL}.
  move=> _ /(nthP 0)[j _ <-]; rewrite coefB coefXn coef_poly.
  apply: integral_sub; first exact: integral_nat.
  by case: ifP => _; [apply: CtoL_P | apply: integral0].
have sz_p: size p = n.+1.
  by rewrite size_addl size_polyXn // size_opp ltnS size_poly.
have [z pz0]: exists z, root p z by apply/closed_rootP; rewrite sz_p eqSS -lt0n.
have Az: integralOver ratr z.
  by apply: integral_root Ap; rewrite // -size_poly_gt0 sz_p.
exists (LtoC Az); apply/CtoL_inj; rewrite -[CtoL _]subr0 -(rootP pz0).
rewrite rmorphX /= LtoC_K hornerD hornerXn hornerN opprD addNKr opprK.
rewrite horner_poly rmorph_sum; apply: eq_bigr => k _.
by rewrite rmorphM rmorphX /= LtoC_K.
Qed.

Definition decFieldMixin := closed_field_QEMixin closedFieldAxiom.
Canonical decFieldType := DecFieldType type decFieldMixin.
Canonical closedFieldType := ClosedFieldType type closedFieldAxiom.

Fact conj_subproof u : integralOver QtoL (conjL (CtoL u)).
Proof.
have [p mon_p pu0] := CtoL_P u; exists p => //.
rewrite -(fmorph_root conjL) conjL_K map_poly_id // => _ /(nthP 0)[j _ <-].
by rewrite coef_map fmorph_rat.
Qed.
Fact conj_is_rmorphism : rmorphism (fun u => LtoC (conj_subproof u)).
Proof.
do 2?split=> [u v|]; apply: CtoL_inj; last by rewrite !LtoC_K rmorph1.
- by rewrite LtoC_K 3!{1}rmorphB /= !LtoC_K.
by rewrite LtoC_K 3!{1}rmorphM /= !LtoC_K.
Qed.
Definition conj : {rmorphism type -> type} := RMorphism conj_is_rmorphism.
Lemma conjK : involutive conj.
Proof. by move=> u; apply: CtoL_inj; rewrite !LtoC_K conjL_K. Qed.

Fact conj_nt : ~ conj =1 id.
Proof.
have [i i2]: exists i : type, i ^+ 2 = -1.
  have [i] := @solve_monicpoly _ 2 (nth 0 [:: -1 : type]) isT.
  by rewrite !big_ord_recl big_ord0 /= mul0r mulr1 !addr0; exists i.
move/(_ i)/(congr1 CtoL); rewrite LtoC_K => iL_J.
have/ltr_geF/idP[] := @ltr01 Lnum; rewrite -oppr_ge0 -(rmorphN1 CtoL_rmorphism).
rewrite -i2 rmorphX /= expr2 -{2}iL_J -(svalP LnumMixin).
by rewrite exprn_ge0 ?normr_ge0.
Qed.

Definition numMixin := sval (ComplexNumMixin conjK conj_nt).
Canonical numDomainType := NumDomainType type numMixin.
Canonical numFieldType := [numFieldType of type].

Lemma normK u : `|u| ^+ 2 = u * conj u.
Proof. exact: svalP (ComplexNumMixin conjK conj_nt) u. Qed.

Lemma algebraic : integralRange (@ratr unitRingType).
Proof.
move=> u; have [p mon_p pu0] := CtoL_P u; exists p => {mon_p}//.
rewrite -(fmorph_root CtoL_rmorphism) -map_poly_comp; congr (root _ _): pu0.
by apply/esym/eq_map_poly; apply: fmorph_eq_rat.
Qed.

Definition conjMixin :=
  ImaginaryMixin (svalP (imaginary_exists closedFieldType))
                 (fun x => esym (normK x)).
Canonical numClosedFieldType := NumClosedFieldType type conjMixin.

End Implementation.

Definition divisor := Implementation.type.

Module Internals.

Import Implementation.

Local Notation algC := type.
Local Notation "z ^*" := (conj z) (at level 2, format "z ^*") : ring_scope.
Local Notation QtoC := (ratr : rat -> algC).
Local Notation QtoCm := [rmorphism of QtoC].
Local Notation pQtoC := (map_poly QtoC).
Local Notation ZtoQ := (intr : int -> rat).
Local Notation ZtoC := (intr : int -> algC).
Local Notation Creal := (Num.real : qualifier 0 algC).

Fact algCi_subproof : {i : algC | i ^+ 2 = -1}.
Proof. exact: GRing.imaginary_exists. Qed.

Variant getCrat_spec : Type := GetCrat_spec CtoQ of cancel QtoC CtoQ.

Fact getCrat_subproof : getCrat_spec.
Proof.
have isQ := rat_algebraic_decidable algebraic.
exists (fun z => if isQ z is left Qz then sval (sig_eqW Qz) else 0) => a.
case: (isQ _) => [Qa | []]; last by exists a.
by case: (sig_eqW _) => b /= /fmorph_inj.
Qed.

Fact floorC_subproof x : {m | x \is Creal -> ZtoC m <= x < ZtoC (m + 1)}.
Proof.
have [Rx | _] := boolP (x \is Creal); last by exists 0.
without loss x_ge0: x Rx / x >= 0.
  have [x_ge0 | /ltrW x_le0] := real_ger0P Rx; first exact.
  case/(_ (- x)) => [||m /(_ isT)]; rewrite ?rpredN ?oppr_ge0 //.
  rewrite ler_oppr ltr_oppl -!rmorphN opprD /= ltr_neqAle ler_eqVlt.
  case: eqP => [-> _ | _ /and3P[lt_x_m _ le_m_x]].
    by exists (- m) => _; rewrite lerr rmorphD ltr_addl ltr01.
  by exists (- m - 1); rewrite le_m_x subrK.
have /ex_minnP[n lt_x_n1 min_n]: exists n, x < n.+1%:R.
  have [n le_x_n] := rat_algebraic_archimedean algebraic x.
  by exists n; rewrite -(ger0_norm x_ge0) (ltr_trans le_x_n) ?ltr_nat.
exists n%:Z => _; rewrite addrC -intS lt_x_n1 andbT.
case Dn: n => // [n1]; rewrite -Dn.
have [||//|] := @real_lerP _ n%:R x; rewrite ?rpred_nat //.
by rewrite Dn => /min_n; rewrite Dn ltnn.
Qed.

Fact minCpoly_subproof (x : algC) :
  {p | p \is monic & forall q, root (pQtoC q) x = (p %| q)%R}.
Proof.
have isQ := rat_algebraic_decidable algebraic.
have [p [mon_p px0 irr_p]] := minPoly_decidable_closure isQ (algebraic x).
exists p => // q; apply/idP/idP=> [qx0 | /dvdpP[r ->]]; last first.
  by rewrite rmorphM rootM px0 orbT.
suffices /eqp_dvdl <-: gcdp p q %= p by apply: dvdp_gcdr.
rewrite irr_p ?dvdp_gcdl ?gtn_eqF // -(size_map_poly QtoCm) gcdp_map /=.
rewrite (@root_size_gt1 _ x) ?root_gcd ?px0 //.
by rewrite gcdp_eq0 negb_and map_poly_eq0 monic_neq0.
Qed.

Definition algC_divisor (x : algC) := x : divisor.
Definition int_divisor m := m%:~R : divisor.
Definition nat_divisor n := n%:R : divisor.

End Internals.

Module Import Exports.

Import Implementation Internals.

Notation algC := type.
Delimit Scope C_scope with C.
Delimit Scope C_core_scope with Cc.
Delimit Scope C_expanded_scope with Cx.
Open Scope C_core_scope.

Canonical eqType.
Canonical choiceType.
Canonical countType.
Canonical zmodType.
Canonical countZmodType.
Canonical ringType.
Canonical countRingType.
Canonical unitRingType.
Canonical comRingType.
Canonical comUnitRingType.
Canonical idomainType.
Canonical numDomainType.
Canonical fieldType.
Canonical numFieldType.
Canonical decFieldType.
Canonical closedFieldType.
Canonical numClosedFieldType.

Notation algCeq := eqType.
Notation algCzmod := zmodType.
Notation algCring := ringType.
Notation algCuring := unitRingType.
Notation algCnum := numDomainType.
Notation algCfield := fieldType.
Notation algCnumField := numFieldType.
Notation algCnumClosedField := numClosedFieldType.

Notation Creal := (@Num.Def.Rreal numDomainType).

Definition getCrat := let: GetCrat_spec CtoQ _ := getCrat_subproof in CtoQ.
Definition Crat : pred_class := fun x : algC => ratr (getCrat x) == x.

Definition floorC x := sval (floorC_subproof x).
Definition Cint : pred_class := fun x : algC => (floorC x)%:~R == x.

Definition truncC x := if x >= 0 then `|floorC x|%N else 0%N.
Definition Cnat : pred_class := fun x : algC => (truncC x)%:R == x.

Definition minCpoly x : {poly algC} :=
  let: exist2 p _ _ := minCpoly_subproof x in map_poly ratr p.

Coercion nat_divisor : nat >-> divisor.
Coercion int_divisor : int >-> divisor.
Coercion algC_divisor : algC >-> divisor.

Lemma nCdivE (p : nat) : p = p%:R :> divisor. Proof. by []. Qed.
Lemma zCdivE (p : int) : p = p%:~R :> divisor. Proof. by []. Qed.
Definition CdivE := (nCdivE, zCdivE).

Definition dvdC (x : divisor) : pred_class :=
   fun y : algC => if x == 0 then y == 0 else y / x \in Cint.
Notation "x %| y" := (y \in dvdC x) : C_expanded_scope.
Notation "x %| y" := (@in_mem divisor y (mem (dvdC x))) : C_scope.

Definition eqCmod (e x y : divisor) := (e %| x - y)%C.

Notation "x == y %[mod e ]" := (eqCmod e x y) : C_scope.
Notation "x != y %[mod e ]" := (~~ (x == y %[mod e])%C) : C_scope.

End Exports.

End Algebraics.

Export Algebraics.Exports.

Section AlgebraicsTheory.

Implicit Types (x y z : algC) (n : nat) (m : int) (b : bool).
Import Algebraics.Internals.

Local Notation ZtoQ := (intr : int -> rat).
Local Notation ZtoC := (intr : int -> algC).
Local Notation QtoC := (ratr : rat -> algC).
Local Notation QtoCm := [rmorphism of QtoC].
Local Notation CtoQ := getCrat.
Local Notation intrp := (map_poly intr).
Local Notation pZtoQ := (map_poly ZtoQ).
Local Notation pZtoC := (map_poly ZtoC).
Local Notation pQtoC := (map_poly ratr).

Local Hint Resolve (intr_inj : injective ZtoC) : core.

(* Specialization of a few basic ssrnum order lemmas. *)

Definition eqC_nat n p : (n%:R == p%:R :> algC) = (n == p) := eqr_nat _ n p.
Definition leC_nat n p : (n%:R <= p%:R :> algC) = (n <= p)%N := ler_nat _ n p.
Definition ltC_nat n p : (n%:R < p%:R :> algC) = (n < p)%N := ltr_nat _ n p.
Definition Cchar : [char algC] =i pred0 := @char_num _.

(* This can be used in the converse direction to evaluate assertions over     *)
(* manifest rationals, such as 3%:R^-1 + 7%:%^-1 < 2%:%^-1 :> algC.           *)
(* Missing norm and integer exponent, due to gaps in ssrint and rat.          *)
Definition CratrE :=
  let CnF := Algebraics.Implementation.numFieldType in
  let QtoCm := ratr_rmorphism CnF in
  ((rmorph0 QtoCm, rmorph1 QtoCm, rmorphMn QtoCm, rmorphN QtoCm, rmorphD QtoCm),
   (rmorphM QtoCm, rmorphX QtoCm, fmorphV QtoCm),
   (rmorphMz QtoCm, rmorphXz QtoCm, @ratr_norm CnF, @ratr_sg CnF),
   =^~ (@ler_rat CnF, @ltr_rat CnF, (inj_eq (fmorph_inj QtoCm)))).

Definition CintrE :=
  let CnF := Algebraics.Implementation.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),
   =^~ (@ler_int CnF, @ltr_int CnF, (inj_eq (@intr_inj CnF)))).

Let nz2 : 2%:R != 0 :> algC. Proof. by rewrite -!CintrE. Qed.

(* Conjugation and norm. *)

Definition algC_algebraic x := Algebraics.Implementation.algebraic x.

(* Real number subset. *)

Lemma Creal0 : 0 \is Creal. Proof. exact: rpred0. Qed.
Lemma Creal1 : 1 \is Creal. Proof. exact: rpred1. Qed.
(* Trivial cannot resolve a general real0 hint. *)
Hint Resolve Creal0 Creal1 : core.

Lemma algCrect x : x = 'Re x + 'i * 'Im x.
Proof. by rewrite [LHS]Crect. Qed.

Lemma algCreal_Re x : 'Re x \is Creal.
Proof. by rewrite Creal_Re. Qed.

Lemma algCreal_Im x : 'Im x \is Creal.
Proof. by rewrite Creal_Im. Qed.
Hint Resolve algCreal_Re algCreal_Im : core.

(* Integer subset. *)
(* Not relying on the undocumented interval library, for now. *)

Lemma floorC_itv x : x \is Creal -> (floorC x)%:~R <= x < (floorC x + 1)%:~R.
Proof. by rewrite /floorC => Rx; case: (floorC_subproof x) => //= m; apply. Qed.

Lemma floorC_def x m : m%:~R <= x < (m + 1)%:~R -> floorC x = m.
Proof.
case/andP=> lemx ltxm1; apply/eqP; rewrite eqr_le -!ltz_addr1.
have /floorC_itv/andP[lefx ltxf1]: x \is Creal.
  by rewrite -[x](subrK m%:~R) rpredD ?realz ?ler_sub_real.
by rewrite -!(ltr_int [numFieldType of algC]) 2?(@ler_lt_trans _ x).
Qed.

Lemma intCK : cancel intr floorC.
Proof.
by move=> m; apply: floorC_def; rewrite ler_int ltr_int ltz_addr1 lerr.
Qed.

Lemma floorCK : {in Cint, cancel floorC intr}. Proof. by move=> z /eqP. Qed.

Lemma floorC0 : floorC 0 = 0. Proof. exact: (intCK 0). Qed.
Lemma floorC1 : floorC 1 = 1. Proof. exact: (intCK 1). Qed.
Hint Resolve floorC0 floorC1 : core.

Lemma floorCpK (p : {poly algC}) :
  p \is a polyOver Cint -> map_poly intr (map_poly floorC p) = p.
Proof.
move/(all_nthP 0)=> Zp; apply/polyP=> i.
rewrite coef_map coef_map_id0 //= -[p]coefK coef_poly.
by case: ifP => [/Zp/floorCK // | _]; rewrite floorC0.
Qed.

Lemma floorCpP (p : {poly algC}) :
  p \is a polyOver Cint -> {q | p = map_poly intr q}.
Proof. by exists (map_poly floorC p); rewrite floorCpK. Qed.

Lemma Cint_int m : m%:~R \in Cint.
Proof. by rewrite unfold_in intCK. Qed.

Lemma CintP x : reflect (exists m, x = m%:~R) (x \in Cint).
Proof.
by apply: (iffP idP) => [/eqP<-|[m ->]]; [exists (floorC x) | apply: Cint_int].
Qed.

Lemma floorCD : {in Cint & Creal, {morph floorC : x y / x + y}}.
Proof.
move=> _ y /CintP[m ->] Ry; apply: floorC_def.
by rewrite -addrA 2!rmorphD /= intCK ler_add2l ltr_add2l floorC_itv.
Qed.

Lemma floorCN : {in Cint, {morph floorC : x / - x}}.
Proof. by move=> _ /CintP[m ->]; rewrite -rmorphN !intCK. Qed.

Lemma floorCM : {in Cint &, {morph floorC : x y / x * y}}.
Proof. by move=> _ _ /CintP[m1 ->] /CintP[m2 ->]; rewrite -rmorphM !intCK. Qed.

Lemma floorCX n : {in Cint, {morph floorC : x / x ^+ n}}.
Proof. by move=> _ /CintP[m ->]; rewrite -rmorphX !intCK. Qed.

Lemma rpred_Cint S (ringS : subringPred S) (kS : keyed_pred ringS) x :
  x \in Cint -> x \in kS.
Proof. by case/CintP=> m ->; apply: rpred_int. Qed.

Lemma Cint0 : 0 \in Cint. Proof. exact: (Cint_int 0). Qed.
Lemma Cint1 : 1 \in Cint. Proof. exact: (Cint_int 1). Qed.
Hint Resolve Cint0 Cint1 : core.

Fact Cint_key : pred_key Cint. Proof. by []. Qed.
Fact Cint_subring : subring_closed Cint.
Proof.
by split=> // _ _ /CintP[m ->] /CintP[p ->];
    rewrite -(rmorphB, rmorphM) Cint_int.
Qed.
Canonical Cint_keyed := KeyedPred Cint_key.
Canonical Cint_opprPred := OpprPred Cint_subring.
Canonical Cint_addrPred := AddrPred Cint_subring.
Canonical Cint_mulrPred := MulrPred Cint_subring.
Canonical Cint_zmodPred := ZmodPred Cint_subring.
Canonical Cint_semiringPred := SemiringPred Cint_subring.
Canonical Cint_smulrPred := SmulrPred Cint_subring.
Canonical Cint_subringPred := SubringPred Cint_subring.

Lemma Creal_Cint : {subset Cint <= Creal}.
Proof. by move=> _ /CintP[m ->]; apply: realz. Qed.

Lemma conj_Cint x : x \in Cint -> x^* = x.
Proof. by move/Creal_Cint/conj_Creal. Qed.

Lemma Cint_normK x : x \in Cint -> `|x| ^+ 2 = x ^+ 2.
Proof. by move/Creal_Cint/real_normK. Qed.

Lemma CintEsign x : x \in Cint -> x = (-1) ^+ (x < 0)%C * `|x|.
Proof. by move/Creal_Cint/realEsign. Qed.

(* Natural integer subset. *)

Lemma truncC_itv x : 0 <= x -> (truncC x)%:R <= x < (truncC x).+1%:R.
Proof.
move=> x_ge0; have /andP[lemx ltxm1] := floorC_itv (ger0_real x_ge0).
rewrite /truncC x_ge0 -addn1 !pmulrn PoszD gez0_abs ?lemx //.
by rewrite -ltz_addr1 -(ltr_int [numFieldType of algC]) (ler_lt_trans x_ge0).
Qed.

Lemma truncC_def x n : n%:R <= x < n.+1%:R -> truncC x = n.
Proof.
move=> ivt_n_x; have /andP[lenx _] := ivt_n_x.
by rewrite /truncC (ler_trans (ler0n _ n)) // (@floorC_def _ n) // addrC -intS.
Qed.

Lemma natCK n : truncC n%:R = n.
Proof. by apply: truncC_def; rewrite lerr ltr_nat /=. Qed.

Lemma CnatP x : reflect (exists n, x = n%:R) (x \in Cnat).
Proof.
by apply: (iffP eqP) => [<- | [n ->]]; [exists (truncC x) | rewrite natCK].
Qed.

Lemma truncCK : {in Cnat, cancel truncC (GRing.natmul 1)}.
Proof. by move=> x /eqP. Qed.

Lemma truncC_gt0 x : (0 < truncC x)%N = (1 <= x).
Proof.
apply/idP/idP=> [m_gt0 | x_ge1].
  have /truncC_itv/andP[lemx _]: 0 <= x.
    by move: m_gt0; rewrite /truncC; case: ifP.
  by apply: ler_trans lemx; rewrite ler1n.
have /truncC_itv/andP[_ ltxm1]:= ler_trans ler01 x_ge1.
by rewrite -ltnS -ltC_nat (ler_lt_trans x_ge1).
Qed.

Lemma truncC0Pn x : reflect (truncC x = 0%N) (~~ (1 <= x)).
Proof. by rewrite -truncC_gt0 -eqn0Ngt; apply: eqP. Qed.

Lemma truncC0 : truncC 0 = 0%N. Proof. exact: (natCK 0). Qed.
Lemma truncC1 : truncC 1 = 1%N. Proof. exact: (natCK 1). Qed.

Lemma truncCD :
  {in Cnat & Num.nneg, {morph truncC : x y / x + y >-> (x + y)%N}}.
Proof.
move=> _ y /CnatP[n ->] y_ge0; apply: truncC_def.
by rewrite -addnS !natrD !natCK ler_add2l ltr_add2l truncC_itv.
Qed.

Lemma truncCM : {in Cnat &, {morph truncC : x y / x * y >-> (x * y)%N}}.
Proof. by move=> _ _ /CnatP[n1 ->] /CnatP[n2 ->]; rewrite -natrM !natCK. Qed.

Lemma truncCX n : {in Cnat, {morph truncC : x / x ^+ n >-> (x ^ n)%N}}.
Proof. by move=> _ /CnatP[n1 ->]; rewrite -natrX !natCK. Qed.

Lemma rpred_Cnat S (ringS : semiringPred S) (kS : keyed_pred ringS) x :
  x \in Cnat -> x \in kS.
Proof. by case/CnatP=> n ->; apply: rpred_nat. Qed.

Lemma Cnat_nat n : n%:R \in Cnat. Proof. by apply/CnatP; exists n. Qed.
Lemma Cnat0 : 0 \in Cnat. Proof. exact: (Cnat_nat 0). Qed.
Lemma Cnat1 : 1 \in Cnat. Proof. exact: (Cnat_nat 1). Qed.
Hint Resolve Cnat_nat Cnat0 Cnat1 : core.

Fact Cnat_key : pred_key Cnat. Proof. by []. Qed.
Fact Cnat_semiring : semiring_closed Cnat.
Proof.
by do 2![split] => //= _ _ /CnatP[n ->] /CnatP[m ->]; rewrite -(natrD, natrM).
Qed.
Canonical Cnat_keyed := KeyedPred Cnat_key.
Canonical Cnat_addrPred := AddrPred Cnat_semiring.
Canonical Cnat_mulrPred := MulrPred Cnat_semiring.
Canonical Cnat_semiringPred := SemiringPred Cnat_semiring.

Lemma Cnat_ge0 x : x \in Cnat -> 0 <= x.
Proof. by case/CnatP=> n ->; apply: ler0n. Qed.

Lemma Cnat_gt0 x : x \in Cnat -> (0 < x) = (x != 0).
Proof. by case/CnatP=> n ->; rewrite pnatr_eq0 ltr0n lt0n. Qed.

Lemma conj_Cnat x : x \in Cnat -> x^* = x.
Proof. by case/CnatP=> n ->; apply: rmorph_nat. Qed.

Lemma norm_Cnat x : x \in Cnat -> `|x| = x.
Proof. by move/Cnat_ge0/ger0_norm. Qed.

Lemma Creal_Cnat : {subset Cnat <= Creal}.
Proof. by move=> z /conj_Cnat/CrealP. Qed.

Lemma Cnat_sum_eq1 (I : finType) (P : pred I) (F : I -> algC) :
     (forall i, P i -> F i \in Cnat) -> \sum_(i | P i) F i = 1 ->
   {i : I | [/\ P i, F i = 1 & forall j, j != i -> P j -> F j = 0]}.
Proof.
move=> natF sumF1; pose nF i := truncC (F i).
have{natF} defF i: P i -> F i = (nF i)%:R by move/natF/eqP.
have{sumF1} /eqP sumF1: (\sum_(i | P i) nF i == 1)%N.
  by rewrite -eqC_nat natr_sum -(eq_bigr _ defF) sumF1.
have [i Pi nZfi]: {i : I | P i & nF i != 0%N}.
  by apply/sig2W/exists_inP; rewrite -negb_forall_in -sum_nat_eq0 sumF1.
have F'ge0 := (leq0n _, etrans (eq_sym _ _) (sum_nat_eq0 (predD1 P i) nF)).
rewrite -lt0n in nZfi; have [_] := (leqif_add (leqif_eq nZfi) (F'ge0 _)).
rewrite /= big_andbC -bigD1 // sumF1 => /esym/andP/=[/eqP Fi1 /forall_inP Fi'0].
exists i; split=> // [|j neq_ji Pj]; first by rewrite defF // -Fi1.
by rewrite defF // (eqP (Fi'0 j _)) // neq_ji.
Qed.

Lemma Cnat_mul_eq1 x y :
  x \in Cnat -> y \in Cnat -> (x * y == 1) = (x == 1) && (y == 1).
Proof. by do 2!move/truncCK <-; rewrite -natrM !pnatr_eq1 muln_eq1. Qed.

Lemma Cnat_prod_eq1 (I : finType) (P : pred I) (F : I -> algC) :
    (forall i, P i -> F i \in Cnat) -> \prod_(i | P i) F i = 1 ->
  forall i, P i -> F i = 1.
Proof.
move=> natF prodF1; apply/eqfun_inP; rewrite -big_andE.
move: prodF1; elim/(big_load (fun x => x \in Cnat)): _.
elim/big_rec2: _ => // i all1x x /natF N_Fi [Nx x1all1].
by split=> [|/eqP]; rewrite ?rpredM ?Cnat_mul_eq1 // => /andP[-> /eqP].
Qed.

(* Relating Cint and Cnat. *)

Lemma Cint_Cnat : {subset Cnat <= Cint}.
Proof. by move=> _ /CnatP[n ->]; rewrite pmulrn Cint_int. Qed.

Lemma CintE x : (x \in Cint) = (x \in Cnat) || (- x \in Cnat).
Proof.
apply/idP/idP=> [/CintP[[n | n] ->] | ]; first by rewrite Cnat_nat.
  by rewrite NegzE opprK Cnat_nat orbT.
by case/pred2P=> [<- | /(canLR opprK) <-]; rewrite ?rpredN rpred_nat.
Qed.

Lemma Cnat_norm_Cint x : x \in Cint -> `|x| \in Cnat.
Proof.
case/CintP=> [m ->]; rewrite [m]intEsign rmorphM rmorph_sign.
by rewrite normrM normr_sign mul1r normr_nat rpred_nat.
Qed.

Lemma CnatEint x : (x \in Cnat) = (x \in Cint) && (0 <= x).
Proof.
apply/idP/andP=> [Nx | [Zx x_ge0]]; first by rewrite Cint_Cnat ?Cnat_ge0.
by rewrite -(ger0_norm x_ge0) Cnat_norm_Cint.
Qed.

Lemma CintEge0 x : 0 <= x -> (x \in Cint) = (x \in Cnat).
Proof. by rewrite CnatEint andbC => ->. Qed.

Lemma Cnat_exp_even x n : ~~ odd n -> x \in Cint -> x ^+ n \in Cnat.
Proof.
rewrite -dvdn2 => /dvdnP[m ->] Zx; rewrite mulnC exprM -Cint_normK ?rpredX //.
exact: Cnat_norm_Cint.
Qed.

Lemma norm_Cint_ge1 x : x \in Cint -> x != 0 -> 1 <= `|x|.
Proof.
rewrite -normr_eq0 => /Cnat_norm_Cint/CnatP[n ->].
by rewrite pnatr_eq0 ler1n lt0n.
Qed.

Lemma sqr_Cint_ge1 x : x \in Cint -> x != 0 -> 1 <= x ^+ 2.
Proof.
by move=> Zx nz_x; rewrite -Cint_normK // expr_ge1 ?normr_ge0 ?norm_Cint_ge1.
Qed.

Lemma Cint_ler_sqr x : x \in Cint -> x <= x ^+ 2.
Proof.
move=> Zx; have [-> | nz_x] := eqVneq x 0; first by rewrite expr0n.
apply: ler_trans (_ : `|x| <= _); first by rewrite real_ler_norm ?Creal_Cint.
by rewrite -Cint_normK // ler_eexpr // norm_Cint_ge1.
Qed.

(* Integer divisibility. *)

Lemma dvdCP x y : reflect (exists2 z, z \in Cint & y = z * x) (x %| y)%C.
Proof.
rewrite unfold_in; have [-> | nz_x] := altP eqP.
  by apply: (iffP eqP) => [-> | [z _ ->]]; first exists 0; rewrite ?mulr0.
apply: (iffP idP) => [Zyx | [z Zz ->]]; last by rewrite mulfK.
by exists (y / x); rewrite ?divfK.
Qed.

Lemma dvdCP_nat x y : 0 <= x -> 0 <= y -> (x %| y)%C -> {n | y = n%:R * x}.
Proof.
move=> x_ge0 y_ge0 x_dv_y; apply: sig_eqW.
case/dvdCP: x_dv_y => z Zz -> in y_ge0 *; move: x_ge0 y_ge0 Zz.
rewrite ler_eqVlt => /predU1P[<- | ]; first by exists 22; rewrite !mulr0.
by move=> /pmulr_lge0-> /CintEge0-> /CnatP[n ->]; exists n.
Qed.

Lemma dvdC0 x : (x %| 0)%C.
Proof. by apply/dvdCP; exists 0; rewrite ?mul0r. Qed.

Lemma dvd0C x : (0 %| x)%C = (x == 0).
Proof. by rewrite unfold_in eqxx. Qed.

Lemma dvdC_mull x y z : y \in Cint -> (x %| z)%C -> (x %| y * z)%C.
Proof.
move=> Zy /dvdCP[m Zm ->]; apply/dvdCP.
by exists (y * m); rewrite ?mulrA ?rpredM.
Qed.

Lemma dvdC_mulr x y z : y \in Cint -> (x %| z)%C -> (x %| z * y)%C.
Proof. by rewrite mulrC; apply: dvdC_mull. Qed.

Lemma dvdC_mul2r x y z : y != 0 -> (x * y %| z * y)%C = (x %| z)%C.
Proof.
move=> nz_y; rewrite !unfold_in !(mulIr_eq0 _ (mulIf nz_y)).
by rewrite mulrAC invfM mulrA divfK.
Qed.

Lemma dvdC_mul2l x y z : y != 0 -> (y * x %| y * z)%C = (x %| z)%C.
Proof. by rewrite !(mulrC y); apply: dvdC_mul2r. Qed.

Lemma dvdC_trans x y z : (x %| y)%C -> (y %| z)%C -> (x %| z)%C.
Proof. by move=> x_dv_y /dvdCP[m Zm ->]; apply: dvdC_mull. Qed.

Lemma dvdC_refl x : (x %| x)%C.
Proof. by apply/dvdCP; exists 1; rewrite ?mul1r. Qed.
Hint Resolve dvdC_refl : core.

Fact dvdC_key x : pred_key (dvdC x). Proof. by []. Qed.
Lemma dvdC_zmod x : zmod_closed (dvdC x).
Proof.
split=> [| _ _ /dvdCP[y Zy ->] /dvdCP[z Zz ->]]; first exact: dvdC0.
by rewrite -mulrBl dvdC_mull ?rpredB.
Qed.
Canonical dvdC_keyed x := KeyedPred (dvdC_key x).
Canonical dvdC_opprPred x := OpprPred (dvdC_zmod x).
Canonical dvdC_addrPred x := AddrPred (dvdC_zmod x).
Canonical dvdC_zmodPred x := ZmodPred (dvdC_zmod x).

Lemma dvdC_nat (p n : nat) : (p %| n)%C = (p %| n)%N.
Proof.
rewrite unfold_in CintEge0 ?divr_ge0 ?invr_ge0 ?ler0n // !pnatr_eq0.
have [-> | nz_p] := altP eqP; first by rewrite dvd0n.
apply/CnatP/dvdnP=> [[q def_q] | [q ->]]; exists q.
  by apply/eqP; rewrite -eqC_nat natrM -def_q divfK ?pnatr_eq0.
by rewrite [num in num / _]natrM mulfK ?pnatr_eq0.
Qed.

Lemma dvdC_int (p : nat) x : x \in Cint -> (p %| x)%C = (p %| `|floorC x|)%N.
Proof.
move=> Zx; rewrite -{1}(floorCK Zx) {1}[floorC x]intEsign.
by rewrite rmorphMsign rpredMsign dvdC_nat.
Qed.

(* Elementary modular arithmetic. *)

Lemma eqCmod_refl e x : (x == x %[mod e])%C.
Proof. by rewrite /eqCmod subrr rpred0. Qed.

Lemma eqCmodm0 e : (e == 0 %[mod e])%C. Proof. by rewrite /eqCmod subr0. Qed.
Hint Resolve eqCmod_refl eqCmodm0 : core.

Lemma eqCmod0 e x : (x == 0 %[mod e])%C = (e %| x)%C.
Proof. by rewrite /eqCmod subr0. Qed.

Lemma eqCmod_sym e x y : ((x == y %[mod e]) = (y == x %[mod e]))%C.
Proof. by rewrite /eqCmod -opprB rpredN. Qed.

Lemma eqCmod_trans e y x z :
  (x == y %[mod e] -> y == z %[mod e] -> x == z %[mod e])%C.
Proof. by move=> Exy Eyz; rewrite /eqCmod -[x](subrK y) -addrA rpredD. Qed.

Lemma eqCmod_transl e x y z :
  (x == y %[mod e])%C -> (x == z %[mod e])%C = (y == z %[mod e])%C.
Proof. by move/(sym_left_transitive (eqCmod_sym e) (@eqCmod_trans e)). Qed.

Lemma eqCmod_transr e x y z :
  (x == y %[mod e])%C -> (z == x %[mod e])%C = (z == y %[mod e])%C.
Proof. by move/(sym_right_transitive (eqCmod_sym e) (@eqCmod_trans e)). Qed.

Lemma eqCmodN e x y : (- x == y %[mod e])%C = (x == - y %[mod e])%C.
Proof. by rewrite eqCmod_sym /eqCmod !opprK addrC. Qed.

Lemma eqCmodDr e x y z : (y + x == z + x %[mod e])%C = (y == z %[mod e])%C.
Proof. by rewrite /eqCmod addrAC opprD !addrA subrK. Qed.

Lemma eqCmodDl e x y z : (x + y == x + z %[mod e])%C = (y == z %[mod e])%C.
Proof. by rewrite !(addrC x) eqCmodDr. Qed.

Lemma eqCmodD e x1 x2 y1 y2 :
  (x1 == x2 %[mod e] -> y1 == y2 %[mod e] -> x1 + y1 == x2 + y2 %[mod e])%C.
Proof.
by rewrite -(eqCmodDl e x2 y1) -(eqCmodDr e y1); apply: eqCmod_trans.
Qed.

Lemma eqCmod_nat (e m n : nat) : (m == n %[mod e])%C = (m == n %[mod e]).
Proof.
without loss lenm: m n / (n <= m)%N.
  by move=> IH; case/orP: (leq_total m n) => /IH //; rewrite eqCmod_sym eq_sym.
by rewrite /eqCmod -natrB // dvdC_nat eqn_mod_dvd.
Qed.

Lemma eqCmod0_nat (e m : nat) : (m == 0 %[mod e])%C = (e %| m)%N.
Proof. by rewrite eqCmod0 dvdC_nat. Qed.

Lemma eqCmodMr e :
  {in Cint, forall z x y, x == y %[mod e] -> x * z == y * z %[mod e]}%C.
Proof. by move=> z Zz x y; rewrite /eqCmod -mulrBl => /dvdC_mulr->. Qed.

Lemma eqCmodMl e :
  {in Cint, forall z x y, x == y %[mod e] -> z * x == z * y %[mod e]}%C.
Proof. by move=> z Zz x y Exy; rewrite !(mulrC z) eqCmodMr. Qed.

Lemma eqCmodMl0 e : {in Cint, forall x, x * e == 0 %[mod e]}%C.
Proof. by move=> x Zx; rewrite -(mulr0 x) eqCmodMl. Qed.

Lemma eqCmodMr0 e : {in Cint, forall x, e * x == 0 %[mod e]}%C.
Proof. by move=> x Zx; rewrite /= mulrC eqCmodMl0. Qed.

Lemma eqCmod_addl_mul e : {in Cint, forall x y, x * e + y == y %[mod e]}%C.
Proof. by move=> x Zx y; rewrite -{2}[y]add0r eqCmodDr eqCmodMl0. Qed.

Lemma eqCmodM e : {in Cint & Cint, forall x1 y2 x2 y1,
  x1 == x2 %[mod e] -> y1 == y2 %[mod e] -> x1 * y1 == x2 * y2 %[mod e]}%C.
Proof.
move=> x1 y2 Zx1 Zy2 x2 y1 eq_x /(eqCmodMl Zx1)/eqCmod_trans-> //.
exact: eqCmodMr.
Qed.

(* Rational number subset. *)

Lemma ratCK : cancel QtoC CtoQ.
Proof. by rewrite /getCrat; case: getCrat_subproof. Qed.

Lemma getCratK : {in Crat, cancel CtoQ QtoC}.
Proof. by move=> x /eqP. Qed.

Lemma Crat_rat (a : rat) : QtoC a \in Crat.
Proof. by rewrite unfold_in ratCK. Qed.

Lemma CratP x : reflect (exists a, x = QtoC a) (x \in Crat).
Proof.
by apply: (iffP eqP) => [<- | [a ->]]; [exists (CtoQ x) | rewrite ratCK].
Qed.

Lemma Crat0 : 0 \in Crat. Proof. by apply/CratP; exists 0; rewrite rmorph0. Qed.
Lemma Crat1 : 1 \in Crat. Proof. by apply/CratP; exists 1; rewrite rmorph1. Qed.
Hint Resolve Crat0 Crat1 : core.

Fact Crat_key : pred_key Crat. Proof. by []. Qed.
Fact Crat_divring_closed : divring_closed Crat.
Proof.
split=> // _ _ /CratP[x ->] /CratP[y ->].
  by rewrite -rmorphB Crat_rat.
by rewrite -fmorph_div Crat_rat.
Qed.
Canonical Crat_keyed := KeyedPred Crat_key.
Canonical Crat_opprPred := OpprPred Crat_divring_closed.
Canonical Crat_addrPred := AddrPred Crat_divring_closed.
Canonical Crat_mulrPred := MulrPred Crat_divring_closed.
Canonical Crat_zmodPred := ZmodPred Crat_divring_closed.
Canonical Crat_semiringPred := SemiringPred Crat_divring_closed.
Canonical Crat_smulrPred := SmulrPred Crat_divring_closed.
Canonical Crat_divrPred := DivrPred Crat_divring_closed.
Canonical Crat_subringPred := SubringPred Crat_divring_closed.
Canonical Crat_sdivrPred := SdivrPred Crat_divring_closed.
Canonical Crat_divringPred := DivringPred Crat_divring_closed.

Lemma rpred_Crat S (ringS : divringPred S) (kS : keyed_pred ringS) :
  {subset Crat <= kS}.
Proof. by move=> _ /CratP[a ->]; apply: rpred_rat. Qed.

Lemma conj_Crat z : z \in Crat -> z^* = z.
Proof. by move/getCratK <-; rewrite fmorph_div !rmorph_int. Qed.

Lemma Creal_Crat : {subset Crat <= Creal}.
Proof. by move=> x /conj_Crat/CrealP. Qed.

Lemma Cint_rat a : (QtoC a \in Cint) = (a \in Qint).
Proof.
apply/idP/idP=> [Za | /numqK <-]; last by rewrite rmorph_int Cint_int.
apply/QintP; exists (floorC (QtoC a)); apply: (can_inj ratCK).
by rewrite rmorph_int floorCK.
Qed.

Lemma minCpolyP x :
   {p | minCpoly x = pQtoC p /\ p \is monic
      & forall q, root (pQtoC q) x = (p %| q)%R}.
Proof. by rewrite /minCpoly; case: (minCpoly_subproof x) => p; exists p. Qed.

Lemma minCpoly_monic x : minCpoly x \is monic.
Proof. by have [p [-> mon_p] _] := minCpolyP x; rewrite map_monic. Qed.

Lemma minCpoly_eq0 x : (minCpoly x == 0) = false.
Proof. exact/negbTE/monic_neq0/minCpoly_monic. Qed.

Lemma root_minCpoly x : root (minCpoly x) x.
Proof. by have [p [-> _] ->] := minCpolyP x. Qed.

Lemma size_minCpoly x : (1 < size (minCpoly x))%N.
Proof. by apply: root_size_gt1 (root_minCpoly x); rewrite ?minCpoly_eq0. Qed.

(* Basic properties of automorphisms. *)
Section AutC.

Implicit Type nu : {rmorphism algC -> algC}.

Lemma aut_Cnat nu : {in Cnat, nu =1 id}.
Proof. by move=> _ /CnatP[n ->]; apply: rmorph_nat. Qed.

Lemma aut_Cint nu : {in Cint, nu =1 id}.
Proof. by move=> _ /CintP[m ->]; apply: rmorph_int. Qed.

Lemma aut_Crat nu : {in Crat, nu =1 id}.
Proof. by move=> _ /CratP[a ->]; apply: fmorph_rat. Qed.

Lemma Cnat_aut nu x : (nu x \in Cnat) = (x \in Cnat).
Proof.
by do [apply/idP/idP=> Nx; have:= aut_Cnat nu Nx] => [/fmorph_inj <- | ->].
Qed.

Lemma Cint_aut nu x : (nu x \in Cint) = (x \in Cint).
Proof. by rewrite !CintE -rmorphN !Cnat_aut. Qed.

Lemma Crat_aut nu x : (nu x \in Crat) = (x \in Crat).
Proof.
apply/idP/idP=> /CratP[a] => [|->]; last by rewrite fmorph_rat Crat_rat.
by rewrite -(fmorph_rat nu) => /fmorph_inj->; apply: Crat_rat.
Qed.

Lemma algC_invaut_subproof nu x : {y | nu y = x}.
Proof.
have [r Dp] := closed_field_poly_normal (minCpoly x).
suffices /mapP/sig2_eqW[y _ ->]: x \in map nu r by exists y.
rewrite -root_prod_XsubC; congr (root _ x): (root_minCpoly x).
have [q [Dq _] _] := minCpolyP x; rewrite Dq -(eq_map_poly (fmorph_rat nu)).
rewrite (map_poly_comp nu) -{q}Dq Dp (monicP (minCpoly_monic x)) scale1r.
rewrite rmorph_prod big_map; apply: eq_bigr => z _.
by rewrite rmorphB /= map_polyX map_polyC.
Qed.
Definition algC_invaut nu x := sval (algC_invaut_subproof nu x).

Lemma algC_invautK nu : cancel (algC_invaut nu) nu.
Proof. by move=> x; rewrite /algC_invaut; case: algC_invaut_subproof. Qed.

Lemma algC_autK nu : cancel nu (algC_invaut nu).
Proof. exact: inj_can_sym (algC_invautK nu) (fmorph_inj nu). Qed.

Fact algC_invaut_is_rmorphism nu : rmorphism (algC_invaut nu).
Proof. exact: can2_rmorphism (algC_autK nu) (algC_invautK nu). Qed.
Canonical algC_invaut_additive nu := Additive (algC_invaut_is_rmorphism nu).
Canonical algC_invaut_rmorphism nu := RMorphism (algC_invaut_is_rmorphism nu).

Lemma minCpoly_aut nu x : minCpoly (nu x) = minCpoly x.
Proof.
wlog suffices dvd_nu: nu x / (minCpoly x %| minCpoly (nu x))%R.
  apply/eqP; rewrite -eqp_monic ?minCpoly_monic //; apply/andP; split=> //.
  by rewrite -{2}(algC_autK nu x) dvd_nu.
have [[q [Dq _] min_q] [q1 [Dq1 _] _]] := (minCpolyP x, minCpolyP (nu x)).
rewrite Dq Dq1 dvdp_map -min_q -(fmorph_root nu) -map_poly_comp.
by rewrite (eq_map_poly (fmorph_rat nu)) -Dq1 root_minCpoly.
Qed.

End AutC.

Section AutLmodC.

Variables (U V : lmodType algC) (f : {additive U -> V}).

Lemma raddfZ_Cnat a u : a \in Cnat -> f (a *: u) = a *: f u.
Proof. by case/CnatP=> n ->; apply: raddfZnat. Qed.

Lemma raddfZ_Cint a u : a \in Cint -> f (a *: u) = a *: f u.
Proof. by case/CintP=> m ->; rewrite !scaler_int raddfMz. Qed.

End AutLmodC.

Section PredCmod.

Variable V : lmodType algC.

Lemma rpredZ_Cnat S (addS : @addrPred V S) (kS : keyed_pred addS) :
  {in Cnat & kS, forall z u, z *: u \in kS}.
Proof. by move=> _ u /CnatP[n ->]; apply: rpredZnat. Qed.

Lemma rpredZ_Cint S (subS : @zmodPred V S) (kS : keyed_pred subS) :
  {in Cint & kS, forall z u, z *: u \in kS}.
Proof. by move=> _ u /CintP[m ->]; apply: rpredZint. Qed.

End PredCmod.

End AlgebraicsTheory.
Hint Resolve Creal0 Creal1 Cnat_nat Cnat0 Cnat1 Cint0 Cint1 floorC0 Crat0 Crat1 : core.
Hint Resolve dvdC0 dvdC_refl eqCmod_refl eqCmodm0 : core.


From mathcomp Require Import ssreflect ssrnat.
From LCAC Require Import Relations_ext.

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

(* Definition 1.1: Lambda-terms *)

Inductive lcterm : Set :=
  | lcbvar of nat
  | lcubvar of nat
  | lclam of lcterm
  | lcapp of lcterm & lcterm.

Lemma eq_lcterm_dec (t1 t2 : lcterm) : {t1 = t2}+{t1 <> t2}.
Proof. do !decide equality. Qed.

Infix "@" := lcapp (at level 20, left associativity).

(* Example 1.2 *)

Check (lclam (lcapp (lcbvar 0) (lcubvar 0))).
Check (lclam (lcapp (lcbvar 0) (lcubvar 0))).
Check (lcapp (lcubvar 0) (lclam (lclam (lcbvar 0)))).
Check (lcapp (lclam (lcbvar 0)) (lclam (lcapp (lcbvar 0) (lcubvar 0)))).
Check (lclam (lcapp (lcubvar 0) (lcbvar 0))).

(* Notation 1.3 *)

Fixpoint lclams (n : nat) (t : lcterm) :=
  match n with
    | 0 => t
    | n.+1 => lclams n (lclam t)
  end.

(* Definition 1.6: Length of lambda-term *)

Fixpoint lc_length (t : lcterm) : nat :=
  match t with
    | lclam t' => (lc_length t').+1
    | lcapp t1 t2 => lc_length t1 + lc_length t2
    | _ => 1
  end.

(* Definition 1.7: Binary relation "occurs in" on lambda-terms *)

Inductive lc_occurs : relation lcterm :=
  | lc_occurs_refl t         : lc_occurs t t
  | lc_occurs_left t1 t2 t3  : lc_occurs t1 t2 -> lc_occurs t1 (t2 @ t3)
  | lc_occurs_right t1 t2 t3 : lc_occurs t1 t3 -> lc_occurs t1 (t2 @ t3)
  | lc_occurs_lam t1 t2      : lc_occurs t1 t2 -> lc_occurs t1 (lclam t2).

(* Definition 1.12: Substitution *)


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (y : natural) (x : natural) : natural := plus Zero (mult y x).


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (x : natural) (y : natural) : natural := plus (mult x y) y.


(*
   generalize dependent m.
   または、intro で「forall m」を残した状態で、
   induction n をする例
*)

Require Import Omega.
Require Import NArith.
Require Import Arith.

Fixpoint sum n :=
  match n with
    | O => O
    | S n' => S n' + sum n'
  end.

Theorem Sum_of_nat : forall (n m: nat),
  m = 2 * sum n -> m = n * (n + 1).
Proof.
  intros n m.
  induction n.
  simpl.
  auto.
  (*
     IHn : m = 2 * sum n -> m = n * (n + 1)
     ============================
     m = 2 * sum (S n) -> m = S n * (S n + 1)
   *)
Abort.

Theorem Sum_of_nat : forall (n m: nat),
  m = 2 * sum n -> m = n * (n + 1).
Proof.
  intro n.
  induction n.
  simpl.
  auto.

(*
   n : nat
   IHn : forall m : nat, m = 2 * sum n -> m = n * (n + 1)
   ============================
   forall m : nat, m = 2 * sum (S n) -> m = S n * (S n + 1)
*)
  intros.

  (* 代数的な式の変形をする *)
  subst.
  unfold sum.
  fold sum.
  ring_simplify.
  cut (forall m n, m = n -> m + 2 = n + 2).
  intros.
  apply (H (2 * n + 2 * sum n) (n * n + 3 * n)).
  cut (forall x y n, x = y + n -> 2 * n + x = y + 3 * n).
  intros.
  apply (H0 (2 * sum n) (n * n)).
  cut (forall m n, m = n * (n + 1) -> m = n * n + n).
  intros.
  apply H1.

  apply IHn.                                (* ここで、上記の前提をつかう！ *)
  reflexivity.                              (* 証明終了！ *)

  (* cutで導入した前提を片付ける *)
  intros.
  rewrite H1.
  ring.
  intros.
  rewrite H0.
  ring.
  intros.
  rewrite H.
  reflexivity.
Qed.

Theorem Sum_of_nat' : forall (m n : nat),
  m = 2 * sum n -> m = n * (n + 1).
Proof.
  intros m n.
  generalize dependent m.
  induction n.
  simpl.
  auto.

(*
   n : nat
   IHn : forall m : nat, m = 2 * sum n -> m = n * (n + 1)
   ============================
   forall m : nat, m = 2 * sum (S n) -> m = S n * (S n + 1)

   Sum_of_nat と同じようにする。
*)
Abort.

(* 1変数の場合 *)

Lemma Sample_of_unfold : forall n, 2 * sum n = n * (n + 1).
Proof.
  induction n.
  reflexivity.
  (*
     ここで、sum を unfold して、fold すると式が少し変形されます。
     *)
  unfold sum.
  fold sum.
  (*
     ここでreplaceを使ってちょっと左辺を書き換えます。書き換えて良い証明はsubgoal 2と後回しです。
     *)
  replace (2 * (S n + sum n)) with (2 * S n + 2 * sum n).
  (*
     ここでIHnを用いて書き換えて式変形を ring で自動証明します。後回しにしたものもringで一発です。
     *)
  rewrite IHn.
  ring.
  ring.
Qed.

(* END *)


Open Scope list.
Require Export List.
Require Import Omega.

Inductive is_perm : (list nat) -> (list nat) -> Prop :=
| is_perm_refl :forall l : (list nat), is_perm l l
| is_perm_sym : forall l1 l2 : (list nat), is_perm l1 l2 -> is_perm l2 l1
| is_perm_transi : forall l1 l2 l3 : (list nat), is_perm l1 l2 -> is_perm l2 l3 -> is_perm l1 l3
| is_perm_cons : forall (a : nat) (l1 l2 : (list nat)), is_perm l1 l2 -> is_perm (a::l1) (a::l2)
| is_perm_a : forall (a : nat) (l : (list nat)), is_perm (a::l) (l++a::nil).

Definition l1 : (list nat) := 1::2::3::nil.
Definition l2 : (list nat) := 3::2::1::nil.

Lemma lemma1 : is_perm l1 l2.
unfold l1.
unfold l2.
apply (is_perm_transi (1::2::3::nil) ((2::3::nil)++1::nil) (3::2::1::nil)).
apply is_perm_a.
apply (is_perm_transi (2::3::1::nil) ((3::1::nil)++2::nil) (3::2::1::nil)).
apply is_perm_a.
apply is_perm_cons.
apply (is_perm_transi (1::2::nil) ((1::nil)++(2::nil)) (2::1::nil)).
apply is_perm_cons.
apply is_perm_refl.
apply is_perm_a.
Qed.

Inductive is_sorted : (list nat) -> Prop :=
| is_sorted_nil : is_sorted nil
| is_sorted_base : forall a : nat , is_sorted (a::nil)
| is_sorted_rec : forall (a b : nat) (l : (list nat)), a <= b -> is_sorted (b::l) -> is_sorted (a::b::l).

Lemma lemma2 : is_sorted l1.
unfold l1.
apply is_sorted_rec.
omega.
apply is_sorted_rec.
omega.
apply is_sorted_base.
Qed.

Fixpoint sorted_insert (n : nat) (l : (list nat)) : (list nat) :=
match l with
 | (nil) => (n::nil)
 | (a::h)=> match le_dec n a with
           | left _=> n::a::h
           | right _=> a::(sorted_insert n h)
           end
 end.

Fixpoint insert_sort (l : (list nat)) : (list nat):=
match l with
 | (nil) => (nil)
 | a::h => (sorted_insert a (insert_sort h))
end.

(*
Lemma is_perm_refl_sort :
      forall (l : list nat), is_perm l (insert_sort l).
intro.
elim l.
simpl.
apply is_perm_refl.
intros.
*)

(*
Theorem insert_sort_correction:
forall (l1 : (list nat)) (l2 : (list nat)),(insert_sort l1) = l2 -> (is_perm l1 l2).
intro.
induction l3.
intros.
rewrite <- H.
simpl.

apply is_perm_refl.
intro.
intro.
rewrite <- H.
is_per
*)

Theorem insert_sort_correction:
forall (l1 : (list nat)) (l2 : (list nat)),(insert_sort l1) = l2 -> (is_perm l1 l2)  /\ (is_sorted l2).
induction l3.
intros.
rewrite <- H.
split.
simpl.
apply is_perm_refl.
simpl.
apply is_sorted_nil.
intros.
rewrite <- H.
elim (IHl3 (insert_sort l3)).
intros.

simpl.
split.elim_perm_transi (is_perm (a::l3), a::(insert_sort(l3))) (a::(insert_sort l3)) (is_perm a::(insert_sort l3) (sorted_insert a l3))).
intro.
induction l3.

intros.

rewrite <- H.
split.
apply is_perm_refl.
apply is_sorted_nil.
elim (IHl3 l3).
intros.
split.
rewrite <- H1.
simpl.

intro.

rewrite <- H.

elim (IHl3 l3).
intros.
split.
simpl.

apply

(*
Functional Scheme even_ind := Induction for even Sort Prop.

Theorem even_sound :
 forall (n : nat) (v : Prop) , (even n) = True -> is_even n.
Proof.
  do 2 intro.
  functional induction (even n) using even_ind; intros.
  apply is_even_O.
  elimtype False; rewrite H; auto.
  apply is_even_S; apply IHP; assumption.
Qed.
*)


Require Import Arith Omega.

Theorem le_plus_minus : forall n m:nat, m <= n -> n = m+(n-m).
Proof.
intros n m H.

induction n.

rewrite <- le_n_0_eq with (1 := H); simpl; trivial.


Require Import FiniteTypes Arith MyTactics MPiecewise  VNArith.

(* Top level definitions  of ellipsis functions using natural numbers *)

 Set Implicit Arguments.

 (** * Top level definitions *)

  (** Linear function in n variables.   *)
 Inductive lfun (n : nat)  : Set :=
   | adD :  lfun n -> lfun n -> lfun n
   | suB :  lfun n -> lfun n -> lfun n
   | vr :  Fin n -> lfun n
   | cnst : nat ->  lfun n.

 (** interpretation  *)
 Fixpoint evl n (i : lfun n) (v : Vec nat n) :  nat :=
   match i with
   | cnst n =>  n
   | vr j =>  vecfin v j
   | adD l r => evl l v + evl r v
   | suB l r  => evl l v - (evl r v )
   end.

 (** composition *)
 Fixpoint cmp n (i j : lfun (S n)) : lfun (S n) :=
   match i with
   | adD  l r => adD (cmp l j) (cmp r j)
   | suB  l r => suB (cmp l j) (cmp r j)
   | vr  i  =>  match finEmtp i with
                 | isTp  =>  j
                 | isEmb l => vr (emb l)
                 end
   | cnst n => cnst _ n
  end.

  Fixpoint cmp' n (i : lfun 1) (j : lfun n) : lfun n :=
   match i with
   | adD  l r => adD (cmp' l j) (cmp' r j)
   | suB  l r => suB (cmp' l j) (cmp' r j)
   | vr  i  =>  j
   | cnst n => cnst _ n
  end.

 (* easy to see composition is correct *)
 Lemma cmp'_ok n (i : lfun 1) (j : lfun n) :
   forall v,  evl (cmp' i j) v = evl i (vcons (evl j v) (vnil _)).
 Proof.
   induction i; simpl; intros; FSimpl.
 Qed.

 (** fix the first n variables then treat it as a function in 1 variable *)
 Fixpoint plsn n (i : lfun (S n)) (v : Vec nat n) : lfun 1 :=
    match i with
    | cnst n   =>   cnst _ n
    | vr j     =>   match finEmtp j with
                    | isTp  =>  vr (fz _)
                    | isEmb l => cnst _ (vecfin v l)
                    end
    | adD l r => adD (plsn l v) (plsn r v)
    | suB l r => suB (plsn l v) (plsn r v)
   end.

  (** check we did the correct thing with  *)
  Lemma plsn_ok n (a : lfun (S n)) :
       forall v,  evl (plsn a (vfirst v)) (vcons (vlast v) (vnil nat)) = evl a (vSnoc (vlast v) (vfirst v)).
  Proof.
    induction a; simpl; intros; FSimpl; vSimp; simpl.
     try (unfold vlast; unfold vfirst; unfold vhead; unfold vtail; simpl).
    rewrite vecfin_tp; vecRwt; trivial. rewrite vecfin_emb; vecRwt; trivial.
  Qed.

  (** compsition is correct *)
  Lemma cmp_ok n (i j : lfun (S n)) : forall v,
    evl (cmp i j) v = (* evl (cmp' (plsn i (vfirst v)) (plsn j (vfirst v))) (vcons (vlast v) (vnil _ )). *)
                      evl (cmp (plsn i (vfirst v)) (plsn j (vfirst v)))  (vcons (vlast v) (vnil nat)).
  Proof.
    induction i; simpl; intros.
    rewrite (IHi1 j v); rewrite (IHi2 j v); trivial.
    rewrite (IHi1 j v); rewrite (IHi2 j v); trivial.
    destruct ( finEmtp f); simpl.
     (* *)
    induction j; simpl; auto.
    destruct ( finEmtp f); simpl. destruct (vCons v); simpl.
    generalize a.
    induction n; vSimp; simpl. unfold vlast; unfold vhead; simpl; trivial.
    rewrite (IHn i a0). unfold vlast. unfold vhead; unfold vtail; simpl; trivial.
    apply vecfin_emb.  apply vecfin_emb . trivial.
 Qed.

  (** embedding a function in n variables into one with n+1 variables from .   *)
    Fixpoint lemb n (i : lfun n) : lfun (S n) :=
    match i with
    | cnst n =>  cnst _ n
    | vr j =>  vr (emb j)
    | adD l r => adD (lemb l) (lemb r)
    | suB l r  => suB (lemb l) (lemb r)
   end.

   (*_ embedding a function in n variables into one with n+1 variables - avoid the first  *)
    Fixpoint lfs n (i : lfun n) : lfun (S n) :=
    match i with
    | cnst n =>  cnst _ n
    | vr j =>  vr (fs j)
    | adD l r => adD (lfs l) (lfs r)
    | suB l r  => suB (lfs l) (lfs r)
   end.

  (** embedding is fine *)
  Lemma lemb_ok : forall n (i : lfun n) v, evl i (vfirst v)  = evl (lemb i) v.
  Proof.
   induction i; simpl; intros; try  rewrite vecfin_emb;  auto.
  Qed.

  (* skip first  is fine *)
  Lemma lfs_ok : forall n (i : lfun n) v, evl i (vtail v)  = evl (lfs i) v.
  Proof.
   induction i; simpl; intros; vSimp;  auto.
  Qed.

   (**
    post composing with bivariate function
     -- Given f : N x N -> N and  v : N^n -> N,  want: \lam (a : N^n) n =>  (f . (v n))  n *)
   Fixpoint pl2n n (i : lfun 2) (j : lfun n) : lfun (S n) :=
    match i with
    | cnst n =>  cnst _ n
    | vr i' =>   match finEmtp i' with
                 | isTp  =>  vr (tp _)
                 | isEmb l => lemb  j
                 end
    | adD l r => adD (pl2n l j) (pl2n r j)
    | suB l r  => suB (pl2n l j) (pl2n r j)
   end.

  (** correctness of bivariate post compositions  *)
   Lemma pl2n_ok n (l :  lfun 2) (ln :  lfun n) : forall vz,
     evl (pl2n l ln) vz =  evl l (vcons (evl ln (vfirst vz)) (vcons (vlast vz) (vnil _))).
   Proof.
     induction l; intros; simpl; FSimpl. rewrite lemb_ok. trivial. clear.
     induction n; vSimp; simpl. unfold vlast; unfold vhead; trivial.
     generalize (IHn (vcons a0 i)); simpl. intro h; rewrite h.
     unfold vlast; unfold vhead; unfold vtail; auto.
  Qed.

 Section TLPiecewise.
   (** * Now extend definitions and proofs to piecewise-linear functions  *)
   Definition Plfun n := Piecewise (lfun n).

   Fixpoint pevl n  (i : Plfun n) v  :=
   match i with
   | lp a => evl a v
   | pf l cl cr => if lt_le_dec 0 (pevl l v) then pevl cl v else pevl cr v
   end.

   Section Composition.

    Fixpoint pcmp' n (l : lfun 1) (ln : Plfun n) :=
     match ln with
     | lp a => lp (cmp' l a)
     | pf a b c => pf a  (pcmp' l b)  (pcmp' l c)
     end.

    Lemma pcmp'_ok n l (ln : Plfun n) v : pevl (pcmp' l ln) v = evl l (vcons (pevl ln v) (vnil _ )).
    Proof.
      induction ln; simpl; intros; try apply cmp'_ok.
      rewrite (IHln2  v);  rewrite  (IHln3 v); destruct ( lt_le_dec 0 (pevl ln1 v)); trivial.
   Qed.

   (** post composing with a univariate piecewise-linear function  *)
   Fixpoint pcmp1 n (i : Plfun 1) (j : Plfun n) :=
    match i with
    | lp l => pcmp' l j
    | pf c l r => pf (pcmp1 c j) (pcmp1 l j) (pcmp1 r j)
   end.

  (** correctness of this composition  *)
  Lemma pcmp1_ok n (i : Plfun 1) (j : Plfun n) : forall v, pevl (pcmp1 i j) v = pevl i (vcons (pevl j v) (vnil _ )).
  Proof.
    induction i; try apply pcmp'_ok; simpl.
    intros j v; rewrite (IHi1 j v); rewrite (IHi2 j v); rewrite (IHi3 j v); trivial.
  Qed.

    (* piecewise case for plSn2n *)
   Fixpoint pplsn n (i :  Plfun (S n)) (v : Vec nat n) : Piecewise (lfun 1) :=
     match i with
     | lp l => lp (plsn l v)
     | pf c l r => pf (pplsn c v)  (pplsn l v) (pplsn r v)
     end.

   (* correctness *)
   Lemma pplsn_ok n (l :  Plfun (S n))  : forall v,
       pevl (pplsn l (vfirst v)) (vcons (vlast v) (vnil _)) = pevl l (vSnoc (vlast v) (vfirst v)) .
   Proof.
     induction l; simpl; intros; try apply plsn_ok.
     rewrite (IHl1 v); rewrite (IHl2 v); rewrite (IHl3 v); trivial.
   Qed.

   (** composition of two n+1-variate piecewise-linear functions, by fixing the
    first n varaibles and treating them as a univariate function *)
  Fixpoint pcmp_aux n (l : lfun (S n)) (i : Plfun (S n)) : Plfun (S n) :=
    match i with
    | lp ll => lp (cmp l ll)
    | pf c ll rr => pf c (pcmp_aux l ll) (pcmp_aux l rr)
    end.

  Lemma cmp_cmp' (i j : lfun 1): forall v,  evl (cmp i j) v = evl (cmp' i j) v.
  Proof.
    induction i; simpl; intros; FSimpl.
  Qed.

 (*  Lemma pcmp_cmp' (i : lfun 1) (j : Plfun 1) : forall v,  pevl (pcmp' i j) v = pevl (pcmp_aux i j) v. *)

  (* correctness proof for pcompSn1*)
  Lemma pcmp_aux_ok n (i : lfun (S n)) (j : Plfun (S n)) : forall v,
    pevl (pcmp_aux i j) v = pevl (pcmp' (plsn i (vfirst v)) (pplsn j (vfirst v))) (vcons (vlast v) (vnil _ )).
   Proof.
     induction j; simpl; intros.  rewrite  (cmp_ok i a v); rewrite  cmp_cmp'.  trivial.
     rewrite (IHj2 v);  rewrite (IHj3 v).
     replace (pevl j1 v) with (pevl (pplsn j1 (vfirst v)) (vcons (vlast v) (vnil _))); trivial.
     rewrite (pplsn_ok j1 v); rewrite <- (vVsnoc v); trivial.
  Qed.

  (** main function *)
  Fixpoint pcmp n (i j : Plfun (S n)) :=
   match i with
   | lp l => pcmp_aux l j
   | pf c l r => pf (pcmp c j) (pcmp l j) (pcmp r j)
   end.

  (** correctness proof for pcompSn*)
  Lemma pcmp_ok n  (i j : Plfun (S n)) : forall v,
    pevl (pcmp i j) v = pevl (pcmp1 (pplsn i (vfirst v)) (pplsn j (vfirst v))) (vcons (vlast v) (vnil _ )).
  Proof.
   induction i; simpl; intros;  try apply pcmp_aux_ok.
   rewrite (IHi1 j v);  rewrite (IHi3 j v);  rewrite (IHi2 j v); trivial.
  Qed.

   (* push a piecewise-linear function in n variables into a functions in n + 1 variables
      such that  f v = (polwk f) (tail v) *)
  Fixpoint plfs n (i : Plfun n) :=
    match i with
    | lp l => lp (lfs l)
    | pf a b c => pf (plfs a) (plfs b) (plfs c)
    end.

  Lemma plfs_ok n (i : Plfun n) : forall v, pevl (plfs i) v = pevl i (vtail v).
  Proof.
    induction i; simpl; intros; try rewrite lfs_ok; trivial.
    rewrite (IHi1 v); rewrite (IHi2 v); rewrite (IHi3 v); trivial.
  Qed.

  (* push a piecewise-linear function in n variables into a functions in n + 1 variables
      such that  f v = (polwk f) (first v) *)
  Fixpoint pemb n (i : Plfun n) :=
    match i with
    | lp l => lp (lemb l)
    | pf a b c => pf (pemb a) (pemb b) (pemb c)
    end.

  Lemma pemb_ok n (i : Plfun n) : forall v, pevl (pemb i) v = pevl i (vfirst v).
  Proof.
    induction i; intros; simpl; try rewrite lemb_ok; trivial.
    rewrite (IHi1 v); rewrite (IHi2 v); rewrite (IHi3 v); trivial.
  Qed.

    (*
    post composing with bivariate piecewise-linear function
    Given f : N x N -> N and  v : N^n -> N, \lambda (a : N^n) m =>  (f . (v a))  m *)
  Fixpoint ppl2n_aux n (l : lfun 2) (i : Plfun  n)  :=
    match i with
    | lp ll => lp (pl2n l ll)
    | pf c ll rr => pf (pemb c) (ppl2n_aux l ll) (ppl2n_aux l rr)
    end.

   Lemma ppl2n_aux_ok n (l :  lfun 2) (ln :  Plfun n) : forall vz,
      pevl (ppl2n_aux l ln) vz =  evl l (vcons (pevl ln (vfirst vz)) (vcons (vlast vz) (vnil _))).
   Proof.
     induction ln; simpl; try apply pl2n_ok.
     intros vz; rewrite (pemb_ok ln1 vz);  rewrite (IHln2 vz); rewrite (IHln3 vz).
     destruct (lt_le_dec 0 (pevl ln1 (vfirst vz))); trivial.
   Qed.

  (* case : bothe piecewise *)
   Fixpoint ppl2n n (l : Plfun 2) (i : Plfun  n)  :=
    match l with
    | lp ll => ppl2n_aux ll i
    | pf c ll rr => pf (ppl2n c i) (ppl2n ll i) (ppl2n rr i)
    end.

    (* correctness *)
    Lemma ppl2Sn_ok n (l : Plfun 2) (ln :  Plfun n) : forall vz,
      pevl (ppl2n l ln) vz =  pevl l (vcons (pevl ln (vfirst vz)) (vcons (vlast vz) (vnil _))).
    Proof.
      induction l; simpl; intros;  try apply ppl2n_aux_ok.
      rewrite (IHl1 ln vz); rewrite (IHl2 ln vz); rewrite (IHl3 ln vz); trivial.
    Qed.

    (* --------------------------------------------------*)
    Fixpoint ppl2n_ax n (l : Plfun 2) (i : lfun n)  :=
    match l with
    | lp ll => lp (pl2n ll i)
    | pf c ll rr => pf (ppl2n_ax c i) (ppl2n_ax ll i) (ppl2n_ax rr i)
    end.

  Lemma ppl2n_ax_ok n (l : Plfun 2) (i : lfun n) :
      forall v, pevl (ppl2n_ax l i) v = pevl  l (vcons (evl i (vfirst v)) (vcons (vlast v) (vnil _))).
  Proof.
    induction l; simpl; intros. apply pl2n_ok.
    rewrite (IHl1 i v); rewrite (IHl2 i v);  rewrite (IHl3 i v). trivial.
  Qed.

 End Composition.

 Section Representation.

   (** We can represent polymorphic functions whose shape maps are linear
     as a pair, given by a linear function for the shapes and a piecewise-linear function
    for the positions. This representaiton does not have a on-to-one correspondence with
    container morphisms, but instead captures the operations inherent in the container representation
    in an intuitive way, amenable to geometric interpretation   *)

    (** liner shape maps only *)
    Definition PCm n :=  prod (lfun  (S n)) (Plfun (S  (S n))).

     (** piecewise-linear shape maps -- these are more general *)
     Definition PPCm n :=  prod (Plfun  (S n)) (Plfun (S  (S n))).

    (** Interpretation  *)
    Definition PCm_int' n (X : Set) :   PCm  n -> Vec nat (S n) * (nat -> X) ->   nat * (nat -> X) :=
       fun pl  vl => let (l , p) := pl in
                                (evl l (fst vl) , fun v => snd vl (pevl p (vSnoc v (fst vl)))).
     (* piecewise case *)
     Definition PPCm_int' n (X : Set) :   PPCm  n -> Vec nat (S n) * (nat -> X) ->   nat * (nat -> X) :=
       fun pl  vl => let (l , p) := pl in
                                (pevl l (fst vl) , fun v => snd vl (pevl p (vSnoc v (fst vl)))).

    (** unpacking  list of lists  *)
    Fixpoint  nf2pvf1 n (X : Set) (v : Vec (nat * (nat -> X)) n) (F : nat -> X) (i : nat) :   X :=
     match v with
     | vnil => F i
     | vcons _ x xs =>  if le_lt_dec (fst x ) i then  nf2pvf1 xs  (snd x) (i - (fst x)) else (snd x) i
     end.

  (*
    Fixpoint  vf2pvf1 n (X : Set) (v : Vec (Z * (Z -> X)) n) (k : Z * (Z -> X)) (z : Z) :   X :=
     match v with
     | vnil => snd k z
     | vcons _ x xs =>  if Z_lt_dec z (fst x) then  (snd x) z
                                 else vf2pvf1 xs k (z - fst x)
     end.
   *)

   Definition nf2pf n (X : Set) (v : Vec (nat * (nat -> X)) (S n)) :=
                (vmap  (fst (A := nat) (B := nat -> X)) v, nf2pvf1 (vtail v) (snd (vhead v))) .

   Definition PCm_int n (X : Set) :   PCm  n -> Vec (prod nat (nat -> X)) (S n) ->   nat * (nat -> X) :=
        fun i nm => PCm_int' i (nf2pf nm).

   (* piecewise *)
    Definition PPCm_int n (X : Set) :   PPCm  n -> Vec (nat * (nat -> X)) (S n) ->   nat * (nat -> X) :=
        fun i nm => PPCm_int' i (nf2pf nm).

 (** Composition : we only postcompose with a univariete functions *)
    Definition PComp n (l : PCm 0) (r : PCm n) :=
      let (v , G) := l in
         let (u , F) := r in
              (cmp' v u , pcmp F (ppl2n_ax G u)).

    (** composition of lmors commute with composition of functions*)
    Lemma PCm_cmp_ok n (l : PCm 0)  (r : PCm n)  (X : Set) :
       forall (k : Vec (prod nat (nat -> X)) (S n)),  PCm_int (PComp l r) k = PCm_int l (vcons (PCm_int r k) (vnil _)).
       unfold PCm; unfold PComp; unfold PCm_int; unfold PCm_int'.
       destruct l; destruct r; simpl. intros.
       assert (forall (A B : Type) (a b : A * B), fst a = fst b -> snd a = snd b -> a = b);
        try (destruct a;  destruct b0; simpl; repeat( intro h; destruct h); trivial).
       apply H; simpl; try apply (cmp'_ok l l0 ).
       apply extensionality;  intros;
       rewrite (pcmp_ok  p0 (ppl2n_ax p l0));  rewrite pcmp1_ok;
       rewrite (pplsn_ok (ppl2n_ax p l0) ); rewrite ppl2n_ax_ok;
       generalize (pplsn_ok p0 (vSnoc (pevl p (vcons (evl l0 (vmap (fst (A := nat) (B := nat -> X)) k)) (vcons a (vnil nat))))
         (vmap (fst (A := nat) (B := nat -> X)) k))); repeat vecRwt ; try ( intro H0; rewrite H0; trivial).
    Qed.

   (* piecewise composition *)
    Definition PPComp n (l : PPCm 0) (r : PPCm n) :=
      let (v , G) := l in
         let (u , F) := r in
              (pcmp1 v u , pcmp F (ppl2n G u)).

    (** piecewise composition is correct *)
    Lemma PPCm_cmp_ok n (l : PPCm 0)  (r : PPCm n)  (X : Set) :
       forall (k : Vec (prod nat (nat -> X)) (S n)),  PPCm_int (PPComp l r) k = PPCm_int l (vcons (PPCm_int r k) (vnil _)).
       unfold PPCm; unfold PPComp; unfold PPCm_int; unfold PPCm_int'.
       destruct l; destruct r; simpl. intros.
       assert (forall (A B : Type) (a b : A * B), fst a = fst b -> snd a = snd b -> a = b);
        try (destruct a;  destruct b0; simpl; repeat( intro h; destruct h); trivial).
       apply H; simpl. try apply (pcmp1_ok p p1 ).
       apply extensionality;  intros.
       rewrite (pcmp_ok  p2 (ppl2n p0 p1)); rewrite pcmp1_ok;
       rewrite (pplsn_ok (ppl2n p0 p1) ); rewrite ppl2Sn_ok;
       generalize (pplsn_ok p2 (vSnoc (pevl p0 (vcons (pevl p1 (vmap (fst (A := nat) (B := nat -> X)) k)) (vcons a (vnil nat))))
         (vmap (fst (A := nat) (B := nat -> X)) k))); repeat vecRwt ; try ( intro H0; rewrite H0; trivial).
    Qed.

   Fixpoint pcmpm_aux (n : nat) (i : Plfun (S n)) (j : lfun (S n))  :=
    match i with
    | lp l => lp (cmp l  j)
    | pf c l r => pf (pcmpm_aux c j) (pcmpm_aux l j) (pcmpm_aux r j)
    end.

   (* correctness *)
   Lemma pcmpm_aux_ok n (i : Plfun (S n)) (l : lfun (S n)) :
    forall v,   pevl (pcmpm_aux i l) v =
       pevl (pcmp1 (pplsn i (vfirst v)) (pplsn (lp l) (vfirst v))) (vcons (vlast v) (vnil nat)).
   Proof.
    induction i; simpl; intros. rewrite <- cmp_cmp'. apply cmp_ok.
    rewrite (IHi1 l v); rewrite (IHi2 l v); rewrite (IHi3 l v). trivial.
   Qed.

  Fixpoint pcmpm (n : nat) (i j : Plfun (S n))  :=
    match j with
    | lp l => pcmpm_aux i l
    | pf c l r => pf c (pcmpm i l) (pcmpm i r)
    end.

  (* correctness *-)
  Lemma pcmpm_ok n (i j : Plfun (S n)) :
    forall v, *)

  (* post compoing a piecewise-linear function along hte if *)
  Fixpoint pmp m (l : PPCm 0) (r : PPCm m) :=
       let (v , G) := l in
         let (u , F) := r in
              (pcmp1 v u , pcmpm F (ppl2n G u)).

 End Representation.

 End TLPiecewise.

 Section Normalizing.
     (** Euqality for linear functions  *)

     (* push a number into a vector at positions determined by Fin n *)
     Fixpoint push n (X : Set) (x0 : X) (i : Fin n) (z : X) : Vec X n :=
     match i in Fin e return (Vec X e ) with
     | fz m => vcons z (vec m x0)
     | fs _ j => vcons x0 (push  x0 j z)
     end.

   (* in n variables, alpha is an array of length n *)
   Fixpoint alps n (i : lfun n) :  Vec nat n :=
    match i  with
    | cnst _ =>  vec n 0
    | vr j => push 0 j 1
    | adD l r => vAdd (alps l) (alps r)
    | suB l r => vSub (alps l) (alps r)
   end.

   (* beta is just a constant *)
   Fixpoint bet n (i : lfun n)  :=
   match i  with
   | cnst n =>   n
   | vr _   => 0
   | adD l r => (bet l + bet r)
   | suB l r => (bet l - bet r)
   end.

   Definition norm n (i : lfun n) := (alps i , bet i).

   (* decision procedure for Lfun n  *)
   Definition lfunEq n (i j : lfun n) :=
     if (vecEqDec eq_nat_dec (alps i) (alps j)) then (if eq_nat_dec (bet i) (bet j) then true else false) else false.

 End Normalizing.

Section Equality.

   Definition vlst n (v : Vec nat n) :=
      match v with
      | vnil  => 0
      | xs    => vlast xs
      end.

   (** Equality:  *)
  Inductive pcmEQ n (i j : PPCm n) : Prop :=
  | isEQ :  (* lfunEq  (fst i) (fst j) = true -> *)
            (forall v, pevl (fst i) v = pevl (fst j) v) ->
            (forall v,
               vlast v < pevl (fst i) (vfirst v) ->
               vlast v < pevl (fst j) (vfirst v) ->  pevl  (snd i) v = pevl (snd j) v) -> pcmEQ i j.

  (** Correctness of equality  *)
 Lemma pcmEQ_ok n (l r : PPCm n)  (X : Set) :
       forall (k : Vec (prod nat (nat -> X)) (S n)),
    pcmEQ l r -> (forall a, a <  pevl (fst l)  (vmap (fst (A := nat) (B := nat -> X)) k) /\
                            a <  pevl (fst r)  (vmap (fst (A := nat) (B := nat -> X)) k) ) -> PPCm_int  l k = PPCm_int r k.
 Proof.
   unfold PPCm_int; unfold PPCm_int'; intros n l r X k H H0.
   destruct l; destruct r; destruct H as [H1 H2]; simpl in *.
   generalize H2; generalize H0. clear H0 ; clear H2.
   rewrite (H1 (vmap (fst (A := nat) (B := nat -> X)) k) ).
   intros H0 H2;
   cut (forall (A B :Set) (a a1 : A) (b b1 : B), a = a1 /\ b = b1 -> (a, b) = (a1 , b1)).
  intros. apply H;split; clear H; trivial.
   apply extensionality. intros.
   generalize (H2 (vSnoc a (vmap (fst (A := nat) (B := nat -> X)) k)) ).
   clear H2; vecRwt.
   rewrite (vfirst_vSnoc  a (vmap (fst (A := nat) (B := nat -> X)) k)  ).
   rewrite (H1 (vmap (fst (A := nat) (B := nat -> X)) k)).
   intros. destruct (vCons k); unfold vhead; unfold vtail; simpl.
   destruct a0; simpl in *.
   rewrite (H (proj1 (H0 a)) (proj2 (H0 a))); trivial.
   intros. destruct H as [L R]; destruct L; destruct R; trivial.
  Qed.

  End Equality.

(** * Experiements with arithmetic representation *)

 (** first some basic tactics to introduce the assumptions, etc *)
  Ltac remLtLe' :=
     match goal with
     | [|- context [lt_le_dec ?x ?y]] =>  destruct (lt_le_dec x y)
  end.

 Ltac remLtLe := repeat remLtLe'.

 Ltac initialise_tac :=
     apply isEQ; simpl; intros; vSimp; simpl in *; remLtLe.

  (** main tactic *)
  Ltac containers :=
      initialise_tac; optimiseOmega;  omega.

  Section Examples_and_Definitions.
(** Definitions and Exmaples*)

  (** reverse *)
  Definition Rev1 :  Plfun 1 *  Plfun 2  :=
   (  lp (vr (fz _ )) ,
   (lp (suB (suB (vr (fz _)) (vr (tp _))) (cnst _ 1))) ). (*pf (lp (suB (vr (fz _))  (vr (tp _)))) (lp (cnst _ 0))). *)

  (** identity function  *)
  Definition Id1 n :  lfun n :=
    match n with
    | O => cnst _ 0
    | S n => vr (tp n)
    end.

  Definition Idf :  Plfun 1 *  Plfun 2  := (   lp (vr (fz _ )) , lp (Id1 2)).

  (** rev is involutive  *)
  Lemma rev_rev_idm  :  pcmEQ (PPComp Rev1 Rev1) Idf.
     containers.
   (*  currently takes 11 seconds *)
  Qed.

  (* Append = (n, f) where
      n = \lambda  n m. n + m
      f = \lambda n m i. if i < n + m then
                               if i < n then i else n - i
                          else 0
   *)
  (** Append  *)
  Definition appn1 : PPCm 1 :=
     (lp (adD (vr (fz _ )) (vr (fs (fz _)))) ,
          (pf (lp (suB (vr (fz _)) (vr (tp _)))) (lp (vr (tp 2))) (lp (suB (vr (fz _)) (vr (tp 2)))))
     ).

   (**  app reverse *)
  Lemma rev1_appn1 : pcmEQ (PPComp Rev1 appn1) (pmp Rev1 appn1).
  Proof.
    containers.
   (* apply isEQ; simpl; intros; vSimp; simpl in *; remLtLe; repeat remMinus_0; auto. *)
  Qed.

 (* tail = (f ,g ) where
         f n = n - 1
         g n i =  i + 1   *)

 (** tail  *)
 Definition tail1 : PPCm 0 :=
    ( lp (suB (vr (fz _)) (cnst _ 1)) , lp (adD (vr (tp 1)) (cnst _ 1)) ).

 (* butlast = (f , g)  where
       (f , g) where
       f n = n - 1
       g n i =  i (or i - 1) *)

 (** But last *)
 Definition butlast1 : PPCm 0 :=
     ( lp (suB (vr (fz _)) (cnst _ 1)) , lp (vr (tp _ ))) (*suB (vr (tp _)) (cnst _ 1)) *).

(** last *)
 Definition last1 : PPCm 0 :=
    ( lp (suB (vr (fz _)) (suB (vr (fz _)) (cnst _ 1))) ,
      pf (lp (suB (suB (vr (fz _)) (suB (vr (fz _)) (cnst _ 1))) (vr (tp _ ))))
         (lp (suB (vr (fz _)) (cnst _ 1))) (lp (cnst _ 0))).

 (** head  *)
 Definition head1 : PPCm 0 :=
    (lp (suB (vr (fz _)) (suB (vr (fz _)) (cnst _ 1))),
        pf (lp (suB (suB (vr (fz _)) (suB (vr (fz _)) (cnst _ 1))) (vr (tp _ ))))
         (lp (cnst _ 0)) (lp (cnst _ 0))).

 (** Theorems:
 -- 1.  Theorem crev_chead_clast :  (m_comp cHead crev) ==== clast.
 -- 2.  Theorem crev_cbut_last_ctail :  (m_comp ctail crev) ==== (m_comp crev cbut_lst).
 *)

 Lemma  rev_head_last : pcmEQ (PPComp head1 Rev1) last1.
    containers.
 Qed.

 Lemma  crev_butlast_tail : pcmEQ (PPComp tail1 Rev1) (PPComp Rev1 butlast1).
   containers.
 Qed.

  (** Take               *)
 Definition take1 m : PPCm 0 :=
    ( pf (lp (suB (cnst _ m) (vr (fz _)))) (lp (cnst _ m)) (lp (vr (fz 0)))  ,
       (pf (lp (suB (cnst _ m) (vr (tp 1)))) (lp (cnst _ m)) (lp (vr (tp 1))))
    ).

  (** drop m   *)
  Definition drop1 m : PPCm 0 :=
    ( lp (suB (vr (fz _)) (cnst _ m)) , lp (adD (vr (tp _)) (cnst _ m)) ).

 (**  drop n (drop m xs) = drop (n + m) xs  *)
 Lemma drop_drop n m : pcmEQ (PPComp (drop1 n) (drop1 m)) (drop1 (n + m)).
 Proof.
   intros. containers.
 Qed.

 (* drop n (take m xs) = take (m - n) (drop n xs)  *)
 Lemma drop_take n m : pcmEQ (PPComp (drop1 n) (take1 m)) (PPComp (take1 (m - n)) (drop1 n)).
 Proof.
   intros. containers.
 Qed.

 (**  take n (drop m xs) = drop m (take (n + m) xs) *)
 Lemma take_drop n m : pcmEQ (PPComp (take1 n) (drop1 m)) (PPComp (drop1 m) (take1 (n + m))).
 Proof.
    intros. containers.
 Qed.

  (* rot1 = (f ,g ) where
        f = id
        g = \lambda n i.  if i < 1 then n- 1 else i -1
                           *)
   (** unrotate  - put last element at the front  *)
  Definition unrot1 : PPCm 0 :=
    (lp (Id1 1) ,
     pf (lp (vr (tp _)))
         (lp (suB (vr (tp _)) (cnst _ 1)))  (lp (suB (vr (fz _)) (cnst _ 1)))
    ).

  (* rotate - dual to unrotate *)
  Definition rot1 : PPCm 0 :=
    (lp (Id1 1) ,
     pf (lp (suB (suB (vr (fz _))  (cnst _ 1)) (vr (tp _))))
         (lp (adD (vr (tp _)) (cnst _ 1)))
        (* (lp (suB (vr (tp _)) (suB (vr (fz _))  (cnst _ 1)))) *)
          (lp (cnst _ 0))
    ).

  (** roatate (unrotate x) = xs *)
 Lemma rot_unrot : pcmEQ (PPComp rot1 unrot1)  Idf.
 Proof.
     containers.
  Qed.

 (** head  head (reverse ( rotate xs )) = head xs  *)
 Lemma head_rev_rot : pcmEQ (PPComp head1 (PPComp Rev1 rot1)) head1.
 Proof.
    containers.
 Qed.

 (**  last (rotate xs) = head xs *)
 Lemma last_rot_head : pcmEQ (PPComp last1 rot1) head1.
 Proof.
   containers.
 Qed.

 (** head (unrotate xs) = last xs  *)
 Lemma head_unrot_last : pcmEQ (PPComp head1 unrot1) last1.
 Proof.
   containers.
 Qed.

 (**   drop 1 (unrotate xs) =  butlast xs *)
 Lemma drop_unrot_but_last : pcmEQ (PPComp (drop1 1) unrot1) butlast1.
 Proof.
   containers.
 Qed.

 (**  butlast (rotate xs) = tail xs*)
 Lemma butlast_rot_tail : pcmEQ (PPComp butlast1 rot1) tail1.
 Proof.
   containers.
 Qed.

End Examples_and_Definitions.


Require Import Coq.Program.Program.
Require Import Coq.Arith.Compare_dec.
Notation "( x & y )" := (existS _ x y) : core_scope.

Require Import Omega.

Program Fixpoint euclid (a : nat) (b : { b : nat | b <> O }) {wf lt a}  :
  { q : nat & { r : nat | a = b * q + r /\ r < b } } :=
  if le_lt_dec b a then let (q', r) := euclid (a - b) b in
  (S q' & r)
  else (O & a).

Next Obligation.
  assert(b * S q' = b * q' + b) by auto with arith ; omega.
Defined.

Program Definition test_euclid : (prod nat nat) := let (q, r) := euclid 4 2 in (q, q).

Eval lazy beta zeta delta iota in test_euclid.

Program Definition testsig (a : nat) : { x : nat & { y : nat | x < y } } :=
  (a & S a).

Check testsig.


(**

Basic facts about types not being equal. Includes some examples and
some more general theorems. The heart of the type inequality proof for
finite types is a fact about finite isomorphisms in finite_iso.v.

Examples include some simple (small) finite types as well as
inequality of sets and their powersets, via diagonalization.

*)

Set Implicit Arguments.

Require Import finite_iso.

(* Some manual proofs of type inequalities, with techniques specific
to the small cardinalities involved. *)

Theorem empty_not_unit : Empty_set <> unit.
Proof.
  intro.
  pose proof tt.
  rewrite <- H in H0.
  inversion H0.
Qed.

Theorem unit_not_bool : unit <> bool.
Proof.
  intro.
  assert (forall x y:unit, x = y).
  destruct x, y; auto.
  rewrite H in H0.
  pose proof (H0 true false).
  inversion H1.
Qed.

(* unit can only be proven not equal to inhabited option types, hence
the extra premise of any a:A) *)
Theorem unit_not_option : forall A (a:A),
   (unit:Type) <> option A.
Proof.
  unfold not; intros.
  assert (forall x y:unit, x = y).
  destruct x, y; auto.
  rewrite H in H0.
  pose proof (H0 (Some a) None).
  inversion H1.
Qed.

Theorem bool_not_nat : bool <> nat.
Proof.
  intro.
  assert (forall x y z:bool, x = y \/ y = z \/ x = z).
  destruct x, y, z; eauto.
  rewrite H in H0.
  pose proof (H0 0 1 2).
  intuition congruence.
Qed.

Require Import cardinality.

Theorem no_iso_ineq : forall A B,
  (Iso.T A B -> False) ->
  A <> B.
Proof.
  unfold not; intros; subst.
  auto using Iso.Refl.
Qed.

Theorem no_iso_ineq_set : forall (A B:Set),
  (Iso.T A B -> False) ->
  A <> B.
Proof.
  unfold not; intros; subst.
  auto using Iso.Refl.
Qed.

Corollary nat_not_baire_space : nat <> (nat -> nat).
Proof.
  apply no_iso_ineq_set.
  apply Iso.Cantor.
Qed.

Theorem one_cardinality : forall A n m
  (iso_n: cardinality A n)
  (iso_m: cardinality A m),
  n = m.
Proof.
  intros.
  pose proof (Iso.Trans (Iso.Sym iso_n) iso_m).
  apply fin_iso; assumption.
Qed.

Theorem neq_cardinalities : forall (A B:Type) n m,
  cardinality A n ->
  cardinality B m ->
  n <> m ->
  A <> B.
Proof.
  intros.
  intro; subst.
  eauto using one_cardinality.
Qed.

Example unit_neq_bool : (unit:Type) <> bool.
Proof.
  apply neq_cardinalities with (n := 1) (m := 2).
  exact unit_1.
  exact bool_2.
  auto.
Qed.

(** Diagonalization between a set and its powerset, defined
computationally as boolean functions on the set. *)
Theorem powerset_bigger : forall A, Iso.T A (A -> bool) -> False.
Proof.
  (* this proof is modeled after Theorem 13.7 in
  http://www.people.vcu.edu/~rhammack/BookOfProof/Cardinality.pdf,
  though our formulation of isomorphisms is a bit different (rather
  than requiring a single injective and surjective function we provide
  both functions and both directions of inverse proofs) *)
  destruct 1.
  pose (f := fun x => if (to x x) then false else true).
  assert (to (from f) (from f) = f (from f)) by
    (rewrite to_from; reflexivity).
  destruct (to (from f) (from f)) eqn:?.
  unfold f in *.
  rewrite Heqb in H.
  congruence.

  unfold f in *.
  rewrite Heqb in H.
  congruence.

  (* the theorem is proven, but we provide an alternate proof that
  looks a bit nicer and uses the same intuition as above. *)
Restart.
  destruct 1.
  pose (f := fun x => negb (to x x)).
  assert (f (from f) = negb (to (from f) (from f))).
  unfold f.
  rewrite to_from.
  reflexivity.
  rewrite to_from in H.
  eapply Bool.no_fixpoint_negb; eauto.
Qed.

Corollary type_not_powerset : forall A,
  A <> (A -> bool).
Proof.
  intros.
  apply no_iso_ineq.
  apply powerset_bigger.
Qed.


Require Import UniMath.Foundations.All.

(** When proving a negation, we may undo a double negation. *)
Lemma wma_dneg {X:Type} (P:Type) : ¬¬ P -> (P -> ¬ X) -> ¬ X.
Proof.
  intros dnp p.
  apply dnegnegtoneg.
  assert (q := dnegf p); clear p.
  apply q; clear q.
  apply dnp.
Defined.

(** It's not false that a type is decidable. *)
Lemma dneg_decidable (P:Type) : ¬¬ decidable P.
Proof.
  intros ndec.
  unfold decidable in ndec.
  assert (q := fromnegcoprod ndec); clear ndec.
  contradicts (pr1 q) (pr2 q).
Defined.

(** When proving a negation, we may assume a type is decidable. *)
Lemma wma_decidable {X:Type} (P:Type) : (decidable P -> ¬ X) -> ¬ X.
Proof.
  apply (wma_dneg (decidable P)).
  apply dneg_decidable.
Defined.

Local Open Scope logic.

(** Compare with [negforall_to_existsneg], which uses LEM instead. *)
Lemma negforall_to_existsneg' {X:Type} (P:X->Type) : (¬ ∏ x, ¬¬ (P x)) -> ¬¬ (∃ x, ¬ (P x)).
Proof.
  intros nf c. use nf; clear nf. intro x.
  assert (q := neghexisttoforallneg _ c x); clear c; simpl in q.
  exact q.
Defined.


(* Exercise 5.7 *)
(* Here are five statements that are often considered as characterizations
   of classical logic. Prove that these five propositions are equivalent. *)

Definition peirce := forall P Q : Prop, ((P -> Q) -> P) -> P.
Definition classic := forall P : Prop, ~~P -> P.
Definition excluded_middle := forall P : Prop, P \/ ~P.
Definition de_morgan_not_and_not := forall P Q : Prop, ~(~P /\ ~Q) -> P \/ Q.
Definition implies_to_or := forall P Q : Prop, (P -> Q) -> (~P \/ Q).

Theorem excluded_middle_peirce_with_elim : excluded_middle -> peirce.
Proof.
  unfold excluded_middle, peirce.
  intros excluded_middle P Q H.
  elim (excluded_middle P).
  apply id.
  intro H0.
  apply H.
  intro p.
  apply False_ind.
  apply H0.
  assumption.
Qed.

Theorem excluded_middle_peirce_with_exact : excluded_middle -> peirce.
Proof.
  unfold excluded_middle, peirce.
  intros excluded_middle P Q H.
  exact (or_ind (* (P:=P) *)
                (fun p => p)
                (fun H0 => (H (fun p => False_ind Q (H0 p))))
                (excluded_middle P)).
Qed.

Theorem excluded_middle_peirce : excluded_middle -> peirce.
Proof.
  unfold excluded_middle, peirce.
  intros excluded_middle P Q H.
  cut (~P -> P).
  intro H0.
  apply (or_ind (fun p => p) H0).
  apply excluded_middle.
  intro H1.
  apply H.
  intro p.
  apply False_ind.
  apply H1.
  assumption.
Qed.

Theorem peirce_implies_classic : peirce -> classic.
Proof.
  unfold peirce, classic.
  intros peirce P H.
  apply (peirce P False).
  intro H0.
  apply False_ind.
  apply H.
  intro p.
  apply H0.
  assumption.
Qed.

Theorem classic_implies_excluded_middle : classic -> excluded_middle.
Proof.
  unfold classic, excluded_middle.
  intros classic P.
  apply classic.
  intro H.
  apply H.
  right.
  intro p.
  apply H.
  left.
  assumption.
Qed.

Theorem excluded_middle_implies_to_or_with_exact :  excluded_middle -> implies_to_or.
Proof.
  unfold excluded_middle, implies_to_or.
  intros excluded_middle P Q H.
  exact (or_ind (fun p : P => or_intror (H p))
                (fun H0 : ~P => or_introl H0)
        (excluded_middle P)).
Qed.

Theorem excluded_middle_implies_to_or_with_elim :  excluded_middle -> implies_to_or.
Proof.
  unfold excluded_middle, implies_to_or.
  intros excluded_middle P Q H.
  elim (excluded_middle P).
  intro p.
  right.
  apply H.
  assumption.
  intro H0.
  left.
  assumption.
Qed.

Theorem excluded_middle_implies_to_or :  excluded_middle -> implies_to_or.
Proof.
  unfold excluded_middle, implies_to_or.
  intros excluded_middle P Q H.
  cut (P -> ~P \/ Q).
  intro H0.
  cut (~P -> ~P \/ Q).
  intro H1.
  apply (or_ind H0 H1).
  apply excluded_middle.
  apply or_introl.
  intro p.
  apply or_intror.
  apply H.
  assumption.
Qed.

Theorem implies_to_or_excluded_middle : implies_to_or -> excluded_middle.
Proof.
  unfold implies_to_or, excluded_middle.
  intros implies_to_or P.
  apply or_comm.
  apply (implies_to_or P P).
  apply id.
Qed.

Theorem implies_to_or_excluded_middle_with_exact : implies_to_or -> excluded_middle.
Proof.
  unfold implies_to_or, excluded_middle.
  intros implies_to_or P.
  exact (match (implies_to_or P P (fun p : P => p)) with
         | or_introl H => or_intror H
         | or_intror H => or_introl H
        end).
Qed.

Theorem implies_to_or_excluded_middle_with_elim : implies_to_or -> excluded_middle.
Proof.
  unfold implies_to_or, excluded_middle.
  intros implies_to_or P.
  elim (implies_to_or P P).
  intro H.
  apply or_intror.
  assumption.
  intro p.
  apply or_introl.
  assumption.
  apply id.
Qed.

Theorem classic_de_morgan_not_and_not : classic -> de_morgan_not_and_not.
  unfold classic, de_morgan_not_and_not.
  intros classic P Q H.
  apply classic.
  intro H0.
  apply H.
  apply conj.
  intro p.
  apply H0.
  apply or_introl.
  assumption.
  intro q.
  apply H0.
  apply or_intror.
  assumption.
Qed.

Theorem de_morgan_not_and_not_excluded_middle : de_morgan_not_and_not -> excluded_middle.
Proof.
  unfold de_morgan_not_and_not, excluded_middle.
  intros de_morgan_not_and_not P.
  apply de_morgan_not_and_not.
  intro H.
  apply H.
  intro p.
  apply proj1 in H.
  apply H.
  assumption.
Qed.

Theorem de_morgan_not_and_not_excluded_middle_with_assert : de_morgan_not_and_not -> excluded_middle.
Proof.
  unfold de_morgan_not_and_not, excluded_middle.
  intros de_morgan_not_and_not P.
  apply de_morgan_not_and_not.
  intro H.
  apply H.
  intro p.
  assert (H0 : ~P).
  apply H.
  apply H0.
  assumption.
Qed.


Require Import init.

Require Export mult_ring.
Require Import relation.

Definition divides {U} `{Mult U} a b := ∃ c, c * a = b.
(** Note that this is the unicode symbol '∣', not '|'!  It is the LaTeX \mid.
The reason for this is that using the normal '|' causes issues with things like
pattern matching.
*)
Infix "∣" := divides (at level 50).

Definition unit {U} `{Mult U, One U} a := a ∣ 1.
Definition associates {U} `{Mult U} a b := a ∣ b ∧ b ∣ a.
Definition irreducible {U} `{Zero U, Mult U, One U} p
    := 0 ≠ p ∧ ¬unit p ∧ ∀ a b, ¬unit a → ¬unit b → p ≠ a * b.
Definition prime {U} `{Zero U, Mult U, One U} p
    := 0 ≠ p ∧ ¬unit p ∧ ∀ a b, p ∣ (a * b) → p ∣ a ∨ p ∣ b.

Definition even {U} `{Plus U, Mult U, One U} a := 2 ∣ a.
Definition odd {U} `{Plus U, Mult U, One U} a := ¬(2 ∣ a).

(* begin hide *)
Section Div.

Context {U} `{Up : Plus U,
                  @PlusAssoc U Up,
                  @PlusComm U Up,
              Uz : Zero U,
                  @PlusLid U Up Uz,
              Un : Neg U,
                  @PlusLinv U Up Uz Un,
              Um : Mult U,
                  @MultAssoc U Um,
                  @MultComm U Um,
                  @Ldist U Up Um,
                  @Rdist U Up Um,
                  @MultLanni U Uz Um,
                  @MultRanni U Uz Um,
              Uo : One U,
                  @MultLid U Um Uo,
                  @MultRid U Um Uo,
                  @MultLcancel U Uz Um,
                  @MultRcancel U Uz Um,
              Ul : Order U,
                  @Connex U le,
                  @Antisymmetric U le,
                  @Transitive U le
              }.

Lemma divides_refl : ∀ a, a ∣ a.
Proof.
    intros a.
    exists 1.
    apply mult_lid.
Qed.
(* end hide *)
Global Instance divides_refl_class : Reflexive divides := {
    refl := divides_refl
}.

(* begin hide *)
Lemma divides_trans : ∀ a b c, a ∣ b → b ∣ c → a ∣ c.
Proof.
    intros a b c [d eq1] [e eq2].
    exists (e * d).
    rewrite <- mult_assoc.
    rewrite eq1.
    rewrite eq2.
    reflexivity.
Qed.
(* end hide *)
Global Instance divides_trans_class : Transitive divides := {
    trans := divides_trans
}.

Theorem one_divides : ∀ n, 1 ∣ n.
Proof.
    intros n.
    exists n.
    apply mult_rid.
Qed.

Theorem divides_zero : ∀ a, a ∣ 0.
Proof.
    intros a.
    exists 0.
    apply mult_lanni.
Qed.

Theorem divides_neg : ∀ a b, a ∣ b → a ∣ -b.
Proof.
    intros a b [c eq].
    exists (-c).
    rewrite mult_lneg.
    apply f_equal.
    exact eq.
Qed.

Theorem plus_stays_divides : ∀ p a b, p ∣ a → p ∣ b → p ∣ (a + b).
Proof.
    intros p a b [c c_eq] [d d_eq].
    exists (c + d).
    rewrite <- c_eq, <- d_eq.
    apply rdist.
Qed.

Theorem plus_changes_divides : ∀ p a b,
                               p ∣ a → ¬(p ∣ b) → ¬(p ∣ (a + b)).
Proof.
    intros p a b [c c_eq] not [d d_eq].
    rewrite <- c_eq in d_eq.
    apply lplus with (-(c * p)) in d_eq.
    rewrite plus_assoc, plus_linv, plus_lid in d_eq.
    rewrite <- mult_lneg in d_eq.
    rewrite <- rdist in d_eq.
    unfold divides in not.
    rewrite not_ex in not.
    specialize (not (-c + d)).
    contradiction.
Qed.

Theorem mult_factors_extend : ∀ p a b, p ∣ a → p ∣ a * b.
Proof.
    intros p a b [c eq].
    exists (b * c).
    rewrite (mult_comm a).
    rewrite <- eq.
    symmetry; apply mult_assoc.
Qed.

Theorem mult_factors_back : ∀ a b c, a * b = c → a ∣ c ∧ b ∣ c.
Proof.
    intros a b c eq.
    split.
    -   exists b.
        rewrite mult_comm.
        exact eq.
    -   exists a.
        exact eq.
Qed.

Theorem mult_div_lself : ∀ a b, a ∣ a * b.
Proof.
    intros a b.
    exists b.
    apply mult_comm.
Qed.

Theorem mult_div_rself : ∀ a b, a ∣ b * a.
Proof.
    intros a b.
    exists b.
    reflexivity.
Qed.

Theorem div_rcancel : ∀ a b c, 0 ≠ c → a * c ∣ b * c → a ∣ b.
Proof.
    intros a b c c_nz [x eq].
    exists x.
    rewrite mult_assoc in eq.
    apply mult_rcancel in eq; [>|exact c_nz].
    exact eq.
Qed.

Theorem div_lcancel : ∀ a b c, 0 ≠ a → a * b ∣ a * c → b ∣ c.
Proof.
    intros a b c a_nz.
    do 2 rewrite (mult_comm a).
    apply div_rcancel.
    exact a_nz.
Qed.

Theorem unit_mult : ∀ a b, unit a → unit b → unit (a * b).
Proof.
    intros a b [a' a_eq] [b' b_eq].
    exists (b' * a').
    rewrite <- mult_assoc.
    rewrite (mult_assoc a').
    rewrite a_eq.
    rewrite mult_lid.
    apply b_eq.
Qed.

Theorem div_mult_unit : ∀ a b, 0 ≠ a → a * b ∣ a → unit b.
Proof.
    intros a b a_nz eq.
    destruct eq as [c eq].
    exists c.
    rewrite (mult_comm a b) in eq.
    rewrite mult_assoc in eq.
    rewrite <- (mult_lid a) in eq at 2.
    apply mult_rcancel in eq; [>|exact a_nz].
    exact eq.
Qed.

Theorem prime_irreducible : ∀ p, prime p → irreducible p.
Proof.
    intros p [p_nz [p_nu p_prime]].
    repeat split; [>exact p_nz|exact p_nu|].
    intros a b a_nu b_nu.
    intros contr.
    subst p.
    assert (0 ≠ a) as a_nz.
    {
        intros contr.
        subst a.
        rewrite mult_lanni in p_nz.
        contradiction.
    }
    assert (0 ≠ b) as b_nz.
    {
        intros contr.
        subst b.
        rewrite mult_ranni in p_nz.
        contradiction.
    }
    specialize (p_prime a b (refl (a * b))) as [d1|d2].
    -   apply div_mult_unit in d1; [>|exact a_nz].
        contradiction.
    -   rewrite mult_comm in d2.
        apply div_mult_unit in d2; [>|exact b_nz].
        contradiction.
Qed.

Theorem associates_refl : ∀ a, associates a a.
Proof.
    intros a.
    split.
    all: exists 1.
    all: apply mult_lid.
Qed.

Theorem associates_sym : ∀ a b, associates a b → associates b a.
Proof.
    intros a b [ab ba].
    split; assumption.
Qed.

Theorem associates_trans :
    ∀ a b c, associates a b → associates b c → associates a c.
Proof.
    intros a b c [ab ba] [bc cb].
    split.
    -   exact (divides_trans _ _ _ ab bc).
    -   exact (divides_trans _ _ _ cb ba).
Qed.

(* begin hide *)
End Div.
(* end hide *)