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

Require Import List Permutation Arith Omega.

Require Import utils ill_form.

Set Implicit Arguments.

Local Infix "~p" := (@Permutation _) (at level 70).

Reserved Notation "l '⊢' x" (at level 70, no associativity).

(* Symbols for cut&paste ⟙   ⟘   𝝐  ﹠ ⊗  ⊕  ⊸  ❗   ‼  ∅  ⊢ *)

Inductive ill_proof : list ill_form -> ill_form -> Type :=

  (* These are the SILL rules in the paper *)

  | in_llp_ax     : forall A,                         A::∅ ⊢ A

  | in_llp_perm   : forall Γ Δ A,              Γ ~p Δ     ->   Γ ⊢ A
                                           (*-----------------------------*)
                                      ->                 Δ ⊢ A

  | in_llp_limp_l : forall Γ Δ A B C,          Γ ⊢ A      ->   B::Δ ⊢ C
                                           (*-----------------------------*)
                                      ->           A -o B::Γ++Δ ⊢ C

  | in_llp_limp_r : forall Γ A B,                    A::Γ ⊢ B
                                           (*-----------------------------*)
                                      ->            Γ ⊢ A -o B

  | in_llp_with_l1 : forall Γ A B C,                  A::Γ ⊢ C
                                           (*-----------------------------*)
                                      ->           A﹠B::Γ ⊢ C

  | in_llp_with_l2 : forall Γ A B C,                  B::Γ ⊢ C
                                           (*-----------------------------*)
                                      ->           A﹠B::Γ ⊢ C

  | in_llp_with_r : forall Γ A B,               Γ ⊢ A     ->   Γ ⊢ B
                                           (*-----------------------------*)
                                      ->              Γ ⊢ A﹠B

  | in_llp_bang_l : forall Γ A B,                    A::Γ ⊢ B
                                           (*-----------------------------*)
                                      ->            !A::Γ ⊢ B

  | in_llp_bang_r : forall Γ A,                       ‼Γ ⊢ A
                                           (*-----------------------------*)
                                      ->              ‼Γ ⊢ !A

  | in_llp_weak : forall Γ A B,                        Γ ⊢ B
                                           (*-----------------------------*)
                                      ->           !A::Γ ⊢ B

  | in_llp_cntr : forall Γ A B,                    !A::!A::Γ ⊢ B
                                           (*-----------------------------*)
                                      ->             !A::Γ ⊢ B

  (* These are the other rule for a complete sequent calculus for the whole ILL *)

  | in_llp_cut : forall Γ Δ A B,                 Γ ⊢ A    ->   A::Δ ⊢ B
                                           (*-----------------------------*)
                                      ->              Γ++Δ ⊢ B

  | in_llp_times_l : forall Γ A B C,               A::B::Γ ⊢ C
                                           (*-----------------------------*)
                                      ->            A⊗B::Γ ⊢ C

  | in_llp_times_r : forall Γ Δ A B,             Γ ⊢ A    ->   Δ ⊢ B
                                           (*-----------------------------*)
                                      ->              Γ++Δ ⊢ A⊗B

  | in_llp_plus_l :  forall Γ A B C,            A::Γ ⊢ C  ->  B::Γ ⊢ C
                                           (*-----------------------------*)
                                      ->            A⊕B::Γ ⊢ C

  | in_llp_plus_r1 : forall Γ A B,                    Γ ⊢ A
                                           (*-----------------------------*)
                                      ->              Γ ⊢ A⊕B

  | in_llp_plus_r2 : forall Γ A B,                    Γ ⊢ B
                                           (*-----------------------------*)
                                      ->              Γ ⊢ A⊕B

  | in_llp_bot_l : forall Γ A,                     ⟘::Γ ⊢ A

  | in_llp_top_r : forall Γ,                          Γ ⊢ ⟙

  | in_llp_unit_l : forall Γ A,                       Γ ⊢ A
                                           (*-----------------------------*)
                                      ->           𝝐 ::Γ ⊢ A

  | in_llp_unit_r :                                   ∅ ⊢ 𝝐

where "l ⊢ x" := (ill_proof l x).

Fixpoint ill_cut_free Γ A (p : Γ ⊢ A) :=
  match p with
    | in_llp_ax _          => True
    | in_llp_perm H1 p     => ill_cut_free p
    | in_llp_limp_l p q    => ill_cut_free p /\ ill_cut_free q
    | in_llp_limp_r p      => ill_cut_free p
    | in_llp_with_l1 _ p   => ill_cut_free p
    | in_llp_with_l2 _ p   => ill_cut_free p
    | in_llp_with_r p q    => ill_cut_free p /\ ill_cut_free q
    | in_llp_bang_l p      => ill_cut_free p
    | in_llp_bang_r _ p    => ill_cut_free p
    | in_llp_weak _ p      => ill_cut_free p
    | in_llp_cntr p        => ill_cut_free p
    | in_llp_cut _ _       => False
    | in_llp_times_l p     => ill_cut_free p
    | in_llp_times_r p q   => ill_cut_free p /\ ill_cut_free q
    | in_llp_plus_l p q    => ill_cut_free p /\ ill_cut_free q
    | in_llp_plus_r1 _ p   => ill_cut_free p
    | in_llp_plus_r2 _ p   => ill_cut_free p
    | in_llp_bot_l _ _     => True
    | in_llp_top_r _       => True
    | in_llp_unit_l p      => ill_cut_free p
    | in_llp_unit_r        => True
  end.

Definition ill_cf_provable Γ A := (∃ p : Γ ⊢ A, ill_cut_free p).

Notation "Γ '⊢cf' A" := (ill_cf_provable Γ A) (at level 70, no associativity).

Fact ill_cf_ax A : A::∅ ⊢cf A.
Proof. exists (in_llp_ax A); simpl; auto. Qed.

Fact ill_cf_perm Γ Δ A : Γ ~p Δ -> Γ ⊢cf A -> Δ ⊢cf A.
Proof. intros H1 [p]; exists (in_llp_perm H1 p); simpl; auto. Qed.

Fact ill_cf_limp_l Γ Δ A B C : Γ ⊢cf A -> B::Δ ⊢cf C -> A -o B::Γ++Δ ⊢cf C.
Proof. intros [p] [q]; exists (in_llp_limp_l p q); simpl; auto. Qed.

Fact ill_cf_limp_r Γ A B : A::Γ ⊢cf B -> Γ ⊢cf A -o B.
Proof. intros [p]; exists (in_llp_limp_r p); simpl; auto. Qed.

Fact ill_cf_with_l1 Γ A B C : A::Γ ⊢cf C -> A﹠B::Γ ⊢cf C.
Proof. intros [p]; exists (in_llp_with_l1 B p); simpl; auto. Qed.

Fact ill_cf_with_l2 Γ A B C : B::Γ ⊢cf C -> A﹠B::Γ ⊢cf C.
Proof. intros [p]; exists (in_llp_with_l2 A p); simpl; auto. Qed.

Fact ill_cf_with_r Γ A B : Γ ⊢cf A -> Γ ⊢cf B -> Γ ⊢cf A﹠B.
Proof. intros [p] [q]; exists (in_llp_with_r p q); simpl; auto. Qed.

Fact ill_cf_bang_l Γ A B : A::Γ ⊢cf B -> !A::Γ ⊢cf B.
Proof. intros [p]; exists (in_llp_bang_l p); simpl; auto. Qed.

Fact ill_cf_bang_r Γ A : ‼Γ ⊢cf A -> ‼Γ ⊢cf !A.
Proof. intros [p]; exists (in_llp_bang_r _ p); simpl; auto. Qed.

Fact ill_cf_weak Γ A B : Γ ⊢cf B -> !A::Γ ⊢cf B.
Proof. intros [p]; exists (in_llp_weak A p); simpl; auto. Qed.

Fact ill_cf_cntr Γ A B : !A::!A::Γ ⊢cf B -> !A::Γ ⊢cf B.
Proof. intros [p]; exists (in_llp_cntr p); simpl; auto. Qed.

Fact ill_cf_times_l Γ A B C : A::B::Γ ⊢cf C -> A⊗B::Γ ⊢cf C.
Proof. intros [p]; exists (in_llp_times_l p); simpl; auto. Qed.

Fact ill_cf_times_r Γ Δ A B : Γ ⊢cf A -> Δ ⊢cf B -> Γ++Δ ⊢cf A⊗B.
Proof. intros [p] [q]; exists (in_llp_times_r p q); simpl; auto. Qed.

Fact ill_cf_plus_l Γ A B C : A::Γ ⊢cf C -> B::Γ ⊢cf C -> A⊕B::Γ ⊢cf C.
Proof. intros [p] [q]; exists (in_llp_plus_l p q); simpl; auto. Qed.

Fact ill_cf_plus_r1 Γ A B : Γ ⊢cf A -> Γ ⊢cf A⊕B.
Proof. intros [p]; exists (in_llp_plus_r1 _ p); simpl; auto. Qed.

Fact ill_cf_plus_r2 Γ A B : Γ ⊢cf B -> Γ ⊢cf A⊕B.
Proof. intros [p]; exists (in_llp_plus_r2 _ p); simpl; auto. Qed.

Fact ill_cf_bot_l Γ A : ⟘::Γ ⊢cf A.
Proof. exists (in_llp_bot_l _ _); simpl; auto. Qed.

Fact ill_cf_top_r Γ : Γ ⊢cf ⟙.
Proof. exists (in_llp_top_r _); simpl; auto. Qed.

Fact ill_cf_unit_l Γ A : Γ ⊢cf A -> 𝝐 ::Γ ⊢cf A.
Proof. intros [p]; exists (in_llp_unit_l p); simpl; auto. Qed.

Fact ill_cf_unit_r : ∅ ⊢cf 𝝐.
Proof. exists (in_llp_unit_r); simpl; auto. Qed.

Fact ill_cf_weak_ctx Γ Δ A : Δ ⊢cf A -> ‼Γ++Δ ⊢cf A.
Proof.
  intros H.
  induction Γ as [ | B ga IH ]; simpl; auto.
  apply ill_cf_weak; auto.
Qed.

Fact ill_cf_cntr_ctx Γ Δ A : ‼Γ++‼Γ++Δ ⊢cf A -> ‼Γ++Δ ⊢cf A.
Proof.
  revert Δ.
  induction Γ as [ | B ga IH ]; simpl; auto; intros de H.
  apply ill_cf_perm with (‼ga++!B::de).
  { apply Permutation_sym, Permutation_cons_app; auto. }
  apply IH.
  apply ill_cf_perm with (!B::‼ga++‼ga++de).
  { apply Permutation_sym; focus (!B); apply Permutation_sym.
    apply Permutation_cons_app; rewrite app_assoc; auto. }
  apply ill_cf_cntr.
  revert H; apply ill_cf_perm.
  constructor 2.
  apply Permutation_sym, Permutation_cons_app; auto.
Qed.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e141m9_6limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e338m15_6limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Require Import Undecidability.Synthetic.Definitions Undecidability.Synthetic.ReducibilityFacts.

Require Import Undecidability.TM.TM.
Require Import Undecidability.StringRewriting.SR.

Require Undecidability.TM.Reductions.HaltTM_1_to_SBTM_HALT.
Require Undecidability.StringRewriting.Reductions.SBTM_HALT_to_SR.

(* Many-one reduction from Turing machine halting to string rewriting *)
Theorem reduction : HaltTM 1 ⪯ SR.
Proof.
  apply (reduces_transitive HaltTM_1_to_SBTM_HALT.reduction).
  exact SBTM_HALT_to_SR.reduction.
Qed.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e150m3_7limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e174m17_7limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e189m25_5limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e171m19_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Tactics.

Global Set Primitive Projections.

Global Set Universe Polymorphism.

Global Unset Universe Minimization ToSet.

Class Category : Type :=
{
  Obj : Type;
  Hom : Obj -> Obj -> Type;
  compose : forall {a b c : Obj}, (Hom a b) -> (Hom b c) -> (Hom a c);
  id : forall {a : Obj}, Hom a a;
}.

Arguments Obj {_}, _.
Arguments id {_ _}, {_} _, _ _.
Arguments Hom {_} _ _, _ _ _.
Arguments compose {_} {_ _ _} _ _, _ {_ _ _} _ _, _ _ _ _ _ _.

Coercion Obj : Category >-> Sortclass.

Definition Opposite (C : Category) : Category :=
{|

  Obj := Obj C;
  Hom := fun a b => Hom b a;
  compose :=
    fun a b c (f : Hom b a) (g : Hom c b) => compose C c b a g f;
  id := fun c => id C c;
|}.

Record Functor (C C' : Category) : Type :=
{
  FO : C -> C';
  FA : forall {a b}, Hom a b -> Hom (FO a) (FO b);
}.

Arguments FO {_ _} _ _.
Arguments FA {_ _} _ {_ _} _, {_ _} _ _ _ _.

Section Opposite_Functor.
  Context {C D : Category} (F : Functor C D).

  Program Definition Opposite_Functor : (Functor (Opposite C) (Opposite D)) :=
    {|
      FO := FO F;
      FA := fun _ _ h => FA F h;
    |}.

End Opposite_Functor.

Section Functor_Compose.
  Context {C C' C'' : Category} (F : Functor C C') (F' : Functor C' C'').

  Program Definition Functor_compose : Functor C C'' :=
    {|
      FO := fun c => FO F' (FO F c);
      FA := fun c d f => FA F' (FA F f)
    |}.

End Functor_Compose.

Section Algebras.
  Context {C : Category} (T : Functor C C).
  Record Algebra : Type :=
    {
      Alg_Carrier : C;
      Constructors : Hom (FO T Alg_Carrier) Alg_Carrier
    }.

  Record Algebra_Hom (alg alg' : Algebra) : Type :=
    {
      Alg_map : Hom (Alg_Carrier alg) (Alg_Carrier alg');

      Alg_map_com : compose (FA T Alg_map) (Constructors alg')
                     = compose (Constructors alg) Alg_map
    }.

  Arguments Alg_map {_ _} _.
  Arguments Alg_map_com {_ _} _.
  Program Definition Algebra_Hom_compose
          {alg alg' alg'' : Algebra}
          (h : Algebra_Hom alg alg')
          (h' : Algebra_Hom alg' alg'')
    : Algebra_Hom alg alg''
    :=
      {|
        Alg_map := compose (Alg_map h) (Alg_map h')
      |}.

  Next Obligation. Proof. Admitted.

  Lemma Algebra_Hom_eq_simplify (alg alg' : Algebra)
        (ah ah' : Algebra_Hom alg alg')
    : (Alg_map ah) = (Alg_map ah') -> ah = ah'.
  Proof. Admitted.

  Program Definition Algebra_Hom_id (alg : Algebra) : Algebra_Hom alg alg :=
    {|
      Alg_map := id
    |}.

  Next Obligation. Admitted.

  Definition Algebra_Cat : Category :=
    {|
      Obj := Algebra;
      Hom := Algebra_Hom;
      compose := @Algebra_Hom_compose;
      id := Algebra_Hom_id;
    |}.

End Algebras.

Arguments Alg_Carrier {_ _} _.
Arguments Constructors {_ _} _.
Arguments Algebra_Hom {_ _} _ _.
Arguments Alg_map {_ _ _ _} _.
Arguments Alg_map_com {_ _ _ _} _.
Arguments Algebra_Hom_id {_ _} _.

Section CoAlgebras.
  Context {C : Category}.

  Definition CoAlgebra (T : Functor C C) :=
    @Algebra (Opposite C) (Opposite_Functor T).

  Definition CoAlgebra_Hom {T : Functor C C} :=
      @Algebra_Hom (Opposite C) (Opposite_Functor T).

  Definition CoAlgebra_Hom_id {T : Functor C C} :=
    @Algebra_Hom_id  (Opposite C) (Opposite_Functor T).

  Definition CoAlgebra_Cat (T : Functor C C) :=
    @Algebra_Cat (Opposite C) (Opposite_Functor T).

End CoAlgebras.

Program Definition Type_Cat : Category :=
{|
  Obj := Type;
  Hom := (fun A B => A -> B);
  compose := fun A B C (g : A -> B) (h : B -> C) => fun (x : A) => h (g x);
  id := fun A => fun x => x
|}.

Local Obligation Tactic := idtac.

Program Definition Prod_Cat (C C' : Category) : Category :=
{|
  Obj := C * C';
  Hom :=
    fun a b =>
      ((Hom (fst a) (fst b)) * (Hom (snd a) (snd b)))%type;
  compose :=
    fun a b c f g =>
      ((compose (fst f) (fst g)), (compose (snd f)(snd g)));
  id := fun c => (id, id)
|}.

Class Terminal (C : Category) : Type :=
{
  terminal : C;
  t_morph : forall (d : Obj), Hom d terminal;
  t_morph_unique : forall (d : Obj) (f g : (Hom d terminal)), f = g
}.

Arguments terminal {_} _.
Arguments t_morph {_} _ _.
Arguments t_morph_unique {_} _ _ _ _.

Coercion terminal : Terminal >-> Obj.

Definition Initial (C : Category) := Terminal (Opposite C).
Existing Class Initial.

Record Product {C : Category} (c d : C) : Type :=
{
  product : C;
  Pi_1 : Hom product c;
  Pi_2 : Hom product d;
  Prod_morph_ex : forall (p' : Obj) (r1 : Hom p' c) (r2 : Hom p' d), (Hom p' product);
}.

Arguments Product _ _ _, {_} _ _.

Arguments Pi_1 {_ _ _ _}, {_ _ _} _.
Arguments Pi_2 {_ _ _ _}, {_ _ _} _.
Arguments Prod_morph_ex {_ _ _} _ _ _ _.

Coercion product : Product >-> Obj.

Definition Has_Products (C : Category) : Type := forall a b, Product a b.

Existing Class Has_Products.

Program Definition Prod_Func (C : Category) {HP : Has_Products C}
  : Functor (Prod_Cat C C) C :=
{|
  FO := fun x => HP (fst x) (snd x);
  FA := fun a b f => Prod_morph_ex _ _ (compose Pi_1 (fst f)) (compose  Pi_2 (snd f))
|}.

Arguments Prod_Func _ _, _ {_}.

Definition Sum (C : Category) := @Product (Opposite C).

Arguments Sum _ _ _, {_} _ _.

Definition Has_Sums (C : Category) : Type :=  forall (a b : C), (Sum a b).

Existing Class Has_Sums.

Program Definition sum_Sum (A B : Type) : (@Sum Type_Cat A B) :=
{|
  product := (A + B)%type;
  Prod_morph_ex :=
    fun (p' : Type)
        (r1 : A -> p')
        (r2 : B -> p')
        (X : A + B) =>
      match X return p' with
      | inl a => r1 a
      | inr b => r2 b
      end
|}.
Next Obligation. simpl; auto. Defined.
Next Obligation. simpl; auto. Defined.

Program Instance Type_Cat_Has_Sums : Has_Sums Type_Cat := sum_Sum.

Definition Sum_Func {C : Category} {HS : Has_Sums C} :
  Functor (Prod_Cat C C) C := Opposite_Functor (Prod_Func (Opposite C) HS).

Arguments Sum_Func _ _, _ {_}.

Program Instance unit_Type_term : Terminal Type_Cat :=
{
  terminal := unit;
  t_morph := fun _ _=> tt
}.

Next Obligation. Proof. Admitted.

Program Definition term_id : Functor Type_Cat (Prod_Cat Type_Cat Type_Cat) :=
{|
  FO := fun a => (@terminal Type_Cat _, a);
  FA := fun a b f => (@id _ (@terminal Type_Cat _), f)
|}.

Definition S_nat_func : Functor Type_Cat Type_Cat :=
  Functor_compose term_id (Sum_Func Type_Cat _).

Definition S_nat_alg_cat := Algebra_Cat S_nat_func.

CoInductive CoNat : Set :=
  | CoO : CoNat
  | CoS : CoNat -> CoNat
.

Definition S_nat_coalg_cat := @CoAlgebra_Cat Type_Cat S_nat_func.

Set Printing Universes.
Program Definition CoNat_alg_term : Initial S_nat_coalg_cat :=
{|
  terminal := _;
  t_morph := _
|}.

Next Obligation. Admitted.
Next Obligation. Admitted.

Axiom Admit : False.

Next Obligation.
Proof.
  intros d f g.
  assert(H1 := (@Alg_map_com _ _ _ _ f)). clear.
  assert (inl tt = inr tt) by (exfalso; apply Admit).
  discriminate.
  all: exfalso; apply Admit.
  Show Universes.
Qed.


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

(** * Relations over pairs *)

Require Import SetoidList.
Require Import Relations Morphisms.
(* NB: This should be system-wide someday, but for that we need to
    fix the simpl tactic, since "simpl fst" would be refused for
    the moment.

Arguments fst {A B}.
Arguments snd {A B}.
Arguments pair {A B}.

/NB *)

Local Notation Fst := (@fst _ _).
Local Notation Snd := (@snd _ _).

Arguments relation_conjunction A%type (R R')%signature _ _.
Arguments relation_equivalence A%type (_ _)%signature.
Arguments subrelation A%type (R R')%signature.
Arguments Reflexive A%type R%signature.
Arguments Irreflexive A%type R%signature.
Arguments Symmetric A%type R%signature.
Arguments Transitive A%type R%signature.
Arguments PER A%type R%signature.
Arguments Equivalence A%type R%signature.
Arguments StrictOrder A%type R%signature.

Generalizable Variables A B RA RB Ri Ro f.

(** Any function from [A] to [B] allow to obtain a relation over [A]
    out of a relation over [B]. *)

Definition RelCompFun {A} {B : Type}(R:relation B)(f:A->B) : relation A :=
 fun a a' => R (f a) (f a').

(** Instances on RelCompFun must match syntactically *)
Typeclasses Opaque RelCompFun.

Infix "@@" := RelCompFun (at level 30, right associativity) : signature_scope.

Notation "R @@1" := (R @@ Fst)%signature (at level 30) : signature_scope.
Notation "R @@2" := (R @@ Snd)%signature (at level 30) : signature_scope.

(** We declare measures to the system using the [Measure] class.
   Otherwise the instances would easily introduce loops,
   never instantiating the [f] function.  *)

Class Measure {A B} (f : A -> B).

(** Standard measures. *)

Instance fst_measure : @Measure (A * B) A Fst.
Instance snd_measure : @Measure (A * B) B Snd.

(** We define a product relation over [A*B]: each components should
    satisfy the corresponding initial relation. *)

Definition RelProd {A : Type} {B : Type} (RA:relation A)(RB:relation B) : relation (A*B) :=
 relation_conjunction (@RelCompFun (A * B) A RA fst) (RB @@2).

Typeclasses Opaque RelProd.

Infix "*" := RelProd : signature_scope.

Section RelCompFun_Instances.
  Context {A : Type} {B : Type} (R : relation B).

  Global Instance RelCompFun_Reflexive
    `(Measure A B f, Reflexive _ R) : Reflexive (R@@f).
  Proof. firstorder. Qed.

  Global Instance RelCompFun_Symmetric
    `(Measure A B f, Symmetric _ R) : Symmetric (R@@f).
  Proof. firstorder. Qed.

  Global Instance RelCompFun_Transitive
    `(Measure A B f, Transitive _ R) : Transitive (R@@f).
  Proof. firstorder. Qed.

  Global Instance RelCompFun_Irreflexive
    `(Measure A B f, Irreflexive _ R) : Irreflexive (R@@f).
  Proof. firstorder. Qed.

  Global Program Instance RelCompFun_Equivalence
    `(Measure A B f, Equivalence _ R) : Equivalence (R@@f).

  Global Program Instance RelCompFun_StrictOrder
    `(Measure A B f, StrictOrder _ R) : StrictOrder (R@@f).

End RelCompFun_Instances.

Section RelProd_Instances.

  Context {A : Type} {B : Type} (RA : relation A) (RB : relation B).

  Global Instance RelProd_Reflexive `(Reflexive _ RA, Reflexive _ RB) : Reflexive (RA*RB).
  Proof. firstorder. Qed.

  Global Instance RelProd_Symmetric `(Symmetric _ RA, Symmetric _ RB)
  : Symmetric (RA*RB).
  Proof. firstorder. Qed.

  Global Instance RelProd_Transitive
           `(Transitive _ RA, Transitive _ RB) : Transitive (RA*RB).
  Proof. firstorder. Qed.

  Global Program Instance RelProd_Equivalence
          `(Equivalence _ RA, Equivalence _ RB) : Equivalence (RA*RB).

  Lemma FstRel_ProdRel :
    relation_equivalence (RA @@1) (RA*(fun _ _ : B => True)).
  Proof. firstorder. Qed.

  Lemma SndRel_ProdRel :
    relation_equivalence (RB @@2) ((fun _ _ : A =>True) * RB).
  Proof. firstorder. Qed.

  Global Instance FstRel_sub :
    subrelation (RA*RB) (RA @@1).
  Proof. firstorder. Qed.

  Global Instance SndRel_sub :
    subrelation (RA*RB) (RB @@2).
  Proof. firstorder. Qed.

  Global Instance pair_compat :
    Proper (RA==>RB==> RA*RB) (@pair _ _).
  Proof. firstorder. Qed.

  Global Instance fst_compat :
    Proper (RA*RB ==> RA) Fst.
  Proof.
    intros (x,y) (x',y') (Hx,Hy); compute in *; auto.
  Qed.

  Global Instance snd_compat :
    Proper (RA*RB ==> RB) Snd.
  Proof.
    intros (x,y) (x',y') (Hx,Hy); compute in *; auto.
  Qed.

  Global Instance RelCompFun_compat (f:A->B)
           `(Proper _ (Ri==>Ri==>Ro) RB) :
    Proper (Ri@@f==>Ri@@f==>Ro) (RB@@f)%signature.
  Proof. unfold RelCompFun; firstorder. Qed.
End RelProd_Instances.

Hint Unfold RelProd RelCompFun.
Hint Extern 2 (RelProd _ _ _ _) => split.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)

(*****************************************************************************)
(*  Theory of reverse polynomial and relation to roots and multiplicity.     *)
(*****************************************************************************)

Require Import mathcomp.ssreflect.ssreflect.
From mathcomp
Require Import ssrbool ssrfun eqtype ssrnat seq choice fintype finset finfun.
From mathcomp
Require Import div tuple finfun bigop ssralg poly polydiv zmodp.
From Newtonsums Require Import auxresults.

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

Import GRing.Theory.
Local Open Scope ring_scope.

Section Valuation.

Variable (R : ringType).
Implicit Types (p : {poly R}).

Definition valp p : nat :=
  if size p is n.+1 then [arg min_(i < (ord_max : 'I_n.+1) | p`_i != 0) i]
  else 0%N.

Lemma valp_small p : p != 0 -> valp p < size p.
Proof. by rewrite -size_poly_gt0 /valp; case: size. Qed.

CoInductive valp_spec p : nat -> Prop :=
| ValpSpec0 of p = 0 : valp_spec p 0
| ValpSpecN0 n of p != 0 & p`_n != 0
  & (forall m, m < n -> p`_m = 0) : valp_spec p n.

Lemma valpP p : valp_spec p (valp p).
Proof.
rewrite /valp; case size_p: size => [|m].
  by constructor; apply/size_poly_leq0P; rewrite size_p.
have p_neq0 : p != 0  by rewrite -size_poly_eq0 size_p.
have [|/= i pi_neq0 i_min] := arg_minP.
  by rewrite /= -[m]/m.+1.-1 -size_p -lead_coefE lead_coef_eq0.
constructor => // k; rewrite ltnNge; apply/contraNeq.
have [k_small|k_big] := ltnP k m.+1; last first.
  by rewrite nth_default ?eqxx // size_p.
by move=> /(i_min (Ordinal k_small)).
Qed.

Lemma valp0 : valp 0 = 0%N.
Proof. by case: valpP => // n; rewrite coef0 eqxx. Qed.

Lemma valp_eqn n p : p`_n != 0 -> (forall m, m < n -> p`_m = 0) -> valp p = n.
Proof.
move=> pn_neq0 n_min; have [p_eq0|n' p_neq0 pn'_neq0 n'_min] := valpP.
  by rewrite p_eq0 coef0 eqxx in pn_neq0.
have [/n_min /eqP /negPn|/n'_min /eqP /negPn|//] := ltngtP n' n;
by rewrite ?pn_neq0 ?pn'_neq0.
Qed.

Lemma valp_coef_eq0 p n : n < valp p -> p`_n = 0.
Proof. by case: valpP => // m ? pm_neq0 m_small /m_small. Qed.

Lemma valp_eq0E p : p != 0 -> (valp p == 0%N) = (p`_0 != 0).
Proof.
case: valpP => [->|[|n] p_neq0 pn_neq0 n_min _]; first by rewrite !eqxx.
  by rewrite eqxx pn_neq0.
by rewrite n_min ?eqxx.
Qed.

Lemma valp_eq0 p : p`_0 != 0 -> valp p = 0%N.
Proof. by move=> /valp_eqn ->. Qed.

Lemma coef_valp_neq0 p : p != 0 -> p`_(valp p) != 0.
Proof. by case: valpP => // ->; rewrite eqxx. Qed.

Lemma valp_leq p : valp p <= size p.
Proof.
case: valpP => //= n ? pn_neq0 _; rewrite leqNgt.
by apply: contra pn_neq0 => ?; rewrite nth_default // ltnW.
Qed.

Lemma valp_leqif p : valp p <= size p ?= iff (p == 0).
Proof.
apply/leqifP; have [->|p_neq0] := altP eqP; first by rewrite valp0 size_poly0.
by rewrite valp_small.
Qed.

Lemma valpC c : valp c%:P = 0%N.
Proof. by have [->|?] := altP (c =P 0); rewrite ?valp0 ?valp_eq0 ?coefC. Qed.

Lemma valpMXn p n : p != 0 -> valp (p * 'X^n) = (valp p + n)%N.
Proof.
move=> p_neq0; apply: valp_eqn=> [|m m_small]; rewrite coefMXn ?addnK.
  by rewrite addnC -ltn_subRL subnn /= coef_valp_neq0.
by have [//|le_nm] := ltnP m n; rewrite valp_coef_eq0 ?leq_ltn_subLR // addnC.
Qed.

Lemma valpXn n : valp 'X^n = n.
Proof. by rewrite -['X^n]mul1r valpMXn ?oner_eq0 ?valpC. Qed.

CoInductive valpXn_spec p : {poly R} -> nat -> Prop :=
| ValpSpecXn0 : valpXn_spec p 0 0
| ValpSpecXnN0 n (q : {poly R}) of q != 0 & q`_0 != 0 :
    valpXn_spec p (q * 'X^n) n.

Lemma valpXP p : valpXn_spec p p (valp p).
Proof.
have [->|p_neq0] := eqVneq p 0; first by rewrite valp0; constructor.
pose q := (\poly_(i < size p) p`_(i + valp p)).
have q0N0 : q`_0 != 0 by rewrite coef_poly size_poly_gt0 p_neq0 coef_valp_neq0.
have q_neq0 : q != 0 by apply: contraNneq q0N0 => ->; rewrite coef0.
suff {2}-> : p = q * 'X^(valp p) by constructor.
apply/polyP => i; rewrite coefMXn; have [i_small|i_inter] := ltnP.
  by rewrite valp_coef_eq0.
rewrite coef_poly ?subnK //; case: ltnP => //= i_big.
by rewrite nth_default // (leq_trans i_big) ?leq_subr.
Qed.

Lemma valpM_id0 (p q : {poly R}) : p`_(valp p) * q`_(valp q) != 0 ->
                  valp (p * q) = (valp p + valp q)%N.
Proof.
case: valpXP=> [|m {p} p pN0 p0N0]; rewrite ?coef0 ?(mulr0, mul0r) ?eqxx //.
case: valpXP=> [|n {q} q qN0 q0N0]; rewrite ?coef0 ?(mulr0, mul0r) ?eqxx //.
rewrite !coefMXn ?ltnn ?subnn -coef0M => p0q0_neq0.
have pq_neq : p * q != 0 by apply: contraNneq p0q0_neq0 => ->; rewrite coef0.
rewrite mulrA -[(p * _ * _)]mulrA -commr_polyXn mulrA -mulrA -exprD.
by rewrite valpMXn // valp_eq0.
Qed.

Lemma valpN p : valp (- p) = valp p.
Proof.
have [->|p_neq0] := eqVneq p 0; first by rewrite oppr0.
apply: valp_eqn=> [|m]; rewrite coefN ?oppr_eq0 ?coef_valp_neq0 //.
by move=> /valp_coef_eq0 ->; rewrite oppr0.
Qed.

Lemma leqif_valpD (p q : {poly R}) : p != 0 -> q != 0 -> p + q != 0 ->
  minn (valp p) (valp q) <= valp (p + q) ?= iff
  ((valp p == valp q) ==> (p`_(valp p) + q`_(valp q) != 0)).
Proof.
wlog le_mn : p q / valp p <= valp q => [hwlog|]; last rewrite (minn_idPl _) //.
  have /orP [le_mn|le_nm] := leq_total (valp p) (valp q); first exact: hwlog.
  move=> *; rewrite minnC addrC eq_sym [_`__ + _]addrC.
  by apply: (hwlog q p) => //; rewrite addrC.
case: valpXP=> [|m {p} p pN0 p0N0] in le_mn *; rewrite ?eqxx => //= _.
case: valpXP=> [|n {q} q qN0 q0N0] in le_mn *; rewrite ?eqxx => //= _.
rewrite !coefMXn ?ltnn ?subnn -coefD.
move: le_mn; rewrite leq_eqVlt => /orP [/eqP eq_mn|lt_mn].
  rewrite eq_mn eqxx -mulrDl implyTb.
  rewrite -lead_coef_eq0 lead_coefMXn lead_coef_eq0 => pDq_eq0.
  rewrite valpMXn // -{1}[n]add0n -[X in _ <= _ ?= iff X]andbT.
  apply: leqif_add; last exact/leqif_refl.
  apply/leqifP; rewrite [0%N == _]eq_sym; case: (altP eqP) => pq0 /=.
    by rewrite lt0n valp_eq0E // negbK pq0.
  by rewrite valp_eq0.
rewrite ltn_eqF // implyFb => H; apply/leqifP; move: H.
rewrite -(subnK lt_mn) addnS -addSn exprD mulrA -mulrDl; set r := p + _.
have r0N0 : r`_0 != 0 by rewrite coefD coefMXn // addr0.
have rN0 : r != 0 by apply: contraNneq r0N0 => ->; rewrite coef0.
by rewrite valpMXn // valp_eq0.
Qed.

Lemma valpD (p q : {poly R}) : p != 0 -> q != 0 ->
  ((valp p == valp q) ==> (p`_(valp p) + q`_(valp q) != 0)) ->
  valp (p + q) = minn (valp p) (valp q).
Proof.
move=> p_neq0 q_neq0 Hpq; apply/eqP; rewrite eq_sym leqif_valpD //.
apply: contraTN Hpq; rewrite addrC addr_eq0 => /eqP ->.
by rewrite valpN coefN subrr !eqxx.
Qed.

End Valuation.


Require Import
  Coq.Program.Program
  Coq.Program.Tactics
  Coq.Sets.Ensembles
  Hask.Control.Monad.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Definition Comp (A : Type) := A -> Prop.

Program Instance Comp_Functor : Functor Comp := {
  fmap := fun A B f (x : Comp A) b => exists a : A, x a /\ f a = b
}.

Program Instance Comp_Applicative : Applicative Comp := {
  pure := fun _ x a => x = a;
  ap   := fun A B mf mx r => exists f x, mf f /\ mx x /\ f x = r
}.

Program Instance Comp_Alternative : Alternative Comp := {
  empty  := fun A _ => False;
  choose := fun A x y s => x s \/ y s (* jww (2016-01-28): right? *)
}.

Program Instance Comp_Monad : Monad Comp := {
  join := fun A m r => exists t : Comp A, t r /\ m t
}.

Module CompLaws.

Import MonadLaws.

Require Import FunctionalExtensionality.

Axiom prop_ext : forall (P Q : Prop), (P <-> Q) -> P = Q.

Ltac shatter :=
  unfold comp, id in *;
  repeat
    match goal with
    | [ H : _ = _           |- _               ] => subst
    | [ H : and _ _         |- _               ] => destruct H
    | [ H : exists _ : _, _ |- _               ] => destruct H
    | [                     |- exists _ : _, _ ] => eexists
    | [                     |- and _ _         ] => split
    end;
  simpl in *.

Ltac simplify_comp :=
  repeat let x := fresh "x" in extensionality x;
  try (apply prop_ext; split; intros);
  repeat (simpl; shatter; try constructor; eauto).

Local Obligation Tactic := simpl; intros; simplify_comp.

Program Instance Comp_FunctorLaws     : FunctorLaws Comp.
Program Instance Comp_ApplicativeLaws : ApplicativeLaws Comp.
Program Instance Comp_MonadLaws       : MonadLaws Comp.

End CompLaws.

Definition comp `(f : A -> Prop) : Comp A := f.

Definition computes_to {A : Type} (ca : Comp A) (a : A) : Prop := ca a.

Notation "c ↝ v" := (computes_to c v) (at level 40).


(** * Trie:  Number Representations and Efficient Lookup Tables *)

(* ################################################################# *)
(** * LogN Penalties in Functional Programming *)

(** Purely functional algorithms sometimes suffer from an asymptotic
  slowdown of order logN compared to imperative algorithms.  The
  reason is that imperative programs can do _indexed array update_
  in constant time, while functional programs cannot.

  Let's take an example.  Give an algorithm for detecting duplicate
  values in a sequence of N integers, each in the range 0..2N.
  As an imperative program, there's a very simple linear-time algorithm:

  collisions=0;
  for (i=0; i<2N; i++)
     a[i]=0;
  for (j=0; j<N; j++) {
     i = input[j];
     if (a[i] != 0)
       collisions++;
     a[i]=1;
  }
  return collisions;

  In a functional program, we must replace [a[i]=1] with the update
  of a finite map.  If we use the inefficient maps in [Maps.v], each
  lookup and update will take (worst-case) linear time, and the whole
  algorithm is quadratic time.  If we use balanced binary search trees
  [Redblack.v], each lookup and update will take (worst-case) logN time,
  and the whole algorithm takes NlogN.  Comparing O(NlogN) to O(N),
  we see that there is a logN asymptotic penalty for using a functional
  implementation of finite maps.  This penalty arises not only in this
  "duplicates" algorithm, but in any algorithm that relies on random
  access in arrays.

  One way to avoid this problem is to use the imperative (array) features
  of a not-really-functional language such as ML.  But that's not really
  a functional program!  In particular, in _Verified Functional Algorithms_
  we prove program correct by relying on the _tractable proof theory_
  of purely functional programs; if we use nonfunctional features of ML,
  then this style of proof will not work.  We'd have to use something like
  Hoare logic instead (see [Hoare.v] in volume 2 of _Software Foundations_),
  and that is not _nearly_ as nice.

  Another choice is to use a purely functional programming language
  designed for imperative programming:  Haskell with the IO monad.
  The IO monad provides a pure-functional interface to efficient random-access
  arrays.  This might be a reasonable approach, but we will not cover it
  here.

  Here, we accept the logN penalty, and focus on making the "constant
  factors" small: that is, let us at least have efficient functional finite maps.

  [Extract] showed one approach: use Ocaml integers.
  The advantage: constant-time greater-than comparison.
  The disadvantages: (1) Need to make sure you axiomatize them correctly
   in Coq, otherwise your proofs are unsound.  (2) Can't easily axiomatize
   addition, multiplication, subtraction, because Ocaml integers don't
   behave like the "mathematical" integers upon 31-bit (or 63-bit) overflow.
   (3) Can _only_ run the programs in Ocaml, not inside Coq.

   So let's examine another approach, which is quite standard inside Coq:
   use a construction in Coq of arbitrary-precision binary numbers,
   with logN-time addition, subtraction, and comparison. *)

(* ################################################################# *)
(** * A Simple Program That's Waaaaay Too Slow. *)

From Coq Require Import Strings.String.  (* for manual grading *)
From VFA Require Import Perm.
From VFA Require Import Maps.
Import FunctionalExtensionality.

Module VerySlow.

Fixpoint loop (input: list nat) (c: nat) (table: total_map bool) : nat :=
  match input with
  | nil => c
  | a::al => if table a
                  then loop al (c+1) table
                  else loop al c (t_update table a true)
 end.

Definition collisions (input: list nat) : nat :=
       loop input 0 (t_empty false).

Example collisions_pi: collisions [3;1;4;1;5;9;2;6] = 1.
Proof. reflexivity. Qed.

(** This program takes cubic time, O(N^3).   Let's assume that there are
      few duplicates, or none at all.  There are [N] iterations
      of [loop], each iteration does a [table] lookup, most iterations do
      a [t_update] as well, and those operations each do [N] comparisons.
      The average length of the [table] (the number of elements) averages
      only N/2, and (if there are few duplicates) the lookup will have to
      traverse the entire list, so really in each iteration there will be only
      [N/2] comparisons instead of [N], but in asymptotic analysis we ignore
      the constant factors.

      So far it seems like this is a quadratic-time algorithm, O(N^2).  But
      to compare Coq natural numbers for equality takes O(N) time as well: *)

Print eqb.
 (* fix eqb (n m : nat) {struct n} : bool :=
  match n with
  | 0 => match m with 0 => true | S _ => false end
  | S n1 => match m with 0 => false | S m1 => eqb n1 m1 end
  end *)

(** Remember, [nat] is a unary representation, with a number of [S] constructors
     proportional to the number being represented! *)

End VerySlow.

(* ################################################################# *)
(** * Efficient Positive Numbers

    We can do better; we _must_ do better.  In fact, Coq's integer type,
     called [Z], is a binary representation (not unary), so that operations
     such as [plus] and [leq] take time linear in the number of bits, that is,
     logarithmic in the value of the numbers.  Here we will explore how [Z]
     is built. *)

Module Integers.

(** We start with positive numbers. *)

Inductive positive : Set :=
  | xI : positive -> positive
  | xO : positive -> positive
  | xH : positive.

(** A positive number is either
     -    1, that is, [xH]
     -    0+2n, that is,  [xO n]
     -    1+2n, that is,  [xI n].
    For example, ten is 0+2(1+2(0+2(1))).
*)

Definition ten := xO (xI (xO xH)).

(** To interpret a [positive] number as a [nat], *)

Fixpoint positive2nat (p: positive) : nat :=
  match p with
  | xI q => 1 + 2 * positive2nat q
  | xO q => 0 + 2 * positive2nat q
  | xH => 1
 end.

Eval compute in positive2nat ten.  (* = 10 : nat *)

(** We can read the binary representation of a positive number
    as the _backwards_ sequence of [xO] (meaning 0) and [xI/xH] (1).
    Thus, ten is 1010 in binary. *)

Fixpoint print_in_binary (p: positive) : list nat :=
  match p with
  | xI q => print_in_binary q ++ [1]
  | xO q =>print_in_binary q ++ [0]
  | xH => [1]
 end.

Eval compute in print_in_binary ten.  (*  = [1; 0; 1; 0] *)

(** Another way to see the "binary representation" is to make up
     postfix notation for [xI] and [xO], as follows *)

Notation "p ~ 1" := (xI p)
 (at level 7, left associativity, format "p '~' '1'").
Notation "p ~ 0" := (xO p)
 (at level 7, left associativity, format "p '~' '0'").

Print ten. (* = xH~0~1~0 : positive *)

(** Why are we using positive numbers anyway?  Since the zero was
    invented 2300 years ago by the Babylonians, it's sort of old-fashioned
    to use number systems that start at 1.

    The answer is that it's highly inconvenient to have number systems
    with several different representations of the same number.
    For one thing, we don't want to worry about  00110=110.
    Then, when we extend this to the integers, with a "minus sign",
    we don't have to worry about -0 = +0.    *)

(**  To find the successor of a binary number--that is to increment--
    we work from low-order to high-order, until we hit a zero bit. *)

Fixpoint succ x :=
  match x with
    | p~1 => (succ p)~0
    | p~0 => p~1
    | xH => xH~0
  end.

(** To add binary numbers, we work from low-order to high-order,
    keeping track of the carry. *)

Fixpoint addc (carry: bool) (x y: positive) {struct x} : positive :=
  match carry, x, y with
    | false, p~1, q~1 => (addc true p q)~0
    | false, p~1, q~0 => (addc false p q)~1
    | false, p~1, xH => (succ p)~0
    | false, p~0, q~1 => (addc false p q)~1
    | false, p~0, q~0 => (addc false p q)~0
    | false, p~0, xH => p~1
    | false, xH, q~1 => (succ q)~0
    | false, xH, q~0 => q~1
    | false, xH, xH => xH~0
    | true, p~1, q~1 => (addc true p q)~1
    | true, p~1, q~0 => (addc true p q)~0
    | true, p~1, xH => (succ p)~1
    | true, p~0, q~1 => (addc true p q)~0
    | true, p~0, q~0 => (addc false p q)~1
    | true, p~0, xH => (succ p)~0
    | true, xH, q~1 => (succ q)~1
    | true, xH, q~0 => (succ q)~0
    | true, xH, xH => xH~1
  end.

Definition add (x y: positive) : positive := addc false x y.

(** **** Exercise: 2 stars, standard (succ_correct)  *)
Lemma succ_correct: forall p,
   positive2nat (succ p) = S (positive2nat p).
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, standard (addc_correct)

    You may use [omega] in this proof if you want, along with induction
    of course.  But really, using [omega] is an anachronism in a sense:
    Coq's [omega] uses theorems about [Z] that are proved from theorems about
    Coq's standard-library [positive] that, in turn, rely on a theorem much
    like this one.  So the authors of the Coq standard library had to
    do the associative-commutative rearrangement proofs "by hand."
    But really, here you can use [omega] without penalty. *)

Lemma addc_correct: forall (c: bool) (p q: positive),
   positive2nat (addc c p q) =
        (if c then 1 else 0) + positive2nat p + positive2nat q.
Proof.
(* FILL IN HERE *) Admitted.

Theorem add_correct: forall (p q: positive),
   positive2nat (add p q) = positive2nat p + positive2nat q.
Proof.
intros.
unfold add.
apply addc_correct.
Qed.
(** [] *)

(** Claim:  the [add] function on positive numbers takes worst-case time
    proportional to the log base 2 of the result.

    We can't prove this in Coq, since Coq has no cost model for execution.
    But we can prove it informally. Notice that [addc] is structurally recursive
   on [p], that is, the number of recursive calls is at most the height of the
    [p] structure; that's equal to log base 2 of [p] (rounded up to the nearest
    integer). The last call may call [succ q], which is structurally recursive on [q],
    but this [q] argument is what remained of the original [q] after
    stripping off a number of constructors equal to the height of [p].
*)

(** To implement comparison algorithms on positives, the recursion
    (Fixpoint) is easier to implement if we compute not only
    "less-than / not-less-than", but actually, "less / equal / greater".
    To express these choices, we use an Inductive data type. *)

Inductive comparison : Set :=
    Eq : comparison | Lt : comparison | Gt : comparison.

(** **** Exercise: 5 stars, standard (compare_correct)  *)
Fixpoint compare x y {struct x}:=
  match x, y with
    | p~1, q~1 => compare p q
    | p~1, q~0 => match compare p q with Lt => Lt | _ => Gt end
    | p~1, xH => Gt

  (* DELETE THIS CASE!  Replace it with cases that actually work. *)
    | _, _ => Lt
  end.

Lemma positive2nat_pos:
 forall p, positive2nat p > 0.
Proof.
intros.
induction p; simpl; omega.
Qed.

Theorem compare_correct:
 forall x y,
  match compare x y with
  | Lt => positive2nat x < positive2nat y
  | Eq => positive2nat x = positive2nat y
  | Gt => positive2nat x > positive2nat y
 end.
Proof.
induction x; destruct y; simpl.
(* FILL IN HERE *) Admitted.
(** [] *)

(** Claim: [compare x y] takes time proportional to the log base 2 of [x].
     Proof: it's structurally inductive on the height of [x]. *)

(* ================================================================= *)
(** ** Coq's Integer Type, [Z]

    Coq's integer type is constructed from positive numbers: *)

Inductive Z : Set :=
  | Z0 : Z
  | Zpos : positive -> Z
  | Zneg : positive -> Z.

(** We can construct efficient (logN time) algorithms for operations
   on [Z]:  [add], [subtract], [compare], and so on.  These algorithms
   call upon the efficient algorithms for [positive]s.

   We won't show these here, because in this chapter we now turn
   to efficient maps over positive numbers. *)

End Integers.  (* Hide away our experiments with [positive] *)

(** These types, [positive] and [Z], are part of the Coq standard library.
   We can access them here, because (above) the [Import Perm]
   has also exported [ZArith] to us. *)

Print positive.  (* from the Coq standard library:
  Inductive positive : Set :=
  |  xI : positive -> positive
  | xO : positive -> positive
  | xH : positive *)

Check Pos.compare.  (*   : positive -> positive -> comparison *)
Check Pos.add. (* : positive -> positive -> positive *)

Check Z.add. (* : Z -> Z -> Z *)

(* ================================================================= *)
(** ** From [N*N*N] to [N*N*logN] *)

(** This program runs in [(N^2)*(log N)] time.  The [loop] does [N]
    iterations; the table lookup does [O(N)] comparisons, and each
    comparison takes [O(log N)] time. *)

Module RatherSlow.

Definition total_mapz (A: Type) := Z -> A.

Definition empty {A:Type} (default: A) : total_mapz A := fun _ => default.
Definition update {A:Type} (m : total_mapz A)
                    (x : Z) (v : A) :=
  fun x' => if Z.eqb x x' then v else m x'.

Fixpoint loop (input: list Z) (c: Z) (table: total_mapz bool) : Z :=
  match input with
  | nil => c
  | a::al => if table a
                  then loop al (c+1) table
                  else loop al c (update table a true)
 end.

Definition collisions (input: list Z) := loop input 0 (empty false).

Example collisions_pi: collisions [3;1;4;1;5;9;2;6]%Z = 1%Z.
Proof. reflexivity. Qed.

End RatherSlow.

(* ================================================================= *)
(** ** From [N*N*logN] to [N*logN*logN] *)

(** We can use balanced binary search trees (red-black trees), with
   keys of type [Z].  Then the [loop] does [N] iterations; the table lookup
   does [O(logN)] comparisons, and each comparison takes [O(log N)] time.
   Overall, the asymptotic run time is [N*(logN)^2]. *)

(* ################################################################# *)
(** * Tries: Efficient Lookup Tables on Positive Binary Numbers *)

(** Binary search trees are very nice, because they can implement lookup
    tables from _any_ totally ordered type to any other type.  But when the
    type of keys is known specifically to be (small-to-medium size) integers,
    then we can use a more specialized representation.

    By analogy, in imperative programming languages (C, Java, ML),
    when the index of a table is the integers in a certain range,
    you can use arrays.    When the keys are not integers, you have
    to use something like hash tables or binary search trees.

    A _trie_ is a tree in which the edges are labeled with letters from
    an alphabet, and you look up a word by following edges labeled
    by successive letters of the word.  In fact, a trie is a special case
    of a Deterministic Finite Automaton (DFA) that happens to be a
    tree rather than a more general graph.

   A _binary trie_ is a trie in which the alphabet is just {0,1}.  The "word"
   is a sequence of bits, that is, a binary number.  To look up the "word"
   10001, use 0 as a signal to "go left", and 1 as a signal to "go right."

   The binary numbers we use will be type [positive]:  *)

Print positive.
(* Inductive positive : Set :=
    xI : positive -> positive
 | xO : positive -> positive
 | xH : positive *)

Goal   10%positive = xO (xI (xO xH)).
Proof. reflexivity. Qed.

(** Given a [positive] number such as ten, we will go left to right in
   the [xO]/[xI] constructors (which is from the low-order bit to the high-order bit),
   using [xO] as a signal to go left, [xI] as a signal to go right,
   and [xH] as a signal to stop. *)

Inductive trie (A : Type) :=
    | Leaf : trie A
    | Node : trie A -> A -> trie A -> trie A.
Arguments Leaf {A}.
Arguments Node {A} _ _ _.

Definition trie_table (A: Type) : Type := (A * trie A)%type.

Definition empty {A: Type} (default: A) : trie_table A :=
      (default, Leaf).

Fixpoint look {A: Type} (default: A) (i: positive) (m: trie A): A :=
    match m with
    | Leaf => default
    | Node l x r =>
        match i with
        | xH => x
        | xO i' => look default i' l
        | xI i' => look default i' r
        end
    end.

Definition lookup {A: Type} (i: positive) (t: trie_table A) : A :=
   look (fst t) i (snd t).

Fixpoint ins {A: Type} default (i: positive) (a: A) (m: trie A): trie A :=
    match m with
    | Leaf =>
        match i with
        | xH => Node Leaf a Leaf
        | xO i' => Node (ins default i' a Leaf) default Leaf
        | xI i' => Node Leaf default (ins default i' a Leaf)
        end
    | Node l o r =>
        match i with
        | xH => Node l a r
        | xO i' => Node (ins default i' a l) o r
        | xI i' => Node l o (ins default i' a r)
        end
    end.

Definition insert {A: Type} (i: positive) (a: A) (t: trie_table A)
                 : trie_table A :=
  (fst t, ins (fst t) i a (snd t)).

Definition three_ten : trie_table bool :=
 insert 3 true (insert 10 true (empty false)).

Eval compute in three_ten.
(* = (false,
        Node (Node Leaf false (Node (Node Leaf true Leaf) false Leaf))
                 false
                 (Node Leaf true Leaf))
     : trie_table bool  *)

Eval compute in
   map (fun i => lookup i three_ten) [3;1;4;1;5]%positive.
(*      = [true; false; false; false; false]  : list bool *)

(* ================================================================= *)
(** ** From [N*logN*logN] to [N*logN] *)

Module FastEnough.

Fixpoint loop (input: list positive) (c: nat) (table: trie_table bool) : nat :=
  match input with
  | nil => c
  | a::al => if lookup a table
                  then loop al (1+c) table
                  else loop al c (insert a true table)
 end.

Definition collisions (input: list positive) := loop input 0 (empty false).

Example collisions_pi: collisions [3;1;4;1;5;9;2;6]%positive = 1.
Proof. reflexivity. Qed.

End FastEnough.

(** This program takes [O(N log N)] time:  the loop executes [N]
    iterations, the [lookup] takes [log N] time, the [insert] takes [log N] time.
    One might worry about [1+c] computed in the natural numbers (unary
    representation), but this evaluates in one step to [S c], which
    takes constant time, no matter how long [c] is.  In "real life", one
    might be advised to use [Z] instead of [nat] for the [c] variables,
    in which case, [1+c] takes worst-case [log N], and average-case
    constant time. *)

(** **** Exercise: 2 stars, standard (successor_of_Z_constant_time)

    Explain why the average-case time for successor of a binary
     integer, with carry, is constant time.  Assume that the input integer
     is random (uniform distribution from 1 to N), or assume that
     we are iterating successor starting at 1, so that each number
     from 1 to N is touched exactly once -- whichever way you like. *)

(* [explain here]
*)
(* Do not modify the following line: *)
Definition manual_grade_for_successor_of_Z_constant_time : option (nat*string) := None.
(** [] *)

(* ################################################################# *)
(** * Proving the Correctness of Trie Tables *)

(** Trie tables are just another implementation of the [Maps]
     abstract data type.  What we have to prove is the same as usual for an ADT:
     define a representation invariant, define an abstraction relation, prove
     that the operations respect the invariant and the abstraction relation.

     We will indeed do that.  But this time we'll take a different approach.
     Instead of defining a "natural" abstraction relation based on what
     we see in the data structure, we'll define an abstraction relation
     that says, "what you get is what you get."    This will work, but it means
     we've moved the work into directly proving some things about the
     relation between the [lookup] and the [insert] operators. *)

(* ================================================================= *)
(** ** Lemmas About the Relation Between [lookup] and [insert] *)

(** **** Exercise: 1 star, standard (look_leaf)  *)
Lemma look_leaf:
 forall A (a:A) j, look a j Leaf = a.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, standard (look_ins_same)

    This is a rather simple induction. *)

Lemma look_ins_same: forall {A} a k (v:A) t, look a k (ins a k v t) = v.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, standard (look_ins_same)

    Induction on j? Induction on t?   Do you feel lucky? *)

Lemma look_ins_other: forall {A} a j k (v:A) t,
   j <> k -> look a j (ins a k v t) = look a j t.
(* FILL IN HERE *) Admitted.
(** [] *)

(* ================================================================= *)
(** ** Bijection Between [positive] and [nat]. *)

(** In order to relate [lookup] on positives to [total_map] on nats,
   it's helpful to have a bijection between [positive] and [nat].
   We'll relate [1%positive] to [0%nat],  [2%positive] to [1%nat], and so on. *)

Definition nat2pos (n: nat) : positive := Pos.of_succ_nat n.
Definition pos2nat (n: positive) : nat := pred (Pos.to_nat n).

Lemma pos2nat2pos: forall p, nat2pos (pos2nat p) = p.
Proof. (* You don't need to read this proof! *)
intro. unfold nat2pos, pos2nat.
rewrite <- (Pos2Nat.id p) at 2.
destruct (Pos.to_nat p) eqn:?.
pose proof (Pos2Nat.is_pos p). omega.
rewrite <- Pos.of_nat_succ.
reflexivity.
Qed.

Lemma nat2pos2nat: forall i, pos2nat (nat2pos i) = i.
Proof. (* You don't need to read this proof! *)
intro. unfold nat2pos, pos2nat.
rewrite SuccNat2Pos.id_succ.
reflexivity.
Qed.

(** Now, use those two lemmas to prove that it's really a bijection! *)

(** **** Exercise: 2 stars, standard (pos2nat_bijective)  *)
Lemma pos2nat_injective: forall p q, pos2nat p = pos2nat q -> p=q.
(* FILL IN HERE *) Admitted.

Lemma nat2pos_injective: forall i j, nat2pos i = nat2pos j -> i=j.
(* FILL IN HERE *) Admitted.
(** [] *)

(* ================================================================= *)
(** ** Proving That Tries are a "Table" ADT. *)

(** Representation invariant.  Under what conditions is a trie
    well-formed?  Fill in the simplest thing you can, to start; then
    correct it later as necessary. *)

Definition is_trie {A: Type} (t: trie_table A) : Prop
(* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

(** Abstraction relation.  This is what we mean by, "what you get is
    what you get."  That is, the abstraction of a [trie_table] is the
    total function, from naturals to [A] values, that you get by
    running the [lookup] function.  Based on this abstraction
    relation, it'll be trivial to prove [lookup_relate].  But
    [insert_relate] will NOT be trivial. *)

Definition abstract {A: Type} (t: trie_table A) (n: nat) : A :=
  lookup (nat2pos n) t.

Definition Abs {A: Type} (t: trie_table A) (m: total_map A) :=
  abstract t = m.

(** **** Exercise: 2 stars, standard (is_trie)

    If you picked a _really simple_ representation invariant, these should be easy.
    Later, if you need to change the representation invariant in order to
    get the [_relate] proofs to work, then you'll need to fix these proofs. *)

Theorem empty_is_trie: forall {A} (default: A), is_trie (empty default).
(* FILL IN HERE *) Admitted.

Theorem insert_is_trie: forall {A} i x (t: trie_table A),
   is_trie t -> is_trie (insert i x t).
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, standard (empty_relate)

    Just unfold a bunch of definitions, use [extensionality], and
    use one of the lemmas you proved above, in the section
    "Lemmas about the relation between [lookup] and [insert]." *)

Theorem empty_relate: forall {A} (default: A),
    Abs (empty default) (t_empty default).
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, standard (lookup_relate)

    Given the abstraction relation we've chosen, this one should be really simple. *)

Theorem lookup_relate: forall {A} i (t: trie_table A) m,
    is_trie t -> Abs t m -> lookup i t = m (pos2nat i).
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, standard (insert_relate)

    Given the abstraction relation we've chosen, this one should NOT be simple.
   However, you've already done the heavy lifting, with the lemmas
  [look_ins_same] and [look_ins_other].   You will not need induction here.
  Instead, unfold a bunch of things, use extensionality, and get to a case analysis
  on whether [pos2nat k =? pos2nat j].   To handle that case analysis,
   use [bdestruct]. You may also need [pos2nat_injective]. *)

Theorem insert_relate: forall {A} k (v: A) t cts,
    is_trie t ->
    Abs t cts ->
    Abs (insert k v t) (t_update cts (pos2nat k) v).
(* FILL IN HERE *) Admitted.
(** [] *)

(* ================================================================= *)
(** ** Sanity Check *)

Example Abs_three_ten:
    Abs
       (insert 3 true (insert 10 true (empty false)))
       (t_update (t_update (t_empty false) (pos2nat 10) true) (pos2nat 3) true).
Proof.
try (apply insert_relate; [hnf; auto | ]).
try (apply insert_relate; [hnf; auto | ]).
try (apply empty_relate).
(* Change this to Qed once you have [is_trie] defined and working. *)
(* FILL IN HERE *) Admitted.

(* ################################################################# *)
(** * Conclusion

    Efficient functional maps with (positive) integer keys are one of the most
   important data structures in functional programming.  They are used for
  symbol tables in compilers and static analyzers; to represent directed graphs
  (the mapping from node-ID to edge-list); and (in general) anywhere that
  an imperative algorithm uses an array or _requires_ a mutable pointer.

  Therefore, these _tries_ on positive numbers are very important in Coq programming.
  They were introduced by Xavier Leroy and Sandrine Blazy in the CompCert
  compiler (2006), and are now available in the Coq standard library as the
  [PositiveMap] module, which implements the [FMaps] interface.
  The core implementation of [PositiveMap] is just as shown in this chapter,
  but [FMaps] uses different names for the functions [insert] and [lookup],
  and also provides several other operations on maps.  *)

(* 2020-08-07 17:08 *)


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq path div choice.
Require Import fintype bigop ssralg finset fingroup morphism perm.
Require Import finalg action gproduct commutator cyclic.

(******************************************************************************)
(*  This file regroups constructions and results that are based on the most   *)
(* primitive version of representation theory -- viewing an abelian group as  *)
(* the additive group of a (finite) Z-module. This includes the Gaschutz      *)
(* splitting and transitivity theorem, from which we will later derive the    *)
(* Schur-Zassenhaus theorem and the elementary abelian special case of        *)
(* Measchke's theorem, the coprime abelian centraliser/commutator trivial     *)
(* intrsection theorem, from which we will derive that p-groups under coprime *)
(* action factor into special groups, and the construction of the transfer    *)
(* homomorphism and its expansion relative to a cycle, from which we derive   *)
(* the Higman Focal Subgroup and the Burside Normal Complement Theorems.      *)
(*   The definitions and lemmas for the finite Z-module induced by an abelian *)
(* are packaged in an auxiliary FiniteModule submodule: they should not be    *)
(* needed much outside this file, which contains all the results that exploit *)
(* this construction.                                                         *)
(*   FiniteModule defines the Z[N(A)]-module associated with a finite abelian *)
(* abelian group A, given a proof abelA : abelian A) :                        *)
(*  fmod_of abelA == the type of elements of the module (similar to but       *)
(*                   distinct from [subg A]).                                 *)
(*   fmod abelA x == the injection of x into fmod_of abelA if x \in A, else 0 *)
(*        fmval u == the projection of u : fmod_of abelA onto A               *)
(*         u ^@ x == the action of x \in 'N(A) on u : fmod_of abelA           *)
(* The transfer morphism is be constructed from a morphism f : H >-> rT, and  *)
(* a group G, along with the two assumptions sHG : H \subset G and            *)
(* abfH : abelian (f @* H):                                                   *)
(*  transfer sGH abfH == the function gT -> FiniteModule.fmod_of abfH that    *)
(*                   implements the transfer morphism induced by f on G.      *)
(*  rcosets_transversal G H X == the function X : {set gT} -> gT defines a    *)
(*                   transversal of the right cosets of H in G: it maps each  *)
(*                   coset H :* x to some y_x \in H :* x, for each x \in G.   *)
(*                   The Lemma transfer_indep states that the transfer        *)
(*                   morphism can be expanded using any transversal.          *)
(*  rcosets_pcycle_transversal G H g X == X is a transversal of the orbits of *)
(*                   the regular action of the cycle <[g]> generated by g on  *)
(*                   the set of right cosets of H if H \subset G and g \in G, *)
(*                   and more generally the function r mapping x : gT to      *)
(*                   rcosets (H :* x) <[g]> is (constructively) a bijection   *)
(*                   from X to a partition of a partition of G: we have       *)
(*                   {in X &, injective r}, X \subset G  and                  *)
(*                   G \subset H * X * <[g]>. The transfer_pcycle_def Lemma   *)
(*                   gives a simplified expansion of the transfer morphism,   *)
(*                   given a set X with this property.                        *)
(*  rcosets_pcycle_transversal_witness G H g == the sigma Type associated     *)
(*                   with the predicate above; it encapsulates a set X, the   *)
(*                   rcosets_pcycle_transversal G H g X property, and an      *)
(*                   abbreviation n_ x for the coefficient #|r x| (with r     *)
(*                   defined as above), which is used in the expansion        *)
(*                   supplied by transfer_pcycle_def.                         *)
(* For applications that do not require a specific transversal, the           *)
(* rcosets_pcycle_transversal_exists Lemma provides a default instance of an  *)
(* rcosets_pcycle_transversal_witness.                                        *)
(******************************************************************************)

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

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

Module FiniteModule.

Reserved Notation "u ^@ x" (at level 31, left associativity).

Inductive fmod_of (gT : finGroupType) (A : {group gT}) (abelA : abelian A) :=
  Fmod x & x \in A.

Bind Scope ring_scope with fmod_of.

Section OneFinMod.

Let f2sub (gT : finGroupType) (A : {group gT}) (abA : abelian A) :=
  fun u : fmod_of abA => let : Fmod x Ax := u in Subg Ax : FinGroup.arg_sort _.
Local Coercion f2sub : fmod_of >-> FinGroup.arg_sort.

Variables (gT : finGroupType) (A : {group gT}) (abelA : abelian A).
Local Notation fmodA := (fmod_of abelA).
Implicit Types (x y z : gT) (u v w : fmodA).

Let sub2f (s : [subg A]) := Fmod abelA (valP s).

Definition fmval u := val (f2sub u).
Canonical fmod_subType := [subType for fmval].
Local Notation valA := (@val _ _ fmod_subType) (only parsing).
Definition fmod_eqMixin := Eval hnf in [eqMixin of fmodA by <:].
Canonical fmod_eqType := Eval hnf in EqType fmodA fmod_eqMixin.
Definition fmod_choiceMixin := [choiceMixin of fmodA by <:].
Canonical fmod_choiceType := Eval hnf in ChoiceType fmodA fmod_choiceMixin.
Definition fmod_countMixin := [countMixin of fmodA by <:].
Canonical fmod_countType := Eval hnf in CountType fmodA fmod_countMixin.
Canonical fmod_subCountType := Eval hnf in [subCountType of fmodA].
Definition fmod_finMixin := [finMixin of fmodA by <:].
Canonical fmod_finType := Eval hnf in FinType fmodA fmod_finMixin.
Canonical fmod_subFinType := Eval hnf in [subFinType of fmodA].

Definition fmod x := sub2f (subg A x).
Definition actr u x := if x \in 'N(A) then fmod (fmval u ^ x) else u.

Definition fmod_opp u := sub2f u^-1.
Definition fmod_add u v := sub2f (u * v).

Fact fmod_add0r : left_id (sub2f 1) fmod_add.
Proof. move=> u; apply: val_inj; exact: mul1g. Qed.

Fact fmod_addrA : associative fmod_add.
Proof. move=> u v w; apply: val_inj; exact: mulgA. Qed.

Fact fmod_addNr : left_inverse (sub2f 1) fmod_opp fmod_add.
Proof. move=> u; apply: val_inj; exact: mulVg. Qed.

Fact fmod_addrC : commutative fmod_add.
Proof. case=> x Ax [y Ay]; apply: val_inj; exact: (centsP abelA). Qed.

Definition fmod_zmodMixin :=
  ZmodMixin fmod_addrA fmod_addrC fmod_add0r fmod_addNr.
Canonical fmod_zmodType := Eval hnf in ZmodType fmodA fmod_zmodMixin.
Canonical fmod_finZmodType := Eval hnf in [finZmodType of fmodA].
Canonical fmod_baseFinGroupType :=
  Eval hnf in [baseFinGroupType of fmodA for +%R].
Canonical fmod_finGroupType :=
  Eval hnf in [finGroupType of fmodA for +%R].

Lemma fmodP u : val u \in A. Proof. exact: valP. Qed.
Lemma fmod_inj : injective fmval. Proof. exact: val_inj. Qed.
Lemma congr_fmod u v : u = v -> fmval u = fmval v.
Proof. exact: congr1. Qed.

Lemma fmvalA : {morph valA : x y / x + y >-> (x * y)%g}. Proof. by []. Qed.
Lemma fmvalN : {morph valA : x / - x >-> x^-1%g}. Proof. by []. Qed.
Lemma fmval0 : valA 0 = 1%g. Proof. by []. Qed.
Canonical fmval_morphism := @Morphism _ _ setT fmval (in2W fmvalA).

Definition fmval_sum := big_morph fmval fmvalA fmval0.

Lemma fmvalZ n : {morph valA : x / x *+ n >-> (x ^+ n)%g}.
Proof. by move=> u; rewrite /= morphX ?inE. Qed.

Lemma fmodKcond x : val (fmod x) = if x \in A then x else 1%g.
Proof. by rewrite /= /fmval /= val_insubd. Qed.
Lemma fmodK : {in A, cancel fmod val}. Proof. exact: subgK. Qed.
Lemma fmvalK : cancel val fmod.
Proof. by case=> x Ax; apply: val_inj; rewrite /fmod /= sgvalK. Qed.
Lemma fmod1 : fmod 1 = 0. Proof. by rewrite -fmval0 fmvalK. Qed.
Lemma fmodM : {in A &, {morph fmod : x y / (x * y)%g >-> x + y}}.
Proof. by move=> x y Ax Ay /=; apply: val_inj; rewrite /fmod morphM. Qed.
Canonical fmod_morphism := Morphism fmodM.
Lemma fmodX n : {in A, {morph fmod : x / (x ^+ n)%g >-> x *+ n}}.
Proof. exact: morphX. Qed.
Lemma fmodV : {morph fmod : x / x^-1%g >-> - x}.
Proof.
move=> x; apply: val_inj; rewrite fmvalN !fmodKcond groupV.
by case: (x \in A); rewrite ?invg1.
Qed.

Lemma injm_fmod : 'injm fmod.
Proof.
apply/injmP=> x y Ax Ay []; move/val_inj; exact: (injmP _ (injm_subg A)).
Qed.

Notation "u ^@ x" := (actr u x) : ring_scope.

Lemma fmvalJcond u x :
  val (u ^@ x) = if x \in 'N(A) then val u ^ x else val u.
Proof. by case: ifP => Nx; rewrite /actr Nx ?fmodK // memJ_norm ?fmodP. Qed.

Lemma fmvalJ u x : x \in 'N(A) -> val (u ^@ x) = val u ^ x.
Proof. by move=> Nx; rewrite fmvalJcond Nx. Qed.

Lemma fmodJ x y : y \in 'N(A) -> fmod (x ^ y) = fmod x ^@ y.
Proof.
move=> Ny; apply: val_inj; rewrite fmvalJ ?fmodKcond ?memJ_norm //.
by case: ifP => // _; rewrite conj1g.
Qed.

Fact actr_is_action : is_action 'N(A) actr.
Proof.
split=> [a u v eq_uv_a | u a b Na Nb].
  case Na: (a \in 'N(A)); last by rewrite /actr Na in eq_uv_a.
  by apply: val_inj; apply: (conjg_inj a); rewrite -!fmvalJ ?eq_uv_a.
by apply: val_inj; rewrite !fmvalJ ?groupM ?conjgM.
Qed.

Canonical actr_action := Action actr_is_action.
Notation "''M'" := actr_action (at level 8) : action_scope.

Lemma act0r x : 0 ^@ x = 0.
Proof. by rewrite /actr conj1g morph1 if_same. Qed.

Lemma actAr x : {morph actr^~ x : u v / u + v}.
Proof.
by move=> u v; apply: val_inj; rewrite !(fmvalA, fmvalJcond) conjMg; case: ifP.
Qed.

Definition actr_sum x := big_morph _ (actAr x) (act0r x).

Lemma actNr x : {morph actr^~ x : u / - u}.
Proof. by move=> u; apply: (addrI (u ^@ x)); rewrite -actAr !subrr act0r. Qed.

Lemma actZr x n : {morph actr^~ x : u / u *+ n}.
Proof.
by move=> u; elim: n => [|n IHn]; rewrite ?act0r // !mulrS actAr IHn.
Qed.

Fact actr_is_groupAction : is_groupAction setT 'M.
Proof.
move=> a Na /=; rewrite inE; apply/andP; split.
  by apply/subsetP=> u _; rewrite inE.
by apply/morphicP=> u v _ _; rewrite !permE /= actAr.
Qed.

Canonical actr_groupAction := GroupAction actr_is_groupAction.
Notation "''M'" := actr_groupAction (at level 8) : groupAction_scope.

Lemma actr1 u : u ^@ 1 = u.
Proof. exact: act1. Qed.

Lemma actrM : {in 'N(A) &, forall x y u, u ^@ (x * y) = u ^@ x ^@ y}.
Proof.
by move=> x y Nx Ny /= u; apply: val_inj; rewrite !fmvalJ ?conjgM ?groupM.
Qed.

Lemma actrK x : cancel (actr^~ x) (actr^~ x^-1%g).
Proof.
move=> u; apply: val_inj; rewrite !fmvalJcond groupV.
by case: ifP => -> //; rewrite conjgK.
Qed.

Lemma actrKV x : cancel (actr^~ x^-1%g) (actr^~ x).
Proof. by move=> u; rewrite /= -{2}(invgK x) actrK. Qed.

End OneFinMod.

Bind Scope ring_scope with fmod_of.
Prenex Implicits fmval fmod actr.
Notation "u ^@ x" := (actr u x) : ring_scope.
Notation "''M'" := actr_action (at level 8) : action_scope.
Notation "''M'" := actr_groupAction : groupAction_scope.

End FiniteModule.

Canonical FiniteModule.fmod_subType.
Canonical FiniteModule.fmod_eqType.
Canonical FiniteModule.fmod_choiceType.
Canonical FiniteModule.fmod_countType.
Canonical FiniteModule.fmod_finType.
Canonical FiniteModule.fmod_subCountType.
Canonical FiniteModule.fmod_subFinType.
Canonical FiniteModule.fmod_zmodType.
Canonical FiniteModule.fmod_finZmodType.
Canonical FiniteModule.fmod_baseFinGroupType.
Canonical FiniteModule.fmod_finGroupType.

(* Still allow ring notations, but give priority to groups now. *)
Import FiniteModule GroupScope.

Section Gaschutz.

Variables (gT : finGroupType) (G H P : {group gT}).
Implicit Types K L : {group gT}.

Hypotheses (nsHG : H <| G) (sHP : H \subset P) (sPG : P \subset G).
Hypotheses (abelH : abelian H) (coHiPG : coprime #|H| #|G : P|).

Let sHG := normal_sub nsHG.
Let nHG := subsetP (normal_norm nsHG).

Let m := (expg_invn H #|G : P|).

Implicit Types a b : fmod_of abelH.
Local Notation fmod := (fmod abelH).

Theorem Gaschutz_split : [splits G, over H] = [splits P, over H].
Proof.
apply/splitsP/splitsP=> [[K /complP[tiHK eqHK]] | [Q /complP[tiHQ eqHQ]]].
  exists (K :&: P)%G; rewrite inE setICA (setIidPl sHP) setIC tiHK eqxx.
  by rewrite group_modl // eqHK (sameP eqP setIidPr).
have sQP: Q \subset P by rewrite -eqHQ mulG_subr.
pose rP x := repr (P :* x); pose pP x := x * (rP x)^-1.
have PpP x: pP x \in P by rewrite -mem_rcoset rcoset_repr rcoset_refl.
have rPmul x y: x \in P -> rP (x * y) = rP y.
  by move=> Px; rewrite /rP rcosetM rcoset_id.
pose pQ x := remgr H Q x; pose rH x := pQ (pP x) * rP x.
have pQhq: {in H & Q, forall h q, pQ (h * q) = q} by exact: remgrMid.
have pQmul: {in P &, {morph pQ : x y / x * y}}.
  apply: remgrM; [exact/complP | exact: normalS (nsHG)].
have HrH x: rH x \in H :* x.
  by rewrite rcoset_sym mem_rcoset invMg mulgA mem_divgr // eqHQ PpP.
have GrH x: x \in G -> rH x \in G.
  move=> Gx; case/rcosetP: (HrH x) => y Hy ->.
  by rewrite groupM // (subsetP sHG).
have rH_Pmul x y: x \in P -> rH (x * y) = pQ x * rH y.
  by move=> Px; rewrite /rH mulgA -pQmul; first by rewrite /pP rPmul ?mulgA.
have rH_Hmul h y: h \in H -> rH (h * y) = rH y.
  by move=> Hh; rewrite rH_Pmul ?(subsetP sHP) // -(mulg1 h) pQhq ?mul1g.
pose mu x y := fmod ((rH x * rH y)^-1 * rH (x * y)).
pose nu y := (\sum_(Px in rcosets P G) mu (repr Px) y)%R.
have rHmul: {in G &, forall x y, rH (x * y) = rH x * rH y * val (mu x y)}.
  move=> x y Gx Gy; rewrite /= fmodK ?mulKVg // -mem_lcoset lcoset_sym.
  rewrite -norm_rlcoset; last by rewrite nHG ?GrH ?groupM.
  by rewrite (rcoset_transl (HrH _)) -rcoset_mul ?nHG ?GrH // mem_mulg.
have actrH a x: x \in G -> (a ^@ rH x = a ^@ x)%R.
  move=> Gx; apply: val_inj; rewrite /= !fmvalJ ?nHG ?GrH //.
  case/rcosetP: (HrH x) => b /(fmodK abelH) <- ->; rewrite conjgM.
  by congr (_ ^ _); rewrite conjgE -fmvalN -!fmvalA (addrC a) addKr.
have mu_Pmul x y z: x \in P -> mu (x * y) z = mu y z.
  move=> Px; congr fmod; rewrite -mulgA !(rH_Pmul x) ?rPmul //.
  by rewrite -mulgA invMg -mulgA mulKg.
have mu_Hmul x y z: x \in G -> y \in H -> mu x (y * z) = mu x z.
  move=> Gx Hy; congr fmod; rewrite (mulgA x) (conjgCV x) -mulgA 2?rH_Hmul //.
  by rewrite -mem_conjg (normP _) ?nHG.
have{mu_Hmul} nu_Hmul y z: y \in H -> nu (y * z) = nu z.
  move=> Hy; apply: eq_bigr => _ /rcosetsP[x Gx ->]; apply: mu_Hmul y z _ Hy.
  by rewrite -(groupMl _ (subsetP sPG _ (PpP x))) mulgKV.
have cocycle_mu: {in G & &, forall x y z,
  mu (x * y)%g z + mu x y ^@ z = mu y z + mu x (y * z)%g}%R.
- move=> x y z Gx Gy Gz; apply: val_inj.
  apply: (mulgI (rH x * rH y * rH z)).
  rewrite -(actrH _ _ Gz) addrC fmvalA fmvalJ ?nHG ?GrH //.
  rewrite mulgA -(mulgA _ (rH z)) -conjgC mulgA -!rHmul ?groupM //.
  by rewrite mulgA -mulgA -2!(mulgA (rH x)) -!rHmul ?groupM.
move: mu => mu in rHmul mu_Pmul cocycle_mu nu nu_Hmul.
have{cocycle_mu} cocycle_nu: {in G &, forall y z,
  nu z + nu y ^@ z = mu y z *+ #|G : P| + nu (y * z)%g}%R.
- move=> y z Gy Gz; rewrite /= (actr_sum z) /=.
  have ->: (nu z = \sum_(Px in rcosets P G) mu (repr Px * y)%g z)%R.
    rewrite /nu (reindex_acts _ (actsRs_rcosets P G) Gy) /=.
    apply: eq_bigr => _ /rcosetsP[x Gx /= ->].
    rewrite rcosetE -rcosetM.
    case: repr_rcosetP=> p1 Pp1; case: repr_rcosetP=> p2 Pp2.
    by rewrite -mulgA [x * y]lock !mu_Pmul.
  rewrite -sumr_const -!big_split /=; apply: eq_bigr => _ /rcosetsP[x Gx ->].
  rewrite -cocycle_mu //; case: repr_rcosetP => p1 Pp1.
  by rewrite groupMr // (subsetP sPG).
move: nu => nu in nu_Hmul cocycle_nu.
pose f x := rH x * val (nu x *+ m)%R.
have{cocycle_nu} fM: {in G &, {morph f : x y / x * y}}.
  move=> x y Gx Gy; rewrite /f ?rHmul // -3!mulgA; congr (_ * _).
  rewrite (mulgA _ (rH y)) (conjgC _ (rH y)) -mulgA; congr (_ * _).
  rewrite -fmvalJ ?actrH ?nHG ?GrH // -!fmvalA actZr -mulrnDl.
  rewrite  -(addrC (nu y)) cocycle_nu // mulrnDl !fmvalA; congr (_ * _).
  by rewrite !fmvalZ expgK ?fmodP.
exists (Morphism fM @* G)%G; apply/complP; split.
  apply/trivgP/subsetP=> x /setIP[Hx /morphimP[y _ Gy eq_x]].
  apply/set1P; move: Hx; rewrite {x}eq_x /= groupMr ?subgP //.
  rewrite -{1}(mulgKV y (rH y)) groupMl -?mem_rcoset // => Hy.
  by rewrite -(mulg1 y) /f nu_Hmul // rH_Hmul //; exact: (morph1 (Morphism fM)).
apply/setP=> x; apply/mulsgP/idP=> [[h y Hh fy ->{x}] | Gx].
  rewrite groupMl; last exact: (subsetP sHG).
  case/morphimP: fy => z _ Gz ->{h Hh y}.
  by rewrite /= /f groupMl ?GrH // (subsetP sHG) ?fmodP.
exists (x * (f x)^-1) (f x); last first; first by rewrite mulgKV.
  by apply/morphimP; exists x.
rewrite -groupV invMg invgK -mulgA (conjgC (val _)) mulgA.
by rewrite groupMl -(mem_rcoset, mem_conjg) // (normP _) ?nHG ?fmodP.
Qed.

Theorem Gaschutz_transitive : {in [complements to H in G] &,
  forall K L,  K :&: P = L :&: P -> exists2 x, x \in H & L :=: K :^ x}.
Proof.
move=> K L /=; set Q := K :&: P => /complP[tiHK eqHK] cpHL QeqLP.
have [trHL eqHL] := complP cpHL.
pose nu x := fmod (divgr H L x^-1).
have sKG: {subset K <= G} by apply/subsetP; rewrite -eqHK mulG_subr.
have sLG: {subset L <= G} by apply/subsetP; rewrite -eqHL mulG_subr.
have val_nu x: x \in G -> val (nu x) = divgr H L x^-1.
  by move=> Gx; rewrite fmodK // mem_divgr // eqHL groupV.
have nu_cocycle: {in G &, forall x y, nu (x * y)%g = nu x ^@ y + nu y}%R.
  move=> x y Gx Gy; apply: val_inj; rewrite fmvalA fmvalJ ?nHG //.
  rewrite !val_nu ?groupM // /divgr conjgE !mulgA mulgK.
  by rewrite !(invMg, remgrM cpHL) ?groupV ?mulgA.
have nuL x: x \in L -> nu x = 0%R.
  move=> Lx; apply: val_inj; rewrite val_nu ?sLG //.
  by rewrite /divgr remgr_id ?groupV ?mulgV.
exists (fmval ((\sum_(X in rcosets Q K) nu (repr X)) *+ m)).
  exact: fmodP.
apply/eqP; rewrite eq_sym eqEcard; apply/andP; split; last first.
  by rewrite cardJg -(leq_pmul2l (cardG_gt0 H)) -!TI_cardMg // eqHL eqHK.
apply/subsetP=> _ /imsetP[x Kx ->]; rewrite conjgE mulgA (conjgC _ x).
have Gx: x \in G by rewrite sKG.
rewrite conjVg -mulgA -fmvalJ ?nHG // -fmvalN -fmvalA (_ : _ + _ = nu x)%R.
  by rewrite val_nu // mulKVg groupV mem_remgr // eqHL groupV.
rewrite actZr -!mulNrn -mulrnDl actr_sum.
rewrite addrC (reindex_acts _ (actsRs_rcosets _ K) Kx) -sumrB /= -/Q.
rewrite (eq_bigr (fun _ => nu x)) => [|_ /imsetP[y Ky ->]]; last first.
  rewrite !rcosetE -rcosetM QeqLP.
  case: repr_rcosetP => z /setIP[Lz _]; case: repr_rcosetP => t /setIP[Lt _].
  rewrite !nu_cocycle ?groupM ?(sKG y) // ?sLG //.
  by rewrite (nuL z) ?(nuL t) // !act0r !add0r addrC addKr.
apply: val_inj; rewrite sumr_const !fmvalZ.
rewrite -{2}(expgK coHiPG (fmodP (nu x))); congr (_ ^+ _ ^+ _).
rewrite -[#|_|]divgS ?subsetIl // -(divnMl (cardG_gt0 H)).
rewrite -!TI_cardMg //; last by rewrite setIA setIAC (setIidPl sHP).
by rewrite group_modl // eqHK (setIidPr sPG) divgS.
Qed.

End Gaschutz.

(* This is the TI part of B & G, Proposition 1.6(d).                          *)
(* We go with B & G rather than Aschbacher and will derive 1.6(e) from (d),   *)
(* rather than the converse, because the derivation of 24.6 from 24.3 in      *)
(* Aschbacher requires a separate reduction to p-groups to yield 1.6(d),      *)
(* making it altogether longer than the direct Gaschutz-style proof.          *)
(* This Lemma is used in maximal.v for the proof of Aschbacher 24.7.          *)
Lemma coprime_abel_cent_TI (gT : finGroupType) (A G : {group gT}) :
  A \subset 'N(G) -> coprime #|G| #|A| -> abelian G -> 'C_[~: G, A](A) = 1.
Proof.
move=> nGA coGA abG; pose f x := val (\sum_(a in A) fmod abG x ^@ a)%R.
have fM: {in G &, {morph f : x y / x * y}}.
  move=> x y Gx Gy /=; rewrite -fmvalA -big_split /=; congr (fmval _).
  by apply: eq_bigr => a Aa; rewrite fmodM // actAr.
have nfA x a: a \in A -> f (x ^ a) = f x.
  move=> Aa; rewrite {2}/f (reindex_inj (mulgI a)) /=; congr (fmval _).
  apply: eq_big => [b | b Ab]; first by rewrite groupMl.
  by rewrite -!fmodJ ?groupM ?(subsetP nGA) // conjgM.
have kerR: [~: G, A] \subset 'ker (Morphism fM).
  rewrite gen_subG; apply/subsetP=> xa; case/imset2P=> x a Gx Aa -> {xa}.
  have Gxa: x ^ a \in G by rewrite memJ_norm ?(subsetP nGA).
  rewrite commgEl; apply/kerP; rewrite (groupM, morphM) ?(groupV, morphV) //=.
  by rewrite nfA ?mulVg.
apply/trivgP; apply/subsetP=> x /setIP[Rx cAx]; apply/set1P.
have Gx: x \in G by apply: subsetP Rx; rewrite commg_subl.
rewrite -(expgK coGA Gx) (_ : x ^+ _ = 1) ?expg1n //.
rewrite -(fmodK abG Gx) -fmvalZ -(mker (subsetP kerR x Rx)); congr fmval.
rewrite -GRing.sumr_const; apply: eq_bigr => a Aa.
by rewrite -fmodJ ?(subsetP nGA) // /conjg (centP cAx) // mulKg.
Qed.

Section Transfer.

Variables (gT aT : finGroupType) (G H : {group gT}).
Variable alpha : {morphism H >-> aT}.

Hypotheses (sHG : H \subset G) (abelA : abelian (alpha @* H)).

Local Notation HG := (rcosets (gval H) (gval G)).

Fact transfer_morph_subproof : H \subset alpha @*^-1 (alpha @* H).
Proof. by rewrite -sub_morphim_pre. Qed.

Let fmalpha := restrm transfer_morph_subproof (fmod abelA \o alpha).

Let V (rX : {set gT} -> gT) g :=
  \sum_(Hx in rcosets H G) fmalpha (rX Hx * g * (rX (Hx :* g))^-1).

Definition transfer g := V repr g.

(* This is Aschbacher (37.2). *)
Lemma transferM : {in G &, {morph transfer : x y / (x * y)%g >-> x + y}}.
Proof.
move=> s t Gs Gt /=.
rewrite [transfer t](reindex_acts 'Rs _ Gs) ?actsRs_rcosets //= -big_split /=.
apply: eq_bigr => _ /rcosetsP[x Gx ->]; rewrite !rcosetE -!rcosetM.
rewrite -zmodMgE -morphM -?mem_rcoset; first by rewrite !mulgA mulgKV rcosetM.
  by rewrite rcoset_repr rcosetM mem_rcoset mulgK mem_repr_rcoset.
by rewrite rcoset_repr (rcosetM _ _ t) mem_rcoset mulgK mem_repr_rcoset.
Qed.

Canonical transfer_morphism := Morphism transferM.

(* This is Aschbacher (37.1). *)
Lemma transfer_indep X (rX := transversal_repr 1 X) :
  is_transversal X HG G -> {in G, transfer =1 V rX}.
Proof.
move=> trX g Gg; have mem_rX := repr_mem_pblock trX 1; rewrite -/rX in mem_rX.
apply: (addrI (\sum_(Hx in HG) fmalpha (repr Hx * (rX Hx)^-1))).
rewrite {1}(reindex_acts 'Rs _ Gg) ?actsRs_rcosets // -!big_split /=.
apply: eq_bigr => _ /rcosetsP[x Gx ->]; rewrite !rcosetE -!rcosetM.
case: repr_rcosetP => h1 Hh1; case: repr_rcosetP => h2 Hh2.
have: H :* (x * g) \in rcosets H G by rewrite -rcosetE mem_imset ?groupM.
have: H :* x \in rcosets H G by rewrite -rcosetE mem_imset.
case/mem_rX/rcosetP=> h3 Hh3 -> /mem_rX/rcosetP[h4 Hh4 ->].
rewrite -!(mulgA h1) -!(mulgA h2) -!(mulgA h3) !(mulKVg, invMg).
by rewrite addrC -!zmodMgE -!morphM ?groupM ?groupV // -!mulgA !mulKg.
Qed.

Section FactorTransfer.

Variable g : gT.
Hypothesis Gg : g \in G.

Let sgG : <[g]> \subset G. Proof. by rewrite cycle_subG. Qed.
Let H_g_rcosets x : {set {set gT}} := rcosets (H :* x) <[g]>.
Let n_ x := #|<[g]> : H :* x|.

Lemma mulg_exp_card_rcosets x : x * (g ^+ n_ x) \in H :* x.
Proof.
rewrite /n_ /indexg -orbitRs -pcycle_actperm ?inE //.
rewrite -{2}(iter_pcycle (actperm 'Rs g) (H :* x)) -permX -morphX ?inE //.
by rewrite actpermE //= rcosetE -rcosetM rcoset_refl.
Qed.

Let HGg : {set {set {set gT}}} := orbit 'Rs <[g]> @: rcosets H G.

Let partHG : partition HG G := rcosets_partition sHG.
Let actsgHG : [acts <[g]>, on HG | 'Rs].
Proof. exact: subset_trans sgG (actsRs_rcosets H G). Qed.
Let partHGg : partition HGg HG := orbit_partition actsgHG.

Let injHGg : {in HGg &, injective cover}.
Proof. by have [] := partition_partition partHG partHGg. Qed.

Let defHGg : HG :* <[g]> = cover @: HGg.
Proof.
rewrite -imset_comp [_ :* _]imset2_set1r; apply: eq_imset => Hx /=.
by rewrite cover_imset -curry_imset2r.
Qed.

Lemma rcosets_cycle_partition : partition (HG :* <[g]>) G.
Proof. by rewrite defHGg; have [] := partition_partition partHG partHGg. Qed.

Variable X : {set gT}.
Hypothesis trX : is_transversal X (HG :* <[g]>) G.

Let sXG : {subset X <= G}. Proof. exact/subsetP/(transversal_sub trX). Qed.

Lemma rcosets_cycle_transversal : H_g_rcosets @: X = HGg.
Proof.
have sHXgHGg x: x \in X -> H_g_rcosets x \in HGg.
  by move/sXG=> Gx; apply: mem_imset; rewrite -rcosetE mem_imset.
apply/setP=> Hxg; apply/imsetP/idP=> [[x /sHXgHGg HGgHxg -> //] | HGgHxg].
have [_ /rcosetsP[z Gz ->] ->] := imsetP HGgHxg.
pose Hzg := H :* z * <[g]>; pose x := transversal_repr 1 X Hzg.
have HGgHzg: Hzg \in HG :* <[g]>.
  by rewrite mem_mulg ?set11 // -rcosetE mem_imset.
have Hzg_x: x \in Hzg by rewrite (repr_mem_pblock trX).
exists x; first by rewrite (repr_mem_transversal trX).
case/mulsgP: Hzg_x => y u /rcoset_transl <- /(orbit_act 'Rs) <- -> /=.
by rewrite rcosetE -rcosetM.
Qed.

Local Notation defHgX := rcosets_cycle_transversal.

Let injHg: {in X &, injective H_g_rcosets}.
Proof.
apply/imset_injP; rewrite defHgX (card_transversal trX) defHGg.
by rewrite (card_in_imset injHGg).
Qed.

Lemma sum_index_rcosets_cycle : (\sum_(x in X) n_ x)%N = #|G : H|.
Proof. by rewrite [#|G : H|](card_partition partHGg) -defHgX big_imset. Qed.

Lemma transfer_cycle_expansion :
   transfer g = \sum_(x in X) fmalpha ((g ^+ n_ x) ^ x^-1).
Proof.
pose Y := \bigcup_(x in X) [set x * g ^+ i | i : 'I_(n_ x)].
pose rY := transversal_repr 1 Y.
pose pcyc x := pcycle (actperm 'Rs g) (H :* x).
pose traj x := traject (actperm 'Rs g) (H :* x) #|pcyc x|.
have Hgr_eq x: H_g_rcosets x = pcyc x.
  by rewrite /H_g_rcosets -orbitRs -pcycle_actperm ?inE.
have pcyc_eq x: pcyc x =i traj x by exact: pcycle_traject.
have uniq_traj x: uniq (traj x) by apply: uniq_traject_pcycle.
have n_eq x: n_ x = #|pcyc x| by rewrite -Hgr_eq.
have size_traj x: size (traj x) = n_ x by rewrite n_eq size_traject.
have nth_traj x j: j < n_ x -> nth (H :* x) (traj x) j = H :* (x * g ^+ j).
  move=> lt_j_x; rewrite nth_traject -?n_eq //.
  by rewrite  -permX -morphX ?inE // actpermE //= rcosetE rcosetM.
have sYG: Y \subset G.
  apply/bigcupsP=> x Xx; apply/subsetP=> _ /imsetP[i _ ->].
  by rewrite groupM ?groupX // sXG.
have trY: is_transversal Y HG G.
  apply/and3P; split=> //; apply/forall_inP=> Hy.
  have /and3P[/eqP <- _ _] := partHGg; rewrite -defHgX cover_imset.
  case/bigcupP=> x Xx; rewrite Hgr_eq pcyc_eq => /trajectP[i].
  rewrite -n_eq -permX -morphX ?in_setT // actpermE /= rcosetE -rcosetM => lti.
  set y := x * _ => ->{Hy}; pose oi := Ordinal lti.
  have Yy: y \in Y by apply/bigcupP; exists x => //; apply/imsetP; exists oi.
  apply/cards1P; exists y; apply/esym/eqP.
  rewrite eqEsubset sub1set inE Yy rcoset_refl.
  apply/subsetP=> _ /setIP[/bigcupP[x' Xx' /imsetP[j _ ->]] Hy_x'gj].
  have eq_xx': x = x'.
    apply: (pblock_inj trX) => //; have /andP[/and3P[_ tiX _] _] := trX.
    have HGgHyg: H :* y * <[g]> \in HG :* <[g]>.
      by rewrite mem_mulg ?set11 // -rcosetE mem_imset ?(subsetP sYG).
    rewrite !(def_pblock tiX HGgHyg) //.
      by rewrite -[x'](mulgK (g ^+ j)) mem_mulg // groupV mem_cycle.
    by rewrite -[x](mulgK (g ^+ i)) mem_mulg ?rcoset_refl // groupV mem_cycle.
  apply/set1P; rewrite /y eq_xx'; congr (_ * _ ^+ _) => //; apply/eqP.
  rewrite -(@nth_uniq _ (H :* x) (traj x)) ?size_traj // ?eq_xx' //.
  by rewrite !nth_traj ?(rcoset_transl Hy_x'gj) // -eq_xx'.
have rYE x i : x \in X -> i < n_ x -> rY (H :* x :* g ^+ i) = x * g ^+ i.
  move=> Xx lt_i_x; rewrite -rcosetM; apply: (canLR_in (pblockK trY 1)).
    by apply/bigcupP; exists x => //; apply/imsetP; exists (Ordinal lt_i_x).
  apply/esym/def_pblock; last exact: rcoset_refl; first by case/and3P: partHG.
  by rewrite -rcosetE mem_imset ?groupM ?groupX // sXG.
rewrite (transfer_indep trY Gg) /V -/rY (set_partition_big _ partHGg) /=.
rewrite -defHgX big_imset /=; last first.
  apply/imset_injP; rewrite defHgX (card_transversal trX) defHGg.
  by rewrite (card_in_imset injHGg).
apply eq_bigr=> x Xx; rewrite Hgr_eq (eq_bigl _ _ (pcyc_eq x)) -big_uniq //=.
have n_gt0: 0 < n_ x by rewrite indexg_gt0.
rewrite /traj -n_eq; case def_n: (n_ x) (n_gt0) => // [n] _.
rewrite conjgE invgK -{1}[H :* x]rcoset1 -{1}(expg0 g).
elim: {1 3}n 0%N (addn0 n) => [|m IHm] i def_i /=.
  rewrite big_seq1 {i}[i]def_i rYE // ?def_n //.
  rewrite  -(mulgA _ _ g) -rcosetM -expgSr -[(H :* x) :* _]rcosetE.
  rewrite -actpermE morphX ?inE // permX // -{2}def_n n_eq iter_pcycle mulgA.
  by rewrite -[H :* x]rcoset1 (rYE _ 0%N) ?mulg1.
rewrite big_cons rYE //; last by rewrite def_n -def_i ltnS leq_addl.
rewrite permE /= rcosetE -rcosetM -(mulgA _ _ g) -expgSr.
rewrite addSnnS in def_i; rewrite IHm //.
rewrite rYE //; last by rewrite def_n -def_i ltnS leq_addl.
by rewrite mulgV [fmalpha 1]morph1 add0r.
Qed.

End FactorTransfer.

End Transfer.