(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq path div choice.
Require Import fintype tuple finfun bigop prime ssralg finalg zmodp poly.
Require Import ssrnum ssrint rat polydiv intdiv algC matrix mxalgebra mxpoly.
Require Import vector falgebra fieldext separable galois cyclotomic.

(******************************************************************************)
(* This file provides a few basic results and constructions in algebraic      *)
(* number theory, that are used in the character theory library. Most of      *)
(* these could be generalized to a more abstract setting. Note that the type  *)
(* of abstract number fields is simply extFieldType rat. We define here:      *)
(*  x \in Crat_span X <=> x is a Q-linear combination of elements of          *)
(*                        X : seq algC.                                       *)
(*  x \in Cint_span X <=> x is a Z-linear combination of elements of          *)
(*                        X : seq algC.                                       *)
(*         x \in Aint <=> x : algC is an algebraic integer, i.e., the (monic) *)
(*                        polynomial of x over Q has integer coeficients.     *)
(*         (e %| a)%A <=> e divides a with respect to algebraic integers,     *)
(*        (e %| a)%Ax     i.e., a is in the algebraic integer ideal generated *)
(*                        by e. This is is notation for a \in dvdA e, where   *)
(*                        dvdv is the (collective) predicate for the Aint     *)
(*                        ideal generated by e. As in the (e %| a)%C notation *)
(*                        e and a can be coerced to algC from nat or int.     *)
(*                        The (e %| a)%Ax display form is a workaround for    *)
(*                        design limitations of the Coq Notation facilities.  *)
(* (a == b %[mod e])%A, (a != b %[mod e])%A <=>                               *)
(*                       a is equal (resp. not equal) to b mod e, i.e., a and *)
(*                       b belong to the same e * Aint class. We do not       *)
(*                       force a, b and e to be algebraic integers.           *)
(*            #[x]%C == the multiplicative order of x, i.e., the n such that  *)
(*                      x is an nth primitive root of unity, or 0 if x is not *)
(*                      a root of unity.                                      *)
(* In addition several lemmas prove the (constructive) existence of number    *)
(* fields and of automorphisms of algC.                                       *)
(******************************************************************************)

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

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

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

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

Local Hint Resolve (@intr_inj _ : injective ZtoC).
Local Notation QtoCm := [rmorphism of QtoC].

(* Number fields and rational spans. *)
Lemma algC_PET (s : seq algC) :
  {z | exists a : nat ^ size s, z = \sum_(i < size s) s`_i *+ a i
     & exists ps, s = [seq (pQtoC p).[z] | p <- ps]}.
Proof.
elim: s => [|x s [z /sig_eqW[a Dz] /sig_eqW[ps Ds]]].
  by exists 0; [exists [ffun _ => 2]; rewrite big_ord0 | exists nil].
have r_exists (y : algC): {r | r != 0 & root (pQtoC r) y}.
  have [r [_ mon_r] dv_r] := minCpolyP y.
  by exists r; rewrite ?monic_neq0 ?dv_r.
suffices /sig_eqW[[n [|px [|pz []]]]// [Dpx Dpz]]:
  exists np, let zn := x *+ np.1 + z in
    [:: x; z] = [seq (pQtoC p).[zn] | p <- np.2].
- exists (x *+ n + z).
    exists [ffun i => oapp a n (unlift ord0 i)].
    rewrite /= big_ord_recl ffunE unlift_none Dz; congr (_ + _).
    by apply: eq_bigr => i _; rewrite ffunE liftK.
  exists (px :: [seq p \Po pz | p <- ps]); rewrite /= -Dpx; congr (_ :: _).
  rewrite -map_comp Ds; apply: eq_map => p /=.
  by rewrite map_comp_poly horner_comp -Dpz.
have [rx nz_rx rx0] := r_exists x.
have [rz nz_rz rz0] := r_exists (- z).
have char0_Q: [char rat] =i pred0 by apply: char_num.
have [n [[pz Dpz] [px Dpx]]] := char0_PET nz_rz rz0 nz_rx rx0 char0_Q.
by exists (n, [:: px; - pz]); rewrite /= !raddfN hornerN -[z]opprK Dpz Dpx.
Qed.

Canonical subfx_unitAlgType (F L : fieldType) iota (z : L) p :=
  Eval hnf in [unitAlgType F of subFExtend iota z p].

Lemma num_field_exists (s : seq algC) :
  {Qs : fieldExtType rat & {QsC : {rmorphism Qs -> algC}
   & {s1 : seq Qs | map QsC s1 = s & <<1 & s1>>%VS = fullv}}}.
Proof.
have [z /sig_eqW[a Dz] /sig_eqW[ps Ds]] := algC_PET s.
suffices [Qs [QsC [z1 z1C z1gen]]]:
  {Qs : fieldExtType rat & {QsC : {rmorphism Qs -> algC} &
     {z1 : Qs | QsC z1 = z & forall xx, exists p, fieldExt_horner z1 p = xx}}}.
- set inQs := fieldExt_horner z1 in z1gen *; pose s1 := map inQs ps.
  have inQsK p: QsC (inQs p) = (pQtoC p).[z].
    rewrite /= -horner_map z1C -map_poly_comp; congr _.[z].
    apply: eq_map_poly => b /=; apply: canRL (mulfK _) _.
      by rewrite intr_eq0 denq_eq0.
    rewrite /= mulrzr -rmorphMz scalerMzl -{1}[b]divq_num_den -mulrzr.
    by rewrite divfK ?intr_eq0 ?denq_eq0 // scaler_int rmorph_int.
  exists Qs, QsC, s1; first by rewrite -map_comp Ds (eq_map inQsK).
  have sz_ps: size ps = size s by rewrite Ds size_map.
  apply/vspaceP=> x; rewrite memvf; have [p {x}<-] := z1gen x.
  elim/poly_ind: p => [|p b ApQs]; first by rewrite /inQs rmorph0 mem0v.
  rewrite /inQs rmorphD rmorphM /= fieldExt_hornerX fieldExt_hornerC -/inQs /=.
  suffices ->: z1 = \sum_(i < size s) s1`_i *+ a i.
    rewrite memvD ?memvZ ?mem1v ?memvM ?memv_suml // => i _.
    by rewrite rpredMn ?seqv_sub_adjoin ?mem_nth // size_map sz_ps.
  apply: (fmorph_inj QsC); rewrite z1C Dz rmorph_sum; apply: eq_bigr => i _.
  by rewrite rmorphMn {1}Ds !(nth_map 0) ?sz_ps //= inQsK.
have [r [Dr /monic_neq0 nz_r] dv_r] := minCpolyP z.
have rz0: root (pQtoC r) z by rewrite dv_r.
have irr_r: irreducible_poly r.
  by apply/(subfx_irreducibleP rz0 nz_r)=> q qz0 nzq; rewrite dvdp_leq // -dv_r.
exists (SubFieldExtType rz0 irr_r), (subfx_inj_rmorphism QtoCm z r).
exists (subfx_root _ z r) => [|x]; first exact: subfx_inj_root.
by have{x} [p ->] := subfxEroot rz0 nz_r x; exists p.
Qed.

Definition in_Crat_span s x :=
  exists a : rat ^ size s, x = \sum_i QtoC (a i) * s`_i.

Fact Crat_span_subproof s x : decidable (in_Crat_span s x).
Proof.
have [Qxs [QxsC [[|x1 s1] // [<- <-] {x s} _]]] := num_field_exists (x :: s).
have QxsC_Z a zz: QxsC (a *: zz) = QtoC a * QxsC zz.
  rewrite mulrAC; apply: (canRL (mulfK _)); first by rewrite intr_eq0 denq_eq0.
  by rewrite mulrzr mulrzl -!rmorphMz scalerMzl -mulrzr -numqE scaler_int.
apply: decP (x1 \in <<in_tuple s1>>%VS) _; rewrite /in_Crat_span size_map.
apply: (iffP idP) => [/coord_span-> | [a Dx]].
  move: (coord _) => a; exists [ffun i => a i x1]; rewrite rmorph_sum.
  by apply: eq_bigr => i _; rewrite ffunE (nth_map 0).
have{Dx} ->: x1 = \sum_i a i *: s1`_i.
  apply: (fmorph_inj QxsC); rewrite Dx rmorph_sum.
  by apply: eq_bigr => i _; rewrite QxsC_Z (nth_map 0).
by apply: memv_suml => i _; rewrite memvZ ?memv_span ?mem_nth.
Qed.

Definition Crat_span s : pred algC := Crat_span_subproof s.
Lemma Crat_spanP s x : reflect (in_Crat_span s x) (x \in Crat_span s).
Proof. exact: sumboolP. Qed.
Fact Crat_span_key s : pred_key (Crat_span s). Proof. by []. Qed.
Canonical Crat_span_keyed s := KeyedPred (Crat_span_key s).

Lemma mem_Crat_span s : {subset s <= Crat_span s}.
Proof.
move=> _ /(nthP 0)[ix ltxs <-]; pose i0 := Ordinal ltxs.
apply/Crat_spanP; exists [ffun i => (i == i0)%:R].
rewrite (bigD1 i0) //= ffunE eqxx // rmorph1 mul1r.
by rewrite big1 ?addr0 // => i; rewrite ffunE rmorph_nat mulr_natl => /negbTE->.
Qed.

Fact Crat_span_zmod_closed s : zmod_closed (Crat_span s).
Proof.
split=> [|_ _ /Crat_spanP[x ->] /Crat_spanP[y ->]].
  apply/Crat_spanP; exists 0.
  by apply/esym/big1=> i _; rewrite ffunE rmorph0 mul0r.
apply/Crat_spanP; exists (x - y); rewrite -sumrB; apply: eq_bigr => i _.
by rewrite -mulrBl -rmorphB !ffunE.
Qed.
Canonical Crat_span_opprPred s := OpprPred (Crat_span_zmod_closed s).
Canonical Crat_span_addrPred s := AddrPred (Crat_span_zmod_closed s).
Canonical Crat_span_zmodPred s := ZmodPred (Crat_span_zmod_closed s).

Section MoreAlgCaut.

Implicit Type rR : unitRingType.

Lemma alg_num_field (Qz : fieldExtType rat) a : a%:A = ratr a :> Qz.
Proof. by rewrite -in_algE fmorph_eq_rat. Qed.

Lemma rmorphZ_num (Qz : fieldExtType rat) rR (f : {rmorphism Qz -> rR}) a x :
  f (a *: x) = ratr a * f x.
Proof. by rewrite -mulr_algl rmorphM alg_num_field fmorph_rat. Qed.

Lemma fmorph_numZ (Qz1 Qz2 : fieldExtType rat) (f : {rmorphism Qz1 -> Qz2}) :
  scalable f.
Proof. by move=> a x; rewrite rmorphZ_num -alg_num_field mulr_algl. Qed.
Definition NumLRmorphism Qz1 Qz2 f := AddLRMorphism (@fmorph_numZ Qz1 Qz2 f).

End MoreAlgCaut.

Section NumFieldProj.

Variables (Qn : fieldExtType rat) (QnC : {rmorphism Qn -> algC}).

Lemma Crat_spanZ b a : {in Crat_span b, forall x, ratr a * x \in Crat_span b}.
Proof.
move=> _ /Crat_spanP[a1 ->]; apply/Crat_spanP; exists [ffun i => a * a1 i].
by rewrite mulr_sumr; apply: eq_bigr => i _; rewrite ffunE mulrA -rmorphM.
Qed.

Lemma Crat_spanM b : {in Crat & Crat_span b, forall a x, a * x \in Crat_span b}.
Proof. by move=> _ x /CratP[a ->]; apply: Crat_spanZ. Qed.

(* In principle CtoQn could be taken to be additive and Q-linear, but this    *)
(* would require a limit construction.                                        *)
Lemma num_field_proj : {CtoQn | CtoQn 0 = 0 & cancel QnC CtoQn}.
Proof.
pose b := vbasis {:Qn}.
have Qn_bC (u : {x | x \in Crat_span (map QnC b)}): {y | QnC y = sval u}.
  case: u => _ /= /Crat_spanP/sig_eqW[a ->].
  exists (\sum_i a i *: b`_i); rewrite rmorph_sum; apply: eq_bigr => i _.
  by rewrite rmorphZ_num (nth_map 0) // -(size_map QnC).
pose CtoQn x := oapp (fun u => sval (Qn_bC u)) 0 (insub x).
suffices QnCK: cancel QnC CtoQn by exists CtoQn; rewrite // -(rmorph0 QnC).
move=> x; rewrite /CtoQn insubT => /= [|Qn_x]; last first.
  by case: (Qn_bC _) => x1 /= /fmorph_inj.
rewrite (coord_vbasis (memvf x)) rmorph_sum rpred_sum // => i _.
rewrite rmorphZ_num Crat_spanZ ?mem_Crat_span // -/b.
by rewrite -tnth_nth -tnth_map mem_tnth.
Qed.

Lemma restrict_aut_to_num_field (nu : {rmorphism algC -> algC}) :
    (forall x, exists y, nu (QnC x) = QnC y) ->
  {nu0 : {lrmorphism Qn -> Qn} | {morph QnC : x / nu0 x >-> nu x}}.
Proof.
move=> Qn_nu; pose nu0 x := sval (sig_eqW (Qn_nu x)).
have QnC_nu0: {morph QnC : x / nu0 x >-> nu x}.
  by rewrite /nu0 => x; case: (sig_eqW _).
suffices nu0M: rmorphism nu0 by exists (NumLRmorphism (RMorphism nu0M)).
do 2?split=> [x y|]; apply: (fmorph_inj QnC); rewrite ?QnC_nu0 ?rmorph1 //.
  by rewrite ?(rmorphB, QnC_nu0).
by rewrite ?(rmorphM, QnC_nu0).
Qed.

Lemma map_Qnum_poly (nu : {rmorphism algC -> algC}) p :
  p \in polyOver 1%VS -> map_poly (nu \o QnC) p = (map_poly QnC p).
Proof.
move=> Qp; apply/polyP=> i; rewrite /= !coef_map /=.
have /vlineP[a ->]: p`_i \in 1%VS by apply: polyOverP.
by rewrite alg_num_field !fmorph_rat.
Qed.

End NumFieldProj.

Lemma restrict_aut_to_normal_num_field (Qn : splittingFieldType rat)
  (QnC : {rmorphism Qn -> algC})(nu : {rmorphism algC -> algC}) :
    {nu0 : {lrmorphism Qn -> Qn} | {morph QnC : x / nu0 x >-> nu x}}.
Proof.
apply: restrict_aut_to_num_field => x.
case: (splitting_field_normal 1%AS x) => rs /eqP Hrs.
have: root (map_poly (nu \o QnC) (minPoly 1%AS x)) (nu (QnC x)).
  by rewrite fmorph_root root_minPoly.
rewrite map_Qnum_poly ?minPolyOver // Hrs.
rewrite [map_poly _ _](_:_ = \prod_(y <- map QnC rs) ('X - y%:P)); last first.
  rewrite big_map rmorph_prod; apply eq_bigr => i _.
  by rewrite rmorphB /= map_polyX map_polyC.
rewrite root_prod_XsubC.
by case/mapP => y _ ?; exists y.
Qed.

(* Integral spans. *)

Lemma dec_Cint_span (V : vectType algC) m (s : m.-tuple V) v :
  decidable (inIntSpan s v).
Proof.
have s_s (i : 'I_m): s`_i \in <<s>>%VS by rewrite memv_span ?memt_nth.
have s_Zs a: \sum_(i < m) s`_i *~ a i \in <<s>>%VS.
  by rewrite memv_suml // => i _; rewrite -scaler_int memvZ.
case s_v: (v \in <<s>>%VS); last by right=> [[a Dv]]; rewrite Dv s_Zs in s_v.
pose IzT := {: 'I_m * 'I_(\dim <<s>>)}; pose Iz := 'I_#|IzT|.
pose b := vbasis <<s>>.
pose z_s := [seq coord b ij.2 (tnth s ij.1) | ij : IzT].
pose rank2 j i: Iz := enum_rank (i, j); pose val21 (p : Iz) := (enum_val p).1.
pose inQzs w := [forall j, Crat_span z_s (coord b j w)].
have enum_pairK j: {in predT, cancel (rank2 j) val21}.
  by move=> i; rewrite /val21 enum_rankK.
have Qz_Zs a: inQzs (\sum_(i < m) s`_i *~ a i).
  apply/forallP=> j; apply/Crat_spanP; rewrite /in_Crat_span size_map -cardE.
  exists [ffun ij => (a (val21 ij))%:Q *+ ((enum_val ij).2 == j)].
  rewrite linear_sum {1}(reindex_onto _ _ (enum_pairK j)).
  rewrite big_mkcond; apply: eq_bigr => ij _ /=; rewrite nth_image (tnth_nth 0).
  rewrite (can2_eq (@enum_rankK _) (@enum_valK _)) ffunE -scaler_int /val21.
  case Dij: (enum_val ij) => [i j1]; rewrite xpair_eqE eqxx /= eq_sym -mulrb.
  by rewrite linearZ rmorphMn rmorph_int mulrnAl; case: eqP => // ->.
case Qz_v: (inQzs v); last by right=> [[a Dv]]; rewrite Dv Qz_Zs in Qz_v.
have [Qz [QzC [z1s Dz_s _]]] := num_field_exists z_s.
have sz_z1s: size z1s = #|IzT| by rewrite -(size_map QzC) Dz_s size_map cardE.
have xv j: {x | coord b j v = QzC x}.
  apply: sig_eqW; have /Crat_spanP[x ->] := forallP Qz_v j.
  exists (\sum_ij x ij *: z1s`_ij); rewrite rmorph_sum.
  apply: eq_bigr => ij _; rewrite mulrAC.
  apply: canLR (mulfK _) _; first by rewrite intr_eq0 denq_neq0.
  rewrite mulrzr -rmorphMz scalerMzl -(mulrzr (x _)) -numqE scaler_int.
  by rewrite rmorphMz mulrzl -(nth_map _ 0) ?Dz_s // -(size_map QzC) Dz_s.
pose sz := [tuple [ffun j => z1s`_(rank2 j i)] | i < m].
have [Zsv | Zs'v] := dec_Qint_span sz [ffun j => sval (xv j)].
  left; have{Zsv} [a Dv] := Zsv; exists a.
  transitivity (\sum_j \sum_(i < m) QzC ((sz`_i *~ a i) j) *: b`_j).
    rewrite {1}(coord_vbasis s_v) -/b; apply: eq_bigr => j _.
    rewrite -scaler_suml; congr (_ *: _).
    have{Dv} /ffunP/(_ j) := Dv; rewrite sum_ffunE !ffunE -rmorph_sum => <-.
    by case: (xv j).
  rewrite exchange_big; apply: eq_bigr => i _.
  rewrite (coord_vbasis (s_s i)) -/b mulrz_suml; apply: eq_bigr => j _.
  rewrite scalerMzl ffunMzE rmorphMz; congr ((_ *~ _) *: _).
  rewrite nth_mktuple ffunE -(nth_map _ 0) ?sz_z1s // Dz_s.
  by rewrite nth_image enum_rankK /= (tnth_nth 0).
right=> [[a Dv]]; case: Zs'v; exists a.
apply/ffunP=> j; rewrite sum_ffunE !ffunE; apply: (fmorph_inj QzC).
case: (xv j) => /= _ <-; rewrite Dv linear_sum rmorph_sum.
apply: eq_bigr => i _; rewrite nth_mktuple raddfMz !ffunMzE rmorphMz ffunE.
by rewrite -(nth_map _ 0 QzC) ?sz_z1s // Dz_s nth_image enum_rankK -tnth_nth.
Qed.

Definition Cint_span (s : seq algC) : pred algC :=
  fun x => dec_Cint_span (in_tuple [seq \row_(i < 1) y | y <- s]) (\row_i x).
Fact Cint_span_key s : pred_key (Cint_span s). Proof. by []. Qed.
Canonical Cint_span_keyed s := KeyedPred (Cint_span_key s).

Lemma Cint_spanP n (s : n.-tuple algC) x :
  reflect (inIntSpan s x) (x \in Cint_span s).
Proof.
rewrite unfold_in; case: (dec_Cint_span _ _) => [Zs_x | Zs'x] /=.
  left; have{Zs_x} [] := Zs_x; rewrite /= size_map size_tuple => a /rowP/(_ 0).
  rewrite !mxE => ->; exists a; rewrite summxE; apply: eq_bigr => i _.
  by rewrite -scaler_int (nth_map 0) ?size_tuple // !mxE mulrzl.
right=> [[a Dx]]; have{Zs'x} [] := Zs'x.
rewrite /inIntSpan /= size_map size_tuple; exists a.
apply/rowP=> i0; rewrite !mxE summxE Dx; apply: eq_bigr => i _.
by rewrite -scaler_int mxE mulrzl (nth_map 0) ?size_tuple // !mxE.
Qed.

Lemma mem_Cint_span s : {subset s <= Cint_span s}.
Proof.
move=> _ /(nthP 0)[ix ltxs <-]; apply/(Cint_spanP (in_tuple s)).
exists [ffun i => i == Ordinal ltxs : int].
rewrite (bigD1 (Ordinal ltxs)) //= ffunE eqxx.
by rewrite big1 ?addr0 // => i; rewrite ffunE => /negbTE->.
Qed.

Lemma Cint_span_zmod_closed s : zmod_closed (Cint_span s).
Proof.
have sP := Cint_spanP (in_tuple s); split=> [|_ _ /sP[x ->] /sP[y ->]].
  by apply/sP; exists 0; rewrite big1 // => i; rewrite ffunE.
apply/sP; exists (x - y); rewrite -sumrB; apply: eq_bigr => i _.
by rewrite !ffunE raddfB.
Qed.
Canonical Cint_span_opprPred s := OpprPred (Cint_span_zmod_closed s).
Canonical Cint_span_addrPred s := AddrPred (Cint_span_zmod_closed s).
Canonical Cint_span_zmodPred s := ZmodPred (Cint_span_zmod_closed s).

(* Automorphism extensions. *)
Lemma extend_algC_subfield_aut (Qs : fieldExtType rat)
  (QsC : {rmorphism Qs -> algC}) (phi : {rmorphism Qs -> Qs}) :
  {nu : {rmorphism algC -> algC} | {morph QsC : x / phi x >-> nu x}}.
Proof.
pose numF_inj (Qr : fieldExtType rat) := {rmorphism Qr -> algC}.
pose subAut := {Qr : _ & numF_inj Qr * {lrmorphism Qr -> Qr}}%type.
pose SubAut := existS _ _ (_, _) : subAut.
pose Sdom (mu : subAut) := projS1 mu.
pose Sinj (mu : subAut) : {rmorphism Sdom mu -> algC} := (projS2 mu).1.
pose Saut (mu : subAut) : {rmorphism Sdom mu -> Sdom mu} := (projS2 mu).2.
have SinjZ Qr (QrC : numF_inj Qr) a x: QrC (a *: x) = QtoC a * QrC x.
  rewrite mulrAC; apply: canRL (mulfK _) _.
    by rewrite intr_eq0 denq_neq0.
  by rewrite mulrzr mulrzl -!rmorphMz scalerMzl -scaler_int -mulrzr -numqE.
have Sinj_poly Qr (QrC : numF_inj Qr) p:
  map_poly QrC (map_poly (in_alg Qr) p) = pQtoC p.
- rewrite -map_poly_comp; apply: eq_map_poly => a.
  by rewrite /= SinjZ rmorph1 mulr1.
have ext1 mu0 x: {mu1 | exists y, x = Sinj mu1 y
  & exists2 in01 : {lrmorphism _}, Sinj mu0 =1 Sinj mu1 \o in01
  & {morph in01: y / Saut mu0 y >-> Saut mu1 y}}.
- pose b0 := vbasis {:Sdom mu0}.
  have [z _ /sig_eqW[[|px ps] // [Dx Ds]]] := algC_PET (x :: map (Sinj mu0) b0).
  have [p [_ mon_p] /(_ p) pz0] := minCpolyP z; rewrite dvdpp in pz0.
  have [r Dr] := closed_field_poly_normal (pQtoC p : {poly algC}).
  rewrite lead_coef_map {mon_p}(monicP mon_p) rmorph1 scale1r in Dr.
  have{pz0} rz: z \in r by rewrite -root_prod_XsubC -Dr.
  have [Qr [QrC [rr Drr genQr]]] := num_field_exists r.
  have{rz} [zz Dz]: {zz | QrC zz = z}.
    by move: rz; rewrite -Drr => /mapP/sig2_eqW[zz]; exists zz.
  have{ps Ds} [in01 Din01]: {in01 : {lrmorphism _} | Sinj mu0 =1 QrC \o in01}.
    have in01P y: {yy | Sinj mu0 y = QrC yy}.
      exists (\sum_i coord b0 i y *: (map_poly (in_alg Qr) ps`_i).[zz]).
      rewrite {1}(coord_vbasis (memvf y)) !rmorph_sum; apply: eq_bigr => i _.
      rewrite !SinjZ; congr (_ * _); rewrite -(nth_map _ 0) ?size_tuple // Ds.
      rewrite -horner_map Dz Sinj_poly (nth_map 0) //.
      by have:= congr1 size Ds; rewrite !size_map size_tuple => <-.
    pose in01 y := sval (in01P y).
    have Din01 y: Sinj mu0 y = QrC (in01 y) by rewrite /in01; case: (in01P y).
    suffices in01M: lrmorphism in01 by exists (LRMorphism in01M).
    pose rwM := (=^~ Din01, SinjZ, rmorph1, rmorphB, rmorphM).
    by do 3?split; try move=> ? ?; apply: (fmorph_inj QrC); rewrite !rwM.
  have {z zz Dz px Dx} Dx: exists xx, x = QrC xx.
    exists (map_poly (in_alg Qr) px).[zz].
    by rewrite -horner_map Dz Sinj_poly Dx.
  pose lin01 := linfun in01; pose K := (lin01 @: fullv)%VS.
  have memK y: reflect (exists yy, y = in01 yy) (y \in K).
    apply: (iffP memv_imgP) => [[yy _ ->] | [yy ->]];
      by exists yy; rewrite ?lfunE ?memvf.
  have algK: is_aspace K.
    rewrite /is_aspace has_algid1; last first.
      by apply/memK; exists 1; rewrite rmorph1.
    apply/prodvP=> _ _ /memK[y1 ->] /memK[y2 ->].
    by apply/memK; exists (y1 * y2); rewrite rmorphM.
  have ker_in01: lker lin01 == 0%VS.
    by apply/lker0P=> y1 y2; rewrite !lfunE; apply: fmorph_inj.
  pose f := (lin01 \o linfun (Saut mu0) \o lin01^-1)%VF.
  have Df y: f (in01 y) = in01 (Saut mu0 y).
    transitivity (f (lin01 y)); first by rewrite !lfunE.
    by do 4!rewrite lfunE /=; rewrite lker0_lfunK.
  have hom_f: kHom 1 (ASpace algK) f.
    apply/kHomP; split=> [_ _ /memK[y1 ->] /memK[y2 ->] |_ /vlineP[a ->]].
      by rewrite -rmorphM !Df !rmorphM.
    by rewrite -(rmorph1 in01) -linearZ /= Df {1}linearZ /= rmorph1.
  pose pr := map_poly (in_alg Qr) p.
  have Qpr: pr \is a polyOver 1%VS.
    by apply/polyOverP=> i; rewrite coef_map memvZ ?memv_line.
  have splitQr: splittingFieldFor K pr fullv.
    apply: splittingFieldForS (sub1v (Sub K algK)) (subvf _) _; exists rr => //.
    congr (_ %= _): (eqpxx pr); apply: (@map_poly_inj _ _ QrC).
    rewrite Sinj_poly Dr -Drr big_map rmorph_prod; apply: eq_bigr => zz _.
    by rewrite rmorphB /= map_polyX map_polyC.
  have [f1 aut_f1 Df1]:= kHom_extends (sub1v (ASpace algK)) hom_f Qpr splitQr.
  pose nu := LRMorphism (kHom_lrmorphism aut_f1).
  exists (SubAut Qr QrC nu) => //; exists in01 => //= y.
  by rewrite -Df -Df1 //; apply/memK; exists y.
have phiZ: scalable phi.
  move=> a y; do 2!rewrite -mulr_algl -in_algE.
  by rewrite -[a]divq_num_den !(fmorph_div, rmorphM, rmorph_int).
pose fix ext n :=
  if n is i.+1 then oapp (fun x => s2val (ext1 (ext i) x)) (ext i) (unpickle i)
  else SubAut Qs QsC (AddLRMorphism phiZ).
have mem_ext x n: (pickle x < n)%N -> {xx | Sinj (ext n) xx = x}.
  move=> ltxn; apply: sig_eqW; elim: n ltxn => // n IHn.
  rewrite ltnS leq_eqVlt => /predU1P[<- | /IHn[xx <-]] /=.
    by rewrite pickleK /=; case: (ext1 _ x) => mu [xx]; exists xx.
  case: (unpickle n) => /= [y|]; last by exists xx.
  case: (ext1 _ y) => mu /= _ [in_mu inj_in_mu _].
  by exists (in_mu xx); rewrite inj_in_mu.
pose nu x := Sinj _ (Saut _ (sval (mem_ext x _ (ltnSn _)))).
have nu_inj n y: nu (Sinj (ext n) y) = Sinj (ext n) (Saut (ext n) y).
  rewrite /nu; case: (mem_ext _ _ _); move: _.+1 => n1 y1 Dy /=.
  without loss /subnK Dn1: n n1 y y1 Dy / (n <= n1)%N.
    by move=> IH; case/orP: (leq_total n n1) => /IH => [/(_ y) | /(_ y1)]->.
  elim: {n}(_ - n)%N {-1}n => [|k IHk] n in Dn1 y Dy *.
    by move: y1 Dy; rewrite -Dn1 => y1  /fmorph_inj ->.
  rewrite addSnnS in Dn1; move/IHk: Dn1 => /=.
  case: (unpickle _) => [z|] /=; last exact.
  case: (ext1 _ _) => mu /= _ [in_mu Dinj Daut].
  by rewrite Dy => /(_ _ (Dinj _))->; rewrite -Daut Dinj.
suffices nuM: rmorphism nu.
  by exists (RMorphism nuM) => x; rewrite /= (nu_inj 0%N).
pose le_nu (x : algC) n := (pickle x < n)%N.
have max3 x1 x2 x3: exists n, [/\ le_nu x1 n, le_nu x2 n & le_nu x3 n].
  exists (maxn (pickle x1) (maxn (pickle x2) (pickle x3))).+1.
  by apply/and3P; rewrite /le_nu !ltnS -!geq_max.
do 2?split; try move=> x1 x2.
- have [n] := max3 (x1 - x2) x1 x2.
  case=> /mem_ext[y Dx] /mem_ext[y1 Dx1] /mem_ext[y2 Dx2].
  rewrite -Dx nu_inj; rewrite -Dx1 -Dx2 -rmorphB in Dx.
  by rewrite (fmorph_inj _ Dx) !rmorphB -!nu_inj Dx1 Dx2.
- have [n] := max3 (x1 * x2) x1 x2.
  case=> /mem_ext[y Dx] /mem_ext[y1 Dx1] /mem_ext[y2 Dx2].
  rewrite -Dx nu_inj; rewrite -Dx1 -Dx2 -rmorphM in Dx.
  by rewrite (fmorph_inj _ Dx) !rmorphM -!nu_inj Dx1 Dx2.
by rewrite -(rmorph1 QsC) (nu_inj 0%N) !rmorph1.
Qed.

(* Extended automorphisms of Q_n. *)
Lemma Qn_aut_exists k n :
    coprime k n ->
  {u : {rmorphism algC -> algC} | forall z, z ^+ n = 1 -> u z = z ^+ k}.
Proof.
have [-> /eqnP | n_gt0 co_k_n] := posnP n.
  by rewrite gcdn0 => ->; exists [rmorphism of idfun].
have [z prim_z] := C_prim_root_exists n_gt0.
have [Qn [QnC [[|zn []] // [Dz]]] genQn] := num_field_exists [:: z].
pose phi := kHomExtend 1 \1 zn (zn ^+ k).
have homQn1: kHom 1 1 (\1%VF : 'End(Qn)) by rewrite kHom1.
have pzn_zk0: root (map_poly \1%VF (minPoly 1 zn)) (zn ^+ k).
  rewrite -(fmorph_root QnC) rmorphX Dz -map_poly_comp.
  rewrite (@eq_map_poly _ _ _ QnC) => [|a]; last by rewrite /= id_lfunE.
  set p1 := map_poly _ _.
  have [q1 Dp1]: exists q1, p1 = pQtoC q1.
    have aP i: (minPoly 1 zn)`_i \in 1%VS.
      by apply/polyOverP; apply: minPolyOver.
    have{aP} a_ i := sig_eqW (vlineP _ _ (aP i)).
    exists (\poly_(i < size (minPoly 1 zn)) sval (a_ i)).
    apply/polyP=> i; rewrite coef_poly coef_map coef_poly /=.
    case: ifP => _; rewrite ?rmorph0 //; case: (a_ i) => a /= ->.
    apply: canRL (mulfK _) _; first by rewrite intr_eq0 denq_eq0.
    by rewrite mulrzr -rmorphMz scalerMzl -mulrzr -numqE scaler_int rmorph_int.
  have: root p1 z by rewrite -Dz fmorph_root root_minPoly.
  rewrite Dp1; have [q2 [Dq2 _] ->] := minCpolyP z.
  case/dvdpP=> r1 ->; rewrite rmorphM rootM /= -Dq2; apply/orP; right.
  rewrite (minCpoly_cyclotomic prim_z) /cyclotomic.
  rewrite (bigD1 (Ordinal (ltn_pmod k n_gt0))) ?coprime_modl //=.
  by rewrite rootM root_XsubC prim_expr_mod ?eqxx.
have phiM: lrmorphism phi.
  by apply/kHom_lrmorphism; rewrite -genQn span_seq1 /= kHomExtendP.
have [nu Dnu] := extend_algC_subfield_aut QnC (RMorphism phiM).
exists nu => _ /(prim_rootP prim_z)[i ->].
rewrite rmorphX exprAC -Dz -Dnu /= -{1}[zn]hornerX /phi.
rewrite (kHomExtend_poly homQn1) ?polyOverX //.
rewrite map_polyE map_id_in => [|?]; last by rewrite id_lfunE.
by rewrite polyseqK hornerX rmorphX.
Qed.

(* Algebraic integers. *)

Definition Aint : pred_class :=
  fun x : algC => minCpoly x \is a polyOver Cint.
Fact Aint_key : pred_key Aint. Proof. by []. Qed.
Canonical Aint_keyed := KeyedPred Aint_key.

Lemma root_monic_Aint p x :
  root p x -> p \is monic -> p \is a polyOver Cint -> x \in Aint.
Proof.
have pZtoQtoC pz: pQtoC (pZtoQ pz) = pZtoC pz.
  by rewrite -map_poly_comp; apply: eq_map_poly => b; rewrite /= rmorph_int.
move=> px0 mon_p /floorCpP[pz Dp]; rewrite unfold_in.
move: px0; rewrite Dp -pZtoQtoC; have [q [-> mon_q] ->] := minCpolyP x.
case/dvdpP_rat_int=> qz [a nz_a Dq] [r].
move/(congr1 (fun q1 => lead_coef (a *: pZtoQ q1))).
rewrite rmorphM scalerAl -Dq lead_coefZ lead_coefM /=.
have /monicP->: pZtoQ pz \is monic by rewrite -(map_monic QtoCm) pZtoQtoC -Dp.
rewrite (monicP mon_q) mul1r mulr1 lead_coef_map_inj //; last exact: intr_inj.
rewrite Dq => ->; apply/polyOverP=> i; rewrite !(coefZ, coef_map).
by rewrite -rmorphM /= rmorph_int Cint_int.
Qed.

Lemma Cint_rat_Aint z : z \in Crat -> z \in Aint -> z \in Cint.
Proof.
case/CratP=> a ->{z} /polyOverP/(_ 0%N).
have [p [Dp mon_p] dv_p] := minCpolyP (ratr a); rewrite Dp coef_map.
suffices /eqP->: p == 'X - a%:P by rewrite polyseqXsubC /= rmorphN rpredN.
rewrite -eqp_monic ?monicXsubC // irredp_XsubC //.
  by rewrite -(size_map_poly QtoCm) -Dp neq_ltn size_minCpoly orbT.
by rewrite -dv_p fmorph_root root_XsubC.
Qed.

Lemma Aint_Cint : {subset Cint <= Aint}.
Proof.
move=> x; rewrite -polyOverXsubC.
by apply: root_monic_Aint; rewrite ?monicXsubC ?root_XsubC.
Qed.

Lemma Aint_int x : x%:~R \in Aint.
Proof. by rewrite Aint_Cint ?Cint_int. Qed.

Lemma Aint0 : 0 \in Aint. Proof. exact: (Aint_int 0). Qed.
Lemma Aint1 : 1 \in Aint. Proof. exact: (Aint_int 1). Qed.
Hint Resolve Aint0 Aint1.

Lemma Aint_unity_root n x : (n > 0)%N -> n.-unity_root x -> x \in Aint.
Proof.
move=> n_gt0 xn1; apply: root_monic_Aint xn1 (monic_Xn_sub_1 _ n_gt0) _.
by apply/polyOverP=> i; rewrite coefB coefC -mulrb coefXn /= rpredB ?rpred_nat.
Qed.

Lemma Aint_prim_root n z : n.-primitive_root z -> z \in Aint.
Proof.
move=> pr_z; apply/(Aint_unity_root (prim_order_gt0 pr_z))/unity_rootP.
exact: prim_expr_order.
Qed.

Lemma Aint_Cnat : {subset Cnat <= Aint}.
Proof. by move=> z /Cint_Cnat/Aint_Cint. Qed.

(* This is Isaacs, Lemma (3.3) *)
Lemma Aint_subring_exists (X : seq algC) :
    {subset X <= Aint} ->
  {S : pred algC &
     (*a*) subring_closed S
  /\ (*b*) {subset X <= S}
   & (*c*) {Y : {n : nat & n.-tuple algC} &
                {subset tagged Y <= S}
              & forall x, reflect (inIntSpan (tagged Y) x) (x \in S)}}.
Proof.
move=> AZ_X; pose m := (size X).+1.
pose n (i : 'I_m) := (size (minCpoly X`_i)).-2; pose N := (\max_i n i).+1.
pose IY := family (fun i => [pred e : 'I_N | e <= n i]%N).
have IY_0: 0 \in IY by apply/familyP=> // i; rewrite ffunE.
pose inIY := enum_rank_in IY_0.
pose Y := [seq \prod_(i < m) X`_i ^+ (f : 'I_N ^ m) i | f in IY].
have S_P := Cint_spanP [tuple of Y]; set S := Cint_span _ in S_P.
have sYS: {subset Y <= S} by apply: mem_Cint_span.
have S_1: 1 \in S.
  by apply/sYS/imageP; exists 0 => //; rewrite big1 // => i; rewrite ffunE.
have SmulX (i : 'I_m): {in S, forall x, x * X`_i \in S}.
  move=> _ /S_P[x ->]; rewrite mulr_suml rpred_sum // => j _.
  rewrite mulrzAl rpredMz {x}// nth_image mulrC (bigD1 i) //= mulrA -exprS.
  move: {j}(enum_val j) (familyP (enum_valP j)) => f fP.
  have:= fP i; rewrite inE /= leq_eqVlt => /predU1P[-> | fi_ltn]; last first.
    apply/sYS/imageP; have fiK: (inord (f i).+1 : 'I_N) = (f i).+1 :> nat.
      by rewrite inordK // ltnS (bigmax_sup i).
    exists (finfun [eta f with i |-> inord (f i).+1]).
      apply/familyP=> i1; rewrite inE ffunE /= fun_if fiK.
      by case: eqP => [-> // | _]; apply: fP.
    rewrite (bigD1 i isT) ffunE /= eqxx fiK; congr (_ * _).
    by apply: eq_bigr => i1; rewrite ffunE /= => /negPf->.
  have [/monicP ] := (minCpoly_monic X`_i, root_minCpoly X`_i).
  rewrite /root horner_coef lead_coefE -(subnKC (size_minCpoly _)) subn2.
  rewrite big_ord_recr /= addrC addr_eq0 => ->; rewrite mul1r => /eqP->.
  have /floorCpP[p Dp]: X`_i \in Aint.
    by have [/(nth_default 0)-> | /(mem_nth 0)/AZ_X] := leqP (size X) i.
  rewrite -/(n i) Dp mulNr rpredN // mulr_suml rpred_sum // => [[e le_e]] /= _.
  rewrite coef_map -mulrA mulrzl rpredMz ?sYS //; apply/imageP.
  have eK: (inord e : 'I_N) = e :> nat by rewrite inordK // ltnS (bigmax_sup i).
  exists (finfun [eta f with i |-> inord e]).
    apply/familyP=> i1; rewrite inE ffunE /= fun_if eK.
    by case: eqP => [-> // | _]; apply: fP.
  rewrite (bigD1 i isT) ffunE /= eqxx eK; congr (_ * _).
  by apply: eq_bigr => i1; rewrite ffunE /= => /negPf->.
exists S; last by exists (Tagged (fun n => n.-tuple _) [tuple of Y]).
split=> [|x Xx]; last first.
  by rewrite -[x]mul1r -(nth_index 0 Xx) (SmulX (Ordinal _)) // ltnS index_size.
split=> // x y Sx Sy; first by rewrite rpredB.
case/S_P: Sy => {y}[y ->]; rewrite mulr_sumr rpred_sum //= => j.
rewrite mulrzAr rpredMz {y}// nth_image; move: {j}(enum_val j) => f.
elim/big_rec: _ => [|i y _ IHy] in x Sx *; first by rewrite mulr1.
rewrite mulrA {y}IHy //.
elim: {f}(f i : nat) => [|e IHe] in x Sx *; first by rewrite mulr1.
by rewrite exprS mulrA IHe // SmulX.
Qed.

Section AlgIntSubring.

Import DefaultKeying GRing.DefaultPred perm.

(* This is Isaacs, Theorem (3.4). *)
Theorem fin_Csubring_Aint S n (Y : n.-tuple algC) :
     mulr_closed S -> (forall x, reflect (inIntSpan Y x) (x \in S)) ->
  {subset S <= Aint}.
Proof.
have ZP_C c: (ZtoC c)%:P \is a polyOver Cint by rewrite raddfMz rpred_int.
move=> mulS S_P x Sx; pose v := \row_(i < n) Y`_i.
have [v0 | nz_v] := eqVneq v 0.
  case/S_P: Sx => {x}x ->; rewrite big1 ?isAlgInt0 // => i _.
  by have /rowP/(_ i) := v0; rewrite !mxE => ->; rewrite mul0rz.
have sYS (i : 'I_n): x * Y`_i \in S.
  by rewrite rpredM //; apply/S_P/Cint_spanP/mem_Cint_span/memt_nth.
pose A := \matrix_(i, j < n) sval (sig_eqW (S_P _ (sYS j))) i.
pose p := char_poly (map_mx ZtoC A).
have: p \is a polyOver Cint.
  rewrite rpred_sum // => s _; rewrite rpredMsign rpred_prod // => j _.
  by rewrite !mxE /= rpredB ?rpredMn ?polyOverX.
apply: root_monic_Aint (char_poly_monic _).
rewrite -eigenvalue_root_char; apply/eigenvalueP; exists v => //.
apply/rowP=> j; case dAj: (sig_eqW (S_P _ (sYS j))) => [a DxY].
by rewrite !mxE DxY; apply: eq_bigr => i _; rewrite !mxE dAj /= mulrzr.
Qed.

(* This is Isaacs, Corollary (3.5). *)
Corollary Aint_subring : subring_closed Aint.
Proof.
suff rAZ: {in Aint &, forall x y, (x - y \in Aint) * (x * y \in Aint)}.
  by split=> // x y AZx AZy; rewrite rAZ.
move=> x y AZx AZy.
have [|S [ringS] ] := @Aint_subring_exists [:: x; y]; first exact/allP/and3P.
move=> /allP/and3P[Sx Sy _] [Y _ genYS].
have AZ_S := fin_Csubring_Aint ringS genYS.
by have [_ S_B S_M] := ringS; rewrite !AZ_S ?S_B ?S_M.
Qed.
Canonical Aint_opprPred := OpprPred Aint_subring.
Canonical Aint_addrPred := AddrPred Aint_subring.
Canonical Aint_mulrPred := MulrPred Aint_subring.
Canonical Aint_zmodPred := ZmodPred Aint_subring.
Canonical Aint_semiringPred := SemiringPred Aint_subring.
Canonical Aint_smulrPred := SmulrPred Aint_subring.
Canonical Aint_subringPred := SubringPred Aint_subring.

End AlgIntSubring.

Lemma Aint_aut (nu : {rmorphism algC -> algC}) x :
  (nu x \in Aint) = (x \in Aint).
Proof. by rewrite !unfold_in minCpoly_aut. Qed.

Definition dvdA (e : Algebraics.divisor) : pred_class :=
  fun z : algC => if e == 0 then z == 0 else z / e \in Aint.
Fact dvdA_key e : pred_key (dvdA e). Proof. by []. Qed.
Canonical dvdA_keyed e := KeyedPred (dvdA_key e).
Delimit Scope algC_scope with A.
Delimit Scope algC_expanded_scope with Ax.
Notation "e %| x" := (x \in dvdA e) : algC_expanded_scope.
Notation "e %| x" := (@in_mem Algebraics.divisor x (mem (dvdA e))) : algC_scope.

Fact dvdA_zmod_closed e : zmod_closed (dvdA e).
Proof.
split=> [|x y]; first by rewrite unfold_in mul0r eqxx rpred0 ?if_same.
rewrite ![(e %| _)%A]unfold_in.
case: ifP => [_ x0 /eqP-> | _]; first by rewrite subr0.
by rewrite mulrBl; apply: rpredB.
Qed.
Canonical dvdA_opprPred e := OpprPred (dvdA_zmod_closed e).
Canonical dvdA_addrPred e := AddrPred (dvdA_zmod_closed e).
Canonical dvdA_zmodPred e := ZmodPred (dvdA_zmod_closed e).

Definition eqAmod (e x y : Algebraics.divisor) := (e %| x - y)%A.
Notation "x == y %[mod e ]" := (eqAmod e x y) : algC_scope.
Notation "x != y %[mod e ]" := (~~ (eqAmod e x y)) : algC_scope.

Lemma eqAmod_refl e x : (x == x %[mod e])%A.
Proof. by rewrite /eqAmod subrr rpred0. Qed.
Hint Resolve eqAmod_refl.

Lemma eqAmod_sym e x y : ((x == y %[mod e]) = (y == x %[mod e]))%A.
Proof. by rewrite /eqAmod -opprB rpredN. Qed.

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

Lemma eqAmod_transl e x y z :
  (x == y %[mod e])%A -> (x == z %[mod e])%A = (y == z %[mod e])%A.
Proof. by move/(sym_left_transitive (eqAmod_sym e) (@eqAmod_trans e)). Qed.

Lemma eqAmod_transr e x y z :
  (x == y %[mod e])%A -> (z == x %[mod e])%A = (z == y %[mod e])%A.
Proof. by move/(sym_right_transitive (eqAmod_sym e) (@eqAmod_trans e)). Qed.

Lemma eqAmod0 e x : (x == 0 %[mod e])%A = (e %| x)%A.
Proof. by rewrite /eqAmod subr0. Qed.

Lemma eqAmodN e x y : (- x == y %[mod e])%A = (x == - y %[mod e])%A.
Proof. by rewrite eqAmod_sym /eqAmod !opprK addrC. Qed.

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

Lemma eqAmodDl e x y z : (x + y == x + z %[mod e])%A = (y == z %[mod e])%A.
Proof. by rewrite !(addrC x) eqAmodDr. Qed.

Lemma eqAmodD e x1 x2 y1 y2 :
  (x1 == x2 %[mod e] -> y1 == y2 %[mod e] -> x1 + y1 == x2 + y2 %[mod e])%A.
Proof.
by rewrite -(eqAmodDl e x2 y1) -(eqAmodDr e y1); apply: eqAmod_trans.
Qed.

Lemma eqAmodm0 e : (e == 0 %[mod e])%A.
Proof. by rewrite /eqAmod subr0 unfold_in; case: ifPn => // /divff->. Qed.
Hint Resolve eqAmodm0.

Lemma eqAmodMr e :
  {in Aint, forall z x y, x == y %[mod e] -> x * z == y * z %[mod e]}%A.
Proof.
move=> z Zz x y.
rewrite /eqAmod -mulrBl ![(e %| _)%A]unfold_in mulf_eq0 mulrAC.
by case: ifP => [_ -> // | _ Exy]; apply: rpredM.
Qed.

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

Lemma eqAmodMl0 e : {in Aint, forall x, x * e == 0 %[mod e]}%A.
Proof. by move=> x Zx; rewrite -(mulr0 x) eqAmodMl. Qed.

Lemma eqAmodMr0 e : {in Aint, forall x, e * x == 0 %[mod e]}%A.
Proof. by move=> x Zx; rewrite /= mulrC eqAmodMl0. Qed.

Lemma eqAmod_addl_mul e : {in Aint, forall x y, x * e + y == y %[mod e]}%A.
Proof. by move=> x Zx y; rewrite -{2}[y]add0r eqAmodDr eqAmodMl0. Qed.

Lemma eqAmodM e : {in Aint &, forall x1 y2 x2 y1,
  x1 == x2 %[mod e] -> y1 == y2 %[mod e] -> x1 * y1 == x2 * y2 %[mod e]}%A.
Proof.
move=> x1 y2 Zx1 Zy2 x2 y1 eq_x /(eqAmodMl Zx1)/eqAmod_trans-> //.
exact: eqAmodMr.
Qed.

Lemma eqAmod_rat :
  {in Crat & &, forall e m n, (m == n %[mod e])%A = (m == n %[mod e])%C}.
Proof.
move=> e m n Qe Qm Qn; rewrite /eqCmod unfold_in /eqAmod unfold_in.
case: ifPn => // nz_e; apply/idP/idP=> [/Cint_rat_Aint | /Aint_Cint] -> //.
by rewrite rpred_div ?rpredB.
Qed.

Lemma eqAmod0_rat : {in Crat &, forall e n, (n == 0 %[mod e])%A = (e %| n)%C}.
Proof. by move=> e n Qe Qn; rewrite /= eqAmod_rat /eqCmod ?subr0 ?Crat0. Qed.

Lemma eqAmod_nat (e m n : nat) : (m == n %[mod e])%A = (m == n %[mod e])%N.
Proof. by rewrite eqAmod_rat ?rpred_nat // eqCmod_nat. Qed.

Lemma eqAmod0_nat (e m : nat) : (m == 0 %[mod e])%A = (e %| m)%N.
Proof. by rewrite eqAmod0_rat ?rpred_nat // dvdC_nat. Qed.

(* Multiplicative order. *)

Definition orderC x :=
  let p := minCpoly x in
  oapp val 0%N [pick n : 'I_(2 * size p ^ 2) | p == intrp 'Phi_n].

Notation "#[ x ]" := (orderC x) : C_scope.

Lemma exp_orderC x : x ^+ #[x]%C = 1.
Proof.
rewrite /orderC; case: pickP => //= [] [n _] /= /eqP Dp.
have n_gt0: (0 < n)%N.
  rewrite lt0n; apply: contraTneq (size_minCpoly x) => n0.
  by rewrite Dp n0 Cyclotomic0 rmorph1 size_poly1.
have [z prim_z] := C_prim_root_exists n_gt0.
rewrite prim_expr_order // -(root_cyclotomic prim_z).
by rewrite -Cintr_Cyclotomic // -Dp root_minCpoly.
Qed.

Lemma dvdn_orderC x n : (#[x]%C %| n)%N = (x ^+ n == 1).
Proof.
apply/idP/eqP=> [|x_n_1]; first by apply: expr_dvd; apply: exp_orderC.
have [-> | n_gt0] := posnP n; first by rewrite dvdn0.
have [m prim_x m_dv_n] := prim_order_exists n_gt0 x_n_1.
have{n_gt0} m_gt0 := dvdn_gt0 n_gt0 m_dv_n; congr (_ %| n)%N: m_dv_n.
pose p := minCpoly x; have Dp: p = cyclotomic x m := minCpoly_cyclotomic prim_x.
rewrite /orderC; case: pickP => /= [k /eqP Dp_k | no_k]; last first.
  suffices lt_m_2p: (m < 2 * size p ^ 2)%N.
    have /eqP[] := no_k (Ordinal lt_m_2p).
    by rewrite /= -/p Dp -Cintr_Cyclotomic.
  rewrite Dp size_cyclotomic (sqrnD 1) addnAC mulnDr -add1n leq_add //.
  suffices: (m <= \prod_(q <- primes m | q == 2) q * totient m ^ 2)%N.
    have [m_even | m_odd] := boolP (2 \in primes m).
      by rewrite -big_filter filter_pred1_uniq ?primes_uniq // big_seq1.
    by rewrite big_hasC ?has_pred1 // => /leq_trans-> //; apply: leq_addl.
  rewrite big_mkcond totientE // -mulnn -!big_split /=.
  rewrite {1}[m]prod_prime_decomp // prime_decompE big_map /= !big_seq.
  elim/big_ind2: _ => // [n1 m1 n2 m2 | q]; first exact: leq_mul.
  rewrite mem_primes => /and3P[q_pr _ q_dv_m].
  rewrite lognE q_pr m_gt0 q_dv_m /=; move: (logn q _) => k.
  rewrite !mulnA expnS leq_mul //.
  case: (ltngtP q) => // [|q_gt2 | ->]; first by rewrite ltnNge prime_gt1.
    rewrite mul1n mulnAC mulnn -{1}[q]muln1 leq_mul ?expn_gt0 ?prime_gt0 //.
    by rewrite -(subnKC q_gt2) (ltn_exp2l 1).
  by rewrite !muln1 -expnS (ltn_exp2l 0).
have k_prim_x: k.-primitive_root x.
  have k_gt0: (0 < k)%N.
    rewrite lt0n; apply: contraTneq (size_minCpoly x) => k0.
    by rewrite Dp_k k0 Cyclotomic0 rmorph1 size_poly1.
  have [z prim_z] := C_prim_root_exists k_gt0.
  rewrite -(root_cyclotomic prim_z) -Cintr_Cyclotomic //.
  by rewrite -Dp_k root_minCpoly.
apply/eqP; rewrite eqn_dvd !(@prim_order_dvd _ _ x) //.
by rewrite !prim_expr_order ?eqxx.
Qed.


Require Import Coq.Strings.String.
Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Psatz.
Require Import Coq.Classes.Morphisms_Prop.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Logic.Classical_Pred_Type.
Require Import Coq.Logic.Classical_Prop.
Require Import SetsClass.SetsClass.
Require Import compcert.lib.Integers.
Import SetsNotation.
Require Import PV.Syntax.
Import Lang_While.
Require Import PV.PracticalDenotations.
Import DntSem_While.
Require Import PV.EquivAndRefine.
Require Import PV.Assignment0306.
Local Open Scope Z.
Local Open Scope sets.
Local Open Scope string.
Arguments Rels.id: simpl never.
Arguments Rels.concat: simpl never.
Arguments Sets.indexed_union: simpl never.

(** 习题：*)

(** 先前，我们证明过_[remove_skip]_操作过后的程序语句中不会再在顺序执行的任何一
    侧出现_[skip]_。下面请证明_[remove_skip]_操作能保持语义等价。*)

Fixpoint remove_skip (c: com): com :=
  match c with
  | CSeq c1 c2 =>
      match remove_skip c1, remove_skip c2 with
      | CSkip, _ => remove_skip c2
      | _, CSkip => remove_skip c1
      | _, _ => CSeq (remove_skip c1) (remove_skip c2)
      end
  | CIf e c1 c2 =>
      CIf e (remove_skip c1) (remove_skip c2)
  | CWhile e c1 =>
      CWhile e (remove_skip c1)
  | _ =>
      c
  end.

Lemma remove_skip_sound: forall c,
  remove_skip c ~=~ c.
Admitted. (* 请删除这一行_[Admitted]_并填入你的证明，以_[Qed]_结束。 *)

(** 习题：*)

(** 下面定义的_[right_assoc]_操作能将所有的顺序执行语法树变为右结合的形式。而
    _[CSeq_right_assoc]_是其中要用到的辅助定义。*)

Fixpoint CSeq_right_assoc (c c0: com): com :=
  match c with
  | CSeq c1 c2 => CSeq c1 (CSeq_right_assoc c2 c0)
  | _ => CSeq c c0
  end.

Fixpoint right_assoc (c: com): com :=
  match c with
  | CSeq c1 c2 =>
      CSeq_right_assoc (right_assoc c1) (right_assoc c2)
  | CIf e c1 c2 =>
      CIf e (right_assoc c1) (right_assoc c2)
  | CWhile e c1 =>
      CWhile e (right_assoc c1)
  | _ =>
      c
  end.

(** 下面请分两步证明：_[right_assoc]_变换前后的程序是语义等价的。*)

Lemma CSeq_right_assoc_sound: forall c c0,
    CSeq_right_assoc c c0 ~=~ [[c ; c0]].
Admitted. (* 请删除这一行_[Admitted]_并填入你的证明，以_[Qed]_结束。 *)

Lemma right_assoc_sound: forall c,
  right_assoc c ~=~ c.
Admitted. (* 请删除这一行_[Admitted]_并填入你的证明，以_[Qed]_结束。 *)

(** 习题：*)

Module StatewiseEequiv.

(** 下面我们将定义一种新的更细粒度的等价关系_[statewise_eequiv]_，可以用符号：
    _[e1 @ s1 ~=~ e2 @ e2]_表示。其含义是，_[e1]_在_[s1]_这个程序状态上的求值结
    果与_[e2]_在_[s2]_这个程序状态上的求值结果相同。如果

       _[H: e1 @ s1 ~=~ e2 @ e2]_

    那么 _[H.(nrm_eequiv_s): forall i, ⟦ e1 ⟧.(nrm) s1 i <-> ⟦ e2 ⟧.(nrm) s2 i]_
    并且 _[H.(err_eequiv_s): ⟦ e1 ⟧.(err) s1 <-> ⟦ e2 ⟧.(err) s2]_。

    如果反过来，需要证明_[e1 @ s1 ~=~ e2 @ e2]_，那么可以用_[skip; simpl]_来拆解
    这一结论。下面是相关定义，可以忽略其中的细节。*)

Record statewise_eequiv
         (p1: expr * state)
         (p2: expr * state): Prop :=
{
  nrm_eequiv_s':
    forall i, ⟦ fst p1 ⟧.(nrm) (snd p1) i <-> ⟦ fst p2 ⟧.(nrm) (snd p2) i;
  err_eequiv_s':
    ⟦ fst p1 ⟧.(err) (snd p1) <-> ⟦ fst p2 ⟧.(err) (snd p2);
}.

Notation "e @ s" := (@pair expr state e s) (at level 59, no associativity).
Notation "p1 '~=~' p2" := (statewise_eequiv p1 p2)
  (at level 69, only printing, no associativity).
Ltac any_equiv x y ::=
  match type of x with
  | expr => exact (eequiv x y)
  | com => exact (cequiv x y)
  | prod expr state => exact (statewise_eequiv x y)
  | _ => match type of y with
         | expr => exact (eequiv x y)
         | com => exact (cequiv x y)
         | prod expr state => exact (statewise_eequiv x y)
         end
  end.

Lemma nrm_eequiv_s: forall (e1 e2: expr) (s1 s2: state),
  (e1 @ s1) ~=~ (e2 @ s2) ->
  forall i, ⟦ e1 ⟧.(nrm) s1 i <-> ⟦ e2 ⟧.(nrm) s2 i.
Proof. intros ? ? ? ?. apply nrm_eequiv_s'. Qed.

Lemma err_eequiv_s: forall (e1 e2: expr) (s1 s2: state),
  (e1 @ s1) ~=~ (e2 @ s2) ->
  (⟦ e1 ⟧.(err) s1 <-> ⟦ e2 ⟧.(err) s2).
Proof. intros ? ? ? ?. apply err_eequiv_s'. Qed.

Notation "x '.(nrm_eequiv_s)'" := (nrm_eequiv_s _ _ _ _ x)
  (at level 1).

Notation "x '.(err_eequiv_s)'" := (err_eequiv_s _ _ _ _ x)
  (at level 1).

(** 下面请证明，这种细粒度的等价关系也是一种等价关系。*)

Instance statewise_eequiv_refl:
  Reflexive statewise_eequiv.
Proof.
  unfold Reflexive.
  intros [e s].
Admitted. (* 请删除这一行_[Admitted]_并填入你的证明，以_[Qed]_结束。 *)

Instance statewise_eequiv_sym:
  Symmetric statewise_eequiv.
Proof.
  unfold Symmetric.
  intros [e1 s1] [e2 s2].
Admitted. (* 请删除这一行_[Admitted]_并填入你的证明，以_[Qed]_结束。 *)

Instance statewise_eequiv_trans:
  Transitive statewise_eequiv.
Proof.
  unfold Transitive.
  intros [e1 s1] [e2 s2] [e3 s3].
Admitted. (* 请删除这一行_[Admitted]_并填入你的证明，以_[Qed]_结束。 *)

(** 下面我们的引理证明了二元运算符与一元运算符能够保持这种_[statewise_eequiv]_关
    系。这些证明不需要你完成。*)

Lemma arith_sem1_nrm_congr_s:
  forall Zfun (e11 e12 e21 e22: expr) (s1 s2: state),
    e11 @ s1 ~=~ e12 @ s2 ->
    e21 @ s1 ~=~ e22 @ s2 ->
    forall i,
      arith_sem1_nrm Zfun ⟦ e11 ⟧.(nrm) ⟦ e21 ⟧.(nrm) s1 i <->
      arith_sem1_nrm Zfun ⟦ e12 ⟧.(nrm) ⟦ e22 ⟧.(nrm) s2 i.
Proof.
  intros.
  unfold arith_sem1_nrm.
  apply ex_iff_morphism; intros i1.
  apply ex_iff_morphism; intros i2.
  apply and_iff_morphism; [apply H.(nrm_eequiv_s) |].
  apply and_iff_morphism; [apply H0.(nrm_eequiv_s) |].
  reflexivity.
Qed.

Lemma arith_sem1_err_congr_s:
  forall Zfun (e11 e12 e21 e22: expr) (s1 s2: state),
    e11 @ s1 ~=~ e12 @ s2 ->
    e21 @ s1 ~=~ e22 @ s2 ->
    ((⟦ e11 ⟧.(err) ∪ ⟦ e21 ⟧.(err) ∪
      arith_sem1_err Zfun ⟦ e11 ⟧.(nrm) ⟦ e21 ⟧.(nrm)) s1) <->
    ((⟦ e12 ⟧.(err) ∪ ⟦ e22 ⟧.(err) ∪
      arith_sem1_err Zfun ⟦ e12 ⟧.(nrm) ⟦ e22 ⟧.(nrm)) s2).
Proof.
  intros.
  unfold arith_sem1_err.
  apply or_iff_morphism.
  + apply or_iff_morphism.
    - apply H.(err_eequiv_s).
    - apply H0.(err_eequiv_s).
  + apply ex_iff_morphism; intros i1.
    apply ex_iff_morphism; intros i2.
    apply and_iff_morphism; [apply H.(nrm_eequiv_s) |].
    apply and_iff_morphism; [apply H0.(nrm_eequiv_s) |].
    reflexivity.
Qed.

Lemma arith_sem2_nrm_congr_s:
  forall int64fun (e11 e12 e21 e22: expr) (s1 s2: state),
    e11 @ s1 ~=~ e12 @ s2 ->
    e21 @ s1 ~=~ e22 @ s2 ->
    forall i,
      arith_sem2_nrm int64fun ⟦ e11 ⟧.(nrm) ⟦ e21 ⟧.(nrm) s1 i <->
      arith_sem2_nrm int64fun ⟦ e12 ⟧.(nrm) ⟦ e22 ⟧.(nrm) s2 i.
Proof.
  intros.
  unfold arith_sem2_nrm.
  apply ex_iff_morphism; intros i1.
  apply ex_iff_morphism; intros i2.
  apply and_iff_morphism; [apply H.(nrm_eequiv_s) |].
  apply and_iff_morphism; [apply H0.(nrm_eequiv_s) |].
  reflexivity.
Qed.

Lemma arith_sem2_err_congr_s:
  forall (e11 e12 e21 e22: expr) (s1 s2: state),
    e11 @ s1 ~=~ e12 @ s2 ->
    e21 @ s1 ~=~ e22 @ s2 ->
    (⟦ e11 ⟧.(err) ∪ ⟦ e21 ⟧.(err) ∪
      arith_sem2_err ⟦ e11 ⟧.(nrm) ⟦ e21 ⟧.(nrm)) s1 <->
    (⟦ e12 ⟧.(err) ∪ ⟦ e22 ⟧.(err) ∪
      arith_sem2_err ⟦ e12 ⟧.(nrm) ⟦ e22 ⟧.(nrm)) s2.
Proof.
  intros.
  unfold arith_sem2_err.
  apply or_iff_morphism.
  + apply or_iff_morphism.
    - apply H.(err_eequiv_s).
    - apply H0.(err_eequiv_s).
  + apply ex_iff_morphism; intros i1.
    apply ex_iff_morphism; intros i2.
    apply and_iff_morphism; [apply H.(nrm_eequiv_s) |].
    apply and_iff_morphism; [apply H0.(nrm_eequiv_s) |].
    reflexivity.
Qed.

Lemma cmp_sem_nrm_congr_s:
  forall op (e11 e12 e21 e22: expr) (s1 s2: state),
    e11 @ s1 ~=~ e12 @ s2 ->
    e21 @ s1 ~=~ e22 @ s2 ->
    forall i,
      cmp_sem_nrm op ⟦ e11 ⟧.(nrm) ⟦ e21 ⟧.(nrm) s1 i <->
      cmp_sem_nrm op ⟦ e12 ⟧.(nrm) ⟦ e22 ⟧.(nrm) s2 i.
Proof.
  intros.
  unfold cmp_sem_nrm.
  apply ex_iff_morphism; intros i1.
  apply ex_iff_morphism; intros i2.
  apply and_iff_morphism; [apply H.(nrm_eequiv_s) |].
  apply and_iff_morphism; [apply H0.(nrm_eequiv_s) |].
  reflexivity.
Qed.

Lemma cmp_sem_err_congr_s:
  forall (e11 e12 e21 e22: expr) (s1 s2: state),
    e11 @ s1 ~=~ e12 @ s2 ->
    e21 @ s1 ~=~ e22 @ s2 ->
    (⟦ e11 ⟧.(err) ∪ ⟦ e21 ⟧.(err)) s1 <->
    (⟦ e12 ⟧.(err) ∪ ⟦ e22 ⟧.(err)) s2.
Proof.
  intros.
  apply or_iff_morphism.
  + apply H.(err_eequiv_s).
  + apply H0.(err_eequiv_s).
Qed.

Lemma and_sem_nrm_congr_s:
  forall (e11 e12 e21 e22: expr) (s1 s2: state),
    e11 @ s1 ~=~ e12 @ s2 ->
    e21 @ s1 ~=~ e22 @ s2 ->
    forall i,
      and_sem_nrm ⟦ e11 ⟧.(nrm) ⟦ e21 ⟧.(nrm) s1 i <->
      and_sem_nrm ⟦ e12 ⟧.(nrm) ⟦ e22 ⟧.(nrm) s2 i.
Proof.
  intros.
  unfold and_sem_nrm.
  apply ex_iff_morphism; intros i1.
  apply and_iff_morphism; [apply H.(nrm_eequiv_s) |].
  apply or_iff_morphism; [reflexivity |].
  apply and_iff_morphism; [reflexivity |].
  apply ex_iff_morphism; intros i2.
  apply and_iff_morphism; [apply H0.(nrm_eequiv_s) |].
  reflexivity.
Qed.

Lemma and_sem_err_congr_s:
  forall (e11 e12 e21 e22: expr) (s1 s2: state),
    e11 @ s1 ~=~ e12 @ s2 ->
    e21 @ s1 ~=~ e22 @ s2 ->
    (⟦ e11 ⟧.(err) ∪ and_sem_err ⟦ e11 ⟧.(nrm) ⟦ e21 ⟧.(err)) s1 <->
    (⟦ e12 ⟧.(err) ∪ and_sem_err ⟦ e12 ⟧.(nrm) ⟦ e22 ⟧.(err)) s2.
Proof.
  intros.
  unfold and_sem_err.
  apply or_iff_morphism; [apply H.(err_eequiv_s) |].
  apply ex_iff_morphism; intros i1.
  apply and_iff_morphism; [apply H.(nrm_eequiv_s) |].
  apply and_iff_morphism; [| apply H0.(err_eequiv_s)].
  reflexivity.
Qed.

Lemma or_sem_nrm_congr_s:
  forall (e11 e12 e21 e22: expr) (s1 s2: state),
    e11 @ s1 ~=~ e12 @ s2 ->
    e21 @ s1 ~=~ e22 @ s2 ->
    forall i,
      or_sem_nrm ⟦ e11 ⟧.(nrm) ⟦ e21 ⟧.(nrm) s1 i <->
      or_sem_nrm ⟦ e12 ⟧.(nrm) ⟦ e22 ⟧.(nrm) s2 i.
Proof.
  intros.
  unfold or_sem_nrm.
  apply ex_iff_morphism; intros i1.
  apply and_iff_morphism; [apply H.(nrm_eequiv_s) |].
  apply or_iff_morphism; [reflexivity |].
  apply and_iff_morphism; [reflexivity |].
  apply ex_iff_morphism; intros i2.
  apply and_iff_morphism; [apply H0.(nrm_eequiv_s) |].
  reflexivity.
Qed.

Lemma or_sem_err_congr_s:
  forall (e11 e12 e21 e22: expr) (s1 s2: state),
    e11 @ s1 ~=~ e12 @ s2 ->
    e21 @ s1 ~=~ e22 @ s2 ->
    (⟦ e11 ⟧.(err) ∪ or_sem_err ⟦ e11 ⟧.(nrm) ⟦ e21 ⟧.(err)) s1 <->
    (⟦ e12 ⟧.(err) ∪ or_sem_err ⟦ e12 ⟧.(nrm) ⟦ e22 ⟧.(err)) s2.
Proof.
  intros.
  unfold or_sem_err.
  apply or_iff_morphism; [apply H.(err_eequiv_s) |].
  apply ex_iff_morphism; intros i1.
  apply and_iff_morphism; [apply H.(nrm_eequiv_s) |].
  apply and_iff_morphism; [| apply H0.(err_eequiv_s)].
  reflexivity.
Qed.

Lemma not_sem_nrm_congr_s:
  forall (e1 e2: expr) (s1 s2: state),
    e1 @ s1 ~=~ e2 @ s2 ->
    forall i,
      not_sem_nrm ⟦ e1 ⟧.(nrm) s1 i <->
      not_sem_nrm ⟦ e2 ⟧.(nrm) s2 i.
Proof.
  intros.
  unfold not_sem_nrm.
  apply ex_iff_morphism; intros i1.
  apply and_iff_morphism; [apply H.(nrm_eequiv_s) |].
  reflexivity.
Qed.

Lemma not_sem_err_congr_s:
  forall (e1 e2: expr) (s1 s2: state),
    e1 @ s1 ~=~ e2 @ s2 ->
    ⟦ e1 ⟧.(err) s1 <-> ⟦ e2 ⟧.(err) s2.
Proof.
  intros.
  apply H.(err_eequiv_s).
Qed.

Lemma neg_sem_nrm_congr_s:
  forall (e1 e2: expr) (s1 s2: state),
    e1 @ s1 ~=~ e2 @ s2 ->
    forall i,
      neg_sem_nrm ⟦ e1 ⟧.(nrm) s1 i <->
      neg_sem_nrm ⟦ e2 ⟧.(nrm) s2 i.
Proof.
  intros.
  unfold neg_sem_nrm.
  apply ex_iff_morphism; intros i1.
  apply and_iff_morphism; [apply H.(nrm_eequiv_s) |].
  reflexivity.
Qed.

Lemma neg_sem_err_congr_s:
  forall (e1 e2: expr) (s1 s2: state),
    e1 @ s1 ~=~ e2 @ s2 ->
    (⟦ e1 ⟧.(err) ∪ neg_sem_err ⟦ e1 ⟧.(nrm)) s1 <->
    (⟦ e2 ⟧.(err) ∪ neg_sem_err ⟦ e2 ⟧.(nrm)) s2.
Proof.
  intros.
  unfold neg_sem_err.
  apply or_iff_morphism; [apply H.(err_eequiv_s) |].
  apply ex_iff_morphism; intros i1.
  apply and_iff_morphism; [apply H.(nrm_eequiv_s) |].
  reflexivity.
Qed.

Lemma EBinop_congr_s:
  forall op (e11 e12 e21 e22: expr) (s1 s2: state),
    e11 @ s1 ~=~ e12 @ s2 ->
    e21 @ s1 ~=~ e22 @ s2 ->
    EBinop op e11 e21 @ s1 ~=~ EBinop op e12 e22 @ s2.
Proof.
  intros.
  destruct op.
  + split; simpl.
    - apply or_sem_nrm_congr_s; tauto.
    - apply or_sem_err_congr_s; tauto.
  + split; simpl.
    - apply and_sem_nrm_congr_s; tauto.
    - apply and_sem_err_congr_s; tauto.
  + split; simpl.
    - apply cmp_sem_nrm_congr_s; tauto.
    - apply cmp_sem_err_congr_s; tauto.
  + split; simpl.
    - apply cmp_sem_nrm_congr_s; tauto.
    - apply cmp_sem_err_congr_s; tauto.
  + split; simpl.
    - apply cmp_sem_nrm_congr_s; tauto.
    - apply cmp_sem_err_congr_s; tauto.
  + split; simpl.
    - apply cmp_sem_nrm_congr_s; tauto.
    - apply cmp_sem_err_congr_s; tauto.
  + split; simpl.
    - apply cmp_sem_nrm_congr_s; tauto.
    - apply cmp_sem_err_congr_s; tauto.
  + split; simpl.
    - apply cmp_sem_nrm_congr_s; tauto.
    - apply cmp_sem_err_congr_s; tauto.
  + split; simpl.
    - apply arith_sem1_nrm_congr_s; tauto.
    - apply arith_sem1_err_congr_s; tauto.
  + split; simpl.
    - apply arith_sem1_nrm_congr_s; tauto.
    - apply arith_sem1_err_congr_s; tauto.
  + split; simpl.
    - apply arith_sem1_nrm_congr_s; tauto.
    - apply arith_sem1_err_congr_s; tauto.
  + split; simpl.
    - apply arith_sem2_nrm_congr_s; tauto.
    - apply arith_sem2_err_congr_s; tauto.
  + split; simpl.
    - apply arith_sem2_nrm_congr_s; tauto.
    - apply arith_sem2_err_congr_s; tauto.
Qed.

Lemma EUnop_congr_s:
  forall op (e1 e2: expr) (s1 s2: state),
    e1 @ s1 ~=~ e2 @ s2 ->
    EUnop op e1 @ s1 ~=~ EUnop op e2 @ s2.
Proof.
  intros.
  destruct op.
  + split; simpl.
    - apply not_sem_nrm_congr_s; tauto.
    - apply not_sem_err_congr_s; tauto.
  + split; simpl.
    - apply neg_sem_nrm_congr_s; tauto.
    - apply neg_sem_err_congr_s; tauto.
Qed.

(** 下面请你证明两条关于_[statewise_eequiv]_的性质，在证明中可能需要你手动运用上
    面给出的_[EBinop_congr_s]_进行证明。

    下面定义的_[subst_const]_关系说的是：可以将_[e1]_中出现的变量_[x]_替换成常数
    _[n]_得到_[e2]_。如果_[x]_在_[e1]_中出现多次，那么_[subst_const]_关系允许只
    替换其中的0次、1次或任意多次乃至全部。请你分两步证明，如果在程序状态_[s]_上
    变量_[x]_的值是_[n]_，那么上述_[e1]_与_[e2]_满足：_[e1 @ s ~=~ e2 @ s]_。*)

Fixpoint subst_const (e1 e2: expr) (x: var_name) (n: Z): Prop :=
  match e1, e2 with
  | EConst n1, EConst n2 => n1 = n2
  | EVar x1, EVar x2 => x1 = x2
  | EVar x1, EConst n2 => x1 = x /\ n2 = n
  | EBinop op1 e11 e12, EBinop op2 e21 e22 =>
      op1 = op2 /\ subst_const e11 e21 x n /\ subst_const e12 e22 x n
  | EUnop op1 e11, EUnop op2 e21 =>
      op1 = op2 /\ subst_const e11 e21 x n
  | _, _ => False
  end.

(** 这是一条辅助引理：*)

Lemma subst_const_base_sound: forall (s: state) (x: var_name) (n: Z),
  Int64.min_signed <= n <= Int64.max_signed ->
  s x = Vint (Int64.repr n) ->
  x @ s ~=~ n @ s.
Admitted. (* 请删除这一行_[Admitted]_并填入你的证明，以_[Qed]_结束。 *)

(** 这是最终需要证明的性质：*)

Theorem subst_const_sound: forall (s: state) e1 e2 (x: var_name) n,
  Int64.min_signed <= n <= Int64.max_signed ->
  s x = Vint (Int64.repr n) ->
  subst_const e1 e2 x n ->
  e1 @ s ~=~ e2 @ s.
Admitted. (* 请删除这一行_[Admitted]_并填入你的证明，以_[Qed]_结束。 *)

(** 下面定义的命题_[appears_in_expr e x]_说的是：程序变量_[x]_会在表达式_[e]_中
    出现至少一次。*)

Fixpoint appears_in_expr (e: expr) (x: var_name): Prop :=
  match e with
  | EConst _ => False
  | EVar y => x = y
  | EBinop op e1 e2 => appears_in_expr e1 x \/ appears_in_expr e2 x
  | EUnop op e1 => appears_in_expr e1 x
  end.

(** 请证明：如果_[e]_中出现的每个变量都在_[s1]_与_[s2]_这两个程序状态上取值相同，
    那么_[e]_在这两个程序状态上的求值结果就相同。*)

Theorem eeval_appears: forall s1 s2 e,
  (forall x: var_name, appears_in_expr e x -> s1 x = s2 x) ->
  e @ s1 ~=~ e @ s2.
Admitted. (* 请删除这一行_[Admitted]_并填入你的证明，以_[Qed]_结束。 *)

End StatewiseEequiv.


Require Export euclidean__axioms.
Require Export euclidean__tactics.
Require Export lemma__betweennotequal.
Require Export lemma__collinear4.
Require Export lemma__collinearorder.
Require Export lemma__inequalitysymmetric.
Require Export logic.
Definition lemma__9__5a : forall A B C P Q R, (euclidean__axioms.TS P A B C) -> ((euclidean__axioms.BetS R P Q) -> ((euclidean__axioms.nCol R Q C) -> ((euclidean__axioms.Col A B R) -> (euclidean__axioms.TS Q A B C)))).
Proof.
intro A.
intro B.
intro C.
intro P.
intro Q.
intro R.
intro H.
intro H0.
intro H1.
intro H2.
assert (exists S, (euclidean__axioms.BetS P S C) /\ ((euclidean__axioms.Col A B S) /\ (euclidean__axioms.nCol A B P))) as H3 by exact H.
destruct H3 as [S H4].
destruct H4 as [H5 H6].
destruct H6 as [H7 H8].
assert (* Cut *) (euclidean__axioms.BetS C S P) as H9.
- apply (@euclidean__axioms.axiom__betweennesssymmetry P S C H5).
- assert (* Cut *) (exists F, (euclidean__axioms.BetS C F Q) /\ (euclidean__axioms.BetS R S F)) as H10.
-- apply (@euclidean__axioms.postulate__Pasch__outer C R P S Q H9 H0 H1).
-- destruct H10 as [F H11].
destruct H11 as [H12 H13].
assert (* Cut *) (euclidean__axioms.Col R S F) as H14.
--- right.
right.
right.
right.
left.
exact H13.
--- assert (* Cut *) (~(A = B)) as H15.
---- intro H15.
assert (* Cut *) (euclidean__axioms.Col A B P) as H16.
----- left.
exact H15.
----- apply (@euclidean__tactics.Col__nCol__False A B P H8 H16).
---- assert (* Cut *) (euclidean__axioms.neq B A) as H16.
----- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric A B H15).
----- assert (* Cut *) (euclidean__axioms.Col B R S) as H17.
------ apply (@euclidean__tactics.not__nCol__Col B R S).
-------intro H17.
apply (@euclidean__tactics.Col__nCol__False B R S H17).
--------apply (@lemma__collinear4.lemma__collinear4 A B R S H2 H7 H15).

------ assert (* Cut *) (euclidean__axioms.Col R S B) as H18.
------- assert (* Cut *) ((euclidean__axioms.Col R B S) /\ ((euclidean__axioms.Col R S B) /\ ((euclidean__axioms.Col S B R) /\ ((euclidean__axioms.Col B S R) /\ (euclidean__axioms.Col S R B))))) as H18.
-------- apply (@lemma__collinearorder.lemma__collinearorder B R S H17).
-------- destruct H18 as [H19 H20].
destruct H20 as [H21 H22].
destruct H22 as [H23 H24].
destruct H24 as [H25 H26].
exact H21.
------- assert (* Cut *) (euclidean__axioms.neq R S) as H19.
-------- assert (* Cut *) ((euclidean__axioms.neq S F) /\ ((euclidean__axioms.neq R S) /\ (euclidean__axioms.neq R F))) as H19.
--------- apply (@lemma__betweennotequal.lemma__betweennotequal R S F H13).
--------- destruct H19 as [H20 H21].
destruct H21 as [H22 H23].
exact H22.
-------- assert (* Cut *) (euclidean__axioms.Col S F B) as H20.
--------- apply (@euclidean__tactics.not__nCol__Col S F B).
----------intro H20.
apply (@euclidean__tactics.Col__nCol__False S F B H20).
-----------apply (@lemma__collinear4.lemma__collinear4 R S F B H14 H18 H19).

--------- assert (* Cut *) (euclidean__axioms.Col S B A) as H21.
---------- assert (* Cut *) ((euclidean__axioms.Col B A S) /\ ((euclidean__axioms.Col B S A) /\ ((euclidean__axioms.Col S A B) /\ ((euclidean__axioms.Col A S B) /\ (euclidean__axioms.Col S B A))))) as H21.
----------- apply (@lemma__collinearorder.lemma__collinearorder A B S H7).
----------- destruct H21 as [H22 H23].
destruct H23 as [H24 H25].
destruct H25 as [H26 H27].
destruct H27 as [H28 H29].
exact H29.
---------- assert (* Cut *) (euclidean__axioms.Col S B F) as H22.
----------- assert (* Cut *) ((euclidean__axioms.Col F S B) /\ ((euclidean__axioms.Col F B S) /\ ((euclidean__axioms.Col B S F) /\ ((euclidean__axioms.Col S B F) /\ (euclidean__axioms.Col B F S))))) as H22.
------------ apply (@lemma__collinearorder.lemma__collinearorder S F B H20).
------------ destruct H22 as [H23 H24].
destruct H24 as [H25 H26].
destruct H26 as [H27 H28].
destruct H28 as [H29 H30].
exact H29.
----------- assert (* Cut *) (euclidean__axioms.Col A B F) as H23.
------------ assert (* Cut *) ((S = B) \/ (euclidean__axioms.neq S B)) as H23.
------------- apply (@euclidean__tactics.eq__or__neq S B).
------------- assert ((S = B) \/ (euclidean__axioms.neq S B)) as H24 by exact H23.
assert ((S = B) \/ (euclidean__axioms.neq S B)) as __TmpHyp by exact H24.
destruct __TmpHyp as [H25|H25].
-------------- assert (* Cut *) (euclidean__axioms.Col B A S) as H26.
--------------- assert (* Cut *) ((euclidean__axioms.Col B S A) /\ ((euclidean__axioms.Col B A S) /\ ((euclidean__axioms.Col A S B) /\ ((euclidean__axioms.Col S A B) /\ (euclidean__axioms.Col A B S))))) as H26.
---------------- apply (@lemma__collinearorder.lemma__collinearorder S B A H21).
---------------- destruct H26 as [H27 H28].
destruct H28 as [H29 H30].
destruct H30 as [H31 H32].
destruct H32 as [H33 H34].
exact H29.
--------------- assert (euclidean__axioms.Col R S F) as H27 by exact H14.
assert (* Cut *) (euclidean__axioms.Col R B F) as H28.
---------------- apply (@eq__ind__r euclidean__axioms.Point B (fun S0 => (euclidean__axioms.BetS P S0 C) -> ((euclidean__axioms.Col A B S0) -> ((euclidean__axioms.BetS C S0 P) -> ((euclidean__axioms.BetS R S0 F) -> ((euclidean__axioms.Col R S0 F) -> ((euclidean__axioms.Col B R S0) -> ((euclidean__axioms.Col R S0 B) -> ((euclidean__axioms.neq R S0) -> ((euclidean__axioms.Col S0 F B) -> ((euclidean__axioms.Col S0 B A) -> ((euclidean__axioms.Col S0 B F) -> ((euclidean__axioms.Col B A S0) -> ((euclidean__axioms.Col R S0 F) -> (euclidean__axioms.Col R B F))))))))))))))) with (x := S).
-----------------intro H28.
intro H29.
intro H30.
intro H31.
intro H32.
intro H33.
intro H34.
intro H35.
intro H36.
intro H37.
intro H38.
intro H39.
intro H40.
exact H40.

----------------- exact H25.
----------------- exact H5.
----------------- exact H7.
----------------- exact H9.
----------------- exact H13.
----------------- exact H14.
----------------- exact H17.
----------------- exact H18.
----------------- exact H19.
----------------- exact H20.
----------------- exact H21.
----------------- exact H22.
----------------- exact H26.
----------------- exact H27.
---------------- assert (* Cut *) (euclidean__axioms.Col R B A) as H29.
----------------- assert (* Cut *) ((euclidean__axioms.Col B A R) /\ ((euclidean__axioms.Col B R A) /\ ((euclidean__axioms.Col R A B) /\ ((euclidean__axioms.Col A R B) /\ (euclidean__axioms.Col R B A))))) as H29.
------------------ apply (@lemma__collinearorder.lemma__collinearorder A B R H2).
------------------ destruct H29 as [H30 H31].
destruct H31 as [H32 H33].
destruct H33 as [H34 H35].
destruct H35 as [H36 H37].
exact H37.
----------------- assert (* Cut *) (~(R = B)) as H30.
------------------ intro H30.
assert (* Cut *) (R = S) as H31.
------------------- apply (@logic.eq__trans Point R B S H30).
--------------------apply (@logic.eq__sym Point S B H25).

------------------- assert (* Cut *) (euclidean__axioms.neq R S) as H32.
-------------------- assert (* Cut *) ((euclidean__axioms.neq S F) /\ ((euclidean__axioms.neq R S) /\ (euclidean__axioms.neq R F))) as H32.
--------------------- apply (@lemma__betweennotequal.lemma__betweennotequal R S F H13).
--------------------- destruct H32 as [H33 H34].
destruct H34 as [H35 H36].
exact H19.
-------------------- assert (* Cut *) (euclidean__axioms.neq R B) as H33.
--------------------- apply (@eq__ind__r euclidean__axioms.Point B (fun R0 => (euclidean__axioms.BetS R0 P Q) -> ((euclidean__axioms.nCol R0 Q C) -> ((euclidean__axioms.Col A B R0) -> ((euclidean__axioms.BetS R0 S F) -> ((euclidean__axioms.Col R0 S F) -> ((euclidean__axioms.Col B R0 S) -> ((euclidean__axioms.Col R0 S B) -> ((euclidean__axioms.neq R0 S) -> ((euclidean__axioms.Col R0 S F) -> ((euclidean__axioms.Col R0 B F) -> ((euclidean__axioms.Col R0 B A) -> ((R0 = S) -> ((euclidean__axioms.neq R0 S) -> (euclidean__axioms.neq R0 B))))))))))))))) with (x := R).
----------------------intro H33.
intro H34.
intro H35.
intro H36.
intro H37.
intro H38.
intro H39.
intro H40.
intro H41.
intro H42.
intro H43.
intro H44.
intro H45.
apply (@eq__ind__r euclidean__axioms.Point B (fun S0 => (euclidean__axioms.BetS P S0 C) -> ((euclidean__axioms.Col A B S0) -> ((euclidean__axioms.BetS C S0 P) -> ((euclidean__axioms.Col B S0 F) -> ((euclidean__axioms.BetS B S0 F) -> ((euclidean__axioms.neq B S0) -> ((euclidean__axioms.Col B S0 B) -> ((euclidean__axioms.Col B B S0) -> ((euclidean__axioms.Col S0 F B) -> ((euclidean__axioms.Col S0 B A) -> ((euclidean__axioms.Col S0 B F) -> ((euclidean__axioms.Col B A S0) -> ((euclidean__axioms.Col B S0 F) -> ((euclidean__axioms.neq B S0) -> ((B = S0) -> (euclidean__axioms.neq B B))))))))))))))))) with (x := S).
-----------------------intro H46.
intro H47.
intro H48.
intro H49.
intro H50.
intro H51.
intro H52.
intro H53.
intro H54.
intro H55.
intro H56.
intro H57.
intro H58.
intro H59.
intro H60.
exact H59.

----------------------- exact H25.
----------------------- exact H5.
----------------------- exact H7.
----------------------- exact H9.
----------------------- exact H37.
----------------------- exact H36.
----------------------- exact H40.
----------------------- exact H39.
----------------------- exact H38.
----------------------- exact H20.
----------------------- exact H21.
----------------------- exact H22.
----------------------- exact H26.
----------------------- exact H41.
----------------------- exact H45.
----------------------- exact H44.

---------------------- exact H30.
---------------------- exact H0.
---------------------- exact H1.
---------------------- exact H2.
---------------------- exact H13.
---------------------- exact H14.
---------------------- exact H17.
---------------------- exact H18.
---------------------- exact H19.
---------------------- exact H27.
---------------------- exact H28.
---------------------- exact H29.
---------------------- exact H31.
---------------------- exact H32.
--------------------- apply (@H19 H31).
------------------ assert (* Cut *) (euclidean__axioms.Col B F A) as H31.
------------------- apply (@euclidean__tactics.not__nCol__Col B F A).
--------------------intro H31.
apply (@euclidean__tactics.Col__nCol__False B F A H31).
---------------------apply (@lemma__collinear4.lemma__collinear4 R B F A H28 H29 H30).

------------------- assert (* Cut *) (euclidean__axioms.Col A B F) as H32.
-------------------- assert (* Cut *) ((euclidean__axioms.Col F B A) /\ ((euclidean__axioms.Col F A B) /\ ((euclidean__axioms.Col A B F) /\ ((euclidean__axioms.Col B A F) /\ (euclidean__axioms.Col A F B))))) as H32.
--------------------- apply (@lemma__collinearorder.lemma__collinearorder B F A H31).
--------------------- destruct H32 as [H33 H34].
destruct H34 as [H35 H36].
destruct H36 as [H37 H38].
destruct H38 as [H39 H40].
exact H37.
-------------------- exact H32.
-------------- assert (* Cut *) (euclidean__axioms.Col B A F) as H26.
--------------- apply (@euclidean__tactics.not__nCol__Col B A F).
----------------intro H26.
apply (@euclidean__tactics.Col__nCol__False B A F H26).
-----------------apply (@lemma__collinear4.lemma__collinear4 S B A F H21 H22 H25).

--------------- assert (* Cut *) (euclidean__axioms.Col A B F) as H27.
---------------- assert (* Cut *) ((euclidean__axioms.Col A B F) /\ ((euclidean__axioms.Col A F B) /\ ((euclidean__axioms.Col F B A) /\ ((euclidean__axioms.Col B F A) /\ (euclidean__axioms.Col F A B))))) as H27.
----------------- apply (@lemma__collinearorder.lemma__collinearorder B A F H26).
----------------- destruct H27 as [H28 H29].
destruct H29 as [H30 H31].
destruct H31 as [H32 H33].
destruct H33 as [H34 H35].
exact H28.
---------------- exact H27.
------------ assert (* Cut *) (~(euclidean__axioms.Col A B Q)) as H24.
------------- intro H24.
assert (* Cut *) (euclidean__axioms.Col B Q R) as H25.
-------------- apply (@euclidean__tactics.not__nCol__Col B Q R).
---------------intro H25.
apply (@euclidean__tactics.Col__nCol__False B Q R H25).
----------------apply (@lemma__collinear4.lemma__collinear4 A B Q R H24 H2 H15).

-------------- assert (* Cut *) (euclidean__axioms.Col B R Q) as H26.
--------------- assert (* Cut *) ((euclidean__axioms.Col Q B R) /\ ((euclidean__axioms.Col Q R B) /\ ((euclidean__axioms.Col R B Q) /\ ((euclidean__axioms.Col B R Q) /\ (euclidean__axioms.Col R Q B))))) as H26.
---------------- apply (@lemma__collinearorder.lemma__collinearorder B Q R H25).
---------------- destruct H26 as [H27 H28].
destruct H28 as [H29 H30].
destruct H30 as [H31 H32].
destruct H32 as [H33 H34].
exact H33.
--------------- assert (* Cut *) (euclidean__axioms.Col B R F) as H27.
---------------- apply (@euclidean__tactics.not__nCol__Col B R F).
-----------------intro H27.
apply (@euclidean__tactics.Col__nCol__False B R F H27).
------------------apply (@lemma__collinear4.lemma__collinear4 A B R F H2 H23 H15).

---------------- assert (* Cut *) (euclidean__axioms.Col R Q F) as H28.
----------------- assert (* Cut *) ((B = R) \/ (euclidean__axioms.neq B R)) as H28.
------------------ apply (@euclidean__tactics.eq__or__neq B R).
------------------ assert ((B = R) \/ (euclidean__axioms.neq B R)) as H29 by exact H28.
assert ((B = R) \/ (euclidean__axioms.neq B R)) as __TmpHyp by exact H29.
destruct __TmpHyp as [H30|H30].
------------------- assert (* Cut *) (~(A = R)) as H31.
-------------------- intro H31.
assert (* Cut *) (A = B) as H32.
--------------------- apply (@logic.eq__trans Point A R B H31).
----------------------apply (@logic.eq__sym Point B R H30).

--------------------- apply (@H15 H32).
-------------------- assert (* Cut *) (euclidean__axioms.Col B A R) as H32.
--------------------- assert (* Cut *) ((euclidean__axioms.Col B A R) /\ ((euclidean__axioms.Col B R A) /\ ((euclidean__axioms.Col R A B) /\ ((euclidean__axioms.Col A R B) /\ (euclidean__axioms.Col R B A))))) as H32.
---------------------- apply (@lemma__collinearorder.lemma__collinearorder A B R H2).
---------------------- destruct H32 as [H33 H34].
destruct H34 as [H35 H36].
destruct H36 as [H37 H38].
destruct H38 as [H39 H40].
exact H33.
--------------------- assert (* Cut *) (euclidean__axioms.Col B A F) as H33.
---------------------- assert (* Cut *) ((euclidean__axioms.Col B A F) /\ ((euclidean__axioms.Col B F A) /\ ((euclidean__axioms.Col F A B) /\ ((euclidean__axioms.Col A F B) /\ (euclidean__axioms.Col F B A))))) as H33.
----------------------- apply (@lemma__collinearorder.lemma__collinearorder A B F H23).
----------------------- destruct H33 as [H34 H35].
destruct H35 as [H36 H37].
destruct H37 as [H38 H39].
destruct H39 as [H40 H41].
exact H34.
---------------------- assert (* Cut *) (euclidean__axioms.Col A R F) as H34.
----------------------- apply (@eq__ind__r euclidean__axioms.Point R (fun B0 => (euclidean__axioms.TS P A B0 C) -> ((euclidean__axioms.Col A B0 R) -> ((euclidean__axioms.Col A B0 S) -> ((euclidean__axioms.nCol A B0 P) -> ((~(A = B0)) -> ((euclidean__axioms.neq B0 A) -> ((euclidean__axioms.Col B0 R S) -> ((euclidean__axioms.Col R S B0) -> ((euclidean__axioms.Col S F B0) -> ((euclidean__axioms.Col S B0 A) -> ((euclidean__axioms.Col S B0 F) -> ((euclidean__axioms.Col A B0 F) -> ((euclidean__axioms.Col A B0 Q) -> ((euclidean__axioms.Col B0 Q R) -> ((euclidean__axioms.Col B0 R Q) -> ((euclidean__axioms.Col B0 R F) -> ((euclidean__axioms.Col B0 A R) -> ((euclidean__axioms.Col B0 A F) -> (euclidean__axioms.Col A R F)))))))))))))))))))) with (x := B).
------------------------intro H34.
intro H35.
intro H36.
intro H37.
intro H38.
intro H39.
intro H40.
intro H41.
intro H42.
intro H43.
intro H44.
intro H45.
intro H46.
intro H47.
intro H48.
intro H49.
intro H50.
intro H51.
exact H45.

------------------------ exact H30.
------------------------ exact H.
------------------------ exact H2.
------------------------ exact H7.
------------------------ exact H8.
------------------------ exact H15.
------------------------ exact H16.
------------------------ exact H17.
------------------------ exact H18.
------------------------ exact H20.
------------------------ exact H21.
------------------------ exact H22.
------------------------ exact H23.
------------------------ exact H24.
------------------------ exact H25.
------------------------ exact H26.
------------------------ exact H27.
------------------------ exact H32.
------------------------ exact H33.
----------------------- assert (* Cut *) (euclidean__axioms.Col B A Q) as H35.
------------------------ assert (* Cut *) ((euclidean__axioms.Col B A Q) /\ ((euclidean__axioms.Col B Q A) /\ ((euclidean__axioms.Col Q A B) /\ ((euclidean__axioms.Col A Q B) /\ (euclidean__axioms.Col Q B A))))) as H35.
------------------------- apply (@lemma__collinearorder.lemma__collinearorder A B Q H24).
------------------------- destruct H35 as [H36 H37].
destruct H37 as [H38 H39].
destruct H39 as [H40 H41].
destruct H41 as [H42 H43].
exact H36.
------------------------ assert (* Cut *) (euclidean__axioms.Col B A R) as H36.
------------------------- assert (* Cut *) ((euclidean__axioms.Col A B Q) /\ ((euclidean__axioms.Col A Q B) /\ ((euclidean__axioms.Col Q B A) /\ ((euclidean__axioms.Col B Q A) /\ (euclidean__axioms.Col Q A B))))) as H36.
-------------------------- apply (@lemma__collinearorder.lemma__collinearorder B A Q H35).
-------------------------- destruct H36 as [H37 H38].
destruct H38 as [H39 H40].
destruct H40 as [H41 H42].
destruct H42 as [H43 H44].
exact H32.
------------------------- assert (* Cut *) (euclidean__axioms.Col A R Q) as H37.
-------------------------- apply (@eq__ind__r euclidean__axioms.Point R (fun B0 => (euclidean__axioms.TS P A B0 C) -> ((euclidean__axioms.Col A B0 R) -> ((euclidean__axioms.Col A B0 S) -> ((euclidean__axioms.nCol A B0 P) -> ((~(A = B0)) -> ((euclidean__axioms.neq B0 A) -> ((euclidean__axioms.Col B0 R S) -> ((euclidean__axioms.Col R S B0) -> ((euclidean__axioms.Col S F B0) -> ((euclidean__axioms.Col S B0 A) -> ((euclidean__axioms.Col S B0 F) -> ((euclidean__axioms.Col A B0 F) -> ((euclidean__axioms.Col A B0 Q) -> ((euclidean__axioms.Col B0 Q R) -> ((euclidean__axioms.Col B0 R Q) -> ((euclidean__axioms.Col B0 R F) -> ((euclidean__axioms.Col B0 A R) -> ((euclidean__axioms.Col B0 A F) -> ((euclidean__axioms.Col B0 A Q) -> ((euclidean__axioms.Col B0 A R) -> (euclidean__axioms.Col A R Q)))))))))))))))))))))) with (x := B).
---------------------------intro H37.
intro H38.
intro H39.
intro H40.
intro H41.
intro H42.
intro H43.
intro H44.
intro H45.
intro H46.
intro H47.
intro H48.
intro H49.
intro H50.
intro H51.
intro H52.
intro H53.
intro H54.
intro H55.
intro H56.
exact H49.

--------------------------- exact H30.
--------------------------- exact H.
--------------------------- exact H2.
--------------------------- exact H7.
--------------------------- exact H8.
--------------------------- exact H15.
--------------------------- exact H16.
--------------------------- exact H17.
--------------------------- exact H18.
--------------------------- exact H20.
--------------------------- exact H21.
--------------------------- exact H22.
--------------------------- exact H23.
--------------------------- exact H24.
--------------------------- exact H25.
--------------------------- exact H26.
--------------------------- exact H27.
--------------------------- exact H32.
--------------------------- exact H33.
--------------------------- exact H35.
--------------------------- exact H36.
-------------------------- assert (* Cut *) (euclidean__axioms.Col R F Q) as H38.
--------------------------- apply (@euclidean__tactics.not__nCol__Col R F Q).
----------------------------intro H38.
apply (@euclidean__tactics.Col__nCol__False R F Q H38).
-----------------------------apply (@lemma__collinear4.lemma__collinear4 A R F Q H34 H37 H31).

--------------------------- assert (* Cut *) (euclidean__axioms.Col R Q F) as H39.
---------------------------- assert (* Cut *) ((euclidean__axioms.Col F R Q) /\ ((euclidean__axioms.Col F Q R) /\ ((euclidean__axioms.Col Q R F) /\ ((euclidean__axioms.Col R Q F) /\ (euclidean__axioms.Col Q F R))))) as H39.
----------------------------- apply (@lemma__collinearorder.lemma__collinearorder R F Q H38).
----------------------------- destruct H39 as [H40 H41].
destruct H41 as [H42 H43].
destruct H43 as [H44 H45].
destruct H45 as [H46 H47].
exact H46.
---------------------------- exact H39.
------------------- assert (* Cut *) (euclidean__axioms.Col R Q F) as H31.
-------------------- apply (@euclidean__tactics.not__nCol__Col R Q F).
---------------------intro H31.
apply (@euclidean__tactics.Col__nCol__False R Q F H31).
----------------------apply (@lemma__collinear4.lemma__collinear4 B R Q F H26 H27 H30).

-------------------- exact H31.
----------------- assert (* Cut *) (euclidean__axioms.Col F Q R) as H29.
------------------ assert (* Cut *) ((euclidean__axioms.Col Q R F) /\ ((euclidean__axioms.Col Q F R) /\ ((euclidean__axioms.Col F R Q) /\ ((euclidean__axioms.Col R F Q) /\ (euclidean__axioms.Col F Q R))))) as H29.
------------------- apply (@lemma__collinearorder.lemma__collinearorder R Q F H28).
------------------- destruct H29 as [H30 H31].
destruct H31 as [H32 H33].
destruct H33 as [H34 H35].
destruct H35 as [H36 H37].
exact H37.
------------------ assert (* Cut *) (euclidean__axioms.Col C F Q) as H30.
------------------- right.
right.
right.
right.
left.
exact H12.
------------------- assert (* Cut *) (euclidean__axioms.Col F Q C) as H31.
-------------------- assert (* Cut *) ((euclidean__axioms.Col F C Q) /\ ((euclidean__axioms.Col F Q C) /\ ((euclidean__axioms.Col Q C F) /\ ((euclidean__axioms.Col C Q F) /\ (euclidean__axioms.Col Q F C))))) as H31.
--------------------- apply (@lemma__collinearorder.lemma__collinearorder C F Q H30).
--------------------- destruct H31 as [H32 H33].
destruct H33 as [H34 H35].
destruct H35 as [H36 H37].
destruct H37 as [H38 H39].
exact H34.
-------------------- assert (* Cut *) (euclidean__axioms.neq F Q) as H32.
--------------------- assert (* Cut *) ((euclidean__axioms.neq F Q) /\ ((euclidean__axioms.neq C F) /\ (euclidean__axioms.neq C Q))) as H32.
---------------------- apply (@lemma__betweennotequal.lemma__betweennotequal C F Q H12).
---------------------- destruct H32 as [H33 H34].
destruct H34 as [H35 H36].
exact H33.
--------------------- assert (* Cut *) (euclidean__axioms.Col Q R C) as H33.
---------------------- apply (@euclidean__tactics.not__nCol__Col Q R C).
-----------------------intro H33.
apply (@euclidean__tactics.Col__nCol__False Q R C H33).
------------------------apply (@lemma__collinear4.lemma__collinear4 F Q R C H29 H31 H32).

---------------------- assert (* Cut *) (euclidean__axioms.Col R Q C) as H34.
----------------------- assert (* Cut *) ((euclidean__axioms.Col R Q C) /\ ((euclidean__axioms.Col R C Q) /\ ((euclidean__axioms.Col C Q R) /\ ((euclidean__axioms.Col Q C R) /\ (euclidean__axioms.Col C R Q))))) as H34.
------------------------ apply (@lemma__collinearorder.lemma__collinearorder Q R C H33).
------------------------ destruct H34 as [H35 H36].
destruct H36 as [H37 H38].
destruct H38 as [H39 H40].
destruct H40 as [H41 H42].
exact H35.
----------------------- apply (@euclidean__tactics.Col__nCol__False A B P H8).
------------------------apply (@euclidean__tactics.not__nCol__Col A B P).
-------------------------intro H35.
apply (@euclidean__tactics.Col__nCol__False R Q C H1 H34).

------------- assert (* Cut *) (euclidean__axioms.BetS Q F C) as H25.
-------------- apply (@euclidean__axioms.axiom__betweennesssymmetry C F Q H12).
-------------- assert (* Cut *) (euclidean__axioms.TS Q A B C) as H26.
--------------- exists F.
split.
---------------- exact H25.
---------------- split.
----------------- exact H23.
----------------- apply (@euclidean__tactics.nCol__notCol A B Q H24).
--------------- exact H26.
Qed.


Require Export Iron.Language.SystemF2Cap.Type.Exp.Base.
Require Export Iron.Language.SystemF2Cap.Type.Relation.EquivT.

(********************************************************************)
(* Type subsumptinon.
   The interesting cases all concern sums. *)
Inductive SubsT : kienv -> stprops -> ty -> ty -> ki -> Prop :=
 | SbEquiv
   :  forall  ke sp t1 t2 k
   ,  EquivT  ke sp t1 t2 k
   -> SubsT   ke sp t1 t2 k

 | SbTrans
   :  forall  ke sp t1 t2 t3 k
   ,  SubsT   ke sp t1 t2 k -> SubsT  ke sp t2 t3 k
   -> SubsT   ke sp t1 t3 k

 | SbBot
   :  forall  ke sp t k
   ,  SumKind k
   -> KindT   ke sp t k
   -> SubsT   ke sp t (TBot k) k

 | SbSumAbove
   :  forall  ke sp t1 t2 t3 k
   ,  SumKind k
   -> SubsT   ke sp t1 t2 k -> SubsT  ke sp t1 t3 k
   -> SubsT   ke sp t1 (TSum t2 t3) k

 | SbSumBelow
   :  forall  ke sp t1 t2 t3 k
   ,  SumKind k
   -> KindT   ke sp t3 k
   -> SubsT   ke sp t1 t2 k
   -> SubsT   ke sp (TSum t1 t3) t2 k

 | SbSumAboveLeft
   :  forall  ke sp t1 t2 t3 k
   ,  SumKind k
   -> SubsT   ke sp t1 (TSum t2 t3) k
   -> SubsT   ke sp t1 t2 k

 | SbSumAboveRight
   :  forall  ke sp t1 t2 t3 k
   ,  SumKind k
   -> SubsT   ke sp t1 (TSum t2 t3) k
   -> SubsT   ke sp t1 t3 k.

Hint Constructors SubsT.

(********************************************************************)
(* Kind projection *)
Lemma subsT_kind_left
 :  forall ke sp t1 t2 k
 ,  SubsT  ke sp t1 t2 k
 -> KindT  ke sp t1 k.
Proof.
 intros.
 induction H; eauto.
Qed.
Hint Resolve subsT_kind_left.

Lemma subsT_kind_right
 :  forall ke sp t1 t2 k
 ,  SubsT  ke sp t1 t2 k
 -> KindT  ke sp t2 k.
Proof.
 intros.
 induction H; eauto.
 - inverts IHSubsT. eauto.
 - inverts IHSubsT. eauto.
Qed.
Hint Resolve subsT_kind_right.

(* Sumkind projection *)
Lemma subsT_sumkind_left
 :  forall ke sp t1 t2 t3 k
 ,  SubsT  ke sp (TSum t1 t2) t3 k
 -> SumKind k.
Proof.
 intros.
 inverts H; eauto.
Qed.
Hint Resolve subsT_sumkind_left.

Lemma subsT_sumkind_right
 :  forall ke sp t1 t2 t3 k
 ,  SubsT  ke sp t1 (TSum t2 t3) k
 -> SumKind k.
Proof.
 intros.
 inverts H; eauto.
Qed.
Hint Resolve subsT_sumkind_right.

(* Subs/Equiv *)
Lemma subsT_equiv_above
 :  forall ke sp t1 t1' t2 k
 ,  EquivT ke sp t1  t1' k
 -> SubsT  ke sp t1  t2  k
 -> SubsT  ke sp t1' t2  k.
Proof.
 intros.
 eapply SbTrans with (t2 := t1); eauto.
Qed.
Hint Resolve subsT_equiv_above.

Lemma subsT_equiv_below
 :  forall ke sp t1 t2 t2' k
 ,  EquivT ke sp t2 t2' k
 -> SubsT  ke sp t1 t2  k
 -> SubsT  ke sp t1 t2' k.
Proof.
 intros.
 eapply SbTrans with (t1 := t1); eauto.
Qed.
Hint Resolve subsT_equiv_below.

(* Subs sum lemmas *)
Lemma subsT_sum_comm_below
 :  forall ke sp t1 t2 t3 k
 ,  SubsT  ke sp t1 (TSum t2 t3) k
 -> SubsT  ke sp t1 (TSum t3 t2) k.
Proof.
 intros.
 eapply subsT_equiv_below with (t2 := TSum t2 t3).
  have HK: (KindT ke sp (TSum t2 t3) k). inverts HK.
  eapply EqSumComm; eauto.
  auto.
Qed.
Hint Resolve subsT_sum_comm_below.

Lemma subsT_sum_comm_above
 :  forall ke sp t1 t2 t3 k
 ,  SubsT  ke sp (TSum t1 t2) t3 k
 -> SubsT  ke sp (TSum t2 t1) t3 k.
Proof.
 intros.
 eapply subsT_equiv_above with (t1 := TSum t1 t2).
  have HK: (KindT ke sp (TSum t1 t2) k). inverts HK.
  eapply EqSumComm; eauto.
  auto.
Qed.
Hint Resolve subsT_sum_comm_above.

Lemma subsT_sum_left
 : forall ke sp t1 t1' t2 k
 ,  SumKind k
 -> KindT  ke sp t2 k
 -> SubsT  ke sp t1 t1' k
 -> SubsT  ke sp (TSum t1 t2) (TSum t1' t2) k.
Proof.
 intros.
 eapply SbSumAbove; eauto.
Qed.
Hint Resolve subsT_sum_left.

Lemma subsT_sum_right
 :  forall ke sp t1 t2 t2' k
 ,  SumKind k
 -> KindT  ke sp t1 k
 -> SubsT  ke sp t2 t2' k
 -> SubsT  ke sp (TSum t1 t2) (TSum t1 t2') k.
Proof.
 intros.
 eapply SbSumAbove; eauto.
Qed.
Hint Resolve subsT_sum_right.

Lemma subsT_sum_merge
 :  forall ke sp t1 t1' t2 t2' k
 ,  SumKind k
 -> SubsT  ke sp t1 t1' k
 -> SubsT  ke sp t2 t2' k
 -> SubsT  ke sp (TSum t1 t2) (TSum t1' t2') k.
Proof.
 intros.
 eapply SbTrans with (t2 := TSum t1' t2); eauto.
Qed.
Hint Resolve subsT_sum_merge.

Lemma subsT_stprops_snoc
 :  forall ke sp p t1 t2 k
 ,  SubsT  ke sp        t1 t2 k
 -> SubsT  ke (p <: sp) t1 t2 k.
Proof.
 intros.
 induction H; eauto.
Qed.
Hint Resolve subsT_stprops_snoc.

Lemma subsT_stprops_app
 :  forall ke sp sp' t1 t2 k
 ,  SubsT ke sp          t1 t2 k
 -> SubsT ke (sp' >< sp) t1 t2 k.
Proof.
 intros. gen ke sp k.
 induction sp'; intros; snorm; auto.
 - rrwrite ((sp' :> a) >< sp = sp' >< (a <: sp)).
   snorm.
Qed.
Hint Resolve subsT_stprops_app.

Lemma subsT_stprops_extends
 :  forall ke sp sp' e1 e2 k
 ,  extends sp' sp
 -> SubsT ke sp  e1 e2 k
 -> SubsT ke sp' e1 e2 k.
Proof.
 intros.
 unfold extends in *.
 destruct H. subst.
 snorm.
Qed.

Lemma subsT_closed_kenv_cons
 :  forall sp t1 t2 k1 k2
 ,  SubsT nil sp t1 t2 k1
 -> SubsT (nil :> k2) sp t1 t2 k1.
Proof.
 intros.
 remember nil as KE.
 induction H; subst; eauto 4.

 - Case "SbBot".
   eapply SbBot; auto.
   have (ClosedT t).
   destruct k2 as [o2 k2].
   lets D: kind_kienv_weaken o2 k2 H0.
   rrwrite (liftTT 1 0 t = t).
   eauto.

 - Case "SbSumAbove".
   eapply SbSumBelow; auto.
   have (ClosedT t3).
   destruct k2 as [o2 k2].
   lets D: kind_kienv_weaken o2 k2 H0.
   rrwrite (liftTT 1 0 t3 = t3).
   eauto.
Qed.
Hint Resolve subsT_closed_kenv_cons.


Require Import Blech.Defaults.

Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.SetoidClass.

Require Import Blech.Bishop.
Require Import Blech.Monoid.

Require Import Psatz.

Import BishopNotations.
Import MonoidNotations.

Open Scope bishop_scope.
Open Scope monoid_scope.

#[program]
Definition Circle: Monoid := {|
  S := type nat ;

  e := 0 ;
  app f g := f + g ;
|}.

Solve All Obligations with cbn; lia.

Module CircleNotations.
  Notation "S¹₊" := Circle.
End CircleNotations.


Set Implicit Arguments.

Require Import
        Discrete.DiscreteType
        Finite.FinType
        Tactics.Tactics.

Import ListNotations.

Lemma option_enum_sound (A : finType) x :
  count (to_option_list (elem A)) x = 1.
Proof.
  destruct x.
  +
    rewrite count_option_list. apply enum_sound.
  +
    apply count_option_list_none.
Qed.

Instance FinTypeC_Option(A : finType): FinTypeC (?? A).
Proof.
  econstructor.  apply option_enum_sound.
Defined.

Canonical Structure FinType_Option (A : finType) := FinType (?? A).

Notation " ? F" := (FinType_Option F) (at level 39).

Lemma cardinality_option (A : finType) : Cardinality (? A) = 1 + (Cardinality A).
Proof.
  cbn. now rewrite map_length.
Qed.


Require Import Coq.Logic.Classical_Prop.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Relations.Relation_Definitions.
Require Import Logic.lib.Coqlib.
Require Import Logic.lib.Ensembles_ext.
Require Import Coq.Logic.ProofIrrelevance.
Require Import Coq.omega.Omega.
Require Import Logic.lib.Bijection.
Require Import Logic.lib.Countable.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.ModelClass.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.GeneralLogic.Semantics.Kripke.
Require Import Logic.GeneralLogic.Complete.ContextProperty.
Require Import Logic.GeneralLogic.Complete.ContextProperty_Kripke.
Require Import Logic.GeneralLogic.Complete.Lindenbaum.
Require Import Logic.GeneralLogic.Complete.Lindenbaum_Kripke.
Require Import Logic.GeneralLogic.Complete.Canonical_Kripke.
Require Import Logic.GeneralLogic.Complete.Complete_Kripke.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.ProofTheory.Minimum.
Require Import Logic.MinimumLogic.ProofTheory.RewriteClass.
Require Import Logic.MinimumLogic.Semantics.Kripke.
Require Import Logic.MinimumLogic.Complete.ContextProperty_Kripke.
Require Import Logic.MinimumLogic.Complete.Lindenbaum_Kripke.
Require Import Logic.MinimumLogic.Complete.Truth_Kripke.
Require Import Logic.MinimumLogic.Complete.Complete.
Require Import Logic.PropositionalLogic.Semantics.Kripke.
Require Import Logic.PropositionalLogic.Complete.Lindenbaum_Kripke.
Require Import Logic.PropositionalLogic.Complete.Truth_Kripke.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.SeparationLogic.ProofTheory.SeparationLogic.
Require Import Logic.SeparationLogic.ProofTheory.TheoryOfSeparationAxioms.
Require Import Logic.SeparationLogic.Model.SeparationAlgebra.
Require Import Logic.SeparationLogic.Model.OrderedSA.
Require Import Logic.SeparationLogic.Semantics.WeakSemantics.
Require Import Logic.SeparationLogic.Complete.ContextProperty_Flat.
Require Import Logic.SeparationLogic.Complete.Lindenbaum_Flat.
Require Import Logic.SeparationLogic.Complete.Truth_Flat.
Require Import Logic.SeparationLogic.Complete.Canonical_Flat.
Require Import Logic.SeparationLogic.Semantics.FlatSemantics.
Require Import Logic.SeparationLogic.DeepEmbedded.MinimumSeparationLogic_LibSupport.

Import KripkeModelFamilyNotation.
Import KripkeModelNotation_Intuitionistic.

(***** Language *****)

Inductive expr: Type :=
  | impp : expr -> expr -> expr
  | andp : expr -> expr -> expr
  | sepcon : expr -> expr -> expr
  | varp : nat -> expr.

Declare Scope local_syntax.
Local Open Scope local_syntax.

Notation "x --> y" := (impp x y) (at level 55, right associativity) : local_syntax.
Notation "x && y" := (andp x y) (at level 40, left associativity) : local_syntax.
Notation "x * y" := (sepcon x y) (at level 40, left associativity) : local_syntax.

(***** Proof Theory *****)

Inductive provable: expr -> Prop :=
| modus_ponens: forall x y, provable (x --> y) -> provable x -> provable y
| axiom1: forall x y, provable (x --> (y --> x))
| axiom2: forall x y z, provable ((x --> y --> z) --> (x --> y) --> (x --> z))
| andp_intros: forall x y, provable (x --> y --> x && y)
| andp_elim1: forall x y, provable (x && y --> x)
| andp_elim2: forall x y, provable (x && y --> y)
| sepcon_comm_impp: forall x y, provable (x * y --> y * x)
| sepcon_assoc1: forall x y z, provable (x * (y * z) --> (x * y) * z)
| sepcon_mono: forall x1 x2 y1 y2,
    provable (x1 --> x2) -> provable (y1 --> y2) -> provable ((x1 * y1) --> (x2 * y2)).

(***** Semantics *****)

Record frame: Type := {
  underlying_set:> Type;
  underlying_relation: relation underlying_set;
  underlying_join: Join underlying_set
}.

Declare Scope TheKripkeSemantics.
Infix "<=" := (underlying_relation _): TheKripkeSemantics.

Local Open Scope TheKripkeSemantics.

Definition sem (f: frame) := @Ensemble (underlying_set f).

Definition denotation (F: frame) (eval: nat -> sem F): expr -> sem F :=
  fix denotation (x: expr): sem F:=
  match x with
  | impp y z => @Semantics.impp F (underlying_relation F) (denotation y) (denotation z)
  | andp y z => @Semantics.andp F (denotation y) (denotation z)
  | sepcon y z => @WeakSemantics.sepcon F (underlying_join F) (denotation y) (denotation z)
  | varp p => eval p
  end.

Record Kmodel : Type := {
  underlying_frame :> frame;
  sem_var: nat -> sem underlying_frame
}.

Record model: Type := {
  underlying_model :> Kmodel;
  elm: underlying_model
}.

Record well_formed (m: Kmodel): Prop := {
  WF_Monotonic:
    forall v: nat, @upwards_closed_Kdenote _ (underlying_relation m) (sem_var m v);
  WF_PreOrder:
    PreOrder (@Krelation _ (underlying_relation m));
  WF_SeparationAlgebra:
    @SeparationAlgebra _ (underlying_join m);
  WF_UpwardsClosed:
    @UpwardsClosedSeparationAlgebra _ (underlying_relation m) (underlying_join m);
  WF_DownwardsClosed:
    @DownwardsClosedSeparationAlgebra _ (underlying_relation m) (underlying_join m)
}.

Definition satisfy (m: model) (x: expr): Prop :=
  denotation m (sem_var m) x (elm m).

Definition valid (x: expr): Prop :=
  forall m: model, well_formed m -> satisfy m x.

Definition sound: Prop := forall x, provable x -> valid x.

Definition complete: Prop := forall x, valid x -> provable x.

(***** Auxiliary *****)

Module Lang <: LanguageSig.
  Definition expr := expr.
  Definition context := expr -> Prop.
  Definition provable := provable.
  Definition impp := impp.
  Definition andp := andp.
  Definition sepcon := sepcon.
End Lang.

Module Rule <: PrimitiveRuleSig Lang.
Include DerivedNames Lang.
Definition modus_ponens := modus_ponens.
Definition axiom1 := axiom1.
Definition axiom2 := axiom2.
Definition andp_intros := andp_intros.
Definition andp_elim1 := andp_elim1.
Definition andp_elim2 := andp_elim2.
Definition sepcon_comm_impp := sepcon_comm_impp.
Definition sepcon_assoc1 := sepcon_assoc1.
Definition sepcon_mono := sepcon_mono.
End Rule.

Module Theorems := LogicTheorem Lang Rule.

Instance MD: Model :=
  Build_Model model.

Instance kMD: KripkeModel MD :=
  Build_KripkeModel _
    Kmodel
    (fun M => M)
    (fun M m => Build_model M m).

Instance SM: Semantics Theorems.L MD :=
  Build_Semantics Theorems.L MD (fun x m => denotation m (sem_var m) x (elm m)).

Instance R (M: Kmodel): Relation (Kworlds M) :=
  @underlying_relation M.

Instance J (M: Kmodel): Join (Kworlds M) :=
  @underlying_join M.

Instance kminSM (M: Kmodel): KripkeMinimumSemantics Theorems.L MD M SM.
Proof.
  constructor.
  intros; apply Same_set_refl.
Qed.

Instance andpSM (M: Kmodel): KripkeAndSemantics Theorems.L MD M SM.
Proof.
  constructor.
  intros; apply Same_set_refl.
Qed.

Instance fsepconSM (M: Kmodel): SepconSemantics Theorems.L MD M SM.
Proof.
  hnf; intros; apply Same_set_refl.
Qed.

Definition Kmodel_Monotonic: Kmodel -> Prop := fun M =>
  forall v: nat, upwards_closed_Kdenote (sem_var M v).

Definition Kmodel_PreOrder: Kmodel -> Prop := fun M =>
  PreOrder (@Krelation _ (R M)).

Definition Kmodel_SeparationAlgebra: Kmodel -> Prop := fun M =>
  SeparationAlgebra (Kworlds M).

Definition Kmodel_UpwardsClosed: Kmodel-> Prop := fun M =>
  UpwardsClosedSeparationAlgebra (Kworlds M).

Definition Kmodel_DownwardsClosed: Kmodel -> Prop := fun M =>
  DownwardsClosedSeparationAlgebra (Kworlds M).

(***** Completeness *****)

Section Complete.

Import KripkeModelFamilyNotation.
Import KripkeModelNotation_Intuitionistic.
Import KripkeModelClass.
Local Open Scope logic_base.
Local Open Scope kripke_model.
Local Open Scope kripke_model_class.

Context {CV: Countable expr}.

Definition cP : context -> Prop :=
  derivable_closed.

Lemma AL_DC: at_least derivable_closed cP.
Proof. solve_at_least. Qed.

Lemma LIN_CD: forall x: expr, Lindenbaum_constructable (cannot_derive x) cP.
Proof.
  intros.
  apply Lindenbaum_constructable_suffice; auto.
  + apply Lindenbaum_preserves_cannot_derive.
  + unfold cP.
    repeat apply Lindenbaum_ensures_by_conjunct.
    apply Lindenbaum_cannot_derive_ensures_derivable_closed.
Qed.

Lemma LIN_SL: forall (Phi: context) (Psi: sig cP), Lindenbaum_constructable (context_sepcon_included_l Phi (proj1_sig Psi)) cP.
Proof.
  intros.
  apply Lindenbaum_constructable_suffice; auto.
  + apply Lindenbaum_preserves_context_sepcon_included_l.
  + unfold cP.
    repeat apply Lindenbaum_ensures_by_conjunct.
    apply Lindenbaum_context_sepcon_included_l_ensures_derivable_closed.
Qed.

Lemma LIN_SR: forall (Phi: context) (Psi: sig cP), Lindenbaum_constructable (context_sepcon_included_r Phi (proj1_sig Psi)) cP.
Proof.
  intros.
  eapply Lindenbaum_constructable_Same_set.
  + symmetry.
    apply context_sepcon_included_equiv.
    apply AL_DC, (proj2_sig Psi).
  + apply LIN_SL.
Qed.

Definition canonical_frame: frame :=
  Build_frame (sig cP)
    (fun a b => Included _ (proj1_sig a) (proj1_sig b))
    (fun a b c => Included _ (context_sepcon (proj1_sig a) (proj1_sig b)) (proj1_sig c)).

Definition canonical_eval: nat -> sem canonical_frame :=
  fun p a => proj1_sig a (varp p).

Definition canonical_Kmodel: @Base.Kmodel MD kMD :=
  Build_Kmodel canonical_frame canonical_eval.

Definition rel: bijection (Kworlds canonical_Kmodel) (sig cP) := bijection_refl.

Definition H_R:
  forall m n Phi Psi, rel m Phi -> rel n Psi ->
    (m <= n <-> Included _ (proj1_sig Phi) (proj1_sig Psi)).
Proof.
  intros.
  change (m = Phi) in H.
  change (n = Psi) in H0.
  subst; reflexivity.
Qed.

Definition H_J:
  forall m1 m2 m Phi1 Phi2 Phi, rel m1 Phi1 -> rel m2 Phi2 -> rel m Phi ->
    (join m1 m2 m <-> Included _ (context_sepcon (proj1_sig Phi1) (proj1_sig Phi2)) (proj1_sig Phi)).
Proof.
  intros.
  change (m = Phi) in H1.
  change (m1 = Phi1) in H.
  change (m2 = Phi2) in H0.
  subst; reflexivity.
Qed.

Lemma TRUTH:
  forall x: expr , forall m Phi, rel m Phi ->
    (KRIPKE: canonical_Kmodel, m |= x <-> proj1_sig Phi x).
Proof.
  induction x.
  + exact (truth_lemma_impp cP rel H_R AL_DC LIN_CD x1 x2 IHx1 IHx2).
  + exact (truth_lemma_andp cP rel AL_DC x1 x2 IHx1 IHx2).
  + exact (truth_lemma_sepcon cP rel H_J AL_DC LIN_SL LIN_SR x1 x2 IHx1 IHx2).
  + intros; change (m = Phi) in H; subst; reflexivity.
Qed.

Theorem completeness: complete.
Proof.
  assert (Same_set model well_formed (KripkeModelClass _ well_formed)).
  {
    apply (@KripkeModelClass_ModelClass_Same_set_spec MD).
    intros.
    destruct m as [M w].
    simpl.
    split; intros; [eauto |].
    destruct H as [? [? [? ?]]].
    inversion H0.
    subst; auto.
  }
  pose proof @strongly_complete_strong _ _ _ _ _ _ well_formed.
  pose proof @general_completeness _ _ _ _ _ canonical_Kmodel _ well_formed cP rel LIN_CD TRUTH.
  apply H0.
  rewrite H.
  apply H1.
  clear H H0 H1.
  constructor.
  + hnf; intros.
    exact (denote_monotonic cP rel H_R
             (varp v)
             (TRUTH (varp v))).
  + exact (po_R cP rel H_R).
  + exact (SA cP rel H_J AL_DC LIN_SR).
  + exact (uSA cP rel H_R H_J AL_DC).
  + exact (dSA cP rel H_R H_J AL_DC).
Qed.

End Complete.


(*

   Benedikt Ahrens and Régis Spadotti

   Terminal semantics for codata types in intensional Martin-Löf type theory

   http://arxiv.org/abs/1401.1053

*)

(*

  Content of this file:

  definition of the category of coalgebras for the signature of infinite tri. matrices

*)

Require Import Category.Types.
Require Import Category.Setoids.
Require Import Category.Types_Setoids.
Require Import Category.RComod.
Require Import Category.RComonadWithCut.
Require Import Theory.Category.
Require Import Theory.Functor.
Require Import Theory.RelativeComonadWithCut.
Require Import Theory.Comodule.
Require Import Theory.Product.
Require Import Theory.PrecompositionWithProduct.
Require Import Theory.PushforwardComodule.

Generalizable All Variables.

(*------------------------------------------------------------------------------
  -- ＣＡＴＥＧＯＲＹ  ＯＦ  ＴＲＩＡＮＧＬＥＳ
  ----------------------------------------------------------------------------*)
(** * Category of triangular matrices **)

(** ** Object and morphism definitions **)
Module TriMat.

  Structure Obj (E : 𝑻𝒚𝒑𝒆) : Type := mkObj
  { T         :>  𝑹𝑪𝒐𝒎𝒐𝒏𝒂𝒅𝑾𝒊𝒕𝒉𝑪𝒖𝒕 𝑬𝑸 E
  ; rest      :>  [T] ⇒ [T][E×─]
  ; rest_cut  :   ∀ {A}, rest(A) ∘ T⋅cut ≈ T⋅cut ∘ rest(E × A) }.

  Arguments mkObj     {_ _ _} _.
  Arguments T         {_} _.
  Arguments rest      {_} _.
  Arguments rest_cut  {_} _ {_ _ _ _}.

  Notation "'TriMat.make' ⦃ 'T' ≔ T ; 'rest' ≔ rest ⦄" :=
           (@mkObj _ T rest _) (only parsing).

  Structure Morphism {E} (T S : Obj E) : Type := mkMorphism
  { τ           :> T ⇒ S
  ; τ_commutes  : ⟨τ⟩［E×─］ ∘ Φ ∘ τ⁎⋅T ≈ S ∘ ⟨τ⟩ }.

  Arguments mkMorphism  {_ _ _ _} _.
  Arguments τ           {_ _ _} _.
  Arguments τ_commutes  {_ _ _} _ {_ _ _ _}.

  Notation "'TriMat.make' ⦃ 'τ' ≔ τ ⦄" := (@mkMorphism _ _ _ τ _) (only parsing).

  Program Definition Hom {E} (T S : Obj E) : Setoid :=
    Setoid.make   ⦃ Carrier  ≔ Morphism T S
                  ; Equiv    ≔ (λ g f ∙ g ≈ f) ⦄.
  (** equivalence **)
  Next Obligation.
    constructor.
    - repeat intro. now rewrite H.
    - repeat intro. symmetry; now rewrite H.
    - repeat intro; etransitivity; eauto. now apply H0.
  Qed.

End TriMat.

Export TriMat.

(** ** Identity and compositon definitions **)

Section Defs.

  Variable (E : 𝑻𝒚𝒑𝒆).

  Implicit Types (T S R U : Obj E).

  Infix "⇒" := Hom.

  Program Definition id {T} : T ⇒ T :=
    TriMat.make ⦃ τ ≔ id[T] ⦄.
  (** τ-cong **)
  Next Obligation.
    now rewrite H.
  Qed.

  Obligation Tactic := idtac.
  Program Definition compose {T S R} : [ S ⇒ R ⟶ T ⇒ S ⟶ T ⇒ R ] :=
    λ g f ↦₂ TriMat.make ⦃ τ ≔ g ∘ f ⦄.
  (** τ-commutes **)
  Next Obligation.
    intros T S R g f.
    destruct g as [g g_commutes]. simpl in g_commutes.
    destruct f as [f f_commutes]. simpl in f_commutes. simpl.
    intros.
    rewrite H.
    etransitivity.
    eapply Setoids.cong.
    apply f_commutes.
    reflexivity.
    apply g_commutes.
    reflexivity.
  Qed.
  (** τ-cong **)
  Next Obligation.
    repeat intro.
    simpl.
    etransitivity. eapply Setoids.cong.
    eapply Setoids.cong. apply H1.
    etransitivity. eapply Setoids.cong.
    apply H0. reflexivity.
    apply H.
    reflexivity.
  Qed.

  Infix "∘" := compose.

  Lemma left_id : ∀ T S (f : T ⇒ S), id ∘ f ≈ f.
  Proof.
    intros. simpl. intros. rewrite H.
    reflexivity.
  Qed.

  Lemma right_id : ∀ T S (f : T ⇒ S), f ∘ id ≈ f.
  Proof.
    repeat intro. simpl. now rewrite H.
  Qed.

  Lemma compose_assoc T R S U (f : T ⇒ R) (g : R ⇒ S) (h : S ⇒ U) : h ∘ g ∘ f ≈ h ∘ (g ∘ f).
  Proof.
    repeat intro.
    simpl. now rewrite H.
  Qed.

  Canonical Structure 𝑻𝒓𝒊𝑴𝒂𝒕 : Category :=
    mkCategory left_id right_id compose_assoc.

End Defs.