Require Import Coq.Sets.Ensembles.
Require Import Coq.Logic.Classical.
Require Import Coq.Logic.Epsilon.
Require Import Finite_sets.
Require Import Coq.Sets.Finite_sets_facts.
Require Import Coq.Sets.Image.

Notation "a ∈ A" := (In _ A a) (at level 10).
Notation "a ∉ A" := (~In _ A a) (at level 10).
Notation "A ⊆ B" := (Included _ A B) (at level 70).
Notation "B ∩ C" := (Intersection _ B C) (at level 60, right associativity).
Notation "B ∪ C" := (Union _ B C) (at level 65, right associativity).
Notation "[ a ]" := (Singleton _ a) (at level 0, right associativity).

Theorem classicT : forall P:Prop, {P} + {~P}.
Proof.
  intros. assert {x:bool | if x then P else ~P}.
  { apply constructive_indefinite_description.
    destruct (classic P).
    - exists true. auto.
    - exists false. auto. }
  destruct H, x; auto.
Qed.

(* 映射 *)
Definition Map {U V} A B (f : U -> V) :=
  forall a, a ∈ A -> (f a) ∈ B.

(* 原象集 preimage set *)
Definition preimage_set {U V} (f : U -> V) y:= fun x => (f x) = y.

(* f是A到Ā的满射 *)
Definition Surjective {U V} A B (f : U -> V) :=
  Map A B f /\ forall y , y ∈ B -> exists x, x∈A /\ (f x) = y.

(* f是A到Ā的单射 a≠b => f(a)≠f(b) *)
Definition Injective {U V} A B (f : U -> V) :=
  Map A B f /\ forall a b, a ∈ A -> b ∈ A -> f a = f b -> a = b.

(* f是A到Ā的双射 *)
Definition Bijective {U V} A B (f : U -> V) :=
  Surjective A B f /\ Injective A B f.

(* f是A到Ā的双射 *)
Definition Bijective_ex {U V} A B  :=
  exists (f : U -> V), Surjective A B f /\ Injective A B f.

Definition pick {A} {P : A->Prop} (l :exists x, P x) :=
  proj1_sig (constructive_indefinite_description _ l).

(* 运算f在G中的封闭性 *)
Definition Closed {U:Type} (f:U->U->U) (G:Ensemble U):=
  forall a b:U, a∈G -> b∈G -> (f a b)∈G.

(* 函数f在G中封闭性 *)
Definition Closedfun {U:Type} (f:U->U) (G:Ensemble U):=
  forall x:U, x∈G -> (f x)∈G.

(* 结合律 *)
Definition associative {U:Type} (f:U->U->U) (G: Ensemble U):=
  forall x y z: U, x∈G -> y∈G -> z∈G -> f (f x y) z = f x (f y z).

(* 单位元 *)
Definition id {U:Type} f (e:U) x:=
  f e x = x /\ f x e = x.

(* 逆元 *)
Definition idinv {U:Type} (f:U->U->U) (e:U) x y:=
   f x y = e /\ f y x = e.

(*群*)
Class Group (U: Type) :={
  G: Ensemble U;
  mul: U->U->U;
  e: U;
  inv : U->U;
  closed_Gr: Closed mul G;
  assoc_Gr: associative mul G;
  e_In_G : e∈G;
  id_Gr: forall x:U, x∈G ->  id mul e x;
  closedinv_Gr : Closedfun inv G;
  invGr : forall x:U, x∈G -> idinv mul e x (inv x)
  }.
Notation "a · b" := (mul a b)(at level 10, left associativity).
Notation "x ⁻¹" := (inv x)(at level 5, left associativity).

Lemma id_l : forall {U} (GG: Group U) a, a∈G -> e·a=a.
Proof. intros. destruct (id_Gr a); auto. Qed.
Lemma id_r : forall {U} (GG: Group U) a, a∈G -> a·e=a.
Proof. intros. destruct (id_Gr a); auto. Qed.
Lemma inv_l : forall {U} (GG: Group U) a, a∈G -> a⁻¹·a=e.
Proof. intros. destruct (invGr a); auto. Qed.
Lemma inv_r : forall {U} (GG: Group U) a, a∈G -> a·a⁻¹=e.
Proof. intros. destruct (invGr a); auto. Qed.

Ltac simp :=
  repeat (rewrite -> (id_l _ _) ||
          rewrite -> (id_r _  _) ||
          rewrite -> (inv_l _ _) ||
          rewrite -> (inv_r _ _)).
Ltac simpH H:=
         (rewrite -> (id_l _ _)  in H||
          rewrite -> (id_r _  _) in H||
          rewrite -> (inv_l _ _) in H||
          rewrite -> (inv_r _ _) in H).

Class subGroup {U:Type} (Gr:Group U) :={
  H: Ensemble U;
  subsG: H⊆G;
  closed_H : Closed mul H;
  id_H: e∈H;
  closed_H_inv: Closedfun inv H
  }.
Global Hint Resolve e_In_G id_H : group.
Ltac autog :=
  match goal with
  | |- (?a · ?n) ∈ G => apply closed_Gr; autog
  | |- (?a)⁻¹∈ G => apply closedinv_Gr; autog
  | |- (?a=e·?a) => rewrite id_l; autog
  | |- (?a=?a·e) => rewrite id_r; autog
  | |- (e=?a⁻¹·?a) => rewrite inv_l; autog
  | |- (e=?a·?a⁻¹) => rewrite inv_r; autog
  | |- (e·?a=?a) => apply id_l; autog
  | |- (?a·e=?a) => apply id_r; autog
  | |- (?a⁻¹·?a=e) => apply inv_l; autog
  | |- (?a·?a⁻¹=e) => apply inv_r; autog
  | |- e∈G => apply e_In_G
  | |- e∈H => apply id_H
  | |- (?a · ?n) ∈ H => apply closed_H; autog
  | |- (?a)⁻¹∈ H => apply closed_H_inv; autog
  | _ : ?a∈ H |- (?a)∈ G => apply subsG; autog
  | |- _ => auto with group
  end.

(* Definition invariant_subgroup {U} {Gr:Group U} (SG: subGroup Gr) :=
  forall g, g∈G -> forall h, h∈G -> (g·h·g⁻¹) ∈ H. *)

(* 模H同余 *)
Definition congruent {U} {Gr:Group U} (SG: subGroup Gr) a b : Prop :=
  a∈G /\ b∈G /\ exists h, h∈H /\ a = b · h.

Definition reflexive {A:Type} (R:A->A->Prop) (G: Ensemble A):=
  forall x:A, x∈G -> R x x.
Definition transitive {A:Type} (R:A->A->Prop) (G: Ensemble A):=
  forall x y z:A, x∈G -> y∈G -> z∈G -> R x y -> R y z -> R x z.
Definition symmetric {A:Type} (R:A->A->Prop) (G: Ensemble A):=
  forall x y:A, x∈G -> y∈G -> R x y -> R y x.

Class equivalence {A:Type} (R:A->A->Prop) (G: Ensemble A): Prop :=
      { equiv_refl : reflexive R G;
        equiv_trans : transitive R G;
        equiv_sym : symmetric R G}.

Theorem equi_congruent {U} {Gr:Group U} (SG: subGroup Gr): equivalence
  (congruent SG) G.
Proof.
  split.
  - repeat split; auto. exists e. split; autog.
  - repeat split; auto. destruct H3 as [? [? [? []]]], H4 as [? [? [? []]]].
    subst. exists (x1·x0); split; autog. apply assoc_Gr; autog.
  - repeat split; auto. destruct H2 as [? [? [? []]]]. subst.
    exists x0⁻¹. split; autog. rewrite assoc_Gr; autog. simp; autog.
Qed.

(*陪集 *)
Definition coset {U} {Gr:Group U} a (SG: subGroup Gr) :Ensemble U:=
  fun x=> exists h, h∈H /\ x = a·h.

Theorem eq_coset_congruent : forall {U} {Gr:Group U} (SG: subGroup Gr) a,
  a∈G -> congruent SG a = coset a SG.
Proof.
  intros. apply Extensionality_Ensembles. split.
  - red; intros. destruct H1 as [? [? [? []]]]. red; red.
    subst. exists x0⁻¹. split; autog. rewrite assoc_Gr; autog. simp; autog.
  - red; intros. destruct H1 as [? []]. subst.
    repeat split; autog. exists x0⁻¹. split; autog.
    rewrite assoc_Gr; autog. simp; autog.
Qed.

(*所有陪集的集族G/H 商集*)
Definition quotient_set {U} (Gr:Group U) (SG: subGroup Gr) :Ensemble (Ensemble U):=
  fun x => exists a, a∈G /\ x = coset a SG.

(*子群是正规子群*)
Definition normal_subgroup {U} {Gr:Group U} (SG: subGroup Gr) :Prop :=
  forall g h, g∈G -> h∈H -> g·h·g⁻¹ ∈H.

(* 子群SG的陪集乘法 *)
Definition mul_coset {U} (Gr:Group U) (SG: subGroup Gr):
  Ensemble U -> Ensemble U -> Ensemble U :=
  fun x y =>
  match (classicT (x∈(quotient_set Gr SG))) with
  | left l0 => match (classicT (y∈(quotient_set Gr SG))) with
               | left l1 => coset ((pick l0)·(pick l1)) SG
               | _ => Empty_set U
               end
  | _ => Empty_set U
  end.

(* 子群SG的陪集的逆运算 *)
Definition inv_coset {U} (Gr:Group U) (SG: subGroup Gr):
  Ensemble U -> Ensemble U:= fun x=>
  match (classicT (x∈(quotient_set Gr SG))) with
  | left l0 => coset (inv (pick l0)) SG
  | _ => Empty_set U
  end.

Fact inv_inv : forall {U} (Gr:Group U) d, d∈G -> (d ⁻¹) ⁻¹ = d.
Proof.
  intros. pose proof invGr. unfold idinv in H1.
  assert (d ⁻¹ ⁻¹· d⁻¹ = d·d⁻¹).
  { simp; autog. }
  assert (d ⁻¹ ⁻¹ · d ⁻¹ ·d = d · d ⁻¹·d). { rewrite H2; auto. }
  rewrite assoc_Gr in H3; autog. repeat (simpH H3; autog).
Qed.
Global Hint Resolve inv_inv:group.

Lemma distr_inv : forall {U} (Gr:Group U) a b,
  a∈G -> b∈G -> (a·b)⁻¹ = b⁻¹· a⁻¹.
Proof.
  intros. pose proof id_Gr. pose proof invGr. red in H2, H3.
  assert (Ha : a ⁻¹ ∈ G). { apply closedinv_Gr; auto. }
  assert (Hb : b ⁻¹ ∈ G). { apply closedinv_Gr; auto. }
  assert ((a · b) ⁻¹·(a · b) = b ⁻¹ · a ⁻¹·(a · b)).
  { destruct (H3 (a · b)). apply closed_Gr; auto.
    rewrite H5. rewrite assoc_Gr; auto.
    pattern (a ⁻¹ · (a · b)). rewrite <-assoc_Gr; auto.
    destruct (H3 a), (H3 b), (H2 b); auto. rewrite H7, H10, H9. auto.
    apply closed_Gr; auto. }
  assert ((a · b) ⁻¹ · (a · b)·(a · b) ⁻¹ = b ⁻¹ · a ⁻¹ · (a · b)·(a · b) ⁻¹).
  { rewrite H4; auto. }
  destruct (H3 (a · b)). apply closed_Gr; auto.
  rewrite H7 in H5. destruct (H2 (a · b) ⁻¹).
  apply closedinv_Gr; apply closed_Gr; auto. rewrite H8 in H5.
  assert ((a · b) ∈ G). { apply closed_Gr; auto. }
  assert ((a · b) ⁻¹∈ G). { apply closedinv_Gr; auto. }
  rewrite assoc_Gr in H5; auto. rewrite H6 in H5. rewrite H5.
  rewrite assoc_Gr; auto. f_equal. destruct (H2 (a⁻¹)); auto.
  apply e_In_G. apply closed_Gr; auto.
Qed.
Global Hint Resolve distr_inv:group.

Lemma coset_eq : forall {U} (Gr:Group U) (SG: subGroup Gr) a b, a∈G -> b∈G ->
  congruent SG a b <-> coset a SG = coset b SG.
Proof.
  split; intros.
  - destruct H2 as [? [? [? []]]]. apply Extensionality_Ensembles.
    split; red; intros.
    + destruct H6 as [? []]. red; red.
      subst. exists (x · x1). split; autog. apply assoc_Gr; autog.
    + destruct H6 as [? []]. red; red. subst.
      exists (x⁻¹·x1); split; autog. repeat rewrite <-assoc_Gr; autog.
      f_equal. rewrite assoc_Gr; autog. simp; autog.
  - pose proof eq_coset_congruent _ _ H0.
    pose proof eq_coset_congruent _ _ H1.
    rewrite H2 in H3. rewrite <-H4 in H3.
    pose proof equi_congruent _ as [].
    unfold reflexive in *. pose proof equiv_refl0 b.
    rewrite H3; auto.
Qed.

Lemma congruent_inv : forall {U} (Gr:Group U) (SG: subGroup Gr) a b,
  normal_subgroup SG ->
  a∈G -> b∈G -> congruent SG a b ->
  congruent SG a⁻¹ b⁻¹.
Proof.
  intros. repeat split. apply closedinv_Gr; auto. apply closedinv_Gr; auto.
  destruct H3 as [? [? [? []]]]. subst. pose proof subsG x H5.
  rewrite distr_inv; auto. pose proof closedinv_Gr x H6.
  pose proof closedinv_Gr _ H4.
  pose proof closed_H_inv _ H5.
  exists (b·x⁻¹·b⁻¹); split; auto.
  repeat rewrite <-assoc_Gr; auto.
  pose proof id_Gr. pose proof invGr. red in H10, H11.
  destruct (H11 b); auto. rewrite H13. destruct (H10 x ⁻¹); auto.
  rewrite H14; auto. apply closed_Gr; auto.
Qed.

Definition finite_group {U} (Gr: Group U) := Finite _ G.

Lemma empty_not_inhabited : forall {U} (A:Ensemble U),
  (Empty_set _ = A) <-> (~ Inhabited _ A).
Proof.
  split; intros.
  - intro. destruct H1. rewrite <-H0 in H1. destruct H1.
  - apply Extensionality_Ensembles; split.
    + red; intros. destruct H1.
    + red; intros. destruct H0. apply Inhabited_intro with x; auto.
Qed.

Lemma not_empty_inhabited : forall {U} (A:Ensemble U),
  ~(Empty_set _ = A) <-> Inhabited _ A.
Proof.
  split; intros.
  - destruct (classic (Inhabited U A)); auto.
    elim H0. apply Extensionality_Ensembles; split.
    + red; intros. destruct H2.
    + red; intros. destruct H1. apply Inhabited_intro with x; auto.
  - intro. destruct H0. rewrite <-H1 in H0. destruct H0.
Qed.

Lemma singlelen_set : forall {U} (a x: U), a ∈ [x] -> a = x.
Proof.
  intros. destruct H0. auto.
Qed.

Lemma eq_Add_Subtract: forall {U} (x:U) A,
  x ∈ A ->  Add U (Subtract U A x) x = A.
Proof.
  intros.
  apply Extensionality_Ensembles; split.
  - red; intros.
    destruct H1.
    + destruct H1; auto.
    + destruct H1; auto.
  - red; intros. destruct (classic (x0 ∈ [x])).
    + apply Union_intror. auto.
    + apply Union_introl. split; auto.
Qed.

Theorem bijection_card : forall n {U V} A B (f : U -> V),
  Bijective A B (f : U -> V) -> cardinal _ A n
  -> cardinal _ B n.
Proof.
  intro. induction n; intros.
  - apply cardinalO_empty in H1.
    destruct H0 as [[][]].
    destruct (classic (B=(Empty_set _))).
    + rewrite H5. constructor.
    + assert (Inhabited _ B).
      { apply not_empty_inhabited; auto. }
      destruct H6. apply H2 in H6 as [x0 []].
      rewrite H1 in H6; destruct H6.
  - assert (Inhabited _ A).
    { destruct (classic (Inhabited U A)); auto.
      apply empty_not_inhabited in H2.
      rewrite <-H2 in H1. pose proof cardinal_Empty U _ H1.
      inversion H3.
      }
    destruct H2.
    pose proof card_soustr_1 _ _ _ H1 _ H2. simpl in H3.
    assert (HSx: Bijective (Subtract U A x) (Subtract V B (f x)) f).
    { destruct H0 as [[][]].
      split.
      - split.
        + red; intros. destruct H7. split. apply H0; auto.
          intro. elim H8. apply singlelen_set in H9.
          apply H6 in H9; autog. subst; split.
        + intros. destruct H7. apply H4 in H7 as [x0 []].
          exists x0. split; auto. split; auto.
          intro. elim H8. apply singlelen_set in H10.
          subst. split.
      - split.
        + red; intros. destruct H7. split.
          apply H0; auto. intro. destruct H8.
          apply singlelen_set in H9. apply H6 in H9; autog.
          subst. split.
        + intros. apply H6; auto.
          * destruct H7; auto.
          * destruct H8; auto.
    }
    pose proof IHn _ _ _ _ _ HSx H3.
    assert (A = Add _ (Subtract U A x) x).
    { apply Extensionality_Ensembles. split.
      - red; intros. rewrite eq_Add_Subtract; auto.
      - rewrite eq_Add_Subtract; auto.
        red; intro; auto.
      }
    assert (B = Add _ (Subtract V B (f x)) (f x)).
    { apply Extensionality_Ensembles. split.
      - red; intros. rewrite eq_Add_Subtract; auto.
        apply H0; auto.
      - rewrite eq_Add_Subtract; auto.
        red; intro; auto. apply H0; auto.
      }
    rewrite H6. constructor; auto. intro.
    destruct H7. destruct H8. split.
Qed.

Definition family_union {U} (A: Ensemble (Ensemble U)) : Ensemble U:=
  fun x => exists X, x∈X /\ X∈A.

Lemma empty_family_empty :
  forall {U}, (family_union (Empty_set (Ensemble U))) = Empty_set _.
Proof.
  intros. apply Extensionality_Ensembles; split.
  - red; intros. destruct H0 as [? [? []]].
  - red; intros. destruct H0.
Qed.

Theorem card_union : forall N {U} (A B: Ensemble U) M,
  cardinal _ A M -> cardinal _ B N ->
  A ∩ B = (Empty_set _) ->
  cardinal _ (A∪B) (N+M).
Proof.
  intro. induction N.
  - intros. simpl. apply cardinalO_empty in H1. rewrite H1.
    assert ((A ∪ Empty_set U)=A).
    { apply Extensionality_Ensembles; split.
      - red; intros. destruct H3; auto. destruct H3.
      - red; intros. apply Union_introl; auto.
      }
    rewrite H3; auto.
  - intros.
    assert (Inhabited _ B).
    { destruct (classic (Inhabited _ B)); auto.
      apply empty_not_inhabited in H3.
      rewrite <-H3 in H1. pose proof cardinal_Empty _ _ H1.
      inversion H4.
      } destruct H3 as [a ?].
    assert (cardinal _ (Subtract _ B a) N).
    { pose proof card_soustr_1 _ _ _ H1 _ H3. simpl in H4. auto. }
    assert (~a∈A). { intro. assert (a∈(A ∩ B)). split; auto.
      rewrite H2 in H6. destruct H6. }
    assert (cardinal _ (Add _ A a) (S M)).
      { apply card_add; auto. }
    assert ((Add U A a)∪(Subtract U B a)=A∪B).
      { apply Extensionality_Ensembles. split.
        - red; intros. destruct H7.
          + destruct H7. apply Union_introl; auto.
            destruct H7. apply Union_intror; auto.
          + destruct H7. apply Union_intror; auto.
        - red; intros. destruct H7.
          + apply Union_introl. apply Union_introl; auto.
          + destruct (classic (x∈[a])).
            * destruct H8. apply Union_introl.
              apply Union_intror; split.
            * apply Union_intror. split; auto.
        }
    assert ((Add U A a)∩(Subtract U B a)= (Empty_set _)).
      { apply Extensionality_Ensembles. split.
        - red; intros. destruct H8. destruct H9.
          destruct H8.
          + rewrite <- H2; split; auto.
          + tauto.
        - red; intros. destruct H8.
        } simpl.
    rewrite PeanoNat.Nat.add_comm.
    assert (((S M) + N)=(S (M + N))). { simpl. auto. }
    rewrite <- H9. rewrite PeanoNat.Nat.add_comm.
    pose proof IHN _ _ _ _ H6 H4 H8. rewrite H7 in H10.
    auto.
Qed.

Theorem family_add : forall N {U} (A:Ensemble (Ensemble U)) x M,
  cardinal _ (family_union A) M -> cardinal _ x N ->
  (forall X, X∈A -> X ∩ x = (Empty_set _)) ->
  cardinal _ (family_union (Add (Ensemble U) A x)) (N+M).
Proof.
  intro. induction N.
  - intros. simpl. pose proof cardinalO_empty _ _ H1.
    rewrite H3 in *.
    assert ((family_union A) = (family_union (Add (Ensemble U) A x))).
    { apply Extensionality_Ensembles; split.
      - red; intros. destruct H4 as [? []].
        rewrite H3. unfold family_union. exists x1. split; auto.
        apply Union_introl; auto.
      - red; intros. destruct H4 as [? []].
        red. red. unfold Add in H5. rewrite H3 in H5.
        destruct H5. eauto. destruct H5. destruct H4.
      }
    rewrite H3 in *. rewrite <-H4. auto.
  - intros. simpl.
    assert ((family_union (Add (Ensemble U) A x) = (family_union A)∪x)).
    { apply Extensionality_Ensembles; split.
      - red; intros.
        destruct H3. destruct H3. destruct H4.
        + apply Union_introl. exists x1; auto.
        + destruct H4.
          apply Union_intror. auto.
      - red; intros. destruct H3.
        + destruct H3. destruct H3.
          exists x1. split; auto. unfold Add.
          apply Union_introl. auto.
        + red. red. exists x.
          split; auto.
          apply Union_intror; split. }
    rewrite H3.
    assert (S (N + M) = S N + M); auto.
    rewrite H4. apply card_union; auto.
    apply Extensionality_Ensembles; split.
    + red; intros.
      destruct H5, H5, H5.
      pose proof H2 _ H7. rewrite <- H8.
      split; auto.
    + red; intros. destruct H5.
Qed.

Theorem family_card :
  forall {U} Q (A:Ensemble (Ensemble U)) n,cardinal _ A Q ->
  (forall X, X∈A -> cardinal _ X n) ->
  (forall X Y, X∈A -> Y∈A -> X<>Y -> X ∩ Y = (Empty_set _)) ->
  cardinal _ (family_union A) (Q*n).
Proof.
  intros U Q. induction Q.
  - intros. simpl. pose proof cardinalO_empty _ _ H0.
    rewrite H3. rewrite empty_family_empty. constructor.
  - intros. assert (Inhabited _ A).
    { destruct (classic (Inhabited _ A)); auto.
      apply empty_not_inhabited in H3.
      rewrite <-H3 in H0. pose proof cardinal_Empty _ _ H0.
      inversion H4.
      } destruct H3 as [a ?].
    assert (cardinal _ (Subtract _ A a) Q).
    { pose proof card_soustr_1 _ _ _ H0 _ H3. simpl in H4. auto. }
    assert (HS1: forall X, X ∈ (Subtract _ A a) -> cardinal U X n).
    { intros. apply H1. destruct H5; auto. }
    assert (HS2: forall X Y, X ∈ (Subtract _ A a) -> Y ∈ (Subtract _ A a)
     -> X<>Y -> X ∩ Y = Empty_set _).
    { intros. apply H2; destruct H5; auto. destruct H6; auto. }
    pose proof IHQ _ _ H4 HS1 HS2.
    assert (Add _ (Subtract (Ensemble U) A a) a = A).
      { apply eq_Add_Subtract; auto. }
    simpl. rewrite <-H6.
    apply family_add; auto. intros. destruct H7.
    apply H2; auto. intro. elim H8. subst; split.
Qed.

(* 集合的阶 *)
Definition order {U} (A:Ensemble U) (FA: Finite _ A) :=
  pick (finite_cardinal _ _ FA).

Theorem eq_order : forall {U V} A B (f:U->V) (FA: Finite _ A)
  (FB: Finite _ B), Bijective A B f -> order _ FA = order _ FB.
Proof.
  intros.
  unfold order. unfold pick.
  repeat destruct constructive_indefinite_description; simpl.
  pose proof bijection_card _ _ _ _ H0 c.
  pose proof cardinal_unicity _ _ _ c0 _ H1. auto.
Qed.

(* Langrange's_theorem *)
Section Langrange's_theorem.

Context
  {U}
  (Gr: Group U)
  (SG : subGroup Gr)
  (FG: finite_group Gr).

(* 群的阶 *)
Definition order_group :=
  order G FG.

Lemma finite_subgroup : Finite _ H.
Proof.
  apply Finite_downward_closed with G; auto. apply subsG.
Qed.

Definition map_H_coset a := fun h => a·h.

Lemma bijective_H_coset :
  forall a, a∈G -> Bijective H (coset a SG) (map_H_coset a).
Proof.
  intros. split.
  - split.
    + red; intros. red; red. exists a0.
      split; auto.
    + intros. unfold map_H_coset.
      destruct H1 as [? []]. exists x; split; auto.
  - split.
    + red; intros. red; red. exists a0.
      split; auto.
    + intros. unfold map_H_coset in H3.
      assert (a⁻¹ ·(a · a0) = a⁻¹ ·(a · b)).
      { rewrite H3; auto. }
      rewrite <- assoc_Gr in H4; autog. simpH H4; autog.
      simpH H4; autog. rewrite <- assoc_Gr in H4; autog.
      simpH H4; autog. simpH H4; autog.
Qed.

Lemma finite_coset :
  forall a, a∈G -> Finite _ (coset a SG).
Proof.
  pose proof finite_cardinal _ _ finite_subgroup as [N CH].
  intros. pose proof bijection_card.
  pose proof H1 N _ _ _ _ _ (bijective_H_coset _ H0) CH.
  apply cardinal_finite in H2. auto.
Qed.
(* Theorem H_im_is_coset : forall a, a∈G ->
  (Im _ _ H (map_H_coset a)) = (coset a SG).
Proof.
  intros. *)

Definition map_G_quotient :U -> Ensemble U:=
  fun a => coset a SG.

Lemma im_is_quotient_set: (Im _ _ G map_G_quotient) = (quotient_set Gr SG).
Proof.
  apply Extensionality_Ensembles; split.
  - red; intros.
    destruct H0.
    unfold map_G_quotient in H1.
    red; red.
    exists x; split; auto.
  - red; intros.
    destruct H0 as [? []].
    unfold map_G_quotient.
    pose proof Im_intro _ _ G map_G_quotient x0 H0.
    apply H2.
    unfold map_G_quotient; auto.
Qed.

Theorem finite_quotient_set :
  Finite _ (quotient_set Gr SG).
Proof.
  pose proof finite_image.
  pose proof H0 _ _ G map_G_quotient FG.
  rewrite im_is_quotient_set in H1; auto.
Qed.

Theorem quotient_set_inter_empty :
  forall X Y, X∈(quotient_set Gr SG) -> Y∈(quotient_set Gr SG) ->
    X<>Y -> X∩Y= (Empty_set _).
Proof.
  intros. destruct H0, H0, H1, H1.
  apply Extensionality_Ensembles; split.
  - red; intros. elim H2. rewrite H3, H4.
    apply coset_eq; autog. destruct H5.
    repeat split; auto.
    rewrite H3 in H5. rewrite H4 in H6.
    destruct H5 as [? []], H6 as [? []].
    rewrite H7 in H8. assert (x · x2· x2⁻¹ = x0 · x3· x2⁻¹).
    { rewrite H8; auto. }
    rewrite assoc_Gr in H9; autog. simpH H9; autog.
    simpH H9; autog. rewrite assoc_Gr in H9; autog.
    exists (x3 · x2 ⁻¹); split; autog.
  - red; intros. destruct H5.
Qed.

Theorem family_quotient_set_eq_G :
  (family_union (quotient_set Gr SG)) = G.
Proof.
  apply Extensionality_Ensembles; split.
  - red; intros. destruct H0 as [? []].
    destruct H1 as [? []]. rewrite H2 in H0.
    destruct H0 as [? []]. subst. autog.
  - red; intros. red; red.
    exists (coset x _); split.
    + red; red. exists e; split; autog.
    + red; red. exists x; split; auto.
Qed.

Theorem Langrange's_theorem :
  (order _ FG) = (order _ finite_quotient_set)* (order _ finite_subgroup).
Proof.
  pose proof finite_cardinal _ _ finite_quotient_set as [Q ?].
  assert ((order _ finite_quotient_set) = Q).
  { unfold order. unfold pick.
    destruct constructive_indefinite_description; simpl.
    pose proof cardinal_unicity _ _ _ H0 _ c. auto. }
  rewrite H1.
  pose proof finite_cardinal _ _ finite_subgroup as [N ?].
  assert ((order _ finite_subgroup) = N).
  { unfold order. unfold pick.
    destruct constructive_indefinite_description; simpl.
    pose proof cardinal_unicity _ _ _ H2 _ c.
    auto. }
  rewrite H3.
  assert (forall a (ag: a∈G),N = order (coset a SG) (finite_coset _ ag) ).
  { intros. rewrite <- H3.
    apply eq_order with (map_H_coset a). apply bijective_H_coset; auto. }
  assert (forall A, A∈(quotient_set Gr SG) -> cardinal _ A N).
  { intros. destruct H5. destruct H5. pose proof H4 _ H5.
    unfold order in H7. unfold pick in H7.
    destruct constructive_indefinite_description in H7. simpl in H7.
    subst; auto. }
  pose proof family_card _ _ _ H0 H5 quotient_set_inter_empty.
  rewrite family_quotient_set_eq_G in H6.
  unfold order. unfold pick.
  destruct constructive_indefinite_description; simpl.
  pose proof cardinal_is_functional _ _ _ c _  _ H6.
  apply H7; auto.
Qed.


Require Import Problem PeanoNat Omega.

Theorem solution : task.
Proof.
  unfold task.
  intro.
  remember n as m.
  assert (m <= n) by omega; clear Heqm.
  revert m H.

  induction n; intros.
  - apply Nat.le_0_r in H; subst m; auto.
  - do 2 (destruct m; [auto|]).
    simpl.
    rewrite IHn; omega.
Qed.


(* Exercise 33 *)

Require Import BenB.

Variables A B C D : Prop.

Theorem exercise_033 : ((A /\ B) -> ~C) -> ((A /\ C) -> ~B).
Proof.
imp_i a1.
imp_i a2.
neg_i C a3.
imp_e (A /\ B).
hyp a1.
con_i.
con_e1 C.
hyp a2.
hyp a3.
con_e2 A.
hyp a2.
Qed.


Section Minimal_propositional_logic.

Variables P Q R T : Prop.

Theorem imp_trans : (P->Q) -> (Q->R) -> P -> R.
Proof.
  intros H H' p.
  apply H'.
  apply H.
  assumption.
Qed.

Print imp_trans.


Require Import Coq.Lists.List.
Require Import Coq.micromega.Lia.

Import ListNotations.

(* pigeon hole principle *)

Lemma list_gen_ind_rec {X : Type} (P : list X -> Prop)
(HP : forall l, (forall m, length m < length l -> P m)%nat -> P l)
n : forall l, (length l < n)%nat -> P l.
Proof.
  induction n as [ | n IHn ]; intros l Hl.
  exfalso; revert Hl. intros; lia.
  apply HP.
  intros m Hm.
  apply IHn.
  lia.
Qed.

Theorem list_gen_ind {X : Type}(P : list X -> Prop)
(HP : forall l, (forall m, length m < length l -> P m)%nat -> P l): forall l, P l.
Proof.
  intros l.
  apply list_gen_ind_rec with (n := S (length l)).
  intros. auto.
  lia.
Qed.

Inductive perm {X:Type} : list X -> list X -> Prop :=
| perm_nil   :                   perm nil nil
| perm_cons  : forall x l1 l2,    perm l1 l2
                           ->   perm (x::l1) (x::l2)
| perm_swap  : forall x y l,  perm (x::y::l) (y::x::l)
| perm_trans : forall l1 l2 l3,    perm l1 l2
                           ->      perm l2 l3
                           ->      perm l1 l3.
Notation "x '~p' y " := (perm x y) (at level 70, no associativity).

Fact perm_incl {X : Type} (l m: list X ): l ~p m -> incl l m.
Proof.
  intros H.
  induction H as [
                 | x l1 l2 H1 IH1
                 | x y l
                 | l1 l2 l3 H1 IH1 H2 IH2
                 ].
  intros Hyp1 Hyp2 .
  apply Hyp2.
  intros Hyp1 Hyp2 .
  destruct Hyp2.
  left.
  apply H.
  right.
  apply IH1.
  apply H.
  intros ? ?.
  revert H.
  simpl.
  tauto.
  revert IH2.
  revert IH1.
  apply incl_tran.
Qed.

Fact perm_refl {A:Type} (l:list A) : l ~p l.
Proof.
 induction l as [ |list head IH].
 apply perm_nil.
 apply perm_cons.
 apply IH.
Qed.

Fact perm_middle {A:Type}x (l r:list A) : x::l++r ~p l++x::r.
Proof.
  induction l as [ | y list IHl ].
  simpl.
  apply perm_refl.
  simpl.
  apply perm_trans with (1 := perm_swap _ _ _).
  apply perm_cons.
  apply IHl.
Qed.

Fact incl_right_app {A:Type} (l m p:list A) : incl m (l++p) -> exists m1 m2, m ~p m1++m2 /\ incl m1 l /\ incl m2 p.
Proof.
  induction m as [ | x m IHm ].
  exists nil, nil; simpl; repeat split;intros;try easy.
  apply perm_nil.
  intros H.
  apply incl_cons_inv in H.
  destruct H as (H1 & H2).
  apply IHm in H2.
  destruct H2 as (m1 & m2 & H3 & H4 & H5).
  destruct IHm.
  apply perm_incl in H3.
  apply incl_appl with(m:=p) in H4.
  apply incl_appr with(m:=l) in H5.
  apply incl_app with(l:=m1) (m:=m2) (n:=l++p) in H4.
  apply incl_tran with(l:=m) in H4.
  apply H4.
  apply H3.
  apply H5.
  destruct H.
  destruct H.
  destruct H0.
  apply in_app_or in H1.
  destruct H1.
  exists (x::x0).
  exists (x1).
  split.
  apply perm_cons with(x:=x) in H.
  apply H.
  split.
  apply incl_cons with(a:=x) in H0.
  apply H0.
  apply H1.
  apply H2.
  exists (x0).
  exists (x::x1).
  split.
  apply perm_cons with(x:=x) in H.
  apply perm_trans with(l2:=(x::x0++x1)) (l3:= (x0++x::x1)) in H.
  apply H.
  apply perm_middle.
  split.
  apply H0.
  apply incl_cons with(a:=x) in H2.
  apply H2.
  apply H1.
Qed.

Fact incl_right_cons_split {X : Type}  x (l m:list X) : incl m (x::l) -> exists m1 m2, m ~p m1 ++ m2 /\ (forall a, In a m1 -> a = x) /\ incl m2 l.
Proof.
  intros H.
  apply (incl_right_app (x::nil) _ l) in H.
  destruct H.
  destruct H.
  destruct H.
  destruct H0.
  exists x0.
  exists x1.
  split.
  apply H.
  split.
  2: apply H1.
  intros.
  apply perm_incl in H.
  apply incl_cons with(l:=nil) in H2.
  apply incl_tran with(l:=a::nil) in H0.
  2: apply H2.
  2: intros;easy.
  apply incl_cons_inv in H0.
  destruct H0.
  induction H0.
  subst.
  trivial.
  exfalso.
  apply H0.
Qed.

Fact perm_sym {A:Type} (l1 l2:list A) : l1 ~p l2 -> l2 ~p l1.
Proof.
  intros H.
  induction H.
  apply perm_nil.
  apply perm_cons.
  assumption.
  apply perm_swap.
  apply perm_trans with l2.
  apply IHperm2.
  apply IHperm1.
Qed.

Fact incl_right_cons_choose {A:Type}x (l m:list A) : incl m (x::l) -> In x m \/ incl m l.
Proof.
  intros H.
  apply incl_right_cons_split in H.
  destruct H as ( m1 & m2 & H1 & H2 & H3 ); simpl in H1.
  destruct m1 as [ | y m1 ].
  right.
  simpl in H1.
  apply perm_incl in H1.
  revert H1 H3.
  apply incl_tran.
  apply Forall_forall in H2.
  apply Forall_inv in H2.
  subst.
  apply perm_sym in H1.
  apply perm_incl in H1.
  apply incl_cons_inv in H1.
  destruct H1.
  left.
  apply H.
Qed.

Fact repeat_choice_two {X:Type} (x : X) m : (forall a, In a m -> a = x) -> (exists m', m = x::x::m') \/ m = nil \/ m = x::nil.
Proof.
  intros H.
  destruct m as [ | a [ | b m ] ].
  right; left; auto.
  right; right; rewrite (H a); auto; left; auto.
  left; rewrite (H a), (H b).
  exists m; auto.
  right; left; auto.
  left; auto.
Qed.

Inductive list_has_dup {X:Type} : list X -> Prop :=
| in_lhd_1 : forall x l, In x l -> list_has_dup (x::l)
| in_lhd_2 : forall x l, list_has_dup l -> list_has_dup (x::l).

Notation lhd := list_has_dup.

Fact lhd_cons_inv {A:Type}x (l:list A) : lhd (x::l) -> In x l \/ lhd l.
Proof.
  inversion_clear 1;auto.
Qed.

Fact perm_lhd {A:Type} (l m:list A) : l ~p m -> lhd l -> lhd m.
Proof.
  intros H.
  induction H as [ | x l m H1 IH1 | x y l | ]; auto.
  intros H.
  apply lhd_cons_inv in H; destruct H as [ H | H ].
  left.
  apply perm_incl in H1.
  apply H1.
  apply H.
  right.
  apply IH1.
  apply H.
  intros H.
  apply lhd_cons_inv in H. simpl in *.
  destruct H as [H | H];subst.
  destruct H as [H | H];subst.
  induction l.
  left.
  left.
  reflexivity.
  left.
  left.
  reflexivity.
  right.
  left.
  apply H.
  apply lhd_cons_inv in H.
  destruct H as [ H | H ].
  left.
  right.
  apply H.
  right.
  right.
  apply H.
Qed.

Fact incl_right_cons_incl_or_lhd_or_perm {A:Type} x (m l:list A) : incl m (x::l) -> incl m l \/ (lhd m) \/ exists m', m ~p x::m' /\ incl m' l.
Proof.
  intros H.
  apply incl_right_cons_split in H.
  destruct H as (m1 & m2 & H1 & H2 & H3).
  destruct (repeat_choice_two _ _ H2) as [ (m3 & H4) | [ H4 | H4 ] ];
    subst m1; simpl in H1; clear H2.
  apply perm_sym in H1.
  right; left.
  apply perm_lhd with (1 := H1).
  constructor 1; left; auto.
  left.
  intros u Hu.
  apply H3.
  apply perm_incl with (1 := H1); auto.
  right; right.
  exists m2; auto.
Qed.

Fact In_perm_head {X:Type}(x : X) l : In x l -> exists m, l ~p x::m.
Proof.
  intros H.
  apply in_split in H.
  destruct H as (u & v & ?).
  subst l.
  exists (u++v).
  apply perm_sym, perm_middle.
Qed.

Fact perm_length {A:Type} (l1 l2:list A) : l1 ~p l2 -> length l1 = length l2.
Proof.
  intros H.
  induction H as [
                  | x l1 l2 H1 IH1
                  | x y l
                  | l1 l2 l3 H1 IH1 H2 IH2
                  ].
  apply refl_equal.
  simpl.
  f_equal.
  apply IH1.
  simpl.
  apply refl_equal.
  transitivity (length l2).
  apply IH1.
  apply IH2.
Qed.

Fact length_le_and_incl_implies_dup_or_perm {A:Type} (l:list A)  :
forall m, (length l <= length m)%nat
                      -> incl m l
                      -> (lhd m) \/ m ~p l.
Proof.
induction l as [ [ | x l ] IHl ] using list_gen_ind.

(* case l -> nil *)
- intros ? ? ?.
  right.
  apply incl_l_nil in H0.
  subst.
  apply perm_nil.

- intros [ | y m ] H1 H2.
  (* case l -> x::l and m -> nil *)
  + simpl in H1. lia.
  (* case l -> x::l and m -> y :: m *)
  + simpl in H1; apply le_S_n in H1.
    apply incl_cons_inv in H2.
    destruct H2 as [ H3 H4 ].
    simpl in H3.
    destruct H3 as [ H3 | H3 ].
    (* case x = y *)
    ++ subst y.
       apply incl_right_cons_choose in H4.
       destruct H4 as [ H4 | H4 ].

      (* case x = y & In x m *)
      +++ left.
          left.
          apply H4.

      (* case x = y & incl m l *)
      +++ destruct IHl with (3 := H4).
          simpl; lia.
          assumption.
          left. right;auto.
          right. constructor;auto.
      (* case In y l *)
    ++ apply incl_right_cons_incl_or_lhd_or_perm in H4.
       destruct H4 as [ H4 | [ H4 | (m' & H4 & H5) ] ].
       (* case In y l and incl m l *)
      +++ destruct IHl with (3 := H4) as [ H5 | H5 ]; auto.
          left;right;apply H5.
          left.
          left.
          apply perm_sym in H5.
          apply perm_incl in H5.
          apply H5.
          apply H3.
          (* case In y l and lhd m *)
      +++ left.
          right.
          apply H4.
      (* case In y l and m ~p x::m' and incl m' l *)
      +++ apply perm_sym in H4.
          apply In_perm_head in H3.
          destruct H3 as (l' & Hl').
          (* l ~p y::l' for some l' *)
          assert (incl m' (y::l')) as H6.
          {intros ? ?; apply perm_incl with (1 := Hl'), H5; auto. }
          clear H5.
          (* and incl m' (y::l') *)
          apply incl_right_cons_choose in H6.
          destruct H6 as [ H6 | H6 ].
          (* subcase In y m' *)
          ++++ left.
               left.
               apply perm_incl in H4.
               apply H4.
               right.
               apply H6.
          (* subcase incl m' l' *)
          ++++ apply IHl in H6.
              destruct H6 as [ H6 | H6 ].
              left.
              apply perm_lhd in H4.
              right.
              apply H4.
              right.
              apply H6.
              right.
              move Hl' after m'.
              apply perm_sym in H4.
              apply perm_cons with(x:=y) in H4.
              apply perm_cons with(x:=x) in H6.
              apply perm_cons with(x:=y) in H6.
              apply perm_cons with(x:=x) in Hl'.
              apply perm_sym in Hl'.
              apply perm_trans with(l2:=x::y::l')(l1:=y::x::l') in Hl' .
              apply perm_trans with(l1:=y::m) in H6.
              apply perm_trans with(l1:=y::m) in Hl'.
              apply Hl'.
              apply H6.
              apply H4.
              apply perm_swap.
              apply perm_length in Hl'.
              simpl in Hl' |- *.
              rewrite Hl'.
              lia.
              apply perm_length in Hl'.
              apply perm_length in H4.
              simpl in H4, Hl'.
              apply le_S_n.
              rewrite <- Hl', H4; auto.
Qed.

Lemma NoDup_lhd_ff {A:Type}: forall l:list A, NoDup l -> lhd l -> False.
Proof.
  intros l H.
  induction H;try easy;simpl;intros.
  inversion H1;subst;auto.
Qed.

Lemma In_pigeon_hole: forall {A: Type} ( X' X: list A), (*11*)
  NoDup X ->
  (length X > length X')%nat ->
  (forall x, In x X -> In x X') ->
  False.
Proof.
  intros.
  eapply length_le_and_incl_implies_dup_or_perm in H1;try lia.
  destruct H1.
  - eapply NoDup_lhd_ff;eauto.
  - apply perm_length in H1;lia.
Qed.


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

(**** Tests of Field with real numbers ****)

Require Import Reals RealField.
Open Scope R_scope.

(* Example 1 *)
Goal
forall eps : R,
eps * (1 / (2 + 2)) + eps * (1 / (2 + 2)) = eps * (1 / 2).
Proof.
  intros.
   field.
Qed.

(* Example 2 *)
Goal
forall (f g : R -> R) (x0 x1 : R),
(f x1 - f x0) * (1 / (x1 - x0)) + (g x1 - g x0) * (1 / (x1 - x0)) =
(f x1 + g x1 - (f x0 + g x0)) * (1 / (x1 - x0)).
Proof.
  intros.
   field.
Abort.

(* Example 3 *)
Goal forall a b : R, 1 / (a * b) * (1 / (1 / b)) = 1 / a.
Proof.
  intros.
   field.
Abort.

Goal forall a b : R, 1 / (a * b) * (1 / 1 / b) = 1 / a.
Proof.
  intros.
   field_simplify_eq.
Abort.

Goal forall a b : R, 1 / (a * b) * (1 / 1 / b) = 1 / a.
Proof.
  intros.
   field_simplify (1 / (a * b) * (1 / 1 / b)).
Abort.

(* Example 4 *)
Goal
forall a b : R, a <> 0 -> b <> 0 -> 1 / (a * b) / (1 / b) = 1 / a.
Proof.
  intros.
   field; auto.
Qed.

(* Example 5 *)
Goal forall a : R, 1 = 1 * (1 / a) * a.
Proof.
  intros.
   field.
Abort.

(* Example 6 *)
Goal forall a b : R, b = b * / a * a.
Proof.
  intros.
   field.
Abort.

(* Example 7 *)
Goal forall a b : R, b = b * (1 / a) * a.
Proof.
  intros.
   field.
Abort.

(* Example 8 *)
Goal forall x y : R,
  x * (1 / x + x / (x + y)) =
  - (1 / y) * y * (- (x * (x / (x + y))) - 1).
Proof.
  intros.
   field.
Abort.

(* Example 9 *)
Goal forall a b : R, 1 / (a * b) * (1 / 1 / b) = 1 / a -> False.
Proof.
intros.
field_simplify_eq in H.
Abort.


(* Software Foundations *)
(* Exercice 2 stars, b_times2 *)

Inductive beautiful: nat -> Prop :=
|b_0: beautiful 0
|b_3: beautiful 3
|b_5: beautiful 5
|b_sum: forall n m, beautiful n -> beautiful m -> beautiful (n +m).

Theorem b_times2: forall n, beautiful n -> beautiful (2 * n).
Proof.
    intros. unfold "*". rewrite <- plus_n_O. apply b_sum with (n:=n)(m:=n).
    apply H.
    apply H.
Qed.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf2 : natural) (y : natural) (lf1 : natural) : natural :=
  plus y (plus lf2 lf1).


From GRP Require Export group.
From GRP Require Export groupop.

Theorem homo_preserves_id :
  forall (G1 G2 : group) (f : grp_homo G1 G2),
    f (gr_id G1) = gr_id G2.
Proof.
  intros.
  replace (gr_id G1) with (gr_op G1 (gr_id G1) (gr_inv G1 (gr_id G1))).
  rewrite preserves_op. rewrite preserves_inv.
  rewrite gr_inv_r. reflexivity.
  rewrite gr_inv_r. reflexivity.
  Qed.

Definition kernel (G1 G2 : group) (f : grp_homo G1 G2) : subgroup_prop G1.
Proof.
  exists (fun g1 => f g1 = gr_id G2).
  - apply homo_preserves_id.
  - intros. rewrite preserves_op.
    rewrite H. rewrite H0. rewrite gr_id_l. reflexivity.
  - intros. rewrite preserves_inv. rewrite H.
    apply grp_id_inv_id.
  Defined.

Definition image (G1 G2 : group) (f : grp_homo G1 G2) : subgroup_prop G2.
Proof.
  exists (fun g2 => exists g1, f g1 = g2).
  - exists (gr_id G1). apply homo_preserves_id.
  - intros. destruct H; destruct H0.
    exists (gr_op G1 x x0). subst. apply preserves_op.
  - intros. destruct H. exists (gr_inv G1 x).
    subst. apply preserves_inv.
  Defined.


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

          IEEE754  :  Fcomp

          Laurent Thery

  ******************************************************************************)
Require Export Float.
Section comparisons.
Variable radix : Z.
Hypothesis radixMoreThanOne : (1 < radix)%Z.

Let radixMoreThanZERO := Zlt_1_O _ (Zlt_le_weak _ _ radixMoreThanOne).
Hint Resolve radixMoreThanZERO: zarith.

Definition Fdiff (x y : float) :=
  (Fnum x * Zpower_nat radix (Zabs_nat (Fexp x - Zmin (Fexp x) (Fexp y))) -
   Fnum y * Zpower_nat radix (Zabs_nat (Fexp y - Zmin (Fexp x) (Fexp y))))%Z.

Let FtoRradix := FtoR radix.
Local Coercion FtoRradix : float >-> R.

Theorem Fdiff_correct :
 forall x y : float,
 (Fdiff x y * powerRZ radix (Zmin (Fexp x) (Fexp y)))%R = (x - y)%R.
intros x y; unfold Fdiff in |- *.
rewrite <- Z_R_minus.
rewrite Rmult_comm; rewrite Rmult_minus_distr_l.
repeat rewrite Rmult_IZR.
repeat rewrite Zpower_nat_Z_powerRZ; auto.
rewrite (Rmult_comm (Fnum x)); rewrite (Rmult_comm (Fnum y)).
repeat rewrite <- Rmult_assoc.
repeat rewrite <- powerRZ_add; auto with real zarith.
repeat rewrite inj_abs; auto with arith.
repeat rewrite Zplus_minus; auto.
rewrite (fun t : R => Rmult_comm t (Fnum x));
 rewrite (fun t : R => Rmult_comm t (Fnum y)); auto.
apply Zplus_le_reg_l with (p := Zmin (Fexp x) (Fexp y)); auto with arith.
rewrite Zplus_minus; rewrite Zplus_0_r; apply Zle_min_r; auto.
apply Zplus_le_reg_l with (p := Zmin (Fexp x) (Fexp y)); auto with arith.
rewrite Zplus_minus; rewrite Zplus_0_r; apply Zle_min_l; auto.
Qed.
(* Definition of  comparison functions*)

Definition Feq (x y : float) := x = y :>R.

Definition Fle (x y : float) := (x <= y)%R.

Definition Flt (x y : float) := (x < y)%R.

Definition Fge (x y : float) := (x >= y)%R.

Definition Fgt (x y : float) := (x > y)%R.

Definition Fcompare (x y : float) := (Fdiff x y ?= 0)%Z.

Definition Feq_bool (x y : float) :=
  match Fcompare x y with
  | Eq => true
  | _ => false
  end.

Theorem Feq_bool_correct_t :
 forall x y : float, Feq_bool x y = true -> Feq x y.
intros x y H'; red in |- *.
apply Rplus_eq_reg_l with (r := (- y)%R).
repeat rewrite (Rplus_comm (- y)).
rewrite Rplus_opp_r.
change ((x - y)%R = 0%R) in |- *.
rewrite <- Fdiff_correct.
apply Rmult_eq_0_compat_r; auto.
cut (Fdiff x y = 0%Z); [ intros H; rewrite H | idtac ]; auto with real.
apply Zcompare_EGAL.
generalize H'; unfold Feq_bool, Fcompare in |- *.
case (Fdiff x y ?= 0)%Z;auto; intros; discriminate.
Qed.

Theorem Feq_bool_correct_r :
 forall x y : float, Feq x y -> Feq_bool x y = true.
intros x y H'; cut ((x - y)%R = 0%R).
rewrite <- Fdiff_correct; intros H'1; case Rmult_integral with (1 := H'1).
intros H'0; unfold Feq_bool, Fcompare in |- *.
rewrite eq_IZR_R0 with (1 := H'0); auto.
intros H'0; Contradict H'0.
case (Zmin (Fexp x) (Fexp y)); simpl in |- *; auto with real zarith.
apply Rplus_eq_reg_l with (r := FtoR radix y); auto with real.
Qed.

Theorem Feq_bool_correct_f :
 forall x y : float, Feq_bool x y = false -> ~ Feq x y.
intros x y H'; Contradict H'.
rewrite Feq_bool_correct_r; auto with arith.
red in |- *; intros H'0; discriminate.
Qed.

Definition Flt_bool (x y : float) :=
  match Fcompare x y with
  | Lt => true
  | _ => false
  end.

Theorem Flt_bool_correct_t :
 forall x y : float, Flt_bool x y = true -> Flt x y.
intros x y H'; red in |- *.
apply Rplus_lt_reg_r with (r := (- y)%R).
repeat rewrite (Rplus_comm (- y)).
rewrite Rplus_opp_r.
change (x - y < 0)%R in |- *.
rewrite <- Fdiff_correct.
replace 0%R with (powerRZ radix (Zmin (Fexp x) (Fexp y)) * 0)%R;
 auto with real arith.
rewrite (Rmult_comm (Fdiff x y)).
apply Rmult_lt_compat_l; auto with real zarith.
replace 0%R with (IZR 0); auto with real arith.
apply Rlt_IZR; red in |- *.
generalize H'; unfold Flt_bool, Fcompare in |- *.
case (Fdiff x y ?= 0)%Z; auto; intros; try discriminate.
Qed.

Theorem Flt_bool_correct_r :
 forall x y : float, Flt x y -> Flt_bool x y = true.
intros x y H'.
cut (0 < y - x)%R; auto with arith.
2: apply Rplus_lt_reg_l with (r := FtoRradix x); rewrite Rplus_0_r;
    rewrite Rplus_minus; auto with real.
intros H'0.
cut (Fdiff x y < 0)%R; auto with arith.
intros H'1.
cut (Fdiff x y < 0)%Z; auto with zarith.
intros H'2; generalize (Zlt_compare _ _ H'2);
 unfold Flt_bool, Fcompare, Zcompare in |- *; case (Fdiff x y);
 auto with arith; intros; contradiction.
apply lt_IZR; auto with arith.
apply (Rlt_monotony_contra_exp radix) with (z := Zmin (Fexp x) (Fexp y));
 auto with arith real; rewrite Rmult_0_l.
rewrite Fdiff_correct; auto with real.
Qed.

Theorem Flt_bool_correct_f :
 forall x y : float, Flt_bool x y = false -> Fle y x.
intros x y H'.
case (Rtotal_order (FtoRradix y) (FtoRradix x)); auto with real.
intros H'0; red in |- *; apply Rlt_le; auto with real.
intros H'0; elim H'0; clear H'0; intros H'1.
red in |- *; rewrite H'1; auto with real.
Contradict H'; rewrite Flt_bool_correct_r; auto with real.
red in |- *; intros H'; discriminate.
Qed.

Definition Fle_bool (x y : float) :=
  match Fcompare x y with
  | Lt => true
  | Eq => true
  | _ => false
  end.

Theorem Fle_bool_correct_t :
 forall x y : float, Fle_bool x y = true -> Fle x y.
intros x y H'.
cut (Feq x y \/ Flt x y).
intros H; case H; intros H1; auto with real.
red in |- *; apply Req_le; auto with real.
red in |- *; apply Rlt_le; auto with real.
generalize H' (Feq_bool_correct_t x y) (Flt_bool_correct_t x y).
unfold Fle_bool, Feq_bool, Flt_bool in |- *; case (Fcompare x y); auto.
Qed.

Theorem Fle_bool_correct_r :
 forall x y : float, Fle x y -> Fle_bool x y = true.
intros x y H'.
cut (Feq x y \/ Flt x y).
intros H; case H; intros H1; auto with real.
generalize (Feq_bool_correct_r x y).
unfold Fle_bool, Feq_bool, Flt_bool in |- *; case (Fcompare x y); auto.
generalize (Flt_bool_correct_r x y);
 unfold Fle_bool, Feq_bool, Flt_bool in |- *; case (Fcompare x y);
 auto with arith.
case H'; auto with arith.
Qed.

Theorem Fle_bool_correct_f :
 forall x y : float, Fle_bool x y = false -> Flt y x.
intros x y H'.
case (Rtotal_order (FtoRradix y) (FtoRradix x)); auto with real.
intros H'0; elim H'0; clear H'0; intros H'1.
Contradict H'.
rewrite Fle_bool_correct_r; auto with real.
red in |- *; intros H'; discriminate.
red in |- *; rewrite H'1; auto with real.
Contradict H'.
rewrite Fle_bool_correct_r; auto with real.
red in |- *; intros H'; discriminate.
red in |- *; auto with real.
Qed.

Lemma Fle_Zle :
 forall n1 n2 d : Z, (n1 <= n2)%Z -> Fle (Float n1 d) (Float n2 d).
intros; unfold Fle, FtoRradix, FtoR in |- *; simpl in |- *; auto.
case Zle_lt_or_eq with (1 := H); intros H1.
apply Rlt_le; auto with real.
rewrite <- H1; auto with real.
Qed.

Lemma Flt_Zlt :
 forall n1 n2 d : Z, (n1 < n2)%Z -> Flt (Float n1 d) (Float n2 d).
intros; unfold Flt, FtoRradix, FtoR in |- *; simpl in |- *; auto with real.
Qed.

Lemma Fle_Fge : forall x y : float, Fle x y -> Fge y x.
unfold Fle, Fge in |- *; intros x y H'; auto with real.
Qed.

Lemma Fge_Zge :
 forall n1 n2 d : Z, (n1 >= n2)%Z -> Fge (Float n1 d) (Float n2 d).
intros n1 n2 d H'; apply Fle_Fge; auto.
apply Fle_Zle; auto.
apply Zge_le; auto.
Qed.

Lemma Flt_Fgt : forall x y : float, Flt x y -> Fgt y x.
unfold Flt, Fgt in |- *; intros x y H'; auto.
Qed.

Lemma Fgt_Zgt :
 forall n1 n2 d : Z, (n1 > n2)%Z -> Fgt (Float n1 d) (Float n2 d).
intros n1 n2 d H'; apply Flt_Fgt; auto.
apply Flt_Zlt; auto.
apply Zgt_lt; auto.
Qed.
(* Arithmetic properties on F : Fle is reflexive, transitive, antisymmetric *)

Lemma Fle_refl : forall x y : float, Feq x y -> Fle x y.
unfold Feq in |- *; unfold Fle in |- *; intros.
rewrite H; auto with real.
Qed.

Lemma Fle_trans : forall x y z : float, Fle x y -> Fle y z -> Fle x z.
unfold Fle in |- *; intros.
apply Rle_trans with (r2 := FtoR radix y); auto.
Qed.

Theorem Rlt_Fexp_eq_Zlt :
 forall x y : float, (x < y)%R -> Fexp x = Fexp y -> (Fnum x < Fnum y)%Z.
intros x y H' H'0.
apply lt_IZR.
apply (Rlt_monotony_contra_exp radix) with (z := Fexp x);
 auto with real arith.
pattern (Fexp x) at 2 in |- *; rewrite H'0; auto.
Qed.

Theorem Rle_Fexp_eq_Zle :
 forall x y : float, (x <= y)%R -> Fexp x = Fexp y -> (Fnum x <= Fnum y)%Z.
intros x y H' H'0.
apply le_IZR.
apply (Rle_monotony_contra_exp radix) with (z := Fexp x);
 auto with real arith.
pattern (Fexp x) at 2 in |- *; rewrite H'0; auto.
Qed.

Theorem LtR0Fnum : forall p : float, (0 < p)%R -> (0 < Fnum p)%Z.
intros p H'.
apply lt_IZR.
apply (Rlt_monotony_contra_exp radix) with (z := Fexp p);
 auto with real arith.
simpl in |- *; rewrite Rmult_0_l; auto.
Qed.

Theorem LeR0Fnum : forall p : float, (0 <= p)%R -> (0 <= Fnum p)%Z.
intros p H'.
apply le_IZR.
apply (Rle_monotony_contra_exp radix) with (z := Fexp p);
 auto with real arith.
simpl in |- *; rewrite Rmult_0_l; auto.
Qed.

Theorem LeFnumZERO : forall x : float, (0 <= Fnum x)%Z -> (0 <= x)%R.
intros x H'; unfold FtoRradix, FtoR in |- *.
replace 0%R with (0%Z * 0%Z)%R; auto 6 with real zarith.
Qed.

Theorem R0LtFnum : forall p : float, (p < 0)%R -> (Fnum p < 0)%Z.
intros p H'.
apply lt_IZR.
apply (Rlt_monotony_contra_exp radix) with (z := Fexp p);
 auto with real arith.
simpl in |- *; rewrite Rmult_0_l; auto.
Qed.

Theorem R0LeFnum : forall p : float, (p <= 0)%R -> (Fnum p <= 0)%Z.
intros p H'.
apply le_IZR.
apply (Rle_monotony_contra_exp radix) with (z := Fexp p);
 auto with real arith.
simpl in |- *; rewrite Rmult_0_l; auto.
Qed.

Theorem LeZEROFnum : forall x : float, (Fnum x <= 0)%Z -> (x <= 0)%R.
intros x H'; unfold FtoRradix, FtoR in |- *.
apply Ropp_le_cancel; rewrite Ropp_0; rewrite <- Ropp_mult_distr_l_reverse.
replace 0%R with (- 0%Z * 0)%R; auto 6 with real zarith.
Qed.
End comparisons.
Hint Resolve LeFnumZERO LeZEROFnum: float.


(* Chap 11 Rel *)
(* PROPERTIES OF RELATIONS *)
Set Warnings "-notation-overridden,-parsing".
From LF Require Export IndProp.

(* Chap 11.1 Relations *)
Definition relation (X: Type) := X -> X -> Prop.

Print le.
Check le: nat -> nat -> Prop.
Check le: relation nat.

(* Chap 11.2 Basic Properties *)
(* Chap 11.2.1 Partial Functions *)

Definition partial_function {X: Type} (R: relation X) :=
  forall x y1 y2: X, R x y1 -> R x y2 -> y1 = y2.

Check next_nat : relation nat.

Theorem next_nat_partial_function:
  partial_function next_nat.
Proof.
  unfold partial_function.
  intros.
  inversion H.
  inversion H0.
  reflexivity.
Qed.

Theorem le_not_a_partial_function:
  ~ (partial_function le).
Proof.
  unfold not.
  unfold partial_function.
  intros.
  assert (0 = 1) as Nonsense.
  { apply H with (x := 0).
    apply le_n.
    apply le_S, le_n. }
  discriminate Nonsense.
Qed.

(* Exercise total_relation_not_partial *)
Print total_relation.

Theorem total_relation_not_partial:
  ~ (partial_function total_relation).
Proof.
  unfold not. unfold partial_function.
  intros.
  assert (0 = 1) as Nonsense.
  { apply H with (x := 1).
    apply re_S_0, re_0_0.
    apply re_n_S, re_S_0, re_0_0.
  }
  discriminate.
Qed.

(* Exercise empty_relation_partial *)
Print empty_relation.

Theorem empty_relation_partial:
  partial_function empty_relation.
Proof.
  unfold partial_function.
  intros.
  inversion H.
Qed.

(* Chap 11.2.2 Reflexive Relations *)
Definition reflexive {X: Type} (R: relation X) :=
  forall a: X, R a a.

Theorem le_reflexive:
  reflexive le.
Proof.
  unfold reflexive.
  intros.
  apply le_n.
Qed.

(* Chap 11.2.3 Transitive Relations *)
Definition transitive {X: Type} (R: relation X) :=
  forall a b c: X, (R a b) -> (R b c) -> (R a c).

Theorem le_trans:
  transitive le.
Proof.
  unfold transitive.
  intros.
  induction H0.
  - apply H.
  - apply le_S, IHle.
Qed.

Theorem lt_trans:
  transitive lt.
Proof.
  unfold transitive.
  intros.
  unfold lt in *.
  apply le_S in H.
  apply (le_trans (S a) (S b) c).
  - apply H.
  - apply H0.
Qed.

(* Exercise le_trans_hard_way *)
Theorem lt_trans':
  transitive lt.
Proof.
  unfold lt. unfold transitive.
  intros n m o Hnm Hmo.
  induction Hmo as [| m' Hm'o].
  - apply le_S, Hnm.
  - apply le_S, IHHm'o.
Qed.

(* Exercise lt_trans'' *)
Theorem lt_trans'':
  transitive lt.
Proof.
  unfold lt. unfold transitive.
  intros n m o Hnm Hmo.
  induction o as [| o'].
  - inversion Hmo.
  - apply le_S.
    inversion Hmo.
    + rewrite <- H0, Hnm.
      apply le_n.
    + apply IHo', H0.
Qed.

Theorem le_Sn_le: forall n m, S n <= m -> n <= m.
Proof.
  intros.
  apply le_trans with (S n).
  - apply le_S, le_n.
  - apply H.
Qed.

(* Exercise le_S_n *)
Theorem le_S_n: forall n m,
  (S n <= S m) -> (n <= m).
Proof.
  intros.
  inversion H.
  - apply le_n.
  - apply le_Sn_le in H1. apply H1.
Qed.

(* Exercise le_Sn_n *)
Theorem le_Sn_n: forall n,
  ~ (S n <= n).
Proof.
  unfold not.
  intros.
  induction n.
  - inversion H.
  - apply IHn. apply le_S_n, H.
Qed.

(* Chap 11.2.4 Symmetric and Antisymmetric Relations *)
Definition symmetric {X: Type} (R: relation X) :=
  forall a b: X, (R a b) -> (R b a).

(* Exercise le_not_symmetric *)
Theorem le_not_symmetric:
  ~ (symmetric le).
Proof.
  unfold symmetric.
  unfold not.
  intros.
  assert (1 <= 0) as Nonsense.
  { apply (H 0 1). apply le_S, le_n. }
  inversion Nonsense.
Qed.

Definition antisymmetric {X: Type} (R: relation X) :=
  forall a b: X, (R a b) -> (R b a) -> a = b.

(* Exercise le_antisymmetric *)
Theorem le_antisymmetric:
  antisymmetric le.
Proof.
  unfold antisymmetric.
  intros a.
  induction a.
  - intros. inversion H.
    + reflexivity.
    + inversion H0. rewrite H3 in H2. discriminate.
  - intros. inversion H.
    + reflexivity.
    + rewrite <- H2 in H0. inversion H0.
      * reflexivity.
      * apply f_equal. apply IHa.
        rewrite <- H2 in H.
        apply le_S_n, H.
        apply le_S_n, H0.
Qed.

(* Exercise le_step *)
Theorem le_step: forall n m p,
  n < m -> m <= S p -> n <= p.
Proof.
  unfold lt.
  intros.
  apply le_S_n.
  apply (le_trans (S n) m (S p)).
  apply H.
  apply H0.
Qed.

(* Chap 11.2.5 Equivalence Relations *)
Definition equivalence {X: Type} (R: relation X) :=
  (reflexive R) /\ (symmetric R) /\ (transitive R).

(* Chap 11.2.6 Partial Orders and Preorders *)
Definition order {X: Type} (R: relation X) :=
  (reflexive R) /\ (antisymmetric R) /\ (transitive R).

Definition preorder {X: Type} (R: relation X) :=
  (reflexive R) /\ (transitive R).

Theorem le_order:
  order le.
Proof.
  unfold order.
  split.
  - apply le_reflexive.
  - split.
    + apply le_antisymmetric.
    + apply le_trans.
Qed.

(* Chap 11.3 Reflexive, Transitive Closure *)
Inductive clos_refl_trans {A: Type} (R: relation A) : relation A :=
  | rt_step x y (H: R x y): clos_refl_trans R x y
  | rt_refl x: clos_refl_trans R x x
  | rt_trans x y z (Hxy: clos_refl_trans R x y) (Hyz: clos_refl_trans R y z):
      clos_refl_trans R x z.

Theorem next_nat_closure_is_le: forall n m,
  (n <= m) <-> ((clos_refl_trans next_nat) n m).
Proof.
  intros. split.
  - intros.
    induction H.
    + apply rt_refl.
    + apply rt_trans with m.
      apply IHle.
      apply rt_step.
      apply nn.
  - intros.
    induction H.
    + inversion H. apply le_S, le_n.
    + apply le_n.
    + apply (le_trans x y z).
      apply IHclos_refl_trans1.
      apply IHclos_refl_trans2.
Qed.

Inductive clos_refl_trans_1n {A: Type} (R: relation A) (x: A): A -> Prop :=
  | rt1n_refl: clos_refl_trans_1n R x x
  | rt1n_trans (y z: A) (Hxy: R x y) (Hrest: clos_refl_trans_1n R y z):
      clos_refl_trans_1n R x z.

Lemma rsc_R: forall (X: Type) (R: relation X) (x y: X),
  R x y -> clos_refl_trans_1n R x y.
Proof.
  intros.
  apply (rt1n_trans R x y y).
  apply H.
  apply rt1n_refl.
Qed.

(* Exercise rsc_trans *)
Lemma rsc_trans:
  forall (X: Type) (R: relation X) (x y z: X),
    clos_refl_trans_1n R x y -> clos_refl_trans_1n R y z ->
    clos_refl_trans_1n R x z.
Proof.
  intros.
  induction H.
  - apply H0.
  - apply (rt1n_trans R x y z).
    apply Hxy.
    apply IHclos_refl_trans_1n, H0.
Qed.

(* Exercise rtc_rsc_coincide *)
Theorem rtc_rsc_coincide:
  forall (X: Type) (R: relation X) (x y: X),
    clos_refl_trans R x y <-> clos_refl_trans_1n R x y.
Proof.
  intros. split.
  - intros.
    induction H.
    + apply rsc_R, H.
    + apply rt1n_refl.
    + apply (rsc_trans X R x y z).
      apply IHclos_refl_trans1. apply IHclos_refl_trans2.
  - intros.
    induction H.
    + apply rt_refl.
    + apply (rt_trans R x y z).
      apply rt_step.
      apply Hxy.
      apply IHclos_refl_trans_1n.
Qed.


From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint drop (drop_arg0 : natural) (drop_arg1 : lst) : lst
           := match drop_arg0, drop_arg1 with
              | x, Nil => Nil
              | Zero, x => x
              | Succ x, Cons y z => drop x z
              end.

Theorem drop_Nil: forall (x: natural), drop x Nil = Nil.
Proof.
  induction x ; simpl; reflexivity.
Qed.

Theorem drop_Cons: forall (x n: natural) (l: lst), drop (Succ x) (Cons n l) = drop x l.
Proof.  induction l; induction x; simpl; reflexivity.
Qed.

Theorem drop_Cons_assoc: forall (x1 x2 x3: natural) (l: lst),
    drop x1 (drop x2 (Cons x3 l)) = drop x2 (drop x1 (Cons x3 l)).
Proof.
  induction x1; induction x2; try (simpl; reflexivity).
  + induction l.
    *
      rewrite 2 drop_Cons. rewrite <- IHx1.
      rewrite IHx2. rewrite 2 drop_Cons.
      induction l.
      - rewrite IHx1. reflexivity.
      -
        rewrite 3 drop_Nil. reflexivity.
    * simpl. rewrite 2 drop_Nil. reflexivity.
  + intros. simpl. destruct (drop x1 l); reflexivity.
  + intros. simpl. destruct (drop x2 l); reflexivity.
Qed.

Theorem theorem0 : forall (x : natural) (y : natural) (z : lst), eq (drop x (drop y z)) (drop y (drop x z)).
Proof.
  induction z.
  +
    rewrite 2 drop_Cons_assoc. reflexivity.
  +
    rewrite 3 drop_Nil. reflexivity.
Qed.


Require Import Arith.
Require Import List.

Fixpoint split A (l:list A) :list A*list A:=
  match l with
  |nil=>(nil,nil)
  |a::nil=>(a::nil,nil)
  |a::b::l'=>let (l1,l2):=split A l' in (a::l1,b::l2)
  end.

Fixpoint partition A (less:A->A->bool) (mid:A) (l:list A):list A*list A:=
  match l with
  |nil=>(nil,nil)
  |a::l'=>let (l1,l2):=partition A less mid l' in
          if less a mid then (a::l1,l2)
          else (l1,a::l2)
  end.

Fixpoint pluslist A (l1:list A) (l2:list A):=
  match l1 with
  |nil=>l2
  |a::l'=>a::(pluslist A l' l2)
  end.

Definition quicksortloop A (less:A->A->bool):=
  fix loop (l:list A) (n:nat):=
    match n with
    |O=>nil
    |S n=>match l with
          |nil=>l
          |x::l'=>let (l1,l2):=partition A less x l' in
                  pluslist A (loop l1 n) (x::(loop l2 n))
          end
    end.

Definition quicksort A less (l:list A):=
  quicksortloop A less l (length l).

Eval vm_compute in quicksort nat leb (2::1::3::10::100::59::1::0::nil).


Require Import Tree List Omega.

Inductive BaseTree := B: list BaseTree -> BaseTree.

Section ListProp.
  Context {A: Type}.
  Context (def: A).
  Theorem appLastNth: forall {l i} a, i = length l -> nth i (l ++ (a :: nil)) def = a.
  Proof.
    intros l.
    induction l.
    intros i a i_len.
    simpl in *.
    rewrite i_len.
    auto.
    intros i a0 i_len.
    unfold length in i_len.
    fold (length l) in i_len.
    rewrite i_len.
    unfold app.
    fold (app l (a0 :: nil)).
    simpl.
    specialize (IHl (length l) a0).
    assert (length l = length l) by auto.
    specialize (IHl H).
    assumption.
  Qed.

  Theorem appNotLastNth: forall {l i} a, i < length l -> nth i (l ++ (a :: nil)) def = nth i l def.
  Proof.
    intros l.
    induction l.
    intros i a i_len.
    simpl in *.
    omega.
    intros i a0 i_len.
    unfold app.
    fold (app l (a0::nil)).
    destruct i.
    simpl.
    auto.
    simpl.
    simpl in i_len.
    assert (i < length l) by omega.
    specialize (IHl i a0 H).
    assumption.
  Qed.

  Theorem appLen: forall (l: list A) a, length (l ++ a :: nil) = S (length l).
  Proof.
    intros l a.
    induction l.
    simpl.
    auto.
    unfold app.
    fold (app l (a :: nil)).
    simpl.
    omega.
  Qed.

  Theorem revLen: forall (l: list A), length l = length (rev l).
  Proof.
    intros l.
    induction l.
    simpl.
    auto.
    simpl.
    pose proof (appLen (rev l) a).
    rewrite H; clear H.
    omega.
  Qed.

  Theorem revProp: forall {l i}, i < length l -> nth i l def = nth (length l - S i) (rev l) def.
  Proof.
    intros l.
    induction l.
    intros i i_lt_len.
    simpl in *.
    omega.
    intros i i_lt_len.
    unfold rev.
    fold (rev l).
    unfold length.
    fold (length l).
    assert (S (length l) - S i = (length l) - i) by omega.
    rewrite H.
    clear H.
    destruct i.
    simpl.
    assert (length l - 0 = length l) by omega.
    rewrite H; clear H.
    pose proof (revLen l) as H.
    rewrite H; clear H.
    assert (length (rev l) = length (rev l)) by reflexivity.
    pose proof (appLastNth a H).
    rewrite H0.
    auto.
    simpl in i_lt_len.
    pose proof (revLen l) as H.
    assert (length l - S i < length (rev l)) by omega.
    pose proof (appNotLastNth a H0).
    rewrite H1.
    simpl.
    assert (i < length l) by omega.
    specialize (IHl i H2).
    assumption.
  Qed.

  Section EqLen.
    Context (l: list A).
    Context {B: Type}.
    Context (f: A -> list A -> B).
    Fixpoint trans ls :=
      match ls with
        | nil => nil
        | x :: xs => f x xs :: trans xs
      end.
    Theorem eqLen: length (trans l) = length l.
    Proof.
      induction l.
      simpl.
      reflexivity.
      simpl.
      f_equal.
      assumption.
    Qed.
  End EqLen.
End ListProp.

Section Strange.
  Context (nm: list nat).

  Fixpoint mkNameList ls :=
    match ls with
      | nil => nil
      | x :: xs => (C (length xs :: nm) x) :: mkNameList xs
    end.

  Theorem mkNameListLength ls: length (mkNameList ls) = length ls.
  Proof.
    induction ls.
    simpl.
    auto.
    simpl.
    f_equal.
    auto.
  Qed.

  Theorem posValue: forall {ls i}, i < length ls -> match nth i (mkNameList ls) (C nil nil) with
                                                      | C x _ => x = (length ls - S i) :: nm
                                                    end.
  Proof.
    intros ls.
    induction ls.
    intros i i_lt_l.
    simpl in i_lt_l.
    omega.
    intros i i_lt_l.
    simpl in i_lt_l.
    unfold mkNameList.
    fold mkNameList.
    destruct i.
    simpl.
    assert (H: length ls - 0 = length ls) by omega.
    rewrite H; clear H.
    auto.
    simpl.
    assert (H: i < length ls) by omega.
    apply (IHls i H).
  Qed.

  Theorem posValueRev': forall {ls i}, i < length ls ->
                                       match nth (length ls - S i) (rev (mkNameList ls)) (C nil nil) with
                                         | C x _ => x = (length ls - S i) :: nm
                                       end.
  Proof.
    intros ls i i_lt_n.
    pose proof (posValue i_lt_n) as gdOne.
    pose proof (mkNameListLength ls) as t1.
    rewrite <- t1 in i_lt_n.
    pose proof (revProp (C nil nil) i_lt_n) as bdOne.
    rewrite t1 in bdOne.
    rewrite bdOne in gdOne.
    auto.
  Qed.

  Theorem posValueRev: forall {ls i}, i < length ls ->
                                      match nth i (rev (mkNameList ls)) (C nil nil) with
                                        | C x _ => x = i :: nm
                                      end.
  Proof.
    intros ls i i_lt_n.
    assert (sth: length ls - S i < length ls) by omega.
    pose proof (posValueRev' sth) as sth2.
    assert (H: length ls - S (length ls - S i) = i) by omega.
    rewrite H in sth2.
    assumption.
  Qed.
End Strange.

Fixpoint getCs nm b :=
  match b with
    | B bs => rev (mkNameList nm
                              ((fix addC bs :=
                                  match bs with
                                    | nil => nil
                                    | b' :: bs' => getCs (length bs' :: nm) b' :: addC bs'
                                  end) bs))
  end.

Definition getC nm b := C nm (getCs nm b).

Theorem parentTreeName {c p np bp}: parent c p ->
                                    p = getC np bp ->
                              exists nc bc, c = getC nc bc.
Proof.
  intros c_p pEq.
  unfold parent in *; unfold getC in *.
  destruct p.
  injection pEq as lEqNp l0Eq.
  rewrite lEqNp in *; rewrite l0Eq in *; clear lEqNp l0Eq.
  clear pEq.
  destruct bp.
  simpl in c_p.
  pose proof @In_rev as sth.
  assert (In_rev: forall A l (x: A), In x (rev l) -> In x l) by
         (generalize sth; clear;
          intros sth A l x inl; specialize (sth A l x);
          destruct sth;
          intuition); clear sth.
  pose proof (In_rev _ _ _ c_p) as inp; clear In_rev c_p l0 l.
  induction l1.
  simpl in *.
  intuition.
  simpl in inp.
  pose proof (eqLen l1 (fun x y => getCs (length y :: np) x)) as sth.
  unfold trans in sth.
  rewrite sth in inp.
  destruct inp.
  exists (length l1 :: np); exists a; auto.
  specialize (IHl1 H).
  assumption.
Qed.

Theorem treeNameHelp nm b:
  match getC nm b with
    | C x ls => treeNthName x ls
  end.
Proof.
  unfold treeNthName.
  unfold getC.
  destruct b.
  simpl.
  intros n n_lt_len.
  apply posValueRev.
  remember  ((fix addC (bs : list BaseTree) : list (list Tree) :=
         match bs with
         | nil => nil
         | b' :: bs' => getCs (length bs' :: nm) b' :: addC bs'
         end) l) as sth.
  clear Heqsth.
  pose proof (mkNameListLength nm sth) as H.
  pose proof (revLen (mkNameList nm sth)) as H0.
  rewrite H in H0.
  rewrite <- H0 in n_lt_len.
  assumption.
Qed.

Theorem descImpGetc {p c}: descendent c p ->
                           (exists np bp, p = getC np bp) ->
                           exists nc bc, c = getC nc bc.
Proof.
  intros desc.
  induction desc.
  intros [np [bp pEq]].
  apply (parentTreeName H pEq).
  intros [np [bp pEq]].
  exists np; exists bp; intuition.
  intros use.
  specialize (IHdesc2 use).
  specialize (IHdesc1 IHdesc2).
  assumption.
Qed.

Parameter bHier : BaseTree.

Theorem treeName2: forall {p}, descendent p (getC nil bHier) ->
                               match p with
                                 | C x ls => treeNthName x ls
                               end.
Proof.
  intros p desc.
  remember (getC nil bHier) as y.
  assert (sth: exists np bp, y = getC np bp) by (exists nil; exists bHier; intuition).
  pose proof (descImpGetc desc sth) as [nc [bc cEq]].
  rewrite cEq.
  apply (treeNameHelp nc bc).
Qed.

Theorem treeName1: match getC nil bHier with
                     | C x ls => x = nil
                   end.
Proof.
  reflexivity.
Qed.


Print nat.

Lemma plus_O_right: forall (n:nat), plus 0 n = n.
Proof.
intro.
reflexivity.
Qed.

Lemma plus_O_left: forall (n:nat), plus n O = n.
Proof.
induction n.
- reflexivity.
- simpl.
  rewrite IHn.
  reflexivity.
Qed.

Print plus_O_left.
(*
apply (nat_ind (fun n => plus n O = n));
[reflexivity |
intros n IHn; simpl; rewrite IHn; reflexivity].
Qed.
*)

Check nat_rec.

Definition msucc := nat_rec (fun n:nat => nat) (S 0) (fun (n:nat)(x:nat) => S x).

Eval compute in msucc 0.
Eval compute in msucc (S(S 0)).

Definition mpred := nat_rec (fun n:nat => nat) 0 (fun (n:nat)(x:nat) => n).

Eval compute in mpred 0.
Eval compute in mpred (S(S 0)).


Require Export TopologicalSpaces.

Definition clopen {X:TopologicalSpace} (S:Ensemble (point_set X))
  : Prop :=
  open S /\ closed S.

Definition connected (X:TopologicalSpace) : Prop :=
  forall S:Ensemble (point_set X), clopen S ->
        S = Empty_set \/ S = Full_set.

Require Export Continuity.

Lemma connected_img: forall {X Y:TopologicalSpace}
  (f:point_set X -> point_set Y),
  connected X -> continuous f -> surjective f -> connected Y.
Proof.
intros.
red; intros.
destruct (H (inverse_image f S)).
split.
apply H0.
apply H2.
red.
rewrite <- inverse_image_complement.
apply H0.
apply H2.

left.
apply Extensionality_Ensembles; split; red; intros.
destruct (H1 x).
assert (In Empty_set x0).
rewrite <- H3.
constructor.
rewrite H5.
trivial.
destruct H6.
destruct H4.

right.
apply Extensionality_Ensembles; split; red; intros.
constructor.
destruct (H1 x).
rewrite <- H5.
assert (In (inverse_image f S) x0).
rewrite H3; constructor.
destruct H6; trivial.
Qed.

Require Export SubspaceTopology.

Lemma connected_union: forall {X:TopologicalSpace}
  {A:Type} (S:IndexedFamily A (point_set X)),
  (forall a:A, connected (SubspaceTopology (S a))) ->
  Inhabited (IndexedIntersection S) ->
  IndexedUnion S = Full_set -> connected X.
Proof.
intros.
pose (inc := fun (a:A) => subspace_inc (S a)).
destruct H0.
destruct H0.
red; intros.
assert (forall a:A, clopen (inverse_image (inc a) S0)).
intro.
split.
apply subspace_inc_continuous.
apply H2.
red.
rewrite <- inverse_image_complement.
apply subspace_inc_continuous.
apply H2.
destruct (classic (In S0 x)).
right.
assert (forall a:A, inverse_image (inc a) S0 = Full_set).
intro.
destruct (H a _ (H3 a)).
assert (In (@Empty_set (point_set (SubspaceTopology (S a))))
  (exist _ x (H0 a))).
rewrite <- H5.
constructor.
simpl.
trivial.
destruct H6.
trivial.
apply Extensionality_Ensembles; split; red; intros.
constructor.
assert (In (IndexedUnion S) x0).
rewrite H1; constructor.
destruct H7.
assert (In (@Full_set (point_set (SubspaceTopology (S a))))
  (exist _ x0 H7)).
constructor.
rewrite <- H5 in H8.
destruct H8.
simpl in H8.
trivial.

left.
assert (forall a:A, inverse_image (inc a) S0 = Empty_set).
intros.
destruct (H a _ (H3 a)).
trivial.
assert (In (@Full_set (point_set (SubspaceTopology (S a))))
  (exist _ x (H0 a))).
constructor.
rewrite <- H5 in H6.
destruct H6.
simpl in H6.
contradiction H4.

apply Extensionality_Ensembles; split; red; intros.
assert (In (IndexedUnion S) x0).
rewrite H1; constructor.
destruct H7.
assert (In (@Empty_set (point_set (SubspaceTopology (S a))))
  (exist _ x0 H7)).
rewrite <- H5.
constructor.
simpl.
trivial.
destruct H8.
destruct H6.
Qed.


Goal forall P Q : nat -> Prop, P 0 -> (forall x, P x -> Q x) -> Q 0.
Proof.
intros.
apply (H0 0).
apply H.
Qed.

Goal forall P : nat -> Prop, P 2 -> (exists y, P (1 + y)).
Proof.
intros.
exists 1.
apply H.
Qed.

Goal forall P : nat -> Prop, (forall n m, P n -> P m) -> (exists p, P p) -> forall q, P q.
Proof.
intros.
destruct H0.
apply (H x q).
apply H0.
Qed.


Require Export IndPrinciples.

(* ================================================================ *)

(** * Casamento de Padrão Dependente *)

(** Nós estudaremos a partir de agora a versão estendida do casamento
    de padrão ("match"), que às vezes é necessário usar para que o Coq
    reconheça que certos termos estão bem-tipados.

    A compreensão desse recurso nos permite terminar de entender como
    a igualdade funciona no Coq, e com ela a tática [rewrite], etc. O
    mesmo se aplica às táticas de prova por absurdo no Coq. *)

(** Primeiramente, portanto, recapitule que, até agora, quando
    escrevíamos um "match", o tipo dele não dependia do termo
    específico que estivesse sendo analisado. No caso da função
    [evenb], por exemplo, o tipo do valor retornado é sempre [bool],
    independentemente do valor ao qual ela é aplicado: *)

Compute
  (
  fix evenb (n:nat) : bool :=
  match n with
  | O        => true
  | S O      => false
  | S (S n') => evenb n'
  end
  )
  8.

(** Considere agora o caso deste teorema:

      forall n : nat, n + 0 = n

    Nós sabemos que podemos prová-lo por meio de uma função
    recursiva: *)

Fixpoint plus_0_r_po (n : nat) : n + 0 = n
  :=
  match n with
  | O => @eq_refl nat 0
  | S n' => f_equal nat nat S (n' + 0) n' (plus_0_r_po n')
  end.

(** Qual é, porém, o tipo do termo "match ... end"?

    É "n + 0 = n", onde "n" é o próprio termo sendo analisado no
    [match]. *)

(** Como um segundo exemplo, considere a seguinte prova para o
    princípio de indução para [ev]: *)

Fixpoint ev_ind_po
  (P : nat -> Prop)
  (p0: P 0)
  (ps: forall n, ev n -> P n -> P (S (S n)) )
  (n : nat)
  (pevn : ev n)
  :
  P n
    :=
    match pevn with
    | ev_0 => p0
    | ev_SS n' evn' (* n = S (S n') /\ ev n' *) =>
        ps n' evn' (ev_ind_po P p0 ps n' evn')
    end.

(** Novamente: qual é o tipo do termo "match ... end"?

    É "P n", onde "n", no que diz respeito ao "match", é o número "x"
    tal que "pevn" tem tipo "ev x". Nesse caso, portanto, o tipo do
    "match" depende do _tipo_ do termo sendo analisado. *)

(** Para casos como esses 2 acima, em que o tipo do "match" depende do
    valor e/ou tipo do termo sendo analisado, o Coq possui o
    _casamento de padrão dependente_, cuja regra de funcionamento está
    muito bem explicada no livro "CPDT", capítulo "More Dependent
    Types" ( http://adam.chlipala.net/cpdt/html/Cpdt.MoreDep.html ):

----------------------------------------------------------------------
A dependent pattern match is a match expression where the type of the
overall match is a function of the value and/or the type of the
discriminee, the value being matched on. In other words, the match
type depends on the discriminee.

[...]

We come now to the one rule of dependent pattern matching in Coq. A
general dependent pattern match assumes this form (with unnecessary
parentheses included to make the syntax easier to parse):

  match E as y in (T x1 ... xn) return U with
    | C z1 ... zm => B
    | ...
  end

The discriminee is a term E, a value in some inductive type family T,
which takes n arguments. An as clause binds the name y to refer to the
discriminee E. An in clause binds an explicit name xi for the ith
argument passed to T in the type of E.

We bind these new variables y and xi so that they may be referred to
in U, a type given in the return clause. The overall type of the match
will be U, with E substituted for y, and with each xi substituted by
the actual argument appearing in that position within E's type.

[...]

The last piece of the typing rule tells how to type-check a match
case. A generic constructor application C z1 ... zm has some type T
x1' ... xn', an application of the type family used in E's type,
probably with occurrences of the zi variables. From here, a simple
recipe determines what type we will require for the case body B. The
type of B should be U with the following two substitutions applied: we
replace y (the as clause variable) with C z1 ... zm, and we replace
each xi (the in clause variables) with xi'. In other words, we
specialize the result type based on what we learn based on which
pattern has matched the discriminee.
----------------------------------------------------------------------

*)

(** Como exemplos concretos da explicação acima, aqui estão objetos de
    prova que usam casamento de padrão dependente para os 2 teoremas
    anteriores, mas ATENÇÃO:

      Não apenas olhe para o que está escrito! Calcule por conta
      própria, de acordo com a regra acima, o tipo esperado para o
      termo retornado por cada caso de cada "match", e verifique se
      o termo retornado realmente tem o tipo esperado. *)

Definition plus_0_r_dpm : forall n : nat, n + 0 = n
  :=
  fix f (n : nat) : n + 0 = n
    :=
    match n as v return v + 0 = v with
    | O => @eq_refl nat 0
    | S n' => f_equal nat nat S (n' + 0) n' (plus_0_r_po n')
    end.

(** Observação: em casos como o do termo acima, em que o objeto
    analisado pelo match consiste apenas numa variável, a cláusula
    "as" é pode ser omitida, e a variável em questão pode ser
    diretamente mencionada na cláusula "return". Assim, o termo acima
    poderia ter a seguinte linha, mais simples:

      match n return n + 0 = n with
*)

Definition ev_ind_dpm:
  forall P : nat -> Prop,
  P 0 ->
  (forall n, ev n -> P n -> P (S (S n)) ) ->
  forall n, ev n -> P n
    :=
    fun P p0 ps
      =>
      fix f n pevn : P n
        :=
        match pevn in ev a return P a with
        | ev_0 => p0
        | ev_SS n' evn' (* n = S (S n') *) =>
            ps n' evn' (f n' evn')
        end.

(** Encaixando o "match" acima na forma geral da explicação anterior

      match E as y in (T x1 ... xn) return U with
      | C z1 ... zm  (* : T x1' ... xn' *)  => B
      | ...
      end

    temos:

      - E: pevn.
      - T: ev, x1: a, n: 1.
      - U: P a.
      - (1º Caso) C: ev_0, m: 0, x1': 0.
      - (2º Caso) C: ev_SS, z1: n', z2: evn', m: 2, x1': S (S n').

    Observe que o termo retornado em cada caso tem tipo [P x1']

      - p0 : P 0
      - ps n' evn' (f n' evn') : P (S (S n'))

    o que garante a boa-tipagem do "match". *)

(** O trecho acima do CPDT tem a seguinte continuação, também
    importante:

----------------------------------------------------------------------
A few details have been omitted above. In Chapter 3, we learned that
inductive type families may have both _parameters_ and regular
arguments. Within an [in] clause, a parameter position must have the
wildcard [_] written, instead of a variable. (In general, Coq uses
wildcard [_]'s either to indicate pattern variables that will not be
mentioned again or to indicate positions where we would like type
inference to infer the appropriate terms.) Furthermore, recent Coq
versions are adding more and more heuristics to infer dependent
[match] annotations in certain conditions. The general annotation
inference problem is undecidable, so there will always be serious
limitations on how much work these heuristics can do. When in doubt
about why a particular dependent [match] is failing to type-check, add
an explicit [return] annotation! At that point, the mechanical rule
sketched in this section will provide a complete account of "what the
type checker is thinking." Be sure to avoid the common pitfall of
writing a [return] annotation that does not mention any variables
bound by [in] or [as]; such a [match] will never refine typing
requirements based on which pattern has matched. (One simple exception
to this rule is that, when the discriminee is a variable, that same
variable may be treated as if it were repeated as an [as] clause.)
----------------------------------------------------------------------

*)

(** EXERCÍCIO: enuncie e prove um princípio de indução para [le'],
               que é a relação <= como definida em IndProp: *)

Inductive le' : nat -> nat -> Prop :=
  | le'_n : forall n, le' n n
  | le'_S : forall n m, (le' n m) -> (le' n (S m)).

Definition le'_ind_po : forall P : nat -> nat -> Prop,
  (forall n : nat, P n n) ->
  (forall n m : nat, le' n m -> P n m -> P n (S m)) ->
  forall n m : nat, le' n m -> P n m :=
  fun P pn ps =>
    fix f n m ple' : P n m :=
    match ple' in le' a b return P a b with
    | le'_n n' => pn n'
    | le'_S n' m' plenm => ps n' m' plenm (f n' m' plenm)
    end.

(** EXERCÍCIO: enuncie e prove o princípio de indução para [le],
               cuja definição é:

      Inductive le (n : nat) : nat -> Prop :=
      | le_n : n <= n
      | le_S : forall m : nat, n <= m -> n <= S m
      end.
*)

Definition le_ind_po : forall (n : nat) (P : nat -> Prop),
  P n -> (forall m : nat, n <= m -> P m -> P (S m)) ->
  forall m : nat, n <= m -> P m :=
  fun n P pn ps =>
    fix f m ple : P m :=
    match ple in le _ b return P b with
    | le_n => pn
    | le_S m' plenm => ps m' plenm (f m' plenm)
    end.

(* ================================================================ *)

(** * Objetos de Prova para Igualdade *)

(** Recapitule a definição de igualdade no Coq: *)

Print eq.  (* Inductive eq (A : Type) (x : A) : A -> Prop :=
              | eq_refl : x = x
              end. *)

(** Uma vez compreendido o casamento de padrão dependente, a definição
    acima de igualdade se torna bastante simples: ela meramente diz
    que nós podemos sempre substituir o termo à direita do '=' pelo
    termo à esquerda!

    De fato, suponha que nós queremos provar P(y), e que temos

      hxy : x = y
      px : P x

    Nesse caso, basta fazer

      match hxy in _ = a return P a with
      | eq_refl => px
      end

    Usando esse conhecimento e a tática [refine], nós podemos
    facilmente provar os teoremas que nós provávamos usando [rewrite]:
*)

Definition eq_sym: forall (T : Type) (x y : T), x = y -> y = x
  :=
  fun T x y hxy
    =>
    match hxy in _ = y' return y' = x with
    | eq_refl => @eq_refl T x
    end.

(** EXERCÍCIO: Prove usando um objeto de prova: *)

Definition eq_trans_po:
  forall (T: Type) (x y z : T), x = y -> y = z -> x = z
    :=
    fun T x y z Hxy Hyz =>
    match Hyz in _ = z' return x = z' with
    | eq_refl => Hxy
    end.

(** EXERCÍCIO: Enuncie e prove o princípio de indução para [eq].

    ATENÇÃO: Nós vimos no capítulo IndPrinciples como são obtidos os
             enunciados dos princípios de indução para tipos
    quaisquer. Assim sendo, é instrutivo tentar escrever a sua propria
    versão do enunciado antes de executar [Check eq_ind]. *)

Check eq_ind.

Definition eq_ind_po : forall (A : Type) (x : A) (P : A -> Prop), P x -> forall y : A, x=y -> P y :=
 fun T x P Hx y Hxy => match Hxy in _ = y' return P y' with
                       | eq_refl => Hx
                       end.

(** * Objetos de Prova para Contradição *)

(** Uma vez compreendido o conteúdo acima, construir objetos de prova
    para provas por contradição requer apenas mais uma observação: a
    de que uma contradição como

      eq10: 0 = 1

    implica que nós podemos deduzir P(1) a partir de P(0), para
    qualquer [P]! Além disso, já que nós podemos escolher [P] à
    vontade, então P(1) pode ser [False] -- justamente o que
    precisamos para obter qualquer conclusão a partir de [False_ind]
    --, enquanto P(0) pode ser qualquer coisa trivial de demonstrar,
    como [True]!

    Essa estratégia é ilustrada a seguir. *)

Definition P_abs (n : nat) : Prop :=
  match n with
  | O => True
  | _ => False
  end.

Definition contradiction_explodes: 0 = 1 -> forall Q : Prop, Q
  :=
  fun eq01 Q
    =>
    False_ind Q
      match eq01 in _ = a return P_abs a with
      | eq_refl => I
      end.

(** Observe que o uso de False_ind não é obrigatório: *)

Definition abs_explodes: 0 = 1 -> forall Q : Prop, Q
  :=
  fun eq01 Q
    =>
    let P := fun n : nat => match n with
                            | O => True
                            | _ => Q
                            end
    in
      match eq01 in _ = a return P a with
      | eq_refl => I
      end.

(** E nós também podemos prová-lo: *)

Definition my_False_ind: forall P : Prop, False -> P
  :=
  fun P abs => match abs with
               end.

(* ================================================================ *)


Require Import Arith.
Require Export List.
Import ListNotations.

Inductive mark: Set:=
  | B: mark
  | X: mark
  | O: mark.

Definition other_mark(mk: mark): mark:=
  match mk with
      | X => O
      | O => X
      | B => B
  end.

Definition mark_eq(m1 m2: mark): bool:=
  match m1, m2 with
      | B, B => true
      | X, X => true
      | O, O => true
      | _, _ => false
  end.

Record board:= mk_board {
                   m00: mark;  m01: mark; m02: mark;
                   m10: mark; m11: mark; m12: mark;
                   m20: mark; m21: mark; m22: mark
}.

Record macro_board := mk_macro_board {
                   b00: board;  b01: board; b02: board;
                   b10: board; b11: board; b12: board;
                   b20: board; b21: board; b22: board
}.

Inductive cell: Set :=
  | C00
  | C01
  | C02
  | C10
  | C11
  | C12
  | C20
  | C21
  | C22.

Definition cell_equal (c1 c2: cell) :=
  match c1, c2 with
    | C00, C00
    | C01, C01
    | C02, C02
    | C10, C10
    | C11, C11
    | C12, C12
    | C20, C20
    | C21, C21
    | C22, C22 => true
    | _, _ => false
  end.

Definition empty_board: board:=
  (mk_board
     B B B
     B B B
     B B B
  ).

Fixpoint lift_list_to_board (l : list mark) :=
  match l with
    | [x1; x2; x3; x4; x5; x6; x7; x8; x9] => mk_board x1 x2 x3 x4 x5 x6 x7 x8 x9
    | _ => empty_board
  end.

Definition empty_macro_board: macro_board:=
  (mk_macro_board
     empty_board empty_board empty_board
     empty_board empty_board empty_board
     empty_board empty_board empty_board
  ).

Inductive move: Set :=
  | mk_move: cell -> cell -> mark -> move
  | first_move.

Inductive outcome: Set :=
  | Xwins
  | Owins
  | incomplete
  | tie
  | malformed.

Inductive game: Set :=
  | mk_game: list move -> nat -> macro_board -> outcome -> game.

Inductive polyboard: Set:=
  | macro: macro_board -> polyboard
  | micro: board -> polyboard.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf3 : natural) (z : natural) : natural :=
  plus lf3 (plus Zero z).