Require Import Coq.Logic.Classical_Prop.
Require Import Coq.Classes.Morphisms.
Require Export TypeConstructor.
Require Import Nontermination.
Require Import LeastFixedPoint.
Open Scope code_scope.

(** * Types as closures *)

(** We follow Dana Scott's types-as-closures idiom from \cite{scott1976data}.
    *)

(** ** Properties of types *)

Notation "x :: a" := (code_ap a x == x)%code : code_scope.

Definition closure {Var : Set} (a : Code Var) := I [= a /\ a o a == a.

Instance closure_proper_eq (Var : Set) :
  Proper (code_eq ==> iff) (@closure Var).
Proof.
  simpl_relation; unfold closure; split; intros [Hn Hi]; split;
  (rewrite -> H || rewrite <- H); auto.
Qed.

Lemma nondecreasing_idempotent (Var : Set) (a : Code Var) :
 I [= a -> a o a [= a -> a o a == a.
Proof.
  intros Hi Hr; split; auto.
  rewrite <- Hi at 2; beta_eta.
Qed.
Hint Resolve nondecreasing_idempotent.

Lemma closure_weak (Var : Set) (a : Code Var) :
 I [= a -> a o a [= a -> closure a.
Proof.
  unfold closure; intros; split; auto.
Qed.

(* ------------------------------------------------------------------------ *)
(** ** [V] is the type of all types *)

Lemma V1_nondecreasing (Var : Set) (a : Code Var) : I [= V * a.
Proof.
  simpl; unfold V; fold (@Y Var).
  eta_expand as x; code_simpl; rewrite code_eq_y; code_simpl; auto.
Qed.

Lemma V1_idempotent (Var : Set) (a : Code Var) : (V * a) o (V * a) == (V * a).
Proof.
  split.
    unfold V; fold (@Y Var).
    eta_expand; beta_simpl.
    admit. (* TODO *)
  apply V_as_limit; intro n; induction n; simpl.
    rewrite <- (V1_nondecreasing _ a); beta_eta.
  rewrite IHn.
  rewrite code_eq_v at 3.
  rewrite pi_j_right.
  eta_expand; beta_simpl; auto.
Qed.
Hint Rewrite V1_idempotent : code_simpl.

Lemma V1_idempotent' (Var : Set) (a x : Code Var) :
  V * a * (V * a * x) == V * a * x.
Proof.
  rewrite <- beta_b; rewrite V1_idempotent; reflexivity.
Qed.
Hint Rewrite V1_idempotent' : code_simpl.

Lemma V_nondecreasing (Var : Set) : I [= (V : Code Var).
Proof.
  eta_expand.
  rewrite code_eq_v; rewrite pi_j_right.
  rewrite code_eq_v; rewrite pi_j_left.
  beta_eta.
Qed.
Hint Resolve V_nondecreasing.

Lemma forall_inhab (Var : Set) (a p q : Code Var) :
  (a :: V) ->
  (forall x, x :: a -> p * x [= q * x) ->
  (p o a [= q o a).
Proof.
  intros Ha H.
  eta_expand as x; beta_simpl.
  assert (exists x', a * x = x') as Ex.
    exists (a * x); auto.
  destruct Ex as [x' Ex]; rewrite Ex.
  assert (x' :: a) as Hx.
    rewrite <- Ex; rewrite <- Ha; code_simpl; auto.
  apply H; auto.
Qed.

Ltac forall_inhab :=
  apply forall_inhab;
  [code_simpl; reflexivity | ].

Ltac sub_case_le f H :=
  apply (code_sub_le f) in H;
  simpl in H;
  rewrite <- H;
  tauto.

Lemma V_idempotent (Var : Set) : V o V == (V : Code Var).
Proof.
  apply nondecreasing_idempotent; auto.
  eta_expand as a; rewrite beta_b.
  apply V_as_limit; intro n; induction n; simpl.
    unfold V; fold (@Y Var).
    eta_expand as x; code_simpl; rewrite code_eq_y; code_simpl; auto.
   rewrite IHn.
   apply V1_idempotent.
Qed.
Hint Rewrite V_idempotent : code_simpl.

Lemma V_closure (Var : Set) : closure (V : Code Var).
Proof.
  split; [apply V_nondecreasing | apply V_idempotent].
Qed.

Inductive V_fixes {Var : Set} : Code Var -> Prop :=
  V_fixes_intro (x : Code Var) : closure x -> V_fixes x.
Hint Constructors V_fixes.

Instance V_fixes_proper (Var : Set) : Proper (code_eq ==> iff) (@V_fixes Var).
Proof.
  intros x x' xx'; split; intro Hc; inversion Hc; apply V_fixes_intro;
  [rewrite <- xx' | rewrite xx']; auto.
Qed.

Lemma V_sound (Var : Set) (x : Code Var) : x :: V -> V_fixes x.
Proof.
  intros Hfix; apply V_fixes_intro.
  assert (I [= x).
    rewrite <- Hfix; rewrite code_eq_v; auto.
  split; auto.
  rewrite <- Hfix at 3; rewrite code_eq_v; rewrite Hfix.
  split; auto.
  apply code_le_j_ub; auto.
  rewrite <- H; beta_eta.
Qed.

Lemma V_complete (Var : Set) (x : Code Var) : V_fixes x -> x :: V.
Proof.
  intros [a [Hn Hi]].
  split.
    unfold V; fold (@Y Var); beta_simpl.
    apply Y_lfp; beta_simpl.
    apply code_le_join; split; [auto | rewrite Hi; auto].
  rewrite <- V_nondecreasing; beta_eta.
Qed.

Corollary V_fixes_closure (Var : Set) (a : Code Var) : closure a -> a :: V.
Proof.
  intro H; apply V_complete; apply V_fixes_intro; auto.
Qed.

Theorem V_inhab (Var : Set) (x : Code Var) : x :: V <-> V_fixes x.
Proof.
  split; [apply V_sound | apply V_complete].
Qed.

Lemma V_V (Var : Set) : V :: (V : Code Var).
Proof.
  apply V_inhab; apply V_fixes_intro; apply V_closure.
Qed.
Hint Rewrite V_V : code_simpl.

(* ------------------------------------------------------------------------ *)
(** Next some lemmas about inhabinants of V. *)

Lemma V_V1 (Var : Set) (a : Code Var) : V * (V * a) == V * a.
Proof.
  apply V_fixes_closure; split; [apply V1_nondecreasing | apply V1_idempotent].
Qed.
Hint Rewrite V_V1 : code_simpl.

Lemma V1_inhab (Var : Set) (a x : Code Var) : a * x [= x <-> x :: V * a.
Proof.
  split.
    intro H; split.
      apply V1_as_limit; unfold limit_le_code.
      intro n; induction n; simpl; auto.
      beta_simpl; rewrite IHn; auto.
    rewrite <- V1_nondecreasing; beta_simpl; auto.
  intro Hf.
  rewrite <- Hf at 2; rewrite <- V_nondecreasing; beta_eta.
Qed.

Lemma V1_inhab_top (Var : Set) (a : Code Var) : TOP :: V * a.
Proof.
  split; auto; rewrite <- V1_nondecreasing; code_simpl; auto.
Qed.
Hint Rewrite V1_inhab_top : code_simpl.

(* ------------------------------------------------------------------------ *)
(** ** [I] is the largest type, the type of everyting *)

Lemma I_nondecreasing (Var : Set) : I [= (I : Code Var).
Proof.
  auto.
Qed.

Lemma I_idempotent (Var : Set) : I o I == (I : Code Var).
Proof.
  beta_eta.
Qed.
Hint Rewrite I_idempotent : code_simpl.

Lemma V_I (Var : Set) : I :: (V : Code Var).
Proof.
  apply V_fixes_closure;
  split; [apply I_nondecreasing | apply I_idempotent].
Qed.
Hint Rewrite V_I : code_simpl.

Inductive I_fixes {Var : Set} : Code Var -> Prop :=
  I_fixes_intro x : I_fixes x.
Hint Constructors I_fixes.

Instance I_fixes_proper (Var : Set) : Proper (code_eq ==> iff) (@I_fixes Var).
Proof.
  simpl_relation; auto.
Qed.

Theorem I_inhab (Var : Set) (x : Code Var) : x :: I <-> I_fixes x.
Proof.
  beta_reduce; firstorder.
Qed.

(* ------------------------------------------------------------------------ *)
(** ** [TOP] is the smallest type, inhabited only by [TOP] *)

Lemma TOP_nondecreasing (Var : Set) : I [= (TOP : Code Var).
Proof.
  auto.
Qed.

Lemma TOP_idempotent (Var : Set) : TOP o TOP == (TOP : Code Var).
Proof.
  beta_eta.
Qed.
Hint Rewrite TOP_idempotent : code_simpl.

Lemma V_TOP (Var : Set) : TOP :: (V : Code Var).
Proof.
  apply V_fixes_closure;
  split; [apply TOP_nondecreasing | apply TOP_idempotent].
Qed.
Hint Rewrite V_TOP : code_simpl.

Inductive TOP_fixes : ClosedCode -> Prop :=
  | TOP_fixes_eq x y : x == y -> TOP_fixes x -> TOP_fixes y
  | TOP_fixes_top : TOP_fixes TOP.
Hint Constructors TOP_fixes.

Instance TOP_fixes_proper : Proper (code_eq ==> iff) TOP_fixes.
Proof.
  intros x y xy; split; [idtac | apply symmetry in xy];
  intro H; induction H; eauto.
Qed.

(* main theorem *)

Theorem TOP_sound (x : ClosedCode) : x :: TOP -> TOP_fixes x.
Proof.
  intros H; code_simpl in H; rewrite <- H; auto.
Qed.

Theorem TOP_inhab (x : ClosedCode) : x :: TOP <-> TOP_fixes x.
Proof.
  split.
    apply TOP_sound.
  code_simpl.
  intro H; induction H; code_simpl; auto.
  rewrite <- H; auto.
Qed.

Theorem TOP_ind (Var : Set) (p q : Code Var) :
  p * TOP [= q * TOP ->
  p o TOP [= q o TOP.
Proof.
  intro Htop; eta_expand as x; code_simpl; auto.
Qed.

(* ------------------------------------------------------------------------ *)
(** ** [P] is a powertype operator *)

(** [P] acts as both a unary subtype operation
    and a binary type intersection operation.
    We start with the unary version. *)

Section P.
  Context {Var : Set}.
  Let a := make_var Var 0.
  Let a' := make_var Var 1.
  Definition P := Eval compute in close_var (\a, \a', V * (a || a')).
End P.

Lemma P_idem (Var : Set) (a : Code Var) : P * a * a == V * a.
Proof.
  unfold P; fold (@V Var); beta_simpl; rewrite code_eq_j_idem; auto.
Qed.
Hint Rewrite P_idem : code_simpl.

Lemma P_comm (Var : Set) (a b : Code Var) : P * a * b == P * b * a.
Proof.
  unfold P; fold (@V Var); beta_simpl; rewrite code_le_j_sym at 1; auto.
Qed.

Lemma code_le_v_join (Var : Set ) (a b : Code Var) :
  V * a || V * b [= V * (a || b).
Proof.
  apply code_le_j_ub; auto.
Qed.

Lemma code_eq_v_join (Var : Set ) (a b : Code Var) :
  V * (V * a || V * b) == V * (a || b).
Proof.
  split.
    rewrite code_le_v_join; code_simpl; auto.
  rewrite <- (beta_left (beta_right beta_i)).
  rewrite <- (beta_right (beta_right beta_i)).
  monotonicity.
Qed.

Lemma code_eq_v_idem (Var : Set ) (a : Code Var) : V * (V * a) == V * a.
Proof.
  rewrite <- beta_b; rewrite V_idempotent; auto.
Qed.
Hint Rewrite code_eq_v_join : code_simpl.

Lemma code_eq_v_join_left (Var : Set ) (a b : Code Var) :
  V * (V * a || b) == V * (a || b).
Proof.
  rewrite <- code_eq_v_join; rewrite code_eq_v_idem.
  rewrite <- (code_eq_v_join _ a b); reflexivity.
Qed.
Hint Rewrite code_eq_v_join_left : code_simpl.

Lemma code_eq_v_join_right (Var : Set ) (a b : Code Var) :
  V * (a || V * b) == V * (a || b).
Proof.
  rewrite <- code_eq_v_join; rewrite code_eq_v_idem.
  rewrite <- (code_eq_v_join _ a b); reflexivity.
Qed.
Hint Rewrite code_eq_v_join_right : code_simpl.

Lemma P_assoc (Var : Set) (a b c : Code Var) :
  P * a * (P * b * c) == P * (P * a * b) * c.
Proof.
  unfold P; fold (@V Var); code_simpl.
  rewrite code_eq_j_assoc; reflexivity.
Qed.

Lemma P1_nondecreasing (Var : Set) (a : Code Var) : I [= P * a.
Proof.
  unfold P; fold (@V Var).
  eta_expand; rewrite beta_b; rewrite beta_b; rewrite pi_j_right.
  monotonicity.
Qed.

Lemma P1_idempotent (Var : Set) (a : Code Var) : (P * a) o (P * a) == P * a.
Proof.
  apply nondecreasing_idempotent.
    apply P1_nondecreasing.
  eta_expand as b; rewrite beta_b.
Admitted.
Hint Rewrite P1_idempotent : code_simpl.

Lemma V_P1 (Var : Set) (a : Code Var) : V * (P * a) == P * a.
Proof.
  apply V_fixes_closure;
  split; [apply P1_nondecreasing | apply P1_idempotent].
Qed.
Hint Rewrite V_P1 : code_simpl.

Inductive P1_fixes {Var : Set} (a : Code Var) : Code Var -> Prop :=
  P1_fixes_intro a' : V_fixes a' -> a [= a' -> P1_fixes a a'.

Instance P1_fixes_proper (Var : Set) :
  Proper (code_eq ==> code_eq ==> iff) (@P1_fixes Var).
Proof.
  intros a a' aa' x x' xx'; split; intro Ha.
    destruct Ha as [x Hv Hl]; apply P1_fixes_intro;
    rewrite <- xx'; try rewrite <- aa'; auto.
  destruct Ha as [x' Hv Hl]; apply P1_fixes_intro;
  rewrite xx'; try rewrite aa'; auto.
Qed.

Lemma P1_sound (Var : Set) (a x : Code Var) : x :: P * a -> P1_fixes a x.
Proof.
  unfold  closure, P; fold (@V Var); beta_simpl.
  intros Hfix.
  assert (I [= x).
    rewrite <- Hfix; rewrite code_eq_v; auto.
  assert (a [= x) as ax.
    rewrite <- Hfix; rewrite <- V_nondecreasing; beta_simpl; auto.
  rewrite code_le_j_sym in Hfix.
  rewrite <- (proj1 (code_le_eq_j Var a x)) in Hfix; auto.
  split; auto.
    apply V_sound; auto.
Qed.

Lemma P1_complete (Var : Set) (a x : Code Var) : P1_fixes a x -> x :: P * a.
Proof.
  unfold  closure; intros [b Hf Hl]; split.
  - rewrite Hl.
    unfold P; fold (@V Var); beta_simpl.
    rewrite code_le_j_idem.
    apply V_complete in Hf; rewrite Hf; auto.
  - assert (b == I * b) as eq; beta_simpl; auto; rewrite eq at 1.
    monotonicity.
    apply (P1_nondecreasing _ a).
Qed.

Theorem P1_inhab (Var : Set) (a x : Code Var) : x :: P * a <-> P1_fixes a x.
Proof.
  split; [apply P1_sound | apply P1_complete].
Qed.

(* ------------------------------------------------------------------------ *)
(** Next we treat [P] as a binary type intersection operation. *)

Lemma P2_nondecreasing (Var : Set) (a b : Code Var) : I [= P * a * b.
Proof.
  unfold P; fold (@V Var); beta_simpl; apply V1_nondecreasing.
Qed.

Lemma P2_idempotent (Var : Set) (a b : Code Var) :
  (P * a * b) o (P * a * b) == P * a * b.
Proof.
  unfold P; fold (@V Var); beta_simpl; apply V1_idempotent.
Qed.
Hint Rewrite P1_idempotent : code_simpl.

Lemma V_P2 (Var : Set) (a b : Code Var) : V * (P * a * b) == P * a * b.
Proof.
  apply V_fixes_closure;
  split; [apply P2_nondecreasing | apply P2_idempotent].
Qed.
Hint Rewrite V_P2 : code_simpl.

Inductive P2_fixes {Var : Set} (a b : Code Var) : Code Var -> Prop :=
  P2_fixes_intro x : x :: V * a -> x :: V * b -> P2_fixes a b x.
  (* Which of these forms is most convenient?
  P2_fixes_intro x : a * x [= x -> b * x [= x -> P2_fixes a b x.
  P2_fixes_intro x : V1_fixes a x -> V1_fixes b x -> P2_fixes a b x.
  *)

Instance P2_fixes_proper (Var : Set) :
  Proper (code_eq ==> code_eq ==> code_eq ==> iff) (@P2_fixes Var).
Proof.
  intros a a' aa' b b' bb' x x' xx'; split; intro Ha; inversion Ha.
  - apply P2_fixes_intro.
    + rewrite <- aa'; rewrite <- xx'; auto.
    + rewrite <- bb'; rewrite <- xx'; auto.
  - apply P2_fixes_intro.
    + rewrite aa'; rewrite xx'; auto.
    + rewrite bb'; rewrite xx'; auto.
Qed.

Lemma P2_sound (Var : Set) (a b x : Code Var) :
  x :: P * a * b -> P2_fixes a b x.
Proof.
  unfold P; fold (@V Var); code_simpl.
  intro Hab; apply V1_inhab in Hab.
  code_simpl in Hab; apply code_le_join in Hab; destruct Hab as [Ha Hb].
  apply P2_fixes_intro; apply V1_inhab; auto.
Qed.

Lemma P2_complete (Var : Set) (a b x : Code Var) :
  P2_fixes a b x -> x :: P * a * b.
Proof.
  intro H; destruct H as [x Ha Hb].
  unfold P; fold (@V Var); code_simpl.
  rewrite <- V1_inhab in Ha.
  rewrite <- V1_inhab in Hb.
  apply V1_inhab; code_simpl; auto.
Qed.

Theorem P2_inhab (Var : Set) (a b x : Code Var) :
  x :: P * a * b <-> P2_fixes a b x.
Proof.
  split; [apply P2_sound | apply P2_complete].
Qed.

Lemma P2_inhab_le (Var : Set) (a b x : Code Var) :
  (a * x [= x /\ b * x [= x) <-> x :: P * a * b.
Proof.
  split.
    intros [Ha Hb].
    unfold P; fold (@V Var); beta_simpl.
    apply V1_inhab; beta_simpl; auto.
  intro Hab.
  unfold P in Hab; fold (@V Var) in Hab; beta_simpl in Hab.
  apply V1_inhab in Hab; beta_simpl in Hab.
  apply code_le_join in Hab; destruct Hab as [Ha Hb].
  split; auto.
Qed.

Lemma P2_fixes_simpl (Var : Set) (a b x : Code Var) :
  (x :: V * a /\ x :: V * b) <-> x :: P * a * b.
Proof.
  rewrite <- P2_inhab_le; repeat rewrite V1_inhab; tauto.
Qed.

(* ------------------------------------------------------------------------ *)
(** ** Closures constructed as [A * f] *)

(* EXPERIMENTAL *)

Inductive type_body {Var : Set} : nat -> nat -> Code (nat + Var) -> Set :=
  | type_body_eq n n' x y : x == y -> type_body n n' x -> type_body n n' y
  | type_body_atom n n' v : v :: V -> type_body n n' v
  | type_body_var n n' : type_body n n' (code_var (inl n'))
  | type_body_exp n n' a b :
      type_body n' n a -> type_body n n' b -> type_body n n' (exp * a * b)
  (*
  | type_body_fix n n' f :
      (forall x, type_body n n' x -> type_body n n' (f * x)) ->
      type_body n n' (Y * f)
  *)
.

Lemma V_fixes_constructed_types
  (Var : Set) (n n' : nat) (f : Code (nat + Var)) :
  type_body n n' f -> (\\code_var (inl n), code_var (inl n'); f) :: V.
Proof.
  intro H; induction H.
  - simpl; rewrite <- c; auto.
  - admit.
  - admit.
  - admit.
Qed.

(* ------------------------------------------------------------------------ *)
(** ** [div] is inhabited by [{BOT, TOP}] *)

Lemma div_nondecreasing (Var : Set) : I [= (div : Code Var).
Proof.
  unfold div; apply V1_nondecreasing.
Qed.

Lemma div_idempotent (Var : Set) : div o div == (div : Code Var).
Proof.
  unfold div; apply V1_idempotent.
Qed.
Hint Rewrite div_idempotent : code_simpl.

Lemma V_div (Var : Set) : V * div == (div : Code Var).
Proof.
  apply V_fixes_closure;
  split; [apply div_nondecreasing | apply div_idempotent].
Qed.
Hint Rewrite V_div : code_simpl.

Lemma div_inhab_bot (Var : Set) : BOT :: (div : Code Var).
Proof.
  apply div_bot.
Qed.
Hint Rewrite div_inhab_bot : code_simpl.

Lemma div_inhab_top (Var : Set) : TOP :: (div : Code Var).
Proof.
  rewrite <- V_div; apply V1_inhab_top.
Qed.
Hint Rewrite div_inhab_top : code_simpl.

(* FIXME this only works for closed codes *)
Inductive div_fixes : ClosedCode -> Prop :=
  | div_fixes_eq x y : x == y -> div_fixes x -> div_fixes y
  | div_fixes_bot : div_fixes BOT
  | div_fixes_top : div_fixes TOP.
Hint Constructors div_fixes.

Instance div_fixes_proper : Proper (code_eq ==> iff) div_fixes.
Proof.
  intros x y xy; split; [idtac | apply symmetry in xy];
  intro H; induction H; eauto.
Qed.

Theorem div_sound (x : ClosedCode) : x :: div -> div_fixes x.
Proof.
  intros H.
  case_le (x [= BOT) as H'.
  - assert (x == BOT) as eq. split; auto. rewrite eq; auto.
  - rewrite <- H; clear H.
    rewrite <- conv_nle_bot in H'.
    apply conv_div_top in H'; rewrite H'; auto.
Qed.

Theorem div_inhab (x : ClosedCode) : x :: div <-> div_fixes x.
Proof.
  split.
    apply div_sound.
  intro H; induction H; code_simpl; auto.
  rewrite <- H; auto.
Qed.

(* We also have an algebraic definition of [div] as nil. *)

Section div'.
  Context {Var : Set}.
  Let a := make_var Var 0.
  Let a' := make_var Var 1.
  Definition div' := Eval compute in close_var (\\a,a'; a').
End div'.

Lemma div'_div (Var : Set) : (div' : Code Var) = div' o div.
Proof.
Admitted.

Lemma div_algebraic (Var : Set) : div' == (div : Code Var).
  (* TODO use tactic wlog_closed or assume_closed *)
  rewrite div'_div; eta_expand as x; beta_simpl.
  set (y := div * x); subst; assert (y = div * x) as eq; auto.
  assert (y :: div) as Hf.
    rewrite eq; rewrite <- beta_b; rewrite div_idempotent; auto.
  (* OLD
  apply div_inhab in Hf; induction Hf.
  - admit. (* TODO *)
  - unfold div'; code_simpl. admit. (* TODO: case BOT *)
  - unfold div'; code_simpl. admit. (* TODO: case TOP *)
  *)
Admitted.

(* this is an ugly proof. why not show [div' : div --> I] then [case_le]? *)
Lemma div_algebraic' (Var : Set) : div' == (div : Code Var).
Proof.
  (* TODO use tactic wlog_closed or assume_closed *)
  split.
  - eta_expand as x.
    case_le (x [= BOT).
    + assert (x == BOT) as eq; try (split; auto).
      rewrite eq; clear x eq H.
      unfold div'; fold (@Y Var); code_simpl.
      admit. (* TODO lfp argument *)
    + rewrite <- conv_nle_bot in H.
      (* OLD
      apply conv_div_top in H; rewrite H; auto.
      *)
      admit.
  - unfold div, div'; fold (@Y Var).
    rewrite pi_j_left at 1.
    rewrite pi_j_left at 1.
    rewrite pi_j_right at 1.
    beta_simpl.
    (* FIXME it looks like A may need to use Y instead of V *)
Admitted.

Theorem div_ind (Var : Set) (p q : Code Var) :
  p * TOP [= q * TOP ->
  p * BOT [= q * BOT ->
  p o div [= q o div.
Proof.
  intros Htop Hbot Hi; forall_inhab; intros x Hx.
  code_le_weaken; intros ys f; simpl.
  apply (code_sub_eq f) in Hx; code_simpl in Hx.
  apply div_inhab in Hx; induction Hx; auto.
  - rewrite <- H; apply IHHx.
  - sub_case_le f Hbot.
  - sub_case_le f Htop.
Qed.

(* ------------------------------------------------------------------------ *)
(** ** [semi] represents Sierpinsky space, inhabited by [{BOT, I, TOP}] *)

Section semi.
  Context {Var : Set}.
  Let a := make_var Var 0.
  Let a' := make_var Var 1.
  Definition semi := Eval compute in close_var (\\a,a'; a --> a').
End semi.

Lemma semi_closed (Var Var' : Set) (f : Var -> Code Var') : semi @ f = semi.
Proof.
  simpl; fold (@semi Var'); reflexivity.
Qed.
Hint Rewrite semi_closed : code_simpl.

Lemma A_exp_semi (Var : Set) : A * exp == (semi : Code Var).
Proof.
  unfold A, exp, semi; beta_simpl; auto.
Qed.

Lemma semi_nondecreasing (Var : Set) : I [= (semi : Code Var).
Proof.
  unfold semi.
  eta_expand.
  rewrite code_eq_y.
  rewrite beta_j_ap.
  rewrite beta_k.
  repeat rewrite pi_j_left.
  beta_eta.
Qed.

Lemma semi_idempotent (Var : Set) : semi o semi == (semi : Code Var).
Proof.
  rewrite <- A_exp_semi.
  split.
  - rewrite A_simpl at 3; rewrite code_eq_y; rewrite <- A_simpl.
    unfold A_step; code_simpl.
    rewrite pi_j_right; rewrite pi_j_left.
    (* TODO argue pairwise [s o s', r' o r] *)
    admit.
  - rewrite A_simpl at 2; rewrite code_eq_y; rewrite <- A_simpl.
    unfold A_step; code_simpl.
    rewrite pi_j_left; rewrite pi_j_left; rewrite pi_j_left.
    unfold exp at 2; unfold pair.
    beta_eta.
Qed.
Hint Rewrite semi_idempotent : code_simpl.

Lemma semi_idempotent' (Var : Set) (x : Code Var) : semi * x :: semi.
Proof.
  rewrite <- beta_b; rewrite semi_idempotent; reflexivity.
Qed.
Hint Rewrite semi_idempotent' : code_simpl.

(* TODO prove by [apply V_fixes_constructed_types] *)
Lemma V_semi (Var : Set) : semi :: (V : Code Var).
Proof.
  apply V_fixes_closure;
  split; [apply semi_nondecreasing | apply semi_idempotent].
Qed.
Hint Rewrite V_semi : code_simpl.

Ltac A_fixes :=
  let r := fresh "r" in
  let s := fresh "s" in
  let Hsr := fresh "H" s r in
  match goal with
    | [Var : Set |- _ :: ?a] =>

      fold (@A Var); split;
      [ apply A_fixes; intros r s Hsr; unfold a
      | rewrite <- V_semi; unfold a; auto]
  end.

Lemma semi_inhab_bot (Var : Set) : BOT :: (semi : Code Var).
Proof.
  fold (@A Var); split.
    apply A_fixes; intros r s Hsr; unfold semi.
    eta_expand; code_simpl.
    rewrite (code_le_bot _ (r * BOT)) at 1.
    rewrite <- beta_b.
    rewrite Hsr; auto.
  rewrite <- semi_nondecreasing; beta_simpl; auto.
Qed.
Hint Rewrite semi_inhab_bot : code_simpl.

Lemma semi_inhab_i (Var : Set) : I :: (semi : Code Var).
Proof.
  fold (@A Var); split.
    apply A_fixes; intros r s Hsr; unfold semi.
    eta_expand; code_simpl.
    rewrite <- beta_b.
    rewrite Hsr; code_simpl; auto.
  rewrite <- semi_nondecreasing; beta_simpl; auto.
Qed.
Hint Rewrite semi_inhab_i : code_simpl.

Lemma semi_inhab_top (Var : Set) : TOP :: (semi : Code Var).
Proof.
  rewrite <- V_semi; apply V1_inhab_top.
Qed.
Hint Rewrite semi_inhab_top : code_simpl.

Inductive semi_fixes : ClosedCode -> Prop :=
  | semi_fixes_eq x y : x == y -> semi_fixes x -> semi_fixes y
  | semi_fixes_bot : semi_fixes BOT
  | semi_fixes_i : semi_fixes I
  | semi_fixes_top : semi_fixes TOP.
Hint Constructors semi_fixes.

Instance semi_fixes_proper : Proper (code_eq ==> iff) semi_fixes.
Proof.
  intros x y xy; split; [idtac | apply symmetry in xy];
  intro H; induction H; eauto.
Qed.

(* main theorem *)

Theorem semi_sound (x : ClosedCode) : x :: semi -> semi_fixes x.
Proof.
  intros H.
  case_le (x [= BOT) as Hbot.
    assert (x == BOT) as eq; [split; auto|].
    rewrite eq; auto.
  case_le (x [= I) as Hi.
    assert (x == I) as eq; [split; [|rewrite <- H; apply A_repairs]; auto|].
    rewrite eq; auto.
  assert (x == TOP) as eq; [split; [|rewrite <- H; apply A_raises]; auto|].
  rewrite eq; auto.
Qed.

Theorem semi_inhab (x : ClosedCode) : x :: semi <-> semi_fixes x.
Proof.
  split.
    apply semi_sound.
  intro H; induction H; code_simpl; auto.
  rewrite <- H; auto.
Qed.

Theorem semi_ind (Var : Set) (p q : Code Var) :
  p * TOP [= q * TOP ->
  p * BOT [= q * BOT ->
  p * I [= q * I ->
  p o semi [= q o semi.
Proof.
  intros Htop Hbot Hi; forall_inhab; intros x Hx.
  code_le_weaken; intros ys f; simpl.
  apply (code_sub_eq f) in Hx; code_simpl in Hx.
  apply semi_inhab in Hx; induction Hx; auto.
  - rewrite <- H; apply IHHx.
  - sub_case_le f Hbot.
  - sub_case_le f Hi.
  - sub_case_le f Htop.
Qed.

(* ------------------------------------------------------------------------ *)
(** ** [boool] is the type of ambiguous boolean values *)
(** [boool] is inhabited by [K], [F], and [J].
    We will later define a stricter [bool] that raises [J] to [TOP],
    i.e., raising an error on ambiguous values. *)

Section boool.
  Context {Var : Set}.
  Let a := make_var Var 0.
  Let a' := make_var Var 1.
  Definition boool := Eval compute in close_var (\\a,a'; a --> a --> a').
End boool.

Lemma boool_nondecreasing (Var : Set) : I [= (boool : Code Var).
Proof.
  unfold boool.
  eta_expand.
  rewrite code_eq_y.
  rewrite pi_j_left.
  rewrite beta_k.
  rewrite beta_j_ap.
  repeat rewrite pi_j_left.
  beta_simpl.
  beta_eta.
Qed.

Lemma boool_idempotent (Var : Set) : boool o boool == (boool : Code Var).
Proof.
  eta_expand as a; rewrite beta_b.
Admitted.
Hint Rewrite boool_idempotent : code_simpl.

Lemma V_boool (Var : Set) : boool :: (V : Code Var).
Proof.
  apply V_fixes_closure;
  split; [apply boool_nondecreasing | apply boool_idempotent].
Qed.
Hint Rewrite V_boool : code_simpl.

Lemma boool_inhab_bot (Var : Set) : BOT :: (boool : Code Var).
Proof.
  fold (@A Var); split.
    apply A_fixes; intros r s Hsr; unfold boool.
    eta_expand; eta_expand; rewrite beta_s; code_simpl.
    rewrite (code_le_bot _ (r * BOT)) at 1.
    rewrite <- beta_b.
    rewrite Hsr; auto.
  auto.
Qed.
Hint Rewrite boool_inhab_bot : code_simpl.

Lemma boool_inhab_k (Var : Set) : K :: (boool : Code Var).
Proof.
  fold (@A Var); split.
    apply A_fixes; intros r s Hsr; unfold boool.
    eta_expand; eta_expand; rewrite beta_s; code_simpl.
    rewrite <- beta_b.
    rewrite Hsr; auto.
  rewrite <- boool_nondecreasing; beta_eta.
Qed.
Hint Rewrite boool_inhab_k : code_simpl.

Lemma boool_inhab_f (Var : Set) : K * I :: (boool : Code Var).
Proof.
  fold (@A Var); split.
    apply A_fixes; intros r s Hsr; unfold boool.
    eta_expand; eta_expand; rewrite beta_s; code_simpl.
    rewrite <- beta_b.
    rewrite Hsr; auto.
  rewrite <- boool_nondecreasing; beta_eta.
Qed.
Hint Rewrite boool_inhab_f : code_simpl.

Lemma boool_inhab_j (Var : Set) : J :: (boool : Code Var).
Proof.
  fold (@A Var); split.
    apply A_fixes; intros r s Hsr; unfold boool.
    eta_expand; eta_expand; rewrite beta_s; code_simpl.
    rewrite code_le_j_ap_right.
    rewrite <- beta_b.
    rewrite Hsr; auto.
  rewrite <- boool_nondecreasing; beta_eta.
Qed.
Hint Rewrite boool_inhab_j : code_simpl.

Lemma boool_inhab_top (Var : Set) : TOP :: (boool : Code Var).
Proof.
  rewrite <- V_boool; apply V1_inhab_top.
Qed.
Hint Rewrite boool_inhab_top : code_simpl.

Inductive boool_fixes : ClosedCode -> Prop :=
  | boool_fixes_eq x y : x == y -> boool_fixes x -> boool_fixes y
  | boool_fixes_bot : boool_fixes BOT
  | boool_fixes_k : boool_fixes K
  | boool_fixes_f : boool_fixes (K * I)
  | boool_fixes_j : boool_fixes J
  | boool_fixes_top : boool_fixes TOP.
Hint Constructors boool_fixes.

Instance boool_fixes_proper : Proper (code_eq ==> iff) boool_fixes.
Proof.
  intros x y xy; split; [idtac | apply symmetry in xy];
  intro H; induction H; eauto.
Qed.

Theorem boool_sound (x : ClosedCode) : x :: boool -> boool_fixes x.
Proof.
  intros H.
  case_le (x [= BOT) as Hbot.
    assert (x == BOT) as eq.
      split; auto.
    rewrite eq; auto.
  (* TODO adapt this argument from semi:
  case_le (x [= I) as Hi.
    assert (x == I) as eq.
      split; [|rewrite <- H; apply A_repairs]; auto.
    rewrite eq; auto.
  assert (x == TOP) as eq.
    split; [|rewrite <- H; apply A_raises]; auto.
  rewrite eq; auto.
  *)
Admitted.

Theorem boool_inhab (x : ClosedCode) : x :: boool <-> boool_fixes x.
Proof.
  split.
    apply boool_sound.
  intro H; induction H; code_simpl; auto.
  rewrite <- H; auto.
Qed.

Theorem boool_ind (Var : Set) (p q : Code Var) :
  p * TOP [= q * TOP ->
  p * BOT [= q * BOT ->
  p * K [= q * K ->
  p * (K*I) [= q * (K*I) ->
  p * J [= q * J ->
  p o boool [= q o boool.
Proof.
  intros Htop Hbot Hk Hf Hj; forall_inhab; intros x Hx.
  code_le_weaken; intros ys f; simpl.
  apply (code_sub_eq f) in Hx; code_simpl in Hx.
  apply boool_inhab in Hx; induction Hx; auto.
  - rewrite <- H; apply IHHx.
  - sub_case_le f Hbot.
  - sub_case_le f Hk.
  - sub_case_le f Hf.
  - sub_case_le f Hj.
  - sub_case_le f Htop.
Qed.

(* ------------------------------------------------------------------------ *)
(** ** [bool] is a disambiguated subtype of [boool] *)
(** We narrow the [boool] type to [bool] by disambiguating the unwanted
    inhabitants *)

Section bool.
  Context {Var : Set}.
  Let f := make_var Var 0.
  Let disambiguate := Eval compute in close_var
    (\f, f * (f * K * TOP) * (f * TOP * (K * I))).
  Definition bool := Eval compute in (P * boool * disambiguate).
End bool.

Lemma bool_nondecreasing (Var : Set) : I [= (bool : Code Var).
Proof.
  apply P2_nondecreasing.
Qed.

Lemma bool_idempotent (Var : Set) : bool o bool == (bool : Code Var).
Proof.
  apply P2_idempotent.
Qed.
Hint Rewrite bool_idempotent : code_simpl.

Lemma V_bool (Var : Set) : bool :: (V : Code Var).
Proof.
  apply V_P2.
Qed.
Hint Rewrite V_bool : code_simpl.

Lemma bool_inhab_bot (Var : Set) : BOT :: (bool : Code Var).
Proof.
  unfold bool; fold (@P Var); fold (@boool Var).
  apply P2_inhab_le;
  split; [ apply boool_inhab_bot | beta_reduce; code_simpl; auto ].
Qed.
Hint Rewrite bool_inhab_bot : code_simpl.

Lemma bool_inhab_k (Var : Set) : K :: (bool : Code Var).
Proof.
  unfold bool; fold (@P Var); fold (@boool Var).
  apply P2_inhab_le;
  split; [ apply boool_inhab_k | beta_reduce; code_simpl; auto ].
Qed.
Hint Rewrite bool_inhab_k : code_simpl.

Lemma bool_inhab_f (Var : Set) : K * I :: (bool : Code Var).
Proof.
  unfold bool; fold (@P Var); fold (@boool Var).
  apply P2_inhab_le;
  split; [ apply boool_inhab_f | beta_reduce; code_simpl; auto ].
Qed.
Hint Rewrite bool_inhab_f : code_simpl.

Lemma bool_inhab_top (Var : Set) : TOP :: (bool : Code Var).
Proof.
  rewrite <- V_bool; apply V1_inhab_top.
Qed.
Hint Rewrite bool_inhab_top : code_simpl.

Lemma bool_j_top (Var : Set) : bool * J == (TOP : Code Var).
Proof.
  split; auto.
  unfold bool; fold (@boool Var); fold (@V Var); rewrite <- V_nondecreasing.
  beta_simpl; rewrite pi_j_right.
  rewrite beta_s; rewrite beta_s; code_simpl; auto.
Qed.
Hint Rewrite bool_j_top : code_simpl.

Inductive bool_fixes : ClosedCode -> Prop :=
  | bool_fixes_eq x y : x == y -> bool_fixes x -> bool_fixes y
  | bool_fixes_bot : bool_fixes BOT
  | bool_fixes_k : bool_fixes K
  | bool_fixes_f : bool_fixes (K * I)
  | bool_fixes_top : bool_fixes TOP.
Hint Constructors bool_fixes.

Instance bool_fixes_proper : Proper (code_eq ==> iff) bool_fixes.
Proof.
  intros x y xy; split; [idtac | apply symmetry in xy];
  intro H; induction H; eauto.
Qed.

Lemma code_nle_top_j (Var : Set) : ~ TOP [= (J : Code Var).
Proof.
  intro H.
  apply (code_le_ap_left _ _ _ BOT) in H.
  apply (code_le_ap_left _ _ _ BOT) in H.
  code_simpl in H.
  apply absolute_consistency in H; contradiction H.
Qed.

Theorem bool_sound (x : ClosedCode) : x :: bool -> bool_fixes x.
Proof.
  intro H; set (H' := H);
  unfold bool in H'; fold (@boool Empty_set) in H'; fold (@P Empty_set) in H'.
  apply P2_fixes_simpl in H'; destruct H' as [Hb Hd].
  rewrite V_boool in Hb; rewrite boool_inhab in Hb; induction Hb; auto.
    rewrite <- H0 in *; apply IHHb; auto.
  code_simpl in H; destruct H as [H _].
  apply code_nle_top_j in H; contradiction H.
Qed.

Theorem bool_inhab (x : ClosedCode) : x :: bool <-> bool_fixes x.
Proof.
  split.
    apply bool_sound.
  intro H; induction H; code_simpl; auto.
  rewrite <- H; auto.
Qed.

Theorem bool_ind (Var : Set) (p q : Code Var) :
  p * TOP [= q * TOP ->
  p * BOT [= q * BOT ->
  p * K [= q * K ->
  p * (K*I) [= q * (K*I) ->
  p o bool [= q o bool.
Proof.
  intros Htop Hbot Hk Hf Hj; forall_inhab; intros x Hx.
  code_le_weaken; intros ys f; simpl.
  apply (code_sub_eq f) in Hx; code_simpl in Hx.
  apply bool_inhab in Hx; induction Hx; auto.
  - rewrite <- H; apply IHHx.
  - sub_case_le f Hbot.
  - sub_case_le f Hk.
  - sub_case_le f Hf.
  - sub_case_le f Htop.
Qed.

(* ------------------------------------------------------------------------ *)
(** Products *)

Section FuzzyProd.
  Context {Var : Set}.
  Let u := make_var Var 0.
  Let v := make_var Var 1.
  Let a := make_var Var 2.
  Let a' := make_var Var 3.

  Definition FuzzyProd : Code Var := Eval compute in close_var
    (\u, \v, \\a,a'; (V * u --> V * v --> a) --> a').
End FuzzyProd.

Section Prod.
  Context {Var : Set}.
  Let u := make_var Var 0.
  Let v := make_var Var 1.

  Let disambiguate := (\u, u * pair).
  Let repair := (\u, [BOT, BOT]).

  Definition Prod : Code Var := Eval compute in close_var
    (\u, \v, V * (FuzzyProd * u * v || disambiguate || repair)).
End Prod.

(* ------------------------------------------------------------------------ *)
(** Sums *)

Section inj_left.
  Context {Var : Set}.
  Let x := make_var Var 0.
  Let f := make_var Var 1.
  Let g := make_var Var 2.

  Definition inj_left : Code Var := Eval compute in close_var
    (\x, \f, \g, f * x).
  Definition inj_right : Code Var := Eval compute in close_var
    (\x, \f, \g, g * x).
End inj_left.

Section FuzzySum.
  Context {Var : Set}.
  Let u := make_var Var 0.
  Let v := make_var Var 1.
  Let a := make_var Var 2.
  Let a' := make_var Var 3.

  Definition FuzzySum : Code Var := Eval compute in close_var
    (\u, \v, \\a,a'; (V * u --> a) --> (V * v --> a) --> a').
End FuzzySum.

Section Sum.
  Context {Var : Set}.
  Let u := make_var Var 0.
  Let v := make_var Var 1.

  Let disambiguate := (\u, u * inj_left * inj_right).  (* does this work? *)

  Definition Sum : Code Var := Eval compute in close_var
    (\u, \v, P * (FuzzySum * u * v) * disambiguate).
End Sum.

(* ------------------------------------------------------------------------ *)
(** Church numerals *)

Section succ.
  Context {Var : Set}.
  Let n := make_var Var 0.
  Let f := make_var Var 1.
  Let x := make_var Var 2.

  Definition succ : Code Var := Eval compute in close_var
    (\n, \f, \x, f * (n * f * x) || n * f * (f * x)).
  Definition zero : Code Var := Eval compute in close_var (\f, \x, x).
End succ.

Section FuzzyChurchNat.
  Context {Var : Set}.
  Let a := make_var Var 0.
  Let a' := make_var Var 1.

  Definition FuzzyChurchNat : Code Var := Eval compute in close_var
    (\\a,a'; (a' --> a) --> a --> a').
End FuzzyChurchNat.

Section ChurchNat.
  Context {Var : Set}.

  Let disambiguate : Code Var := [succ, zero].  (* does this work? *)
  Definition ChurchNat : Code Var := P * FuzzyChurchNat * disambiguate.
End ChurchNat.

(* ------------------------------------------------------------------------ *)
(** TODO: additional types

    - [Maybe]
    - [num]
    - [Stream]
*)


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 A B C D : Universe, ((wd_ A B /\ (wd_ C D /\ (col_ A B C /\ col_ A B D))) -> col_ A D C)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import ZArith.
Require Import divsteps_base.

Lemma example724 : ZMap.Empty (N.iter 724 (processDivstep 0x1030596cf6d817d1357f908ef70cdb00b38d047fbba852139babb6c8646fb15b2) state0).
Proof.
apply ZMap.is_empty_2.
vm_cast_no_check (refl_equal true).
Time Qed.


Require Import QArith PArith.
Require Import List.
From Bremen.theories.physics Require Import Frequency.
Import ListNotations.

(* measured in decibel *)
Definition amplitude := Q.

Inductive frequency_amplitude :=
  freq_amp : frequency -> amplitude -> frequency_amplitude.

Notation "A 'Hz' B 'dB'" := (freq_amp A B) (at level 85, right associativity).

Definition frequency_sample := list frequency_amplitude.

Example s1 : frequency_sample := [(10.0 Hz 10 dB); (20.0 Hz 9.0 dB); (30.0 Hz 2 dB)].

Definition is_harmonic (a b : frequency_amplitude) : bool :=
  match a, b with
  | f1 Hz _ dB , f2 Hz _ dB => is_harmonic f1 f2
  end.

(* Noise and overlapping harmonics are not considered, but should be. *)
Definition maximum_one_pitch (s : frequency_sample) : bool :=
  match s with
    | [] => true
    | a :: b => forallb (is_harmonic a) b
  end
.

Definition lowest_frequency_within (f1 f2 : frequency) (s : frequency_sample) : bool :=
  match s with
  | [] => true
  | (f Hz _ dB) :: _ => andb (Qle_bool f1 f) (Qle_bool f f2)
  end.

Fixpoint strength (s : frequency_sample) : Q :=
  match s with
  | [] => 0.0
  | (_ Hz a dB) :: ss => Qplus a (strength ss)
  end.

Definition is_musical (s : frequency_sample) : bool :=
  true.

Eval compute in lowest_frequency_within 9.0 8.0 s1.


Add LoadPath "Analysis/KaisekiNyuumonn" as Analysis.KaisekiNyuumonn.
Add LoadPath "MyAlgebraicStructure" as MyAlgebraicStructure.
Add LoadPath "Tools" as Tools.
Add LoadPath "BasicProperty" as BasicProperty.
Add LoadPath "LibraryExtension" as LibraryExtension.
Add LoadPath "Topology/ShuugouIsouNyuumonn" as Topology.ShuugouIsouNyuumonn.
Add LoadPath "LibraryExtension" as LibraryExtension.
Add LoadPath "Topology/ShuugouIsouNyuumonn" as Topology.ShuugouIsouNyuumonn.

From mathcomp Require Import ssreflect.
Require Import Coq.Program.Basics.
Require Import Coq.Program.Combinators.
Require Import Coq.Sets.Ensembles.
Require Import Coq.Sets.Finite_sets.
Require Import Coq.Sets.Image.
Require Import Coq.Logic.ClassicalDescription.
Require Import Coq.Logic.IndefiniteDescription.
Require Import Tools.MySum.
Require Import Tools.BasicTools.
Require Import BasicProperty.MappingProperty.
Require Import LibraryExtension.DatatypesExtension.
Require Import Topology.ShuugouIsouNyuumonn.ShuugouIsouNyuumonn1.
Require Import Topology.ShuugouIsouNyuumonn.ShuugouIsouNyuumonn1AC.
Require Import Topology.ShuugouIsouNyuumonn.ShuugouIsouNyuumonn2.

Lemma Theorem_2_dash : forall (A B : Type), (exists (f : A -> B), Injective f) -> (exists (g : A -> B), Surjective g) -> SameCard A B.
Proof.
move=> A B H1 H2.
apply (Theorem_2 A B H1 (Theorem_7_corollary_2 A B H2)).
Qed.

Lemma Theorem_2_dash_dash : forall (A B : Type), (exists (f : A -> B), Surjective f) -> (exists (g : B -> A), Surjective g) -> SameCard A B.
Proof.
move=> A B H1 H2.
apply (Theorem_2 A B (Theorem_7_corollary_2 B A H2) (Theorem_7_corollary_2 A B H1)).
Qed.

Lemma cardLeDef3 : forall (A B : Type), A -> cardLe A B <-> exists (f : B -> A), Surjective f.
Proof.
move=> A B a.
apply conj.
move=> H1.
apply (Theorem_7_corollary_1 A B a H1).
move=> H1.
apply (Theorem_7_corollary_2 B A H1).
Qed.

Lemma Theorem_4 : forall (T : Type), ~ Finite T (Full_set T) -> exists (A : Ensemble T), SameCard {t : T | In T A t} nat.
Proof.
move=> T H1.
suff: (forall (A : {B : Ensemble T | ~ Finite T B}), {t : T | In T (proj1_sig A) t}).
move=> H2.
suff: (forall (A : Ensemble T) (t : T), In T A t -> ~ Finite T A -> ~ Finite T (Subtract T A t)).
move=> H3.
suff: (let F := fix F (n : nat) : (T * {B : Ensemble T | ~ Finite T B}) := match n with
  | O => (proj1_sig (H2 (exist (fun (A : Ensemble T) => ~ Finite T A) (Full_set T) H1)), (exist (fun (A : Ensemble T) => ~ Finite T A) (Subtract T (Full_set T) (proj1_sig (H2 (exist (fun (A : Ensemble T) => ~ Finite T A) (Full_set T) H1)))) (H3 (Full_set T) (proj1_sig (H2 (exist (fun (A : Ensemble T) => ~ Finite T A) (Full_set T) H1))) (proj2_sig (H2 (exist (fun (A : Ensemble T) => ~ Finite T A) (Full_set T) H1))) H1)))
  | S n => (proj1_sig (H2 (snd (F n))), (exist (fun (A : Ensemble T) => ~ Finite T A) (Subtract T (proj1_sig (snd (F n))) (proj1_sig (H2 (snd (F n))))) (H3 (proj1_sig (snd (F n))) (proj1_sig (H2 (snd (F n)))) (proj2_sig (H2 (snd (F n)))) (proj2_sig (snd (F n))))))
end in exists (A : Ensemble T), SameCard {t : T | In T A t} nat).
apply.
move=> F.
exists (Im nat T (Full_set nat) (fun (n : nat) => fst (F n))).
apply Formula_1_2.
exists (fun (m : nat) => exist (Im nat T (Full_set nat) (fun (n : nat) => fst (F n))) (fst (F m)) (Im_intro nat T (Full_set nat) (fun (n : nat) => fst (F n)) m (Full_intro nat m) (fst (F m)) eq_refl)).
apply InjSurjBij.
suff: (forall (m1 m2 : nat), m1 <= m2 -> Included T (proj1_sig (snd (F m2))) (proj1_sig (snd (F m1)))).
move=> H4.
suff: (forall (m1 m2 : nat), m1 < m2 -> fst (F m1) <> fst (F m2)).
move=> H5 m1 m2 H6.
elim (le_or_lt m1 m2).
move=> H7.
elim (le_lt_or_eq m1 m2 H7).
move=> H8.
elim (H5 m1 m2 H8).
suff: (fst (F m1) = proj1_sig (exist (Im nat T (Full_set nat) (fun (n : nat) => fst (F n))) (fst (F m1)) (Im_intro nat T (Full_set nat) (fun (n : nat) => fst (F n)) m1 (Full_intro nat m1) (fst (F m1)) eq_refl))).
move=> H9.
rewrite H9.
rewrite H6.
reflexivity.
reflexivity.
apply.
move=> H7.
elim (H5 m2 m1 H7).
suff: (fst (F m1) = proj1_sig (exist (Im nat T (Full_set nat) (fun (n : nat) => fst (F n))) (fst (F m1)) (Im_intro nat T (Full_set nat) (fun (n : nat) => fst (F n)) m1 (Full_intro nat m1) (fst (F m1)) eq_refl))).
move=> H8.
rewrite H8.
rewrite H6.
reflexivity.
reflexivity.
move=> m1 m2 H5 H6.
suff: (~ In T (proj1_sig (snd (F m1))) (fst (F m1))).
elim.
suff: (exists (n : nat), m2 = S n).
elim.
move=> n H7.
apply (H4 m1 n).
apply (le_S_n m1 n).
rewrite - H7.
apply H5.
rewrite H6.
rewrite H7.
apply (proj2_sig (H2 (snd (F n)))).
suff: (m1 < m2).
elim m2.
move=> H7.
elim (le_not_lt O m1 (le_0_n m1) H7).
move=> k H7 H8.
exists k.
reflexivity.
apply H5.
elim m1.
move=> H7.
apply (proj2 H7).
apply (In_singleton T).
move=> n H7 H8.
apply (proj2 H8).
apply (In_singleton T).
move=> m1 m2.
elim.
move=> t H4.
apply H4.
move=> m3 H4 H5 t H6.
apply (H5 t).
apply (proj1 H6).
move=> t.
suff: (exists (n : nat), fst (F n) = proj1_sig t).
elim.
move=> n H4.
exists n.
apply sig_map.
apply H4.
elim (proj2_sig t).
move=> x H4 y H5.
exists x.
rewrite H5.
reflexivity.
move=> A t H3 H4 H5.
apply H4.
suff: (A = Add T (Subtract T A t) t).
move=> H6.
rewrite H6.
apply (Union_is_finite T (Subtract T A t) H5 t).
move=> H7.
apply (proj2 H7).
apply (In_singleton T t).
apply Extensionality_Ensembles.
apply conj.
move=> a H6.
elim (classic (t = a)).
move=> H7.
right.
rewrite H7.
apply (In_singleton T a).
move=> H7.
left.
apply conj.
apply H6.
move=> H8.
apply H7.
elim H8.
reflexivity.
move=> a.
elim.
move=> t0 H6.
apply (proj1 H6).
move=> t0.
elim.
apply H3.
move=> A.
apply constructive_indefinite_description.
apply NNPP.
move=> H2.
apply (proj2_sig A).
suff: (proj1_sig A = Empty_set T).
move=> H3.
rewrite H3.
apply (Empty_is_finite T).
apply Extensionality_Ensembles.
apply conj.
move=> t H3.
elim H2.
exists t.
apply H3.
move=> t.
elim.
Qed.

Lemma Theorem_4_corollary : forall (C : CardT), InfiniteCard C -> CardLe (Card nat) C.
Proof.
move=> C H1.
elim (proj2_sig C).
move=> T H2.
rewrite - (CardLeNature nat T (Card nat) C (ERref Type CardEquivalence nat)).
apply (proj2 (cardLeDef2 nat T)).
elim (Theorem_4 T).
move=> B H3.
exists B.
apply (Formula_1_2 {t : T | In T B t} nat H3).
move=> H3.
apply H1.
elim (finite_cardinal T (Full_set T) H3).
move=> n H4.
exists n.
suff: (C = EquivalenceRelationQuotientFunction Type CardEquivalence T).
move=> H5.
rewrite H5.
apply (Formula_66_1 T (Count n)).
apply (Formula_1_2 (Count n) T (proj2 (CountCardinalBijective T n) H4)).
apply sig_map.
apply H2.
rewrite H2.
apply (Formula_1_1 T).
Qed.

Lemma Theorem_5_2_1 : forall (T : Type) (Ti : T -> Type), cardLe T nat -> (forall (t : T), cardLe (Ti t) nat) -> cardLe (sumT T Ti) nat.
Proof.
move=> T Ti.
elim.
move=> f H1 H2.
suff: (forall (t : T), {fi : Ti t -> nat | Injective fi}).
move=> H3.
elim (Formula_1_2 nat (nat * nat) Example_3).
move=> g H4.
exists (fun (x : sumT T Ti) => match x with
  | inT t tf => g (f t, proj1_sig (H3 t) tf)
end).
suff: (forall (t1 t2 : T), (t1 = t2) -> forall (tf1 : Ti t1) (tf2 : Ti t2), proj1_sig (H3 t1) tf1 = proj1_sig (H3 t2) tf2 -> inT T Ti t1 tf1 = inT T Ti t2 tf2).
move=> H5 x1 x2.
elim x1.
move=> t1 tf1.
elim x2.
move=> t2 tf2 H6.
apply (H5 t1 t2).
apply (H1 t1 t2).
suff: (f t1 = fst (f t1, proj1_sig (H3 t1) tf1)).
move=> H7.
rewrite H7.
rewrite (BijInj (nat * nat) nat g H4 (f t1, proj1_sig (H3 t1) tf1) (f t2, proj1_sig (H3 t2) tf2) H6).
reflexivity.
reflexivity.
suff: (proj1_sig (H3 t1) tf1 = snd (f t1, proj1_sig (H3 t1) tf1)).
move=> H7.
rewrite H7.
rewrite (BijInj (nat * nat) nat g H4 (f t1, proj1_sig (H3 t1) tf1) (f t2, proj1_sig (H3 t2) tf2) H6).
reflexivity.
reflexivity.
move=> t1 t2 H5.
rewrite H5.
move=> tf1 tf2 H6.
rewrite (proj2_sig (H3 t2) tf1 tf2 H6).
reflexivity.
move=> t.
apply constructive_indefinite_description.
apply (H2 t).
Qed.

Lemma Theorem_5_2_2 : forall (T : Type) (Ti : T -> Type), cardLe T nat -> (forall (t : T), cardLe (Ti t) nat) -> (exists (t : T), SameCard (Ti t) nat) -> SameCard (sumT T Ti) nat.
Proof.
move=> T Ti H1 H2 H3.
apply (Theorem_2 (sumT T Ti) nat).
apply (Theorem_5_2_1 T Ti H1 H2).
elim H3.
move=> t H4.
elim (Formula_1_2 (Ti t) nat H4).
move=> f H5.
exists (fun (n : nat) => inT T Ti t (f n)).
move=> n1 n2 H6.
apply (BijInj nat (Ti t) f H5 n1 n2).
suff: (f n1 = let temp := inT T Ti t (f n1) in match temp with
  | inT t0 tf0 => match excluded_middle_informative (t0 = t) with
    | left H => TypeEqConvert (Ti t0) (Ti t) (f_equal Ti H) tf0
    | right _ => f n1
  end
end).
move=> H7.
rewrite H7.
rewrite H6.
simpl.
elim (excluded_middle_informative (t = t)).
move=> H8.
apply (TypeEqConvertNature (Ti t) (f_equal Ti H8) (f n2)).
elim.
reflexivity.
simpl.
elim (excluded_middle_informative (t = t)).
move=> H7.
rewrite (TypeEqConvertNature (Ti t) (f_equal Ti H7) (f n1)).
reflexivity.
elim.
reflexivity.
Qed.

Lemma Theorem_6 : forall (T : Type) (A : Ensemble T), ~ Finite T (Complement T A) -> cardLe {t : T | In T A t} nat -> SameCard T {t : T | ~ In T A t}.
Proof.
move=> T A H1 H2.
suff: (exists (B : Ensemble T), SameCard {t : T | ~ In T A t /\ In T B t} nat).
elim.
move=> B H3.
suff: (SameCard {t : T | In T A t \/ In T B t} {t : T | ~ In T A t /\ In T B t}).
elim.
move=> f.
elim.
move=> g H4.
suff: (forall (t : T), ~ (In T A t \/ In T B t) -> ~ In T A t).
move=> H5.
exists (fun (t : T) => match excluded_middle_informative (In T A t \/ In T B t) with
  | left H => exist (fun (t : T) => ~ In T A t) (proj1_sig (f (exist (fun (t : T) => In T A t \/ In T B t) t H))) (proj1 (proj2_sig (f (exist (fun (t : T) => In T A t \/ In T B t) t H))))
  | right H => exist (fun (t : T) => ~ In T A t) t (H5 t H)
end).
exists (fun (t : {t : T | ~ In T A t}) => match excluded_middle_informative (In T B (proj1_sig t)) with
  | left H => proj1_sig (g (exist (fun (t : T) => ~ In T A t /\ In T B t) (proj1_sig t) (conj (proj2_sig t) H)))
  | right _ => proj1_sig t
end).
apply conj.
move=> x.
elim (excluded_middle_informative (In T A x \/ In T B x)).
move=> H6.
simpl.
elim (excluded_middle_informative (In T B (proj1_sig (f (exist (fun (t : T) => In T A t \/ In T B t) x H6))))).
move=> H7.
suff: ((exist (fun (t : T) => ~ In T A t /\ In T B t) (proj1_sig (f (exist (fun (t : T) => In T A t \/ In T B t) x H6))) (conj (proj1 (proj2_sig (f (exist (fun (t : T) => In T A t \/ In T B t) x H6)))) H7)) = (f (exist (fun (t : T) => In T A t \/ In T B t) x H6))).
move=> H8.
rewrite H8.
rewrite (proj1 H4).
reflexivity.
apply sig_map.
reflexivity.
elim.
apply (proj2 (proj2_sig (f (exist (fun (t : T) => In T A t \/ In T B t) x H6)))).
move=> H6.
elim (excluded_middle_informative (In T B (proj1_sig (exist (fun (t : T) => ~ In T A t) x (H5 x H6))))).
move=> H7.
elim H6.
right.
apply H7.
move=> H7.
reflexivity.
move=> y.
elim (excluded_middle_informative (In T B (proj1_sig y))).
move=> H6.
elim (excluded_middle_informative (In T A (proj1_sig (g (exist (fun (t : T) => ~ In T A t /\ In T B t) (proj1_sig y) (conj (proj2_sig y) H6)))) \/ In T B (proj1_sig (g (exist (fun (t : T) => ~ In T A t /\ In T B t) (proj1_sig y) (conj (proj2_sig y) H6)))))).
move=> H7.
suff: ((exist (fun (t : T) => In T A t \/ In T B t) (proj1_sig (g (exist (fun (t : T) => ~ In T A t /\ In T B t) (proj1_sig y) (conj (proj2_sig y) H6)))) H7) = (g (exist (fun (t : T) => ~ In T A t /\ In T B t) (proj1_sig y) (conj (proj2_sig y) H6)))).
move=> H8.
rewrite H8.
rewrite (proj2 H4).
apply sig_map.
reflexivity.
apply sig_map.
reflexivity.
elim.
apply (proj2_sig (g (exist (fun (t : T) => ~ In T A t /\ In T B t) (proj1_sig y) (conj (proj2_sig y) H6)))).
move=> H6.
elim (excluded_middle_informative (In T A (proj1_sig y) \/ In T B (proj1_sig y))).
move=> H7.
elim H6.
elim H7.
move=> H8.
elim ((proj2_sig y) H8).
apply.
move=> H7.
apply sig_map.
reflexivity.
move=> t H5 H6.
apply H5.
left.
apply H6.
apply (Formula_1_3 {t : T | In T A t \/ In T B t} nat {t : T | ~ In T A t /\ In T B t}).
apply (Theorem_2 {t : T | In T A t \/ In T B t} nat).
elim (Formula_1_2 nat (nat * nat) Example_3).
move=> f H4.
elim H2.
move=> g H5.
elim H3.
move=> h H6.
suff: (forall (t : {t : T | In T A t \/ In T B t}), ~ In T A (proj1_sig t) -> ~ In T A (proj1_sig t) /\ In T B (proj1_sig t)).
move=> H7.
exists (fun (t : {t : T | In T A t \/ In T B t}) => match excluded_middle_informative (In T A (proj1_sig t)) with
  | left H => f (g (exist A (proj1_sig t) H), O)
  | right H => f (h (exist (fun (t : T) => ~ In T A t /\ In T B t) (proj1_sig t) (H7 t H)), 1)
end).
move=> t1 t2.
elim (excluded_middle_informative (In T A (proj1_sig t1))).
move=> H8.
elim (excluded_middle_informative (In T A (proj1_sig t2))).
move=> H9 H10.
apply sig_map.
suff: (proj1_sig t1 = proj1_sig (exist A (proj1_sig t1) H8)).
move=> H11.
rewrite H11.
rewrite (H5 (exist A (proj1_sig t1) H8) (exist A (proj1_sig t2) H9)).
reflexivity.
suff: (g (exist A (proj1_sig t1) H8) = fst (g (exist A (proj1_sig t1) H8), 0)).
move=> H12.
rewrite H12.
rewrite (BijInj (nat * nat) nat f H4 (g (exist A (proj1_sig t1) H8), 0) (g (exist A (proj1_sig t2) H9), 0) H10).
reflexivity.
reflexivity.
reflexivity.
move=> H9 H10.
elim (lt_irrefl (snd (g (exist A (proj1_sig t1) H8), 0))).
rewrite {2} (BijInj (nat * nat) nat f H4 (g (exist A (proj1_sig t1) H8), 0) (h (exist (fun t : T => ~ In T A t /\ In T B t) (proj1_sig t2) (H7 t2 H9)), 1) H10).
apply (le_n 1).
move=> H8.
elim (excluded_middle_informative (In T A (proj1_sig t2))).
move=> H9 H10.
elim (lt_irrefl (snd (h (exist (fun (t : T) => ~ In T A t /\ In T B t) (proj1_sig t1) (H7 t1 H8)), 1))).
rewrite {1} (BijInj (nat * nat) nat f H4 (h (exist (fun (t : T) => ~ In T A t /\ In T B t) (proj1_sig t1) (H7 t1 H8)), 1) (g (exist A (proj1_sig t2) H9), 0) H10).
apply (le_n 1).
move=> H9 H10.
apply sig_map.
suff: (proj1_sig t1 = proj1_sig (exist (fun (t : T) => ~ In T A t /\ In T B t) (proj1_sig t1) (H7 t1 H8))).
move=> H11.
rewrite H11.
rewrite (BijInj {t : T | ~ In T A t /\ In T B t} nat h H6 (exist (fun (t : T) => ~ In T A t /\ In T B t) (proj1_sig t1) (H7 t1 H8)) (exist (fun (t : T) => ~ In T A t /\ In T B t) (proj1_sig t2) (H7 t2 H9))).
reflexivity.
suff: (h (exist (fun (t : T) => ~ In T A t /\ In T B t) (proj1_sig t1) (H7 t1 H8)) = fst (h (exist (fun (t : T) => ~ In T A t /\ In T B t) (proj1_sig t1) (H7 t1 H8)), 1)).
move=> H12.
rewrite H12.
rewrite (BijInj (nat * nat) nat f H4 (h (exist (fun (t : T) => ~ In T A t /\ In T B t) (proj1_sig t1) (H7 t1 H8)), 1) (h (exist (fun (t : T) => ~ In T A t /\ In T B t) (proj1_sig t2) (H7 t2 H9)), 1) H10).
reflexivity.
reflexivity.
reflexivity.
move=> t H7.
apply conj.
apply H7.
elim (proj2_sig t).
move=> H8.
elim (H7 H8).
apply.
elim (Formula_1_2 {t : T | ~ In T A t /\ In T B t} nat H3).
move=> f H4.
suff: (forall (n : nat), In T A (proj1_sig (f n)) \/ In T B (proj1_sig (f n))).
move=> H5.
exists (fun (n : nat) => exist (fun (t : T) => In T A t \/ In T B t) (proj1_sig (f n)) (H5 n)).
move=> n1 n2 H6.
apply (BijInj nat {t : T | ~ In T A t /\ In T B t} f H4 n1 n2).
apply sig_map.
suff: (proj1_sig (f n1) = proj1_sig (exist (fun (t : T) => In T A t \/ In T B t) (proj1_sig (f n1)) (H5 n1))).
move=> H7.
rewrite H7.
rewrite H6.
reflexivity.
reflexivity.
move=> n.
right.
apply (proj2 (proj2_sig (f n))).
apply (Formula_1_2 {t : T | ~ In T A t /\ In T B t} nat H3).
elim (Theorem_4 {t : T | In T (Complement T A) t}).
move=> B.
elim.
move=> f H3.
exists (fun (t : T) => match excluded_middle_informative (In T A t) with
  | left _ => False
  | right H => In {t : T | In T (Complement T A) t} B (exist (Complement T A) t H)
end).
suff: (forall (t : {t : T | ~ In T A t /\ In T (fun (t0 : T) => match excluded_middle_informative (In T A t0) with
  | left _ => False
  | right H => In {t1 : T | In T (Complement T A) t1} B (exist (Complement T A) t0 H)
end) t}), In T (Complement T A) (proj1_sig t)).
move=> H4.
suff: (forall (t : {t : T | ~ In T A t /\ In T (fun (t0 : T) => match excluded_middle_informative (In T A t0) with
  | left _ => False
  | right H => In {t1 : T | In T (Complement T A) t1} B (exist (Complement T A) t0 H)
end) t}), In {t0 : T | In T (Complement T A) t0} B (exist (Complement T A) (proj1_sig t) (H4 t))).
move=> H5.
exists (fun (t : {t : T | ~ In T A t /\ In T (fun (t0 : T) => match excluded_middle_informative (In T A t0) with
  | left _ => False
  | right H => In {t1 : T | In T (Complement T A) t1} B (exist (Complement T A) t0 H)
end) t}) => f (exist B (exist (Complement T A) (proj1_sig t) (H4 t)) (H5 t))).
elim H3.
move=> g H6.
suff: (forall (n : nat), In T (fun (t : T) => ~ In T A t /\ In T (fun (t0 : T) => match excluded_middle_informative (In T A t0) with
  | left _ => False
  | right H => In {t1 : T | In T (Complement T A) t1} B (exist (Complement T A) t0 H)
end) t) (proj1_sig (proj1_sig (g n)))).
move=> H7.
exists (fun (n : nat) => exist (fun (t : T) => ~ In T A t /\ In T (fun (t0 : T) => match excluded_middle_informative (In T A t0) with
  | left _ => False
  | right H => In {t1 : T | In T (Complement T A) t1} B (exist (Complement T A) t0 H)
end) t) (proj1_sig (proj1_sig (g n))) (H7 n)).
apply conj.
move=> x.
apply sig_map.
simpl.
rewrite (proj1 H6).
reflexivity.
move=> y.
simpl.
rewrite - {6} (proj2 H6 y).
apply (f_equal f).
apply sig_map.
apply sig_map.
reflexivity.
move=> n.
unfold In.
apply conj.
apply (proj2_sig (proj1_sig (g n))).
elim (excluded_middle_informative (A (@proj1_sig T (fun (t : T) => Complement T A t) (@proj1_sig (@sig T (fun (t : T) => Complement T A t)) (fun (t : @sig T (fun (t : T) => Complement T A t)) => B t) (g n))))).
move=> H7.
elim (proj2_sig (proj1_sig (g n)) H7).
move=> H7.
suff: ((exist (Complement T A) (proj1_sig (proj1_sig (g n))) H7) = proj1_sig (g n)).
move=> H8.
rewrite H8.
apply (proj2_sig (g n)).
apply sig_map.
reflexivity.
move=> t.
suff: (In T (fun (t0 : T) => match excluded_middle_informative (In T A t0) with
  | left _ => False
  | right H => In {t1 : T | In T (Complement T A) t1} B (exist (Complement T A) t0 H)
end) (proj1_sig t)).
unfold In.
elim (excluded_middle_informative (A (@proj1_sig T (fun (t0 : T) => and (not (A t0)) match excluded_middle_informative (A t0) return Prop with
  | left _ => False
  | right H => B (@exist T (Complement T A) t0 H)
end) t))).
move=> H5.
elim.
move=> H5.
suff: (H5 = H4 t).
move=> H6.
rewrite H6.
apply.
apply proof_irrelevance.
apply (proj2 (proj2_sig t)).
move=> t.
apply (proj1 (proj2_sig t)).
move=> H3.
apply H1.
apply (proj2 (FiniteSigSame T (Complement T A)) H3).
Qed.

Lemma Theorem_6_corollary_1 : forall (T1 T2 : Type), ~ Finite T1 (Full_set T1) -> cardLe T2 nat -> SameCard T1 (T1 + T2).
Proof.
move=> T1 T2 H1 H2.
elim (Theorem_6 (T1 + T2) (fun (t : T1 + T2) => match t with
  | inl _ => False
  | inr _ => True
end)).
move=> f.
elim.
move=> g H3.
exists (fun (t : T1) => g (exist (fun (t0 : T1 + T2) => ~ match t0 with
  | inl _ => False
  | inr _ => True
end) (inl t) (fun (b : False) => b))).
exists (let temp : forall (t : T1 + T2), ~ In (T1 + T2) (fun (t0 : T1 + T2) => match t0 with
  | inl _ => False
  | inr _ => True
end) t -> T1 := (fun (t : T1 + T2) => match t with
  | inl t0 => fun (H : False -> False) => t0
  | inr t0 => fun (H : True -> False) => match H I with
  end
end) in fun (t : T1 + T2) => temp (proj1_sig (f t)) (proj2_sig (f t))).
apply conj.
move=> t.
simpl.
rewrite (proj2 H3).
reflexivity.
move=> t.
rewrite - {2} (proj1 H3 t).
apply (f_equal g).
apply sig_map.
simpl.
suff: (forall (t1 : T1 + T2) (H : ~ In (T1 + T2) (fun (t1 : T1 + T2) => match t1 with
  | inl _ => False
  | inr _ => True
end) t1), inl (match t1 as t0 return (~ In (T1 + T2) (fun (t1 : T1 + T2) => match t1 with
    | inl _ => False
    | inr _ => True
  end) t0 -> T1) with
  | inl t0 => fun (_ : False -> False) => t0
  | inr _ => fun (H : True -> False) => match H I return T1 with
  end
end H) = t1).
move=> H4.
apply (H4 (proj1_sig (f t)) (proj2_sig (f t))).
elim.
move=> t1 H4.
reflexivity.
move=> t2 H4.
elim (H4 I).
move=> H3.
apply H1.
apply (proj1 (CountFiniteBijective T1)).
elim (proj2 (CountFiniteBijective {t : T1 + T2 | In (T1 + T2) (Complement (T1 + T2) (fun (t : T1 + T2) => match t with
  | inl _ => False
  | inr _ => True
end)) t})).
move=> N.
elim.
move=> f.
elim.
move=> g H4.
exists N.
exists (let temp : forall (t : T1 + T2), ~ In (T1 + T2) (fun (t0 : T1 + T2) => match t0 with
  | inl _ => False
  | inr _ => True
end) t -> T1 := (fun (t : T1 + T2) => match t with
  | inl t0 => fun (H : False -> False) => t0
  | inr t0 => fun (H : True -> False) => match H I with
  end
end) in fun (m : Count N) => temp (proj1_sig (f m)) (proj2_sig (f m))).
exists (fun (t : T1) => g (exist (fun (t0 : T1 + T2) => ~ match t0 with
  | inl _ => False
  | inr _ => True
end) (inl t) (fun (b : False) => b))).
apply conj.
move=> x.
rewrite - {2} (proj1 H4 x).
apply (f_equal g).
apply sig_map.
simpl.
suff: (forall (t1 : T1 + T2) (H : ~ In (T1 + T2) (fun (t1 : T1 + T2) => match t1 with
  | inl _ => False
  | inr _ => True
end) t1), inl (match t1 as t0 return (~ In (T1 + T2) (fun (t1 : T1 + T2) => match t1 with
    | inl _ => False
    | inr _ => True
  end) t0 -> T1) with
  | inl t0 => fun (_ : False -> False) => t0
  | inr _ => fun (H : True -> False) => match H I return T1 with
  end
end H) = t1).
move=> H5.
apply (H5 (proj1_sig (f x)) (proj2_sig (f x))).
elim.
move=> t1 H5.
reflexivity.
move=> t2 H5.
elim (H5 I).
move=> y.
simpl.
rewrite (proj2 H4).
reflexivity.
apply (proj1 (FiniteSigSame (T1 + T2) (Complement (T1 + T2) (fun (t : T1 + T2) => match t with
  | inl _ => False
  | inr _ => True
end))) H3).
elim H2.
move=> f H3.
exists (let temp : forall (t : T1 + T2), (match t with
  | inl _ => False
  | inr _ => True
end) -> T2 := (fun (t : T1 + T2) => match t with
  | inl _ => fun (H : False) => match H with
  end
  | inr t0 => fun (H : True) => t0
end) in fun (t : {t : T1 + T2 | In (T1 + T2) (fun (t0 : T1 + T2) => match t0 with
  | inl _ => False
  | inr _ => True
end) t}) => f (temp (proj1_sig t) (proj2_sig t))).
move=> t1 t2.
simpl.
suff: (forall (t1 t2 : T1 + T2) (H1 : In (T1 + T2) (fun (t0 : T1 + T2) => match t0 with
  | inl _ => False
  | inr _ => True
end) t1) (H2 : In (T1 + T2) (fun (t0 : T1 + T2) => match t0 with
  | inl _ => False
  | inr _ => True
end) t2), match t1 as t return (match t with
    | inl _ => False
    | inr _ => True
  end -> T2) with
  | inl _ => fun (H : False) => match H return T2 with
  end
  | inr t0 => fun (_ : True) => t0
end H1 = match t2 as t return (match t with
    | inl _ => False
    | inr _ => True
  end -> T2) with
  | inl _ => fun (H : False) => match H return T2 with
  end
  | inr t0 => fun (_ : True) => t0
end H2 -> t1 = t2).
move=> H4 H5.
apply sig_map.
apply (H4 (proj1_sig t1) (proj1_sig t2) (proj2_sig t1) (proj2_sig t2)).
apply H3.
apply H5.
elim.
move=> t3 t4.
elim.
move=> t3.
elim.
move=> t4 H4.
elim.
move=> t4 H5 H6 H7.
rewrite H7.
reflexivity.
Qed.

Lemma Theorem_6_corollary_2 : forall (T : Type), ~ Finite T (Full_set T) -> exists (A : Ensemble T), Strict_Included T A (Full_set T) /\ SameCard T {t : T | In T A t}.
Proof.
move=> T H1.
suff: (exists (t : T), True).
elim.
move=> t H2.
exists (Complement T (Singleton T t)).
apply conj.
apply conj.
move=> t0 H3.
apply (Full_intro T t0).
move=> H3.
suff: (In T (Complement T (Singleton T t)) t).
move=> H4.
apply H4.
apply (In_singleton T t).
rewrite H3.
apply (Full_intro T t).
apply (Theorem_6 T (Singleton T t)).
move=> H3.
apply H1.
suff: (Full_set T = Add T (Complement T (Singleton T t)) t).
move=> H4.
rewrite H4.
apply (Union_is_finite T (Complement T (Singleton T t)) H3 t).
move=> H5.
apply H5.
apply (In_singleton T t).
apply Extensionality_Ensembles.
apply conj.
move=> t0 H4.
elim (classic (t = t0)).
move=> H5.
rewrite H5.
right.
apply (In_singleton T t0).
move=> H5.
left.
move=> H6.
apply H5.
elim H6.
reflexivity.
move=> t0 H4.
apply (Full_intro T t0).
exists (fun (t1 : {t0 : T | In T (Singleton T t) t0}) => O).
move=> t1 t2 H3.
apply sig_map.
elim (proj2_sig t1).
elim (proj2_sig t2).
reflexivity.
apply NNPP.
move=> H2.
apply H1.
suff: (Full_set T = Empty_set T).
move=> H3.
rewrite H3.
apply (Empty_is_finite T).
apply Extensionality_Ensembles.
apply conj.
move=> t.
elim H2.
exists t.
apply I.
move=> t H3.
apply (Full_intro T t).
Qed.

Lemma Theorem_9 : forall (T : Type) (tf : T -> Type) (C : CardT), (forall (t : T), Card (tf t) = C) -> Card (sumT T tf) = CardMult C (Card T).
Proof.
move=> T1 tf C H1.
elim (EquivalenceRelationQuotientInhabited Type CardEquivalence C).
move=> T2 H2.
suff: (proj1_sig C T2).
move=> H3.
suff: (forall (t : T1), {ft : tf t -> T2 | Bijective ft}).
move=> H4.
suff: (forall (t : T1), {gt : T2 -> tf t | (forall (x : tf t), gt (proj1_sig (H4 t) x) = x) /\ (forall (y : T2), proj1_sig (H4 t) (gt y) = y)}).
move=> H5.
rewrite - (CardMultNature T2 T1 C (Card T1)).
apply (proj1 (Formula_66_1 (sumT T1 tf) (T2 * T1))).
exists (fun (x : sumT T1 tf) => match x with
  | inT t x0 => (proj1_sig (H4 t) x0, t)
end).
exists (fun (x : T2 * T1) => inT T1 tf (snd x) (proj1_sig (H5 (snd x)) (fst x))).
apply conj.
elim.
move=> t x.
rewrite (proj1 (proj2_sig (H5 t)) x).
reflexivity.
elim.
move=> a b.
rewrite (proj2 (proj2_sig (H5 b)) a).
reflexivity.
apply H3.
apply (Formula_1_1 T1).
move=> t.
apply constructive_indefinite_description.
apply (proj2_sig (H4 t)).
move=> t.
apply constructive_indefinite_description.
apply (proj2 (Formula_66_1 (tf t) T2)).
rewrite (H1 t).
apply H2.
rewrite H2.
apply (Formula_1_1 T2).
Qed.

Lemma Formula_83 : forall (T : Type) (tf : T -> Type) (C : CardT), (forall (t : T), Card (tf t) = C) -> Card (forall (t : T), tf t) = CardPow C (Card T).
Proof.
move=> T1 tf C H1.
elim (EquivalenceRelationQuotientInhabited Type CardEquivalence C).
move=> T2 H2.
suff: (proj1_sig C T2).
move=> H3.
suff: (forall (t : T1), {ft : tf t -> T2 | Bijective ft}).
move=> H4.
suff: (forall (t : T1), {gt : T2 -> tf t | (forall (x : tf t), gt (proj1_sig (H4 t) x) = x) /\ (forall (y : T2), proj1_sig (H4 t) (gt y) = y)}).
move=> H5.
rewrite - (CardPowNature T2 T1 C (Card T1)).
apply (proj1 (Formula_66_1 (forall (t : T1), tf t) (T1 -> T2))).
exists (fun (x : forall (t : T1), tf t) (t : T1) => proj1_sig (H4 t) (x t)).
exists (fun (x : T1 -> T2) (t : T1) => proj1_sig (H5 t) (x t)).
apply conj.
move=> x.
apply functional_extensionality_dep.
move=> t.
apply (proj1 (proj2_sig (H5 t)) (x t)).
move=> y.
apply functional_extensionality.
move=> t.
apply (proj2 (proj2_sig (H5 t)) (y t)).
apply H3.
apply (Formula_1_1 T1).
move=> t.
apply constructive_indefinite_description.
apply (proj2_sig (H4 t)).
move=> t.
apply constructive_indefinite_description.
apply (proj2 (Formula_66_1 (tf t) T2)).
rewrite (H1 t).
apply H2.
rewrite H2.
apply (Formula_1_1 T2).
Qed.


Require Import list_examples.

Definition sum_code :=
  Push 0::Swap::While (Dup 0::nil)
    (Swap::Over::Load::Binop Zplus::Swap::Plus1++Load::nil)
  ::Drop::Ret::nil.

Definition sum := fold_right Zplus 0.
Inductive sum_spec : Spec cfg :=
  sum_claim : forall H l, fun_claim sum_spec
  "sum" sum_code
    1 (fun p => asP H (rep_list l p))
    1 (fun n => constraint (n = sum l) :* litP H)
 |loop_claim : forall H n l, loop_claim sum_spec
  0 sum_code
    2 (fun p k => constraint (k = n) :* asP H (rep_list l p))
    1 (fun k => constraint (k = n + sum l) :* litP H).

Lemma sum_proof : sound stack_step sum_spec.
Proof. list_solver. Qed.


Require Import CtxFibrancy.Overture CtxFibrancy.Path_eq.
Set Universe Polymorphism.

Module Export FibrantReplacement.

  Private Inductive repl (X: Type) : Type :=
  | η : X -> repl X.

  Arguments η {_} _.

  Axiom fibrant_repl : forall X, Fibrant (repl X).

  Definition repl_ind {X} (P: repl X -> Type) {FibP: PFibrant P}
             (H: forall x : X, P (η x))
    : forall z, P z.
  Proof.
    destruct z. apply H.
  Defined.
End FibrantReplacement.

Definition repl_rec {X P} {FibP: Fibrant P} (H: X -> P)
  : repl X -> P
  := repl_ind (λ _ : repl X, P) H.

Axiom pfibrant_repl_rec : ∀ A (P: A -> Type) {FibP: PFibrant P}, PFibrant (repl_rec P).

Definition repl_sigma {A} (B: repl A -> Type) {FibB: PFibrant B}
  : sigT B -> repl (sigT (B o η)).
Proof.
  intros [x y]; revert x y.
  use repl_ind; cbn. intros x y. exact (η (x; y)).
Defined.

Definition repl_J' {A} {x: A} (P: (∃ y: A, η x = η y) -> Type)
           {FibP: PFibrant P}
           {y: A} (p: η x = η y)
  : P (x; 1) -> P (y; p).
Proof.
  transparent assert (P' : ((∃ z, η x = z) → Type)). {
    refine (_ o repl_sigma (λ z, η x = z)).
    use repl_rec. exact P. }
  change (P' (η x; 1) -> P' (η y; p)).
  intro u; refine (paths_rec (η x; 1) P' u (η y; p) _).
  subst P'. classes.
  ref (path_sigma (λ z, η x = z) p _).
  exact (transport_paths_r _ p 1 @ concat_1p p).
Defined.

Definition repl_J {A} {x: A} (P: ∀ (y: A), η x = η y -> Type)
           {H: PFibrant (λ w: ∃ y, η x = η y, P w.1 w.2)}
           {y: A} (p: η x = η y)
  : P x 1 -> P y p.
Proof.
  ref (repl_J' (λ w, P w.1 w.2) p).
Defined.

Axiom repl_rec_eta : forall {X P} {FibP: Fibrant P} (f: repl X -> P),
    repl_rec (f o η) ≡≡ f.

Definition repl_eta {X P} {FibP: Fibrant P} (f g: repl X -> P)
  : f o η ≡≡ g o η -> f ≡≡ g.
Proof.
  intros H x.
  refine ((repl_rec_eta f x)^E E@ _ E@ repl_rec_eta g _).
  use Eap10.
  exact (Eap _ (eq_funext H)).
Defined.

Definition repl_f {A B} (f: A -> B) : repl A -> repl B.
Proof.
  apply repl_rec. exact (η o f).
Defined.

Definition repl_f_compose {A B C} (f: A -> B) (g: B -> C)
  : repl_f g o repl_f f ≡≡ repl_f (g o f).
Proof.
  use repl_eta; now intro.
Defined.

Definition repl_f_idmap A
  : repl_f (λ x: A, x) ≡≡ idmap.
Proof.
  use repl_eta; now intro.
Defined.


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.
Set Implicit Arguments.

Import WfExtensionality.

Lemma subtype_sel_bnd_sel_low_reduce :
  forall T1 x1 L1, T1 = (t_sel_bnd x1 L1) ->
                  forall T2 x2 L2 T2', T2 = (t_sel_low x2 L2 T2') ->
                                  subtype T1 T2 = orb (andb (eq_var x1 x2)
                                                            (eq_label L1 L2))
                                                      (subtype T1 T2').
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.
Qed.


From Undecidability Require Import simple simple_construction hypersimple hypersimple_construction myhill MoreEnumerabilityFacts ReducibilityFacts.

Theorem Myhill_Isomorphism_Theorem :
  forall X : Set, discrete X -> enumerableᵗ X ->
  forall Y : Set, discrete Y -> enumerableᵗ Y ->
  forall p : X -> Prop, forall q : Y -> Prop,
      p ⪯₁ q -> q ⪯₁ p -> exists f g, reduces_m f p q /\ reduces_m g q p /\ forall x y, f (g y) = y /\ g (f x) = x.
Proof.
  intros X [dX HdX] [eX HeX] Y [dY HdY] [eY HeY] p q [f [f_inj Hf]] [g [g_inj Hg]].
  assert (inhabited (eq_dec X)) as [eq_dec_X]  by (eapply discrete_iff; firstorder).
  assert (inhabited (eq_dec Y)) as [eq_dec_Y]  by (eapply discrete_iff; firstorder).
  destruct (enumerator_retraction _ _ _ HdX HeX) as [IX HIX].
  destruct (enumerator_retraction _ _ _ HdY HeY) as [IY HIY].
  eexists _, _. repeat eapply conj.
  - unshelve eapply f'_red; eauto; firstorder.
  - unshelve eapply g'_red; eauto; firstorder.
  - intros. split.
    + eapply f'_g'.
    + eapply g'_f'.
Qed.

Corollary Computational_Cantor_Bernstein :
  forall X : Set, discrete X -> enumerableᵗ X ->
  forall Y : Set, discrete Y -> enumerableᵗ Y ->
  forall f : X -> Y, (forall x1 x2, f x1 = f x2 -> x1 = x2) ->
  forall g : Y -> X, (forall y1 y2, g y1 = g y2 -> y1 = y2) ->
  exists (f' : X -> Y) (g' : Y -> X), forall x y, f' (g' y) = y /\ g' (f' x) = x.
Proof.
  intros X HX1 HX2 Y HY1 HY2 f Hf g Hg.
  destruct (@Myhill_Isomorphism_Theorem X HX1 HX2 Y HY1 HY2 (fun _ => True) (fun _ => True)) as (f' & g' & Hf' & Hg' & H).
  - exists f. firstorder.
  - exists g. firstorder.
  - exists f', g'. eapply H.
Qed.

Theorem Posts_problem_many_one :
  exists p : nat -> Prop, simple p /\ enumerable p /\ ~ decidable p /\ ~ uncurry W ⪯ₘ p.
Proof.
  assert (semi_decidable (uncurry W)) as [W_sdec H_sdec]. {
    eapply enumerable_semi_decidable. eapply discrete_prod; eapply discrete_nat.
    eapply enumerable_W.
  }
  destruct (do_EA (fun _ => True)) as [c_top H_top]. {
    eapply decidable_enumerable. 2:eauto. exists (fun _ => true). firstorder.
  }
  eexists.
  split; [ | repeat eapply conj].
  - eapply S_simple; eauto.
  - eapply semi_decidable_enumerable. eauto. eapply S_simple; eauto.
  - eapply simple_undecidable. eapply S_simple; eauto.
  - intros H. eapply simple_m_incomplete. eapply S_simple; eauto.
    intros q Hq.
    eapply red_m_transitive. eapply m_complete_W. eauto.
    eapply red_m_transitive with (q0 := uncurry W). eapply W_uncurry_red.
    exact H.
    Unshelve. all:eauto. firstorder.
Qed.

Corollary one_one_and_many_one_differ :
  exists p : nat * nat -> Prop, exists q : nat -> Prop, enumerable p /\ ~ decidable p /\ enumerable q /\ ~ decidable q /\ p ⪯ₘ q /\ ~ p ⪯₁ q.
Proof.
  assert (semi_decidable (uncurry W)) as [W_sdec H_sdec]. {
    eapply enumerable_semi_decidable. eapply discrete_prod; eapply discrete_nat.
    eapply enumerable_W.
  }
  destruct (do_EA (fun _ => True)) as [c_top H_top]. {
    eapply decidable_enumerable. 2:eauto. exists (fun _ => true). firstorder.
  }
  epose (S := S W_sdec H_sdec c_top ltac:(abstract firstorder)).
  assert (H1 : enumerable S). { eapply semi_decidable_enumerable. eauto. eapply S_simple; eauto. }
  assert (H2 : ~ decidable S). { eapply simple_undecidable. eapply S_simple; eauto. }
  assert (H3 : ((fun '(x,_) => S x) : nat * nat -> Prop) ⪯ₘ S). { exists (fun '(x,_) => x). now intros (x, _). }
  exists (fun '(x,_) => S x). exists S. repeat eapply conj.
  - eapply enumerable_red; eauto.
  - intros ?. eapply red_m_transports in H.
    eapply H2. eassumption. exists (fun x => (x,0)). now intros x.
  - eauto.
  - eauto.
  - eauto.
  - intros ? % simple_no_cylinder. eapply H0. eapply S_simple; eauto.
Qed.

Theorem Posts_problem_truth_table :
  exists p : nat -> Prop, hyper_simple p /\ enumerable p /\ ~ decidable p /\ ~ uncurry W ⪯ₜₜ p.
Proof.
  destruct (@generative_enumerable_strong _ (fun! ⟨n,m⟩ => W n m)) as [f Hf].
  - eapply discrete_nat.
  - eapply enumerable_red. eapply W_uncurry_red. eauto. eauto.
    eapply enumerable_W.
  - eapply generative_W.
  - unshelve epose proof (HS_hypersimple (fun! ⟨n,m⟩ => W n m) f _ _ _).
    + firstorder.
    + firstorder.
    + intros ? % decidable_complement % decidable_enumerable.
      eapply not_coenumerable. 5: eapply H0. eapply W_uncurry_red'. all: eauto.
      eapply W_not_enumerable.
    + eexists. split. eapply H. repeat eapply conj.
      * eapply H.
      * eapply (HS_undec (fun! ⟨n,m⟩ => W n m) f). firstorder. firstorder.
        intros ? % decidable_complement % decidable_enumerable.
        eapply not_coenumerable. 5: eapply H1. eapply W_uncurry_red'. all: eauto.
        eapply W_not_enumerable.
      * intros Htt. eapply H.
        edestruct tt_complete_exceeds as [g Hg % exceeds_majorizes]. 2:eauto.
        eapply red_tt_transitive. 2: eauto.
        eapply red_mo_tt, K0_red.
Qed.

Corollary many_one_truth_table_differ :
  exists p q : nat -> Prop, enumerable p /\ ~ decidable p /\ enumerable q /\ ~ decidable q /\ p ⪯ₜₜ q /\ ~ p ⪯ₘ q.
Proof.
  assert (semi_decidable (uncurry W)) as [W_sdec H_sdec]. {
    eapply enumerable_semi_decidable. eapply discrete_prod; eapply discrete_nat.
    eapply enumerable_W.
  }
  destruct (do_EA (fun _ => True)) as [c_top H_top]. {
    eapply decidable_enumerable. 2:eauto. exists (fun _ => true). firstorder.
  }
  epose (S_Star := S_Star W_sdec H_sdec c_top ltac:(abstract firstorder)).
  assert (H1 : enumerable S_Star). { eapply semi_decidable_enumerable. eauto. eapply S_Star_simple; eauto. }
  assert (H2 : ~ decidable S_Star). { eapply simple_undecidable. eapply S_Star_simple; eauto. }
  exists (fun! ⟨n,m⟩ => W n m), S_Star. repeat eapply conj.
  - eapply enumerable_red. eapply W_uncurry_red. eauto. eauto.
    eapply enumerable_W.
  - intros H. eapply red_m_transports in H. eapply H2; eassumption.
    eapply m_complete_W. eauto.
  - eauto.
  - eauto.
  - eapply red_tt_transitive. 2: eapply tt_red_W_S_Star.
    eapply red_mo_tt, W_uncurry_red.
  - intros H. eapply simple_m_incomplete.
    eapply S_Star_simple; eauto.
    intros ? ?. eapply red_m_transitive. 2: eapply H.
    eapply m_complete_W. eauto.
Qed.

Print Assumptions Myhill_Isomorphism_Theorem.
Print Assumptions Posts_problem_many_one.
Print Assumptions Posts_problem_truth_table.


(***********************************************************************)
(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
(*                                                                     *)
(***********************************************************************)
Require Import ssreflect ssrbool ssrfun eqtype ssrnat.
Require Import div seq fintype.
(* Require Import connect. *)
Require Import tuple finfun ssralg bigops finset.
Require Import groups group_perm morphisms.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Import GroupScope.

Section ActionDef.

Variable aT : finGroupType.

Definition is_action T (to : T -> aT -> T) :=
  prod (forall x, to x 1 = x) (forall a x y, to a (x * y) = to (to a x) y).

Record action (T : Type) : Type :=
  Action { afun :> T -> aT -> T; _ : is_action afun }.

Definition action_for of phant aT := action.

End ActionDef.

Notation "{ 'action' aT &-> T }" := (action_for (Phant aT) T)
  (at level 0, format "{ 'action'  aT  &->  T }") : type_scope.

Notation "[ 'action' 'of' a ]" :=
  (StructureOf (@Action _ _ a)
   match [is a : _ -> _ <: action _ _] as s
   return {type of @Action _ _ for s} -> _ with
   | Action _ actP => fun k => k actP
   end) (at level 0, only parsing) : form_scope.

Notation "[ 'action' 'o' 'f' a ]" := (StructureOf (@Action _ _ a) _)
  (at level 0, format "[ 'action'  'o' 'f'  a ]") : form_scope.

Delimit Scope action_scope with act.
Bind Scope action_scope with action.
Bind Scope action_scope with action_for.

Section ActionOpsDef.

Variables (aT : finGroupType) (sT : finType).
Implicit Type A : {set aT}.
Implicit Type to : {action aT &-> sT}.
Implicit Type S : {set sT}.

Definition afix A to := [set x | A \subset [set a | to x a == x]].

Definition astab to S := [set a | S \subset [set x | to x a == x]].

Definition orbit to A x := to x @: A.

Definition astabs to S := [set a | S \subset to^~ a @^-1: S ].

Definition acts_on to S := forall a x, (to x a \in S) = (x \in S).

Definition atrans A to S := S \in orbit to A @: S.

Definition faithful A to S := A :&: astab to S \subset [1].

End ActionOpsDef.

Notation "''C' ( A | to )" := (afix A to)
 (at level 8, format "''C' ( A  |  to )") : group_scope.

Notation "''C_' S ( A | to )" := (S :&: 'C(A | to))
 (at level 8, S at level 2, format "''C_' S ( A  |  to )") : group_scope.

(* Camlp4 factoring. *)
Notation "''C_' ( G ) ( A )" := 'C_G(A)
  (at level 8, only parsing) : group_scope.
Notation "''C_' ( G ) ( A )" := 'C_G(A)%G (only parsing) : subgroup_scope.
Notation "''C_' ( G ) ( A | to )" := 'C_G(A | to)
  (at level 8, only parsing) : group_scope.

Notation "''N_' ( G ) ( A )" := 'N_G(A)
  (at level 8, only parsing) : group_scope.
Notation "''N_' ( G ) ( A )" := 'N_G(A)%G (only parsing) : subgroup_scope.

Notation "''C_' ( | to ) ( S )" := (astab to S)
 (at level 8, format "''C_' ( | to ) ( S )") : group_scope.

Notation "''C_' ( A | to ) ( S )" := (A :&: 'C_(|to)(S))
 (at level 8, format "''C_' ( A  |  to ) ( S )") : group_scope.

Notation "''N_' ( | to ) ( S )" := (astabs to S)
  (at level 8, format "''N_' ( | to ) ( S )") : group_scope.

Notation "''N_' ( A | to ) ( S )" := (A :&: 'N_(|to)(S))
  (at level 8, format "''N_' ( A  |  to ) ( S )") : group_scope.

Notation "''C_' ( | to ) [ x ]" := 'C_(|to)([set x])
  (at level 8, format "''C_' ( | to ) [ x ]") : group_scope.

Notation "''C_' ( A | to ) [ x ]" := 'C_(A | to)([set x])
  (at level 8, format "''C_' ( A  |  to ) [ x ]") : group_scope.

Notation "''C' [ a | to ]" := 'C([set a] | to)
  (at level 8, format "''C' [ a  |  to ]") : group_scope.

Notation "''C_' S [ a | to ] " := 'C_S([set a] | to)
  (at level 8, S at level 2, format "''C_' S [ a  |  to ]") : group_scope.

Notation "[ 'acts' ( A | to ) 'on' S ]" := (A \subset pred_of_set 'N_(|to)(S))
  (at level 0, format "[ 'acts'  ( A  |  to )  'on'  S ]") : form_scope.

Notation "{ 'acts' ( A | to ) 'on' S }" := {in A, acts_on to S}
  (at level 0, format "{ 'acts'  ( A  |  to )  'on'  S }") : form_scope.

Notation "[ 'transitive' ( A | to ) 'on' S ]" := (atrans A to S)
  (at level 0, format "[ 'transitive'  ( A  |  to )  'on'  S ]") : form_scope.

Notation "[ 'faithful' ( A | to ) 'on' S ]" := (faithful A to S)
  (at level 0, format "[ 'faithful'  ( A  |  to )  'on'  S ]") : form_scope.

Prenex Implicits orbit.

Section Action.

Variable (aT : finGroupType) (sT : finType).

Implicit Types a b c : aT.
Implicit Types x y z : sT.
Implicit Types A B : {group aT}.
Implicit Types S : {set sT}.

Variable to : {action aT &-> sT}.

Lemma act1 : forall x, to x 1 = x.
Proof. by case: to => ? []. Qed.

Lemma actM : forall x a b, to x (a * b) = to (to x a) b.
Proof. by case: to => ? []. Qed.

Lemma actK : forall a, cancel (to^~ a) (to^~ a^-1).
Proof. by move=> a x; rewrite -actM ?groupV // mulgV act1. Qed.

Lemma actKV : forall a, cancel (to^~ a^-1) (to^~ a).
Proof. by move=> a x; rewrite -{2}(invgK a) actK. Qed.

Lemma actCJ : forall a b x, to (to x a) b = to (to x b) (a ^ b).
Proof. by move=> a b x; rewrite !actM actK. Qed.

Lemma actCJV : forall a b x, to (to x a) b = to (to x (b ^ a^-1)) a.
Proof. by move=> a b x; rewrite (actCJ _ a) conjgKV. Qed.

Lemma act_inj : forall a, injective (to^~ a).
Proof. move=> a; exact: (can_inj (actK a)). Qed.

Lemma orbitE : forall A x, orbit to A x = to x @: A. Proof. by []. Qed.

Lemma orbitP : forall A x y,
  reflect (exists2 a, a \in A & to x a = y) (y \in orbit to A x).
Proof. by move=> A x y; apply: (iffP imsetP) => [] [a]; exists a. Qed.

Lemma orbit_to : forall A x a, a \in A -> to x a \in orbit to A x.
Proof. move=> A x; exact: mem_imset. Qed.

Lemma orbit_refl : forall A x, x \in orbit to A x.
Proof. by move=> A x; rewrite -{1}[x]act1 orbit_to. Qed.

Lemma orbit_sym : forall A x y, (y \in orbit to A x) = (x \in orbit to A y).
Proof.
move=> A x y; apply/idP/idP; case/orbitP=> a Aa; move/(canRL (actK a))->;
  by rewrite mem_imset ?groupV.
Qed.

Lemma orbit_trans : forall A x y z,
  y \in orbit to A x -> z \in orbit to A y -> z \in orbit to A x.
Proof.
move=> A x y z; case/orbitP=> a Aa <-; case/orbitP=> b Ab <-{y z}.
by rewrite -actM mem_imset ?groupM.
Qed.

Lemma orbit_transl : forall A x y,
  y \in orbit to A x -> orbit to A y = orbit to A x.
Proof.
move=> A x y Axy; apply/setP=> z; apply/idP/idP; apply: orbit_trans => //.
by rewrite orbit_sym.
Qed.

Lemma orbit_transr : forall A x y z,
  y \in orbit to A x -> (y \in orbit to A z) = (x \in orbit to A z).
Proof.
by move=> A x y z Axy; rewrite !(orbit_sym A z) (orbit_transl Axy).
Qed.

Lemma afixP : forall (A : {set aT}) x,
  reflect (forall a, a \in A -> to x a = x) (x \in 'C(A | to)).
Proof.
move=> A x; rewrite inE; apply: (iffP subsetP) => [xfix a | xfix a Aa].
  by move/xfix; rewrite inE; move/eqP.
by rewrite inE xfix.
Qed.

Lemma orbit1P : forall A x,
  reflect ([set x] = orbit to A x) (x \in 'C(A | to)).
Proof.
move=> A x; apply: (iffP (afixP _ _)) => [xfix | xfix a Aa].
  apply/eqP; rewrite eqEsubset sub1set orbit_refl.
  by apply/subsetP=> y; case/imsetP=> a Aa ->; rewrite inE xfix.
by apply/set1P; rewrite xfix mem_imset.
Qed.

Lemma afix1P : forall a x, reflect (to x a = x) (x \in 'C[a | to]).
Proof. move=> a x; rewrite inE sub1set inE; exact: eqP. Qed.

Lemma astabP : forall S a,
  reflect (forall x, x \in S -> to x a = x) (a \in 'C_(|to)(S)).
Proof.
move=> S a; rewrite inE; apply: (iffP subsetP) => fix_a y => [|Sy].
  by move/fix_a; rewrite inE; move/eqP.
by rewrite inE fix_a.
Qed.

Lemma astab1P : forall x a, reflect (to x a = x) (a \in 'C_(|to)[x]).
Proof. move=> x a; rewrite inE sub1set inE; exact: eqP. Qed.

Lemma astabsP : forall S a,
  reflect (forall x, (to x a \in S) = (x \in S)) (a \in 'N_(|to)(S)).
Proof.
move=> S a; rewrite inE; apply: (iffP idP) => [sSaS x | eSaS]; last first.
  by apply/subsetP=> x Sx; rewrite inE eSaS.
rewrite {2}((S =P to^~ a @^-1: S) _) ?inE // eqEcard {}sSaS /=.
rewrite card_preimset //; exact: act_inj.
Qed.

Lemma group_set_astab : forall S, group_set 'C_(|to)(S).
Proof.
move=> S; apply/group_setP; split=> [|a b].
  by apply/astabP=> x _; rewrite act1.
move/astabP=> Ca; move/astabP=> Cb; apply/astabP=> x Sx.
by rewrite actM Ca ?Cb.
Qed.

Canonical Structure astab_group S := group (group_set_astab S).

Lemma group_set_astabs : forall S, group_set 'N_(|to)(S).
Proof.
move=> S; apply/group_setP; split=> [|a b].
  by apply/astabsP=> y; rewrite act1.
move/astabsP=> Na; move/astabsP=> Nb; apply/astabsP=> x.
by rewrite actM Nb Na.
Qed.

Canonical Structure astabs_group S := group (group_set_astabs S).

Lemma subset_astab : forall A S, 'C_(A | to)(S) \subset A.
Proof. move=> A S; exact: subsetIl. Qed.

Lemma card_orbit_stab : forall A x,
  (#|orbit to A x| * #|'C_(A | to)[x]|)%N = #|A|.
Proof.
move=> A x; rewrite -[#|A|]sum1_card (partition_big_imset (to x)) /=.
rewrite -sum_nat_const; apply: eq_bigr => y; case/imsetP=> a Aa ->{y}.
rewrite (reindex (mulg^~ a)) /= -?sum1_card; last first.
  by exists (mulg^~ a^-1) => b _; rewrite (mulgK, mulgKV).
apply: eq_bigl => b; rewrite inE groupMr // actM inE sub1set inE.
by rewrite (inj_eq (@act_inj a)).
Qed.

Lemma card_orbit : forall A x, #|orbit to A x| = #|A : 'C_(A | to)[x]|.
Proof.
move=> A x; rewrite -divgS ?subsetIl //.
by rewrite -(card_orbit_stab A x) mulnK ?ltn_0group.
Qed.

Lemma dvdn_orbit : forall A x, #|orbit to A x| %| #|A|.
Proof. by move=> A x; rewrite -(card_orbit_stab A x) dvdn_mulr. Qed.

Lemma card_orbit1 : forall A x,
  #|orbit to A x| = 1%N -> orbit to A x = [set x].
Proof.
move=> A x orb1; apply/eqP; rewrite eq_sym eqEcard {}orb1 cards1.
by rewrite sub1set orbit_refl.
Qed.

Lemma actsP : forall A S,
  reflect {acts (A | to) on S} [acts (A | to) on S].
Proof.
move=> A S; apply: (iffP subsetP) => nAS a Aa; apply/astabsP; exact: nAS.
Qed.
Implicit Arguments actsP [A S].

Lemma acts_orbit : forall A S x,
  [acts (A | to) on S] -> (orbit to A x \subset S) = (x \in S).
Proof.
move=> A S x; move/actsP=> AactS; apply/subsetP/idP=> [| Sx y].
  apply; exact: orbit_refl.
by case/imsetP=> a Aa ->{y}; rewrite AactS.
Qed.

Lemma orbit_in_act : forall A S x y,
  [acts (A | to) on S] -> y \in orbit to A x -> x \in S -> y \in S.
Proof. move=> A S x y; move/acts_orbit=> <- xAy; move/subsetP; exact. Qed.

Lemma acts_sum_card_orbit : forall A S, [acts (A | to) on S] ->
  \sum_(T \in orbit to A @: S) #|T| = #|S|.
Proof.
move=> A S AactS; rewrite -sum1_card (partition_big_imset (orbit to A)) /=.
apply: eq_bigr => xS; case/imsetP=> x Sx ->{xS}; rewrite -sum1_card.
apply: eq_bigl=> y; apply/idP/andP=> [xAy|[_]].
  by rewrite (orbit_transl xAy) (orbit_in_act _ xAy).
by move/eqP <-; exact: orbit_refl.
Qed.

Lemma astab_to : forall S a, 'C_(| to)(to^~a @: S) = 'C_(| to)(S) :^ a.
Proof.
move=> S a; apply/setP=> b; rewrite mem_conjg.
apply/astabP/astabP=> stab x => [Sx|].
  by rewrite conjgE invgK !actM stab ?actK //; apply/imsetP; exists x.
by case/imsetP=> y Sy ->{x}; rewrite -actM conjgCV actM stab.
Qed.

Lemma astab1_to : forall G x a,
  a \in 'N(G) -> 'C_(G | to)[to x a] = 'C_(G | to)[x] :^ a.
Proof.
by move=> G x a nGa; rewrite conjIg (normP nGa) -astab_to imset_set1.
Qed.

Theorem Frobenius_Cauchy : forall A S, [acts (A | to) on S] ->
  \sum_(a \in A) #|'C_S[a | to]| = (#|orbit to A @: S| * #|A|)%N.
Proof.
move=> A S AactS; transitivity (\sum_(a \in A) \sum_(x \in 'C_S[a | to]) 1%N).
  by apply: eq_bigr => a _; rewrite -sum1_card.
rewrite (exchange_big_dep (mem S)) /= => [|a x _]; last by case/setIP.
set orbA := orbit to A; rewrite (partition_big_imset orbA) -sum_nat_const /=.
apply: eq_bigr => X; case/imsetP=> x Sx ->{X}.
rewrite (eq_bigl (mem (orbA x))) => [|y] /=; last first.
  apply/andP/idP=> [[_]|xAy]; first by move/eqP <-; exact: orbit_refl.
  by rewrite /orbA (orbit_transl xAy) (orbit_in_act AactS xAy).
rewrite -(card_orbit_stab A x) -sum_nat_const.
apply: eq_bigr => y; rewrite orbit_sym; case/imsetP=> a Aa defx.
rewrite defx astab1_to (subsetP (normG _), cardJg) // -sum1_card.
by apply: eq_bigl => b; rewrite !(sub1set, inE) -(actsP AactS a Aa) -defx Sx.
Qed.

Lemma atransP : forall A S, [transitive (A | to) on S] ->
  forall x, x \in S -> orbit to A x = S.
Proof. move=> A S; case/imsetP=> x _ -> y; exact: orbit_transl. Qed.

Lemma atransP2 : forall A S, [transitive (A | to) on S] ->
  {in S &, forall x y, exists2 a, a \in A & y = to x a}.
Proof. by move=> A S AtrS x y; move/(atransP AtrS) <-; move/imsetP. Qed.

Lemma trans_acts : forall A S,
  [transitive (A | to) on S] -> [acts (A | to) on S].
Proof.
move=> A S AtrS; apply/subsetP=> a Aa; rewrite inE.
by apply/subsetP=> x; move/(atransP AtrS) <-; rewrite inE mem_imset.
Qed.

Lemma atrans_acts_card : forall A S,
  [transitive (A | to) on S] =
     [acts (A | to) on S] && (#|orbit to A @: S| == 1%N).
Proof.
move=> A S; apply/idP/andP=> [AtrS | [nSA]].
  split; first exact: trans_acts.
  rewrite ((_ @: S =P [set S]) _) ?cards1 // eqEsubset sub1set.
  apply/andP; split=> //; apply/subsetP=> X; case/imsetP=> x Sx ->.
  by rewrite inE (atransP AtrS).
rewrite eqn_leq andbC lt0n; case/andP.
case/existsP=> X; case/imsetP=> x Sx X_Ax.
rewrite (cardD1 X) {X}X_Ax mem_imset // ltnS leqn0; move/eqP=> AtrS.
apply/imsetP; exists x => //; apply/eqP.
rewrite eqEsubset acts_orbit // Sx andbT.
apply/subsetP=> y Sy; have:= card0_eq AtrS (orbit to A y).
rewrite !inE /= mem_imset // andbT; move/eqP <-; exact: orbit_refl.
Qed.

Lemma trans_div : forall A S x,
  x \in S -> [transitive (A | to) on S] -> #|S| %| #|A|.
Proof.
by move=> A S x Sx; move/atransP=> AtrS; rewrite -(AtrS x Sx) dvdn_orbit.
Qed.

(* Aschbacher 5.2 *)
Lemma norm_act_fix : forall A B,
  A \subset 'N(B) -> [acts (A | to) on 'C(B | to)].
Proof.
move=> A B; move/subsetP=> nBA; apply/actsP=> a Aa x.
apply/afixP/afixP=> fix_x b Bb.
  by rewrite -(actK a (to x b)) (actCJ b) fix_x (actK, memJ_norm) // nBA.
by rewrite actCJV fix_x // memJ_norm // groupV nBA.
Qed.

Lemma norm_stab : forall A B S,
  A \subset 'N(B) -> 'C_(A | to)(S) \subset 'N('C_(B | to)(S)).
Proof.
move=> A B S nAB; apply/normsP=> a; case/setIP=> Aa; move/astabP=> toSa.
apply/setP=> b; rewrite mem_conjg !in_setI memJ_norm ?(groupV, subsetP nAB) //.
congr (_ && _); apply/astabP/astabP=> toSb x Sx.
  by rewrite -(toSa _ Sx) actCJV toSb.
by rewrite !actM invgK toSa ?toSb // -{1}(toSa x Sx) actK.
Qed.

Lemma faithfulP : forall A S,
  reflect (forall a, a \in A -> {in S, to^~ a =1 id} -> a = 1)
          [faithful (A | to) on S].
Proof.
move=> A S; apply: (iffP subsetP) => [Cto1 a Aa Ca | Cto1 a].
  apply/set1P; rewrite Cto1 // inE Aa; exact/astabP.
case/setIP=> Aa; move/astabP=> Ca; apply/set1P; exact: Cto1.
Qed.

Lemma subset_faithful : forall A B S,
  B \subset A -> [faithful (A | to) on S] -> [faithful (B | to) on S].
Proof. move=> A B S sAB; apply: subset_trans; exact: setSI. Qed.

(* Aschbacher 5.20 *)
Theorem subgroup_transitiveP : forall (G H : {group aT}) S x,
     x \in S -> H \subset G -> [transitive (G | to) on S] ->
  reflect ('C_(G | to)[x] * H = G) [transitive (H | to) on S].
Proof.
move=> G H S x Sx sHG trG; apply: (iffP idP) => [trH | defG].
  rewrite group_modr //; apply/setIidPl; apply/subsetP=> a Ga.
  have Sxa: to x a \in S by rewrite (actsP (trans_acts trG)).
  have [b Hb xab]:= atransP2 trH Sxa Sx.
  by rewrite -(mulgK b a) mem_mulg ?groupV //; apply/astab1P; rewrite actM.
apply/imsetP; exists x => //; apply/setP=> y; rewrite -(atransP trG Sx).
apply/imsetP/imsetP=> [] [a]; last by exists a; first exact: (subsetP sHG).
rewrite -defG; case/imset2P=> c b; case/setIP=> _; move/astab1P=> xc Hb -> ->.
by exists b; rewrite // actM xc.
Qed.

End Action.

Implicit Arguments act_inj [aT sT].
Implicit Arguments orbitP [aT sT to A x y].
Implicit Arguments afixP [aT sT to A x].
Implicit Arguments afix1P [aT sT to a x].
Implicit Arguments orbit1P [aT sT to A x].
Implicit Arguments astabP [aT sT to S a].
Implicit Arguments astab1P [aT sT to x a].
Implicit Arguments astabsP [aT sT to S a].
Implicit Arguments atransP [aT sT to A S].
Implicit Arguments actsP [aT sT to A S].
Implicit Arguments faithfulP [aT sT to A S].

Prenex Implicits orbitP afixP afix1P orbit1P astabP astab1P astabsP.
Prenex Implicits atransP actsP faithfulP.

Notation "''C_' ( | to ) ( S )" := (astab_group to S) : subgroup_scope.
Notation "''C_' ( A | to ) ( S )" := (A :&: 'C_(|to)(S))%G : subgroup_scope.
Notation "''C_' ( | to ) [ x ]" := ('C_(|to)([set x]))%G : subgroup_scope.
Notation "''C_' ( A | to ) [ x ]" := (A :&: 'C_(|to)[x])%G : subgroup_scope.
Notation "''N_' ( | to ) ( S )" := (astabs_group to S) : subgroup_scope.
Notation "''N_' ( A | to ) ( S )" := (A :&: 'N_(|to)(S))%G : subgroup_scope.

Section SetAction.

Variables (aT : finGroupType) (sT : finType) (to : {action aT &-> sT}).

Definition set_act (S : {set sT}) a := to^~ a @: S.

Lemma is_set_action : is_action set_act.
Proof.
split=> [S | S a b].
  apply/eqP; rewrite eqEcard card_imset ?leqnn ?andbT; last exact: act_inj.
  by apply/subsetP=> x1; case/imsetP=> x Sx ->; rewrite act1.
rewrite /set_act -imset_comp; apply: eq_imset => x; exact: actM.
Qed.

Canonical Structure set_action := Action is_set_action.

Lemma astab1_set : forall S, 'C_(|set_action)[S] = 'N_(|to)(S).
Proof.
move=> S; apply/setP=> a; rewrite -groupV !inE sub1set inE /=.
rewrite /set_act (can_imset_pre _ (actKV to _)) eq_sym eqEcard andbC.
by rewrite card_preimset ?leqnn //; exact: act_inj.
Qed.

End SetAction.

Notation "to ^*" := (set_action to)
  (at level 2, format "to ^*") : action_scope.

(*  Definition of the right translation as an action on cosets.        *)

Section GroupActions.

Variable gT : finGroupType.
Implicit Type A : {set gT}.
Implicit Type G : {group gT}.

Canonical Structure mulgr_action := Action (@mulg1 gT, @mulgA gT).

Canonical Structure conjg_action := Action (@conjg1 gT, @conjgM gT).

Lemma rcoset_is_action : is_action (@rcoset gT).
Proof. by split=> [A|A x y]; rewrite !rcosetE (mulg1, rcosetM). Qed.

Canonical Structure rcoset_action := Action rcoset_is_action.

Canonical Structure conjsg_action := Action (@conjsg1 gT, @conjsgM gT).

Lemma conjG_is_action : is_action (@conjG_group gT).
Proof. by split=> *; apply: group_inj; rewrite /= ?conjsg1 ?conjsgM. Qed.

Definition conjG_action := Action conjG_is_action.

End GroupActions.

Notation "'Mr" := (@mulgr_action _) (at level 0) : action_scope.
Notation "'Msr" := (@rcoset_action _) (at level 0) : action_scope.
Notation "'J" := (@conjg_action _) (at level 0) : action_scope.
Notation "'Js" := (@conjsg_action _) (at level 0) : action_scope.
Notation "'JG" := (@conjG_action _) (at level 0) : action_scope.

Section Bij.

Variable (gT : finGroupType).
Implicit Types A B : {set gT}.
Implicit Types H G : {group gT}.

(*  Various identities for actions on groups; may need some trimming.  *)

Lemma act_fix_sub : forall G x A,
 (G :* x \in 'C(A | 'Msr)) = (A \subset G :^ x).
Proof.
move=> G x A; rewrite inE /=; apply: eq_subset_r => a.
rewrite inE rcosetE -(can2_eq (rcosetKV x) (rcosetK x)) -!rcosetM.
rewrite (conjgCV x) mulgK eqEcard card_rcoset leqnn andbT.
by rewrite -{2 3}(mulGid G) mulGS sub1set -mem_conjg.
Qed.

Lemma act_fix_norm : forall G x, (G :* x \in 'C(G | 'Msr)) = (x \in 'N(G)).
Proof. by move=> G x; rewrite act_fix_sub -groupV inE sub_conjgV. Qed.

Lemma rtrans_fix_norm : forall A G,
  'C_(rcosets G A)(G | 'Msr) = rcosets G 'N_A(G).
Proof.
move=> A G; apply/setP=> Gx; apply/setIP/rcosetsP=> [[]|[x]].
  case/rcosetsP=> x Ax ->{Gx}; rewrite act_fix_norm => Nx.
  by exists x; rewrite // inE Ax.
by case/setIP=> Ax Nx ->; rewrite -{1}rcosetE mem_imset // act_fix_norm.
Qed.

Lemma rtrans_stabG : forall G, 'C_(| 'Msr)[G : {set gT}] = G.
Proof.
move=> G; apply/setP=> x.
by apply/astab1P/idP=> /= [<- | Gx]; rewrite rcosetE (rcoset_refl, rcoset_id).
Qed.

Lemma conjg_fix : forall A, 'C(A | 'J) = 'C(A).
Proof.
move=> A; apply/setP=> x; apply/afixP/centP=> cAx y Ay /=.
  by rewrite /commute conjgC cAx.
by rewrite conjgE cAx ?mulKg.
Qed.

Lemma conjg_astab : forall A, 'C_(| 'J)(A) = 'C(A).
Proof.
move=> A; apply/setP=> x; apply/astabP/centP=> cAx y Ay /=.
  by apply: esym; rewrite conjgC cAx.
by rewrite conjgE -cAx ?mulKg.
Qed.

Lemma conjg_astab1 : forall x : gT, 'C_(| 'J)[x] = 'C[x].
Proof. by move=> x; rewrite conjg_astab cent_set1. Qed.

Lemma conjg_astabs : forall G, 'N_(|'J)(G) = 'N(G).
Proof.
by move=> G; apply/setP=> x; rewrite -2!groupV !inE -conjg_preim -sub_conjg.
Qed.

Lemma conjsg_astab1 : forall A, 'C_(| 'Js)[A] = 'N(A).
Proof. by move=> A; apply/setP=> x; apply/astab1P/normP. Qed.

Lemma conjG_fix: forall G A, (G \in 'C(A | 'JG)) = (A \subset 'N(G)).
Proof.
by move=> G A; apply/afixP/normsP=> nG x Ax; apply/eqP; move/eqP: (nG x Ax).
Qed.

Lemma conjG_astab1 : forall G, 'C_(| 'JG)[G] = 'N(G).
Proof.
move=> G; apply/setP=> x.
by apply/astab1P/normP; [move/(congr1 val) | move/group_inj].
Qed.

(* Other group action identities, most of which hold by conversion
   Outcommented for now, until we require them.
Lemma conjg_orbit : forall x, orbit 'J%act G x = x ^: G.
Proof. by []. Qed.

Lemma rtrans_orbit : forall A : {set gT}, orbit 'Msr%act G A = rcosets A G.
Proof. by []. Qed.

Lemma rmul_orbit : forall x, orbit 'Mr%act G x = x *: G.
Proof. by move=> x; rewrite -lcosetE. Qed.

Lemma conjsg_orbit : forall A : {set gT}, orbit 'Js%act G A = A :^: G.
Proof. by []. Qed.
*)
End Bij.

Section CardClass.

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

Lemma index_cent1 : forall x, #|G : 'C_G[x]| = #|x ^: G|.
Proof. by move=> x; rewrite -conjg_astab1 -card_orbit. Qed.

Lemma sum_card_class : \sum_(C \in classes G) #|C| = #|G|.
Proof. apply: acts_sum_card_orbit; apply/actsP=> x Gx y; exact: groupJr. Qed.

Lemma class_formula : \sum_(C \in classes G) #|G : 'C_G[repr C]| = #|G|.
Proof.
rewrite -sum_card_class; apply: eq_bigr => C; case/imsetP=> x Gx ->.
have: x \in x ^: G by rewrite -{1}(conjg1 x) mem_imset.
by move/mem_repr; case/imsetP=> y Gy ->; rewrite index_cent1 classGidl.
Qed.

End CardClass.

(***********************************************************************)
(***********************************************************************)
(*                                                                     *)
(*  Definition of permutation as an action                             *)
(*                                                                     *)
(***********************************************************************)
(***********************************************************************)

Section PermAction.

Variable sT : finType.
Notation gT := {perm sT}.
Implicit Types a b c : gT.

Definition aperm x (a : gT) := a x.

Definition apermE : forall x a, aperm x a = a x. Proof. by []. Qed.

Lemma aperm_is_action : is_action aperm.
Proof. by split=> [x|x a b]; rewrite apermE (perm1, permM). Qed.

Canonical Structure perm_action := Action aperm_is_action.

Lemma perm_act1P : forall a, reflect (forall x, aperm x a = x) (a == 1).
Proof.
move=> a; apply: (iffP eqP) => [-> x | a1]; first exact: act1.
by apply/permP=> x; rewrite -apermE a1 perm1.
Qed.

End PermAction.

Implicit Arguments perm_act1P [sT a].
Prenex Implicits perm_act1P.

Notation "'P" := (perm_action _) (at level 0) : action_scope.

Section PermFact.

Variable gT : finGroupType.
Variable sT : finType.
Variable to : {action gT &-> sT}.
Implicit Type A : {set gT}.

Definition actm A a := perm (act_inj to a).

Lemma actmE : forall A a x, actm A a x = to x a.
Proof. by move=> A a x; rewrite permE. Qed.

Lemma aperm_actm : forall A x a, aperm x (actm A a) = to x a.
Proof. move=> A x a; exact: actmE. Qed.

Lemma perm_of_actM : forall A, {morph actm A : a b / a * b}.
Proof. by move=> A a b; apply/permP => x; rewrite permM !permE actM. Qed.

Canonical Structure actm_morphism A :=
  @Morphism _ _ A _ (in2W (@perm_of_actM A)).

(* For equality we would need to restrict the permutation to S. *)
Lemma faithful_isom : forall (A : {group gT}) (S : {set sT}),
  [faithful (A | to) on S] -> isom A (actm A @: A) (actm A).
Proof.
move=> A S ffulA; apply/isomP; split; last exact: morphimEdom.
apply/subsetP=> a; case/morphpreP=> Aa; move/set1P=> /= a1; apply/set1P.
by apply: (faithfulP ffulA) => // x _; rewrite -(actmE A) a1 perm1.
Qed.

End PermFact.

(* We can't do the converse -- define an action from a morphism --  *)
(* without also restricting the action group type to the morphism   *)
(* domain. This only really makes sense for automorphism actions,   *)
(* but then it seems these are almost always best treated as        *)
(* internal actions.                                                *)