(** * [Proper] morphisms for ℤ constants *)
Require Import Coq.micromega.Lia.
Require Import Coq.ZArith.ZArith.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Classes.RelationPairs.
Require Import Crypto.Util.ZUtil.Definitions.
Require Import Crypto.Util.ZUtil.Div.
Require Import Crypto.Util.ZUtil.LandLorBounds.
Require Import Crypto.Util.ZUtil.Tactics.PeelLe.
Require Import Crypto.Util.ZUtil.Tactics.DivModToQuotRem.
Require Import Crypto.Util.ZUtil.Tactics.LtbToLt.
Require Import Crypto.Util.Tactics.UniquePose.
Require Import Crypto.Util.Tactics.DestructHead.
Require Import Crypto.Util.Tactics.BreakMatch.
Local Open Scope Z_scope.

Module Z.
  (** We prove a bunch of [Proper] lemmas, but do not make them
      instances; making them instances would slow typeclass search
      unacceptably.  In files where we use these, we add them with
      [Local Existing Instances]. *)
  Lemma succ_le_Proper : Proper (Z.le ==> Z.le) Z.succ.
  Proof. repeat (lia || intro). Qed.
#[global]
  Hint Resolve succ_le_Proper : zarith.
  Lemma add_le_Proper : Proper (Z.le ==> Z.le ==> Z.le) Z.add.
  Proof. repeat (lia || intro). Qed.
#[global]
  Hint Resolve add_le_Proper : zarith.
  Lemma add_le_Proper' x : Proper (Z.le ==> Z.le) (Z.add x).
  Proof. repeat (lia || intro). Qed.
#[global]
  Hint Resolve add_le_Proper' : zarith.
  Lemma sub_le_ge_Proper : Proper (Z.le ==> Z.ge ==> Z.le) Z.sub.
  Proof. repeat (lia || intro). Qed.
#[global]
  Hint Resolve sub_le_ge_Proper : zarith.
  Lemma sub_le_flip_le_Proper : Proper (Z.le ==> Basics.flip Z.le ==> Z.le) Z.sub.
  Proof. unfold Basics.flip; repeat (lia || intro). Qed.
#[global]
  Hint Resolve sub_le_flip_le_Proper : zarith.
  Lemma sub_le_eq_Proper : Proper (Z.le ==> Logic.eq ==> Z.le) Z.sub.
  Proof. repeat (lia || intro). Qed.
#[global]
  Hint Resolve sub_le_eq_Proper : zarith.
  Lemma mul_Zpos_le_Proper p : Proper (Z.le ==> Z.le) (Z.mul (Z.pos p)).
  Proof. repeat (nia || intro). Qed.
#[global]
  Hint Resolve mul_Zpos_le_Proper : zarith.
  Lemma log2_up_le_Proper : Proper (Z.le ==> Z.le) Z.log2_up.
  Proof. intros ???; apply Z.log2_up_le_mono; assumption. Qed.
#[global]
  Hint Resolve log2_up_le_Proper : zarith.
  Lemma log2_le_Proper : Proper (Z.le ==> Z.le) Z.log2.
  Proof. intros ???; apply Z.log2_le_mono; assumption. Qed.
#[global]
  Hint Resolve log2_le_Proper : zarith.
  Lemma pow_Zpos_le_Proper x : Proper (Z.le ==> Z.le) (Z.pow (Z.pos x)).
  Proof. intros ???; apply Z.pow_le_mono_r; try reflexivity; try assumption. Qed.
#[global]
  Hint Resolve pow_Zpos_le_Proper : zarith.
  Lemma lt_le_flip_Proper_flip_impl
    : Proper (Z.le ==> Basics.flip Z.le ==> Basics.flip Basics.impl) Z.lt.
  Proof. unfold Basics.flip; repeat (lia || intro). Qed.
#[global]
  Hint Resolve lt_le_flip_Proper_flip_impl : zarith.
  Lemma le_Proper_ge_le_flip_impl : Proper (Z.le ==> Z.ge ==> Basics.flip Basics.impl) Z.le.
  Proof. intros ???????; lia. Qed.
#[global]
  Hint Resolve le_Proper_ge_le_flip_impl : zarith.
  Lemma add_le_Proper_flip : Proper (Basics.flip Z.le ==> Basics.flip Z.le ==> Basics.flip Z.le) Z.add.
  Proof. unfold Basics.flip; repeat (lia || intro). Qed.
#[global]
  Hint Resolve add_le_Proper_flip : zarith.
  Lemma sub_le_ge_Proper_flip : Proper (Basics.flip Z.le ==> Basics.flip Z.ge ==> Basics.flip Z.le) Z.sub.
  Proof. unfold Basics.flip; repeat (lia || intro). Qed.
#[global]
  Hint Resolve sub_le_ge_Proper_flip : zarith.
  Lemma sub_flip_le_le_Proper_flip : Proper (Basics.flip Z.le ==> Z.le ==> Basics.flip Z.le) Z.sub.
  Proof. unfold Basics.flip; repeat (lia || intro). Qed.
#[global]
  Hint Resolve sub_flip_le_le_Proper_flip : zarith.
  Lemma sub_le_eq_Proper_flip : Proper (Basics.flip Z.le ==> Logic.eq ==> Basics.flip Z.le) Z.sub.
  Proof. unfold Basics.flip; repeat (lia || intro). Qed.
#[global]
  Hint Resolve sub_le_eq_Proper_flip : zarith.
  Lemma log2_up_le_Proper_flip : Proper (Basics.flip Z.le ==> Basics.flip Z.le) Z.log2_up.
  Proof. intros ???; apply Z.log2_up_le_mono; assumption. Qed.
#[global]
  Hint Resolve log2_up_le_Proper_flip : zarith.
  Lemma log2_le_Proper_flip : Proper (Basics.flip Z.le ==> Basics.flip Z.le) Z.log2.
  Proof. intros ???; apply Z.log2_le_mono; assumption. Qed.
#[global]
  Hint Resolve log2_le_Proper_flip : zarith.
  Lemma pow_Zpos_le_Proper_flip x : Proper (Basics.flip Z.le ==> Basics.flip Z.le) (Z.pow (Z.pos x)).
  Proof. intros ???; apply Z.pow_le_mono_r; try reflexivity; try assumption. Qed.
#[global]
  Hint Resolve pow_Zpos_le_Proper_flip : zarith.
  Lemma add_with_carry_le_Proper : Proper (Z.le ==> Z.le ==> Z.le ==> Z.le) Z.add_with_carry.
  Proof. unfold Z.add_with_carry; repeat (lia || intro). Qed.
#[global]
  Hint Resolve add_with_carry_le_Proper : zarith.
  Lemma sub_with_borrow_le_Proper : Proper (Basics.flip Z.le ==> Z.le ==> Basics.flip Z.le ==> Z.le) Z.sub_with_borrow.
  Proof. unfold Z.sub_with_borrow, Z.add_with_carry, Basics.flip; repeat (lia || intro). Qed.
#[global]
  Hint Resolve sub_with_borrow_le_Proper : zarith.
  Lemma opp_flip_le_le_Proper : Proper (Basics.flip Z.le ==> Z.le) Z.opp.
  Proof. cbv [Basics.flip]; repeat (lia || intro). Qed.
#[global]
  Hint Resolve opp_flip_le_le_Proper : zarith.
  Lemma opp_le_flip_le_Proper : Proper (Z.le ==> Basics.flip Z.le) Z.opp.
  Proof. cbv [Basics.flip]; repeat (lia || intro). Qed.
#[global]
  Hint Resolve opp_le_flip_le_Proper : zarith.
  Lemma opp_le_ge_Proper : Proper (Z.le ==> Z.ge) Z.opp.
  Proof. cbv [Basics.flip]; repeat (lia || intro). Qed.
#[global]
  Hint Resolve opp_le_ge_Proper : zarith.
  Lemma opp_ge_le_Proper : Proper (Z.ge ==> Z.le) Z.opp.
  Proof. cbv [Basics.flip]; repeat (lia || intro). Qed.
#[global]
  Hint Resolve opp_ge_le_Proper : zarith.
  Lemma add_le_Proper'' x : Proper (Z.le ==> Z.le) (fun y => Z.add y x).
  Proof. repeat (lia || intro). Qed.
#[global]
  Hint Resolve add_le_Proper'' : zarith.
  Lemma sub_le_ge_Proper_r p : Proper (Z.le ==> Z.ge) (Z.sub p).
  Proof. repeat (lia || intro). Qed.
#[global]
  Hint Resolve sub_le_ge_Proper_r : zarith.
  Lemma sub_le_le_Proper_l p : Proper (Z.le ==> Z.le) (fun x => Z.sub x p).
  Proof. repeat (lia || intro). Qed.
#[global]
  Hint Resolve sub_le_le_Proper_l : zarith.
  Lemma sub_le_flip_le_Proper_r p : Proper (Z.le ==> Basics.flip Z.le) (Z.sub p).
  Proof. unfold Basics.flip; repeat (lia || intro). Qed.
#[global]
  Hint Resolve sub_le_flip_le_Proper_r : zarith.
  Lemma sub_flip_le_le_Proper_r p : Proper (Basics.flip Z.le ==> Z.le) (Z.sub p).
  Proof. unfold Basics.flip; repeat (lia || intro). Qed.
#[global]
  Hint Resolve sub_flip_le_le_Proper_r : zarith.
  Lemma sub_ge_le_Proper_r p : Proper (Z.ge ==> Z.le) (Z.sub p).
  Proof. unfold Basics.flip; repeat (lia || intro). Qed.
#[global]
  Hint Resolve sub_ge_le_Proper_r : zarith.
  Lemma mul_Z0_le_Proper : Proper (Z.le ==> Z.le) (Z.mul Z0).
  Proof. repeat (nia || intro). Qed.
#[global]
  Hint Resolve mul_Z0_le_Proper : zarith.
  Lemma mul_Zneg_le_flip_le_Proper p : Proper (Z.le ==> Basics.flip Z.le) (Z.mul (Zneg p)).
  Proof. cbv [Basics.flip]; repeat (nia || intro). Qed.
#[global]
  Hint Resolve mul_Zneg_le_flip_le_Proper : zarith.
  Lemma mul_Zneg_le_ge_Proper p : Proper (Z.le ==> Z.ge) (Z.mul (Zneg p)).
  Proof. cbv [Basics.flip]; repeat (nia || intro). Qed.
#[global]
  Hint Resolve mul_Zneg_le_ge_Proper : zarith.
  Lemma mul_Zneg_flip_le_le_Proper p : Proper (Basics.flip Z.le ==> Z.le) (Z.mul (Zneg p)).
  Proof. cbv [Basics.flip]; repeat (nia || intro). Qed.
#[global]
  Hint Resolve mul_Zneg_flip_le_le_Proper : zarith.
  Lemma mul_Zneg_ge_le_Proper p : Proper (Z.ge ==> Z.le) (Z.mul (Zneg p)).
  Proof. cbv [Basics.flip]; repeat (nia || intro). Qed.
#[global]
  Hint Resolve mul_Zneg_ge_le_Proper : zarith.
  Lemma mul_Zpos_le_Proper' p : Proper (Z.le ==> Z.le) (fun y => Z.mul y (Zpos p)).
  Proof. cbv [Basics.flip]; repeat (nia || intro). Qed.
#[global]
  Hint Resolve mul_Zpos_le_Proper' : zarith.
  Lemma mul_Z0_le_Proper' : Proper (Z.le ==> Z.le) (fun y => Z.mul y Z0).
  Proof. repeat (nia || intro). Qed.
#[global]
  Hint Resolve mul_Z0_le_Proper' : zarith.
  Lemma mul_Zneg_le_flip_le_Proper' p : Proper (Z.le ==> Basics.flip Z.le) (fun y => Z.mul y (Zneg p)).
  Proof. cbv [Basics.flip]; repeat (nia || intro). Qed.
#[global]
  Hint Resolve mul_Zneg_le_flip_le_Proper' : zarith.
  Lemma mul_Zneg_le_ge_Proper' p : Proper (Z.le ==> Z.ge) (fun y => Z.mul y (Zneg p)).
  Proof. cbv [Basics.flip]; repeat (nia || intro). Qed.
#[global]
  Hint Resolve mul_Zneg_le_ge_Proper' : zarith.
  Lemma mul_Zneg_flip_le_le_Proper' p : Proper (Basics.flip Z.le ==> Z.le) (fun y => Z.mul y (Zneg p)).
  Proof. cbv [Basics.flip]; repeat (nia || intro). Qed.
#[global]
  Hint Resolve mul_Zneg_flip_le_le_Proper' : zarith.
  Lemma mul_Zneg_ge_le_Proper' p : Proper (Z.ge ==> Z.le) (fun y => Z.mul y (Zneg p)).
  Proof. cbv [Basics.flip]; repeat (nia || intro). Qed.
#[global]
  Hint Resolve mul_Zneg_ge_le_Proper' : zarith.
  Lemma div_Zpos_le_Proper_r p : Proper (Z.le ==> Z.le) (fun x => Z.div x (Zpos p)).
  Proof. repeat (nia || Z.div_mod_to_quot_rem || intro). Qed.
#[global]
  Hint Resolve div_Zpos_le_Proper_r : zarith.
  Lemma div_Z0_le_Proper_r : Proper (Z.le ==> Z.le) (fun x => Z.div x Z0).
  Proof. repeat (nia || Z.div_mod_to_quot_rem || intro). Qed.
#[global]
  Hint Resolve div_Z0_le_Proper_r : zarith.
  Lemma div_Zneg_le_flip_le_Proper_r p : Proper (Z.le ==> Basics.flip Z.le) (fun x => Z.div x (Zneg p)).
  Proof. cbv [Basics.flip]; repeat (nia || Z.div_mod_to_quot_rem || intro). Qed.
#[global]
  Hint Resolve div_Zneg_le_flip_le_Proper_r : zarith.
  Lemma div_Zneg_flip_le_le_Proper_r p : Proper (Basics.flip Z.le ==> Z.le) (fun x => Z.div x (Zneg p)).
  Proof. cbv [Basics.flip]; repeat (nia || Z.div_mod_to_quot_rem || intro). Qed.
#[global]
  Hint Resolve div_Zneg_flip_le_le_Proper_r : zarith.
  Lemma div_Z0_le_Proper_l : Proper (Z.le ==> Z.le) (Z.div Z0).
  Proof. do 3 intro; destruct_head' Z; cbv; congruence. Qed.
#[global]
  Hint Resolve div_Z0_le_Proper_l : zarith.
  Local Ltac div_Proper_t :=
    let H := fresh in
    cbv [Basics.flip]; intros ?? H; apply Pos2Z.pos_le_pos in H;
    apply Z.div_cross_le_abs; cbn [Z.sgn Z.abs]; try nia.
  Lemma div_Zpos_Zpos_le_Proper_l p : Proper (Basics.flip Pos.le ==> Z.le) (fun x => Z.div (Zpos p) (Zpos x)).
  Proof. div_Proper_t. Qed.
#[global]
  Hint Resolve div_Zpos_Zpos_le_Proper_l : zarith.
  Lemma div_Zpos_Zneg_le_Proper_l p : Proper (Pos.le ==> Z.le) (fun x => Z.div (Zpos p) (Zneg x)).
  Proof. div_Proper_t. Qed.
#[global]
  Hint Resolve div_Zpos_Zneg_le_Proper_l : zarith.
  Lemma div_Zneg_Zpos_le_Proper_l p : Proper (Pos.le ==> Z.le) (fun x => Z.div (Zneg p) (Zpos x)).
  Proof. div_Proper_t. Qed.
#[global]
  Hint Resolve div_Zneg_Zpos_le_Proper_l : zarith.
  Lemma div_Zneg_Zneg_le_Proper_l p : Proper (Basics.flip Pos.le ==> Z.le) (fun x => Z.div (Zneg p) (Zneg x)).
  Proof. div_Proper_t. Qed.
#[global]
  Hint Resolve div_Zneg_Zneg_le_Proper_l : zarith.
  Lemma div_Z0_Zpos_le_Proper_l : Proper (Basics.flip Pos.le ==> Z.le) (fun x => Z.div Z0 (Zpos x)).
  Proof. div_Proper_t. Qed.
#[global]
  Hint Resolve div_Z0_Zpos_le_Proper_l : zarith.
  Lemma div_Z0_Zneg_le_Proper_l : Proper (Pos.le ==> Z.le) (fun x => Z.div Z0 (Zneg x)).
  Proof. div_Proper_t. Qed.
#[global]
  Hint Resolve div_Z0_Zneg_le_Proper_l : zarith.
  Lemma div_Zpos_Zpos_le_Proper_r x : Proper (Pos.le ==> Z.le) (fun p => Z.div (Zpos p) (Zpos x)).
  Proof. div_Proper_t. Qed.
#[global]
  Hint Resolve div_Zpos_Zpos_le_Proper_r : zarith.
  Lemma div_Zpos_Zneg_le_Proper_r x : Proper (Basics.flip Pos.le ==> Z.le) (fun p => Z.div (Zpos p) (Zneg x)).
  Proof. div_Proper_t. Qed.
#[global]
  Hint Resolve div_Zpos_Zneg_le_Proper_r : zarith.
  Lemma div_Zneg_Zpos_le_Proper_r x : Proper (Basics.flip Pos.le ==> Z.le) (fun p => Z.div (Zneg p) (Zpos x)).
  Proof. div_Proper_t. Qed.
#[global]
  Hint Resolve div_Zneg_Zpos_le_Proper_r : zarith.
  Lemma div_Zneg_Zneg_le_Proper_r x : Proper (Pos.le ==> Z.le) (fun p => Z.div (Zneg p) (Zneg x)).
  Proof. div_Proper_t. Qed.
#[global]
  Hint Resolve div_Zneg_Zneg_le_Proper_r : zarith.
  Lemma div_Zpos_Z0_le_Proper_r : Proper (Pos.le ==> Z.le) (fun p => Z.div (Zpos p) Z0).
  Proof. do 3 intro; cbv; congruence. Qed.
#[global]
  Hint Resolve div_Zpos_Z0_le_Proper_r : zarith.
  Lemma div_Zneg_Z0_le_Proper_r : Proper (Basics.flip Pos.le ==> Z.le) (fun p => Z.div (Zneg p) Z0).
  Proof. do 3 intro; cbv; congruence. Qed.
#[global]
  Hint Resolve div_Zneg_Z0_le_Proper_r : zarith.
  Local Ltac shift_t :=
    repeat first [ progress intros
                 | progress cbv [Proper respectful Basics.flip] in *
                 | progress rewrite ?Z.shiftr_div_pow2, ?Z.shiftr_mul_pow2, ?Z.shiftl_div_pow2, ?Z.shiftl_mul_pow2, ?Z.div_1_r, ?Zdiv_0_l by lia
                 | progress (cbn [Z.pow Z.opp]; change Z.pow_pos with (fun x p => Z.pow x (Zpos p)); cbn beta)
                 | progress Z.peel_le
                 | nia
                 | match goal with
                   | [ |- context[(2^Zpos ?p)%Z] ] => unique assert (0 < 2^Zpos p)%Z by (apply Z.pow_pos_nonneg; lia)
                   | [ |- (?x / ?a <= ?x * ?b)%Z ] => transitivity x
                   | [ |- (?x * ?a <= ?x / ?b)%Z ] => transitivity x
                   | [ H : (0 > Z.neg _)%Z |- _ ] => clear H
                   | [ H : (Zneg ?a <= Zneg ?b)%Z |- _ ] => assert ((Zpos b <= Zpos a)%Z) by lia; clear H
                   | [ H : (?a <= ?b)%Z |- context[(2^?a)%Z] ]
                     => unique assert (2^a <= 2^b)%Z by (apply Z.pow_le_mono_r; lia); clear H
                   | [ |- context[(2^Zpos ?a)%Z] ] => generalize dependent (2^Zpos a)%Z; clear a
                   end
                 | progress destruct_head' Z
                 | Z.div_mod_to_quot_rem; nia
                 | apply Z.div_cross_le_abs; cbn [Z.sgn Z.abs]; nia ].
  Lemma shiftr_le_Proper_l : forall y : Z, Proper (Z.le ==> Z.le) (fun x : Z => Z.shiftr x y).
  Proof. shift_t. Qed.
#[global]
  Hint Resolve shiftr_le_Proper_l : zarith.
  Lemma shiftl_le_Proper_l : forall y : Z, Proper (Z.le ==> Z.le) (fun x : Z => Z.shiftl x y).
  Proof. shift_t. Qed.
#[global]
  Hint Resolve shiftl_le_Proper_l : zarith.
  Lemma shiftr_le_Proper_r x
        (R := fun b : bool => if b then Basics.flip Z.le else Z.le)
    : Proper (R (0 <=? x)%Z ==> Z.le) (Z.shiftr x).
  Proof. subst R; cbv beta; break_match; Z.ltb_to_lt; shift_t. Qed.
#[global]
  Hint Resolve shiftr_le_Proper_r : zarith.
  Lemma shiftl_le_Proper_r x
        (R := fun b : bool => if b then Z.le else Basics.flip Z.le)
    : Proper (R (0 <=? x)%Z ==> Z.le) (Z.shiftl x).
  Proof. subst R; cbv beta; break_match; Z.ltb_to_lt; shift_t. Qed.
#[global]
  Hint Resolve shiftl_le_Proper_r : zarith.
  Local Ltac shift_Proper_t' :=
    let H := fresh in
    cbv [Basics.flip]; intros ?? H; apply Pos2Z.pos_le_pos in H;
    try ((apply shiftr_le_Proper_r + apply shiftr_le_Proper_l + apply shiftl_le_Proper_r + apply shiftl_le_Proper_l);
         cbv [Z.leb Z.compare Basics.flip];
         lia).
  Lemma shiftr_Zpos_Zpos_le_Proper_l p : Proper (Basics.flip Pos.le ==> Z.le) (fun x => Z.shiftr (Zpos p) (Zpos x)).
  Proof. shift_Proper_t'. Qed.
#[global]
  Hint Resolve shiftr_Zpos_Zpos_le_Proper_l : zarith.
  Lemma shiftr_Zpos_Zneg_le_Proper_l p : Proper (Pos.le ==> Z.le) (fun x => Z.shiftr (Zpos p) (Zneg x)).
  Proof. shift_Proper_t'. Qed.
#[global]
  Hint Resolve shiftr_Zpos_Zneg_le_Proper_l : zarith.
  Lemma shiftr_Zneg_Zpos_le_Proper_l p : Proper (Pos.le ==> Z.le) (fun x => Z.shiftr (Zneg p) (Zpos x)).
  Proof. shift_Proper_t'. Qed.
#[global]
  Hint Resolve shiftr_Zneg_Zpos_le_Proper_l : zarith.
  Lemma shiftr_Zneg_Zneg_le_Proper_l p : Proper (Basics.flip Pos.le ==> Z.le) (fun x => Z.shiftr (Zneg p) (Zneg x)).
  Proof. shift_Proper_t'. Qed.
#[global]
  Hint Resolve shiftr_Zneg_Zneg_le_Proper_l : zarith.
  Lemma shiftr_Z0_Zpos_le_Proper_l : Proper (Basics.flip Pos.le ==> Z.le) (fun x => Z.shiftr Z0 (Zpos x)).
  Proof. shift_Proper_t'. Qed.
#[global]
  Hint Resolve shiftr_Z0_Zpos_le_Proper_l : zarith.
  Lemma shiftr_Z0_Zneg_le_Proper_l : Proper (Pos.le ==> Z.le) (fun x => Z.shiftr Z0 (Zneg x)).
  Proof. shift_Proper_t'. Qed.
#[global]
  Hint Resolve shiftr_Z0_Zneg_le_Proper_l : zarith.
  Lemma shiftr_Zpos_Zpos_le_Proper_r x : Proper (Pos.le ==> Z.le) (fun p => Z.shiftr (Zpos p) (Zpos x)).
  Proof. shift_Proper_t'. Qed.
#[global]
  Hint Resolve shiftr_Zpos_Zpos_le_Proper_r : zarith.
  Lemma shiftr_Zpos_Zneg_le_Proper_r x : Proper (Pos.le ==> Z.le) (fun p => Z.shiftr (Zpos p) (Zneg x)).
  Proof. shift_Proper_t'. Qed.
#[global]
  Hint Resolve shiftr_Zpos_Zneg_le_Proper_r : zarith.
  Lemma shiftr_Zneg_Zpos_le_Proper_r x : Proper (Basics.flip Pos.le ==> Z.le) (fun p => Z.shiftr (Zneg p) (Zpos x)).
  Proof. shift_Proper_t'. Qed.
#[global]
  Hint Resolve shiftr_Zneg_Zpos_le_Proper_r : zarith.
  Lemma shiftr_Zneg_Zneg_le_Proper_r x : Proper (Basics.flip Pos.le ==> Z.le) (fun p => Z.shiftr (Zneg p) (Zneg x)).
  Proof. shift_Proper_t'. Qed.
#[global]
  Hint Resolve shiftr_Zneg_Zneg_le_Proper_r : zarith.
  Lemma shiftr_Zpos_Z0_le_Proper_r : Proper (Pos.le ==> Z.le) (fun p => Z.shiftr (Zpos p) Z0).
  Proof. shift_Proper_t'. Qed.
#[global]
  Hint Resolve shiftr_Zpos_Z0_le_Proper_r : zarith.
  Lemma shiftr_Zneg_Z0_le_Proper_r : Proper (Basics.flip Pos.le ==> Z.le) (fun p => Z.shiftr (Zneg p) Z0).
  Proof. shift_Proper_t'. Qed.
#[global]
  Hint Resolve shiftr_Zneg_Z0_le_Proper_r : zarith.
  Lemma shiftl_Zpos_Zpos_le_Proper_l p : Proper (Pos.le ==> Z.le) (fun x => Z.shiftl (Zpos p) (Zpos x)).
  Proof. shift_Proper_t'. Qed.
#[global]
  Hint Resolve shiftl_Zpos_Zpos_le_Proper_l : zarith.
  Lemma shiftl_Zpos_Zneg_le_Proper_l p : Proper (Basics.flip Pos.le ==> Z.le) (fun x => Z.shiftl (Zpos p) (Zneg x)).
  Proof. shift_Proper_t'. Qed.
#[global]
  Hint Resolve shiftl_Zpos_Zneg_le_Proper_l : zarith.
  Lemma shiftl_Zneg_Zpos_le_Proper_l p : Proper (Basics.flip Pos.le ==> Z.le) (fun x => Z.shiftl (Zneg p) (Zpos x)).
  Proof. shift_Proper_t'. Qed.
#[global]
  Hint Resolve shiftl_Zneg_Zpos_le_Proper_l : zarith.
  Lemma shiftl_Zneg_Zneg_le_Proper_l p : Proper (Pos.le ==> Z.le) (fun x => Z.shiftl (Zneg p) (Zneg x)).
  Proof. shift_Proper_t'. Qed.
#[global]
  Hint Resolve shiftl_Zneg_Zneg_le_Proper_l : zarith.
  Lemma shiftl_Z0_Zpos_le_Proper_l : Proper (Pos.le ==> Z.le) (fun x => Z.shiftl Z0 (Zpos x)).
  Proof. shift_Proper_t'. Qed.
#[global]
  Hint Resolve shiftl_Z0_Zpos_le_Proper_l : zarith.
  Lemma shiftl_Z0_Zneg_le_Proper_l : Proper (Basics.flip Pos.le ==> Z.le) (fun x => Z.shiftl Z0 (Zneg x)).
  Proof. shift_Proper_t'. Qed.
#[global]
  Hint Resolve shiftl_Z0_Zneg_le_Proper_l : zarith.
  Lemma shiftl_Zpos_Zpos_le_Proper_r x : Proper (Pos.le ==> Z.le) (fun p => Z.shiftl (Zpos p) (Zpos x)).
  Proof. shift_Proper_t'. Qed.
#[global]
  Hint Resolve shiftl_Zpos_Zpos_le_Proper_r : zarith.
  Lemma shiftl_Zpos_Zneg_le_Proper_r x : Proper (Pos.le ==> Z.le) (fun p => Z.shiftl (Zpos p) (Zneg x)).
  Proof. shift_Proper_t'. Qed.
#[global]
  Hint Resolve shiftl_Zpos_Zneg_le_Proper_r : zarith.
  Lemma shiftl_Zneg_Zpos_le_Proper_r x : Proper (Basics.flip Pos.le ==> Z.le) (fun p => Z.shiftl (Zneg p) (Zpos x)).
  Proof. shift_Proper_t'. Qed.
#[global]
  Hint Resolve shiftl_Zneg_Zpos_le_Proper_r : zarith.
  Lemma shiftl_Zneg_Zneg_le_Proper_r x : Proper (Basics.flip Pos.le ==> Z.le) (fun p => Z.shiftl (Zneg p) (Zneg x)).
  Proof. shift_Proper_t'. Qed.
#[global]
  Hint Resolve shiftl_Zneg_Zneg_le_Proper_r : zarith.
  Lemma shiftl_Zpos_Z0_le_Proper_r : Proper (Pos.le ==> Z.le) (fun p => Z.shiftl (Zpos p) Z0).
  Proof. shift_Proper_t'. Qed.
#[global]
  Hint Resolve shiftl_Zpos_Z0_le_Proper_r : zarith.
  Lemma shiftl_Zneg_Z0_le_Proper_r : Proper (Basics.flip Pos.le ==> Z.le) (fun p => Z.shiftl (Zneg p) Z0).
  Proof. shift_Proper_t'. Qed.
#[global]
  Hint Resolve shiftl_Zneg_Z0_le_Proper_r : zarith.

#[global]
  Hint Resolve Z.land_round_Proper_pos_r : zarith.
#[global]
  Hint Resolve Z.land_round_Proper_pos_l : zarith.
#[global]
  Hint Resolve Z.lor_round_Proper_pos_r : zarith.
#[global]
  Hint Resolve Z.lor_round_Proper_pos_l : zarith.
#[global]
  Hint Resolve Z.land_round_Proper_neg_r : zarith.
#[global]
  Hint Resolve Z.land_round_Proper_neg_l : zarith.
#[global]
  Hint Resolve Z.lor_round_Proper_neg_r : zarith.
#[global]
  Hint Resolve Z.lor_round_Proper_neg_l : zarith.
End Z.


Lemma list_eq_dec : forall A (A_eq_dec : forall (x y : A), {x=y}+{x<>y})
  (x y : list A), {x = y} + {x <> y}.
Proof. decide equality. Defined.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable p_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable goal_ : Prop.
Variable dom_ : Universe -> Prop.

Variable a9_ : Universe.
Variable a8_ : Universe.
Variable a7_ : Universe.
Variable a6_ : Universe.
Variable a5_ : Universe.
Variable a4_ : Universe.
Variable a3_ : Universe.
Variable a2_ : Universe.
Variable a18_ : Universe.
Variable a17_ : Universe.
Variable a16_ : Universe.
Variable a15_ : Universe.
Variable a14_ : Universe.
Variable a13_ : Universe.
Variable a12_ : Universe.
Variable a11_ : Universe.
Variable a10_ : Universe.
Variable a1_ : Universe.

Variable ax1_1 : (dom_ a1_ /\ (dom_ a2_ /\ (dom_ a3_ /\ (dom_ a4_ /\ (dom_ a5_ /\ (dom_ a6_ /\ (dom_ a7_ /\ (dom_ a8_ /\ (dom_ a9_ /\ (dom_ a10_ /\ (dom_ a11_ /\ (dom_ a12_ /\ (dom_ a13_ /\ (dom_ a14_ /\ (dom_ a15_ /\ (dom_ a16_ /\ (dom_ a17_ /\ dom_ a18_))))))))))))))))).
Variable ax2_2 : (forall A1 A2 A3 A4 A5 A6 A7 A8 A9 A10 A11 A12 A13 A14 A15 A16 A17 A18 : Universe, ((dom_ A1 /\ (dom_ A2 /\ (dom_ A3 /\ (dom_ A4 /\ (dom_ A5 /\ (dom_ A6 /\ (dom_ A7 /\ (dom_ A8 /\ (dom_ A9 /\ (dom_ A10 /\ (dom_ A11 /\ (dom_ A12 /\ (dom_ A13 /\ (dom_ A14 /\ (dom_ A15 /\ (dom_ A16 /\ (dom_ A17 /\ dom_ A18))))))))))))))))) -> p_ A1 A2 A3 A4 A5 A6 A7 A8 A9 A10 A11 A12 A13 A14 A15 A16 A17 A18)).
Variable ax3_3 : (p_ a18_ a17_ a16_ a15_ a14_ a13_ a12_ a11_ a10_ a9_ a8_ a7_ a6_ a5_ a4_ a3_ a2_ a1_ -> goal_).

Theorem lemma18_4 : goal_.
Proof.
  time tac.
Qed.

End FOFProblem.


(* Verify simple double floating add. *)
Require Import VST.floyd.proofauto.
Require Import Step0.step0.
Require Import compcert.lib.Floats.

(* The next line is "boilerplate", always required after importing an AST. *)
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs.  mk_varspecs prog. Defined.

(* In this section we abstract over the semantics of the function that
   computes the delta.
*)
Section XD_Abstract.
  Variable delta : float -> float.

  Definition oneStep0 (input: float) : float :=
    let xd := delta input in
    Float.add input xd.

  Definition xdp_spec :=
    WITH xf: float
    PRE [ _x OF tdouble]
            PROP ()
            LOCAL (temp _x (Vfloat xf))
            SEP ()
    POST [ tdouble ]
            PROP()
            LOCAL (temp ret_temp (Vfloat (delta xf)))
            SEP().

  Definition xdp_type :=
    (tptr (Tfunction (Tcons tdouble Tnil) tdouble cc_default)).

  Definition step0_spec :=
    DECLARE _step0
      WITH x: float, xdp: val
      PRE [ _x OF tdouble,
            _xdp OF xdp_type]
      PROP( )
      LOCAL(temp _x (Vfloat x); temp _xdp xdp)
      SEP (func_ptr' xdp_spec xdp)
      POST [ tdouble ]
      PROP()
      LOCAL(temp ret_temp (Vfloat (oneStep0 x)))
      SEP (func_ptr' xdp_spec xdp).

  Definition Gprog : funspecs :=
    ltac:(with_library prog [ step0_spec ]).

  Lemma body_step0: semax_body Vprog Gprog f_step0 step0_spec.
  Proof.
    start_function.
    forward_call x.
    forward.
    forward.
  Qed.

End XD_Abstract.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj25synthconj1 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural) (lv3 : natural), (@eq natural (plus (mult lv0 lv1) (plus Zero (plus lv1 lv2))) (plus lv3 lv2)).
Admitted.
QuickChick conj25synthconj1.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj19eqsynthconj2 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus lv0 (mult lv1 lv2)) (plus Zero (plus (mult lv2 lv1) lv0))).
Admitted.
QuickChick conj19eqsynthconj2.


Require Import Coqlib.
Require Import List. Import ListNotations.
Require Import Coq.Strings.String.
Require Import Coq.Strings.Ascii.
Require Import sha.functional_prog.
Require Import hmacdrbg.HMAC256_DRBG_functional_prog.
Require Import hmacdrbg.entropy.
Require Import hmacdrbg.DRBG_functions.
(*Require Import DRBG_state_handle.
Require Import DRBG_generate_function.
Require Import DRBG_instantiate_function.
Require Import DRBG_reseed_function.
*)
Require Import sha.ByteBitRelations.

Definition stream_dummy (result: string) (n: nat) : option bool :=
  let hex := bytesToBits (hexstring_to_Zlist result) in
  if nth_ok n hex false then Some (nth n hex false)
  else None.

Definition get_nonce_dummy (result: string) (_: unit) := hexstring_to_Zlist result.

Definition noop_reseed_function (s: ENTROPY.stream) (x: DRBG_state_handle) (_: bool) (_: list Z) := ENTROPY.success x s.

Fixpoint DRBG_generate_check (state_handle: DRBG_state_handle) (internal_states: list (string * string * string)) (returned_bits: string) :=
  let test_HMAC256_DRBG_generate_function := HMAC256_DRBG_generate_function noop_reseed_function 1024 128 128 in
  match internal_states with
    | [] => True
    | (key, v, additional_input)::[] =>
      let key := hexstring_to_Zlist key in
      let value := hexstring_to_Zlist v in
      let additional_input := hexstring_to_Zlist additional_input in
      let returned_bits := hexstring_to_Zlist returned_bits in
      match test_HMAC256_DRBG_generate_function (stream_dummy "") state_handle 128 256 false additional_input with
        | ENTROPY.success (returned_bits', ((value', key', _), _, _)) _ => listZ_eq value value' = true /\ listZ_eq key key' = true /\ listZ_eq returned_bits returned_bits' = true
        | ENTROPY.error _ _ => False
      end
    | (key, v, additional_input)::tl =>
      let key := hexstring_to_Zlist key in
      let value := hexstring_to_Zlist v in
      let additional_input := hexstring_to_Zlist additional_input in
      match test_HMAC256_DRBG_generate_function (stream_dummy "") state_handle 128 256 false additional_input with
        | ENTROPY.success (_, ((value', key', x), y, z)) _ => listZ_eq value value' = true /\ listZ_eq key key' = true /\ DRBG_generate_check ((value', key', x), y, z) tl returned_bits
        | ENTROPY.error _ _ => False
      end
  end.

Definition DRBG_reseed_check (state_handle: DRBG_state_handle) (entropy_input_reseed additional_input_reseed key_reseed value_reseed: string) (internal_states: list (string * string * string)) (returned_bits: string) :=
  let key := hexstring_to_Zlist key_reseed in
  let value := hexstring_to_Zlist value_reseed in
  match HMAC256_DRBG_reseed_function 32 32 256 (stream_dummy entropy_input_reseed) state_handle false (hexstring_to_Zlist additional_input_reseed) with
    | ENTROPY.success ((value', key', x), y, z) _ => listZ_eq value value' = true /\ listZ_eq key key' = true /\ DRBG_generate_check ((value', key', x), y, z) internal_states returned_bits
    | _ => False
  end.

Definition DRBG_check (entropy_input nonce key value personalization_string: string) (entropy_input_reseed additional_input_reseed key_reseed value_reseed: string) (internal_states: list (string * string * string)) (returned_bits: string) :=
  let key := hexstring_to_Zlist key in
  let value := hexstring_to_Zlist value in
  let personalization_string := hexstring_to_Zlist personalization_string in
  match HMAC256_DRBG_instantiate_function 32 32 (get_nonce_dummy nonce) 256 256 false (stream_dummy entropy_input) 256 false personalization_string with
    | ENTROPY.success ((value', key', x), y, z) _ => listZ_eq value value' = true /\ listZ_eq key key' = true /\ DRBG_reseed_check ((value', key', x), y, z) entropy_input_reseed additional_input_reseed key_reseed value_reseed internal_states returned_bits
    | _ => False
  end.

Lemma test0: DRBG_check
               "06032cd5eed33f39265f49ecb142c511da9aff2af71203bffaf34a9ca5bd9c0d"
               "0e66f71edc43e42a45ad3c6fc6cdc4df"
               "17dc11c2389f5eeb9d0f6a5148a1ea83ee8a828f4f140ac78272a0da435fa121"
               "81e0d8830ed2d16f9b288a1cb289c5fab3f3c5c28131be7cafedcc7734604d34"
               ""
               "01920a4e669ed3a85ae8a33b35a74ad7fb2a6bb4cf395ce00334a9c9a5a5d552"
               ""
               "ca43e73325de43c41d7e0a7a3163fb04061b09fcee4c7b8884e969e3bdfdff9a"
               "c246fa97570ba2b9d9e5b453fe4632366f146fbd8491146563eb463c9eafe50c"
               [
                 ("8be4c7f9f249d5af2c6345a8f07af14be1d7adc2b9892286ffe37760d8aa5a1b"%string, "df67d0816d6a8f3b73ba7638ea113bef0e33a1da451272ef1472211fb31c1cd6"%string, ""%string);
                 ("5ed31bc06cc4f3a97f7f34929b0558b0c34de1f4bd1cef456a8364140e2d9f41"%string, "80524881711e89a61e6fe7169581e50fb9ad642f3dff48fba5773352fa04cec3"%string, ""%string)
               ]
               "76fc79fe9b50beccc991a11b5635783a83536add03c157fb30645e611c2898bb2b1bc215000209208cd506cb28da2a51bdb03826aaf2bd2335d576d519160842e7158ad0949d1a9ec3e66ea1b1a064b005de914eac2e9d4f2d72a8616a80225422918250ff66a41bd2f864a6a38cc5b6499dc43f7f2bd09e1e0f8f5885935124".
  vm_compute. repeat (split;auto). Qed.

Lemma test_with_additional_input0: DRBG_check
               "05ac9fc4c62a02e3f90840da5616218c6de5743d66b8e0fbf833759c5928b53d"
               "2b89a17904922ed8f017a63044848545"
               "8d3006bd33b7d8b935a8484b786850f107b731a7efc51521848b875c2214d154"
               "eaa29892ee1e46198ea68c07588ac12641fc901e484eda321c2f26a9ff328e3d"
               ""
               "2791126b8b52ee1fd9392a0a13e0083bed4186dc649b739607ac70ec8dcecf9b"
               "43bac13bae715092cf7eb280a2e10a962faf7233c41412f69bc74a35a584e54c"
               "3138df070c49f48b080004df669f386676b4cb92b40de4d021b2a9e4451e5013"
               "25d3b766cd9f8ad5c45efd7fa01cc08dbce8d0d3792ec2b59bfead7bce39ed01"
               [
                 ("cac850b111de755bb8a5ed1ebc052ed53ab1ff1b9d0fab2946a3728c7e9f43e4"%string, "06624fa590e1d63397b13a0e69081274434f793fdfc1e6298a7373834024da46"%string, "3f2fed4b68d506ecefa21f3f5bb907beb0f17dbc30f6ffbba5e5861408c53a1e"%string);
                 ("b15ae269570790a8c6a81c5be7aef33f645abb161d218761ff8739cb7997eed8"%string, "92971e96fc46608d4343821491990915cdb957ae983ab6cdab84fd094bce1380"%string, "529030df50f410985fde068df82b935ec23d839cb4b269414c0ede6cffea5b68"%string)
               ]
               "02ddff5173da2fcffa10215b030d660d61179e61ecc22609b1151a75f1cbcbb4363c3a89299b4b63aca5e581e73c860491010aa35de3337cc6c09ebec8c91a6287586f3a74d9694b462d2720ea2e11bbd02af33adefb4a16e6b370fa0effd57d607547bdcfbb7831f54de7073ad2a7da987a0016a82fa958779a168674b56524".
  vm_compute. repeat (split;auto). Qed.

Lemma test_with_additional_input_and_personalization0: DRBG_check
               "cdb0d9117cc6dbc9ef9dcb06a97579841d72dc18b2d46a1cb61e314012bdf416"
               "d0c0d01d156016d0eb6b7e9c7c3c8da8"
               "108a7674f3348216c91f5745dd87a919f552fc44373b84ad4b3b843a26b574cb"
               "6c02577c505aed360be7b1cecb61068d8765be1391bacb10f4180d91bd3915db"
               "6f0fb9eab3f9ea7ab0a719bfa879bf0aaed683307fda0c6d73ce018b6e34faaa"
               "8ec6f7d5a8e2e88f43986f70b86e050d07c84b931bcf18e601c5a3eee3064c82"
               "1ab4ca9014fa98a55938316de8ba5a68c629b0741bdd058c4d70c91cda5099b3"
               "e57f901d4bff2909f09467003096edfdb46c89af6bd82e904d11b6753d645c90"
               "21a645aeca821899e7e733a10f64565deee5ced3cd5c0356b66c76dc8a906e69"
               [
                 ("648f92d385c3fbf61526deef48ca5ca4dfe4646d82fe8e73bc1705824e181dc9"%string, "490c0b7786c80f16ad5ee1cc0efd29618968dce14cccebecec8964ea8a41b439"%string, "16e2d0721b58d839a122852abd3bf2c942a31c84d82fca74211871880d7162ff"%string);
                 ("db4853ca51700d43c5b6d63eb6cd20ea2dbe3dff512f2dc9531b5b3d9120121c"%string, "47390036d5cb308cf9592fdfe95bf19b8ed1a3db88ed8c3b2b2d77540dfb5470"%string, "53686f042a7b087d5d2eca0d2a96de131f275ed7151189f7ca52deaa78b79fb2"%string)
               ]
               "dda04a2ca7b8147af1548f5d086591ca4fd951a345ce52b3cd49d47e84aa31a183e31fbc42a1ff1d95afec7143c8008c97bc2a9c091df0a763848391f68cb4a366ad89857ac725a53b303ddea767be8dc5f605b1b95f6d24c9f06be65a973a089320b3cc42569dcfd4b92b62a993785b0301b3fc452445656fce22664827b88f".
  vm_compute. repeat (split;auto). Qed.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj17eqsynthconj5 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus lv0 (plus lv1 (mult lv2 lv1))) (plus (mult lv1 (Succ lv2)) lv0)).
Admitted.
QuickChick conj17eqsynthconj5.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj18synthconj3 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural) (lv3 : natural), (@eq natural (Succ (plus lv0 (plus lv1 lv2))) (plus lv3 (plus lv1 (Succ Zero)))).
Admitted.
QuickChick conj18synthconj3.


From Hammer Require Import Hammer.

Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Theory.Isomorphism.
Require Export Category.Theory.Naturality.
Require Export Category.Theory.Natural.Transformation.
Require Export Category.Instance.Sets.

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

Section Adjunction.

Context {C : Category}.
Context {D : Category}.
Context {F : D ⟶ C}.
Context {U : C ⟶ D}.

Reserved Notation "⌊ f ⌋".
Reserved Notation "⌈ f ⌉".

Class Adjunction := {
adj {x y} : F x ~{C}~> y ≊ x ~{D}~> U y
where "⌊ f ⌋" := (to   adj f)
and "⌈ f ⌉" := (from adj f);

to_adj_nat_l {x y z} (f : F y ~> z) (g : x ~> y) :
⌊f ∘ fmap[F] g⌋ ≈ ⌊f⌋ ∘ g;
to_adj_nat_r {x y z} (f : y ~> z) (g : F x ~> y) :
⌊f ∘ g⌋ ≈ fmap[U] f ∘ ⌊g⌋;

from_adj_nat_l {x y z} (f : y ~> U z) (g : x ~> y) :
⌈f ∘ g⌉ ≈ ⌈f⌉ ∘ fmap[F] g;
from_adj_nat_r {x y z} (f : y ~> z) (g : x ~> U y) :
⌈fmap[U] f ∘ g⌉ ≈ f ∘ ⌈g⌉
}.

Context `{@Adjunction}.

Notation "⌊ f ⌋" := (to adj f).
Notation "⌈ f ⌉" := (from adj f).

Corollary adj_univ `(f : F x ~> y) (g : x ~> U y) :
f ≈ ⌈g⌉ ↔ ⌊f⌋ ≈ g.
Proof. hammer_hook "Adjunction" "Adjunction.adj_univ".
split; intros.
rewrite X.
sapply (@iso_to_from Sets _ _ (@adj _ x y)).
rewrite <- X.
symmetry.
sapply (@iso_from_to Sets _ _ (@adj _ x y)).
Qed.

Corollary to_adj_comp_law {x y} (f : F x ~> y) :
⌈⌊f⌋⌉ ≈ f.
Proof. hammer_hook "Adjunction" "Adjunction.to_adj_comp_law". sapply (@iso_from_to Sets _ _ (@adj _ x y) f). Qed.

Corollary from_adj_comp_law {x y} (f : x ~> U y) :
⌊⌈f⌉⌋ ≈ f.
Proof. hammer_hook "Adjunction" "Adjunction.from_adj_comp_law". sapply (@iso_to_from Sets _ _ (@adj _ x y) f). Qed.

Definition unit   {x : D} : x ~> U (F x) := ⌊id⌋.
Definition counit {x : C} : F (U x) ~> x := ⌈id⌉.

Notation "'η'" := unit.
Notation "'ε'" := counit.

Corollary from_adj_unit {x} :
⌈η⌉ ≈ id[F x].
Proof. hammer_hook "Adjunction" "Adjunction.from_adj_unit". sapply (@iso_from_to Sets _ _ (@adj _ x (F x))). Qed.

Corollary to_adj_counit {x} :
⌊ε⌋ ≈ id[U x].
Proof. hammer_hook "Adjunction" "Adjunction.to_adj_counit". sapply (@iso_to_from Sets _ _ (@adj _ (U x) x)). Qed.

Corollary counit_comp {x y} (f : F x ~> y) :
ε ∘ fmap[F] (fmap[U] f) ≈ f ∘ ε.
Proof. hammer_hook "Adjunction" "Adjunction.counit_comp".
unfold counit.
rewrite <- from_adj_nat_l.
rewrite <- from_adj_nat_r.
rewrite id_left, id_right.
reflexivity.
Qed.

Corollary unit_comp {x y} (f : x ~> U y) :
fmap[U] (fmap[F] f) ∘ η ≈ η ∘ f.
Proof. hammer_hook "Adjunction" "Adjunction.unit_comp".
unfold unit.
rewrite <- to_adj_nat_l.
rewrite <- to_adj_nat_r.
rewrite id_left, id_right.
reflexivity.
Qed.

Corollary adj_univ_impl {x y} (f : F x ~> y) (g : x ~> U y) :
f ≈ ε ∘ fmap[F] g ↔ ⌊f⌋ ≈ g.
Proof. hammer_hook "Adjunction" "Adjunction.adj_univ_impl".
unfold counit.
split; intros.
rewrite X; clear X.
rewrite <- from_adj_nat_l.
rewrite id_left.
apply from_adj_comp_law.
rewrite <- X; clear X.
rewrite <- from_adj_nat_l.
rewrite id_left.
symmetry.
apply to_adj_comp_law.
Qed.

Corollary to_adj_unit {x y} (f : F x ~> y) :
⌊f⌋ ≈ fmap[U] f ∘ η.
Proof. hammer_hook "Adjunction" "Adjunction.to_adj_unit".
rewrite <- (id_right f).
rewrite to_adj_nat_r.
rewrite fmap_comp; cat.
Qed.

Corollary from_adj_counit {x y} (f : x ~> U y) :
⌈f⌉ ≈ ε ∘ fmap[F] f.
Proof. hammer_hook "Adjunction" "Adjunction.from_adj_counit".
rewrite <- (id_left f).
rewrite from_adj_nat_l.
rewrite fmap_comp; cat.
Qed.

Corollary counit_fmap_unit  {x} :
ε ∘ fmap[F] η ≈ id[F x].
Proof. hammer_hook "Adjunction" "Adjunction.counit_fmap_unit".
unfold unit, counit.
rewrite <- from_adj_nat_l; cat.
sapply (@iso_from_to Sets _ _ (@adj _ x (F x))).
Qed.

Corollary fmap_counit_unit  {x} :
fmap[U] ε ∘ η ≈ id[U x].
Proof. hammer_hook "Adjunction" "Adjunction.fmap_counit_unit".
unfold unit, counit.
rewrite <- to_adj_nat_r; cat.
sapply (@iso_to_from Sets _ _ (@adj _ (U x) x)).
Qed.

Corollary fmap_from_adj_unit {x y} (f : x ~{D}~> y) : fmap[F] f ≈ ⌈η ∘ f⌉.
Proof. hammer_hook "Adjunction" "Adjunction.fmap_from_adj_unit".
unfold unit.
rewrite from_adj_nat_l.
rewrite to_adj_comp_law; cat.
Qed.

Corollary fmap_to_adj_counit {x y} (f : x ~{C}~> y) : fmap[U] f ≈ ⌊f ∘ ε⌋.
Proof. hammer_hook "Adjunction" "Adjunction.fmap_to_adj_counit".
unfold counit.
rewrite to_adj_nat_r.
rewrite from_adj_comp_law; cat.
Qed.

Theorem adj_monic  {x y} (f : F x ~> y) c (g h : c ~> x) :
Faithful F -> Monic f ->
⌊f⌋ ∘ g ≈ ⌊f⌋ ∘ h -> g ≈ h.
Proof. hammer_hook "Adjunction" "Adjunction.adj_monic".
intros.
rewrite <- !to_adj_nat_l in X1.
pose proof (monic (Monic:=@iso_to_monic Sets _ _ (@adj H c y))
{| carrier   := Datatypes.unit
; is_setoid := {| equiv := eq |} |}
{| morphism  := fun _ => f ∘ fmap[F] g |}
{| morphism  := fun _ => f ∘ fmap[F] h |}) as X2;
simpl in X2.
apply X.
apply X0.
apply X2; intros.
exact X1.
exact tt.
Qed.

Corollary to_adj_respects {x y} (f g : F x ~{C}~> y) :
f ≈ g -> ⌊f⌋ ≈ ⌊g⌋.
Proof. hammer_hook "Adjunction" "Adjunction.to_adj_respects". intros; now rewrites. Qed.

Corollary from_adj_respects {x y} (f g : x ~{D}~> U y) :
f ≈ g -> ⌈f⌉ ≈ ⌈g⌉.
Proof. hammer_hook "Adjunction" "Adjunction.from_adj_respects". intros; now rewrites. Qed.

End Adjunction.

Arguments Adjunction {C D} F%functor U%functor.

Bind Scope adjunction_scope with Adjunction.
Delimit Scope adjunction_type_scope with adjunction_type.
Delimit Scope adjunction_scope with adjunction.
Open Scope adjunction_type_scope.
Open Scope adjunction_scope.

Notation "F ⊣ G" := (@Adjunction _ _ F G) (at level 59) : category_scope.
Notation "adj[ A ]" := (@adj _ _ _ _ A _ _)
(at level 9, format "adj[ A ]") : morphism_scope.


Require Import Crypto.Compilers.Syntax.
Require Import Crypto.Compilers.Wf.
Require Import Crypto.Compilers.InlineConstAndOpByRewriteWf.
Require Import Crypto.Compilers.Z.Syntax.
Require Import Crypto.Compilers.Z.InlineConstAndOpByRewrite.

Module Export Rewrite.
  Definition Wf_InlineConstAndOp {t} (e : Expr t) (Hwf : Wf e)
  : Wf (InlineConstAndOp e)
    := @Wf_InlineConstAndOp _ _ _ _ _ t e Hwf.

  Hint Resolve Wf_InlineConstAndOp : wf.
End Rewrite.


Require Import Coq.Lists.List.

From Equations Require Import Equations.
Set Equations With UIP.

Require Import Category.Lib.
Require Import Category.Theory.Category.
Require Import Category.Solver.Expr.
Require Import Category.Solver.Denote.
Require Import Category.Solver.Reify.

Section Normal.

Context `{Arrows}.

Inductive Morphism : Set :=
  | Identity
  | Morphisms (c : Composition)

with Composition : Set :=
  | Single   (f : Arrow)
  | Composed (f : Arrow) (fs : Composition)

with Arrow : Set :=
  | Arr (n : nat).

Ltac breakit :=
  lazymatch goal with
  | [ H : Morphism    |- _ ] => destruct H
  | [ H : Composition |- _ ] => destruct H
  | [ H : Arrow       |- _ ] => destruct H
  end.

Ltac substituted :=
  match goal with
  | [ n : nat, H : ∀ _ _ : nat, _ |- _ ] =>
    specialize (H n n); intuition
  | [ f : Morphism, g : Morphism, H : ∀ _ _ _ _ : Morphism, _ |- _ ] =>
    specialize (H f g f g); intuition
  | [ f : Arrow, g : Composition,
      H : ∀ (_ : Arrow) (_ : Composition)
            (_ : Arrow) (_ : Composition), _ |- _ ] =>
    specialize (H f g f g); intuition
  | [ f : Arrow, H : ∀ _ _ : Arrow, _ |- _ ] =>
    specialize (H f f); intuition
  | [ f : Composition, H : ∀ _ _ : Composition, _ |- _ ] =>
    specialize (H f f); intuition
  end.

Ltac solveit :=
  solve [ intros; subst; breakit; intuition; substituted
        | split; intros; breakit; intuition; discriminate ].

Program Fixpoint morphism_eq_dec (f g : Morphism) : {f = g} + {f ≠ g} :=
  match f, g with
  | Identity, Identity => left eq_refl
  | Morphisms fs, Morphisms gs =>
    match composition_eq_dec fs gs with
    | left  _ => in_left
    | right _ => in_right
    end
  | _, _ => right _
  end

with composition_eq_dec (f g : Composition) : {f = g} + {f ≠ g} :=
  match f, g with
  | Single f, Single g =>
    match arrow_eq_dec f g with
    | left  _ => in_left
    | right _ => in_right
    end
  | Composed f fs, Composed g gs =>
    match arrow_eq_dec f g with
    | left  _ =>
      match composition_eq_dec fs gs with
      | left  _ => in_left
      | right _ => in_right
      end
    | right _ => in_right
    end
  | _, _ => in_right
  end

with arrow_eq_dec (f g : Arrow) : {f = g} + {f ≠ g} :=
  match f, g with
  | Arr f, Arr g =>
    match PeanoNat.Nat.eq_dec f g with
    | left  _ => in_left
    | right _ => in_right
    end
  end.
Next Obligation. solveit. Defined.
Next Obligation. solveit. Defined.
Next Obligation. solveit. Defined.
Next Obligation. solveit. Defined.
Next Obligation. solveit. Defined.
Next Obligation. solveit. Defined.

#[export]
Program Instance Morphism_EqDec : EqDec Morphism := {
  eq_dec := morphism_eq_dec
}.

#[export]
Program Instance Composition_EqDec : EqDec Composition := {
  eq_dec := composition_eq_dec
}.

#[export]
Program Instance Arrow_EqDec : EqDec Arrow := {
  eq_dec := arrow_eq_dec
}.

Fixpoint append (f g : Composition) : Composition :=
  match f, g with
  | Single f, gs      => Composed f gs
  | Composed f fs, gs => Composed f (append fs gs)
  end.

Lemma append_assoc {f g h} :
  append f (append g h) = append (append f g) h.
Proof.
  induction f; simpl; auto.
  now rewrite IHf.
Qed.

Definition combine (f g : Morphism) : Morphism :=
  match f, g with
  | Identity, g => g
  | f, Identity => f
  | Morphisms fs, Morphisms gs => Morphisms (append fs gs)
  end.

Fixpoint to_morphism (t : Term) : Morphism :=
  match t with
  | Ident    => Identity
  | Morph a  => Morphisms (Single (Arr a))
  | Comp f g => combine (to_morphism f) (to_morphism g)
  end.

Coercion to_morphism : Term >-> Morphism.

Definition from_arrow (a : Arrow) : Term :=
  match a with
  | Arr f => Morph f
  end.

Fixpoint from_composition (fs : Composition) : Term :=
  match fs with
  | Single f => from_arrow f
  | Composed f gs => Comp (from_arrow f) (from_composition gs)
  end.

Definition from_morphism (f : Morphism) : Term :=
  match f with
  | Identity => Ident
  | Morphisms fs => from_composition fs
  end.

Ltac matches :=
  match goal with
  | [ H : context[match lookup_arr ?f ?dom with _ => _ end] |- _ ] =>
    destruct (lookup_arr f dom) as [[? ?]|] eqn:?
  | [ H : context[match @termD_work ?c ?h ?n ?s with _ => _ end] |- _ ] =>
    destruct (@termD_work c h n s) as [[? ?]|] eqn:?
  | [ H : context[match Classes.eq_dec ?n ?m with _ => _ end] |- _ ] =>
    destruct (eq_dec n m); subst
  end;
  try contradiction;
  try discriminate;
  let n := numgoals in guard n < 2.

Ltac desh :=
  repeat matches;
  simpl_eq;
  try rewrite peq_dec_refl in *;
  repeat lazymatch goal with
  | [ H : Some _ = Some _ |- _ ] =>
    inversion H; subst; try clear H
  | [ H : (?X; _) = (?X; _) |- _ ] =>
    apply Eqdep_dec.inj_pair2_eq_dec in H;
      [|now apply eq_dec]; subst
  | [ H : ∃ _, _ |- _ ] =>
    let x := fresh "x" in
    let e := fresh "e" in destruct H as [x e]
  | [ H : _ ∧ _ |- _ ] =>
    let x := fresh "x" in
    let e := fresh "e" in destruct H as [x e]
  end; auto; try solve [ cat ].

Lemma from_morphism_app {d c} {t1 t2 : Morphism} {f} :
  termD_work d (from_morphism (combine t1 t2)) = Some (c; f)
    → ∃ m g h, f ≈ g ∘ h
        ∧ termD_work m (from_morphism t1) = Some (c; g)
        ∧ termD_work d (from_morphism t2) = Some (m; h).
Proof.
  generalize dependent c.
  generalize dependent d.
  generalize dependent t2.
  unfold termD; destruct t1; simpl; intros.
  - eexists _, _, f.
    now split; cat.
  - generalize dependent c0.
    induction c; simpl; intros.
    + destruct t2; simpl in *.
      * exists d, f0, id.
        split; cat.
      * desh.
        exists _, h0, h.
        split; cat.
    + destruct t2; simpl in *; desh.
      * specialize (IHc _ _ eq_refl); desh.
        exists _, (h0 ∘ h), id.
        split; cat.
        now rewrite Heqo, Heqo0.
      * specialize (IHc _ _ eq_refl); desh.
        rewrite e.
        exists x0, (h0 ∘ x1), x2.
        rewrite x4, Heqo0.
        split; cat.
        rewrite x3; cat.
Qed.

Theorem from_morphism_to_morphism {d c} {t : Term} {f} :
  termD d c (from_morphism (to_morphism t)) = Some f
    → termD d c t ≈ Some f.
Proof.
  generalize dependent c.
  generalize dependent d.
  unfold termD; induction t; simpl; intros; desh.
  - pose proof (from_morphism_app Heqo); desh.
    specialize (IHt2 _ _ x1).
    rewrite e in IHt2; clear e.
    specialize (IHt1 _ _ x0).
    rewrite x3 in IHt1; clear x3.
    rewrite EqDec.peq_dec_refl in IHt1, IHt2.
    specialize (IHt1 eq_refl).
    specialize (IHt2 eq_refl).
    simpl in *; desh.
    rewrite Heqo1, EqDec.peq_dec_refl.
    now rewrite IHt1, IHt2, <- x2.
Qed.

Lemma from_morphism_app_r {d m c} {t1 t2 : Morphism} {g h} :
    termD_work m (from_morphism t1) = Some (c; g)
  → termD_work d (from_morphism t2) = Some (m; h)
  → ∃ f, f ≈ g ∘ h ∧
          termD_work d (from_morphism (combine t1 t2)) = Some (c; f).
Proof.
  generalize dependent c.
  generalize dependent d.
  generalize dependent t2.
  unfold termD; destruct t1; simpl; intros; desh.
  generalize dependent c0.
  induction c; simpl; intros; desh.
  - destruct t2; simpl in *; desh.
    exists (g ∘ h).
    split; cat.
    now rewrite H1, H0.
  - destruct t2; simpl in *; desh.
    + specialize (IHc _ _ eq_refl); desh.
      exists (h1 ∘ x0).
      split.
      * now rewrite x1; cat.
      * now rewrite e0, Heqo0.
    + specialize (IHc _ _ eq_refl); desh.
      exists (h1 ∘ x0).
      split.
      * now rewrite x1; cat.
      * now rewrite e0, Heqo0.
Qed.

Theorem from_morphism_to_morphism_r {d c} {t : Term} {f} :
  termD d c t = Some f
    → termD d c (from_morphism (to_morphism t)) ≈ Some f.
Proof.
  generalize dependent c.
  generalize dependent d.
  unfold termD; induction t; simpl; intros; desh.
  - specialize (IHt2 _ _ h).
    rewrite Heqo in IHt2; clear Heqo.
    specialize (IHt1 _ _ h0).
    rewrite Heqo0 in IHt1; clear Heqo0.
    rewrite EqDec.peq_dec_refl in IHt1, IHt2.
    specialize (IHt1 eq_refl).
    specialize (IHt2 eq_refl).
    simpl in *; desh.
    pose proof (from_morphism_app_r Heqo0 Heqo); desh.
    rewrite e0, EqDec.peq_dec_refl.
    now rewrite x1, IHt1, IHt2.
Qed.

(* Normalization gives us a way to define the category of reifed terms. *)

#[local]
Program Instance Terms : Category := {
  obj        := Obj;
  hom        := λ _ _, Term;
  homset     := λ _ _,
    {| equiv f g := to_morphism f = to_morphism g |};
  id         := λ _, Ident;
  compose    := λ _ _ _, Comp;
}.
Next Obligation.
  unfold combine.
  induction (to_morphism f); auto.
Qed.
Next Obligation.
  unfold combine.
  induction (to_morphism g); auto.
  - induction (to_morphism f); auto.
  - induction (to_morphism f); auto.
    induction (to_morphism h); auto.
    now rewrite append_assoc.
Qed.
Next Obligation.
  symmetry.
  unshelve eapply Terms_obligation_5; eauto.
Qed.

Fixpoint exprAD (e : Expr) : Type :=
  match e with
  | Top    => True
  | Bottom => False
  | Equiv d c f g =>
    match termD d c (from_morphism (to_morphism f)),
          termD d c (from_morphism (to_morphism g)) with
    | Some f, Some g => f ≈ g
    | _, _ => False
    end
  | And p q  => exprAD p ∧ exprAD q
  | Or p q   => exprAD p + exprAD q
  | Impl p q => exprAD p → exprAD q
  end.

Theorem exprAD_sound (e : Expr) : exprAD e ↔ exprD e.
Proof.
  induction e; split; simpl in *; intuition.
  - destruct (termD _ _ _) eqn:?; [|tauto].
    destruct (termD _ _ (_ (_ g))) eqn:?; [|tauto].
    apply from_morphism_to_morphism in Heqo.
    apply from_morphism_to_morphism in Heqo0.
    simpl in *.
    destruct (termD _ _ f); [|tauto].
    destruct (termD _ _ g); [|tauto].
    now rewrite Heqo, Heqo0, <- X.
  - desh.
    destruct (termD _ _ f) eqn:?; [|tauto].
    destruct (termD _ _ g) eqn:?; [|tauto].
    apply from_morphism_to_morphism_r in Heqo.
    apply from_morphism_to_morphism_r in Heqo0.
    simpl in *.
    destruct (termD _ _ _) eqn:?; [|tauto].
    destruct (termD _ _ (_ (_ g))) eqn:?; [|tauto].
    now rewrite Heqo, Heqo0, X.
Qed.

Fixpoint exprSD (e : Expr) : Type :=
  match e with
  | Top           => True
  | Bottom        => False
  | Equiv d c f g => (f : d ~> c) ≈ g
  | And p q       => exprSD p ∧ exprSD q
  | Or p q        => exprSD p + exprSD q
  | Impl p q      => exprSD p → exprSD q
  end.

Theorem exprSD_enough {d c f g h} :
  termD d c f = Some h →
  exprSD (Equiv d c f g) → exprAD (Equiv d c f g).
Proof.
  simpl; intros.
  rewrite H1.
  apply from_morphism_to_morphism_r in H0.
  rewrite H1 in H0.
  destruct (termD _ _ _) eqn:?.
  + reflexivity.
  + tauto.
Qed.

End Normal.

(* * This is a much easier theorem to apply, so it speeds things up a lot! *)
Corollary exprAD_sound' {cat} (env : Arrows cat) (e : Expr) :
  exprAD e → exprD e.
Proof. apply exprAD_sound. Qed.

Ltac normalize :=
  reify_and_change;
  simple apply exprAD_sound';
  vm_compute.

Ltac structure :=
  reify_and_change;
  simple apply exprAD_sound';
  simple eapply exprSD_enough;
    [now vm_compute|];
  clear.

Example ex_normalize
  (C : Category) (x y z w : C)
  (f : z ~> w) (g : y ~> z) (h : x ~> y) (i : x ~> z) :
  g ∘ id ∘ id ∘ id ∘ h ≈ i ->
  g ∘ id ∘ id ∘ id ∘ h ≈ g ∘ h ->
  g ∘ id ∘ id ∘ id ∘ h ≈ g ∘ h ->
  g ∘ id ∘ id ∘ id ∘ h ≈ g ∘ h ->
  g ∘ id ∘ id ∘ id ∘ h ≈ g ∘ h ->
  g ∘ id ∘ id ∘ id ∘ h ≈ g ∘ h ->
  g ∘ id ∘ id ∘ id ∘ h ≈ g ∘ h ->
  g ∘ id ∘ id ∘ id ∘ h ≈ g ∘ h ->
  g ∘ h ≈ i ->
  f ∘ (id ∘ g ∘ h) ≈ (f ∘ g) ∘ h.
Proof.
  intros.
  (* Set Ltac Profiling. *)
  normalize.
  clear.
(*
  reify_and_change.
  clear.                        (* no effect *)
*)
(*
  structure.                    (* only works on Coq 8.16 *)
*)
  reflexivity.
  (* Show Ltac Profile. *)
Qed.


(*  DEC 2.0 language specification.
   Paolo Torrini,
   Universite' de Lille - CRIStAL-CNRS
*)

Require Import List.
Require Import Equality.

Require Import AuxLibI1.
Require Import TypSpecI1.
Require Import ModTypI1.
Require Import LangSpecI1.
Require Import StaticSemI1.

Import ListNotations.

(** * DEC 2.0 language specification *)

(** Dynamic small-step semantics *)

Module DynamicSem (IdT: ModTyp) <: ModTyp.

Module StaticSemL := StaticSem IdT.
Export StaticSemL.

Definition Id := IdT.Id.
Definition IdEqDec := IdT.IdEqDec.
Definition IdEq := IdT.IdEq.
Definition W := IdT.W.
Definition BInit := IdT.BInit.
Definition WP := IdT.WP.

(*********************************************************************)

(** * Dynamic semantics *)

(** Configurations *)

Inductive AConfig (T: Type) : Type := Conf (state: W) (fuel: nat) (qq: T).

Definition confState {T: Type} (a: AConfig T) : W :=
  match a with | Conf _ s _ _ => s end.

Definition confFuel {T: Type} (a: AConfig T) : nat :=
  match a with | Conf _ _ n _ => n end.

Definition confProg {T: Type} (a: AConfig T) : T :=
  match a with | Conf _ _ _ x => x end.

Fixpoint sValueList (ls: list Value) : tlist2type (map valueSTyp ls) :=
  match ls with
    | nil => tt
    | v:: vs => (sValue v, sValueList vs)
  end.

Lemma sValueListRel
         (ftenv: funTC) (tenv: valTC) (vs: list Value) (pt: PTyp) :
  PrmsTyping ftenv tenv (PS (map Val vs)) pt -> sPTyp pt.
  revert pt.
  unfold sPTyp.
  induction vs.
  intros.
  inversion X; subst.
  simpl.
  exact tt.
  intros.
  inversion X; subst.
  inversion X0; subst.
  specialize (IHvs (PT ts) X1).
  simpl in *.
  split.
  destruct a.
  simpl.
  destruct v.
  inversion H2; subst.
  simpl in *.
  exact v.
  exact IHvs.
Defined.

(** Program term computation *)

Inductive EStep : (** - Expressions *)
            funEnv -> valEnv -> AConfig Exp -> AConfig Exp -> Type :=
(** - variable lifting *)
| Var_EStep : forall (fenv: funEnv) (env: valEnv)
                     (s: W) (n: nat) (x: Id) (v: Value),
    findE env x = Some v ->
    EStep fenv env (Conf Exp s n (Var x))
                        (Conf Exp s n (Val v))
(** - sequencing *)
| BindN_EStep : forall (fenv: funEnv) (env: valEnv)
                       (s: W) (n: nat) (v: Value) (e: Exp),
    EStep fenv env (Conf Exp s n (BindN (Val v) e)) (Conf Exp s n e)
| BindN_Cg_EStep : forall (fenv: funEnv) (env: valEnv)
                          (s s': W) (n n': nat) (e1 e1' e2: Exp),
    EStep fenv env (Conf Exp s n e1) (Conf Exp s' n' e1') ->
    EStep fenv env (Conf Exp s n (BindN e1 e2))
                   (Conf Exp s' n' (BindN e1' e2))
(** - let-style binding *)
| BindS_EStep : forall (fenv: funEnv) (env: valEnv)
                       (s: W) (n: nat) (x: Id) (v: Value) (e: Exp)
                       (mt: option VTyp),
    EStep fenv env (Conf Exp s n (BindS x mt (Val v) e))
                   (Conf Exp s n (BindMS (singleE x v) e))
| BindS_Cg_EStep : forall (fenv: funEnv) (env: valEnv)
                          (s s': W) (n n': nat) (x: Id) (e1 e1' e2: Exp)
                          (m: option VTyp),
    EStep fenv env (Conf Exp s n e1) (Conf Exp s' n' e1') ->
    EStep fenv env (Conf Exp s n (BindS x m e1 e2))
                   (Conf Exp s' n' (BindS x m e1' e2))
(** - local environments *)
| BindMS_EStep : forall (fenv: funEnv) (env env': valEnv)
                        (s: W) (n: nat) (v: Value),
    EStep fenv env (Conf Exp s n (BindMS env' (Val v)))
                   (Conf Exp s n (Val v))
| BindMS_Cg_EStep : forall (fenv: funEnv) (env envL env': valEnv)
                           (s s': W) (n n': nat) (e e': Exp),
    env' = envL ++ env ->
    EStep fenv env' (Conf Exp s n e) (Conf Exp s' n' e') ->
    EStep fenv env (Conf Exp s n (BindMS envL e))
                   (Conf Exp s' n' (BindMS envL e'))
(** - conditional *)
| IfThenElse_EStep1 : forall (fenv: funEnv) (env: valEnv)
                             (s: W) (n: nat) (e1 e2: Exp),
    EStep fenv env (Conf Exp s n
                   (IfThenElse (Val (cst Bool true)) e1 e2))
                        (Conf Exp s n e1)
| IfThenElse_EStep2 : forall (fenv: funEnv) (env: valEnv)
                             (s: W) (n: nat) (e1 e2: Exp),
     EStep fenv env (Conf Exp s n
                (IfThenElse (Val (cst Bool false)) e1 e2))
                         (Conf Exp s n e2)
| IfThenElse_Cg_EStep :  forall (fenv: funEnv) (env: valEnv)
                                (s s': W) (n n': nat)
                                (e e' e1 e2: Exp),
     EStep fenv env (Conf Exp s n e) (Conf Exp s' n' e') ->
     EStep fenv env (Conf Exp s n (IfThenElse e e1 e2))
                    (Conf Exp s' n' (IfThenElse e' e1 e2))
(* function application - note: no side-effects in the
   fuel congruence rule *)
| Apply_Cg1_EStep : forall (fenv: funEnv) (env: valEnv)
                           (s s': W) (n n': nat) (x: Id) (ps: Prms)
                           (e e': Exp),
     EStep fenv env (Conf Exp s n e) (Conf Exp s' n' e') ->
     EStep fenv env (Conf Exp s n (Apply x ps e))
                    (Conf Exp s' n' (Apply x ps e'))
| Apply_Cg2_EStep : forall (fenv: funEnv) (env: valEnv)
                           (s s': W) (n n': nat) (x: Id) (ps ps': Prms)
                           (v: Value),
     PStep fenv env (Conf Prms s n ps) (Conf Prms s' n' ps') ->
     EStep fenv env (Conf Exp s n (Apply x ps (Val v)))
                    (Conf Exp s' n' (Apply x ps' (Val v)))
| Apply_EStep : forall (fenv: funEnv) (env: valEnv)
                       (s: W)  (n0 n1 n: nat) (x: Id)
                       (es: list Exp) (v: Value)
                       (f: Fun),
     v = cst Nat n1 ->
     isValueListT es ->
     n = min n0 n1 ->
     EStep fenv env (Conf Exp s n0 (Apply x (PS es) (Val v)))
                    (Conf Exp s n (Call x (PS es)))
(* function call *)
| Call_Cg_EStep : forall (fenv: funEnv) (env: valEnv)
                         (s s': W) (n n': nat) (x: Id) (ps ps': Prms),
     PStep fenv env (Conf Prms s n ps) (Conf Prms s' n' ps') ->
     EStep fenv env (Conf Exp s n (Call x ps))
                    (Conf Exp s' n' (Call x ps'))
| Call_EStep0 : forall (fenv: funEnv) (env env': valEnv)
                       (s: W) (x: Id)
                       (es: list Exp)
                       (vs: list Value)
                       (f: Fun) (v: Value),
     findE fenv x = Some f ->
     isValueList2T es vs ->
     funArity f = length vs ->
     env' = mkVEnv (funValTC f) vs ->
     v = fun0Exp f ->
     EStep fenv env (Conf Exp s 0 (Call x (PS es)))
                    (Conf Exp s 0 (Val v))
| Call_EStepS : forall (fenv: funEnv) (env env': valEnv)
                       (s: W) (n: nat) (x: Id)
                       (es: list Exp)
                       (vs: list Value)
                       (f: Fun) (e: Exp),
     isValueList2T es vs ->
     findE fenv x = Some f ->
     funArity f = length vs ->
     env' = mkVEnv (funValTC f) vs ->
     e = funSExp f ->
     EStep fenv env (Conf Exp s (S n) (Call x (PS es)))
                         (Conf Exp s n (BindMS env' e))
(** - modify *)
| Modify_EStep : forall (fenv: funEnv) (env: valEnv) (s: W) (n: nat)
                        (t1 t2: VTyp)
                        (XF: XFun t1 t2)
                        (w: sVTyp t1),
      EStep fenv env
         (Conf Exp s n (Modify t1 t2 XF (Val (cst t1 w))))
         (Conf Exp (x_exec t1 t2 XF w s) n
                   (Val (cst t2 (x_eval t1 t2 XF w s))))
| Modify_Cg_EStep : forall (fenv: funEnv) (env: valEnv) (s s': W) (n n': nat)
                           (t1 t2: VTyp)
                           (XF: XFun t1 t2) (e e': Exp),
    EStep fenv env (Conf Exp s n e) (Conf Exp s' n' e') ->
    EStep fenv env (Conf Exp s n (Modify t1 t2 XF e))
                        (Conf Exp s' n' (Modify t1 t2 XF e'))
with PStep : (** - Parameters *)
       funEnv -> valEnv -> AConfig Prms -> AConfig Prms -> Type :=
| Prms_Cg_Step : forall (fenv: funEnv) (env: valEnv)
                        (s s': W) (n n': nat)
                        (es es': list Exp) (v: Value),
         PStep fenv env (Conf Prms s n (PS es))
                        (Conf Prms s' n' (PS es')) ->
         PStep fenv env (Conf Prms s n (PS (Val v :: es)))
                        (Conf Prms s' n' (PS (Val v :: es')))
| Prms_Step1 : forall (fenv: funEnv) (env: valEnv)
                      (s s': W) (n n': nat) (es: list Exp) (e e': Exp),
         EStep fenv env (Conf Exp s n e) (Conf Exp s' n' e') ->
         PStep fenv env (Conf Prms s n (PS (e::es)))
                        (Conf Prms s' n' (PS (e'::es))).

Scheme EStep_mut := Induction for EStep Sort Type
with PStep_mut := Induction for PStep Sort Type.

(*****************************************************************)

(** reflexive-transitive closures *)

Inductive EClosure :
     funEnv -> valEnv -> AConfig Exp -> AConfig Exp -> Type :=
  | EC_Base : forall (fenv: funEnv) (env: valEnv) (p: AConfig Exp),
              EClosure fenv env p p
  | EC_Step : forall (fenv: funEnv) (env: valEnv) (p1 p2 p3: AConfig Exp),
           EStep fenv env p1 p2 ->
           EClosure fenv env p2 p3 -> EClosure fenv env p1 p3.

Inductive PClosure :
     funEnv -> valEnv -> AConfig Prms -> AConfig Prms -> Type :=
  | PrmsC_Base : forall (fenv: funEnv) (env: valEnv) (p: AConfig Prms),
              PClosure fenv env p p
  | PrmsC_Step : forall (fenv: funEnv) (env: valEnv)
                        (p1 p2 p3: AConfig Prms),
                   PStep fenv env p1 p2 ->
                   PClosure fenv env p2 p3 ->
                   PClosure fenv env p1 p3.

(******************************************************************)

(** a small step is a big step *)

Lemma StepIsEClos :
         forall (fenv: funEnv) (env: valEnv) (p1 p2: AConfig Exp),
               EStep fenv env p1 p2 -> EClosure fenv env p1 p2.
Proof.
intros.
eapply EC_Step.
eassumption.
constructor.
Defined.

Lemma StepIsPClos :
     forall (fenv: funEnv) (env: valEnv) (p1 p2: AConfig Prms),
       PStep fenv env p1 p2 -> PClosure fenv env p1 p2.
Proof.
  intros.
  eapply PrmsC_Step.
  eassumption.
  constructor.
Defined.

(**************************************************************)

(** appending two big steps gives one big step *)

Lemma EClosConcat :
    forall (fenv: funEnv) (env: valEnv)
           (p1 p2 p3: AConfig Exp),
   EClosure fenv env p1 p2 -> EClosure fenv env p2 p3 ->
                                   EClosure fenv env p1 p3.
Proof.
  intros.
  induction X.
  assumption.
  apply IHX in X0.
  econstructor.
  eassumption.
  assumption.
Defined.

Lemma PConcat :
  forall (fenv: funEnv) (env: valEnv)
         (p1 p2 p3: AConfig Prms),
   PClosure fenv env p1 p2 -> PClosure fenv env p2 p3 ->
                              PClosure fenv env p1 p3.
Proof.
  intros.
  induction X.
  assumption.
  apply IHX in X0.
  econstructor.
  eassumption.
  assumption.
Defined.

End DynamicSem.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrbool ssrfun eqtype fintype bigop finset.
Require Import fingroup morphism automorphism quotient gproduct.

(* DOCUMENTATION TO DO !!! *)

Import GroupScope.

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

Section IdentitySubFunctorDefs.

Implicit Types gT hT : finGroupType.

(* An object mapping on sets *)

Definition obmap : Type := forall gT, {set gT} -> {set gT}.

Identity Coercion fun_of_obmap : obmap >-> Funclass.

(* General functoriality, a.k.a continuity of the object mapping *)

Definition cont (F : obmap) : Prop :=
  forall gT hT (G : {group gT}) (phi : {morphism G >-> hT}),
    phi @* (F _ G) \subset F _ (phi @* G).

(* Functoriality on grp whose arrows are restricted to isomorphisms *)

Definition acont (F : obmap) : Prop :=
  forall gT hT (G : {group gT}) (phi : {morphism G >-> hT}),
   'injm phi -> phi @* (F _ G) \subset F _ (phi @* G).

Lemma acont_of_cont : forall F, cont F -> acont F.
Proof. by move=> F H gT hT G phi Ha; apply:H. Qed.

(* Hereditary w.r.t. inclusion *)

Definition hereditary (F : obmap) : Prop :=
  forall gT (H G : {group gT}), H \subset G -> (F _ G) :&: H \subset (F _ H).

(* Modulo Application *)

Definition appmod (F1 F2 : obmap) :=
  fun gT G => coset (F2 gT G) @*^-1 (F1 _ (G / (F2 gT G))).

Definition app (F1 F2 : obmap) :=
  fun gT G => F1 _ (F2 gT G).

(* Strong functoriality (wrt domains) *)

Definition dcont (F : obmap) : Prop :=
  forall gT hT (G D : {group gT}) (phi : {morphism D >-> hT}),
    phi @* (F _ G) \subset F _ (phi @* G).

Lemma cont_of_dcont : forall F, dcont F -> cont F.
Proof. by move=> F contF gT hT G; exact: contF. Qed.

Lemma hereditary_of_dcont : forall sF, dcont sF -> hereditary sF.
Proof.
move=> sF Hcont gT H G sHG; move: (Hcont _ _ G _ (idm_morphism H)) => /=.
rewrite -morphimIdom -[idm H @* G]morphimIdom !morphim_idm ?subsetIl //.
by rewrite (setIidPl sHG) setIC.
Qed.

(* Order-preserving w.r.t. inclusion *)

Definition monotonous (F : obmap) : Prop :=
  forall gT (H G : {group gT}), H \subset G -> (F _ H) \subset (F _ G).

End IdentitySubFunctorDefs.

Module FunctorDefs.

Section ClassDefs.

Implicit Type gT : finGroupType.

Structure bgFunc : Type := BGFunc {
  Fobj : obmap;
  (* group preservation *)
  _ : forall gT (G : {group gT}), group_set (@Fobj gT G);
  (* submapping *)
  _ : forall gT (G : {group gT}), @Fobj gT G \subset G;
  (* functoriality condition *)
  _ : acont Fobj}.
Local Coercion Fobj : bgFunc >-> obmap.

Structure gFunc : Type := GFunc {
  F_bgFunc : bgFunc ;
   _ : cont F_bgFunc}.
Local Coercion F_bgFunc : gFunc >-> bgFunc.

Structure hgFunc : Type := HGFunc {
  F_hgFunc : gFunc;
   _ : hereditary F_hgFunc}.
Local Coercion F_hgFunc : hgFunc >-> gFunc.

Structure mgFunc : Type := MGFunc {
  F_mgFunc : gFunc;
   _ : monotonous F_mgFunc}.
Local Coercion F_mgFunc : mgFunc >-> gFunc.

Definition mkBGFunc F rF gF sF := @BGFunc F gF sF rF.

Definition mkGFunc F rF gF sF :=
  @GFunc (@BGFunc F gF sF (acont_of_cont rF)) rF.

Definition repack_bgFunc bgF :=
let: BGFunc _ gp smap arp := bgF
  return {type of BGFunc for bgF} -> bgFunc in
  fun k => k gp smap arp.

Definition obmap_phant := phantom obmap.
Definition obmap_uni op1 op2 := obmap_phant op1 -> obmap_phant op2.

Definition repack_gFunc F (bgF : bgFunc) (gF : gFunc) :=
  fun (_ : obmap_uni bgF F) ( _ : obmap_uni gF F) obmapEq =>
    (let: GFunc _ rp := gF
      return {type of GFunc for gF} -> gFunc in
      fun k => k rp)
    (let: erefl in _ = gF := obmapEq
      return {type of GFunc for gF}
      in @GFunc bgF).

Definition repack_hgFunc F (gF : gFunc) (hgF : hgFunc) :=
  fun (_ : obmap_uni gF F) ( _ : obmap_uni hgF F) obmapEq =>
    (let: HGFunc _ hp := hgF
      return {type of HGFunc for hgF} -> hgFunc in
      fun k => k hp)
    (let: erefl in _ = hgF := obmapEq
      return {type of HGFunc for hgF}
      in @HGFunc gF).

Definition repack_mgFunc F (gF : gFunc) (mgF : mgFunc) :=
  fun (_ : obmap_uni gF F) ( _ : obmap_uni mgF F) obmapEq =>
    (let: MGFunc _ cp := mgF
      return {type of MGFunc for mgF} -> mgFunc in
      fun k => k cp)
    (let: erefl in _ = mgF := obmapEq
      return {type of MGFunc for mgF}
      in @MGFunc gF).
End ClassDefs.

Module Exports.
Coercion Fobj : bgFunc >-> obmap.
Coercion F_bgFunc : gFunc >-> bgFunc.
Coercion F_hgFunc : hgFunc >-> gFunc.
Coercion F_mgFunc : mgFunc >-> gFunc.
End Exports.

End FunctorDefs.
Export FunctorDefs.Exports.

Notation "[ 'bgFunc' 'of' F ]" :=
  (FunctorDefs.repack_bgFunc (fun bgP => @FunctorDefs.BGFunc F bgP))
  (at level 0, format"[ 'bgFunc'  'of'  F ]") : form_scope.

Notation "[ 'bgFunc' 'by' sF & ! rF ]" :=
  (FunctorDefs.mkBGFunc rF (fun gT G => groupP _) sF)
  (at level 0, format "[ 'bgFunc'  'by'  sF  &  ! rF ]") : form_scope.

Notation "[ 'bgFunc' 'by' sF & rF ]" :=
  [bgFunc by sF & !acont_of_cont rF]
  (at level 0, format "[ 'bgFunc'  'by'  sF  &  rF ]") : form_scope.

Notation "[ 'gFunc' 'by' sF & rF ]" :=
  (FunctorDefs.mkGFunc rF (fun gT G => groupP _) sF)
  (at level 0, format "[ 'gFunc'  'by'  sF  &  rF ]") : form_scope.

Notation "[ 'gFunc' 'of' F ]" :=
  (@FunctorDefs.repack_gFunc F _ _ id id (erefl _))
  (at level 0, format "[ 'gFunc'  'of'  F ]") : form_scope.

Notation "[ 'hgFunc' 'of' F ]" :=
  (@FunctorDefs.repack_hgFunc F _ _ id id (erefl _))
  (at level 0, format "[ 'hgFunc' 'of'  F ]") : form_scope.

Notation "[ 'mgFunc' 'of' F ]" :=
  (@FunctorDefs.repack_mgFunc F _ _ id id (erefl _))
  (at level 0, format "[ 'mgFunc' 'of'  F ]") : form_scope.

Notation bgFunc := FunctorDefs.bgFunc.
Notation gFunc := FunctorDefs.gFunc.
Notation hgFunc := FunctorDefs.hgFunc.
Notation mgFunc := FunctorDefs.mgFunc.

Notation BGFunc := FunctorDefs.BGFunc.
Notation GFunc := FunctorDefs.GFunc.
Notation HGFunc := FunctorDefs.HGFunc.
Notation MGFunc := FunctorDefs.MGFunc.

Section BgGroup.
(* Preliminary : group structure *)
Variables (sF : bgFunc) (gT : finGroupType) (H : {group gT}).
Lemma bgFunc_groupset : group_set (sF _ H). Proof. by case: sF. Qed.
Canonical Structure bgFunc_group := Group bgFunc_groupset.
End BgGroup.

Section BaseIdentitySubFunctorProps.

Implicit Types gT hT : finGroupType.
Variable sF : bgFunc.

Lemma bgFunc_clos : forall gT (H : {group gT}), sF _ H \subset H.
Proof. by case sF. Qed.

Lemma bgFunc_acont : acont sF.
Proof. by case sF. Qed.

Lemma bgFunc_char : forall gT (G : {group gT}), sF _ G \char G.
Proof.
move=> gT G; apply/andP; split => //; first by apply: bgFunc_clos.
apply/forallP=> f; apply/implyP=> Af; rewrite -{2}(im_autm Af) -(autmE Af).
by rewrite -morphimEsub ?bgFunc_clos ?bgFunc_acont ?injm_autm.
Qed.

Lemma bgFunc_norm : forall gT (G : {group gT}), G \subset 'N(sF _ G).
Proof. by move=> *; rewrite char_norm ?bgFunc_char. Qed.

(* independent from the group preservation requirement*)
Lemma bgFunc_gen_norm : forall gT (G : {group gT}),
  << sF _ G >> \subset 'N(sF _ G).
Proof.
move=> gT G; apply/normsP=> x Hx; move/normsP: (bgFunc_norm G); apply.
by move: ((subsetP (genS (bgFunc_clos G))) _ Hx); rewrite genGid.
Qed.

Lemma bgFunc_normal : forall gT (G : {group gT}), sF _ G <| G.
Proof.  by move=> *; rewrite char_normal ?bgFunc_char. Qed.

Lemma bgFunc_ascont_sub :
   forall gT hT (H G : {group gT}) (f : {morphism G >-> hT}),
  'injm f -> H \subset G -> f @* (sF _ H) \subset sF _ (f @* H).
Proof.
move=> gT hT H G f injf sHG; apply/eqP; rewrite -(setIidPr (bgFunc_clos H)).
by rewrite-{3}(setIid H) -!(morphim_restrm sHG) bgFunc_acont // injm_restrm.
Qed.

Lemma bgFunc_ascont :
 forall gT hT (H G : {group gT}) (f : {morphism G >-> hT}),
 'injm f -> H \subset G -> f @* (sF _ H) = sF _ (f @* H).
Proof.
move=> gT hT H G f injf sHG.
apply/eqP; rewrite eqEsubset bgFunc_ascont_sub //=.
rewrite -{2}(morphim_invm injf sHG) -[f @* sF _ _](morphpre_invm injf).
have sFtr := subset_trans (bgFunc_clos _).
by rewrite -sub_morphim_pre (bgFunc_ascont_sub, sFtr) ?morphimS ?injm_invm.
Qed.

Lemma bgFunc_nker_cont :
  forall gT hT (H G : {group gT}) (f : {morphism G >-> hT}),
  'ker f = 1 -> H \subset G -> f @* (sF _ H) = sF _ (f @* H).
Proof. by move=> gT hT H G f; move/trivgP => /=; apply: bgFunc_ascont. Qed.

Lemma bgFunc_isom :
  forall gT hT (H G : {group gT}) (R : {group hT}) (f : {morphism G >-> hT}),
  H \subset G -> isom H R f -> isom (sF _ H) (sF _ R) f.
Proof.
move=> gT rT H G R f; case/(restrmP f)=> g [gf _ _ _]; rewrite -{f}gf.
by case/isomP=> injg <-; rewrite sub_isom ?bgFunc_clos ?bgFunc_ascont.
Qed.

Lemma bgFunc_isog : forall gT hT (G : {group gT}) (R : {group hT}),
  G \isog R -> sF _ G \isog sF _ R.
Proof.
move=> gT rT D R; case/isogP=> f *.
apply: (isom_isog f) => //; first by apply: bgFunc_clos.
apply: bgFunc_isom => //; exact/isomP.
Qed.

End BaseIdentitySubFunctorProps.

Section IdentitySubFunctorProps.

Implicit Types gT hT : finGroupType.
Variable sF : gFunc.

Lemma gFunc_cont : cont sF.
Proof. by case sF. Qed.

Lemma morphim_sFunctor : forall gT hT (G D : {group gT})
  (f : {morphism D >-> hT}),
  G \subset D -> f @* (sF _ G) \subset sF _ (f @* G).
Proof.
move=> gT hT G D f sGD; rewrite -(setIidPr (bgFunc_clos sF G)).
by rewrite  -{3}(setIid G) -!(morphim_restrm sGD) gFunc_cont.
Qed.

Lemma injm_sFunctor :
  forall gT hT (G D : {group gT}) (f : {morphism D >-> hT}),
  'injm f -> G \subset D -> f @* (sF _ G) = sF _ (f @* G).
Proof. exact: bgFunc_ascont. Qed.

Lemma isom_sFunctor :
  forall gT hT (D G : {group gT}) (R : {group hT}) (f : {morphism D >-> hT}),
  G \subset D -> isom G R f -> isom (sF _ G) (sF _ R) f.
Proof. move=> gT hT D G; exact: bgFunc_isom. Qed.

Lemma isog_sFunctor : forall gT hT (D : {group gT}) (R : {group hT}),
  D \isog R -> sF _ D \isog sF _ R.
Proof. exact: bgFunc_isog. Qed.

End IdentitySubFunctorProps.

Section HereditaryIdentitySubFunctorProps.

Implicit Types gT hT : finGroupType.

Section HereditaryIdBaseProps.

Variable sF : hgFunc.

Lemma hgFunc_cont : cont sF.
Proof. by apply: gFunc_cont. Qed.

Lemma hgFunc_hereditary : hereditary sF.
Proof. by case sF. Qed.

Lemma hgFunc_imsetI : forall gT (G H : {group gT}),
  sF _ G :&: H = sF _ G :&: sF _ (G :&: H).
Proof.
move=> gT G H; rewrite -{1}(setIidPr (bgFunc_clos sF G)) [G :&: _]setIC -setIA.
move/setIidPr: (hgFunc_hereditary (subsetIl G H)) <-.
by rewrite setIC -setIA (setIidPr (bgFunc_clos sF (G:&: H))).
Qed.

Lemma hgFunc_morphim : dcont sF.
Proof.
move=> gT hT G D f.
rewrite -morphimIdom -(setIidPl (bgFunc_clos sF G)) setICA.
apply: (subset_trans (morphimS f (hgFunc_hereditary (subsetIr D G)))).
apply: (subset_trans (morphim_sFunctor sF _ _ )); last by rewrite morphimIdom.
exact: subsetIl.
Qed.

(* TOFIX: this should ultimately use the Idempotent Property defined below *)
Lemma hereditary_idem : forall (gT:finGroupType) (G:{group gT}),
  (app sF sF) _ G  = sF _ G.
Proof.
move=> gT G /=; apply/eqP; rewrite eqEsubset bgFunc_clos.
by move/hgFunc_hereditary: (bgFunc_clos sF G); rewrite setIid /=.
Qed.

End HereditaryIdBaseProps.

Section HereditaryIdentitySFComp.

Variables (sF : hgFunc) (sF2 : gFunc).

(* independent from the group preservation requirement *)
Lemma hgFunc_comp_clos : forall gT (G : {group gT}),
  (appmod sF sF2) gT G \subset G.
Proof.
move=> gT G; rewrite /appmod; have nFD := (bgFunc_norm sF2 G).
rewrite sub_morphpre_im ?(bgFunc_clos sF) //=.
  by rewrite ker_coset_prim subIset // gen_subG (bgFunc_clos sF2 G).
by apply: subset_trans (bgFunc_clos sF _) _; apply: morphimS.
Qed.

Lemma hgFunc_comp_quo : forall gT (G : {group gT}) (B : {set gT}),
  (coset B @*^-1  sF _ (G / B)) / B  = sF _ (G / B).
Proof.
move=> gT A B; apply: morphpreK; apply: subset_trans (bgFunc_clos sF _) _.
by rewrite /= /quotient -morphimIdom  morphimS ?subsetIl.
Qed.

Lemma hgFunc_comp_cont : cont (appmod sF sF2).
Proof.
move=> gT rT G f; have nF := bgFunc_norm sF2.
have kF := ker_coset (Group (bgFunc_groupset sF2 _)); simpl in kF.
have sDF: G \subset 'dom (coset (sF2 _ G)) by rewrite ?nF.
have sDFf: G \subset 'dom (coset (sF2 _ (f @* G)) \o f).
  by rewrite -sub_morphim_pre ?subsetIl // nF.
pose K := 'ker (restrm sDFf (coset (sF2 _ (f @* G)) \o f)).
have sFK: 'ker (restrm sDF (coset (sF2 _ G))) \subset K.
  rewrite /K  !ker_restrm ker_comp /= subsetI subsetIl /=.
  by rewrite -sub_morphim_pre ?subsetIl // morphimIdom !kF ?morphim_sFunctor.
have sOF := bgFunc_clos sF (G / sF2 _ G); have sGG: G \subset G by [].
rewrite -sub_morphim_pre -?quotientE; last first.
  by apply: subset_trans (nF _ _); rewrite morphimS ?hgFunc_comp_clos.
suffices im_fact: forall H : {group gT}, sF2 _ G \subset H -> H \subset G ->
  factm sFK sGG @* (H / sF2 _ G) = f @* H / sF2 _ (f @* G).
- rewrite -2?im_fact ?hgFunc_comp_clos ?bgFunc_clos //.
  by rewrite hgFunc_comp_quo morphim_sFunctor /= ?morphim_restrm ?setIid //.
  by rewrite -{1}kF morphpreS ?sub1G.
move=> H sFH sHG; rewrite -(morphimIdom _ (H / _)) /= {2}morphim_restrm setIid.
rewrite -morphimIG ?kF // -(morphim_restrm sDF) morphim_factm morphim_restrm.
by rewrite morphim_comp -quotientE morphimIdom.
Qed.

Canonical Structure hgFunc_comp_bgFunc :=
  [bgFunc by hgFunc_comp_clos & hgFunc_comp_cont].

Canonical Structure hgFunc_comp_gFunc := GFunc hgFunc_comp_cont.

End HereditaryIdentitySFComp.

Variables sF sF3 : hgFunc.

Lemma hgFunc_comp_hereditary : hereditary (appmod sF sF3).
Proof.
move=> gT H G sHG; set FGH := _ :&: H; have nF3H := bgFunc_norm sF3 H.
rewrite -sub_quotient_pre; last exact: subset_trans (subsetIr _ _) _.
pose rH := restrm nF3H (coset (sF3 _ H)); pose rHM := [morphism of rH].
have rnorm_simpl: rHM @* H = H / sF3 _ H by rewrite morphim_restrm setIid.
have nF3G := subset_trans sHG (bgFunc_norm sF3 _).
pose rG := restrm nF3G (coset (sF3 _ G)); pose rGM := [morphism of rG].
have sqKfK: 'ker rGM \subset 'ker rHM.
  rewrite !ker_restrm !ker_coset (setIidPr (bgFunc_clos sF3 _)) setIC /=.
  exact: (hgFunc_hereditary sF3).
have sHH := subxx H; rewrite -rnorm_simpl /= -(morphim_factm sqKfK sHH) /=.
apply: subset_trans (gFunc_cont sF _); rewrite /= {2}morphim_restrm setIid /=.
apply: subset_trans (morphimS _ (hgFunc_hereditary _ (quotientS _ sHG))) => /=.
have ->: FGH / _ = restrm nF3H (coset _) @* FGH.
  by rewrite morphim_restrm setICA setIid.
rewrite -(morphim_factm sqKfK sHH) morphimS //= morphim_restrm -quotientE.
by rewrite setICA setIid (subset_trans (quotientI _ _ _)) // cosetpreK.
Qed.

Canonical Structure hgFunc_comp_hgFunc := HGFunc hgFunc_comp_hereditary.

End HereditaryIdentitySubFunctorProps.

Section MonotonousIdentitySubFunctorProps.

Implicit Types gT hT : finGroupType.

Section MonotonousIdBaseProps.

Variable sF : mgFunc.

Lemma mgFunc_cont : cont sF.
Proof. exact: gFunc_cont. Qed.

Lemma mgFunc_monotonous : monotonous sF.
Proof. by case sF. Qed.

End MonotonousIdBaseProps.

Section MonotonousIdentitySFComp.

Variables (sF : mgFunc) (sF2 : gFunc).

(* independent from the group preservation requirement *)
Lemma mgFunc_comp_clos : forall gT (G : {group gT}),
  (app sF sF2) gT G \subset G.
Proof.
by move=> gT G; rewrite (subset_trans (bgFunc_clos _ _)) ?bgFunc_clos.
Qed.

Lemma mgFunc_comp_cont : cont (app sF sF2).
Proof.
move=> gT hT G phi.
rewrite (subset_trans (morphim_sFunctor _ _ (bgFunc_clos _ _))) //.
by rewrite (subset_trans (mgFunc_monotonous sF (gFunc_cont sF2 phi))).
Qed.

Canonical Structure mgFunc_comp_bgFunc :=
  [bgFunc by mgFunc_comp_clos & mgFunc_comp_cont].

Canonical Structure mgFunc_comp_gFunc := GFunc mgFunc_comp_cont.

End MonotonousIdentitySFComp.

Variables sF sF3 : mgFunc.

Lemma mgFunc_comp_monotonous : monotonous (mgFunc_comp_gFunc sF sF3).
Proof. by move=> gT H G sHG; rewrite !mgFunc_monotonous. Qed.

Definition mgFunc_comp_hgFunc := MGFunc mgFunc_comp_monotonous.

End MonotonousIdentitySubFunctorProps.

Section IdentitySubFunctorsExamples.

Implicit Types gT : finGroupType.

Definition id_sF gT := @id {set gT}.

Lemma id_cont : cont id_sF.
Proof. by []. Qed.

Lemma id_monotonous : monotonous id_sF.
Proof. by []. Qed.

Canonical Structure bgFunc_id := [bgFunc by fun _ _ => subxx _ & id_cont].
Canonical Structure gFunc_id := GFunc id_cont.
Canonical Structure mgFunc_id := MGFunc id_monotonous.

Definition triv_sF gT of {set gT} := [1 gT].

Lemma triv_cont : cont triv_sF.
Proof. by move=> gT hT H f; rewrite morphim1. Qed.

Canonical Structure bgFunc_triv := [bgFunc by sub1G & triv_cont].
Canonical Structure gFunc_triv := GFunc triv_cont.
Canonical Structure hgFunc_triv :=
  @HGFunc gFunc_triv (fun gT G _ _ => subsetIl 1 G).

End IdentitySubFunctorsExamples.

Section Torsion.

Implicit Types gT hT: finGroupType.

(* Orthogonality property*)
Definition trivlsed gT (B : {group gT}) hT (C : {group hT}) :=
  forall f : {morphism B >-> hT},
  f @* B \subset C -> f @* B :=: 1%G.

Definition GClass := forall gT (B: {group gT}), Prop.

Identity Coercion fun_of_obsel : GClass >-> Funclass.

Implicit Types P Pa Pb : GClass.

(* Closure properties*)

Definition cisom P := forall gT (G : {group gT}) hT (H : {group hT}),
  isog G H -> P _ G -> P _ H.

Definition csub P := forall gT (G H : {group gT}),
  H \subset G -> P _ G -> P _ H.

Definition cquo P := forall gT (G H : {group gT}),
  H <| G -> P _ G -> P _ (G / H)%G.

Lemma cquoisom1 : forall P, cquo P -> cisom P ->
  (forall gT (G:{group gT}), P _ G -> forall hT, P _ (one_group hT)).
Proof.
move=> P qP iP gT G PG hT; have : P (coset_groupType G) 1%G.
  move:(trivg_quotient G); move/group_inj=><-.
  by apply:(qP _ _ _ (normal_refl _) PG).
by apply: iP; exact: trivial_isog.
Qed.

Definition cex P := forall gT (G H : {group gT}),
  H <| G -> P _ H -> P _ (G / H)%G -> P _ G.

Definition cjoin P := forall gT (H G : {group gT}),
  P _ H -> P _ G -> P _ (H <*> G)%G.

(* TOFIX : this is a puny excuse for being 'closed by direct product' *)
Definition csetX P := forall gT (G : {group gT}) hT (H : {group hT}),
  P _ G -> P _ H -> P _ [group of setX G H].

(* Order relations on group classes *)

(* NB : lP has to relate polymorphically quantified classes,
   otherwise a finGroupType and a quotient type of it can't be in the same class
   This is necessary as soon as ClB below. *)

Definition lP Pa Pb := forall gT B, Pa gT B -> Pb _ B.

Definition eP Pa Pb := forall gT B, Pa gT B <-> Pb _ B.

(* a torsion theory is a couple of classes related by the two operators below.

   A formal definition would correspond to the hypotheses of sections
   EquivalenceTheorem2 & EquivalenceTheorem3.*)

Definition Rfun P hT (C : {group hT}) :=
  lP P (fun gT B => trivlsed B C) (* : forall gT, Prop ~= bool*).

Definition Lfun P gT (B : {group gT}) :=
  lP P (trivlsed B).

Lemma RightLeft : forall (Bs Cs : GClass),
   lP Cs (Rfun Bs) <-> lP Bs (Lfun Cs).
Proof.
by move=> Bs Cs; split; move=> H gT B HB hT C HC; apply H.
Qed.

(* TOFIX : those should be moved to section IdentitySubFunctorDefs *)
Definition Idemp (F : obmap) := forall gT (G : {group gT}), F _ (F _ G) = F _ G.
Definition radical (F : obmap) := forall gT (G : {group gT}),
  F _ (G / (F _ G)) = 1.

Section EquivalenceTheorem1.
(* An indempotent radical generated by a torsion theory*)

Variable T : mgFunc.
Hypothesis Hid : Idemp T.
Hypothesis Hrad : radical T.

Local Notation Bs :=
  (fun (fT:finGroupType) (B : {group fT}) => T _ B = B).
Local Notation Cs :=
  (fun (fT:finGroupType) (C : {group fT}) => T _ C = 1).

(* NB : we need monotonicity (alone) here *)
Lemma BCl : lP Bs (Lfun Cs).
Proof.
move=> gT B /= HB hT C /= HC; move=> f; rewrite /= -{6}HB.
move/(mgFunc_monotonous T)=>HTB; apply/trivgP; rewrite -HC.
by apply:subset_trans HTB; apply: mgFunc_cont.
Qed.

Lemma CBr : lP Cs (Rfun Bs).
Proof. by apply/RightLeft; apply:BCl. Qed.

(* NB : radicality alone needed*)
Lemma ClB : lP (Lfun Cs) Bs.
Proof.
move=> gT B2; rewrite /Lfun /lP; move/(_ _ (B2 / T _ B2)%G); move/(_ (Hrad B2)).
pose f:= [morphism of restrm (bgFunc_norm T B2) (coset (T _ B2))].
move/(_ f); rewrite /= /restrm quotientE=> H.
have e : B2 \subset 'ker (coset (T _ B2)).
  rewrite ker_trivg_morphim bgFunc_norm; apply/trivgP.
  by apply: val_inj; rewrite /= -H !morphim_restrm !morphimE setIid.
by apply/eqP; rewrite eqEsubset bgFunc_clos; rewrite ker_coset in e.
Qed.

(* NB : idempotence alone needed *)
Lemma BrC : lP (Rfun Bs) Cs.
Proof.
move=> hT C2; rewrite /Rfun /lP; move/(_ _ [group of T _ C2])=>/=.
move/(_ (Hid C2)); pose f := [morphism of restrm (bgFunc_clos T C2) (idm C2)].
move/(_ f); rewrite /= /restrm morphim_restrm morphim_idm setIid bgFunc_clos //.
by apply.
Qed.

Lemma eBC : eP Bs (Lfun Cs) /\ eP Cs (Rfun Bs).
Proof.
by split; move=> gT B; split; [apply BCl|apply ClB|apply CBr|apply BrC].
Qed.

End EquivalenceTheorem1.

Section EquivalenceTheorem2.

(* Here we get closure properties from Lfun properties.
   Those will ultimately allow us to build a corresponding
   (not necessarily idempotent) radical
*)

Variables Bs Cs : forall gT (_:{group gT}), Prop.
Hypothesis eBC : eP Bs (Lfun Cs).

Lemma hBCl : lP Bs (Lfun Cs).
Proof. by move=> gT B; rewrite (eBC B). Qed.

Lemma hClB : lP (Lfun Cs) Bs.
Proof. by move=> gT B; rewrite (eBC B). Qed.

Lemma cisomB : cisom Bs.
Proof.
move=> gT B hT C; move/isogP => [f Hfinj Hfim]; move/hBCl=>HB.
apply:hClB=> fT Y HY g Hgim; move : (injmK Hfinj (subxx _)).
rewrite Hfim=> Hfpre; have:= (comp_morphM g (f:=f)); rewrite Hfpre => H.
pose gof := Morphism H; move: (HB _ _ HY gof).
by rewrite morphimE imset_comp -morphimE Hfim -{2 4}(setIid C) -morphimE;
move/(_ Hgim).
Qed.

Lemma cquoB : cquo Bs.
Proof.
move=> gT X H Hs; move/hBCl=>HX; apply:hClB=> hT C2 HC2 g2 Hg2.
pose f:= [morphism of restrm (normal_sub Hs) (coset H)].
have:= (comp_morphM g2 (f:=f)); rewrite /restrm (quotientGK Hs)=>Hm.
pose g:= Morphism Hm; move:(HX _ _ HC2 g); rewrite morphimE imset_comp.
rewrite setIid -(setIidPr (normal_norm Hs)) -morphimE /= /restrm -quotientE.
by rewrite -{2 4}(setIid (X / H)) -morphimE; move/(_ Hg2).
Qed.

Lemma cexB : cex Bs.
Proof.
move=> gT M B Hs; move/hBCl=>HB; move/hBCl=> Hqu; apply:hClB=> hT C3 HC3 f3 Hf3.
move: (comp_morphM f3 (f:= [morphism of idm B])).
rewrite morphpre_idm (setIidPl (normal_sub Hs))=>Hf3i; pose f:= Morphism Hf3i.
move: (HB _ _ HC3 f); rewrite morphimE imset_comp -morphimE.
rewrite morphim_idm ?subxx // -{1 2}(setIidPr (normal_sub Hs)) -morphimE.
move/(_ (subset_trans (morphimS f3 (normal_sub Hs)) Hf3))=>Hf3B.
move/trivgP:(Hf3B); move/(conj (normal_sub Hs)); move/andP.
rewrite -ker_trivg_morphim=> HBker.
have Hinj : 'injm (coset (f3 @* B)) by rewrite Hf3B; apply:coset1_injm.
move: (morphM [morphism of (invm Hinj) \o (quotm f3 Hs)])=>/=.
rewrite -quotientE morphpre_quotm {1}Hf3B norm1 morphpreT=>Hq.
pose qfq := Morphism Hq; move:(Hqu _ _ HC3 qfq).
rewrite morphimE imset_comp -morphimE morphim_quotm quotientE.
have:= (subsetT (f3 @* M)); rewrite -norm1 -[1]/(gval _) -{1}Hf3B =>Hm.
rewrite -(setIidPr (morphimS _  Hm)) -morphimE morphim_invm ?Hm //.
by move/(_ Hf3).
Qed.

Lemma cjoinB : cjoin Bs.
Proof.
move=> Pb G H BH BG; apply: hClB=> hT C5 HC5 f5.
rewrite morphim_gen ?subset_gen // gen_subG {1}morphimU subUset.
rewrite 2!morphimE (setIidPr (joing_subl _ _)) (setIidPr (joing_subr _ _)).
move/andP=> [Hf5G Hf5H]; apply/trivgP; rewrite gen_subG.
rewrite sub_morphim_pre ?subset_gen -?sub_morphim_pre ?sub_gen //.
move: (morphM [morphism of f5 \o (idm G)]).
move: (morphM [morphism of f5 \o (idm H)]).
rewrite {1}[idm_morphism G @*^-1 _]morphpre_idm.
rewrite {1}[idm_morphism H @*^-1 _]morphpre_idm.
rewrite (setIidPl (joing_subl _ _)) (setIidPl (joing_subr _ _)) =>Hf Hg.
pose f:= Morphism Hf; pose g:= Morphism Hg.
move: (hBCl BH HC5) (hBCl BG HC5)=> HtG HtH; move: (HtG g) (HtH f).
rewrite 2!morphimE 2!imset_comp -!morphimE !morphim_idm ?subxx // morphimU.
rewrite subUset !morphimE (setIidPr (joing_subl _ _)).
rewrite (setIidPr (joing_subr _ _)); move/(_ Hf5G)=>->; move/(_ Hf5H)=>->.
by rewrite subxx.
Qed.

(*
TOFIX : add closure wrt direct sum
*)

End EquivalenceTheorem2.

Section EquivalenceTheorem3.

(* Closure properties from Rfun properties.
   Those will ultimately allow us to build a corresponding
   (not necessarily radical) idempotent pre-radical
*)

Variables Bs Cs : forall gT (_:{group gT}), Prop.
Hypothesis eCB : eP Cs (Rfun Bs).

(* This is done to syntactically isolate what I use, of course views apply
   bidirectionnaly
*)

Lemma hCBr : lP Cs (Rfun Bs).
Proof. by move=> gT C; rewrite (eCB C). Qed.

Lemma hBrC : lP (Rfun Bs) Cs.
Proof. by move=> gT C; rewrite (eCB C). Qed.

Lemma cisomC : cisom Cs.
Proof.
move=> gT G hT H; case/isogP=> f Hfinj Hfim; move/hCBr=>HC.
apply:hBrC=> fT Y HY g Hgim; pose h := (invm Hfinj)\o g.
have mH: morphic Y h.
  move:Hgim; rewrite (sub_morphim_pre _ _ (subxx _)); move/subsetP=>Hgim.
  have:= (comp_morphM [morphism of invm Hfinj] (f:=g)); rewrite /= Hfim=> Hm.
  by apply/morphicP; move=> x y; move/Hgim=> Hx; move/Hgim=>Hy; apply:Hm.
rewrite -Hfim in Hgim.
apply: (injm_morphim_inj (injm_invm Hfinj) Hgim (sub1G _)).
pose invfog := Morphism (morphicP mH); move: (HC _ _ HY invfog).
rewrite morphimE imset_comp -morphimE -{1 2}(setIidPr Hgim) -morphimE.
move/(morphimS [morphism of invm Hfinj]) : Hgim =>/=.
by rewrite morphim1 (morphim_invm _ (subxx _))=>Hi; move/(_ Hi).
Qed.

Lemma csubC : csub Cs.
Proof.
move=> hT X H Hs; move/hCBr=> HtBrG; apply:hBrC=> gT B2 HB2 f2 Hf2.
pose h:= (idm H) \o f2; have mH : morphic B2 h.
  rewrite (sub_morphim_pre _ _ (subxx _)) in Hf2; move/subsetP:Hf2=>Hf2.
  apply/morphicP; have := (morphM [morphism of h])=> Hm x y; move/Hf2=>Hx.
  by move/Hf2=>Hy; apply:Hm.
pose iof := Morphism (morphicP mH); move: (HtBrG _ _ HB2 iof); rewrite morphimE.
rewrite imset_comp -morphimE -{1 2}(setIidPr Hf2) -morphimE morphim_idm ?Hf2 //.
by move/(_ (subset_trans Hf2 Hs)).
Qed.

Lemma cexC : cex Cs.
Proof.
move=> hT M C Hs; move/hCBr=>HB; move/hCBr=> Hqu; apply:hBrC=> gT B3 HB3 f3 Hf3.
pose h:= (restrm (normal_norm Hs) (coset C)) \o f3.
have mH: morphic B3 h.
  apply/morphicP; move: (morphM [morphism of h])=> Hm x y.
  rewrite (sub_morphim_pre _ _ (subxx _)) in Hf3; move/subsetP:Hf3=>Hf3.
  by move/Hf3=> Hx; move/Hf3=> Hy; apply:Hm.
(* TOFIX : don't know why the simpl is mandatory here*)
move/morphicP: mH=> /= mH; pose hm := Morphism mH.
move: (Hqu _ _ HB3 hm); rewrite morphimE imset_comp -morphimE /restrm.
rewrite -{1 2}(setIidPr (subset_trans Hf3 (normal_norm Hs))) -morphimE.
rewrite -quotientE; move/(_ (quotientS _ Hf3)).
move/trivgP; move/(conj (subset_trans Hf3 (normal_norm Hs))); move/andP.
by rewrite -ker_trivg_morphim ker_coset; move/(HB _ _ HB3 f3).
Qed.

(* TOFIX : according to what is inferred in this lemma, the structures on
   [eta fst], [eta snd] declared in gprod.v don't work so well*)
Lemma csetXP : csetX Cs.
Proof.
move=> gT G hT H; move/hCBr=> HG; move/hCBr=> HH; apply hBrC=> fT B4 HB4 g4 Hg4.
pose p1g4 := restrm (subsetT (setX G H)) [morphism of fun x => x.1] \o g4.
pose p2g4 := restrm (subsetT (setX G H)) [morphism of fun x => x.2] \o g4.
have Hp1g4 : morphic B4 p1g4.
  apply/morphicP=> x y;  move: Hg4; rewrite (sub_morphim_pre _ _ (subxx _)).
  move/subsetP=> Hs; move/Hs=> Hx; move/Hs=>Hy.
  by apply:(morphM [morphism of p1g4]).
have Hp2g4: morphic B4 p2g4.
  apply/morphicP=> x y;  move: Hg4; rewrite (sub_morphim_pre _ _ (subxx _)).
  move/subsetP=> Hs; move/Hs=> Hx; move/Hs=>Hy.
  by apply: (morphM [morphism of p2g4]).
pose mp1g4:= Morphism (morphicP Hp1g4); pose mp2g4 := Morphism (morphicP Hp2g4).
move: (HG _ _ HB4 mp1g4) (HH _ _ HB4 mp2g4).
rewrite morphimE imset_comp -morphimE /restrm -{1}(setTI (g4 @* B4)) -morphimE.
move: (morphimS [morphism of restrm (subsetT (setX G H)) (fun x => x.1)] Hg4).
move: (morphimS [morphism of restrm (subsetT (setX G H)) (fun x => x.2)] Hg4).
rewrite morphim_fstX morphim_sndX /restrm=> Hm2 Hm1.
move/(_ Hm1)=>H1; rewrite morphimE imset_comp -morphimE /restrm.
rewrite  -{1}(setTI (g4 @* B4)) -morphimE; move/(_ Hm2)=> H2.
apply/trivgP; apply/subsetP; case=>[x1 x2 Hx12].
move: (mem_imset [morphism of fun x =>x.1] Hx12); rewrite H1 /=; move/set1P=>->.
move: (mem_imset [morphism of fun x =>x.2] Hx12); rewrite H2 /=; move/set1P=>->.
by apply/set1P.
Qed.

End EquivalenceTheorem3.

Section EquivalenceTheorem4.

(* Here, as well as in the next section we define a (pre-)radical from
 closure properties.

 Since our assumptions in the last section are minimal, the ones in this
 section might surprise. Notice that in fact, we simply require closure
 properties on the class we study (here, Bs), and computational definition
 on the other (C = B^r).

*)

Variables (Bs Cs : GClass).
Hypothesis  eCB : eP Cs (Rfun Bs).

(* This is done to syntactically isolate what I use, of course views apply
   bidirectionnaly
*)

Lemma hCBr' : lP Cs (Rfun Bs).
Proof. by move=> gT C; rewrite (eCB C). Qed.

Lemma hBrC' : lP (Rfun Bs) Cs.
Proof. by move=> gT C; rewrite (eCB C). Qed.

Hypothesis cquoB : cquo Bs.
Hypothesis cisomB : cisom Bs.
Hypothesis cexB : cex Bs.
Hypothesis cjoinB : cjoin Bs.

Variables Bbool Cbool : forall gT, pred {group gT}.
Hypothesis reflectB : forall gT (G:{group gT}), reflect (Bs G) (Bbool G).

(***************************************************************************)
(* This implies our interpretation of class Bs in terms of a functor will  *)
(* only be valid when Bs is not empty. We will have to carry around a      *)
(* non-emptyness hypothesis, but this is actually better than the          *)
(* alternative, which is to have a T that does not always carry a group    *)
(* structure (being sometimes empty) - hence one that wouldn't even fit our*)
(* bgFunc structure.                                                       *)
(***************************************************************************)

Definition T gT (G:{set gT}) :=
  \big[joinG/1%G]_(H: {group gT} | (@Bbool _ H) && (H \subset G)) H.

(* The following is trivial, but important to notice *)
Lemma sub1TG : forall gT (G:{group gT}), 1%G \subset T G.
Proof. by move=> gT G; apply: sub1G. Qed.

Lemma noBstrivT : (forall gT (H:{group gT}), Bs H -> False) ->
  (forall hT (H:{group hT}), T H :=: 1).
Proof.
move=> noBs hT H; apply/trivgP; rewrite bigprodGE gen_subG.
by apply/bigcupsP=> G; case/andP; move/reflectB; move/noBs.
Qed.

Lemma T_B : forall hT (H:{group hT}), Bs H ->
  forall gT (G:{group gT}), Bs (T G).
Proof.
move=> hT H BsH gT G.
apply: big_prop; last by move=>H0; case/andP => BbH0 _; apply/reflectB.
  apply: (cquoisom1 cquoB cisomB BsH).
apply: cjoinB.
Qed.

Lemma T_sub : forall gT (G:{group gT}), T G \subset G.
Proof.
by move=>gT G; rewrite bigprodGE gen_subG; apply/bigcupsP=> H; case/andP.
Qed.

Lemma T_cont : cont T.
Proof.
move=> gT hT G f; have sUG:(\bigcup_(H | Bbool H && (H \subset G)) H \subset G).
 by apply/bigcupsP=> H; case/andP.
rewrite bigprodGE morphim_gen ?sUG ?gen_subG ?sub_morphim_pre ?sUG //.
apply/bigcupsP=> H; case/andP=> BbH sHG; rewrite -sub_morphim_pre ?sub_gen //.
rewrite -[f @* H]/(gval _); rewrite bigprodGE sub_gen //; apply:bigcup_sup.
rewrite morphimS ?andbT //; apply/reflectB; suff : (Bs (H / 'ker_H f)%G).
  by apply : cisomB; apply: (first_isog_loc f sHG).
apply:cquoB; last by apply/reflectB.
by rewrite /= -(ker_restrm sHG f) ker_normal.
Qed.

Canonical Structure bgFunc_T := [bgFunc by T_sub & T_cont].
Canonical Structure gFunc_T := GFunc (T_cont: cont bgFunc_T).

Lemma T_rad : radical T.
Proof.
move=> gT G; apply/trivgP; rewrite (@bigprodGE (coset_groupType _) _) gen_subG.
apply/bigcupsP=> H; case/andP=> BbH.
case/(inv_quotientS (bgFunc_normal bgFunc_T G)) => K KH sTGK sKG.
have KsNTG : K \subset 'N(T G) by exact: (subset_trans sKG (bgFunc_norm bgFunc_T G)).
rewrite KH quotient_sub1; last by exact: KsNTG.
rewrite bigprodGE sub_gen //; apply:bigcup_sup; rewrite sKG andbT.
move: (BbH); move/group_inj: KH =>->; move/reflectB => Bbquo.
apply/reflectB; apply: (cexB _ _ Bbquo); first by rewrite /normal sTGK KsNTG.
exact: (T_B (reflectB _ BbH)).
Qed.

Lemma T_Bs_devel : forall hT (H:{group hT}), Bs H ->
  forall gT (G : {group gT}), Bs G <-> T G :=: G.
Proof.
move=> hT H BsH gT G; split; last first.
  by move/group_inj=>eq; move:(T_B BsH G); rewrite eq.
move=> BsG; apply/eqP; rewrite eqEsubset; apply/andP; split; rewrite bigprodGE.
  by rewrite gen_subG; apply/bigcupsP=> H0; case/andP=> _.
by rewrite sub_gen //; apply: bigcup_sup; rewrite subxx andbT; apply/reflectB.
Qed.

Lemma T_idem : Idemp T.
Proof.
move=> gT G /=.
case e: (existsb H:{group gT}, Bbool H).
  move/idP: e; move/existsP; case=> /= H; move/reflectB=> BsH.
  by move: (T_B BsH G); move/(T_Bs_devel BsH).
suff noBs : (forall gT (H:{group gT}), Bs H -> False).
  by rewrite !(noBstrivT noBs).
move=> hT H BsH; case: (elimF existsP e); exists 1%G.
by apply/reflectB; apply: (cquoisom1 _ _ BsH).
Qed.

Lemma T_Cs_devel : forall hT (H:{group hT}), Bs H ->
  forall gT (G : {group gT}), Cs G <-> T G :=: 1%G.
Proof.
move=> hT H BsH gT G; split.
  move:(T_B BsH G)=>BsTG; move/hCBr'; move/(_ _ _ BsTG).
  move/(_ (idm_morphism (T G))); rewrite morphim_idm ?subxx //.
  (* TOFIX : Ugh ! Tsub !*)
  by move: (bgFunc_clos bgFunc_T G)=>/= TsubG; move/(_ TsubG).
move=> trivTG; apply: hBrC'=> hT0 H0 BsH0 f sfH0G.
apply/trivgP; rewrite -trivTG bigprodGE sub_gen //.
apply:bigcup_sup; rewrite sfH0G andbT; apply/reflectB.
move: (gFunc_cont gFunc_T f); move:(BsH0); move/(T_Bs_devel BsH0 H0)=>-> /=.
move/(conj (bgFunc_clos bgFunc_T (f @* H0))); move/andP; rewrite -eqEsubset /=.
by move/eqP; move/(T_Bs_devel BsH0).
Qed.

End EquivalenceTheorem4.

End Torsion.

Unset Implicit Arguments.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O E Eprime U A B C : Universe, ((wd_ U O /\ (wd_ U E /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ O U /\ (wd_ U Eprime /\ (wd_ A O /\ (wd_ B O /\ (col_ O E U /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C /\ (col_ O U A /\ (col_ O U B /\ (col_ O U C /\ col_ O Eprime A)))))))))))))))) -> col_ O E Eprime)).
Proof.
  time tac.
Qed.

End FOFProblem.