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

If a category C is small and has binary products then yoneda of any object is
tiny, that is, exponentiation by it has a right adjoint in the presheaf
category on C ([is_left_adjoint_exp_yoneda]).

The proof closely follows the one on page 10 of:

Internal Universes in Models of Homotopy Type Theory (2018)
Daniel R. Licata, Ian Orton, Andrew M. Pitts, Bas Spitters
https://arxiv.org/abs/1801.07664

In order to show that the exponential functor Yon(c) ⇒ _ has a right adjoint
we show that it is isomorphic to the functor given by precomposition by the
product functor c × _. The precomposition functor always has a right adjoint
given by right Kan extension. This isomorphism is constructed by a chain of
four isomorphisms at the set level. These are then lifted to an isomorphism
on the level of functors using that they are all natural.

We show that the exponential and precomposition with product functors are
isomorphic by the isomorphisms

 (Yon(c) → F) x ≅ Ĉ(Yon(x), Yon(c) → F)
                ≅ Ĉ(Yon(c) × Yon(x), F)
                ≅ Ĉ(Yon(c × x), F)
                ≅ ((c × _)* F) x

which are all natural in both F and x. This gives an isomorphism of the
functors. We show each functor isomorphism separately.

The three functors in the middle are denoted Fun1, Fun2 and Fun3 respectively.

Written by: Elisabeth Bonnevier, 2019

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

Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.limits.binproducts.
Require Import UniMath.CategoryTheory.exponentials.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.opp_precat.
Require Import UniMath.CategoryTheory.FunctorCategory.
Require Import UniMath.CategoryTheory.RightKanExtension.
Require Import UniMath.CategoryTheory.Adjunctions.Core.
Require Import UniMath.CategoryTheory.yoneda.
Require Import UniMath.CategoryTheory.YonedaBinproducts.
Require Import UniMath.CategoryTheory.categories.HSET.Core.
Require Import UniMath.CategoryTheory.categories.HSET.Limits.
Require Import UniMath.CategoryTheory.categories.HSET.Structures.
Require Import UniMath.CategoryTheory.categories.HSET.MonoEpiIso.
Require Import UniMath.CategoryTheory.limits.graphs.limits.
Require Import UniMath.CategoryTheory.Presheaf.

Local Open Scope cat.

Section tiny_object_preshv.

Context {C : category} (PC : BinProducts C) (c : C).

Let prod_functor_c : functor C C := constprod_functor1 PC c.

Let Yon {C : category} : C ⟶ PreShv C := yoneda C.

Definition precomp_prod_functor : functor (PreShv C) (PreShv C).
Proof.
  use pre_composition_functor.
  apply functor_opp.
  exact prod_functor_c.
Defined.

Lemma precomp_prod_functor_has_right_adjoint : is_left_adjoint precomp_prod_functor.
Proof.
  apply RightKanExtension_from_limits.
  apply LimsHSET.
Defined.

Definition PreShv_exponentials : Exponentials (@BinProducts_PreShv C).
Proof.
  apply Exponentials_functor_HSET.
Defined.

Definition exp (F : PreShv C) : functor (PreShv C) (PreShv C) :=
  pr1 (PreShv_exponentials F).

(** The first isomorphism. Follows from the yoneda lemma. *)
Definition Fun1_functor_data : functor_data (PreShv C) (PreShv C).
Proof.
  use make_functor_data.
  - intro F.
    use functor_composite.
    + exact (PreShv C)^op.
    + use functor_opp.
      exact Yon.
    + exact (yoneda _ ((exp (Yon c)) F)).
  - intros F G α.
    use make_nat_trans.
    + intros X f.
      exact (f · (# (exp (Yon c)) α)).
    + intros X Y f.
      use funextsec; intro h.
      use assoc'.
Defined.

Lemma is_functor_Fun1 : is_functor Fun1_functor_data.
Proof.
  split;
    [ intro F | intros F G H α β ];
    use (nat_trans_eq has_homsets_HSET); intro X;
    use funextsec; intro f;
    [ set (idax := id_right f);
      rewrite <- (functor_id (exp (Yon c)) F) in idax;
      use idax
    | set (compax := assoc f (# (exp (Yon c)) α) (# (exp (Yon c)) β));
      rewrite <- (functor_comp (exp (Yon c)) α β) in compax;
      use compax ].
Qed.

Definition Fun1 : functor (PreShv C) (PreShv C) :=
  make_functor _ is_functor_Fun1.

Lemma first_iso_on_sets (F : PreShv C) (x : C) :
  z_iso (pr1 (Fun1 F) x) (pr1 ((exp (Yon c)) F) x).
Proof.
  use hset_equiv_z_iso.
  use yoneda_weq.
Defined.

Lemma first_iso_nat_in_x (F : PreShv C) :
  is_nat_trans (pr1 (Fun1 F)) _ (λ x, first_iso_on_sets F x).
Proof.
  use is_natural_yoneda_iso.
Qed.

Lemma first_iso_nat_in_F:
  is_nat_trans Fun1 (exp (Yon c))
    (λ F, make_nat_trans (pr1 (Fun1 F)) _ (first_iso_on_sets F) (first_iso_nat_in_x F)).
Proof.
  intros X Y f.
  apply (nat_trans_eq has_homsets_HSET); intros x.
  apply funextsec; intros g.
  apply (nat_trans_eq has_homsets_HSET); intros y.
  now apply funextsec.
Qed.

Lemma first_iso_on_functors : @z_iso [PreShv C, PreShv C] (exp (Yon c)) Fun1.
Proof.
  use z_iso_inv_from_z_iso.
  use make_PreShv_functor_z_iso.
  - intros F x.
    use first_iso_on_sets.
  - intro F.
    use first_iso_nat_in_x.
  - use first_iso_nat_in_F.
Defined.

(** The second isomorphism. Follows from the fact that the exponential functor
is right adjoint to the product functor. *)
Definition Fun2_functor_data : functor_data (PreShv C) (PreShv C).
Proof.
  use make_functor_data.
    - intro F.
      use functor_composite.
      + exact (PreShv C)^op.
      + use functor_opp.
        use functor_composite.
        * exact (PreShv C).
        * exact Yon.
        * exact (constprod_functor1 (@BinProducts_PreShv C) (Yon c)).
      + exact (Yon F).
    - intros F G α.
      use make_nat_trans.
      + intros X f.
        exact (f · α).
      + intros X Y f.
        use funextsec; intro g.
        use assoc'.
Defined.

Lemma is_functor_Fun2 : is_functor Fun2_functor_data.
Proof.
  split;
    [ intro F | intros F G H α β ];
    use (nat_trans_eq has_homsets_HSET); intro X;
    use funextsec; intro f;
    [ use id_right | use assoc ].
Qed.

Definition Fun2 : functor (PreShv C) (PreShv C) := make_functor _ is_functor_Fun2.

Lemma second_iso_on_sets (F : PreShv C) (x : C) :
  z_iso (pr1 (Fun1 F) x) (pr1 (Fun2 F) x).
Proof.
  use hset_equiv_z_iso.
  use invweq.
  use (adjunction_hom_weq (pr2 (PreShv_exponentials (Yon c)))).
Defined.

Lemma second_iso_nat_in_x (F : PreShv C) :
  is_nat_trans (pr1 (Fun1 F)) (pr1 (Fun2 F)) (λ x, second_iso_on_sets F x).
Proof.
  intros X Y f.
  apply funextsec; intro g.
  apply (nat_trans_eq has_homsets_HSET); intro.
  apply funextsec; intro.
  apply maponpaths; apply idpath.
Qed.

Lemma second_iso_nat_in_F :
  is_nat_trans Fun1 Fun2
               (λ F, make_nat_trans (pr1 (Fun1 F)) (pr1 (Fun2 F))
                                    (second_iso_on_sets F) (second_iso_nat_in_x F)).
Proof.
  intros X Y f.
  apply (nat_trans_eq has_homsets_HSET); intro.
  apply funextsec; intros g.
  apply (nat_trans_eq has_homsets_HSET); intro.
  apply funextsec; intros h.
  apply (maponpaths (pr1 f x0)).
  apply (maponpaths (pr1 (pr1 g x0 (pr2 h)) x0)).
  now apply pathsdirprod; [use id_left|].
Qed.

Lemma second_iso_on_functors : @z_iso [PreShv C, PreShv C] Fun1 Fun2.
Proof.
  use make_PreShv_functor_z_iso.
  - intros F x.
    use second_iso_on_sets.
  - intro F.
    use second_iso_nat_in_x.
  - use second_iso_nat_in_F.
Defined.

(** The third isomorphism. Follows from the fact that the Yoneda functor
commutes with binary products. *)
Definition Fun3_functor_data : functor_data (PreShv C) (PreShv C).
Proof.
  use make_functor_data.
  - intro F.
    use functor_composite.
    + exact (PreShv C)^op.
    + use functor_opp.
      use functor_composite.
      * exact C.
      * exact (constprod_functor1 PC c).
      * exact Yon.
    + use Yon; apply F.
  - intros F G α.
    use make_nat_trans.
    + intros X f.
      exact (f · α).
    + intros X Y f.
      use funextsec; intro g.
      use assoc'.
Defined.

Lemma is_functor_Fun3 : is_functor Fun3_functor_data.
Proof.
   split;
    [ intro F | intros F G H α β ];
    use (nat_trans_eq has_homsets_HSET); intro X;
    use funextsec; intro f;
    [ use id_right | use assoc ].
Qed.

Definition Fun3 : functor (PreShv C) (PreShv C) := make_functor _ is_functor_Fun3.

Lemma third_iso_on_sets (F : PreShv C) (x : C) : z_iso (pr1 (Fun2 F) x) (pr1 (Fun3 F) x).
Proof.
  use hset_equiv_z_iso.
  use iso_comp_right_weq.
  use iso_yoneda_binproducts.
Defined.

Lemma third_iso_nat_in_x (F : PreShv C) :
  is_nat_trans (pr1 (Fun2 F)) (pr1 (Fun3 F)) (λ x, third_iso_on_sets F x).
Proof.
  intros X Y f.
  apply funextsec; intro g.
  apply (nat_trans_eq has_homsets_HSET); intros x.
  apply funextsec; intros y.
  apply (maponpaths (pr1 g x)), pathsdirprod; cbn;
  unfold yoneda_morphisms_data, BinProduct_of_functors_mor; cbn.
  - now rewrite <- assoc, (BinProductOfArrowsPr1 _ (PC c X) (PC c Y)), id_right.
  - now rewrite <- !assoc, (BinProductOfArrowsPr2 _ (PC c X) (PC c Y)).
Qed.

Lemma third_iso_nat_in_F :
  is_nat_trans Fun2 Fun3
               (λ F, make_nat_trans (pr1 (Fun2 F)) (pr1 (Fun3 F))
                                    (third_iso_on_sets F) (third_iso_nat_in_x F)).
Proof.
  intros X Y f.
  apply (nat_trans_eq has_homsets_HSET); intro.
  apply funextsec; intros g.
  apply (nat_trans_eq has_homsets_HSET); intro.
  apply funextsec; intros h.
  apply maponpaths; apply idpath.
Qed.

Lemma third_iso_on_functors : @z_iso [PreShv C, PreShv C] Fun2 Fun3.
Proof.
  use make_PreShv_functor_z_iso.
  - intros F x.
    use third_iso_on_sets.
  - intro F.
    use third_iso_nat_in_x.
  - use third_iso_nat_in_F.
Defined.

(** The fourth isomorphism. Follows from the yoneda lemma. *)
Lemma fourth_iso_on_sets (F : PreShv C) (x : C) :
  z_iso (pr1 (Fun3 F) x) (pr1 (precomp_prod_functor F) x).
Proof.
  use hset_equiv_z_iso.
  use yoneda_weq.
Defined.

Lemma fourth_iso_nat_in_x (F : PreShv C) :
  is_nat_trans (pr1 (Fun3 F)) _ (λ x, fourth_iso_on_sets F x).
Proof.
  intros X Y f.
  use (is_natural_yoneda_iso _ _ _ _  (BinProduct_of_functors_mor _ _ PC _ _ _ _ _)).
Qed.

Lemma fourth_iso_nat_in_F:
  is_nat_trans Fun3 precomp_prod_functor
    (λ F, make_nat_trans (pr1 (Fun3 F)) _ (fourth_iso_on_sets F) (fourth_iso_nat_in_x F)).
Proof.
  intros X Y f.
  apply (nat_trans_eq has_homsets_HSET); intro.
  apply funextsec; intros g.
  apply idpath.
Qed.

Lemma fourth_iso_on_functors : @z_iso [(PreShv C), (PreShv C)] Fun3 precomp_prod_functor.
Proof.
  use make_PreShv_functor_z_iso.
  - intros F x.
    use fourth_iso_on_sets.
  - intro F.
    use fourth_iso_nat_in_x.
  - use fourth_iso_nat_in_F.
Defined.

(** The exponential functor and the precomposition functor are isomorphic. *)
Lemma iso_exp_precomp_prod_functor : @z_iso [PreShv C, PreShv C] precomp_prod_functor (exp (Yon c)).
Proof.
  use z_iso_inv_from_z_iso.
  use (z_iso_comp first_iso_on_functors).
  use (z_iso_comp second_iso_on_functors).
  use (z_iso_comp third_iso_on_functors).
  use fourth_iso_on_functors.
Defined.

(** The exponential functor has a right adjoint. *)
Theorem is_left_adjoint_exp_yoneda : is_left_adjoint (exp (Yon c)).
Proof.
  use is_left_adjoint_z_iso.
  - exact precomp_prod_functor.
  - use iso_exp_precomp_prod_functor.
  - use precomp_prod_functor_has_right_adjoint.
Defined.

End tiny_object_preshv.


(**
 Properties of projection functions

 Contents:
 1. First projection is a Street fibration
 2. First projection is a Street opfibration
 *)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Morphisms.InternalStreetFibration.
Require Import UniMath.Bicategories.Morphisms.InternalStreetOpFibration.
Require Import UniMath.Bicategories.Limits.Products.
Import Products.Notations.

Local Open Scope cat.

(**
 1. First projection is a Street fibration
 *)
Section ProjectionSFib.
  Context {B : bicat_with_binprod}
          (b₁ b₂ : B).

  Section InvertibleToCartesian.
    Context {a : B}
            {f g : a --> b₁ ⊗ b₂}
            (α : f ==> g)
            (Hα : is_invertible_2cell (α ▹ π₂)).

    Definition invertible_to_cartesian_unique
               (h : a --> b₁ ⊗ b₂)
               (β : h ==> g)
               (δp : h · π₁ ==> f · π₁)
               (q : β ▹ π₁ = δp • (α ▹ π₁))
      : isaprop (∑ (δ : h ==> f), δ ▹ π₁ = δp × δ • α = β).
    Proof.
      use invproofirrelevance.
      intros φ₁ φ₂.
      use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ].
      use binprod_ump_2cell_unique_alt.
      - apply (pr2 B).
      - exact (pr12 φ₁ @ !(pr12 φ₂)).
      - use (vcomp_rcancel _ Hα).
        rewrite !rwhisker_vcomp.
        apply maponpaths.
        exact (pr22 φ₁ @ !(pr22 φ₂)).
    Qed.

    Definition invertible_to_cartesian
      : is_cartesian_2cell_sfib π₁ α.
    Proof.
      intros h β δp q.
      use iscontraprop1.
      - exact (invertible_to_cartesian_unique h β δp q).
      - simple refine (_ ,, _ ,, _).
        + use binprod_ump_2cell.
          * apply (pr2 B).
          * exact δp.
          * exact (β ▹ _ • Hα^-1).
        + apply binprod_ump_2cell_pr1.
        + use binprod_ump_2cell_unique_alt.
          * apply (pr2 B).
          * abstract
              (rewrite <- !rwhisker_vcomp ;
               rewrite binprod_ump_2cell_pr1 ;
               exact (!q)).
          * abstract
              (rewrite <- !rwhisker_vcomp ;
               rewrite binprod_ump_2cell_pr2 ;
               rewrite !vassocl ;
               refine (_ @ id2_right _) ;
               rewrite vcomp_linv ;
               apply idpath).
    Defined.
  End InvertibleToCartesian.

  Section CartesianToInvertible.
    Context {a : B}
            {f g : a --> b₁ ⊗ b₂}
            (α : f ==> g)
            (Hα : is_cartesian_2cell_sfib π₁ α).

    Let h : a --> b₁ ⊗ b₂ := ⟨ f · π₁, g · π₂ ⟩.
    Let δ : h ==> g
      := binprod_ump_2cell
           (pr2 (pr2 B _ _))
           (binprod_ump_1cell_pr1 _ _ _ _ • (α ▹ _))
           (binprod_ump_1cell_pr2 _ _ _ _).
    Let hπ₁ : h · π₁ ==> f · π₁ := binprod_ump_1cell_pr1 _ _ _ _.

    Local Lemma cartesian_to_invertible_eq
      : δ ▹ π₁ = hπ₁ • (α ▹ π₁).
    Proof.
      apply binprod_ump_2cell_pr1.
    Qed.

    Let lift : ∃! δ0 : h ==> f, δ0 ▹ π₁ = hπ₁ × δ0 • α = δ
      := Hα h δ hπ₁ cartesian_to_invertible_eq.
    Let lift_map : h ==> f := pr11 lift.
    Let inv : g · π₂ ==> f · π₂
      := (binprod_ump_1cell_pr2 _ _ _ _)^-1 • (lift_map ▹ π₂).

    Let ζ : f ==> f
      := binprod_ump_2cell
           (pr2 (pr2 B _ _))
           (id2 _)
           ((α ▹ π₂) • inv).

    Local Lemma cartesian_to_invertible_map_inv_help
      : ζ = id₂ f.
    Proof.
      refine (maponpaths
                (λ z, pr1 z)
                (proofirrelevance
                   _
                   (isapropifcontr (Hα f α (id2 _) (!(id2_left _))))
                   (ζ ,, _ ,, _)
                   (id₂ _ ,, _ ,, _))).
      - apply binprod_ump_2cell_pr1.
      - use binprod_ump_2cell_unique_alt.
        + apply (pr2 B).
        + rewrite <- rwhisker_vcomp.
          unfold ζ.
          rewrite binprod_ump_2cell_pr1.
          apply id2_left.
        + unfold ζ, inv.
          rewrite <- rwhisker_vcomp.
          rewrite binprod_ump_2cell_pr2.
          rewrite !vassocl.
          rewrite rwhisker_vcomp.
          etrans.
          {
            do 3 apply maponpaths.
            apply (pr221 lift).
          }
          unfold δ.
          rewrite binprod_ump_2cell_pr2.
          rewrite vcomp_linv.
          apply id2_right.
      - apply id2_rwhisker.
      - apply id2_left.
    Qed.

    Local Lemma cartesian_to_invertible_map_inv
      : (α ▹ π₂) • inv = id₂ (f · π₂).
    Proof.
      refine (_ @ maponpaths (λ z, z ▹ π₂) cartesian_to_invertible_map_inv_help @ _).
      - unfold ζ.
        refine (!_).
        apply binprod_ump_2cell_pr2.
      - apply id2_rwhisker.
    Qed.

    Local Lemma cartesian_to_invertible_inv_map
      : inv • (α ▹ π₂) = id₂ (g · π₂).
    Proof.
      unfold inv.
      rewrite !vassocl.
      rewrite rwhisker_vcomp.
      etrans.
      {
        do 2 apply maponpaths.
        exact (pr221 lift).
      }
      unfold δ.
      etrans.
      {
        apply maponpaths.
        apply binprod_ump_2cell_pr2.
      }
      apply vcomp_linv.
    Qed.

    Definition cartesian_to_invertible
      : is_invertible_2cell (α ▹ π₂).
    Proof.
      unfold is_cartesian_2cell_sfib in Hα.
      use make_is_invertible_2cell.
      - exact inv.
      - exact cartesian_to_invertible_map_inv.
      - exact cartesian_to_invertible_inv_map.
    Defined.
  End CartesianToInvertible.

  Definition pr1_internal_cleaving
    : internal_sfib_cleaving (π₁ : b₁ ⊗ b₂ --> b₁).
  Proof.
    intros a f g α.
    simple refine (⟨ f , g · π₂ ⟩
                     ,, ⟪ α , id2 _ ⟫ • prod_1cell_eta _ g
                     ,, prod_1cell_pr1 _ f _
                     ,, _
                     ,, _) ; simpl.
    - apply invertible_to_cartesian.
      rewrite <- rwhisker_vcomp.
      use is_invertible_2cell_vcomp.
      + rewrite prod_2cell_pr2.
        is_iso.
        apply prod_1cell_pr2.
      + is_iso.
        apply prod_1cell_eta.
    - abstract
        (unfold prod_1cell_eta_map ;
         rewrite <- !rwhisker_vcomp ;
         etrans ;
         [ apply maponpaths ;
           apply binprod_ump_2cell_pr1
         | ] ;
         rewrite prod_2cell_pr1 ;
         rewrite !vassocl ;
         rewrite vcomp_linv ;
         rewrite id2_right ;
         apply idpath).
  Defined.

  Definition pr1_lwhisker_is_cartesian
    : lwhisker_is_cartesian (π₁ : b₁ ⊗ b₂ --> b₁).
  Proof.
    intros x y h f g γ Hγ.
    apply invertible_to_cartesian.
    pose (cartesian_to_invertible _ Hγ) as i.
    use make_is_invertible_2cell.
    - exact (rassociator _ _ _ • (h ◃ i^-1) • lassociator _ _ _).
    - rewrite !vassocr.
      rewrite <- rwhisker_lwhisker_rassociator.
      refine (_ @ rassociator_lassociator _ _ _).
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite lwhisker_vcomp.
      rewrite vcomp_rinv.
      rewrite lwhisker_id2.
      apply id2_left.
    - rewrite !vassocl.
      rewrite <- rwhisker_lwhisker.
      rewrite !vassocr.
      refine (_ @ rassociator_lassociator _ _ _).
      apply maponpaths_2.
      rewrite !vassocl.
      rewrite lwhisker_vcomp.
      rewrite vcomp_linv.
      rewrite lwhisker_id2.
      apply id2_right.
  Qed.

  Definition pr1_internal_sfib
    : internal_sfib (π₁ : b₁ ⊗ b₂ --> b₁).
  Proof.
    split.
    - exact pr1_internal_cleaving.
    - exact pr1_lwhisker_is_cartesian.
  Defined.
End ProjectionSFib.

(**
 2. First projection is a Street opfibration
 *)
Section ProjectionSOpFib.
  Context {B : bicat_with_binprod}
          (b₁ b₂ : B).

  Section InvertibleToOpCartesian.
    Context {a : B}
            {f g : a --> b₁ ⊗ b₂}
            (α : f ==> g)
            (Hα : is_invertible_2cell (α ▹ π₂)).

    Definition invertible_to_opcartesian_unique
               (h : a --> b₁ ⊗ b₂)
               (β : f ==> h)
               (δp : g · π₁ ==> h · π₁)
               (q : β ▹ π₁ = (α ▹ π₁) • δp)
      : isaprop (∑ (δ : g ==> h), δ ▹ π₁ = δp × α • δ = β).
    Proof.
      use invproofirrelevance.
      intros φ₁ φ₂.
      use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ].
      use binprod_ump_2cell_unique_alt.
      - apply (pr2 B).
      - exact (pr12 φ₁ @ !(pr12 φ₂)).
      - use (vcomp_lcancel _ Hα).
        rewrite !rwhisker_vcomp.
        apply maponpaths.
        exact (pr22 φ₁ @ !(pr22 φ₂)).
    Qed.

    Definition invertible_to_opcartesian
      : is_opcartesian_2cell_sopfib π₁ α.
    Proof.
      intros h β δp q.
      use iscontraprop1.
      - exact (invertible_to_opcartesian_unique h β δp q).
      - simple refine (_ ,, _ ,, _).
        + use binprod_ump_2cell.
          * apply (pr2 B).
          * exact δp.
          * exact (Hα^-1 • (β ▹ _)).
        + apply binprod_ump_2cell_pr1.
        + use binprod_ump_2cell_unique_alt.
          * apply (pr2 B).
          * abstract
              (rewrite <- !rwhisker_vcomp ;
               rewrite binprod_ump_2cell_pr1 ;
               exact (!q)).
          * abstract
              (rewrite <- !rwhisker_vcomp ;
               rewrite binprod_ump_2cell_pr2 ;
               rewrite !vassocr ;
               refine (_ @ id2_left _) ;
               rewrite vcomp_rinv ;
               apply idpath).
    Defined.
  End InvertibleToOpCartesian.

  Section OpCartesianToInvertible.
    Context {a : B}
            {f g : a --> b₁ ⊗ b₂}
            (α : f ==> g)
            (Hα : is_opcartesian_2cell_sopfib π₁ α).

    Let h : a --> b₁ ⊗ b₂ := ⟨ g · π₁, f · π₂ ⟩.
    Let δ : f ==> h
      := binprod_ump_2cell
           (pr2 (pr2 B _ _))
           (α ▹ _ • (binprod_ump_1cell_pr1 _ _ (g · π₁) (f · π₂))^-1)
           ((binprod_ump_1cell_pr2 _ _ (g · π₁) (f · π₂))^-1).
    Let hπ₁ : g · π₁ ==> h · π₁
      := (binprod_ump_1cell_pr1 _ _ (g · π₁) (f · π₂))^-1.

    Local Lemma opcartesian_to_invertible_eq
      : δ ▹ π₁ = (α ▹ π₁) • hπ₁.
    Proof.
      apply binprod_ump_2cell_pr1.
    Qed.

    Let lift : ∃! (δ0 : g ==> h), δ0 ▹ π₁ = hπ₁ × α • δ0 = δ
      := Hα h δ hπ₁ opcartesian_to_invertible_eq.
    Let lift_map : g ==> h := pr11 lift.
    Let inv : g · π₂ ==> f · π₂
      := lift_map ▹ π₂ • binprod_ump_1cell_pr2 _ _ _ _.

    Let ζ : g ==> g
      := binprod_ump_2cell
           (pr2 (pr2 B _ _))
           (id2 _)
           (inv • (α ▹ π₂)).

    Local Lemma opcartesian_to_invertible_map_inv_help
      : ζ = id₂ g.
    Proof.
      refine (maponpaths
                (λ z, pr1 z)
                (proofirrelevance
                   _
                   (isapropifcontr (Hα g α (id2 _) (!(id2_right _))))
                   (ζ ,, _ ,, _)
                   (id₂ _ ,, _ ,, _))).
      - apply binprod_ump_2cell_pr1.
      - use binprod_ump_2cell_unique_alt.
        + apply (pr2 B).
        + rewrite <- rwhisker_vcomp.
          unfold ζ.
          rewrite binprod_ump_2cell_pr1.
          apply id2_right.
        + unfold ζ, inv.
          rewrite <- rwhisker_vcomp.
          rewrite binprod_ump_2cell_pr2.
          rewrite !vassocr.
          rewrite rwhisker_vcomp.
          etrans.
          {
            do 2 apply maponpaths_2.
            apply maponpaths.
            exact (pr221 lift).
          }
          unfold δ.
          etrans.
          {
            do 2 apply maponpaths_2.
            apply binprod_ump_2cell_pr2.
          }
          rewrite vcomp_linv.
          apply id2_left.
      - apply id2_rwhisker.
      - apply id2_right.
    Qed.

    Local Lemma opcartesian_to_invertible_map_inv
      : (α ▹ π₂) • inv = id₂ (f · π₂).
    Proof.
      unfold inv.
      rewrite !vassocr.
      rewrite rwhisker_vcomp.
      etrans.
      {
        apply maponpaths_2.
        apply maponpaths.
        exact (pr221 lift).
      }
      unfold δ.
      etrans.
      {
        apply maponpaths_2.
        apply binprod_ump_2cell_pr2.
      }
      apply vcomp_linv.
    Qed.

    Local Lemma opcartesian_to_invertible_inv_map
      : inv • (α ▹ π₂) = id₂ (g · π₂).
    Proof.
      refine (_ @ maponpaths (λ z, z ▹ π₂) opcartesian_to_invertible_map_inv_help @ _).
      - unfold ζ.
        refine (!_).
        apply binprod_ump_2cell_pr2.
      - apply id2_rwhisker.
    Qed.

    Definition opcartesian_to_invertible
      : is_invertible_2cell (α ▹ π₂).
    Proof.
      unfold is_cartesian_2cell_sfib in Hα.
      use make_is_invertible_2cell.
      - exact inv.
      - exact opcartesian_to_invertible_map_inv.
      - exact opcartesian_to_invertible_inv_map.
    Defined.
  End OpCartesianToInvertible.

  Definition pr1_internal_opcleaving
    : internal_sopfib_opcleaving (π₁ : b₁ ⊗ b₂ --> b₁).
  Proof.
    intros a f g α.
    refine (⟨ g , f · π₂ ⟩
            ,,
            (prod_1cell_eta _ f)^-1 • ⟪ α , id2 _ ⟫
            ,,
            inv_of_invertible_2cell (prod_1cell_pr1 _ g _)
            ,,
            _
            ,,
            _).
    - apply invertible_to_opcartesian.
      rewrite <- rwhisker_vcomp.
      use is_invertible_2cell_vcomp.
      + is_iso.
      + rewrite prod_2cell_pr2.
        is_iso.
        apply prod_1cell_pr2.
    - abstract
        (unfold prod_1cell_eta_map ;
         rewrite <- !rwhisker_vcomp ;
         rewrite prod_2cell_pr1 ;
         cbn ;
         etrans ;
         [ apply maponpaths_2 ;
           apply binprod_ump_2cell_pr1
         | ] ;
         rewrite !vassocr ;
         rewrite vcomp_linv ;
         rewrite id2_left ;
         apply idpath).
  Defined.

  Definition pr1_lwhisker_is_opcartesian
    : lwhisker_is_opcartesian (π₁ : b₁ ⊗ b₂ --> b₁).
  Proof.
    intros x y h f g γ Hγ.
    apply invertible_to_opcartesian.
    pose (opcartesian_to_invertible _ Hγ) as i.
    use make_is_invertible_2cell.
    - exact (rassociator _ _ _ • (h ◃ i^-1) • lassociator _ _ _).
    - rewrite !vassocr.
      rewrite <- rwhisker_lwhisker_rassociator.
      refine (_ @ rassociator_lassociator _ _ _).
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite lwhisker_vcomp.
      rewrite vcomp_rinv.
      rewrite lwhisker_id2.
      apply id2_left.
    - rewrite !vassocl.
      rewrite <- rwhisker_lwhisker.
      rewrite !vassocr.
      refine (_ @ rassociator_lassociator _ _ _).
      apply maponpaths_2.
      rewrite !vassocl.
      rewrite lwhisker_vcomp.
      rewrite vcomp_linv.
      rewrite lwhisker_id2.
      apply id2_right.
  Qed.

  Definition pr1_internal_sopfib
    : internal_sopfib (π₁ : b₁ ⊗ b₂ --> b₁).
  Proof.
    split.
    - exact pr1_internal_opcleaving.
    - exact pr1_lwhisker_is_opcartesian.
  Defined.
End ProjectionSOpFib.


Require Import rt.util.all.
Require Import rt.model.time rt.model.arrival.basic.job rt.model.arrival.basic.arrival_sequence rt.model.priority.
Require Import rt.model.schedule.uni.schedule rt.model.schedule.uni.workload.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq fintype bigop.

Module Insert.

  Import UniprocessorSchedule.

  (* In this section we define the function that inserts a job
     in a schedule. *)

  Section Defs.

    Context {Job: eqType}.

    (* Consider any uniprocessor schedule. *)
    Variable sched: schedule Job.

    (* Let t be any point in time ... *)
    Variable t_insert : time.
    (* ...and j_new be the job to be inserted. *)
    Variable j_new : Job.

    (* The function insert returns a schedule that is the same as
       the original one but with job j_new scheduled at time t. *)
    Definition insert :=
      fun (t:time) => if t_insert == t then Some j_new else sched t.

  End Defs.

  (* In this section, we prove lemmas about the insert function. *)
  Section Lemmas.

    Context {Job: eqType}.

    (* Consider any uniprocessor schedule. *)
    Variable sched: schedule Job.

    (* Let t be any point in time ... *)
    Variable t_insert : time.
    (* ...and j_new be the job to be inserted. *)
    Variable j_new : Job.

    (* For simplicity, we define some local names. *)
    Let replaced_job := sched t_insert.
    Let new_sched := insert sched t_insert j_new.

    (* First, we prove some lemmas about the new schedule. *)
    Section Schedule.

      (* In the new schedule, job j_new is scheduled at time t. *)
      Lemma insert_changes_job_at_time_t:
        new_sched t_insert = Some j_new.
      Proof.
        Admitted.

      (* For any point in time other than t the new schedule
         is the same as the old one. *)
      Lemma insert_same_schedule_at_different_times:
        forall t, t <> t_insert -> sched t = insert sched t_insert j_new t.
      Proof.
        Admitted.

      (* If j_new is already scheduled at time t in sched,
         then new_sched is the same as sched. *)
      Lemma insert_no_change_if_job_already_scheduled:
        forall t, sched t_insert = Some j_new -> sched t = new_sched t.
      Proof.
        Admitted.

      (* If j_new was not scheduled in sched,
         new_sched is different from sched at time t.*)
      Lemma insert_changes_schedule_if_jobs_are_different:
        Some j_new <> sched t_insert -> new_sched t_insert <> sched t_insert.
      Proof.
        Admitted.

    End Schedule.

    (* In this section, we prove lemmas about service_at in new_sched. *)
    Section ServiceAt.

      (* Let j be any job. *)
      Variable j : Job.

      (* The service of j at any point in time different from t in
         new_sched is the same as in sched. *)
      Lemma insert_service_at_stays_the_same_at_times_other_than_t:
        forall t, t <> t_insert -> service_at sched j t = service_at new_sched j t.
      Proof.
        Admitted.

      (* As a corollary the service at any point in time before t
         in new_sched is the same as in sched. *)
      Corollary insert_service_at_stays_the_same_before_t:
        forall t, t < t_insert -> service_at sched j t = service_at new_sched j t.
      Proof.
        Admitted.

    End ServiceAt.

    (* In this section, we prove lemmas about the service in new_sched. *)
    Section Service.

      (* Let j be any job from the arrival sequence. *)
      Variable j : Job.

      (* The service of j before t in new_sched is the same as in sched. *)
      Lemma insert_service_invariant_before_t :
        forall t, t <= t_insert -> service new_sched j t = service sched j t.
      Proof.
        Admitted.

      (* The service of the assigned job j_new in the new schedule is
         either the same as in the original schedule (if j_new
         was already scheduled), or it increases by 1. *)
      Lemma insert_service_of_new_job :
        forall t, t < t_insert -> service new_sched j_new t = service sched j_new t + (replaced_job != Some j_new).
      Proof.
        Admitted.

      (* In this section, we prove some lemmas about the service
         of the job which was replaced. *)
      Section ReplacedJob.

        (* If j is the job that was replaced, ... *)
        Hypothesis H_j_is_replaced_job:
          replaced_job = Some j.

        (* ...and the inserted job j_new is the same as the replaced one,
              then the service of j in new_sched at any point in time
              after t decreases by 1 compared to the one in sched.*)
        Lemma insert_service_sched_job:
          forall t,
            t > t_insert ->
            (Some j_new != Some j) ->
            1 + service new_sched j t = service sched j t.
      Proof.
        Admitted.

        (* If j_new is the replaced job, the service does not change. *)
        Lemma insert_service_does_not_change_without_replacement:
          forall t,
            (Some j_new = Some j) ->
            service new_sched j t = service sched j t.
      Proof.
        Admitted.

      End ReplacedJob.

    End Service.

  End Lemmas.

End Insert.


(** * 6.887 Formal Reasoning About Programs, Spring 2016 - Pset 3 *)

Require Import Frap.

Set Implicit Arguments.

(* Authors: Adam Chlipala (adamc@csail.mit.edu), Peng Wang (wangpeng@csail.mit.edu) *)

(* In our classroom discussion of abstraction for model checking, there, were
 * some objections that writing and proving an abstraction feels like just as
 * much work as finding an invariant in the first place.  In this pset, we'll
 * examine a kind of abstraction where the payoff is clearer, because the author
 * of the abstraction only needs to think about the effects of the different
 * atomic statements in the program, not the control flow that connects them to
 * each other.  Many different abstraction techniques work well in that setting,
 * and we will develop just one of them, *predicate abstraction*, which has been
 * used quite successfully in fully automated tools like SLAM and BLAST.  In
 * this pset, we'll write predicate abstractions manually, but the overall idea
 * can be proved sound once and for all. *)

(* First, here's a generic step relation parameterized over a few types and
 * relations. *)
Inductive step
          pc     (* This is the type of program-counter locations. *)
          state  (* This is the type of variable values. *)
          action (* Variables are changed by actions from this set. *)

          (actionOf : pc -> action -> pc -> Prop)
          (* This relation explains which actions can run from which program
           * counters, taking us to particular new program counters.  It's very
           * similar to the step relation of a deterministic finite automaton
           * (DFA), where "actions" would be characters of a finite alphabet. *)

          (doAction : action -> state -> state -> Prop)
          (* This relation explains which effects each action might have on
           * states. *)

  : pc * state -> pc * state -> Prop :=
| StepAction : forall pc1 act pc2 st1 st2,
  actionOf pc1 act pc2
  -> doAction act st1 st2
  -> step actionOf doAction (pc1, st1) (pc2, st2).
(* Notice the clean split between [doAction], for modeling the effects of
 * actions, and [actionOf], for explaining which actions a particular program
 * could trigger.  We will develop an abstraction technique that lets us focus
 * on [doAction] alone. *)

(* Here's a wrapper to create a proper transition system, given the relations
 * initial values for the program counter and state. *)
Definition actionSys pc state action (pc0 : pc) (st0 : state)
           (actionOf : pc -> action -> pc -> Prop)
           (doAction : action -> state -> state -> Prop)
           : trsys (pc * state) := {|
  Initial := {(pc0, st0)};
  Step := step actionOf doAction
|}.

(* Now, we begin defining predicate abstraction.  In general, this abstraction
 * will involve tracking the values of some finite set of logical *predicates*
 * over the state (program variables).  We will represent predicates with
 * strings, written here with the type synonym [var]. *)

(* This type captures a single assertion: a predicate is known to be either
 * true or false. *)
Record assertion := {
  AssumedPredicate : var;
  AssumedToBe : bool
}.

(* A *rule* gives us a way to deduce the *new* value of a predicate, given the
 * *old* values of other predicates, before some action. *)
Record rule := {
  Assumptions : list assertion;
  Conclusion : assertion
}.

(* A predicate abstraction gives us two key ingredients. *)
Record predicate_abstraction state action := {
  Predicates : fmap var (state -> Prop);
  (* We include these predicates, explaining the meaning of each by mapping it
   * to the logical notion of a predicate on states. *)

  Rules : fmap action (list rule)
  (* These rules show, for each action, how we may update the truth values of
   * the predicates we are tracking. *)
}.

(* This predicate formalizes the meaning of an assertion, given a map assigning
 * known truth values to (some of) the predicates. *)
Definition assertionHolds (st : fmap var bool) (asr : assertion) : bool :=
  match asr with
  | {| AssumedPredicate := p; AssumedToBe := b |} =>
    match st $? p with
    | None => false
    | Some true => b
    | Some false => negb b
    end
  end.

(* We can lift the operation to check that every assumption in a list holds,
 * instead of just one of them. *)
Fixpoint assumptionsHold (st : fmap var bool) (asms : list assertion) : bool :=
  match asms with
  | nil => true
  | asm :: asms' => assertionHolds st asm && assumptionsHold st asms'
  end.

(* Given a predicate state [st] from before running an action, where rule [r]
 * explains the effects of that action, *extend* predicate state [st'] with the
 * additional predicates that [r] allows us to deduce. *)
Definition applyRule (st st' : fmap var bool) (r : rule)
  : fmap var bool :=
  match r with
  | {| Assumptions := asns; Conclusion := conc |} =>
    if assumptionsHold st asns
    then st' $+ (conc.(AssumedPredicate), conc.(AssumedToBe))
    else st'
  end.

(* Iterate the above logic for multiple rules. *)
Fixpoint applyRules (st st' : fmap var bool) (rs : list rule)
  : fmap var bool :=
  match rs with
  | nil => st'
  | r :: rs' => applyRules st (applyRule st st' r) rs'
  end.

(* We use that operation to implement a step relation. *)
Inductive predicate_step pc action (actionOf : pc -> action -> pc -> Prop)
          (rules : fmap action (list rule))
  : pc * fmap var bool -> pc * fmap var bool -> Prop :=
| PredicateStep : forall pc1 act pc2 pm,
  actionOf pc1 act pc2
  -> predicate_step actionOf rules (pc1, pm) (pc2, match rules $? act with
                                                   | None => $0
                                                   | Some rs => applyRules pm $0 rs
                                                   end).
(* Note a crucial effect of the [match]: when an action is not in the rules map,
 * we conservatively pick the state with no asserted predicates. *)

(* Finally, we bring it all together into a transition system. *)
Definition predicate_abstract pc state action (pc0 : pc)
           (actionOf : pc -> action -> pc -> Prop)
           (pa : predicate_abstraction state action) : trsys (pc * fmap var bool) := {|
  Initial := {(pc0, $0)};
  Step := predicate_step actionOf pa.(Rules)
|}.

(* Next, let's characterize what makes a particular rule set sound. *)

(* First, when is an assertion accurate, with respect to a concrete state
 * [st]? *)
Definition assertionAccurate state (predicates : fmap var (state -> Prop))
           (asr : assertion) (st : state) :=
  match predicates $? asr.(AssumedPredicate) with
  | None => False
  | Some pr => pr st <-> asr.(AssumedToBe) = true
  end.

(* Next, lift to lists of assertions. *)
Fixpoint assumptionsAccurate state (predicates : fmap var (state -> Prop))
         (asms : list assertion) (st : state) :=
  match asms with
  | nil => True
  | asm :: asms' => assertionAccurate predicates asm st
                    /\ assumptionsAccurate predicates asms' st
  end.

(* A rule is accurate when accuracy of its assumptions implies accuracy of its
 * conclusion, with respect to a particular relation [doIt] for performing some
 * action. *)
Definition ruleAccurate state (predicates : fmap var (state -> Prop))
           (doIt : state -> state -> Prop) (r : rule) :=
  forall st st', assumptionsAccurate predicates r.(Assumptions) st
                 -> doIt st st'
                 -> assertionAccurate predicates r.(Conclusion) st'.

(* A predicate abstraction is sound when every one of its rules, for every
 * action, is accurate. *)
Definition predicate_abstraction_sound state action
           (doAction : action -> state -> state -> Prop)
           (pa : predicate_abstraction state action) :=
  forall act rs r, pa.(Rules) $? act = Some rs
                   -> In r rs
                   -> ruleAccurate pa.(Predicates) (doAction act) r.

(* Here is a good simulation relation, to connect the original system to its
 * predicate abstraction. *)
Inductive paR pc state action (pa : predicate_abstraction state action)
  : pc * state -> pc * fmap var bool -> Prop :=
| PaR : forall pc0 st pm,
  (forall x b, pm $? x = Some b
               -> match pa.(Predicates) $? x with
                  | None => False
                  | Some pr => pr st <-> b = true
                  end)
  -> paR pa (pc0, st) (pc0, pm).

(* Here's the one theorem you're asking you to prove, for full credit. *)
Module Type S.
  (* Predicate abstraction really is a sound abstraction! *)
  Axiom predicate_abstraction_simulates : forall pc state action
    (pc0 : pc) (st0 : state)
    (actionOf : pc -> action -> pc -> Prop)
    (doAction : action -> state -> state -> Prop)
    (pa : predicate_abstraction state action),
    predicate_abstraction_sound doAction pa
    -> simulates (paR pa)
                 (actionSys pc0 st0 actionOf doAction)
                 (predicate_abstract pc0 actionOf pa).
End S.

(* Here's an example that might be useful to understand predicate
 * abstraction. *)

(*
  f(int n) {
    int a = 1;

    while (n > 0) {
      a = a + n;
      n = n - 1;
    }
  }
*)

Module Program1.

  Inductive pc := Initialize | Loop | IncrementA | DecrementN | Done.

  Require Import ZArith.
  Open Scope Z_scope.

  Record state := {
                   N : Z;
                   A : Z
                 }.

  Inductive action := AssignA | TestTrue | TestFalse | AddToA | SubtractFromN.

  Inductive actionOf : pc -> action -> pc -> Prop :=
  | ActInitialize : actionOf Initialize AssignA Loop
  | ActLoopTrue : actionOf Loop TestTrue IncrementA
  | ActLoopFalse : actionOf Loop TestFalse Done
  | ActIncrementA : actionOf IncrementA AddToA DecrementN
  | ActDecrementN : actionOf DecrementN SubtractFromN Loop.

  Inductive doAction : action -> state -> state -> Prop :=
  | DoAssignA : forall n a, doAction AssignA {| N := n; A := a |} {| N := n; A := 1 |}
  | DoTestTrue : forall n a, n > 0 -> doAction TestTrue {| N := n; A := a |} {| N := n; A := a |}
  | DoTestFalse : forall n a, n <= 0 -> doAction TestFalse {| N := n; A := a |} {| N := n; A := a |}
  | DoAddToA : forall n a, doAction AddToA {| N := n; A := a |} {| N := n; A := a + n |}
  | DoSubtractFromN : forall n a, doAction SubtractFromN {| N := n; A := a |} {| N := n-1; A := a |}.

  Definition sys n a := actionSys Initialize {| N := n; A := a |} actionOf doAction.

  (* Here's the rule set. *)
  Definition sys_pa := {|
    Predicates := $0 $+ ("a > 0", fun st => st.(A) > 0)
                     $+ ("n > 0", fun st => st.(N) > 0);
    Rules := $0 $+ (AssignA, [{|Assumptions := [];
                                Conclusion := {|AssumedPredicate := "a > 0";
                                                AssumedToBe := true|} |}])
              $+ (TestTrue, [{|Assumptions := [];
                               Conclusion := {|AssumedPredicate := "n > 0";
                                               AssumedToBe := true|} |};
                               {|Assumptions := [{|AssumedPredicate := "a > 0";
                                                   AssumedToBe := true|}];
                                 Conclusion := {|AssumedPredicate := "a > 0";
                                                 AssumedToBe := true|} |}])
              $+ (TestFalse, [{|Assumptions := [{|AssumedPredicate := "a > 0";
                                                  AssumedToBe := true|}];
                                Conclusion := {|AssumedPredicate := "a > 0";
                                                AssumedToBe := true|} |}])
              $+ (AddToA, [{|Assumptions := [{|AssumedPredicate := "a > 0";
                                               AssumedToBe := true|};
                                               {|AssumedPredicate := "n > 0";
                                                 AssumedToBe := true|}];
                             Conclusion := {|AssumedPredicate := "a > 0";
                                             AssumedToBe := true|} |}])
              $+ (SubtractFromN,  [{|Assumptions := [{|AssumedPredicate := "a > 0";
                                                       AssumedToBe := true|}];
                                     Conclusion := {|AssumedPredicate := "a > 0";
                                                     AssumedToBe := true|} |}])
  |}.

  Theorem sys_ok :
    (forall pc state action
        (pc0 : pc) (st0 : state)
        (actionOf : pc -> action -> pc -> Prop)
        (doAction : action -> state -> state -> Prop)
        (pa : predicate_abstraction state action),
        predicate_abstraction_sound doAction pa
        -> simulates (paR pa)
                     (actionSys pc0 st0 actionOf doAction)
                     (predicate_abstract pc0 actionOf pa))
    (* We assume the theorem we ask you above to prove. *)
    -> forall n a,
      invariantFor (sys n a) (fun st => fst st <> Initialize -> (snd st).(A) > 0).
  Proof.
    intro predicate_abstraction_simulates.
    simplify.
    eapply invariant_weaken.
    eapply invariant_simulates.
    eapply predicate_abstraction_simulates with (pa := sys_pa).

    unfold predicate_abstraction_sound; simplify.
    cases act; simplify; invert H; unfold ruleAccurate, assertionAccurate in *; simplify; propositional; subst;
      simplify.
    invert H1; simplify; propositional.
    linear_arithmetic.
    invert H1; simplify; propositional.
    unfold assertionAccurate in *; simplify.
    invert H1; simplify.
    propositional.
    unfold assertionAccurate in *; simplify.
    invert H1; simplify.
    propositional.
    unfold assertionAccurate in *; simplify.
    invert H1; simplify.
    propositional.
    linear_arithmetic.
    unfold assertionAccurate in *; simplify.
    invert H1; simplify.
    propositional.

    model_check_infer.

    simplify.
    invert H.
    simplify.
    propositional; subst.

    invert H1; simplify.
    propositional.

    invert H1; simplify.
    specialize (H3 "a > 0"); simplify.
    eapply H3; equality.
    (* Note a useful tactic here.
     * [specialize (H e)] instantiates [H]'s first quantifier with [e]. *)

    invert H1; simplify.
    specialize (H3 "a > 0"); simplify.
    eapply H3; equality.

    invert H1; simplify.
    specialize (H3 "a > 0"); simplify.
    eapply H3; equality.

    invert H1; simplify.
    specialize (H3 "a > 0"); simplify.
    eapply H3; equality.
  Qed.

End Program1.

(* Another example, not required to get full credit, but which you might find
 * worthwhile to finish, using predication abstraction *)

(* Here is a (simplified) snippet from a device driver for Microsoft Windows,
 * adapted from http://fm.csl.sri.com/SSFT12/predabs-SSFT12.pdf.

  <<
  do {
    lock();
    nPacketsOld = nPackets;
    if (request) {
       unlock();
       ++nPackets;
    }
  } while (nPackets != nPacketsOld);
  unlock();
  >>

  We want to prove that the locking principle, i.e. balance of lock/unlock, is obeyed.
*)

Module Program2.
  Inductive pc := Lock | Assign | If | Unlock1 | Inc | While | Unlock2 | Done.

  Require Import ZArith.
  Open Scope Z_scope.

  Record state := {
                   NP : Z; (* nPackets*)
                   NPO : Z; (* nPacketsOld *)
                   HasLock : bool
                 }.

  Inductive action := LockOK | AssignA | IfFalse | IfTrue | UnlockOK | IncA | WhileFalse | WhileTrue.

  Inductive actionOf : pc -> action -> pc -> Prop :=
  | ActLock : actionOf Lock LockOK Assign
  | ActAssign : actionOf Assign AssignA If
  | ActIfFalse : actionOf If IfFalse While
  | ActIfTrue : actionOf If IfTrue Unlock1
  | ActUnlock1 : actionOf Unlock1 UnlockOK Inc
  | ActInc : actionOf Inc IncA While
  | ActWhileFalse : actionOf While WhileFalse Unlock2
  | ActWhileTrue : actionOf While WhileTrue Lock
  | ActUnlock2 : actionOf Unlock2 UnlockOK Done.

  Inductive doAction : action -> state -> state -> Prop :=
  | DoLock np npo l :
      doAction LockOK
               {| NP := np; NPO := npo; HasLock := l |}
               {| NP := np; NPO := npo; HasLock := true |}
  | DoAssignA np npo l :
      doAction AssignA
               {| NP := np; NPO := npo; HasLock := l |}
               {| NP := np; NPO := np; HasLock := l |}
  | DoIfFalse np npo l :
      doAction IfFalse
               {| NP := np; NPO := npo; HasLock := l |}
               {| NP := np; NPO := npo; HasLock := l |}
  | DoIfTrue np npo l :
      doAction IfTrue
               {| NP := np; NPO := npo; HasLock := l |}
               {| NP := np; NPO := npo; HasLock := l |}
  | DoUnlock np npo l :
      doAction UnlockOK
               {| NP := np; NPO := npo; HasLock := l |}
               {| NP := np; NPO := npo; HasLock := false |}
  | DoIncA np npo l :
      doAction IncA
               {| NP := np; NPO := npo; HasLock := l |}
               {| NP := 1 + np; NPO := npo; HasLock := l |}
  | DoWhileTrue np npo l :
      np <> npo ->
      doAction WhileTrue
               {| NP := np; NPO := npo; HasLock := l |}
               {| NP := np; NPO := npo; HasLock := l |}
  | DoWhileFalse npo l :
      doAction WhileFalse
               {| NP := npo; NPO := npo; HasLock := l |}
               {| NP := npo; NPO := npo; HasLock := l |}.

  Definition sys np npo :=
    actionSys Lock {| NP := np; NPO := npo; HasLock := false |} actionOf doAction.

  (* Here's the theorem to prove.
   * Warning: even on my workstation, with a good predicate abstraction, it
   * takes on the order of 10 minutes to model check!  *)
  Theorem sys_ok : forall np npo,
    invariantFor (sys np npo) (fun st => fst st = Unlock2 -> (snd st).(HasLock) = true).
  Proof.
  Admitted.

End Program2.


(*

   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 setoids

*)

Require Import Theory.Category.
Require Import Theory.Product.

(*------------------------------------------------------------------------------
  -- ＣＡＴＥＧＯＲＹ  ＯＦ  ＳＥＴＯＩＤＳ
  ----------------------------------------------------------------------------*)
(** * Category of Setoids **)

(** In this file, we define the category of Setoids and show that this category has binary product.

    Note that to avoid universe inconsistancies we duplicate the definition of Setoid used to define
    the type of categories. **)

(** ** Setoid category definition **)

Module Setoids.

  Structure Obj := mkObj
  { SCarrier   :>  Type
  ; SEquiv     :   SCarrier → SCarrier → Prop
  ; is_SEquiv  :   Equivalence SEquiv }.

  Arguments mkObj   {_ _} _.
  Arguments SEquiv  {_} _ _.

  Notation "'Setoids.make' ⦃ 'Carrier' ≔ c ; 'Equiv' ≔ eq ⦄" :=
    (@mkObj c eq _) (only parsing).

  Existing Instance is_SEquiv.

  Structure Morphism (A B : Obj) := mkMorphism
  { map   :>  A → B
  ; cong  :   ∀ {x y}, SEquiv x y → SEquiv (map x) (map y) }.

  Instance map_Proper : ∀ A B (f : Morphism A B), Proper (SEquiv ==> SEquiv) (map A B f).
  Proof.
    intros A B f x y eq_xy.
    now apply cong.
  Qed.

  Arguments mkMorphism  {_ _ _} _.
  Arguments map         {_ _} _ _.
  Arguments cong        {_ _} _ {_ _ _}.

  Module Morphism.

    Notation make map := (@mkMorphism _ _ map _) (only parsing).

  End Morphism.

  Program Definition Hom (A B : Obj) : Setoid :=
    Setoid.make  ⦃ Carrier  ≔ Morphism A B
                 ; Equiv    ≔ λ f g ∙ ∀ x y, SEquiv x y → SEquiv (f x) (g y) ⦄.
  (** equivalence **)
  Next Obligation.
    constructor.
    - intros f x y eq_xy. now apply cong.
    - intros f g eq_fg x y eq_xy.
      etransitivity; [ apply cong; apply eq_xy | ].
      symmetry; now apply eq_fg.
    - intros f g h eq_fg eq_gh x y eq_xy.
      etransitivity; eauto. now apply eq_gh.
  Qed.

End Setoids.

Export Setoids.

Local Infix "⇒" := Hom.

Program Definition id {A} : A ⇒ A := Setoids.Morphism.make (λ x ∙ x).

Program Definition compose {A B C} : [ B ⇒ C ⟶ A ⇒ B ⟶ A ⇒ C ] :=
  λ g f ↦₂ Setoids.Morphism.make (λ x ∙ g (f x)).
(** g-cong **)
Next Obligation.
  now do 2 apply cong.
Qed.
(** g-cong₂ **)
Next Obligation.
  intros f₁ f₂ eq_f₁f₂ g₁ g₂ eq_g₁g₂ x y eq_xy; simpl.
  now apply eq_f₁f₂, eq_g₁g₂.
Qed.

Local Infix "∘" := compose.

Lemma left_id A B (f : A ⇒ B) : id ∘ f ≈ f.
Proof.
  intros x y eq_xy; simpl; now apply cong.
Qed.

Lemma right_id A B (f : A ⇒ B) : f ∘ id ≈ f.
Proof.
  intros x y eq_xy; simpl; now apply cong.
Qed.

Lemma compose_assoc A B C D (f : A ⇒ B) (g : B ⇒ C) (h : C ⇒ D) : h ∘ g ∘ f ≈ h ∘ (g ∘ f).
Proof.
  intros x y eq_xy; simpl; now repeat apply cong.
Qed.

Canonical Structure 𝑺𝒆𝒕𝒐𝒊𝒅 : Category :=
  mkCategory left_id right_id compose_assoc.

(*------------------------------------------------------------------------------
  -- ＳＥＴＯＩＤＳ  ＨＡＶＥ  ＢＩＮＡＲＹ  ＰＲＯＤＵＣＴ
  ----------------------------------------------------------------------------*)
(** ** Setoids have binary product **)

Section Product_construction.

  Infix "∼" := SEquiv (at level 70).

  Program Definition product (A B : 𝑺𝒆𝒕𝒐𝒊𝒅) : 𝑺𝒆𝒕𝒐𝒊𝒅 :=
    Setoids.make  ⦃ Carrier  ≔ A ⟨×⟩ B
                  ; Equiv    ≔ λ S₁ S₂ ∙ fst S₁ ∼ fst S₂ ∧ snd S₁ ∼ snd S₂ ⦄.
  (** equivalence **)
  Next Obligation.
    constructor; hnf.
    - intros [a  b]; split; reflexivity.
    - intros [x y] [x' y'] [eq_xx' eq_yy']; split; now symmetry.
    - intros [x y] [x' y'] [x'' y''] [eq_xx' eq_yy'] [eq_x'x'' eq_y'y''];
      split; etransitivity; eauto.
  Qed.

  Program Definition product_mor (A B C : 𝑺𝒆𝒕𝒐𝒊𝒅) (f : C ⇒ A) (g : C ⇒ B) : C ⇒ product A B :=
    Setoids.Morphism.make (λ c ∙ (f c , g c)).
  (** -,- cong **)
  Next Obligation.
    split; now apply cong.
  Qed.

  Program Definition proj_l {A B} : product A B ⇒ A := Setoids.Morphism.make fst.

  Program Definition proj_r {A B} : product A B ⇒ B := Setoids.Morphism.make snd.

End Product_construction.

Program Instance 𝑺𝒆𝒕𝒐𝒊𝒅_BinaryProduct : BinaryProduct 𝑺𝒆𝒕𝒐𝒊𝒅 :=
  BinaryProduct.make  ⦃ Category  ≔ 𝑺𝒆𝒕𝒐𝒊𝒅
                      ; _×_       ≔ product
                      ; ⟨_,_⟩     ≔ @product_mor _ _
                      ; π₁        ≔ proj_l
                      ; π₂        ≔ proj_r ⦄.
(** Pmor-cong₂ **)
Next Obligation.
  intros f₁ f₂ eq_f₁f₂ g₁ g₂ eq_g₁g₂ x y eq_xy; simpl; split.
  - now apply eq_f₁f₂.
  - now apply eq_g₁g₂.
Qed.
(** π₁-cong **)
Next Obligation.
  now apply cong.
Qed.
(** π₂-cong **)
Next Obligation.
  now apply cong.
Qed.


(* Expressions and Values *)

Require Import MyReals.
Require Import Types.

(* We distinguish syntactically between Values (canonical forms)
   and general expressions.  These are mutually recursive,
   because of abstractions. *)

(* Expressions and Values of type o, with free variables drawn from G *)

Inductive Exp G : Otype -> Type :=
| valexp : forall o, Val G o -> Exp G o
| prodexp : forall m m', Exp G (Stype m) -> Exp G (Stype m') ->
                         Exp G (Stype (Prod_type m m'))
| proj1exp : forall m m', Exp G (Stype (Prod_type m m'))
                          -> Exp G (Stype m)
| proj2exp : forall m m', Exp G (Stype (Prod_type m m'))
                          -> Exp G (Stype m')
| appexp : forall (a b : Otype),
             (Exp G (Funtype a b)) -> (Exp G a) -> (Exp G b)
| bindexp : forall (o o' : Mtype),  Exp G (Meastype o) ->
                        Exp G (Funtype (Stype o) (Meastype o')) ->
                        Exp G (Meastype o')
| returnexp : forall (o : Mtype), Exp G (Stype o)
                                  -> Exp G (Meastype o)
with
Val G : Otype -> Type :=
| constexp : real -> Val G (Stype Real_type)
| prodval : forall m m', Val G (Stype m) -> Val G (Stype m')
                         -> Val G (Stype (Prod_type m m'))
| varexp : forall o, Var G o -> Val G o
| absexp : forall (o o': Otype),
             (Exp (cons o G) o') -> (Val G (Funtype o o'))
| uniformval : Val G (Meastype Real_type)
(* | distval : Val G (Meastype Real_type)  (* some non-uniform distribution: *) *)

| bindval : forall o o', Val G (Meastype o) ->
                         Val G (Funtype
                                  (Stype o)
                                  (Meastype o')) ->
                        Val G (Meastype o')
| returnval : forall a, Val G (Stype a) -> Val G (Meastype a).

Arguments valexp {G o} _.
Arguments prodexp {G m m'} _ _.
Arguments proj1exp {G m m'} _.
Arguments proj2exp {G m m'} _.
Arguments appexp {G a b} _ _.
Arguments bindexp {G o o'} _ _.
Arguments returnexp {G o} _.
Arguments constexp {G} _.
Arguments varexp {G o} _.
Arguments prodval {G m m'} _ _.
Arguments absexp {G o o'} _.
Arguments uniformval {G}.
(* Arguments distval {G}. *)
Arguments bindval {G o o'} _ _.
Arguments returnval {G a} _.

(* Coq doesn't generate the correct mutual induction hypotheses
   for these, so we have to help it along. *)

Scheme exp_val_rec := Induction for Exp Sort Prop
with
val_exp_rec := Induction for Val Sort Prop.


(* (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 poly finset.
Require Import fingroup morphism perm automorphism quotient action finalg zmodp.
Require Import commutator cyclic center pgroup sylow gseries nilpotent abelian.
Require Import ssrnum ssrint polydiv rat matrix mxalgebra intdiv mxpoly.
Require Import vector falgebra fieldext separable galois algC cyclotomic algnum.
Require Import mxrepresentation classfun character.

(******************************************************************************)
(* This file provides some standard results based on integrality properties   *)
(* of characters, such as theorem asserting that the degree of an irreducible *)
(* character of G divides the order of G (Isaacs 3.11), or the famous p^a.q^b *)
(* solvability theorem of Burnside.                                           *)
(*   Defined here:                                                            *)
(*    'K_k == the kth class sum in gring F G, where k : 'I_#|classes G|, and  *)
(*            F is inferred from the context.                                 *)
(*            := gset_mx F G (enum_val k) (see mxrepresentation.v).           *)
(* --> The 'K_k form a basis of 'Z(group_ring F G)%MS.                        *)
(*   gring_classM_coef i j k == the coordinate of 'K_i *m 'K_j on 'K_k; this  *)
(*            is usually abbreviated as a i j k.                              *)
(*   gring_classM_coef_set A B z == the set of all (x, y) in setX A B such    *)
(*            that x * y = z; if A and B are respectively the ith and jth     *)
(*            conjugacy class of G, and z is in the kth conjugacy class, then *)
(*            gring_classM_coef i j k is exactly the cardinal of this set.    *)
(*  'omega_i[A] == the mode of 'chi[G]_i on (A \in 'Z(group_ring algC G))%MS, *)
(*            i.e., the z such that gring_op 'Chi_i A  = z%:M.                *)
(******************************************************************************)

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

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

Lemma group_num_field_exists (gT : finGroupType) (G : {group gT}) :
  {Qn : splittingFieldType rat & galois 1 {:Qn} &
    {QnC : {rmorphism Qn -> algC}
         & forall nuQn : argumentType (mem ('Gal({:Qn}%VS / 1%VS))),
              {nu : {rmorphism algC -> algC} |
                 {morph QnC: a / nuQn a >-> nu a}}
         & {w : Qn & #|G|.-primitive_root w /\ <<1; w>>%VS = fullv
              & forall (hT : finGroupType) (H : {group hT}) (phi : 'CF(H)),
                       phi \is a character ->
                       forall x, (#[x] %| #|G|)%N -> {a | QnC a = phi x}}}}.
Proof.
have [z prim_z] := C_prim_root_exists (cardG_gt0 G); set n := #|G| in prim_z *.
have [Qn [QnC [[|w []] // [Dz] genQn]]] := num_field_exists [:: z].
have prim_w: n.-primitive_root w by rewrite -Dz fmorph_primitive_root in prim_z.
have Q_Xn1: ('X^n - 1 : {poly Qn}) \is a polyOver 1%AS.
  by rewrite rpredB ?rpred1 ?rpredX //= polyOverX.
have splitXn1: splittingFieldFor 1 ('X^n - 1) {:Qn}.
  pose r := codom (fun i : 'I_n => w ^+ i).
  have Dr: 'X^n - 1 = \prod_(y <- r) ('X - y%:P).
    by rewrite -(factor_Xn_sub_1 prim_w) big_mkord big_map enumT.
  exists r; first by rewrite -Dr eqpxx.
  apply/eqP; rewrite eqEsubv subvf -genQn adjoin_seqSr //; apply/allP=> /=.
  by rewrite andbT -root_prod_XsubC -Dr; apply/unity_rootP/prim_expr_order.
have Qn_ax : SplittingField.axiom Qn by exists ('X^n - 1).
exists (SplittingFieldType _ _ Qn_ax).
  apply/splitting_galoisField.
  exists ('X^n - 1); split => //.
  apply: separable_Xn_sub_1; rewrite -(fmorph_eq0 QnC) rmorph_nat.
  by rewrite pnatr_eq0 -lt0n cardG_gt0.
exists QnC => [// nuQn|].
  by apply: (extend_algC_subfield_aut QnC [rmorphism of nuQn]).
rewrite span_seq1 in genQn.
exists w => // hT H phi Nphi x x_dv_n.
apply: sig_eqW; have [rH ->] := char_reprP Nphi.
have [Hx | /cfun0->] := boolP (x \in H); last by exists 0; rewrite rmorph0.
have [e [_ [enx1 _] [-> _] _]] := repr_rsim_diag rH Hx.
have /fin_all_exists[k Dk] i: exists k, e 0 i = z ^+ k.
  have [|k ->] := (prim_rootP prim_z) (e 0 i); last by exists k.
  by have /dvdnP[q ->] := x_dv_n; rewrite mulnC exprM enx1 expr1n.
exists (\sum_i w ^+ k i); rewrite rmorph_sum; apply/eq_bigr => i _.
by rewrite rmorphX Dz Dk.
Qed.

Section GenericClassSums.

(* This is Isaacs, Theorem (2.4), generalized to an arbitrary field, and with *)
(* the combinatorial definition of the coeficients exposed.                   *)
(* This part could move to mxrepresentation.*)

Variable (gT : finGroupType) (G : {group gT}) (F : fieldType).

Definition gring_classM_coef_set (Ki Kj : {set gT}) g :=
  [set xy in [predX Ki & Kj] | let: (x, y) := xy in x * y == g]%g.

Definition gring_classM_coef (i j k : 'I_#|classes G|) :=
  #|gring_classM_coef_set (enum_val i) (enum_val j) (repr (enum_val k))|.

Definition gring_class_sum (i : 'I_#|classes G|) := gset_mx F G (enum_val i).

Local Notation "''K_' i" := (gring_class_sum i)
  (at level 8, i at level 2, format "''K_' i") : ring_scope.
Local Notation a := gring_classM_coef.

Lemma gring_class_sum_central i : ('K_i \in 'Z(group_ring F G))%MS.
Proof. by rewrite -classg_base_center (eq_row_sub i) // rowK. Qed.

Lemma set_gring_classM_coef (i j k : 'I_#|classes G|) g :
    g \in enum_val k ->
  a i j k = #|gring_classM_coef_set (enum_val i) (enum_val j) g|.
Proof.
rewrite /a; have /repr_classesP[] := enum_valP k; move: (repr _) => g1 Gg1 ->.
have [/imsetP[zi Gzi ->] /imsetP[zj Gzj ->]] := (enum_valP i, enum_valP j).
move=> g1Gg; have Gg := subsetP (class_subG Gg1 (subxx _)) _ g1Gg.
set Aij := gring_classM_coef_set _ _.
without loss suffices IH: g g1 Gg Gg1 g1Gg / (#|Aij g1| <= #|Aij g|)%N.
  by apply/eqP; rewrite eqn_leq !IH // class_sym.
have [w Gw Dg] := imsetP g1Gg; pose J2 (v : gT) xy := (xy.1 ^ v, xy.2 ^ v)%g.
have J2inj: injective (J2 w).
  by apply: can_inj (J2 w^-1)%g _ => [[x y]]; rewrite /J2 /= !conjgK.
rewrite -(card_imset _ J2inj) subset_leq_card //; apply/subsetP.
move=> _ /imsetP[[x y] /setIdP[/andP[/= x1Gx y1Gy] Dxy1] ->]; rewrite !inE /=.
rewrite !(class_sym _ (_ ^ _)) !classGidl // class_sym x1Gx class_sym y1Gy.
by rewrite -conjMg (eqP Dxy1) /= -Dg.
Qed.

Theorem gring_classM_expansion i j : 'K_i *m 'K_j = \sum_k (a i j k)%:R *: 'K_k.
Proof.
have [/imsetP[zi Gzi dKi] /imsetP[zj Gzj dKj]] := (enum_valP i, enum_valP j).
pose aG := regular_repr F G; have sKG := subsetP (class_subG _ (subxx G)).
transitivity (\sum_(x in zi ^: G) \sum_(y in zj ^: G) aG (x * y)%g).
  rewrite mulmx_suml -/aG dKi; apply: eq_bigr => x /sKG Gx.
  rewrite mulmx_sumr -/aG dKj; apply: eq_bigr => y /sKG Gy.
  by rewrite repr_mxM ?Gx ?Gy.
pose h2 xy : gT := (xy.1 * xy.2)%g.
pose h1 xy := enum_rank_in (classes1 G) (h2 xy ^: G).
rewrite pair_big (partition_big h1 xpredT) //=; apply: eq_bigr => k _.
rewrite (partition_big h2 (mem (enum_val k))) /= => [|[x y]]; last first.
  case/andP=> /andP[/= /sKG Gx /sKG Gy] /eqP <-.
  by rewrite enum_rankK_in ?class_refl ?mem_classes ?groupM ?Gx ?Gy.
rewrite scaler_sumr; apply: eq_bigr => g Kk_g; rewrite scaler_nat.
rewrite (set_gring_classM_coef _ _ Kk_g) -sumr_const; apply: eq_big => [] [x y].
  rewrite !inE /= dKi dKj /h1 /h2 /=; apply: andb_id2r => /eqP ->.
  have /imsetP[zk Gzk dKk] := enum_valP k; rewrite dKk in Kk_g.
  by rewrite (class_eqP Kk_g) -dKk enum_valK_in eqxx andbT.
by rewrite /h2 /= => /andP[_ /eqP->].
Qed.

Fact gring_irr_mode_key : unit. Proof. by []. Qed.
Definition gring_irr_mode_def (i : Iirr G) := ('chi_i 1%g)^-1 *: 'chi_i.
Definition gring_irr_mode := locked_with gring_irr_mode_key gring_irr_mode_def.
Canonical gring_irr_mode_unlockable := [unlockable fun gring_irr_mode].

End GenericClassSums.

Arguments Scope gring_irr_mode [_ Group_scope ring_scope group_scope].

Notation "''K_' i" := (gring_class_sum _ i)
  (at level 8, i at level 2, format "''K_' i") : ring_scope.

Notation "''omega_' i [ A ]" := (xcfun (gring_irr_mode i) A)
   (at level 8, i at level 2, format "''omega_' i [ A ]") : ring_scope.

Section IntegralChar.

Variables (gT : finGroupType) (G : {group gT}).

(* This is Isaacs, Corollary (3.6). *)
Lemma Aint_char (chi : 'CF(G)) x : chi \is a character -> chi x \in Aint.
Proof.
have [Gx /char_reprP[rG ->] {chi} | /cfun0->//] := boolP (x \in G).
have [e [_ [unit_e _] [-> _] _]] := repr_rsim_diag rG Gx.
rewrite rpred_sum // => i _; apply: (@Aint_unity_root #[x]) => //.
exact/unity_rootP.
Qed.

Lemma Aint_irr i x : 'chi[G]_i x \in Aint.
Proof. exact/Aint_char/irr_char. Qed.

Local Notation R_G := (group_ring algCfield G).
Local Notation a := gring_classM_coef.

(* This is Isaacs (2.25). *)
Lemma mx_irr_gring_op_center_scalar n (rG : mx_representation algCfield G n) A :
  mx_irreducible rG -> (A \in 'Z(R_G))%MS -> is_scalar_mx (gring_op rG A).
Proof.
move/groupC=> irrG /center_mxP[R_A cGA].
apply: mx_abs_irr_cent_scalar irrG _ _; apply/centgmxP => x Gx.
by rewrite -(gring_opG rG Gx) -!gring_opM ?cGA // envelop_mx_id.
Qed.

Section GringIrrMode.

Variable i : Iirr G.

Let n := irr_degree (socle_of_Iirr i).
Let mxZn_inj: injective (@scalar_mx algCfield n).
Proof. by rewrite -[n]prednK ?irr_degree_gt0 //; apply: fmorph_inj. Qed.

Lemma cfRepr_gring_center n1 (rG : mx_representation algCfield G n1) A :
  cfRepr rG = 'chi_i -> (A \in 'Z(R_G))%MS -> gring_op rG A = 'omega_i[A]%:M.
Proof.
move=> def_rG Z_A; rewrite unlock xcfunZl -{2}def_rG xcfun_repr.
have irr_rG: mx_irreducible rG.
  have sim_rG: mx_rsim 'Chi_i rG by apply: cfRepr_inj; rewrite irrRepr.
  exact: mx_rsim_irr sim_rG (socle_irr _).
have /is_scalar_mxP[e ->] := mx_irr_gring_op_center_scalar irr_rG Z_A.
congr _%:M; apply: (canRL (mulKf (irr1_neq0 i))).
by rewrite mulrC -def_rG cfunE repr_mx1 group1 -mxtraceZ scalemx1.
Qed.

Lemma irr_gring_center A :
  (A \in 'Z(R_G))%MS -> gring_op 'Chi_i A = 'omega_i[A]%:M.
Proof. exact: cfRepr_gring_center (irrRepr i). Qed.

Lemma gring_irr_modeM A B :
    (A \in 'Z(R_G))%MS -> (B \in 'Z(R_G))%MS ->
  'omega_i[A *m B] = 'omega_i[A] * 'omega_i[B].
Proof.
move=> Z_A Z_B; have [[R_A cRA] [R_B cRB]] := (center_mxP Z_A, center_mxP Z_B).
apply: mxZn_inj; rewrite scalar_mxM -!irr_gring_center ?gring_opM //.
apply/center_mxP; split=> [|C R_C]; first exact: envelop_mxM.
by rewrite mulmxA cRA // -!mulmxA cRB.
Qed.

Lemma gring_mode_class_sum_eq (k : 'I_#|classes G|) g :
  g \in enum_val k -> 'omega_i['K_k] = #|g ^: G|%:R * 'chi_i g / 'chi_i 1%g.
Proof.
have /imsetP[x Gx DxG] := enum_valP k; rewrite DxG => /imsetP[u Gu ->{g}].
rewrite unlock classGidl ?cfunJ {u Gu}// mulrC mulr_natl.
rewrite xcfunZl raddf_sum DxG -sumr_const /=; congr (_ * _).
by apply: eq_bigr => _ /imsetP[u Gu ->]; rewrite xcfunG ?groupJ ?cfunJ.
Qed.

(* This is Isaacs, Theorem (3.7). *)
Lemma Aint_gring_mode_class_sum k : 'omega_i['K_k] \in Aint.
Proof.
move: k; pose X := [tuple 'omega_i['K_k] | k < #|classes G| ].
have memX k: 'omega_i['K_k] \in X by apply: image_f.
have S_P := Cint_spanP X; set S := Cint_span X in S_P.
have S_X: {subset X <= S} by apply: mem_Cint_span.
have S_1: 1 \in S.
  apply: S_X; apply/codomP; exists (enum_rank_in (classes1 G) 1%g).
  rewrite (@gring_mode_class_sum_eq _ 1%g) ?enum_rankK_in ?classes1 //.
  by rewrite mulfK ?irr1_neq0 // class1G cards1.
suffices Smul: mulr_closed S.
  by move=> k; apply: fin_Csubring_Aint S_P _ _; rewrite ?S_X.
split=> // _ _ /S_P[x ->] /S_P[y ->].
rewrite mulr_sumr rpred_sum // => j _.
rewrite mulrzAr mulr_suml rpredMz ?rpred_sum // => k _.
rewrite mulrzAl rpredMz {x y}// !nth_mktuple.
rewrite -gring_irr_modeM ?gring_class_sum_central //.
rewrite gring_classM_expansion raddf_sum rpred_sum // => jk _.
by rewrite scaler_nat raddfMn rpredMn ?S_X ?memX.
Qed.

(* A more usable reformulation that does not involve the class sums. *)
Corollary Aint_class_div_irr1 x :
  x \in G -> #|x ^: G|%:R * 'chi_i x / 'chi_i 1%g \in Aint.
Proof.
move=> Gx; have clGxG := mem_classes Gx; pose k := enum_rank_in clGxG (x ^: G).
have k_x: x \in enum_val k by rewrite enum_rankK_in // class_refl.
by rewrite -(gring_mode_class_sum_eq k_x) Aint_gring_mode_class_sum.
Qed.

(* This is Isaacs, Theorem (3.8). *)
Theorem coprime_degree_support_cfcenter g :
    coprime (truncC ('chi_i 1%g)) #|g ^: G| -> g \notin ('Z('chi_i))%CF ->
  'chi_i g = 0.
Proof.
set m := truncC _ => co_m_gG notZg.
have [Gg | /cfun0-> //] := boolP (g \in G).
have Dm: 'chi_i 1%g = m%:R by rewrite truncCK ?Cnat_irr1.
have m_gt0: (0 < m)%N by rewrite -ltC_nat -Dm irr1_gt0.
have nz_m: m%:R != 0 :> algC by rewrite pnatr_eq0 -lt0n.
pose alpha := 'chi_i g / m%:R.
have a_lt1: `|alpha| < 1.
  rewrite normrM normfV normr_nat -{2}(divff nz_m).
  rewrite ltr_def (can_eq (mulfVK nz_m)) eq_sym -{1}Dm -irr_cfcenterE // notZg.
  by rewrite ler_pmul2r ?invr_gt0 ?ltr0n // -Dm char1_ge_norm ?irr_char.
have Za: alpha \in Aint.
  have [u _ /dvdnP[v eq_uv]] := Bezoutl #|g ^: G| m_gt0.
  suffices ->: alpha = v%:R * 'chi_i g - u%:R * (alpha * #|g ^: G|%:R).
    rewrite rpredB // rpredM ?rpred_nat ?Aint_irr //.
    by rewrite mulrC mulrA -Dm Aint_class_div_irr1.
  rewrite -mulrCA -[v%:R](mulfK nz_m) -!natrM -eq_uv (eqnP co_m_gG).
  by rewrite mulrAC -mulrA -/alpha mulr_natl mulr_natr mulrS addrK.
have [Qn galQn [QnC gQnC [_ _ Qn_g]]] := group_num_field_exists <[g]>.
have{Qn_g} [a Da]: exists a, QnC a = alpha.
  rewrite /alpha; have [a <-] := Qn_g _ G _ (irr_char i) g (dvdnn _).
  by exists (a / m%:R); rewrite fmorph_div rmorph_nat.
have Za_nu nu: sval (gQnC nu) alpha \in Aint by rewrite Aint_aut.
have norm_a_nu nu: `|sval (gQnC nu) alpha| <= 1.
  move: {nu}(sval _) => nu; rewrite fmorph_div rmorph_nat normrM normfV.
  rewrite normr_nat -Dm -(ler_pmul2r (irr1_gt0 (aut_Iirr nu i))) mul1r.
  congr (_ <= _): (char1_ge_norm g (irr_char (aut_Iirr nu i))).
  by rewrite !aut_IirrE !cfunE Dm rmorph_nat divfK.
pose beta := QnC (galNorm 1 {:Qn} a).
have Dbeta: beta = \prod_(nu in 'Gal({:Qn} / 1)) sval (gQnC nu) alpha.
  rewrite /beta rmorph_prod. apply: eq_bigr => nu _.
  by case: (gQnC nu) => f /= ->; rewrite Da.
have Zbeta: beta \in Cint.
  apply: Cint_rat_Aint; last by rewrite Dbeta rpred_prod.
  rewrite /beta; have /vlineP[/= c ->] := mem_galNorm galQn (memvf a).
  by rewrite alg_num_field fmorph_rat rpred_rat.
have [|nz_a] := boolP (alpha == 0).
  by rewrite (can2_eq (divfK _) (mulfK _)) // mul0r => /eqP.
have: beta != 0 by rewrite Dbeta; apply/prodf_neq0 => nu _; rewrite fmorph_eq0.
move/(norm_Cint_ge1 Zbeta); rewrite ltr_geF //; apply: ler_lt_trans a_lt1.
rewrite -[`|alpha|]mulr1 Dbeta (bigD1 1%g) ?group1 //= -Da.
case: (gQnC _) => /= _ <-; rewrite gal_id normrM.
rewrite -subr_ge0 -mulrBr mulr_ge0 ?normr_ge0 // Da subr_ge0.
elim/big_rec: _ => [|nu c _]; first by rewrite normr1 lerr.
apply: ler_trans; rewrite -subr_ge0 -{1}[`|c|]mul1r normrM -mulrBl.
by rewrite mulr_ge0 ?normr_ge0 // subr_ge0 norm_a_nu.
Qed.

End GringIrrMode.

(* This is Isaacs, Theorem (3.9). *)
Theorem primes_class_simple_gt1 C :
  simple G -> ~~ abelian G -> C \in (classes G)^# -> (size (primes #|C|) > 1)%N.
Proof.
move=> simpleG not_cGG /setD1P[ntC /imsetP[g Gg defC]].
have{ntC} nt_g: g != 1%g by rewrite defC classG_eq1 in ntC.
rewrite ltnNge {C}defC; set m := #|_|; apply/negP=> p_natC.
have{p_natC} [p p_pr [a Dm]]: {p : nat & prime p & {a | m = p ^ a}%N}.
  have /prod_prime_decomp->: (0 < m)%N by rewrite /m -index_cent1.
  rewrite prime_decompE; case Dpr: (primes _) p_natC => [|p []] // _.
    by exists 2 => //; rewrite big_nil; exists 0%N.
  rewrite big_seq1; exists p; last by exists (logn p m).
  by have:= mem_primes p m; rewrite Dpr mem_head => /esym/and3P[].
have{simpleG} [ntG minG] := simpleP _ simpleG.
pose p_dv1 i := (p %| 'chi[G]_i 1%g)%C.
have p_dvd_supp_g i: ~~ p_dv1 i && (i != 0) -> 'chi_i g = 0.
  rewrite /p_dv1 irr1_degree dvdC_nat -prime_coprime // => /andP[co_p_i1 nz_i].
  have fful_i: cfker 'chi_i = [1].
    have /minG[//|/eqP] := cfker_normal 'chi_i.
    by rewrite eqEsubset subGcfker (negPf nz_i) andbF.
  have trivZ: 'Z(G) = [1] by have /minG[|/center_idP/idPn] := center_normal G.
  have trivZi: ('Z('chi_i))%CF = [1].
    apply/trivgP; rewrite -quotient_sub1 ?norms1 //= -fful_i cfcenter_eq_center.
    rewrite fful_i subG1 -(isog_eq1 (isog_center (quotient1_isog G))) /=.
    by rewrite trivZ.
  rewrite coprime_degree_support_cfcenter ?trivZi ?inE //.
  by rewrite -/m Dm irr1_degree natCK coprime_sym coprime_expl.
pose alpha := \sum_(i | p_dv1 i && (i != 0)) 'chi_i 1%g / p%:R * 'chi_i g.
have nz_p: p%:R != 0 :> algC by rewrite pnatr_eq0 -lt0n prime_gt0.
have Dalpha: alpha = - 1 / p%:R.
  apply/(canRL (mulfK nz_p))/eqP; rewrite -addr_eq0 addrC; apply/eqP/esym.
  transitivity (cfReg G g); first by rewrite cfRegE (negPf nt_g).
  rewrite cfReg_sum sum_cfunE (bigD1 0) //= irr0 !cfunE cfun11 cfun1E Gg.
  rewrite mulr1; congr (1 + _); rewrite (bigID p_dv1) /= addrC big_andbC.
  rewrite big1 => [|i /p_dvd_supp_g chig0]; last by rewrite cfunE chig0 mulr0.
  rewrite add0r big_andbC mulr_suml; apply: eq_bigr => i _.
  by rewrite mulrAC divfK // cfunE.
suffices: (p %| 1)%C by rewrite (dvdC_nat p 1) dvdn1 -(subnKC (prime_gt1 p_pr)).
rewrite unfold_in (negPf nz_p).
rewrite Cint_rat_Aint ?rpred_div ?rpred1 ?rpred_nat //.
rewrite -rpredN // -mulNr -Dalpha rpred_sum // => i /andP[/dvdCP[c Zc ->] _].
by rewrite mulfK // rpredM ?Aint_irr ?Aint_Cint.
Qed.

End IntegralChar.

Section MoreIntegralChar.

Implicit Type gT : finGroupType.

(* This is Burnside's famous p^a.q^b theorem (Isaacs, Theorem (3.10)). *)
Theorem Burnside_p_a_q_b gT (G : {group gT}) :
  (size (primes #|G|) <= 2)%N -> solvable G.
Proof.
move: {2}_.+1 (ltnSn #|G|) => n; elim: n => // n IHn in gT G *.
rewrite ltnS => leGn piGle2; have [simpleG | ] := boolP (simple G); last first.
  rewrite negb_forall_in => /exists_inP[N sNG]; rewrite eq_sym.
  have [-> | ] := altP (N =P G).
    rewrite groupP /= genGid normG andbT eqb_id negbK => /eqP->.
    exact: solvable1.
  rewrite [N == G]eqEproper sNG eqbF_neg !negbK => ltNG /and3P[grN].
  case/isgroupP: grN => {N}N -> in sNG ltNG *; rewrite /= genGid => ntN nNG.
  have nsNG: N <| G by apply/andP.
  have dv_le_pi m: (m %| #|G| -> size (primes m) <= 2)%N.
    move=> m_dv_G; apply: leq_trans piGle2.
    by rewrite uniq_leq_size ?primes_uniq //; apply: pi_of_dvd.
  rewrite (series_sol nsNG) !IHn ?dv_le_pi ?cardSg ?dvdn_quotient //.
    by apply: leq_trans leGn; apply: ltn_quotient.
  by apply: leq_trans leGn; apply: proper_card.
have [->|[p p_pr p_dv_G]] := trivgVpdiv G; first exact: solvable1.
have piGp: p \in \pi(G) by rewrite mem_primes p_pr cardG_gt0.
have [P sylP] := Sylow_exists p G; have [sPG pP p'GP] := and3P sylP.
have ntP: P :!=: 1%g by rewrite -rank_gt0 (rank_Sylow sylP) p_rank_gt0.
have /trivgPn[g /setIP[Pg cPg] nt_g]: 'Z(P) != 1%g.
  by rewrite center_nil_eq1 // (pgroup_nil pP).
apply: abelian_sol; have: (size (primes #|g ^: G|) <= 1)%N.
  rewrite -ltnS -[_.+1]/(size (p :: _)) (leq_trans _ piGle2) //.
  rewrite -index_cent1 uniq_leq_size // => [/= | q].
    rewrite primes_uniq -p'natEpi ?(pnat_dvd _ p'GP) ?indexgS //.
    by rewrite subsetI sPG sub_cent1.
  by rewrite inE => /predU1P[-> // |]; apply: pi_of_dvd; rewrite ?dvdn_indexg.
rewrite leqNgt; apply: contraR => /primes_class_simple_gt1-> //.
by rewrite !inE classG_eq1 nt_g mem_classes // (subsetP sPG).
Qed.

(* This is Isaacs, Theorem (3.11). *)
Theorem dvd_irr1_cardG gT (G : {group gT}) i : ('chi[G]_i 1%g %| #|G|)%C.
Proof.
rewrite unfold_in -if_neg irr1_neq0 Cint_rat_Aint //=.
  by rewrite rpred_div ?rpred_nat // rpred_Cnat ?Cnat_irr1.
rewrite -[n in n / _]/(_ *+ true) -(eqxx i) -mulr_natr.
rewrite -first_orthogonality_relation mulVKf ?neq0CG //.
rewrite sum_by_classes => [|x y Gx Gy]; rewrite -?conjVg ?cfunJ //.
rewrite mulr_suml rpred_sum // => K /repr_classesP[Gx {1}->].
by rewrite !mulrA mulrAC rpredM ?Aint_irr ?Aint_class_div_irr1.
Qed.

(* This is Isaacs, Theorem (3.12). *)
Theorem dvd_irr1_index_center gT (G : {group gT}) i :
  ('chi[G]_i 1%g %| #|G : 'Z('chi_i)%CF|)%C.
Proof.
without loss fful: gT G i / cfaithful 'chi_i.
  rewrite -{2}[i](quo_IirrK _ (subxx _)) ?mod_IirrE ?cfModE ?cfker_normal //.
  rewrite morph1; set i1 := quo_Iirr _ i => /(_ _ _ i1) IH.
  have fful_i1: cfaithful 'chi_i1.
    by rewrite quo_IirrE ?cfker_normal ?cfaithful_quo.
  have:= IH fful_i1; rewrite cfcenter_fful_irr // -cfcenter_eq_center.
  rewrite index_quotient_eq ?cfcenter_sub ?cfker_norm //.
  by rewrite setIC subIset // normal_sub ?cfker_center_normal.
have [lambda lin_lambda Dlambda] := cfcenter_Res 'chi_i.
have DchiZ: {in G & 'Z(G), forall x y, 'chi_i (x * y)%g = 'chi_i x * lambda y}.
  rewrite -(cfcenter_fful_irr fful) => x y Gx Zy.
  apply: (mulfI (irr1_neq0 i)); rewrite mulrCA.
  transitivity ('chi_i x * ('chi_i 1%g *: lambda) y); last by rewrite !cfunE.
  rewrite -Dlambda cfResE ?cfcenter_sub //.
  rewrite -irrRepr cfcenter_repr !cfunE in Zy *.
  case/setIdP: Zy => Gy /is_scalar_mxP[e De].
  rewrite repr_mx1 group1 (groupM Gx Gy) (repr_mxM _ Gx Gy) Gx Gy De.
  by rewrite mul_mx_scalar mxtraceZ mulrCA mulrA mulrC -mxtraceZ scalemx1.
have inj_lambda: {in 'Z(G) &, injective lambda}.
  rewrite -(cfcenter_fful_irr fful) => x y Zx Zy eq_xy.
  apply/eqP; rewrite eq_mulVg1 -in_set1 (subsetP fful) // cfkerEirr inE.
  apply/eqP; transitivity ('Res['Z('chi_i)%CF] 'chi_i (x^-1 * y)%g).
    by rewrite cfResE ?cfcenter_sub // groupM ?groupV.
  rewrite Dlambda !cfunE lin_charM ?groupV // -eq_xy -lin_charM ?groupV //.
  by rewrite mulrC mulVg lin_char1 ?mul1r.
rewrite unfold_in -if_neg irr1_neq0 Cint_rat_Aint //.
  by rewrite rpred_div ?rpred_nat // rpred_Cnat ?Cnat_irr1.
rewrite (cfcenter_fful_irr fful) nCdivE natf_indexg ?center_sub //=.
have ->: #|G|%:R = \sum_(x in G) 'chi_i x * 'chi_i (x^-1)%g.
  rewrite -[_%:R]mulr1; apply: canLR (mulVKf (neq0CG G)) _.
  by rewrite first_orthogonality_relation eqxx.
rewrite (big_setID [set x | 'chi_i x == 0]) /= -setIdE.
rewrite big1 ?add0r => [| x /setIdP[_ /eqP->]]; last by rewrite mul0r.
pose h x := (x ^: G * 'Z(G))%g; rewrite (partition_big_imset h).
rewrite !mulr_suml rpred_sum //= => _ /imsetP[x /setDP[Gx nz_chi_x] ->].
have: #|x ^: G|%:R * ('chi_i x * 'chi_i x^-1%g) / 'chi_i 1%g \in Aint.
  by rewrite !mulrA mulrAC rpredM ?Aint_irr ?Aint_class_div_irr1.
congr 2 (_ * _ \in Aint); apply: canRL (mulfK (neq0CG _)) _.
rewrite inE in nz_chi_x.
transitivity ('chi_i x * 'chi_i (x^-1)%g *+ #|h x|); last first.
  rewrite -sumr_const.
  apply: eq_big => [y | _ /mulsgP[_ z /imsetP[u Gu ->] Zz] ->].
    rewrite !inE -andbA; apply/idP/and3P=> [|[_ _ /eqP <-]]; last first.
      by rewrite -{1}[y]mulg1 mem_mulg ?class_refl.
    case/mulsgP=> _ z /imsetP[u Gu ->] Zz ->; have /centerP[Gz cGz] := Zz.
    rewrite groupM 1?DchiZ ?groupJ ?cfunJ //; split=> //.
      by rewrite mulf_neq0 // lin_char_neq0 /= ?cfcenter_fful_irr.
    rewrite -[z](mulKg u) -cGz // -conjMg /h classGidl {u Gu}//.
    apply/eqP/setP=> w; apply/mulsgP/mulsgP=> [][_ z1 /imsetP[v Gv ->] Zz1 ->].
      exists (x ^ v)%g (z * z1)%g; rewrite ?mem_imset ?groupM //.
      by rewrite conjMg -mulgA /(z ^ v)%g cGz // mulKg.
    exists ((x * z) ^ v)%g (z^-1 * z1)%g; rewrite ?mem_imset ?groupM ?groupV //.
    by rewrite conjMg -mulgA /(z ^ v)%g cGz // mulKg mulKVg.
  rewrite !irr_inv DchiZ ?groupJ ?cfunJ // rmorphM mulrACA -!normCK -exprMn.
  by rewrite (normC_lin_char lin_lambda) ?mulr1 //= cfcenter_fful_irr.
rewrite mulrAC -natrM mulr_natl; congr (_ *+ _).
symmetry; rewrite /h /mulg /= /set_mulg [in _ @2: (_, _)]unlock cardsE.
rewrite -cardX card_in_image // => [] [y1 z1] [y2 z2] /=.
move=> /andP[/=/imsetP[u1 Gu1 ->] Zz1] /andP[/=/imsetP[u2 Gu2 ->] Zz2] {y1 y2}.
move=> eq12; have /eqP := congr1 'chi_i eq12.
rewrite !(cfunJ, DchiZ) ?groupJ // (can_eq (mulKf nz_chi_x)).
rewrite (inj_in_eq inj_lambda) // => /eqP eq_z12; rewrite eq_z12 in eq12 *.
by rewrite (mulIg _ _ _ eq12).
Qed.

(* This is Isaacs, Problem (3.7). *)
Lemma gring_classM_coef_sum_eq gT (G : {group gT}) j1 j2 k g1 g2 g :
   let a := @gring_classM_coef gT G j1 j2 in let a_k := a k in
   g1 \in enum_val j1 -> g2 \in enum_val j2 -> g \in enum_val k ->
   let sum12g := \sum_i 'chi[G]_i g1 * 'chi_i g2 * ('chi_i g)^* / 'chi_i 1%g in
  a_k%:R = (#|enum_val j1| * #|enum_val j2|)%:R / #|G|%:R * sum12g.
Proof.
move=> a /= Kg1 Kg2 Kg; rewrite mulrAC; apply: canRL (mulfK (neq0CG G)) _.
transitivity (\sum_j (#|G| * a j)%:R *+ (j == k) : algC).
  by rewrite (bigD1 k) //= eqxx -natrM mulnC big1 ?addr0 // => j /negPf->.
have defK (j : 'I_#|classes G|) x: x \in enum_val j -> enum_val j = x ^: G.
  by have /imsetP[y Gy ->] := enum_valP j => /class_eqP.
have Gg: g \in G.
  by case/imsetP: (enum_valP k) Kg => x Gx -> /imsetP[y Gy ->]; apply: groupJ.
transitivity (\sum_j \sum_i 'omega_i['K_j] * 'chi_i 1%g * ('chi_i g)^* *+ a j).
  apply: eq_bigr => j _; have /imsetP[z Gz Dj] := enum_valP j.
  have Kz: z \in enum_val j by rewrite Dj class_refl.
  rewrite -(Lagrange (subsetIl G 'C[z])) index_cent1 -mulnA natrM -mulrnAl.
  have ->: (j == k) = (z \in enum_val k).
    by rewrite -(inj_eq enum_val_inj); apply/eqP/idP=> [<-|/defK->].
  rewrite (defK _ g) // -second_orthogonality_relation // mulr_suml.
  apply: eq_bigr=> i _; rewrite natrM mulrA mulr_natr mulrC mulrA.
  by rewrite (gring_mode_class_sum_eq i Kz) divfK ?irr1_neq0.
rewrite exchange_big /= mulr_sumr; apply: eq_bigr => i _.
transitivity ('omega_i['K_j1 *m 'K_j2] * 'chi_i 1%g * ('chi_i g)^*).
  rewrite gring_classM_expansion -/a raddf_sum !mulr_suml /=.
  by apply: eq_bigr => j _; rewrite xcfunZr -!mulrA mulr_natl.
rewrite !mulrA 2![_ / _]mulrAC (defK _ _ Kg1) (defK _ _ Kg2); congr (_ * _).
rewrite gring_irr_modeM ?gring_class_sum_central // mulnC natrM.
rewrite (gring_mode_class_sum_eq i Kg2) !mulrA divfK ?irr1_neq0 //.
by congr (_ * _); rewrite [_ * _]mulrC (gring_mode_class_sum_eq i Kg1) !mulrA.
Qed.

(* This is Isaacs, Problem (2.16). *)
Lemma index_support_dvd_degree gT (G H : {group gT}) chi :
    H \subset G -> chi \is a character -> chi \in 'CF(G, H) ->
    (H :==: 1%g) || abelian G ->
  (#|G : H| %| chi 1%g)%C.
Proof.
move=> sHG Nchi Hchi ZHG.
suffices: (#|G : H| %| 'Res[H] chi 1%g)%C by rewrite cfResE ?group1.
rewrite ['Res _]cfun_sum_cfdot sum_cfunE rpred_sum // => i _.
rewrite cfunE dvdC_mulr ?Cint_Cnat ?Cnat_irr1 //.
have [j ->]: exists j, 'chi_i = 'Res 'chi[G]_j.
  case/predU1P: ZHG => [-> | cGG] in i *.
    suffices ->: i = 0 by exists 0; rewrite !irr0 cfRes_cfun1 ?sub1G.
    apply/val_inj; case: i => [[|i] //=]; rewrite ltnNge NirrE.
    by rewrite (@leq_trans 1) // leqNgt classes_gt1 eqxx.
  have linG := char_abelianP G cGG; have linG1 j := eqP (proj2 (andP (linG j))).
  have /fin_all_exists[rH DrH] j: exists k, 'Res[H, G] 'chi_j = 'chi_k.
    apply/irrP/lin_char_irr/andP.
    by rewrite cfRes_char ?irr_char // cfRes1 ?linG1.
  suffices{i} all_rH: codom rH =i Iirr H.
    by exists (iinv (all_rH i)); rewrite DrH f_iinv.
  apply/subset_cardP; last exact/subsetP; apply/esym/eqP.
  rewrite card_Iirr_abelian ?(abelianS sHG) //.
  rewrite -(eqn_pmul2r (indexg_gt0 G H)) Lagrange //; apply/eqP.
  rewrite -sum_nat_const -card_Iirr_abelian // -sum1_card.
  rewrite (partition_big rH (mem (codom rH))) /=; last exact: image_f.
  have nsHG: H <| G by rewrite -sub_abelian_normal.
  apply: eq_bigr => _ /codomP[i ->]; rewrite -card_quotient ?normal_norm //.
  rewrite -card_Iirr_abelian ?quotient_abelian //.
  have Mlin j1 j2: exists k, 'chi_j1 * 'chi_j2 = 'chi[G]_k.
    exact/irrP/lin_char_irr/rpredM.
  have /fin_all_exists[rQ DrQ] (j : Iirr (G / H)) := Mlin i (mod_Iirr j).
  have mulJi: ('chi[G]_i)^*%CF * 'chi_i = 1.
    apply/cfun_inP=> x Gx; rewrite !cfunE -lin_charV_conj ?linG // cfun1E Gx.
    by rewrite lin_charV ?mulVf ?lin_char_neq0 ?linG.
  have inj_rQ: injective rQ.
    move=> j1 j2 /(congr1 (fun k => (('chi_i)^*%CF * 'chi_k) / H)%CF).
    by rewrite -!DrQ !mulrA mulJi !mul1r !mod_IirrE ?cfModK // => /irr_inj.
  rewrite -(card_imset _ inj_rQ) -sum1_card; apply: eq_bigl => j.
  rewrite -(inj_eq irr_inj) -!DrH; apply/eqP/imsetP=> [eq_ij | [k _ ->]].
    have [k Dk] := Mlin (conjC_Iirr i) j; exists (quo_Iirr H k) => //.
    apply/irr_inj; rewrite -DrQ quo_IirrK //.
      by rewrite -Dk conjC_IirrE mulrCA mulrA mulJi mul1r.
    apply/subsetP=> x Hx; have Gx := subsetP sHG x Hx.
    rewrite cfkerEirr inE linG1 -Dk conjC_IirrE; apply/eqP.
    transitivity ((1 : 'CF(G)) x); last by rewrite cfun1E Gx.
    by rewrite -mulJi !cfunE -!(cfResE _ sHG Hx) eq_ij.
  rewrite -DrQ; apply/cfun_inP=> x Hx; rewrite !cfResE // cfunE mulrC.
  by rewrite cfker1 ?linG1 ?mul1r ?(subsetP _ x Hx) // mod_IirrE ?cfker_mod.
have: (#|G : H| %| #|G : H|%:R * '[chi, 'chi_j])%C.
  by rewrite dvdC_mulr ?Cint_Cnat ?Cnat_cfdot_char_irr.
congr (_ %| _)%C; rewrite (cfdotEl _ Hchi) -(Lagrange sHG) mulnC natrM.
rewrite invfM -mulrA mulVKf ?neq0CiG //; congr (_ * _).
by apply: eq_bigr => x Hx; rewrite !cfResE.
Qed.

(* This is Isaacs, Theorem (3.13). *)
Theorem faithful_degree_p_part gT (p : nat) (G P : {group gT}) i :
    cfaithful 'chi[G]_i -> p.-nat (truncC ('chi_i 1%g)) ->
    p.-Sylow(G) P -> abelian P ->
  'chi_i 1%g = (#|G : 'Z(G)|`_p)%:R.
Proof.
have [p_pr | pr'p] := boolP (prime p); last first.
  have p'n n: (n > 0)%N -> p^'.-nat n.
    by move/p'natEpi->; rewrite mem_primes (negPf pr'p).
  rewrite irr1_degree natCK => _ /pnat_1-> => [_ _|].
    by rewrite part_p'nat ?p'n.
  by rewrite p'n ?irr_degree_gt0.
move=> fful_i /p_natP[a Dchi1] sylP cPP.
have Dchi1C: 'chi_i 1%g = (p ^ a)%:R by rewrite -Dchi1 irr1_degree natCK.
have pa_dv_ZiG: (p ^ a %| #|G : 'Z(G)|)%N.
  rewrite -dvdC_nat -[pa in (pa %| _)%C]Dchi1C -(cfcenter_fful_irr fful_i).
  exact: dvd_irr1_index_center.
have [sPG pP p'PiG] := and3P sylP.
have ZchiP: 'Res[P] 'chi_i \in 'CF(P, P :&: 'Z(G)).
  apply/cfun_onP=> x; rewrite inE; have [Px | /cfun0->//] := boolP (x \in P).
  rewrite /= -(cfcenter_fful_irr fful_i) cfResE //.
  apply: coprime_degree_support_cfcenter.
  rewrite Dchi1 coprime_expl // prime_coprime // -p'natE //.
  apply: pnat_dvd p'PiG; rewrite -index_cent1 indexgS // subsetI sPG.
  by rewrite sub_cent1 (subsetP cPP).
have /andP[_ nZG] := center_normal G; have nZP := subset_trans sPG nZG.
apply/eqP; rewrite Dchi1C eqr_nat eqn_dvd -{1}(pfactorK a p_pr) -p_part.
rewrite partn_dvd //= -dvdC_nat -[pa in (_ %| pa)%C]Dchi1C -card_quotient //=.
rewrite -(card_Hall (quotient_pHall nZP sylP)) card_quotient // -indexgI.
rewrite -(cfResE _ sPG) // index_support_dvd_degree ?subsetIl ?cPP ?orbT //.
by rewrite cfRes_char ?irr_char.
Qed.

(* This is Isaacs, Lemma (3.14). *)
(* Note that the assumption that G be cyclic is unnecessary, as S will be     *)
(* empty if this is not the case.                                             *)
Lemma sum_norm2_char_generators gT (G : {group gT}) (chi : 'CF(G)) :
    let S := [pred s | generator G s] in
    chi \is a character -> {in S, forall s, chi s != 0} ->
  \sum_(s in S) `|chi s| ^+ 2 >= #|S|%:R.
Proof.
move=> S Nchi nz_chi_S; pose n := #|G|.
have [g Sg | S_0] := pickP (generator G); last first.
  by rewrite eq_card0 // big_pred0 ?lerr.
have defG: <[g]> = G by apply/esym/eqP.
have [cycG Gg]: cyclic G /\ g \in G by rewrite -defG cycle_cyclic cycle_id.
pose I := {k : 'I_n | coprime n k}; pose ItoS (k : I) := (g ^+ sval k)%g.
have imItoS: codom ItoS =i S.
  move=> s; rewrite inE /= /ItoS /I /n /S -defG -orderE.
  apply/codomP/idP=> [[[i cogi] ->] | Ss]; first by rewrite generator_coprime.
  have [m ltmg Ds] := cyclePmin (cycle_generator Ss).
  by rewrite Ds generator_coprime in Ss; apply: ex_intro (Sub (Sub m _) _) _.
have /injectiveP injItoS: injective ItoS.
  move=> k1 k2 /eqP; apply: contraTeq.
  by rewrite eq_expg_mod_order orderE defG -/n !modn_small.
have [Qn galQn [QnC gQnC [eps [pr_eps defQn] QnG]]] := group_num_field_exists G.
have{QnG} QnGg := QnG _ G _ _ g (order_dvdG Gg).
pose calG := 'Gal({:Qn} / 1).
have /fin_all_exists2[ItoQ inItoQ defItoQ] (k : I):
  exists2 nu, nu \in calG & nu eps = eps ^+ val k.
- case: k => [[m _] /=]; rewrite coprime_sym => /Qn_aut_exists[nuC DnuC].
  have [nuQ DnuQ] := restrict_aut_to_normal_num_field QnC nuC.
  have hom_nu: kHom 1 {:Qn} (linfun nuQ).
    rewrite k1HomE; apply/ahom_inP.
    by split=> [u v | ]; rewrite !lfunE ?rmorphM ?rmorph1.
  have [|nu cGnu Dnu] := kHom_to_gal _ (normalFieldf 1) hom_nu.
    by rewrite !subvf.
  exists nu => //; apply: (fmorph_inj QnC).
  rewrite -Dnu ?memvf // lfunE DnuQ rmorphX DnuC //.
  by rewrite prim_expr_order // fmorph_primitive_root.
have{defQn} imItoQ: calG = ItoQ @: {:I}.
  apply/setP=> nu; apply/idP/imsetP=> [cGnu | [k _ ->] //].
  have pr_nu_e: n.-primitive_root (nu eps) by rewrite fmorph_primitive_root.
  have [i Dnue] := prim_rootP pr_eps (prim_expr_order pr_nu_e).
  rewrite Dnue prim_root_exp_coprime // coprime_sym in pr_nu_e.
  apply: ex_intro2 (Sub i _) _ _ => //; apply/eqP.
  rewrite /calG /= -defQn in ItoQ inItoQ defItoQ nu cGnu Dnue *.
  by rewrite gal_adjoin_eq // defItoQ -Dnue.
have injItoQ: {in {:I} &, injective ItoQ}.
  move=> k1 k2 _ _ /(congr1 (fun nu : gal_of _ => nu eps))/eqP.
  by apply: contraTeq; rewrite !defItoQ (eq_prim_root_expr pr_eps) !modn_small.
pose pi1 := \prod_(s in S) chi s; pose pi2 := \prod_(s in S) `|chi s| ^+ 2.
have Qpi1: pi1 \in Crat.
  have [a Da] := QnGg _ Nchi; suffices ->: pi1 = QnC (galNorm 1 {:Qn} a).
    have /vlineP[q ->] := mem_galNorm galQn (memvf a).
    by rewrite rmorphZ_num rmorph1 mulr1 Crat_rat.
  rewrite /galNorm rmorph_prod -/calG imItoQ big_imset //=.
  rewrite /pi1 -(eq_bigl _ _ imItoS) -big_uniq // big_map big_filter /=.
  apply: eq_bigr => k _;  have [nuC DnuC] := gQnC (ItoQ k); rewrite DnuC Da.
  have [r ->] := char_sum_irr Nchi; rewrite !sum_cfunE rmorph_sum.
  apply: eq_bigr => i _; have /QnGg[b Db] := irr_char i.
  have Lchi_i: 'chi_i \is a linear_char by rewrite irr_cyclic_lin.
  have /(prim_rootP pr_eps)[m Dem]: b ^+ n = 1.
    apply/eqP; rewrite -(fmorph_eq1 QnC) rmorphX Db -lin_charX //.
    by rewrite -expg_mod_order orderE defG modnn lin_char1.
  rewrite -Db -DnuC Dem rmorphX /= defItoQ exprAC -{m}Dem rmorphX {b}Db.
  by rewrite lin_charX.
clear I ItoS imItoS injItoS ItoQ inItoQ defItoQ imItoQ injItoQ.
clear Qn galQn QnC gQnC eps pr_eps QnGg calG.
have{Qpi1} Zpi1: pi1 \in Cint.
  by rewrite Cint_rat_Aint // rpred_prod // => s _; apply: Aint_char.
have{pi1 Zpi1} pi2_ge1: 1 <= pi2.
  have ->: pi2 = `|pi1| ^+ 2.
    by rewrite (big_morph Num.norm (@normrM _) (@normr1 _)) -prodrXl.
  by rewrite Cint_normK // sqr_Cint_ge1 //; apply/prodf_neq0.
have Sgt0: (#|S| > 0)%N by rewrite (cardD1 g) [g \in S]Sg.
rewrite -mulr_natr -ler_pdivl_mulr ?ltr0n //.
have n2chi_ge0 s: s \in S -> 0 <= `|chi s| ^+ 2 by rewrite exprn_ge0 ?normr_ge0.
rewrite -(expr_ge1 Sgt0); last by rewrite divr_ge0 ?ler0n ?sumr_ge0.
by rewrite (ler_trans pi2_ge1) // lerif_AGM.
Qed.

(* This is Burnside's vanishing theorem (Isaacs, Theorem (3.15)). *)
Theorem nonlinear_irr_vanish gT (G : {group gT}) i :
  'chi[G]_i 1%g > 1 -> exists2 x, x \in G & 'chi_i x = 0.
Proof.
move=> chi1gt1; apply/exists_eq_inP; apply: contraFT (ltr_geF chi1gt1).
rewrite negb_exists_in => /forall_inP-nz_chi.
rewrite -(norm_Cnat (Cnat_irr1 i)) -(@expr_le1 _ 2) ?normr_ge0 //.
rewrite -(ler_add2r (#|G|%:R * '['chi_i])) {1}cfnorm_irr mulr1.
rewrite (cfnormE (cfun_onG _)) mulVKf ?neq0CG // (big_setD1 1%g) //=.
rewrite addrCA ler_add2l (cardsD1 1%g) group1 mulrS ler_add2l.
rewrite -sumr_const !(partition_big_imset (fun s => <[s]>)) /=.
apply: ler_sum => _ /imsetP[g /setD1P[ntg Gg] ->].
have sgG: <[g]> \subset G by rewrite cycle_subG.
pose S := [pred s | generator <[g]> s]; pose chi := 'Res[<[g]>] 'chi_i.
have defS: [pred s in G^# | <[s]> == <[g]>] =i S.
  move=> s; rewrite inE /= eq_sym andb_idl // !inE -cycle_eq1 -cycle_subG.
  by move/eqP <-; rewrite cycle_eq1 ntg.
have resS: {in S, 'chi_i =1 chi}.
  by move=> s /cycle_generator=> g_s; rewrite cfResE ?cycle_subG.
rewrite !(eq_bigl _ _ defS) sumr_const.
rewrite (eq_bigr (fun s => `|chi s| ^+ 2)) => [|s /resS-> //].
apply: sum_norm2_char_generators => [|s Ss].
  by rewrite cfRes_char ?irr_char.
by rewrite -resS // nz_chi ?(subsetP sgG) ?cycle_generator.
Qed.

End MoreIntegralChar.


Require Import Imp.
Require Import Maps.

Definition Assertion := state -> Prop.

Definition assert_implies (P Q : Assertion) : Prop :=
  forall st, P st -> Q st.

Definition assert_iff (P Q : Assertion) : Prop := assert_implies P Q /\ assert_implies Q P.

Definition hoare_triple
           (P:Assertion) (c:com) (Q:Assertion) : Prop :=
  forall st st',
     ceval c st st' ->
     P st ->
     Q st'.

Theorem hoare_post_true : forall (P Q : Assertion) c,
  (forall st, Q st) ->
  hoare_triple P c Q.
unfold Assertion.
intros P Q.
intro com.
intro hq.
unfold hoare_triple.
intros src dst.
intro heval.
intro psrc.
apply hq.
Qed.

Theorem hoare_pre_false : forall (P Q : Assertion) c,
  (forall st, ~(P st)) ->
  (hoare_triple P c Q).
unfold Assertion.
intros P Q.
intros com hnp.
unfold hoare_triple.
intros src dst.
intro heval.
intro psrc.
apply hnp in psrc. inversion psrc.
Qed.

Definition assn_sub X a P : Assertion :=
  fun (st : state) =>  P (t_update st X (aeval st a) ).

Theorem hoare_asgn : forall Q X a,
  hoare_triple (assn_sub X a Q) (CAss X a) Q.
intros Q X exp.
unfold hoare_triple.
intros src dst.
intro heval.
unfold assn_sub.
intro hq.
inversion heval as [|src1 exp1 n id hevaln heqid heqsrc hupdate | | | | | ].
subst id. subst exp1. subst src1.
subst n.
assumption.
Qed.

Theorem hoare_consequence_pre : forall (P P' Q : Assertion) c,
  hoare_triple P' c Q ->
  assert_implies P P' ->
  hoare_triple P c Q.
intros P Q R.
intro com.
intro hqr.
intro apq.
unfold assert_implies in apq.
unfold hoare_triple.
intros src dst.
intro heval.
intro psrc.
unfold hoare_triple in hqr.
apply (hqr src).
{ assumption. }
{ apply apq. assumption. }
Qed.

Theorem hoare_consequence_post : forall (P Q Q' : Assertion) c,
  (hoare_triple P c Q') ->
  (assert_implies Q' Q) ->
  (hoare_triple P c Q).
unfold hoare_triple.
unfold assert_implies.
intros P Q R.
intro com.
intro hpr.
intro hrq.
intros src dst.
intro heval.
intro psrc.
apply hrq.
apply (hpr src).
{ assumption. }
{ assumption. }
Qed.

Theorem hoare_consequence : forall (P P' Q Q' : Assertion) c,
  hoare_triple P' c Q' ->
  assert_implies P P' ->
  assert_implies Q' Q ->
  hoare_triple P c Q.
intros P Q R S.
intro com.
intros hqs hpq hsr.
unfold hoare_triple.
intros src dst.
intros heval psrc.
unfold hoare_triple in hqs.
unfold assert_implies in hpq, hsr.
apply hsr.
apply (hqs src).
{ assumption. }
{ apply hpq. assumption. }
Qed.

Theorem hoare_skip : forall P,
     (hoare_triple P CSkip P).
intro P.
unfold hoare_triple.
intros src dst.
intro heval.
inversion heval as [ tmp eq srceq dsteq | | | | | | ].
intro;assumption.
Qed.

Theorem hoare_seq : forall P Q R c1 c2,
     hoare_triple Q c2 R ->
     hoare_triple P c1 Q ->
     hoare_triple P (CSeq c1 c2) R.
unfold hoare_triple.
intros P Q R cam cem.
intros hqr hpq.
intros src dst.
intro heval.
intro psrc.
inversion heval as [ | | cam1 cem1 src1 tmp dst1 cameval cemeval cameq srceq dsteq | | | | ].
subst cam1 cem1 src1 dst1.
apply (hqr tmp).
{ assumption. }
{ apply (hpq src).
  { assumption. }
  { assumption. }
}
Qed.

Definition bassn b : Assertion :=
  fun st => (beval st b = true).

Lemma bexp_eval_true : forall b st,
  beval st b = true -> (bassn b) st.
intros exp st.
intro htrue.
unfold bassn. assumption.
Qed.

Lemma bexp_eval_false : forall b st,
  beval st b = false -> ~ ((bassn b) st).
intros exp st hfalse.
unfold bassn.
intro tata.
rewrite hfalse in tata.
inversion tata.
Qed.

Theorem hoare_if : forall P Q b c1 c2,
  hoare_triple (fun st => P st /\ bassn b st) c1 Q ->
  hoare_triple (fun st => P st /\ ~(bassn b st)) c2 Q ->
  hoare_triple P (CIf b c1 c2) Q.
unfold hoare_triple.
intros P Q exp ctrue cfalse.
intro htrue.
intro hfalse.
intros src dst.
intro heval.
intro psrc.
inversion heval as [ | |
| src1 dst1 exp1 ctrue1 cfalse1 hevaltrue  hcevaltrue  expeq srceq dsteq
| src1 dst1 exp1 ctrue1 cfalse1 hevalfalse hcevalfalse expeq srceq dsteq
| | ].
{
  subst dst1 src1 cfalse1 ctrue1 exp1.
  apply (htrue src).
  {
    assumption.
  }
  { split.
    { assumption. }
    { unfold bassn. assumption. }
  }
}
{
  subst dst1 src1 cfalse1 ctrue1 exp1.
  apply (hfalse src).
  {
    assumption.
  }
  { split.
    { assumption. }
    { intro hn. unfold bassn in hn. rewrite hevalfalse in hn. inversion hn. }
  }
}
Qed.

Theorem hoare_while : forall P b c,
  (hoare_triple (fun st => P st /\ bassn b st) c P ->
  (hoare_triple P (CWhile b c) (fun st => P st /\ ~ (bassn b st)))).
  intros P b c Hhoare st st' He HP.
  remember (CWhile b c ) as wcom eqn:Heqwcom.
  induction He;
    try (inversion Heqwcom); subst; clear Heqwcom.
  - (* E_WhileFalse *)
    split. assumption. apply bexp_eval_false. assumption.
  - (* E_WhileTrue *)
    apply IHHe2. reflexivity.
    apply (Hhoare st st'). assumption.
      split. assumption. apply bexp_eval_true. assumption.
Qed.


Require Import Coq.Numbers.BinNums.
Require Import Coq.PArith.BinPosDef.
Require Import Logic.lib.PTree.
Require Import Coq.Sets.Ensembles.
Require Import Coq.Lists.List.
Require Import Logic.SeparationLogic.Model.OSAGenerators.
Require Import Logic.SeparationLogic.Model.SeparationAlgebra.
Import ListNotations.

Definition var : Type := nat.
Definition val : Type := Z.
Definition addr : Type := nat.
Definition store : Type := var -> val.
Definition heap : Type := addr -> (option val).
Definition store_Join := @equiv_Join store.
Definition heap_Join := @fun_Join addr (option val) (@option_Join val trivial_Join).
Definition store_Unit := @equiv_Unit store.
Definition heap_Unit := @fun_Unit addr (option val) (@option_Unit val).

Module NaiveLang.
  Definition model : Type := store * heap.
  Definition join := @prod_Join store heap store_Join heap_Join.
  Definition is_unit := @prod_Unit store heap store_Unit heap_Unit.
  Definition expr := (model -> Prop).
End NaiveLang.

Require Import Interface.

Module NaiveRule.
Include DerivedNames (NaiveLang).

Definition store_SA := @equiv_SA store.
Definition heap_SA := @fun_SA addr (option val) _ (@option_SA val _ trivial_SA).
Definition join_SA := @prod_SA store heap store_Join heap_Join store_SA heap_SA.

Definition store_UJR := @equiv_UJR store.
Definition heap_UJR := @fun_UJR addr (option val) _ _ (@option_UJR val trivial_Join).
Definition state_UJR := @prod_UJR store heap store_Unit heap_Unit store_Join heap_Join store_UJR heap_UJR.

Lemma join_comm : (forall m1 m2 m : model, join m1 m2 m -> join m2 m1 m) .
Proof.
  pose proof join_SA. induction H. apply join_comm.
Qed.

Lemma join_assoc : (forall mx my mz mxy mxyz : model, join mx my mxy -> join mxy mz mxyz -> exists myz : model, join my mz myz /\ join mx myz mxyz) .
Proof.
  pose proof join_SA. induction H. tauto.
Qed.

End NaiveRule.

Module T := LogicTheorem NaiveLang NaiveRule.
(* Module Solver := IPSolver NaiveLang. *)
Import T.
(* Import Solver. *)