(*|
##########################################
How can I generalise Coq proofs of an iff?
##########################################

:Link: https://stackoverflow.com/q/65588333
|*)

(*|
Question
********

A common kind of proof I have to make is something like
|*)

Context (T : Type) (Q : T -> T -> T -> Prop) (P : T -> T -> Prop).
Lemma my_lemma : forall y,
    (forall x x', Q x x' y) -> (forall x x', P x y <-> P x' y).
Proof.
  intros y Q_y.
  split.
  - (* some proof using Q *) admit. (* .none *)

  - (* the same proof using Q, but x and x' are swapped *) admit. (* .none *)
Abort. (* .none *)

(*|
where ``Q`` is itself some kind of iff-shaped predicate.

My problem is that the proofs of ``P x y -> P x' y`` and ``P x' y -> P
x y`` are often basically identical, with the only difference between
that the roles of ``x`` and ``x'`` are swapped between them. Can I ask
Coq to transform the goal into

.. code-block:: coq

    forall x x', P x y -> P x' y

which then generalises to the iff case, so that I don't need to repeat
myself in the proof?

I had a look through the standard library, the tactic index, and some
SO questions, but nothing told me how to do this.
|*)

(*|
Answer
******

In mathematics, one often can make "assumptions" "*without loss of
generality*" (WLOG) to simplify proofs of this kind. In your example,
you could say "assume *without loss of generality* that ``P x y``
holds. To prove ``P x y <-> P x' y`` it is sufficient to prove ``P x'
y``."

If you are using ``ssreflect``, you have the `wlog tactic
<https://coq.inria.fr/refman/proof-engine/ssreflect-proof-language.html#variants-the-suff-and-wlog-tactics>`__.

You essentially ``cut`` in another goal which can easily solve your
goal. You can also do it with standard tactics like ``assert`` or
``enough`` (which is like ``assert`` but the proof obligations are in
the other order).

An example to show what I mean: below I just want to show the
implication in one direction, because it can easily solve the
implication in the other direction (with ``firstorder``).
|*)

Goal forall x y, P x y <-> P y x.
  enough (forall x y, P x y -> P y x) by firstorder.

(*|
Now I just have to show the goal in one direction, because it implies
the real goal's both directions.

For more about WLOG see for instance `1
<https://www.cl.cam.ac.uk/~jrh13/papers/wlog.pdf>`__
|*)


Require Import A1_Plan A2_Orientation A7_Tactics.
Require Import B1_ClockwiseProp B2_CollinearProp B3_EquiOrientedProp B4_RaysProp.

Section EQUIDIRECTED_PROP.

Lemma EquiDirectedRefl : forall A B : Point, EquiDirected A B A B.
Proof.
	canonize1.
Qed.

Lemma EquiDirectedSym : forall A B C D : Point,
	EquiDirected A B C D -> EquiDirected C D A B.
Proof.
	canonize1.
Qed.

Lemma EquiDirectedPermutAB : forall A B C D : Point,
	EquiDirected A B C D -> EquiDirected B A C D.
Proof.
	canonize1.
Qed.

Lemma EquiDirectedPermutCD: forall A B C D : Point,
	EquiDirected A B C D -> EquiDirected A B D C.
Proof.
	canonize1.
Qed.

Lemma NotEquiDirectedSym : forall A B C D : Point,
	~EquiDirected A B C D -> ~EquiDirected C D A B.
Proof.
	intros A B C D H; contrapose0 H; apply EquiDirectedSym; exact H.
Qed.

Lemma NotEquiDirectedPermutAB : forall A B C D : Point,
	~EquiDirected A B C D -> ~EquiDirected B A C D.
Proof.
	intros A B C D H; contrapose0 H; apply EquiDirectedPermutAB; exact H.
Qed.

Lemma NotEquiDirectedPermutCD: forall A B C D : Point,
	~EquiDirected A B C D -> ~EquiDirected A B D C.
Proof.
	intros A B C D H; contrapose0 H; apply EquiDirectedPermutCD; exact H.
Qed.

Lemma EquiDirectedCollinear : forall A B C : Point,
	EquiDirected A B C A -> Collinear A B C.
Proof.
	canonize1.
	 elim (NotClockwiseABA C A); auto.
	 elim (NotClockwiseABB A C); apply (ChangeSenseABCA _ _ _ H0 C H).
	 elim (NotClockwiseABB A C); auto.
	 elim (NotClockwiseABA C A); apply (ChangeSenseABAC _ _ _ H C H0).
	 elim (NotClockwiseABB A C); apply (ChangeSenseABCB _ _ _ H0 C H).
	 elim (NotClockwiseABA C A); auto.
	 elim (NotClockwiseABA C A); apply (ChangeSenseABBC _ _ _ H C H0).
	 elim (NotClockwiseABB A C); auto.
	 elim (NotClockwiseABB A B); apply H0; apply (ClockwiseCAB _ _ _ H).
	 elim (NotClockwiseABA B A); apply (ChangeSenseABBC _ _ _ H0); apply (ClockwiseBCA _ _ _ H).
	 elim (NotClockwiseABA B A); apply H; apply (ClockwiseCAB _ _ _ H0).
	 elim (NotClockwiseABB A B); apply (ChangeSenseABCB _ _ _ H); apply (ClockwiseBCA _ _ _ H0).
	 elim (NotClockwiseABA B A); apply (ChangeSenseABAC _ _ _ H0); apply (ClockwiseCAB _ _ _ H).
	 elim (NotClockwiseABB A B); apply H0; apply (ClockwiseBCA _ _ _ H).
	 elim (NotClockwiseABB A B); apply (ChangeSenseABCA _ _ _ H0); apply (ClockwiseCAB _ _ _ H).
	 elim (NotClockwiseABA B A); apply H0; apply (ClockwiseBCA _ _ _ H).
Qed.

Lemma CollinearEquiDirected : forall A B C : Point,
	Collinear A B C -> EquiDirected A B C A.
Proof.
	intros A B C H; destruct (CollinearTwoCases B C A (CollinearBCA A B C H)).
	 destruct (CollinearTwoCases A C B (CollinearACB A B C H)); canonize1.
	   do 4 right; left; intros.
	   apply (ChangeSenseABAC _ _ _ H0); auto.
	 destruct (CollinearTwoCases A B C H); canonize1.
	   do 3 right; left; intros.
	   apply (ChangeSenseABAC _ _ _ H0); auto.
Qed.

End EQUIDIRECTED_PROP.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Functor.Functor Functor.Functor_Ops.
From Categories Require Import NatTrans.Main.

(** Local notations for readability *)
Local Notation NID := NatTrans_id (only parsing).

Local Hint Extern 1 => progress
                        (repeat (apply NatTrans_eq_simplify; FunExt); cbn in *).

(** for a functor p : C -> C' and a category D, the left functor extender is a
     functor that maps (as an object) functor F : C' -> D to F ∘ p : C -> D.  *)
Section Left_Functor_Extender.
  Context {C C' : Category} (p : (C –≻ C')%functor) (D : Category).

    Program Definition Left_Functor_Extender :
      ((Func_Cat C' D) –≻ (Func_Cat C D))%functor :=
      {|
        FO := fun F => (F ∘ p)%functor;
        FA := fun F F' N => (N ∘_h (NID p))%nattrans
      |}.

End Left_Functor_Extender.

(** for a functor p : C -> C' and a category D, the left functor extender is a
    functor that maps (as an object) functor F : D -> C to p ∘ F : D -> C'.  *)
Section Right_Functor_Extender.
  Context {C C' : Category} (p : (C –≻ C')%functor) (D : Category).

    Program Definition Right_Functor_Extender :
      ((Func_Cat D C) –≻ (Func_Cat D C'))%functor :=
      {|
        FO := fun F => (p ∘ F)%functor;
        FA := fun F F' N => ((NID p) ∘_h N)%nattrans
      |}.

End Right_Functor_Extender.

(** if two functors are naturally isomorphic then so are left exending with them. *)
Section Left_Functor_Extender_Iso.
  Context {C C' : Category} {p p' : (C –≻ C')%functor}
          (N : (p ≃ p')%natiso) (D : Category).

  Local Hint Extern 1 => (rewrite Trans_com); trivial; fail.
  Local Hint Extern 1 => rewrite <- F_compose.
  Local Hint Extern 1 =>
  match goal with
    [w : @Obj C |- _] =>
    cbn_rewrite (f_equal (fun u => Trans u w) (left_inverse N))
  end.
  Local Hint Extern 1 =>
  match goal with
    [w : @Obj C |- _] =>
    cbn_rewrite (f_equal (fun u => Trans u w) (right_inverse N))
  end.

  Program Definition Left_Functor_Extender_Iso :
    ((Left_Functor_Extender p D) ≃ (Left_Functor_Extender p' D))%natiso
    :=
      {|
        iso_morphism :=
          {|
            Trans :=
              fun e =>
                ((NatTrans_id_Iso e) ∘_h N)%natiso
          |};
        inverse_morphism :=
          {|
            Trans :=
              fun e =>
                ((NatTrans_id_Iso e) ∘_h (N⁻¹))%natiso
          |}
      |}
  .

End Left_Functor_Extender_Iso.

(** if two functors are naturally isomorphic then so are right exending with them. *)
Section Right_Functor_Extender_Iso.
  Context {C C' : Category} {p p' : (C –≻ C')%functor}
          (N : (p ≃ p')%natiso) (D : Category).

  Local Hint Extern 1 => (rewrite Trans_com); trivial; fail.
  Local Hint Extern 1 => rewrite <- F_compose.
  Local Hint Extern 1 =>
  match goal with
    [w : @Obj D, F : (D –≻ C)%functor |- _] =>
    cbn_rewrite (f_equal (fun u => Trans u (F _o w)%object) (left_inverse N))
    end.
  Local Hint Extern 1 =>
  match goal with
    [w : @Obj D, F : (D –≻ C)%functor |- _] =>
    cbn_rewrite (f_equal (fun u => Trans u (F _o w)%object) (right_inverse N))
    end.

  Program Definition Right_Functor_Extender_Iso :
    ((Right_Functor_Extender p D) ≃ (Right_Functor_Extender p' D))%natiso
    :=
      {|
        iso_morphism :=
          {|
            Trans :=
              fun e =>
                (N ∘_h (NatTrans_id_Iso e))%natiso
          |};
        inverse_morphism :=
          {|
            Trans :=
              fun e =>
                ((N⁻¹) ∘_h (NatTrans_id_Iso e))%natiso
          |}
      |}
  .

End Right_Functor_Extender_Iso.

Section Right_Left_Functor_Extension_Iso.
  Context {B C D E : Category} (F : (B –≻ C)%functor) (G : (D –≻ E)%functor).

  (** It doesn't matter if we first extend from left or right.
      The resulting functors are isomorphic. *)
  Program Definition Right_Left_Functor_Extension_Iso :
    (
      (((Right_Functor_Extender G B) ∘ (Left_Functor_Extender F D))%functor)
        ≃ ((Left_Functor_Extender F E) ∘ (Right_Functor_Extender G C))%functor
    )%natiso :=
    {|
      iso_morphism := {|Trans := fun h => NatTrans_Functor_assoc_sym F h G |};
      inverse_morphism := {|Trans := fun h => NatTrans_Functor_assoc F h G |}
    |}.

End Right_Left_Functor_Extension_Iso.


Require Export FunctionalExtensionality JMeq.
Require Import Common Notations.

Set Implicit Arguments.

Set Asymmetric Patterns.

Set Universe Polymorphism.

Local Infix "==" := JMeq.

Section f_equal_dep.
  Theorem f_type_equal {A B A' B'} : A = A' -> B = B' -> (A -> B) = (A' -> B').
    intros; repeat subst; reflexivity.
  Qed.

  Theorem forall_extensionality_dep : forall {A}
    (f g : A -> Type),
    (forall x, f x = g x) -> (forall x, f x) = (forall x, g x).
    intros.
    replace f with g; auto.
    apply functional_extensionality_dep; auto.
  Qed.

  Theorem forall_extensionality_dep_JMeq : forall {A B}
    (f : A -> Type) (g : B -> Type),
    A = B -> (A = B -> forall x y, x == y -> f x == g y) -> (forall x, f x) = (forall x, g x).
    intros; firstorder; intuition; repeat subst.
    apply forall_extensionality_dep.
    intro.
    apply JMeq_eq.
    eauto.
  Qed.

  Lemma JMeq_eqT A B (x : A) (y : B) : x == y -> A = B.
    intro H; destruct H; reflexivity.
  Qed.

  Lemma fg_equal_JMeq A B B' (f : forall a : A, B a) (g : forall a : A, B' a) x :
    f == g -> (f == g -> B = B') -> f x == g x.
    intros.
    repeat (firstorder; repeat subst).
  Qed.

  Lemma f_equal_JMeq A A' B B' a b (f : forall a : A, A' a) (g : forall b : B, B' b) :
    f == g -> (f == g -> A' == B') -> (f == g -> a == b) -> f a == g b.
    intros.
    firstorder.
    repeat destruct_type @JMeq.
    repeat subst; reflexivity.
  Qed.

  Lemma f_equal1_JMeq A0 B a0 b0 (f : forall (a0 : A0), B a0) :
    a0 = b0
    -> f a0 == f b0.
    intros.
    repeat (firstorder; repeat subst).
  Qed.

  Lemma f_equal2_JMeq A0 A1 B a0 b0 a1 b1 (f : forall (a0 : A0) (a1 : A1 a0), B a0 a1) :
    a0 = b0
    -> (a0 = b0 -> a1 == b1)
    -> f a0 a1 == f b0 b1.
    intros.
    repeat (firstorder; repeat subst).
  Qed.

  Lemma f_equal3_JMeq A0 A1 A2 B a0 b0 a1 b1 a2 b2 (f : forall (a0 : A0) (a1 : A1 a0) (a2 : A2 a0 a1), B a0 a1 a2) :
    a0 = b0
    -> (a0 = b0 -> a1 == b1)
    -> (a0 = b0 -> a1 == b1 -> a2 == b2)
    -> f a0 a1 a2 == f b0 b1 b2.
    intros.
    repeat (firstorder; repeat subst).
  Qed.

  Lemma f_equal4_JMeq A0 A1 A2 A3 B a0 b0 a1 b1 a2 b2 a3 b3 (f : forall (a0 : A0) (a1 : A1 a0) (a2 : A2 a0 a1) (a3 : A3 a0 a1 a2), B a0 a1 a2 a3) :
    a0 = b0
    -> (a0 = b0 -> a1 == b1)
    -> (a0 = b0 -> a1 == b1 -> a2 == b2)
    -> (a0 = b0 -> a1 == b1 -> a2 == b2 -> a3 == b3)
    -> f a0 a1 a2 a3 == f b0 b1 b2 b3.
    intros.
    repeat (firstorder; repeat subst).
  Qed.

  Lemma f_equal5_JMeq A0 A1 A2 A3 A4 B a0 b0 a1 b1 a2 b2 a3 b3 a4 b4 (f : forall (a0 : A0) (a1 : A1 a0) (a2 : A2 a0 a1) (a3 : A3 a0 a1 a2) (a4 : A4 a0 a1 a2 a3), B a0 a1 a2 a3 a4) :
    a0 = b0
    -> (a0 = b0 -> a1 == b1)
    -> (a0 = b0 -> a1 == b1 -> a2 == b2)
    -> (a0 = b0 -> a1 == b1 -> a2 == b2 -> a3 == b3)
    -> (a0 = b0 -> a1 == b1 -> a2 == b2 -> a3 == b3 -> a4 == b4)
    -> f a0 a1 a2 a3 a4 == f b0 b1 b2 b3 b4.
    intros.
    repeat (firstorder; repeat subst).
  Qed.

  Lemma eq_JMeq T (A B : T) : A = B -> A == B.
    intro; subst; reflexivity.
  Qed.

  Theorem functional_extensionality_dep_JMeq : forall {A} {B1 B2 : A -> Type},
    forall (f : forall x : A, B1 x) (g : forall x : A, B2 x),
      (forall x, B1 x = B2 x)
      -> (forall x, f x == g x) -> f == g.
    intros.
    assert (B1 = B2) by (extensionality x; auto); subst.
    assert (f = g) by (extensionality x; apply JMeq_eq; auto).
    subst; reflexivity.
  Qed.

  Theorem functional_extensionality_dep_JMeq' : forall {A1 A2} {B1 : A1 -> Type} {B2 : A2 -> Type},
    forall (f : forall x : A1, B1 x) (g : forall x : A2, B2 x),
      A1 = A2
      -> (A1 = A2 -> forall x y, x == y -> B1 x = B2 y)
      -> (A1 = A2 -> forall x y, x == y -> f x == g y) -> f == g.
    intros.
    intuition; repeat subst.
    apply functional_extensionality_dep_JMeq; intros;
      intuition.
  Qed.
End f_equal_dep.

Inductive identity_dep (A : Type) (a : A) : forall B : Type, B -> Type :=
  identity_dep_refl : identity_dep a a.

Section f_identity_dep.
  Local Infix "~" := identity (at level 50).
  Local Infix "~~" := identity_dep (at level 50).
  Definition f_identity (A B : Type) (f : A -> B) (x y : A) (H : x ~ y) : f x ~ f y
    := match H in (_ ~ y0) return (f x ~ f y0) with
         | identity_refl => identity_refl (f x)
       end.

  Definition f_type_identity {A B A' B'} : A ~ A' -> B ~ B' -> (A -> B) ~ (A' -> B').
    intros; destruct_head identity; reflexivity.
  Defined.

  Axiom functional_extensionality_dep_identity : forall {A : Type} {B : A -> Type} (f g : forall x : A, B x),
                                                   (forall x : A, f x ~ g x) -> f ~ g.

  Axiom identity_dep_identity : forall A (x y : A), x ~~ y -> x ~ y.

  Definition functional_extensionality_identity {A B : Type} := fun (f g : A -> B) (H : forall x : A, f x ~ g x) => functional_extensionality_dep_identity f g H.

  Theorem forall_extensionality_dep_identity : forall {A}
                                                      (f g : A -> Type),
                                                 (forall x, f x ~ g x) -> (forall x, f x) ~ (forall x, g x).
    intros.
    cut (f ~ g); [ let H := fresh in intro H; destruct H; reflexivity | ].
    apply functional_extensionality_dep_identity; assumption.
  Qed.

  Theorem forall_extensionality_dep_identity_dep : forall {A B}
                                                          (f : A -> Type) (g : B -> Type),
                                                     A ~ B -> (A ~ B -> forall x y, x ~~ y -> f x ~~ g y) -> (forall x, f x) ~ (forall x, g x).
    intros; intuition; destruct_head identity.
    apply forall_extensionality_dep_identity.
    intro.
    apply identity_dep_identity.
    match goal with | [ H : _ |- _ ] => apply H; reflexivity end.
  Qed.

  Definition identity_dep_identityT A B (x : A) (y : B) : x ~~ y -> A ~ B
    := fun H => match H in (_ ~~ b) return _ with
                  | identity_dep_refl => identity_refl A
                end.
End f_identity_dep.

Ltac JMeq_eq :=
  repeat match goal with
           | [ |- _ == _ ] => apply eq_JMeq
           | [ H : _ == _ |- _ ] => apply JMeq_eq in H
         end.

Ltac f_equal_dep_cleanup := JMeq_eq; eta_red.

Ltac f_equal_dep' := intros; f_equal; simpl in *;
  match goal with
    | [ |- ?f ?a == ?g ?b ] => apply (@f_equal_JMeq _ _ _ _ a b f g); intros; try reflexivity; repeat subst; intros;
      match goal with
        | [ |- f == g ] => f_equal_dep'
        | [ |- ?x == ?y ] => f_equal_dep_cleanup; try reflexivity
        | _ => idtac
      end
  end; f_equal_dep_cleanup.

Ltac f_equal_dep := intros; f_equal; simpl in *;
  repeat match goal with
           | [ |- ?f ?a = ?g ?b ] => apply JMeq_eq; f_equal_dep'
           | [ |- ?f ?a == ?g ?b ] => f_equal_dep'
           | _ => try reflexivity
         end; f_equal_dep_cleanup.

Section misc.
  Lemma sig_JMeq A0 A1 B0 B1 (a : @sig A0 A1) (b : @sig B0 B1) : A1 == B1 -> proj1_sig a == proj1_sig b -> a == b.
    intros.
    destruct_sig.
    repeat destruct_type @JMeq.
    JMeq_eq; subst.
    JMeq_eq.
    simpl_eq.
    trivial.
  Qed.
End misc.


(*******************************************************************)
(*  This is part of RelationAlgebra, it is distributed under the   *)
(*    terms of the GNU Lesser General Public License version 3     *)
(*              (see file LICENSE for more details)                *)
(*                                                                 *)
(*  Copyright 2012: Damien Pous. (CNRS, LIP - ENS Lyon, UMR 5668)  *)
(*******************************************************************)

(** * level: tuples of Booleans identifying a point in the algebraic hierarchy  *)

Require Import common.

(** a level specifies which relation algebra operations are considered

   the interpretation in the model of binary relations is given on the
   right-hand side. *)
Record level := mk_level {
  has_cup: bool;                (** set theoretic union *)
  has_bot: bool;                (** empty relation *)
  has_cap: bool;                (** set theoretic intersection *)
  has_top: bool;                (** full relation *)
  has_str: bool;                (** reflexive transitive closure *)
  has_cnv: bool;                (** converse, or transpose *)
  has_neg: bool;                (** Boolean negation *)
  has_div: bool                 (** residuals, or factors *)
}.
Bind Scope level_scope with level.
Delimit Scope level_scope with level.

(** dual level, for symmetry arguments related to lattices *)
Definition dual l := mk_level
  (has_cap l)
  (has_top l)
  (has_cup l)
  (has_bot l)
  (has_str l)
  (has_cnv l)
  (has_neg l)
  (has_div l).

(** * Level constraints *)

(** [lower k k'], or [k << k'], denotes the fact that there are less
   operations/axioms at level [k] than at level [k'] *)
Class lower (k k': level) := mk_lower:
  let 'mk_level a  b  c  d  e  f  g  h  := k in
  let 'mk_level a' b' c' d' e' f' g' h' := k' in
  is_true (a<<<a'&&& b<<<b' &&& c<<<c' &&& d<<<d'
           &&& e<<<e' &&& f<<<f' &&& g<<<g' &&& h <<< h').
Infix "<<" := lower (at level 79): ra_scope.
Arguments lower _ _: simpl never.

Local Open Scope ra_scope.

(** alternative specifiaction of [h << k] *)
Lemma lower_spec h k: h<<k <->
  (has_cup h -> has_cup k) /\
  (has_bot h -> has_bot k) /\
  (has_cap h -> has_cap k) /\
  (has_top h -> has_top k) /\
  (has_str h -> has_str k) /\
  (has_cnv h -> has_cnv k) /\
  (has_neg h -> has_neg k) /\
  (has_div h -> has_div k).
Proof.
  destruct h; destruct k. unfold lower.
  rewrite !landb_spec, !le_bool_spec. reflexivity.
Qed.

(** [<<] is a preorder *)
Instance lower_refl: Reflexive lower.
Proof. intro. setoid_rewrite lower_spec. tauto. Qed.

Instance lower_trans: Transitive lower.
Proof. intros h k l. setoid_rewrite lower_spec. tauto. Qed.

(** * Merging levels *)

(** merging two levels: taking the union of their supported operations *)
Definition merge h k := mk_level
  (has_cup h ||| has_cup k)
  (has_bot h ||| has_bot k)
  (has_cap h ||| has_cap k)
  (has_top h ||| has_top k)
  (has_str h ||| has_str k)
  (has_cnv h ||| has_cnv k)
  (has_neg h ||| has_neg k)
  (has_div h ||| has_div k).
Infix "+" := merge: level_scope.
Arguments merge _ _: simpl never.

(** [merge] is a supremum for the [<<] preorder *)
Lemma merge_spec h k l: h+k<<l <-> h<<l /\ k<<l.
Proof. setoid_rewrite lower_spec. setoid_rewrite lorb_spec. tauto. Qed.

Lemma lower_xmerge h k l: l<<h \/ l<<k -> l << (h + k).
Proof.
  assert (C:= merge_spec h k (h+k)).
  intros [E|E]; (eapply lower_trans; [eassumption|]); apply C, lower_refl.
Qed.

Lemma lower_mergex h k l: h<<l -> k<<l -> h+k << l.
Proof. rewrite merge_spec. tauto. Qed.

Instance merge_lower: Proper (lower ==> lower ==> lower) merge.
Proof. intros h k H h' k' H'. apply lower_mergex; apply lower_xmerge; auto. Qed.

(** * Tactics for level constraints resolution *)

(** simple but efficient tactic, this is the one used by default, we
   give it as a hint for maximally inserted arguments (typeclasses
   resolution) *)
Ltac solve_lower := solve
  [ exact eq_refl               (* trivial constraint (on closed levels) *)
  | eassumption                 (* context assumption *)
  | repeat
    match goal with
      | H: ?h << ?l , H': ?k << ?l |- _ << ?l =>
        (* merge assumptions about [l] *)
        apply (lower_mergex h k l H) in H'; clear H
      | H: ?k << ?l |- ?h << _ =>
        (* use assumptions by transitivity *)
        apply (lower_trans h k l eq_refl H)
    end ] || fail "could not prove this entailment".
Hint Extern 0 (_ << _) => solve_lower: typeclass_instances.

(** heavier and more complete tactic, which we use in a selfdom way *)
Ltac solve_lower' := solve [
  (repeat
    match goal with
      H: _ + _ << _ |- _ => apply merge_spec in H as [? ?]
    end);
  (repeat apply lower_mergex);
  auto 100 using lower_xmerge, lower_refl ] || fail "could not prove this entailment".

(** tactic used to discriminate unsatisfiable level constraint *)
Ltac discriminate_levels := solve [
  intros; repeat discriminate ||
    match goal with
      | H: _ + _ << _ |- _ => apply merge_spec in H as [? ?]
    end ].

(** * Concrete levels *)
Section levels.
Notation "1" := true.
Notation "0" := false.
(** atoms *)
Definition MIN := mk_level 0 0 0 0 0 0 0 0.
Definition CUP := mk_level 1 0 0 0 0 0 0 0.
Definition BOT := mk_level 0 1 0 0 0 0 0 0.
Definition CAP := mk_level 0 0 1 0 0 0 0 0.
Definition TOP := mk_level 0 0 0 1 0 0 0 0.
Definition STR := mk_level 0 0 0 0 1 0 0 0.
Definition CNV := mk_level 0 0 0 0 0 1 0 0.
Definition NEG := mk_level 0 0 0 0 0 0 1 0.
Definition DIV := mk_level 0 0 0 0 0 0 0 1.
Local Open Scope level_scope.
(** points of particular interest (i.e., corresponding to standard
    mathematical structures) *)
Definition SL  := CUP.
Definition DL  := Eval compute in CUP+CAP.
Definition BSL := Eval compute in SL+BOT.
Definition BDL := Eval compute in DL+BOT+TOP.
Definition BL  := Eval compute in BDL+NEG.
Definition KA  := Eval compute in SL+STR.
Definition AA  := Eval compute in DL+STR.
Definition AL  := Eval compute in CAP+CNV.
Definition DAL := Eval compute in DL+CNV.
Definition BKA := Eval compute in KA+BOT.
Definition CKA := Eval compute in KA+CNV.
End levels.

(* sanity checks for the [solve_lower] tactic *)
(*
Goal forall l, CUP<<l -> AL<<l -> CNV+CUP<<l.
intros. solve_lower || fail "bad". Abort.
Goal forall l, KA<<l -> AL<<l -> CNV+CUP<<l.
intros. solve_lower || fail "bad". Abort.
Goal forall l, CAP<<l -> AL<<l -> CNV+CUP<<l.
intros. Fail solve_lower. Abort.
*)


(************************************************************************)
(* Copyright 2007 Milad Niqui                                           *)
(* This file is distributed under the terms of the                      *)
(* GNU Lesser General Public License Version 2.1                        *)
(* A copy of the license can be found at                                *)
(*                  <http://www.gnu.org/licenses/lgpl.txt>              *)
(************************************************************************)

Require Import AMM11262.
Import NatSet GeneralProperties.

Section example_five_inhabitants.
(** Now we find the witness, in a town with 5 inhabitants; ie, n=2 *)

Definition town_2:= 1 ++ 2 ++ 3 ++ 4 ++ 5 ++ empty.

Remark population_2 : cardinal town_2 = 2*2 +1.
Proof.
 reflexivity.
Qed.

(* (1,2),(1,3),(1,4),(1,5),
   (2,5),
   (3,4),(3,5)
*)
Definition familiarity_2 (m n:elt):Prop :=
  match m,n with
  | 1,2=> True
  | 1,3 => True
  | 1,4 => True
  | 1,5 => True
  | 2,1 => True
  | 2,5 => True
  | 3,1 => True
  | 3,4 => True
  | 3,5 => True
  | 4,1 => True
  | 4,3 => True
  | 5,1 => True
  | 5,2 => True
  | 5,3 => True
  | _,_ => False
  end.

Remark familiarity_2_sym:forall m n : elt, familiarity_2 m n -> familiarity_2 n m.
Proof.
 intros [|[|[|[|[|[|m']]]]]] [|[|[|[|[|[|n']]]]]]; trivial.
Qed.

Remark familiarity_2_extensional:forall (m : elt) (n p : E.t), E.eq n p -> familiarity_2 m n -> familiarity_2 m p.
Proof.
 intros m n p H1 H2; compute in H1; rewrite <- H1; assumption.
Qed.

Remark subsets_2: forall B : t, Subset B town_2 -> cardinal B = 2 ->
  {B [=] 1++2++empty}+{B[=]1++3++empty}+{B[=]1++4++empty}+{B [=] 1++5++empty}+{B[=]2++3++empty}+
  {B[=]2++4++empty}+{B[=]2++5++empty}+{B[=]3++4++empty}+{B [=] 3++5++empty}+{B[=]4++5++empty}.
Proof.
 intros B H_sub H_card.
 destruct (In_dec 1 B) as [H1|H1].
  (* IN 1 B *)
  do 6 left.
  assert (H_card_rem:cardinal (remove 1 B)=1);
  [ rewrite <- (remove_cardinal_1 H1) in H_card; apply eq_add_S; assumption|].
  destruct (In_dec 2 (remove 1 B)) as [H12|H12].
   (* B={1,2} *)
   do 3 left.
   rewrite <- (add_remove H1).
   rewrite <- (add_remove H12).
   generalize (remove_cardinal_1 H12).
   rewrite H_card_rem; intro H_eq2.
   rewrite (empty_is_empty_1 (cardinal_inv_1 (eq_add_S _ _ H_eq2))); reflexivity...
   (* ~ In 2 B *)
   destruct (In_dec 3 (remove 1 B)) as [H13|H13].
    (* B={1,3} *)
    do 2 left; right.
    rewrite <- (add_remove H1).
    rewrite <- (add_remove H13).
    generalize (remove_cardinal_1 H13).
    rewrite H_card_rem; intro H_eq2.
    rewrite (empty_is_empty_1 (cardinal_inv_1 (eq_add_S _ _ H_eq2))); reflexivity...
    (* ~ In 3 B *)
    destruct (In_dec 4 (remove 1 B)) as [H14|H14].
     (* B={1,4} *)
     left; right.
     rewrite <- (add_remove H1).
     rewrite <- (add_remove H14).
     generalize (remove_cardinal_1 H14).
     rewrite H_card_rem; intro H_eq2.
     rewrite (empty_is_empty_1 (cardinal_inv_1 (eq_add_S _ _ H_eq2))); reflexivity...
     (* ~ In 4 B *)
     destruct (In_dec 5 (remove 1 B)) as [H15|H15].
      (* B={1,5} *)
      right.
      rewrite <- (add_remove H1).
      rewrite <- (add_remove H15).
      generalize (remove_cardinal_1 H15).
      rewrite H_card_rem; intro H_eq2.
      rewrite (empty_is_empty_1 (cardinal_inv_1 (eq_add_S _ _ H_eq2))); reflexivity...
      (* ~ In 5 B *)
      apply False_rec.
      assert (H11:=(@remove_1 B _ _ (refl_equal 1))).
      destruct (cardinal_inv_2 H_card_rem) as [b Hb].
       destruct (NatSet.E.eq_dec b 1) as [Hb1|Hb1].
        apply H11; rewrite Hb1 in Hb; assumption.
        destruct (NatSet.E.eq_dec b 2) as [Hb2|Hb2].
         apply H12; rewrite <- Hb2; assumption.
         destruct (NatSet.E.eq_dec b 3) as [Hb3|Hb3].
          apply H13; rewrite <- Hb3; assumption.
          destruct (NatSet.E.eq_dec b 4) as [Hb4|Hb4].
           apply H14; rewrite <- Hb4; assumption.
           destruct (NatSet.E.eq_dec b 5) as [Hb5|Hb5].
            apply H15; rewrite <- Hb5; assumption.

            assert (H_sub':=@subset_remove_3 _ _ 1 H_sub).
            assert (Hb_town:=H_sub' _ Hb).
            unfold town_2 in Hb_town.
            destruct (proj1 (FM.add_iff _ _ b) Hb_town) as [Hb1_town|Hb1_town].
             apply Hb1; rewrite Hb1_town; reflexivity.
             destruct (proj1 (FM.add_iff _ _ b) Hb1_town) as [Hb2_town|Hb2_town].
              apply Hb2; rewrite Hb2_town; reflexivity.
               destruct (proj1 (FM.add_iff _ _ b) Hb2_town) as [Hb3_town|Hb3_town].
                apply Hb3; rewrite Hb3_town; reflexivity.
                destruct (proj1 (FM.add_iff _ _ b) Hb3_town) as [Hb4_town|Hb4_town].
                 apply Hb4; rewrite Hb4_town; reflexivity.
                 destruct (proj1 (FM.add_iff _ _ b) Hb4_town) as [Hb5_town|Hb5_town].
                  apply Hb5; rewrite Hb5_town; reflexivity.
                  apply (proj1 (FM.empty_iff b) Hb5_town)...
  (* ~ IN 1 B *)
  destruct (In_dec 2 B) as [H2|H2].
   (* IN 2 B *)
   assert (H_card_rem:cardinal (remove 2 B)=1);
   [ rewrite <- (remove_cardinal_1 H2) in H_card; apply eq_add_S; assumption|].
   assert (H21:=fun HH : In 1 (remove 2 B) => H1 (remove_3 HH)).
   destruct (In_dec 3 (remove 2 B)) as [H23|H23].
    (* B={2,3} *)
    do 5 left; right.
    rewrite <- (add_remove H2).
    rewrite <- (add_remove H23).
    generalize (remove_cardinal_1 H23).
    rewrite H_card_rem; intro H_eq2.
    rewrite (empty_is_empty_1 (cardinal_inv_1 (eq_add_S _ _ H_eq2))); reflexivity...
    (* ~ In 3 B *)
    destruct (In_dec 4 (remove 2 B)) as [H24|H24].
     (* B={2,4} *)
     do 4 left; right.
     rewrite <- (add_remove H2).
     rewrite <- (add_remove H24).
     generalize (remove_cardinal_1 H24).
     rewrite H_card_rem; intro H_eq2.
     rewrite (empty_is_empty_1 (cardinal_inv_1 (eq_add_S _ _ H_eq2))); reflexivity...
     (* ~ In 4 B *)
     destruct (In_dec 5 (remove 2 B)) as [H25|H25].
      (* B={2,5} *)
      do 3 left; right.
      rewrite <- (add_remove H2).
      rewrite <- (add_remove H25).
      generalize (remove_cardinal_1 H25).
      rewrite H_card_rem; intro H_eq2.
      rewrite (empty_is_empty_1 (cardinal_inv_1 (eq_add_S _ _ H_eq2))); reflexivity...
      (* ~ In 5 B *)
      apply False_rec.
      assert (H22:=(@remove_1 B _ _ (refl_equal 2))).
      destruct (cardinal_inv_2 H_card_rem) as [b Hb].
       destruct (NatSet.E.eq_dec b 1) as [Hb1|Hb1].
        apply H21; rewrite Hb1 in Hb; assumption.
        destruct (NatSet.E.eq_dec b 2) as [Hb2|Hb2].
         apply H22; rewrite Hb2 in Hb; assumption.
         destruct (NatSet.E.eq_dec b 3) as [Hb3|Hb3].
          apply H23; rewrite <- Hb3; assumption.
          destruct (NatSet.E.eq_dec b 4) as [Hb4|Hb4].
           apply H24; rewrite <- Hb4; assumption.
           destruct (NatSet.E.eq_dec b 5) as [Hb5|Hb5].
            apply H25; rewrite <- Hb5; assumption.

            assert (H_sub':=@subset_remove_3 _ _ 2 H_sub).
            assert (Hb_town:=H_sub' _ Hb).
            unfold town_2 in Hb_town.
            destruct (proj1 (FM.add_iff _ _ b) Hb_town) as [Hb1_town|Hb1_town].
             apply Hb1; rewrite Hb1_town; reflexivity.
             destruct (proj1 (FM.add_iff _ _ b) Hb1_town) as [Hb2_town|Hb2_town].
              apply Hb2; rewrite Hb2_town; reflexivity.
               destruct (proj1 (FM.add_iff _ _ b) Hb2_town) as [Hb3_town|Hb3_town].
                apply Hb3; rewrite Hb3_town; reflexivity.
                destruct (proj1 (FM.add_iff _ _ b) Hb3_town) as [Hb4_town|Hb4_town].
                 apply Hb4; rewrite Hb4_town; reflexivity.
                 destruct (proj1 (FM.add_iff _ _ b) Hb4_town) as [Hb5_town|Hb5_town].
                  apply Hb5; rewrite Hb5_town; reflexivity.
                  apply (proj1 (FM.empty_iff b) Hb5_town)...
   (* ~ IN 2 B *)
   destruct (In_dec 3 B) as [H3|H3].
    (* IN 3 B *)
    assert (H_card_rem:cardinal (remove 3 B)=1);
    [ rewrite <- (remove_cardinal_1 H3) in H_card; apply eq_add_S; assumption|].
    assert (H31:=fun HH : In 1 (remove 3 B) => H1 (remove_3 HH)).
    assert (H32:=fun HH : In 2 (remove 3 B) => H2 (remove_3 HH)).
    destruct (In_dec 4 (remove 3 B)) as [H34|H34].
     (* B={3,4} *)
     do 2 left; right.
     rewrite <- (add_remove H3).
     rewrite <- (add_remove H34).
     generalize (remove_cardinal_1 H34).
     rewrite H_card_rem; intro H_eq2.
     rewrite (empty_is_empty_1 (cardinal_inv_1 (eq_add_S _ _ H_eq2))); reflexivity...
     (* ~ In 4 B *)
     destruct (In_dec 5 (remove 3 B)) as [H35|H35].
      (* B={3,5} *)
      left; right.
      rewrite <- (add_remove H3).
      rewrite <- (add_remove H35).
      generalize (remove_cardinal_1 H35).
      rewrite H_card_rem; intro H_eq2.
      rewrite (empty_is_empty_1 (cardinal_inv_1 (eq_add_S _ _ H_eq2))); reflexivity...
      (* ~ In 5 B *)
      apply False_rec.
      assert (H33:=(@remove_1 B _ _ (refl_equal 3))).
      destruct (cardinal_inv_2 H_card_rem) as [b Hb].
       destruct (NatSet.E.eq_dec b 1) as [Hb1|Hb1].
        apply H31; rewrite Hb1 in Hb; assumption.
        destruct (NatSet.E.eq_dec b 2) as [Hb2|Hb2].
         apply H32; rewrite Hb2 in Hb; assumption.
         destruct (NatSet.E.eq_dec b 3) as [Hb3|Hb3].
          apply H33; rewrite Hb3 in Hb; assumption.
          destruct (NatSet.E.eq_dec b 4) as [Hb4|Hb4].
           apply H34; rewrite <- Hb4; assumption.
           destruct (NatSet.E.eq_dec b 5) as [Hb5|Hb5].
            apply H35; rewrite <- Hb5; assumption.

            assert (H_sub':=@subset_remove_3 _ _ 3 H_sub).
            assert (Hb_town:=H_sub' _ Hb).
            unfold town_2 in Hb_town.
            destruct (proj1 (FM.add_iff _ _ b) Hb_town) as [Hb1_town|Hb1_town].
             apply Hb1; rewrite Hb1_town; reflexivity.
             destruct (proj1 (FM.add_iff _ _ b) Hb1_town) as [Hb2_town|Hb2_town].
              apply Hb2; rewrite Hb2_town; reflexivity.
               destruct (proj1 (FM.add_iff _ _ b) Hb2_town) as [Hb3_town|Hb3_town].
                apply Hb3; rewrite Hb3_town; reflexivity.
                destruct (proj1 (FM.add_iff _ _ b) Hb3_town) as [Hb4_town|Hb4_town].
                 apply Hb4; rewrite Hb4_town; reflexivity.
                 destruct (proj1 (FM.add_iff _ _ b) Hb4_town) as [Hb5_town|Hb5_town].
                  apply Hb5; rewrite Hb5_town; reflexivity.
                  apply (proj1 (FM.empty_iff b) Hb5_town)...
    (* ~ IN 3 B *)
    destruct (In_dec 4 B) as [H4|H4].
     (* IN 4 B *)
     assert (H_card_rem:cardinal (remove 4 B)=1);
     [ rewrite <- (remove_cardinal_1 H4) in H_card; apply eq_add_S; assumption|].
     assert (H41:=fun HH : In 1 (remove 4 B) => H1 (remove_3 HH)).
     assert (H42:=fun HH : In 2 (remove 4 B) => H2 (remove_3 HH)).
     assert (H43:=fun HH : In 3 (remove 4 B) => H3 (remove_3 HH)).
     destruct (In_dec 5 (remove 4 B)) as [H45|H45].
      (* B={4,5} *)
      right.
      rewrite <- (add_remove H4).
      rewrite <- (add_remove H45).
      generalize (remove_cardinal_1 H45).
      rewrite H_card_rem; intro H_eq2.
      rewrite (empty_is_empty_1 (cardinal_inv_1 (eq_add_S _ _ H_eq2))); reflexivity...
      (* ~ In 5 B *)
      apply False_rec.
      assert (H44:=(@remove_1 B _ _ (refl_equal 4))).
      destruct (cardinal_inv_2 H_card_rem) as [b Hb].
       destruct (NatSet.E.eq_dec b 1) as [Hb1|Hb1].
        apply H41; rewrite Hb1 in Hb; assumption.
        destruct (NatSet.E.eq_dec b 2) as [Hb2|Hb2].
         apply H42; rewrite Hb2 in Hb; assumption.
         destruct (NatSet.E.eq_dec b 3) as [Hb3|Hb3].
          apply H43; rewrite Hb3 in Hb; assumption.
          destruct (NatSet.E.eq_dec b 4) as [Hb4|Hb4].
           apply H44; rewrite Hb4 in Hb; assumption.
           destruct (NatSet.E.eq_dec b 5) as [Hb5|Hb5].
            apply H45; rewrite <- Hb5; assumption.

            assert (H_sub':=@subset_remove_3 _ _ 4 H_sub).
            assert (Hb_town:=H_sub' _ Hb).
            unfold town_2 in Hb_town.
            destruct (proj1 (FM.add_iff _ _ b) Hb_town) as [Hb1_town|Hb1_town].
             apply Hb1; rewrite Hb1_town; reflexivity.
             destruct (proj1 (FM.add_iff _ _ b) Hb1_town) as [Hb2_town|Hb2_town].
              apply Hb2; rewrite Hb2_town; reflexivity.
               destruct (proj1 (FM.add_iff _ _ b) Hb2_town) as [Hb3_town|Hb3_town].
                apply Hb3; rewrite Hb3_town; reflexivity.
                destruct (proj1 (FM.add_iff _ _ b) Hb3_town) as [Hb4_town|Hb4_town].
                 apply Hb4; rewrite Hb4_town; reflexivity.
                 destruct (proj1 (FM.add_iff _ _ b) Hb4_town) as [Hb5_town|Hb5_town].
                  apply Hb5; rewrite Hb5_town; reflexivity.
                  apply (proj1 (FM.empty_iff b) Hb5_town)...
     (* ~ IN 4 B *)
     apply False_rec.
     destruct (In_dec 5 B) as [H5|H5].
      (* IN 5 B *)
      assert (H_card_rem:cardinal (remove 5 B)=1);
      [ rewrite <- (remove_cardinal_1 H5) in H_card; apply eq_add_S; assumption|].
      assert (H51:=fun HH : In 1 (remove 5 B) => H1 (remove_3 HH)).
      assert (H52:=fun HH : In 2 (remove 5 B) => H2 (remove_3 HH)).
      assert (H53:=fun HH : In 3 (remove 5 B) => H3 (remove_3 HH)).
      assert (H54:=fun HH : In 4 (remove 5 B) => H4 (remove_3 HH)).
      assert (H55:=(@remove_1 B _ _ (refl_equal 5))).
      destruct (cardinal_inv_2 H_card_rem) as [b Hb].
      assert (H_sub':=@subset_remove_3 _ _ 5 H_sub).
      assert (Hb_town:=H_sub' _ Hb).
      unfold town_2 in Hb_town.
      destruct (proj1 (FM.add_iff _ _ b) Hb_town) as [Hb1_town|Hb1_town].
       apply H51; rewrite <- Hb1_town in Hb; assumption.
       destruct (proj1 (FM.add_iff _ _ b) Hb1_town) as [Hb2_town|Hb2_town].
        apply H52; rewrite <- Hb2_town in Hb; assumption.
         destruct (proj1 (FM.add_iff _ _ b) Hb2_town) as [Hb3_town|Hb3_town].
          apply H53; rewrite <- Hb3_town in Hb; assumption.
          destruct (proj1 (FM.add_iff _ _ b) Hb3_town) as [Hb4_town|Hb4_town].
           apply H54; rewrite <- Hb4_town in Hb; assumption.
           destruct (proj1 (FM.add_iff _ _ b) Hb4_town) as [Hb5_town|Hb5_town].
            apply H55; rewrite <- Hb5_town in Hb; assumption.
            apply (proj1 (FM.empty_iff b) Hb5_town)...
      (* IN 1,2,3,4,5 B *)
      destruct (cardinal_inv_2 H_card) as [b Hb].
       destruct (NatSet.E.eq_dec b 1) as [Hb1|Hb1].
        apply H1; rewrite Hb1 in Hb; assumption.
        destruct (NatSet.E.eq_dec b 2) as [Hb2|Hb2].
         apply H2; rewrite Hb2 in Hb; assumption.
         destruct (NatSet.E.eq_dec b 3) as [Hb3|Hb3].
          apply H3; rewrite Hb3 in Hb; assumption.
          destruct (NatSet.E.eq_dec b 4) as [Hb4|Hb4].
           apply H4; rewrite Hb4 in Hb; assumption.
           destruct (NatSet.E.eq_dec b 5) as [Hb5|Hb5].
            apply H5; rewrite <- Hb5; assumption.

            assert (Hb_town:=H_sub _ Hb).
            unfold town_2 in Hb_town.
            destruct (proj1 (FM.add_iff _ _ b) Hb_town) as [Hb1_town|Hb1_town].
             apply Hb1; rewrite Hb1_town; reflexivity.
             destruct (proj1 (FM.add_iff _ _ b) Hb1_town) as [Hb2_town|Hb2_town].
              apply Hb2; rewrite Hb2_town; reflexivity.
               destruct (proj1 (FM.add_iff _ _ b) Hb2_town) as [Hb3_town|Hb3_town].
                apply Hb3; rewrite Hb3_town; reflexivity.
                destruct (proj1 (FM.add_iff _ _ b) Hb3_town) as [Hb4_town|Hb4_town].
                 apply Hb4; rewrite Hb4_town; reflexivity.
                 destruct (proj1 (FM.add_iff _ _ b) Hb4_town) as [Hb5_town|Hb5_town].
                  apply Hb5; rewrite Hb5_town; reflexivity.
                  apply (proj1 (FM.empty_iff b) Hb5_town)...
Qed.

Remark acquintance_2: forall B : t, Subset B town_2 -> cardinal B = 2 ->
          {d : elt |In d (diff town_2 B) /\ (forall b : elt, In b B -> familiarity_2 d b)}.
Proof.
 intros B H_sub H_card.
 destruct (subsets_2 B H_sub H_card) as [[[[[[[[[HB12|HB13]|HB14]|HB15]|HB23]|HB24]|HB25]|HB34]|HB35]|HB45].
  (* B={1,2} *)
  exists 5; split.
   rewrite HB12; apply mem_2; trivial.
   intro b; rewrite HB12; intro Hb.
   destruct (proj1 (FM.add_iff _ _ b) Hb) as [H|H].
    compute in H; rewrite <- H; simpl; trivial.
    destruct (proj1 (FM.add_iff _ _ b) H) as [H'|H'].
     compute in H'; rewrite <- H'; simpl; trivial.
     apply False_ind; apply (proj1 (FM.empty_iff b) H').
  (* B={1,3} *)
  exists 4; split.
   rewrite HB13; apply mem_2; trivial.
   intro b; rewrite HB13; intro Hb.
   destruct (proj1 (FM.add_iff _ _ b) Hb) as [H|H].
    compute in H; rewrite <- H; simpl; trivial.
    destruct (proj1 (FM.add_iff _ _ b) H) as [H'|H'].
     compute in H'; rewrite <- H'; simpl; trivial.
     apply False_ind; apply (proj1 (FM.empty_iff b) H').
  (* B={1,4} *)
  exists 3; split.
   rewrite HB14; apply mem_2; trivial.
   intro b; rewrite HB14; intro Hb.
   destruct (proj1 (FM.add_iff _ _ b) Hb) as [H|H].
    compute in H; rewrite <- H; simpl; trivial.
    destruct (proj1 (FM.add_iff _ _ b) H) as [H'|H'].
     compute in H'; rewrite <- H'; simpl; trivial.
     apply False_ind; apply (proj1 (FM.empty_iff b) H').
  (* B={1,5} *)
  exists 2; split.
   rewrite HB15; apply mem_2; trivial.
   intro b; rewrite HB15; intro Hb.
   destruct (proj1 (FM.add_iff _ _ b) Hb) as [H|H].
    compute in H; rewrite <- H; simpl; trivial.
    destruct (proj1 (FM.add_iff _ _ b) H) as [H'|H'].
     compute in H'; rewrite <- H'; simpl; trivial.
     apply False_ind; apply (proj1 (FM.empty_iff b) H').
  (* B={2,3} *)
  exists 5; split.
   rewrite HB23; apply mem_2; trivial.
   intro b; rewrite HB23; intro Hb.
   destruct (proj1 (FM.add_iff _ _ b) Hb) as [H|H].
    compute in H; rewrite <- H; simpl; trivial.
    destruct (proj1 (FM.add_iff _ _ b) H) as [H'|H'].
     compute in H'; rewrite <- H'; simpl; trivial.
     apply False_ind; apply (proj1 (FM.empty_iff b) H').
  (* B={2,4} *)
  exists 1; split.
   rewrite HB24; apply mem_2; trivial.
   intro b; rewrite HB24; intro Hb.
   destruct (proj1 (FM.add_iff _ _ b) Hb) as [H|H].
    compute in H; rewrite <- H; simpl; trivial.
    destruct (proj1 (FM.add_iff _ _ b) H) as [H'|H'].
     compute in H'; rewrite <- H'; simpl; trivial.
     apply False_ind; apply (proj1 (FM.empty_iff b) H').
  (* B={2,5} *)
  exists 1; split.
   rewrite HB25; apply mem_2; trivial.
   intro b; rewrite HB25; intro Hb.
   destruct (proj1 (FM.add_iff _ _ b) Hb) as [H|H].
    compute in H; rewrite <- H; simpl; trivial.
    destruct (proj1 (FM.add_iff _ _ b) H) as [H'|H'].
     compute in H'; rewrite <- H'; simpl; trivial.
     apply False_ind; apply (proj1 (FM.empty_iff b) H').
  (* B={3,4} *)
  exists 1; split.
   rewrite HB34; apply mem_2; trivial.
   intro b; rewrite HB34; intro Hb.
   destruct (proj1 (FM.add_iff _ _ b) Hb) as [H|H].
    compute in H; rewrite <- H; simpl; trivial.
    destruct (proj1 (FM.add_iff _ _ b) H) as [H'|H'].
     compute in H'; rewrite <- H'; simpl; trivial.
     apply False_ind; apply (proj1 (FM.empty_iff b) H').
  (* B={3,5} *)
  exists 1; split.
   rewrite HB35; apply mem_2; trivial.
   intro b; rewrite HB35; intro Hb.
   destruct (proj1 (FM.add_iff _ _ b) Hb) as [H|H].
    compute in H; rewrite <- H; simpl; trivial.
    destruct (proj1 (FM.add_iff _ _ b) H) as [H'|H'].
     compute in H'; rewrite <- H'; simpl; trivial.
     apply False_ind; apply (proj1 (FM.empty_iff b) H').
  (* B={4,5} *)
  exists 3; split.
   rewrite HB45; apply mem_2; trivial.
   intro b; rewrite HB45; intro Hb.
   destruct (proj1 (FM.add_iff _ _ b) Hb) as [H|H].
    compute in H; rewrite <- H; simpl; trivial.
    destruct (proj1 (FM.add_iff _ _ b) H) as [H'|H'].
     compute in H'; rewrite <- H'; simpl; trivial.
     apply False_ind; apply (proj1 (FM.empty_iff b) H').
Defined.

Check (AMM11262 town_2 2 population_2 familiarity_2 familiarity_2_sym familiarity_2_extensional acquintance_2).

Definition social_citizen_2:=AMM11262 town_2 2 population_2 familiarity_2
                                      familiarity_2_sym familiarity_2_extensional acquintance_2.

End example_five_inhabitants.

Extraction "social2" social_citizen_2.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

Require Import Rbase.
Require Import Rfunctions.
Require Import Rseries.
Require Import Rcomplete.
Require Import Max.
Open Local Scope R_scope.

Lemma tech1 :
  forall (An:nat -> R) (N:nat),
    (forall n:nat, (n <= N)%nat -> 0 < An n) -> 0 < sum_f_R0 An N.
Proof.
  intros; induction  N as [| N HrecN].
  simpl in |- *; apply H; apply le_n.
  simpl in |- *; apply Rplus_lt_0_compat.
  apply HrecN; intros; apply H; apply le_S; assumption.
  apply H; apply le_n.
Qed.

(* Chasles' relation *)
Lemma tech2 :
  forall (An:nat -> R) (m n:nat),
    (m < n)%nat ->
    sum_f_R0 An n =
    sum_f_R0 An m + sum_f_R0 (fun i:nat => An (S m + i)%nat) (n - S m).
Proof.
  intros; induction  n as [| n Hrecn].
  elim (lt_n_O _ H).
  cut ((m < n)%nat \/ m = n).
  intro; elim H0; intro.
  replace (sum_f_R0 An (S n)) with (sum_f_R0 An n + An (S n));
  [ idtac | reflexivity ].
  replace (S n - S m)%nat with (S (n - S m)).
  replace (sum_f_R0 (fun i:nat => An (S m + i)%nat) (S (n - S m))) with
  (sum_f_R0 (fun i:nat => An (S m + i)%nat) (n - S m) +
    An (S m + S (n - S m))%nat); [ idtac | reflexivity ].
  replace (S m + S (n - S m))%nat with (S n).
  rewrite (Hrecn H1).
  ring.
  apply INR_eq; rewrite S_INR; rewrite plus_INR; do 2 rewrite S_INR;
    rewrite minus_INR.
  rewrite S_INR; ring.
  apply lt_le_S; assumption.
  apply INR_eq; rewrite S_INR; repeat rewrite minus_INR.
  repeat rewrite S_INR; ring.
  apply le_n_S; apply lt_le_weak; assumption.
  apply lt_le_S; assumption.
  rewrite H1; rewrite <- minus_n_n; simpl in |- *.
  replace (n + 0)%nat with n; [ reflexivity | ring ].
  inversion H.
  right; reflexivity.
  left; apply lt_le_trans with (S m); [ apply lt_n_Sn | assumption ].
Qed.

(* Sum of geometric sequences *)
Lemma tech3 :
  forall (k:R) (N:nat),
    k <> 1 -> sum_f_R0 (fun i:nat => k ^ i) N = (1 - k ^ S N) / (1 - k).
Proof.
  intros; cut (1 - k <> 0).
  intro; induction  N as [| N HrecN].
  simpl in |- *; rewrite Rmult_1_r; unfold Rdiv in |- *; rewrite <- Rinv_r_sym.
  reflexivity.
  apply H0.
  replace (sum_f_R0 (fun i:nat => k ^ i) (S N)) with
  (sum_f_R0 (fun i:nat => k ^ i) N + k ^ S N); [ idtac | reflexivity ];
  rewrite HrecN;
    replace ((1 - k ^ S N) / (1 - k) + k ^ S N) with
    ((1 - k ^ S N + (1 - k) * k ^ S N) / (1 - k)).
  apply Rmult_eq_reg_l with (1 - k).
  unfold Rdiv in |- *; do 2 rewrite <- (Rmult_comm (/ (1 - k)));
    repeat rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym;
      [ do 2 rewrite Rmult_1_l; simpl in |- *; ring | apply H0 ].
  apply H0.
  unfold Rdiv in |- *; rewrite Rmult_plus_distr_r; rewrite (Rmult_comm (1 - k));
    repeat rewrite Rmult_assoc; rewrite <- Rinv_r_sym.
  rewrite Rmult_1_r; reflexivity.
  apply H0.
  apply Rminus_eq_contra; red in |- *; intro; elim H; symmetry  in |- *;
    assumption.
Qed.

Lemma tech4 :
  forall (An:nat -> R) (k:R) (N:nat),
    0 <= k -> (forall i:nat, An (S i) < k * An i) -> An N <= An 0%nat * k ^ N.
Proof.
  intros; induction  N as [| N HrecN].
  simpl in |- *; right; ring.
  apply Rle_trans with (k * An N).
  left; apply (H0 N).
  replace (S N) with (N + 1)%nat; [ idtac | ring ].
  rewrite pow_add; simpl in |- *; rewrite Rmult_1_r;
    replace (An 0%nat * (k ^ N * k)) with (k * (An 0%nat * k ^ N));
    [ idtac | ring ]; apply Rmult_le_compat_l.
  assumption.
  apply HrecN.
Qed.

Lemma tech5 :
  forall (An:nat -> R) (N:nat), sum_f_R0 An (S N) = sum_f_R0 An N + An (S N).
Proof.
  intros; reflexivity.
Qed.

Lemma tech6 :
  forall (An:nat -> R) (k:R) (N:nat),
    0 <= k ->
    (forall i:nat, An (S i) < k * An i) ->
    sum_f_R0 An N <= An 0%nat * sum_f_R0 (fun i:nat => k ^ i) N.
Proof.
  intros; induction  N as [| N HrecN].
  simpl in |- *; right; ring.
  apply Rle_trans with (An 0%nat * sum_f_R0 (fun i:nat => k ^ i) N + An (S N)).
  rewrite tech5; do 2 rewrite <- (Rplus_comm (An (S N)));
    apply Rplus_le_compat_l.
  apply HrecN.
  rewrite tech5; rewrite Rmult_plus_distr_l; apply Rplus_le_compat_l.
  apply tech4; assumption.
Qed.

Lemma tech7 : forall r1 r2:R, r1 <> 0 -> r2 <> 0 -> r1 <> r2 -> / r1 <> / r2.
Proof.
  intros; red in |- *; intro.
  assert (H3 := Rmult_eq_compat_l r1 _ _ H2).
  rewrite <- Rinv_r_sym in H3; [ idtac | assumption ].
  assert (H4 := Rmult_eq_compat_l r2 _ _ H3).
  rewrite Rmult_1_r in H4; rewrite <- Rmult_assoc in H4.
  rewrite Rinv_r_simpl_m in H4; [ idtac | assumption ].
  elim H1; symmetry  in |- *; assumption.
Qed.

Lemma tech11 :
  forall (An Bn Cn:nat -> R) (N:nat),
    (forall i:nat, An i = Bn i - Cn i) ->
    sum_f_R0 An N = sum_f_R0 Bn N - sum_f_R0 Cn N.
Proof.
  intros; induction  N as [| N HrecN].
  simpl in |- *; apply H.
  do 3 rewrite tech5; rewrite HrecN; rewrite (H (S N)); ring.
Qed.

Lemma tech12 :
  forall (An:nat -> R) (x l:R),
    Un_cv (fun N:nat => sum_f_R0 (fun i:nat => An i * x ^ i) N) l ->
    Pser An x l.
Proof.
  intros; unfold Pser in |- *; unfold infinite_sum in |- *; unfold Un_cv in H;
    assumption.
Qed.

Lemma scal_sum :
  forall (An:nat -> R) (N:nat) (x:R),
    x * sum_f_R0 An N = sum_f_R0 (fun i:nat => An i * x) N.
Proof.
  intros; induction  N as [| N HrecN].
  simpl in |- *; ring.
  do 2 rewrite tech5.
  rewrite Rmult_plus_distr_l; rewrite <- HrecN; ring.
Qed.

Lemma decomp_sum :
  forall (An:nat -> R) (N:nat),
    (0 < N)%nat ->
    sum_f_R0 An N = An 0%nat + sum_f_R0 (fun i:nat => An (S i)) (pred N).
Proof.
  intros; induction  N as [| N HrecN].
  elim (lt_irrefl _ H).
  cut ((0 < N)%nat \/ N = 0%nat).
  intro; elim H0; intro.
  cut (S (pred N) = pred (S N)).
  intro; rewrite <- H2.
  do 2 rewrite tech5.
  replace (S (S (pred N))) with (S N).
  rewrite (HrecN H1); ring.
  rewrite H2; simpl in |- *; reflexivity.
  assert (H2 := O_or_S N).
  elim H2; intros.
  elim a; intros.
  rewrite <- p.
  simpl in |- *; reflexivity.
  rewrite <- b in H1; elim (lt_irrefl _ H1).
  rewrite H1; simpl in |- *; reflexivity.
  inversion H.
  right; reflexivity.
  left; apply lt_le_trans with 1%nat; [ apply lt_O_Sn | assumption ].
Qed.

Lemma plus_sum :
  forall (An Bn:nat -> R) (N:nat),
    sum_f_R0 (fun i:nat => An i + Bn i) N = sum_f_R0 An N + sum_f_R0 Bn N.
Proof.
  intros; induction  N as [| N HrecN].
  simpl in |- *; ring.
  do 3 rewrite tech5; rewrite HrecN; ring.
Qed.

Lemma sum_eq :
  forall (An Bn:nat -> R) (N:nat),
    (forall i:nat, (i <= N)%nat -> An i = Bn i) ->
    sum_f_R0 An N = sum_f_R0 Bn N.
Proof.
  intros; induction  N as [| N HrecN].
  simpl in |- *; apply H; apply le_n.
  do 2 rewrite tech5; rewrite HrecN.
  rewrite (H (S N)); [ reflexivity | apply le_n ].
  intros; apply H; apply le_trans with N; [ assumption | apply le_n_Sn ].
Qed.

(* Unicity of the limit defined by convergent series *)
Lemma uniqueness_sum :
  forall (An:nat -> R) (l1 l2:R),
    infinite_sum An l1 -> infinite_sum An l2 -> l1 = l2.
Proof.
  unfold infinite_sum in |- *; intros.
  case (Req_dec l1 l2); intro.
  assumption.
  cut (0 < Rabs ((l1 - l2) / 2)); [ intro | apply Rabs_pos_lt ].
  elim (H (Rabs ((l1 - l2) / 2)) H2); intros.
  elim (H0 (Rabs ((l1 - l2) / 2)) H2); intros.
  set (N := max x0 x); cut (N >= x0)%nat.
  cut (N >= x)%nat.
  intros; assert (H7 := H3 N H5); assert (H8 := H4 N H6).
  cut (Rabs (l1 - l2) <= R_dist (sum_f_R0 An N) l1 + R_dist (sum_f_R0 An N) l2).
  intro; assert (H10 := Rplus_lt_compat _ _ _ _ H7 H8);
    assert (H11 := Rle_lt_trans _ _ _ H9 H10); unfold Rdiv in H11;
      rewrite Rabs_mult in H11.
  cut (Rabs (/ 2) = / 2).
  intro; rewrite H12 in H11; assert (H13 := double_var); unfold Rdiv in H13;
    rewrite <- H13 in H11.
  elim (Rlt_irrefl _ H11).
  apply Rabs_right; left; change (0 < / 2) in |- *; apply Rinv_0_lt_compat;
    cut (0%nat <> 2%nat);
      [ intro H20; generalize (lt_INR_0 2 (neq_O_lt 2 H20)); unfold INR in |- *;
        intro; assumption
        | discriminate ].
  unfold R_dist in |- *; rewrite <- (Rabs_Ropp (sum_f_R0 An N - l1));
    rewrite Ropp_minus_distr'.
  replace (l1 - l2) with (l1 - sum_f_R0 An N + (sum_f_R0 An N - l2));
  [ idtac | ring ].
  apply Rabs_triang.
  unfold ge in |- *; unfold N in |- *; apply le_max_r.
  unfold ge in |- *; unfold N in |- *; apply le_max_l.
  unfold Rdiv in |- *; apply prod_neq_R0.
  apply Rminus_eq_contra; assumption.
  apply Rinv_neq_0_compat; discrR.
Qed.

Lemma minus_sum :
  forall (An Bn:nat -> R) (N:nat),
    sum_f_R0 (fun i:nat => An i - Bn i) N = sum_f_R0 An N - sum_f_R0 Bn N.
Proof.
  intros; induction  N as [| N HrecN].
  simpl in |- *; ring.
  do 3 rewrite tech5; rewrite HrecN; ring.
Qed.

Lemma sum_decomposition :
  forall (An:nat -> R) (N:nat),
    sum_f_R0 (fun l:nat => An (2 * l)%nat) (S N) +
    sum_f_R0 (fun l:nat => An (S (2 * l))) N = sum_f_R0 An (2 * S N).
Proof.
  intros.
  induction  N as [| N HrecN].
  simpl in |- *; ring.
  rewrite tech5.
  rewrite (tech5 (fun l:nat => An (S (2 * l))) N).
  replace (2 * S (S N))%nat with (S (S (2 * S N))).
  rewrite (tech5 An (S (2 * S N))).
  rewrite (tech5 An (2 * S N)).
  rewrite <- HrecN.
  ring.
  ring.
Qed.

Lemma sum_Rle :
  forall (An Bn:nat -> R) (N:nat),
    (forall n:nat, (n <= N)%nat -> An n <= Bn n) ->
    sum_f_R0 An N <= sum_f_R0 Bn N.
Proof.
  intros.
  induction  N as [| N HrecN].
  simpl in |- *; apply H.
  apply le_n.
  do 2 rewrite tech5.
  apply Rle_trans with (sum_f_R0 An N + Bn (S N)).
  apply Rplus_le_compat_l.
  apply H.
  apply le_n.
  do 2 rewrite <- (Rplus_comm (Bn (S N))).
  apply Rplus_le_compat_l.
  apply HrecN.
  intros; apply H.
  apply le_trans with N; [ assumption | apply le_n_Sn ].
Qed.

Lemma Rsum_abs :
  forall (An:nat -> R) (N:nat),
    Rabs (sum_f_R0 An N) <= sum_f_R0 (fun l:nat => Rabs (An l)) N.
Proof.
  intros.
  induction  N as [| N HrecN].
  simpl in |- *.
  right; reflexivity.
  do 2 rewrite tech5.
  apply Rle_trans with (Rabs (sum_f_R0 An N) + Rabs (An (S N))).
  apply Rabs_triang.
  do 2 rewrite <- (Rplus_comm (Rabs (An (S N)))).
  apply Rplus_le_compat_l.
  apply HrecN.
Qed.

Lemma sum_cte :
  forall (x:R) (N:nat), sum_f_R0 (fun _:nat => x) N = x * INR (S N).
Proof.
  intros.
  induction  N as [| N HrecN].
  simpl in |- *; ring.
  rewrite tech5.
  rewrite HrecN; repeat rewrite S_INR; ring.
Qed.

(**********)
Lemma sum_growing :
  forall (An Bn:nat -> R) (N:nat),
    (forall n:nat, An n <= Bn n) -> sum_f_R0 An N <= sum_f_R0 Bn N.
Proof.
  intros.
  induction  N as [| N HrecN].
  simpl in |- *; apply H.
  do 2 rewrite tech5.
  apply Rle_trans with (sum_f_R0 An N + Bn (S N)).
  apply Rplus_le_compat_l; apply H.
  do 2 rewrite <- (Rplus_comm (Bn (S N))).
  apply Rplus_le_compat_l; apply HrecN.
Qed.

(**********)
Lemma Rabs_triang_gen :
  forall (An:nat -> R) (N:nat),
    Rabs (sum_f_R0 An N) <= sum_f_R0 (fun i:nat => Rabs (An i)) N.
Proof.
  intros.
  induction  N as [| N HrecN].
  simpl in |- *.
  right; reflexivity.
  do 2 rewrite tech5.
  apply Rle_trans with (Rabs (sum_f_R0 An N) + Rabs (An (S N))).
  apply Rabs_triang.
  do 2 rewrite <- (Rplus_comm (Rabs (An (S N)))).
  apply Rplus_le_compat_l; apply HrecN.
Qed.

(**********)
Lemma cond_pos_sum :
  forall (An:nat -> R) (N:nat),
    (forall n:nat, 0 <= An n) -> 0 <= sum_f_R0 An N.
Proof.
  intros.
  induction  N as [| N HrecN].
  simpl in |- *; apply H.
  rewrite tech5.
  apply Rplus_le_le_0_compat.
  apply HrecN.
  apply H.
Qed.

(* Cauchy's criterion for series *)
Definition Cauchy_crit_series (An:nat -> R) : Prop :=
  Cauchy_crit (fun N:nat => sum_f_R0 An N).

(* If (|An|) satisfies the Cauchy's criterion for series, then (An) too *)
Lemma cauchy_abs :
  forall An:nat -> R,
    Cauchy_crit_series (fun i:nat => Rabs (An i)) -> Cauchy_crit_series An.
Proof.
  unfold Cauchy_crit_series in |- *; unfold Cauchy_crit in |- *.
  intros.
  elim (H eps H0); intros.
  exists x.
  intros.
  cut
    (R_dist (sum_f_R0 An n) (sum_f_R0 An m) <=
      R_dist (sum_f_R0 (fun i:nat => Rabs (An i)) n)
      (sum_f_R0 (fun i:nat => Rabs (An i)) m)).
  intro.
  apply Rle_lt_trans with
    (R_dist (sum_f_R0 (fun i:nat => Rabs (An i)) n)
      (sum_f_R0 (fun i:nat => Rabs (An i)) m)).
  assumption.
  apply H1; assumption.
  assert (H4 := lt_eq_lt_dec n m).
  elim H4; intro.
  elim a; intro.
  rewrite (tech2 An n m); [ idtac | assumption ].
  rewrite (tech2 (fun i:nat => Rabs (An i)) n m); [ idtac | assumption ].
  unfold R_dist in |- *.
  unfold Rminus in |- *.
  do 2 rewrite Ropp_plus_distr.
  do 2 rewrite <- Rplus_assoc.
  do 2 rewrite Rplus_opp_r.
  do 2 rewrite Rplus_0_l.
  do 2 rewrite Rabs_Ropp.
  rewrite
    (Rabs_right (sum_f_R0 (fun i:nat => Rabs (An (S n + i)%nat)) (m - S n)))
    .
  set (Bn := fun i:nat => An (S n + i)%nat).
  replace (fun i:nat => Rabs (An (S n + i)%nat)) with
  (fun i:nat => Rabs (Bn i)).
  apply Rabs_triang_gen.
  unfold Bn in |- *; reflexivity.
  apply Rle_ge.
  apply cond_pos_sum.
  intro; apply Rabs_pos.
  rewrite b.
  unfold R_dist in |- *.
  unfold Rminus in |- *; do 2 rewrite Rplus_opp_r.
  rewrite Rabs_R0; right; reflexivity.
  rewrite (tech2 An m n); [ idtac | assumption ].
  rewrite (tech2 (fun i:nat => Rabs (An i)) m n); [ idtac | assumption ].
  unfold R_dist in |- *.
  unfold Rminus in |- *.
  do 2 rewrite Rplus_assoc.
  rewrite (Rplus_comm (sum_f_R0 An m)).
  rewrite (Rplus_comm (sum_f_R0 (fun i:nat => Rabs (An i)) m)).
  do 2 rewrite Rplus_assoc.
  do 2 rewrite Rplus_opp_l.
  do 2 rewrite Rplus_0_r.
  rewrite
    (Rabs_right (sum_f_R0 (fun i:nat => Rabs (An (S m + i)%nat)) (n - S m)))
    .
  set (Bn := fun i:nat => An (S m + i)%nat).
  replace (fun i:nat => Rabs (An (S m + i)%nat)) with
  (fun i:nat => Rabs (Bn i)).
  apply Rabs_triang_gen.
  unfold Bn in |- *; reflexivity.
  apply Rle_ge.
  apply cond_pos_sum.
  intro; apply Rabs_pos.
Qed.

(**********)
Lemma cv_cauchy_1 :
  forall An:nat -> R,
    { l:R | Un_cv (fun N:nat => sum_f_R0 An N) l } ->
    Cauchy_crit_series An.
Proof.
  intros An X.
  elim X; intros.
  unfold Un_cv in p.
  unfold Cauchy_crit_series in |- *; unfold Cauchy_crit in |- *.
  intros.
  cut (0 < eps / 2).
  intro.
  elim (p (eps / 2) H0); intros.
  exists x0.
  intros.
  apply Rle_lt_trans with (R_dist (sum_f_R0 An n) x + R_dist (sum_f_R0 An m) x).
  unfold R_dist in |- *.
  replace (sum_f_R0 An n - sum_f_R0 An m) with
  (sum_f_R0 An n - x + - (sum_f_R0 An m - x)); [ idtac | ring ].
  rewrite <- (Rabs_Ropp (sum_f_R0 An m - x)).
  apply Rabs_triang.
  apply Rlt_le_trans with (eps / 2 + eps / 2).
  apply Rplus_lt_compat.
  apply H1; assumption.
  apply H1; assumption.
  right; symmetry  in |- *; apply double_var.
  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
    [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
Qed.

Lemma cv_cauchy_2 :
  forall An:nat -> R,
    Cauchy_crit_series An ->
    { l:R | Un_cv (fun N:nat => sum_f_R0 An N) l }.
Proof.
  intros.
  apply R_complete.
  unfold Cauchy_crit_series in H.
  exact H.
Qed.

(**********)
Lemma sum_eq_R0 :
  forall (An:nat -> R) (N:nat),
    (forall n:nat, (n <= N)%nat -> An n = 0) -> sum_f_R0 An N = 0.
Proof.
  intros; induction  N as [| N HrecN].
  simpl in |- *; apply H; apply le_n.
  rewrite tech5; rewrite HrecN;
    [ rewrite Rplus_0_l; apply H; apply le_n
      | intros; apply H; apply le_trans with N; [ assumption | apply le_n_Sn ] ].
Qed.

Definition SP (fn:nat -> R -> R) (N:nat) (x:R) : R :=
  sum_f_R0 (fun k:nat => fn k x) N.

(**********)
Lemma sum_incr :
  forall (An:nat -> R) (N:nat) (l:R),
    Un_cv (fun n:nat => sum_f_R0 An n) l ->
    (forall n:nat, 0 <= An n) -> sum_f_R0 An N <= l.
Proof.
  intros; case (total_order_T (sum_f_R0 An N) l); intro.
  elim s; intro.
  left; apply a.
  right; apply b.
  cut (Un_growing (fun n:nat => sum_f_R0 An n)).
  intro; set (l1 := sum_f_R0 An N) in r.
  unfold Un_cv in H; cut (0 < l1 - l).
  intro; elim (H _ H2); intros.
  set (N0 := max x N); cut (N0 >= x)%nat.
  intro; assert (H5 := H3 N0 H4).
  cut (l1 <= sum_f_R0 An N0).
  intro; unfold R_dist in H5; rewrite Rabs_right in H5.
  cut (sum_f_R0 An N0 < l1).
  intro; elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H7 H6)).
  apply Rplus_lt_reg_r with (- l).
  do 2 rewrite (Rplus_comm (- l)).
  apply H5.
  apply Rle_ge; apply Rplus_le_reg_l with l.
  rewrite Rplus_0_r; replace (l + (sum_f_R0 An N0 - l)) with (sum_f_R0 An N0);
    [ idtac | ring ]; apply Rle_trans with l1.
  left; apply r.
  apply H6.
  unfold l1 in |- *; apply Rge_le;
    apply (growing_prop (fun k:nat => sum_f_R0 An k)).
  apply H1.
  unfold ge, N0 in |- *; apply le_max_r.
  unfold ge, N0 in |- *; apply le_max_l.
  apply Rplus_lt_reg_r with l; rewrite Rplus_0_r;
    replace (l + (l1 - l)) with l1; [ apply r | ring ].
  unfold Un_growing in |- *; intro; simpl in |- *;
    pattern (sum_f_R0 An n) at 1 in |- *; rewrite <- Rplus_0_r;
      apply Rplus_le_compat_l; apply H0.
Qed.

(**********)
Lemma sum_cv_maj :
  forall (An:nat -> R) (fn:nat -> R -> R) (x l1 l2:R),
    Un_cv (fun n:nat => SP fn n x) l1 ->
    Un_cv (fun n:nat => sum_f_R0 An n) l2 ->
    (forall n:nat, Rabs (fn n x) <= An n) -> Rabs l1 <= l2.
Proof.
  intros; case (total_order_T (Rabs l1) l2); intro.
  elim s; intro.
  left; apply a.
  right; apply b.
  cut (forall n0:nat, Rabs (SP fn n0 x) <= sum_f_R0 An n0).
  intro; cut (0 < (Rabs l1 - l2) / 2).
  intro; unfold Un_cv in H, H0.
  elim (H _ H3); intros Na H4.
  elim (H0 _ H3); intros Nb H5.
  set (N := max Na Nb).
  unfold R_dist in H4, H5.
  cut (Rabs (sum_f_R0 An N - l2) < (Rabs l1 - l2) / 2).
  intro; cut (Rabs (Rabs l1 - Rabs (SP fn N x)) < (Rabs l1 - l2) / 2).
  intro; cut (sum_f_R0 An N < (Rabs l1 + l2) / 2).
  intro; cut ((Rabs l1 + l2) / 2 < Rabs (SP fn N x)).
  intro; cut (sum_f_R0 An N < Rabs (SP fn N x)).
  intro; assert (H11 := H2 N).
  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H11 H10)).
  apply Rlt_trans with ((Rabs l1 + l2) / 2); assumption.
  case (Rcase_abs (Rabs l1 - Rabs (SP fn N x))); intro.
  apply Rlt_trans with (Rabs l1).
  apply Rmult_lt_reg_l with 2.
  prove_sup0.
  unfold Rdiv in |- *; rewrite (Rmult_comm 2); rewrite Rmult_assoc;
    rewrite <- Rinv_l_sym.
  rewrite Rmult_1_r; rewrite double; apply Rplus_lt_compat_l; apply r.
  discrR.
  apply (Rminus_lt _ _ r0).
  rewrite (Rabs_right _ r0) in H7.
  apply Rplus_lt_reg_r with ((Rabs l1 - l2) / 2 - Rabs (SP fn N x)).
  replace ((Rabs l1 - l2) / 2 - Rabs (SP fn N x) + (Rabs l1 + l2) / 2) with
  (Rabs l1 - Rabs (SP fn N x)).
  unfold Rminus in |- *; rewrite Rplus_assoc; rewrite Rplus_opp_l;
    rewrite Rplus_0_r; apply H7.
  unfold Rdiv in |- *; rewrite Rmult_plus_distr_r;
    rewrite <- (Rmult_comm (/ 2)); rewrite Rmult_minus_distr_l;
      repeat rewrite (Rmult_comm (/ 2)); pattern (Rabs l1) at 1 in |- *;
        rewrite double_var; unfold Rdiv in |- *; ring.
  case (Rcase_abs (sum_f_R0 An N - l2)); intro.
  apply Rlt_trans with l2.
  apply (Rminus_lt _ _ r0).
  apply Rmult_lt_reg_l with 2.
  prove_sup0.
  rewrite (double l2); unfold Rdiv in |- *; rewrite (Rmult_comm 2);
    rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
  rewrite Rmult_1_r; rewrite (Rplus_comm (Rabs l1)); apply Rplus_lt_compat_l;
    apply r.
  discrR.
  rewrite (Rabs_right _ r0) in H6; apply Rplus_lt_reg_r with (- l2).
  replace (- l2 + (Rabs l1 + l2) / 2) with ((Rabs l1 - l2) / 2).
  rewrite Rplus_comm; apply H6.
  unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2));
    rewrite Rmult_minus_distr_l; rewrite Rmult_plus_distr_r;
      pattern l2 at 2 in |- *; rewrite double_var;
        repeat rewrite (Rmult_comm (/ 2)); rewrite Ropp_plus_distr;
          unfold Rdiv in |- *; ring.
  apply Rle_lt_trans with (Rabs (SP fn N x - l1)).
  rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr'; apply Rabs_triang_inv2.
  apply H4; unfold ge, N in |- *; apply le_max_l.
  apply H5; unfold ge, N in |- *; apply le_max_r.
  unfold Rdiv in |- *; apply Rmult_lt_0_compat.
  apply Rplus_lt_reg_r with l2.
  rewrite Rplus_0_r; replace (l2 + (Rabs l1 - l2)) with (Rabs l1);
    [ apply r | ring ].
  apply Rinv_0_lt_compat; prove_sup0.
  intros; induction  n0 as [| n0 Hrecn0].
  unfold SP in |- *; simpl in |- *; apply H1.
  unfold SP in |- *; simpl in |- *.
  apply Rle_trans with
    (Rabs (sum_f_R0 (fun k:nat => fn k x) n0) + Rabs (fn (S n0) x)).
  apply Rabs_triang.
  apply Rle_trans with (sum_f_R0 An n0 + Rabs (fn (S n0) x)).
  do 2 rewrite <- (Rplus_comm (Rabs (fn (S n0) x))).
  apply Rplus_le_compat_l; apply Hrecn0.
  apply Rplus_le_compat_l; apply H1.
Qed.


Require Import Category FunctionalExtensionality Equality ProofIrrelevance.

Class Functor (C D: Category) := {
    f_ob : [C] -> [D] ;
    f_hom {a b: [C]} (f: a ~> b) : f_ob a ~> f_ob b ;

    f_id_distr (a: [C]) : f_hom (id a) = id (f_ob a) ;
    f_commute {a b c: [C]} (f: a ~> b) (g: b ~> c) :
        f_hom (f >> g) = (f_hom f) >> (f_hom g) ;
}.

Notation "C → D" := (Functor C D) (at level 90, right associativity).
Notation "ob[ F ]" := (@f_ob _ _ F) (at level 9, format "ob[ F ]").
Notation "hom[ F ]" := (@f_hom _ _ F _ _) (at level 9, format "hom[ F ]").

Record FunctorData (C D: Category) := {
  fdata_ob : [C] -> [D] ;
  fdata_hom {a b: [C]} (f: a ~> b) : fdata_ob a ~> fdata_ob b ;
}.
Definition functor_data_of {C D: Category} (F: C → D) := Build_FunctorData C D (@f_ob _ _ F) (@f_hom _ _ F).

Lemma functor_simpl_eq {C D: Category} (F G: C → D) :
  (functor_data_of F = functor_data_of G) -> F = G.
set (f := functor_data_of F).
set (g := functor_data_of G).
intro e. destruct F, G.
unfold functor_data_of, f_ob, f_hom in *. simpl.

assert (e_ob : f_ob0 = f_ob1).
now dependent destruction e. destruct e_ob.

assert (e_hom : f_hom0 = f_hom1).
now dependent destruction e. destruct e_hom.

assert (e_dis: f_id_distr0 = f_id_distr1).
apply proof_irrelevance. destruct e_dis.

assert (e_comm: f_commute0 = f_commute1).
apply proof_irrelevance. destruct e_comm.

reflexivity.
Qed.

Instance id_functor (C: Category) : Functor C C.
apply (Build_Functor C C (fun x => x) (fun _ _ f => f)).
- reflexivity.
- reflexivity.
Defined.

Definition comp_functor {C D E: Category} (F: Functor C D) (G: Functor D E) : Functor C E.
apply (Build_Functor C E (fun c => f_ob (f_ob c)) (fun _ _ f => f_hom (f_hom f))).
(* Applying when possible instead of rewriting to define simpler lambda-terms *)
- intros. rewrite f_id_distr. apply f_id_distr.
- intros. rewrite f_commute. apply f_commute.
Defined.
Notation "f >>> g" := (comp_functor f g) (at level 40, left associativity).

Lemma functor_id_r {C D: Category} (F: Functor C D) : F >>> id_functor D = F.
unfold comp_functor, id_functor. destruct F. simpl. f_equal.
- apply functional_extensionality_dep. intro. now rewrite f_id_distr0.
- repeat (apply functional_extensionality_dep ; intro). now rewrite f_commute0.
Qed.

Lemma functor_id_l {C D: Category} (F: Functor C D) : id_functor C >>> F = F.
unfold comp_functor, id_functor. destruct F. simpl. f_equal.
Qed.

Lemma functor_comp_assoc {A B C D: Category} (F: Functor A B) (G: Functor B C) (H: Functor C D) :
    (F >>> G) >>> H = F >>> (G >>> H).
unfold comp_functor, id_functor. destruct F, G, H. simpl. f_equal.
- apply functional_extensionality_dep. intro x. unfold eq_ind_r, eq_ind, eq_sym.
  now rewrite f_id_distr0, f_id_distr1.
- repeat (apply functional_extensionality_dep ; intro). unfold eq_ind_r, eq_ind, eq_sym.
  now rewrite f_commute0, f_commute1.
Qed.

Definition is_faithful {C D: Category} (F: Functor C D) :=
  forall (c c' : [C]) (f g : c ~> c'), f_hom f = f_hom g -> f = g.

Definition is_full {C D: Category} (F: Functor C D) :=
  forall (c c' : [C]) (g : f_ob c ~> f_ob c'), exists f : c ~> c', f_hom f = g.

Definition is_fully_faithful {C D: Category} (F: Functor C D) :=
  is_full F /\ is_faithful F.

Lemma functor_preserves_iso {C D: Category} (F: Functor C D) :
  forall (c c' : [C]) (f : c ~> c'), is_iso f -> is_iso (f_hom f).
Proof.
intros. unfold is_iso in *. destruct H as [f']. exists (f_hom f'). destruct H. split.
  - now rewrite <- f_commute, H, f_id_distr.
  - now rewrite <- f_commute, H0, f_id_distr.
Qed.

Lemma fully_faithful_injective_on_object {C D: Category} (F: C → D) (fully_faith_F : is_fully_faithful F):
  forall c c' : [C], ob[F] c ≃ ob[F] c' -> c ≃ c'.
Proof.
intros. destruct H as [f]. destruct fully_faith_F.
destruct (H0 c c' f) as [g]. exists g. destruct H as [f']. destruct (H0 c' c f') as [g'].
exists g'. rewrite <- !H2, <- !H3, <- !f_commute, <- !f_id_distr in H. split; apply H1; easy.
Qed.

Lemma constant_functor_commute (C : Category) (c : [C]): id c = id c >> id c.
Proof.
  now rewrite cat_id_l.
Qed.

Definition constant_functor {I C : Category} (c : [C]) : I → C := {|
  f_ob := fun _ => c;
  f_hom := fun _ _ _ => id c;

  f_id_distr := fun _ => eq_refl;
  f_commute := fun _ _ _ _ _ => constant_functor_commute C c;
|}.

Notation "Δ[ c ]" := (@constant_functor _ _ c) (at level 9).

(* trivial but useful lemma *)
Lemma functor_comp_commute_ob {C D E : Category} (F : C → D) (G : D → E) (c : [C]):
  ob[F >>> G] c = ob[G] (ob[F] c).
Proof.
  reflexivity.
Qed.

Lemma functor_comp_commute_mph {C D E : Category} (F : C → D) (G : D → E) (a b : [C]) (f : a ~> b) :
  hom[F >>> G] f = hom[G] (hom[F] f).
Proof.
  reflexivity.
Qed.


Set Implicit Arguments.
Require Import AutoSep Arith.

(* usuful and safe hints *)
Hint Rewrite Npow2_nat : N.
Hint Resolve bound_N_nat : N.
Hint Rewrite natToWord_wordToNat : N.

(* ============================================================================
 * word to nat
 * ========================================================================= *)

Theorem wordToNat_inj : forall sz (x y:word sz),
                          wordToNat x = wordToNat y -> x = y.
  intros.
  apply (f_equal (natToWord sz)) in H.
  autorewrite with N in *.
  assumption.
Qed.

Theorem wordToNat_inj' : forall sz (x y:word sz), x <> y ->
                                                      wordToNat x <> wordToNat y.
  intros.
  contradict H.
  apply wordToNat_inj; assumption.
Qed.

(* ============================================================================
 * nat to word
 * ========================================================================= *)

Lemma natToWord_pow2' : forall(sz k:nat)(w:word sz),
                          natToWord sz (k * pow2 sz) ^+ w = w.
  induction k; intros; simpl.

  apply wplus_unit.

  rewrite natToWord_plus.
  rewrite <- wplus_assoc.
  rewrite natToWord_pow2.
  rewrite wplus_unit.
  apply IHk.
Qed.

Lemma natToWord_pow2_zero: forall sz n, $ (n * pow2 sz) = natToWord sz 0.
  intros.
  rewrite <- (wplus_unit $(n * pow2 sz)).
  rewrite wplus_comm.
  apply natToWord_pow2'.
Qed.

Lemma natToWord_pow2_factor : forall (sz:nat)(w:word sz), exists n, forall k,
                    (n < pow2 sz)%nat /\ w = natToWord sz (k * pow2 sz + n).
  intros.
  exists (wordToNat w).
  intro.
  split.
  apply (wordToNat_bound w).
  rewrite natToWord_plus.
  rewrite natToWord_pow2'.
  rewrite natToWord_wordToNat.
  reflexivity.
Qed.

Corollary word_eq_natToWord : forall (sz:nat)(w:word sz), exists n,
                                     (n < pow2 sz)%nat /\ w = natToWord sz n.
  intros.
  generalize natToWord_pow2_factor; intro.
  specialize (H sz w).
  destruct H.
  specialize (H 0).
  destruct H.
  simpl in H0.
  exists x; auto.
Qed.

Lemma natToWord_inj' : forall sz a b, goodSize a -> goodSize b
                                      -> natToWord sz a <> $ b
                                      -> a <> b.
  intros; intro; subst; congruence.
Qed.

(* ============================================================================
 * nat to W
 * ========================================================================= *)

Transparent goodSize.

Lemma goodSize_natToW_wlt_lt : forall n m:nat, goodSize n -> goodSize m ->
                                     natToW n < natToW m -> (n < m)%nat.
  unfold goodSize, natToW.
  generalize dependent 32; intros; nomega.
Qed.

Corollary W_eq_natToW : forall(w:W), exists n, goodSize n /\ w = natToW n.
  intros.
  generalize word_eq_natToWord; intro.
  specialize (H 32 w).
  destruct H.
  destruct H.
  exists x.
  unfold goodSize.
  split; auto.
Qed.

Opaque goodSize.

Lemma wneg_natToW_pow2_minus : forall n:nat, goodSize n ->
                                      ^~ (natToW n) = natToW (pow2 32 - n).
  unfold wneg; intros.
  rewrite NToWord_nat.
  autorewrite with N; reflexivity.
Qed.

Lemma natToW_plus_pow2 : forall n : nat, natToW (pow2 32 + n) = $ n.
  unfold natToW; intros.
  rewrite natToWord_plus.
  rewrite natToWord_pow2.
  words.
Qed.

(* ============================================================================
 * destruct_word
   Turn word arithmetic into nat arithmetic.
 * ========================================================================= *)

Ltac destruct_word sz w n :=
  let H := fresh "W" in
  let Hub := fresh "Wub" in
  let Heq := fresh "Weq" in
  assert (H:exists w', (w' < pow2 sz)%nat /\ w = natToWord sz w') by
      apply word_eq_natToWord;
  elim H; clear H; intros n H; elim H; intros Hub Heq; rewrite Heq in *; clear H Heq w.

Ltac destruct_W w n :=
  let H := fresh "W" in
  let Hub := fresh "Wub" in
  let Heq := fresh "Weq" in
  assert (H:exists w', goodSize w' /\ w = natToW w') by
      apply W_eq_natToW;
  elim H; clear H; intros n H; elim H; intros Hub Heq; rewrite Heq in *; clear H Heq w.

Ltac destruct_words := repeat
  match goal with
    | w : W |- context[?w] =>
      is_var w; let w' := fresh "w" in destruct_W w w'
    | w : word 32 |- context[?w] =>
      is_var w; let w' := fresh "w" in destruct_W w w'
    | w : word ?sz |- context[?w] =>
      is_var w; let w' := fresh "w" in destruct_word sz w w'
  end.

(* ============================================================================
 * goodsize tactic
 * ========================================================================= *)

Ltac goodsize :=
  match goal with
    | |- (_ < pow2 32)%nat => apply goodSize_danger
    | _ => idtac
  end;
  match goal with
    | [ H: goodSize _ |- goodSize _ ]
      => solve [apply (goodSize_weaken _ _ H); auto; omega]
    | |- goodSize _ => solve [auto]
    | _ => omega
  end.

(* ============================================================================
 * roundTrip-related lemmas and roundtrip tactic
 * ========================================================================= *)

Corollary wordToNat_natToWord_idempotent_W : forall n,
                                             goodSize n ->
                                             wordToNat (natToW n) = n.
  intros; apply wordToNat_natToWord_idempotent; auto.
Qed.
Hint Rewrite wordToNat_natToWord_idempotent_W using solve [goodsize] : N.

Corollary roundTrip : forall sz n : nat,
                        (n < pow2 sz)%nat -> wordToNat (natToWord sz n) = n.
  intros; apply wordToNat_natToWord_idempotent; nomega.
Qed.
Hint Rewrite roundTrip using solve [eauto] : N.

Lemma natToW_wordToNat : forall w:W, natToW (wordToNat w) = w.
  intros; rewrite <- natToWord_wordToNat; auto.
Qed.
Hint Rewrite natToW_wordToNat : N.

Lemma wordToNat_wplus' : forall sz (x y: word sz),
                           (wordToNat x + wordToNat y < pow2 sz)%nat
                           -> wordToNat (x ^+ y) = wordToNat x + wordToNat y.
  intros.
  destruct_words.
  rewrite <- natToWord_plus.
  rewrite roundTrip; auto.
  pre_nomega; auto.
  rewrite wordToNat_natToWord_idempotent in * by nomega.
  rewrite wordToNat_natToWord_idempotent in * by nomega.
  auto.
Qed.

Corollary wordToNat_wplus'' : forall sz (x y: nat), (x + y < pow2 sz)%nat
                           -> wordToNat ($ x ^+ natToWord sz y) = x + y.
  intros.
  rewrite wordToNat_wplus' by nomega.
  rewrite ! roundTrip; auto.
Qed.

Lemma wordToNat_wminus : forall sz (w u : word sz),
  u <= w
  -> wordToNat (w ^- u) = wordToNat w - wordToNat u.
  intros.
  eapply natToWord_inj; try eapply wordToNat_bound.
  2: generalize (wordToNat_bound w); omega.
  rewrite natToWord_wordToNat.
  unfold wminus.
  rewrite wneg_alt.
  unfold wnegN.
  pattern w at 1.
  rewrite <- (natToWord_wordToNat w).
  rewrite <- natToWord_plus.
  specialize (wordToNat_bound u); intro.
  destruct (le_lt_dec (wordToNat u) (wordToNat w)).
  replace (wordToNat w + (pow2 sz - wordToNat u))
    with (pow2 sz + (wordToNat w - wordToNat u)) by omega.
  rewrite natToWord_plus.
  rewrite natToWord_pow2.
  apply wplus_unit.
  elimtype False; apply H.
  nomega.
Qed.
Corollary wordToNat_wminus'' : forall sz (x y: nat), (x < pow2 sz)%nat
                           -> (y <= x)%nat
                           -> wordToNat ($ x ^- natToWord sz y) = x - y.
  intros.
  rewrite wordToNat_wminus by nomega.
  rewrite ! roundTrip; auto.
Qed.

Lemma mult_S : forall x y, (x <= x * S y)%nat.
  intros; rewrite mult_comm; simpl; apply le_plus_l.
Qed.
Local Hint Resolve mult_S.

Local Hint Resolve mult_comm.

Lemma wordToNat_wmult : forall (w u : W),
  goodSize (wordToNat w * wordToNat u)
  -> wordToNat (w ^* u) = wordToNat w * wordToNat u.
  intros.
  rewrite wmult_alt; unfold wmultN, wordBinN.
  apply wordToNat_natToWord_idempotent; auto.
Qed.

Corollary wordToNat_wmult_W : forall (x y: nat), goodSize (x * y)%nat
                           -> wordToNat (natToW x ^* natToW y) = x * y.
  intros.
  unfold natToW in *.
  destruct x, y; simpl; auto.
  assert (wordToNat (natToWord 32 0) = 0).
  rewrite roundTrip by goodsize; auto.
  rewrite wordToNat_wmult.
  unfold natToW in *; rewrite H0; omega.
  rewrite H0; simpl; goodsize.

  assert (goodSize (S x)) by goodsize.
  assert (goodSize (S y)).
  {
    apply (goodSize_weaken _ _ H).
    rewrite mult_comm; auto.
  }
  rewrite wordToNat_wmult.
  rewrite ! roundTrip by goodsize; simpl; omega.
  rewrite ! roundTrip by goodsize; auto.
Qed.

(* ============================================================================
 * natToWord and operators
 * ========================================================================= *)

Lemma natToWord_mult : forall sz x y, natToWord sz (x * y)
                                      = natToWord _ x ^* natToWord _ y.
  unfold "^*", wordBin; intros.
  pre_nomega.
  rewrite <- Nat2N.inj_mul.
  rewrite NToWord_nat.
  pre_nomega.

  destruct (wordToNat_natToWord' sz x).
  rewrite <- H at 1.
  remember (wordToNat $ (x)) as x'.

  rewrite mult_plus_distr_r.
  rewrite natToWord_plus.
  replace (x0 * pow2 sz * y)%nat with ((x0 * y) * pow2 sz)%nat.
  rewrite natToWord_pow2_zero.
  rewrite <- natToWord_plus.
  rewrite plus_0_r.

  destruct (wordToNat_natToWord' sz y).
  rewrite <- H0 at 1.
  remember (wordToNat $ (y)) as y'.
  rewrite mult_plus_distr_l.
  rewrite natToWord_plus.
  replace (x' * (x1 * pow2 sz))%nat with ((x' * x1) * pow2 sz)%nat by apply mult_assoc_reverse.
  rewrite natToWord_pow2_zero.
  rewrite <- natToWord_plus; auto.

  rewrite 2 mult_assoc_reverse.
  f_equal.
  apply mult_comm.
Qed.

(* ============================================================================
 * simplification tactic
 * ========================================================================= *)

Ltac roundtrip :=
  pre_nomega; unfold natToW in *;
  repeat match goal with
           | _ => rewrite wordToNat_natToWord_idempotent_W in * by goodsize
           | _ => rewrite wordToNat_wminus'' in * by goodsize
           | _ => rewrite wordToNat_wminus in * by nomega
           | _ => rewrite wordToNat_wplus'' in * by goodsize
           | _ => rewrite wordToNat_wplus' in * by goodsize
           | _ => rewrite wordToNat_wmult_W in * by goodsize
           | _ => rewrite wordToNat_wmult in * by goodsize

           | H: _ |- _ => rewrite <- natToW_minus in H by omega; unfold natToW in H
           | H: _ |- _ => rewrite <- natToWord_plus in H
           | H: _ |- _ => rewrite <- natToWord_mult in H
           | H: natToWord ?sz _ = natToWord ?sz _ |- _
             => apply natToWord_inj with sz _ _ in H; try goodsize
           | H: not (natToWord ?sz _ = natToWord ?sz _) |- _
             => apply natToWord_inj' with sz _ _ in H; try goodsize
         end.

(* ============================================================================
 * word equality lemmas
 * ========================================================================= *)

Definition eq_W_dec : forall x y : W, { x = y } + { x <> y }.
  intros.
  destruct (Word.weqb x y) eqn:Heq; [apply weqb_sound in Heq | ]; auto.
  right; intro.
  apply weqb_true_iff in H; congruence.
Qed.

Lemma weqb_false_iff : forall sz (x y : word sz), Word.weqb x y = false <-> x <> y.
  intros.
  split; intros.
  intro Eq; apply weqb_true_iff in Eq; congruence.
  case_eq (Word.weqb x y); intro; auto.
  apply weqb_sound in H0; congruence.
Qed.

Lemma weqb_refl : forall w, weqb w w = true.
  intros; apply weqb_true_iff; auto.
Qed.
Hint Rewrite weqb_refl : N.

Lemma weqb_refl' : forall x y, x = y -> weqb x y = true.
  intros; subst; autorewrite with N; auto.
Qed.
Hint Rewrite weqb_refl' using solve [auto; words] : N.

Lemma weqb_diff : forall w1 w2, w1 <> w2 -> weqb w1 w2 = false.
  intros; apply weqb_false_iff; auto.
Qed.
Hint Rewrite weqb_diff using solve [auto; discriminate] : N.

(* ============================================================================
 * word operators
 * ========================================================================= *)

Lemma wplus_unit_r : forall sz w, w ^+ natToWord sz 0 = w.
  intros; rewrite wplus_comm; rewrite wplus_unit; auto.
Qed.
Hint Rewrite wplus_unit wplus_unit_r : N.

Lemma wminus_unit : forall sz w, w ^- natToWord sz 0 = w.
  intros.
  unfold "^-", "^~".
  roundtrip.
  rewrite N.sub_0_r.
  rewrite NToWord_nat.
  roundtrip.
  rewrite natToWord_pow2.
  autorewrite with N; auto.
Qed.

Lemma wmult_zero : forall w, natToW 0 ^* w = natToW 0.
  auto.
Qed.

Lemma wmult_zero_r : forall w, w ^* natToW 0 = natToW 0.
  intros; roundtrip; rewrite wmult_comm; auto.
Qed.
Hint Rewrite wmult_zero wmult_zero_r : N.

(* ============================================================================
 * natToW and operators
 * ========================================================================= *)

Lemma natToW_S_wminus_1 : forall n, $ (S n) ^- $1 = natToW n.
  unfold natToW; intros.
  replace (S n) with (n + 1) by omega; rewrite natToWord_plus.
  words.
Qed.
Hint Rewrite natToW_S_wminus_1 : N.

(* ============================================================================
 * goodSize lemmas
 * ========================================================================= *)

Transparent goodSize.

Lemma goodSize_dec : forall x, { goodSize x } + { ~ goodSize x }.
  intros.
  destruct (le_lt_dec (pow2 32) x); [right | left].
  unfold goodSize; intro; contradict l.
  apply Lt.lt_not_le.
  apply Nlt_out in H.
  rewrite ! Nat2N.id in H.
  rewrite Npow2_nat in H; auto.

  unfold goodSize.
  apply Nlt_in.
  rewrite ! Nat2N.id.
  rewrite Npow2_nat.
  auto.
Qed.

Lemma not_goodSize_gt : forall x y, goodSize x -> ~ goodSize y -> (x < y)%nat.
  intros.
  unfold goodSize in *.
  apply N.nlt_ge in H0.
  assert (N.of_nat x < N.of_nat y)%N.
  eapply N.lt_le_trans; eassumption.
  apply Nlt_out in H1.
  rewrite ! Nat2N.id in *; auto.
Qed.

Opaque goodSize.

(* ============================================================================
 * word inequalities
 * ========================================================================= *)

Lemma wle_wneq_wlt : forall i j:W, i <= j -> i <> j -> i < j.
  intros; destruct_words.
  apply wordToNat_inj' in H0.
  autorewrite with N in *; nomega.
Qed.

Lemma wle_wle_antisym : forall n m:W, n <= m -> m <= n -> n = m.
  intros; destruct_words; f_equal; nomega.
Qed.

Lemma lt_natToW : forall n (w : W), w < natToW n -> (wordToNat w < n)%nat.
  intros.
  destruct (goodSize_dec n).
  roundtrip; auto.
  destruct_words.
  roundtrip.
  apply not_goodSize_gt; auto.
Qed.


Require Import Bvector.
Require Vector.
Require Import Ascii.
Require Import String.
Require Import List.
Import ListNotations.

Definition ascii_to_vec (a : Ascii.ascii) : Bvector 8 :=
  let (b1, b2, b3, b4, b5, b6, b7, b8) := a in
  Vector.of_list [b1; b2; b3; b4; b5; b6; b7; b8].

Lemma string_to_vec_helper :
  forall a s,
    8 + 8 * (String.length s) = 8 * String.length (String a s).
Proof using.
  intros.
  simpl.
  now repeat rewrite plus_n_Sm.
Qed.

Fixpoint string_to_vec (s : string) : Bvector (8 * String.length s).
Proof using.
  refine match s as s' return Bvector (8 * String.length s') with
         | EmptyString => Bnil
         | String a s' =>
           let bv := string_to_vec s' in
           _
         end.
  rewrite <- (string_to_vec_helper a s').
  exact (Vector.append (ascii_to_vec a) bv).
Defined.

Definition fixed_length_string_to_vec {n : nat} (asc : { s : string | String.length s = n }) : Bvector (8 * n).
  destruct asc as [str pf].
  rewrite <- pf.
  exact (string_to_vec str).
Defined.

Fixpoint bit_list_to_string (bits : list bool) : string :=
  match bits with
  | b1 :: b2 :: b3 :: b4 :: b5 :: b6 :: b7 :: b8 :: rest =>
    let a := Ascii.Ascii b1 b2 b3 b4 b5 b6 b7 b8 in
    String a (bit_list_to_string rest)
  | _ => String.EmptyString
  end.

Definition vec_to_string {n : nat} (b : Bvector n) : string :=
  bit_list_to_string (Vector.to_list b).


Require Import List.
Require Import Arith.

(* We are using the type we are defining as the argument of parameterized     *)
(* type family: this is an example of 'nested inductive type'                 *)

Inductive tree (a:Set) : Set :=
| Node : a -> list (tree a) -> tree a
.

Arguments Node {a} _ _.

(* This inductive type is too complicated for coq. The default recursive      *)
(* principle is not useful.                                                   *)
(*                                                                            *)
(* Check tree_rect.                                                           *)
(*                                                                            *)
(* So we need to write our own induction principle. We shall need             *)

Fixpoint All' (a:Set) (P:a -> Prop) (xs:list a) : Prop :=
    match xs with
    | nil       => True
    | x :: xs   => P x /\ All' a P xs
    end.

Arguments All' {a} _ _.

(* Let us define All in a slightly different way.                             *)

Definition All (a:Set) (P:a -> Prop) : list a -> Prop :=
    fix g (xs:list a) : Prop :=
        match xs with
        | nil       => True
        | x :: xs   => P x /\ g xs
        end.

Arguments All {a} _ _.

Lemma All_same : forall (a:Set) (P:a -> Prop) (xs:list a),
    All P xs <-> All' P xs.
Proof.
    intros a P. induction xs as [|x xs IH].
    - reflexivity.
    - destruct IH as [H1 H2]. split; simpl;
      intros [H3 H4]; split; try (assumption).
        + apply H1. assumption.
        + apply H2. assumption.
Qed.

(* This definition should be fine but is rejected by Coq                      *)
(* Whether we use All or All' in the below makes no difference                *)

(*
   "Recursive call to tree_nest_ind has principal argument equal to
   't' instead of 'ts0'"

Fixpoint tree_nested_ind (a:Set) (P:tree a -> Prop)
    (p:forall (x:a) (ts:list (tree a)), All P ts -> P (Node x ts))
    (t:tree a) {struct t}
    : P t :=
        match t with
        | Node x ts => p x ts (all a P p ts)
        end
with all (a:Set) (P:tree a -> Prop)
         (p:forall (x:a) (ts:list (tree a)), All P ts -> P (Node x ts))
         (ts:list (tree a)) {struct ts}
         : All P ts :=
             match ts with
             | nil          => I
             | cons t ts    => conj (tree_nested_ind a P p t) (all a P p ts)
             end
.
                                                                              *)

(* instead of mutually inductive definition, we shall used nested induction   *)
Fixpoint tree_nested_ind (a:Set) (P:tree a -> Prop)
    (p:forall (x:a) (ts:list (tree a)), All P ts -> P (Node x ts))
    (t:tree a) : P t :=
        match t with
        | Node x ts     => p x ts
            ((fix all (ts':list (tree a)) : All P ts' :=
                match ts' with
                | nil       => I
                | cons t ts => conj (tree_nested_ind a P p t) (all ts)
                end) ts)
        end.

(* This has nothing to do with 'tree a' but since 'tree a' contains a list... *)
Fixpoint map' (a b:Set) (f:a -> b) (xs:list a) : list b :=
    match xs with
    | nil       => nil
    | x :: xs =>  f x :: map' a b f xs
    end.

Arguments map' {a} {b} _ _.

(* Once again, let us try and provide a slightly different definition for map *)

Definition map (a b:Set) (f:a -> b) : list a -> list b :=
    fix g (xs:list a) : list b :=
        match xs with
        | nil       => nil
        | x :: xs   => f x :: g xs
        end.

Arguments map {a} {b} _ _.

Lemma map_same : forall (a b:Set) (f:a -> b) (xs:list a),
    map f xs = map' f xs.
Proof.
    intros a b f. induction xs as [|x xs IH].
    - reflexivity.
    - simpl. rewrite IH. reflexivity.
Qed.

(* We define All and All' without visible benefit. We shall now see that      *)
(* defining map instead of map' bring a significant benefit, namely the       *)
(* following definition of fmap succeeds for map but fails for map':          *)

Fixpoint fmap (a b:Set) (f:a -> b) (t:tree a) : tree b :=
    match t with
    | Node x ts  => Node (f x) (map (fmap a b f) ts)
    end.

Arguments fmap {a} {b} _ _.

(* This is a lot nicer than defining fmap with nested recursion as follows:   *)
Fixpoint fmap' (a b:Set) (f:a -> b) (t:tree a) : tree b :=
    match t with
    | Node x ts     => Node (f x)
        ((fix g (ts':list (tree a)) : list (tree b) :=
            match ts' with
            | nil       => nil
            | cons t ts => cons (fmap' a b f t) (g ts)
            end) ts)

    end.

Arguments fmap' {a} {b} _ _.

(* We want to check that fmap and fmap's are the same things and the only     *)
(* realistic tool for this is our induction principle. However, our induction *)
(* formula will be 'All (fun t => fmap f t = fmap' f t) ts', i.e. the two     *)
(* functions (fmap f) and (fmap' f) coincide on ts. We need to be able to     *)
(* conclude that: map (fmap f) ts = map (fmap' f) ts                          *)

Lemma All_map : forall (a b:Set) (f g:a -> b) (xs: list a),
    All (fun x => f x = g x) xs -> map f xs = map g xs.
Proof.
    intros a b f g xs. induction xs as [| x xs IH].
    - reflexivity.
    - intros [H1 H2]. simpl. rewrite H1. apply IH in H2. rewrite H2. reflexivity.
Qed.

Lemma fmap_same: forall (a b:Set) (f:a -> b) (t:tree a),
    fmap f t = fmap' f t.
Proof.
    intros a b f. apply tree_nested_ind. intros x ts IH. simpl.
    fold (map (fmap' f) ts). apply All_map in IH. rewrite IH. reflexivity.
Qed.

(* Another definition which succeeds with map but fails with map'             *)
Fixpoint fold' (a b:Set) (f:a -> list b -> b) (t:tree a) : b :=
    match t with
    | Node x ts     => f x (map (fold' a b f) ts)
    end.

Arguments fold' {a} {b} _ _.

(* However, in the spirit of All vs All' and map vs map' we should define     *)
Definition fold (a b:Set) (f:a -> list b -> b): tree a -> b :=
    fix g (t:tree a) : b :=
        match t with
        | Node x ts => f x (map g ts)
        end.

Arguments fold {a} {b} _ _.

Lemma fold_same : forall (a b:Set) (f:a -> list b -> b) (t:tree a),
    fold f t = fold' f t.
Proof.
    intros a b f. apply tree_nested_ind. intros x ts IH. simpl.
    apply All_map in IH. rewrite IH. reflexivity.
Qed.

(* We could have defined fold using nested recursion                          *)
Fixpoint fold'' (a b:Set) (f:a -> list b -> b) (t:tree a) : b :=
    match t with
    | Node x ts     => f x
        ((fix g (ts': list (tree a)) : list b :=
            match ts' with
            | nil       => nil
            | t :: ts => cons (fold'' a b f t) (g ts)
            end) ts)
    end.

Arguments fold'' {a} {b} _ _.

Lemma fold_same' : forall (a b:Set) (f:a -> list b -> b) (t:tree a),
    fold f t = fold'' f t.
Proof.
    intros a b f. apply tree_nested_ind. intros x ts IH. simpl.
    fold (map (fold'' f) ts). apply All_map in IH. rewrite IH.
    reflexivity.
Qed.

Definition fmap_callback (a b:Set) (f:a -> b) : a -> list (tree b) -> tree b :=
    fun (x:a) (ts : list (tree b)) => Node (f x) ts.

Arguments fmap_callback {a} {b} _ _ _.

Lemma fmap_is_a_fold : forall (a b:Set) (f:a -> b) (t:tree a),
    fmap f t = fold (fmap_callback f) t.
Proof.
    intros a b f. apply tree_nested_ind. intros x ts IH. simpl.
    unfold fmap_callback at 1. apply All_map in IH. rewrite <- IH.
    reflexivity.
Qed.

Fixpoint sum (ls:list nat) : nat :=
    match ls with
    | nil       => 0
    | n :: ns   => plus n (sum ns)
    end.

(* Another definition which succeeds with map but fails with map'             *)
Fixpoint tree_size' (a:Set) (t:tree a) : nat :=
    match t with
    | Node _ ts     => S (sum (map (tree_size' a) ts))
    end.

Arguments tree_size' {a} _.

(* Another definition which succeeds with map but fails with map'             *)
Definition tree_size (a:Set) : tree a -> nat :=
    fix g (t:tree a) : nat :=
        match t with
        | Node _ ts => S (sum (map g ts))
        end.

Arguments tree_size {a} _.

Lemma tree_size_same : forall (a:Set) (t:tree a),
    tree_size t = tree_size' t.
Proof.
    intros a. apply tree_nested_ind. intros x ts IH. simpl.
    apply All_map in IH. rewrite IH. reflexivity.
Qed.

(* Some notion is tree splicing. The point is that preserves sizes            *)
Fixpoint tree_splice' (a:Set) (t1 t2:tree a) : tree a :=
    match t2 with
    | Node x nil        => Node x (t1 :: nil)
    | Node x (t :: ts)  => Node x (tree_splice' a t1 t :: ts)
    end.

Arguments tree_splice' {a} _ _.

(* In the same spirit                                                         *)
Definition tree_splice (a:Set) (t1:tree a) : tree a -> tree a :=
    fix g (t:tree a) : tree a :=
        match t with
        | Node x nil        => Node x (t1 :: nil)
        | Node x (t :: ts)  => Node x (g t :: ts)
        end.

Arguments tree_splice {a} _ _.

Lemma tree_splice_same : forall (a:Set) (t1 t2:tree a),
    tree_splice t1 t2 = tree_splice' t1 t2.
Proof.
    intros a t1. apply tree_nested_ind. intros x ts. destruct ts as [|t ts].
    - reflexivity.
    - intros [H1 H2]. simpl. rewrite H1. reflexivity.
Qed.

Theorem tree_size_splice: forall (a:Set) (t1 t2:tree a),
    tree_size (tree_splice t1 t2) = plus (tree_size t1) (tree_size t2).
Proof.
    intros a t1. apply tree_nested_ind. intros x ts. destruct ts.
    - intros. simpl. apply plus_n_Sm.
    - intros [H1 H2]. simpl. rewrite H1. rewrite <- plus_n_Sm.
      rewrite plus_assoc. reflexivity.
Qed.