(** * SetInterface.v : An abstract interface for sets
   and an implementation using lists *)

Set Implicit Arguments.

Require Export BoolEquality.
Require Export List.

(** Abstract interface for sets of elements of a type equipped
    with boolean equality *)
Module Type SET.

 Declare Module E : EQDEC.
 Export E.

 Parameter t : Type.

 (** Boolean equality *)
 Parameter eqb : t -> t -> bool.
 Definition eq : t -> t -> Prop := eqb.

 (** The empty set *)
 Parameter empty : t.

 (** [mem x s] tests whether [x] belongs to the set [s] *)
 Parameter mem : E.t -> t -> bool.

 (** [add x s] returns a set containing all elements of [s], plus [x].
     If [x] was already in [s], [s] is returned unchanged. *)
 Parameter add : E.t -> t -> t.

 (** [singleton x] returns the one-element set containing only [x] *)
 Parameter singleton : E.t -> t.

 (** [remove x s] returns a set containing all elements of [s], except [x].
     If [x] was not in [s], [s] is returned unchanged *)
 Parameter remove : E.t -> t -> t.

 (** Set union *)
 Parameter union : t -> t -> t.

 (** Set intersection *)
 Parameter inter : t -> t -> t.

 (** Set difference *)
 Parameter diff : t -> t -> t.

 (** [subset s1 s2] tests whether the set [s1] is a subset of the set [s2] *)
 Parameter subsetb : t -> t -> bool.
 Definition subset: t -> t -> Prop := subsetb.

 (** Lists the elements of the set in some unspecified order *)
 Parameter elements : t -> list E.t.

 (** [fold f s] a computes (f xN ... (f x2 (f x1 a))...),
     where [x1 ... xN] is the result of [elements s] *)
 Parameter fold : forall A : Type, (E.t -> A -> A) -> t -> A -> A.

 Parameter filter : (E.t -> bool) -> t -> t.

 Parameter forallb : (E.t -> bool) -> t -> bool.

 Notation "s [=] t" := (eq s t) (at level 70, no associativity).
 Notation "s [<=] t" := (subset s t) (at level 70, no associativity).
 Notation "s '[=?]' t" := (eqb s t) (at level 70, no associativity).
 Notation "s '[<=?]' t" := (subsetb s t) (at level 70, no associativity).

 Definition disjoint s1 s2 := eqb (inter s1 s2) empty.

 Hint Unfold disjoint.

 (** * Specification *)

 (** Specification of [subset] *)
 Parameter subset_correct : forall s1 s2,
  s1 [<=] s2 -> (forall x, mem x s1 -> mem x s2).

 Parameter subset_complete : forall s1 s2,
  (forall x, mem x s1 -> mem x s2) -> s1 [<=] s2.

 (** Specification of [eq] *)
 Parameter eq_correct_l : forall s1 s2,
  s1 [=] s2 -> s1 [<=] s2.

 Parameter eq_correct_r : forall s1 s2,
  s1 [=] s2 -> s2 [<=] s1.

 Parameter eq_complete : forall s1 s2,
  s1 [<=] s2 -> s2 [<=] s1 -> s1 [=] s2.

 (** Specification of [empty] *)
 Parameter empty_spec : forall x, ~mem x empty.

 (** Specification of [mem] *)
 Parameter mem_correct : forall x y s,
  E.eq x y -> mem x s -> mem y s.

 (** Specification of [add] *)
 Parameter add_correct : forall x y s,
  E.eq x y -> mem y (add x s).

 Parameter add_complete : forall x y s,
  mem y s -> mem y (add x s).

 Parameter add_inversion : forall x y s,
  ~E.eq x y -> mem y (add x s) -> mem y s.

 (** Specification of [singleton] *)
 Parameter singleton_correct : forall x y,
  E.eq x y -> mem y (singleton x).

 Parameter singleton_complete : forall x y,
  mem y (singleton x) -> E.eq x y.

 (** Specification of [remove] *)
 Parameter remove_correct : forall x y s,
  E.eq x y -> ~mem x (remove y s).

 Parameter remove_complete : forall x y s,
  ~E.eq x y -> mem y s -> mem y (remove x s).

 Parameter remove_inversion : forall x y s,
  mem y (remove x s) -> mem y s.

 (** Specification of [union] *)
 Parameter union_correct : forall s1 s2 x,
  mem x (union s1 s2) -> (mem x s1 \/ mem x s2).

 Parameter union_complete_l : forall s1 s2 x,
  mem x s1 -> mem x (union s1 s2).

 Parameter union_complete_r : forall s1 s2 x,
  mem x s2 -> mem x (union s1 s2).

 (** Specification of [inter] *)
 Parameter inter_correct_l : forall s1 s2 x,
  mem x (inter s1 s2) -> mem x s1.

 Parameter inter_correct_r : forall s1 s2 x,
  mem x (inter s1 s2) -> mem x s2.

 Parameter inter_complete : forall s1 s2 x,
  mem x s1 -> mem x s2 -> mem x (inter s1 s2).

 (** Specification of [diff] *)
 Parameter diff_correct_l : forall s1 s2 x,
  mem x (diff s1 s2) -> mem x s1.

 Parameter diff_correct_r : forall s1 s2 x,
  mem x (diff s1 s2) -> ~mem x s2.

 Parameter diff_complete : forall s1 s2 x,
  mem x s1 -> ~mem x s2 -> mem x (diff s1 s2).

 (** Specification of [fold] *)
 Parameter fold_spec : forall A (f:E.t -> A -> A) i s,
  fold f s i = fold_left (fun a x => f x a) (elements s) i.

 (* Alternatively,
 Parameter fold_spec : forall A (f:E.t -> A -> A) i s,
  fold f s i = fold_right f i (elements s). *)

 (** Specification of [forallb] *)
 Parameter forallb_correct : forall f, (forall x y, E.eq x y -> f x = f y) ->
   forall s, forallb f s -> forall x, mem x s -> f x.

 Parameter forallb_complete : forall (f:E.t->bool),
   (forall x y, E.eq x y -> f x = f y) ->
   forall s, (forall x, mem x s -> f x) -> forallb f s.

 (** Specification of [elements] *)
 Parameter elements_correct : forall s x,
  mem x s -> InA E.eq x (elements s).

 Parameter elements_complete : forall s x,
  InA E.eq x (elements s) -> mem x s.

 (** Specification of filter *)
 Parameter filter_correct : forall (f:E.t->bool) x s,
  (forall x y, E.eq x y -> f x = f y) -> mem x (filter f s) -> mem x s /\ f x.

 Parameter filter_complete : forall (f:E.t->bool) x s,
  (forall x y, E.eq x y -> f x = f y) ->
  mem x s -> f x -> mem x (filter f s).

End SET.

(** Functor extending [SET] *)
Module MkSet_Theory (S:SET).

 Export S.

 Module ET := MkEqDec_Theory E.

 Lemma subset_iff : forall s1 s2,
  s1 [<=] s2 <-> (forall x, mem x s1 -> mem x s2).
 Proof.
  split; [apply subset_correct | apply subset_complete].
 Qed.

 Lemma subset_refl : forall s, s [<=] s.
 Proof.
  auto using subset_complete.
 Qed.

 Lemma subset_trans : forall s s0 s1,
  s [<=] s0 -> s0 [<=] s1 -> s [<=] s1.
 Proof.
  intros s s0 s1; repeat rewrite subset_iff; firstorder.
 Qed.

 Add Relation t subset
   reflexivity proved by subset_refl
   transitivity proved by subset_trans
   as subset_relation.

 Lemma eq_refl : forall s, s [=] s.
 Proof.
  auto using subset_refl, eq_complete.
 Qed.

 Lemma eq_sym : forall s1 s2,
  s1 [=] s2 -> s2 [=] s1.
 Proof.
  intros; apply eq_complete.
  apply eq_correct_r; trivial.
  apply eq_correct_l; trivial.
 Qed.

 Lemma eq_trans : forall s1 s2 s3,
  s1 [=] s2 -> s2 [=] s3 -> s1 [=] s3.
 Proof.
  intros; apply eq_complete.
  apply subset_trans with s2; apply eq_correct_l; trivial.
  apply subset_trans with s2; apply eq_correct_r; trivial.
 Qed.

 Add Relation t eq
  reflexivity proved by eq_refl
  symmetry proved by eq_sym
  transitivity proved by eq_trans as eq_setoid.

 Add Morphism eqb
  with signature eq ==> eq ==> (@Logic.eq bool)
  as eqb_morphism.
 Proof.
  intros s1 s2 H s3 s4 H0.
  case_eq (s1 [=?] s3); intros.
  change (s1 [=] s3) in H1.
  symmetry; change (s2 [=] s4).
  transitivity s1.
  symmetry; trivial.
  transitivity s3; auto.
  case_eq (s2 [=?] s4); auto; intros.
  rewrite <- H1; change (s2 [=] s4) in H2.
  change (s1 [=] s3).
  transitivity s2; auto.
  transitivity s4; auto.
  symmetry; trivial.
 Qed.

 Add Morphism subsetb
  with signature eq ==> eq ==> (@Logic.eq bool)
  as subsetb_morphism.
 Proof.
  intros s1 s2 H s3 s4 H0.
  case_eq (s1 [<=?] s3); case_eq (s2 [<=?] s4); intros; trivial.

  assert (L:=eq_correct_r H); assert (R:=eq_correct_l H0).
  elim H1.
  symmetry; apply fold_is_true.
  eapply subset_trans; eauto.
  eapply subset_trans; eauto.
  trivialb.

  assert (L:=eq_correct_r H0); assert (R:=eq_correct_l H).
  elim H2.
  apply fold_is_true.
  eapply subset_trans; eauto.
  eapply subset_trans; eauto.
 Qed.

 Add Morphism subset
  with signature eq ==> eq ==> iff
  as subset_morphism.
 Proof.
  intros; unfold subset.
  rewrite iff_eq.
  apply subsetb_morphism; trivial.
 Qed.

 Lemma eq_spec : forall s1 s2,
  s1 [=] s2 <-> (s1 [<=] s2 /\ s2 [<=] s1).
 Proof.
  split; intros.
  auto using eq_correct_l, eq_correct_r.
  apply eq_complete; autob.
 Qed.

 Lemma eqb_eq : forall s1 s2,
  eqb s1 s2 -> s1 [=] s2.
 Proof.
  trivial.
 Qed.

 Add Morphism mem
  with signature E.eq ==> eq ==> (@Logic.eq bool)
  as mem_morphism.
 Proof.
  intros x y H s1 s2 H0.
  destruct (eq_spec s1 s2).
  destruct (H1 H0); clear H0 H1 H2.
  rewrite <- iff_eq.
  split; eauto using mem_correct, subset_correct.
 Qed.

 Lemma mem_diff : forall s x y, ~mem x s -> mem y s -> ~E.eq x y.
 Proof.
  intros s x y H H0.
  case (ET.eq_dec x y); intro; trivial.
  rewrite e in H; trivialb.
 Qed.

 Lemma mem_dec : forall x s, {mem x s} + {~mem x s}.
 Proof.
  intros x s; case_eq (mem x s); intro; [left | right]; trivialb.
 Qed.

 Add Morphism add
  with signature E.eq ==> eq ==> eq
  as add_morphism.
 Proof.
  intros x y H s1 s2 H0.
  apply eq_complete; apply subset_complete; intros.
  case (ET.eq_dec x0 y); intro.
  apply add_correct; auto.
  apply add_complete.
  rewrite <- H0; rewrite <- H in n.
  apply add_inversion with x; auto.
  case (ET.eq_dec x0 x); intro.
  apply add_correct; auto.
  apply add_complete.
  rewrite H0; rewrite H in n.
  apply add_inversion with y; auto.
 Qed.

 Lemma add_spec : forall a s x,
  mem x (add a s) <-> (E.eq a x \/ mem x s).
 Proof.
  split; intros.
  case (ET.eq_dec a x); intro.
  left; trivial.
  right; apply (add_inversion n H).
  destruct H; [apply add_correct | apply add_complete]; trivial.
 Qed.

 Lemma subset_empty : forall s, empty [<=] s.
 Proof.
  intros; apply subset_complete.
  intros; elim (empty_spec H).
 Qed.

 Lemma subset_add : forall a s, s [<=] (add a s).
 Proof.
  intros; apply subset_complete.
  intros; apply add_complete; auto.
 Qed.

 Lemma add_idem : forall x s,
  mem x s -> (add x s) [=] s.
 Proof.
  intros x s H; apply eq_complete.
  apply subset_complete; intros y Hy.
  case (ET.eq_dec x y); intro.
  rewrite <- e; trivial.
  apply add_inversion with x; trivial.
  apply subset_add.
 Qed.

 Add Morphism singleton
  with signature E.eq ==> eq
  as singleton_morphism.
 Proof.
  intros.
  unfold eq; apply eq_complete; apply subset_complete; intros.
  apply singleton_correct.
  rewrite <- H.
  apply singleton_complete; trivial.
  apply singleton_correct.
  rewrite H.
  apply singleton_complete; trivial.
 Qed.

 Lemma singleton_mem_diff : forall x y,
  ~E.eq x y -> ~mem y (singleton x).
 Proof.
  intros x y H; case_eq (mem y (singleton x)); intros; autob.
  elim H; apply singleton_complete; trivialb.
 Qed.

 Lemma mem_singleton_diff : forall x y,
  ~mem y (singleton x) -> ~E.eq x y.
 Proof.
  intros x y H H0.
  rewrite H0 in H.
  elim H; apply singleton_correct; trivial.
 Qed.

 Add Morphism remove
  with signature E.eq ==> eq ==> eq
  as remove_morphism.
 Proof.
  intros x y H s1 s2 H0.
  apply eq_complete; apply subset_complete; intros.
  apply remove_complete.
  rewrite <- H.
  intro H2; elim (remove_correct (E.eq_sym H2) H1).
  rewrite <- H0; apply remove_inversion with x; trivial.
  apply remove_complete.
  rewrite H.
  intro H2; elim (remove_correct (E.eq_sym H2) H1).
  rewrite H0; apply remove_inversion with y; trivial.
 Qed.

 Lemma remove_spec : forall x y s,
  mem y (remove x s) <-> (mem y s /\ ~E.eq x y).
 Proof.
  repeat split; intros.
  apply remove_inversion with x; trivial.
  intro H0; elim (remove_correct (E.eq_sym H0) H).
  apply remove_complete; destruct H; auto.
 Qed.

 Lemma subset_remove : forall x s, (remove x s) [<=] s.
 Proof.
  intros; apply subset_complete; intros.
  apply remove_inversion with x; trivial.
 Qed.

 Lemma remove_idem : forall x s,
  ~mem x s -> (remove x s) [=] s.
 Proof.
  intros x s H; apply eq_complete.
  apply subset_remove.
  apply subset_complete; intros y Hy.
  case (ET.eq_dec x y); intro e.
  rewrite e in H; trivialb.
  apply remove_complete; trivial.
 Qed.

 Add Morphism union
  with signature eq ==> eq ==> eq
  as union_morphism.
 Proof.
  intros; apply eq_complete; apply subset_complete; intros.
  destruct (union_correct H1).
  apply union_complete_l; rewrite <- H; trivial.
  apply union_complete_r; rewrite <- H0; trivial.
  destruct (union_correct H1).
  apply union_complete_l; rewrite H; trivial.
  apply union_complete_r; rewrite H0; trivial.
 Qed.

 Lemma union_spec : forall s1 s2 x,
  mem x (union s1 s2) <-> (mem x s1 \/ mem x s2).
 Proof.
  split.
  apply union_correct.
  destruct 1; auto using union_complete_l, union_complete_r.
 Qed.

 Lemma union_sym : forall s1 s2, union s1 s2 [=] union s2 s1.
 Proof.
  intros; rewrite eq_spec; split; apply subset_complete; intros x H;
   rewrite union_spec in *; destruct H; auto.
 Qed.

 Lemma union_empty : forall s, union empty s [=] s.
 Proof.
  intros; apply eq_complete; apply subset_complete; intros.
  destruct (union_correct H); trivial.
  elim (empty_spec H0).
  apply union_complete_r; trivial.
 Qed.

 Lemma subset_union_l : forall s1 s2, s1 [<=] (union s1 s2).
 Proof.
  intros; apply subset_complete; intros.
  apply union_complete_l; auto.
 Qed.

 Lemma subset_union_r : forall s1 s2, s2 [<=] (union s1 s2).
 Proof.
  intros; apply subset_complete; intros.
  apply union_complete_r; auto.
 Qed.

 Lemma union_assoc : forall s1 s2 s3, union (union s1 s2) s3 [=] union s1 (union s2 s3).
 Proof.
  intros; rewrite eq_spec; split; apply subset_complete; intro x;
  repeat rewrite union_spec; tauto.
 Qed.

 Lemma subset_union : forall s1 s2, s1 [<=] s2 -> union s1 s2 [=] s2.
 Proof.
  intros s1 s2; rewrite eq_spec; repeat rewrite subset_iff;
  split; intros; rewrite union_spec in *; intuition.
 Qed.

 Lemma union_idem : forall s, union s s [=] s.
 Proof.
  intros; apply eq_complete; rewrite subset_iff; intros;
  rewrite union_spec in *; intuition.
 Qed.

 Lemma subset_union_ctxt : forall s1 s1' s2 s2',
   s1 [<=] s1' -> s2 [<=] s2' -> union s1 s2 [<=] union s1' s2'.
 Proof.
  intros s1 s1' s2 s2'; repeat rewrite subset_iff; intros.
  rewrite union_spec in *; intuition.
 Qed.

 Lemma union_subset : forall s1 s2 s3,
  s1 [<=] s3 ->
  s2 [<=] s3 ->
  union s1 s2 [<=] s3.
 Proof.
  intros; rewrite <- (union_idem s3).
  apply subset_union_ctxt; trivial.
 Qed.

 Add Morphism inter
  with signature eq ==> eq ==> eq
  as inter_morphism.
 Proof.
  intros s1 s2 H s3 s4 H0.
  apply eq_complete; apply subset_complete; intros.
  apply inter_complete.
  rewrite <- H; apply inter_correct_l with s3; trivial.
  rewrite <- H0; apply inter_correct_r with s1; trivial.
  apply inter_complete.
  rewrite H; apply inter_correct_l with s4; trivial.
  rewrite H0; apply inter_correct_r with s2; trivial.
 Qed.

 Lemma inter_spec : forall s1 s2 x,
  mem x (inter s1 s2) <-> (mem x s1 /\ mem x s2).
 Proof.
  repeat split; intros.
  apply inter_correct_l with s2; trivial.
  apply inter_correct_r with s1; trivial.
  apply inter_complete; autob.
 Qed.

 Lemma inter_sym : forall s1 s2, inter s1 s2 [=] inter s2 s1.
 Proof.
  intros s1 s2; apply eq_complete; apply subset_complete;
   eauto using inter_complete, inter_correct_l, inter_correct_r.
 Qed.

 Lemma subset_inter_l : forall s1 s2, (inter s1 s2) [<=] s1.
 Proof.
  intros; apply subset_complete; intros.
  apply inter_correct_l with s2; trivial.
 Qed.

 Lemma subset_inter_r : forall s1 s2, (inter s1 s2) [<=] s2.
 Proof.
  intros; apply subset_complete; intros.
  apply inter_correct_r with s1; trivial.
 Qed.

 Lemma subset_inter : forall s1 s2,
  s1 [<=] s2 -> inter s1 s2 [=] s1.
 Proof.
  intros.
  apply eq_complete; apply subset_complete; intros.
  eauto using inter_correct_l.
  eauto using inter_complete, subset_correct.
 Qed.

 Lemma inter_idem : forall s, inter s s [=] s.
 Proof.
  intros; rewrite subset_inter.
  apply eq_refl.
  apply subset_refl.
 Qed.

 Add Morphism diff
  with signature eq ==> eq ==> eq
  as diff_morphism.
 Proof.
  intros s1 s2 H s3 s4 H0.
  apply eq_complete; apply subset_complete; intros.
  apply diff_complete.
  rewrite <- H; apply diff_correct_l with s3; trivial.
  rewrite <- H0; apply diff_correct_r with s1; trivial.
  apply diff_complete.
  rewrite H; apply diff_correct_l with s4; trivial.
  rewrite H0; apply diff_correct_r with s2; trivial.
 Qed.

 Lemma diff_spec : forall s1 s2 x,
  mem x (diff s1 s2) <-> (mem x s1 /\ ~mem x s2).
 Proof.
  repeat split; intros.
  apply diff_correct_l with s2; trivial.
  apply diff_correct_r with s1; trivial.
  apply diff_complete; autob.
 Qed.

 Lemma subset_diff : forall s1 s2, (diff s1 s2) [<=] s1.
 Proof.
  intros; apply subset_complete; intros.
  apply diff_correct_l with s2; trivial.
 Qed.

 Lemma remove_diff : forall x s,
  remove x s [=] diff s (singleton x).
 Proof.
  intros; rewrite eq_spec; split; apply subset_complete; intros.
  apply diff_complete.
  eauto using remove_inversion.
  intro H0.
  assert (W:=singleton_complete H0).
  exact (remove_correct (E.eq_sym W) H).
  eauto using remove_complete, mem_singleton_diff, diff_correct_r,
   diff_correct_l.
 Qed.

 Lemma union_diff_assoc : forall s1 s2 s3, union (diff s1 s3) (diff s2 s3) [=] diff (union s1 s2) s3.
 Proof.
   intros; rewrite eq_spec; split; apply subset_complete; intros;
   repeat (rewrite union_spec in * ||  rewrite diff_spec in * ); tauto.
 Qed.

 Lemma union_diff : forall s1 s2, union (diff s1 s2) s2 [=] union s1 s2.
 Proof.
  intros; rewrite eq_spec; split; apply subset_complete; intros;
   repeat (rewrite union_spec in * ||  rewrite diff_spec in * ); intuition.
  destruct (mem x s2); auto.
  left; split; auto.
  intros; autob.
 Qed.

 (* To declare [elements] and [fold] as morphisms it is necessary to declare
    equality on lists up to permutation as a relation first (as done in the
    Coq standard library)*)

 Lemma elements_empty : elements empty = nil.
 Proof.
  generalize (@elements_complete empty).
  destruct (elements empty); trivial.
  intros; assert (mem t0 empty) by auto.
  elim (empty_spec H0).
 Qed.

 Lemma mem_fold_add_inversion : forall l s x,
  mem x (fold_left (fun s y => add y s) l s) ->
  InA E.eq x l \/ mem x s.
 Proof.
  induction l; simpl; intros.
  auto.
  case (ET.eq_dec a x); intro.
  auto.
  assert (InA E.eq x l \/ mem x (add a s)).
  apply IHl; trivial.
  destruct H0; auto.
  right; apply (add_inversion n H0).
 Qed.

 Lemma mem_fold_add_r : forall l s x,
  mem x s -> mem x (fold_left (fun s y => add y s) l s).
 Proof.
  induction l; simpl; intros.
  trivial.
  auto using add_complete.
 Qed.

 Lemma mem_fold_add_l : forall s1 s2 x,
  mem x s1 -> mem x (fold add s1 s2).
 Proof.
  intros s1 s2 x H; rewrite fold_spec; generalize s2; clear s2.
  assert (W:=elements_correct H).
  induction (elements s1); intros; simpl; inversion_clear W.
  auto using mem_fold_add_r, add_correct.
  auto.
 Qed.

 Lemma union_fold : forall s1 s2,
  union s1 s2 [=] fold add s1 s2.
 Proof.
  intros; apply eq_complete; apply subset_complete; intros.
  destruct (union_correct H).
  auto using mem_fold_add_l.
  rewrite fold_spec; auto using mem_fold_add_r.
  rewrite fold_spec in H.
  destruct (mem_fold_add_inversion _ _ H);
   auto using union_complete_l, union_complete_r, elements_complete.
 Qed.

 Lemma diff_le_compat : forall s1 s2 s1' s2',
     s1 [<=] s1' -> s2' [<=] s2 ->
     diff s1 s2 [<=] diff s1' s2'.
 Proof.
  intros s1 s2 s1' s2'; repeat rewrite subset_iff; intros H H0 x;
  repeat rewrite diff_spec; intuition.
 Qed.

 Hint Resolve subset_complete eq_correct_l eq_correct_r
  eq_complete add_correct add_complete
  singleton_correct singleton_complete remove_correct remove_complete
  union_complete_l union_complete_r inter_correct_l inter_correct_r
  diff_correct_l diff_correct_r elements_correct
  subset_refl subset_trans eq_refl eq_trans
  subset_empty singleton_mem_diff mem_singleton_diff diff_le_compat: set.

 Hint Immediate subset_correct eq_complete mem_correct
  empty_spec union_correct inter_complete diff_complete
  elements_complete eq_sym subset_empty subset_add subset_remove
  subset_union_l subset_union_r subset_inter_l subset_inter_r
  subset_diff remove_diff : set.

 Lemma empty_union : forall s1 s2,
   union s1 s2 [=] empty ->
   s1 [=] empty /\ s2 [=] empty.
 Proof.
  intros; apply eq_spec in H; destruct H.
  split; apply eq_spec; split; auto with set;
  eapply subset_trans; eauto; auto with set.
 Qed.

 Lemma inter_remove_comm : forall x s1 s2,
  inter (remove x s1) s2 [=] remove x (inter s1 s2).
 Proof.
  intros; apply eq_complete; apply subset_complete; intro;
   rewrite remove_spec; repeat rewrite inter_spec;
   try rewrite remove_spec; tauto.
 Qed.

 Lemma add_remove : forall x s, add x (remove x s) [=] add x s.
 Proof.
  intros; apply eq_complete; apply subset_complete; intro;
   repeat rewrite add_spec; rewrite remove_spec; try tauto.
  assert (W:=E.eqb_spec x x0); destruct (E.eqb x x0); tauto.
 Qed.

 Lemma add_union_comm : forall x s1 s2,
  add x (union s1 s2) [=] union (add x s1) s2.
 Proof.
   intros; apply eq_complete; apply subset_complete; intro;
    repeat (rewrite union_spec || rewrite add_spec); tauto.
 Qed.

 Lemma add_union_swap : forall x s1 s2,
  union (add x s1) s2 [=] union s1 (add x s2).
 Proof.
  intros x s1 s2; rewrite (union_sym s1); repeat rewrite <- add_union_comm;
   rewrite union_sym; apply eq_refl.
 Qed.

 Lemma inter_union_comm : forall s1 s2 s3,
  inter s1 (union s2 s3) [=] union (inter s1 s2) (inter s1 s3).
 Proof.
  intros; apply eq_complete; apply subset_complete; intro;
   repeat (rewrite union_spec || rewrite inter_spec); tauto.
 Qed.

 Lemma union_inter_comm : forall s1 s2 s3,
  union (inter s1 s2) s3 [=]
  inter (union s1 s3) (union s2 s3).
 Proof.
  intros; apply eq_complete; apply subset_complete; intro;
   repeat (rewrite union_spec || rewrite inter_spec); tauto.
 Qed.

 Lemma empty_dec : forall s, s[=] empty \/ exists x, mem x s.
 Proof.
  intros s; case_eq (elements s); intros.
  left; apply eq_complete; auto with set.
  apply subset_complete; intros.
  assert (U:=elements_correct H0); rewrite H in U; inversion U.
  right; exists t0; apply elements_complete.
  rewrite H; constructor; trivial.
 Qed.

 Lemma subset_remove_ctxt : forall x s1 s2,
  s1 [<=] s2 -> remove x s1 [<=] remove x s2.
 Proof.
  intros x s1 s2; repeat rewrite subset_iff; intros.
  rewrite remove_spec in *; intuition.
 Qed.

 Lemma subset_inter_ctxt : forall s1 s1' s2 s2',
   s1 [<=] s1' -> s2 [<=] s2' -> inter s1 s2 [<=] inter s1' s2'.
 Proof.
  intros s1 s1' s2 s2'; repeat rewrite subset_iff; intros.
  rewrite inter_spec in *; intuition.
 Qed.

 Lemma subset_add_ctxt : forall x s1 s2,
   s1 [<=] s2 -> (add x s1) [<=] (add x s2).
 Proof.
  intros x s1 s2; repeat rewrite subset_iff; intros.
  rewrite add_spec in *; intuition.
 Qed.

 Lemma disjoint_sym : forall s1 s2, disjoint s1 s2 -> disjoint s2 s1.
 Proof.
  unfold disjoint; intros; rewrite inter_sym; trivial.
 Qed.

 Lemma disjoint_subset_l : forall X Y Z,
  X [<=] Y ->
  disjoint Y Z ->
  disjoint X Z.
 Proof.
  unfold disjoint; intros X Y Z Hsub Heq.
  apply eq_complete; auto with set.
  change (inter Y Z [=] empty) in Heq.
  rewrite <- Heq.
  apply subset_inter_ctxt; auto with set.
 Qed.

 Lemma disjoint_mem_not_mem : forall s1 s2,
  disjoint s1 s2 -> forall x, mem x s1 -> ~mem x s2.
 Proof.
  unfold disjoint; intros s1 s2 H x H1 H2.
  assert (mem x (inter s1 s2)) by auto using inter_complete.
  change (inter s1 s2 [=] empty) in H.
  rewrite H in H0; elim (empty_spec H0).
 Qed.

 Lemma disjoint_complete : forall X1 X2,
      (forall x, mem x X1 -> ~mem x X2) -> disjoint X1 X2.
 Proof.
  unfold disjoint; intros.
  change ((inter X1 X2) [=] empty).
  apply eq_complete; apply subset_complete; intros.
  rewrite inter_spec in H0; destruct H0.
  elim (H _ H0 H1).
  elim (empty_spec H0).
 Qed.

 Lemma filter_union : forall s f,
  (forall x y, E.eq x y -> f x = f y) ->
  s [=] union (filter f s) (filter (fun x => negb (f x)) s).
 Proof.
  intros s f Hf.
  assert (Hnf: forall x y, E.eq x y -> negb (f x) = negb (f y)) by
   (intros y z Heq; rewrite (Hf _ _ Heq); trivial).

  apply eq_complete.
  apply subset_complete; intros x Hx.
  case_eq (f x); intro H.
  apply union_complete_l; apply filter_complete; trivial.
  apply union_complete_r; apply filter_complete; trivialb.

  apply subset_complete; intros x Hx.
  destruct (union_correct Hx).
  destruct (filter_correct Hf H); trivial.
  destruct (filter_correct Hnf H); trivial.
 Qed.

 Lemma filter_subset : forall s f,
  (forall x y, E.eq x y -> f x = f y) ->
  (filter f s) [<=] s.
 Proof.
  intros s f Hf; apply subset_complete; intros x Hx.
  generalize (filter_correct Hf Hx); intuition.
 Qed.

End MkSet_Theory.

(** A concrete implementation of [SET] using lists *)
Module MkListSet (X:EQDEC) <: SET.

 Module E := X.
 Module ET := MkEqDec_Theory X.

 Definition t := list X.t.

 Definition empty : t := nil.

 Definition singleton (x:X.t) : t := x::nil.

 Fixpoint mem (x:X.t) (s:t) {struct s} : bool :=
  match s with
   | nil => false
   | y :: s' => if X.eqb x y then true else mem x s'
  end.

 Fixpoint add (x:X.t) (s:t) {struct s} : t :=
  match s with
   | nil => x::nil
   | y :: s' => if X.eqb x y then y :: s' else y :: add x s'
  end.

 Fixpoint remove (x:X.t) (s:t) {struct s} : t :=
  match s with
   | nil => nil
   | y::s' => if X.eqb x y then remove x s' else y::remove x s'
  end.

 Fixpoint inter (s1 s2:t) {struct s1} : t :=
  match s1 with
   | nil => nil
   | y :: s1' => if mem y s2 then y :: inter s1' s2 else inter s1' s2
  end.

 Fixpoint union (s1 s2:t) {struct s1} : t :=
  match s1 with
   | nil => s2
   | y :: s1' =>  union s1' (add y s2)
  end.

 Fixpoint diff (s1 s2:t) {struct s2} : t :=
  match s2 with
   | nil => s1
   | x :: s2' => remove x (diff s1 s2')
  end.

 Fixpoint subsetb (s1 s2:t) {struct s1} : bool :=
  match s1 with
   | nil => true
   | x :: s1' => if mem x s2 then subsetb s1' s2 else false
  end.

 Definition filter : (E.t -> bool) -> t -> t := @List.filter E.t.

 Definition eqb (s1 s2:t) : bool :=
  if subsetb s1 s2 then subsetb s2 s1 else false.

 Definition subset : t -> t -> Prop := subsetb.

 Definition eq : t -> t -> Prop := eqb.

 Definition elements (s:t) : list E.t := s.

 Definition fold (A:Type) (f:X.t -> A -> A) (s:t) (i:A) :=
  fold_left (fun a x => f x a) s i.

 Definition forallb (f:X.t ->bool) :=
  Eval cbv beta delta [List.forallb andb ifb] in List.forallb f.

 Notation "s [=] t" := (eq s t) (at level 70, no associativity).
 Notation "s [<=] t" := (subset s t) (at level 70, no associativity).
 Notation "s '[=?]' t" := (eqb s t) (at level 70, no associativity).
 Notation "s '[<=?]' t" := (subsetb s t) (at level 70, no associativity).

 Definition disjoint s1 s2 := eqb (inter s1 s2) empty.

 (** * Specification *)

 (** Specification of [mem] *)
 Lemma mem_correct : forall x y s,
  X.eq x y -> mem x s -> mem y s.
 Proof.
  induction s; trivial.
  simpl; intros.
  case (ET.eq_dec x a); intro.
  assert (X.eqb y a) by eauto.
  trivialb.

  rewrite H in n.
  assert (~X.eqb x a) by eauto.
  rewrite ET.neq_neqb in n.
  autob.
 Qed.

 (** Specification of [subset] *)
 Lemma subset_correct : forall s1 s2,
  s1 [<=] s2 -> (forall x, mem x s1 -> mem x s2).
 Proof.
  unfold subset; induction s1; simpl; intros; autob.
  case_eq (mem a s2); intro.
  case_eq (X.eqb x a); intro.
  apply mem_correct with a; auto.
  rewrite H1 in H; rewrite H2 in H0; autob.
  rewrite H1 in H; trivialb.
 Qed.

 Lemma subset_complete : forall s1 s2,
  (forall x, mem x s1 -> mem x s2) -> s1 [<=] s2.
 Proof.
  unfold subset; induction s1; simpl; intros; autob.
  assert (W:=H a).
  assert (X.eqb a a) by auto.
  simplb.
  apply IHs1; intros.
  apply H; intros.
  case (X.eqb x a); trivialb.
 Qed.

 (** Specification of [eqb] *)
 Lemma eq_correct_l : forall s1 s2,
  s1 [=] s2 -> s1 [<=] s2.
 Proof.
  intros s1 s2; unfold eq, eqb, subset.
  case (s1 [<=?] s2); trivial.
 Qed.

 Lemma eq_correct_r : forall s1 s2,
  s1 [=] s2 -> s2 [<=] s1.
 Proof.
  intros s1 s2; unfold eq, eqb, subset.
  case (s2 [<=?] s1); case (s1 [<=?] s2); trivial.
 Qed.

 Lemma eq_complete : forall s1 s2,
  s1 [<=] s2 -> s2 [<=] s1 -> s1 [=] s2.
 Proof.
  unfold eq, eqb, subset; intros; trivialb.
 Qed.

 (** Specification of [empty] *)
 Lemma empty_spec : forall x, ~mem x empty.
 Proof.
  intros x; unfold empty; trivialb.
 Qed.

 (** Specification of [add] *)
 Lemma add_correct : forall x y s,
  X.eq x y -> mem y (add x s).
 Proof.
  induction s; simpl; intros.
  assert (X.eqb y x) by auto; trivialb.

  case (ET.eq_dec x a); intro.
  assert (X.eqb x a) by auto; assert (X.eqb y a) by eauto; trivialb; simpl;
   trivialb.
  assert (~X.eqb y a) by eauto; rewrite ET.eq_eqb in n.
  rewrite (if_notb n); simpl.
  rewrite (if_notb H0); auto.
 Qed.

 Lemma add_complete : forall x y s,
  mem y s -> mem y (add x s).
 Proof.
  induction s; simpl; intros.
  trivialb.
  case (X.eqb x a); simpl; destruct (X.eqb y a); autob.
 Qed.

 Lemma add_inversion : forall x y s,
  ~X.eq x y -> mem y (add x s) -> mem y s.
 Proof.
  induction s; simpl; intros.
  assert (~X.eqb y x) by auto.
  rewrite (if_notb H1) in H0; trivialb.
  destruct (X.eqb x a); simpl in H0; destruct (X.eqb y a); autob.
 Qed.

 (** Specification of [singleton] *)
 Lemma singleton_correct : forall x y,
  X.eq x y -> mem y (singleton x).
 Proof.
  intros; simpl.
  assert (X.eqb y x) by auto; trivialb.
 Qed.

 Lemma singleton_complete : forall x y,
  mem y (singleton x) -> X.eq x y.
 Proof.
  simpl; intros.
  symmetry.
  apply ET.eq_eqb_r; destruct (X.eqb y x); trivial.
 Qed.

 (** Specification of [remove] *)
 Lemma remove_correct : forall x y s,
  X.eq x y -> ~mem x (remove y s).
 Proof.
  induction s; intros.
  trivialb.
  simpl; case (ET.eq_dec y a); intro.
  assert (X.eqb y a) by auto.
  autob.
  assert (~X.eq x a) by eauto.
  rewrite ET.eq_eqb in n; rewrite ET.eq_eqb in H0.
  rewrite (if_notb n); simpl.
  rewrite (if_notb H0); auto.
 Qed.

 Lemma remove_complete : forall x y s,
  ~X.eq x y -> mem y s -> mem y (remove x s).
 Proof.
  induction s; intros.
  trivial.
  simpl in H0 |- *.
  case (ET.eq_dec x a); intro.
  assert (~X.eqb y a) by eauto.
  assert (X.eqb x a) by auto.
  autob.

  assert (~X.eqb x a) by auto.
  simplb; destruct (X.eqb y a); auto.
 Qed.

 Lemma remove_inversion : forall x y s,
  mem y (remove x s) -> mem y s.
 Proof.
  induction s; intros.
  trivial.
  simpl in H |- *.
  case (ET.eq_dec y a); intro.
  assert (X.eqb y a) by auto.
  trivialb.

  assert (~X.eqb y a) by auto.
  simplb.
  case (ET.eq_dec x a); intro.
  assert (X.eqb x a) by auto.
  trivialb.

  assert (~X.eqb x a) by auto.
  simplb; simpl in H; trivialb.
 Qed.

 (** Specification of [union] *)
 Lemma union_correct : forall s1 s2 x,
  mem x (union s1 s2) -> (mem x s1 \/ mem x s2).
 Proof.
  induction s1; simpl; intros; auto.
  destruct (IHs1 (add a s2) x H).
  left; rewrite H0; destruct (X.eqb x a); trivial.
  case (ET.eq_dec a x); intro.
  assert (X.eqb x a) by auto; autob.
  right; apply add_inversion with a; trivial.
 Qed.

 Lemma union_complete : forall s1 s2 x,
  mem x s1 \/ mem x s2 -> mem x (union s1 s2).
 Proof.
  induction s1; simpl; intros s2 x H.
  destruct H; autob.

  apply IHs1; simpl.
  case (ET.eq_dec x a); intro.
  assert (X.eqb x a) by auto.
  right; auto using add_correct.

  destruct H; auto using add_complete.
  assert (~X.eqb x a) by auto; trivialb.
  auto.
 Qed.

 Lemma union_complete_l : forall s1 s2 x,
  mem x s1 -> mem x (union s1 s2).
 Proof.
  auto using union_complete.
 Qed.

 Lemma union_complete_r : forall s1 s2 x,
  mem x s2 -> mem x (union s1 s2).
 Proof.
  auto using union_complete.
 Qed.

 (** Specification of [inter] *)
 Lemma inter_correct_l : forall s1 s2 x,
  mem x (inter s1 s2) -> mem x s1.
 Proof.
  induction s1; intros.
  trivial.

  simpl in *.
  case_eq (X.eqb x a); intro; trivial.
  case_eq (mem a s2); intro; simplb.
  simpl in H; eautob.
  eauto.
 Qed.

 Lemma inter_correct_r : forall s1 s2 x,
  mem x (inter s1 s2) -> mem x s2.
 Proof.
  induction s1; simpl; intros.
  trivialb.
  case_eq (mem a s2); intro; simplb; simpl in H.
  case (ET.eq_dec x a); intro.
  apply mem_correct with a; auto.
  assert (~X.eqb x a) by auto; simplb; auto.
  auto.
 Qed.

 Lemma inter_complete : forall s1 s2 x,
  mem x s1 -> mem x s2 -> mem x (inter s1 s2).
 Proof.
  induction s1; simpl; intros.
  trivialb.

  case_eq (X.eqb x a); intro.
  case_eq (mem a s2); intro; trivialb.
  assert (~mem a s2) by autob.
  assert (X.eq x a) by auto.
  elim H; eauto using mem_correct.

  case (mem a s2); autob.
 Qed.

 (** Specification of [diff] *)
 Lemma diff_correct_l : forall s1 s2 x,
  mem x (diff s1 s2) -> mem x s1.
 Proof.
  induction s2; simpl; intros.
  trivial.
  eauto using remove_inversion.
 Qed.

 Lemma diff_correct_r : forall s1 s2 x,
  mem x (diff s1 s2) -> ~mem x s2.
 Proof.
  induction s2; simpl; intros.
  trivialb.

  case (ET.eq_dec x a); intro; simplb.
  assert (X.eqb x a) by auto; simplb.
  elim (remove_correct (diff s1 s2) e); auto.
  assert (~X.eqb x a) by auto; simplb.
  eauto using remove_inversion.
 Qed.

 Lemma diff_complete : forall s1 s2 x,
  mem x s1 -> ~mem x s2 -> mem x (diff s1 s2).
 Proof.
  induction s2; simpl; intros.
  trivial.
  case (ET.eq_dec x a); intro.
  assert (X.eqb x a) by auto; trivialb.
  assert (~X.eqb x a) by auto; simplb.
  apply remove_complete; auto.
 Qed.

 (** Specification of [fold] *)
 Lemma fold_spec : forall A (f:X.t -> A -> A) i s,
  fold f s i = fold_left (fun x a => f a x) (elements s) i.
 Proof.
  trivial.
 Qed.

 (* Alternatively,
 Parameter fold_spec : forall A (f:E.t -> A -> A) i s,
  fold f s i = fold_right f i (elements s). *)

 (** Specification of [elements] *)
 Lemma elements_correct : forall s x,
  mem x s -> InA X.eq x (elements s).
 Proof.
  induction s; unfold elements; simpl; intros.
  trivialb.
  case (ET.eq_dec x a); intro.
  constructor; trivial.
  rewrite ET.eq_eqb in n; simplb.
  constructor 2; auto.
 Qed.

 Lemma elements_complete : forall s x,
  InA X.eq x (elements s) -> mem x s.
 Proof.
  induction s; unfold elements; simpl; intros.
  inversion H.
  inversion H.
  rewrite ET.eq_eqb in H1; trivialb.
  destruct (X.eqb x a); auto.
 Qed.

 Lemma filter_correct : forall (f:E.t->bool) x s,
  (forall x y, E.eq x y -> f x = f y) -> mem x (filter f s) -> mem x s /\ f x.
 Proof.
  intros.
  assert (W:=elements_correct _ _ H0).
  rewrite InA_spec in W; destruct W as (y,(W1,W2)).
  unfold filter, elements in W2; rewrite filter_In in W2.
  destruct W2; rewrite (H _ _ W1); split; trivial.
  apply elements_complete.
  rewrite InA_spec.
  exists y; auto.
 Qed.

 Lemma filter_complete : forall (f:E.t -> bool) x s,
  (forall x y, E.eq x y -> f x = f y) ->
  mem x s -> f x -> mem x (filter f s).
 Proof.
  intros.
  assert (W:=elements_correct _ _ H0).
  rewrite InA_spec in W; destruct W as (y, (W1,W2)).
  assert (In y s /\ f y).
  rewrite <- (H _ _ W1); auto.
  unfold filter, is_true in H2; rewrite <- filter_In in H2.
  apply elements_complete.
  rewrite InA_spec; exists y; auto.
 Qed.

 Lemma forallb_correct : forall f, (forall x y, X.eq x y -> f x = f y) ->
  forall s, forallb f s -> forall x, mem x s -> f x.
 Proof.
  induction s; simpl; intros; autob.
  assert (W:= X.eqb_spec x a); destruct (X.eqb x a).
  rewrite (H x a W).
  destruct (f a); trivialb.
  destruct (f a); trivialb; auto.
 Qed.

 Lemma forallb_complete : forall (f:E.t -> bool),
  (forall x y, X.eq x y -> f x = f y) ->
  forall s, (forall x, mem x s -> f x) -> forallb f s.
 Proof.
  induction s; simpl; intros; auto.
  assert (W:= H0 a).
  assert (Heq:= X.eqb_spec a a); destruct (X.eqb a a).
  rewrite W; auto.
  apply IHs; intros; apply H0.
  destruct (X.eqb x a); auto.
  elim Heq; apply X.eq_refl.
 Qed.

End MkListSet.


(* From coq-projects/circuits/ *)
Require Import Bool.
Require Import Nat.
Require Import Arith.
Require Import Lia.

Definition half_adder_sum (b1 : bool) (b2: bool) : bool:=
match b1, b2 with
| true, true => false
| true, false => true
| false, true => true
| false, false => false
end.

Definition half_adder_carry (b1 : bool) (b2: bool) : bool:=
match b1 with
| true => b2
| false => false
end.

Definition bool_to_nat (b : bool) :=
  match b with
  | true => 1
  | false => 0
  end.

Lemma half_adder_sum_sym:
  forall a b: bool, half_adder_sum a b = half_adder_sum b a.
Proof.
  induction a; induction b; auto.
Qed.

Lemma half_adder_carry_sym:
  forall a b: bool, half_adder_carry a b = half_adder_carry b a.
Proof.
simple  induction a; induction b; auto.
Qed.

Lemma half_adder_sum_false : forall a : bool, half_adder_sum a false = a.
Proof.
simple induction a; auto.
Qed.

Lemma half_adder_carry_false :
 forall a : bool, half_adder_carry a false = false.
Proof.
 simple induction a; auto.
Qed.

Lemma half_adder_sum_true : forall a : bool, half_adder_sum a true = negb a.
Proof.
auto.
Qed.

Lemma half_adder_carry_true : forall a : bool, half_adder_carry a true = a.
Proof.
simple induction a; auto.
Qed.

Theorem half_adder_ok :
 forall a b : bool,
 bool_to_nat (half_adder_sum a b) +
 (bool_to_nat (half_adder_carry a b) + bool_to_nat (half_adder_carry a b)) =
 bool_to_nat a + bool_to_nat b.
Proof.
simple induction a; simple induction b; auto.
Qed.

Definition full_adder_sum (a b c : bool) :=
  match true with
  | true => half_adder_sum (half_adder_sum a b) c
  | false => false
  end.

Definition full_adder_carry (a b c : bool) :=
  match half_adder_carry a b with
  | true => true
  | false => half_adder_carry (half_adder_sum a b) c
  end.

Lemma full_adder_sum_sym1 :
 forall a b c : bool, full_adder_sum a b c = full_adder_sum b a c.
Proof.
simple induction a; simple induction b; auto.
Qed.

Lemma full_adder_sum_sym2 :
 forall a b c : bool, full_adder_sum a b c = full_adder_sum a c b.
Proof.
simple induction b.
simple induction c.
auto.
unfold full_adder_sum in |- *.
rewrite half_adder_sum_false.
rewrite half_adder_sum_false.
auto.
unfold full_adder_sum in |- *. intro.
rewrite half_adder_sum_false.
rewrite half_adder_sum_false.
auto.
Qed.

Lemma full_adder_sum_false :
 forall a : bool, full_adder_sum a false false = a.
Proof.
 simple induction a; auto.
Qed.

Lemma full_adder_sum_true : forall a : bool, full_adder_sum a true true = a.
Proof.
simple induction a; auto.
Qed.

Lemma full_adder_carry_sym1 :
 forall a b c : bool, full_adder_carry a b c = full_adder_carry b a c.
Proof.
simple induction a; simple induction b; auto.
Qed.

Lemma full_adder_carry_sym2 :
 forall a b c : bool, full_adder_carry a b c = full_adder_carry a c b.
Proof.
simple induction b.
simple induction c.
auto.
unfold full_adder_carry in |- *.
rewrite half_adder_sum_false.
rewrite half_adder_carry_false.
rewrite half_adder_carry_false.
simpl in |- *.
elim (half_adder_carry a true); auto.
intros.
unfold full_adder_carry in |- *.
rewrite half_adder_carry_false.
rewrite half_adder_sum_false.
rewrite half_adder_carry_false.
simpl in |- *.
elim (half_adder_carry a c); auto.
Qed.

Lemma full_adder_carry_false :
 forall a : bool, full_adder_carry a false false = false.
Proof.
simple induction a; auto.
Qed.

Lemma full_adder_carry_true :
 forall a : bool, full_adder_carry a true true = true.
Proof.
simple induction a.
unfold full_adder_carry in |- *.
auto.
unfold full_adder_carry in |- *.
auto.
Qed.

Lemma full_adder_carry_true_false :
 forall a : bool, full_adder_carry a true false = a.
Proof.
simple induction a; auto.
Qed.

Lemma full_adder_carry_neg :
 forall a b : bool, full_adder_carry a (negb a) b = b.
Proof.
simple induction a; simple induction b; simpl in |- *.
rewrite full_adder_carry_sym1.
rewrite full_adder_carry_true. trivial.
rewrite full_adder_carry_false. trivial.
rewrite full_adder_carry_true. trivial.
rewrite full_adder_carry_sym1.
rewrite full_adder_carry_false. trivial.
Qed.

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

Theorem full_adder_ok :
 forall a b c : bool,
 bool_to_nat (full_adder_sum a b c) +
 (bool_to_nat (full_adder_carry a b c) + bool_to_nat (full_adder_carry a b c)) =
 bool_to_nat a + bool_to_nat b + bool_to_nat c.
Proof.
simple induction a; simple induction b; simple induction c; auto.
Qed.

Lemma plus_permute2 : forall x y z : nat, x + y + z = x + z + y.
Proof.
intros.
rewrite (plus_comm x y).
rewrite (plus_comm x z).
rewrite plus_comm.
symmetry  in |- *.
rewrite plus_comm.
rewrite plus_permute.
auto with arith.
Qed.

Inductive boolList : Type :=
| Nil : boolList
| Cons : bool -> boolList -> boolList.

(* Infix "::" := Cons (at level 60, right associativity). *)

Definition length : boolList -> nat :=
  fix length l :=
  match l with
   | Nil => O
   | Cons _ l' => S (length l')
  end.

Definition app : boolList -> boolList -> boolList :=
  fix app l m :=
  match l with
   | Nil => m
   | Cons a l1 => Cons a (app l1 m)
  end.

(* Infix "++" := app (right associativity, at level 60). *)

Lemma app_eq2 : forall (x : bool) (l l' : boolList), app (Cons x l) l' = Cons x  (app l l').
Proof.
auto.
Qed.

Lemma length_eq2 :
 forall (x : bool) (l : boolList), length (Cons x l) = S (length l).
 Proof.
 auto with arith. Qed.

 Fixpoint bV_full_adder_sum_nil (l0: boolList) (b0: bool): boolList :=
  match l0 with
  | Nil => Nil
  | Cons b l1 => Cons (half_adder_sum b b0)
                      (bV_full_adder_sum_nil l1 (half_adder_carry b b0))
  end.

Fixpoint bV_full_adder_sum (l m: boolList) (bb: bool): boolList :=
  match l with
  | Nil => bV_full_adder_sum_nil m bb
  | Cons b l0 =>
    match m with
    | Nil =>
      Cons (half_adder_sum b bb) (bV_full_adder_sum l0 Nil (half_adder_carry b bb))
    | Cons b0 l1 =>
      Cons (full_adder_sum b b0 bb)
           (bV_full_adder_sum l0 l1 (full_adder_carry b b0 bb))
    end
  end.

Lemma BV_full_adder_sum_eq1 :
 forall b : bool, bV_full_adder_sum Nil Nil b = Nil.
Proof.
 auto.
Qed.

Lemma BV_full_adder_sum_eq2 :
 forall (vh : bool) (vt : boolList) (b : bool),
 bV_full_adder_sum Nil (Cons vh vt) b =
 Cons (half_adder_sum vh b)
   (bV_full_adder_sum Nil vt (half_adder_carry vh b)).
Proof.
 auto.
Qed.

Lemma BV_full_adder_sum_eq3 :
 forall (vh : bool) (vt : boolList) (b : bool),
 bV_full_adder_sum (Cons vh vt) Nil b =
 Cons (half_adder_sum vh b)
   (bV_full_adder_sum vt Nil (half_adder_carry vh b)).
Proof.
 auto.
Qed.

Lemma BV_full_adder_sum_eq4 :
 forall (vh : bool) (vt : boolList) (wh : bool) (wt : boolList) (b : bool),
 bV_full_adder_sum (Cons vh vt) (Cons wh wt) b =
 Cons (full_adder_sum vh wh b)
   (bV_full_adder_sum vt wt (full_adder_carry vh wh b)).
Proof.
 auto.
Qed.

Fixpoint bV_full_adder_carry_nil (l0: boolList) (bb: bool): bool :=
  match l0 with
  | Nil => bb
  | Cons b l1 => bV_full_adder_carry_nil l1 (half_adder_carry b bb)
  end.

Fixpoint bV_full_adder_carry (l m: boolList) (bb: bool) :=
  match l with
  | Nil => bV_full_adder_carry_nil m bb
  | Cons b l0 =>
    match m with
    | Nil => bV_full_adder_carry l0 Nil (half_adder_carry b bb)
    | Cons b0 l1 => bV_full_adder_carry l0 l1 (full_adder_carry b b0 bb)
    end
  end.

Lemma BV_full_adder_carry_eq1 :
 forall b : bool, bV_full_adder_carry Nil Nil b = b.
Proof.
 auto.
Qed.

Lemma BV_full_adder_carry_eq2 :
 forall (vh : bool) (vt : boolList) (b : bool),
 bV_full_adder_carry Nil (Cons vh vt) b =
 bV_full_adder_carry Nil vt (half_adder_carry vh b).
Proof.
 auto.
Qed.

Lemma BV_full_adder_carry_eq3 :
 forall (vh : bool) (vt : boolList) (b : bool),
 bV_full_adder_carry (Cons vh vt) Nil b =
 bV_full_adder_carry vt Nil (half_adder_carry vh b).

Proof.
 auto.
Qed.

Lemma BV_full_adder_carry_eq4 :
 forall (vh : bool) (vt : boolList) (wh : bool) (wt : boolList) (b : bool),
 bV_full_adder_carry (Cons vh vt) (Cons wh wt) b =
 bV_full_adder_carry vt wt (full_adder_carry vh wh b).

Proof.
 auto.
Qed.

Definition bV_full_adder (v w : boolList) (cin : bool) : boolList :=
  match true with
  |true =>
  app (bV_full_adder_sum v w cin)
    (Cons (bV_full_adder_carry v w cin) Nil)
  | false => Nil
  end.

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

Lemma BV_full_adder_sum_v_nil_false :
 forall v : boolList, bV_full_adder_sum v Nil false = v.
Proof.
simple induction v. trivial. intros.
rewrite BV_full_adder_sum_eq3.
rewrite half_adder_carry_false.
rewrite half_adder_sum_false.
rewrite H; auto.
Qed.

Lemma BV_full_adder_carry_v_nil_false :
 forall v : boolList, bV_full_adder_carry v Nil false = false.
Proof.
simple induction v. trivial. intros.
rewrite BV_full_adder_carry_eq3.
rewrite half_adder_carry_false.
trivial.
Qed.

Lemma BV_full_adder_sum_sym :
 forall (v w : boolList) (cin : bool),
 bV_full_adder_sum v w cin = bV_full_adder_sum w v cin.
Proof.
simple induction v. simple induction w. auto. intros.
rewrite BV_full_adder_sum_eq2.
rewrite BV_full_adder_sum_eq3.
rewrite H. auto. simple induction w. intro.
rewrite BV_full_adder_sum_eq2.
rewrite BV_full_adder_sum_eq3. rewrite H.
auto. intros. repeat rewrite BV_full_adder_sum_eq4. rewrite H.
do 2 rewrite full_adder_carry_sym1.
do 2 rewrite full_adder_sum_sym1. auto.
Qed.

Lemma length_BV_full_adder_sum :
 forall (v w : boolList) (cin : bool),
 length v = length w -> length (bV_full_adder_sum v w cin) = length v.
Proof.
unfold length in |- *. simple induction v. simple induction w. intros. case cin. simpl in |- *. trivial.
simpl in |- *. trivial.
intros. absurd (length (Nil:boolList) = length (Cons b b0)).
simpl in |- *. discriminate. exact H0. simple induction w. simpl in |- *. intros. discriminate H0.
intros. simpl in |- *. rewrite H. trivial. generalize H1. simpl in |- *. auto.
Qed.

Lemma BV_full_adder_carry_sym :
 forall (v w : boolList) (cin : bool),
 bV_full_adder_carry v w cin = bV_full_adder_carry w v cin.
Proof.
simple induction v. simple induction w. auto. intros.
rewrite BV_full_adder_carry_eq2.
rewrite BV_full_adder_carry_eq3.
rewrite H; auto. simple induction w. intros.
rewrite BV_full_adder_carry_eq2.
rewrite BV_full_adder_carry_eq3.
rewrite H. auto. intros.
do 2 rewrite BV_full_adder_carry_eq4.
rewrite H. rewrite full_adder_carry_sym1. auto.
Qed.

Lemma BV_full_adder_sym :
 forall (v w : boolList) (cin : bool),
 bV_full_adder v w cin = bV_full_adder w v cin.
Proof.
unfold bV_full_adder in |- *.
intros.
rewrite BV_full_adder_sum_sym.
rewrite BV_full_adder_carry_sym. auto.
Qed.

Fixpoint bV_to_nat (v : boolList) : nat :=
  match v return nat with
  | Nil => 0
  | Cons b w => bool_to_nat b + (bV_to_nat w + bV_to_nat w)
  end.

Fixpoint power2 (n : nat) : nat :=
  match n with
  | O => 1
  | S x => power2 x + power2 x
  end.

Lemma BV_to_nat_app :
 forall (l n : boolList) (ll : nat),
 (******************)
 length l = ll -> bV_to_nat (app l n) = bV_to_nat l + power2 ll * bV_to_nat n.
Proof.
simple induction l. intros. inversion H. simpl in |- *. auto.
intros. simpl.
destruct ll.
inversion H0.
inversion H0.
rewrite (H n ll H2).
rewrite <- (plus_assoc (bool_to_nat b) (bV_to_nat b0 + bV_to_nat b0)).
f_equal.
rewrite <- plus_assoc.
rewrite <- (plus_assoc (bV_to_nat b0) (bV_to_nat b0)).
f_equal.
simpl.

rewrite mult_plus_distr_r.
repeat rewrite plus_assoc.
subst.
rewrite <- plus_assoc.
rewrite Nat.add_comm.
reflexivity.
Qed.

Lemma BV_to_nat_app2 :
 forall l n : boolList,
 (*******************)
 bV_to_nat (app l n) = bV_to_nat l + power2 (length l) * bV_to_nat n.
Proof.
 intros. apply BV_to_nat_app. auto.
Qed.

Lemma BV_full_adder_nil_true_ok :
 forall v : boolList, bV_to_nat (bV_full_adder v Nil true) = S (bV_to_nat v).
Proof.
simple induction v; auto with arith. unfold bV_full_adder in |- *. intros.
rewrite BV_full_adder_sum_eq3.
rewrite BV_full_adder_carry_eq3.
rewrite app_eq2.
rewrite half_adder_carry_true.
simpl in |- *. elim b. rewrite H. simpl in |- *. auto with arith.
rewrite BV_full_adder_sum_v_nil_false.
rewrite BV_full_adder_carry_v_nil_false.
rewrite BV_to_nat_app2.
simpl in |- *. elim mult_n_O. elim plus_n_O. trivial with arith.
Qed.

Lemma BV_full_adder_nil_ok :
 forall (v : boolList) (cin : bool),
 bV_to_nat (bV_full_adder v Nil cin) = bV_to_nat v + bool_to_nat cin.
 Proof.
simple induction v. simple induction cin; auto with arith.
simple induction cin. rewrite BV_full_adder_nil_true_ok. simpl in |- *. rewrite Nat.add_1_r. reflexivity.
unfold bV_full_adder in |- *. rewrite BV_full_adder_sum_v_nil_false.
rewrite BV_full_adder_carry_v_nil_false.
rewrite BV_to_nat_app2.
simpl in |- *. elim mult_n_O. elim plus_n_O. trivial with arith.
Qed.

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

Theorem BV_full_adder_ok :
 forall (v w : boolList) (cin : bool),
 bV_to_nat (bV_full_adder v w cin) =
 bV_to_nat v + bV_to_nat w + bool_to_nat cin.
Proof.
simple induction v.
intros.
rewrite BV_full_adder_sym.
simpl in |- *.
rewrite BV_full_adder_nil_ok.
auto with arith.

unfold bV_full_adder in |- *.
simple induction w.
rename b into a.
rename b0 into l.
simpl in |- *.
intro.
rewrite H.
simpl in |- *.
elim plus_n_O.
elim plus_n_O.
replace
 (bV_to_nat l + bool_to_nat (half_adder_carry a cin) +
  (bV_to_nat l + bool_to_nat (half_adder_carry a cin))) with
 (bool_to_nat (half_adder_carry a cin) + bool_to_nat (half_adder_carry a cin) +
  (bV_to_nat l + bV_to_nat l)).
repeat rewrite plus_assoc.
replace
 (bool_to_nat (half_adder_sum a cin) + bool_to_nat (half_adder_carry a cin) +
  bool_to_nat (half_adder_carry a cin)) with
 (bool_to_nat (half_adder_sum a cin) +
  (bool_to_nat (half_adder_carry a cin) +
   bool_to_nat (half_adder_carry a cin))).
rewrite half_adder_ok.
rewrite (plus_permute2 (bool_to_nat a) (bool_to_nat cin) (bV_to_nat l)).
rewrite
 (plus_permute2 (bool_to_nat a + bV_to_nat l) (bool_to_nat cin) (bV_to_nat l))
 .
trivial with arith.

trivial with arith.

repeat rewrite plus_assoc.
rewrite
 (plus_permute2 (bool_to_nat (half_adder_carry a cin))
    (bool_to_nat (half_adder_carry a cin)) (bV_to_nat l))
 .
rewrite (plus_comm (bool_to_nat (half_adder_carry a cin)) (bV_to_nat l)).
rewrite
 (plus_permute2 (bV_to_nat l + bool_to_nat (half_adder_carry a cin))
    (bool_to_nat (half_adder_carry a cin)) (bV_to_nat l))
 .
trivial with arith.

 rename b into a.
 rename b0 into l.
 intros a0 l0.
 intros.
simpl in |- *.
rewrite H.
clear H.
elim cin; elim a.
rewrite full_adder_carry_sym1.
rewrite full_adder_carry_true.
rewrite full_adder_sum_sym1.
rewrite full_adder_sum_true.
simpl in |- *.
repeat rewrite plus_n_SO.
elim plus_n_Sm.
elim plus_n_Sm.
simpl in |- *.
elim plus_n_Sm.
repeat rewrite plus_assoc.
lia.
(* rewrite *)
(*  (plus_permute2 (bool_to_nat a0 + bV_to_nat l) (bV_to_nat l0) (bV_to_nat l)) *)
(*  . *)
(* rewrite (plus_comm (bool_to_nat a0) (bV_to_nat l)). *)
(* rewrite (plus_permute2 (bV_to_nat l) (bool_to_nat a0) (bV_to_nat l)). *)
(* trivial with arith. *)

elim a0.
simpl in |- *.
elim plus_n_Sm.
simpl in |- *.
elim plus_n_O.
elim plus_n_Sm.
elim plus_n_Sm.
elim plus_n_Sm.
elim plus_n_O.
repeat rewrite plus_assoc.
rewrite (plus_permute2 (bV_to_nat l) (bV_to_nat l0) (bV_to_nat l)).
trivial with arith.

simpl in |- *.
repeat rewrite <- plus_n_Sm.
repeat rewrite <- plus_n_O.
repeat rewrite plus_assoc.
try trivial with arith.
rewrite (plus_permute2 (bV_to_nat l) (bV_to_nat l0) (bV_to_nat l)).
try trivial with arith.

elim a0.
simpl in |- *.
repeat rewrite <- plus_n_Sm.
repeat rewrite <- plus_n_O.
repeat rewrite plus_assoc.
simpl in |- *.
rewrite (plus_permute2 (bV_to_nat l) (bV_to_nat l0) (bV_to_nat l)).
trivial with arith.

simpl in |- *.
repeat rewrite <- plus_n_O.
repeat rewrite plus_assoc.
rewrite (plus_permute2 (bV_to_nat l) (bV_to_nat l0) (bV_to_nat l)).
trivial with arith.

elim a0; simpl in |- *; repeat rewrite <- plus_n_Sm;
 repeat rewrite <- plus_n_O; repeat rewrite plus_assoc;
 rewrite (plus_permute2 (bV_to_nat l) (bV_to_nat l0) (bV_to_nat l));
 trivial with arith.

Qed.


Require Import List Arith Bool Decidable PeanoNat Coq.Arith.Peano_dec.
Import ListNotations.
Require Extraction.

(** * A. Reflet bool/Prop *)

Print eqb.

Locate "=?".

Search((_ =? _ = false) -> ~(_ = _)).
Print beq_nat_false.

Search((_ =? _ = true) -> (_ = _)).
Print beq_nat_true.

(** * B. Relations d'ordre *)

(** * B.1 Supérieur ou égal dans Type *)

(*
n      m = n
^       /
|      /
|     x
|    /x
|   / x   m >= n
|  /  x
| /
|-----------------------> m
                          m >= S n
------ [diagonale]        -------- [descenteVerticale]
m >= m                    m >= n

 *)
(* Sorte Type car utilisé dans des calculs. *)
(* Paramétrisation par 'm : nat', indexation par un 'nat'. *)
Inductive SuperieurOuEgal(m : nat) : nat -> Prop :=
| diagonale : SuperieurOuEgal m m
| descenteVerticale : forall n, SuperieurOuEgal m (S n)  -> SuperieurOuEgal m n.

Proposition superieurOuEgal_Scroissante :
  forall m n, SuperieurOuEgal m n -> SuperieurOuEgal (S m) (S n).
Proof.
Admitted.

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

                          m <= n
------ [diagonale]        -------- [montéeVerticale]
m <= m                    m <= S n

*)

Definition superieurOuEgal_adequation : forall m n, (SuperieurOuEgal m n) -> (n <= m).
Proof.
  fix REC 3.
Admitted.

Definition superieurOuEgal_completude : forall m n, m <= n -> (SuperieurOuEgal n m).
Proof.
  fix REC 3.
Admitted.

(** * B.2 Inférieur strict *)
Print lt.
(*
S n <= m
--------
  n <  m

lt = fun n m : nat => S n <= m
     : nat -> nat -> Prop
*)

Lemma lt_inferieurStrict :
  forall m n, m < n -> (m <= n) /\ (m <> n).
Proof.
Admitted.

Lemma inferieurStrict_lt :
  forall m n, ((m <= n) /\ (m <> n)) -> (m < n).
Proof.
Admitted.

(** * Division euclidienne *)

Fixpoint divisionEuclidienne(n d : nat) : nat * nat.
Proof.
  case n as [ | pn].
Admitted.

Print divisionEuclidienne.

Example divisionEuclidienne_13_5 : divisionEuclidienne 13 5 = (2, 3).
Admitted.

Example divisionEuclidienne_14_5 : divisionEuclidienne 14 5 = (2, 4).
Admitted.

Example divisionEuclidienne_15_5 : divisionEuclidienne 15 5 = (3, 0).
Admitted.

Example divisionEuclidienne_13_0 : divisionEuclidienne 13 0 = (0, 13).
Admitted.

Definition quotient(n d : nat) : nat.
  case (divisionEuclidienne n d) as [q _].
  exact q.
Defined.

Print quotient.

Definition reste(n d : nat) : nat.
Admitted.

Print reste.

Proposition divEuclidienne_decomposition :
  forall n d, n = (quotient n d) * d + (reste n d).
Proof.
  (* unfold quotient, reste.*)
  fix HR 1.
  (* Indication : utiiser ring.*)
Admitted.

Proposition divEuclidienne_resteDivParZero : forall n, (reste n 0 = n).
Proof.
Admitted.

Proposition divEuclidienne_quotientDivParZero : forall n, (quotient n 0 = 0).
Proof.
Admitted.

Proposition divEuclidienne_majorationReste :
  forall n d, (0 < d) -> (reste n d) < d.
Proof.
Admitted.

Proposition divEuclidienne_caracterisation :
  forall d, (0 < d) ->
       forall n q r, (n = q * d + r) -> (r < d)
                -> ((quotient n d = q) /\ (reste n d = r)).
Proof.
  (* compliqué ! *)
Admitted.

Proposition divEuclidienne_caracterisationReste :
  forall d, (0 < d) ->
       forall n q r, (n = q * d + r) -> (r < d)
                -> (reste n d = r).
Proof.
Admitted.

Proposition reste_idempotence :
  forall d n, reste (reste n d) d = reste n d.
Proof.
Admitted.

Proposition reste_preMorphismeAdditif :
  forall d m n, reste (m + n) d = reste ((reste m d) + (reste n d)) d.
Proof.
Admitted.

Definition modulo_egalite(d m n: nat) : Prop.
  exact (reste m d = reste n d).
Defined.

Proposition modulo_egalite_reflexivite : forall d n, modulo_egalite d n n.
Proof.
Admitted.

Proposition modulo_egalite_symetrie : forall d m n, modulo_egalite d m n -> modulo_egalite d n m.
Proof.
Admitted.

Proposition modulo_egalite_transitivite :
  forall d n1 n2 m, modulo_egalite d n1 m -> modulo_egalite d m n2 -> modulo_egalite d n1 n2.
Proof.
Admitted.

Proposition modulo_egalite_compatibiliteAddition :
  forall d, forall m1 n1 m2 n2,
    modulo_egalite d m1 m2
    -> modulo_egalite d n1 n2
    -> modulo_egalite d (m1 + n1) (m2 + n2).
Proof.
Admitted.

(** * Vers une représentation canonique ? question difficile.

Modulo d (pour représenter les classes de la relation modulo (S d)) :
{(h : d, v : 0), ..., (h : 0, v : d)} formé de couples (h, v), avec
v la valeur et h le nombre de valeurs au-dessus. Invariant : h + v = d.

Construction en deux temps.

1. ModuloBrut(d : nat) : nat -> Type - paramétrisation par 'd' et indexation par 'h'

                          (ModuloBrut d (S h))
-------------- [zeroMod]  -------------------- [succMod]
ModuloBrut d d              (ModuloBrut d h)

Interprétation :
- ModuloBrut d h est le type singleton {h, v}, avec h + v = d.

2. Modulo (d : nat) : somme des singletons (ModuloBrut d h)

Modulo(d : nat) : Type.

(h : nat) (ModuloBrut d h)
-------------------------- [modulo]
       Modulo d

- Interprétation : Modulo d = {(d, 0), ..., (0, d)} - Nat modulo (S d)
*)

Inductive ModuloBrut(d : nat) : nat -> Type :=
| mb_zero : ModuloBrut d d
| mb_succ : forall h, ModuloBrut d (S h) -> ModuloBrut d h.

Fixpoint moduloBrut_valeur(d h : nat)(mb : ModuloBrut d h) : nat.
Proof.
  case mb as [ | h pmb].
  - exact 0.
  - exact (S (moduloBrut_valeur _ _ pmb)).
Defined.

Proposition moduloBrut_majoration :
  forall (d h : nat)(mb : ModuloBrut d h), SuperieurOuEgal d h.
Proof.
  fix HR 3.
Admitted.

Proposition moduloBrut_invariant :
  forall d h, forall (mb : ModuloBrut d h),
    (moduloBrut_valeur d h mb) + h = d.
Proof.
Admitted.

Inductive Modulo(d : nat) : Type :=
| modulo : forall h, ModuloBrut d h -> Modulo d.

Definition modulo_valeur(d : nat)(m : Modulo d) : nat.
Proof.
  case m as [h mb].
  exact (moduloBrut_valeur _ _ mb).
Defined.

Definition modulo_hauteur(d : nat)(m : Modulo d) : nat.
Proof.
  case m as [h mb].
  exact h.
Defined.

Proposition modulo_invariant :
  forall d, forall (m : Modulo d),
    (modulo_valeur d m) + (modulo_hauteur d m) = d.
Proof.
Admitted.

(* Modulo d : algèbre sur la signature (0, S). *)

Definition modulo_zero(d : nat) : Modulo d := modulo _ _ (mb_zero d).

Definition modulo_succ(d : nat)(m : Modulo d) : Modulo d.
Proof.
  case m as [h mb].
  case h as [ | ph].
  + exact (modulo_zero d).
  + exact (modulo _ _ (mb_succ _ _ mb)).
Defined.

Fixpoint modulo_morphismeNat(d n : nat) : Modulo d.
Proof.
  case n as [ | pn].
  - exact (modulo_zero d).
  - exact (modulo_succ d (modulo_morphismeNat d pn)).
Defined.

Lemma modulo_morphismeNat_valeur :
  forall d, forall n,
    modulo_valeur d (modulo_morphismeNat d n) = reste n (S d).
Proof.
  fix HR 2.
  (* compliqué ! *)
Admitted.

(* compatibilité *)
Lemma modulo_morphismeNat_calculParReste :
  forall d, forall n,
    modulo_morphismeNat d n = modulo_morphismeNat d (reste n (S d)).
Proof.
  fix HR 2.
  (* compliqué ! *)
Admitted.

Proposition modulo_egalite_compatibiliteMorphismeNat :
  forall d, forall m n,
    modulo_egalite (S d) m n
    -> modulo_morphismeNat d m = modulo_morphismeNat d n.
Proof.
  intros d m n equiv_m_n.
  unfold modulo_egalite.
  rewrite (modulo_morphismeNat_calculParReste d m).
  rewrite (modulo_morphismeNat_calculParReste d n).
  rewrite equiv_m_n.
  reflexivity.
Qed.

Definition zeroMod3 := modulo_morphismeNat 2 3.
Print zeroMod3.
Compute zeroMod3.

Definition unMod3 := modulo_morphismeNat 2 1.
Print unMod3.
Compute unMod3.

Definition deuxMod3 := modulo_morphismeNat 2 2.
Print deuxMod3.
Compute deuxMod3.

Example identite_valeur_2_mod3 :
  modulo_morphismeNat 2 (modulo_valeur _ deuxMod3) = deuxMod3.
Admitted.

(* L'inversibilité antérieure entraîne la surjectivité. *)
Proposition moduloBrut_morphismeNat_inversibiliteAnterieure :
  forall d h (mb : ModuloBrut d h),
    modulo_morphismeNat d (moduloBrut_valeur _ _ mb) = modulo _ _ mb.
Proof.
Admitted.

Proposition modulo_morphismeNat_inversibiliteAnterieure :
  forall d (m : Modulo d),
    modulo_morphismeNat d (modulo_valeur _ m) = m.
Proof.
Admitted.

(* L'inversibilité postérieure entraîne l'injectivité (modulo (S d)). *)

Proposition modulo_morphismeNat_inversibilitePosterieure :
  forall d n,
    modulo_egalite (S d) (modulo_valeur d (modulo_morphismeNat d n))
                                  n.
Proof.
Admitted.

(* Monoïde additif *)

Fixpoint sommeBrute(d h : nat)(mb : ModuloBrut d h)(n : Modulo d){struct mb} : Modulo d.
Proof.
Admitted.

Definition somme{d : nat}(m n : Modulo d) : Modulo d.
Proof.
Admitted.

Example somme_12_13_mod25 :
  somme (modulo_morphismeNat 24 12) (modulo_morphismeNat 24 13) = modulo_morphismeNat 24 0.
Admitted.

(*
Fixpoint sommeBrute(d h k : nat)(m : ModuloBrut h d)(n : ModuloBrut k d){struct m} : Modulo d.
Proof.
  case m as [ | d m].
  - exact (modulo (S h) k n).
  - case (sommeBrute _ _ _ m n) as [hr mbr].
    case hr as [ | phr].
    * exact (modulo _ d (zeroMod _)).
    * exact (modulo _ phr (succMod _ _ mbr)).
Defined.

Definition somme{d : nat}(m n : Modulo d) : Modulo d.
Proof.
  case m as [h mb].
  case n as [k nb].
  exact (sommeBrute _ _ _ mb nb).
Defined.  *)

Example somme_1_2_mod3 : somme unMod3 deuxMod3 = zeroMod3.
Admitted.

Example somme_2_2_mod3 : somme deuxMod3 deuxMod3 = unMod3.
Admitted.

(* Complément : sur l'unicité de la représentation. *)

(* Conversion : foncteur catégorique - voir egalite_preuves_singletonSiDecidable. *)
Definition conversion(d h1 h2 : nat)(eg : h1 = h2) : ModuloBrut d h1 -> ModuloBrut d h2.
  case eg.
  exact (fun mb => mb).
Defined.

(* Utilisation de l'unicité des preuves d'égalité sur nat :
- apply UIP_nat. *)
Lemma moduloBrut_singleton_casZeroModuloConversion :
  forall d h (mb : ModuloBrut d h)(eg : h = d),
    conversion d h d eg mb = mb_zero d.
Proof.
Admitted.

Lemma moduloBrut_singleton_casZero :  forall d (mb : ModuloBrut d d),
    mb = mb_zero d.
Proof.
Admitted.

(* Les types 'ModuloBrut'sont des types singletons. *)
Proposition moduloBrut_typesSingletons :
  forall (d h : nat)(mb1 mb2 : ModuloBrut d h),
    mb1 = mb2.
Proof.
  fix HR 3.
Admitted.


Add LoadPath "F:\sfsol".
Require Export Chap5.

Definition funny_prop1 :=
  forall n, forall (E : beautiful n), beautiful (n+3).

Definition funny_prop1' :=
  forall n, forall (_ : beautiful n), beautiful (n+3).

Definition funny_prop1'' :=
  forall n, beautiful n -> beautiful (n+3).

Inductive and (P Q : Prop) : Prop :=
  conj : P -> Q -> (and P Q).

Notation "P /\ Q" := (and P Q) : type_scope.

Check conj.

Theorem and_example :
  (beautiful 0) /\ (beautiful 3).
Proof.
  apply conj.
  apply b_0.
  apply b_3.
  Qed.

Print and_example.

Theorem and_example' :
  (ev 0) /\ (ev 4).
Proof.
  split.
    Case "left". apply ev_0.
    Case "right". apply ev_SS. apply ev_SS. apply ev_0. Qed.

Theorem proj1 : forall P Q : Prop,
  P /\ Q -> P.
Proof.
  intros P Q H.
  inversion H as [HP HQ].
  apply HP. Qed.

Theorem proj2 : forall P Q : Prop,
  P /\ Q -> Q.
Proof.
  intros P Q H.
  inversion H as [HP HQ].
  apply HQ. Qed.

Theorem and_commut : forall P Q : Prop,
  P /\ Q -> Q /\ P.
Proof.
  intros.
  inversion H as [HP HQ].
  split.
  assumption.
  assumption.
  Qed.

Print and_commut.

Theorem and_assoc : forall P Q R : Prop,
  P /\ (Q /\ R) -> (P /\ Q) /\ R.
Proof.
  intros P Q R H.
  inversion H as [HP [HQ HR]].
  split.
  split.
  assumption.
  assumption.
  assumption.
  Qed.

Theorem even__ev : forall n : nat,
  (even n -> ev n) /\ (even (S n) -> ev (S n)).
Proof.
  intros.
  induction n.
  split.
  intros. apply ev_0.
  intros. inversion H.
  inversion IHn as [IHn1 IHn2].
  split.
  apply IHn2.
  intros.
  apply ev_SS. unfold even in H. unfold evenb in H.
  assert (even n). unfold even. apply H.
  apply IHn1. apply H0.
  Qed.

Definition conj_fact : forall P Q R, P /\ Q -> Q /\ R -> P /\ R :=
  fun (P Q R : Prop) (H : P /\ Q) =>
    match H with
    | conj HP HQ => (
      fun (H2 : Q /\ R) =>
        match H2 with
        | conj HQ HR => conj P R HP HR
        end
    )
    end.

Print conj_fact.

Definition iff (P Q : Prop) := (P -> Q) /\ (Q -> P).

Notation "P <-> Q" := (iff P Q)
                      (at level 95, no associativity) : type_scope.

Theorem iff_implies : forall P Q : Prop,
  (P <-> Q) -> P -> Q.
Proof.
  intros P Q H.
  inversion H as [HAB HBA]. apply HAB. Qed.

Theorem iff_sym : forall P Q : Prop,
  (P <-> Q) -> (Q <-> P).
Proof.
  intros P Q H.
  inversion H as [HAB HBA].
  split.
    Case "->". apply HBA.
    Case "<-". apply HAB. Qed.

Theorem iff_refl : forall P : Prop,
  P <-> P.
Proof.
  split.
  intros. assumption.
  intros. assumption.
  Qed.

Theorem iff_trans : forall P Q R : Prop,
  (P <-> Q) -> (Q <-> R) -> (P <-> R).
Proof.
  intros.
  inversion H as [HPQ HQP].
  inversion H0 as [HQR HRQ].
  split.
  intros. apply HQR. apply HPQ. apply H1.
  intros. apply HQP. apply HRQ. apply H1.
  Qed.

SearchAbout gorgeous.

Definition beautiful_iff_gorgeous :
  forall n, beautiful n <-> gorgeous n :=
    fun (n:nat) => conj (beautiful n -> gorgeous n) (gorgeous n -> beautiful n) (beautiful__gorgeous n) (gorgeous__beautiful n).

Inductive or (P Q : Prop) : Prop :=
  | or_introl : P -> or P Q
  | or_intror : Q -> or P Q.

Notation "P \/ Q" := (or P Q) : type_scope.

Theorem or_commut : forall P Q : Prop,
  P \/ Q -> Q \/ P.
Proof.
  intros P Q H.
  inversion H as [HP | HQ].
    Case "left". apply or_intror. apply HP.
    Case "right". apply or_introl. apply HQ. Qed.

Definition or_comm_defn : forall P Q : Prop, P \/ Q -> Q \/ P :=
  fun (P Q : Prop) (H : P \/ Q) =>
    match H with
    | or_introl P1 => or_intror Q P P1
    | or_intror Q1 => or_introl Q P Q1
    end.

Theorem or_distributes_over_and_1 : forall P Q R : Prop,
  P \/ (Q /\ R) -> (P \/ Q) /\ (P \/ R).
Proof.
  intros P Q R. intros H. inversion H as [HP | [HQ HR]].
    Case "left". split.
      SCase "left". left. apply HP.
      SCase "right". left. apply HP.
    Case "right". split.
      SCase "left". right. apply HQ.
      SCase "right". right. apply HR. Qed.

Theorem or_distributes_over_and_2 : forall P Q R : Prop,
  (P \/ Q) /\ (P \/ R) -> P \/ (Q /\ R).
Proof.
  intros.
  inversion H.
  destruct H0.
  apply or_introl.
  apply H0.
  destruct H1.
  apply or_introl.
  apply H1.
  apply or_intror.
  split.
  assumption.
  assumption.
  Qed.

Theorem or_distributes_over_and : forall P Q R : Prop,
  P \/ (Q /\ R) <-> (P \/ Q) /\ (P \/ R).
Proof.
  intros.
  split.
  apply or_distributes_over_and_1.
  apply or_distributes_over_and_2.
  Qed.

Theorem andb_true__and : forall b c,
  andb b c = true -> b = true /\ c = true.
Proof.
  intros b c H.
  destruct b.
    Case "b = true". destruct c.
      SCase "c = true". apply conj. reflexivity. reflexivity.
      SCase "c = false". inversion H.
    Case "b = false". inversion H. Qed.

Theorem and__andb_true : forall b c,
  b = true /\ c = true -> andb b c = true.
Proof.
  intros b c H.
  inversion H.
  rewrite H0. rewrite H1. reflexivity. Qed.

Theorem andb_false : forall b c,
  andb b c = false -> b = false \/ c = false.
Proof.
  intros.
  destruct b.
  simpl in H.
  apply or_intror.
  apply H.
  apply or_introl. reflexivity.
  Qed.

Theorem orb_true : forall b c,
  orb b c = true -> b = true \/ c = true.
Proof.
  intros.
  destruct b.
  apply or_introl. reflexivity.
  simpl in H.
  apply or_intror. apply H.
  Qed.

Theorem orb_false : forall b c,
  orb b c = false -> b = false /\ c = false.
Proof.
  intros.
  destruct b.
  inversion H.
  simpl in H.
  split.
  reflexivity.
  apply H.
  Qed.

Inductive False : Prop := .

Check False_ind.

Theorem False_implies_nonsense :
  False -> 2 + 2 = 5.
Proof.
  intros contra.
  inversion contra. Qed.

Theorem nonsense_implies_False :
  2 + 2 = 5 -> False.
Proof.
  intros contra.
  inversion contra. Qed.

Theorem ex_falso_quodlibet : forall (P:Prop),
  False -> P.
Proof.
  intros.
  inversion H.
  Qed.

Inductive True : Prop :=
  | evidence : forall (P : Prop), P -> True.

Check True_ind.

Definition not (P:Prop) := P -> False.

Notation "~ x" := (not x) : type_scope.

Check not.

Theorem not_False :
  ~ False.
Proof.
  unfold not. intros H. inversion H. Qed.

Theorem contradiction_implies_anything : forall P Q : Prop,
  (P /\ ~P) -> Q.
Proof.
  intros P Q H. inversion H as [HP HNA]. unfold not in HNA.
  apply HNA in HP. inversion HP. Qed.

Theorem double_neg : forall P : Prop,
  P -> ~~P.
Proof.
  intros P H. unfold not. intros G. apply G. apply H. Qed.

Theorem double_neg_inf : forall (P : Prop),
  P -> ~~P.
Proof.
  intros.
  unfold not.
  intros.
  apply H0.
  apply H.
  Qed.

Theorem contrapositive : forall P Q : Prop,
  (P -> Q) -> (~Q -> ~P).
Proof.
  intros.
  unfold not in H0.
  unfold not.
  intros.
  apply H0. apply H. apply H1.
  Qed.

Theorem not_both_true_and_false : forall P : Prop,
  ~ (P /\ ~P).
Proof.
  unfold not.
  intros.
  inversion H.
  apply H1. apply H0.
  Qed.

Theorem five_not_even :
  ~ ev 5.
Proof.
  unfold not. intros Hev5. inversion Hev5 as [|n Hev3 Heqn].
  inversion Hev3 as [|n' Hev1 Heqn']. inversion Hev1. Qed.

Theorem ev_not_ev_S : forall n,
  ev n -> ~ ev (S n).
Proof.
  unfold not. intros n H. induction H.
  intros.
  inversion H.
  intros.
  inversion H0.
  apply IHev.
  apply H2.
  Qed.

Definition peirce := forall P Q: Prop,
  ((P->Q)->P)->P.
Definition classic := forall P:Prop,
  ~~P -> P.
Definition excluded_middle := forall P:Prop,
  P \/ ~P.
Definition de_morgan_not_and_not := forall P Q:Prop,
  ~(~P/\~Q) -> P\/Q.
Definition implies_to_or := forall P Q:Prop,
  (P->Q) -> (~P\/Q).

Theorem peirce__classic : ( forall P Q: Prop,
  ((P->Q)->P)->P ) -> ( forall P:Prop,
  ~~P -> P ).
Proof.
  intros.
  unfold not in H0.
  apply H with (Q := False).
  intros.
  assert(H2 : False).
    apply H0.
    apply H1.
  inversion H2.
  Qed.

Notation "x <> y" := (~ (x = y)) : type_scope.

Theorem not_false_then_true : forall b : bool,
  b <> false -> b = true.
Proof.
  intros b H. destruct b.
  Case "b = true". reflexivity.
  Case "b = false".
    unfold not in H.
    apply ex_falso_quodlibet.
    apply H. reflexivity. Qed.

Theorem inv_inequal : forall n n' : nat,
  S n <> S n' -> n <> n'.
Proof.
  unfold not.
  intros. apply H. rewrite -> H0.
  reflexivity. Qed.

Theorem not_eq_beq_false : forall n n' : nat,
     n <> n' ->
     beq_nat n n' = false.
Proof.
  intros.
  generalize dependent n'.
  induction n.
  intros. unfold not in H.
  destruct n'. apply ex_falso_quodlibet.
  apply H. reflexivity.
  reflexivity.
  destruct n'. reflexivity.
  intros.
  simpl. apply IHn.
  apply inv_inequal. apply H.
  Qed.

Theorem beq_false_not_eq : forall n m,
  false = beq_nat n m -> n <> m.
Proof.
  intros.
  unfold not.
  destruct n.
  destruct m.
  inversion H.
  intros.
  inversion H0.
  intros.
  destruct m.
  inversion H0.
  inversion H0.
  simpl in H.
  rewrite -> H2 in H.
  rewrite <- beq_nat_refl in H.
  inversion H.
  Qed.

Inductive ex (X:Type) (P : X->Prop) : Prop :=
  ex_intro : forall(witness:X), P witness -> ex X P.

Definition some_nat_is_even : Prop :=
  ex nat ev.

Definition snie : some_nat_is_even :=
  ex_intro _ ev 4 (ev_SS 2 (ev_SS 0 ev_0)).

Notation "'exists' x , p" := (ex _ (fun x => p))
  (at level 200, x ident, right associativity) : type_scope.
Notation "'exists' x : X , p" := (ex _ (fun x:X => p))
  (at level 200, x ident, right associativity) : type_scope.

Example exists_example_1 : exists n, n + (n * n) = 6.
Proof.
  apply ex_intro with (witness:=2).
  reflexivity. Qed.

Example exists_example_1' : exists n,
  n + (n * n) = 6.
Proof.
  exists 2.
  reflexivity. Qed.

Theorem exists_example_2 : forall n,
  (exists m, n = 4 + m) ->
  (exists o, n = 2 + o).
Proof.
  intros n H.
  inversion H as [m Hm].
  exists (2 + m).
  apply Hm. Qed.

Definition p : ex nat (fun n => beautiful (S n)) :=
  ex_intro nat (fun n:nat => beautiful (S n)) 2 b_3.

Theorem dist_not_exists : forall (X:Type) (P : X -> Prop),
  (forall x, P x) -> ~ (exists x, ~ P x).
Proof.
  intros.
  unfold not.
  intros.
  inversion H0.
  apply H1.
  apply H.
  Qed.

Theorem not_exists_dist :
  excluded_middle ->
  forall (X:Type) (P : X -> Prop),
    ~ (exists x, ~ P x) -> (forall x, P x).
Proof.
  unfold excluded_middle.
  intros.
  unfold not in H.
  assert((P x) \/ (~ P x)).
  apply H.
  inversion H1.
  apply H2.
  assert(False).
  apply H0.
  apply ex_intro with (witness := x).
  apply H2.
  inversion H3.
  Qed.

Theorem dist_exists_or : forall (X:Type) (P Q : X -> Prop),
  (exists x, P x \/ Q x) <-> (exists x, P x) \/ (exists x, Q x).
Proof.
  intros.
  split.
  intros.
  inversion H.
  inversion H0.
  apply or_introl.
  apply ex_intro with (witness := witness).
  apply H1.
  apply or_intror.
  apply ex_intro with (witness := witness).
  apply H1.
  intros.
  inversion H.
  inversion H0.
  apply ex_intro with (witness := witness).
  apply or_introl. apply H1.
  inversion H0.
  apply ex_intro with (witness := witness).
  apply or_intror. apply H1.
  Qed.

Module MyEquality.

Inductive eq (X:Type) : X -> X -> Prop :=
  refl_equal : forall x, eq X x x.

Notation "x = y" := (eq _ x y)
                    (at level 70, no associativity) : type_scope.

Inductive eq' (X:Type) (x:X) : X -> Prop :=
    refl_equal' : eq' X x x.

Notation "x =' y" := (eq' _ x y)
                     (at level 70, no associativity) : type_scope.

Theorem two_defs_of_eq_coincide : forall (X:Type) (x y : X),
  x = y <-> x =' y.
Proof.
  intros.
  split.
  intros.
  inversion H.
  apply refl_equal'.
  intros.
  inversion H.
  apply refl_equal.
  Qed.

Definition four : 2 + 2 = 1 + 3 :=
  refl_equal nat 4.

Definition singleton : forall (X:Set) (x:X), []++[x] = x::[] :=
  fun (X:Set) (x:X) => refl_equal (list X) [x].

End MyEquality.

Module LeFirstTry.

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

End LeFirstTry.

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

Notation "m <= n" := (le m n).

Check le_ind.

Theorem test_le1 :
  3 <= 3.
Proof.
  apply le_n. Qed.

Theorem test_le2 :
  3 <= 6.
Proof.
  apply le_S. apply le_S. apply le_S. apply le_n. Qed.

Theorem test_le3 :
  ~ (2 <= 1).
Proof.
  intros H. inversion H. inversion H1. Qed.

Definition lt (n m:nat) := le (S n) m.

Notation "m < n" := (lt m n).

Inductive square_of : nat -> nat -> Prop :=
  sq : forall n:nat, square_of n (n * n).

Inductive next_nat (n:nat) : nat -> Prop :=
  | nn : next_nat n (S n).

Inductive next_even (n:nat) : nat -> Prop :=
  | ne_1 : ev (S n) -> next_even n (S n)
  | ne_2 : ev (S (S n)) -> next_even n (S (S n)).

Inductive total_relation (n m:nat) : Prop :=
  | tr_1 : total_relation n m.

Inductive empty_relation (n m:nat) : Prop :=
  | er_1 : ~ (total_relation n m) -> (empty_relation n m).

Module R.

Inductive R : nat -> nat -> nat -> Prop :=
   | c1 : R 0 0 0
   | c2 : forall m n o, R m n o -> R (S m) n (S o)
   | c3 : forall m n o, R m n o -> R m (S n) (S o)
   | c4 : forall m n o, R (S m) (S n) (S (S o)) -> R m n o
   | c5 : forall m n o, R m n o -> R n m o.

Inductive R' : nat -> nat -> nat -> Prop :=
   | d1 : R' 0 0 0
   | d2 : forall m n o, R' m n o -> R' (S m) n (S o)
   | d3 : forall m n o, R' m n o -> R' m (S n) (S o)
   | d4 : forall m n o, R' m n o -> R' n m o.

Inductive R'' : nat -> nat -> nat -> Prop :=
   | e1 : R'' 0 0 0
   | e2 : forall m n o, R'' m n o -> R'' (S m) n (S o)
   | e3 : forall m n o, R'' m n o -> R'' m (S n) (S o).

Theorem e3_R'' : forall (m n o:nat),
  (R'' m (S n) (S o)) <-> (R'' m n o).
Proof.
  split.
  generalize dependent n.
  generalize dependent o.
  induction m.
  intros.
  inversion H.
  apply H3.
  intros.
  inversion H.
  destruct o.
  inversion H3.
  apply e2.
  apply IHm.
  apply H3.
  apply H3.
  intros.
  apply e3.
  apply H.
  Qed.

Theorem e2_R'' : forall (m n o:nat),
  (R'' (S m) n (S o)) <-> (R'' m n o).
Proof.
  split.
  generalize dependent m.
  generalize dependent o.
  induction n.
  intros.
  inversion H.
  apply H3.
  intros.
  inversion H.
  apply H3.
  destruct o.
  inversion H3.
  apply e3.
  apply IHn.
  apply H3.
  intros.
  apply e2.
  apply H.
  Qed.

Theorem e3_e2_R'' : forall (m n o:nat),
  (R'' (S m) n o) <-> (R'' m (S n) o).
Proof.
  split.
  intros.
  destruct o.
  inversion H.
  apply e3.
  apply e2_R''.
  apply H.
  intros.
  destruct o.
  inversion H.
  apply e2.
  apply e3_R''.
  apply H.
  Qed.

Theorem symm_R'' : forall (m n o:nat),
  (R'' m n o) -> (R'' n m o).
Proof.
  induction m.
  induction n.
  intros. apply H.
  intros.
  destruct o.
  inversion H.
  inversion H.
  apply e2.
  apply IHn.
  apply H3.
  intros.
  apply e3_e2_R''.
  apply IHm.
  apply e3_e2_R''.
  apply H.
  Qed.

Theorem eq_R_R'' : forall (m n o:nat),
  (R m n o) <-> (R'' m n o).
Proof.
  split.
  apply R_ind.
  apply e1.
  intros.
  apply e2.
  apply H0.
  intros.
  apply e3.
  apply H0.
  intros.
  apply e2_R''.
  apply e3_R''.
  apply H0.
  intros.
  apply symm_R''.
  apply H0.
  apply R''_ind.
  apply c1.
  intros.
  apply c2.
  apply H0.
  intros.
  apply c3.
  apply H0.
  Qed.

Definition sum_eq (m n o:nat) : Prop :=
  m + n = o.

Theorem eq_R : forall (m n o:nat),
  (R m n o) <-> (sum_eq m n o).
Proof.
  split.
  assert ((R'' m n o) -> (sum_eq m n o)).
  apply R''_ind.
  unfold sum_eq. reflexivity.
  intros.
  unfold sum_eq in H0.
  unfold sum_eq.
  rewrite <- H0.
  reflexivity.
  intros.
  unfold sum_eq in H0.
  unfold sum_eq.
  rewrite <- H0.
  rewrite -> plus_n_Sm.
  reflexivity.
  intros.
  apply H.
  apply eq_R_R''.
  apply H0.
  unfold sum_eq.
  generalize dependent o.
  generalize dependent n.
  induction m.
  intros.
  simpl in H.
  rewrite -> H.
  generalize dependent n.
  induction o.
  intros.
  apply c1.
  intros.
  apply c3.
  destruct n.
  inversion H.
  inversion H.
  apply IHo with (n:=n).
  apply H1.
  intros.
  destruct o.
  inversion H.
  apply c2.
  inversion H.
  apply IHm.
  reflexivity.
  Qed.

End R.

Inductive all (X : Type) (P : X -> Prop) : list X -> Prop :=
  | all1 : all X P []
  | all2 : forall (x:X) (l:list X), (P x) -> (all X P l) -> (all X P (x::l)).

Theorem all_forallb : forall (X:Type) (P: X ->bool) (l:list X),
  all X (fun x:X => (P x)=true) l -> (forallb P l = true).
Proof.
  intros.
  induction l.
  reflexivity.
  simpl.
  inversion H.
  rewrite -> H2.
  apply IHl.
  apply H3.
  Qed.

Inductive in_merge (X:Type) : list X->list X->list X->Prop :=
  | in1 : in_merge X [] [] []
  | in2 : forall (hx:X) (x y xy:list X) , in_merge X x y xy -> in_merge X (hx::x) y (hx::xy)
  | in3 : forall (hy:X) (x y xy:list X) , in_merge X x y xy -> in_merge X x (hy::y) (hy::xy).

Theorem filter_challenge : forall (X:Set) (l1 l2 l:list X) (test:X->bool),
  (all X (fun x:X => (test x)=true) l1)->(all X (fun x:X => (test x)=false) l2)
  ->(in_merge X l1 l2 l)
  -> filter test l=l1.
Proof.
  intros.
  generalize dependent l.
  generalize dependent l2.
  induction l1.
  induction l2.
  intros.
  inversion H1.
  reflexivity.
  intros.
  inversion H1.
  inversion H0.
  unfold filter.
  rewrite -> H9.
  apply IHl2.
  apply H10.
  apply H6.
  intros.
  generalize dependent l.
  generalize dependent l2.
  induction l2.
  intros.
  inversion H1.
  inversion H.
  assert(filter test xy = l1).
  apply IHl1 with (l2:=[]).
  apply H10.
  apply H0.
  apply H6.
  rewrite <- H11.
  unfold filter.
  rewrite -> H9.
  reflexivity.
  intros.
  inversion H.
  inversion H1.
  assert(filter test xy = l1).
  apply IHl1 with (l2:=(x0::l2)).
  apply H5.
  apply H0.
  apply H10.
  rewrite <- H11.
  unfold filter.
  rewrite -> H4.
  reflexivity.
  inversion H0.
  assert(filter test (x0::xy) = filter test xy).
  unfold filter.
  rewrite -> H13.
  reflexivity.
  rewrite -> H15.
  apply IHl2.
  apply H14.
  apply H10.
  Qed.

Inductive appears_in {X:Type} (a:X) : list X -> Prop :=
  | ai_here : forall l, appears_in a (a::l)
  | ai_later : forall b l, appears_in a l -> appears_in a (b::l).

Lemma appears_in_app : forall {X:Type} (xs ys : list X) (x:X),
  appears_in x (xs ++ ys) -> appears_in x xs \/ appears_in x ys.
Proof.
  intros X.
  induction xs.
  intros.
  simpl in H.
  apply or_intror.
  apply H.
  intros.
  inversion H.
  apply or_introl.
  apply ai_here.
  assert (appears_in x0 xs \/ appears_in x0 ys).
    apply IHxs.
    apply H1.
  inversion H3 as [ H4 | H5].
    apply or_introl.
    apply ai_later.
    apply H4.
    apply or_intror.
    apply H5.
  Qed.

Lemma app_appears_in : forall {X:Type} (xs ys : list X) (x:X),
  appears_in x xs \/ appears_in x ys -> appears_in x (xs ++ ys).
Proof.
  intros.
  inversion H as [H1 | H2].
  induction xs.
  inversion H1.
  inversion H1.
  apply ai_here.
  apply ai_later.
  apply IHxs.
  apply or_introl.
  apply H2.
  apply H2.
  induction xs.
  apply H2.
  apply ai_later.
  apply IHxs.
  apply or_intror.
  apply H2.
  Qed.

Definition disjoint (X:Type) (l1 l2:list X) :=
  forall (x:X), ((appears_in x l1)/\ ~(appears_in x l2))\/(~(appears_in x l1)/\ (appears_in x l2)).

Inductive no_repeats (X:Type) : list X->Prop :=
  | nr1 : no_repeats X []
  | nr2 : forall (x:X) (l:list X), ~ (appears_in x l) -> no_repeats X (x::l).

Theorem O_le_n : forall n,
  0 <= n.
Proof.
  intros.
  induction n.
  apply le_n.
  apply le_S.
  apply IHn.
  Qed.

Theorem n_le_m__Sn_le_Sm : forall n m,
  n <= m -> S n <= S m.
Proof.
  intros.
  generalize dependent m.
  induction n.
  intros.
  induction m.
  apply le_n.
  apply le_S.
  apply IHm.
  apply O_le_n.
  induction m.
  intros.
  inversion H.
  intros.
  inversion H.
  apply le_n.
  apply le_S.
  apply IHm.
  apply H1.
  Qed.

Theorem Sn_le_Sm__n_le_m : forall n m,
  S n <= S m -> n <= m.
Proof.
  intros n m. generalize dependent n. induction m.
  intros.
  inversion H.
  apply le_n.
  inversion H1.
  intros.
  inversion H.
  apply le_n.
  apply le_S.
  apply IHm.
  apply H1.
  Qed.

Theorem le_plus_l : forall a b,
  a <= a + b.
Proof.
  intros a b.
  induction b.
  rewrite -> plus_0_r.
  apply le_n.
  rewrite <- plus_n_Sm.
  apply le_S.
  apply IHb.
  Qed.

Theorem plus_lt_l : forall n1 n2 m,
  n1 + n2 < m ->
  n1 < m .
Proof.
  intros.
  generalize dependent m.
  induction n2.
  intros.
  rewrite -> plus_0_r in H.
  apply H.
  intros.
  inversion H.
  unfold lt.
  apply n_le_m__Sn_le_Sm.
  apply le_plus_l.
  rewrite <- H1 in H.
  unfold lt in H.
  apply Sn_le_Sm__n_le_m in H.
  rewrite <- plus_n_Sm in H.
  apply le_S.
  apply IHn2.
  apply H.
  Qed.

Theorem plus_lt : forall n1 n2 m,
  n1 + n2 < m ->
  n1 < m /\ n2 < m.
Proof.
  intros.
  apply conj.
  apply plus_lt_l with (n2:=n2).
  apply H.
  rewrite -> plus_comm in H.
  apply plus_lt_l with (n2:=n1).
  apply H.
  Qed.

Theorem lt_S : forall n m,
  n < m ->
  n < S m.
Proof.
  intros.
  apply le_S.
  apply H.
  Qed.

Theorem ble_nat_true : forall n m,
  ble_nat n m = true -> n <= m.
Proof.
  intros.
  generalize dependent m.
  induction n.
  intros.
  apply O_le_n.
  intros.
  inversion H.
  destruct m.
  inversion H1.
  apply n_le_m__Sn_le_Sm.
  apply IHn.
  apply H1.
  Qed.

Theorem ble_nat_n_Sn_false : forall n m,
  ble_nat n (S m) = false ->
  ble_nat n m = false.
Proof.
  intros.
  generalize dependent m.
  induction n.
  intros.
  inversion H.
  intros.
  inversion H.
  destruct m.
  rewrite -> H1.
  unfold ble_nat.
  reflexivity.
  rewrite -> H1.
  unfold ble_nat.
  apply IHn.
  apply H1.
  Qed.

Theorem ble_nat_false : forall n m,
  ble_nat n m = false -> ~(n <= m).
Proof.
  intros.
  generalize dependent n.
  induction m.
  intros.
  unfold not.
  intros.
  inversion H0.
  rewrite -> H1 in H.
  inversion H.
  induction n.
  intros.
  inversion H.
  intros.
  unfold not.
  intros.
  apply Sn_le_Sm__n_le_m in H0.
  generalize H0.
  apply IHm.
  inversion H.
  reflexivity.
  Qed.

Inductive nostutter: list nat -> Prop :=
  | ns1 : nostutter []
  | ns2 : forall (x:nat), (nostutter [x])
  | ns3 : forall (x y:nat) (l:list nat),~(x=y) -> (nostutter (y::l)) -> (nostutter (x::y::l)).

Example test_nostutter_1: nostutter [3,1,4,1,5,6].
Proof. repeat constructor; apply beq_false_not_eq; auto. Qed.

Example test_nostutter_2: nostutter [].
Proof. repeat constructor; apply beq_false_not_eq; auto. Qed.

Example test_nostutter_3: nostutter [5].
Proof. repeat constructor; apply beq_false_not_eq; auto. Qed.

Example test_nostutter_4: not (nostutter [3,1,1,4]).
  Proof. intro.
  repeat match goal with
    h: nostutter _ |- _ => inversion h; clear h; subst
  end.
  contradiction H1; auto. Qed.

Lemma app_length : forall {X:Type} (l1 l2 : list X),
  length (l1 ++ l2) = length l1 + length l2.
Proof.
  intros.
  generalize dependent l2.
  induction l1.
  auto.
  intros.
  simpl.
  auto.
  Qed.

Lemma appears_in_app_split : forall {X:Type} (x:X) (l:list X),
  appears_in x l ->
  exists l1, exists l2, l = l1 ++ (x::l2).
Proof.
  intros.
  induction l.
  inversion H.
  inversion H.
  apply ex_intro with (witness:=[]).
  apply ex_intro with (witness:=l).
  reflexivity.
  assert(exists l1 : list X, exists l2 : list X, l = l1 ++ x :: l2).
  auto.
  inversion H3.
  inversion H4.
  apply ex_intro with (witness:=(x0::witness)).
  apply ex_intro with (witness:=witness0).
  rewrite -> H5. reflexivity.
  Qed.

Inductive repeats {X:Type} : list X -> Prop :=
  | rp1 : forall (x:X) (l:list X),(appears_in x l)->(repeats (x::l))
  | rp2 : forall (x:X) (l:list X),(repeats l)->(repeats (x::l)).

Theorem remove_one: forall (X:Type) (x:X) (l l1 l2:list X),
  (forall (x1:X), (appears_in x1 (x::l)) -> (appears_in x1 (l1++(x::l2)))) ->
  (forall (x2:X), ~(x2=x) -> (appears_in x2 l) -> (appears_in x2 (l1++l2))).
Proof.
  intros.
  assert(appears_in x2 (l1++x::l2)).
  apply H.
  apply ai_later.
  apply H1.
  apply appears_in_app in H2.
  inversion H2 as [H3 | H4].
  apply app_appears_in.
  apply or_introl.
  apply H3.
  inversion H4.
  assert(False).
  apply H0. apply H5.
  inversion H3.
  apply app_appears_in.
  apply or_intror.
  apply H5.
  Qed.

Theorem pigeonhole_principle: forall {X:Type} (l1 l2:list X),
  excluded_middle ->
  (forall x, appears_in x l1 -> appears_in x l2) ->
  length l2 < length l1 ->
  repeats l1.
Proof. intros X l1. induction l1.
  intros.
  inversion H1.
  intros.
  assert((appears_in x l1)\/~(appears_in x l1)).
  apply H.
  inversion H2 as [H3 | H4].
  apply rp1. apply H3.
  apply rp2.
  assert(appears_in x l2).
  apply H0. apply ai_here.
  apply appears_in_app_split in H3.
  inversion H3.
  inversion H5.
  assert((forall x1 : X, (~x1=x) -> appears_in x1 l1 -> appears_in x1 (witness++witness0))).
  apply remove_one.
  rewrite <- H6.
  apply H0.
  assert(forall x1 : X, appears_in x1 l1 -> appears_in x1 (witness ++ witness0)).
  intros.
  apply H7.
  assert(forall (y y1:X) (l:list X),~(appears_in y l)->(appears_in y1 l)->~(y=y1)).
    induction l.
    intros.
    inversion H10.
    intros.
    inversion H10.
    rewrite <- H12 in H9.
    unfold not in H9.
    unfold not. intros.
    apply H9.
    rewrite -> H12.
    rewrite -> H11.
    apply ai_here.
    apply IHl.
    unfold not.
    intros.
    apply H9.
    apply ai_later.
    apply H14.
    apply H12.
  assert(x<>x1).
  apply H9 with (l:=l1).
  auto.
  auto.
  unfold not.
  auto.
  apply H8.
  apply IHl1 with (l2:=(witness ++ witness0)).
  apply H.
  assumption.
  rewrite -> H6 in H1.
  rewrite -> app_length.
  rewrite -> app_length in H1.
  unfold lt in H1.
  unfold lt.
  apply Sn_le_Sm__n_le_m.
  assert(forall (l:list X), length(x::l)=S (length l)).
    intros.
    unfold length.
    reflexivity.
  rewrite -> H9 in H1.
  rewrite -> H9 in H1.
  rewrite <- plus_n_Sm in H1.
  assumption.
  Qed.


Require Export Iron.Language.SystemF.Ki.

(* Type Expressions *)
Inductive ty  : Type :=
 | TCon    : nat -> ty            (* Data type constructor. *)
 | TVar    : nat -> ty            (* deBruijn index. *)
 | TForall : ty  -> ty            (* Type variable binding. *)
 | TFun    : ty  -> ty -> ty.     (* Function type constructor. *)

Hint Constructors ty.

(********************************************************************)
(* Well formed types are closed under the given kind environment *)
Fixpoint wfT (ke: kienv) (tt: ty) : Prop :=
 match tt with
 | TCon _     => True
 | TVar i     => exists k, get i ke = Some k
 | TForall t  => wfT (ke :> KStar) t
 | TFun t1 t2 => wfT ke t1 /\ wfT ke t2
 end.
Hint Unfold wfT.

(* A closed type is well formed under an empty type environment. *)
Definition closedT (tt: ty) : Prop
 := wfT nil tt.
Hint Unfold closedT.

(********************************************************************)
(* Lifting of type indices in types.
   When we push new elements on the environment stack, we need
   to lift referenes to existing elements across the new ones. *)
Fixpoint liftTT (d: nat) (tt: ty) : ty :=
  match tt with
  | TCon _     => tt

  |  TVar ix
  => if le_gt_dec d ix
      then TVar (S ix)
      else tt

  |  TForall t
  => TForall (liftTT (S d) t)

  |  TFun t1 t2
  => TFun    (liftTT d t1) (liftTT d t2)
  end.
Hint Unfold liftTT.

(* Tactic to help deal with lifting functions. *)
Ltac lift_cases
 := match goal with
     |  [ |- context [le_gt_dec ?n ?n'] ]
     => case (le_gt_dec n n')
    end.

(********************************************************************)
(* Substitution for the outer-most binder in a type. *)
Fixpoint substTT (d: nat) (u: ty) (tt: ty) : ty
 := match tt with
    |  TCon _
    => tt

    | TVar ix
    => match nat_compare ix d with
       | Eq => u
       | Gt => TVar (ix - 1)
       | _  => TVar  ix
       end

    |  TForall t
    => TForall (substTT (S d) (liftTT 0 u) t)

    |  TFun t1 t2
    => TFun (substTT d u t1) (substTT d u t2)
  end.

(********************************************************************)
(* Changing the order of lifting. *)
Lemma liftTT_liftTT
 :  forall n n' t
 ,  liftTT n              (liftTT (n + n') t)
 =  liftTT (1 + (n + n')) (liftTT n t).
Proof.
 intros. gen n n'.
 induction t; intros; auto.

 Case "TVar".
  simpl.
  repeat (unfold liftTT; lift_cases; intros); burn.

 Case "TForall".
  simpl.
  assert (S (n + n') = (S n) + n'). omega. rewrite H.
  rewrite IHt. auto.

 Case "TFun".
  simpl. apply f_equal2; auto.
Qed.

(* Lifting then substituting at the same index doesn't do anything.

   When we lift indices in a type that are greater or equal to some
   depth d, there will be no indices of value d in the result. The
   lifting process increments indices greater than 'd', but then the
   substitution process decrements them again, so we get back to
   the type we started with.
 *)
Lemma substTT_liftTT
 :  forall d t1 t2
 ,  substTT d t2 (liftTT d t1) = t1.
Proof.
 intros. gen d t2.
 induction t1; intros; eauto.

 Case "TVar".
  simpl; lift_cases; unfold substTT;
   fbreak_nat_compare; intros;
   burn.

 Case "TForall".
  simpl.
  rewrite IHt1. auto.

 Case "TFun".
  simpl.
  rewrite IHt1_1.
  rewrite IHt1_2. auto.
Qed.

(* Lifting after substitution *)
Lemma liftTT_substTT
 :  forall n n' t1 t2
 ,  liftTT n (substTT (n + n') t2 t1)
 =  substTT (1 + n + n') (liftTT n t2) (liftTT n t1).
Proof.
 intros. gen n n' t2.
 induction t1; intros; eauto.

 Case "TVar".
  repeat (simpl; fbreak_nat_compare;
          try lift_cases; try intros);
   burn.

 Case "TForall".
  simpl.
  rewrite (IHt1 (S n) n'). simpl.
  rewrite (liftTT_liftTT 0 n). auto.

 Case "TFun".
  simpl.
  rewrite IHt1_1. auto.
  rewrite IHt1_2. auto.
Qed.

(* Lifting after substitution, another way. *)
Lemma liftTT_substTT'
 :  forall n n' t1 t2
 ,  liftTT (n + n') (substTT n t2 t1)
 =  substTT n (liftTT (n + n') t2) (liftTT (1 + n + n') t1).
Proof.
 intros. gen n n' t2.
 induction t1; intros; auto.

 Case "TVar".
  repeat ( unfold liftTT; unfold substTT; fold liftTT; fold substTT
         ; try lift_cases; try fbreak_nat_compare
         ; intros); burn.

 Case "TForall".
  simpl. f_equal.
  rewrite (IHt1 (S n) n'). f_equal.
   simpl. rewrite (liftTT_liftTT 0 (n + n')). auto.

 Case "TFun".
  simpl. f_equal.
   apply IHt1_1.
   apply IHt1_2.
Qed.

(* Commuting substitutions. *)
Lemma substTT_substTT
 :  forall n m t1 t2 t3
 ,  substTT (n + m) t3 (substTT n t2 t1)
 =  substTT n (substTT (n + m) t3 t2)
              (substTT (1 + n + m) (liftTT n t3) t1).
Proof.
 intros. gen n m t2 t3.
 induction t1; intros; auto.

 Case "TVar".
  repeat (simpl; fbreak_nat_compare); try burn.
  rewrite substTT_liftTT. auto.

 Case "TForall".
  simpl. f_equal.
  rewrite (IHt1 (S n) m). f_equal.
   simpl. rewrite (liftTT_substTT 0 (n + m)). auto.
   simpl. rewrite (liftTT_liftTT 0 n). auto.

 Case "TFun".
  simpl. f_equal.
   apply IHt1_1.
   apply IHt1_2.
Qed.


From mathcomp Require Import ssreflect mini_ssrfun mini_ssrbool.
From mathcomp Require Import mini_eqtype mini_ssrnat mini_seq.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Definition sum m n F := (foldr (fun i a => F i + a) 0 (iota m (n - m))).

Notation "\sum_ ( m <= i < n ) F" := (sum m n (fun i => F))
  (at level 41, F at level 41, i, m, n at level 50,
           format "'[' \sum_ ( m  <=  i  <  n ) '/  '  F ']'").

Lemma sum_geq m n F : n <= m -> \sum_(m <= i < n) F i = 0.
Proof. by rewrite /sum => /eqP->. Qed.

Lemma sum_recr m n F : m <= n ->
  \sum_(m <= i < n.+1) F i = \sum_(m <= i < n) F i + F n.
Proof.
move=> leq_mn; rewrite /sum subSn// -addn1 iota_add subnKC// foldr_cat/=.
by elim: iota (F n) => [|x s IHs] k; rewrite -?addnA -?IHs ?addn0.
Qed.

Lemma sum_recl m n F : m <= n ->
  \sum_(m <= i < n.+1) F i = F m + \sum_(m <= i < n) F (S i).
Proof.
move=> leq_mn; rewrite /sum subSn//=; congr (_ + _).
by move: (n - m) => k {leq_mn}; elim: k m => //= k IHk m; rewrite IHk.
Qed.

Lemma muln_sumr (m n k : nat) F :
  k * (\sum_(m <= i < n) F i) = \sum_(m <= i < n) k * F i.
Proof.
by rewrite /sum; elim: iota => [|x s IHs]; rewrite (muln0, mulnDr) ?IHs.
Qed.

Lemma eqn_sum (m n : nat) G F : (forall i, F i = G i) ->
  (\sum_(m <= i < n) F i) = \sum_(m <= i < n) G i.
Proof.
by rewrite /sum; elim: iota => [|x s IHs]//= eqFG; rewrite IHs ?eqFG.
Qed.
Arguments eqn_sum {m n} G F eq_FG.

Lemma muln_suml (m n k : nat) F :
  (\sum_(m <= i < n) F i) * k = \sum_(m <= i < n) F i * k.
Proof. by rewrite mulnC muln_sumr; apply: eqn_sum => i; rewrite mulnC. Qed.


Require Export TopologicalSpaces.
Require Export Neighborhoods.
From ZornsLemma Require Export InverseImage.
Require Export OpenBases.
Require Export NeighborhoodBases.
Require Export Subbases.

Section continuity.

Variable X Y:TopologicalSpace.
Variable f:point_set X -> point_set Y.

Definition continuous : Prop :=
  forall V:Ensemble (point_set Y), open V ->
  open (inverse_image f V).

Definition continuous_at (x:point_set X) : Prop :=
  forall V:Ensemble (point_set Y),
  neighborhood V (f x) -> neighborhood (inverse_image f V) x.

Lemma continuous_at_open_neighborhoods:
  forall x:point_set X,
  (forall V:Ensemble (point_set Y),
  open_neighborhood V (f x) -> neighborhood (inverse_image f V) x) ->
  continuous_at x.
Proof.
intros.
red; intros.
destruct H0 as [V' [? ?]].
pose proof (H V' H0).
destruct H2 as [U' [? ?]].
exists U'; split; trivial.
apply (inverse_image_increasing f) in H1; auto with sets.
Qed.

Lemma pointwise_continuity :
  (forall x:point_set X, continuous_at x) -> continuous.
Proof.
intros.
red; intros.
assert (interior (inverse_image f V) = inverse_image f V).
apply Extensionality_Ensembles; split.
apply interior_deflationary.
red; intros.
destruct H1.
assert (neighborhood V (f x)).
exists V; repeat split; auto with sets.
pose proof (H x V H2).
destruct H3 as [U].
destruct H3.
destruct H3.
assert (Included U (interior (inverse_image f V))).
apply interior_maximal; trivial.
auto.

rewrite <- H1; apply interior_open.
Qed.

Lemma continuous_func_continuous_everywhere:
  continuous -> forall x:point_set X, continuous_at x.
Proof.
intros.
apply continuous_at_open_neighborhoods.
intros.
apply open_neighborhood_is_neighborhood.
destruct H0; split; try constructor; auto.
Qed.

Lemma continuous_at_neighborhood_basis:
  forall (x:point_set X) (NB:Family (point_set Y)),
  neighborhood_basis NB (f x) ->
  (forall V:Ensemble (point_set Y),
  In NB V -> neighborhood (inverse_image f V) x) ->
  continuous_at x.
Proof.
intros.
red; intros.
destruct H.
apply neighborhood_basis_cond in H1.
destruct H1 as [N [? ?]].
pose proof (H0 N H).
destruct H2 as [U [? ?]].
exists U; split; trivial.
assert (Included (inverse_image f N) (inverse_image f V));
  auto with sets.
Qed.

Lemma continuous_open_basis:
  forall (B:Family (point_set Y)), open_basis B ->
  (forall V:Ensemble (point_set Y),
    In B V -> open (inverse_image f V)) -> continuous.
Proof.
intros.
apply pointwise_continuity.
intro.
pose proof (open_basis_to_open_neighborhood_basis B (f x) H).
apply open_neighborhood_basis_is_neighborhood_basis in H1.
apply (continuous_at_neighborhood_basis _ _ H1).
intros.
destruct H2 as [[? ?]].
apply open_neighborhood_is_neighborhood.
split; try constructor; auto.
Qed.

Lemma continuous_subbasis:
  forall (SB:Family (point_set Y)), subbasis SB ->
  (forall V:Ensemble (point_set Y),
     In SB V -> open (inverse_image f V)) -> continuous.
Proof.
intros.
apply (continuous_open_basis _
  (finite_intersections_of_subbasis_form_open_basis _ _ H)).
intros.
destruct H1.
destruct H1 as [A [? [V' []]]].
rewrite H3.
assert (inverse_image f (IndexedIntersection V') =
  IndexedIntersection (fun a:A => inverse_image f (V' a))).
apply Extensionality_Ensembles; split; red; intros.
destruct H4.
inversion_clear H4.
constructor; intros.
constructor.
apply H5.
destruct H4.
constructor.
constructor; intros.
destruct (H4 a).
exact H5.

rewrite H4.
apply open_finite_indexed_intersection; trivial.
intros.
apply H0.
apply H2.
Qed.

End continuity.

Arguments continuous {X} {Y}.
Arguments continuous_at {X} {Y}.

Lemma continuous_composition_at: forall {X Y Z:TopologicalSpace}
  (f:point_set Y -> point_set Z) (g:point_set X -> point_set Y)
  (x:point_set X),
  continuous_at f (g x) -> continuous_at g x ->
  continuous_at (fun x:point_set X => f (g x)) x.
Proof.
intros.
red; intros.
rewrite inverse_image_composition.
auto.
Qed.

Lemma continuous_composition: forall {X Y Z:TopologicalSpace}
  (f:point_set Y -> point_set Z) (g:point_set X -> point_set Y),
  continuous f -> continuous g ->
  continuous (fun x:point_set X => f (g x)).
Proof.
intros.
red; intros.
rewrite inverse_image_composition.
auto.
Qed.

Lemma continuous_identity: forall (X:TopologicalSpace),
  continuous (fun x:point_set X => x).
Proof.
intros.
red; intros.
apply eq_ind with (1:=H).
apply Extensionality_Ensembles; split; red; intros.
constructor; trivial.
destruct H0; trivial.
Qed.

Lemma continuous_constant: forall (X Y:TopologicalSpace)
  (y0:point_set Y), continuous (fun x:point_set X => y0).
Proof.
intros.
pose (f := fun _:point_set X => y0).
fold f.
red; intros.
destruct (classic (In V y0)).
replace (inverse_image f V) with (@Full_set (point_set X)).
apply open_full.
apply Extensionality_Ensembles; split; red; intros.
constructor; trivial.
constructor.
replace (inverse_image f V) with (@Empty_set (point_set X)).
apply open_empty.
apply Extensionality_Ensembles; split; auto with sets;
  red; intros.
destruct H1.
contradiction H0.
Qed.

Lemma continuous_at_is_local: forall (X Y:TopologicalSpace)
  (x0:point_set X) (f g:point_set X -> point_set Y)
  (N:Ensemble (point_set X)),
  neighborhood N x0 -> (forall x:point_set X, In N x -> f x = g x) ->
  continuous_at f x0 -> continuous_at g x0.
Proof.
intros.
red; intros.
destruct H as [U1 [[]]].
rewrite <- H0 in H2.
apply H1 in H2.
destruct H2 as [U2 [[]]].
exists (Intersection U1 U2).
repeat split; trivial.
apply open_intersection2; trivial.
destruct H7.
rewrite <- H0.
apply H6 in H8.
destruct H8; trivial.
auto.
auto.
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 (lf1 : natural) (lf2 : natural) (lf3 : natural) : natural :=
  plus lf2 lf3.