Set Implicit Arguments.

Require Import
        Discrete.DiscType
        Discrete.Disjoint
        Discrete.DupFree
        Discrete.Filter
        Discrete.In
        Discrete.Inclusion
        Tactics.Tactics.

Import ListNotations.

Section POWER.
  Variable A : discType.
  Context {eq_A_dec : eq_dec A}.

  Fixpoint power (xs : list A) : list (list A) :=
    match xs with
      | nil => [nil]
      | y :: ys => power ys ++ map (cons y) (power ys)
    end.

  Lemma power_incl xs ys :
    xs el power ys -> xs <<= ys.
  Proof.
    revert xs ; induction ys as [ | y ys ] ; simpl ; intros xs D.
    -
      destruct* D as [[]|[]].
    - apply In_app_iff in D as [E|E]. now auto.
      apply In_map_iff in E as [zs [E F]]. substs*.
      apply incl_shift ; eauto.
  Qed.

  Lemma power_nil xs :
    nil el power xs.
  Proof.
    induction xs ; simpl ; crush.
    rewrite In_app_iff ; crush.
  Qed.

  Definition rep (xs ys : list A) : list A :=
    filter (fun x => x el xs) ys.

  Lemma rep_incl xs ys :
    rep xs ys <<= xs.
  Proof.
    unfold rep. intros x D. apply In_filter_iff in D. apply D.
  Qed.

  Lemma rep_power xs ys :
    rep xs ys el power ys.
  Proof.
    revert xs. induction ys as [|y ys] ; intros xs.
    -
      simpl ; auto.
    -
      unfold rep ; simpl ;
        decide (y el xs) as [E | E]
        ; rewrite In_app_iff ; specialize (IHys xs) ;
          unfold rep in IHys ; [right ; eauto | left*].
  Qed.

  Lemma rep_in x xs ys :
    xs <<= ys -> x el xs -> x el rep xs ys.
  Proof.
    intros D E. apply In_filter_iff ; crush.
  Qed.

  Lemma rep_equiv xs ys :
    xs <<= ys -> rep xs ys === xs.
  Proof.
    intros D. split. now apply rep_incl.
    intros x. apply rep_in, D.
  Qed.

  Lemma rep_mono xs ys zs :
    xs <<= ys -> rep xs zs <<= rep ys zs.
  Proof.
    intros D.
    apply filter_pq_mono.
    auto.
  Qed.

  Lemma rep_eq' xs ys zs :
    (forall x, x el zs -> (x el xs <-> x el ys)) -> rep xs zs = rep ys zs.
  Proof.
    intros D.
    apply filter_pq_eq.
    auto.
  Qed.

  Lemma rep_eq xs ys zs :
    xs === ys -> rep xs zs = rep ys zs.
  Proof.
    intros D.
    apply filter_pq_eq.
    firstorder.
  Qed.

  Lemma rep_injective xs ys zs :
    xs <<= zs -> ys <<= zs -> rep xs zs = rep ys zs -> xs === ys.
  Proof.
    intros D E F. transitivity (rep xs zs).
    -
      symmetry. apply rep_equiv, D.
    -
      rewrite F. apply rep_equiv, E.
  Qed.

  Lemma rep_idempotent xs ys :
    rep (rep xs ys) ys = rep xs ys.
  Proof.
    unfold rep at 1 3. apply filter_pq_eq.
    intros x D. split.
    +
      apply rep_incl.
    +
      intros E.
      apply In_filter_iff.
      auto.
  Qed.

  Lemma dup_free_power xs :
    dup_free xs -> dup_free (power xs).
  Proof.
    intros D. induction D as [|x U E D]; simpl.
    -
      constructor.
      now auto.
      constructor.
    - apply dup_free_app.
      + intros [A1 [F G]]. apply In_map_iff in G as [A' [G G']].
        subst A1. apply E. apply (power_incl F). crush.
      + exact IHD.
      + apply dup_free_map ; congruence.
  Qed.

  Lemma dup_free_in_power xs ys :
    xs el power ys -> dup_free ys -> dup_free xs.
  Proof.
    intros E D. revert xs E.
    induction D as [|x U D D']; simpl; intros xs E ; crush.
    - apply In_app_iff in E as [E|E] ; crush.
      apply In_map_iff in E as [A' [E E']]. substs.
      constructor.
      *
        intros F; apply D. apply (power_incl E'), F.
      *
        auto.
  Qed.

  Lemma rep_id xs : rep xs xs = xs.
  Proof.
    unfolds.
    apply filter_id. tauto.
  Qed.

  Hint Resolve rep_id.

  Lemma rep_nil ys :
    rep [] ys = [].
  Proof.
    unfolds ; induction ys ; crush.
    decide (False) ; crush.
  Qed.

  Hint Resolve rep_nil.

  Lemma rep_dup_free xs ys :
    dup_free ys -> xs el power ys -> rep xs ys = xs.
  Proof.
    intros D ; revert xs.
    induction D as [|x U E F] ; intros xs G.
    -
      destruct* G as [[]|[]].
    -
      simpl in G.
      apply In_app_iff in G as [G|G].
      +
        simpl.
        decide (x el xs) as [H|H].
        *
          exfalso.
          apply E.
          apply (power_incl G), H.
        *
          unfolds.
          rewrite filter_fst' ; auto.
          specialize (IHF _ G). crush.
      +
        apply In_map_iff in G as [A' [G H]]. subst xs.
        unfold rep. simpl.
        decide (x = x \/ x el A') as [G|G] ; crush.
        *
          f_equal. specialize (IHF A' H). unfold rep in IHF. rewrite <- IHF at -2.
          apply filter_pq_eq. apply power_incl in H.
          intros z K. split; [|now auto].
          intros [L|L]; subst; tauto.
        *
          exfalso. apply E. apply power_incl in H. eauto.
  Qed.

  Lemma power_extensional xs ys zs :
    dup_free zs -> xs el power zs -> ys el power zs -> xs === ys -> xs = ys.
  Proof.
    intros D E F G.
    rewrite <- (rep_dup_free D E). rewrite <- (rep_dup_free D F).
    apply rep_eq, G.
  Qed.

End POWER.


(**************************************************************)
(*   Copyright                                                *)
(*             Jean-François Monin           [+]              *)
(*             Dominique Larchey-Wendling    [*]              *)
(*                                                            *)
(*            [+] Affiliation VERIMAG - Univ. Grenoble-Alpes  *)
(*            [*] Affiliation LORIA -- CNRS                   *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

(* List traversal from right to left *)
Require Import List Utf8.
Import ListNotations.

Require Import lr.
(* The domain of 𝔾_foldl happens to be exactly 𝔻lz as defined in lr_rec *)
Require Import lr_rec.

(* Here is a reference definition of List.fold_left, which follows the
same structural pattern as List.fold_right, but where lists are
traversed from right to left.

let rec foldl_ref f b l = fakematch l with
  | [] → b
  | u +: z → f (foldl_ref f b u) z

This can be actually programmed by reflecting this
decomposition of lists from the right using l2r.

let rec foldl_ref f b l = match l2r l with
  | Nilr → b
  | Consr (u, z) → f (foldl_ref f b u) z

This definition corresponds to the usual informal drawings explaining
the expected result. It is of course quite inefficient, however and it
can be seen as a specification of fold_left.

let rec foldl f b l = match l with
   | [] → b
   | x :: l → foldl f (f b x) l

This Coq scripts shows that foldl is actually equivalent to
foldl_ref.

The point is to get a Coq definition of foldl_ref, whereas
the recursion is not the usual structural recursion on lists.
Following the method exposed at Braga, we start with an
inductive graph corresponding to foldl_ref.
*)

(* -------------------------------------------------------------------------- *)
(* Relational Graph *)

Section sec_context.

Context {A B: Type}.
Implicit Type l u v : list A.
Implicit Type r : lr A.
Implicit Type x y z : A.
Implicit Type b : B.

Section sec_params_foldl.
Variable f: B → A → B.
Variable b0 : B.

Reserved Notation "l '⟼fl' b" (at level 70, format "l  ⟼fl  b").

Inductive 𝔾_foldl : list A → B → Prop :=
| FLnil : [] ⟼fl b0
| FLcons : ∀ {u z b},    u ⟼fl b   →  u +: z ⟼fl f b z
where "l ⟼fl b" := (𝔾_foldl l b).

(* A technical variant of FLcons, for later convenience *)
Definition FLcons_lrl {u z b} : lrl u ⟼fl b  →  u +: z ⟼fl f b z.
  refine (fun G => FLcons _). pattern u. exact (down_llP _ u G).
Defined.

(* -------------------------------------------------------------------------- *)
(* Using the Braga method *)

(* foldl conform by construction (or "packed with conformness") *)

(* The explicit dependent pattern matching

   match l2r l as x return ** 𝔻lz (r2l x) ... → _ ** with

   ** ... ** added below, is not needed any more for Coq 8.11+ *)

(* Shape of the goal before refine:
   𝔻lz (r2l (l2r l)) →
   (∀y, r2l (l2r l) ⟼fl y → l ⟼fl y) →
   {b | l ⟼fl b} *)
Let Fixpoint foldl_pwc l (D: 𝔻lz l): {b | l ⟼fl b}.
Proof.
  gen_help l 𝔾_foldl. apply up_llP in D; revert D.
  refine (match l2r l as x return 𝔻lz (r2l x)
                                → (∀ y : B, r2l x ⟼fl y → l ⟼fl y)
                                → _ with
          | Nilr      => λ D T,  exist _ b0 _
          | Consr u z => λ D T,
                 let (b, Gb) := foldl_pwc u (π_𝔻lz D) in
                 exist _ (f b z) _
          end).
  - apply T; constructor 1.
  - apply T; constructor 2; exact Gb.
Defined.

(* Alternative definition, with just an equality in the Trojan horse
   -->
   + simpler goal before refine
   - structural inversion of D obtained after a rewriting step,
     cannot directly be put in the match
   - no explicit view of the rewriting steps
     (rewrite makes no difference between eq_ind and eq_recT)
*)
Let Fixpoint foldl_pwc_eq l (D: 𝔻lz l): {b | l ⟼fl b}.
Proof.
  generalize (lrl_id l).
  (* r2l (l2r l) = l → {b | l ⟼fl b} *)
  refine (match l2r l with
          | Nilr      => λ E,  exist _ b0 _
          | Consr u z => λ E,
                  let (b, Gb) := foldl_pwc_eq u _ in
                  exist _ (f b z) _
          end); simpl in E.
  - rewrite <- E in *. constructor 1.
  - rewrite <- E in D. apply (π_𝔻lz D).
  - rewrite <- E in *. constructor 2. exact Gb.
Defined.

(* The reference function for foldl *)
Definition foldl_ref l (D : 𝔻lz l) : B :=
  proj1_sig (foldl_pwc l D).

Lemma foldl_ref_corr_partial l (D: 𝔻lz l) :
  l ⟼fl foldl_ref l D.
Proof.
  exact (proj2_sig (foldl_pwc l D)).
Qed.

(* -------------------------------------------------------------------------- *)
(* Version corresponding to OCaml fold_left *)
Fixpoint foldl b l : B :=
    match l with
    | [] => b
    | x :: l => foldl (f b x) l
    end.

(* foldl is compatible with +: in the following sense *)
Lemma foldl_consr b (u: list A) (z: A) :
  foldl b (u +: z) = f (foldl b u) z.
Proof.
  revert b. induction u as [|x u Hu]; intro b; simpl.
  - reflexivity.
  - rewrite Hu. reflexivity.
Qed.

(* Completeness of foldl wrt 𝔾_foldl follows *)
Theorem foldl_compl b l :  l ⟼fl b  →  b = foldl b0 l.
Proof.
  intro g. induction g as [ | u z b g Hg]; simpl.
  - reflexivity.
  - rewrite foldl_consr. rewrite Hg. reflexivity.
Qed.
(* Corollary for free: 𝔾_foldl is functional; but useless *)

(* Partial conformity wrt 𝔾_foldl: whenever l is in the domain,
   fold computes a good result *)
(* Induction on  𝔻lz l *)
Theorem foldl_corr_partial l : 𝔻lz l  →  l ⟼fl foldl b0 l.
Proof.
  intro D. induction D as [ | u Gu z].
  - apply FLnil.
  - rewrite foldl_consr. apply (FLcons Gu).
Qed.

(* Total conformity wrt 𝔾_foldl follows independently *)
Corollary foldl_corr l :  l  ⟼fl  foldl b0 l.
Proof.
  apply foldl_corr_partial. apply 𝔻lz_all.
Qed.

End sec_params_foldl.

(* -------------------------------------------------------------------------- *)
(* Partial conformity wrt foldl_ref: whenever foldl_ref terminates,
   fold computes the same result *)
Theorem foldl_equiv_partial :
     ∀ f b l (D: 𝔻lz l), foldl f b l = foldl_ref f b l D.
Proof.
  intros. symmetry. apply foldl_compl. apply foldl_ref_corr_partial.
Qed.

(* Total conformity wrt foldl_ref follows independently *)
Corollary foldl_equiv_total :
    ∀ f b l, foldl f b l = foldl_ref f b l (𝔻lz_all l).
Proof.
  intros; apply foldl_equiv_partial.
Qed.

(* Additional remarks
- conformity of foldl wrt foldl_ref needs its completeness wrt 𝔾_foldl,
  not its conformity
- conformity of foldl wrt 𝔾_foldl is technically easier:
  an induction on the domain;
  in contrast, the definition foldl_ref requires a stronger recursion,
  including projective inversions (see lr_rec)
- as expected, termination is considered separately (with 𝔻lz_all),
  whatever the approach (using a relational or a functional specification)
*)

End sec_context.

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

Require Import Extraction.
Extract Inductive list => "list" [ "[]" "(::)" ].
Recursive Extraction foldl_ref foldl.
(*

type 'a lr =
| Nilr
| Consr of 'a list * 'a

(** val l2r : 'a1 list -> 'a1 lr **)

let rec l2r = function
| [] -> Nilr
| x::lr0 ->
  (match l2r lr0 with
   | Nilr -> Consr ([], x)
   | Consr (lg, z) -> Consr ((x::lg), z))

(** val foldl_ref : ('a2 -> 'a1 -> 'a2) -> 'a2 -> 'a1 list -> 'a2 **)

let rec foldl_ref f b0 l =
  match l2r l with
  | Nilr -> b0
  | Consr (u, z) -> f (foldl_ref f b0 u) z

(** val foldl : ('a2 -> 'a1 -> 'a2) -> 'a2 -> 'a1 list -> 'a2 **)

let rec foldl f b = function
| [] -> b
| x::l0 -> foldl f (f b x) l0

*)

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


From mathcomp Require Import ssreflect.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Require Import Coq.Logic.Decidable. (* Introducing decidable *)
Require Import Coq.Sets.Powerset_Classical_facts.

Notation "x ∈ X" := (In _ X x) (right associativity, at level 48).
Notation "A ⊂ B" := (Included _ A B) (right associativity, at level 51).
Notation "A ⊊ B" := (Strict_Included _ A B) (right associativity, at level 51).
Notation "A ^c"   := (Complement _ A) (at level 47).
Notation "A ∪ B" := (Union _ A B) (left associativity, at level 50).
Notation "A ∩ B" := (Intersection _ A B) (left associativity, at level 50).
Notation "A \ B"  := (Setminus _ A B) (left associativity, at level 50).

Notation "{||}"  := (Empty_set _).
Notation "{| x |}" := (Singleton _ x).
Notation "{| x , y , .. , z |}" := (Union _ .. (Union _ (Singleton _ x) (Singleton _ y)) .. (Singleton _ z)).

Theorem Axiom_of_EmptySet:
  forall (U:Type) (X:Ensemble U), X = {||} <-> (forall (x:U), x ∈ X -> False).
  move => X.
  rewrite /iff.
  split.
  move => HE.
  rewrite HE.
  apply Noone_in_empty.
  move => HF.
  apply /Extensionality_Ensembles.
  split => y.
  move => H0.
  move: (HF y).
  case.
  apply H0.
  case.
Qed.

Theorem not_empty_set_has_element:
  forall (U:Type) (X:Ensemble U), ~(X={||}) <-> exists x:U, x ∈ X.
  Proof.
    rewrite /iff.
    split => H.
    -have L1: Inhabited U X.
     apply not_empty_Inhabited.
     apply H.
     inversion L1.
     exists x.
     apply H0.
    -inversion H as [x].
     apply Inhabited_not_empty.
     apply (Inhabited_intro U X x).
     apply H0.
  Qed.

(* Axiom of separation { x;U | P(x) } *)
Inductive SchemaOfSeparation (U:Type) (x:U) (P:U -> Prop): Ensemble U :=
  Definition_of_Schema_Sepatation:
    forall (x0: U), P x0 -> In U (SchemaOfSeparation x P) x0.

Definition OrderedPair {U:Type} (a b : U) := {|{|a|},{|a,b|}|}.

(* Axiom of the Power Set *)
Inductive DirectProduct {U:Type} (X Y:Ensemble U) : Ensemble (Ensemble (Ensemble U)) :=
  Definition_of_DirectProduct:
    forall (Z: Ensemble (Ensemble U)),
      (exists x:U, exists y:U, (x ∈ X /\ y ∈ Y /\ Z = {|{|x|},{|x,y|}|})) ->
      In (Ensemble (Ensemble U)) (DirectProduct X Y) Z.

(* 𝔓:Unicode 1D513 *)
Notation "𝔓( X )" := (@Power_set _ X) (at level 47).

Notation "X × Y" := (DirectProduct X Y) (at level 47).
Notation "(| a , b |)" := (OrderedPair a b) (at level 48).

(* Binary Relation {z|z=(|x,y|) /\ x ∈ X /\ y ∈ Y} *)

Inductive FirstOfOrderedPair {U:Type} (XY: (Ensemble (Ensemble U))): Ensemble U :=
| ordered_pair_first_accessor: forall (x:U), (exists y:U, (|x,y|) = XY) -> FirstOfOrderedPair XY x.

Inductive SecondOfOrderedPair {U:Type} (XY: (Ensemble (Ensemble U))): Ensemble U :=
| ordered_pair_second_accessor: forall (y:U), (exists x:U, (|x,y|) = XY) -> SecondOfOrderedPair XY y.

Inductive Pr1 {U:Type} (XY: Ensemble (Ensemble (Ensemble U))) : Ensemble U :=
| pr1_accessor: forall (x:U), (exists y:U, (|x,y|) ∈ XY) ->  Pr1 XY x.

Inductive Pr2 {U:Type} (XY: Ensemble (Ensemble (Ensemble U))) : Ensemble U :=
| pr2_accessor: forall (y:U), (exists x:U, (|x,y|) ∈ XY) ->  Pr2 XY y.

Section Class_Set.

  Variable U:Type.

  Lemma eq_iff: forall (V:Type) (x y:V), x = y <-> y = x.
  Proof.
  +move => V x y.
   rewrite /iff.
   split; move => H; rewrite H; reflexivity.
  Qed.

  Lemma singleton_eq_iff: forall (V:Type) (x y: V), x ∈ {|y|} <-> x = y.
  Proof.
    +move => V x y.
     rewrite /iff.
     split => H.
     (* x ∈ {|y|} -> x = y *)
     ++apply eq_sym.
       apply Singleton_inv.
       apply H.
     (* x = y -> x ∈ {|y|} *)
     ++rewrite H.
       apply Singleton_intro.
       reflexivity.
  Qed.

  Lemma eq_singleton_eq_element_iff: forall (x y : U), {|x|} = {|y|} <-> x = y.
  Proof.
    +move => x y.
     rewrite /iff.
     split => H.
     (* {|x|} = {|y|} -> x = y *)
     ++apply Singleton_inv.
       rewrite H.
       apply singleton_eq_iff.
       reflexivity.
     (* x = y -> {|x|} = {|y|} *)
     ++rewrite H.
       reflexivity.
  Qed.

  Theorem theorem_of_pairing: forall (V:Type) (x y z:V), x ∈ {|y,z|} <-> x = y \/ x = z.
  Proof.
    +move => V x y z.
     rewrite /iff.
     split.     (* x ∈ {|y,z|} -> x = y \/ x = z. *)
     ++case => w H.
       left.
       apply singleton_eq_iff.
       apply H.
       right.
       apply singleton_eq_iff.
       apply H.
     (*  x = y \/ x = z -> x ∈ {|y,z|} *)
     ++case => H; rewrite H.
       left.
       reflexivity.
       right.
       reflexivity.
  Qed.

  Theorem T_0: forall (a b c:U), {|a|} = {|b,c|} -> a = b /\ b = c.
  Proof.
    move => a b c H.
    have L1: b ∈ {|b,c|}.
    left.
    apply Singleton_intro.
    reflexivity.
    have L2: a=b.
    rewrite -H in L1.
    apply Singleton_inv.
    apply L1.
    split.
    apply L2.
    rewrite -L2.
    have L3: c ∈ {|b,c|}.
    right.
    apply Singleton_intro.
    reflexivity.
    rewrite -H in L3.
    apply Singleton_inv.
    apply L3.
  Qed.

  Theorem T_1: forall (a b c d: U), a <> c -> {|a,b|}={|c,d|} -> a = d.
  Proof.
    +move => a b c d H0 H1.
     --have L1: a ∈ {|a,b|}.
       left.
       apply Singleton_intro.
       reflexivity.
    +rewrite H1 in L1.
    +move: L1.
     rewrite theorem_of_pairing.
     rewrite -imp_not_l.
     apply.
     apply H0.
     apply classic.
  Qed.

  Theorem T_2: forall (V:Type) (a b c d: V),
      {|a,b|}={|c,d|} <-> (a = c /\ b = d) \/ (a = d /\ b = c).
  Proof.
    move => V.
    (* x = z \/ y = z -> x <> z -> y = z *)
    ++have L0: forall (x y z: V), x = z \/ y = z -> x <> z -> y = z.
      move => x y z H.
      apply or_not_l_iff_2.
      apply classic.
      move: H.
      case => H.
      left.
      case.
      exact H.
      right.
      exact H.
    ++have L1: forall (x y: V), {|x, y|} = {|y, x|}.
      move => x y.
      apply /Extensionality_Ensembles.
      split => z; case => w H.
      right.
      apply H.
      left.
      apply H.
      right.
      apply H.
      left.
      apply H.
    +move => a b c d.
     rewrite /iff.
     split.
     ++move => H.
       apply imp_not_l.
       apply classic.
     --have L2: a <> c \/ b <> d <-> (a = c /\ b = d -> False).
       rewrite /iff.
       split => H0.
       apply or_not_and.
       apply H0.
       apply not_and_or.
       rewrite /not.
       apply H0.
    ++rewrite -L2.
      case => H0.
      split.
      (* a = c \/ a = d -> a <> c -> a = d *)
      ---have L01: a = c \/ a = d.
         apply theorem_of_pairing.
         rewrite -H.
         left.
         apply Singleton_intro.
         reflexivity.
      ---move: H0.
         move: L01.
         rewrite (eq_iff a c).
         rewrite (eq_iff a d).
         apply L0.
      (* a = c \/ b = c -> a <> c -> b = c *)
      ---have L02: a = c \/ b = c.
         rewrite (eq_iff a c).
         rewrite (eq_iff b c).
         apply theorem_of_pairing.
         rewrite H.
         left.
         apply Singleton_intro.
         reflexivity.
      ---move: H0.
         move: L02.
         apply L0.
    +split.
     ++move: H0.
     (* b = d \/ a = d -> b <> d -> a = d *)
       ---have L30: b = d \/ a = d.
          rewrite (eq_iff b d).
          rewrite (eq_iff a d).
          apply theorem_of_pairing.
          rewrite L1.
          rewrite H.
          right.
          apply Singleton_intro.
          reflexivity.
     ++move: L30.
       apply L0.
     (* b = d -> b = c -> b <> d -> b = c *)
     ++move: H0.
       ---have L31: b = d \/ b = c.
          apply theorem_of_pairing.
          rewrite L1.
          rewrite -H.
          right.
          apply Singleton_intro.
          reflexivity.
     ++move: L31.
       rewrite (eq_iff b d).
       rewrite (eq_iff b c).
       apply L0.
    +case; case => [H0 H1]; rewrite H0; rewrite H1.
     ++reflexivity.
     ++apply L1.
  Qed.

  Theorem ordered_pair_iff: forall (x y w z: U), (| x , y |) = (| w , z |) <-> x = w /\ y = z.
  Proof.
     unfold OrderedPair.
    +move => x y w z.
     rewrite /iff.
     split.
     (* {|{|x|}, {|x, y|}|} = {|{|w|}, {|w, z|}|} -> x = w /\ y = z *)
     ++move => H0.
       ---have L1: ({|x|}={|w|}/\{|x,y|}={|w,z|}) \/ ({|x|}={|w,z|}/\{|x,y|}={|w|}).
          (* {|{|x|}, {|x, y|}|} = {|{|w|}, {|w, z|}|} -> ({|x|}={|w|}/\{|x,y|}={|w,z|}) \/ ({|x|}={|w,z|}/\{|x,y|}={|w|}) *)
          apply T_2.
          apply H0.
     ++move: L1.
       (* ({|x|} = {|w|} /\ {|x, y|} = {|w, z|}) \/ ({|x|} = {|w, z|} /\ {|x, y|} = {|w|}) -> x = w /\ y = z *)
       case.
       +++case => H00. (* ({|x|} = {|w|} /\ {|x, y|} = {|w, z|}) -> x = w /\ y = z *)
          rewrite T_2.
          case.
          apply.
          case => H01 H02.
          split.
          move: H00.
          apply eq_singleton_eq_element_iff.
          rewrite -H01.
          rewrite H02.
          apply eq_sym.
          move: H00.
          apply eq_singleton_eq_element_iff.
       +++case => H00 H01. (*({|x|} = {|w, z|} /\ {|x, y|} = {|w|}) -> x = w /\ y = z *)
          ----have L1: x = w /\ w = z.
              move: H00.
              apply T_0.
          ----have L2: w = x /\ x = y.
              move: H01.
          ----have L20: {|x,y|} = {|w|} <-> {|w|} = {|x,y|}.
              rewrite /iff.
              split; move => H20; rewrite H20; reflexivity.
       +++rewrite L20.
          apply T_0.
          inversion L1.
          inversion L2.
          split.
          apply H.
          rewrite -H3.
          rewrite -H1.
          apply H.
     (* x = w /\ y = z -> {|{|x|}, {|x, y|}|} = {|{|w|}, {|w, z|}|} *)
     ++case => H0 H1.
       rewrite H0.
       rewrite H1.
       reflexivity.
  Qed.

  Lemma FirstOfOrderedPairAccess: forall (a b:U), FirstOfOrderedPair ((| a, b |)) = {|a|}.
  Proof.
    move => a b.
    apply /Extensionality_Ensembles.
    split => z.
    case => [x [y]].
    rewrite ordered_pair_iff.
    case => H0 H1.
    apply singleton_eq_iff.
    apply H0.
    move => H.
    split.
    exists b.
    apply ordered_pair_iff.
    split.
    apply singleton_eq_iff.
    apply H.
    reflexivity.
  Qed.

  Lemma SecondOfOrderedPairAccess: forall (a b:U), SecondOfOrderedPair ((| a, b |)) = {|b|}.
  Proof.
    move => a b.
    apply /Extensionality_Ensembles.
    split => z.
    case => [y [x]].
    rewrite ordered_pair_iff.
    case => Hxa Hyb.
    apply singleton_eq_iff.
    apply Hyb.
    move => H.
    split.
    exists a.
    rewrite ordered_pair_iff.
    split.
    reflexivity.
    apply singleton_eq_iff.
    apply H.
  Qed.

End Class_Set.

Export Coq.Sets.Powerset_Classical_facts.
Export Coq.Logic.Decidable.


 (* Gabriel Braun April 2013 *)

Require Export GeoCoq.Tarski_dev.Ch13_2_length.

Section Angles_1.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

(************************************* angle *****************************)

Lemma ang_exists : forall A B C, A <> B -> C <> B -> exists a, Q_CongA a /\ a A B C.
Proof.
    intros.
    exists (fun D E F => CongA A B C D E F).
    split.
      unfold Q_CongA.
      exists A.
      exists B.
      exists C.
      split; auto.
      split; auto.
      intros.
      split.
        auto.
      auto.
    apply conga_refl; auto.
Qed.

Lemma ex_points_ang : forall a , Q_CongA a ->  exists A, exists B, exists C, a A B C.
Proof.
    intros.
    unfold Q_CongA in H.
    ex_and H A.
    ex_and H0 B.
    ex_and H C.
    assert(HH:= H1 A B C).
    destruct HH.
    exists A.
    exists B.
    exists C.
    apply H2.
    apply conga_refl; auto.
Qed.

End Angles_1.

Ltac ang_instance a A B C :=
  assert(tempo_ang:= ex_points_ang a);
  match goal with
    |H: Q_CongA a |-  _ => assert(tempo_H:=H); apply tempo_ang in tempo_H;
                       elim tempo_H; intros A ; let tempo_HP := fresh "tempo_HP" in intro tempo_HP; clear tempo_H;
                       elim tempo_HP; intro B; let tempo_HQ := fresh "tempo_HQ" in intro tempo_HQ ; clear tempo_HP ;
                       elim tempo_HQ; intro C; intro;  clear tempo_HQ
  end;
  clear tempo_ang.

Section Angles_2.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Lemma ang_conga : forall a A B C A' B' C', Q_CongA a -> a A B C -> a A' B' C' -> CongA A B C A' B' C'.
Proof.
    intros.
    unfold Q_CongA in H.
    ex_and H A0.
    ex_and H2 B0.
    ex_and H C0.
    assert(HH:=H3 A B C).
    assert(HH1:= H3 A' B' C').
    destruct HH.
    destruct HH1.
    apply H5 in H0.
    apply H7 in H1.
    eapply conga_trans.
      apply conga_sym.
      apply H0.
    auto.
Qed.

Lemma is_ang_conga : forall A B C A' B' C' a, Ang A B C a -> Ang A' B' C' a -> CongA A B C A' B' C'.
Proof.
    intros.
    unfold Ang in *.
    spliter.
    eapply (ang_conga a); auto.
Qed.

Lemma is_ang_conga_is_ang : forall A B C A' B' C' a, Ang A B C a -> CongA A B C A' B' C' -> Ang A' B' C' a.
Proof.
    intros.
    unfold Ang in *.
    spliter.
    split.
      auto.
    unfold Q_CongA in H.
    ex_and H A0.
    ex_and H2 B0.
    ex_and H C0.
    assert(HH:= H3 A B C).
    destruct HH.
    assert(HH1:= H3 A' B' C').
    destruct HH1.
    apply H5 in H1.
    apply H6.
    eapply conga_trans.
      apply H1.
    auto.
Qed.

Lemma not_conga_not_ang : forall A B C A' B' C' a , Q_CongA a -> ~(CongA A B C A' B' C') -> a A B C -> ~(a A' B' C').
Proof.
    intros.
    intro.
    assert(HH:=ang_conga a A B C A' B' C' H H1 H2).
    contradiction.
Qed.

Lemma not_conga_is_ang : forall A B C A' B' C' a , ~(CongA A B C A' B' C') -> Ang A B C a -> ~(a A' B' C').
Proof.
    intros.
    unfold Ang in H0.
    spliter.
    intro.
    apply H.
    apply (ang_conga a); auto.
Qed.

Lemma not_cong_is_ang1 : forall A B C A' B' C' a , ~(CongA A B C A' B' C') -> Ang A B C a -> ~(Ang A' B' C' a).
Proof.
    intros.
    intro.
    unfold Ang in *.
    spliter.
    apply H.
    apply (ang_conga a); auto.
Qed.

Lemma ex_eqa : forall a1 a2, (exists A , exists B, exists C, Ang A B C a1 /\ Ang A B C a2)  -> EqA a1 a2.
Proof.
    intros.
    ex_and H A.
    ex_and H0 B.
    ex_and H C.
    assert(HH:=H).
    assert(HH0:=H0).
    unfold Ang in HH.
    unfold Ang in HH0.
    spliter.
    unfold EqA.
    repeat split; auto; intro.
      assert(CongA A B C A0 B0 C0).
        eapply (is_ang_conga _ _ _ _ _ _ a1); auto.
        split; auto.
      assert(Ang A0 B0 C0 a2).
        apply (is_ang_conga_is_ang A B C); auto.
      unfold Ang in H7.
      tauto.
    assert(CongA A B C A0 B0 C0).
      eapply (is_ang_conga _ _ _ _ _ _ a2); auto.
      split; auto.
    assert(Ang A0 B0 C0 a1).
      apply (is_ang_conga_is_ang A B C); auto.
    unfold Ang in H7.
    tauto.
Qed.

Lemma all_eqa : forall A B C a1 a2, Ang A B C a1 -> Ang A B C a2 -> EqA a1 a2.
Proof.
    intros.
    apply ex_eqa.
    exists A.
    exists B.
    exists C.
    split; auto.
Qed.

Lemma is_ang_distinct : forall A B C a , Ang A B C a -> A <> B /\ C <> B.
Proof.
    intros.
    unfold Ang in H.
    spliter.
    unfold Q_CongA in H.
    ex_and H A0.
    ex_and H1 B0.
    ex_and H C0.
    assert(HH:= H2 A B C).
    destruct HH.
    apply H4 in H0.
    unfold CongA in H0.
    spliter.
    tauto.
Qed.

Lemma null_ang : forall A B C D a1 a2, Ang A B A a1 -> Ang C D C a2 -> EqA a1 a2.
Proof.
    intros.
    eapply (all_eqa A B A).
      apply H.
    eapply (is_ang_conga_is_ang C D C).
      auto.
    eapply l11_21_b.
      apply out_trivial.
      apply is_ang_distinct in H0.
      tauto.
    apply out_trivial.
    apply is_ang_distinct in H.
    tauto.
Qed.

Lemma flat_ang : forall A B C A' B' C' a1 a2, Bet A B C -> Bet A' B' C' -> Ang A B C a1 -> Ang A' B' C' a2  -> EqA a1 a2.
Proof.
    intros.
    eapply (all_eqa A B C).
      apply H1.
    eapply (is_ang_conga_is_ang A' B' C').
      apply H2.
    apply is_ang_distinct in H1.
    apply is_ang_distinct in H2.
    spliter.
    eapply conga_line; auto.
Qed.

Lemma ang_distinct: forall a A B C, Q_CongA a -> a A B C -> A <> B /\ C <> B.
Proof.
    intros.
    assert(Ang A B C a).
      split; auto.
    apply (is_ang_distinct _ _ _ a); auto.
Qed.

Lemma ex_ang : forall A B C, B <> A -> B <> C -> exists a, Q_CongA a /\ a A B C.
Proof.
    intros.
    exists (fun X Y Z => CongA A B C X Y Z).
    unfold Q_CongA.
    split.
      exists A.
      exists B.
      exists C.
      split.
        auto.
      split.
        auto.
      intros.
      split.
        intro.
        auto.
      intro.
      auto.
    apply conga_refl; auto.
Qed.

(************************************* Acute angle *****************************************)

Lemma anga_exists : forall A B C, A <> B -> C <> B -> Acute A B C -> exists a, Q_CongA_Acute a /\ a A B C.
Proof.
    intros.
    exists (fun D E F => CongA A B C D E F).
    split.
      unfold Q_CongA.
      exists A.
      exists B.
      exists C.
      split.
        auto.
      intros.
      split; auto.
    apply conga_refl; auto.
Qed.

Lemma anga_is_ang : forall a, Q_CongA_Acute a -> Q_CongA a.
Proof.
    intros.
    unfold Q_CongA_Acute in H.
    unfold Q_CongA.
    ex_and H A.
    ex_and H0 B.
    ex_and H C.
    exists A.
    exists B.
    exists C.
    apply acute_distincts in H.
    spliter.
    split.
      auto.
    split.
      auto.
    intros.
    split.
      intro.
      assert(Ang X Y Z a).
        unfold Ang.
        split.
          unfold Q_CongA.
          exists A.
          exists B.
          exists C.
          split.
            assumption.
          split.
            assumption.
          auto.
        assert(HH:= H0 X Y Z).
        apply HH.
        auto.
      unfold Ang in H3.
      spliter.
      auto.
    intro.
    apply H0.
    auto.
Qed.

Lemma ex_points_anga : forall a , Q_CongA_Acute a ->  exists A, exists B, exists C, a A B C.
Proof.
    intros.
    assert(HH:=H).
    apply anga_is_ang in H.
    ang_instance a A B C.
    exists A.
    exists B.
    exists C.
    assumption.
Qed.

End Angles_2.

Ltac anga_instance a A B C :=
  assert(tempo_anga:= ex_points_anga a);
  match goal with
    |H: Q_CongA_Acute a |-  _ => assert(tempo_H:=H); apply tempo_anga in tempo_H;
                                 elim tempo_H; intros A ;
                                 let tempo_HP := fresh "tempo_HP" in
                                 intro tempo_HP; clear tempo_H;
                                 elim tempo_HP; intro B;
                                 let tempo_HQ := fresh "tempo_HQ" in
                                 intro tempo_HQ ; clear tempo_HP ;
                        elim tempo_HQ; intro C; intro;  clear tempo_HQ
  end;
  clear tempo_anga.

Require Import Setoid.

Section Angles_3.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Lemma anga_conga : forall a A B C A' B' C', Q_CongA_Acute a -> a A B C -> a A' B' C' -> CongA A B C A' B' C'.
Proof.
    intros.
    apply (ang_conga a); auto.
    apply anga_is_ang.
    auto.
Qed.

Lemma is_anga_to_is_ang : forall A B C a, Ang_Acute A B C a -> Ang A B C a.
Proof.
    intros.
    unfold Ang_Acute in H.
    unfold Ang.
    spliter.
    split.
      apply anga_is_ang.
      auto.
    auto.
Qed.

Lemma is_anga_conga : forall A B C A' B' C' a, Ang_Acute A B C a -> Ang_Acute A' B' C' a -> CongA A B C A' B' C'.
Proof.
    intros.
    unfold Ang_Acute in *.
    spliter.
    apply (anga_conga a); auto.
Qed.

Lemma is_anga_conga_is_anga : forall A B C A' B' C' a, Ang_Acute A B C a -> CongA A B C A' B' C' -> Ang_Acute A' B' C' a.
Proof.
    intros.
    unfold Ang_Acute in *.
    spliter.
    split.
      auto.
    apply anga_is_ang in H.
    unfold Q_CongA in H.
    ex_and H A0.
    ex_and H2 B0.
    ex_and H C0.
    assert(HH:= H3 A B C).
    destruct HH.
    assert(HH1:= H3 A' B' C').
    destruct HH1.
    apply H5 in H1.
    apply H6.
    eapply conga_trans.
      apply H1.
    auto.
Qed.

Lemma not_conga_is_anga : forall A B C A' B' C' a , ~ CongA A B C A' B' C' -> Ang_Acute A B C a -> ~(a A' B' C').
Proof.
    intros.
    unfold Ang_Acute in H0.
    spliter.
    intro.
    apply H.
    apply (anga_conga a); auto.
Qed.

Lemma not_cong_is_anga1 : forall A B C A' B' C' a , ~ CongA A B C A' B' C' -> Ang_Acute A B C a -> ~ Ang_Acute A' B' C' a.
Proof.
    intros.
    intro.
    unfold Ang_Acute in *.
    spliter.
    apply H.
    apply (anga_conga a); auto.
Qed.

Lemma ex_eqaa : forall a1 a2, (exists A , exists B, exists C, Ang_Acute A B C a1 /\ Ang_Acute A B C a2)  -> EqA a1 a2.
Proof.
    intros.
    apply ex_eqa.
    ex_and H A.
    ex_and H0 B.
    ex_and H C.
    exists A.
    exists B.
    exists C.
    split; apply is_anga_to_is_ang; auto.
Qed.

Lemma all_eqaa : forall A B C a1 a2, Ang_Acute A B C a1 -> Ang_Acute A B C a2 -> EqA a1 a2.
Proof.
    intros.
    apply ex_eqaa.
    exists A.
    exists B.
    exists C.
    split; auto.
Qed.

Lemma is_anga_distinct : forall A B C a , Ang_Acute A B C a -> A <> B /\ C <> B.
Proof.
    intros.
    apply (is_ang_distinct A B C a).
    apply is_anga_to_is_ang.
    auto.
Qed.

Global Instance eqA_equivalence : Equivalence EqA.
Proof.
split.
unfold Reflexive.
intros.
unfold EqA.
intros;tauto.
unfold Symmetric, EqA.
intros.
firstorder.
unfold Transitive, EqA.
intros.
rewrite H.
apply H0.
Qed.

Lemma null_anga : forall A B C D a1 a2, Ang_Acute A B A a1 -> Ang_Acute C D C a2 -> EqA a1 a2.
Proof.
    intros.
    eapply (all_eqaa A B A).
      apply H.
    eapply (is_anga_conga_is_anga C D C).
      auto.
    eapply l11_21_b.
      apply out_trivial.
      apply is_anga_distinct in H0.
      tauto.
    apply out_trivial.
    apply is_anga_distinct in H.
    tauto.
Qed.

Lemma anga_distinct: forall a A B C, Q_CongA_Acute a -> a A B C -> A <> B /\ C <> B.
Proof.
    intros.
    assert(Ang_Acute A B C a).
      split; auto.
    apply (is_anga_distinct _ _ _ a); auto.
Qed.

Lemma out_is_len_eq : forall A B C l, Out A B C -> Len A B l -> Len A C l -> B = C.
Proof.
    intros.
    assert(Cong A B A C).
      apply (is_len_cong _ _ _ _ l); auto.
    assert(A <> C).
      unfold Out in H.
      spliter.
      auto.
    eapply (l6_11_uniqueness A A C C ); Cong.
    apply out_trivial.
    auto.
Qed.

Lemma out_len_eq : forall A B C l, Q_Cong l -> Out A B C -> l A B -> l A C -> B = C.
Proof.
    intros.
    apply (out_is_len_eq A _ _ l).
      auto.
      split; auto.
    split; auto.
Qed.

Lemma ex_anga : forall A B C, Acute A B C -> exists a, Q_CongA_Acute a /\ a A B C.
Proof.
    intros.
    exists (fun X Y Z => CongA A B C X Y Z).
    unfold Q_CongA_Acute.
    assert (HH := acute_distincts A B C H).
    spliter.
    split.
      exists A.
      exists B.
      exists C.
      split; auto.
      intros.
      intros.
      split.
        intro.
        auto.
      intro.
      auto.
    apply conga_refl; auto.
Qed.

Lemma not_null_ang_ang : forall a, Q_CongA_nNull a -> Q_CongA a.
Proof.
    intros.
    unfold Q_CongA_nNull  in H.
    spliter; auto.
Qed.

Lemma not_null_ang_def_equiv : forall a, Q_CongA_nNull a <-> (Q_CongA a /\ exists A, exists B, exists C, a A B C /\  ~Out B A C).
Proof.
    intros.
    split.
      intro.
      unfold Q_CongA_nNull in H.
      spliter.
      assert(HH:= H).
      unfold Q_CongA in HH.
      ex_and HH A.
      ex_and H1 B.
      ex_and H2 C.
      split.
        auto.
      exists A.
      exists B.
      exists C.
      assert(HH:= H3 A B C).
      destruct HH.
      assert(a A B C).
        apply H4.
        apply conga_refl; auto.
      split.
        auto.
      apply (H0 A B C).
      auto.
    intros.
    spliter.
    ex_and H0 A.
    ex_and H1 B.
    ex_and H0 C.
    unfold Q_CongA_nNull.
    split; auto.
    intros.
    assert(CongA A0 B0 C0 A B C).
      apply (ang_conga a); auto.
    intro.
    apply H1.
    apply (l11_21_a A0 B0 C0); auto.
Qed.

Lemma not_flat_ang_def_equiv : forall a, Q_CongA_nFlat a <-> (Q_CongA a /\ exists A, exists B, exists C, a A B C /\  ~Bet A B C).
Proof.
    intros.
    split.
      intro.
      unfold Q_CongA_nFlat in H.
      spliter.
      assert(HH:= H).
      unfold Q_CongA in HH.
      ex_and HH A.
      ex_and H1 B.
      ex_and H2 C.
      split.
        auto.
      exists A.
      exists B.
      exists C.
      assert(HH:= H3 A B C).
      destruct HH.
      assert(a A B C).
        apply H4.
        apply conga_refl; auto.
      split.
        auto.
      apply (H0 A B C).
      auto.
    intros.
    spliter.
    ex_and H0 A.
    ex_and H1 B.
    ex_and H0 C.
    unfold Q_CongA_nFlat.
    split; auto.
    intros.
    assert(CongA A0 B0 C0 A B C).
      apply (ang_conga a); auto.
    intro.
    apply H1.
    apply (bet_conga__bet A0 B0 C0); auto.
Qed.

Lemma ang_const : forall a A B, Q_CongA a -> A <> B -> exists C, a A B C.
Proof.
    intros.
    unfold Q_CongA in H.
    ex_and H A0.
    ex_and H1 B0.
    ex_and H C0.
    apply(swap_diff) in H1.
    assert(HH:= H2 A0 B0 C0).
    destruct HH.
    assert(a A0 B0 C0).
      apply H3.
      apply conga_refl; auto.
    assert(HH :=not_col_exists A B H0).
    ex_and HH P.
    induction(eq_dec_points A0 C0).
      subst C0.
      exists A.
      assert(HH:= (H2 A B A)).
      destruct HH.
      apply H7.
      apply conga_trivial_1; auto.
    assert(HH:=angle_construction_2 A0 B0 C0 A B P H H7 H1).
    ex_and HH C; auto.
    exists C.
    apply H2.
    auto.
Qed.

End Angles_3.

Ltac ang_instance1 a A B C :=
	assert(tempo_ang:= ang_const a A B);
        match goal with
           |H: Q_CongA a |-  _ => assert(tempo_H:= H);apply tempo_ang in tempo_H; ex_elim tempo_H C
        end;
        clear tempo_ang.

Section Angles_4.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Lemma ang_sym : forall a A B C, Q_CongA a -> a A B C -> a C B A.
Proof.
    intros.
    unfold Q_CongA in H.
    ex_and H A0.
    ex_and H1 B0.
    ex_and H C0.
    assert(HH:= H2 A B C).
    destruct HH.
    apply H4 in H0.
    apply conga_right_comm in H0.
    assert(HH:= H2 C B A).
    destruct HH.
    apply H5.
    auto.
Qed.

Lemma ang_not_null_lg : forall a l A B C, Q_CongA a -> Q_Cong l -> a A B C -> l A B -> ~ Q_Cong_Null l.
Proof.
    intros.
    intro.
    unfold Q_CongA in H.
    unfold Q_Cong_Null in H3.
    spliter.
    unfold Q_Cong in H0.
    ex_and H A0.
    ex_and H5 B0.
    ex_and H C0.
    assert(HH:= H6 A B C).
    destruct HH.
    assert(CongA A0 B0 C0 A B C).
      apply H8.
      auto.
    apply conga_distinct in H8.
      spliter.
      ex_and H0 A1.
      ex_and H14 B1.
      assert(HH:= H0 A B).
      destruct HH.
      ex_and H4 A'.
      assert(HH:= H0 A' A').
      destruct HH.
      assert(Cong A1 B1 A' A').
        apply H17.
        auto.
      assert(Cong A1 B1 A B).
        apply H15.
        auto.
      apply cong_identity in H17.
        subst B1.
        apply cong_symmetry in H19.
        apply cong_identity in H19.
        contradiction.
      auto.
    auto.
Qed.

Lemma ang_distincts : forall a A B C, Q_CongA a -> a A B C -> A <> B /\ C <> B.
Proof.
    intros.
    assert(HH:= ex_lg A B).
    ex_and HH la.
    assert(HH:= ex_lg C B).
    ex_and HH lc.
    assert(HH:= ang_not_null_lg a la A B C H H1 H0 H2).
    assert(a C B A).
      apply ang_sym; auto.
    assert(HQ:= ang_not_null_lg a lc C B A H H3 H5 H4).
    split; intro; subst B.
      apply HH.
      unfold Q_Cong_Null.
      split.
        auto.
      exists A.
      auto.
    apply HQ.
    unfold Q_Cong_Null.
    split.
      auto.
    exists C.
    auto.
Qed.

Lemma anga_sym : forall a A B C, Q_CongA_Acute a -> a A B C -> a C B A.
Proof.
    intros.
    unfold Q_CongA_Acute in H.
    ex_and H A0.
    ex_and H1 B0.
    ex_and H C0.
    assert(HH:= H1 A B C).
    destruct HH.
    apply H3 in H0.
    apply conga_right_comm in H0.
    assert(HH:= H1 C B A).
    destruct HH.
    apply H4.
    auto.
Qed.

Lemma anga_not_null_lg : forall a l A B C, Q_CongA_Acute a -> Q_Cong l -> a A B C -> l A B -> ~ Q_Cong_Null l.
Proof.
    intros.
    intro.
    unfold Q_CongA_Acute in H.
    unfold Q_Cong_Null in H3.
    spliter.
    unfold Q_Cong in H0.
    ex_and H A0.
    ex_and H5 B0.
    ex_and H C0.
    assert(HH:= H5 A B C).
    destruct HH.
    assert(CongA A0 B0 C0 A B C).
      apply H7.
      auto.
    apply conga_distinct in H8.
    spliter.
    ex_and H0 A1.
    ex_and H13 B1.
    assert(HH:= H0 A B).
    destruct HH.
    ex_and H4 A'.
    assert(HH:= H0 A' A').
    destruct HH.
    assert(Cong A1 B1 A' A').
      apply H16.
      auto.
    assert(Cong A1 B1 A B).
      apply H14.
      auto.
    apply cong_identity in H17.
    subst B1.
    apply cong_symmetry in H18.
    apply cong_identity in H18.
    contradiction.
Qed.

Lemma anga_distincts : forall a A B C, Q_CongA_Acute a -> a A B C -> A <> B /\ C <> B.
Proof.
    intros.
    assert(HH:= ex_lg A B).
    ex_and HH la.
    assert(HH:= ex_lg C B).
    ex_and HH lc.
    assert(HH:= anga_not_null_lg a la A B C H H1 H0 H2).
    assert(a C B A).
      apply anga_sym; auto.
    assert(HQ:= anga_not_null_lg a lc C B A H H3 H5 H4).
    split; intro; subst B.
      apply HH.
      unfold Q_Cong_Null.
      split.
        auto.
      exists A.
      auto.
    apply HQ.
    unfold Q_Cong_Null.
    split.
      auto.
    exists C.
    auto.
Qed.

Lemma ang_const_o : forall a A B P, ~Col A B P -> Q_CongA a -> Q_CongA_nNull a -> Q_CongA_nFlat a -> exists C, a A B C /\ OS A B C P.
Proof.
    intros.
    assert(HH:= H0).
    unfold Q_CongA in HH.
    ex_and HH A0.
    ex_and H3 B0.
    ex_and H4 C0.
    apply(swap_diff) in H4.
    assert(HH:= H5 A0 B0 C0).
    destruct HH.
    assert(a A0 B0 C0).
      apply H6.
      apply conga_refl; auto.
    assert(HH:=ang_distincts a A0 B0 C0 H0 H8).
    assert(A0 <> C0).
      intro.
      subst C0.
      unfold Q_CongA_nNull in H1.
      spliter.
      assert(HH:=H11 A0 B0 A0 H8).
      apply HH.
      apply out_trivial; auto.
    spliter.
    assert(A <> B).
      intro.
      subst B.
      apply H.
      Col.
    assert(HH:=angle_construction_2 A0 B0 C0 A B P H10 H9 H4).
    ex_and HH C; auto.
    exists C.
    assert(a A B C).
      assert(HH:= H5 A B C).
      destruct HH.
      apply H15.
      auto.
    split.
      auto.
    induction H14.
      auto.
    unfold Q_CongA_nNull in H1.
    spliter.
    assert(HH:= H16 A B C H15).
    unfold Q_CongA_nFlat in H2.
    spliter.
    assert(Hh:=H17 A B C H15).
    apply False_ind.
    assert(HH0:=ang_distincts a A B C H0 H15).
    spliter.
    assert(HP:=or_bet_out A B C).
    induction HP.
      contradiction.
    induction H20.
      contradiction.
    contradiction.
Qed.

Lemma anga_const : forall a A B, Q_CongA_Acute a -> A <> B -> exists C, a A B C.
Proof.
    intros.
    apply anga_is_ang in H.
    apply ang_const; auto.
Qed.

End Angles_4.

Ltac anga_instance1 a A B C :=
	assert(tempo_anga:= anga_const a A B);
        match goal with
           |H: Q_CongA_Acute a |-  _ => assert(tempo_H:= H); apply tempo_anga in tempo_H; ex_elim tempo_H C
        end;
        clear tempo_anga.

Section Angles_5.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Lemma null_anga_null_anga' : forall a, Q_CongA_Null_Acute a <-> is_null_anga' a.
Proof.
    intro.
    split.
      intro.
      unfold Q_CongA_Null_Acute in H.
      unfold is_null_anga'.
      spliter.
      split.
        auto.
      anga_instance a A B C.
      assert(HH:= H0 A B C H1).
      exists A.
      exists B.
      exists C.
      split; auto.
    intro.
    unfold is_null_anga' in H.
    unfold Q_CongA_Null_Acute.
    spliter.
    ex_and H0 A.
    ex_and H1 B.
    ex_and H0 C.
    split; auto.
    intros.
    assert(CongA A B C A0 B0 C0).
      apply (anga_conga a); auto.
    apply (l11_21_a A B C); auto.
Qed.

Lemma is_null_anga_out : forall a A B C, Q_CongA_Acute a -> a A B C -> Q_CongA_Null_Acute a -> Out B A C.
Proof.
    intros.
    unfold Q_CongA_Null_Acute in H1.
    spliter.
    assert(HH:= (H2 A B C)).
    apply HH.
    auto.
Qed.

Lemma acute_not_bet : forall A B C, Acute A B C -> ~Bet A B C.
Proof.
    intros.
    unfold Acute in H.
    ex_and H A0.
    ex_and H0 B0.
    ex_and H C0.
    unfold LtA in H0.
    spliter.
    unfold LeA in H0.
    ex_and H0 P.
    unfold InAngle in H0.
    spliter.
    ex_and H5 X.
    intro.
    apply conga_distinct in H2.
    spliter.
    assert(A<>C) by (intro; treat_equalities; auto).
    induction H6.
      subst X.
      apply H1.
      apply conga_line; auto.
    assert(Bet A0 B0 P).
      apply (bet_conga__bet A B C); auto.
    assert(Bet A0 B0 C0).
      unfold Out in H6.
      spliter.
      induction H15.
        eBetween.
      eBetween.
    apply H1.
    apply (conga_line A B C); auto.
Qed.

Lemma anga_acute : forall a A B C , Q_CongA_Acute a -> a A B C -> Acute A B C.
Proof.
    intros.
    unfold Q_CongA_Acute in H.
    ex_and H A0.
    ex_and H1 B0.
    ex_and H C0.
    assert(HH:= acute_lea_acute A B C A0 B0 C0).
    apply HH.
      auto.
    unfold LeA.
    exists C0.
    split.
      unfold InAngle.
      apply acute_distincts in H.
      spliter.
      repeat split; auto.
      exists C0.
      split.
        Between.
      right.
      apply out_trivial.
      auto.
    assert(HP:= H1 A B C).
    destruct HP.
    apply conga_sym.
    apply H3.
    auto.
Qed.

Lemma not_null_not_col : forall a A B C, Q_CongA_Acute a -> ~ Q_CongA_Null_Acute a -> a A B C -> ~Col A B C.
Proof.
    intros.
    intro.
    apply H0.
    unfold Q_CongA_Null_Acute.
    split.
      auto.
    assert(Acute A B C).
      apply (anga_acute a); auto.
    intros.
    assert(Out B A C).
      apply acute_col__out; auto.
    assert(HH:= anga_conga a A B C A0 B0 C0 H H1 H4).
    apply (l11_21_a A B C); auto.
Qed.

Lemma ang_cong_ang : forall a A B C A' B' C', Q_CongA a -> a A B C -> CongA A B C A' B' C' -> a A' B' C'.
Proof.
    intros.
    assert(Ang A B C a).
      unfold Ang.
      split; auto.
    assert(Ang A' B' C' a).
      apply (is_ang_conga_is_ang A B C); auto.
    unfold Ang in H3.
    tauto.
Qed.

Lemma is_null_ang_out : forall a A B C, Q_CongA a -> a A B C -> Q_CongA_Null a -> Out B A C.
Proof.
    intros.
    unfold Q_CongA_Null in H1.
    spliter.
    assert(HH:= (H2 A B C)).
    apply HH.
    auto.
Qed.

Lemma out_null_ang : forall a A B C, Q_CongA a -> a A B C -> Out B A C -> Q_CongA_Null a.
Proof.
    intros.
    unfold Q_CongA_Null.
    split.
      auto.
    intros.
    assert(HH:=l11_21_a A B C A0 B0 C0 H1).
    apply HH.
    apply (ang_conga a); auto.
Qed.

Lemma bet_flat_ang : forall a A B C, Q_CongA a -> a A B C -> Bet A B C -> Ang_Flat a.
Proof.
    intros.
    unfold Ang_Flat.
    split.
      auto.
    intros.
    assert(HH:=bet_conga__bet A B C A0 B0 C0 H1).
    apply HH.
    apply (ang_conga a); auto.
Qed.

Lemma out_null_anga : forall a A B C, Q_CongA_Acute a -> a A B C -> Out B A C -> Q_CongA_Null_Acute a.
Proof.
    intros.
    unfold Q_CongA_Null_Acute.
    split.
      auto.
    intros.
    assert(HH:=l11_21_a A B C A0 B0 C0 H1).
    apply HH.
    apply (anga_conga a); auto.
Qed.

Lemma anga_not_flat : forall a, Q_CongA_Acute a -> Q_CongA_nFlat a.
Proof.
    intros.
    unfold Q_CongA_nFlat.
    split.
      apply anga_is_ang in H.
      auto.
    intros.
    assert(HH:= anga_acute a A B C H H0).
    unfold Q_CongA_Acute in H.
    ex_and H A0.
    ex_and H1 B0.
    ex_and H C0.
    assert(HP:= H1 A B C).
    apply acute_not_bet.
    auto.
Qed.

Lemma anga_const_o : forall a A B P, ~Col A B P -> ~ Q_CongA_Null_Acute a -> Q_CongA_Acute a -> exists C, a A B C /\ OS A B C P.
Proof.
    intros.
    assert(Q_CongA a).
      apply anga_is_ang; auto.
    assert(Q_CongA_nNull a).
      unfold Q_CongA_nNull.
      split.
        auto.
      intros A' B' C' HP.
      intro.
      apply H0.
      eapply (out_null_anga a A' B' C'); auto.
    assert(Q_CongA_nFlat a).
      apply anga_not_flat.
      auto.
    assert(HH:= ang_const_o a A B P H H2 H3 H4).
    auto.
Qed.

Lemma anga_conga_anga : forall a A B C A' B' C' , Q_CongA_Acute a -> a A B C -> CongA A B C A' B' C' -> a A' B' C'.
Proof.
    intros.
    unfold Q_CongA_Acute in H.
    ex_and H A0.
    ex_and H2 B0.
    ex_and H C0.
    assert(HH := H2 A B C).
    assert(HP := H2 A' B' C').
    destruct HH.
    destruct HP.
    apply H4 in H0.
    assert(CongA A0 B0 C0 A' B' C').
      eapply conga_trans.
        apply H0.
      apply H1.
    apply H5.
    auto.
Qed.

Lemma anga_out_anga : forall a A B C A' C', Q_CongA_Acute a -> a A B C -> Out B A A' -> Out B C C' -> a A' B C'.
Proof.
    intros.
    assert(HH:= H).
    unfold Q_CongA_Acute in HH.
    ex_and HH A0.
    ex_and H3 B0.
    ex_and H4 C0.
    assert(HP:= H4 A B C).
    destruct HP.
    assert(CongA A0 B0 C0 A B C).
      apply H6.
      auto.
    assert(HP:= anga_distincts a A B C H H0).
    spliter.
    assert(CongA A B C A' B C').
      apply out2__conga; apply l6_6; assumption.
    assert(HH:= H4 A' B C').
    destruct HH.
    apply H11.
    apply (conga_trans _ _ _ A B C); auto.
Qed.

Lemma out_out_anga : forall a A B C A' B' C', Q_CongA_Acute a -> Out B A C -> Out B' A' C' -> a A B C -> a A' B' C'.
Proof.
    intros.
    assert(CongA A B C A' B' C').
      apply l11_21_b; auto.
    apply (anga_conga_anga a A B C); auto.
Qed.

Lemma is_null_all : forall a A B, A <> B -> Q_CongA_Null_Acute a -> a A B A.
Proof.
    intros.
    unfold Q_CongA_Null_Acute in H0.
    spliter.
    assert(HH:= H0).
    unfold Q_CongA_Acute in HH.
    ex_and HH A0.
    ex_and H2 B0.
    ex_and H3 C0.
    apply acute_distincts in H2.
    spliter.
    apply H3.
    assert (a A0 B0 C0).
      apply H3.
      apply conga_refl; auto.
    assert(HH:= (H1 A0 B0 C0 H5)).
    apply l11_21_b; auto.
    apply out_trivial.
    auto.
Qed.

Lemma anga_col_out : forall a A B C, Q_CongA_Acute a -> a A B C -> Col A B C -> Out B A C.
Proof.
    intros.
    assert(Acute A B C).
      apply (anga_acute a); auto.
    unfold Col in H1.
    induction H1.
      apply acute_not_bet in H2.
      contradiction.
    unfold Out.
    apply (anga_distinct a A B C) in H.
      spliter.
      repeat split; auto.
      induction H1.
        right.
        auto.
      left.
      Between.
    auto.
Qed.

Lemma ang_not_lg_null : forall a la lc A B C, Q_Cong la -> Q_Cong lc -> Q_CongA a ->
 la A B -> lc C B -> a A B C -> ~ Q_Cong_Null la /\ ~ Q_Cong_Null lc.
Proof.
    intros.
    assert(HH:=ang_distincts a A B C H1 H4).
    spliter.
    split.
      intro.
      unfold Q_Cong_Null in H7.
      spliter.
      ex_and H8 P.
      assert(HH:= lg_cong la A B P P H H2 H9).
      apply cong_identity in HH.
      contradiction.
    intro.
    unfold Q_Cong_Null in H7.
    spliter.
    ex_and H8 P.
    assert(HH:= lg_cong lc C B P P H0 H3 H9).
    apply cong_identity in HH.
    contradiction.
Qed.

Lemma anga_not_lg_null : forall a la lc A B C, Q_Cong la -> Q_Cong lc ->
 Q_CongA_Acute a -> la A B -> lc C B -> a A B C -> ~ Q_Cong_Null la /\ ~ Q_Cong_Null lc.
Proof.
    intros.
    apply anga_is_ang in H1.
    apply(ang_not_lg_null a la lc A B C); auto.
Qed.

Lemma anga_col_null : forall a A B C, Q_CongA_Acute a -> a A B C -> Col A B C -> Out B A C /\ Q_CongA_Null_Acute a.
Proof.
    intros.
    assert(HH:= anga_distincts a A B C H H0).
    spliter.
    assert(Out B A C).
      induction H1.
        assert(HP:=anga_acute a A B C H H0).
        assert(HH:=acute_not_bet A B C HP).
        contradiction.
      induction H1.
        unfold Out.
        repeat split; auto.
      unfold Out.
      repeat split; auto.
      left.
      Between.
    split.
      auto.
    apply (out_null_anga a A B C); auto.
Qed.

Lemma eqA_preserves_ang: forall a b, Q_CongA a -> EqA a b -> Q_CongA b.
Proof.
intros.
unfold Q_CongA in *.
decompose [ex and] H.
exists x. exists x0. exists x1.
split.
assumption.
split.
assumption.
intros.
rewrite H4.
unfold EqA in H0.
apply H0.
Qed.

Lemma eqA_preserves_anga : forall a b, Q_CongA_Acute a -> Q_CongA b -> EqA a b -> Q_CongA_Acute b.
Proof.
    intros.
    assert (Q_CongA a).
        apply eqA_preserves_ang with b;auto.
        symmetry;auto.
    unfold EqA in H1.
    anga_instance a A B C.

    assert(HH:= H1 A B C).
    destruct HH.
    unfold Q_CongA_Acute.
    exists A.
    exists B.
    exists C.
    split.
      unfold Q_CongA_Acute in H.
      ex_and H A'.
      ex_and H6 B'.
      ex_and H C'.
      assert(a A' B' C').
        assert(HP:= H6 A B C).
        destruct HP.
        assert(CongA A B C A' B' C') by (apply conga_sym;auto).
        assert(HP:=is_ang_conga_is_ang A B C A' B' C' a).
        assert(Ang A' B' C' a).
          apply HP.
            split; auto.
          auto.
        unfold Ang in H10.
        spliter.
        auto.
      apply (acute_lea_acute _ _ _ A' B' C').
        auto.
      unfold LeA.
      exists C'.
      split.
        assert (HH:= acute_distincts A' B' C' H).
        spliter.
        apply inangle3123; auto.
      apply (is_ang_conga _ _ _ _ _ _ a).
        split; auto.
      split; auto.
    intros.
    split.
      intro.
      assert(HH:= H1 X Y Z).
      destruct HH.
      assert(Ang X Y Z a).
        eapply (is_ang_conga_is_ang A B C).
          split; auto.
        auto.
      unfold Ang in H9.
      spliter.
      auto.
    intro.
    assert(HH:= H1 X Y Z).
    destruct HH.
    assert(a X Y Z).
      auto.
    apply (is_ang_conga _ _ _ _ _ _ a).
      split; auto.
    split; auto.
Qed.

End Angles_5.


Require Export XR_R.
Require Export XR_Rle.
Require Export XR_Rlt_asym.

Implicit Type r : R.
Local Open Scope R_scope.

Lemma Rle_antisym : forall r1 r2, r1 <= r2 -> r2 <= r1 -> r1 = r2.
Proof.
  intros x y.
  intros hxy hyx.
  unfold "<=" in hxy, hyx.
  destruct hxy as [ hxy | heq ].
  {
    destruct hyx as [ hyx | heq ].
    {
      exfalso.
      assert (asym := Rlt_asym x y).
      unfold "~" in asym.
      apply asym.
      { exact hxy. }
      { exact hyx. }
    }
    { subst y. reflexivity. }
  }
  { subst y. reflexivity. }
Qed.


Definition or_user_2[a:bool]:=<bool->bool>Case a of ([_:bool]true) ([b:bool]b)  end.

Parameter c:bool.
Lemma or1:(or_user_2 true c)=true.
Simpl.
Trivial.
Save.

Require codigoCoq.
Require Arith.

(* ===== OPERACIONES DE NUMEROS NATURALES =========*)

(* suma de dos naturales, resultado natural *)
Fixpoint sumN[n,m:nat]:nat:=
Cases n m of
h O=>h
|h (S i)=>(S (sumN h i))
end.

(* predecesor de un natural, para el cero es cero *)
Definition predN:=[n:nat]Cases n of O=>O | (S i)=>i end.

(* resta de dos naturales, resultado natural *)
Fixpoint restaN[n,m:nat]:nat:=
Cases n m of
h O=>h
|h (S k)=>(predN(restaN h k))
end.

(* resta de dos naturales, resultado natural, VERSION _REC *)
Definition mi_restaN:=[n:nat]
(nat_rec [_:nat]nat n [k,b:nat](predN b)).

(* producto de naturales, resultado natural *)
Fixpoint productoN[n,m:nat]:nat:= Cases n m of
_ O => O
|k (S l)=> (sumN k (productoN k l))
end.

(* potencia de naturales, resultado natural *)
Fixpoint potenciaN[n,m:nat]:nat:= Cases n m of
_ O => (S O)
|k (S l)=> (productoN k (potenciaN k l))
end.

(* factorial de un natural, resultado natural *)
Fixpoint factorial[n:nat]:nat:=
Cases n of
O => (S O)
|(S l)=>(productoN (S l) (factorial l))
end.

(* factorial de un natural, resultado natural, VERSION _REC *)
Definition mifactorial:=
(nat_rec ([_:nat]nat) (S O) [j:nat][l:nat](productoN (S j) l)).

(* potencia de dos naturales, resultado natural, VERSION _REC *)
Definition mipotencia:=[x:nat]
(nat_rec ([_:nat]nat) (S O) [k:nat][v:nat](productoN x v)).

(* producto de dos naturales, resultado natural, VERSION _REC *)
Definition miproducto:=[x:nat]
(nat_rec ([_:nat]nat) O [k:nat][f:nat](sumN x f)).

(* suma de dos naturales, resultado natural, VERSION _REC *)
Definition misuma:=[x:nat]
(nat_rec ([_:nat]nat) x [k:nat][f:nat](S f)).

(* LEMAS DE LAS RESTAS==================*)

(* primer lema sobre las restas *)
Lemma restaN_eq1:(n,m:nat)(restaN n m)=(mi_restaN  n m).
Intros.
Induction m.
Simpl.
Trivial.
Simpl.
Induction n.
Rewrite Hrecm.
Trivial.
Rewrite Hrecm.
Trivial.
Save.

(* segundo lema sobre la resta *)
Lemma mi_restaN_1:(n:nat)(mi_restaN O n)=O.
Induction n.
Simpl; Trivial.
Simpl.
Intros.
Rewrite H.
Simpl.
Trivial.
Save.

(* tercer lema sobre la resta *)
Lemma mi_restaN_2:(n:nat)(mi_restaN n O)=n.
Induction n.
Simpl; Trivial.
Simpl.
Trivial.
Save.

(* IGUALDAD ======= *)
(* igualdad para los naturales *)
Fixpoint egal_nat[n:nat]:nat->bool:=
[m:nat]
Cases n m of
O O=>true
|(S n) (S m)=>(egal_nat n m)
|_ _=>false
end.

(* comprobacion de igualdad con cero *)
Definition es_cero[n:nat]:=
Cases n of
O=>true
|(S n)=>false
end.

(* igualdad para los naturales, VERSION _REC *)
Definition egal_natt:=[n:nat]
(nat_rec [_:nat]bool (if (es_cero n) then true else false)
[indice:nat][k:bool](if (k) then false else
			(if (es_cero (minus (S indice) n))
				then true
				else false)
		    )
).

(* ===== DEFINICION DE ENTEROS ===== *)
Inductive Set Z:=
cero:Z
|pos:nat->Z
|neg:nat->Z.

(* primera version de opuestos de enteros *)
Definition opuestoZ[a:Z]:=
Cases a of
cero=>cero
|(pos n)=>(neg n)
|(neg n)=>(pos n)
end.

(* segunda version de opuestos de enteros *)
Definition opu_Z[a:Z]:=
Cases a of
cero=>cero
|(pos n)=>(neg n)
|(neg n)=>(pos n)
end.

(* opuesto de un entero, VERSION _REC *)
Definition mi_opuesto:=
(Z_rec ([_:Z]Z) cero [v:nat](neg v) [vn:nat](pos vn)).

(* siguiente de un entero *)
Definition sigZ[a:Z]:=
Cases a of
cero=>(pos O)
|(pos n)=>(pos (S n))
|(neg O)=>cero
|(neg (S n))=>(neg n)
end.

(* predecesor de un entero *)
Definition predZ[a:Z]:=
Cases a of
cero=>(neg O)
|(pos (S n))=>(pos  n)
|(pos O)=>cero
|(neg n)=>(neg (S n))
end.

(* igual a signo(a)*(abs(a)+1) *)
Definition absZ[a:Z]:=
Cases a of
cero=>(pos O)
|(pos n)=>(pos (S n))
|(neg n)=>(neg (S n))
end.

(* proyeccion de nat sobre Z, impares son positivos, pares negativos *)
Fixpoint semantica[n:nat]:Z:=
Cases n of
O=>cero
|(S O)=>(pos O)
|(S(S O))=>(neg O)
|(S(S n))=>(absZ (semantica n))
end.

(* resta de dos naturales,resultado entero *)
Fixpoint difN[n:nat]:nat->Z:=
Cases n of
O => ([n2:nat] Cases n2 of O=>cero | (S k)=>(neg k) end)
|(S l) => ([n2:nat] Cases n2 of O=>(pos l) | (S m)=> (difN l m) end)
end.

(* suma de dos naturales, resultado entero *)
Fixpoint sumZ[n:nat]:nat->Z:=
Cases n of
O => ([n2:nat] Cases n2 of O=>cero | (S k)=>(pos k) end)
|(S l) => ([n2:nat] Cases n2 of O=>(pos l) | (S m)=> (sigZ(sumZ l (S m))) end)
end.

(* suma de dos enteros, resultado entero *)
Definition suma[a,b:Z]:=<Z>Cases (a,b) of
(cero,v)=>v
|(v,cero)=>v
|((pos n),(pos m))=>(sumZ (S n) (S m))
|((pos n),(neg m))=>(difN (S n) (S m))
|((neg n),(pos m))=>(difN (S m) (S n))
|((neg n),(neg m))=>(opu_Z (sumZ (S n) (S m)))
end.

(* TONTERIAS =================================*)

(* proyeccion de los naturales sobre las expresiones *)
Fixpoint semExpr[e:expr]:Z:=
Cases e of
CERO => cero
| UNO => (pos O)
| (mas a b)=>(suma (semExpr a) (semExpr b))
| (menos a b)=>(suma (semExpr a) (opu_Z (semExpr b)))
end.

(* TONTERIAS =================================*)
(* lemas de los ejercicios *)
Lemma consUno:(n,m:nat)(n=m)->(pos n)=(pos m).
Intros.
Rewrite H.
Trivial.
Save.

Lemma consDos:(n,m:nat)(n=m)->(neg n)=(neg m).
Intros.
Rewrite H.
Trivial.
Save.

Lemma diffff:(n,m:nat)(difN (S n) (S m))=(difN n m).
Intros.
Simpl.
Trivial.
Save.

(*======= DEFINICIONES DE LISTAS =================================*)
(* Seccion de listas *)

(* definicion de las listas *)
Inductive lista[A:Set]:Set:=
Nil:(lista A)
|Cons:A->(lista A)->(lista A).

(* obtencion de la cola de una lista *)
Definition cdr[A:Set;l:(lista A)]:=<lista A>Cases l of
Nil=>(Nil A)
|(Cons A x)=>x
end.

(* obtiene la cola de una lista, VERSION _REC *)
Definition micdr:=[A:Set]
(lista_rec A [_:(lista A)](lista A) (Nil A) [_:A][l:(lista A)][_:(lista A)]l).

(* concatena dos listas *)
Fixpoint concat[A:Set;l:(lista A)]:(lista A)->(lista A):=
Cases l of
Nil=>[m:(lista A)]m
|(Cons x cd)=>[m:(lista A)](Cons A x (concat A cd m))
end.

(* concatena un elemento a una lista por detras, VERSION _REC *)
Definition mi_concatenar:=[A:Set;e:A]
(lista_rec A [_:(lista A)](lista A)
	(Cons A e (Nil A))
	[x:A;_:(lista A);l2:(lista A)](Cons A x l2)
).

(* concatena dos listas, VERSION _REC, NO FUNCIONA *)
(*
Definition mi_concat:=[A:Set;l1:(lista A)]
(lista_rec A [_:(lista A)](lista A) (invertir A l1)
	[x:A;la:(lista A)][l2:(lista A)](Cons A x l2)
).
*)

(* comprobacion *)
(*
Eval Compute in (concat nat (Cons nat (3) (Cons nat (2) (Nil nat))) (Cons nat (1) (Cons nat (0) (Nil nat)))).
*)

(* obtiene la longitud de una lista *)
Fixpoint longit[A:Set;l:(lista A)]:nat:=
Cases l of
Nil=>O
|(Cons _ cd)=>(S (longit A cd))
end.

(* obtiene la longitud de una lista , VERSION _REC*)
Definition milongit:=[A:Set]
(lista_rec A ([_:(lista A)]nat) O [_:A][l:(lista A)]S).

(* invierte una lista *)
Fixpoint invertir[A:Set;l:(lista A)]:(lista A):=
Cases l of
Nil => (Nil A)
|(Cons x l')=>(concat A (invertir A l') (Cons A x (Nil A)))
end.

(* invierte una lista, VERSION _REC *)
Definition miinvertir:=[A:Set]
(lista_rec A ([_:(lista A)](lista A)) (Nil A) [v:A][l:(lista A)][m:(lista A)]
(concat A m (Cons A v (Nil A)))).

(* cuenta el numero de ocurrencias de un entero en una lista de enteros *)
Fixpoint nocc[e:nat;l:(lista nat)]:nat:=
Cases l of
Nil => O
|(Cons x v)=>(if (egal_nat e x) then (S (nocc e v)) else (nocc e v))
end.

(* cuenta el numero de ocurrencias de un entero en una lista de enteros, VERSION _REC *)
Definition mi_nocc:=[e:nat]
(lista_rec nat [_:(lista nat)]nat O
	([i:nat;l:(lista nat);anterior:nat](if (egal_nat anterior e)
						then (S i)
						else i)
	)
).

(* obtiene la primera posicion de un elemento en una lista,funcion auxiliar *)
Fixpoint posicion_aux[e:nat;l:(lista nat)]:nat->nat:=[i:nat]
Cases l of
Nil=>O
|(Cons x l')=>(if (egal_nat e x) then (S i) else (posicion_aux e l' (S i)))
end.

(* obtiene la primera posicion de un elemento en una lista *)
Definition posicion:=[e:nat;l:(lista nat)](posicion_aux e l O).

(* obtiene la primera posicion de un elemento en una lista, VERSION _REC *)
Definition mi_posicion:=[e:nat]
(lista_rec nat [_:(lista nat)]nat O
	[y:nat;li:(lista nat)][ant:nat](if (egal_nat y e) then (S O)
					else (if (egal_nat O ant)
						then O
						else (S ant)
					      )
					)
).

(*=================================*)

(* not de un valor booleano *)
Definition mi_not[b:bool]:=
Case b of false true end.

(* operacion xor sobre booleanos *)
Definition mxor[b1,b2:bool]:=
Cases b1 b2 of
false b2=>b2
|true b2=>(mi_not b2)
end.

(* operacion xor sobre booleanos, VERSION _REC *)
Definition mi_xor:=[b:bool]
(bool_rec ([_:bool]bool) (mi_not b) b).

(*===== ENTEROS ALTERNATIVOS =================================*)
(*
Definicion de los enteros independientes, para hacer la suma de enteros recursivamente
*)
Inductive Set ZZ:=
cc:ZZ
|pp:ZZ->ZZ
|nn:ZZ->ZZ.

Definition sssig[l:ZZ]:=
Cases l of
cc=>(pp cc)
|(pp u)=>(pp l)
|(nn y)=>y
end.

Definition pppred[l:ZZ]:=
Cases l of
cc=>(nn cc)
|(pp u)=>u
|(nn y)=>(nn l)
end.

Fixpoint sumaZ[z1:ZZ]:ZZ->ZZ:=
[z2:ZZ]
Cases z1 of
cc=>z2
|(pp k)	=>(sumaZ k (sssig z2))
|(nn k)	=>(sumaZ k (pppred z2))
end.

(*=================================*)


Require Export Bool.
Require Export Arith.
Require Export Compare_dec.
Require Export Peano_dec.
Require Export MyList.
Require Export MyRelations.

Set Implicit Arguments.
Unset Strict Implicit.

  Definition max_nat (n m : nat) :=
    match le_gt_dec n m with
    | left _ => m
    | right _ => n
    end.

  Lemma least_upper_bound_max_nat :
   forall n m p : nat, n <= p -> m <= p -> max_nat n m <= p.
intros.
unfold max_nat in |- *.
elim (le_gt_dec n m); auto with arith.
Qed.

Require Export Relation_Definitions.

  Definition decide (P : Prop) := {P} + {~ P}.

  Hint Unfold decide: core.

  Inductive Acc3 (A B C : Set) (R : relation (A * (B * C))) :
  A -> B -> C -> Prop :=
      Acc3_intro :
        forall (x : A) (x0 : B) (x1 : C),
        (forall (y : A) (y0 : B) (y1 : C),
         R (y, (y0, y1)) (x, (x0, x1)) -> Acc3 R y y0 y1) ->
        Acc3 R x x0 x1.

  Lemma Acc3_rec :
   forall (A B C : Set) (R : relation (A * (B * C))) (P : A -> B -> C -> Set),
   (forall (x : A) (x0 : B) (x1 : C),
    (forall (y : A) (y0 : B) (y1 : C),
     R (y, (y0, y1)) (x, (x0, x1)) -> P y y0 y1) ->
    P x x0 x1) ->
   forall (x : A) (x0 : B) (x1 : C), Acc3 R x x0 x1 -> P x x0 x1.
Proof.
do 6 intro.
fix F 4.
intros.
apply H; intros.
apply F.
generalize H1.
case H0; intros.
apply H2.
exact H3.
Qed.

  Lemma Acc_Acc3 :
   forall (A B C : Set) (R : relation (A * (B * C))) (x : A) (y : B) (z : C),
   Acc R (x, (y, z)) -> Acc3 R x y z.
Proof.
intros.
change
  ((fun p : A * (B * C) =>
    match p with
    | (x2, (x3, x4)) => Acc3 R x2 x3 x4
    end) (x, (y, z))) in |- *.
elim H.
simple destruct x0.
simple destruct p; intros.
apply Acc3_intro; intros.
apply (H1 (y0, (y1, y2))); auto.
Qed.

Section Principal.

  Variables (A : Set) (P : A -> Prop) (R : A -> A -> Prop).

  Record ppal (x : A) : Prop := Pp_intro
    {pp_ok : P x; pp_least : forall y : A, P y -> R x y}.

  Definition ppal_dec : Set := {x : A | ppal x} + {(forall x : A, ~ P x)}.

End Principal.


Section PropositionLanguage.

Context { atom : Type }.

Inductive prop : Type :=
| atom_prop : atom -> prop
| bot_prop : prop
| top_prop : prop
| and_prop : prop -> prop -> prop
| or_prop : prop -> prop -> prop
| impl_prop : prop -> prop -> prop.

Definition not_prop (P : prop) :=
  impl_prop P bot_prop.

End PropositionLanguage.

Arguments prop atom : clear implicits.

(*Notation "⊥" := bot_prop.
Notation "⊤" := top_prop.*)
Notation "¬ P" := (not_prop P) (at level 51).
Infix "∧" := and_prop (left associativity, at level 52).
Infix "∨" := or_prop (left associativity, at level 53).
Infix "⊃" := impl_prop (right associativity, at level 54).


Inductive Foo : Set :=
| A : Foo
| B : nat -> Foo
| C : Foo -> Foo
.

Check Foo_ind.
Check Foo_rec.

Fixpoint Foo_rect'
    (P:Foo -> Type)
    (pa:P A)
    (pb:forall (n:nat), P (B n))
    (pc: forall (f:Foo), P f -> P (C f)) (f:Foo): P f
    :=
    match f with
    | A     => pa
    | B n   => pb n
    | C f'  => pc f' (Foo_rect' P pa pb pc f')
    end.

Check Foo_rect.
Check Foo_rect'.


Require Import OrderedType Lia.
Require Import String.
Require Import Utf8_core.
Require Import FunInd.
Require Import NArith.

Module VarsString <: OrderedType with Definition t := String.string.
  Definition t:= String.string.
  Definition eq := @eq t.

  Module M.  (* Just to bypass sort of a bug in rewrite *)
    Function lt (s1 s2:string) {struct s1} : Prop :=
      match s1,s2 with
        | EmptyString,EmptyString => False
        | EmptyString, _ => True
        | _,EmptyString => False
        | String c1 s1, String c2 s2 =>
          ((Ascii.nat_of_ascii c1) < (Ascii.nat_of_ascii c2)) \/
          ((c1=c2) /\ lt s1 s2)
      end.

    Function compare_digits (l1 l2:list bool) {struct l1} : comparison :=
      match l1,l2 with
        | nil,nil => Eq
        | _,nil => Gt
        | nil,_ => Lt
        | b1::l1,b2::l2 =>
          match compare_digits l1 l2 with
            | Eq => match b1,b2 with
                      | true,true | false,false => Eq
                      | false,true => Lt
                      | true,false => Gt
                    end
            | v => v
          end
      end.

    Definition ascii_compare c1 c2 :=
      match c1,c2 with
        Ascii.Ascii b1 b2 b3 b4 b5 b6 b7 b8,
        Ascii.Ascii b1' b2' b3' b4' b5' b6' b7' b8' =>
        compare_digits
        (b1::b2::b3::b4::b5::b6::b7::b8::nil)
        (b1'::b2'::b3'::b4'::b5'::b6'::b7'::b8'::nil)
      end.

    Lemma compare_digits_eq_correct : forall l1 l2,
      compare_digits l1 l2 = Eq -> l1 = l2.
    Proof.
      intros l1 l2.
      functional induction (compare_digits l1 l2);try discriminate;intros;f_equal;auto.
      rewrite H in y;tauto.
    Qed.

    Lemma ascii_compare_eq_correct :
      forall c1 c2, ascii_compare c1 c2 = Eq -> c1 = c2.
    Proof.
      destruct c1 as [b1 b2 b3 b4 b5 b6 b7 b8];
        destruct c2 as [b1' b2' b3' b4' b5' b6' b7' b8'].
      unfold ascii_compare.
      intros H.
      apply compare_digits_eq_correct in H.
      injection H;intros;subst;reflexivity.
    Qed.

    Lemma compare_digits_lt_correct :
      forall (l1 l2:list bool),
        List.length l1 = List.length l2 ->
        compare_digits l1 l2 = Lt ->
        N.lt (Ascii.N_of_digits l1) (Ascii.N_of_digits l2).
    Proof.
      intros l1 l2;functional induction (compare_digits l1 l2);try discriminate.

      destruct l2;tauto||(simpl;discriminate).

      intros Hlength;injection Hlength;clear Hlength;intro Hlength.
      rewrite (compare_digits_eq_correct _ _ e1).
      simpl.
      destruct ( Ascii.N_of_digits l3).
      vm_compute;reflexivity.
      intros _.
      unfold N.lt.
      simpl.
      rewrite  Pos.compare_xO_xI.
      rewrite Pos.compare_refl;auto.

      intros Hlength;injection Hlength;clear Hlength;intro Hlength.
      intros Heq;rewrite Heq in *.
      simpl.
      generalize (IHc Hlength (refl_equal _)).
      destruct b1;destruct b2;
      destruct (Ascii.N_of_digits l0);
        destruct (Ascii.N_of_digits l3); lia.
    Qed.

    Lemma compare_digits_gt_correct :
      forall (l1 l2:list bool),
        List.length l1 = List.length l2 ->
        compare_digits l1 l2 = Gt ->
        N.lt (Ascii.N_of_digits l2) (Ascii.N_of_digits l1).
    Proof.
      intros l1 l2;functional induction (compare_digits l1 l2);try discriminate.

      destruct l1;tauto||(simpl;discriminate).

      intros Hlength;injection Hlength;clear Hlength;intro Hlength.
      rewrite (compare_digits_eq_correct _ _ e1).
      simpl.
      destruct ( Ascii.N_of_digits l3).
      vm_compute;reflexivity.
      lia.

      intros Hlength;injection Hlength;clear Hlength;intro Hlength.
      intros Heq;rewrite Heq in *.
      simpl.
      generalize (IHc Hlength (refl_equal _)).
      destruct b1;destruct b2;
      destruct (Ascii.N_of_digits l0);
        destruct (Ascii.N_of_digits l3); lia.
    Qed.

    Lemma ascii_compare_lt_correct : forall c1 c2, ascii_compare c1 c2 = Lt -> (Ascii.nat_of_ascii c1) < (Ascii.nat_of_ascii c2).
    Proof.
      unfold ascii_compare.
      destruct c1;destruct c2.
      intros Heq.
      apply compare_digits_lt_correct in Heq;[|vm_compute;reflexivity].
      unfold Ascii.nat_of_ascii.
      assert (forall p q, (p < q)%N -> (N.to_nat p) < (N.to_nat q)) as H by lia.
      apply H;assumption.
    Qed.

    Lemma ascii_compare_gt_correct : forall c1 c2, ascii_compare c1 c2 = Gt -> (Ascii.nat_of_ascii c2) < (Ascii.nat_of_ascii c1).
    Proof.
      unfold ascii_compare.
      destruct c1;destruct c2.
      intros Heq.
      apply compare_digits_gt_correct in Heq;[|vm_compute;reflexivity].
      unfold Ascii.nat_of_ascii.
      assert (forall p q, (p < q)%N -> (N.to_nat p) < (N.to_nat q)) as H by lia.
      apply H;assumption.
    Qed.

    Function compare' (s1 s2 : string) {struct s1} : comparison :=
      match s1,s2 with
        | EmptyString,EmptyString => Eq
        | EmptyString,_ => Lt
        | _,EmptyString => Gt
        | String c1 s1,String c2 s2 =>
          match ascii_compare c1 c2 with
            | Eq => compare' s1 s2
            | v => v
          end
      end.

    Lemma compare'_eq_correct : forall s1 s2, compare' s1 s2 = Eq -> s1=s2.
    Proof.
      intros s1 s2;functional induction (compare' s1 s2);
        reflexivity || (try discriminate).

      intros Heq;rewrite (IHc Heq).
      rewrite (ascii_compare_eq_correct _ _ e1).
      reflexivity.

      intros Heq;rewrite Heq in y;tauto.
    Qed.

    Lemma compare'_lt_correct :
      forall s1 s2, compare' s1 s2 = Lt -> lt s1 s2.
    Proof.
      intros s1 s2;functional induction (compare' s1 s2);
        reflexivity || (try discriminate).

      destruct s2;try tauto.

      intros Heq;assert (IHc':=IHc Heq);clear IHc Heq.
      simpl.
      right;rewrite (ascii_compare_eq_correct _ _ e1);tauto.

      intros Heq;clear y.
      simpl;left;apply ascii_compare_lt_correct;assumption.
    Qed.

    Lemma compare'_gt_correct :
      forall s1 s2, compare' s1 s2 = Gt -> lt s2 s1.
    Proof.
      intros s1 s2;functional induction (compare' s1 s2);
        reflexivity || (try discriminate).

      destruct s1;try tauto.

      intros Heq;assert (IHc':=IHc Heq);clear IHc Heq.
      simpl.
      right;rewrite (ascii_compare_eq_correct _ _ e1);tauto.

      intros Heq;clear y.
      simpl;left;apply ascii_compare_gt_correct;assumption.
    Qed.

  End M.
  Import M.
  Definition eq_sym := @Logic.eq_sym t.
  Definition eq_refl := @Logic.eq_refl t.
  Definition eq_trans := @Logic.eq_trans t.

  Definition lt := M.lt.

  Ltac clear_goal :=
    repeat match goal with
      | h: ?t = ?t  |- _ => clear h
      | h: Compare_dec.lt_eq_lt_dec _ _ = _  |- _ => clear h
    end.

  Lemma lt_trans : forall s1 s2 s3, lt s1 s2 -> lt s2 s3 -> lt s1 s3.
  Proof.
    unfold lt.
    intros s1 s2.
    functional induction (M.lt s1 s2);try tauto.
    intros s3. revert y;functional induction (M.lt s2 s3);simpl;try tauto.
    destruct s1;simpl;try tauto.
    intuition (subst).
    left;eauto with arith .
    left;eauto with arith .
    left;eauto with arith .
    right;eauto.
  Qed.

  Lemma lt_not_eq : ∀ x y, lt x y -> not (eq x y).
  Proof.
    unfold lt.
    intros s1 s2; functional induction (M.lt s1 s2);try tauto.

    unfold eq;intros _ abs;subst;tauto.

    intuition.
    unfold eq in H0;simpl in H0;injection H0;clear H0;intros;subst;lia.
    subst.
    injection H0;clear H0;intros;subst;unfold eq in *;auto.
  Qed.

  Lemma compare : ∀ x y, Compare lt eq x y.
  Proof.
    intros x y.
    case_eq (compare' x y);intros Heq.
    constructor 2.
    apply compare'_eq_correct;assumption.
    constructor 1.
    apply compare'_lt_correct;assumption.
    constructor 3.
    apply compare'_gt_correct;assumption.
  Defined.

  Function eq_bool (s1 s2: string) {struct s1} : bool :=
    match s1,s2 with
      | EmptyString,EmptyString => true
      | String c1 s1,String c2 s2 =>
        if Peano_dec.eq_nat_dec (Ascii.nat_of_ascii c1) (Ascii.nat_of_ascii c2)
          then eq_bool s1 s2
          else false
      | _,_ => false
    end.

  Lemma eq_bool_correct : forall s1 s2, eq_bool s1 s2 = true -> eq s1 s2.
  Proof.
    intros s1 s2;functional induction (eq_bool s1 s2);try discriminate.

    reflexivity.

    intros H;assert (IHb':=IHb H);clear IHb H.
    red. f_equal.
    rewrite <- (Ascii.ascii_nat_embedding c1);
    rewrite <- (Ascii.ascii_nat_embedding c2);
    rewrite _x. reflexivity.
    exact IHb'.
  Qed.

  Lemma eq_bool_correct_2 : forall s1 s2, eq_bool s1 s2 = false -> ~ eq s1 s2.
  Proof.
    intros s1 s2;functional induction (eq_bool s1 s2);try discriminate.

    intros H;assert (IHb':= IHb H);clear e1 IHb H;intro abs;red in abs;injection abs;clear abs;intros;elim IHb';assumption.

    intros _;clear e1;intro abs;red in abs;injection abs;clear abs;intros;elim _x;subst;reflexivity.

    intros _ abs;destruct s1;destruct s2;simpl in y;try tauto;
    discriminate abs.
  Qed.

  Definition eq_dec : forall (s1 s2:string), {eq s1 s2}+{~eq s1 s2}.
  Proof.
    intros s1 s2.
    case_eq (eq_bool s1 s2);intro H.
    left;apply eq_bool_correct;exact H.
    right;apply eq_bool_correct_2;assumption.
  Qed.

End VarsString.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import Arith Euclid Omega Relations.

Require Import utils brent_common.

Set Implicit Arguments.

Local Infix "div" := (nat_divides) (at level 70).

(** This is an implementation of Brent's period finding
    algorithm refined for unary nats. It extracts to
    the following OCaml code

    type nat = O | S of nat
    type sumbool = Left | Right

    let brent eqdec f x0 =
      let rec loop l p m x y =
        match eqdec x y with
          | Left -> l
          | Right -> (match m with
            | O   -> loop (S O) (S p) p y (f y)
            | S n -> loop (S l) (S p) n x (f y))
    in loop (S O) (S O) O x0 (f x0)

*)

Section Brent.

  Variables (X : Type) (eqdec : forall x y : X, { x = y } + { x <> y }).

  Infix "=?" := eqdec (at level 70).

  Variable (f : X -> X) (x0 : X) (Hx0 : exists τ, 0 < τ /\ f↑τ x0 = f↑(2*τ) x0).

  Inductive bar_br l p : nat -> X -> X ->  Prop :=
    | in_bar_br_0 : forall m x,   bar_br    l    p      m  x    x

    | in_bar_br_1 : forall x y,   bar_br    1 (S p)     p  y (f y)
                             ->   bar_br    l    p      0  x    y

    | in_bar_br_2 : forall m x y, bar_br (S l) (S p)    m  x (f y)
                             ->   bar_br    l     p  (S m) x    y.

  (* pre explains the meaning of p and l w.r.t. the conventional Brent algorithm
     which is OK for binary nats but not for unary nats

     - p is 2^q + l - 1   and      m is 2^q - l
          for some 1 <= l <= 2^q

     the test l = 2^q is replaced with m = 0
   *)

  Let pre l p m x y := exists q,
                     x = f↑(pow2 q-1) x0
                  /\ y = f↑(l+pow2 q-1) x0
                  /\ 1 <= l <= pow2 q
                  /\ p = pow2 q+l-1
                  /\ m = pow2 q-l.

  Let post l p k := exists q,  p <= pow2 q + l - 1
                            /\ 1 <= k <= pow2 q
                            /\ f↑(pow2 q - 1) x0 = f↑(k+pow2 q - 1) x0
                            /\ forall l', 1 <= l'
                                       -> f↑(pow2 q - 1) x0 = f↑(l'+pow2 q - 1) x0
                                       -> p = pow2 q + l - 1 /\ (l' < l \/ k <= l')
                                       \/ p < pow2 q + l - 1 /\ k <= l'.

  (* This is a bit complicated because we need equations m = 0 and m = S n
     to build the termination certificate *)

  Let loop : forall l p m x y (Hb : bar_br l p m x y) (Hp : pre l p m x y), { k | post l p k }.
  Proof.
    refine (fix loop l p m x y Hb Hp := match x =? y with
      | left E  => exist _ l _
      | right C => match m as m' return bar_br l p m' x y -> pre l p m' x y -> _ with
                     | 0   => fun Hb' Hp' => match loop    1  (S p) p y (f y) _ _ with exist _ k Hk => exist _ k _ end
                     | S n => fun Hb' Hp' => match loop (S l) (S p) n x (f y) _ _ with exist _ k Hk => exist _ k _ end
                   end Hb Hp
    end); trivial.
    1,2,5: cycle 1.

    (* The two termination certificates *)
    1,2: revert C; inversion Hb'; trivial; intros []; trivial.

    2-5: clear Hb Hp; rename Hb' into Hb; rename Hp' into Hp.
    1,2,4: cycle 1.

    (* Check the pre-conditions *)

    * destruct Hp as (q & H1 & H2 & H3 & H4 & H5).
      exists (S q); repeat split; try (simpl; omega).
      rewrite H2; f_equal; simpl; omega.
      rewrite H2.
      change (f (f↑(l+pow2 q-1) x0)) with (f↑(1+(l+pow2 q-1)) x0).
      f_equal; simpl; omega.

    * destruct Hp as (q & H1 & H2 & H3 & H4 & H5).
      exists q; repeat split; auto; try omega.
      rewrite H2.
      change (f (f↑(l+pow2 q-1) x0)) with (f↑(1+(l+pow2 q-1)) x0).
      f_equal; simpl; omega.

    (* Check the post-conditions *)

    * destruct Hp as (q & H1 & H2 & H3 & H4 & H5).
      exists q; repeat split; try omega.
      rewrite <- H2, <- H1; auto.
      intros l' _ _; left; omega.

    * destruct Hk as (q' & H1 & H2 & H3 & H4).
      exists q'; repeat split; auto; try omega.
      intros l' Hl' H5; specialize (H4 _ Hl' H5).
      destruct Hp as (? & _ & _ & ? & _); omega.

    * destruct Hk as (q' & H1 & H2 & H3 & H4).
      exists q'; repeat split; auto; try omega.
      intros l' Hl' H5.
      specialize (H4 _ Hl' H5).
      destruct H4 as [ (H4 & [ H6 | H6 ]) | (H4 & H6) ]; try omega.
      destruct (eq_nat_dec l l') as [ H7 | ]; try omega.
      destruct Hp as (q & G1 & G2 & G3 & G4 & G5).
      assert (q = q') as H8 by (apply pow2_inj; omega).
      subst q' l' x y p; destruct C; trivial.
  Qed.

  (* Properties of the domain using the 3rd constructor *)

  Local Fact lex_bar_br_0 l p m x y n :
         bar_br (n+l) (n+p)   m  x (f↑n y)
      -> bar_br    l     p (n+m) x      y.
  Proof.
    revert l p m x y.
    induction n as [ | n IHn ]; simpl; auto; intros l p m x y H.
    constructor 3; apply IHn.
    eq goal with H; f_equal; try omega.
    rewrite <- (iter_plus f _ 1), plus_comm; auto.
  Qed.

  Local Fact lex_bar_br_1 q l1 l2 :
         l1 <= l2 <= pow2 q
      -> bar_br l2 (pow2 q+l2-1) (pow2 q-l2) (f↑(pow2 q-1) x0) (f↑(l2+pow2 q-1) x0)
      -> bar_br l1 (pow2 q+l1-1) (pow2 q-l1) (f↑(pow2 q-1) x0) (f↑(l1+pow2 q-1) x0).
  Proof.
    intros H1 H2.
    replace (pow2 q-l1) with ((l2 - l1)+ (pow2 q-l2)) by omega.
    apply lex_bar_br_0.
    eq goal with H2; f_equal; try omega.
    rewrite <- iter_plus; f_equal; omega.
  Qed.

  Local Fact lex_bar_br q1 l1 q2 l2 :
         (q1 < q2 \/ q1 = q2 /\ l1 <= l2)
      -> 1 <= l1 <= pow2 q1
      -> 1 <= l2 <= pow2 q2
      -> bar_br l2 (pow2 q2+l2-1) (pow2 q2-l2) (f↑(pow2 q2-1) x0) (f↑(l2+pow2 q2-1) x0)
      -> bar_br l1 (pow2 q1+l1-1) (pow2 q1-l1) (f↑(pow2 q1-1) x0) (f↑(l1+pow2 q1-1) x0).
   Proof.
    intros H1 H3 H4.
    assert (q1 <= q2) as H by omega.
    revert H l1 l2 H1 H3 H4.
    induction 1 as [ | q2 H IH ]; intros l1 l2.
    * intros [ H1 | (H1 & H2) ] (H3 & _) (_ & H4).
      + exfalso; omega.
      + apply lex_bar_br_1; auto.
    * intros _ H3 H4 H5.
      apply IH with (l2 := pow2 q2); auto.
      + destruct (le_lt_dec q2 q1); auto.
        right; replace q2 with q1; omega.
      + split; auto; apply pow2_ge1.
      + rewrite minus_diag.
        constructor 2.
        apply lex_bar_br_1 with (l1 := 1) in H5; try omega.
       eq goal with H5; f_equal; try (simpl; omega).
       - f_equal; generalize (pow2_ge1 q2); simpl; omega.
       - f_equal; simpl; omega.
       - rewrite <- (iter_plus f 1); f_equal; simpl.
         generalize (pow2_ge1 q2); omega.
  Qed.

  Let pre_bar l ppl pml x y : pre l ppl pml x y -> bar_br l ppl pml x y.
  Proof.
    intros (q & H1 & H2 & H3 & H4 & H5).
    destruct brent_cyclicity with (1 := Hx0) (p := q) as (l' & q' & H7 & H8 & H9).
    rewrite H1, H2, H4, H5.
    apply lex_bar_br with (3 := H8); auto.
    rewrite H9; constructor.
  Qed.

  (* We deduce the full specification of Brent's algorithm which computes the period *)

  Definition brent_una : { μ |   0 < μ
                         /\ (exists λ, f↑λ x0 = f↑(λ+μ) x0)
                         /\ forall i j, i < j -> f↑i x0 = f↑j x0 -> μ div (j-i) }.
  Proof.
    assert (pre 1 1 0 x0 (f x0)) as H.
    { exists 0; repeat split; auto. }
    destruct (loop (pre_bar H) H) as (m & Hm).
    exists m.
    destruct Hm as (q & H1 & H2 & H3 & H4).
    split; try omega.
    assert (forall l', 1 <= l' -> f ↑ (pow2 q - 1) x0 = f ↑ (l' + (pow2 q - 1)) x0 -> m <= l') as H0.
    { intros l' G1 G2.
      replace (l' + (pow2 q - 1)) with (l' + pow2 q - 1) in G2 by omega.
      specialize (H4 _ G1 G2); omega. }
    clear H4; rename H0 into H4.
    replace (m + pow2 q - 1) with (m + (pow2 q - 1)) in H3 by omega.
    revert H1 H2 H3 H4.
    generalize (pow2 q -1).
    intros l _ (Hm & _) H3 H4; clear q.
    split.
    * exists l; rewrite H3; f_equal; omega.
    * intros i j H5 H6.
      destruct (eucl_dev _ Hm (j-i)) as [ q r G1 G2 ].
      destruct (le_lt_dec 1 r); [ | exists q; omega ].
      replace j with (r+q*m+i) in H6 by omega.
      assert (f↑l x0 = f↑(r+(q*m+l)) x0) as G3.
      { rewrite plus_assoc.
        apply iter_xchg with (3 := H6) (4 := H3); omega. }
      rewrite <- iter_loop_gen in G3; auto.
      apply H4 in G3; omega.
  Qed.

End Brent.

Check brent_una.
Print Assumptions brent_una.
Recursive Extraction brent_una.