Section five_houses.

(* Definitions and axioms *)
Definition left_inv {A B:Type} (f1:A->B) (f2:B->A) : Prop :=
  forall (a:A), f2 (f1 a) = a.

Definition right_inv {A B:Type} (f1:A->B) (f2:B->A) : Prop :=
  forall (b:B), f1 (f2 b) = b.

Definition bijective {A B:Type} (f1:A->B) (f2:B->A) : Prop :=
  left_inv f1 f2 /\ right_inv f1 f2.

Inductive owner : Type :=
| a : owner
| b : owner
| c : owner
| d : owner
| e : owner.

Inductive nationality : Type :=
| dane : nationality
| brit : nationality
| swede : nationality
| norwegian : nationality
| german : nationality.

Parameter to_citizen : owner -> nationality.
Parameter from_citizen : nationality -> owner.

Axiom citizen_biject : bijective to_citizen from_citizen.

Inductive color : Type :=
| yellow : color
| red : color
| white : color
| green : color
| blue : color.

Parameter to_house : owner -> color.
Parameter from_house : color -> owner.

Axiom house_biject : bijective to_house from_house.

Inductive animal : Type :=
| horse : animal
| cat : animal
| bird : animal
| fish : animal
| dog : animal.

Parameter to_pet : owner -> animal.
Parameter from_pet : animal -> owner.

Axiom pet_biject : bijective to_pet from_pet.

Inductive beverage : Type :=
| water : beverage
| tea : beverage
| milk : beverage
| coffee : beverage
| root_beer : beverage.

Parameter to_drink : owner -> beverage.
Parameter from_drink : beverage -> owner.

Axiom drink_biject : bijective to_drink from_drink.

Inductive cigar : Type :=
| pall_mall : cigar
| prince : cigar
| blue_master : cigar
| dunhill : cigar
| blends : cigar.

Parameter to_smoke : owner -> cigar.
Parameter from_smoke : cigar -> owner.

Axiom smoke_biject : bijective to_smoke from_smoke.

Definition left_of (X1 X2 : owner) : Prop :=
  match X1, X2 with
    | a, b => True
    | b, c => True
    | c, d => True
    | d, e => True
    | _, _ => False
  end.

Definition next_to (X1 X2 : owner) : Prop :=
  left_of X1 X2 \/ left_of X2 X1.

Axiom clue1: (* The Brit lives in the house with red walls. *)
  from_citizen brit = from_house red.

Axiom clue2: (* The Swede has a dog. *)
  from_citizen swede = from_pet dog.

Axiom clue3: (* The Dane drinks tea. *)
  from_citizen dane = from_drink tea.

Axiom clue4: (* The house with green walls is directly to the left of the house with white walls. *)
  left_of (from_house green) (from_house white).

Axiom clue5: (* The owner of the house with green walls drinks coffee. *)
  from_house green = from_drink coffee.

Axiom clue6: (* The person who smokes Pall Mall cigars owns a bird. *)
  from_smoke pall_mall = from_pet bird.

Axiom clue7: (* The owner of the house with yellow walls smokes Dunhill. *)
  from_house yellow = from_smoke dunhill.

Axiom clue8: (* The man living in the center house drinks milk. *)
  to_drink c = milk.

Axiom clue9: (* The Norwegian lives in the first house. *)
  to_citizen a = norwegian.

Axiom clue10: (* The man who smokes blends lives next to the cat owner. *)
  next_to (from_smoke blends) (from_pet cat).

Axiom clue11: (* The horse’s owner lives next to the man who smokes Dunhill. *)
  next_to (from_pet horse) (from_smoke dunhill).

Axiom clue12: (* The man who smokes Blue Master drinks root beer. *)
  from_smoke blue_master = from_drink root_beer.

Axiom clue13: (* The German smokes Prince. *)
  from_citizen german = from_smoke prince.

Axiom clue14: (* The Norwegian lives next to the house with blue walls. *)
  next_to (from_citizen norwegian) (from_house blue).

Axiom clue15: (* The man who smokes Blends lives next to the man who drinks water. *)
  next_to (from_smoke blends) (from_drink water).

(* prelimilary theorems *)
(* identity for bijection *)
Theorem biject_ident :
  forall {A B : Type}  {f1 : A-> B} {f2: B->A} (a : A) (b : B), bijective f1 f2 -> (f1 a = b <-> a = f2 b).
Proof.
  intros.
  elim H.
  intros.
  split.
  intros.
  rewrite <- H2.
  assert (f2 (f1 a0)=a0).
  apply (H0 a0).
  rewrite H3.
  reflexivity.
  intros.
  rewrite H2.
  apply (H1 b0).
Qed.

(* specification of biject_ident *)
Theorem citizen_ident:
  forall (a:owner)(b:nationality), to_citizen a = b <-> a = from_citizen b.
Proof.
  intros.
  split;intros;apply (biject_ident a0 b0 citizen_biject); assumption.
Qed.

Theorem house_ident:
  forall (a:owner)(b:color), to_house a = b <-> a = from_house b.
Proof.
  intros.
  split; intros; apply (biject_ident a0 b0 house_biject); assumption.
Qed.

Theorem pet_ident:
  forall (a:owner)(b:animal), to_pet a = b <-> a = from_pet b.
Proof.
  intros.
  split; intros; apply (biject_ident a0 b0 pet_biject); assumption.
Qed.

Theorem drink_ident:
  forall (a:owner)(b:beverage), to_drink a = b <-> a = from_drink b.
Proof.
  intros.
  split; intros; apply (biject_ident a0 b0 drink_biject); assumption.
Qed.

Theorem smoke_ident:
  forall (a:owner)(b:cigar), to_smoke a = b <-> a = from_smoke b.
Proof.
  intros.
  split; intros; apply (biject_ident a0 b0 smoke_biject); assumption.
Qed.

(* function property: a = b -> f a = f b *)
Theorem func_prop :
  forall {A B : Type} (f : A->B) (a1 a2 : A), a1 = a2 -> f a1 = f a2.
Proof.
  intros.
  rewrite H; reflexivity.
Qed.

(* left injection *)
Theorem inject_l : forall {A B : Type} {f1 : A->B}{f2:B->A}, bijective f1 f2 -> forall a1 a2:A, f1 a1 = f1 a2 -> a1 = a2.
Proof.
  intros.
  destruct H.
  assert (f2 (f1 a1) = f2 (f1 a2)).
  rewrite H0; reflexivity.
  rewrite H in H2.
  rewrite H in H2.
  assumption.
Qed.

(* right injection *)
Theorem inject_r : forall {A B : Type} {f1 : A->B}{f2:B->A}, bijective f1 f2 -> forall b1 b2:B, f2 b1 = f2 b2 -> b1 = b2.
Proof.
  intros.
  destruct H.
  assert (f1 (f2 b1) = f1 (f2 b2)).
  rewrite H0; reflexivity.
  rewrite H1 in H2.
  rewrite H1 in H2.
  assumption.
Qed.

(* left surjection *)
Theorem surject_l : forall {A B:Type}{f1 : A->B}{f2:B->A}, bijective f1 f2 -> forall b : B, exists a : A, f1 a = b.
Proof.
  intros.
  destruct H.
  assert ( f1 (f2 b0) = b0 ).
  apply H0.
  exists (f2 b0).
  assumption.
Qed.

(* right surjection *)
Theorem surject_r : forall {A B:Type}{f1 : A->B}{f2:B->A}, bijective f1 f2 -> forall a : A, exists b : B, f2 b = a.
Proof.
  intros.
  destruct H.
  assert ( f2 (f1 a0) = a0 ).
  apply H.
  exists (f1 a0).
  assumption.
Qed.

(* lemma for left_of and next to *)
Lemma a_left_of_b : forall X:owner, left_of a X -> X = b.
Proof.
  intros.
  induction X; simpl in H; contradiction || reflexivity.
Qed.

Lemma d_left_of_e : forall X:owner, left_of d X -> X = e.
Proof.
  intros.
  induction X; simpl in H; contradiction || reflexivity.
Qed.

Lemma e_left_of_no : forall X:owner, left_of e X -> False.
Proof.
  intros.
  induction X; simpl in H; contradiction.
Qed.

Lemma b_next_to_a : forall X:owner, next_to a X -> X = b.
Proof.
  intros.
  destruct H.
  apply a_left_of_b; assumption.
  induction X; simpl in H; contradiction.
Qed.

Lemma b_next_to_a' : forall X:owner, next_to X a -> X = b.
Proof.
  intros.
  destruct H.
  induction X; simpl in H; contradiction.
  apply a_left_of_b; assumption.
Qed.

Lemma blue_is_b : to_house b = blue.
Proof.
  assert (a = from_citizen norwegian).
  apply citizen_ident.
  exact clue9.
  apply house_ident.
  apply eq_sym.
  apply b_next_to_a.
  rewrite H.
  exact clue14.
Qed.

Lemma green_is_d : to_house d = green.
Proof.
  assert (to_house a <> green).
  intro H.
  apply house_ident in H.
  generalize clue4; intros.
  rewrite <- H in H0.
  apply a_left_of_b in H0.
  apply eq_sym in H0.
  apply house_ident in H0.
  rewrite blue_is_b in H0; discriminate.
  assert (to_house b <> green).
  intro.
  rewrite blue_is_b in H0; discriminate.
  assert (to_house c <> green).
  intro.
  apply house_ident in H1.
  rewrite clue5 in H1.
  apply drink_ident in H1.
  rewrite clue8 in H1; discriminate.
  assert (to_house e <> green).
  intro.
  apply house_ident in H2.
  generalize clue4; intros.
  rewrite <- H2 in H3.
  apply (e_left_of_no (from_house white)); assumption.
  assert (exists x:owner, to_house x = green).
  apply (surject_l house_biject).
  elim H3; intros.
  induction x; contradiction || assumption.
Qed.

Lemma white_is_e : to_house e = white.
Proof.
  generalize clue4 green_is_d; intros.
  apply house_ident in H0.
  rewrite <- H0 in H.
  apply d_left_of_e in H.
  apply eq_sym in H.
  apply house_ident in H.
  assumption.
Qed.

Lemma red_is_c : to_house c = red.
Proof.
  assert (to_house a <> red).
  intro H.
  apply house_ident in H.
  rewrite <- clue1 in H.
  apply citizen_ident in H.
  rewrite clue9 in H; discriminate.
  assert (to_house b <> red).
  intro H0; rewrite blue_is_b in H0; discriminate.
  assert (to_house d <> red).
  intro H1; rewrite green_is_d in H1; discriminate.
  assert (to_house e <> red).
  intro H2; rewrite white_is_e in H2; discriminate.
  assert (exists x:owner, to_house x = red).
  apply (surject_l house_biject).
  elim H3; intros.
  induction x; contradiction || assumption.
Qed.

Lemma yellow_is_a : to_house a = yellow.
Proof.
  assert (to_house b <> yellow).
  intro H; rewrite blue_is_b in H; discriminate.
  assert (to_house c <> yellow).
  intro H0; rewrite red_is_c in H0; discriminate.
  assert (to_house d <> yellow).
  intro H1; rewrite green_is_d in H1; discriminate.
  assert (to_house e <> yellow).
  intro H2; rewrite white_is_e in H2; discriminate.
  assert (exists x:owner, to_house x = yellow).
  apply (surject_l house_biject).
  elim H3; intros.
  induction x; contradiction || assumption.
Qed.

Lemma c_is_brit : to_citizen c = brit.
Proof.
  apply citizen_ident.
  rewrite clue1.
  apply house_ident.
  apply red_is_c.
Qed.

Lemma a_smoke_dunhill : to_smoke a = dunhill.
Proof.
  apply smoke_ident.
  rewrite <- clue7.
  apply house_ident.
  apply yellow_is_a.
Qed.

Lemma d_drink_coffee : to_drink d = coffee.
Proof.
  apply drink_ident.
  rewrite <- clue5.
  apply house_ident.
  apply green_is_d.
Qed.

Lemma b_have_horse : to_pet b = horse.
Proof.
  generalize clue11 a_smoke_dunhill; intros.
  apply smoke_ident in H0.
  rewrite <- H0 in H.
  apply b_next_to_a' in H.
  apply pet_ident.
  apply eq_sym.
  assumption.
Qed.

Lemma citizen_b_not_swede : to_citizen b <> swede.
Proof.
  intro.
  apply citizen_ident in H.
  rewrite clue2 in H.
  apply pet_ident in H.
  rewrite b_have_horse in H.
  discriminate.
Qed.

Lemma dane_not_e : to_citizen e <> dane.
Proof.
  intro.
  generalize H.
  apply citizen_ident in H.
  rewrite clue3 in H.
  apply drink_ident in H.
  assert (to_drink e <> root_beer).
  intro.
  rewrite H in H0; discriminate.
  assert (to_drink c <> root_beer).
  intro H1; rewrite clue8 in H1; discriminate.
  assert (to_drink d <> root_beer).
  intro H2; rewrite d_drink_coffee in H2; discriminate.
  assert (to_drink a <> root_beer).
  intro.
  apply drink_ident in H3.
  rewrite <- clue12 in H3.
  apply smoke_ident in H3.
  rewrite a_smoke_dunhill in H3; discriminate.
  assert (exists x:owner, to_drink x = root_beer).
  apply (surject_l drink_biject).
  elim H4; intros.
  induction x; try contradiction.
  apply drink_ident in H5.
  rewrite <- clue12 in H5.
  assert (to_citizen e <> swede).
  intro Hn0; rewrite H6 in Hn0; discriminate.
  assert (to_citizen a <> swede).
  intro Hn1; rewrite clue9 in Hn1; discriminate.
  assert (to_citizen c <> swede).
  intro Hn2; rewrite c_is_brit in Hn2; discriminate.
  generalize citizen_b_not_swede; intro.
  assert (exists x:owner, to_citizen x = swede).
  apply (surject_l citizen_biject).
  elim H11; intros.
  induction x; try contradiction.
  assert (to_citizen e <> german).
  intro Hn0; rewrite H6 in Hn0; discriminate.
  assert (to_citizen a <> german).
  intro Hn1; rewrite clue9 in Hn1; discriminate.
  assert (to_citizen c <> german).
  intro Hn2; rewrite c_is_brit in Hn2; discriminate.
  assert (to_citizen d <> german).
  intro Hn3; rewrite H12 in Hn3; discriminate.
  assert (exists x:owner, to_citizen x = german).
  apply (surject_l citizen_biject).
  elim H17; intros.
  induction x; try contradiction.
  apply citizen_ident in H18.
  rewrite clue13 in H18.
  rewrite H5 in H18.
  apply (inject_r smoke_biject) in H18; discriminate.
Qed.

Lemma b_is_dane : to_citizen b = dane.
Proof.
  assert (to_citizen a <> dane).
  intro Hn0; rewrite clue9 in Hn0; discriminate.
  assert (to_citizen c <> dane).
  intros Hn1; rewrite c_is_brit in Hn1; discriminate.
  assert (to_citizen d <> dane).
  intro Hn2.
  apply citizen_ident in Hn2.
  rewrite clue3 in Hn2.
  apply drink_ident in Hn2.
  rewrite d_drink_coffee in Hn2; discriminate.
  generalize dane_not_e; intros.
  assert (exists x:owner, to_citizen x = dane).
  apply (surject_l citizen_biject).
  elim H3;intros.
  induction x; contradiction || assumption.
Qed.

Lemma b_drink_tea : to_drink b = tea.
Proof.
  apply drink_ident.
  rewrite <- clue3.
  apply citizen_ident.
  exact b_is_dane.
Qed.

Lemma e_drink_root_beer : to_drink e = root_beer.
Proof.
  assert (to_drink a <> root_beer).
  intro.
  apply drink_ident in H.
  rewrite <- clue12 in H.
  apply smoke_ident in H.
  rewrite a_smoke_dunhill in H; discriminate.
  assert (to_drink b <> root_beer).
  intro Hn0; rewrite b_drink_tea in Hn0; discriminate.
  assert (to_drink c <> root_beer).
  intro Hn0; rewrite clue8 in Hn0; discriminate.
  assert (to_drink d <> root_beer).
  intro Hn0; rewrite d_drink_coffee in Hn0; discriminate.
  assert (exists x:owner, to_drink x = root_beer).
  apply (surject_l drink_biject).
  elim H3; intros.
  induction x; contradiction || assumption.
Qed.

Lemma e_smoke_blue_master : to_smoke e = blue_master.
Proof.
  apply smoke_ident.
  rewrite clue12.
  apply drink_ident.
  exact e_drink_root_beer.
Qed.

Lemma a_drink_water : to_drink a = water.
Proof.
  assert (to_drink b <> water).
  intro Hn; rewrite b_drink_tea in Hn; discriminate.
  assert (to_drink c <> water).
  intro Hn; rewrite clue8 in Hn; discriminate.
  assert (to_drink d <> water).
  intro Hn; rewrite d_drink_coffee in Hn; discriminate.
  assert (to_drink e <> water).
  intro Hn; rewrite e_drink_root_beer in Hn; discriminate.
  assert (exists x:owner, to_drink x = water).
  apply (surject_l drink_biject).
  elim H3; intros.
  induction x; contradiction || assumption.
Qed.

Lemma b_smoke_blends : to_smoke b = blends.
Proof.
  generalize clue15, a_drink_water; intros.
  apply drink_ident in H0.
  rewrite <- H0 in H.
  apply b_next_to_a' in H.
  apply smoke_ident.
  rewrite H; reflexivity.
Qed.

Lemma d_smoke_prince : to_smoke d = prince.
Proof.
  assert (to_smoke a <> prince).
  intro Hn; rewrite a_smoke_dunhill in Hn; discriminate.
  assert (to_smoke b <> prince).
  intro Hn; rewrite b_smoke_blends in Hn; discriminate.
  assert (to_smoke e <> prince).
  intro Hn; rewrite e_smoke_blue_master in Hn; discriminate.
  assert (to_smoke c <> prince).
  intro Hn.
  apply smoke_ident in Hn.
  rewrite <- clue13 in Hn.
  apply citizen_ident in Hn.
  rewrite c_is_brit in Hn; discriminate.
  assert (exists x:owner, to_smoke x = prince).
  apply (surject_l smoke_biject).
  elim H3; intros.
  induction x; contradiction || assumption.
Qed.

Lemma c_smoke_pall_mall : to_smoke c = pall_mall.
Proof.
  assert (to_smoke a <> pall_mall).
  intro Hn; rewrite a_smoke_dunhill in Hn; discriminate.
  assert (to_smoke b <> pall_mall).
  intro Hn; rewrite b_smoke_blends in Hn; discriminate.
  assert (to_smoke d <> pall_mall).
  intro Hn; rewrite d_smoke_prince in Hn; discriminate.
  assert (to_smoke e <> pall_mall).
  intro Hn; rewrite e_smoke_blue_master in Hn; discriminate.
  assert (exists x:owner, to_smoke x = pall_mall).
  apply (surject_l smoke_biject).
  elim H3; intros.
  induction x; contradiction || assumption.
Qed.

Lemma c_have_bird : to_pet c = bird.
Proof.
  apply pet_ident.
  rewrite <- clue6.
  apply smoke_ident.
  exact c_smoke_pall_mall.
Qed.

Lemma d_is_german : to_citizen d = german.
Proof.
  apply citizen_ident.
  rewrite clue13.
  apply smoke_ident.
  exact d_smoke_prince.
Qed.

Lemma e_is_swede : to_citizen e = swede.
Proof.
  assert (to_citizen a <> swede).
  intro Hn; rewrite clue9 in Hn; discriminate.
  assert (to_citizen b <> swede).
  intro Hn; rewrite b_is_dane in Hn; discriminate.
  assert (to_citizen c <> swede).
  intro Hn; rewrite c_is_brit in Hn; discriminate.
  assert (to_citizen d <> swede).
  intro Hn; rewrite d_is_german in Hn; discriminate.
  assert (exists x:owner, to_citizen x = swede).
  apply (surject_l citizen_biject).
  elim H3; intros.
  induction x; contradiction || assumption.
Qed.

Lemma e_have_dog : to_pet e = dog.
Proof.
  apply pet_ident.
  rewrite <- clue2.
  apply citizen_ident.
  exact e_is_swede.
Qed.

Lemma a_have_cat : to_pet a = cat.
Proof.
  assert (to_pet b <> cat).
  intro Hn; rewrite b_have_horse in Hn; discriminate.
  assert (to_pet c <> cat).
  intro Hn; rewrite c_have_bird in Hn; discriminate.
  assert (to_pet e <> cat).
  intro Hn; rewrite e_have_dog in Hn; discriminate.
  assert (to_pet d <> cat).
  intro Hn.
  apply pet_ident in Hn.
  generalize clue10, b_smoke_blends; intros.
  rewrite <- Hn in H2.
  apply smoke_ident in H3.
  rewrite <- H3 in H2.
  destruct H2; simpl in H2; assumption.
  assert (exists x:owner, to_pet x = cat).
  apply (surject_l pet_biject).
  elim H3; intros.
  induction x; contradiction || assumption.
Qed.

Theorem d_have_fish : to_pet d = fish.
Proof.
  assert (to_pet a <> fish).
  intro Hn; rewrite a_have_cat in Hn; discriminate.
  assert (to_pet b <> fish).
  intro Hn; rewrite b_have_horse in Hn; discriminate.
  assert (to_pet c <> fish).
  intro Hn; rewrite c_have_bird in Hn; discriminate.
  assert (to_pet e <> fish).
  intro Hn; rewrite e_have_dog in Hn; discriminate.
  assert (exists x:owner, to_pet x = fish).
  apply (surject_l pet_biject).
  elim H3; intros.
  induction x; contradiction || assumption.
Qed.

End five_houses.


Require Import michelson.

Require Import List.
Import ListNotations.

Hint Constructors BigStep.

Inductive AExp : Set :=
  | AEConst (n  : nat) : AExp
  | AEAdd (e1 e2  : AExp) : AExp
  | AEMul (e1 e2  : AExp) : AExp.

Fixpoint AExp_denot (e : AExp) : nat:=
  match e with
  | AEConst n => n
  | AEAdd e1 e2 => AExp_denot e1 + AExp_denot e2
  | AEMul e1 e2 => AExp_denot e1 * AExp_denot e2
  end.

Goal (AExp_denot (AEAdd (AEConst 1) (AEConst 5)) = 6). repeat econstructor. Qed.

(* Notation for sequence of instructinos *)
Notation "x ;; y" :=  (i_SEQ x y) (at level 100)  : list_scope .

Fixpoint AExp_compile (e : AExp) : code :=
  match e with
  | AEConst n => i_Fun (i_PUSH (ty_Comparable_type cty_nat) (d_Num (num_NatConstant n)))
  | AEAdd e1 e2 => AExp_compile e2 ;;
                   AExp_compile e1 ;;
                   i_Fun i_ADD
  | AEMul e1 e2 => AExp_compile e2 ;;
                   AExp_compile e1 ;;
                   i_Fun i_MUL
  (* | _ => i_Failwith *)
  end.

Definition aexp_denot_compil_corr (e : AExp) (s_init  : list data): Prop :=
  (BigStep (AExp_compile e)
           (SE_Stack s_init)
           (SE_Stack ((d_Num (num_NatConstant (AExp_denot e))) :: s_init))).

Fact test1 : aexp_denot_compil_corr (AEAdd (AEConst 1) (AEConst 5)) [].
  unfold aexp_denot_compil_corr. simpl.
  repeat econstructor.
Qed.

Lemma aexp_denot_compil_corr_all' :
  forall e s, aexp_denot_compil_corr e s.
Proof.
  unfold aexp_denot_compil_corr.
  induction e; intro s; repeat (eauto; econstructor).
Qed.

Theorem aexp_denot_compil_corr_all :
  forall e, (BigStep (AExp_compile e)
                     (SE_Stack [])
                     (SE_Stack ([(d_Num (num_NatConstant (AExp_denot e)))]))).
Proof. intro e. apply (aexp_denot_compil_corr_all' e []). 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)         *)
(************************************************************************)

Require Import Notations Logic Datatypes.
Require Decimal.
Local Open Scope nat_scope.
Local Unset Universe Polymorphism.
(**********************************************************************)
(** * Peano natural numbers, definitions of operations *)
(**********************************************************************)

(** This file is meant to be used as a whole module,
    without importing it, leading to qualified definitions
    (e.g. Nat.pred) *)

Definition t := nat.

(** ** Constants *)

Local Notation "0" := O.
Local Notation "1" := (S O).
Local Notation "2" := (S (S O)).

Definition zero := 0.
Definition one := 1.
Definition two := 2.

(** ** Basic operations *)

Definition succ := S.

Definition pred n :=
  match n with
    | 0 => n
    | S u => u
  end.

Fixpoint add n m :=
  match n with
  | 0 => m
  | S p => S (p + m)
  end

where "n + m" := (add n m) : nat_scope.

Definition double n := n + n.

Fixpoint mul n m :=
  match n with
  | 0 => 0
  | S p => m + p * m
  end

where "n * m" := (mul n m) : nat_scope.

(** Truncated subtraction: [n-m] is [0] if [n<=m] *)

Fixpoint sub n m :=
  match n, m with
  | S k, S l => k - l
  | _, _ => n
  end

where "n - m" := (sub n m) : nat_scope.

(** ** Minimum, maximum *)

Fixpoint max n m :=
  match n, m with
    | 0, _ => m
    | S n', 0 => n
    | S n', S m' => S (max n' m')
  end.

Fixpoint min n m :=
  match n, m with
    | 0, _ => 0
    | S n', 0 => 0
    | S n', S m' => S (min n' m')
  end.

(** ** Power *)

Fixpoint pow n m :=
  match m with
    | 0 => 1
    | S m => n * (n^m)
  end

where "n ^ m" := (pow n m) : nat_scope.

(** ** Tail-recursive versions of [add] and [mul] *)

Fixpoint tail_add n m :=
  match n with
    | O => m
    | S n => tail_add n (S m)
  end.

(** [tail_addmul r n m] is [r + n * m]. *)

Fixpoint tail_addmul r n m :=
  match n with
    | O => r
    | S n => tail_addmul (tail_add m r) n m
  end.

Definition tail_mul n m := tail_addmul 0 n m.

(** ** Conversion with a decimal representation for printing/parsing *)

Local Notation ten := (S (S (S (S (S (S (S (S (S (S O)))))))))).

Fixpoint of_uint_acc (d:Decimal.uint)(acc:nat) :=
  match d with
  | Decimal.Nil => acc
  | Decimal.D0 d => of_uint_acc d (tail_mul ten acc)
  | Decimal.D1 d => of_uint_acc d (S (tail_mul ten acc))
  | Decimal.D2 d => of_uint_acc d (S (S (tail_mul ten acc)))
  | Decimal.D3 d => of_uint_acc d (S (S (S (tail_mul ten acc))))
  | Decimal.D4 d => of_uint_acc d (S (S (S (S (tail_mul ten acc)))))
  | Decimal.D5 d => of_uint_acc d (S (S (S (S (S (tail_mul ten acc))))))
  | Decimal.D6 d => of_uint_acc d (S (S (S (S (S (S (tail_mul ten acc)))))))
  | Decimal.D7 d => of_uint_acc d (S (S (S (S (S (S (S (tail_mul ten acc))))))))
  | Decimal.D8 d => of_uint_acc d (S (S (S (S (S (S (S (S (tail_mul ten acc)))))))))
  | Decimal.D9 d => of_uint_acc d (S (S (S (S (S (S (S (S (S (tail_mul ten acc))))))))))
  end.

Definition of_uint (d:Decimal.uint) := of_uint_acc d O.

Fixpoint to_little_uint n acc :=
  match n with
  | O => acc
  | S n => to_little_uint n (Decimal.Little.succ acc)
  end.

Definition to_uint n :=
  Decimal.rev (to_little_uint n Decimal.zero).

Definition of_int (d:Decimal.int) : option nat :=
  match Decimal.norm d with
    | Decimal.Pos u => Some (of_uint u)
    | _ => None
  end.

Definition to_int n := Decimal.Pos (to_uint n).

(** ** Euclidean division *)

(** This division is linear and tail-recursive.
    In [divmod], [y] is the predecessor of the actual divisor,
    and [u] is [y] minus the real remainder
*)

Fixpoint divmod x y q u :=
  match x with
    | 0 => (q,u)
    | S x' => match u with
                | 0 => divmod x' y (S q) y
                | S u' => divmod x' y q u'
              end
  end.

Definition div x y :=
  match y with
    | 0 => y
    | S y' => fst (divmod x y' 0 y')
  end.

Definition modulo x y :=
  match y with
    | 0 => y
    | S y' => y' - snd (divmod x y' 0 y')
  end.

Infix "/" := div : nat_scope.
Infix "mod" := modulo (at level 40, no associativity) : nat_scope.

(** ** Greatest common divisor *)

(** We use Euclid algorithm, which is normally not structural,
    but Coq is now clever enough to accept this (behind modulo
    there is a subtraction, which now preserves being a subterm)
*)

Fixpoint gcd a b :=
  match a with
   | O => b
   | S a' => gcd (b mod (S a')) (S a')
  end.

(** ** Square *)

Definition square n := n * n.

(** ** Square root *)

(** The following square root function is linear (and tail-recursive).
  With Peano representation, we can't do better. For faster algorithm,
  see Psqrt/Zsqrt/Nsqrt...

  We search the square root of n = k + p^2 + (q - r)
  with q = 2p and 0<=r<=q. We start with p=q=r=0, hence
  looking for the square root of n = k. Then we progressively
  decrease k and r. When k = S k' and r=0, it means we can use (S p)
  as new sqrt candidate, since (S k')+p^2+2p = k'+(S p)^2.
  When k reaches 0, we have found the biggest p^2 square contained
  in n, hence the square root of n is p.
*)

Fixpoint sqrt_iter k p q r :=
  match k with
    | O => p
    | S k' => match r with
                | O => sqrt_iter k' (S p) (S (S q)) (S (S q))
                | S r' => sqrt_iter k' p q r'
              end
  end.

Definition sqrt n := sqrt_iter n 0 0 0.

(** ** Log2 *)

(** This base-2 logarithm is linear and tail-recursive.

  In [log2_iter], we maintain the logarithm [p] of the counter [q],
  while [r] is the distance between [q] and the next power of 2,
  more precisely [q + S r = 2^(S p)] and [r<2^p]. At each
  recursive call, [q] goes up while [r] goes down. When [r]
  is 0, we know that [q] has almost reached a power of 2,
  and we increase [p] at the next call, while resetting [r]
  to [q].

  Graphically (numbers are [q], stars are [r]) :

<<
                    10
                  9
                8
              7   *
            6       *
          5           ...
        4
      3   *
    2       *
  1   *       *
0   *   *       *
>>

  We stop when [k], the global downward counter reaches 0.
  At that moment, [q] is the number we're considering (since
  [k+q] is invariant), and [p] its logarithm.
*)

Fixpoint log2_iter k p q r :=
  match k with
    | O => p
    | S k' => match r with
                | O => log2_iter k' (S p) (S q) q
                | S r' => log2_iter k' p (S q) r'
              end
  end.

Definition log2 n := log2_iter (pred n) 0 1 0.

(** Iterator on natural numbers *)

Definition iter (n:nat) {A} (f:A->A) (x:A) : A :=
 nat_rect (fun _ => A) x (fun _ => f) n.


Require Export ZArith.
Require Export List.
Require Export Arith.

Ltac caseEq f := generalize (refl_equal f); pattern f at -1; case f.

Section bad_proof_example_for_Induction1.

 Theorem le_plus_minus' : forall n m:nat, m <= n -> n = m+(n-m).
 Proof.
  intros n m H.
  induction n.
  rewrite <- le_n_O_eq with (1 := H); simpl; trivial.
 Abort.

End bad_proof_example_for_Induction1.

Theorem simpl_pattern_example :  3*3 + 3*3 = 18.
Proof.
 simpl (3*3) at 2.
 lazy beta iota zeta delta [mult].
 simpl.
 trivial.
Qed.

Theorem lazy_example : forall n:nat, (S n) + 0 = S n.
Proof.
 intros n; lazy beta iota zeta delta.
 fold plus.
 (* attendre un commit *)
 rewrite plus_0_r; reflexivity.
Qed.

Hint Extern 4 (_ <> _) => discriminate : core.
Hint Resolve le_S_n : le_base.

Theorem auto_le_example :
 forall n m:nat, S (S (S n)) <= S (S (S m))-> le n m.
Proof.
  intros n m H.
  auto with le_base.
Qed.

Lemma unprovable_le : forall n m:nat, n <= m.
Proof.
 Time auto with arith.
 Time auto with le_base arith.
Abort.

Section bad_proof_for_auto.

 Section Trying_auto.
  Variable l1 : forall n m:nat, S n <= S m -> n <= m.

  Theorem unprovable_le2 : forall n m:nat, n <= m.
  Proof.
   Time auto with arith.
   Time try (clear l1; auto with arith; fail).
  Abort.
 End Trying_auto.
End bad_proof_for_auto.

Section combinatory_logic.

Variables (CL:Set)(App:CL->CL->CL)(S:CL)(K:CL).
Hypotheses
  (S_rule :
   forall A B C:CL, App (App (App S A) B) C = App (App A C)(App B C))
  (K_rule :
   forall A B:CL, App (App K A) B = A).

Hint Rewrite  S_rule K_rule : CL_rules.

Theorem obtain_I : forall A:CL, App (App (App S K) K) A = A.
Proof.
 intros.
 autorewrite with CL_rules.
 trivial.
Qed.

End combinatory_logic.

Theorem example_for_subst :
  forall (a b c d:nat), a = b+c -> c = 1 -> a+b = d -> 2*a = d+c.
Proof.
 intros a b c d H H1 H2.
 subst a.
 subst.
 lazy delta [mult] iota zeta beta;
  rewrite  plus_0_r;
  repeat rewrite plus_assoc_reverse;
   trivial.
Qed.

Open Scope Z_scope.

Theorem ring_example1 : forall x y:Z, (x+y)*(x+y)=x*x + 2*x*y + y*y.
Proof.
 intros x y; ring.
Qed.

Definition square (z:Z) := z*z.

Theorem ring_example2 :
  forall x y:Z, square (x+y) = square x + 2*x*y + square y.
Proof.
 intros x y; unfold square; ring.
Qed.

Theorem ring_example3 :
  (forall x y:nat, (x+y)*(x+y) = x*x + 2*x*y + y*y)%nat.
Proof.
 intros x y; ring.
Qed.

Theorem ring_example4 :
 (forall x:nat, (S x)*(x+1) = x*x + (x+x+1))%nat.
Proof.
 intro x; ring_simplify.
 ring_simplify.
 trivial.
Qed.

Require Omega.

Theorem omega_example1 :
 forall x y z t:Z, x <= y <= z /\  z <= t <= x -> x = t.
Proof.
 intros x y z t H; omega.
Qed.

Theorem omega_example2 :
 forall x y:Z,
    0 <= square x -> 3*(square x) <= 2*y -> square x <= y.
Proof.
 intros x y H H0; omega.
Qed.

Theorem omega_example3 :
 forall x y:Z,
   0 <= x*x -> 3*(x*x) <= 2*y -> x*x <= y.
Proof.
 intros x y H H0; omega.
Qed.

Check (fun (X y:Z) => 0 <= X -> 3*X <= 2*y  ->  X < y).
Require Export Reals.

Open Scope R_scope.

Theorem example_for_field : forall x y:R, y <> 0 ->(x+y)/y = 1+(x/y).
Proof.
  intros x y H; field.
  trivial.
Qed.
Require Import Fourier.

Theorem example_for_Fourier : forall x y:R, x-y>1->x-2*y<0->x>1.
Proof.
  intros x y H H0.
  fourier.
Qed.

Theorem ex_tauto1 : forall A B:Prop, A/\B->A.
Proof.
 tauto.
Qed.

Theorem ex_tauto2 : forall A B:Prop, A/\~A -> B.
Proof.
 tauto.
Qed.

Open Scope Z_scope.
Theorem ex_tauto3 : forall x y:Z, x<=y -> ~(x<=y) -> x=3.
Proof.
 tauto.
Qed.

Theorem ex_tauto4 : forall A B:Prop, A\/B -> B\/A.
Proof.
 tauto.
Qed.

Theorem ex_tauto5 :
 forall A B C D:Prop, (A->B)\/(A->C)->A->(B->D)->(C->D)->D.
Proof.
 tauto.
Qed.

Open Scope nat_scope.

Theorem example_intuition :
  (forall n p q:nat,  n <= p \/ n <= q -> n <= p \/ n <= S q).
Proof.
 intros n p q; intuition auto with arith.
Qed.

Ltac autoClear h := try (clear h; auto with arith; fail).

Ltac autoAfter tac := try (tac; auto with arith; fail).

Open Scope nat_scope.

Theorem example_for_autoAfter : forall  n p:nat,
   n < p -> n <= p -> 0 < p -> S n < S p.
Proof.
 intros n p H H0 H1.
 autoAfter ltac:(clear H0 H1).
Qed.

Open Scope nat_scope.

Ltac le_S_star := apply le_n || (apply le_S; le_S_star).

Theorem le_5_25 : 5 <= 25.
Proof.
 le_S_star.
Qed.

Ltac contrapose H :=
  match goal with
  | id:(~_) |- (~_) => intro H; apply id
  end.

Theorem example_contrapose :
  forall x y:nat, x <> y -> x <= y -> ~y <= x.
Proof.
 intros x y H H0.
 contrapose H'.
 auto with arith.
Qed.

Section primes.

 Definition divides (n m:nat) := exists p:nat, p*n = m.

 Hypotheses
  (divides_O : forall n:nat, divides n 0)
  (divides_plus : forall n m:nat, divides n m -> divides n (n+m))
  (not_divides_plus : forall n m:nat, ~divides n m -> ~divides n (n+m))
  (not_divides_lt : forall n m:nat, 0<m -> m<n -> ~divides n m)
  (not_lt_2_divides : forall n m:nat, n<>1 -> n<2 -> 0 < m -> ~divides n m)
  (le_plus_minus : forall n m:nat, le n m -> m = n+(m-n))
  (lt_lt_or_eq : forall n m:nat, n < S m ->  n<m \/ n=m).

 Ltac check_not_divides :=
   match goal with
   | |- (~divides ?X1 ?X2) =>
       cut (X1<=X2);[ idtac | le_S_star ]; intros Hle;
        rewrite (le_plus_minus _ _ Hle); apply not_divides_plus;
        simpl; clear Hle; check_not_divides
   | |- _ => apply not_divides_lt; unfold lt; le_S_star

  end.
Open Scope nat_scope.

Hint Resolve lt_O_Sn.

Ltac check_lt_not_divides :=
  match goal with
  | Hlt:(lt ?X1 2%nat) |- (~divides ?X1 ?X2) =>
      apply not_lt_2_divides; auto
  | Hlt:(lt ?X1 ?X2) |- (~divides ?X1 ?X3) =>
      elim (lt_lt_or_eq _ _ Hlt);
       [clear Hlt; intros Hlt; check_lt_not_divides
        | intros Heq; rewrite Heq; check_not_divides]
  end.

Definition is_prime (p:nat) : Prop :=
   forall n:nat, n <> 1 -> lt n p -> ~divides n p.

Theorem prime37 : is_prime 37.
Proof.
 unfold is_prime; intros.
 check_lt_not_divides.
Time Qed.

End primes.

Ltac clear_all :=
  match goal with
  | id:_ |- _ => clear id; clear_all
  | |- _ => idtac
  end.

Theorem clear_example_thm :
  forall (x y z:nat), x<z->z=2*x->0<x->x=2*y->y<z->x>y.
Proof.
 intros x y z H H1 H2 H3.
 generalize H1 H2 H3; clear_all; intros; omega.
Qed.

Theorem S_to_plus_one : forall n:nat, S n = n+1.
Proof.
  intros; rewrite plus_comm; reflexivity.
Qed.

Ltac S_to_plus_simpl :=
  match goal with
  | |-  context [(S ?X1)] =>
      match X1 with
      | 0%nat => fail 1
      | ?X2 => rewrite (S_to_plus_one X2); S_to_plus_simpl
      end
  | |- _ => idtac
  end.

Ltac a_function X1 :=
        match X1 with
      | 0%nat => fail 1
      | ?X2 => rewrite (S_to_plus_one X2); S_to_plus_simpl
      end.

Ltac simpl_on e :=
  let v := eval simpl in e in
  match goal with
  | |- context [e] => replace e with v; [idtac | auto]
  end.

Theorem simpl_on_example :
  forall n:nat, exists m : nat, (1+n) + 4*(1+n) = 5*(S m).
Proof.
  intros n; simpl_on (1+n).
  exists n; auto with arith.
Qed.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import ZArith.
Require Import Rbase.
Add Rec LoadPath "/home/cmarche/recherche/why3/share/theories".
Add Rec LoadPath "/home/cmarche/recherche/why3/share/modules".

Inductive set_ (X:Type) : Type := mk_set: (X -> Prop) -> set_ X.

Definition set : forall (a:Type), Type.
(* YOU MAY EDIT THE PROOF BELOW *)
exact set_.
(*
exact (fun (X: Type) => X -> Prop).
*)
Defined.
(* DO NOT EDIT BELOW *)

Definition mem: forall (a:Type), a -> (set a) -> Prop.
(* YOU MAY EDIT THE PROOF BELOW *)
intros X x s.
destruct s.
exact (P x).
Defined.
(* DO NOT EDIT BELOW *)

Implicit Arguments mem.

Definition infix_eqeq (a:Type)(s1:(set a)) (s2:(set a)): Prop :=
  forall (x:a), (mem x s1) <-> (mem x s2).
Implicit Arguments infix_eqeq.

(* YOU MAY EDIT THE CONTEXT BELOW *)
Hint Unfold mem.
Notation "x == y" := (infix_eqeq x y) (at level 70, no associativity).
(*
Require FunctionalExtensionality.
Require ProofIrrelevance.
*)
(* DO NOT EDIT BELOW *)

Lemma extensionality : forall (a:Type), forall (s1:(set a)) (s2:(set a)),
  (infix_eqeq s1 s2) -> (s1 = s2).
(* YOU MAY EDIT THE PROOF BELOW *)
admit.
(*
intros.
apply FunctionalExtensionality.functional_extensionality.
red in H.
unfold mem in H.
intro x.
apply ProofIrrelevance.proof_irrelevance.
rewrite H.
; auto.
*)
Qed.
(* DO NOT EDIT BELOW *)

Definition subset (a:Type)(s1:(set a)) (s2:(set a)): Prop := forall (x:a),
  (mem x s1) -> (mem x s2).
Implicit Arguments subset.

(* YOU MAY EDIT THE CONTEXT BELOW *)
(*Hint Unfold subset.*)
(* DO NOT EDIT BELOW *)

Lemma subset_trans : forall (a:Type), forall (s1:(set a)) (s2:(set a))
  (s3:(set a)), (subset s1 s2) -> ((subset s2 s3) -> (subset s1 s3)).
(* YOU MAY EDIT THE PROOF BELOW *)
unfold subset; intuition.
Qed.
(* DO NOT EDIT BELOW *)

Definition empty: forall (a:Type), (set a).
(* YOU MAY EDIT THE PROOF BELOW *)
exact (fun X => mk_set X (fun _ => False)).
Defined.
(* DO NOT EDIT BELOW *)

Set Contextual Implicit.
Implicit Arguments empty.
Unset Contextual Implicit.

Definition is_empty (a:Type)(s:(set a)): Prop := forall (x:a), ~ (mem x s).
Implicit Arguments is_empty.

(* YOU MAY EDIT THE CONTEXT BELOW *)
(*Print Implicit empty.*)
(* DO NOT EDIT BELOW *)

Lemma empty_def1 : forall (a:Type), (is_empty (empty:(set a))).
(* YOU MAY EDIT THE PROOF BELOW *)
unfold is_empty; intuition.
Qed.
(* DO NOT EDIT BELOW *)

Definition add: forall (a:Type), a -> (set a) -> (set a).
(* YOU MAY EDIT THE PROOF BELOW *)
intros X x s.
destruct s.
exact (mk_set _ (fun y => P y \/ y=x)).
Defined.
(* DO NOT EDIT BELOW *)

Implicit Arguments add.

(* YOU MAY EDIT THE CONTEXT BELOW *)

(* DO NOT EDIT BELOW *)

Lemma add_def1 : forall (a:Type), forall (x:a) (y:a), forall (s:(set a)),
  (mem x (add y s)) <-> ((x = y) \/ (mem x s)).
(* YOU MAY EDIT THE PROOF BELOW *)
intros; destruct s.
unfold mem,add; intuition.
Qed.
(* DO NOT EDIT BELOW *)

Definition remove: forall (a:Type), a -> (set a) -> (set a).
(* YOU MAY EDIT THE PROOF BELOW *)
intros X x s.
destruct s.
exact (mk_set _ (fun y => y<>x /\ P y)).
Defined.
(* DO NOT EDIT BELOW *)

Implicit Arguments remove.

(* YOU MAY EDIT THE CONTEXT BELOW *)

(* DO NOT EDIT BELOW *)

Lemma remove_def1 : forall (a:Type), forall (x:a) (y:a) (s:(set a)), (mem x
  (remove y s)) <-> ((~ (x = y)) /\ (mem x s)).
(* YOU MAY EDIT THE PROOF BELOW *)
intros; destruct s.
unfold mem,remove; intuition.
Qed.
(* DO NOT EDIT BELOW *)

(* YOU MAY EDIT THE CONTEXT BELOW *)

(* DO NOT EDIT BELOW *)

Lemma subset_remove : forall (a:Type), forall (x:a) (s:(set a)),
  (subset (remove x s) s).
(* YOU MAY EDIT THE PROOF BELOW *)
intros; destruct s.
unfold subset, remove, mem; intuition.
Qed.
(* DO NOT EDIT BELOW *)

Definition union: forall (a:Type), (set a) -> (set a) -> (set a).
(* YOU MAY EDIT THE PROOF BELOW *)
intros X s1 s2.
destruct s1; destruct s2.
exact (mk_set _ (fun y => P y \/ P0 y)).
Defined.
(* DO NOT EDIT BELOW *)

Implicit Arguments union.

(* YOU MAY EDIT THE CONTEXT BELOW *)

(* DO NOT EDIT BELOW *)

Lemma union_def1 : forall (a:Type), forall (s1:(set a)) (s2:(set a)) (x:a),
  (mem x (union s1 s2)) <-> ((mem x s1) \/ (mem x s2)).
(* YOU MAY EDIT THE PROOF BELOW *)
intros; destruct s1; destruct s2.
unfold union,mem; intuition.
Qed.
(* DO NOT EDIT BELOW *)

Definition inter: forall (a:Type), (set a) -> (set a) -> (set a).
(* YOU MAY EDIT THE PROOF BELOW *)
intros X s1 s2.
destruct s1; destruct s2.
exact (mk_set _ (fun y => P y /\ P0 y)).
Defined.
(* DO NOT EDIT BELOW *)

Implicit Arguments inter.

(* YOU MAY EDIT THE CONTEXT BELOW *)

(* DO NOT EDIT BELOW *)

Lemma inter_def1 : forall (a:Type), forall (s1:(set a)) (s2:(set a)) (x:a),
  (mem x (inter s1 s2)) <-> ((mem x s1) /\ (mem x s2)).
(* YOU MAY EDIT THE PROOF BELOW *)
intros; destruct s1; destruct s2.
unfold inter, mem; intuition.
Qed.
(* DO NOT EDIT BELOW *)

Definition diff: forall (a:Type), (set a) -> (set a) -> (set a).
(* YOU MAY EDIT THE PROOF BELOW *)
intros X s1 s2.
destruct s1; destruct s2.
exact (mk_set _ (fun y => P y /\ ~(P0 y))).
Defined.
(* DO NOT EDIT BELOW *)

Implicit Arguments diff.

(* YOU MAY EDIT THE CONTEXT BELOW *)

(* DO NOT EDIT BELOW *)

Lemma diff_def1 : forall (a:Type), forall (s1:(set a)) (s2:(set a)) (x:a),
  (mem x (diff s1 s2)) <-> ((mem x s1) /\ ~ (mem x s2)).
(* YOU MAY EDIT THE PROOF BELOW *)
intros; destruct s1; destruct s2.
unfold diff, mem; intuition.
Qed.
(* DO NOT EDIT BELOW *)

(* YOU MAY EDIT THE CONTEXT BELOW *)

(* DO NOT EDIT BELOW *)

Lemma subset_diff : forall (a:Type), forall (s1:(set a)) (s2:(set a)),
  (subset (diff s1 s2) s1).
(* YOU MAY EDIT THE PROOF BELOW *)
intros; destruct s1; destruct s2.
unfold subset, diff, mem; intuition.
Qed.
(* DO NOT EDIT BELOW *)


(************************************************************************)
(*         *   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)         *)
(************************************************************************)

Require Import Zpow_facts Qfield Qreduction.

Lemma Qpower_positive_1 : forall n, Qpower_positive 1 n == 1.
Proof.
induction n;
simpl; try rewrite IHn; reflexivity.
Qed.

Lemma Qpower_1 : forall n, 1^n == 1.
Proof.
  intros [|n|n]; simpl; try rewrite Qpower_positive_1; reflexivity.
Qed.

Lemma Qpower_positive_0 : forall n, Qpower_positive 0 n == 0.
Proof.
induction n;
simpl; try rewrite IHn; reflexivity.
Qed.

Lemma Qpower_0 : forall n, (n<>0)%Z -> 0^n == 0.
Proof.
  intros [|n|n] Hn; try (elim Hn; reflexivity); simpl;
  rewrite Qpower_positive_0; reflexivity.
Qed.

Lemma Qpower_not_0_positive : forall a n, ~a==0 -> ~Qpower_positive a n == 0.
Proof.
intros a n X H.
apply X; clear X.
induction n; simpl in *; try assumption;
destruct (Qmult_integral _ _ H);
try destruct (Qmult_integral _ _ H0); auto.
Qed.

Lemma Qpower_pos_positive : forall p n, 0 <= p -> 0 <= Qpower_positive p n.
Proof.
intros p n Hp.
induction n; simpl; repeat apply Qmult_le_0_compat;assumption.
Qed.

Lemma Qpower_pos : forall p n, 0 <= p -> 0 <= p^n.
Proof.
  intros p [|n|n] Hp; simpl; try discriminate;
  try apply Qinv_le_0_compat;  apply Qpower_pos_positive; assumption.
Qed.

Lemma Qmult_power_positive  : forall a b n, Qpower_positive (a*b) n == (Qpower_positive a n)*(Qpower_positive b n).
Proof.
induction n;
simpl; repeat rewrite IHn; ring.
Qed.

Lemma Qmult_power : forall a b n, (a*b)^n == a^n*b^n.
Proof.
  intros a b [|n|n]; simpl;
  try rewrite Qmult_power_positive;
  try rewrite Qinv_mult_distr;
  reflexivity.
Qed.

Lemma Qinv_power_positive  : forall a n, Qpower_positive (/a) n == /(Qpower_positive a n).
Proof.
induction n;
simpl; repeat (rewrite IHn || rewrite Qinv_mult_distr); reflexivity.
Qed.

Lemma Qinv_power : forall a n, (/a)^n == /a^n.
Proof.
  intros a [|n|n]; simpl;
  try rewrite Qinv_power_positive;
  reflexivity.
Qed.

Lemma Qdiv_power : forall a b n, (a/b)^n == (a^n/b^n).
Proof.
unfold Qdiv.
intros a b n.
rewrite Qmult_power.
rewrite Qinv_power.
reflexivity.
Qed.

Lemma Qinv_power_n : forall n p, (1#p)^n == /(inject_Z (Zpos p))^n.
Proof.
intros n p.
rewrite Qmake_Qdiv.
rewrite Qdiv_power.
rewrite Qpower_1.
unfold Qdiv.
ring.
Qed.

Lemma Qpower_plus_positive : forall a n m, Qpower_positive a (n+m) == (Qpower_positive a n)*(Qpower_positive a m).
Proof.
intros a n m.
unfold Qpower_positive.
apply pow_pos_add.
apply Q_Setoid.
apply Qmult_comp.
apply Qmult_assoc.
Qed.

Lemma Qpower_opp : forall a n, a^(-n) == /a^n.
Proof.
intros a [|n|n]; simpl; try reflexivity.
symmetry; apply Qinv_involutive.
Qed.

Lemma Qpower_minus_positive : forall a (n m:positive),
  (m < n)%positive ->
  Qpower_positive a (n-m)%positive == (Qpower_positive a n)/(Qpower_positive a m).
Proof.
intros a n m H.
destruct (Qeq_dec a 0) as [EQ|NEQ].
- now rewrite EQ, !Qpower_positive_0.
- rewrite <- (Qdiv_mult_l (Qpower_positive a (n - m)) (Qpower_positive a m)) by
   (now apply Qpower_not_0_positive).
  f_equiv.
  rewrite <- Qpower_plus_positive.
  now rewrite Pos.sub_add.
Qed.

Lemma Qpower_plus : forall a n m, ~a==0 -> a^(n+m) == a^n*a^m.
Proof.
intros a [|n|n] [|m|m] H; simpl; try ring;
try rewrite Qpower_plus_positive;
try apply Qinv_mult_distr; try reflexivity;
rewrite ?Z.pos_sub_spec;
case Pos.compare_spec; intros H0; simpl; subst;
 try rewrite Qpower_minus_positive;
 try (field; try split; apply Qpower_not_0_positive);
 assumption.
Qed.

Lemma Qpower_plus' : forall a n m, (n+m <> 0)%Z -> a^(n+m) == a^n*a^m.
Proof.
intros a n m H.
destruct (Qeq_dec a 0)as [X|X].
rewrite X.
rewrite Qpower_0 by assumption.
destruct n; destruct m; try (elim H; reflexivity);
 simpl; repeat rewrite Qpower_positive_0; ring_simplify;
 reflexivity.
apply Qpower_plus.
assumption.
Qed.

Lemma Qpower_mult_positive : forall a n m,
  Qpower_positive a (n*m) == Qpower_positive (Qpower_positive a n) m.
Proof.
intros a n m.
induction n using Pos.peano_ind.
 reflexivity.
rewrite Pos.mul_succ_l.
rewrite <- Pos.add_1_l.
do 2 rewrite Qpower_plus_positive.
rewrite IHn.
rewrite Qmult_power_positive.
reflexivity.
Qed.

Lemma Qpower_mult : forall a n m, a^(n*m) ==  (a^n)^m.
Proof.
intros a [|n|n] [|m|m]; simpl;
 try rewrite Qpower_positive_1;
 try rewrite Qpower_mult_positive;
 try rewrite Qinv_power_positive;
 try rewrite Qinv_involutive;
 try reflexivity.
Qed.

Lemma Zpower_Qpower : forall (a n:Z), (0<=n)%Z -> inject_Z (a^n) == (inject_Z a)^n.
Proof.
intros a [|n|n] H;[reflexivity| |elim H; reflexivity].
induction n using Pos.peano_ind.
 replace (a^1)%Z with a by ring.
 ring.
rewrite Pos2Z.inj_succ.
unfold Z.succ.
rewrite Zpower_exp; auto with *; try discriminate.
rewrite Qpower_plus' by discriminate.
rewrite <- IHn by discriminate.
replace (a^Zpos n*a^1)%Z with (a^Zpos n*a)%Z by ring.
ring_simplify.
reflexivity.
Qed.

Lemma Qsqr_nonneg : forall a, 0 <= a^2.
Proof.
intros a.
destruct (Qlt_le_dec 0 a) as [A|A].
apply (Qmult_le_0_compat a a);
 (apply Qlt_le_weak; assumption).
setoid_replace (a^2) with ((-a)*(-a)) by ring.
rewrite Qle_minus_iff in A.
setoid_replace (0+ - a) with (-a) in A by ring.
apply Qmult_le_0_compat; assumption.
Qed.

Theorem Qpower_decomp p x y :
  Qpower_positive (x#y) p = x ^ Zpos p # (y ^ p).
Proof.
induction p; intros; simpl Qpower_positive; rewrite ?IHp.
- (* xI *)
  unfold Qmult, Qnum, Qden. f_equal.
  + now rewrite <- Z.pow_twice_r, <- Z.pow_succ_r.
  + apply Pos2Z.inj; rewrite !Pos2Z.inj_mul, !Pos2Z.inj_pow.
    now rewrite <- Z.pow_twice_r, <- Z.pow_succ_r.
- (* xO *)
  unfold Qmult, Qnum, Qden. f_equal.
  + now rewrite <- Z.pow_twice_r.
  + apply Pos2Z.inj; rewrite !Pos2Z.inj_mul, !Pos2Z.inj_pow.
    now rewrite <- Z.pow_twice_r.
- (* xO *)
  now rewrite Z.pow_1_r, Pos.pow_1_r.
Qed.


Require Reals.
Require Raxiom.
Require Import ZArith.

(* Realisation of Raxioms thanks to the standard library of Coq *)

Module RD := Coq.Reals.Rdefinitions.
Module RA := Coq.Reals.Raxioms.
Module RI := Coq.Reals.RIneq.

Module Rimpl <: Raxiom.CReals.

  Definition R := RD.R.
  Definition R0 := RD.R0.
  Definition R1 := RD.R1.
  Definition Radd := RD.Rplus.
  Definition Rmul := RD.Rmult.
  Definition Ropp := RD.Ropp.
  Definition Rsub := RD.Rminus.
  Definition Rlt := RD.Rlt.

  Definition Rgt (r1 r2 : R) := Rlt r2 r1.
  Definition Rdiscr (r1 r2 : R) := sum (Rlt r1 r2) (Rlt r2 r1).
  Definition Req (r1 r2 : R) := Rdiscr r1 r2 -> False.
  Definition Rle (r1 r2 : R) := sumor (Rlt r1 r2) (Req r1 r2).
  Definition Rge (r1 r2 : R) := Rle r2 r1.

  Definition Rdiv x y (_ : Rdiscr y R0) := RD.Rdiv x y.

  Definition Rinv (x : R) (_ : Rdiscr x R0) := RD.Rinv x.

  Definition Rlt_trans := Coq.Reals.Raxioms.Rlt_trans.
  Definition Rlt_asym : forall r1 r2 : R, Rlt r1 r2 -> Rlt r2 r1 -> False.
  Proof.
    intros a b Hab Hba.
    apply (RIneq.Rlt_not_le a b Hba).
    apply (RIneq.Rlt_le _ _ Hab).
  Defined.

  Lemma Req_refl : forall x, Req x x.
  Proof.
    intros x [H|H]; eapply (Rlt_asym _ _); apply H.
  Qed.

  Lemma eq_Req : forall {a b}, eq a b -> Req a b.
  Proof.
    intros a b Hab; subst; apply Req_refl.
  Qed.

  Lemma Req_eq : forall {a b}, Req a b -> eq a b.
  Proof.
    intros a b Hab.
    apply RIneq.Rle_antisym; apply RIneq.Rnot_lt_le;
      intro; destruct Hab; compute; intuition.
  Qed.

  Lemma Rdiscr_neq : forall {a b}, Rdiscr a b -> a <> b.
  Proof.
    intros a b [Lab|Lba]; apply RI.Rlt_dichotomy_converse; eauto.
  Qed.

  Lemma neq_Rdiscr : forall {a b}, a <> b -> Rdiscr a b.
  Proof.
    intros a b Nab.
    destruct (RD.total_order_T a b) as [[|]|].
     left; assumption.
     elimtype False; auto.
     right; auto.
  Qed.

  Ltac fold_Req := repeat (match goal with H : Req ?a ?b |- _ => apply Req_eq in H end).

  (** Congruences **)
  Definition Req_lt_compat_l : forall x1 x2 y : R, Req x1 x2 -> Rlt x1 y -> Rlt x2 y.
  Proof.
    intros; fold_Req.
    fold_Req.
    subst; auto.
  Qed.

  Definition Req_lt_compat_r : forall x1 x2 y : R, Req x1 x2 -> Rlt y x1 -> Rlt y x2.
  Proof.
    intros; fold_Req.
    subst; auto.
  Qed.

  Definition Radd_lt_compat_l := RA.Rplus_lt_compat_l.

  Definition Radd_eq_compat_l : forall x y1 y2, Req y1 y2 -> Req (Radd x y1) (Radd x y2).
  Proof.
    intros; fold_Req.
    subst.
    intros [H|H]; eapply (Rlt_asym _ _); apply H.
  Qed.

  Definition Rmul_lt_compat_l := RA.Rmult_lt_compat_l.

  Definition Rmul_eq_compat_l : forall x y1 y2, Req y1 y2 -> Req (Rmul x y1) (Rmul x y2).
  Proof.
    intros; fold_Req.
    subst.
    intros [H|H]; eapply (Rlt_asym _ _); apply H.
  Qed.

  Definition Rinv_0_lt_compat : forall (x : R) (pr : Rlt R0 x) (pr' : Rdiscr x R0), Rlt R0 (Rinv x pr').
  Proof.
    unfold Rinv, Rlt.
    intros.
    apply RI.Rinv_0_lt_compat.
    auto.
  Qed.

  (** Ring operations **)
  Definition Radd_comm : forall a b, Req (Radd a b) (Radd b a).
  Proof.
    intros; apply eq_Req, RA.Rplus_comm.
  Qed.

  Definition Radd_assoc : forall x y z, Req (Radd (Radd x y) z) (Radd x (Radd y z)).
  Proof.
    intros; apply eq_Req, RA.Rplus_assoc.
  Qed.

  Definition Radd_opp_r : forall x, Req (Radd x (Ropp x)) R0.
  Proof.
    intros; apply eq_Req, RA.Rplus_opp_r.
  Qed.

  Definition Radd_0_l : forall x, Req (Radd R0 x) x.
  Proof.
    intros; apply eq_Req, RA.Rplus_0_l.
  Qed.

  Definition Rmul_add_distr_l a b c : Req (Rmul a (Radd b c)) (Radd (Rmul a b) (Rmul a c)).
  Proof.
    intros; apply eq_Req, RA.Rmult_plus_distr_l.
  Qed.

  Definition Rmul_comm : forall a b, Req (Rmul a b) (Rmul b a).
  Proof.
    intros; apply eq_Req, RA.Rmult_comm.
  Qed.

  Definition Rmul_assoc : forall x y z, Req (Rmul (Rmul x y) z) (Rmul x (Rmul y z)).
  Proof.
    intros; apply eq_Req, RA.Rmult_assoc.
  Qed.

  Definition Rmul_1_l : forall x, Req (Rmul R1 x) x.
  Proof.
    intros; apply eq_Req, RA.Rmult_1_l.
  Qed.

  (** Constructive field operation **)
  Definition Rinv_l : forall (x : R) (pr : Rdiscr x R0), Req (Rmul (Rinv x pr) x) R1.
  Proof.
    intros.
    apply eq_Req.
    apply RA.Rinv_l.
    apply Rdiscr_neq.
    apply pr.
  Qed.

  (** Ordered Field **)
  Definition Rlt_0_1 : Rlt R0 R1.
  Proof.
    apply RI.Rlt_0_1.
  Qed.

  (** * Archimedean **)

  (** Injection from Z to R **)
  Fixpoint IPR (p : positive) : R :=
    match p with
      | xI p => Radd (Rmul (Radd R1 R1) (IPR p)) R1
      | xO p => Rmul (Radd R1 R1) (IPR p)
      | xH => R1
    end.

  Definition IZR (z : Z) : R :=
    match z with
      | Z0 => R0
      | Zpos p => IPR p
      | Zneg p => Ropp (IPR p)
    end.

  Definition Rdist x y d : Type := prod (Rlt (Rsub x y) d) (Rlt (Ropp d) (Rsub x y)).

  (** Getting back to Z **)

  Definition Rup : R -> Z.
  Proof.
    exact Coq.Reals.R_Ifp.Int_part.
  Defined.

  Lemma IPR_2_same : forall p, RD.IPR_2 p = Rmul (Radd R1 R1) (IPR p).
  Proof.
    intros p.
    induction p; simpl.
      rewrite IHp, (RA.Rplus_comm RD.R1 (RD.Rmult _ _)); auto.
      rewrite IHp; auto.
      rewrite <-RI.Rmult_1_r at 1; auto.
  Qed.

  Lemma IPR_same : forall p, RD.IPR p = IPR p.
  Proof.
    intros []; auto.
      change (RD.Rplus RD.R1 (RD.IPR_2 p) = IPR p~1). rewrite IPR_2_same, RA.Rplus_comm. auto.
      change (RD.IPR_2 p = IPR p~0). rewrite IPR_2_same. auto.
  Qed.

  Lemma IZR_same : forall z, RD.IZR z = IZR z.
  Proof.
    destruct z; auto.
      apply IPR_same.
      change (RD.Ropp (RD.IPR p) = Ropp (IPR p)). rewrite IPR_same. auto.
  Qed.

  Lemma Rup_spec : forall r : R, Rdist r (IZR (Rup r)) R1.
  Proof.
    intros r.
    destruct (Coq.Reals.R_Ifp.base_Int_part r) as (Ir, Ur).
    rewrite IZR_same in *.
    unfold Rup, Rdist, Rsub, R1, Rlt.
    remember (R_Ifp.Int_part r) as z.
    split; [clear Ir|clear Ur].
     apply RI.Ropp_lt_cancel, RI.Rgt_lt.
     refine (RI.Rlt_eq_compat _ _ _ _ _ Ur _).
      reflexivity.
      rewrite RI.Ropp_minus_distr; auto.
     apply RI.Rlt_le_trans with RD.R0.
      apply RI.Ropp_lt_gt_0_contravar, Rlt_0_1.
      eapply RI.Rle_trans.
       apply RI.Req_le.
       symmetry.
       apply (RA.Rplus_opp_r (IZR z)).

       apply (RI.Rplus_le_compat_r (RD.Ropp (IZR z)) _ _ Ir).
  Qed.

  (** * Completeness **)

  Definition Rseq_Cauchy (Un : nat -> R) : Type := forall eps, Rlt R0 eps ->
    {N : nat & forall p q, (N <= p)%nat -> (N <= q)%nat -> Rdist (Un p) (Un q) eps}.

  Definition Rseq_cv (Un : nat -> R) (l : R) : Type := forall eps, Rlt R0 eps ->
    {N : nat & forall n, (N <= n)%nat -> Rdist (Un n) l eps}.

  Lemma R_dist : forall a b x, RD.Rlt (Rfunctions.R_dist a b) x -> Rdist a b x.
  Proof.
  intros.
  unfold Rdist. unfold Rfunctions.R_dist in H.
  destruct (RD.total_order_T (Rdefinitions.Rminus a b) R0) as [[H1 | H1] | H1].
  rewrite Rbasic_fun.Rabs_left in H; try assumption.
  split. unfold Rsub.
  destruct (RD.total_order_T x R0) as [[H2 | H2] | H2]; intuition.
  apply RA.Rlt_trans with (Rdefinitions.Ropp (Rdefinitions.Rminus a b)).
  apply RA.Rlt_trans with R0. apply H1.
  intuition.
  apply H.
  rewrite H2. apply H1.
  apply RA.Rlt_trans with R0; intuition.
  rewrite <- RI.Ropp_involutive. apply RI.Ropp_lt_contravar.
  assumption.
  unfold Rsub. rewrite H1 in *. unfold R0 in H.
  change RD.R0 with (RD.IZR Z0) in H. rewrite Rbasic_fun.Rabs_R0 in H.
  split. apply H. apply RI.Ropp_lt_gt_0_contravar. intuition.

  rewrite Rbasic_fun.Rabs_right in H; intuition.
  destruct (RD.total_order_T x R0) as [[H2 | H2] | H2].
  assert (RD.Rlt x x). apply RA.Rlt_trans with ((Rdefinitions.Rminus a b)).
  apply RA.Rlt_trans with R0; intuition.
  intuition.
  apply RI.Rlt_irrefl in H0. destruct H0.
  subst. unfold R0. unfold Ropp.
  change RD.R0 with (RD.IZR Z0). rewrite RI.Ropp_0. assumption.

  apply RA.Rlt_trans with R0. intuition.
  intuition.
  Qed.

  Lemma Rcomplete : forall Un, Rseq_Cauchy Un -> {l : R & Rseq_cv Un l}.
  Proof.
    intros u Hu.
    destruct (Coq.Reals.Rcomplete.R_complete u) as (l, Hl).
    intros eps Heps. specialize (Hu eps Heps).
    destruct Hu as (N, Hu). exists N.
    intros. specialize (Hu n m H H0). destruct Hu as (Hu1, Hu2).
    unfold Rfunctions.R_dist. unfold Rbasic_fun.Rabs.
    destruct (Rbasic_fun.Rcase_abs (Rdefinitions.Rminus (u n) (u m))).
    rewrite <- (RI.Ropp_involutive eps). apply RI.Ropp_gt_lt_contravar.
    apply Hu2.
    apply Hu1.
     (* montrer que le critère ci-dessus implique celui de la stdlib (proof ci dessus) *)

(* TODO preuve = disjonction sur le total_order puis preuve directe ou preuve de False *)
     exists l.
     intros eps Heps.
     assert (Heps2 : Rlt R0 (RD.Rdiv eps (Radd R1 R1) )).
     unfold Rlt. apply RI.Rmult_lt_0_compat. apply Heps.
     apply RI.Rinv_0_lt_compat. intuition.
     specialize (Hu (RD.Rdiv eps (Radd R1 R1)) Heps2).
     destruct Hu as (N, Hu).
     exists N. intros. specialize (Hl (RD.Rdiv eps (Radd R1 R1)) Heps2).
     destruct (RD.total_order_T eps (Rbasic_fun.Rabs (Rsub (u n) l))) as [H3 | H3].
     assert (H4 : RD.Rle eps (Rbasic_fun.Rabs (Rsub (u n) l))).
     destruct H3. intuition.
     rewrite <- e. intuition.
     assert False. destruct Hl as (N0, Hl0).
     pose (n_spe := (Max.max N N0)).
     assert (n_spe_t : n_spe >= N0). apply Max.le_max_r.
     specialize (Hl0 n_spe n_spe_t).
     assert (Rlt eps eps).
     apply RI.Rle_lt_trans with (Rbasic_fun.Rabs (Rsub (u n) l)).
     apply H4.
     replace (Rsub (u n) l) with (Radd (Rsub (u n) (u n_spe)) (Rsub (u n_spe) l)).

     apply RI.Rle_lt_trans with (Radd (Rbasic_fun.Rabs (Rsub (u n) (u n_spe))) (Rbasic_fun.Rabs (Rsub (u n_spe) l))).
     apply Rbasic_fun.Rabs_triang.
     replace eps with (Radd (RD.Rdiv eps (Radd R1 R1)) (RD.Rdiv eps (Radd R1 R1))).
     unfold Radd. apply RI.Rplus_lt_compat.
     assert (n_spe_r : n_spe >= N). apply Max.le_max_l.
     specialize (Hu n n_spe H n_spe_r). unfold Rdist in Hu.
     destruct Hu as (Hu1, Hu2).
     unfold Rlt in Hu1, Hu2.
     unfold Rbasic_fun.Rabs. destruct (Rbasic_fun.Rcase_abs (Rsub (u n) (u n_spe))).
     rewrite <- RI.Ropp_involutive. apply RI.Ropp_gt_lt_contravar. apply Hu2.
     apply Hu1.
     apply Hl0.

     unfold Radd, Rsub. unfold RD.Rdiv. rewrite <- RA.Rmult_plus_distr_l.
     replace (Rdefinitions.Rplus (RD.Rinv (RD.Rplus R1 R1)) (RD.Rinv (RD.Rplus R1 R1))) with
     (RD.Rmult (RD.Rplus R1 R1) (RD.Rinv (RD.Rplus R1 R1))).
     rewrite (RA.Rmult_comm (RD.Rplus _ _) _). rewrite RA.Rinv_l. intuition.
     assert (RD.Rlt R0 (RD.Rplus R1 R1)). change R0 with (RD.IZR Z0). intuition. intro. unfold R0 in *.
     change RD.R0 with (RD.IZR Z0)in H0. rewrite <- H1 in H0. apply RI.Rlt_irrefl in H0.
     destruct H0.
     apply RI.double.

     unfold Radd, Rsub. unfold RD.Rminus. rewrite RA.Rplus_assoc.
     replace (Rdefinitions.Rplus (RD.Ropp (u n_spe)) (RD.Rplus (u n_spe) (RD.Ropp l))) with (RD.Ropp l).
     reflexivity.
     rewrite <- RA.Rplus_assoc. rewrite RI.Rplus_opp_l. intuition.
     apply RI.Rlt_irrefl in H0. apply H0.
     destruct H0.
     apply R_dist. apply H3.
  Qed.

End Rimpl.


(* ----------------------------------------------------------------- *)
(*                       Topological Spaces                          *)
(*                                                                   *)
(*  Based on Topology textbook by Munkres.                           *)
(* ----------------------------------------------------------------- *)

From Practice Require Import Basin.Base.
From Practice Require Import Basin.ElemAlg.
From Practice Require Import Basin.ClassicalSets.
From Practice Require Import Basin.ClSetLists.
Import List.
Import ListNotations.

(* Topology-like structure over type X *)
Record Topolike X (F: Powerset X -> Prop) := mkTopo{
  opens: Powerset X
; topo_proper: ProperSet opens
; topo_cond: F opens
}.

Arguments mkTopo {X F}.
Arguments opens {X F}.
Arguments topo_proper {X F}.
Arguments topo_cond {X F}.

Property mkTopo_spec: forall X (F: Powerset X -> Prop) (C: Powerset X),
  ProperSet C -> F C -> exists T: Topolike X F, opens T = C.
Proof. intros * HP HC. exists (mkTopo C HP HC). reflexivity. Qed.

Program Instance setoid_topo X F: Setoid (Topolike X F) := {
  equiv := (fun T T' => opens T == opens T')
}.
Next Obligation. firstorder. Qed.

Instance proper_opens X F (T: Topolike X F): ProperSet (opens(T)).
Proof. apply topo_proper. Qed.

(* Closed sets: all those where its complement is open *)
Definition closes {X F} (T: Topolike X F): Powerset X :=
  mkSet (fun E => ~! E :in: opens(T)).

Instance proper_closes X F (T: Topolike X F): ProperSet (closes(T)).
Proof. intros ? **. unfold closes, InSet. rw_refl. Qed.

Notation "'open' [ T ]" := (InSet (opens T))
  (format "'open' [ T ]").
Notation "'closed' [ T ]" := (InSet (closes T))
  (format "'closed' [ T ]").

Record isTopology {X} (opens: Powerset X): Prop := {
  union_open: forall M: Powerset X,
    M <:= opens -> Unions M :in: opens
; intersect_open: forall L: list (ESet X),
    Forall (InSet opens) L -> MCat Intersect L :in: opens
}.
Definition Topology X := Topolike X isTopology.
Arguments union_open {X} {opens}.
Arguments intersect_open {X} {opens}.

Definition covers {X} (V: ESet X) (C: Powerset X): Prop :=
  V <:= Unions C.
Notation cover_all := (covers FullSet).

(* ----------------------------------------------------------------- *)
(*                       General Properties                          *)
(* ----------------------------------------------------------------- *)

Section Topo.
Context {X:Type} (T: Topology X).

(* Property of open sets *)
Property unions_is_open: forall M: Powerset X,
  ForallIn M (open[T]) -> open[T] (Unions M).
Proof. apply union_open, topo_cond. Qed.

Property intersects_is_open: forall L: list (ESet X),
  Forall (open[T]) L -> open[T] (MCat Intersect L).
Proof. apply intersect_open, topo_cond. Qed.

Property empty_is_open: open[T] EmptySet.
Proof. rewrite <- unions_empty.
  apply unions_is_open. intros ? []. Qed.

Property full_is_open: open[T] FullSet.
Proof. replace (@FullSet X) with (MCat (@Intersect X) []) by reflexivity.
  apply intersects_is_open. trivial. Qed.

Lemma union_is_open: forall U V: ESet X,
  open[T] U -> open[T] V -> open[T] (U \\// V).
Proof. intros.
  rewrite <- unions_couple. apply unions_is_open.
  intros ? [K|K]; do 2 red in K; rewrite <- K; auto.
Qed.

Lemma intersect_is_open: forall U V: ESet X,
  open[T] U -> open[T] V -> open[T] (U //\\ V).
Proof. intros.
  rewrite <- mcat_couple. apply intersects_is_open.
  repeat constructor; auto.
Qed.

Lemma unionover_is_open: forall I (P: ESet I) (F: I -> ESet X),
  ForallIn P (fun i => open[T] (F i)) -> open[T] (unions i in P, F i).
Proof. intros * H. apply unions_is_open.
  intros _ (i & ? & ->). apply H. trivial. Qed.

Lemma intersectover_is_open: forall I (L: list I) (F: I -> ESet X),
  Forall (fun i => open[T] (F i)) L -> open[T] (MCatOver Intersect F L).
Proof. intros * H. apply intersects_is_open.
  rewrite Forall_forall in *.
  intros _ (i & <- & ?)%in_map_iff. apply H. trivial. Qed.

(* Property of closed sets *)
Property intersects_is_closed: forall M: Powerset X,
  ForallIn M (closed[T]) -> closed[T] (Intersects M).
Proof. intros. do 3 red.
  rewrite intersects_as_over, intersectover_compl.
  apply unionover_is_open. trivial. Qed.

Property unions_is_closed: forall L: list (ESet X),
  Forall (closed[T]) L -> closed[T] (MCat Union L).
Proof. intros. do 2 red.
  rewrite cat_unions_as_unionover, cat_unionover_compl.
  apply intersectover_is_open. trivial. Qed.

Property empty_is_closed: closed[T] EmptySet.
Proof. do 3 red. rewrite empty_compl. apply full_is_open. Qed.

Property full_is_closed: closed[T] FullSet.
Proof. do 3 red. rewrite full_compl. apply empty_is_open. Qed.

Lemma intersect_is_closed: forall U V: ESet X,
  closed[T] U -> closed[T] V -> closed[T] (U //\\ V).
Proof. intros. do 2 red. rewrite intersect_compl.
  apply union_is_open; trivial. Qed.

Lemma union_is_closed: forall U V: ESet X,
  closed[T] U -> closed[T] V -> closed[T] (U \\// V).
Proof. intros. do 2 red. rewrite union_compl.
  apply intersect_is_open; trivial. Qed.

Lemma intersectover_is_closed: forall I (P: ESet I) (F: I -> ESet X),
  ForallIn P (fun i => closed[T] (F i)) -> closed[T] (intersects i in P, F i).
Proof. intros * H. apply intersects_is_closed.
  intros _ (i & ? & ->). apply H. trivial. Qed.

Lemma unionover_is_closed: forall I (L: list I) (F: I -> ESet X),
  Forall (fun i => closed[T] (F i)) L -> closed[T] (MCatOver Union F L).
Proof. intros * H. apply unions_is_closed.
  rewrite Forall_forall in *.
  intros _ (i & <- & ?)%in_map_iff. apply H. trivial. Qed.

End Topo.

(* ----------------------------------------------------------------- *)
(*                         Topology Basis                            *)
(* ----------------------------------------------------------------- *)

Record isBase {X} (opens: Powerset X): Type := {
  bopen_cover: exists (C: Powerset X), C <:= opens /\ cover_all C
; inter_refine_open: forall (U V: ESet X) x,
  U :in: opens -> V :in: opens -> x :in: U //\\ V ->
  exists W, W :in: opens /\ x :in: W /\ (W <:= U //\\ V)
}.
Definition Basis X := Topolike X isBase.
Arguments bopen_cover {X} {opens}.
Arguments inter_refine_open {X} {opens}.

Definition Subbasis X := Topolike X (const True).

Section Base.
Context {X:Type}.

Property topology_is_base (T: Topology X): isBase (opens(T)).
Proof with (auto with sets). split.
  - unfold covers. exists (opens(T)). split... apply unions_inc_one, full_is_open.
  - intros. exists (U //\\ V). split... apply intersect_is_open...
Qed.

(* Generation *)
Program Definition topoFromBase (B: Powerset X): Powerset X :=
  mkSet (fun U => forall x, x :in: U ->
    ExistsIn B (fun V => x :in: V /\ V <:= U)).

Global Instance proper_topoFromBase (B: Powerset X): ProperSet (topoFromBase B).
Proof. intros ? **. unfold topoFromBase, ExistsIn. rewrite mkSet_In. rw_refl. Qed.

Lemma base_is_open: forall B, B <:= topoFromBase B.
Proof. firstorder. Qed.

Proposition generate_by_base (B: Basis X): isTopology (topoFromBase (opens B)).
Proof with firstorder.
  unfold topoFromBase. split; rewrite mkSet_In.
  - (* Unions *)
    intros ? H ? (U & I1 & I2)%unions_iff.
    specialize (H _ I1 _ I2)...
  - (* Intersects *)
    intros ? H ?. pose proof (topo_cond B) as (HC & HR).
    apply mcat_ind.
    + (* Full set *)
      destruct HC as (C & HI & HC).
      intros (U & HU & Hx) %HC %unions_iff...
    + (* Intersect-2 *)
      intros U V HU HV ([S (HU1 & HU2 & HU3)]%HU & [T (HV1 & HV2 & HV3)]%HV).
      destruct (HR _ _ x HU1 HV1) as [W (H1 & H2 & H3)]...
    + clear HC HR. rewrite Forall_forall in *...
Qed.

Lemma open_iff_base_unions: forall (B: Basis X),
  topoFromBase (opens B) == {' Unions F | F in PsetOn (opens B) '}.
Proof with firstorder.
  intros ? U. split.
  - (* <:= *)
    intros H.
    exists (unions x in U,
      mkSet(fun S => S :in: opens(B) /\ x :in: S /\ S <:= U)). split.
    + do 4 red...
    + rewrite unions_unionover. apply same_inc_iff. split.
      * intros x Hx. apply unionover_iff...
      * apply inc_forall_unionover_iff...
  - (* =:> *)
    intros [F (? & ->)]. do 4 red in H.
    apply (union_open (generate_by_base B))...
Qed.

Definition baseFromSubbase (S: Powerset X): Powerset X :=
  {' MCat Intersect L | L in ForallSet S '}.

Lemma subbase_is_base_open: forall S, S <:= baseFromSubbase S.
Proof. intros ? B ?. exists [B]. firstorder. simpl. repeat constructor. auto. Qed.

Lemma subbase_is_open: forall S, S <:= topoFromBase (baseFromSubbase S).
Proof. etransitivity. apply subbase_is_base_open. apply base_is_open. Qed.

Proposition generate_by_subbase (S: Subbasis X): isBase (baseFromSubbase (opens S)).
Proof with (auto with sets alg).
  split.
  - (* Covers *)
    unfold covers. exists {{FullSet}}. split...
    intros U <-%singleton_iff. exists []. split... simpl...
  - (* Intersects *)
    intros ? ? ? [LU (AU & EU)] [LV (AV & EV)] HI.
    exists (U //\\ V). split... apply im_iff.
    exists (LU ++ LV). split; [ apply Forall_app | ]...
    rewrite EU, EV...
Qed.

Program Definition topoByBase (B: Basis X): Topology X := mkTopo (topoFromBase (opens B)) _ _.
Next Obligation. apply generate_by_base. Qed.

Program Definition baseBySubbase (S: Subbasis X): Basis X := mkTopo (baseFromSubbase (opens S)) _ _.
Next Obligation. apply generate_by_subbase. Qed.

(*  Denotes is that certain powerset serves as a base of the topology *)
Definition isBaseOf (C: Powerset X) (T: Topology X): Prop :=
  exists B: Basis X, opens(B) = C /\ topoByBase B == T.
Definition isSubbaseOf (C: Powerset X) (T: Topology X): Prop :=
  exists S: Subbasis X, opens(S) = C /\ topoByBase (baseBySubbase S) == T.

Property isBase_then_generate: forall C T,
  isBaseOf C T -> topoFromBase C == opens(T).
Proof. intros * (? & <- & ?). trivial. Qed.

Property isSubbase_then_generate: forall C T,
  isSubbaseOf C T -> topoFromBase (baseFromSubbase C) == opens(T).
Proof. intros * (? & <- & ?). trivial. Qed.

(* Topology generated by Basis / Subbasis is minimal -> so it is unique *)
Lemma basis_gen_minimal: forall (B: Basis X) (T: Topology X),
  opens(B) <:= opens(T) -> opens(topoByBase B) <:= opens(T).
Proof.
  intros **. unfold topoByBase. simpl.
  rewrite open_iff_base_unions. intros U [F (H0 & ->)].
  apply unions_is_open. firstorder.
Qed.

Lemma subbasis_gen_minimal: forall (S: Subbasis X) (T: Topology X),
  opens(S) <:= opens(T) -> opens(topoByBase (baseBySubbase S)) <:= opens(T).
Proof.
  intros **. apply basis_gen_minimal.
  unfold baseBySubbase. simpl. intros U [L (H1 & ->)].
  apply intersects_is_open. simpl in H1.
  rewrite Forall_forall in *. firstorder.
Qed.

Lemma identify_base: forall (T: Topology X) (C: Powerset X) `(@ProperSet _ (setoid_set _) C),
  C <:= opens(T) ->
  ForallIn (opens T) (fun U =>
    forall x, x :in: U -> ExistsIn C (fun V => x :in: V /\ V <:= U)) ->
  isBaseOf C T.
Proof with (auto with sets).
  intros * HP HI H. destruct (mkTopo_spec _ isBase C) as [B ?].
  - apply HP.
  - (* Is Basis *) split.
    + (* Cover *)
      exists C. split... unfold cover_all.
      intros x [V (? & ? & ?)]%H. firstorder.
      apply full_is_open.
    + (* Intersection *)
      intros * HU%HI HV%HI IN.
      apply H... apply intersect_is_open...
  - (* Generates *)
    exists B. split; subst... apply same_inc_iff. simpl.
    split... apply basis_gen_minimal...
Qed.

End Base.

(* ----------------------------------------------------------------- *)
(*                     Continuity & Homeomorphism                    *)
(* ----------------------------------------------------------------- *)

Definition Continuous {X Y} (S: Topology X) (T: Topology Y) (f: X -> Y): Prop :=
  ForallIn (opens(T)) (fun V => InvIm f V :in: opens(S)).

Notation "f ':-' S '~>' T" := (Continuous S T f)
  (at level 75, no associativity).

Add Parametric Morphism X Y: (@Continuous X Y)
  with signature equiv ==> equiv ==> eq ==> iff as conti_mor.
Proof. firstorder. Qed.

Property conti_as_set: forall X Y (S: Topology X) (T: Topology Y) (f: X -> Y),
  (f :- S ~> T) <-> ({' InvIm f V | V in opens(T) '} <:= opens(S)).
Proof. intros. split.
  - intros H _ (V & ? & ->). apply H. trivial.
  - intros H V HV. apply H. apply im_def. trivial.
Qed.

Lemma basis_invim_conti: forall X Y (S: Topology X) (B: Basis Y) (f: X -> Y),
  ForallIn (opens(B)) (fun V => open[S] (InvIm f V)) ->
  f :- S ~> topoByBase B.
Proof.
  intros ** V (F & HV1 & ->)%open_iff_base_unions.
  rewrite unions_as_over, invim_unionover.
  apply unionover_is_open. firstorder.
Qed.

Lemma subbasis_invim_conti: forall X Y (S: Topology X) (B: Subbasis Y) (f: X -> Y),
  ForallIn (opens(B)) (fun V => open[S] (InvIm f V)) ->
  f :- S ~> topoByBase (baseBySubbase B).
Proof.
  intros **. apply basis_invim_conti.
  intros _ (L & HL & ->). induction L.
  - simpl. rewrite invim_full. apply full_is_open.
  - simpl. rewrite invim_intersect.
    inversion HL; subst.
    apply intersect_is_open; firstorder.
Qed.

Section ConstrConti.
Context {X Y Z: Type} (R: Topology X) (S: Topology Y) (T: Topology Z).

Lemma const_conti: forall (y: Y), (const y) :- R ~> S.
Proof. intros ** U HU. decides (y :in: U) as [H|H].
  - eapply proper_opens; [| apply full_is_open]. firstorder.
  - eapply proper_opens; [| apply empty_is_open]. firstorder.
Qed.

Lemma id_conti: id :- R ~> R.
Proof. intros U. rewrite invim_identity. easy. Qed.

Lemma compose_conti: forall f g,
  (f :- R ~> S) -> (g :- S ~> T) -> compose g f :- R ~> T.
Proof. intros * Hf Hg U HU.
  rewrite invim_compose. apply Hf, Hg, HU. Qed.

End ConstrConti.

Section UsualMap.
Context {X Y: Type} `{D: UsualSetoid Y}.

Definition OpenMap (S: Topology X) (T: Topology Y) (f: X -> Y): Prop :=
  ForallIn (opens(S)) (fun U => open[T] (Im f U)).

Definition Homeomorphism (S: Topology X) (T: Topology Y) (f: X -> Y): Prop :=
  bijective f /\ Continuous S T f /\ OpenMap S T f.

End UsualMap.

Notation "f ':-' S '~=' T" := (Homeomorphism S T f)
  (at level 75, no associativity).

Lemma homeo_bijective: forall X Y `(DX: UsualSetoid X) `(DY: UsualSetoid Y),
  forall (S: Topology X) (T: Topology Y) f g,
  compose f g == id -> compose g f == id ->
  f :- S ~> T -> g :- T ~> S -> f :- S ~= T.
Proof with auto.
  intros * E1 E2 Hf Hg.
  assert (Bij: bijective f). { split.
    eapply left_inv_then_inj. apply E2.
    eapply right_inv_then_surj. apply E1.
  }
  split... split... (* Only open map is nontrivial *)
  intros U HU.
  setoid_replace (Im f U) with (InvIm g U). apply Hg...
  rewrite <- invim_identity, <- E1, invim_compose.
  eapply invim_mor... apply invim_of_im_eq_inj, Bij.
Qed.

(* ----------------------------------------------------------------- *)
(*                       Subspace Topology                           *)
(* ----------------------------------------------------------------- *)

(* Subspace topology *)
Section Subspace.
Context {X:Type} (T: Topology X) (A: ESet X).

Definition subsetOver (C: Powerset X): Powerset (Subset A) :=
  {' InvIm inclu U | U in C '}.

Proposition subspace_topo: isTopology (subsetOver (opens T)).
Proof with (auto with sets; firstorder).
  split; unfold subsetOver.
  - (* Unions *)
    intros. (* Need W s.t. Unions M == InvIm inclu W *)
    exists (Unions {: U in opens(T) | InvIm inclu U :in: properForm M :}). split.
    + apply unions_is_open. intros ? []...
    + symmetry. rewrite unions_as_over, invim_unionover.
      apply same_inc_iff; split.
      * apply inc_forall_unionover_iff...
      * apply inc_forall_unions_iff. intros V HV.
        specialize (H _ HV) as [U (? & E)]...
  - (* Intersects *)
    intros L. apply mcat_ind.
    + (* FullSet *)
      exists FullSet... apply full_is_open.
    + (* Intersect-2 *)
      intros U U' [V (HV1 & HV2)] [V' (HV'1 & HV'2)].
      exists (V //\\ V'). rewrite invim_intersect.
      split; [apply intersect_is_open | all_rewrite]...
Qed.

Program Definition SubspaceT: Topology (Subset A) := mkTopo (subsetOver (opens T)) _ _.
Next Obligation. apply subspace_topo. Qed.

Lemma subsp_basis_from_basis: forall C: Powerset X,
  isBaseOf C T -> isBaseOf (subsetOver C) SubspaceT.
Proof with (auto with sets).
  intros ? [B (<- & HE)]. do 2 red in HE. apply identify_base.
  - (* Proper *) exact _.
  - (* Contained in subspace topology *)
    apply im_inc. rewrite <- HE. apply base_is_open.
  - (* Forms basis of the topo *)
    intros V [U (HU%HE & EV)] y Hy%EV.
    specialize (HU (inclu y) Hy) as [W (? & ? & ?)].
    exists (InvIm inclu W). rewrite EV.
    split. apply im_def... split...
Qed.

(* Using usual equality *)
Section UsualEq.
Context `{UsualSetoid X}.

Lemma open_subsp_open_whole: forall U: ESet (Subset A),
  open[T] A -> open[SubspaceT] U -> open[T] (Im inclu U).
Proof with (auto with sets).
  intros * ? [V [? ->]]%im_iff.
  rewrite incl_im_of_invim. apply intersect_is_open...
Qed.

Lemma closes_subsp_is: closes(SubspaceT) == {' InvIm inclu E | E in closes(T) '}.
Proof with (auto with sets).
  intros E. split.
  - (* -> *)
    intros [U [H0 HE]]. exists (~! U).
    split. do 4 red. rewrite compl_compl...
    rewrite <- invim_compl, <- HE...
  - (* <- *)
    intros [F [HC HE]]. do 4 red in HC |- *.
    rewrite HE, invim_compl. apply im_def...
Qed.
Corollary closed_subsp_iff: forall (F: ESet (Subset A)),
  closed[SubspaceT] F <-> ExistsIn (closes(T)) (fun E => F == InvIm inclu E).
Proof. intros. rewrite closes_subsp_is. firstorder. Qed.

Lemma closed_subsp_closed_whole: forall (E: ESet (Subset A)),
  closed[T] A -> closed[SubspaceT] E -> closed[T] (Im inclu E).
Proof with (eauto with sets).
  intros * ?. rewrite closes_subsp_is.
  intros [F [? ->]]%im_iff.
  rewrite incl_im_of_invim. apply intersect_is_closed...
Qed.

End UsualEq.

(* Subspace and continuity *)

Lemma inclu_conti: inclu :- SubspaceT ~> T.
Proof. intros U HU. apply im_def. auto. Qed.

End Subspace.

(* Use local-continuity to prove continuity *)
Lemma localconti_conti: forall X Y (R: Topology X) (S: Topology Y),
  forall `(UsualSetoid X) f (P: Powerset X),
  P <:= opens(R) -> cover_all P ->
  ForallIn P (fun U => compose f inclu :- (SubspaceT R U) ~> S) ->
  f :- R ~> S.
Proof with (auto with sets).
  intros * ? * HO HC Hf V HV. set (fU U := compose f (@inclu _ U)).
  assert (E: forall U, InvIm f V //\\ U == Im inclu (InvIm (fU U) V)). {
    intros U. unfold fU.
    rewrite invim_compose, incl_im_of_invim...
  }
  assert (Claim: InvIm f V == unions U in P, Im inclu (InvIm (fU U) V)). {
    setoid_replace (InvIm f V) with (InvIm f V //\\ unions U in P, U).
    rewrite intersect_distr_unions. apply unionover_mor...
    firstorder.
  }
  rewrite Claim. apply unionover_is_open. intros U HU.
  apply open_subsp_open_whole. apply HO... apply Hf...
Qed.

(* Imbedding *)
Section UsualMap.
Context {X Y: Type} `{D: UsualSetoid Y}.

Program Definition imbed (f: X -> Y): X -> Subset (Im f FullSet) :=
  fun x => exist _ (f x) _.
Next Obligation. exists x. firstorder. Qed.

Definition Imbedding (S: Topology X) (T: Topology Y) (f: X -> Y): Prop :=
  let SubT := SubspaceT(T) (Im f FullSet) in
  imbed f :- S ~= SubT.

End UsualMap.

(* ----------------------------------------------------------------- *)
(*                        Product Topology                           *)
(* ----------------------------------------------------------------- *)

Section Product.
Context {X Y:Type}.
Context (S: Topology X) (T: Topology Y).

Definition prodOver (C: Powerset X) (D: Powerset Y): Powerset (X * Y) :=
  {' U ** V | '(U, V) in C ** D '}.

Property prodover_def: forall C D U V,
  U :in: C -> V :in: D -> (U ** V) :in: prodOver C D.
Proof. intros. exists (U, V). firstorder. Qed.

Proposition prod_basis: isBase (prodOver (opens S) (opens T)).
Proof with (eauto 3 with sets).
  split.
  - (* Covers *)
    exists {{FullSet}}. split.
    + intros _ <-%singleton_iff. rewrite <- full_prod.
      apply prodover_def; apply full_is_open.
    + red...
  - (* Intersection *)
    intros W1 W2 x [(U1, V1) [H1 E1]] [(U2, V2) [H2 E2]] H.
    exists (W1 //\\ W2). split; [| split]...
    destruct H1 as (HU1 & HV1), H2 as (HU2 & HV2).
    specialize (intersect_is_open _ _ _ HU1 HU2) as H1.
    specialize (intersect_is_open _ _ _ HV1 HV2) as H2.
    eexists (_, _). split... rewrite E1, E2...
Qed.

Program Definition ProductB: Basis (X * Y) := mkTopo (prodOver (opens S) (opens T)) _ _.
Next Obligation. apply prod_basis. Qed.

Definition ProductT: Topology (X * Y) := topoByBase ProductB.

Lemma prod_basis_from_basis: forall (B: Powerset X) (C: Powerset Y),
  isBaseOf B S -> isBaseOf C T ->
  isBaseOf (prodOver B C) ProductT.
Proof with (auto with sets).
  intros * [Bt (<- & EB)] [Ct (<- & EC)].
  apply identify_base.
  - exact _.
  - (* Contained in ProductT *)
    etransitivity; [| apply base_is_open].
    intros _ [(U, V) ([] & ->)].
    apply prodover_def; firstorder.
  - (* Forms basis of the topo *)
    intros W HW (x, y) Hxy.
    specialize (HW (x, y) Hxy) as [_ [[(U, V) (HI & ->)] (HR1 & HR2)]].
    destruct HI as (HU%EB & HV%EC), HR1 as (HU2 & HV2).
    specialize (HU x HU2) as [I (?&?&?)]. specialize (HV y HV2) as [J (?&?&?)].
    exists (I ** J). split. apply prodover_def...
    split... etransitivity; eauto...
Qed.

Lemma fst_conti: fst :- ProductT ~> S.
Proof with (auto with sets).
  intros * V HV. rewrite invim_fst_prod.
  apply base_is_open, prodover_def...
  apply full_is_open.
Qed.

Lemma snd_conti: snd :- ProductT ~> T.
Proof with (auto with sets).
  intros * V HV. rewrite invim_snd_prod.
  apply base_is_open, prodover_def...
  apply full_is_open.
Qed.

Definition prodSubbasis: Powerset (X * Y) :=
  {' InvIm fst U | U in opens S '} \\// {' InvIm snd V | V in opens T '}.

Theorem prod_subbasis_spec:
  isSubbaseOf prodSubbasis ProductT.
Proof with (eauto with sets).
  destruct (mkTopo_spec _ (const True) prodSubbasis) as [B HS].
  - (* Proper *) exact _.
  - (* Subbase, trivial *) apply I.
  - (* Generates exact *)
    exists B. split; auto. apply same_inc_iff. split.
    + (* open ProductT =:> *)
      apply subbasis_gen_minimal. rewrite HS.
      apply union_inc_split.
      split; apply conti_as_set. apply fst_conti. apply snd_conti.
    + (* open ProductT <:= *)
      apply basis_gen_minimal. etransitivity; [| apply base_is_open].
      intros _ [(U, V) ((HU & HV) & ->)]. apply im_iff.
      exists [InvIm fst U; InvIm snd V]. rewrite HS. split.
      * repeat apply Forall_cons; [left | right | constructor]...
      * rewrite mcat_couple...
Qed.

(* Checking continuous function into product space *)
Theorem product_map_conti: forall W (R: Topology W),
  forall f1 f2, let f := fun a => (f1 a, f2 a) in
  (f :- R ~> ProductT) <-> (f1 :- R ~> S) /\ (f2 :- R ~> T).
Proof with (auto with sets).
  intros. split.
  - (* -> *)
    intros H. split;
    [ replace f1 with (compose fst f) | replace f2 with (compose snd f) ]...
    all: eapply compose_conti; [apply H|].
    apply fst_conti. apply snd_conti.
  - (* <- *)
    intros (H1 & H2). apply basis_invim_conti.
    intros _ ((U, V) & [HU HV] & ->).
    assert (InvIm f (U ** V) == InvIm f1 U //\\ InvIm f2 V) as ->. {
      intros x. rewrite intersect_iff. rewrite 3 invim_iff. apply prod_iff. }
    apply intersect_is_open. apply H1... apply H2...
Qed.

End Product.

(* Homeomorphism btwn product of subspaces and subspace of products *)
(* TODO Rewrite *)
Theorem prod_subsp_exch: forall X Y `(DX: UsualSetoid X) `(DY: UsualSetoid Y),
  forall (S: Topology X) (T: Topology Y) (A: ESet X) (B: ESet Y),
  let SubA := SubspaceT(S) A in let SubB := SubspaceT(T) (B) in
  ps_to_sp :- ProductT SubA SubB ~= SubspaceT (ProductT S T) (A ** B).
Proof with auto.
  intros.
  (* Convert subspace of product space to use basis *)
  assert ( isBaseOf ( subsetOver (A ** B) ( prodOver (opens S) (opens T) ) )
      (SubspaceT (ProductT S T) (A ** B))
  ) as (BSP & HE & Rep).
  { apply subsp_basis_from_basis; exists (ProductB S T)... }

  (* TODO Set equal under bijection *)
  (* Basis elements are equal *)
  assert ( EQ: forall U V,
    InvIm ps_to_sp (InvIm (@inclu _ (A ** B)) (U ** V)) ==
    InvIm inclu U ** InvIm inclu V ).
  { intros * (x, y). rewrite prod_iff, 4 invim_iff. reflexivity. }

  assert (E1: compose ps_to_sp (@sp_to_ps _ _ A B) == id).
  { intros ?. apply sub_prod_id. }
  assert (E2: compose sp_to_ps (@ps_to_sp _ _ A B) == id).
  { intros ?. apply prod_sub_id. }

  eapply homeo_bijective with (g := sp_to_ps)...
  - (* ps_to_sp continuous *)
    rewrite <- Rep. apply basis_invim_conti. rewrite HE.
    intros _ (_ & ((U, V) & [HU HV] & ->) & ->).
    apply base_is_open.
    rewrite -> EQ.
    apply prodover_def... all: apply im_def...
  - (* sp_to_ps continuous *)
    rewrite <- Rep. apply basis_invim_conti.
    intros _ ((_, _) & [(U & HU & ->) (V & Hv & ->)] & ->).
    apply base_is_open. rewrite HE.
    rewrite <- EQ, <- invim_compose, E1, invim_identity.
    apply im_def. apply prodover_def...
Qed.

(* ----------------------------------------------------------------- *)
(*                 Basic Structure in a Topology                     *)
(* ----------------------------------------------------------------- *)

Section TopoStr.
Context {X:Type} (T: Topology X).

Definition Interior (A: ESet X): ESet X :=
  Unions {: U in opens(T) | U <:= A :}.
Definition Closure (A: ESet X): ESet X :=
  Intersects {: E in closes(T) | E =:> A :}.

Property interior_in: forall A, Interior A <:= A.
Proof. firstorder. Qed.

Property closure_out: forall A, Closure A =:> A.
Proof. firstorder. Qed.

Property interior_eq_iff: forall A, open[T] A <-> Interior A == A.
Proof. firstorder. rewrite <- H. apply unions_is_open. firstorder. Qed.

Property closure_eq_iff: forall A, closed[T] A <-> Closure A == A.
Proof. firstorder. rewrite <- H. apply intersects_is_closed. firstorder. Qed.

Property interior_open: forall A, open[T] (Interior A).
Proof. intros. apply unions_is_open. firstorder. Qed.

Property closure_closed: forall A, closed[T] (Closure A).
Proof. intros. apply intersects_is_closed. firstorder. Qed.

Property interior_inc_if: forall A B, A <:= B -> Interior A <:= Interior B.
Proof. intros ** x [U]. exists U. firstorder. Qed.

Property closure_inc_if: forall A B, A <:= B -> Closure A <:= Closure B.
Proof. intros ** x ? E []. apply H0. firstorder. Qed.

End TopoStr.

Notation "'Int' [ T ]" := (Interior T)
  (format "'Int' [ T ]").
Notation "'Cl' [ T ]" := (Closure T)
  (format "'Cl' [ T ]").

Lemma subspace_closure: forall X `(D: UsualSetoid X) T (Y: ESet X) (A: ESet (Subset Y)),
  let S := SubspaceT T Y in
  Cl[S] A == InvIm inclu (Cl[T] (Im inclu A)).
Proof with (auto with sets).
  intros. apply same_inc_iff. split.
  - (* Cl[S] A <:= Cl[T] A /\ Y *)
    set (E := Cl[T] (Im inclu A)).
    apply intersects_inced_one. split.
    apply closes_subsp_is, im_def, closure_closed.
    rewrite mkSet_In, <- (incl_invim_of_im _ A).
    apply invim_inc, closure_out.
  - (* Cl[S] A =:> Cl[T] A /\ Y *)
    set (B := Cl[S] A).
    assert (closed[S] B) as (C & HC & HE)%closed_subsp_iff by apply closure_closed...
    rewrite HE. apply invim_inc, intersects_inced_one.
    split... rewrite mkSet_In. transitivity (Y //\\ C)...
    rewrite <- incl_im_of_invim. apply im_inc.
    rewrite <- HE. apply closure_out.
Qed.

Lemma closure_intersects: forall X T (A: ESet X) x,
  x :in: Cl[T] A <-> ForallIn (opens(T)) (fun U => x :in: U -> Inhabited (A //\\ U)).
Proof with (auto with sets).
  split.
  - (* -> *)
    intros H U H1 H2. contra.
    apply not_inhabited_empty in contra.
    assert (I: A <:= ~! U). firstorder.
    specialize (H (~! U)). apply H...
    split... do 4 red. rewrite compl_compl...
  - (* <- *)
    intros H E [HC HI]. contra.
    specialize (H (~!E) HC contra) as []. firstorder.
Qed.
Corollary closure_intersects_basis: forall X S (A: ESet X) x,
  let T := topoByBase S in
  x :in: Cl[T] A <-> ForallIn (opens(S)) (fun B => x :in: B -> Inhabited (A //\\ B)).
Proof with (auto with sets).
  intros. etransitivity. apply closure_intersects. split.
  - intros H B ? ?. apply H... apply base_is_open...
  - intros H U HO [V (? & ? & ?)]%HO. firstorder.
Qed.

Definition Neighborhood {X} (T: Topology X) x: Powerset X :=
  {: U in opens(T) | x :in: U :}.

Notation "'nbhd' [ T ]" := (Neighborhood T)
  (format "'nbhd' [ T ]").

Corollary closure_nbhd: forall X T (A: ESet X) x,
  x :in: Cl[T] A <-> ForallIn (nbhd[T] x) (fun U => Inhabited (A //\\ U)).
Proof. intros. etransitivity. apply closure_intersects. firstorder. Qed.

(* Elaboration on continuity *)
Section MapToEq.
Context {X Y} `{D: UsualSetoid Y} (S: Topology X) (T: Topology Y) (f: X -> Y).

Theorem tfae_continuity:
  TFAE [
      Continuous S T f
    ; forall A: ESet X, Im f (Cl[S] A) <:= Cl[T] (Im f A)
    ; ForallIn (closes(T)) (fun E => InvIm f E :in: closes(S))
  ].
Proof with (auto 4 with sets).
  intros. tfae_chain.
  - (* 0 -> 1 *)
    intros H A _ (x & Hx & ->).
    rewrite -> closure_intersects in *.
    intros V HV1%H HV2%invim_iff.
    specialize (Hx _ HV1 HV2) as (y & ? & ?).
    exists (f y)...
  - (* 1 -> 2 *)
    intros H E HE%closure_eq_iff. apply closure_eq_iff.
    set (A := InvIm f E).
    apply same_inc_iff. split; [| apply closure_out].
    assert (HI: Im f (Cl[S] A) <:= Cl[T] E).
      etransitivity... apply closure_inc_if. unfold A...
    rewrite HE in HI. intros x Hx.
    apply invim_iff. apply HI...
  - (* 2 -> 0 *)
    intros H V HV. specialize (H (~! V)).
    rewrite <- (compl_compl V), <- invim_compl.
    apply H. do 4 red. rewrite compl_compl...
Qed.

Theorem conti_alt_def: (f :- S ~> T) <->
  (forall x, ForallIn (nbhd[T] (f x)) (fun V =>
    ExistsIn (nbhd[S] x) (fun U => Im f U <:= V) )).
Proof with (auto with sets).
  split.
  - intros H x V (HV1 & HV2). exists (InvIm f V).
    apply H in HV1. apply invim_iff in HV2. split... split...
  - intros H V HV. apply interior_eq_iff.
    apply same_inc_iff. split; try apply interior_in.
    intros x Hx. unfold Interior.
    specialize (H x V (conj HV Hx)) as (Ux & [] & ?).
    exists Ux. split... split... rewrite mkSet_In.
    etransitivity. apply (invim_of_im_inc _ f). apply invim_inc...
Qed.

End MapToEq.

(* Limit and Hausdorff *)
Section TopoStr.
Context {X:Type} `{UsualSetoid X} (T: Topology X).

Definition IsLimit (A: ESet X) (x: X): Prop :=
  ForallIn (nbhd[T] x) (fun U => Inhabited (A //\\ U \\ {{ x }})).
Definition LimitPts (A: ESet X): ESet X :=
  mkSet (IsLimit A).

Theorem closure_limit_rel: forall (A: ESet X),
  Cl[T] A == A \\// LimitPts A.
Proof with (auto with sets).
  intros. apply same_inc_iff. split.
  - (* <:= *)
    intros x HX. decides (x :in: A) as [|K]...
    apply -> closure_nbhd in HX.
    right. intros U HI%HX.
    assert (A //\\ U \\ {{x}} == A //\\ U) as ->...
    rewrite setminus_as_intersect. apply inc_intersect_eq.
    intros y [Hy ?] <-. contradiction.
  - (* =:> *)
    apply union_inc_split. split. apply closure_out.
    intros x Hx. apply closure_nbhd. firstorder.
Qed.
Corollary closed_iff_limit: forall (E: ESet X),
  closed[T] E <-> LimitPts E <:= E.
Proof. intros. rewrite closure_eq_iff, closure_limit_rel. firstorder. Qed.

Definition Converges (a: nat -> X) (x: X): Prop :=
  ForallIn (nbhd[T] x) (fun U => exists N, forall n, n >= N -> a n :in: U).

Definition Hausdorff: Prop :=
  forall x1 x2: X, x1 =/= x2 -> exists (U1 U2: ESet X),
    U1 :in: nbhd[T] x1 /\ U2 :in: nbhd[T] x2 /\ U1 //\\ U2 == EmptySet.

Theorem hausdorff_single_closed: forall x,
  Hausdorff -> closed[T] {{x}}.
Proof with (auto with sets).
  intros x Haus. set (C := Cl[T] {{x}}).
  enough (Claim: C <:= {{x}}).
    apply closure_eq_iff, same_inc_iff. split... apply closure_out.
  intros y Hy. apply -> closure_nbhd in Hy.
  contra. simpl in contra.
  apply Haus in contra as (U1 & U2 & [_ HU1] & (? & <- & HU2)%Hy & EE).
  firstorder.
Qed.

(*
Following requires cardinarlity:
Theorem limit_pt_nbhd_iff: forall A x,
  (forall t, closed[T] {|t|}) ->
  IsLimit A x <-> ForallIn (nbhd[T] x) (fun U => A //\\ U).
Proof.

Qed.
*)

Theorem hausdorff_seq_conv_unique: forall (a: nat -> X),
  Hausdorff -> uniqueness (Converges a).
Proof with (auto with arith).
  intros * Haus. unfold uniqueness. intros x y Hx Hy.
  contra.
  apply Haus in contra as (U & V & [N HU]%Hx & [M HV]%Hy & HE).
  apply not_inhabited_empty in HE. apply HE.
  exists (a (N + M)). split...
Qed.

End TopoStr.

Theorem subset_hausdorff: forall X `{UsualSetoid X} T (A: ESet X),
  Hausdorff T -> Hausdorff (SubspaceT T A).
Proof with (auto with sets).
  intros * HT.
  intros x x' Hx. simpl in Hx.
  decides (inclu x = inclu x') as [|K]. exfalso...
  apply HT in K as (U & V & [HU1 HU2] & [HV1 HV2] & HE).
  exists (InvIm inclu U), (InvIm inclu V).
  split; [|split].
  + split... apply im_def...
  + split... apply im_def...
  + rewrite <- invim_intersect, HE...
Qed.

Theorem product_hausdorff: forall X Y `{UsualSetoid X} `{UsualSetoid Y},
  forall (S: Topology X) (T: Topology Y),
  Hausdorff S -> Hausdorff T -> Hausdorff (ProductT S T).
Proof with (auto with sets).
  intros * HS HT. (* HS: Hausdorff S, HT: Hausdorff T *)
  assert (K: prodSubbasis S T <:= opens (ProductT S T)).
    rewrite <- isSubbase_then_generate.
    apply subbase_is_open. apply prod_subbasis_spec.
  intros (x, y) (x', y') Hxy.
  decides (x == x') as [->|Hx]. decides (y == y') as [->|Hy].
  - exfalso...
  - apply HT in Hy as (V & V' & [HV1 HV2] & [HV'1 HV'2] & HE).
    exists (InvIm snd V), (InvIm snd V').
    split; [|split].
    + split... apply K. right. apply im_def...
    + split... apply K. right. apply im_def...
    + rewrite <- invim_intersect. rewrite HE...
  - apply HS in Hx as (U & U' & [HU1 HU2] & [HU'1 HU'2] & HE).
    exists (InvIm fst U), (InvIm fst U').
    split; [|split].
    + split... apply K. left. apply im_def...
    + split... apply K. left. apply im_def...
    + rewrite <- invim_intersect. rewrite HE...
Qed.