(***********************************************************************)
(* version 2 License, as specified in the README file.                 *)
(*                                                                     *)
(***********************************************************************)
Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq div choice.
Require Import fintype finfun finset groups morphisms automorphism.

(***********************************************************************)
(* This file contains the definitions of:                              *)
(*                                                                     *)
(*   coset_of H           == right cosets by the group H (see below)   *)
(*   coset_groupType H    == the groupType induced by 'N(H) / H        *)
(*   coset H              == the canonical projection induced by H     *)
(*   A / B                == the quotient of A by B,                   *)
(*                               made to coincide w/ (A :&: 'N(B)) / B *)
(*   quotm (nHG: H <| G) (nGf : f@* G = G) (nHf : f@*H = H)            *)
(*                        == the quotient morphism induced by f and H  *)
(***********************************************************************)
(* Lemmas for these notions, plus the three isomorphism theorems, and  *)
(* counting lemmas for morphisms.                                      *)
(***********************************************************************)

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

Import GroupScope.

(********************************************************************)
(*       Cosets are right cosets of elements in the normaliser      *)
(********************************************************************)

Section Cosets.

Variables (gT : finGroupType) (Q A : {set gT}).

(* We let cosets coerce to GroupSet.sort, so they inherit the group  *)
(* subset base group structure. Later we will define a proper group  *)
(* structure on cosets, which will then hide the inherited structure *)
(* once coset_of unifies with FinGroup.sort; the coercion to         *)
(* GroupSet.sort will no longer be used.                             *)
(*   Note that for Hx Hy : coset_of H, Hx * Hy : {set gT} can mean   *)
(*      either set_of_coset (mulg Hx Hy)                             *)
(*          OR mulg (set_of_coset Hx) (set_of_coset Hy)              *)
(* However, since the two terms are actually convertible, we can     *)
(* live with this ambiguity.                                         *)
(*   We take great care that neither the type coset_of H, its        *)
(* finGroupType structure, nor the coset H morphism depend on the    *)
(* actual group structure of H. Otherwise, rewriting would be        *)
(* extremely awkward because all our equalities are stated at the    *)
(* set level.                                                        *)
(*   The trick we use is to interpret coset_of A, when A is any set, *)
(* as the type of cosets of the group <A> generated by A, in the     *)
(* group <A, N(A)> generated by A and its normaliser. This coincides *)
(* with the type of bilateral cosets of A when A is a group. We      *)
(* restrict the domain of coset_of A to 'N(A), so that we get almost *)
(* all the same conversion equalities as if we had forced A to be a  *)
(* group in the first place -- the only exception is that            *)
(*      1 : coset_of A : set _ = <<A>> rather than A,                *)
(* is covered by the genGid lemma.                                   *)

Notation H := <<A>>.
Definition coset_range := [pred B \in rcosets H 'N(A)].

Record coset_of : Type :=
  Coset { set_of_coset :> GroupSet.sort gT; _ : coset_range set_of_coset }.

Canonical Structure coset_subType :=
  Eval hnf in [subType for set_of_coset by coset_of_rect].
Definition coset_eqMixin := Eval hnf in [eqMixin of coset_of by <:].
Canonical Structure coset_eqType := Eval hnf in EqType coset_eqMixin.
Definition coset_choiceMixin := [choiceMixin of coset_of by <:].
Canonical Structure coset_choiceType :=
  Eval hnf in ChoiceType coset_choiceMixin.
Definition coset_countMixin := [countMixin of coset_of by <:].
Canonical Structure coset_countType := Eval hnf in CountType coset_countMixin.
Canonical Structure coset_subCountType :=
  Eval hnf in [subCountType of coset_of].
Definition coset_finMixin := [finMixin of coset_of by <:].
Canonical Structure coset_finType := Eval hnf in FinType coset_finMixin.
Canonical Structure coset_subFinType := Eval hnf in [subFinType of coset_of].

(* We build a new (canonical) structure of groupType for cosets.      *)
(* When A is a group, this is the largest possible quotient 'N(A) / A *)

Lemma coset_one_proof : coset_range H.
Proof. by apply/rcosetsP; exists (1 : gT); rewrite (group1, mulg1). Qed.
Definition coset_one := Coset coset_one_proof.

Let nNH := subsetP (norm_gen A).

Lemma coset_range_mul : forall B C : coset_of, coset_range (B * C).
Proof.
case=> B /=; case/rcosetsP=> x Nx ->{B} [C] /=; case/rcosetsP=> y Ny ->{C}.
by apply/rcosetsP; exists (x * y); rewrite !(groupM, rcoset_mul, nNH).
Qed.

Definition coset_mul B C := Coset (coset_range_mul B C).

Lemma coset_range_inv : forall B : coset_of, coset_range B^-1.
Proof.
case=> B /=; case/rcosetsP=> x Nx ->{B}.
rewrite norm_rlcoset ?nNH // invg_lcoset.
by apply/rcosetsP; exists x^-1; rewrite ?groupV.
Qed.

Definition coset_inv B := Coset (coset_range_inv B).

Lemma coset_mulP : associative coset_mul.
Proof. by move=> B C D; apply: val_inj; rewrite /= mulgA. Qed.

Lemma coset_oneP : left_id coset_one coset_mul.
Proof.
case=> B coB; apply: val_inj => /=; case/rcosetsP: coB => x Hx ->{B}.
by rewrite mulgA mulGid.
Qed.

Lemma coset_invP : left_inverse coset_one coset_inv coset_mul.
Proof.
case=> B coB; apply: val_inj => /=; case/rcosetsP: coB => x Hx ->{B}.
rewrite invg_rcoset -mulgA (mulgA H) mulGid.
by rewrite norm_rlcoset ?nNH // -lcosetM mulVg mul1g.
Qed.

Definition coset_of_groupMixin :=
  FinGroup.Mixin coset_mulP coset_oneP coset_invP.

Canonical Structure coset_baseGroupType :=
  Eval hnf in BaseFinGroupType coset_of_groupMixin.
Canonical Structure coset_groupType := FinGroupType coset_invP.

(* Projection of the initial group type over the cosets groupType  *)

Definition coset x : coset_of := insubd (1 : coset_of) (H :* x).

(* This is a primitive lemma -- we'll need to restate it for *)
(* the case where A is a group. *)
Lemma val_coset_prim : forall x, x \in 'N(A) -> coset x :=: H :* x.
Proof.
by move=> x Nx; rewrite val_insubd /= mem_rcosets -{1}(mul1g x) mem_mulg.
Qed.

Lemma coset_morphM : {in 'N(A) &, {morph coset : x y / x * y}}.
Proof.
move=> x y Nx Ny; apply: val_inj.
by rewrite /= !val_coset_prim ?groupM //= rcoset_mul ?nNH.
Qed.

Canonical Structure coset_morphism := Morphism coset_morphM.

Lemma ker_coset_prim : 'ker coset = 'N_H(A).
Proof.
apply/setP=> z; rewrite !in_setI andbC 2!inE -val_eqE /=.
case Nz: (z \in 'N(A)); rewrite ?andbF ?val_coset_prim // !andbT.
by apply/eqP/idP=> [<-| Az]; rewrite (rcoset_refl, rcoset_id).
Qed.

Implicit Type xbar : coset_of.

Lemma coset_mem : forall y xbar, y \in xbar -> coset y = xbar.
Proof.
move=> y [/= Hx NHx] /= Hxy; apply: val_inj=> /=.
case/rcosetsP: NHx (NHx) Hxy => x Nx -> NHx Hxy.
by rewrite val_insubd /= (rcoset_transl Hxy) NHx.
Qed.

(* coset is an inverse to repr *)

Lemma mem_repr_coset : forall xbar, repr xbar \in xbar.
Proof. case=> xbar /=; case/rcosetsP=> x _ ->; exact: mem_repr_rcoset. Qed.

Lemma repr_coset1 : repr (1 : coset_of) = 1.
Proof. exact: repr_group. Qed.

Lemma coset_reprK : cancel (fun xbar => repr xbar) coset.
Proof. move=> xbar; exact: coset_mem (mem_repr_coset xbar). Qed.

(* cosetP is slightly stronger than using repr because we only *)
(* guarantee  repr xbar \in 'N(A) when A is a group.           *)
Lemma cosetP : forall xbar, {x | x \in 'N(A) & xbar = coset x}.
Proof.
move=> xbar; pose x := repr 'N_xbar(A).
have [xbar_x Nx]: x \in xbar /\ x \in 'N(A).
  apply/setIP; rewrite {}/x; case: xbar => Hy /=.
  by case/rcosetsP=> y Ny ->; apply: (@mem_repr _ y); rewrite inE rcoset_refl.
by exists x; last rewrite (coset_mem xbar_x).
Qed.

Lemma coset_id : forall x, x \in A -> coset x = 1.
Proof. move=> x Ax; apply: coset_mem; exact: mem_gen. Qed.

Lemma coset_imT : coset @* 'N(A) = setT.
Proof.
by apply/setP=> xbar; case: (cosetP xbar) => x Nx ->; rewrite inE mem_morphim.
Qed.

Lemma coset_im : forall C : {set coset_of}, C \subset coset @* 'N(A).
Proof. by move=> C; rewrite coset_imT subsetT. Qed.

Definition quotient : {set coset_of} := coset @* Q.

Lemma quotientE : quotient = coset @* Q. Proof. by []. Qed.

End Cosets.

Prenex Implicits coset_of coset.
Arguments Scope quotient [_ group_scope group_scope].

Bind Scope group_scope with coset_of.

Notation "A / B" := (quotient A B) : group_scope.

Section CosetOfGroupTheory.

Variables (gT : finGroupType) (H : {group gT}).
Implicit Types A B : {set gT}.
Implicit Types G K : {group gT}.
Implicit Types xbar yb : coset_of H.
Implicit Types C D : {set coset_of H}.
Implicit Types L M : {group coset_of H}.

Canonical Structure quotient_group G A : {group coset_of A} :=
  Eval hnf in [group of G / A].

Infix "/" := quotient_group : subgroup_scope.

Lemma val_coset : forall x, x \in 'N(H) -> coset H x :=: H :* x.
Proof. by move=> x Nx; rewrite val_coset_prim // genGid. Qed.

Lemma coset_default : forall x, (x \in 'N(H)) = false -> coset H x = 1.
Proof.
move=> x Nx; apply: val_inj.
by rewrite val_insubd /= mem_rcosets /= genGid mulSGid ?normG ?Nx.
Qed.

Lemma coset_norm : forall xbar, xbar \subset 'N(H).
Proof.
case=> Hx /=; case/rcosetsP=> x Nx ->.
by rewrite genGid mul_subG ?sub1set ?normG.
Qed.

Lemma ker_coset : 'ker (coset H) = H.
Proof. by rewrite ker_coset_prim genGid (setIidPl _) ?normG. Qed.

Lemma coset_idr : forall x, x \in 'N(H) -> coset H x = 1 -> x \in H.
Proof. by move=> x Nx Hx1; rewrite -ker_coset mem_morphpre //= Hx1 set11. Qed.

Lemma repr_coset_norm : forall xbar, repr xbar \in 'N(H).
Proof. move=> xbar; exact: subsetP (coset_norm _) _ (mem_repr_coset _). Qed.

Lemma imset_coset : forall G, coset H @: G = G / H.
Proof.
move=> G; apply/eqP; rewrite eqEsubset andbC imsetS ?subsetIr //=.
apply/subsetP=> xbar; case/imsetP=> x Gx -> {xbar}.
by case Nx: (x \in 'N(H)); rewrite ?(coset_default Nx) ?mem_morphim ?group1.
Qed.

Lemma val_quotient : forall A, val @: (A / H) = rcosets H 'N_A(H).
Proof.
move=> A; apply/setP=> B; apply/imsetP/rcosetsP=> [[xbar Axbar]|[x ANx]] ->{B}.
  case/morphimP: Axbar => x Nx Ax ->{xbar}.
  by exists x; [rewrite inE Ax | rewrite /= val_coset].
case/setIP: ANx => Ax Nx.
by exists (coset H x); [apply/morphimP; exists x | rewrite /= val_coset].
Qed.

Lemma card_quotient_subnorm : forall A, #|A / H| = #|'N_A(H) : H|.
Proof. by move=> A; rewrite -(card_imset _ val_inj) val_quotient. Qed.

Lemma card_quotient : forall A, A \subset 'N(H) -> #|A / H| = #|A : H|.
Proof. by move=> A nHA; rewrite card_quotient_subnorm (setIidPl nHA). Qed.

(* Specializing all the morphisms lemmas that have different assumptions    *)
(* (e.g., because 'ker (coset H) = H), or conclusions (e.g., because we use *)
(* A / H rather than coset H @* A). We may want to reevaluate later, and    *)
(* eliminate variants that aren't used                                  .   *)

(* Variant of morph1; no specialization for other morph lemmas. *)
Lemma coset1 : coset H 1 :=: H.
Proof. by rewrite morph1 /= genGid. Qed.

(* Variant of kerE. *)
Lemma cosetpre1 : coset H @*^-1 1 = H.
Proof. by rewrite -kerE ker_coset. Qed.

(* Variant of morphimEdom; mophimE[sub] covered by imset_coset. *)
(* morph[im|pre]Iim are also covered by quotientT.              *)
Lemma quotientT : 'N(H) / H = setT.
Proof. exact: coset_imT. Qed.

(* Variant of morphimIdom. *)
Lemma quotientInorm : forall A, 'N_A(H) / H = A / H.
Proof. by move=> A; rewrite /quotient setIC morphimIdom. Qed.

Lemma mem_quotient : forall x G, x \in G -> coset H x \in G / H.
Proof. by move=> x G Gx; rewrite -imset_coset mem_imset. Qed.

Lemma quotientS : forall A B, A \subset B -> A / H \subset B / H.
Proof. exact: morphimS. Qed.

Lemma quotient0 : set0 / H = set0.
Proof. exact: morphim0. Qed.

Lemma quotient_set1 : forall x, x \in 'N(H) -> [set x] / H = [set coset H x].
Proof. exact: morphim_set1. Qed.

Lemma quotient1 : 1 / H = 1.
Proof. exact: morphim1. Qed.

Lemma quotientV : forall A, A^-1 / H = (A / H)^-1.
Proof. exact: morphimV. Qed.

Lemma quotientMl : forall A B,
  A \subset 'N(H) -> A * B / H = (A / H) * (B / H).
Proof. exact: morphimMl. Qed.

Lemma quotientMr : forall A B,
  B \subset 'N(H) -> A * B / H = (A / H) * (B / H).
Proof. exact: morphimMr. Qed.

Lemma cosetpreM : forall C D,
  coset H @*^-1 (C * D) = coset H @*^-1 C * coset H @*^-1 D.
Proof. by move=> C D; rewrite morphpreMl ?coset_im. Qed.

Lemma quotientJ : forall A x, x \in 'N(H) -> A :^ x / H = (A / H) :^ coset H x.
Proof. exact: morphimJ. Qed.

Lemma quotientU : forall A B, (A :|: B) / H = A / H :|: B / H.
Proof. exact: morphimU. Qed.

Lemma quotientI : forall A B, (A :&: B) / H \subset A / H :&: B / H.
Proof. exact: morphimI. Qed.

Lemma coset_kerl : forall x y, x \in H -> coset H (x * y) = coset H y.
Proof.
move=> x y Hx; case Ny: (y \in 'N(H)); first by rewrite mkerl ?ker_coset.
by rewrite !coset_default ?groupMl // (subsetP (normG H)).
Qed.

Lemma coset_kerr : forall x y, y \in H -> coset H (x * y) = coset H x.
Proof.
move=> x y Hy; case Nx: (x \in 'N(H)); first by rewrite mkerr ?ker_coset.
by rewrite !coset_default ?groupMr // (subsetP (normG H)).
Qed.

Lemma rcoset_kercosetP : forall x y,
  x \in 'N(H) -> y \in 'N(H) -> reflect (coset H x = coset H y) (x \in H :* y).
Proof. rewrite -{6}ker_coset; exact: rcoset_kerP. Qed.

Lemma kercoset_rcoset : forall x y,
  x \in 'N(H) -> y \in 'N(H) ->
    coset H x = coset H y -> exists2 z, z \in H & x = z * y.
Proof. move=> x y Gx Gy eqfxy; rewrite -ker_coset; exact: ker_rcoset. Qed.

Lemma quotientGI : forall G A, H \subset G -> (G :&: A) / H = G / H :&: A / H.
Proof. rewrite -{1}ker_coset; exact: morphimGI. Qed.

Lemma quotientIG : forall A G, H \subset G -> (A :&: G) / H = A / H :&: G / H.
Proof. rewrite -{1}ker_coset. exact: morphimIG. Qed.

Lemma quotientD : forall A B, A / H :\: B / H \subset (A :\: B) / H.
Proof. exact: morphimD. Qed.

Lemma quotientDG : forall A G, H \subset G -> (A :\: G) / H = A / H :\: G / H.
Proof. rewrite -{1}ker_coset; exact: morphimDG. Qed.

Lemma quotientK : forall A, A \subset 'N(H) -> coset H @*^-1 (A / H) = H * A.
Proof. rewrite -{8}ker_coset; exact: morphimK. Qed.

Lemma quotientGK : forall G, H <| G -> coset H @*^-1 (G / H) = G.
Proof. move=> G; case/andP; rewrite -{1}ker_coset; exact: morphimGK. Qed.

Lemma cosetpre_set1 : forall x,
  x \in 'N(H) -> coset H @*^-1 [set coset H x] = H :* x.
Proof. by rewrite -{9}ker_coset; exact: morphpre_set1. Qed.

Lemma cosetpre_set1_coset : forall xbar, coset H @*^-1 [set xbar] = xbar.
Proof.
move=> xbar; case: (cosetP xbar) => x Nx ->.
by rewrite cosetpre_set1 ?val_coset.
Qed.

Lemma cosetpreK : forall C, coset H @*^-1 C / H = C.
Proof. by move=> C; rewrite /quotient morphpreK ?coset_im. Qed.

(* Variant of morhphim_ker *)
Lemma trivg_quotient : H / H = 1.
Proof. by rewrite -{3}ker_coset /quotient morphim_ker. Qed.

Lemma sub_cosetpre : forall M, H \subset coset H @*^-1 M.
Proof. rewrite -{3}ker_coset; exact: ker_sub_pre. Qed.

Lemma normal_cosetpre : forall M, H <| coset H @*^-1 M.
Proof. rewrite -{3}ker_coset; exact: ker_normal_pre. Qed.

Lemma cosetpreSK : forall C D,
  (coset H @*^-1 C \subset coset H @*^-1 D) = (C \subset D).
Proof. by move=> C D; rewrite morphpreSK ?coset_im. Qed.

Lemma sub_quotient_pre : forall A C,
  A \subset 'N(H) -> (A / H \subset C) = (A \subset coset H @*^-1 C).
Proof. by move=> A C; exact: sub_morphim_pre. Qed.

Lemma sub_cosetpre_quo : forall C G,
  H <| G -> (coset H @*^-1 C \subset G) = (C \subset G / H).
Proof. by move=> C G nHG; rewrite -cosetpreSK quotientGK. Qed.

(* Variant of ker_trivg_morphim. *)
Lemma quotient_sub1 : forall A,
  A \subset 'N(H) -> (A / H \subset [1]) = (A \subset H).
Proof. by move=> A nHA /=; rewrite -{10}ker_coset ker_trivg_morphim nHA. Qed.

Lemma quotientSK : forall A B,
  A \subset 'N(H) -> (A / H \subset B / H) = (A \subset H * B).
Proof. by move=> A B nHA; rewrite morphimSK ?ker_coset. Qed.

Lemma quotientSGK : forall A G,
  A \subset 'N(H) -> H \subset G -> (A / H \subset G / H) = (A \subset G).
Proof. rewrite -{2}ker_coset; exact: morphimSGK. Qed.

Lemma quotient_injG :
  {in [pred G : {group gT} | H <| G] &, injective (fun G => G / H)}.
Proof. rewrite /normal -{1}ker_coset; exact: morphim_injG. Qed.

Lemma quotient_inj : forall G1 G2,
   H <| G1 -> H <| G2 -> G1 / H = G2 / H -> G1 :=: G2.
Proof. rewrite /normal -{1 3}ker_coset; exact: morphim_inj. Qed.

Lemma quotient_gen : forall A, A \subset 'N(H) -> <<A>> / H = <<A / H>>.
Proof. exact: morphim_gen. Qed.

Lemma cosetpre_gen : forall C,
  1 \in C -> coset H @*^-1 <<C>> = <<coset H @*^-1 C>>.
Proof. by move=> C C1; rewrite morphpre_gen ?coset_im. Qed.

Lemma quotientR : forall A B,
  A \subset 'N(H) -> B \subset 'N(H) -> [~: A, B] / H = [~: A / H, B / H].
Proof. exact: morphimR. Qed.

Lemma quotient_norm : forall A, 'N(A) / H \subset 'N(A / H).
Proof. exact: morphim_norm. Qed.

Lemma quotient_norms : forall A B, A \subset 'N(B) -> A / H \subset 'N(B / H).
Proof. exact: morphim_norms. Qed.

Lemma quotient_subnorm : forall A B, 'N_A(B) / H \subset 'N_(A / H)(B / H).
Proof. exact: morphim_subnorm. Qed.

Lemma quotient_normal : forall A B, A <| B -> A / H <| B / H.
Proof. exact: morphim_normal. Qed.

Lemma quotient_cent1 : forall x, 'C[x] / H \subset 'C[coset H x].
Proof.
move=> x; case Nx: (x \in 'N(H)); first exact: morphim_cent1.
by rewrite coset_default // cent11T subsetT.
Qed.

Lemma quotient_cent1s : forall A x,
  A \subset 'C[x] -> A / H \subset 'C[coset H x].
Proof.
move=> A x sAC; exact: subset_trans (quotientS sAC) (quotient_cent1 x).
Qed.

Lemma quotient_subcent1 : forall A x,
  'C_A[x] / H \subset 'C_(A / H)[coset H x].
Proof.
move=> A x; exact: subset_trans (quotientI _ _) (setIS _ (quotient_cent1 x)).
Qed.

Lemma quotient_cent : forall A, 'C(A) / H \subset 'C(A / H).
Proof. exact: morphim_cent. Qed.

Lemma quotient_cents : forall A B,
  A \subset 'C(B) -> A / H \subset 'C(B / H).
Proof. exact: morphim_cents. Qed.

Lemma quotient_abelian : forall A, abelian A -> abelian (A / H).
Proof. exact: morphim_abelian. Qed.

Lemma quotient_subcent : forall A B, 'C_A(B) / H \subset 'C_(A / H)(B / H).
Proof. exact: morphim_subcent. Qed.

Lemma cosetpre_normal : forall C D,
  (coset H @*^-1 C <| coset H @*^-1 D) = (C <| D).
Proof. by move=> C D; rewrite morphpre_normal ?coset_im. Qed.

Lemma quotient_normG : forall G, H <| G -> 'N(G) / H = 'N(G / H).
Proof.
move=> G; case/andP=> sHG nHG.
by rewrite [_ / _]morphim_normG ?ker_coset // coset_imT setTI.
Qed.

Lemma quotient_subnormG : forall A G,
   H <| G -> 'N_A(G) / H = 'N_(A / H)(G / H).
Proof.
by move=> A G; case/andP=> sHG nHG; rewrite -morphim_subnormG ?ker_coset.
Qed.

Lemma cosetpre_cent1 : forall x,
  'C_('N(H))[x] \subset coset H @*^-1 'C[coset H x].
Proof.
move=> x; case Nx: (x \in 'N(H)); first by rewrite morphpre_cent1.
by rewrite coset_default // cent11T morphpreT subsetIl.
Qed.

Lemma cosetpre_cent1s : forall C x,
  coset H @*^-1 C \subset 'C[x] -> C \subset 'C[coset H x].
Proof.
move=> C x sC; rewrite -cosetpreSK; apply: subset_trans (cosetpre_cent1 x).
by rewrite subsetI subsetIl.
Qed.

Lemma cosetpre_subcent1 : forall C x,
  'C_(coset H @*^-1 C)[x] \subset coset H @*^-1 'C_C[coset H x].
Proof.
move=> C x; rewrite -morphpreIdom -setIA setICA morphpreI setIS //.
exact: cosetpre_cent1.
Qed.

Lemma cosetpre_cent : forall A, 'C_('N(H))(A) \subset coset H @*^-1 'C(A / H).
Proof. exact: morphpre_cent. Qed.

Lemma cosetpre_cents : forall A C,
  coset H @*^-1 C \subset 'C(A) -> C \subset 'C(A / H).
Proof. by move=> A C; apply: morphpre_cents; rewrite ?coset_im. Qed.

Lemma cosetpre_subcent : forall C A,
  'C_(coset H @*^-1 C)(A) \subset coset H @*^-1 'C_C(A / H).
Proof. exact: morphpre_subcent. Qed.

Section InverseImage.

Variables (G : {group gT}) (Kbar : {group coset_of H}).

Hypothesis nHG : H <| G.

CoInductive inv_quotient_spec (P : pred {group gT}) : Prop :=
  InvQuotientSpec K of Kbar :=: K / H & H \subset K & P K.

Lemma inv_quotientS :
  Kbar \subset G / H -> inv_quotient_spec (fun K => K \subset G).
Proof.
case/andP: nHG => sHG nHG' sKbarG.
have sKdH: Kbar \subset 'N(H) / H by rewrite (subset_trans sKbarG) ?morphimS.
exists (coset H @*^-1 Kbar)%G; first by rewrite cosetpreK.
  by rewrite -{1}ker_coset morphpreS ?sub1G.
by rewrite sub_cosetpre_quo.
Qed.

Lemma inv_quotientN : Kbar <| G / H -> inv_quotient_spec (fun K => K <| G).
Proof.
move=> nKbar; case/inv_quotientS: (normal_sub nKbar) => K defKbar sHK sKG.
exists K => //; rewrite defKbar -cosetpre_normal !quotientGK // in nKbar.
exact: normalS nHG.
Qed.

End InverseImage.

Lemma quotient_mulg : forall A, A * H / H = A / H.
Proof.
move=> A; rewrite [_ /_]morphimMr ?normG //= -!quotientE.
by rewrite trivg_quotient mulg1.
Qed.

Lemma quotient_mulgr : forall A, H * A / H = A / H.
Proof.
move=> A; rewrite [_ /_]morphimMl ?normG //= -!quotientE.
by rewrite trivg_quotient mul1g.
Qed.

Lemma quotient_mulgen : forall G, G \subset 'N(H) -> G <*> H / H = G / H.
Proof.
move=> G nHG; rewrite -genM_mulgen quotientE morphim_gen -?quotientE.
  by rewrite quotient_mulg genGid.
by rewrite -(mulSGid nHG) mulgS ?normG.
Qed.

Section Injective.

Variables (G : {group gT}).
Hypotheses (nHG : G \subset 'N(H)) (trGH : G :&: H = 1).

Lemma quotient_isom : isom G (G / H) (restrm nHG (coset H)).
Proof.
by apply/isomP; rewrite ker_restrm ker_coset morphim_restrm setIid trGH.
Qed.

Lemma quotient_isog : isog G (G / H).
Proof. exact: isom_isog quotient_isom. Qed.

End Injective.

End CosetOfGroupTheory.

Notation "A / H" := (quotient_group A H) : subgroup_scope.

Section Quotient1.

Variables (gT : finGroupType) (A : {set gT}).

Lemma coset1_injm : 'injm (@coset gT 1).
Proof. by rewrite ker_coset /=. Qed.

Lemma quotient1_isom : isom A (A / 1) (coset 1).
Proof. by apply: sub_isom coset1_injm; rewrite ?norms1. Qed.

Lemma quotient1_isog : isog A (A / 1).
Proof. apply: isom_isog quotient1_isom; exact: norms1. Qed.

End Quotient1.

Section QuotientMorphism.

Variable (gT : finGroupType) (G H : {group gT}) (f : {morphism G >-> gT}).

Implicit Types A : {set gT}.
Implicit Types B : {set (coset_groupType H)}.
Hypotheses (nHG : H <| G) (nGf : f @* G = G) (nHf : f @* H = H).

Notation fH := (coset H \o f).

Lemma quotm_restr_proof : G \subset 'dom fH.
Proof. by rewrite -sub_morphim_pre // nGf; case/andP: nHG. Qed.

Notation fH_G := (restrm quotm_restr_proof fH).

Lemma quotm_fact_proof1 : G \subset 'N(H).
Proof. by case/andP: nHG. Qed.

Lemma quotm_fact_proof2 : 'ker (coset H) \subset 'ker fH_G.
Proof.
case/andP: nHG => sHG _; rewrite ker_restrm ker_comp ker_coset subsetI.
by rewrite -sub_morphim_pre sHG ?nHf /=.
Qed.

Definition quotm := factm quotm_fact_proof1 quotm_fact_proof2.
Canonical Structure quotm_morphism := Eval hnf in [morphism of quotm].

Lemma morphim_quotm : forall A, quotm @* (A / H) = f @* A / H.
Proof.
case/andP: nHG => sHG nHG' A.
by rewrite morphim_factm morphim_restrm morphim_comp morphimIdom.
Qed.

Lemma cosetpre_quotm : forall A,
  quotm @*^-1 (A / H) = f @*^-1 A / H.
Proof.
case/andP: nHG => sHG nHG' A; rewrite morphpre_factm morphpre_restrm.
rewrite morphpre_comp morphpreIdom quotientE -(morphimIdom _ A) /= -quotientE.
rewrite morphimK ?subsetIl // ker_coset morphpreMl ?nGf // -{3}nHf morphimK //.
rewrite -morphpreIim setIA -(morphpreIim _ A) !nGf (setIidPl nHG').
rewrite [_ * H]normC; last by apply: subset_trans nHG'; rewrite subsetIl.
by rewrite -mulgA quotient_mulgr -morphpreMl (mul1g, sub1G).
Qed.

Lemma ker_quotm : 'ker quotm = 'ker f / H.
Proof. by rewrite -cosetpre_quotm /quotient morphim1. Qed.

Lemma injm_quotm : 'injm f -> 'injm quotm.
Proof. by move/trivgP=> /= kf1; rewrite ker_quotm kf1 quotientE morphim1. Qed.

End QuotientMorphism.

Section FirstIsomorphism.

Variables aT rT : finGroupType.

Lemma first_isom : forall (G : {group aT}) (f : {morphism G >-> rT}),
  {g : {morphism G / 'ker f >-> rT} | 'injm g &
      forall A : {set aT}, g @* (A / 'ker f) = f @* A}.
Proof.
move=> G f; have nkG := ker_norm f.
have skk: 'ker (coset ('ker f)) \subset 'ker f by rewrite ker_coset.
exists (factm_morphism nkG skk) => /=; last exact: morphim_factm.
by rewrite ker_factm -quotientE trivg_quotient.
Qed.

Variables (G H : {group aT}) (f : {morphism G >-> rT}).
Hypothesis sHG : H \subset G.

Lemma first_isog : (G / 'ker f) \isog (f @* G).
Proof.
by case: (first_isom f) => g injg im_g; apply/isogP; exists g; rewrite ?im_g.
Qed.

Lemma first_isom_loc : {g : {morphism H / 'ker_H f >-> rT} |
 'injm g & forall A : {set aT}, A \subset H -> g @* (A / 'ker_H f) = f @* A}.
Proof.
case: (first_isom (restrm_morphism sHG f)).
rewrite ker_restrm => g injg im_g; exists g => // A sAH.
by rewrite im_g morphim_restrm (setIidPr sAH).
Qed.

Lemma first_isog_loc : (H / 'ker_H f) \isog (f @* H).
Proof.
by case: first_isom_loc => g injg im_g; apply/isogP; exists g; rewrite ?im_g.
Qed.

End FirstIsomorphism.

Section SecondIsomorphism.

Variables (gT : finGroupType) (H K : {group gT}).

Hypothesis nKH : H \subset 'N(K).

Lemma second_isom : {f : {morphism H / (K :&: H) >-> coset_of K} |
  'injm f & forall A : {set gT}, A \subset H -> f @* (A / (K :&: H)) = A / K}.
Proof.
have ->: K :&: H = 'ker_H (coset K) by rewrite ker_coset setIC.
exact: first_isom_loc.
Qed.

Lemma second_isog : H / (K :&: H) \isog H / K.
Proof. rewrite setIC -{1 3}(ker_coset K); exact: first_isog_loc. Qed.

Lemma weak_second_isog : H / (K :&: H) \isog H * K / K.
Proof. rewrite quotient_mulg; exact: second_isog. Qed.

End SecondIsomorphism.

Section ThirdIsomorphism.

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

Hypothesis sHK : H \subset K.
Hypothesis snHG : H <| G.
Hypothesis snKG : K <| G.

Theorem third_isom : {f : {morphism (G / H) / (K / H) >-> coset_of K} | 'injm f
   & forall A : {set gT}, A \subset G -> f @* (A / H / (K / H)) = A / K}.
Proof.
case/andP: snKG => sKG nKG; case/andP: snHG => sHG nHG.
have sHker: 'ker (coset H) \subset 'ker (restrm nKG (coset K)).
  by rewrite ker_restrm !ker_coset subsetI sHG.
have:= first_isom_loc (factm_morphism nHG sHker) (subxx _) => /=.
rewrite ker_factm_loc ker_restrm ker_coset !(setIidPr sKG) /= -!quotientE.
case=> f injf im_f; exists f => // A sAG; rewrite im_f ?morphimS //.
by rewrite morphim_factm morphim_restrm (setIidPr sAG).
Qed.

Theorem third_isog : (G / H / (K / H)) \isog (G / K).
Proof.
by case: third_isom => f inj_f im_f; apply/isogP; exists f; rewrite ?im_f.
Qed.

End ThirdIsomorphism.

Lemma char_from_quotient : forall (gT : finGroupType) (G H K : {group gT}),
  H <| K -> H \char G -> K / H \char G / H -> K \char G.
Proof.
move=> gT G H K; case/andP=> sHK nHK chHG; case/charP=> sKG chKG.
have nHG := char_normal chHG; case: (andP nHG) => sHG nHG'.
rewrite -(ker_coset H) in sHK; rewrite morphimSGK ?ker_coset // in sKG.
apply/charP; split=> // f injf Gf; apply/morphim_fixP => //.
have{chHG} Hf: f @* H = H by case/charP: chHG => _; apply.
rewrite -(morphimSGK _ sHK) -?quotientE; last first.
  by apply: subset_trans nHG'; rewrite -{3}Gf morphimS.
rewrite -(morphim_quotm nHG Gf Hf) {}chKG // ?injm_quotm //.
by rewrite morphim_quotm Gf.
Qed.

(* Counting lemmas for morphisms. *)

Section CardMorphism.

Variables (aT rT : finGroupType) (D : {group aT}) (f : {morphism D >-> rT}).
Implicit Types G H : {group aT}.
Implicit Types L M : {group rT}.

Lemma card_morphim : forall G, #|f @* G| = #|D :&: G : 'ker f|.
Proof.
move=> G; rewrite -morphimIdom -indexgI -card_quotient; last first.
  by rewrite normsI ?normG ?subIset ?ker_norm.
by apply: esym (isog_card _); rewrite first_isog_loc ?subsetIl.
Qed.

Lemma dvdn_morphim :  forall G, #|f @* G| %| #|G|.
Proof.
move=> G; rewrite card_morphim (dvdn_trans (dvdn_indexg _ _)) //.
by rewrite cardSg ?subsetIr.
Qed.

Lemma index_morphim_ker : forall G H,
    H \subset G -> G \subset D ->
  (#|f @* G : f @* H| * #|'ker_G f : H|)%N = #|G : H|.
Proof.
move=> G H sHG sGD; apply/eqP.
rewrite -(eqn_pmul2l (cardG_gt0 (f @* H))) mulnA LaGrange ?morphimS //.
rewrite !card_morphim (setIidPr sGD) (setIidPr (subset_trans sHG sGD)).
rewrite -(eqn_pmul2l (cardG_gt0 ('ker_H f))) /=.
by rewrite -{1}(setIidPr sHG) setIAC mulnCA mulnC mulnA !LaGrangeI LaGrange.
Qed.

Lemma index_morphim : forall G H,
  G :&: H \subset D -> #|f @* G : f @* H| %| #|G : H|.
Proof.
move=> G H dGH; rewrite -(indexgI G) -(setIidPr dGH) setIA.
apply: dvdn_trans (indexSg (subsetIl _ H) (subsetIr D G)).
rewrite -index_morphim_ker ?subsetIl ?subsetIr ?dvdn_mulr //= morphimIdom.
by rewrite indexgS ?morphimS ?subsetIr.
Qed.

Lemma index_injm : forall G H,
  'injm f -> G \subset D -> #|f @* G : f @* H| = #|G : H|.
Proof.
move=> G H injf dG; rewrite -{2}(setIidPr dG) -(indexgI _ H) /=.
rewrite -index_morphim_ker ?subsetIl ?subsetIr //= setIAC morphimIdom setIC.
rewrite injmI ?subsetIr // indexgI /= morphimIdom setIC ker_injm //.
by rewrite -(indexgI (1 :&: _)) /= -setIA !(setIidPl (sub1G _)) indexgg muln1.
Qed.

Lemma card_morphpre : forall L,
  L \subset f @* D -> #|f @*^-1 L| = (#|'ker f| * #|L|)%N.
Proof.
move=> L; move/morphpreK=> defL; rewrite -{2}defL card_morphim morphpreIdom.
by rewrite LaGrange // morphpreS ?sub1G.
Qed.

Lemma index_morphpre : forall L M,
  L \subset f @* D -> #|f @*^-1 L : f @*^-1 M| = #|L : M|.
Proof.
move=> L M dL; rewrite -!divgI -morphpreI card_morphpre //.
have: L :&: M \subset f @* D by rewrite subIset ?dL.
by move/card_morphpre->; rewrite divn_pmul2l ?cardG_gt0.
Qed.

End CardMorphism.

Section CardCosetpre.

Variables (gT : finGroupType) (G H K : {group gT}) (L M : {group coset_of H}).

Lemma dvdn_quotient : #|G / H| %| #|G|.
Proof. exact: dvdn_morphim. Qed.

Lemma index_quotient_ker :
     K \subset G -> G \subset 'N(H) ->
  (#|G / H : K / H| * #|G :&: H : K|)%N = #|G : K|.
Proof. rewrite -{5}(ker_coset H); exact: index_morphim_ker. Qed.

Lemma index_quotient : G :&: K \subset 'N(H) -> #|G / H : K / H| %| #|G : K|.
Proof. exact: index_morphim. Qed.

Lemma index_quotient_eq :
    G :&: H \subset K -> K \subset G -> G \subset 'N(H) ->
 #|G / H : K / H| = #|G : K|.
Proof.
move=> sGH_K sKG sGN; rewrite -index_quotient_ker {sKG sGN}//.
by rewrite -(indexgI _ K) (setIidPl sGH_K) indexgg muln1.
Qed.

Lemma card_cosetpre : #|coset H @*^-1 L| = (#|H| * #|L|)%N.
Proof. by rewrite card_morphpre ?ker_coset ?coset_im. Qed.

Lemma index_cosetpre : #|coset H @*^-1 L : coset H @*^-1 M| = #|L : M|.
Proof. by rewrite index_morphpre ?coset_im. Qed.

End CardCosetpre.


Require Import SfLib.

Require Import Smallstep.

Require Import Coq.Relations.Relation_Definitions.

Inductive Context {type : Type} : Type :=
| empty : Context
| update : id -> type -> Context -> Context.

Hint Constructors Context.

Fixpoint byContext {type : Type} (ctx : Context) (i : id) : option type :=
match ctx with
    | empty => None
    | update x Ty ctx' =>
        if (eq_id_dec i x) then Some Ty else byContext ctx' i
        end.

Definition context_equivalence {type : Type}  : relation Context :=
        fun (x y : Context (type := type)) => forall i, byContext x i = byContext y i.

    Notation "x '=-=' y" := (context_equivalence x y) (at level 40).

    Print reflexive.
    Print equiv.

    Theorem refl_ctxeq {x : Type}:
        reflexive _ (context_equivalence (type := x )).
        unfold reflexive; unfold context_equivalence. auto.
    Qed.

    Hint Unfold reflexive.

    Theorem symm_ctxeq {x : Type}:
        symmetric _ (context_equivalence (type := x)).
        unfold symmetric; unfold context_equivalence. auto.
    Qed.

    Hint Unfold symmetric.
    Theorem trans_ctxeq {x : Type}:
    transitive _ (context_equivalence (type :=x)).

    unfold transitive.

    unfold context_equivalence.
    intros. rewrite H; auto.
Qed.

Hint Unfold transitive.

Theorem equiv_ctxeq {x : Type}:
    equiv _ (context_equivalence (type := x)).

    unfold equiv.
    pose (refl_ctxeq (x := x)). pose (symm_ctxeq (x := x)). pose (trans_ctxeq (x:= x)).
    tauto.
Qed.

    Theorem update_shadow {z : Type}:
        forall i (x y : z) (U V : Context (type := z)),
            U =-= V ->
            update i x (update i y U) =-= update i x V.

        unfold context_equivalence. intros.
        cbn. destruct (eq_id_dec i0 i); auto.

    Qed.

    Theorem update_permute {z : Type}:
        forall i j (x y : z) U V,
            i <> j ->
            U =-= V ->
            update i x (update j y U) =-= update j y (update i x U).

        unfold context_equivalence.
        intros. cbn. destruct (eq_id_dec i0 i); destruct (eq_id_dec i0 j); auto; subst.
        destruct (H eq_refl).
    Qed.

    Theorem update_inc {z : Type}:
        forall i (x: z) U V,
            U =-= V ->
            update i x U =-= update i x V.

        unfold context_equivalence.
        intros. cbn. destruct (eq_id_dec i0 i); subst; auto.
    Qed.

Module STLCARITH.

Inductive ty : Type :=
    | TArrow : ty -> ty -> ty
    | TNat : ty.

    Hint Constructors ty.
Inductive tm : Type :=
    | tvar : id -> tm
    | tapp : tm -> tm -> tm
    | tabs : id -> ty -> tm -> tm
    | tnat : nat -> tm
    | tsucc : tm -> tm
    | tpred : tm -> tm
    | tmult : tm -> tm -> tm
    | tif0 : tm -> tm -> tm -> tm.

(* Weak Typing. 0 as False, others are true. *)

    Hint Constructors tm.

Reserved Notation "Gamma '|=' t '\in' T" (at level 40).

Inductive has_type : Context -> tm -> ty -> Prop :=
    | tyVar :
        forall G i T,
            byContext G i = Some T ->
            G |= tvar i \in T
    | tyApp :
        forall Gamma a b G T,
        Gamma |= a \in TArrow G T ->
        Gamma |= b \in G ->
        Gamma |= tapp a b \in T
    | tyAbs :
        forall Gamma i x G T,
        update i G Gamma |= x \in T ->
        Gamma |= tabs i G x \in TArrow G T
    | tyNat :
        forall i Gamma,
        Gamma |= tnat i \in TNat
    | tySucc :
        forall x Gamma,
        Gamma |= x \in TNat ->
        Gamma |= tsucc x \in TNat
    | tyPred :
        forall x Gamma,
        Gamma |= x \in TNat ->
        Gamma |= tpred x \in TNat
    | tyMult :
        forall x y Gamma,
        Gamma |= x \in TNat ->
        Gamma |= y \in TNat ->
        Gamma |= tmult x y \in TNat
    | tyIf :
        forall t t0 t1 Gamma T,
        Gamma |= t0 \in T ->
        Gamma |= t1 \in T ->
        Gamma |= t \in TNat ->
        Gamma |= tif0 t t0 t1 \in T
    where "Gamma '|=' t '\in' T " := (has_type Gamma t T).

    Hint Constructors has_type.
    Reserved Notation "'[' x ':=' s ']' t" (at level 20).

Fixpoint subst (i : id) (t org : tm) : tm :=
    match org with
        | tvar j => if(eq_id_dec i j) then t else org
        | tapp a b => tapp ([i := t] a) ([i := t] b)
        | tabs x T y => tabs x T (if (eq_id_dec x i) then y else ([i := t] y))
        | tsucc x => tsucc ([i := t] x)
        | tpred y => tpred ([i := t] y)
        | tmult x y => tmult ([i := t] x) ([i := t] y)
        | tif0 x t0 t1 => tif0 ([i := t] x) ([i := t] t0) ([i := t] t1)
        | _ => org
        end
        where "'[' x ':=' s ']' t" := (subst x s t).

Inductive value : tm -> Prop :=
    | vnat :
        forall n,
            value (tnat n)
    | vabs :
        forall x T y,
            value (tabs x T y).

Reserved Notation "t '==>' t'" (at level 40).

    Hint Constructors value.
Inductive step : tm -> tm -> Prop :=
    | ST_AppAbs :
        forall abs abs' arg,
        abs ==> abs' ->
        tapp abs arg ==> tapp abs' arg
    | ST_AppArg :
        forall abs arg arg',
        value abs ->
        arg ==> arg' ->
        tapp abs arg ==> tapp abs arg'
    | ST_App :
        forall x T y arg,
        value arg ->
        tapp (tabs x T y) arg ==> [x := arg] y
    | ST_Succ0 :
        forall n n',
        n ==> n' ->
        tsucc n ==> tsucc n'
    | ST_Succ1 :
        forall n,
        tsucc (tnat n) ==> tnat (S n)
    | ST_Pred0 :
        forall n n',
        n ==> n' ->
        tpred n ==> tpred n'
    | ST_Pred1 :
        forall n,
        tpred (tnat n) ==> tnat (pred n)
    | ST_Mult0 :
        forall n0 n0' n1,
        n0 ==> n0' ->
        tmult n0 n1 ==> tmult n0' n1
    | ST_Mult1 :
        forall n0 n1 n1',
        value n0 ->
        n1 ==> n1' ->
        tmult n0 n1 ==> tmult n0 n1'
    | ST_Mult2 :
        forall n0 n1,
        tmult (tnat n0) (tnat n1) ==> tnat (n0 * n1)
    | ST_If0 :
        forall t t' t0 t1,
        t ==> t' ->
        tif0 t t0 t1 ==> tif0 t' t0 t1
    | ST_IfFalse :
        forall t0 t1,
        tif0 (tnat 0) t0 t1 ==> t1
    | ST_IfTrue :
        forall t t0 t1,
        t <> 0 ->
        tif0 (tnat t) t0 t1 ==> t0
    where "t '==>' t'" := (step t t').

    Hint Constructors step.

    Theorem deterministic_step :
        deterministic step.

    unfold deterministic.
    intros x y1 y2 h.
    generalize dependent y2.
    elim h; intros.

    inversion H1; subst. pose (H0 _ H5). rewrite e; auto.
    inversion H4; subst. inversion H.

    Abort.

    Lemma value_cant_step:
        forall n n',
        value n ->
        n ==> n' ->
        False.
    intros n n' h.
    generalize dependent n'.
    elim h; subst; intros.
    inversion H. inversion H.
Qed.

Ltac value_no_stepping_ :=
    match goal with
     | [ H1 : tabs ?X ?T ?Y ==> ?Z |- _ ] => inversion H1
     | [ H1 : tnat ?N ==> ?Z |- _ ] => inversion H1
     | [ H1 : value ?X, H2 : ?X ==> ?Z |- _ ] => destruct (value_cant_step _ _ H1 H2)
     end.

Ltac value_no_stepping := repeat value_no_stepping_.

Theorem deterministic_step :
     deterministic step.

     unfold deterministic.
     intros x y1 y2 h.
     generalize dependent y2.
     elim h; intros until y2; intro HH;
     inversion HH; subst; try value_no_stepping; auto.

     pose (H0 _ H4). rewrite e; auto.

     pose (H1 _ H6). rewrite e; auto.

     rewrite (H0 _ H2); auto.

     rewrite (H0 _ H2); auto.

     rewrite (H0 _ H4); auto.

     rewrite (H1 _ H6); auto.

     rewrite (H0 _ H5); auto.

     destruct (H3 eq_refl).
     destruct (H eq_refl).

Qed.

Lemma canonical_forms_bool :
    forall t,
    empty |= t \in TNat ->
    value t ->
    (exists i, t = tnat i).

    intros. inversion H0; subst.
    exists n; auto.
    inversion H; subst.
Qed.

Lemma canonical_forms_fun :
    forall t G T,
        empty |= t \in TArrow G T ->
        value t ->
        (exists x v, t = tabs x G v).

    intros. inversion H0; subst.
    inversion H.
    exists x. exists y. inversion H; subst. auto.

Qed.

Hint Unfold byContext.

Theorem progress :
    forall t T,
        empty |= t \in T ->
        value t \/ (exists t', t ==> t').

    intro. elim t; intros.
    inversion H; subst.  inversion H2.

    inversion H1; subst.
    right.
    destruct (H _ H5).
    destruct (H0 _ H7).
    inversion H2; subst. inversion H5.
    exists ([x := t1] y). eauto.

    destruct H3. exists (tapp t0 x). eauto.
    destruct H2. exists (tapp x t1). eauto.

    left; eauto.
    left; eauto.

    right. inversion H0; subst.
    destruct (H _ H3).
    inversion H1; subst.
    exists (tnat (S n)). eauto.
    inversion H3.
    destruct H1.
    exists (tsucc x). eauto.

    right. inversion H0; subst.
    destruct (H _ H3). inversion H1; subst.
    exists (tnat (pred n)); eauto.
    inversion H3.

    destruct H1.
    exists (tpred x). eauto.

    right. inversion H1; subst.
    destruct  (H _ H5). destruct (H0 _ H7).
    inversion H2; inversion H3; subst.
    exists (tnat (n * n0)); eauto.

    inversion H7. inversion H5. inversion H5.

    destruct H3.
    exists (tmult t0 x). eauto.

    destruct H2.
    exists (tmult x t1). eauto.

    right. inversion H2; subst.
    destruct (H _ H10). inversion H3; subst.
    destruct n. exists t2; eauto.
    assert (S n <> 0); eauto.
    inversion H10.
    destruct H3.
    exists (tif0 x t1 t2); eauto.
Qed.

Theorem preservation :
    forall t t' T,
        empty |= t \in T ->
        step t t' ->
        empty |= t' \in T.

    intro. elim t; intros.
    inversion H0.

    inversion H1; inversion H2; subst; eauto.

    Abort.

Lemma app_preserv:
    forall t x y T G U,
        U |= tabs x T t \in TArrow T G ->
        empty |= y \in T ->
        U |= [x := y] t \in G.
    intro t. elim t; intros.
    inversion H; subst. unfold subst.
    inversion H3; subst. unfold byContext in *.
    destruct (eq_id_dec i x); subst. inversion H4; subst.
    rewrite eq_id_dec_id.

    Abort.

(*
Theorem update_shadow:
    forall U i x y,
    update i x (update i y U) =-= update i x U.

    unfold context_equivalence.
    intro. induction U; intros.
    unfold byContext in *.
    destruct (eq_id_dec i0 i); subst; auto.

    unfold byContext in *.
    destruct (eq_id_dec i1 i0); subst; auto.

Qed.

Theorem update_permute:
    forall U i j x y,
    i <> j ->
    update i x (update j y U) =-= update j y (update i x U).

    intro.

    induction U; intros.
    unfold context_equivalence. intros.
    unfold byContext in *. destruct (eq_id_dec i0 i); destruct (eq_id_dec i0 j); subst; eauto.
    destruct (H eq_refl).

    destruct (eq_id_dec i j); subst.
    Abort.

Print relation.
Print equiv.

Theorem equiv_ctx_eq:
    equiv context_equivalence.
*)

Inductive occurs_free : id -> tm -> Prop :=
    | occurs_free_var :
        forall i,
            occurs_free i (tvar i)
    | occurs_free_abs :
        forall i j x T,
            occurs_free i x ->
            i <> j ->
            occurs_free i (tabs j T x)
    | occurs_free_app1 :
        forall i x y,
            occurs_free i x ->
            occurs_free i (tapp x y)
    | occurs_free_app2 :
        forall i x y,
            occurs_free i y ->
            occurs_free i (tapp x y)
    | occurs_free_succ :
        forall i x,
            occurs_free i x ->
            occurs_free i (tsucc x)
    | occurs_free_pred :
        forall i x,
            occurs_free i x ->
            occurs_free i (tpred x)
    | occurs_free_mult1 :
        forall i x y,
            occurs_free i x ->
            occurs_free i (tmult x y)
    | occurs_free_mult2 :
        forall i x y,
            occurs_free i y ->
            occurs_free i (tmult x y)
    | occurs_free_if0 :
        forall i t t0 t1,
            occurs_free i t ->
            occurs_free i (tif0 t t0 t1)
    | occurs_free_if1 :
        forall i t t0 t1,
            occurs_free i t0 ->
            occurs_free i (tif0 t t0 t1)
    | occurs_free_if2 :
        forall i t t0 t1,
            occurs_free i t1 ->
            occurs_free i (tif0 t t0 t1).

    Hint Constructors occurs_free.
Theorem occurs_dec:
    forall i x,
    {occurs_free i x} + {~occurs_free i x}.

    intros i x. generalize dependent i.
    induction x; eauto.
    intros.
    destruct (eq_id_dec i0 i); subst.
    left; eauto.
    right; intros H; inversion H; subst. destruct (n eq_refl).

    intros. destruct (IHx1 i). left; eauto.
    destruct (IHx2 i). left; eauto.
    right; intro. inversion H; subst; eauto.

    intro. destruct (IHx i0). destruct (eq_id_dec i0 i); subst.
    right; intro HH; inversion HH; subst. destruct (H4 eq_refl).
    left; eauto.

    right; intro HH; inversion HH; subst; eauto.

    intros; right; intro HH; inversion HH.

    intros i; destruct (IHx i). left; eauto. right; intro HH; inversion HH; subst; eauto.

    intros i; destruct (IHx i). left; eauto. right; intro HH; inversion HH; subst; eauto.

    intros i; destruct (IHx1 i).
    left; eauto. destruct (IHx2 i). left; eauto.
    right; intro HH; inversion HH; subst; eauto.

    intros i; destruct (IHx1 i).
    left; eauto. destruct (IHx2 i). left; eauto.
    destruct (IHx3 i). left; eauto.
    right; intro HH; inversion HH; subst; eauto.
Qed.

Definition closed (x : tm) :=
    forall i, ~ occurs_free i x.

Theorem ctx_swap:
    forall x U V T ,
        U |= x \in T ->
        U =-= V ->
        V |= x \in T.

    intros x U V T h.
    generalize dependent V.
    induction h; unfold context_equivalence; intros; eauto.
    eapply tyVar. rewrite <- H0. auto.

    eapply tyAbs.
    pose (update_inc (z := ty)).
    pose (update_inc i G _ _ H).
    eauto.
Qed.

Theorem non_occurs_free_ctx_rm:
    forall v i x U T,
    update i x U |= v \in T ->
    (~occurs_free i v) ->
    U |= v \in T.

    intros v i x U T h.
    remember (update i x U) as u.
    generalize Hequ.
    induction h; subst; eauto.
    intros. cbn in H.
    destruct (eq_id_dec i0 i); subst. destruct (H0 (occurs_free_var i)).
    eauto.

    intros.
    pose (contrapositive _ _ (occurs_dec _ _) (occurs_free_app1 i a b)).
    pose (contrapositive _ _ (occurs_dec _ _) (occurs_free_app2 i a b)).

    pose (IHh2 eq_refl eq_refl).
    pose (IHh1 eq_refl eq_refl).
    eapply tyApp; eauto.

    intros. destruct (occurs_dec i x0).
    destruct (eq_id_dec i i0); subst.

    pose (update_shadow i0 G x U U (refl_ctxeq _ )).
    pose (ctx_swap _ _ _ _ h c).
    eauto.

    assert (occurs_free i (tabs i0 G x0)) as HH; eauto.
    destruct (H HH).

    eauto.
    Abort.

Theorem non_occurs_free_ctx_rm:
    forall v i x U T,
    update i x U |= v \in T ->
    (~occurs_free i v) ->
    U |= v \in T.

    intro v; induction v; eauto.
    intros. inversion H; subst.
    cbn in H3. destruct (eq_id_dec i i0); subst.
    destruct (H0 (occurs_free_var i0)).
    eauto.

    intros.
    pose (contrapositive _ _ (occurs_dec _ _) (occurs_free_app1 i v1 v2)).
    pose (contrapositive _ _ (occurs_dec _ _) (occurs_free_app2 i v1 v2)).
    inversion H; subst. eapply tyApp; eauto.

    intros. inversion H; subst.
    destruct (occurs_dec i0 v);
    destruct (eq_id_dec i0 i); subst. inversion H; subst.

    pose (update_shadow i t x U U (refl_ctxeq _ )).
    pose (ctx_swap _ _ _ _ H6 c).
    eauto.

    assert (occurs_free i0 (tabs i t v)) as HH; eauto.
    destruct (H0 HH).

    inversion H; subst.
    pose (update_shadow i t x U U (refl_ctxeq _ )).
    pose (ctx_swap _ _ _ _ H6 c).
    eauto.
    pose (update_permute i0 i x t U U n0 (refl_ctxeq _)).
    Print symm_ctxeq.
    pose (symm_ctxeq _ _ c).
    pose (ctx_swap _ _ _ _ H6 c0).
    eauto.

    intros. inversion H; subst. eauto.

    intros. inversion H; subst.
    Print occurs_free_succ.
    pose (contrapositive _ _ (occurs_dec _ _) (occurs_free_succ i v)).
    eauto.

    intros. inversion H; subst.
    pose (contrapositive _ _ (occurs_dec _ _) (occurs_free_pred i v)).
    eauto.

    intros. inversion H; subst.
    pose (contrapositive _ _ (occurs_dec _ _) (occurs_free_mult1 i v1 v2)).
    pose (contrapositive _ _ (occurs_dec _ _) (occurs_free_mult2 i v1 v2)).
    eapply tyMult; eauto.

    intros.
     inversion H; subst.
     pose (contrapositive _ _ (occurs_dec _ _) (occurs_free_if0 i v1 v2 v3)).
     pose (contrapositive _ _ (occurs_dec _ _) (occurs_free_if1 i v1 v2 v3)).
     pose (contrapositive _ _ (occurs_dec _ _) (occurs_free_if2 i v1 v2 v3)).
     eapply tyIf; eauto.

Qed.

Lemma occurs_free_is_in_ctx:
forall i x U T,
    U |= x \in T ->
    occurs_free i x ->
    (exists K, byContext U i = Some K).

intros i x U T h0 h.
generalize dependent U.
generalize dependent T.
induction h; intros; eauto; try (inversion h0; subst; eauto).

inversion h0; subst.
destruct (IHh _ _ H5).
cbn in H0. destruct (eq_id_dec i j); subst; eauto.
destruct (H eq_refl).
Qed.

Theorem empty_means_closed:
    forall t T,
        empty |= t \in T ->
        closed t.

    unfold closed.
    intros t.
    induction t; intros; intro.
    inversion H; subst. inversion H3.

    inversion H; subst. inversion H0; subst.
    destruct ((IHt1 _ H4 i) H3).
    destruct ((IHt2 _ H6 i) H3).

    inversion H; subst; inversion H0; subst.
    destruct (occurs_free_is_in_ctx _ _ _ _ H H0).
    inversion H1.

    inversion H0.

    inversion H; inversion H0; subst; eauto.
    eapply IHt. apply H3. apply H7.

    inversion H; inversion H0; subst; eapply IHt. apply H3. apply H7.
    inversion H; inversion H0; subst. eapply IHt1; eauto. eapply IHt2; eauto.
    inversion H; inversion H0; subst. eapply IHt1; eauto. eapply IHt2; eauto. eapply IHt3; eauto.

Qed.

Theorem empty_is_strong:
    forall x T U,
        empty |= x \in T ->
        U |= x \in T.

    intros x T U.
    generalize dependent x;
    generalize dependent T.
    induction U; intros; auto.
    pose (empty_means_closed x T H).
    unfold closed in c.
    pose (c i).
    Print non_occurs_free_ctx_rm.
    Abort.

Theorem occurs_free_ctx_add :
    forall i j x T U,
    U |= x \in T ->
    ~(occurs_free i x) ->
    update i j U |= x \in T.

    intros i j x.
    generalize dependent i;
    generalize dependent j.

    induction x; eauto.
    intros. inversion H; subst.
    eapply tyVar. cbn.
    destruct (eq_id_dec i i0); subst.
    destruct (H0 (occurs_free_var i0)).
    auto.

    intros. inversion H; subst. eapply tyApp; eauto.

    intros. inversion H; subst.
    destruct (occurs_dec i0 x); subst.
    destruct (eq_id_dec i0 i); subst.
    eapply tyAbs.
    eapply ctx_swap. eapply H6. eapply symm_ctxeq.
    eapply update_shadow. eapply refl_ctxeq.
    assert (occurs_free i0 (tabs i t x)). eauto.
    destruct (H0 H1).
    destruct (eq_id_dec i0 i); subst.
    eapply tyAbs. eapply ctx_swap. eapply H6.
    eapply symm_ctxeq. eapply update_shadow. eapply refl_ctxeq.
    eapply tyAbs. eapply ctx_swap. eapply IHx. eapply H6. eauto.
    eapply update_permute; eauto. eapply refl_ctxeq.

    intros. inversion H; subst; eauto.

    intros. inversion H; subst; eauto. eapply tySucc; eauto.

    intros. inversion H; subst;eauto. eapply tyPred; eauto.

    intros. inversion H; subst; eauto. eapply tyMult; eauto.

    intros. inversion H; subst; eauto. eapply tyIf; eauto.
Qed.

Theorem empty_is_strong:
forall x T U,
    empty |= x \in T ->
    U |= x \in T.

intros x T U.
generalize dependent x;
generalize dependent T.
induction U; intros; auto.
pose (empty_means_closed x T H).
unfold closed in c.
pose (c i).
eapply occurs_free_ctx_add; eauto.
Qed.

Lemma app_preserv:
forall t x y T G U,
    U |= tabs x T t \in TArrow T G ->
    empty |= y \in T ->
    U |= [x := y] t \in G.
intro t. elim t; intros.
inversion H; subst. unfold subst.
inversion H3; subst. cbn in H4.
destruct (eq_id_dec i x); subst. inversion H4; subst.
rewrite eq_id_dec_id. eapply empty_is_strong; eauto.
destruct (eq_id_dec x i); subst. destruct (n eq_refl).
eapply tyVar; auto.

inversion H1; subst.
change (U |= tapp ([x := y] t0) ([x := y] t1) \in G).
inversion H5; subst.
eapply tyApp; eauto.

change (U |= tabs i t0 (if eq_id_dec i x then t1 else [x := y] t1) \in G).
inversion H0; subst. inversion H4; subst.
destruct (eq_id_dec i x); subst.
eapply tyAbs. eapply ctx_swap. apply H8. eapply update_shadow. eapply refl_ctxeq.
eapply tyAbs. eapply H. eapply tyAbs. eapply ctx_swap. eapply H8. eapply update_permute; eauto. eapply refl_ctxeq. auto.

inversion H; subst. inversion H3; subst. unfold subst. eauto.

inversion H0; subst. inversion H4; subst.
change (U |= tsucc ([x := y] t0) \in TNat).
eapply tySucc. eapply H; eauto.

inversion H0; subst. inversion H4; subst.
change (U |= tpred ([x := y] t0) \in TNat).
eauto.

inversion H1; subst. inversion H5; subst.
change (U |= tmult ([ x:= y] t0) ([x := y] t1) \in TNat).
eapply tyMult; eauto.

inversion H2; subst. inversion H6; subst.
change (U |= tif0 ([x := y] t0) ([x := y] t1) ([x := y] t2) \in G).
eapply tyIf; eauto.

Qed.

Theorem preservation :
forall t t' T,
    empty |= t \in T ->
    step t t' ->
    empty |= t' \in T.

intro. elim t; intros.
inversion H0.

inversion H1; inversion H2; subst; eauto. inversion H6; subst.
eapply app_preserv; eauto.

inversion H1.

inversion H0.

inversion H1; subst. inversion H0; subst. eauto.

inversion H0; subst. eauto.

inversion H1; subst; inversion H0; subst; eauto.

inversion H1; subst; inversion H2; subst; eauto.

inversion H2; subst; inversion H3; subst; eauto.
Qed.

Definition stuck (t: tm) : Prop :=
(normal_form step) t /\ ~ value t.

Notation "t '==>*' t'" := (multi step t t') (at level 40).

Corollary soundness :
    forall t t' T,
        empty |= t \in T ->
        t ==>* t' ->
        ~(stuck t').

    intros t t' T h0 h. generalize dependent T.
    unfold stuck. unfold normal_form.
    induction h; intros; auto; intro.
    destruct H.
    Print progress.
    destruct (progress _ _ h0); eauto.
    Print preservation.
    pose (preservation _ _ _ h0 H).
    destruct ((IHh _ h1) H0).
Qed.

Theorem types_unique:
    forall x T G U,
    U |= x \in T ->
    U |= x \in G ->
    T = G.
    intro x; induction x; eauto; intros; (try (inversion H; inversion H0; subst; eauto)).
    inversion H; inversion H0; subst. rewrite H7 in H3. inversion H3; subst. auto.

    inversion H; inversion H0; subst; eauto.
    pose (IHx1 _ _ _ H4 H10). inversion e; subst; auto.

    inversion H; inversion H0; subst. rewrite (IHx _ _ _ H6 H12); eauto.

Qed.

End STLCARITH.


Require Import ExtLib.Core.Type.

Global Instance type_Prop : type Prop :=
{ equal := iff
; proper := fun _ => True
}.

Global Instance typeOk_Prop : typeOk type_Prop.
Proof.
  constructor; compute; firstorder.
Qed.

(** NOTE: These should fit into a larger picture, e.g. lattices or monoids **)
(** And/Conjunction **)
Lemma and_True_iff : forall P, (P /\ True) <-> P.
Proof. intuition. Qed.

Lemma and_and_iff : forall P, (P /\ P) <-> P.
Proof. intuition. Qed.

Lemma and_assoc : forall P Q R, (P /\ Q /\ R) <-> ((P /\ Q) /\ R).
Proof. intuition. Qed.

Lemma and_comm : forall P Q, (P /\ Q) <-> (Q /\ P).
Proof. intuition. Qed.

Lemma and_False_iff : forall P, (P /\ False) <-> False.
Proof. intuition. Qed.

Lemma and_cancel
: forall P Q R : Prop, (P -> (Q <-> R)) -> ((P /\ Q) <-> (P /\ R)).
Proof. intuition. Qed.

Lemma and_iff
: forall P Q R S : Prop,
    (P <-> R) ->
    (P -> (Q <-> S)) ->
    ((P /\ Q) <-> (R /\ S)).
Proof. clear; intuition. Qed.

(** Or/Disjunction **)
Lemma or_False_iff : forall P, (P \/ False) <-> P.
Proof. intuition. Qed.

Lemma or_or_iff : forall P, (P \/ P) <-> P.
Proof. intuition. Qed.

Lemma or_assoc : forall P Q R, (P \/ Q \/ R) <-> ((P \/ Q) \/ R).
Proof. intuition. Qed.

Lemma or_comm : forall P Q, (P \/ Q) <-> (Q \/ P).
Proof. intuition. Qed.

Lemma or_True_iff : forall P, (P \/ True) <-> True.
Proof. intuition. Qed.

(** Implication **)
Lemma impl_True_iff : forall (P : Prop), (True -> P) <-> P.
Proof.
  clear; intros; tauto.
Qed.

Lemma impl_iff
: forall P Q R S : Prop,
    (P <-> R) ->
    (P -> (Q <-> S)) ->
    ((P -> Q) <-> (R -> S)).
Proof. clear. intuition. Qed.

Lemma impl_eq : forall (P Q : Prop), P = Q -> (P -> Q).
Proof. clear. intros; subst; auto. Qed.

Lemma uncurry : forall (P Q R : Prop),
    (P /\ Q -> R) <-> (P -> Q -> R).
Proof. clear. tauto. Qed.

(** Forall **)
Lemma forall_iff : forall T P Q,
                     (forall x,
                        P x <-> Q x) ->
                     ((forall x : T, P x) <-> (forall x : T, Q x)).
Proof.
   intros. setoid_rewrite H. reflexivity.
Qed.

Lemma forall_impl : forall {T} (P Q : T -> Prop),
                      (forall x, P x -> Q x) ->
                      (forall x, P x) -> (forall x, Q x).
Proof.
  clear. intuition.
Qed.

(** Exists **)
Lemma exists_iff : forall T P Q,
                     (forall x,
                        P x <-> Q x) ->
                     ((exists x : T, P x) <-> (exists x : T, Q x)).
Proof.
   intros. setoid_rewrite H. reflexivity.
Qed.

Lemma exists_impl : forall {T} (P Q : T -> Prop),
                      (forall x, P x -> Q x) ->
                      (exists x, P x) -> (exists x, Q x).
Proof.
  clear. intuition.
  destruct H0; eauto.
Qed.

Lemma iff_eq : forall (P Q : Prop), P = Q -> (P <-> Q).
Proof. clear. intros; subst; reflexivity. Qed.


(* week-02_programming-and-proving.v *)
(* YSC3236 2017-2018, Sem1 *)
(* Olivier Danvy <danvy@yale-nus.edu.sg> *)
(* Version of 25 Aug 2017 *)

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

(* Paraphernalia: *)

Ltac unfold_tactic name := intros; unfold name; (* fold name; *) reflexivity.

Require Import Arith Bool.

Notation "A =n= B" :=
  (beq_nat A B) (at level 70, right associativity).

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

Inductive regexp :=
  | empty : regexp
  | atom : nat -> regexp
  | any : regexp
  | seq : regexp -> regexp -> regexp
  | disj : regexp -> regexp -> regexp
  | star : regexp -> regexp
  | plus : regexp -> regexp.

Lemma seq_re_empty :
  forall re : regexp,
    seq re empty = re.
Proof.
Admitted.

Lemma seq_empty_re :
  forall re : regexp,
    seq empty re = re.
Proof.
Admitted.

Lemma seq_assoc :
  forall re1 re2 re3 : regexp,
    seq re1 (seq re2 re3) = seq (seq re1 re2) re3.
Proof.
Admitted.

(* ***** *)

(* Prove the following proposition using seq_empty_re: *)

Proposition about_regular_expressions_1 :
  seq empty (seq empty empty) = seq (seq empty empty) empty.
Proof.
  Check (seq_re_empty empty).
  rewrite -> (seq_re_empty empty).
  reflexivity.

Restart.

(* Prove the same proposition using seq_assoc: *)

  apply (seq_assoc empty empty empty).

Proposition about_regular_expressions_2 :
  seq empty (seq empty empty) = seq (seq empty empty) empty.
Proof.

  Check (seq_assoc empty empty empty).
  rewrite -> (seq_assoc empty empty empty).

Abort.

(* The Restart tactic: *)

Proposition about_regular_expressions_1_and_2 :
  seq empty (seq empty empty) = seq (seq empty empty) empty.
Proof.
  (* put here your proof of about_regular_expressions_1 *)

  Restart.

  (* put here your proof of about_regular_expressions_2 *)

Abort.

(* ***** *)

(* Exercise 1 of Week 02 in the PL lecture notes: *)

Proposition Exercise_1_of_Week_02_a :
  (seq (atom 1) (seq (atom 2) (seq (atom 3) (seq (atom 4) (empty)))))
  =
  (seq (atom 1) (seq (atom 2) (seq (atom 3) (atom 4)))).
Proof.
  Check (seq_re_empty (atom 4)).
  rewrite -> (seq_re_empty (atom 4)).
  reflexivity.
Abort.

Proposition Exercise_1_of_Week_02_b :
  (seq (atom 1) (seq (atom 2) (seq (atom 3) (atom 4))))
  =
  (seq (seq (empty) (seq (atom 1) (atom 2))) (seq (empty) (seq (atom 3) (atom 4)))).
Proof.

Abort.

Proposition Exercise_1_of_Week_02_c :
  (seq (seq (empty) (seq (atom 1) (atom 2))) (seq (empty) (seq (atom 3) (atom 4))))
  =
  (seq (seq (seq (atom 1) (atom 2)) (atom 3)) (atom 4)).
Proof.
Abort.

Proposition Exercise_1_of_Week_02_d :
  (seq (seq (seq (atom 1) (atom 2)) (atom 3)) (atom 4))
  =
  (seq (seq (seq (seq (empty) (atom 1)) (atom 2)) (atom 3)) (atom 4)).
Proof.
Abort.

Proposition Exercise_1_of_Week_02_e :
  (seq (seq (seq (seq (empty) (atom 1)) (atom 2)) (atom 3)) (atom 4))
  =
  (seq (atom 1) (seq (atom 2) (seq (atom 3) (seq (atom 4) (empty))))).
Proof.
Abort.

(* Re-prove Proposition Exercise_1_of_Week_02_e
   as a corollary of the previous exercises,
   Exercise_1_of_Week_02_a to Exercise_1_of_Week_02_d: *)

Corollary Exercise_1_of_Week_02_e' :
  (seq (seq (seq (seq (empty) (atom 1)) (atom 2)) (atom 3)) (atom 4))
  =
  (seq (atom 1) (seq (atom 2) (seq (atom 3) (seq (atom 4) (empty))))).
Proof.
Abort.

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

Definition test_add (candidate: nat -> nat -> nat) :=
  (candidate 0 0 =n= 0)
  &&
  (candidate 0 1 =n= 1)
  &&
  (candidate 1 0 =n= 1)
  &&
  (candidate 1 1 =n= 2)
  &&
  (candidate 1 2 =n= 3)
  &&
  (candidate 2 1 =n= 3)
  &&
  (candidate 2 2 =n= 4)
  .

Fixpoint add_v1 (i j : nat) : nat :=
  match i with
  | O => j
  | S i' => S (add_v1 i' j)
  end.

Compute (test_add add_v1).

(* Canonical unfold lemmas for recursive definitions: *)

Lemma unfold_add_v1_0 :
  forall j : nat,
    add_v1 0 j = j.
Proof.
  unfold_tactic add_v1.
Qed.

Lemma unfold_add_v1_S :
  forall i' j : nat,
    add_v1 (S i') j = S (add_v1 i' j).
Proof.
  unfold_tactic add_v1.
Qed.

Proposition add_v1_0_n :
  forall n : nat,
    add_v1 0 n = n.
Proof.
Abort.

Proposition add_v1_n_0 :
  forall n : nat,
    add_v1 n 0 = n.
Proof.
Abort.

Lemma add_v1_assoc :
  forall x y z : nat,
    add_v1 x (add_v1 y z) =
    add_v1 (add_v1 x y) z.
Proof.
  intro x.
  induction x as [ | x' IHx'].

  intros y z.
  rewrite -> (unfold_add_v1_0 (add_v1 y z)).
  rewrite -> (unfold_add_v1_0 y).
  reflexivity.

  intros y z.
  rewrite -> (unfold_add_v1_S x' (add_v1 y z)).
  rewrite -> (unfold_add_v1_S x' y).
  rewrite -> (unfold_add_v1_S (add_v1 x' y)).
  rewrite -> (IHx' y z).
  reflexivity.
Qed.

(* ***** *)

Fixpoint add_v2 (i j : nat) : nat :=
  match i with
  | O => j
  | S i' => add_v2 i' (S j)
  end.

Compute (test_add add_v2).

(* Canonical unfold lemmas for recursive definitions: *)

Lemma unfold_add_v2_0 :
  forall j : nat,
    add_v2 0 j = j.
Proof.
  unfold_tactic add_v2.
Qed.

Lemma unfold_add_v2_S :
  forall i' j : nat,
    add_v2 (S i') j = add_v2 i' (S j).
Proof.
  unfold_tactic add_v2.
Qed.

(* ***** *)

Proposition equivalence_of_add_v1_and_add_v2 :
  forall i j : nat,
    add_v1 i j = add_v2 i j.
Proof.
Abort.

Proposition add_v2_0_n :
  forall n : nat,
    add_v2 0 n = n.
Proof.
Abort.

Proposition add_v2_n_0 :
  forall n : nat,
    add_v2 n 0 = n.
Proof.
Abort.

Lemma add_v2_assoc :
  forall x y z : nat,
    add_v2 x (add_v2 y z) =
    add_v2 (add_v2 x y) z.
Proof.
Abort.

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

Definition test_min (candidate : nat -> nat -> nat) : bool :=
  (candidate 0 3 =n= 0)
  &&
  (candidate 3 0 =n= 0)
  &&
  (candidate 2 3 =n= 2)
  &&
  (candidate 3 2 =n= 2)
  &&
  (candidate 3 3 =n= 3)
  .

(* ***** *)

(* Lambda-dropped version of min_v1: *)

Fixpoint visit_min_v1 (m_init n_init m n : nat) : nat :=
  match m with
  | 0 => m_init
  | S m' => match n with
            | 0 => n_init
            | S n' => visit_min_v1 m_init n_init m' n'
            end
  end.

Definition min_v1 (m_init n_init : nat) : nat :=
  visit_min_v1 m_init n_init m_init n_init.

Compute (test_min min_v1).

Fixpoint min_v2 (m n : nat) : nat :=
  match m with
  | 0 => 0
  | S m' => match n with
            | 0 => 0
            | S n' => S (min_v2 m' n')
            end
  end.

Compute (test_min min_v2).

(* ***** *)

(* Canonical unfold lemmas for recursive definitions: *)

Lemma unfold_visit_min_v1_0 :
  forall m_init n_init n : nat,
    visit_min_v1 m_init n_init 0 n = m_init.
Proof.
  unfold_tactic visit_min_v1.
Qed.

Lemma unfold_visit_min_v1_S :
  forall m_init n_init m' n : nat,
    visit_min_v1 m_init n_init (S m') n =
    match n with
    | 0 => n_init
    | S n' => visit_min_v1 m_init n_init m' n'
    end.
Proof.
  unfold_tactic visit_min_v1.
Qed.

Lemma unfold_min_v2_0 :
  forall n : nat,
    min_v2 0 n = 0.
Proof.
  unfold_tactic min_v2.
Qed.

Lemma unfold_min_v2_S :
  forall m' n : nat,
    min_v2 (S m') n =
    match n with
    | 0 => 0
    | S n' => S (min_v2 m' n')
    end.
Proof.
  unfold_tactic min_v2.
Qed.

(* ***** *)

Proposition equivalence_of_min_v1_and_min_v2 :
  forall m n : nat,
    min_v1 m n = min_v2 m n.
Proof.
Abort.

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

Definition test_evenp (candidate : nat -> bool) : bool :=
  (eqb (candidate 0) true)
  &&
  (eqb (candidate 1) false)
  &&
  (eqb (candidate 7) false)
  &&
  (eqb (candidate 8) true)
  &&
  (eqb (candidate 17) false)
  .

Fixpoint evenp_v1 (n : nat) : bool :=
  match n with
  | 0 => true
  | S n' => match n' with
            | 0 => false
            | S n'' => evenp_v1 n''
            end
  end.

Compute (test_evenp evenp_v1).

(* With an inherited attribute, lambda-lifted: *)

Fixpoint visit_evenp_v2 (n : nat) (a : bool) : bool :=
  match n with
  | 0 => a
  | S n' => visit_evenp_v2 n' (negb a)
  end.

Definition evenp_v2 (n : nat) : bool :=
  visit_evenp_v2 n true.

Compute (test_evenp evenp_v2).

Fixpoint evenp_v3 (n : nat) : bool :=
  match n with
  | 0 => true
  | S n' => negb (evenp_v3 n')
  end.

Compute (test_evenp evenp_v3).

Proposition equivalence_of_evenp_v1_and_evenp_v2 :
  forall n : nat,
    evenp_v1 n = evenp_v2 n.
Proof.
Abort.

Proposition equivalence_of_evenp_v2_and_evenp_v3 :
  forall n : nat,
    evenp_v2 n = evenp_v3 n.
Proof.
Abort.

Proposition equivalence_of_evenp_v1_and_evenp_v3 :
  forall n : nat,
    evenp_v1 n = evenp_v3 n.
Proof.
Abort.

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

Definition test_fac (candidate: nat -> nat) : bool :=
  (candidate 0 =n= 1)
  &&
  (candidate 1 =n= 1)
  &&
  (candidate 2 =n= 2)
  &&
  (candidate 3 =n= 6) &&
  (candidate 4 =n= 24)
  &&
  (candidate 5 =n= 120)
  .

Fixpoint fac_v1 (n : nat) : nat :=
  match n with
  | 0 => 1
  | S n' =>  n * (fac_v1 n')
  end.

Compute (test_fac fac_v1).

Fixpoint visit_fac_v2 (n a : nat) : nat :=
  match n with
  | 0 => a
  | S n' => (visit_fac_v2 n' (n * a))
  end.

Definition fac_v2 (n : nat) : nat :=
  visit_fac_v2 n 1.

Compute (test_fac fac_v2).

Proposition equivalence_of_fac_v1_and_fac_v2 :
  forall n : nat,
    fac_v1 n = fac_v2 n.
Proof.
Abort.

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

Definition test_fib (candidate: nat -> nat) : bool :=
  (candidate 0 =n= 0)
  &&
  (candidate 1 =n= 1)
  &&
  (candidate 2 =n= 1)
  &&
  (candidate 3 =n= 2)
  &&
  (candidate 4 =n= 3)
  &&
  (candidate 5 =n= 5)
  &&
  (candidate 6 =n= 8)
  &&
  (candidate 7 =n= 13)
  &&
  (candidate 8 =n= 21)
  .

Fixpoint fib_v1 (n : nat) : nat :=
  match n with
  | 0 => O
  | S n' => match n' with
            | O => 1
            | S n'' => (fib_v1 n') + (fib_v1 n'')
            end
  end.

Compute (test_fib fib_v1).

Fixpoint visit_fib_v2 (n a1 a2 : nat) : nat :=
  match n with
  | 0 => a1
  | S n' => (visit_fib_v2 n' a2 (a1 + a2))
  end.

Definition fib_v2 (n : nat) : nat :=
  visit_fib_v2 n 0 1.

Compute (test_fib fib_v2).

Fixpoint visit_fib_v3 (n : nat) : nat * nat :=
  match n with
  | 0 => (0, 1)
  | S n' => match visit_fib_v3 n' with
              | (a1, a2) => (a2, a1 + a2)
            end
  end.

Definition fib_v3 (n : nat) : nat :=
  match visit_fib_v3 n with
    | (a1, a2) => a1
  end.

Compute (test_fib fib_v3).

Proposition equivalence_of_fib_v1_and_fib_v2 :
  forall n : nat,
    fib_v1 n = fib_v2 n.
Proof.
Abort.

Proposition equivalence_of_fib_v1_and_fib_v3 :
  forall n : nat,
    fib_v1 n = fib_v3 n.
Proof.
Abort.

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

Inductive list_nat : Type :=
  nil_nat : list_nat
| cons_nat : nat -> list_nat -> list_nat.

Fixpoint beq_list_nat (xs ys : list_nat) : bool :=
  match xs with
    nil_nat =>
    match ys with
      nil_nat =>
      true
    | cons_nat y ys' =>
      false
    end
  | cons_nat x xs' =>
    match ys with
      nil_nat =>
      false
    | cons_nat y ys' =>
      (x =n= y) && beq_list_nat xs' ys'
    end
  end.

Notation "A =ns= B" :=
  (beq_list_nat A B) (at level 70, right associativity).

(* ***** *)

Definition test_append_list_nat (candidate: list_nat -> list_nat -> list_nat) :=
  (candidate nil_nat nil_nat =ns= nil_nat)
  &&
  (candidate nil_nat (cons_nat 10 nil_nat) =ns= (cons_nat 10 nil_nat))
  &&
  (candidate (cons_nat 1 nil_nat) (cons_nat 10 nil_nat) =ns= (cons_nat 1 (cons_nat 10 nil_nat)))
  (* etc. *)
  .

Fixpoint append_list_nat (xs ys : list_nat) : list_nat :=
  match xs with
  | nil_nat =>
    ys
  | cons_nat x xs' =>
    cons_nat x (append_list_nat xs' ys)
  end.

Compute (test_append_list_nat append_list_nat).

(* Canonical unfold lemmas for recursive definitions: *)

Lemma unfold_append_list_nat_nil_nat :
  forall ys : list_nat,
    append_list_nat nil_nat ys = ys.
Proof.
  unfold_tactic append_list_nat.
Qed.

Lemma unfold_append_list_nat_cons_nat :
  forall (x : nat) (xs' ys : list_nat),
    append_list_nat (cons_nat x xs') ys =
    cons_nat x (append_list_nat xs' ys).
Proof.
  unfold_tactic append_list_nat.
Qed.

Lemma append_nil_nat_ys :
  forall ys : list_nat,
    append_list_nat nil_nat ys = ys.
Proof.
Abort.

Lemma append_ys_nil_nat :
  forall xs : list_nat,
    append_list_nat xs nil_nat = xs.
Proof.
Abort.

Lemma append_list_nat_assoc :
  forall xs ys zs : list_nat,
    append_list_nat xs (append_list_nat ys zs) =
    append_list_nat (append_list_nat xs ys) zs.
Proof.
Abort.

(* ***** *)

Definition test_length_list_nat (candidate: list_nat -> nat) :=
  (candidate nil_nat =n= 0)
  &&
  (candidate (cons_nat 1 nil_nat) =n= 1)
  &&
  (candidate (cons_nat 2 (cons_nat 1 nil_nat)) =n= 2)
  (* etc. *)
  .

Fixpoint length_list_nat_v1 (xs : list_nat) : nat :=
  match xs with
  | nil_nat =>
    0
  | cons_nat x xs' =>
    S (length_list_nat_v1 xs')
  end.

Compute (test_length_list_nat length_list_nat_v1).

Fixpoint visit_length_list_nat_v2 (xs : list_nat) (a : nat) : nat :=
  match xs with
  | nil_nat =>
    a
  | cons_nat x xs' =>
    visit_length_list_nat_v2 xs' (S a)
  end.

Definition length_list_nat_v2 (xs : list_nat) : nat :=
  visit_length_list_nat_v2 xs 0.

Compute (test_length_list_nat length_list_nat_v2).

Proposition equivalence_of_length_list_nat_v1_and_length_list_nat_v2 :
  forall xs : list_nat,
    length_list_nat_v1 xs = length_list_nat_v2 xs.
Proof.
Abort.

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

Proposition append_and_length_commute_with_each_other :
  forall xs ys : list_nat,
    length_list_nat_v1 (append_list_nat xs ys) =
    (length_list_nat_v1 xs) + (length_list_nat_v1 ys).
Proof.
Abort.

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

Inductive binary_tree : Type :=
  Leaf : nat -> binary_tree
| Node : binary_tree -> binary_tree -> binary_tree.

Definition test_number_of_leaves (candidate: binary_tree -> nat) :=
  (candidate (Leaf 1) =n= 1)
  &&
  (candidate (Node (Leaf 1) (Leaf 2)) =n= 2)
  &&
  (candidate (Node (Node (Leaf 1) (Leaf 2)) (Leaf 3)) =n= 3)
  (* etc. *)
  .

Fixpoint number_of_leaves_v1 (t : binary_tree) : nat :=
  match t with
    Leaf n =>
    1
  | Node t1 t2 =>
    (number_of_leaves_v1 t1) + (number_of_leaves_v1 t2)
  end.

Compute (test_number_of_leaves number_of_leaves_v1).

Fixpoint visit_number_of_leaves_v2 (t : binary_tree) (a : nat) : nat :=
  match t with
    Leaf n =>
    S a
  | Node t1 t2 =>
    visit_number_of_leaves_v2 t1 (visit_number_of_leaves_v2 t2 a)
  end.

Definition number_of_leaves_v2 (t : binary_tree) : nat :=
  visit_number_of_leaves_v2 t 0.

Compute (test_number_of_leaves number_of_leaves_v1).

Proposition equivalence_of_number_of_leaves_v1_and_number_of_leaves_v2 :
  forall t : binary_tree,
    number_of_leaves_v1 t = number_of_leaves_v2 t.
Proof.
Abort.

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

(* end of week-02_programming-and-proving.v *)


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(****************************************************************************)
(*                                                                          *)
(*                         Naive Set Theory in Coq                          *)
(*                                                                          *)
(*                     INRIA                        INRIA                   *)
(*              Rocquencourt                        Sophia-Antipolis        *)
(*                                                                          *)
(*                                 Coq V6.1                                 *)
(*									    *)
(*			         Gilles Kahn 				    *)
(*				 Gerard Huet				    *)
(*									    *)
(*									    *)
(*                                                                          *)
(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
(* to the Newton Institute for providing an exceptional work environment    *)
(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
(****************************************************************************)

(*i $Id: Finite_sets_facts.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Require Export Finite_sets.
Require Export Constructive_sets.
Require Export Classical_Type.
Require Export Classical_sets.
Require Export Powerset.
Require Export Powerset_facts.
Require Export Powerset_Classical_facts.
Require Export Gt.
Require Export Lt.

Section Finite_sets_facts.
  Variable U : Type.

  Lemma finite_cardinal :
    forall X:Ensemble U, Finite U X ->  exists n : nat, cardinal U X n.
  Proof.
    induction 1 as [| A _ [n H]].
    exists 0; auto with sets.
    exists (S n); auto with sets.
  Qed.

  Lemma cardinal_finite :
    forall (X:Ensemble U) (n:nat), cardinal U X n -> Finite U X.
  Proof.
    induction 1; auto with sets.
  Qed.

  Theorem Add_preserves_Finite :
    forall (X:Ensemble U) (x:U), Finite U X -> Finite U (Add U X x).
  Proof.
    intros X x H'.
    elim (classic (In U X x)); intro H'0; auto with sets.
    rewrite (Non_disjoint_union U X x); auto with sets.
  Qed.

  Theorem Singleton_is_finite : forall x:U, Finite U (Singleton U x).
  Proof.
    intro x; rewrite <- (Empty_set_zero U (Singleton U x)).
    change (Finite U (Add U (Empty_set U) x)) in |- *; auto with sets.
  Qed.

  Theorem Union_preserves_Finite :
    forall X Y:Ensemble U, Finite U X -> Finite U Y -> Finite U (Union U X Y).
  Proof.
    intros X Y H; induction H as [|A Fin_A Hind x].
    rewrite (Empty_set_zero U Y). trivial.
    intros.
    rewrite (Union_commutative U (Add U A x) Y).
    rewrite <- (Union_add U Y A x).
    rewrite (Union_commutative U Y A).
    apply Add_preserves_Finite.
    apply Hind. assumption.
  Qed.

  Lemma Finite_downward_closed :
    forall A:Ensemble U,
      Finite U A -> forall X:Ensemble U, Included U X A -> Finite U X.
  Proof.
    intros A H'; elim H'; auto with sets.
    intros X H'0.
    rewrite (less_than_empty U X H'0); auto with sets.
    intros; elim Included_Add with U X A0 x; auto with sets.
    destruct 1 as [A' [H5 H6]].
    rewrite H5; auto with sets.
  Qed.

  Lemma Intersection_preserves_finite :
    forall A:Ensemble U,
      Finite U A -> forall X:Ensemble U, Finite U (Intersection U X A).
  Proof.
    intros A H' X; apply Finite_downward_closed with A; auto with sets.
  Qed.

  Lemma cardinalO_empty :
    forall X:Ensemble U, cardinal U X 0 -> X = Empty_set U.
  Proof.
    intros X H; apply (cardinal_invert U X 0); trivial with sets.
  Qed.

  Lemma inh_card_gt_O :
    forall X:Ensemble U, Inhabited U X -> forall n:nat, cardinal U X n -> n > 0.
  Proof.
    induction 1 as [x H'].
    intros n H'0.
    elim (gt_O_eq n); auto with sets.
    intro H'1; generalize H'; generalize H'0.
    rewrite <- H'1; intro H'2.
    rewrite (cardinalO_empty X); auto with sets.
    intro H'3; elim H'3.
  Qed.

  Lemma card_soustr_1 :
    forall (X:Ensemble U) (n:nat),
      cardinal U X n ->
      forall x:U, In U X x -> cardinal U (Subtract U X x) (pred n).
  Proof.
    intros X n H'; elim H'.
    intros x H'0; elim H'0.
    clear H' n X.
    intros X n H' H'0 x H'1 x0 H'2.
    elim (classic (In U X x0)).
    intro H'4; rewrite (add_soustr_xy U X x x0).
    elim (classic (x = x0)).
    intro H'5.
    absurd (In U X x0); auto with sets.
    rewrite <- H'5; auto with sets.
    intro H'3; try assumption.
    cut (S (pred n) = pred (S n)).
    intro H'5; rewrite <- H'5.
    apply card_add; auto with sets.
    red in |- *; intro H'6; elim H'6.
    intros H'7 H'8; try assumption.
    elim H'1; auto with sets.
    unfold pred at 2 in |- *; symmetry  in |- *.
    apply S_pred with (m := 0).
    change (n > 0) in |- *.
    apply inh_card_gt_O with (X := X); auto with sets.
    apply Inhabited_intro with (x := x0); auto with sets.
    red in |- *; intro H'3.
    apply H'1.
    elim H'3; auto with sets.
    rewrite H'3; auto with sets.
    elim (classic (x = x0)).
    intro H'3; rewrite <- H'3.
    cut (Subtract U (Add U X x) x = X); auto with sets.
    intro H'4; rewrite H'4; auto with sets.
    intros H'3 H'4; try assumption.
    absurd (In U (Add U X x) x0); auto with sets.
    red in |- *; intro H'5; try exact H'5.
    lapply (Add_inv U X x x0); tauto.
  Qed.

  Lemma cardinal_is_functional :
    forall (X:Ensemble U) (c1:nat),
      cardinal U X c1 ->
      forall (Y:Ensemble U) (c2:nat), cardinal U Y c2 -> X = Y -> c1 = c2.
  Proof.
    intros X c1 H'; elim H'.
    intros Y c2 H'0; elim H'0; auto with sets.
    intros A n H'1 H'2 x H'3 H'5.
    elim (not_Empty_Add U A x); auto with sets.
    clear H' c1 X.
    intros X n H' H'0 x H'1 Y c2 H'2.
    elim H'2.
    intro H'3.
    elim (not_Empty_Add U X x); auto with sets.
    clear H'2 c2 Y.
    intros X0 c2 H'2 H'3 x0 H'4 H'5.
    elim (classic (In U X0 x)).
    intro H'6; apply f_equal with nat.
    apply H'0 with (Y := Subtract U (Add U X0 x0) x).
    elimtype (pred (S c2) = c2); auto with sets.
    apply card_soustr_1; auto with sets.
    rewrite <- H'5.
    apply Sub_Add_new; auto with sets.
    elim (classic (x = x0)).
    intros H'6 H'7; apply f_equal with nat.
    apply H'0 with (Y := X0); auto with sets.
    apply Simplify_add with (x := x); auto with sets.
    pattern x at 2 in |- *; rewrite H'6; auto with sets.
    intros H'6 H'7.
    absurd (Add U X x = Add U X0 x0); auto with sets.
    clear H'0 H' H'3 n H'5 H'4 H'2 H'1 c2.
    red in |- *; intro H'.
    lapply (Extension U (Add U X x) (Add U X0 x0)); auto with sets.
    clear H'.
    intro H'; red in H'.
    elim H'; intros H'0 H'1; red in H'0; clear H' H'1.
    absurd (In U (Add U X0 x0) x); auto with sets.
    lapply (Add_inv U X0 x0 x); [ intuition | apply (H'0 x); apply Add_intro2 ].
  Qed.

  Lemma cardinal_Empty : forall m:nat, cardinal U (Empty_set U) m -> 0 = m.
  Proof.
    intros m Cm; generalize (cardinal_invert U (Empty_set U) m Cm).
    elim m; auto with sets.
    intros; elim H0; intros; elim H1; intros; elim H2; intros.
    elim (not_Empty_Add U x x0 H3).
  Qed.

  Lemma cardinal_unicity :
    forall (X:Ensemble U) (n:nat),
      cardinal U X n -> forall m:nat, cardinal U X m -> n = m.
  Proof.
    intros; apply cardinal_is_functional with X X; auto with sets.
  Qed.

  Lemma card_Add_gen :
    forall (A:Ensemble U) (x:U) (n n':nat),
      cardinal U A n -> cardinal U (Add U A x) n' -> n' <= S n.
  Proof.
    intros A x n n' H'.
    elim (classic (In U A x)).
    intro H'0.
    rewrite (Non_disjoint_union U A x H'0).
    intro H'1; cut (n = n').
    intro E; rewrite E; auto with sets.
    apply cardinal_unicity with A; auto with sets.
    intros H'0 H'1.
    cut (n' = S n).
    intro E; rewrite E; auto with sets.
    apply cardinal_unicity with (Add U A x); auto with sets.
  Qed.

  Lemma incl_st_card_lt :
    forall (X:Ensemble U) (c1:nat),
      cardinal U X c1 ->
      forall (Y:Ensemble U) (c2:nat),
	cardinal U Y c2 -> Strict_Included U X Y -> c2 > c1.
  Proof.
    intros X c1 H'; elim H'.
    intros Y c2 H'0; elim H'0; auto with sets arith.
    intro H'1.
    elim (Strict_Included_strict U (Empty_set U)); auto with sets arith.
    clear H' c1 X.
    intros X n H' H'0 x H'1 Y c2 H'2.
    elim H'2.
    intro H'3; elim (not_SIncl_empty U (Add U X x)); auto with sets arith.
    clear H'2 c2 Y.
    intros X0 c2 H'2 H'3 x0 H'4 H'5; elim (classic (In U X0 x)).
    intro H'6; apply gt_n_S.
    apply H'0 with (Y := Subtract U (Add U X0 x0) x).
    elimtype (pred (S c2) = c2); auto with sets arith.
    apply card_soustr_1; auto with sets arith.
    apply incl_st_add_soustr; auto with sets arith.
    elim (classic (x = x0)).
    intros H'6 H'7; apply gt_n_S.
    apply H'0 with (Y := X0); auto with sets arith.
    apply sincl_add_x with (x := x0).
    rewrite <- H'6; auto with sets arith.
    pattern x0 at 1 in |- *; rewrite <- H'6; trivial with sets arith.
    intros H'6 H'7; red in H'5.
    elim H'5; intros H'8 H'9; try exact H'8; clear H'5.
    red in H'8.
    generalize (H'8 x).
    intro H'5; lapply H'5; auto with sets arith.
    intro H; elim Add_inv with U X0 x0 x; auto with sets arith.
    intro; absurd (In U X0 x); auto with sets arith.
    intro; absurd (x = x0); auto with sets arith.
  Qed.

  Lemma incl_card_le :
    forall (X Y:Ensemble U) (n m:nat),
      cardinal U X n -> cardinal U Y m -> Included U X Y -> n <= m.
  Proof.
    intros; elim Included_Strict_Included with U X Y; auto with sets arith; intro.
    cut (m > n); auto with sets arith.
    apply incl_st_card_lt with (X := X) (Y := Y); auto with sets arith.
    generalize H0; rewrite <- H2; intro.
    cut (n = m).
    intro E; rewrite E; auto with sets arith.
    apply cardinal_unicity with X; auto with sets arith.
  Qed.

  Lemma G_aux :
    forall P:Ensemble U -> Prop,
      (forall X:Ensemble U,
	Finite U X ->
	(forall Y:Ensemble U, Strict_Included U Y X -> P Y) -> P X) ->
      P (Empty_set U).
  Proof.
    intros P H'; try assumption.
    apply H'; auto with sets.
    clear H'; auto with sets.
    intros Y H'; try assumption.
    red in H'.
    elim H'; intros H'0 H'1; try exact H'1; clear H'.
    lapply (less_than_empty U Y); [ intro H'3; try exact H'3 | assumption ].
    elim H'1; auto with sets.
  Qed.

  Lemma Generalized_induction_on_finite_sets :
    forall P:Ensemble U -> Prop,
      (forall X:Ensemble U,
	Finite U X ->
	(forall Y:Ensemble U, Strict_Included U Y X -> P Y) -> P X) ->
      forall X:Ensemble U, Finite U X -> P X.
  Proof.
    intros P H'0 X H'1.
    generalize P H'0; clear H'0 P.
    elim H'1.
    intros P H'0.
    apply G_aux; auto with sets.
    clear H'1 X.
    intros A H' H'0 x H'1 P H'3.
    cut (forall Y:Ensemble U, Included U Y (Add U A x) -> P Y); auto with sets.
    generalize H'1.
    apply H'0.
    intros X K H'5 L Y H'6; apply H'3; auto with sets.
    apply Finite_downward_closed with (A := Add U X x); auto with sets.
    intros Y0 H'7.
    elim (Strict_inclusion_is_transitive_with_inclusion U Y0 Y (Add U X x));
      auto with sets.
    intros H'2 H'4.
    elim (Included_Add U Y0 X x);
      [ intro H'14
	| intro H'14; elim H'14; intros A' E; elim E; intros H'15 H'16; clear E H'14
	| idtac ]; auto with sets.
    elim (Included_Strict_Included U Y0 X); auto with sets.
    intro H'9; apply H'5 with (Y := Y0); auto with sets.
    intro H'9; rewrite H'9.
    apply H'3; auto with sets.
    intros Y1 H'8; elim H'8.
    intros H'10 H'11; apply H'5 with (Y := Y1); auto with sets.
    elim (Included_Strict_Included U A' X); auto with sets.
    intro H'8; apply H'5 with (Y := A'); auto with sets.
    rewrite <- H'15; auto with sets.
    intro H'8.
    elim H'7.
    intros H'9 H'10; apply H'10 || elim H'10; try assumption.
    generalize H'6.
    rewrite <- H'8.
    rewrite <- H'15; auto with sets.
  Qed.

End Finite_sets_facts.