Require Import Wellfounded Wf_nat Lexicographic_Product Relation_Operators.
Require Import base generic_set_theory.
Require Import NArith NArith.Nnat.

Section LIM_CARD.

  Variable A:Type.
  Context `{AOrd : OrderedType A}.

  Inductive lim_card (z:nat) : set A -> set A -> Prop :=
  | in_re_set : forall x y:set A,
    z - (cardinal x) < z - (cardinal y) -> lim_card z x y.

  Definition lim_cardN (z:N) : relation (set A) :=
  fun x y:set A => nat_of_N z - (cardinal x) < nat_of_N z - (cardinal y).

  Theorem le_trans1 : forall n m p, n <= m -> m <= p -> n <= p.
  Proof.
    induction 2; auto.
  Defined.

  Theorem le_S_n1 : forall n m, S n <= S m -> n <= m.
  Proof.
    intros n m H; change (pred (S n) <= pred (S m)) in |- *.
    destruct H; simpl.
    constructor.
    apply (le_trans1 _ (S n) _).
    constructor.
    constructor.
    exact H.
  Defined.

  Lemma lim_card_wf : forall z,  well_founded (lim_card z).
  Proof.
    unfold well_founded.
    intros.
    cut(forall n a, lt (z - (cardinal a)) n -> Acc (lim_card z) a).
    intros.
    eapply H with (S (z - (cardinal a))).
    unfold lt.
    constructor.

    induction n;intros.
    inversion H.
    constructor;intros.
    inversion_clear H0.
    apply IHn.
    unfold lt in H, H1.
    unfold lt.
    apply (@le_trans1 _ _ _ H1).
    apply le_S_n1 in H.
    exact H.
  Defined.

  Lemma lim_card_lim_cardN_inclusion :
    forall z, inclusion (set A) (lim_cardN z) (lim_card (nat_of_N z)).
  Proof.
    repeat red.
    intros.
    unfold lim_cardN in H.
    constructor.
    assumption.
  Qed.

  Lemma lim_cardN_wf : forall z, well_founded (lim_cardN z).
  Proof.
    intro z.
    red.
    eapply wf_incl.
    eapply lim_card_lim_cardN_inclusion.
    apply lim_card_wf.
  Qed.

  (* Definition dec_H (x y:set A) := *)
  (*   cardinal x < cardinal y. *)

  (* Lemma dec_H_wf : well_founded dec_H. *)
  (* Proof. *)
  (*   red. *)
  (*   intros. *)
  (*   apply Acc_inverse_image. *)
  (*   apply Wf_nat.lt_wf. *)
  (* Defined. *)

  Open Scope N_scope.

  Fixpoint pow2N(n:nat):N :=
    match n with
      | O => 1
      | S m => 2 * pow2N m
    end.

  Lemma pow2N_S : forall n,
    pow2N (S n) = 2*pow2N n.
  Proof.
    induction n.
    reflexivity.
    destruct n;auto with arith.
  Qed.

  Close  Scope N_scope.

  Lemma pow2N_S_nat : forall n,
    nat_of_N (pow2N (S n)) = 2*nat_of_N (pow2N n).
  Proof.
    induction n.
    reflexivity.
    rewrite pow2N_S.
    rewrite nat_of_Nmult.
    rewrite IHn.
    reflexivity.
  Qed.

  Fixpoint pow2(n:nat):nat :=
    match n with
      | O => 1
      | S m => 2 * pow2 m
    end.

  Lemma pow2_pow2N_equiv : forall n,
    nat_of_N (pow2N n) = pow2 n.
  Proof.
    induction n.
    simpl.
    reflexivity.
    rewrite pow2N_S_nat.
    rewrite IHn.
    simpl.
    omega.
  Qed.

  Lemma pow2_S : forall n,
    pow2 (S n) = 2*pow2 n.
  Proof.
    induction n;simpl;omega.
  Qed.

  Lemma pow2_le : forall n m,
    n <= m -> pow2 n <= pow2 m.
  Proof.
    induction 1;simpl;try omega.
  Qed.

  Lemma add_plus_nat :
    forall x y,
      (S x)* y = y + x*y.
  Proof.
    induction x;simpl;intros.
    reflexivity.
    omega.
  Qed.

  (*Transparent cart_prod.*)

  Lemma cart_prod_add_right :
    forall x x1 s,
    cart_prod {x} {x1; s} === cart_prod {x} {x1} ++ cart_prod {x} s.
  Proof.
    split;intros.
    apply cart_prod_spec in H.
    destruct H.
    apply add_iff in H0.
    destruct H0.
    apply union_2.
    apply cart_prod_spec.
    split;auto with typeclass_instances.
    rewrite H0.
    apply singleton_2;auto.
    apply union_3.
    apply cart_prod_spec.
    split;auto.
    apply union_1 in H.
    destruct H;apply cart_prod_spec in H;apply cart_prod_spec;destruct H;split;auto.
    apply add_1.
    apply singleton_1 in H0.
    assumption.
    apply add_2;auto.
  Qed.

  Corollary map_singleton :
    forall x0 x,
      cart_prod {x0} {x} === singleton (pair x0 x).
  Proof.
    split;intros.
    apply cart_prod_spec in H;destruct H as [H1 H2];
    apply singleton_1 in H1;apply singleton_1 in H2.
    apply singleton_2.
    destruct a;simpl in *.
    constructor;auto.
    apply singleton_1 in H;destruct a;simpl in *.
    apply cart_prod_spec;simpl;split;apply singleton_2;
    inversion H;normalize_notations;auto.
  Qed.

  Lemma cardinal_cart_prod_singleton :
    forall s2 x,
      cardinal (cart_prod {x} s2) = cardinal s2.
  Proof.
    induction s2 using set_induction;intros.
    cut(cart_prod {x} s2 === {}).
    abstract(intros;rewrite (@Equal_cardinal _ _ _ _ _ _ H0);symmetry;rewrite cardinal_fold;
             rewrite fold_1b;eauto).
    abstract(
        split;intros;[apply cart_prod_spec in H0;destruct H0;apply H in H1;elim H1|inversion H0]).

    cut(cart_prod {x0} s2_2 === cart_prod {x0} {x;s2_1}).
    intro;
    rewrite (@Equal_cardinal _ _ _ _ _ _ H1);
    pose proof cart_prod_add_right x0 x s2_1;
    rewrite (@Equal_cardinal _ _ _ _ _ _ H2);
    rewrite map_singleton;
    apply Add_Equal in H0;
    rewrite H0;
    apply Add_Equal in H0;
    rewrite union_cardinal_inter.
    assert(inter {(x0, x)} (cart_prod {x0} s2_1) === {}) by
    abstract(split;intros;try (now (inversion H3));
    apply inter_iff in H3;destruct H3;apply cart_prod_spec in H4;
    destruct H4;
    apply singleton_1 in H3;
    apply singleton_1 in H4;
    destruct a ;simpl in *;inversion H3;subst;rewrite <- H11 in H5;
    contradiction).
    rewrite H3, singleton_cardinal,empty_cardinal.
    simpl.
    rewrite add_cardinal_2;eauto.
    apply Add_Equal in H0;apply cart_prod_m;eauto.
  Qed.

  Lemma cart_prod_add :
    forall x s1 s2,
      cart_prod {x;s1} s2 === cart_prod {x} s2 ++ cart_prod s1 s2.
  Proof.
    split;intros.
    apply cart_prod_spec in H.
    destruct H.
    apply add_iff in H.
    destruct H.
    apply union_2.
    apply cart_prod_spec.
    split;auto.
    apply singleton_2.
    assumption.
    apply union_3.
    apply cart_prod_spec.
    split;auto.
    apply union_iff in H;destruct H.
    apply cart_prod_spec in H.
    apply cart_prod_spec.
    destruct H.
    split;auto.
    apply add_1.
    apply singleton_1 in H.
    assumption.
    apply cart_prod_spec in H.
    apply cart_prod_spec.
    destruct H.
    split;eauto.
    apply add_2;eauto.
  Qed.

  Lemma cart_prod_empty :
    forall s1 s2, s1 === {} -> cart_prod s1 s2 === {}.
  Proof.
    split;intros.
    apply cart_prod_spec in H0.
    destruct H0.
    apply H in H0.
    abstract(inversion H0).
    abstract(inversion H0).
  Qed.

  Lemma cart_prod_card : forall s1 s2,
    cardinal (cart_prod s1 s2) = cardinal s1 * cardinal s2.
  Proof.
    induction s1 using set_induction.
    intros.
    symmetry.
    rewrite cardinal_fold.
    rewrite fold_1b;auto.
    simpl.
    apply empty_is_empty_1 in H.
    pose proof cart_prod_empty s1 s2 H.
    symmetry.
    apply empty_is_empty_2 in H0.
    rewrite cardinal_fold.
    rewrite fold_1b;auto.
    intros.
    specialize IHs1_1 with s2.
    cut(cart_prod s1_2 s2 === cart_prod {x;s1_1} s2).
    intro.
    pose proof @Equal_cardinal _ _ _ _ _ _ H1.
    rewrite H2.
    rewrite cart_prod_add.
    pose proof H0.
    apply Add_Equal in H3.
    rewrite H3.
    pose proof @add_cardinal_2 _ _ _ _ s1_1 x H.
    rewrite H4.
    rewrite add_plus_nat.
    rewrite <- IHs1_1.
    assert((inter (cart_prod {x} s2) (cart_prod s1_1 s2)) === {}).
    split;intros.
    apply inter_iff in H5.
    destruct H5.
    apply cart_prod_spec in H5.
    destruct H5.
    apply singleton_1 in H5.
    apply cart_prod_spec in H6.
    destruct H6.
    rewrite <- H5 in H6.
    contradiction.
    inversion H5.
    rewrite union_cardinal_inter.
    rewrite H5.
    rewrite empty_cardinal.
    rewrite IHs1_1.
    rewrite cardinal_cart_prod_singleton.
    rewrite <- minus_n_O;reflexivity.
    apply Add_Equal in H0.
    apply cart_prod_m;auto.
  Qed.

  Lemma powerset_empty :
    (powerset {}) === singleton (empty).
  Proof.
    split;intros.
    apply powerset_spec in H.
    apply singleton_2.
    split;intros.
    inv H0.
    apply H;auto.
    apply singleton_1 in H.
    apply powerset_spec.
    red;intros.
    apply H in H0.
    assumption.
  Qed.

  Lemma powerset_Empty :
    forall s,
      s === {} -> powerset s === singleton empty.
  Proof.
    intros.
    split;intros.
    apply powerset_spec in H0.
    rewrite H in H0.
    apply singleton_2.
    split;intros.
    inversion H1.
    apply H0 in H1.
    assumption.

    apply singleton_1 in H0.
    apply powerset_spec.
    red;intros.
    apply H.
    rewrite <- H0 in H1.
    assumption.
  Qed.

  Transparent powerset.

  Instance add_vals_m :
    forall x, Proper (_eq ==> Equal ==> Equal) (fun y : set A => add {x; y}).
  Proof.
    repeat red.
    split;intros.
    apply add_iff in H1;destruct H1.
    rewrite <- H1.
    rewrite H.
    apply add_1;auto.
    rewrite H0 in H1.
    apply add_2;auto.
    apply add_iff in H1;destruct H1.
    rewrite <- H1.
    rewrite H.
    apply add_1;auto.
    rewrite H0.
    apply add_2;auto.
  Qed.

  Lemma add_vals_transp :
    forall x, transpose Equal (fun y : set A => add {x; y}).
  Proof.
    repeat red.
    split;intros.
    apply add_iff in H;destruct H.
    rewrite <- H.
    apply add_2;apply add_1;auto.
    apply add_iff in H;destruct H.
    apply add_1;auto.
    do 2 apply add_2;auto.
    apply add_iff in H;destruct H.
    rewrite <- H.
    apply add_2;apply add_1;auto.
    apply add_iff in H;destruct H.
    rewrite <- H.
    apply add_1;auto.
    do 2 apply add_2;auto.
  Qed.

  Property subset_empty :
  forall s,
    s[<=]{} -> s === {}.
  Proof.
    induction s using set_induction;intros.
    split;intros.
    apply H0;auto.
    inversion H1.
    split;intros.
    apply H0 in H2.
    destruct H2.
    apply H1.
    apply H0.
    left;auto.
    assert(a \In s2).
    apply H0.
    right;auto.
    apply H1 in H3.
    assumption.
    inversion H2.
  Qed.

  Lemma empty_in_powerset :
    forall s,
      {} \In powerset s.
  Proof.
    intros.
    apply powerset_spec.
    red;intros.
    inv H.
  Qed.

  Lemma add_not_empty :
    forall x s,
      {} =/= {x;s}.
  Proof.
    intros;intro.
    destruct(H x).
    assert(x \In {x;s}).
    apply add_1;auto.
    apply H1 in H2.
    inversion H2.
  Qed.

  Instance powerset_add_m : forall x,
    Proper (_eq ==> _eq) (fun y : set A => {x; y}).
  Proof.
    repeat red;split;intros;apply add_iff in H0;destruct H0.
    rewrite <- H0;apply add_1;auto.
    apply H in H0;apply add_2;auto.
    rewrite H0;apply add_1;auto.
    rewrite H;apply add_2;auto.
  Qed.

  Instance add_one_m : Proper (_eq ==> _eq ==> _eq) add_one.
  Proof.
    repeat red.
    intros.
    split;intros.
    apply add_one_spec in H1.
    apply add_one_spec.
    rewrite H0 in H1.
    destruct H1;auto.
    right.
    destruct H1.
    exists x1.
    rewrite H0 in H1.
    rewrite H in H1.
    assumption.
    apply add_one_spec in H1.
    apply add_one_spec.
    rewrite H0.
    destruct H1;auto.
    right.
    destruct H1.
    exists x1.
    rewrite H;auto.
    rewrite H0.
    assumption.
  Qed.

  Lemma transpose_add_one : transpose equiv add_one.
  Proof.
    red;intros.
    split;intros.
    apply add_one_spec in H.
    destruct H.
    apply add_one_spec in H.
    destruct H.
    apply add_one_spec.
    left;apply add_one_spec;auto.
    destruct H as [a' [H1 H2]].
    apply add_one_spec.
    right.
    exists a';split;auto.
    apply add_one_spec;auto.
    destruct H as [a' [H1 H2]].
    eapply add_one_spec in H1.
    destruct H1.
    apply add_one_spec.
    left.
    apply add_one_spec.
    right;exists a';auto.
    destruct H as [a'' [H3 H4]].
    assert(a[=]{y;{x;a''}}).
    split;intros.
    apply H2 in H.
    rewrite H4 in H.
    apply add_iff in H.
    destruct H.
    rewrite H.
    apply add_2;apply add_1;auto.
    apply add_iff in H.
    destruct H.
    rewrite H;apply add_1;auto.
    apply add_2;apply add_2;auto.
    apply add_iff in H;destruct H.
    rewrite H2,H4.
    rewrite <- H.
    apply add_2;apply add_1;auto.
    apply add_iff in H;destruct H.
    rewrite H2.
    rewrite <- H.
    apply add_1;auto.
    rewrite H2,H4.
    apply add_2;apply add_2;auto.
    apply add_one_spec.
    right.
    exists {x;a''}.
    split;auto.
    apply add_one_spec.
    right.
    exists a'';split;auto.
    reflexivity.
    apply add_one_spec in H.
    destruct H.
    apply add_one_spec in H.
    destruct H.
    apply add_one_spec.
    left;apply add_one_spec;auto.
    destruct H as [a' [H1 H2]].
    apply add_one_spec.
    right.
    exists a';split;auto.
    apply add_one_spec;auto.
    destruct H as [a' [H1 H2]].
    eapply add_one_spec in H1.
    destruct H1.
    apply add_one_spec.
    left.
    apply add_one_spec.
    right;exists a';auto.
    destruct H as [a'' [H3 H4]].
    assert(a[=]{x;{y;a''}}).
    split;intros.
    apply H2 in H.
    rewrite H4 in H.
    apply add_iff in H.
    destruct H.
    rewrite H.
    apply add_2;apply add_1;auto.
    apply add_iff in H.
    destruct H.
    rewrite H;apply add_1;auto.
    apply add_2;apply add_2;auto.
    apply add_iff in H;destruct H.
    rewrite H2,H4.
    rewrite <- H.
    apply add_2;apply add_1;auto.
    apply add_iff in H;destruct H.
    rewrite H2.
    rewrite <- H.
    apply add_1;auto.
    rewrite H2,H4.
    apply add_2;apply add_2;auto.
    apply add_one_spec.
    right.
    exists {y;a''}.
    split;auto.
    apply add_one_spec.
    right.
    exists a'';split;auto.
    reflexivity.
  Qed.

  Lemma powerset_step :
    forall s2 s1 x,
      ~x \In s1 ->
      Add x s1 s2 ->
      powerset s2 === powerset s1 ++ map (fun y => add x y) (powerset s1).
  Proof.
    intros.
    unfold powerset.
    rewrite (@fold_2 A AOrd _ _ s1 s2 x);auto with typeclass_instances.
    split;intros.
    apply add_one_spec in H1.
    destruct H1.
    apply union_2;auto.
    apply union_3.
    apply map_spec;auto with typeclass_instances.
    apply union_iff in H1;destruct H1.
    apply add_one_spec.
    left;auto.
    apply add_one_spec.
    apply map_iff in H1;auto with typeclass_instances.
    unfold equiv;auto with typeclass_instances.
    apply transpose_add_one.
  Qed.

  Lemma map_add : forall s s' x,
                    s' \In (map (fun y : set A => {x; y}) s) <->
                      x \In s' /\ (s' \In s \/ (remove x s') \In  s).
  Proof.
    intros.
    split;intros.
    apply map_iff in H;auto with typeclass_instances.
    destruct H.
    destruct H.
    split.
    rewrite H0.
    apply add_1;auto.
    destruct(In_dec x x0).
    rewrite add_equal in H0;auto.
    left.
    rewrite H0.
    assumption.
    right.
    rewrite H0.
    pose proof @remove_add _ _ _ _ x0 x n.
    rewrite H1.
    assumption.

    destruct H.
    destruct H0.
    apply map_iff;auto with typeclass_instances.
    exists s'.
    split.
    assumption.
    rewrite add_equal;auto.
    apply map_iff;auto with typeclass_instances.
    exists (remove x s').
    split;auto.
    split;intros.
    destruct(eq_dec x a).
    rewrite <- H2.
    apply add_1;auto.
    apply add_2.
    apply remove_iff.
    split;auto.
    apply add_iff in H1.
    destruct H1.
    rewrite <- H1;auto.
    apply remove_iff in H1.
    destruct H1;auto.
  Qed.

  Transparent map.

  Lemma powerset_cardinal : forall s,
    cardinal (powerset s) = pow2 (cardinal s).
  Proof.
    induction s using set_induction;intros.

    symmetry ; rewrite cardinal_fold.
    rewrite fold_1b;auto.
    simpl.
    pose proof powerset_empty.
    apply Equal_cardinal in H0.
    assert(powerset s === powerset {}).
    apply empty_is_empty_1 in H.
    split;intros.
    apply powerset_spec.
    apply powerset_spec in H1.
    red;intros.
    apply H1 in H2.
    apply H in H2.
    assumption.
    apply powerset_spec in H1.
    apply powerset_spec.
    rewrite <- H in H1.
    assumption.
    apply Equal_cardinal in H1.
    rewrite H1.
    rewrite H0.
    vm_compute.
    reflexivity.

    pose proof powerset_step _ _ _ H H0.
    rewrite H1.
    rewrite union_cardinal.
    rewrite map_cardinal;auto with typeclass_instances.
    rewrite IHs1.
    rewrite (cardinal_2 H H0).
    simpl;auto with arith.
    intros u v.
    rewrite 2 powerset_spec.
    red;red;intros.
    simpl.
    red.
    intro.
    red.
    generalize (H4 a) (H2 a) (H3 a).
    set_iff.
    clear H2 H3 H4.
    intuition;auto with sets.
    rewrite <- H7 in H9;apply H in H9;elim H9.
    rewrite <- H7 in H9;apply H in H9;elim H9.
    rewrite <- H8 in H9;apply H in H9;elim H9.
    rewrite <- H8 in H9;apply H in H9;elim H9.
    intros u (X,Y).
    apply powerset_spec in X.
    rewrite map_add in Y.
    destruct Y as (Y,_).
    apply X in Y.
    contradiction.
  Qed.

  (* Definition of the well_founded relation *)
  (*Definition lex (MAX:nat) := (lexprod (set A) (fun _:set A => set A)
    (lim_card MAX) (fun _:set A => dec_H)).

  Lemma lex_wf : forall M:nat, well_founded (lex M).
  Proof.
    intro.
    apply wf_lexprod.
    apply lim_card_wf.
    intro.
    apply dec_H_wf.
  Defined.*)

End LIM_CARD.


(*Daniel Rivas*)
Variables A : Set.
Variables P Q : A -> A -> Prop.
(*first validation*)
Lemma proof1: (forall y x:A, P x y) -> (forall z x y:A, Q z x ->
Q z y) -> (forall x:A, P x x).
Proof.
intros.
apply H.
Qed.
(*second validation*)
Lemma proof2: (forall z x y:A, Q z x -> Q z y) ->
(forall y x:A, P x y) ->  (forall x:A, P x x).
Proof.
intros.
apply H0.
Qed.


Require Export TopologicalSpaces.
From ZornsLemma Require Export CountableTypes.
Require Export NeighborhoodBases.
From ZornsLemma Require Import EnsemblesSpec.

Global Set Asymmetric Patterns.

Definition first_countable (X:TopologicalSpace) : Prop :=
  forall x:point_set X, exists NBx:Family (point_set X),
    neighborhood_basis NBx x /\ Countable NBx.

Lemma first_countable_open_neighborhood_bases:
  forall X:TopologicalSpace, first_countable X ->
    forall x:point_set X, exists NBx:Family (point_set X),
      open_neighborhood_basis NBx x /\ Countable NBx.
Proof.
intros.
destruct (H x) as [NBx [? ?]].
exists (@Im (Ensemble (point_set X)) (Ensemble (point_set X)) NBx (@interior X)).
split.
constructor.
intros.
destruct H2 as [U].
split.
rewrite H3; apply interior_open.
rewrite H3; apply neighborhood_interior.
apply H0; trivial.
intros.
destruct H0.
destruct (neighborhood_basis_cond U) as [N].
apply open_neighborhood_is_neighborhood; trivial.
destruct H0.
exists (interior N).
split.
exists N; trivial.
pose proof (interior_deflationary N).
auto with sets.

apply countable_img; trivial.
Qed.

Require Export Nets.

Lemma first_countable_sequence_closure:
  forall (X:TopologicalSpace) (S:Ensemble (point_set X)) (x:point_set X),
  first_countable X -> In (closure S) x ->
  exists y:Net nat_DS X, (forall n:nat, In S (y n)) /\
                         net_limit y x.
Proof.
intros.
destruct (first_countable_open_neighborhood_bases _ H x) as [NB []].
destruct H2 as [g].
pose (U (n:nat) := IndexedIntersection
  (fun x: {x:{x:Ensemble (point_set X) | In NB x} | (g x < n)%nat} =>
     proj1_sig (proj1_sig x))).
assert (forall n:nat, open (U n)).
intros.
apply open_finite_indexed_intersection.
apply inj_finite with _ (fun x:{x:{x:Ensemble (point_set X) | In NB x}
                           | (g x < n)%nat} =>
  exist (fun m:nat => (m<n)%nat) (g (proj1_sig x)) (proj2_sig x)).
From ZornsLemma Require Import InfiniteTypes.
apply finite_nat_initial_segment.
red.
intros [[x0 P] p] [[y0 Q] q] ?.
simpl in H3.
From ZornsLemma Require Import Proj1SigInjective.
apply subset_eq_compatT.
apply subset_eq_compatT.
injection H3; intros.
apply H2 in H4.
injection H4; trivial.
intros; apply classic.
intros.
destruct a as [[x0]].
simpl.
Opaque In. apply H1; trivial. Transparent In.

Require Import ClassicalChoice.
destruct (choice (fun (n:nat) (x:point_set X) => In (U n) x /\
                                                 In S x)) as [y].
intros n.
destruct (closure_impl_meets_every_open_neighborhood _ _ _ H0 (U n))
  as [y]; trivial.
constructor; trivial.
destruct a as [[x0]].
simpl.
apply H1; trivial.
exists y; destruct H4; split; trivial.
exists y.
split.
apply H4.

red; intros V ? ?.
destruct H1.
destruct (open_neighborhood_basis_cond V) as [W []].
split; trivial.
pose (a := (exist _ W H1 : {x:Ensemble (point_set X)|In NB x})).
exists (Datatypes.S (g a)).
intros.
simpl in j.
simpl in H8.
apply H7.
assert (Included (U j) W).
red; intros.
destruct H9.
exact (H9 (exist _ a H8)).
apply H9.
apply H4.
Qed.

Inductive separable (X:TopologicalSpace) : Prop :=
  | intro_dense_ctbl: forall S:Ensemble (point_set X),
    Countable S -> dense S -> separable X.

Definition Lindelof (X:TopologicalSpace) : Prop :=
  forall cover:Family (point_set X),
    (forall U:Ensemble (point_set X),
       In cover U -> open U) ->
    FamilyUnion cover = Full_set ->
  exists subcover:Family (point_set X), Included subcover cover /\
     Countable subcover /\ FamilyUnion subcover = Full_set.

Inductive second_countable (X:TopologicalSpace) : Prop :=
  | intro_ctbl_basis: forall B:Family (point_set X),
    open_basis B -> Countable B -> second_countable X.

Lemma second_countable_impl_first_countable:
  forall X:TopologicalSpace, second_countable X -> first_countable X.
Proof.
intros.
destruct H.
red; intros.
exists [ U:Ensemble (point_set X) | In B U /\ In U x ]; split.
apply open_neighborhood_basis_is_neighborhood_basis.
apply open_basis_to_open_neighborhood_basis; trivial.
apply countable_downward_closed with B; trivial.
red; intros.
destruct H1 as [[? ?]]; trivial.
Qed.

Lemma second_countable_impl_separable:
  forall X:TopologicalSpace, second_countable X -> separable X.
Proof.
intros.
destruct H.
Require Import ClassicalChoice.
destruct (choice (fun (U:{U:Ensemble (point_set X) | In B U /\ Inhabited U})
  (x:point_set X) => In (proj1_sig U) x)) as [choice_fun].
intros.
destruct x as [U [? ?]].
simpl.
destruct i0.
exists x; trivial.

exists (Im Full_set choice_fun).
apply countable_img.
red.
match goal with |- CountableT ?S =>
  pose (g := fun (x:S) =>
    match x return {U:Ensemble (point_set X) | In B U} with
    | exist (exist U (conj i _)) _ => exist _ U i
    end)
end.
apply inj_countable with g.
assumption.
red; intros.
unfold g in H2.
destruct x1 as [[U [? ?]]].
destruct x2 as [[V [? ?]]].
From ZornsLemma Require Import Proj1SigInjective.
apply subset_eq_compatT.
apply subset_eq_compatT.
injection H2; trivial.

apply meets_every_nonempty_open_impl_dense.
intros.
destruct H3.
destruct H.
destruct (open_basis_cover x U) as [V [? [? ?]]]; trivial.
assert (In B V /\ Inhabited V).
split; trivial.
exists x; trivial.
exists (choice_fun (exist _ V H6)).

constructor.
(* apply H4. *)
pose proof (H1 (exist _ V H6)).
simpl in H7.
(* assumption. *)
exists (exist (fun U0:Ensemble (point_set X) => In B U0 /\ Inhabited U0) V H6).
constructor.
reflexivity.
apply H4.
pose proof (H1 (exist _ V H6)).
simpl in H7.
assumption.
Qed.

Lemma second_countable_impl_Lindelof:
  forall X:TopologicalSpace, second_countable X -> Lindelof X.
Proof.
intros.
destruct H.
red; intros.

pose (basis_elts_contained_in_cover_elt :=
  [ U:Ensemble (point_set X) | In B U /\ Inhabited U /\
    exists V:Ensemble (point_set X), In cover V /\ Included U V ]).
destruct (choice (fun (U:{U | In basis_elts_contained_in_cover_elt U})
  (V:Ensemble (point_set X)) => In cover V /\ Included (proj1_sig U) V))
  as [choice_fun].
intros.
destruct x.
simpl.
destruct i as [[? [? ?]]].
exact H5.
exists (Im Full_set choice_fun).
repeat split.
red; intros.
destruct H4.
destruct (H3 x).
rewrite H5; assumption.
apply countable_img.
apply countable_type_ensemble.
apply countable_downward_closed with B; trivial.
red; intros.
destruct H4 as [[]].
assumption.

apply Extensionality_Ensembles; red; split; red; intros.
constructor.
clear H4.
assert (In (FamilyUnion cover) x).
rewrite H2; constructor.
destruct H4.

destruct H.
destruct (open_basis_cover x S) as [V]; trivial.
apply H1; trivial.

destruct H as [? [? ?]].

assert (In basis_elts_contained_in_cover_elt V).
constructor.
repeat split; trivial.
exists x; trivial.
exists S; split; trivial.

exists (choice_fun (exist _ V H8)).
exists (exist _ V H8).
constructor.
reflexivity.

pose proof (H3 (exist _ V H8)).
destruct H9.
simpl in H10.
apply H10; trivial.
Qed.


Require Omega.

Module Part1.
    (* Coq's standard library's ordering on peano nats defines <= as given by the rules (forall n, n <= n) and (forall n m, n <= m -> n <= S m) (i.e. reflexivity and right-successor).
        (x < y) is an alias for (S x <= y), and (y < x) is an alias for (x < y). *)

    (* nat_compare is a decideable trichotomy for peano naturals (i.e. given two nats, it computes which ordering holds between them) *)
    Definition or_inj1 {P Q R : Prop} : P -> {P} + {Q} + {R} := ltac:(tauto).
    Definition or_inj2 {P Q R : Prop} : Q -> {P} + {Q} + {R} := ltac:(tauto).
    Definition or_inj3 {P Q R : Prop} : R -> {P} + {Q} + {R} := ltac:(tauto).
    Fixpoint nat_compare (n m : nat) : {n < m} + {n = m} + {n > m} :=
        match n with
        | 0 => match m with
            | 0 => or_inj2 eq_refl
            | S m' => or_inj1 (le_n_S _ _ (le_0_n m'))
            end
        | S n' => match m with
            | 0 => or_inj3 (le_n_S _ _ (le_0_n n'))
            | S m' => match nat_compare n' m' with
                | inleft (left less) => inleft (left (le_n_S _ _ less))
                | inleft (right equal) => inleft (right (f_equal S equal))
                | inright greater => inright (le_n_S _ _ greater)
                end
            end
        end.

    (* trichotomy is an Ltac script that flattens the structure of the result of nat-compare, to be used in proofs/definitions by cases *)
    Ltac trichotomy x y := destruct (nat_compare x y) as [s | ?g]; [destruct s as [?l | ?e]|].

    Definition max' : nat -> nat -> nat.
        intros n m. trichotomy n m.
        - (* n < m *) exact m.
        - (* n = m *) exact n.
        - (* n > m *) exact n.
        Defined.

    (* Idempotence is easy to prove; running the comparison on x and x yields a goal of showing x = x, which is discharged by reflexivity in all 3 cases. *)
    Theorem max'_idempotent : forall x, max' x x = x.
        intro x; unfold max'; trichotomy x x; reflexivity.
        Qed.

    (* Some helper lemmas on inequalities *)
    Lemma lt_irreflexive : forall x, ~(x < x).
        intros x e. unfold lt in e. induction x; inversion e.
        - rewrite H0 in e. exact (IHx e).
        - subst. exact (IHx (le_pred _ _ (le_S _ _ H0))).
        Qed.

    Lemma not_le_plus_l : forall n k, ~((S k) + n <= n).
        induction k; intro e.
        - exact (lt_irreflexive _ e).
        - exact (IHk (le_pred _ _ (le_S _ _ e))).
        Qed.

    Lemma le_trans : forall x y z, x <= y -> y <= z -> x <= z.
        induction x, y, z; try easy; intros Hxy Hyz.
        - apply le_0_n.
        - exact (le_n_S _ _ (IHx y z (le_pred _ _ Hxy) (le_pred _ _ Hyz))).
        Qed.

    (* fully-automatic versions of the above lemmas, with the omega tactic (a Presburger arithmetic solver) *)
    Module Omega_demo.
        Import Omega.
        Lemma lt_irreflexive' : forall x, ~(x < x). intros; omega. Qed.
        Lemma not_le_plus_l' : forall n k, ~((S k) + n <= n). intros; omega. Qed.
        Lemma le_trans' : forall x y z, x <= y -> y <= z -> x <= z. intros; omega. Qed.
    End Omega_demo.

    (* reduction lemmas for max, max'_0_l and max'_S are the ones that ended up being used, the ones with disjunctions in their RHS ended up being too cumbersome to use *)
    Lemma max'_0_l : forall x, max' 0 x = x.
        destruct x.
        - reflexivity.
        - unfold max'. trichotomy 0 (S x).
          + reflexivity.
          + exact e.
          + inversion g.
        Qed.

    Lemma max'_S_l : forall x y, max' (S x) y = S (max' x y) \/ max' (S x) y = y.
        intros x y. unfold max'. trichotomy (S x) y.
        - right. reflexivity.
        - right. exact e.
        - left. trichotomy x y; try easy. destruct (lt_irreflexive _ (le_trans _ _ _ g l)).
        Qed.
    Lemma max'_S_l' : forall x y, max' (S x) y = S x \/ max' (S x) y = y.
        intros x y. unfold max'. trichotomy (S x) y.
        - right. reflexivity.
        - right. exact e.
        - left. reflexivity.
        Qed.

    Ltac double_inversion H := inversion H as [| ? ?H' ]; inversion H'.
    Ltac recursive_inversion H := inversion H as [| ? ?H' ]; try recursive_inversion H'.

    Lemma max'_S : forall x y, max' (S x) (S y) = S (max' x y).
        induction x; intro y.
        - rewrite max'_0_l. unfold max'.
            trichotomy 1 (S y); try easy. recursive_inversion g.
        - unfold max'. trichotomy (S x) y; trichotomy (S (S x)) (S y); try easy.
            + set (H := le_trans _ _ _ g l). destruct (not_le_plus_l y 1 H).
            + subst. reflexivity.
            + set (H := le_trans _ _ _ l g). destruct (not_le_plus_l (S x) 1 H).
        Qed.

    (* max_compat_max' shows that max' defined via trichotomy has the same behavior as a version defined directly via recursion on peano naturals; the latter is more transparent to Coq's reduction machinery.
        This makes use of the reduction lemmas defined above. *)

    Lemma max_compat_max' : forall n m, max' n m = Nat.max n m.
        induction n; intro m.
        - apply max'_0_l.
        - induction m.
            + trichotomy (S n) 0; easy.
            + simpl. rewrite <- (IHn m). rewrite max'_S. reflexivity.
        Qed.

    (* once max_compat_max' has been proven, max'_associative is proven by routine induction on peano naturals (with some care taken to ensure that the generated inductive hypothesis is general enough *)
    Theorem max'_associative : forall x y z, max' x (max' y z) = max' (max' x y) z.
        intros x y z.
        repeat rewrite max_compat_max'.
        revert z; revert y; induction x; destruct y, z; try reflexivity.
        simpl. rewrite (IHx y z).
        reflexivity.
        Qed.

End Part1.

Load ListBackedSet.
(* ListBackedSet contains functions that deal with lists-as-sets via decideable equality, that I developed for the lattice project. *)
Import ListBackedSet.
(* ListBackedSet' contains functions that deal with lists-as-sets via the Elem inductive predicate and unification, developed for this project.
    The various _compat lemmas proven in it show that the original versions are correct relative to the (new, shorter) specifications. *)
Import ListBackedSet'.

Module Part2.
    Definition relation (S T : Type) := list (S * T).

    (* The domain and range of a relation are both implemented via map, which I defined in ListBackedSet. *)
    Definition domain {S T} (rel : relation S T) := map fst rel.
    Definition range {S T} (rel : relation S T) := map snd rel.

    (* There were a lot of false starts/proof attempts for range_theorem_2, which eventually lead to discovering the following lemmas (proved in ListBackedSet.v):
        Lemma map_elem {A B} (f : A -> B) : forall x xs, Elem x xs -> Elem (f x) (map f xs).
        Lemma co_map_elem_inhabited {A B} (f : A -> B) : forall y xs, Elem y (map f xs) -> exists x, Elem x xs /\ f x = y.

        These ended up making the finished proofs relatively short.
    *)
    Lemma range_theorem_2_lemma_1 {S T} : forall (r1 r2 : relation S T) xs ys (x : S * T), Intersection r1 r2 xs -> Intersection (range r1) (range r2) ys -> Elem x xs -> Elem (snd x) ys.
        intros r1 r2 xs ys x Int_xs Int_ys x_in_xs.
        unfold Intersection in *.
        destruct (proj1 (Int_xs x) x_in_xs) as [xr1 xr2].
        apply (map_elem snd) in xr1; apply (map_elem snd) in xr2.
        fold (range r1) in xr1; fold (range r2) in xr2.
        exact (proj2 (Int_ys (snd x)) (conj xr1 xr2)).
        Qed.

    Theorem range_theorem_2 {S T} : forall (r1 r2 : relation S T) xs ys, Intersection r1 r2 xs -> Intersection (range r1) (range r2) ys -> Subset (range xs) ys.
        intros r1 r2 xs ys Int_xs Int_ys y y_in_rxs.
        destruct (co_map_elem_inhabited snd _ _ y_in_rxs) as [st [ist est]].
        set (H := range_theorem_2_lemma_1 r1 r2 _ _ st Int_xs Int_ys ist).
        rewrite est in H. exact H.
        Qed.

    (* I proved domain_theorem_3' next, and then realized that its proof could be generalized to handle the range case as well *)
    Theorem domain_theorem_3' {S T} : forall (r1 r2 : relation S T) xs ys, Difference (domain r1) (domain r2) xs -> Difference r1 r2 ys -> Subset xs (domain ys).
        unfold Difference.
        intros r1 r2 xs ys diff_xs diff_ys x x_in_xs.
        destruct (proj1 (diff_xs x) x_in_xs) as [e1 e2].
        destruct (co_map_elem_inhabited _ _ _ e1) as [a [Ha1 Ha2]].
        assert (Hb : ~(Elem a r2)). { intros H. apply e2. rewrite <- Ha2. apply (map_elem _ _ _ H). }
        rewrite <- Ha2.
        exact (map_elem fst _ _ (proj2 (diff_ys a) (conj Ha1 Hb))).
        Qed.

    (* the generalized map_theorem_3 differs from domain_theorem_3' only in that it replaces fst with an arbitrary f *)
    Lemma map_theorem_3 {S T U} : forall (f : S * T -> U) (r1 r2 : relation S T) xs ys, Difference (map f r1) (map f r2) xs -> Difference r1 r2 ys -> Subset xs (map f ys).
        unfold Difference.
        intros f r1 r2 xs ys diff_xs diff_ys x x_in_xs.
        destruct (proj1 (diff_xs x) x_in_xs) as [e1 e2].
        destruct (co_map_elem_inhabited _ _ _ e1) as [a [Ha1 Ha2]].
        assert (Hb : ~(Elem a r2)). { intros H. apply e2. rewrite <- Ha2. apply (map_elem _ _ _ H). }
        rewrite <- Ha2.
        exact (map_elem f _ _ (proj2 (diff_ys a) (conj Ha1 Hb))).
        Qed.

    (* domain_theorem_3 and range_theorem_3 are both trivial corollaries of map_theorem_3 *)
    Theorem domain_theorem_3 {S T} : forall (r1 r2 : relation S T) xs ys, Difference (domain r1) (domain r2) xs -> Difference r1 r2 ys -> Subset xs (domain ys).
        exact (map_theorem_3 fst). Qed.
    Theorem range_theorem_3 {S T} : forall (r1 r2 : relation S T) xs ys, Difference (range r1) (range r2) xs -> Difference r1 r2 ys -> Subset xs (range ys).
        exact (map_theorem_3 snd). Qed.

End Part2.


Require Import Coq.Arith.Arith.
Require Export Coq.Vectors.Vector.
Require Import Coq.Program.Equality. (* for dependent induction *)
Require Import Coq.Setoids.Setoid.
Require Import Coq.Logic.ProofIrrelevance.

(* CoLoR: `opam install coq-color`  *)
Require Export CoLoR.Util.Vector.VecUtil.

Open Scope vector_scope.

(* Re-define :: List notation for vectors. Probably not such a good idea *)
Notation "h :: t" := (cons h t) (at level 60, right associativity)
                     : vector_scope.

Import VectorNotations.

Section VPermutation.

  Variable A:Type.

  Inductive VPermutation: forall n, vector A n -> vector A n -> Prop :=
  | vperm_nil: VPermutation 0 [] []
  | vperm_skip {n} x l l' : VPermutation n l l' -> VPermutation (S n) (x::l) (x::l')
  | vperm_swap {n} x y l : VPermutation (S (S n)) (y::x::l) (x::y::l)
  | vperm_trans {n} l l' l'' :
      VPermutation n l l' -> VPermutation n l' l'' -> VPermutation n l l''.

  Local Hint Constructors VPermutation : vperm_hints.

  (** Some facts about [VPermutation] *)

  Theorem VPermutation_nil : forall (l : vector A 0), VPermutation 0 [] l -> l = [].
  Proof.
    intros l HF.
    dependent destruction l.
    reflexivity.
  Qed.

  (** VPermutation over vectors is a equivalence relation *)

  Theorem VPermutation_refl : forall {n} (l: vector A n), VPermutation n l l.
  Proof.
    induction l; constructor. exact IHl.
  Qed.

  Theorem VPermutation_sym : forall {n} (l l' : vector A n),
      VPermutation n l l' -> VPermutation n l' l.
  Proof.
    intros n l l' Hperm.
    induction Hperm; auto with vperm_hints.
    apply vperm_trans with (l'0:=l'); auto.
  Qed.

  Theorem VPermutation_trans : forall {n} (l l' l'' : vector A n),
      VPermutation n l l' -> VPermutation n l' l'' -> VPermutation n l l''.
  Proof.
    intros n l l' l''.
    apply vperm_trans.
  Qed.

End VPermutation.

Hint Resolve VPermutation_refl vperm_nil vperm_skip : vperm_hints.

(* These hints do not reduce the size of the problem to solve and they
   must be used with care to avoid combinatoric explosions *)

Local Hint Resolve vperm_swap vperm_trans : vperm_hints.
Local Hint Resolve VPermutation_sym VPermutation_trans : vperm_hints.

(* This provides reflexivity, symmetry and transitivity and rewriting
   on morphims to come *)

Instance VPermutation_Equivalence A n : Equivalence (@VPermutation A n) | 10 :=
  {
    Equivalence_Reflexive := @VPermutation_refl A n ;
    Equivalence_Symmetric := @VPermutation_sym A n ;
    Equivalence_Transitive := @VPermutation_trans A n
  }.

Require Import Coq.Sorting.Permutation.
Require Import Helix.Util.VecUtil.

Section VPermutation_properties.

  Variable A:Type.

  Lemma ListVecPermutation {n} {l1 l2} {v1 v2}:
    l1 = list_of_vec v1 ->
    l2 = list_of_vec v2 ->
    Permutation l1 l2 <->
    VPermutation A n v1 v2.
  Proof.
    intros H1 H2.
    split.
    -
      intros P; revert n v1 v2 H1 H2.
      dependent induction P; intros n v1 v2 H1 H2.
      + dependent destruction v1; inversion H1; subst.
        dependent destruction v2; inversion H2; subst.
        apply vperm_nil.
      + dependent destruction v1; inversion H1; subst.
        dependent destruction v2; inversion H2; subst.
        apply vperm_skip.
        now apply IHP.
      + do 2 (dependent destruction v1; inversion H1; subst).
        do 2 (dependent destruction v2; inversion H2; subst).
        apply list_of_vec_eq in H5; subst.
        apply vperm_swap.
      + assert (n = length l').
        { pose proof (Permutation_length P1) as len.
          subst.
          now rewrite list_of_vec_length in len.
        }
        subst.
        apply vperm_trans with (l' := vec_of_list l').
        * apply IHP1; auto.
          now rewrite list_of_vec_vec_of_list.
        * apply IHP2; auto.
          now rewrite list_of_vec_vec_of_list.
    -
      subst l1 l2.
      intros P.
      dependent induction P.
      +
        subst; auto.
      +
        simpl.
        apply perm_skip.
        apply IHP.
      +
        simpl.
        apply perm_swap.
      +
        apply perm_trans with (l':=list_of_vec l'); auto.
  Qed.

End VPermutation_properties.

Lemma Vsig_of_forall_cons
      {A : Type}
      {n : nat}
      (P : A->Prop)
      (x : A)
      (l : vector A n)
      (P1h : P x)
      (P1x : @Vforall A P n l):
  (@Vsig_of_forall A P (S n) (@cons A x n l) (@conj (P x) (@Vforall A P n l) P1h P1x)) =
  (Vcons (@exist A P x P1h) (Vsig_of_forall P1x)).
Proof.
  simpl.
  f_equal.
  apply subset_eq_compat.
  reflexivity.
  f_equal.
  apply proof_irrelevance.
Qed.

Lemma VPermutation_Vsig_of_forall
      {n: nat}
      {A: Type}
      (P: A->Prop)
      (v1 v2 : vector A n)
      (P1 : Vforall P v1)
      (P2 : Vforall P v2):
  VPermutation A n v1 v2
  -> VPermutation {x : A | P x} n (Vsig_of_forall P1) (Vsig_of_forall P2).
Proof.
  intros V.
  revert P1 P2.
  dependent induction V; intros P1 P2.
  -
    apply vperm_nil.
  -
    destruct P1 as [P1h P1x].
    destruct P2 as [P2h P2x].
    rewrite 2!Vsig_of_forall_cons.
    replace P1h with P2h by apply proof_irrelevance.
    apply vperm_skip.
    apply IHV.
  -
    destruct P1 as [P1y [P1x P1l]].
    destruct P2 as [P1x' [P1y' P1l']].

    repeat rewrite Vsig_of_forall_cons.

    replace P1y' with P1y by apply proof_irrelevance.
    replace P1x' with P1x by apply proof_irrelevance.
    replace P1l' with P1l by apply proof_irrelevance.
    apply vperm_swap.
  -
    assert(Vforall P l').
    {
      apply Vforall_intro.
      intros x H.
      apply list_of_vec_in in H.
      eapply ListVecPermutation in V1; auto.
      apply Permutation_in with (l':=(list_of_vec l)) in H.
      +
        apply Vforall_lforall in P1.
        apply ListUtil.lforall_in with (l:=(list_of_vec l)); auto.
      +
        symmetry.
        auto.
    }
    (* Looks like a coq bug here. It should find H automatically *)
    unshelve eauto with vperm_hints.
    apply H.
Qed.


Require Import Func.

Definition lem (p:Prop) : Prop := p \/ ~p.

Definition ifRel (a b:Type) (p:Prop) (f g:a ==> b) (x:a) (y:b) : Prop :=
    (p /\ rel f x y) \/ (~p /\ rel g x y).

Arguments ifRel {a} {b} _ _ _ _ _.

Lemma ifRelFunctional : forall (a b:Type) (p:Prop) (f g:a ==> b),
    Functional (ifRel p f g).
Proof.
    unfold Functional. intros a b p [fr fTot fFunc] [gr gTot gFunc] x y y'.
    unfold ifRel. simpl. intros [[Hp H1]|[Hp H1]] [[Hq H2]|[Hq H2]].
    - unfold Functional in fFunc. apply (fFunc x).
        + exact H1.
        + exact H2.
    - exfalso. apply Hq. exact Hp.
    - exfalso. apply Hp. exact Hq.
    - unfold Functional in gFunc. apply (gFunc x).
        + exact H1.
        + exact H2.
Qed.

Arguments ifRelFunctional {a} {b} _ _ _ _ _ _ _ _.

Lemma ifRelTotal : forall (a b:Type) (p:Prop) (f g:a ==> b),
    lem p -> Total (ifRel p f g).
Proof.
    unfold Total, ifRel. intros a b p [fr fTot fFunc] [gr gTot gFunc] [H|H] x.
    - simpl. unfold Total in fTot. destruct (fTot x) as [y Hy].
        exists y. left. split.
            + exact H.
            + exact Hy.
    - simpl. unfold Total in fTot. destruct (gTot x) as [y Hy].
        exists y. right. split.
            + exact H.
            + exact Hy.
Qed.

Arguments ifRelTotal {a} {b} _ _ _ _ _.

(* not that useful but good to know. Only applies if type a is not empty*)
Lemma ifRelTotal_converse : forall (a b:Type) (p:Prop) (f g:a ==> b),
    (exists (x:a), True) -> Total (ifRel p f g) -> lem p.
Proof.
    unfold Total, ifRel, lem. intros a b p f g [x _] H.
    destruct (H x) as [y [[Hp H']|[Hp H']]].
    - left.  exact Hp.
    - right. exact Hp.
Qed.

Definition ifFunc (a b:Type) (p:Prop) (q: lem p) (f g:a ==> b) : a ==> b :=
    func (ifRel p f g) (ifRelTotal p f g q) (ifRelFunctional p f g).

Arguments ifFunc {a} {b} _ _ _ _.

Lemma ifFunc_correct_true : forall (a b:Type) (p:Prop) (q:lem p) (f g:a ==> b),
    forall (x:a) (y:b), p -> (rel (ifFunc p q f g) x y <-> rel f x y).
Proof.
    intros a b p q f g x y H. unfold ifFunc. simpl. unfold ifRel.
    remember (rel f) as r. split.
    - intros [[Hp H']|[Hp H']].
        + exact H'.
        + exfalso. apply Hp. exact H.
    - intros H'. left. split.
        + exact H.
        + exact H'.
Qed.

Lemma ifFunc_correct_false : forall (a b:Type) (p:Prop) (q:lem p) (f g:a ==> b),
    forall (x:a) (y:b), ~p -> (rel (ifFunc p q f g) x y <-> rel g x y).
Proof.
    intros a b p q f g x y H. unfold ifFunc. simpl. unfold ifRel.
    remember (rel g) as r. split.
    - intros [[Hp H']|[Hp H']].
        + exfalso.  apply H. exact Hp.
        + exact H'.
    - intros H'. right. split.
        +  exact H.
        +  exact H'.
Qed.


From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat.
From mathcomp Require Import eqtype choice order.
Require Import Equations.Prop.Loader.

(******************************************************************************)
(* This file contains the definitions of:                                     *)
(*             wfType d == the structure for types with                       *)
(*                         well-founded partial order.                        *)
(*  well_founded_bool r <-> r is a decidable well-founded relation.           *)
(*                  wfb <-> wfType's order relation is well-founded.          *)
(*              wfb_ind <-> well-founded induction principle for wfType.      *)
(* This file also contains canonical instance of wfType for nat.              *)
(******************************************************************************)

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Section WfBool.

Context {T : Type} (r : rel T).

Inductive acc_bool (x : T) :=
  acc_bool_intro of (forall y : T, r y x -> acc_bool y).

Definition well_founded_bool := forall x, acc_bool x.

End WfBool.

Open Scope order_scope.

Module WellFounded.

Section ClassDef.

Record mixin_of T0 (b : Order.POrder.class_of T0)
  (T := Order.POrder.Pack tt b) := Mixin {
  _ : well_founded_bool (<%O : rel T);
}.

Set Primitive Projections.

Record class_of (T : Type) := Class {
  base   : Order.POrder.class_of T;
  mixin  : mixin_of base;
}.

Unset Primitive Projections.

Local Coercion base : class_of >-> Order.POrder.class_of.

Structure type (disp : unit) := Pack { sort; _ : class_of sort }.

Local Coercion sort : type >-> Sortclass.

Variables (T : Type) (disp : unit) (cT : type disp).

Definition class := let: Pack _ c as cT' := cT return class_of cT' in c.
Definition clone c of phant_id class c := @Pack disp T c.

Definition pack :=
  fun bT b & phant_id (@Order.POrder.class disp bT) b =>
  fun m => Pack disp (@Class T b m).

Definition eqType := @Equality.Pack cT class.
Definition choiceType := @Choice.Pack cT class.
Definition porderType := @Order.POrder.Pack disp cT class.
End ClassDef.

Module Exports.

Notation wfType := type.
Coercion base : class_of >-> Order.POrder.class_of.
Coercion mixin : class_of >-> mixin_of.
Coercion sort : type >-> Sortclass.
Coercion eqType : type >-> Equality.type.
Coercion choiceType : type >-> Choice.type.
Coercion porderType : type >-> Order.POrder.type.
Canonical eqType.
Canonical choiceType.
Canonical porderType.
Notation WfType disp T m := (@pack T disp _ _ id m).

End Exports.

End WellFounded.

Export WellFounded.Exports.

Section WfInduction.

Context {disp : unit} {T : wfType disp}.

Lemma wfb : well_founded_bool (<%O : rel T).
Proof. by case: T=> ? [] ? []. Qed.

Lemma wfb_ind (P : T -> Type) :
  (forall n, (forall m, m < n -> P m) -> P n) ->
  forall n, P n.
Proof. by move=> accP M; elim: (wfb M) => ?? /accP. Qed.

End WfInduction.

Global Instance wf_wfType {disp : unit} {T : wfType disp} :
  Equations.Prop.Classes.WellFounded (<%O : rel T).
Proof. by apply: wfb_ind; constructor. Qed.

(* Canonical well-founded order for nat *)

Import Order.NatOrder.

Lemma nat_well_founded_bool:  well_founded_bool (<%O : rel nat).
Proof. by elim/ltn_ind=> n IHn; constructor=> m /IHn. Qed.

Definition nat_wfMixin := @WellFounded.Mixin nat _ nat_well_founded_bool.
Canonical nat_wfType := Eval hnf in WfType nat_display nat nat_wfMixin.


Set Implicit Arguments.
Unset Strict Implicit.

Arguments fst : default implicits.
Arguments snd : default implicits.

Module Type PO.
  Parameter T : Set.
  Parameter le : T -> T -> Prop.

  Axiom le_refl : forall x : T, le x x.
  Axiom le_trans : forall x y z : T, le x y -> le y z -> le x z.
  Axiom le_antis : forall x y : T, le x y -> le y x -> x = y.

  Hint Resolve le_refl le_trans le_antis.
End PO.

Module Pair (X: PO) (Y: PO) <: PO.
  Definition T := (X.T * Y.T)%type.
  Definition le p1 p2 := X.le (fst p1) (fst p2) /\ Y.le (snd p1) (snd p2).

  Hint Unfold le.

  Lemma le_refl : forall p : T, le p p.
    info auto.
  Qed.

  Lemma le_trans : forall p1 p2 p3 : T, le p1 p2 -> le p2 p3 -> le p1 p3.
    unfold le;  intuition; info  eauto.
  Qed.

  Lemma le_antis : forall p1 p2 : T, le p1 p2 -> le p2 p1 -> p1 = p2.
    destruct p1.
    destruct p2.
    unfold le.
     intuition.
     cutrewrite (t = t1).
     cutrewrite (t0 = t2).
    reflexivity.

    info auto.

    info auto.
  Qed.

End Pair.

Require Nat.

Module NN := Pair Nat Nat.

Lemma zz_min : forall p : NN.T, NN.le (0, 0) p.
  info auto with arith.
Qed.


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

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

(** Equality on natural numbers *)

Open Local Scope nat_scope.

Implicit Types m n x y : nat.

(** * Propositional equality  *)

Fixpoint eq_nat n m : Prop :=
  match n, m with
    | O, O => True
    | O, S _ => False
    | S _, O => False
    | S n1, S m1 => eq_nat n1 m1
  end.

Theorem eq_nat_refl : forall n, eq_nat n n.
  induction n; simpl in |- *; auto.
Qed.
Hint Resolve eq_nat_refl: arith v62.

(** [eq] restricted to [nat] and [eq_nat] are equivalent *)

Lemma eq_eq_nat : forall n m, n = m -> eq_nat n m.
  induction 1; trivial with arith.
Qed.
Hint Immediate eq_eq_nat: arith v62.

Lemma eq_nat_eq : forall n m, eq_nat n m -> n = m.
  induction n; induction m; simpl in |- *; contradiction || auto with arith.
Qed.
Hint Immediate eq_nat_eq: arith v62.

Theorem eq_nat_is_eq : forall n m, eq_nat n m <-> n = m.
Proof.
  split; auto with arith.
Qed.

Theorem eq_nat_elim :
  forall n (P:nat -> Prop), P n -> forall m, eq_nat n m -> P m.
Proof.
  intros; replace m with n; auto with arith.
Qed.

Theorem eq_nat_decide : forall n m, {eq_nat n m} + {~ eq_nat n m}.
Proof.
  induction n.
  destruct m as [| n].
  auto with arith.
  intros; right; red in |- *; trivial with arith.
  destruct m as [| n0].
  right; red in |- *; auto with arith.
  intros.
  simpl in |- *.
  apply IHn.
Defined.

(** * Boolean equality on [nat] *)

Fixpoint beq_nat n m : bool :=
  match n, m with
    | O, O => true
    | O, S _ => false
    | S _, O => false
    | S n1, S m1 => beq_nat n1 m1
  end.

Lemma beq_nat_refl : forall n, true = beq_nat n n.
Proof.
  intro x; induction x; simpl in |- *; auto.
Qed.

Definition beq_nat_eq : forall x y, true = beq_nat x y -> x = y.
Proof.
  double induction x y; simpl in |- *.
    reflexivity.
    intros n H1 H2. discriminate H2.
    intros n H1 H2. discriminate H2.
    intros n H1 z H2 H3. case (H2 _ H3). reflexivity.
Defined.

Lemma beq_nat_true : forall x y, beq_nat x y = true -> x=y.
Proof.
 induction x; destruct y; simpl; auto; intros; discriminate.
Qed.

Lemma beq_nat_false : forall x y, beq_nat x y = false -> x<>y.
Proof.
 induction x; destruct y; simpl; auto; intros; discriminate.
Qed.

Lemma beq_nat_true_iff : forall x y, beq_nat x y = true <-> x=y.
Proof.
 split. apply beq_nat_true.
 intros; subst; symmetry; apply beq_nat_refl.
Qed.

Lemma beq_nat_false_iff : forall x y, beq_nat x y = false <-> x<>y.
Proof.
 intros x y.
 split. apply beq_nat_false.
 generalize (beq_nat_true_iff x y).
 destruct beq_nat; auto.
 intros IFF NEQ. elim NEQ. apply IFF; auto.
Qed.


Require Export Coq.Relations.Relation_Definitions.
Require Import Coq.Classes.Morphisms.
Require Export Coq.Classes.Equivalence.
Require Coq.Setoids.Setoid.

Definition full_relation {A} : relation A := fun _ _ => True.

Lemma inclusion_full_relation: forall {A} P, inclusion A P full_relation.
Proof.
  intros.
  hnf; intros.
  hnf.
  auto.
Qed.

Lemma same_relation_spec: forall {A} a1 a2, same_relation A a1 a2 <-> pointwise_relation A (pointwise_relation A iff) a1 a2.
Proof.
  intros.
  unfold same_relation, inclusion, pointwise_relation.
  firstorder.
Qed.

Lemma same_relation_Reflexive {A}: Reflexive (same_relation A).
Proof.
  hnf; intros.
  rewrite same_relation_spec.
  unfold pointwise_relation.
  firstorder.
Qed.

Lemma same_relation_Symmetric {A}: Symmetric (same_relation A).
Proof.
  hnf; intros.
  rewrite same_relation_spec in *.
  unfold pointwise_relation in *.
  firstorder.
Qed.

Lemma same_relation_Transitive {A}: Transitive (same_relation A).
Proof.
  hnf; intros.
  rewrite same_relation_spec in *.
  unfold pointwise_relation in *.
  intros a b. specialize (H a b). specialize (H0 a b).
  firstorder.
Qed.

Instance same_relation_Equivalence {A}: Equivalence (same_relation A).
Proof.
  split.
  + apply same_relation_Reflexive.
  + apply same_relation_Symmetric.
  + apply same_relation_Transitive.
Qed.

Instance inclusion_proper {A}: Proper (same_relation A ==> same_relation A ==> iff) (inclusion A).
Proof.
  intros.
  do 2 (hnf; intros ?F ?G ?H).
  unfold inclusion.
  rewrite same_relation_spec in H, H0.
  split; intros HH x y; specialize (HH x y).
  + rewrite (H x y), (H0 x y) in HH.
    auto.
  + rewrite (H x y), (H0 x y).
    auto.
Qed.

Lemma app_same_relation: forall {A: Type} (R1 R2: relation A) (a1 a2: A),
  same_relation A R1 R2 ->
  (R1 a1 a2 <-> R2 a1 a2).
Proof.
  intros.
  rewrite same_relation_spec in H.
  specialize (H a1 a2).
  tauto.
Qed.

Inductive compond_relation {A: Type} (R1 R2: relation A) : relation A :=
  | compond_intro: forall x y z, R1 x y -> R2 y z -> compond_relation R1 R2 x z.

Lemma compond_relation_spec: forall {A} (R1 R2: relation A) x z,
  compond_relation R1 R2 x z ->
  exists y, R1 x y /\ R2 y z.
Proof.
  intros.
  inversion H; subst.
  eauto.
Qed.

Lemma compond_relation_inclusion: forall {A} (R1 R2 R3 R4: relation A),
  inclusion _ R1 R2 ->
  inclusion _ R3 R4 ->
  inclusion _ (compond_relation R1 R3) (compond_relation R2 R4).
Proof.
  intros.
  hnf; intros.
  inversion H1; subst.
  apply compond_intro with y0; auto.
Qed.

Instance compond_relation_proper {A: Type}: Proper (same_relation A ==> same_relation A ==> same_relation A) compond_relation.
Proof.
  do 2 (hnf; intros).
  destruct H, H0.
  split; apply compond_relation_inclusion; auto.
Defined.

Lemma compond_assoc: forall {A: Type} (R1 R2 R3: relation A),
  same_relation _ (compond_relation (compond_relation R1 R2) R3) (compond_relation R1 (compond_relation R2 R3)).
Proof.
  intros.
  split; hnf; intros;
  do 2
  match goal with
  | H : compond_relation _ _ _ _ |- _ => inversion H; subst; clear H
  end;
  do 2 (econstructor; eauto).
Qed.

Lemma compond_eq_right: forall {A: Type} (R: relation A), same_relation _(compond_relation R eq) R.
Proof.
  intros.
  split; hnf; intros.
  + inversion H; subst.
    auto.
  + econstructor; eauto.
Qed.

Lemma compond_eq_left: forall {A: Type} (R: relation A), same_relation _(compond_relation eq R) R.
Proof.
  intros.
  split; hnf; intros.
  + inversion H; subst.
    auto.
  + econstructor; eauto.
Qed.

Lemma relation_conjunction_inclusion: forall {A} (R1 R2 R3 R4: relation A),
  inclusion _ R1 R2 ->
  inclusion _ R3 R4 ->
  inclusion _ (relation_conjunction R1 R3) (relation_conjunction R2 R4).
Proof.
  intros.
  hnf; intros.
  inversion H1; subst.
  split; auto.
Qed.

Instance relation_conjunction_proper {A: Type}: Proper (same_relation A ==> same_relation A ==> same_relation A) relation_conjunction.
Proof.
  do 2 (hnf; intros).
  destruct H, H0.
  split; apply relation_conjunction_inclusion; auto.
Defined.

Lemma relation_conjunction_iff: forall {A} (R R': relation A) x y,
  relation_conjunction R R' x y <-> R x y /\ R' x y.
Proof.
  intros.
  reflexivity.
Qed.

Lemma relation_disjunction_iff: forall {A} (R R': relation A) x y,
  relation_disjunction R R' x y <-> R x y \/ R' x y.
Proof.
  intros.
  reflexivity.
Qed.

Lemma relation_disjunction_inclusion_left: forall {A} (R R': relation A),
  inclusion _ R (relation_disjunction R R').
Proof.
  intros.
  intros ? ? ?.
  rewrite relation_disjunction_iff.
  tauto.
Qed.

Lemma relation_disjunction_inclusion_right: forall {A} (R R': relation A),
  inclusion _ R' (relation_disjunction R R').
Proof.
  intros.
  intros ? ? ?.
  rewrite relation_disjunction_iff.
  tauto.
Qed.

Definition respectful_relation {A B} (f: A -> B) (R: relation B): relation A := fun x y => R (f x) (f y).

Definition fst_relation {A B}: relation A -> relation (A * B) := respectful_relation (@fst A B).

Definition snd_relation {A B}: relation B -> relation (A * B) := respectful_relation (@snd A B).

Instance respectful_relation_proper {A B} (f: A -> B): Proper (same_relation _ ==> same_relation _) (respectful_relation f).
Proof.
  hnf; intros.
  rewrite @same_relation_spec in H |- *.
  intros b1 b2.
  unfold respectful_relation.
  apply H.
Defined.

Lemma respectful_compond_relation: forall {A B} (f: A -> B) R1 R2,
  inclusion _
    (compond_relation (respectful_relation f R1) (respectful_relation f R2))
    (respectful_relation f (compond_relation R1 R2)).
Proof.
  intros.
  intros a1 a2 ?.
  inversion H; subst.
  apply compond_intro with (f y); auto.
Qed.


(* A basic implementation of left-leaning red-black trees. *)
(* See: https://mew.org/~kazu/proj/red-black-tree/ *)

Require Import Lia.
From larith Require Import A_setup B1_utils C2_order.

Section Red_black_tree.

Variable X : Type.
Variable cmp : X -> X -> comparison.
Hypothesis ord : Order cmp.

Inductive rb_color := Red | Black.
Inductive rb_tree :=
  | Leaf
  | Fork (c : rb_color) (l : rb_tree) (x : X) (r : rb_tree).

Notation Rd := (Fork Red).
Notation Bk := (Fork Black).

Definition rb_col t :=
  match t with
  | Leaf => Black
  | Fork c _ _ _ => c
  end.

Definition rb_balance_l c l z r :=
  match c, l with
  (* Rotation for double red fork. *)
  | Black, Rd (Rd xl x xr) y yr =>
    Rd (Bk xl x xr) y (Bk yr z r)
  (* No rotation needed. *)
  | _, _ => Fork c l z r
  end.

Definition rb_balance_r c l y r :=
  match c, l, r with
  (* Propagate red fork upward. *)
  | Black, Rd xl x xr, Rd zl z zr =>
    Rd (Bk xl x xr) y (Bk zl z zr)
  (* Rotation to make tree left-leaning. *)
  | _, _, Rd zl z zr =>
    Fork c (Rd l y zl) z zr
  (* No rotation needed. *)
  | _, _, _ => Fork c l y r
  end.

Fixpoint rb_ins x t :=
  match t with
  | Leaf => Rd Leaf x Leaf
  | Fork c l y r =>
    match cmp x y with
    | Eq => t
    | Lt => rb_balance_l c (rb_ins x l) y r
    | Gt => rb_balance_r c l y (rb_ins x r)
    end
  end.

Definition rb_insert x t :=
  match rb_ins x t with
  | Fork _ l x r => Bk l x r
  | Leaf => Leaf (* never reached. *)
  end.

Fixpoint rb_contains x t :=
  match t with
  | Leaf => false
  | Fork _ l y r =>
    match cmp x y with
    | Eq => true
    | Lt => rb_contains x l
    | Gt => rb_contains x r
    end
  end.

Fixpoint rb_height t :=
  match t with
  | Leaf => 0
  | Fork _ l _ r => S (max (rb_height l) (rb_height r))
  end.

(* Prove that the algorithm obeys the invariants that keep the tree balanced. *)
Section Tree_invariants.

(* A red node has two black children; there are no red nodes on the right. *)
Fixpoint LLRB_col c t :=
  match c, t with
  | _, Leaf => True
  | Black, Bk l _ r => LLRB_col (rb_col l) l /\ LLRB_col Black r
  | Red, Rd l _ r => LLRB_col Black l /\ LLRB_col Black r
  | _, _ => False
  end.

(* The root is red and its left child is as well. *)
Notation Quasi_LLRB_col t :=
  match t with
  | Rd l _ r => LLRB_col Red l /\ LLRB_col Black r
  | _ => False
  end.

(* The black nodes are equally balanced. *)
Inductive Bk_balanced : nat -> rb_tree -> Prop :=
  | Bk_balanced_Leaf :
    Bk_balanced 0 Leaf
  | Bk_balanced_Rd n l x r :
    Bk_balanced n l -> Bk_balanced n r -> Bk_balanced n (Rd l x r)
  | Bk_balanced_Bk n l x r :
    Bk_balanced n l -> Bk_balanced n r -> Bk_balanced (S n) (Bk l x r).

Definition LLRB p n t := LLRB_col p t /\ Bk_balanced n t.
Definition Quasi_LLRB n t := Quasi_LLRB_col t /\ Bk_balanced n t.

Lemma LLRB_0_Bk_inv c l x r :
  ¬LLRB Black 0 (Fork c l x r).
Proof.
intros []; inv H0.
Qed.

Lemma LLRB_Rd_inv c n l x r :
  LLRB Red n (Fork c l x r) -> LLRB Black n l /\ LLRB Black n r.
Proof.
intros []. inv H0; simpl in H. easy.
Qed.

Lemma LLRB_Bk_inv c n l x r :
  LLRB Black (S n) (Fork c l x r) -> LLRB (rb_col l) n l /\ LLRB Black n r.
Proof.
intros []. inv H0; simpl in H. easy.
Qed.

Theorem rb_height_upper_bound c n t :
  LLRB c n t ->
  match c with
  | Red => rb_height t <= 1 + 2 * n
  | Black => rb_height t <= 2 * n
  end.
Proof.
revert n c; induction t; simpl; intros.
- destruct c, H; inv H0; simpl; auto.
- destruct c0.
  + apply LLRB_Rd_inv in H as [].
    apply IHt1 in H; apply IHt2 in H0; lia.
  + destruct n. apply LLRB_0_Bk_inv in H; easy.
    apply LLRB_Bk_inv in H as [].
    apply IHt1 in H; apply IHt2 in H0.
    destruct (rb_col t1); lia.
Qed.

Theorem LLRB_rb_insert n x t :
  LLRB Black n t ->
  LLRB Black n (rb_insert x t) \/
  LLRB Black (S n) (rb_insert x t).
Proof.
Admitted.

End Tree_invariants.

(* Prove that the algorithm maintains a binary-search tree structure. *)
Section Correct_insertion.

Definition In_interval lwb upb y :=
  match lwb with
  | Some x => cmp x y = Lt
  | None => True
  end /\
  match upb with
  | Some z => cmp y z = Lt
  | None => True
  end.

Fixpoint BST lwb upb t :=
  match t with
  | Leaf => True
  | Fork _ l y r =>
    BST lwb (Some y) l /\
    BST (Some y) upb r /\
    In_interval lwb upb y
  end.

Theorem rb_insert_BST upb lwb x t :
  In_interval upb lwb x -> BST lwb upb t -> BST lwb upb (rb_insert x t).
Proof.
Admitted.

Theorem rb_insert_contains x t :
  rb_contains x (rb_insert x t) = true.
Proof.
Admitted.

End Correct_insertion.

End Red_black_tree.


From Equations Require Import Equations.
From Coq Require Import ssreflect ssrbool ssrfun.
From mathcomp Require Import ssrnat eqtype seq div.
From favssr Require Import prelude.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Section Basics.
Context {T : Type}.
Implicit Types (xs ys zs: seq T).

(* 1.2.3 Multisets *)

(* We'll be using perm_eq instead of msets. *)

(* 1.4 Proofs *)

(* GCD is terminating as the second argument is decreasing *)
Equations? gcd' (m n : nat) : nat by wf n lt :=
gcd' m 0 => m;
gcd' m n => gcd' n (m %% n).
Proof. by apply/ssrnat.ltP/ltn_pmod. Qed.

Lemma gcd_ind P :
  (forall m n, (n != 0 -> P n (m %% n)) -> P m n) -> forall m n, P m n.
Proof.
move=>H m n; elim/ltn_ind: n m=>n IH m; apply: H.
by move=>Hn; apply/IH/ltn_pmod; rewrite lt0n.
Qed.

(* Equations generates a more detailed principle (uncomment to run): *)

(* Check gcd'_elim. *)

(***********************************************************)
(* gcd'_elim                                               *)
(*      : forall P : nat -> nat -> nat -> Type,            *)
(*          (forall m : nat, P m 0 m) ->                   *)
(*          (forall m n : nat,                             *)
(*           P n.+1 (m %% n.+1) (gcd' n.+1 (m %% n.+1)) -> *)
(*           P m n.+1 (gcd' n.+1 (m %% n.+1))) ->          *)
(*          forall m n : nat, P m n (gcd' m n)             *)
(***********************************************************)

(* 1.5 Running time *)

Fixpoint T_app xs ys : nat :=
  if xs is _ :: xs' then (T_app xs' ys).+1 else 1.

(* A simplified implementation compared to the lib *)
Fixpoint rev' xs :=
  if xs is x :: xs' then rcons (rev' xs') x else [::].

Lemma rev'_size xs : size (rev' xs) = size xs.
Proof. by elim: xs=>//=x xs IH; rewrite size_rcons IH. Qed.

Fixpoint T_rev xs : nat :=
  if xs is x :: xs' then (T_rev xs' + T_app (rev' xs') [:: x]).+1 else 1.

Lemma T_app_complexity xs ys : T_app xs ys = (size xs).+1.
Proof. by elim: xs=>//= x xs ->. Qed.

Lemma T_rev_bound xs : T_rev xs <= (size xs).+1 ^2.
Proof.
elim: xs=>//=x xs IH.
rewrite T_app_complexity rev'_size -[in _.+2]addn1
  sqrnD -(mulnn 1) !muln1 -addnA.
apply: leq_ltn_add=>//.
by rewrite addnC addn1 ltnS; apply: leq_addr.
Qed.

(* Exercise 1.5.1: exact complexity for T_rev *)
Lemma T_rev_complexity xs : T_rev xs = (size xs).+1 ^2. (* FIXME *)
Proof.
Admitted.

(* itrev is called catrev in the lib *)

Fixpoint T_catrev xs ys : nat :=
  if xs is x :: xs' then (T_catrev xs' (x :: ys)).+1 else 1.

Lemma T_catrev_complexity xs ys : T_catrev xs ys = (size xs).+1.
Proof. by elim: xs ys=>//=x xs IH ys; rewrite IH. Qed.

Lemma catrev_rev_eq xs ys : catrev xs ys = rev' xs ++ ys.
Proof.
elim: xs ys =>//= x xs IH ys.
by rewrite IH -cats1 -catA.
Qed.

End Basics.


Require Export prosa.util.notation.
Require Export prosa.util.nat.

From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq fintype bigop path.

(* Lemmas about sum. *)
Section ExtraLemmas.

  Lemma leq_sum_seq (I: eqType) (r: seq I) (P : pred I) (E1 E2 : I -> nat) :
    (forall i, i \in r -> P i -> E1 i <= E2 i) ->
    \sum_(i <- r | P i) E1 i <= \sum_(i <- r | P i) E2 i.
  Proof.
    intros LE.
    rewrite big_seq_cond [\sum_(_ <- _| P _)_]big_seq_cond.
      by apply leq_sum; move => j /andP [IN H]; apply LE.
  Qed.

  Lemma eq_sum_seq: forall (I: eqType) (r: seq I) (P: pred I) (E1 E2 : I -> nat),
      (forall i, i \in r -> P i -> E1 i == E2 i) ->
      \sum_(i <- r | P i) E1 i == \sum_(i <- r | P i) E2 i.
  Proof.
    intros; rewrite eqn_leq; apply/andP; split.
    - apply leq_sum_seq; intros.
        by move: (H i H0 H1) => /eqP EQ; rewrite EQ.
    - apply leq_sum_seq; intros.
        by move: (H i H0 H1) => /eqP EQ; rewrite EQ.
  Qed.

  Lemma sum_nat_eq0_nat (T : eqType) (F : T -> nat) (r: seq T) :
    all (fun x => F x == 0) r = (\sum_(i <- r) F i == 0).
  Proof.
    destruct (all (fun x => F x == 0) r) eqn:ZERO.
    - move: ZERO => /allP ZERO; rewrite -leqn0.
      rewrite big_seq_cond (eq_bigr (fun x => 0));
        first by rewrite big_const_seq iter_addn mul0n addn0 leqnn.
      intro i; rewrite andbT; intros IN.
      specialize (ZERO i); rewrite IN in ZERO.
        by move: ZERO => /implyP ZERO; apply/eqP; apply ZERO.
    - apply negbT in ZERO; rewrite -has_predC in ZERO.
      move: ZERO => /hasP ZERO; destruct ZERO as [x IN NEQ]; simpl in NEQ.
      rewrite (big_rem x) /=; last by done.
      symmetry; apply negbTE; rewrite neq_ltn; apply/orP; right.
      apply leq_trans with (n := F x); last by apply leq_addr.
        by rewrite lt0n.
  Qed.

  Lemma sum_seq_gt0P:
    forall (T:eqType) (r: seq T) (F: T -> nat),
      reflect (exists i, i \in r /\ 0 < F i) (0 < \sum_(i <- r) F i).
  Proof.
    intros; apply: (iffP idP); intros.
    {
      induction r; first by rewrite big_nil in H.
      destruct (F a > 0) eqn:POS.
      exists a; split; [by rewrite in_cons; apply/orP; left | by done].
      apply negbT in POS; rewrite -leqNgt leqn0 in POS; move: POS => /eqP POS.
      rewrite big_cons POS add0n in H. clear POS.
      feed IHr; first by done. move: IHr => [i [IN POS]].
      exists i; split; [by rewrite in_cons; apply/orP;right | by done].
    }
    {
      move: H => [i [IN POS]].
      rewrite (big_rem i) //=.
      apply leq_trans with (F i); [by done | by rewrite leq_addr].
    }
  Qed.

  Lemma sum_notin_rem_eqn:
    forall (T:eqType) (a: T) xs P F,
      a \notin xs ->
      \sum_(x <- xs | P x && (x != a)) F x = \sum_(x <- xs | P x) F x.
  Proof.
    intros ? ? ? ? ? NOTIN.
    induction xs; first by rewrite !big_nil.
    rewrite !big_cons.
    rewrite IHxs; clear IHxs; last first.
    { apply/memPn; intros y IN.
      move: NOTIN => /memPn NOTIN.
        by apply NOTIN; rewrite in_cons; apply/orP; right.
    }
    move: NOTIN => /memPn NOTIN.
    move: (NOTIN a0) => NEQ.
    feed NEQ; first by (rewrite in_cons; apply/orP; left).
      by rewrite NEQ Bool.andb_true_r.
  Qed.

  (* Trivial identity: any sum of zeros is zero. *)
  Lemma sum0 m n:
    \sum_(m <= i < n) 0 = 0.
  Proof.
    by rewrite big_const_nat iter_addn mul0n addn0 //.
  Qed.

  (* A sum of natural numbers equals zero iff all terms are zero. *)
  Lemma big_nat_eq0 m n F:
    \sum_(m <= i < n) F i = 0 <-> (forall i, m <= i < n -> F i = 0).
  Proof.
    split.
    - rewrite /index_iota => /eqP.
      rewrite -sum_nat_eq0_nat => /allP ZERO i.
      rewrite -mem_index_iota /index_iota => IN.
      by apply/eqP; apply ZERO.
    - move=> ZERO.
      have ->: \sum_(m <= i < n) F i = \sum_(m <= i < n) 0
        by apply eq_big_nat => //.
      by apply sum0.
  Qed.

  (* We prove that if any element of a set r is bounded by constant [const],
     then the sum of the whole set is bounded by [const * size r]. *)
  Lemma sum_majorant_constant:
    forall (T: eqType) (r: seq T) (P: pred T) F const,
      (forall a,  a \in r -> P a -> F a <= const) ->
      \sum_(j <- r | P j) F j <= const * (size [seq j <- r | P j]).
  Proof.
    clear; intros.
    induction r; first by rewrite big_nil.
    feed IHr.
    { intros; apply H.
      - by rewrite in_cons; apply/orP; right.
      - by done. }
    rewrite big_cons.
    destruct (P a) eqn:EQ.
    { rewrite -cat1s filter_cat size_cat.
      rewrite mulnDr.
      apply leq_add; last by done.
      rewrite size_filter.
      simpl; rewrite addn0.
      rewrite EQ muln1.
      apply H; last by done.
        by rewrite in_cons; apply/orP; left.
    }
    { apply leq_trans with (const * size [seq j <- r | P j]); first by done.
      rewrite leq_mul2l; apply/orP; right.
      rewrite -cat1s filter_cat size_cat.
        by rewrite leq_addl.
    }
  Qed.

  (* We prove that if for any element x of a set [xs] the following two statements hold
     (1) [F1 x] is less than or equal to [F2 x] and (2) the sum [F1 x_1, ..., F1 x_n]
     is equal to the sum of [F2 x_1, ..., F2 x_n], then [F1 x] is equal to [F2 x] for
     any element x of [xs]. *)
  Lemma sum_majorant_eqn:
    forall (T: eqType) xs F1 F2 (P: pred T),
      (forall x, x \in xs -> P x -> F1 x <= F2 x) ->
      \sum_(x <- xs | P x) F1 x = \sum_(x <- xs | P x) F2 x ->
      (forall x, x \in xs -> P x -> F1 x = F2 x).
  Proof.
    intros T xs F1 F2 P H1 H2 x IN PX.
    induction xs; first by done.
    have Fact: \sum_(j <- xs | P j) F1 j <= \sum_(j <- xs | P j) F2 j.
    { rewrite [in X in X <= _]big_seq_cond [in X in _ <= X]big_seq_cond leq_sum //.
      move => y /andP [INy PY].
      apply: H1; last by done.
        by rewrite in_cons; apply/orP; right. }
    feed IHxs.
    { intros x' IN' PX'.
      apply H1; last by done.
        by rewrite in_cons; apply/orP; right. }
    rewrite big_cons [RHS]big_cons in H2.
    have EqLeq: forall a b c d, a + b = c + d -> a <= c -> b >= d.
    { clear; intros; ssromega. }
    move: IN; rewrite in_cons; move => /orP [/eqP EQ | IN].
    { subst a.
      rewrite PX in H2.
      specialize (H1 x).
      feed_n 2 H1; [ by rewrite in_cons; apply/orP; left | by done | ].
      move: (EqLeq
               (F1 x) (\sum_(j <- xs | P j) F1 j)
               (F2 x) (\sum_(j <- xs | P j) F2 j) H2 H1) => Q.
      have EQ: \sum_(j <- xs | P j) F1 j = \sum_(j <- xs | P j) F2 j.
      { by apply/eqP; rewrite eqn_leq; apply/andP; split. }
        by move: H2 => /eqP; rewrite EQ eqn_add2r; move => /eqP EQ'.
    }
    { destruct (P a) eqn:PA; last by apply IHxs.
      apply: IHxs; last by done.
      specialize (H1 a).
      feed_n 2 (H1); [ by rewrite in_cons; apply/orP; left | by done | ].
      move: (EqLeq
               (F1 a) (\sum_(j <- xs | P j) F1 j)
               (F2 a) (\sum_(j <- xs | P j) F2 j) H2 H1) => Q.
        by apply/eqP; rewrite eqn_leq; apply/andP; split.
    }
  Qed.

  (* We prove that the sum of Δ ones is equal to Δ. *)
  Lemma sum_of_ones:
    forall t Δ,
      \sum_(t <= x < t + Δ) 1 = Δ.
  Proof.
    intros.
    rewrite big_const_nat iter_addn_0 mul1n.
    rewrite addnC -addnBA; last by done.
      by rewrite subnn addn0.
  Qed.

  (* We show that the fact that the sum is smaller than the range
     of the summation implies the existence of a zero element. *)
  Lemma sum_le_summation_range :
    forall f t Δ,
      \sum_(t <= x < t + Δ) f x < Δ ->
      exists x, t <= x < t + Δ /\ f x = 0.
  Proof.
    induction Δ; intros; first by rewrite ltn0 in H.
    destruct (f (t + Δ)) eqn: EQ.
    { exists (t + Δ); split; last by done.
        by apply/andP; split; [rewrite leq_addr | rewrite addnS ltnS].
    }
    { move: H; rewrite addnS big_nat_recr //= ?leq_addr // EQ addnS ltnS; move => H.
      feed IHΔ.
      { by apply leq_ltn_trans with (\sum_(t <= i < t + Δ) f i + n); first rewrite leq_addr. }
      move: IHΔ => [z [/andP [LE GE] ZERO]].
      exists z; split; last by done.
      apply/andP; split; first by done.
        by rewrite ltnS ltnW.
    }
  Qed.

End ExtraLemmas.

(* Lemmas about arithmetic with sums. *)
Section SumArithmetic.

  Lemma sum_seq_diff:
    forall (T:eqType) (rs: seq T) (F G : T -> nat),
      (forall i : T, i \in rs -> G i <= F i) ->
      \sum_(i <- rs) (F i - G i) = \sum_(i <- rs) F i - \sum_(i <- rs) G i.
  Proof.
    intros.
    induction rs; first by rewrite !big_nil subn0.
    rewrite !big_cons subh2.
    - apply/eqP; rewrite eqn_add2l; apply/eqP; apply IHrs.
        by intros; apply H; rewrite in_cons; apply/orP; right.
    - by apply H; rewrite in_cons; apply/orP; left.
    - rewrite big_seq_cond [in X in _ <= X]big_seq_cond.
      rewrite leq_sum //; move => i /andP [IN _].
        by apply H; rewrite in_cons; apply/orP; right.
  Qed.

  Lemma sum_diff:
    forall n F G,
      (forall i (LT: i < n), F i >= G i) ->
      \sum_(0 <= i < n) (F i - G i) =
      (\sum_(0 <= i < n) (F i)) - (\sum_(0 <= i < n) (G i)).
  Proof.
    intros n F G ALL.
    rewrite sum_seq_diff; first by done.
    move => i; rewrite mem_index_iota; move => /andP [_ LT].
      by apply ALL.
  Qed.

  Lemma sum_pred_diff:
    forall (T: eqType) (rs: seq T) (P: T -> bool) (F: T -> nat),
      \sum_(r <- rs | P r) F r =
      \sum_(r <- rs) F r - \sum_(r <- rs | ~~ P r) F r.
  Proof.
    clear; intros.
    induction rs; first by rewrite !big_nil subn0.
    rewrite !big_cons !IHrs; clear IHrs.
    case (P a); simpl; last by rewrite subnDl.
    rewrite addnBA; first by done.
    rewrite big_mkcond leq_sum //.
    intros t _.
      by case (P t).
  Qed.

End SumArithmetic.


Require Import Arith.
Require Import Omega.

Definition prop1 (P Q R : Prop) : (P -> Q) -> (Q -> R) -> (P -> R).
Proof.
intros.
apply (H0 (H H1)).
Qed.


Require Import ZArith.

Definition var := nat.

Inductive expr: Type :=
  | impp : expr -> expr -> expr
  | varp : var -> expr.

Declare Scope syntax.
Notation "x --> y" := (impp x y) (at level 55, right associativity) : syntax.
Local Open Scope syntax.

Inductive provable: expr -> Prop :=
| modus_ponens: forall x y, provable (x --> y) -> provable x -> provable y
| axiom1: forall x y, provable (x --> (y --> x))
| axiom2: forall x y z, provable ((x --> y --> z) --> (x --> y) --> (x --> z)).

Module NaiveLang.
  Definition expr := expr.
  Definition impp := impp.
  Definition provable := provable.
End NaiveLang.

Require Import interface_2.

Module NaiveRule.
  Include DerivedNames (NaiveLang).
  Lemma modus_ponens :
    forall x y : expr, provable (impp x y) -> provable x -> provable y.
  Proof. intros. eapply modus_ponens; eauto. Qed.

  Lemma axiom1 : forall x y : expr, provable (impp x (impp y x)).
  Proof. exact axiom1. Qed.

  Lemma axiom2 : forall x y z : expr,
      provable (impp (impp x (impp y z)) (impp (impp x y) (impp x z))).
  Proof. exact axiom2. Qed.

End NaiveRule.

Module T := LogicTheorem NaiveLang NaiveRule.
Module Solver := IPSolver NaiveLang.
Import T.
Import Solver.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

Definition synth (lf2 : natural) (lf1 : natural) (z : natural) (x : natural)
  : natural := plus z lf2.


Require Import Reals.

Open Scope R_scope.

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


Require Import
  Coq.Relations.Relation_Definitions Coq.setoid_ring.Ring
  MathClasses.interfaces.abstract_algebra MathClasses.interfaces.orders MathClasses.theory.rings MathClasses.theory.dec_fields.
Require Export
  MathClasses.orders.rings.

Section contents.
Context `{DecField F} `{Apart F} `{!TrivialApart F} `{!FullPseudoSemiRingOrder Fle Flt} `{∀ x y : F, Decision (x = y)}.
Add Ring F : (stdlib_ring_theory F).

Instance pos_dec_recip_compat x : PropHolds (0 < x) → PropHolds (0 < /x).
Proof.
  intros E.
  apply (strictly_order_reflecting (x *.)).
  rewrite dec_recip_inverse by now apply orders.lt_ne_flip.
  rewrite mult_0_r. solve_propholds.
Qed.

Instance nonneg_dec_recip_compat x : PropHolds (0 ≤ x) → PropHolds (0 ≤ /x).
Proof.
  intros E. red.
  destruct (decide (x = 0)) as [E2 | E2].
   now rewrite E2, dec_recip_0.
  apply lt_le. apply pos_dec_recip_compat.
  apply lt_iff_le_ne. split. easy. now apply not_symmetry.
Qed.

Lemma neg_dec_recip_compat x : x < 0 → /x < 0.
Proof.
  intros. apply flip_neg_negate.
  rewrite dec_recip_negate.
  apply pos_dec_recip_compat.
  now apply flip_neg_negate.
Qed.

Lemma nonpos_dec_recip_compat x : x ≤ 0 → /x ≤ 0.
Proof.
  intros. apply flip_nonpos_negate.
  rewrite dec_recip_negate.
  apply nonneg_dec_recip_compat.
  now apply flip_nonpos_negate.
Qed.

Lemma flip_le_dec_recip x y : 0 < y → y ≤ x  → /x ≤ /y.
Proof with trivial.
  intros E1 E2.
  apply (order_reflecting_pos (.*.) x)...
   now apply lt_le_trans with y.
  rewrite dec_recip_inverse.
   apply (order_reflecting_pos (.*.) y)...
   rewrite (commutativity x), associativity, dec_recip_inverse.
    now ring_simplify.
   now apply lt_ne_flip.
  apply lt_ne_flip.
  now apply lt_le_trans with y.
Qed.

Lemma flip_le_dec_recip_l x y : 0 < y → /y ≤ x  → /x ≤ y.
Proof with trivial.
  intros E1 E2.
  rewrite <-(dec_recip_involutive y).
  apply flip_le_dec_recip...
  now apply pos_dec_recip_compat.
Qed.

Lemma flip_le_dec_recip_r x y : 0 < y → y ≤ /x  → x ≤ /y.
Proof.
  intros E1 E2.
  rewrite <-(dec_recip_involutive x).
  now apply flip_le_dec_recip.
Qed.

Lemma flip_lt_dec_recip x y : 0 < y → y < x  → /x < /y.
Proof.
  intros E1 E2.
  assert (0 < x) by now transitivity y.
  apply (strictly_order_reflecting (x *.)).
  rewrite dec_recip_inverse.
   apply (strictly_order_reflecting (y *.)).
   rewrite (commutativity x), associativity, dec_recip_inverse.
    now ring_simplify.
   now apply lt_ne_flip.
  now apply lt_ne_flip.
Qed.

Lemma flip_lt_dec_recip_l x y : 0 < y → /y < x  → /x < y.
Proof.
  intros E1 E2.
  rewrite <-(dec_recip_involutive y).
  apply flip_lt_dec_recip; trivial.
  now apply pos_dec_recip_compat.
Qed.

Lemma flip_lt_dec_recip_r x y : 0 < y → y < /x  → x < /y.
Proof.
  intros E1 E2.
  rewrite <-(dec_recip_involutive x).
  now apply flip_lt_dec_recip.
Qed.
End contents.

(* Due to bug #2528 *)
#[global]
Hint Extern 12 (PropHolds (0 ≤ _)) => eapply @nonneg_dec_recip_compat : typeclass_instances.
#[global]
Hint Extern 12 (PropHolds (0 < _)) => eapply @pos_dec_recip_compat : typeclass_instances.


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

Require Import ZArithRing.
Require Import ZArith_base.
Require Export Omega.
Require Import Wf_nat.
Local Open Scope Z_scope.

(**********************************************************************)
(** About parity *)

Notation two_or_two_plus_one := Z_modulo_2 (only parsing).

(**********************************************************************)
(** The biggest power of 2 that is stricly less than [a]

    Easy to compute: replace all "1" of the binary representation by
    "0", except the first "1" (or the first one :-) *)

Fixpoint floor_pos (a:positive) : positive :=
  match a with
    | xH => 1%positive
    | xO a' => xO (floor_pos a')
    | xI b' => xO (floor_pos b')
  end.

Definition floor (a:positive) := Zpos (floor_pos a).

Lemma floor_gt0 : forall p:positive, floor p > 0.
Proof. reflexivity. Qed.

Lemma floor_ok : forall p:positive, floor p <= Zpos p < 2 * floor p.
Proof.
 unfold floor. induction p; simpl.
 - rewrite !Pos2Z.inj_xI, (Pos2Z.inj_xO (xO _)), Pos2Z.inj_xO. omega.
 - rewrite (Pos2Z.inj_xO (xO _)), (Pos2Z.inj_xO p), Pos2Z.inj_xO. omega.
 - omega.
Qed.

(**********************************************************************)
(** Two more induction principles over [Z]. *)

Theorem Z_lt_abs_rec :
  forall P:Z -> Set,
    (forall n:Z, (forall m:Z, Z.abs m < Z.abs n -> P m) -> P n) ->
    forall n:Z, P n.
Proof.
  intros P HP p.
  set (Q := fun z => 0 <= z -> P z * P (- z)).
  enough (H:Q (Z.abs p)) by
    (destruct (Zabs_dec p) as [-> | ->]; elim H; auto with zarith).
  apply (Z_lt_rec Q); auto with zarith.
  subst Q; intros x H.
  split; apply HP.
  - rewrite Z.abs_eq; auto; intros.
    destruct (H (Z.abs m)); auto with zarith.
    destruct (Zabs_dec m) as [-> | ->]; trivial.
  - rewrite Z.abs_neq, Z.opp_involutive; auto with zarith; intros.
    destruct (H (Z.abs m)); auto with zarith.
    destruct (Zabs_dec m) as [-> | ->]; trivial.
Qed.

Theorem Z_lt_abs_induction :
  forall P:Z -> Prop,
    (forall n:Z, (forall m:Z, Z.abs m < Z.abs n -> P m) -> P n) ->
    forall n:Z, P n.
Proof.
  intros P HP p.
  set (Q := fun z => 0 <= z -> P z /\ P (- z)) in *.
  enough (Q (Z.abs p)) by
    (destruct (Zabs_dec p) as [-> | ->]; elim H; auto with zarith).
  apply (Z_lt_induction Q); auto with zarith.
  subst Q; intros.
  split; apply HP.
  - rewrite Z.abs_eq; auto; intros.
    elim (H (Z.abs m)); intros; auto with zarith.
    elim (Zabs_dec m); intro eq; rewrite eq; trivial.
  - rewrite Z.abs_neq, Z.opp_involutive; auto with zarith; intros.
    destruct (H (Z.abs m)); auto with zarith.
    destruct (Zabs_dec m) as [-> | ->]; trivial.
Qed.

(** To do case analysis over the sign of [z] *)

Lemma Zcase_sign :
  forall (n:Z) (P:Prop), (n = 0 -> P) -> (n > 0 -> P) -> (n < 0 -> P) -> P.
Proof.
  intros x P Hzero Hpos Hneg.
  destruct x; [apply Hzero|apply Hpos|apply Hneg]; easy.
Qed.

Lemma sqr_pos n : n * n >= 0.
Proof.
 Z.swap_greater. apply Z.square_nonneg.
Qed.

(**********************************************************************)
(** A list length in Z, tail recursive.  *)

Require Import List.

Fixpoint Zlength_aux (acc:Z) (A:Type) (l:list A) : Z :=
  match l with
    | nil => acc
    | _ :: l => Zlength_aux (Z.succ acc) A l
  end.

Definition Zlength := Zlength_aux 0.
Arguments Zlength [A] l.

Section Zlength_properties.

  Variable A : Type.

  Implicit Type l : list A.

  Lemma Zlength_correct l : Zlength l = Z.of_nat (length l).
  Proof.
    assert (H : forall l acc, Zlength_aux acc A l = acc + Z.of_nat (length l)).
    clear l. induction l.
    auto with zarith.
    intros. simpl length; simpl Zlength_aux.
     rewrite IHl, Nat2Z.inj_succ; auto with zarith.
    unfold Zlength. now rewrite H.
  Qed.

  Lemma Zlength_nil : Zlength (A:=A) nil = 0.
  Proof. reflexivity. Qed.

  Lemma Zlength_cons (x:A) l : Zlength (x :: l) = Z.succ (Zlength l).
  Proof.
    intros. now rewrite !Zlength_correct, <- Nat2Z.inj_succ.
  Qed.

  Lemma Zlength_nil_inv l : Zlength l = 0 -> l = nil.
  Proof.
    rewrite Zlength_correct.
    destruct l as [|x l]; auto.
    now rewrite <- Nat2Z.inj_0, Nat2Z.inj_iff.
  Qed.

End Zlength_properties.

Arguments Zlength_correct [A] l.
Arguments Zlength_cons [A] x l.
Arguments Zlength_nil_inv [A] l _.