From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
From LCAC Require Import Relations_ext seq_ext_base ssrnat_ext seq_ext.
Require FunInd.

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

Inductive term : Set := var of nat | app of term & term | abs of term.

Coercion var : nat >-> term.

Fixpoint eqterm t1 t2 :=
  match t1, t2 with
    | var n, var m => n == m
    | app t1l t1r, app t2l t2r => eqterm t1l t2l && eqterm t1r t2r
    | abs t1, abs t2 => eqterm t1 t2
    | _, _ => false
  end.

Lemma eqtermP : Equality.axiom eqterm.
Proof.
move => t1 t2; apply: (iffP idP) => [| <-]; last by elim: t1 => //= t1l ->.
by elim: t1 t2 => [n | t1l IH t1r IH' | t1 IH]
  [// m /eqP -> | //= t2l t2r /andP [] /IH -> /IH' -> | // t2 /IH ->].
Defined.

Canonical term_eqMixin := EqMixin eqtermP.
Canonical term_eqType := Eval hnf in EqType term term_eqMixin.

Fixpoint shift d c t : term :=
  match t with
    | var n => var (if c <= n then n + d else n)
    | app t1 t2 => app (shift d c t1) (shift d c t2)
    | abs t1 => abs (shift d c.+1 t1)
  end.

Notation substitutev ts m n :=
  (shift n 0 (nth (var (m - n - size ts)) ts (m - n))) (only parsing).

Fixpoint substitute n ts t : term :=
  match t with
    | var m => if n <= m then substitutev ts m n else m
    | app t1 t2 => app (substitute n ts t1) (substitute n ts t2)
    | abs t' => abs (substitute n.+1 ts t')
  end.

Reserved Notation "t ->b1 t'" (at level 70, no associativity).

Inductive betared1 : relation term :=
  | betared1beta t1 t2     : app (abs t1) t2 ->b1 substitute 0 [:: t2] t1
  | betared1appl t1 t1' t2 : t1 ->b1 t1' -> app t1 t2 ->b1 app t1' t2
  | betared1appr t1 t2 t2' : t2 ->b1 t2' -> app t1 t2 ->b1 app t1 t2'
  | betared1abs t t'       : t ->b1 t' -> abs t ->b1 abs t'
  where "t ->b1 t'" := (betared1 t t').

Notation betared := [* betared1].
Infix "->b" := betared (at level 70, no associativity).

Hint Constructors betared1.

Lemma shiftzero n t : shift 0 n t = t.
Proof. by elim: t n; congruence' => v n; rewrite addn0 if_same. Qed.

Lemma shift_add d d' c c' t :
  c <= c' <= c + d -> shift d' c' (shift d c t) = shift (d' + d) c t.
Proof. case/andP; do 2 elimleq; elim: t c; congruence' => *; elimif_omega. Qed.

Lemma shift_shift_distr d c d' c' t :
  c' <= c -> shift d' c' (shift d c t) = shift d (d' + c) (shift d' c' t).
Proof. elimleq; elim: t c'; congruence' => *; elimif_omega. Qed.

Lemma shift_subst_distr n d c ts t :
  c <= n -> shift d c (substitute n ts t) = substitute (d + n) ts (shift d c t).
Proof.
by elimleq; elim: t c; congruence' => v c; elimif;
  rewrite shift_add //= add0n leq_addr.
Qed.

Lemma subst_shift_distr n d c ts t :
  n <= c ->
  shift d c (substitute n ts t) =
  substitute n (map (shift d (c - n)) ts) (shift d (size ts + c) t).
Proof.
elimleq; elim: t n; congruence' => v n; elimif.
- rewrite !nth_default ?size_map /=; elimif_omega.
- rewrite -shift_shift_distr // nth_map' /=;
    congr shift; apply nth_equal; rewrite size_map; elimif_omega.
Qed.

(*
Lemma subst_shift_distr' n d c ts t :
  shift d (n + c) (substitute n ts t) =
  substitute n [seq shift d c i | i <- ts] (shift d (size ts + (n + c)) t).
Proof. by rewrite subst_shift_distr ?addKn // leq_addr. Qed.
*)

Lemma subst_shift_cancel n d c ts t :
  c <= n -> size ts + n <= d + c ->
  substitute n ts (shift d c t) = shift (d - size ts) c t.
Proof.
do 2 elimleq; elim: t c; congruence' => v c;
  elimif; rewrite nth_default /=; elimif_omega.
Qed.

Lemma subst_subst_distr n m xs ys t :
  m <= n ->
  substitute n xs (substitute m ys t) =
  substitute m (map (substitute (n - m) xs) ys) (substitute (size ys + n) xs t).
Proof.
elimleq; elim: t m; congruence' => v m; elimif.
- rewrite nth_default ?(@subst_shift_cancel m) // ?size_map /=; elimif_omega.
- rewrite -shift_subst_distr // nth_map' /=;
    congr shift; apply nth_equal; rewrite size_map; elimif_omega.
Qed.

Lemma subst_app n xs ys t :
  substitute n xs (substitute (size xs + n) ys t) = substitute n (xs ++ ys) t.
Proof.
elim: t n; congruence' => v n; rewrite nth_cat size_cat;
  elimif_omega; rewrite subst_shift_cancel; elimif_omega.
Qed.

Lemma subst_nil n t : substitute n [::] t = t.
Proof. elim: t n; congruence' => m n; rewrite nth_nil /=; elimif_omega. Qed.

Lemma subst_betared1 n ts t t' :
  t ->b1 t' -> substitute n ts t ->b1 substitute n ts t'.
Proof.
move => H; elim/betared1_ind: t t' / H n => /=; auto => t t' n.
by rewrite subst_subst_distr //= add1n subn0.
Qed.

(* small example for PPL2015 paper *)
Lemma shift_betared t t' d c : t ->b1 t' -> shift d c t ->b1 shift d c t'.
Proof.
move => H; elim/betared1_ind: t t' / H d c => /=; auto => t1 t2 d c.
rewrite subst_shift_distr //= add1n subn0; auto.
Qed.

Module confluence_proof.

Reserved Notation "t ->bp t'" (at level 70, no associativity).

Inductive parred : relation term :=
  | parredvar n : var n ->bp var n
  | parredapp t1 t1' t2 t2' :
    t1 ->bp t1' -> t2 ->bp t2' -> app t1 t2 ->bp app t1' t2'
  | parredabs t t' : t ->bp t' -> abs t ->bp abs t'
  | parredbeta t1 t1' t2 t2' :
    t1 ->bp t1' -> t2 ->bp t2' -> app (abs t1) t2 ->bp substitute 0 [:: t2'] t1'
  where "t ->bp t'" := (parred t t').

Hint Constructors parred.

Function reduce_all_redex t : term :=
  match t with
    | var _ => t
    | app (abs t1) t2 =>
      substitute 0 [:: reduce_all_redex t2] (reduce_all_redex t1)
    | app t1 t2 => app (reduce_all_redex t1) (reduce_all_redex t2)
    | abs t' => abs (reduce_all_redex t')
  end.

Lemma parred_refl t : parred t t.
Proof. elim: t; auto. Qed.

Lemma betaredappl t1 t1' t2 : t1 ->b t1' -> app t1 t2 ->b app t1' t2.
Proof. apply (rtc_map' (fun x y => @betared1appl x y t2)). Qed.

Lemma betaredappr t1 t2 t2' : t2 ->b t2' -> app t1 t2 ->b app t1 t2'.
Proof. apply (rtc_map' (@betared1appr t1)). Qed.

Lemma betaredabs t t' : t ->b t' -> abs t ->b abs t'.
Proof. apply (rtc_map' betared1abs). Qed.

Hint Resolve parred_refl betaredappl betaredappr betaredabs.

Lemma betared1_in_parred : inclusion betared1 parred.
Proof. apply betared1_ind; auto. Qed.

Lemma parred_in_betared : inclusion parred betared.
Proof.
apply parred_ind; auto => t1 t1' t2 t2' H H0 H1 H2.
- apply rtc_trans with (app t1' t2); auto.
- apply rtc_trans with (app (abs t1') t2); auto.
  apply rtc_trans with (app (abs t1') t2'); auto.
  by apply rtc_step.
Qed.

Lemma shift_parred t t' d c : t ->bp t' -> shift d c t ->bp shift d c t'.
Proof.
move => H; elim/parred_ind: t t' / H d c => //=;
  auto => t1 t1' t2 t2' H H0 H1 H2 d c.
rewrite subst_shift_distr //= add1n subn0; auto.
Qed.

Lemma subst_parred n ps t t' :
  Forall (prod_curry parred) ps -> t ->bp t' ->
  substitute n [seq fst p | p <- ps] t ->bp
  substitute n [seq snd p | p <- ps] t'.
Proof.
move => H H0; elim/parred_ind: t t' / H0 n => /=; auto.
- move => v n; elimif; rewrite !size_map; apply shift_parred.
  elim: ps v H => //= [[t t']] ps IH [| v] [] //= H H0.
  by rewrite subSS; apply IH.
- move => t1 t1' t2 t2' H0 H1 H2 H3 n.
  by rewrite subst_subst_distr //= add1n subn0; auto.
Qed.

Lemma parred_all_lemma t t' : t ->bp t' -> t' ->bp reduce_all_redex t.
Proof with auto.
elim/reduce_all_redex_ind: {t}_ t'.
- by move => t n H t' H0; inversion H0; subst.
- move => _ t1 t2 _ H H0 t' H1; inversion H1; subst.
  + inversion H4; subst...
  + apply (@subst_parred 0 [:: (t2', reduce_all_redex t2)]) => /=...
- move => _ t1 t2 _ H H0 H1 t' H2; inversion H2; subst => //...
- move => _ t1 _ H t2 H0; inversion H0; subst...
Qed.

Lemma parred_confluent : confluent parred.
Proof.
by move => t1 t2 t3 H H0; exists (reduce_all_redex t1); apply parred_all_lemma.
Qed.

Theorem betared_confluent : confluent betared.
Proof.
apply (rtc_confluent' betared1_in_parred parred_in_betared parred_confluent).
Qed.

End confluence_proof.


Require Export H1_4.
Require Export Reals.

Module Section1_5.

Open Scope R_scope.

(* 数环 *)
Definition Ring (S : Ensemble R) := forall (a b : R),
  S ≠ Φ R -> a ∈ S -> b ∈ S ->
  ((a+b) ∈ S /\ (a-b) ∈ S /\ (a*b) ∈ S).

(* 数域 *)
Definition Field (F : Ensemble R) := Ring F /\
  (exists c, c ≠ 0 /\ c ∈ F) /\
  (forall a b, a ∈ F -> b ∈ F -> b ≠ 0 -> (a/b) ∈ F).

(* 实数下的有理数域 *)
Definition Q2R := \{ λ u, exists (c1 c2 : Z),
  (IZR c2) ≠ 0/\u = (IZR c1)/(IZR c2) \}.

(* 定理1.5.1 *)
Theorem Theorem1_5_1 : forall (F : Ensemble R), Field F -> Q2R ⊂ F.
Proof.
  intros. red in H. destruct H, H0. destruct H0 as [a H0]. destruct H0.
  generalize (H1 a a); intros. apply H3 in H2; auto.
  assert (a / a = 1). { field; auto. } rewrite H4 in H2; clear H4.
  assert (F ≠ Φ R). { intro. rewrite H4 in H2.
  apply -> AxiomII in H2; simpl in H2. apply H2; auto. } red in H.
  (* 所有的正整数属于F *)
  assert (forall x : Z, (0 <= x)%Z -> (IZR x) ∈ F). {
  apply Z_of_nat_prop. intros. rewrite <- INR_IZR_INZ.
   induction n.
  - simpl. generalize (H 1 1); intros. apply H5 in H4; auto. clear H5.
    destruct H4, H5. assert (1-1 = 0). { field. } rewrite H7 in H5; auto.
  - rewrite S_INR. generalize (H (INR n) 1); intros. apply H5 in H4; auto.
    clear H5. destruct H4, H5. auto. }
  (* 所有的整数属于F *)
  assert (forall x : Z, (IZR x) ∈ F).
  { intros.
    generalize (classic (0 <= x)%Z); intros; destruct H6.
    - apply H5 in H6; auto.
    - apply Znot_le_gt in H6. assert (0 <= -x)%Z. {
      Z.swap_greater. lia. } apply H5 in H7.
      generalize (H 0 (IZR (- x))); intros. apply H8 in H4; auto.
      + clear H8. destruct H4, H8. rewrite Z_R_minus in H8. simpl in H8.
        assert (- - x = x)%Z. { ring. } rewrite H10 in H8; auto.
      + generalize (H 1 1); intros. apply H9 in H4; clear H9; auto.
        destruct H4, H9. assert (1-1=0). { field. } rewrite <- H11; auto. }
  red; intros. apply -> AxiomII in H7; simpl in H7. destruct H7, H7.
  assert (IZR x ∈ F /\ IZR x0 ∈ F). {
  generalize (H6 x); generalize (H6 x0); intros. split; auto. }
  destruct H7. rewrite H9. eapply H1; eauto.
Qed.

End Section1_5.
Export Section1_5.


Require Import Base.
Require Import SemanticsBase.

Inductive 𝔱sem : 𝔱 -> 𝔱 -> Prop :=
  | 𝔱sem_prj1 : forall t1 t2, 𝔱sem (𝔱prj 1 (𝔱pair t1 t2)) t1
  | 𝔱sem_prj2 : forall t1 t2, 𝔱sem (𝔱prj 2 (𝔱pair t1 t2)) t2
  | 𝔱sem_app : forall x t t', 𝔱sem (𝔱app (𝔱lambda x t) t') (𝔱subst t x t')
  | 𝔱sem_case1 : forall v x1 x2 t1 t2, 𝔱sem (𝔱case (𝔱inj 1 v) x1 t1 x2 t2) (𝔱subst t1 x1 v)
  | 𝔱sem_case2 : forall v x1 x2 t1 t2, 𝔱sem (𝔱case (𝔱inj 2 v) x1 t1 x2 t2) (𝔱subst t2 x2 v).

Inductive 𝔢sem : 𝔢 -> 𝔢 -> Prop :=
  | 𝔢sem_let_hole : forall e, 𝔢sem (𝔢holelet (𝔢hole) e) e
  | 𝔢sem_let : forall x1 x2 e1 e2 e, x1 <> x2 -> 𝔢sem (𝔢let x1 x2 (𝔢pair e1 e2) e) (𝔢subst (𝔢subst e x1 e1) x2 e2)
  | 𝔢sem_app : forall x e1 e2, 𝔢sem (𝔢app (𝔢lambda x e1) e2) (𝔢subst e1 x e2)
  | 𝔢sem_bind : forall x e1 e2, 𝔢sem (𝔢bind x (𝔢return e1) e2) (𝔢subst e2 x e1)
  | 𝔢sem_force_suspend : forall e, 𝔢sem (𝔢force (𝔱suspend e)) e
  | 𝔢sem_case1 : forall x1 x2 e1 e2 e, 𝔢sem (𝔢case (𝔢inj 1 e) x1 e1 x2 e2) (𝔢subst e1 x1 e)
  | 𝔢sem_case2 : forall x1 x2 e1 e2 e, 𝔢sem (𝔢case (𝔢inj 2 e) x1 e1 x2 e2) (𝔢subst e2 x2 e).

(*  | 𝔢sem_flor_let : forall v x e, 𝔢sem (𝔢florlet x (𝔢flor v) e) (𝔢subst e x v). *)


(*

   Benedikt Ahrens and Régis Spadotti

   Terminal semantics for codata types in intensional Martin-Löf type theory

   http://arxiv.org/abs/1401.1053

*)

(*

  Content of this file:

  - definition of type of setoids and type of setoid morphisms
  - identity and composition of setoid morphisms

*)

Require Import Misc.Unicode.
Require Import Morphisms.
Require Export SetoidClass.

Generalizable All Variables.
(** * Setoid **)

(*------------------------------------------------------------------------------
  -- ＳＥＴＯＩＤ  ＤＥＦＩＮＩＴＩＯＮ
  ----------------------------------------------------------------------------*)
(** ** Setoid definiton **)

Module Setoid.

  Structure Setoid : Type := mkSetoid
  { Carrier   :>  Type
  ; Equiv     :   Carrier → Carrier → Prop
  ; is_Equiv  :   Equivalence Equiv }.

  Existing Instance is_Equiv.

  Arguments Equiv {_} _ _.

  Notation "'Setoid.make' ⦃ 'Carrier' ≔ c ; 'Equiv' ≔ eq ⦄" :=
    (mkSetoid c eq _) (only parsing).

  Program Definition eq_setoid (T : Type) : Setoid := Setoid.make  ⦃ Carrier  ≔ T
                                                                   ; Equiv    ≔ eq ⦄.

  Notation "_≈_"         := Equiv                    (only parsing).
  Notation "x ≈ y :> T"  := (Equiv (s := T) x y)     (at level 70, y at next level, no associativity).
  Notation "x ≈ y"       := (Equiv x y)              (at level 70, no associativity).
  Notation "x ≉ y"       := (complement Equiv x y)   (at level 70, no associativity).

End Setoid.

(*------------------------------------------------------------------------------
  -- ＳＥＴＯＩＤ  ＭＯＲＰＨＩＳＭ
  ----------------------------------------------------------------------------*)
(** ** Morphism between setoids **)

Module Π.

  Import Setoid.

  Structure Π (From To : Setoid) : Type := mkΠ
  { map         :>  From → To
  ; map_proper  :   Proper (_≈_ ==> _≈_) map }.

  Existing Instance map_proper.

  Lemma cong From To (f : Π From To) : ∀ x y, x ≈ y → f x ≈ f y.
  Proof.
    intros x y eq_xy; now rewrite eq_xy.
  Qed.

  Program Definition setoid (From To : Setoid) : Setoid :=
    Setoid.make  ⦃ Carrier  ≔ Π From To
                 ; Equiv    ≔ λ f g ∙ ∀ x y, x ≈ y → f x ≈ g y ⦄.
  Next Obligation.
    constructor.
    - (* Reflexivity *)
      intros f x y eq_xy. now rewrite eq_xy.
    - (* Symmetry *)
      intros f g eq_fg x y eq_xy. rewrite eq_xy. symmetry. now apply eq_fg.
    - (* Transitivity *)
      intros f g h eq_fg eq_gh x y eq_xy. etransitivity; eauto.
      now apply eq_gh.
  Qed.

  Notation "[ A ⟶ B ]" := (Π A B).

  Notation make f := (@mkΠ _ _ f _) (only parsing).

  Notation "'λ' x .. y ↦ F" := (make (λ x ∙ .. (λ y ∙ F) ..))
    (at level 200, x binder, y binder, no associativity).

  Program Definition id {A} : [A ⟶ A] := make (λ x ∙ x).
  Next Obligation.
    intros f g eq_fg. exact eq_fg.
  Qed.

  Program Definition compose {A B C} (g : [B ⟶ C]) (f : [A ⟶ B]) : [A ⟶ C] := make (λ x ∙ g (f x)).
  Next Obligation.
    intros x y eq_xy. rewrite eq_xy. reflexivity.
  Qed.

End Π.

Module Π₂.

  Import Setoid.

  Structure Π₂ (A B C : Setoid) : Type := mkΠ₂
  { map          :>  A → B → C
  ; map_compose  :   Proper (_≈_ ==> _≈_ ==> _≈_) map }.

  Existing Instance map_compose.

  Lemma cong A B C (f : Π₂ A B C) : ∀ x x' y y', x ≈ x' → y ≈ y' → f x y ≈ f x' y'.
  Proof.
    intros x x' y y' eq_xx' eq_yy'; now rewrite eq_xx', eq_yy'.
  Qed.

  Notation "[ A ⟶ B ⟶ C ]" := (Π₂ A B C).

  Notation make  f := (@mkΠ₂ _ _ _ f _) (only parsing).

  Notation "'λ' x .. y ↦₂ F" := (make (λ x ∙ .. (λ y ∙ F) ..))
    (at level 200, x binder, y binder, no associativity).

End Π₂.

(*----------------------------------------------------------------------------*)

Export Setoid Π Π₂.


Require Coq.Logic.Classical_Prop.
Require Import ProofCheckingEuclid.euclidean_axioms.
Require Import ProofCheckingEuclid.euclidean_defs.
Require Import ProofCheckingEuclid.euclidean_tactics.
Require Import ProofCheckingEuclid.lemma_altitudebisectsbase.
Require Import ProofCheckingEuclid.lemma_betweennotequal.
Require Import ProofCheckingEuclid.lemma_collinear_ABC_ABD_BCD.
Require Import ProofCheckingEuclid.lemma_collinearorder.
Require Import ProofCheckingEuclid.lemma_collinearright.
Require Import ProofCheckingEuclid.lemma_congruenceflip.
Require Import ProofCheckingEuclid.lemma_extension.
Require Import ProofCheckingEuclid.lemma_inequalitysymmetric.
Require Import ProofCheckingEuclid.lemma_midpointunique.
Require Import ProofCheckingEuclid.lemma_orderofpoints_ABC_BCD_ABD.
Require Import ProofCheckingEuclid.lemma_orderofpoints_ABC_BCD_ACD.
Require Import ProofCheckingEuclid.lemma_rightreverse.
Require Import ProofCheckingEuclid.lemma_s_midpoint.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_droppedperpendicularunique :
	forall A J M P,
	RightTriangle A M P ->
	RightTriangle A J P ->
	Col A M J ->
	eq M J.
Proof.
	intros A J M P.
	intros RightTriangle_AMP.
	intros RightTriangle_AJP.
	intros Col_A_M_J.

	pose proof (lemma_collinearorder _ _ _ Col_A_M_J) as (_ & Col_M_J_A & _ & _ & Col_J_M_A).

	assert (~ neq M J) as eq_M_J.
	{
		intros neq_M_J.

		pose proof (lemma_inequalitysymmetric _ _ neq_M_J) as neq_J_M.

		pose proof (lemma_extension _ _ _ _ neq_M_J neq_M_J) as (E & BetS_M_J_E & _).

		pose proof (lemma_betweennotequal _ _ _ BetS_M_J_E) as (_ & _ & neq_M_E).
		pose proof (axiom_betweennesssymmetry _ _ _ BetS_M_J_E) as BetS_E_J_M.

		pose proof (lemma_extension _ _ _ _ neq_J_M neq_M_E) as (F & BetS_J_M_F & Cong_MF_ME).

		pose proof (lemma_orderofpoints_ABC_BCD_ABD _ _ _ _ BetS_E_J_M BetS_J_M_F) as BetS_E_J_F.
		pose proof (lemma_orderofpoints_ABC_BCD_ACD _ _ _ _ BetS_E_J_M BetS_J_M_F) as BetS_E_M_F.
		pose proof (axiom_betweennesssymmetry _ _ _ BetS_E_J_F) as BetS_F_J_E.
		pose proof (axiom_betweennesssymmetry _ _ _ BetS_E_M_F) as BetS_F_M_E.
		pose proof (lemma_betweennotequal _ _ _ BetS_E_J_F) as (neq_J_F & _ & _).
		pose proof (lemma_betweennotequal _ _ _ BetS_J_M_F) as (neq_M_F & _ & _).
		pose proof (lemma_inequalitysymmetric _ _ neq_J_F) as neq_F_J.
		pose proof (lemma_inequalitysymmetric _ _ neq_M_F) as neq_F_M.

		pose proof (lemma_congruenceflip _ _ _ _ Cong_MF_ME) as (_ & Cong_FM_ME & _ ).

		assert (Col J M F) as Col_J_M_F by (unfold Col; one_of_disjunct BetS_J_M_F).
		pose proof (lemma_collinearorder _ _ _ Col_J_M_F) as (Col_M_J_F & _ & _ & _ & _).

		pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_M_J_F Col_M_J_A neq_M_J) as Col_J_F_A.
		pose proof (lemma_collinearorder _ _ _ Col_J_F_A) as (_ & _ & Col_A_J_F & _ & _).

		pose proof (lemma_collinearright _ _ _ _ RightTriangle_AJP Col_A_J_F neq_F_J) as RightTriangle_FJP.

		pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_J_M_F Col_J_M_A neq_J_M) as Col_M_F_A.
		pose proof (lemma_collinearorder _ _ _ Col_M_F_A) as (_ & _ & Col_A_M_F & _ & _).

		pose proof (lemma_collinearright _ _ _ _ RightTriangle_AMP Col_A_M_F neq_F_M) as RightTriangle_FMP.
		pose proof (lemma_rightreverse _ _ _ _ RightTriangle_FMP BetS_F_M_E Cong_FM_ME) as Cong_FP_EP.
		pose proof (lemma_altitudebisectsbase _ _ _ _ BetS_F_J_E Cong_FP_EP RightTriangle_FJP) as Midpoint_F_J_E.
		pose proof (lemma_s_midpoint _ _ _ BetS_F_M_E Cong_FM_ME) as Midpoint_F_M_E.
		pose proof (lemma_midpointunique _ _ _ _ Midpoint_F_J_E Midpoint_F_M_E) as eq_J_M.

		contradict eq_J_M.
		exact neq_J_M.
	}
	apply Classical_Prop.NNPP in eq_M_J.

	exact eq_M_J.
Qed.

End Euclid.


Load LFindLoad.
From lfind Require Import LFind.
From adtind Require Import goal33.

Set Printing Depth 1000.
Definition lfind_eval  x:=
mult (qfac x (Succ Zero)) x.

Compute lfind_eval  (Succ (Succ (Succ Zero))).

Compute lfind_eval  (Succ (Succ (Succ Zero))).

Compute lfind_eval  (Succ (Succ (Succ (Succ Zero)))).

Compute lfind_eval  (Succ Zero).

Compute lfind_eval  (Succ (Succ (Succ Zero))).

Compute lfind_eval  (Zero).

Compute lfind_eval  (Succ (Succ (Succ (Succ (Succ Zero))))).

Compute lfind_eval  (Succ Zero).

Compute lfind_eval  (Succ Zero).

Compute lfind_eval  (Succ (Succ Zero)).

Compute lfind_eval  (Zero).

Compute lfind_eval  (Succ (Succ (Succ (Succ Zero)))).

Compute lfind_eval  (Succ (Succ Zero)).

Compute lfind_eval  (Zero).

Compute lfind_eval  (Zero).


Section Evolution.
  Variable St : Type.
  Variable t : St -> St -> Type.

  CoInductive evolutionFrom : St -> Type :=
  | evolve {s s'} : t s s' -> evolutionFrom s' -> evolutionFrom s.

  Definition evolution := sigT evolutionFrom.

  Fixpoint fastForward (e:evolution) (n:nat) {struct n} : evolution.
    refine (match n with
    | 0 => e
    | S n' => let ' existT _ _ (evolve _ e') := e in
             fastForward (existT _ _ e') n'
    end).
  Defined.

  Section Property.
    Variable P : St -> Prop.

    CoInductive ForallStates : forall {s}, P s -> evolutionFrom s -> Prop :=
    | evolveHolds s p s' p' t e : @ForallStates s p e -> @ForallStates s' p' (evolve t e).

    Definition always e := exists p, ForallStates p (projT2 e).

    Definition eventually e := exists n, always (fastForward e n).
  End Property.
End Evolution.


(*
Chapter 9
Simply Typed Lambda-Calculus
*)

Require Import TLC.LibLN.

Inductive typ : Set :=
  | t_arrow : typ -> typ -> typ
  | t_bool  : typ.

Inductive exp : Set :=
  | e_fvar : var -> exp
  | e_bvar : nat -> exp
  | e_abs : typ -> exp -> exp
  | e_app : exp -> exp -> exp
  | e_tru : exp
  | e_fls : exp
  | e_cond : exp -> exp -> exp -> exp.

Definition env := env typ.

Fixpoint subst_ee (x : var) (s t: exp) {struct t} : exp :=
  match t with
  | e_fvar y => If (y = x) then s else e_fvar y
  | e_bvar i => e_bvar i
  | e_abs T t1 => e_abs T (subst_ee x s t1)
  | e_app t1 t2 => e_app (subst_ee x s t1) (subst_ee x s t2)
  | e_tru => e_tru
  | e_fls => e_fls
  | e_cond t t1 t2 => e_cond (subst_ee x s t) (subst_ee x s t1) (subst_ee x s t2)
end.

Fixpoint open_ee_rec (j : nat) (s t: exp) {struct t} : exp :=
  match t with
  | e_fvar y => e_fvar y
  | e_bvar i => If (i = j) then s else e_bvar i
  | e_abs T t1 => e_abs T (open_ee_rec (S j) s t1)
  | e_app t1 t2 => e_app (open_ee_rec j s t1) (open_ee_rec j s t2)
  | e_tru => e_tru
  | e_fls => e_fls
  | e_cond t t1 t2 => e_cond (open_ee_rec j s t) (open_ee_rec j s t1) (open_ee_rec j s t2)
end.

Definition open_ee t u := open_ee_rec 0 u t.

(** Notation for opening up binders with type or term variables *)

Notation "t 'open_ee_var' x" := (open_ee t (e_fvar x)) (at level 67).

Inductive lc_exp : exp -> Prop :=
  | lc_fvar : forall x,
      lc_exp (e_fvar x)
 | lc_abs : forall (L:vars) (e:exp) T,
      ( forall x , x \notin L -> lc_exp (open_ee e (e_fvar x)))  ->
     lc_exp (e_abs T e)
 | lc_app : forall (e1 e2:exp),
     lc_exp e1 ->
     lc_exp e2 ->
     lc_exp (e_app e1 e2)
 | lc_tru :
      lc_exp e_tru
 | lc_fls :
      lc_exp e_fls
 | lc_cond : forall e e1 e2,
      lc_exp e ->
      lc_exp e1 ->
      lc_exp e2 ->
      lc_exp (e_cond e e1 e2).

Inductive value : exp -> Prop :=
  | val_abs : forall T e,
      value (e_abs T e)
  | val_tru : value e_tru
  | val_fls : value e_fls.

Inductive typing : env -> exp -> typ -> Prop :=
  | typ_var : forall x E T,
     ok E ->
     binds x T E ->
     typing E (e_fvar x) T
  | typ_abs : forall (L:vars) (E:env) (T1 T2:typ) (e:exp),
     ok E ->
     (forall x, x \notin L ->
        typing (E & x ~ T1) (open_ee e (e_fvar x)) T2) ->
     typing E (e_abs T1 e) (t_arrow T1 T2)
  | typ_app : forall (E:env) (e1 e2: exp) (T1 T2:typ),
      typing E e1 (t_arrow T1 T2) ->
      typing E e2 T1 ->
      typing E (e_app e1 e2) T2
  | typ_tru : forall E,
      ok E ->
      typing E e_tru t_bool
  | typ_fls : forall E,
      ok E ->
      typing E e_fls t_bool
  | typ_cond : forall E e e1 e2 T,
      typing E e t_bool ->
      typing E e1 T ->
      typing E e2 T ->
      typing E (e_cond e e1 e2) T.

Inductive step : exp -> exp -> Prop :=
  | step_appl : forall e1 e2 e1',
      lc_exp e2 ->
      step e1 e1' ->
      step (e_app e1 e2) (e_app e1' e2)
  | step_appr : forall e1 e2 e2',
      value e1 ->
      step e2 e2' ->
      step (e_app e1 e2) (e_app e1 e2')
 | step_beta : forall (e:exp) (v:exp) T,
     lc_exp (e_abs T e) ->
     value v ->
     step (e_app (e_abs T e) v) (open_ee e v)
 | step_cond : forall e e1 e2 e',
     lc_exp e1 ->
     lc_exp e2 ->
     step e e' ->
     step (e_cond e e1 e2) (e_cond e' e1 e2)
 | step_condl : forall e1 e2,
     lc_exp e1 ->
     lc_exp e2 ->
     step (e_cond e_tru e1 e2) e1
 | step_condr : forall e1 e2,
     lc_exp e1 ->
     lc_exp e2 ->
     step (e_cond e_fls e1 e2) e2.

Lemma cannonical_form_bool : forall v,
  value v ->
  forall E, typing E v t_bool ->
  v = e_tru \/ v = e_fls.
Proof.
  introv Val Typ.
  inverts Typ; try solve [inverts* Val].
Qed.

Lemma canonical_form_abs : forall v,
  value v ->
  forall T1 T2 E, typing E v (t_arrow T1 T2) ->
  exists e, v = e_abs T1 e.
Proof.
  introv Val Typ. inverts Val; try solve [inverts Typ].
  inverts Typ. exists* e.
Qed.

#[export]
Hint Constructors value step lc_exp step : core.

(** Gathering free names already used in the proofs **)

Fixpoint fv_ee (e:exp) : vars :=
  match e with
  | e_fvar y => \{y}
  | e_bvar i => \{}
  | e_abs T t1 => fv_ee t1
  | e_app t1 t2 => (fv_ee t1) \u (fv_ee t2)
  | e_tru => \{}
  | e_fls => \{}
  | e_cond t t1 t2 => (fv_ee t) \u (fv_ee t1) \u (fv_ee t2)
  end.

Ltac gather_vars :=
  let A := gather_vars_with (fun x : vars => x) in
  let B := gather_vars_with (fun x : var => \{x}) in
  let C := gather_vars_with (fun x : exp => fv_ee x) in
  let F := gather_vars_with (fun x : env => dom x) in
  constr:(A \u B \u C \u F).

(** "pick_fresh x" tactic create a fresh variable with name x *)

Ltac pick_fresh x :=
  let L := gather_vars in (pick_fresh_gen L x).

(** "apply_fresh T as x" is used to apply inductive rule which
   use an universal quantification over a cofinite set *)

Tactic Notation "apply_fresh" constr(T) "as" ident(x) :=
  apply_fresh_base T gather_vars x.

Tactic Notation "apply_fresh" "*" constr(T) "as" ident(x) :=
  apply_fresh T as x; autos*.

(** These tactics help applying a lemma which conclusion mentions
  an environment (E & F) in the particular case when F is empty *)

Ltac get_env :=
  match goal with
  | |- typing ?E _ _ => E
  end.

Tactic Notation "apply_empty_bis" tactic(get_env) constr(lemma) :=
  let E := get_env in rewrite <- (concat_empty_r E);
  eapply lemma; try rewrite concat_empty_r.

Tactic Notation "apply_empty" constr(F) :=
  apply_empty_bis (get_env) F.

Tactic Notation "apply_empty" "*" constr(F) :=
  apply_empty F; autos*.

Lemma progress : forall e T,
  lc_exp e ->
  typing empty e T ->
  value e \/ exists e', step e e'.
Proof.
  introv LC Typ.
  inductions Typ.
 - apply binds_empty_inv in H0. inverts H0.
 - inverts LC. left*.
 - right. inverts LC. destruct~ IHTyp1.
   destruct~ IHTyp2.
   apply canonical_form_abs in Typ1; auto.
   destruct Typ1 as [e Typ1].
   subst. exists* (open_ee e e2).
   destruct H0 as [e' H0]. exists*.
   destruct H as [e' H]. exists*.
 - left*.
 - left*.
 - right. inverts LC. destruct~ IHTyp1.
   apply cannonical_form_bool in Typ1; auto.
   destruct Typ1.
   subst. exists*. subst. exists*.
   destruct H as [e' H]. exists*.
Qed.

Lemma typing_weakening : forall E F G e T,
  typing (E & G) e T ->
  ok (E & F & G) ->
  typing (E & F & G) e T.
Proof.
  introv Typ Ok. gen F. inductions Typ; simpl; intros.
  - apply* typ_var.
    apply* binds_weaken.
  - apply_fresh* typ_abs as y.
    forwards*: H1 y E (G & y ~ T1) F.
    rewrite~ concat_assoc.
    rewrite~ concat_assoc.
    rewrite~ concat_assoc in H2.
  - apply* typ_app.
  - apply* typ_tru.
  - apply* typ_fls.
  - apply* typ_cond.
Qed.

(* ********************************************************************** *)
(** ** Properties of term substitution in terms *)

Lemma open_ee_rec_term_core : forall e j v u i, i <> j ->
open_ee_rec j v e = open_ee_rec i u (open_ee_rec j v e) ->
  e = open_ee_rec i u e.
Proof.
  induction e; introv Neq H; simpl in *; inversion H; f_equal*.
  case_nat*. case_nat*.
Qed.

Lemma open_ee_rec_term : forall u e,
  lc_exp e -> forall k, e = open_ee_rec k u e.
Proof.
  induction 1; intros; simpl; f_equal*.
  unfolds open_ee_rec. pick_fresh x.
   apply* (@open_ee_rec_term_core e 0 (e_fvar x)).
Qed.

(** Substitution for a fresh name is identity. *)

Lemma subst_ee_fresh : forall x u e,
  x \notin fv_ee e -> subst_ee x u e = e.
Proof.
  induction e; simpl; intros; f_equal*.
  case_var*.
Qed.

(** Substitution distributes on the open operation. *)

Lemma subst_ee_open_ee : forall t1 t2 u x, lc_exp u ->
subst_ee x u (open_ee t1 t2) =
open_ee (subst_ee x u t1) (subst_ee x u t2).
Proof.
  intros. unfold open_ee. generalize 0.
  induction t1; intros; simpls; f_equal*.
  case_var*. rewrite* <- open_ee_rec_term.
  case_nat*.
Qed.

(** Substitution and open_var for distinct names commute. *)

Lemma subst_ee_open_ee_var : forall x y u e, y <> x -> lc_exp u ->
  (subst_ee x u e) open_ee_var y = subst_ee x u (e open_ee_var y).
Proof.
  introv Neq Wu. rewrite* subst_ee_open_ee.
  simpl. case_var*.
Qed.

(** Opening up a body t with a type u is the same as opening
  up the abstraction with a fresh name x and then substituting u for x. *)

Lemma subst_ee_intro : forall x u e,
  x \notin fv_ee e -> lc_exp u ->
  open_ee e u = subst_ee x u (e open_ee_var x).
Proof.
  introv Fr Wu. rewrite* subst_ee_open_ee.
  rewrite* subst_ee_fresh. simpl. case_var*.
Qed.

Lemma typing_regular : forall E e T,
  typing E e T -> ok E /\ lc_exp e.
Proof.
  introv Typ. inductions Typ; auto.
  - split*.
    apply_fresh lc_abs as y.
    forwards*: H1 y.
  - split*.
  - split*.
Qed.

Lemma typing_through_subst_ee : forall E F x S e T s,
  typing (E & x ~ S & F) e T ->
  typing (E & F) s S ->
  typing (E & F) (subst_ee x s e) T.
Proof.
  introv TypT TypS.
  inductions TypT; simpl.
  - case_var.
    binds_get H0. auto.
    binds_cases H0; apply* typ_var.
  - apply_fresh* typ_abs as y.
    specialize (H1 y).
    forwards*: H1 E (F & y ~ T1) x S.
    rewrite~ concat_assoc.
    rewrite~ concat_assoc.
    apply_empty* typing_weakening.
    (* rewrite <- (concat_empty_r (E & F & y ~ T1)).
    apply* typing_weakening.
    rewrite~ concat_empty_r.
    rewrite~ concat_empty_r. *)
    rewrite~ concat_assoc in H2.
    rewrite~ subst_ee_open_ee_var.
    apply typing_regular in TypS.
    destruct~ TypS.
  - apply* typ_app.
  - apply* typ_tru.
  - apply* typ_fls.
  - apply* typ_cond.
Qed.

Lemma preservation : forall E e T e',
  typing E e T ->
  step e e' ->
  typing E e' T.
Proof.
  introv Typ red.
  gen e'. inductions Typ; intros; try solve [inverts red].
  - inverts red.
    eapply typ_app; eauto.
    eapply typ_app; eauto.
    inverts Typ1.
    pick_fresh y.
    forwards*: H7 y.
    rewrite <- (concat_empty_r E).
    rewrite <- (concat_empty_r (E & y ~ T1)) in H.
    rewrite~ (@subst_ee_intro y).
    forwards*: typing_through_subst_ee H.
    rewrite~ (concat_empty_r).
    forwards*: typing_regular Typ2.
  - inverts* red.
    apply* typ_cond.
Qed.


Require Import Coq.Program.Basics.
Require Import Coq.Logic.FunctionalExtensionality.

Definition surjective {A B : Type} (f : A -> B) :=
  forall (b : B), exists a, f a = b.

Definition injective {A B : Type} (f : A -> B) :=
  forall (a1 a2 : A), f a1 = f a2 -> a1 = a2.

Definition left_inverse {A B : Type} (f : A -> B) :=
  exists (g : B -> A), (forall a, g (f a) = a).

(* Permutations are bijections on an alphabet *)
Definition bijective {A B : Type} (f : A -> B) :=
  injective f /\ surjective f.

Theorem injective_composition :
  forall (A B C : Type) (f : A -> B) (g : B -> C),
    injective f ->
    injective g ->
    injective (compose g f).
Proof.
  intros A B C f g Hf Hg.
  unfold injective in *. unfold compose in *.
  intros a1 a2 H.
  apply Hg in H. apply Hf in H.
  assumption.
Qed.

Theorem composition_injective :
  forall (A B C : Type) (f : A -> B) (g : B -> C),
    injective (compose g f) ->
    surjective f ->
    injective f /\ injective g.
Proof.
  intros A B C f g Hinj Hsurj.
  unfold injective in *. unfold compose in *.
  split.
  - intros a1 a2 Hf.
    apply Hinj. rewrite Hf.
    reflexivity.
  - intros b1 b2 Hg.
    unfold surjective in Hsurj.
    destruct (Hsurj b1) as [a1 Hfa1].
    destruct (Hsurj b2) as [a2 Hfa2].
    subst.
    apply Hinj in Hg. subst.
    reflexivity.
Qed.

Theorem composition_surjective :
  forall (A B C : Type) (f : A -> B) (g : B -> C),
    surjective (compose g f) ->
    surjective g.
Proof.
  intros A B C f g H.
  unfold surjective in *.
  intros b. destruct (H b) as [a Hcomp].
  exists (f a). assumption.
Qed.

Theorem injective_id :
  forall (A : Type), injective (@id A).
Proof.
  unfold injective. intros A a1 a2 H.
  compute in H.
  assumption.
Qed.

Theorem surjective_id :
  forall (A : Type), surjective (@id A).
Proof.
  unfold surjective. intros A b.
  exists b.
  reflexivity.
Qed.

Theorem composition_id :
  forall (A B : Type) (f : A -> B) (g : B -> A),
  (forall a, g (f a) = a) -> compose g f = id.
Proof.
  intros A B f g H.
  apply functional_extensionality.
  apply H.
Qed.

Theorem composition_surjective_f :
  forall (A B : Type) (f : A -> B) (g : B -> A),
  surjective (compose g f) -> injective g -> surjective f.
Proof.
  unfold surjective.
  intros A B f g H Hinj b.
  pose proof (H (g b)). destruct H0.
  exists x. unfold compose in H0.
  apply Hinj in H0.
  assumption.
Qed.

Theorem to_compose :
  forall (A B C : Type) (f : A -> B) (g : B -> C) (a : A),
    g (f a) = (compose g f) a.
Proof.
  reflexivity.
Qed.

Theorem left_inverse_injective :
  forall {A B : Type} (f : A -> B),
    left_inverse f ->
    injective f.
Proof.
  intros A B f [g H].
  unfold injective.
  intros a1 a2 Hfa.
  apply f_equal with (f:=g) in Hfa.
  apply composition_id in H.
  rewrite to_compose with (f:=f) in Hfa.
  rewrite to_compose with (f:=f) in Hfa.
  rewrite H in Hfa.
  compute in Hfa.
  assumption.
Qed.

Theorem left_inverse_not_equal :
  forall {A B : Type} (f : A -> B) (a b : A),
    left_inverse f ->
    a <> b ->
    f a <> f b.
Proof.
  intros A B f a b [g Hinv] Hab.
  unfold not in *.
  intros Hfab.
  apply Hab.
  apply (f_equal g) in Hfab.
  repeat rewrite Hinv in Hfab.
  assumption.
Qed.

Theorem left_inverse_injective_on_domain :
  forall {A B : Type} (f : A -> B) (g : B -> A),
    (forall a, g (f a) = a) ->
    forall a1 a2, g (f a1) = g (f a2) -> f a1 = f a2.
Proof.
  intros A B f g H a1 a2 Hgf.
  repeat rewrite H in Hgf.
  subst. reflexivity.
Qed.


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

(** * denum: retracting various countable types into positives *)

Require Import common positives ordinal.
Set Implicit Arguments.

(** * Sums *)

Definition mk_sum (x: positive+positive) :=
  match x with
    | inl p => xO p
    | inr p => xI p
  end.
Definition get_sum x :=
  match x with
    | xO p => inl p
    | xI p => inr p
    | _ => assert_false (inl xH)
  end.
Lemma get_mk_sum x: get_sum (mk_sum x) = x.
Proof. now destruct x. Qed.

(** * Pairs *)

Fixpoint xpair y x :=
  match x with
    | xH => xI (xO y)
    | xO x => xO (xO (xpair y x))
    | xI x => xI (xI (xpair y x))
  end.
Definition mk_pair (x: positive*positive) := xpair (snd x) (fst x).
Fixpoint get_pair x :=
  match x with
    | xI (xO p) => (xH,p)
    | xO (xO x) => let '(x,y) := get_pair x in (xO x,y)
    | xI (xI x) => let '(x,y) := get_pair x in (xI x,y)
    | _ => assert_false (xH,xH)
  end.
Lemma get_mk_pair x: get_pair (mk_pair x) = x.
Proof.
  destruct x as [x y]. unfold mk_pair. simpl.
  induction x; simpl; now rewrite ?IHx.
Qed.

(** * Natural numbers *)

(** we use a much simpler function than the standard bijection,
   since we only need a retract *)
Definition mk_nat := nat_rec (fun _=>positive) xH (fun _ => xO).
Fixpoint get_nat x :=
  match x with
    | xH => O
    | xO x => S (get_nat x)
    | _ => assert_false O
  end.
Lemma get_mk_nat x: get_nat (mk_nat x) = x.
Proof. induction x; simpl; now rewrite ?IHx. Qed.

(** * Ordinals *)

Definition mk_ord n (x: ord n) := mk_nat x.
(** get_ord returns an option since [n] could be 0,
   this is not problematic in practice *)
Definition get_ord n (x: positive): option (ord n).
 set (y:=get_nat x). case (lt_ge_dec y n).
 intro Hy. exact (Some (Ord y Hy)).
 intros _. exact None.
Defined.
Lemma get_mk_ord n x: get_ord n (mk_ord x) = Some x.
Proof.
  unfold mk_ord, get_ord. destruct x as [i Hi]; simpl.
  rewrite get_mk_nat. case lt_ge_dec.
  intro. f_equal. now apply eq_ord.
  rewrite Hi at 1. discriminate.
Qed.


(*
   Here we prove that if a series converges absolutely, then every
   rearrangement of that series (1) converges absolutely, and (2)
   converges to the same value.  This is needed to show that the
   definition of expectation is sensible and matches alternate ways of
   defining it.
*)

From discprob.basic Require Import base order bigop_ext nify sval.
From discprob.prob Require Import countable.
Require Import Reals Fourier Omega Psatz ClassicalEpsilon.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype seq bigop fintype ssrnat choice.
From Coquelicot Require Import Rcomplements Rbar Series Lim_seq Hierarchy Markov.

Lemma sum_n_m_filter (a: nat → R) (P: pred nat) n m:
  sum_n_m (λ n, if P n then (Rabs (a n)) else 0) n m <= sum_n_m (Rabs \o a) n m.
Proof.
  apply sum_n_m_le => k. destruct (P k) => //=; try nra.
  apply Rabs_pos.
Qed.

Lemma foldl_max l:
  ∀ x, foldl max x l ≥ x.
Proof.
  induction l; rewrite //=; intros; try lia.
  specialize (IHl (Init.Nat.max x a)).
  etransitivity; eauto. apply Max.le_max_l.
Qed.

Lemma max_fun_range (σ: nat → nat) m:
  ∃ N, (∀ m', m' ≤ m → σ m' ≤ N) ∧ (∃ m0, m0 ≤ m ∧ σ m0 = N).
Proof.
  induction m.
  - exists (σ O). split.
    * by inversion 1.
    * exists O. split; auto.
  - destruct IHm as (N&?&Hachieve).
    exists (Init.Nat.max N (σ (S m))). split.
    * intros m'. inversion 1; subst.
      ** auto with *.
      ** etransitivity; last apply Max.le_max_l; eauto.
    * apply (Max.max_case_strong).
      ** intros. destruct Hachieve as (m0&?&?). exists m0; split; subst; auto.
      ** intros. exists (S m). split; auto.
Qed.

Section bijective.

Lemma bij_nat_cover (σ: nat → nat) (bij: bijective σ):
  ∀ n, ∃ m, ∀ m', m' ≥ m →
  ∃ N, (∀ n', n' ≤ n → ∃ m'', m'' ≤ m' ∧ σ m'' = n') ∧ N ≥ n ∧ (∀ m'', m'' ≤ m' → σ m'' ≤ N).
Proof.
  destruct bij as [σinv Hcan1 Hcan2].
  induction n.
  - exists (σinv O) => m' Hgem.
    edestruct (max_fun_range σ m') as (N&?&?).
    exists N; split.
    * intros n'. inversion 1; subst. exists (σinv O); repeat split; auto.
    * split; auto with *.
  - destruct IHn as (m&Hm). (* N&(IHm1&?&?)). *)
    exists (Init.Nat.max m (σinv (S n))) => m' Hgem.
    edestruct (max_fun_range σ (Init.Nat.max m' (σinv (S n)))) as (N'&Hbound&?).
    exists N'; repeat split.
    * intros n'. inversion 1; subst.
      ** exists (σinv (S n)). split; auto.
         transitivity (Init.Nat.max m (σinv (S n))); first apply Max.le_max_r; eauto.
      ** destruct (Hm m') as (N&(IHm1&?&?)).
         { etransitivity; eauto; first apply Max.le_max_l. }
         destruct (IHm1 n') as (x&?&?); auto.
    * specialize (Hbound (σinv (S n))).
      rewrite Hcan2 in Hbound. apply Hbound. auto with *.
    * intros m'' Hlem'. eapply Hbound. etransitivity; eauto. apply Max.le_max_l.
Qed.

Lemma sum_n_bij_sandwich (a: nat → R) (σ: nat → nat) (bij: bijective σ):
  ∀ n, ∃ m, ∀ m', m' ≥ m →
  ∃ n', n' ≥ n ∧ sum_n (Rabs \o a) n <= sum_n ((Rabs \o a) \o σ) m' <= sum_n (Rabs \o a) n'.
Proof.
  intros n; edestruct (bij_nat_cover σ bij n) as (m&Hm).
  exists m => m' Hgem.
  edestruct Hm as (N&(Hhit&?&Hup)); eauto.
  exists N. repeat split; auto.
  - rewrite ?sum_n_bigop //=.
    rewrite /index_enum.
    destruct bij as [σinv Hcan1 Hcan2].
    assert (Hupinv : ∀ n' : nat, n' ≤ n → σinv n' ≤ m').
    {
      intros n'. move /Hhit => [m''] [Hle Heq].
      rewrite -Heq Hcan1. done.
    }
    set (σinv' := λ x: 'I_(S n),
                  match x with
                    | Ordinal k Hle =>
                      Ordinal (proj2 (SSR_leq _ _) (le_n_S _ _ (Hupinv _ (proj1 (SSR_leq k n) Hle))))
                  end).
    apply (sum_reidx_map_le _ _ _ _ σinv').
    * intros (x&Hlex) ?. rewrite Hcan2. reflexivity.
    * intros; split; auto. rewrite -enumT mem_enum //=.
    * intros. apply Rle_ge, Rabs_pos.
    * rewrite -enumT. apply enum_uniq.
    * rewrite -enumT. apply enum_uniq.
    * intros (x&?) (y&?) => //= _. inversion 1. apply ord_inj => //=.
      apply (bij_inj (Bijective Hcan2 Hcan1)). done.
  - rewrite ?sum_n_bigop //=.
    rewrite /index_enum.
    set (σ' := λ x: 'I_(S m'),
                  match x with
                    | Ordinal k Hle =>
                      Ordinal (proj2 (SSR_leq _ _) (le_n_S _ _ (Hup _ (proj1 (SSR_leq k m') Hle))))
                  end).
    apply (sum_reidx_map_le _ _ _ _ σ').
    * intros (x&Hlex) ?. reflexivity.
    * intros; split; auto. rewrite -enumT mem_enum //=.
    * intros. apply Rle_ge, Rabs_pos.
    * rewrite -enumT. apply enum_uniq.
    * rewrite -enumT. apply enum_uniq.
    * intros (x&?) (y&?) => //= _. inversion 1. apply ord_inj => //=.
      apply (bij_inj bij). done.
Qed.

Lemma sum_n_m_bij_diff_abs (a: nat → R) (σ: nat → nat) (bij: bijective σ):
  ∀ N, ∃ M, ∀ m, m ≥ M →
  ∃ n, n ≥ N ∧ Rabs (sum_n (Rabs \o a \o σ) m - sum_n (Rabs \o a) N) <= sum_n_m (Rabs \o a) (S N) n.
Proof.
  intros N.
  destruct (sum_n_bij_sandwich a σ bij N) as (M&HM).
  exists M => m HgeM.
  edestruct (HM m HgeM) as (N'&?&(?&?)); eauto.
  exists N'; split; auto.
  rewrite (sum_n_m_sum_n); last done.
  rewrite Rabs_right; last nra.
  rewrite /minus/plus/opp/=. nra.
Qed.

Lemma sum_n_m_bij_diff (a: nat → R) (σ: nat → nat) (bij: bijective σ):
  ∀ N, ∃ M, ∀ m, m ≥ M →
  ∃ n, n ≥ N ∧ Rabs (sum_n (a \o σ) m - sum_n a N) <= sum_n_m (Rabs \o a) (S N) n.
Proof.
  intros n; edestruct (bij_nat_cover σ bij n) as (m&Hm).
  exists m => m' Hgem.
  edestruct Hm as (N&(Hhit&?&Hup)); eauto.
  exists N. repeat split; auto.
  transitivity (Rabs (\big[Rplus/0]_(S n <= i < S N | exC (λ m0, (leq m0 m') && (σ m0 == i))) (a i)));
    last first.
  {
    rewrite sum_n_m_bigop. etransitivity; first apply Rabs_bigop_triang.
    rewrite //=. apply Rabs_bigop_filter. auto.
  }
  right. f_equal.
  assert (sum_n (a \o σ) m' =
          \big[Rplus/0]_(i < S N | exC (λ m0, (m0 <= m')%nat && (σ m0 == i))) a i) as ->.
  {
    rewrite sum_n_bigop.
    rewrite /index_enum.
    set (σ' := λ x: 'I_(S m'),
                  match x with
                    | Ordinal k Hle =>
                      Ordinal (proj2 (SSR_leq _ _) (le_n_S _ _ (Hup _ (proj1 (SSR_leq k m') Hle))))
                  end).
    eapply (sum_reidx_map (Finite.enum (ordinal_finType m'.+1))
                          (Finite.enum (ordinal_finType N.+1))
                          (λ x, true) _ σ').
    * intros (x&Hlex) ? => //=.
    * intros (m0&?); split; auto. apply (introT (exCP _)).
      exists m0. apply /andP; split => //=.
    * intros (n'&?) _. move /exCP => [m0]. move /andP => [Hle Heq].
      intros Hfalse. contradiction Hfalse.
      assert (m0 < S m')%nat as Hlt.
      { nify.  omega. }
      exists (Ordinal Hlt). repeat split; eauto.
      apply ord_inj => //=. nify. done.
    * rewrite -enumT. apply enum_uniq.
    * rewrite -enumT. apply enum_uniq.
    * intros (x&?) (y&?)  _ => //=. inversion 1. apply ord_inj => //=.
      eapply bij_inj; eauto.
  }
  assert (sum_n a n =
          \big[Rplus/0]_(i < S n | exC (λ m0, (m0 <= m')%nat && (σ m0 == i))) a i) as ->.
  {
    rewrite sum_n_bigop.
    apply eq_bigl. intros (i&Hle).
    symmetry. eapply (introT (exCP _)).
    edestruct (Hhit i) as (m''&?&?); first by (nify; lia).
    exists m''. apply /andP; split; nify; auto.
  }
  rewrite -(big_mkord (λ i, exC (λ m0, (m0 <= m')%nat && (σ m0 == i)))).
  assert (S n <= S N)%nat as Hsplit by (nify; lia).
  rewrite (big_cat_nat _ _ _ _ Hsplit) //=.
  rewrite big_mkord.
  assert (∀ a b, a + b - a = b) as -> by (intros; field).
  done.
Qed.

Lemma norm_dist_mid x y z: norm (x - y) <= norm (x - z) + norm (z - y).
Proof.
  replace (x - y) with ((x - z) + (z - y)) by field.
  etransitivity; last eapply norm_triangle.
  apply Rle_refl.
Qed.
Lemma series_rearrange (a: nat → R) (σ: nat → nat) (bij: bijective σ) (v: R):
  is_series (λ n, Rabs (a n)) v →
  is_series (λ n, Rabs (a (σ n))) v ∧
  is_series (λ n, a (σ n)) (Series a).
Proof.
  intros Habsconv.
  assert (ex_series a) as (v'&Hconv) by (eapply ex_series_Rabs; eexists; eauto).
  assert(Hnorm: ∀ eps : posreal, ∃ N M, ∀ m, M ≤ m →
         norm (sum_n (Rabs \o a) N - sum_n (Rabs \o a \o σ) m) < eps ∧
         norm (sum_n a N - sum_n (a \o σ) m) < eps ∧
         norm (sum_n (Rabs \o a) N - v) < eps ∧
         norm (sum_n a N - v') < eps).
  {
    intros eps.
    edestruct (Cauchy_ex_series (Rabs \o a)) as (N0&IHN).
    { exists v; eauto. }
    assert (∃ N, ∀ N', N' ≥ N → norm (sum_n (Rabs \o a) N' - v) < eps) as (N1&HN1).
    { rewrite /is_series in Habsconv.
      edestruct Habsconv as (x&Hball). eapply locally_ball.
      exists x. eapply Hball.
    }
    assert (∃ N, ∀ N', N' ≥ N → norm (sum_n a N' - v') < eps) as (N2&HN2).
    { rewrite /is_series in Hconv.
      edestruct Hconv as (x&Hball). eapply locally_ball.
      exists x. eapply Hball.
    }
    set (N := max N0 (max N1 N2)).
    edestruct (sum_n_m_bij_diff_abs a σ bij N) as (M1&IHM1).
    edestruct (sum_n_m_bij_diff a σ bij N) as (M2&IHM2).
    exists N. exists (max M1 M2) => m Hle.
    apply Nat.max_lub_iff in Hle as (?&?).
    rewrite /norm//=/abs//=; repeat split; auto.
    - rewrite Rabs_minus_sym. edestruct (IHM1 m) as (n&?&Hle); auto.
      eapply Rle_lt_trans; first eapply Hle.
      rewrite /norm//=/abs//= in IHN.
      eapply Rle_lt_trans; first apply Rle_abs.
      assert (N0 <= N)%coq_nat.
      { rewrite /N. apply Max.le_max_l. }
      eapply IHN; auto. omega.
    - rewrite Rabs_minus_sym. edestruct (IHM2 m) as (n&?&Hle); auto.
      eapply Rle_lt_trans; first eapply Hle.
      rewrite /norm//=/abs//= in IHN.
      eapply Rle_lt_trans; first apply Rle_abs.
      assert (N0 <= N)%coq_nat.
      { rewrite /N. apply Max.le_max_l. }
      eapply IHN; auto. omega.
    - eapply HN1.
      rewrite /N. etransitivity; first apply Max.le_max_r. apply Max.le_max_l.
    - eapply HN2.
      rewrite /N. etransitivity; first apply Max.le_max_r. apply Max.le_max_r.
  }
  split.
  - rewrite /is_series. eapply filterlim_locally => eps.
    edestruct (Hnorm (pos_div_2 eps)) as (N&M&?HNM).
    exists M => m Hle.
    specialize (HNM m Hle) as (?&?&?&?).
    rewrite /ball//=/AbsRing_ball//=/abs/AbsRing.abs//=/minus//=/plus//=/opp//=.
    specialize (norm_dist_mid (sum_n (Rabs \o a \o σ) m) v (sum_n (Rabs \o a) N)).
    rewrite {1}/norm//={1}/Rminus.
    intros Hle'. eapply Rle_lt_trans; first eapply Hle'.
    destruct eps as (eps&?).
    replace (eps) with (eps/2 + eps/2); last by field.
    apply Rplus_lt_compat; eauto.
    rewrite /norm//=/abs//= Rabs_minus_sym. done.
  - assert (Series a = v') as -> by (eapply is_series_unique; eauto).
    rewrite /is_series. eapply filterlim_locally => eps.
    edestruct (Hnorm (pos_div_2 eps)) as (N&M&?HNM).
    exists M => m Hle.
    specialize (HNM m Hle) as (?&?&?&?).
    rewrite /ball//=/AbsRing_ball//=/abs/AbsRing.abs//=/minus//=/plus//=/opp//=.
    specialize (norm_dist_mid (sum_n (a \o σ) m) v' (sum_n a N)).
    rewrite {1}/norm//={1}/Rminus.
    intros Hle'. eapply Rle_lt_trans; first eapply Hle'.
    destruct eps as (eps&?).
    replace (eps) with (eps/2 + eps/2); last by field.
    apply Rplus_lt_compat; eauto.
    rewrite /norm//=/abs//= Rabs_minus_sym. done.
Qed.

End bijective.

Section covering.

Variable (a: nat → R).
Variable (σ: nat → nat).
Variable (INJ: ∀ n n', a (σ n) <> 0 → σ n = σ n' → n = n').
Variable (COV: ∀ n, a n <> 0 → ∃ m, σ m = n).

Lemma inj_nat_cover:
  ∀ n, ∃ m, ∀ m', m' ≥ m →
  ∃ N, (∀ n', n' ≤ n → (∃ m'', m'' ≤ m' ∧ σ m'' = n') ∨ a n' = 0)
       ∧ N ≥ n ∧ (∀ m'', m'' ≤ m' → σ m'' ≤ N).
Proof.
  induction n.
  - destruct (Req_dec (a O) 0) as [|Hneq].
    * exists O => m' Hge.
      edestruct (max_fun_range σ m') as (N&?&?).
      exists N; split.
      ** intros n'. inversion 1. subst. auto.
      ** split; auto with *.
    * edestruct (COV O Hneq) as (m&?).
      exists m => m'.
      edestruct (max_fun_range σ m') as (N&?&?).
      exists N; split.
      ** intros n'. inversion 1. subst. left. eauto.
      ** split; auto with *.
  - destruct IHn as (m&Hm).
    destruct (Req_dec (a (S n)) 0) as [|Hneq].
    * exists m => m' Hge.
      edestruct Hm as (N&?&?&?); eauto.
      exists (S N); repeat split; auto; last omega.
      intros n'. inversion 1; subst; auto.
    * edestruct (COV (S n) Hneq) as (minv&Heq).
    exists (Init.Nat.max m minv) => m' Hgem.
    edestruct (max_fun_range σ (Init.Nat.max m' minv)) as (N'&Hbound&?).
    exists N'; repeat split.
    ** intros n'. inversion 1; subst. left.
      *** exists minv. split; auto.
         transitivity (Init.Nat.max m minv); first apply Max.le_max_r; eauto.
      *** destruct (Hm m') as (N&(IHm1&?&?)).
         { etransitivity; eauto; first apply Max.le_max_l. }
         eauto.
    ** specialize (Hbound minv).
       rewrite -Heq. eapply Hbound. apply Max.le_max_r.
    ** intros m'' Hlem'. eapply Hbound. etransitivity; eauto. apply Max.le_max_l.
Qed.

Lemma sum_n_m_cover_diff:
  ∀ N, ∃ M, ∀ m, m ≥ M →
  ∃ n, n ≥ N ∧ Rabs (sum_n (a \o σ) m - sum_n a N) <= sum_n_m (Rabs \o a) (S N) n.
Proof.
  intros n; edestruct (inj_nat_cover n) as (m&Hm).
  exists m => m' Hgem.
  edestruct Hm as (N&(Hhit&?&Hup)); eauto.
  exists N. repeat split; auto.
  transitivity (Rabs (\big[Rplus/0]_(S n <= i < S N | exC (λ m0, (leq m0 m') && (σ m0 == i))) (a i)));
    last first.
  {
    rewrite sum_n_m_bigop. etransitivity; first apply Rabs_bigop_triang.
    rewrite //=. apply Rabs_bigop_filter. auto.
  }
  right. f_equal.
  assert (sum_n (a \o σ) m' =
          \big[Rplus/0]_(i < S N | exC (λ m0, (m0 <= m')%nat && (σ m0 == i))) a i) as ->.
  {
    rewrite sum_n_bigop.
    rewrite bigop_cond_non0 [a in _ = a]bigop_cond_non0.
    rewrite /index_enum.
    set (σ' := λ x: 'I_(S m'),
                  match x with
                    | Ordinal k Hle =>
                      Ordinal (proj2 (SSR_leq _ _) (le_n_S _ _ (Hup _ (proj1 (SSR_leq k m') Hle))))
                  end).
    eapply (sum_reidx_map (Finite.enum (ordinal_finType m'.+1))
                          (Finite.enum (ordinal_finType N.+1))
                          _ _ σ').
    * intros (x&Hlex) ? => //=.
    * intros (m0&?); split; auto. apply /andP; split; auto. apply (introT (exCP _)).
      exists m0. apply /andP; split => //=.
    * intros (n'&?) _. move /andP => [HexC ?]. move /exCP in HexC.
      destruct (HexC) as (m0&HexC'). move /andP in HexC'.  destruct (HexC') as (?&Heq).
      intros Hfalse. contradiction Hfalse.
      assert (m0 < S m')%nat as Hlt.
      { nify.  omega. }
      exists (Ordinal Hlt). repeat split; auto.
      ** apply /andP; split; auto. rewrite //=. move /eqP in Heq. rewrite Heq. done.
      ** apply ord_inj => //=. nify. done.
    * rewrite -enumT. apply enum_uniq.
    * rewrite -enumT. apply enum_uniq.
    * intros (x&?) (y&?) Hneq0 => //=. inversion 1. apply ord_inj => //=.
      eapply INJ; eauto. move /eqP. move /negP in Hneq0. auto.
  }
  assert (sum_n a n =
          \big[Rplus/0]_(i < S n | exC (λ m0, (m0 <= m')%nat && (σ m0 == i))) a i) as ->.
  {
    rewrite sum_n_bigop.
    rewrite bigop_cond_non0 [a in _ = a]bigop_cond_non0.
    eapply (sum_reidx_map _ _ _ _ id).
    * intros (x&Hlex) ? => //=.
    * intros (n'&Hle) ? Hneq0; split; auto. apply /andP; split; auto. apply (introT (exCP _)).
      edestruct (Hhit n') as [(m''&?&?)|].
      { clear -Hle. nify. omega. }
      ** exists m''. apply /andP; split; nify; try omega => //=. subst. done.
      ** exfalso. rewrite //= in Hneq0. move /eqP in Hneq0. auto.
    * intros (n'&Hle) _. move /andP => [HexC ?]. move /exCP in HexC.
      destruct (HexC) as (m0&HexC'). move /andP in HexC'.  destruct (HexC') as (?&Heq).
      intros Hfalse. exfalso. eapply Hfalse. exists (Ordinal Hle). repeat split; auto.
    * rewrite /index_enum. rewrite -enumT. apply enum_uniq.
    * rewrite /index_enum. rewrite -enumT. apply enum_uniq.
    * intros (x&?) (y&?) => //=.
  }
  rewrite -(big_mkord (λ i, exC (λ m0, (m0 <= m')%nat && (σ m0 == i)))).
  assert (S n <= S N)%nat as Hsplit by (nify; lia).
  rewrite (big_cat_nat _ _ _ _ Hsplit) //=.
  rewrite big_mkord.
  assert (∀ a b, a + b - a = b) as -> by (intros; field).
  done.
Qed.

End covering.

Lemma series_rearrange_covering (a: nat → R) (σ: nat → nat)
      (INJ: ∀ n n', a (σ n) <> 0 → σ n = σ n' → n = n')
      (COV: ∀ n, a n <> 0 → ∃ m, σ m = n)
      (v: R):
  is_series (λ n, Rabs (a n)) v →
  is_series (λ n, Rabs (a (σ n))) v ∧
  is_series (λ n, a (σ n)) (Series a).
Proof.
  intros Habsconv.
  assert (ex_series a) as (v'&Hconv) by (eapply ex_series_Rabs; eexists; eauto).
  assert(Hnorm: ∀ eps : posreal, ∃ N M, ∀ m, M ≤ m →
         norm (sum_n (Rabs \o a) N - sum_n (Rabs \o a \o σ) m) < eps ∧
         norm (sum_n a N - sum_n (a \o σ) m) < eps ∧
         norm (sum_n (Rabs \o a) N - v) < eps ∧
         norm (sum_n a N - v') < eps).
  {
    intros eps.
    edestruct (Cauchy_ex_series (Rabs \o a)) as (N0&IHN).
    { exists v; eauto. }
    assert (∃ N, ∀ N', N' ≥ N → norm (sum_n (Rabs \o a) N' - v) < eps) as (N1&HN1).
    { rewrite /is_series in Habsconv.
      edestruct Habsconv as (x&Hball). eapply locally_ball.
      exists x. eapply Hball.
    }
    assert (∃ N, ∀ N', N' ≥ N → norm (sum_n a N' - v') < eps) as (N2&HN2).
    { rewrite /is_series in Hconv.
      edestruct Hconv as (x&Hball). eapply locally_ball.
      exists x. eapply Hball.
    }
    set (N := max N0 (max N1 N2)).
    edestruct (sum_n_m_cover_diff (Rabs \o a) σ) as (M1&IHM1).
    {  rewrite //= => n n'. intros Hneq0. apply INJ; eauto.
       intros Heq0. rewrite Heq0 Rabs_R0 in Hneq0. auto.
    }
    {
      rewrite //= => n. intros Hneq0. eapply COV.
       intros Heq0. rewrite Heq0 Rabs_R0 in Hneq0. auto.
    }
    edestruct (sum_n_m_cover_diff a σ INJ COV N) as (M2&IHM2).
    exists N. exists (max M1 M2) => m Hle.
    apply Nat.max_lub_iff in Hle as (?&?).
    rewrite /norm//=/abs//=; repeat split; auto.
    - rewrite Rabs_minus_sym. edestruct (IHM1 m) as (n&?&Hle); auto.
      eapply Rle_lt_trans; first eapply Hle.
      rewrite /norm//=/abs//= in IHN.
      eapply Rle_lt_trans; first apply Rle_abs.
      assert (N0 <= N)%coq_nat.
      { rewrite /N. apply Max.le_max_l. }
      eapply Rle_lt_trans; last apply (IHN (S N) n); auto; try omega.
      right. f_equal. apply sum_n_m_ext_loc; auto.
      intros => //=. rewrite //= Rabs_Rabsolu. done.
    - rewrite Rabs_minus_sym. edestruct (IHM2 m) as (n&?&Hle); auto.
      eapply Rle_lt_trans; first eapply Hle.
      rewrite /norm//=/abs//= in IHN.
      eapply Rle_lt_trans; first apply Rle_abs.
      assert (N0 <= N)%coq_nat.
      { rewrite /N. apply Max.le_max_l. }
      eapply IHN; auto. omega.
    - eapply HN1.
      rewrite /N. etransitivity; first apply Max.le_max_r. apply Max.le_max_l.
    - eapply HN2.
      rewrite /N. etransitivity; first apply Max.le_max_r. apply Max.le_max_r.
  }
  split.
  - rewrite /is_series. eapply filterlim_locally => eps.
    edestruct (Hnorm (pos_div_2 eps)) as (N&M&?HNM).
    exists M => m Hle.
    specialize (HNM m Hle) as (?&?&?&?).
    rewrite /ball//=/AbsRing_ball//=/abs/AbsRing.abs//=/minus//=/plus//=/opp//=.
    specialize (norm_dist_mid (sum_n (Rabs \o a \o σ) m) v (sum_n (Rabs \o a) N)).
    rewrite {1}/norm//={1}/Rminus.
    intros Hle'. eapply Rle_lt_trans; first eapply Hle'.
    destruct eps as (eps&?).
    replace (eps) with (eps/2 + eps/2); last by field.
    apply Rplus_lt_compat; eauto.
    rewrite /norm//=/abs//= Rabs_minus_sym. done.
  - assert (Series a = v') as -> by (eapply is_series_unique; eauto).
    rewrite /is_series. eapply filterlim_locally => eps.
    edestruct (Hnorm (pos_div_2 eps)) as (N&M&?HNM).
    exists M => m Hle.
    specialize (HNM m Hle) as (?&?&?&?).
    rewrite /ball//=/AbsRing_ball//=/abs/AbsRing.abs//=/minus//=/plus//=/opp//=.
    specialize (norm_dist_mid (sum_n (a \o σ) m) v' (sum_n a N)).
    rewrite {1}/norm//={1}/Rminus.
    intros Hle'. eapply Rle_lt_trans; first eapply Hle'.
    destruct eps as (eps&?).
    replace (eps) with (eps/2 + eps/2); last by field.
    apply Rplus_lt_compat; eauto.
    rewrite /norm//=/abs//= Rabs_minus_sym. done.
Qed.

Lemma series_rearrange_covering_pos (a: nat → R) (σ: nat → nat)
      (INJ: ∀ n n', a (σ n) <> 0 → σ n = σ n' → n = n')
      (COV: ∀ n, a n <> 0 → ∃ m, σ m = n)
      (POS: ∀ n, a n >= 0)
      (v: R):
  is_series a v →
  is_series (λ n, a (σ n)) v.
Proof.
  intros. eapply (is_series_ext (λ n, Rabs (a (σ n)))).
  { intros n. rewrite Rabs_right; auto. }
  edestruct series_rearrange_covering as (His1&?); last eapply His1; eauto.
  eapply is_series_ext; eauto.
  { intros n. rewrite Rabs_right; auto. }
Qed.

Lemma Series_rearrange_covering (a: nat → R) (σ: nat → nat)
      (INJ: ∀ n n', a (σ n) <> 0 → σ n = σ n' → n = n')
      (COV: ∀ n, a n <> 0 → ∃ m, σ m = n):
  ex_series (λ n, Rabs (a n)) →
  Series a = Series (a \o σ).
Proof.
  intros (v'&?).
  symmetry. apply is_series_unique. edestruct series_rearrange_covering; eauto.
Qed.

Lemma countable_series_rearrange_covering {Y X: countType}
      (a: X → R) (σ: Y → X)
      (INJ: ∀ n n', a (σ n) <> 0 → σ n = σ n' → n = n')
      (COV: ∀ n, a n <> 0 → ∃ m, σ m = n)
      (v: R):
  is_series (countable_sum (λ n, Rabs (a n))) v →
  is_series (countable_sum (λ n, Rabs (a (σ n)))) v ∧
  is_series (countable_sum (λ n, a (σ n))) (Series (countable_sum a)).
Proof.
  set (a' := λ n, match n with | O => 0 | S n' => countable_sum a n' end).
  set (σ' := λ n, match @pickle_inv Y n with
                  | Some x =>
                    S (pickle (σ x))
                  | None => O
                  end).
  intros His. edestruct (series_rearrange_covering a' σ') as (Habs&?).
  { intros n n'. rewrite /σ'/a'/countable_sum/oapp//=.
    destruct (@pickle_inv Y n) as [s|] eqn:Heqs.
    * rewrite pickleK_inv.
      destruct (@pickle_inv Y n') as [s'|] eqn:Heqs'.
      ** intros ? HeqS. inversion HeqS as [Heq]. apply pickle_inj in Heq.
         assert (s = s').
         { eapply INJ; eauto. }
         subst. eapply pickle_inv_some_inj; eauto; congruence.
      ** intros Hneq0 Hpickle. inversion Hpickle.
    * nra.
  }
  {
    intros n. rewrite /a'/countable_sum/σ'//=.
    destruct n as [|n]; first nra.
    destruct (@pickle_inv X n) as [s|] eqn:Heqs.
    * rewrite //= => Hneq0.  edestruct (COV _ Hneq0) as (m&Heqm).
      exists (pickle m). rewrite pickleK_inv => //=. subst.
      f_equal.
      eapply pickle_inv_some_inv; eauto.
    * rewrite //=; nra.
  }
  {
    rewrite /a'.
    apply: is_series_decr_1.
    rewrite Rabs_R0 /opp//= Ropp_0/plus//= Rplus_0_r.
    eapply is_series_ext; last eassumption.
    intros n. rewrite /countable_sum//=. destruct pickle_inv => //=.
    by rewrite Rabs_R0.
  }
  split.
  * eapply is_series_ext; last eapply Habs.
    intros n. rewrite /a'/countable_sum/σ'//=.
    destruct (@pickle_inv Y n) as [s|] eqn:Heqs.
    ** rewrite pickleK_inv //=.
    ** rewrite //= Rabs_R0 //=.
  * assert (Series a' = Series (countable_sum a)) as Heq.
    { rewrite /a'. by eapply Series_incr_1_aux. }
    rewrite -Heq.
    eapply is_series_ext; last eassumption.
    intros n. rewrite /a'/countable_sum/σ'//=.
    destruct (@pickle_inv Y n) as [s|] eqn:Heqs.
    ** rewrite pickleK_inv //=.
    ** rewrite //=.
Qed.

Lemma countable_series_oapp {X: countType}
      (a: X → R) (v: R):
  is_series (countable_sum (λ n, Rabs (oapp a R0 n))) v →
  is_series (countable_sum (λ n, Rabs (a n))) v ∧
  is_series (countable_sum (λ n, a n)) (Series (countable_sum (oapp a R0))).
Proof.
  intros. edestruct (countable_series_rearrange_covering (oapp a R0) Some) as (Habs&?).
  { rewrite //=. intros. congruence. }
  { rewrite //=. intros [|]; rewrite //=; (eauto || nra). }
  { eauto. }
  split.
  * eapply is_series_ext; last eapply Habs.
    intros n. rewrite //=.
  * eapply is_series_ext; eauto.
Qed.

Lemma countable_series_oapp' {X: countType}
      (a: X → R) (v: R):
  is_series (countable_sum (λ n, Rabs (a n))) v →
  is_series (countable_sum (λ n, Rabs (oapp a R0 n))) v ∧
  is_series (countable_sum (oapp a R0)) (Series (countable_sum a)).
Proof.
  intros His.
  set (a' := λ n, match n with | O => 0 | S n' => countable_sum a n' end).
  set (σ' := λ n, match @pickle_inv (option_countType X) n with
                  | Some (Some x) =>
                    S (pickle x)
                  | _ => O
                  end).
  edestruct (series_rearrange_covering a' σ') as (Habs&?).
  { intros n n'. rewrite /σ'/a'/countable_sum/oapp//=.
    destruct (@pickle_inv (option_countType X) n) as [[s|]|] eqn:Heqs.
    * rewrite pickleK_inv.
      destruct (@pickle_inv (option_countType X) n') as [[s'|]|] eqn:Heqs'.
      ** intros ? HeqS. inversion HeqS as [Heq]. apply pickle_inj in Heq.
         subst. eapply pickle_inv_some_inj; eauto; congruence.
      ** intros Hneq0 Hpickle. inversion Hpickle.
      ** intros Hneq0 Hpickle. inversion Hpickle.
    * nra.
    * congruence.
  }
  {
    intros n. rewrite /a'/countable_sum/σ'//=.
    destruct n as [|n]; first nra.
    destruct (@pickle_inv X n) as [s|] eqn:Heqs => //=.
    * rewrite //= => Hneq0.
      exists (pickle (Some s)). rewrite pickleK_inv => //=. f_equal.
      eapply pickle_inv_some_inv; eauto.
  }
  {
    rewrite /a'.
    apply: is_series_decr_1.
    rewrite Rabs_R0 /opp//= Ropp_0/plus//= Rplus_0_r.
    eapply is_series_ext; last eassumption.
    intros n. rewrite /countable_sum//=. destruct pickle_inv => //=.
    by rewrite Rabs_R0.
  }
  split.
  * eapply is_series_ext; last eapply Habs.
    intros n. rewrite /a'/countable_sum/σ'//=.
    destruct (@pickle_inv (option_countType X) n) as [[s|]|] eqn:Heqs.
    ** rewrite pickleK_inv //=.
    ** rewrite //= Rabs_R0 //=.
    ** rewrite //= Rabs_R0 //=.
  * assert (Series a' = Series (countable_sum a)) as Heq.
    { rewrite /a'. by eapply Series_incr_1_aux. }
    rewrite -Heq.
    eapply is_series_ext; last eassumption.
    intros n. rewrite /a'/countable_sum/σ'//=.
    destruct (@pickle_inv (option_countType X) n) as [[s|]|] eqn:Heqs.
    ** rewrite pickleK_inv //=.
    ** rewrite //=.
    ** rewrite //=.
Qed.

Lemma countable_Series_oapp' {X: countType}
      (a: X → R):
  ex_series (countable_sum (λ n, Rabs (a n))) →
  Series (countable_sum a) = Series (countable_sum (oapp a R0)).
Proof.
  intros (v&Hex).
  edestruct (countable_series_oapp' a); eauto.
  symmetry. apply is_series_unique; eauto.
Qed.

Remark gt_support_conv {X: countType} (b: X → R): ∀ x, b x > 0 → support b.
Proof.
  intros x Hgt. exists x. destruct (Rgt_dec (b x) 0); auto.
Defined.

Lemma countable_series_rearrange_covering_match {X Y: countType}
      (a: X → R) (b: Y → R) (σ: support b → support a)
      (Hapos: ∀ x, a x >= 0)
      (Hbpos: ∀ x, b x >= 0)
      (INJ: ∀ n n', σ n = σ n' → n = n')
      (COV: ∀ n, ∃ m, σ m = n)
      (EQ: ∀ n, a (sval (σ n)) = b (sval n))
      (v: R):
  is_series (countable_sum (λ n, a n)) v →
  is_series (countable_sum (λ n, b n)) v.
Proof.
  intros His.
  set (σ':=
         λ y, match Rgt_dec (b y) 0 with
              | left Hpf =>
                Some (sval (σ (gt_support_conv _ _ Hpf)))
              | _  => None
              end).
    cut (is_series (countable_sum (λ n, Rabs (oapp a R0 (σ' n)))) v).
    { intros Hext. eapply is_series_ext; last eapply Hext.
      intros n. rewrite /countable_sum/σ'//=.
      destruct pickle_inv as [s|] => //=.
      { destruct Rgt_dec => //=.
        * rewrite EQ //=; try nra.
          rewrite Rabs_right; nra.
        * rewrite Rabs_R0. destruct (Hbpos s); nra.
      }
    }
  edestruct (countable_series_rearrange_covering (oapp a R0) σ').
  { rewrite /σ'. intros n n'. do 2 destruct Rgt_dec => //=.
    intros Hneq0 Heq. inversion Heq as [Heq']. apply sval_inj_pi in Heq'. eapply INJ in Heq'.
    inversion Heq'. done.
  }
  { intros [s|] => //=. intros Hneq0.
    destruct (Hapos s) as [Hgt0|Heq0]; last nra.
    destruct (COV (gt_support_conv a s Hgt0)) as (y&Heqy).
    exists (sval y). rewrite /σ'.
    destruct Rgt_dec as [|Hngt]; last first.
    { destruct y as (y&Hgt). simpl in Hngt. exfalso. clear -Hngt Hgt. destruct Rgt_dec; auto. }
    f_equal. transitivity (sval (σ y)).
    { do 2 f_equal. apply sval_inj_pred => //=. }
    rewrite Heqy => //=.
  }
  { edestruct (countable_series_oapp' a).
    { eapply is_series_ext; last eassumption.
      rewrite /countable_sum => n. destruct (@pickle_inv X n) => //=.
      rewrite Rabs_right; eauto.
    }
    eauto.
  }
  eauto.
Qed.

Lemma countable_series_rearrange_covering_match_fun {X Y: countType}
      (a: X → R) (b: Y → R) (σ: {x : Y | b x ≠ 0} → { x : X | a x ≠ 0 })
   (*   (Hapos: ∀ x, a x >= 0)
      (Hbpos: ∀ x, b x >= 0)  *)
      (INJ: ∀ n n', σ n = σ n' → n = n')
      (COV: ∀ n, ∃ m, σ m = n)
      (EQ: ∀ n, a (sval (σ n)) = b (sval n))
      (v: R):
  is_series (countable_sum (λ n, Rabs (a n))) v →
  is_series (countable_sum (λ n, Rabs (b n))) v ∧
  is_series (countable_sum b) (Series (countable_sum a)).
Proof.
  intros His.
  set (σ':=
         λ y, match Req_EM_T (b y) 0 with
              | right Hpf =>
                Some (sval (σ (exist _ y Hpf)))
              | _  => None
              end).
  assert (Hext0: ∀ n : nat, countable_sum (λ n0 : Y, (oapp a R0 (σ' n0))) n
                           = countable_sum (λ n0 : Y, (b n0)) n).
  {
      intros n. rewrite /countable_sum/σ'//=.
      destruct pickle_inv as [s|] => //=.
      { destruct Req_EM_T as [Heq0|Hneq0] => //=.
        rewrite //=. eapply EQ.
      }
  }
  cut (is_series (countable_sum (λ n, Rabs (oapp a R0 (σ' n)))) v ∧
       is_series (countable_sum (λ n, oapp a R0 (σ' n))) (Series (countable_sum a))).
  { intros (Hext_abs&Hext). split.
    * eapply is_series_ext; last eapply Hext_abs.
      intros n. rewrite ?countable_sum_Rabs. f_equal; eauto.
    * eapply is_series_ext; last eapply Hext.
      intros n. eauto.
  }
  edestruct (countable_series_rearrange_covering (oapp a R0) σ').
  { rewrite /σ'. intros n n'. do 2 destruct Req_EM_T => //=.
    intros Hneq0 Heq. inversion Heq as [Heq']. apply sval_inj_pi in Heq'. eapply INJ in Heq'.
    inversion Heq'. done.
  }
  { intros [s|] => //=. intros Hneq0.
    destruct (COV (exist _ s Hneq0)) as (y&Heqy).
    exists (sval y). rewrite /σ'.
    destruct Req_EM_T as [Hngt|].
    { destruct y as (y&Hgt). simpl in Hngt. exfalso. clear -Hngt Hgt. congruence. }
    f_equal. transitivity (sval (σ y)).
    { do 2 f_equal. apply sval_inj_pi => //=. }
    rewrite Heqy => //=.
  }
  { edestruct (countable_series_oapp' a).
    { eapply is_series_ext; last eassumption.
      rewrite /countable_sum => n. destruct (@pickle_inv X n) => //=.
    }
    eauto.
  }
  split; eauto.
  rewrite countable_Series_oapp'; eauto.
  eexists; eauto.
Qed.


From CoqMTL Require Export Base.

(** This module aims to check whether [Applicative]'s laws are orthogonal,
    i.e. independent from each other. We take an axiomatic approach.

    First we postulate the existence of a thing [F] that has some functions
    named [fmap], [pure] and [ap]. *)

Axiom
  (F : Type -> Type)
  (fmap : forall {A B : Type}, (A -> B) -> F A -> F B)
  (pure : forall {A : Type}, A -> F A)
  (ap : forall {A B : Type}, F (A -> B) -> F A -> F B).

(** We introduce familiar notations. *)

Notation "f <*> x" := (ap f x)
  (left associativity, at level 40).

(** Then we define various laws that this [F] can possibly satisfy. *)

Definition fmap_id : Prop :=
  forall A : Type, fmap (@id A) = id.

Definition fmap_comp : Prop :=
  forall (A B C : Type) (f : A -> B) (g : B -> C),
    fmap (f .> g) = fmap f .> fmap g.

Definition identity : Prop :=
  forall (A : Type) (ax : F A), ap (pure id) ax = ax.

Definition composition : Prop :=
  forall (A B C : Type) (af : F (A -> B)) (ag : F (B  -> C)) (ax : F A),
    ap (ap (ap (pure compose) ag) af) ax = ap ag (ap af ax).

Definition homomorphism : Prop :=
  forall (A B : Type) (f : A -> B) (x : A),
    ap (pure f) (pure x) = pure (f x).

Definition interchange : Prop :=
  forall (A B : Type) (f : F (A -> B)) (x : A),
    ap f (pure x) = ap (pure (fun f => f x)) f.

Definition fmap_pure_ap : Prop :=
  forall (A B : Type) (f : A -> B) (x : F A),
    fmap f x = ap (pure f) x.

(** This law is some kind of alternative for [fmap_pure_ap]. *)
Definition fmap_pure : Prop :=
  forall (A B : Type) (f : A -> B) (x : A),
    fmap f (pure x) = pure (f x).

(** Finally we try to derive some of these laws from others. It turns out
    that [identity] follows from [fmap_pure_ap] and the functor laws. *)

Lemma identity' :
  fmap_pure_ap -> fmap_id -> identity.
Proof.
  compute. intros fmap_pure_ap fmap_id A x.
  rewrite <- fmap_pure_ap, fmap_id. reflexivity.
Qed.

Lemma homomorphism' :
  fmap_pure_ap -> fmap_pure -> homomorphism.
Proof.
  compute. intros fmap_pure_ap fmap_pure A B f x.
  rewrite <- fmap_pure_ap, fmap_pure. reflexivity.
Qed.

Lemma fmap_id' :
  fmap_pure_ap -> identity -> fmap_id.
Proof.
  compute. intros fmap_pure_ap identity A.
  ext a. rewrite fmap_pure_ap, identity.
  reflexivity.
Qed.

Lemma fmap_pure' :
  fmap_pure_ap -> homomorphism -> fmap_pure.
Proof.
  compute. intros fmap_pure_ap homomorphism A B f x.
  rewrite fmap_pure_ap, homomorphism. reflexivity.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
From adtind Require Import goal20.

Set Printing Depth 1000.
Definition lfind_eval  x n:=
Cons n x.

Compute lfind_eval  (Cons (Succ (Succ (Succ Zero))) (Cons Zero Nil)) (Zero).

Compute lfind_eval  (Cons Zero (Cons (Succ (Succ (Succ Zero))) Nil)) (Zero).

Compute lfind_eval  (Nil) (Succ (Succ Zero)).

Compute lfind_eval  (Cons (Succ Zero) (Cons (Succ (Succ (Succ Zero))) Nil)) (Zero).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Succ Zero).

Compute lfind_eval  (Cons (Succ Zero) (Cons (Succ (Succ Zero)) Nil)) (Succ (Succ Zero)).

Compute lfind_eval  (Cons (Succ (Succ (Succ Zero))) (Cons (Succ (Succ Zero)) Nil)) (Succ Zero).

Compute lfind_eval  (Cons Zero (Cons (Succ Zero) (Cons Zero Nil))) (Succ (Succ (Succ Zero))).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Zero).

Compute lfind_eval  (Nil) (Succ Zero).

Compute lfind_eval  (Cons Zero (Cons Zero Nil)) (Zero).

Compute lfind_eval  (Nil) (Succ (Succ (Succ (Succ Zero)))).

Compute lfind_eval  (Cons Zero Nil) (Succ Zero).

Compute lfind_eval  (Cons Zero (Cons (Succ Zero) (Cons Zero Nil))) (Zero).

Compute lfind_eval  (Cons Zero Nil) (Zero).

Compute lfind_eval  (Cons (Succ Zero) (Cons Zero Nil)) (Zero).

Compute lfind_eval  (Cons Zero Nil) (Succ (Succ Zero)).

Compute lfind_eval  (Cons Zero (Cons Zero (Cons Zero (Cons Zero (Cons (Succ Zero) Nil))))) (Zero).

Compute lfind_eval  (Nil) (Zero).


Require Import BenB.

(*
  Eerst leggen we de basisproposities vast.
*)

Variable G1: Prop. (* Het goud zit in koffer 1. *)
Variable G2: Prop. (* Het goud zit in koffer 2. *)
Variable G3: Prop. (* Het goud zit in koffer 3. *)
Variable G4: Prop. (* Het goud zit in koffer 4. *)

(*
  Daarna leggen we de daaruit afgeleide uitspraken vast.
*)

Definition K1 := G2     . (* Het goud zit in koffer 2. *)
Definition K2 := ~G1 /\ ~G3 /\ ~G4      . (* Alle andere koffers zijn leeg. *)
Definition K3 := G3     . (* Deze koffer bevat goud. *)
Definition K4 := ~G4      . (* Deze koffer is leeg. *)

(*
  En vervolgens maken we wat hulpdefinities.

  Vul de definities aan waar dat nodig is!
*)

Definition erIsMinimaalEenKofferMetGoud :=
G1 \/ G2 \/ G3 \/ G4.

Definition erIsMaximaalEenKofferMetGoud :=
~(G1\/G2\/G3) \/ ~(G1\/G2\/G4) \/ ~(G1\/G3\/G4) \/ ~(G2\/G3\/G4).

Definition erIsPreciesEenKofferMetGoud :=
  erIsMinimaalEenKofferMetGoud
/\
  erIsMaximaalEenKofferMetGoud
.

Definition erIsMinimaalEenKofferMetEenWareUitspraak :=
K1 \/ K2 \/ K3 \/ K4.

Definition erIsMaximaalEenKofferMetEenWareUitspraak :=
~(K1\/K2\/K3) \/ ~(K1\/K2\/K4) \/ ~(K1\/K3\/K4) \/ ~(K2\/K3\/K4).

Definition erIsPreciesEenKofferMetEenWareUitspraak :=
  erIsMinimaalEenKofferMetEenWareUitspraak
/\
  erIsMaximaalEenKofferMetEenWareUitspraak
.

Theorem deOplossingIs :
    erIsPreciesEenKofferMetGoud
/\
    erIsPreciesEenKofferMetEenWareUitspraak
->
    G1 (* Geef hier aan in welke koffer het goud zit. *)
    /\
    K4  (* Geef hier aan op welke koffer de ware uitspraak staat. *)
.
Proof.
unfold erIsPreciesEenKofferMetGoud.
unfold erIsMinimaalEenKofferMetGoud.
unfold erIsMaximaalEenKofferMetGoud.
unfold erIsPreciesEenKofferMetEenWareUitspraak.
unfold erIsMinimaalEenKofferMetEenWareUitspraak.
unfold erIsMaximaalEenKofferMetEenWareUitspraak.
unfold K1.
unfold K2.
unfold K3.
unfold K4.
tauto.
Qed.


(*************************************************************)
(*      This file is distributed under the terms of the      *)
(*      GNU Lesser General Public License Version 2.1        *)
(*************************************************************)
(*    Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr      *)
(*************************************************************)

(***********************************************************************
      UList.v

      Definition of list with distinct elements

      Definition: ulist
************************************************************************)
Require Import List.
Require Import Arith.
Require Import Permutation.
Require Import ListSet.

Section UniqueList.
Variable A : Set.
Variable eqA_dec : forall (a b : A),  ({ a = b }) + ({ a <> b }).
(* A list is unique if there is not twice the same element in the list *)

Inductive ulist : list A ->  Prop :=
  ulist_nil: ulist nil
 | ulist_cons: forall a l, ~ In a l -> ulist l ->  ulist (a :: l) .
Hint Constructors ulist : core.
(* Inversion theorem *)

Theorem ulist_inv: forall a l, ulist (a :: l) ->  ulist l.
intros a l H; inversion H; auto.
Qed.
(* The append of two unique list is unique if the list are distinct *)

Theorem ulist_app:
 forall l1 l2,
 ulist l1 ->
 ulist l2 -> (forall (a : A), In a l1 -> In a l2 ->  False) ->  ulist (l1 ++ l2).
intros L1; elim L1; simpl; auto.
intros a l H l2 H0 H1 H2; apply ulist_cons; simpl; auto.
red; intros H3; case in_app_or with ( 1 := H3 ); auto; intros H4.
inversion H0; auto.
apply H2 with a; auto.
apply H; auto.
apply ulist_inv with ( 1 := H0 ); auto.
intros a0 H3 H4; apply (H2 a0); auto.
Qed.
(* Iinversion theorem the appended list *)

Theorem ulist_app_inv:
 forall l1 l2 (a : A), ulist (l1 ++ l2) -> In a l1 -> In a l2 ->  False.
intros l1; elim l1; simpl; auto.
intros a l H l2 a0 H0 [H1|H1] H2.
inversion H0 as [|a1 l0 H3 H4 H5]; auto.
case H3; rewrite H1; auto with datatypes.
apply (H l2 a0); auto.
apply ulist_inv with ( 1 := H0 ); auto.
Qed.
(* Iinversion theorem the appended list *)

Theorem ulist_app_inv_l: forall (l1 l2 : list A), ulist (l1 ++ l2) ->  ulist l1.
intros l1; elim l1; simpl; auto.
intros a l H l2 H0.
inversion H0 as [|il1 iH1 iH2 il2 [iH4 iH5]]; apply ulist_cons; auto.
intros H5; case iH2; auto with datatypes.
apply H with l2; auto.
Qed.
(* Iinversion theorem the appended list *)

Theorem ulist_app_inv_r: forall (l1 l2 : list A), ulist (l1 ++ l2) ->  ulist l2.
intros l1; elim l1; simpl; auto.
intros a l H l2 H0; inversion H0; auto.
Qed.
(* Uniqueness is decidable *)

Definition ulist_dec: forall l,  ({ ulist l }) + ({ ~ ulist l }).
intros l; elim l; auto.
intros a l1 [H|H]; auto.
case (In_dec eqA_dec a l1); intros H2; auto.
right; red; intros H1; inversion H1; auto.
right; intros H1; case H; apply ulist_inv with ( 1 := H1 ).
Defined.
(* Uniqueness is compatible with permutation *)

Theorem ulist_perm:
 forall (l1 l2 : list A), permutation l1 l2 -> ulist l1 ->  ulist l2.
intros l1 l2 H; elim H; clear H l1 l2; simpl; auto.
intros a l1 l2 H0 H1 H2; apply ulist_cons; auto.
inversion_clear H2 as [|ia il iH1 iH2 [iH3 iH4]]; auto.
intros H3; case iH1;
 apply permutation_in with ( 1 := permutation_sym _ _ _ H0 ); auto.
inversion H2; auto.
intros a b L H0; apply ulist_cons; auto.
inversion_clear H0 as [|ia il iH1 iH2]; auto.
inversion_clear iH2 as [|ia il iH3 iH4]; auto.
intros H; case H; auto.
intros H1; case iH1; rewrite H1; simpl; auto.
apply ulist_cons; auto.
inversion_clear H0 as [|ia il iH1 iH2]; auto.
intros H; case iH1; simpl; auto.
inversion_clear H0 as [|ia il iH1 iH2]; auto.
inversion iH2; auto.
Qed.

Theorem ulist_def:
 forall l a,
 In a l -> ulist l ->  ~ (exists l1 , permutation l (a :: (a :: l1)) ).
intros l a H H0 [l1 H1].
absurd (ulist (a :: (a :: l1))); auto.
intros H2; inversion_clear H2; simpl; auto with datatypes.
apply ulist_perm with ( 1 := H1 ); auto.
Qed.

Theorem ulist_incl_permutation:
 forall (l1 l2 : list A),
 ulist l1 -> incl l1 l2 ->  (exists l3 , permutation l2 (l1 ++ l3) ).
intros l1; elim l1; simpl; auto.
intros l2 H H0; exists l2; simpl; auto.
intros a l H l2 H0 H1; auto.
case (in_permutation_ex _ a l2); auto with datatypes.
intros l3 Hl3.
case (H l3); auto.
apply ulist_inv with ( 1 := H0 ); auto.
intros b Hb.
assert (H2: In b (a :: l3)).
apply permutation_in with ( 1 := permutation_sym _ _ _ Hl3 );
 auto with datatypes.
simpl in H2 |-; case H2; intros H3; simpl; auto.
inversion_clear H0 as [|c lc Hk1]; auto.
case Hk1; subst a; auto.
intros l4 H4; exists l4.
apply permutation_trans with (a :: l3); auto.
apply permutation_sym; auto.
Qed.

Theorem ulist_eq_permutation:
 forall (l1 l2 : list A),
 ulist l1 -> incl l1 l2 -> length l1 = length l2 ->  permutation l1 l2.
intros l1 l2 H1 H2 H3.
case (ulist_incl_permutation l1 l2); auto.
intros l3 H4.
assert (H5: l3 = @nil A).
generalize (permutation_length _ _ _ H4); rewrite length_app; rewrite H3.
rewrite plus_comm; case l3; simpl; auto.
intros a l H5; absurd (lt (length l2) (length l2)); auto with arith.
pattern (length l2) at 2; rewrite H5; auto with arith.
replace l1 with (app l1 l3); auto.
apply permutation_sym; auto.
rewrite H5; rewrite app_nil_end; auto.
Qed.

Theorem ulist_incl_length:
 forall (l1 l2 : list A), ulist l1 -> incl l1 l2 ->  le (length l1) (length l2).
intros l1 l2 H1 Hi; case ulist_incl_permutation with ( 2 := Hi ); auto.
intros l3 Hl3; rewrite permutation_length with ( 1 := Hl3 ); auto.
rewrite length_app; simpl; auto with arith.
Qed.

Theorem ulist_incl2_permutation:
 forall (l1 l2 : list A),
 ulist l1 -> ulist l2 -> incl l1 l2 -> incl l2 l1  ->  permutation l1 l2.
intros l1 l2 H1 H2 H3 H4.
apply ulist_eq_permutation; auto.
apply le_antisym; apply ulist_incl_length; auto.
Qed.

Theorem ulist_incl_length_strict:
 forall (l1 l2 : list A),
 ulist l1 -> incl l1 l2 -> ~ incl l2 l1 ->  lt (length l1) (length l2).
intros l1 l2 H1 Hi Hi0; case ulist_incl_permutation with ( 2 := Hi ); auto.
intros l3 Hl3; rewrite permutation_length with ( 1 := Hl3 ); auto.
rewrite length_app; simpl; auto with arith.
generalize Hl3; case l3; simpl; auto with arith.
rewrite <- app_nil_end; auto.
intros H2; case Hi0; auto.
intros a HH; apply permutation_in with ( 1 := H2 ); auto.
intros a l Hl0; (rewrite plus_comm; simpl; rewrite plus_comm; auto with arith).
Qed.

Theorem in_inv_dec:
 forall (a b : A) l, In a (cons b l) ->  a = b \/ ~ a = b /\ In a l.
intros a b l H; case (eqA_dec a b); auto; intros H1.
right; split; auto; inversion H; auto.
case H1; auto.
Qed.

Theorem in_ex_app_first:
 forall (a : A) (l : list A),
 In a l ->
  (exists l1 : list A , exists l2 : list A , l = l1 ++ (a :: l2) /\ ~ In a l1  ).
intros a l; elim l; clear l; auto.
intros H; case H.
intros a1 l H H1; auto.
generalize (in_inv_dec _ _ _ H1); intros [H2|[H2 H3]].
exists (nil (A:=A)); exists l; simpl; split; auto.
subst; auto.
case H; auto; intros l1 [l2 [Hl2 Hl3]]; exists (a1 :: l1); exists l2; simpl;
 split; auto.
subst; auto.
intros H4; case H4; auto.
Qed.

Theorem ulist_inv_ulist:
 forall (l : list A),
 ~ ulist l ->
  (exists a ,
   exists l1 ,
   exists l2 ,
   exists l3 , l = l1 ++ ((a :: l2) ++ (a :: l3)) /\ ulist (l1 ++ (a :: l2))    ).
intros l; elim l  using list_length_ind; clear l.
intros l; case l; simpl; auto; clear l.
intros Rec H0; case H0; auto.
intros a l H H0.
case (In_dec eqA_dec a l); intros H1; auto.
case in_ex_app_first with ( 1 := H1 ); intros l1 [l2 [Hl1 Hl2]]; subst l.
case (ulist_dec l1); intros H2.
exists a; exists (@nil A); exists l1; exists l2; split; auto.
simpl; apply ulist_cons; auto.
case (H l1); auto.
rewrite length_app; auto with arith.
intros b [l3 [l4 [l5 [Hl3 Hl4]]]]; subst l1.
exists b; exists (a :: l3); exists l4; exists (l5 ++ (a :: l2)); split; simpl;
 auto.
(repeat (rewrite <- ass_app; simpl)); auto.
apply ulist_cons; auto.
contradict Hl2; auto.
replace (l3 ++ (b :: (l4 ++ (b :: l5)))) with ((l3 ++ (b :: l4)) ++ (b :: l5));
 auto with datatypes.
(repeat (rewrite <- ass_app; simpl)); auto.
case (H l); auto; intros a1 [l1 [l2 [l3 [Hl3 Hl4]]]]; subst l.
exists a1; exists (a :: l1); exists l2; exists l3; split; auto.
simpl; apply ulist_cons; auto.
contradict H1.
replace (l1 ++ (a1 :: (l2 ++ (a1 :: l3))))
     with ((l1 ++ (a1 :: l2)) ++ (a1 :: l3)); auto with datatypes.
(repeat (rewrite <- ass_app; simpl)); auto.
Qed.

Theorem incl_length_repetition:
 forall (l1 l2 : list A),
 incl l1 l2 ->
 lt (length l2) (length l1) ->
  (exists a ,
   exists ll1 ,
   exists ll2 ,
   exists ll3 ,
   l1 = ll1 ++ ((a :: ll2) ++ (a :: ll3)) /\ ulist (ll1 ++ (a :: ll2))    ).
intros l1 l2 H H0; apply ulist_inv_ulist.
intros H1; absurd (le (length l1) (length l2)); auto with arith.
apply ulist_incl_length; auto.
Qed.

End UniqueList.
Arguments ulist [A].
Global Hint Constructors ulist : core.

Theorem ulist_map:
 forall (A B : Set) (f : A ->  B) l,
 (forall x y, (In x l) -> (In y l) ->  f x = f y ->  x = y) -> ulist l ->  ulist (map f l).
intros a b f l Hf Hl; generalize Hf; elim Hl; clear Hf;  auto.
simpl; auto.
intros a1 l1 H1 H2 H3 Hf; simpl.
apply ulist_cons; auto with datatypes.
contradict H1.
case in_map_inv with ( 1 := H1 ); auto with datatypes.
intros b1 [Hb1 Hb2].
replace a1 with b1; auto with datatypes.
Qed.

Theorem ulist_list_prod:
 forall (A : Set) (l1 l2 : list A),
 ulist l1 -> ulist l2 ->  ulist (list_prod l1 l2).
intros A l1 l2 Hl1 Hl2; elim Hl1; simpl; auto.
intros a l H1 H2 H3; apply ulist_app; auto.
apply ulist_map; auto.
intros x y _ _ H; inversion H; auto.
intros p Hp1 Hp2; case H1.
case in_map_inv with ( 1 := Hp1 ); intros a1 [Ha1 Ha2]; auto.
case in_list_prod_inv with ( 1 := Hp2 ); intros b1 [c1 [Hb1 [Hb2 Hb3]]]; auto.
replace a with b1; auto.
rewrite Ha2 in Hb1; injection Hb1; auto.
Qed.


Require Import Arith List Recdef.
Import ListNotations.
Fixpoint ltn_rec (l : list bool) : nat :=
  match l with
    nil => 0
  | a::tl => (if a then 1 else 0) + 2 * ltn_rec tl
  end.

Definition ltn (l : list bool) := ltn_rec (rev l).

Definition testing_liste := [true;true;true].
Compute ltn testing_liste.

Function ntl (n : nat) {wf lt} :=
  match n with
    0 => nil
  | S p =>  negb (Nat.even n) :: ntl (Nat.div2 n)
  end.
intros n p nsp; apply Nat.lt_div2.
auto with arith.
exact lt_wf.
Qed.

Lemma toto : ntl 32 = false::false::false::false::false::true::nil.
rewrite 7!ntl_equation; simpl; reflexivity.
Qed.

Lemma titi n : ltn (ntl n) = n.
Proof.
induction n using (well_founded_ind lt_wf).
rewrite ntl_equation.
case_eq n.
  trivial.
intros p n_is_Sp.
change ((if negb (Nat.even (S p)) then 1 else 0) +
        2 * ltn (ntl (Nat.div2 (S p))) = S p).
rewrite H; cycle 1.
  rewrite n_is_Sp; apply Nat.lt_div2; auto with arith.

Lemma toto : ntl 4 = true::false::false::nil.
rewrite 4!ntl_equation; simpl.
Check ntl_terminate.
Search Nat.div2.
Search (list bool).
Check Nat.bitwise.

Definition ntl (n : nat) :=
  Fix lt_wf (fun _ => list bool)
  (fun x ntl =>
     match zerop x with
       left _ => nil
     | right h => negb(Nat.even x) ::
                  ntl (Nat.div2 x) (Nat.lt_div2 _ h)
end).

Check Fix.