Require Import Logic.Rel.Prop.
Require Import Logic.Func.Identity.
Require Import Logic.Func.Composition.

Require Import Logic.Axiom.Dec.
Require Import Logic.Axiom.Sec.
Require Import Logic.Axiom.Sat.

Definition red (a b:Type) (p:a -> Prop) (q:b -> Prop) (f:a -> b) : Prop :=
   forall (x:a), p x <-> q (f x).

Arguments red {a} {b}.

Lemma red_comp :
    forall (a b c:Type) (p:a -> Prop) (q:b -> Prop) (r:c -> Prop),
    forall (f:a -> b) (g:b -> c),
        red p q f -> red q r g -> red p r (g ; f).
Proof.
    unfold red, comp. intros a b c p q r f g H1 H2.
    intros x. apply equivTrans with (q (f x)).
    - apply H1.
    - apply H2.
Qed.

Definition ReducesTo (a b:Type) (p:a -> Prop) (q:b -> Prop) : Prop :=
    exists (f:a -> b), red p q f.

Arguments ReducesTo {a}{b}.

Lemma ReducesToRefl : forall (a:Type) (p:a -> Prop), ReducesTo p p.
Proof.
    intros a p. exists id. intros x. apply equivRefl.
Qed.

Lemma ReducesToTrans :
    forall (a b c:Type) (p:a -> Prop) (q:b -> Prop) (r:c -> Prop),
        ReducesTo p q -> ReducesTo q r -> ReducesTo p r.
Proof.
    intros a b c p q r [f H1] [g H2]. exists (g ; f).
    apply red_comp with q; assumption.
Qed.

Lemma redDec : forall (a b:Type) (p:a -> Prop) (q:b -> Prop) (f:a -> b),
    red p q f -> pDec q -> pDec p.
Proof.
    intros a b p q f H1 H2 x. unfold pDec in H2.
    unfold red in H1. specialize H1 with x. destruct H1 as [H1 H3].
    specialize H2 with (f x). destruct H2 as [H2|H2].
    - left. auto.
    - right. intros H4. apply H2, H1. assumption.
Qed.

Lemma ReducesDecidable : forall (a b:Type) (p:a -> Prop) (q:b -> Prop),
    ReducesTo p q -> Decidable q -> Decidable p.
Proof.
    intros a b p q [f H1] [g H2]. exists (fun n => g (f n)). intros x.
    unfold red in H1. specialize H1 with x.
    unfold DeciderOf in H2. specialize H2 with (f x).
    destruct H1 as [H1 G1]. destruct H2 as [H2 G2]. split; intros H3.
    - apply H2, H1, H3.
    - apply G1, G2, H3.
Qed.

Lemma redSec : forall (a b:Type) (p:a -> Prop) (q:b -> Prop) (f:a -> b),
    red p q f -> pSec q -> pSec p.
Proof.
    intros a b p q f H1 H2 x. unfold pSec in H2.
    unfold red in H1. specialize H1 with x. destruct H1 as [H1 H3].
    specialize H2 with (f x). destruct H2 as [g H2].
    exists g. destruct H2 as [H2 H4]. split; intros H5.
    - apply H2, H1, H5.
    - apply H3, H4, H5.
Qed.

Lemma ReducesSemiDecidable : forall (a b:Type) (p:a -> Prop) (q:b -> Prop),
    ReducesTo p q -> SemiDecidable q -> SemiDecidable p.
Proof.
    intros a b p q [f H1] [F H2]. exists (fun x n => F (f x) n). intros x.
    unfold red in H1. specialize H1 with x.
    unfold SemiDeciderOf in H2. specialize H2 with (f x).
    destruct H1 as [H1 G1]. destruct H2 as [H2 G2]. split; intros H3.
    - apply H2, H1, H3.
    - apply G1, G2, H3.
Qed.

Lemma SemiDecidableReducesToSat : forall (a:Type) (p:a -> Prop),
    pSec p -> ReducesTo p tsat.
Proof.
    intros a p H1.
    unfold ReducesTo, red. unfold pSec in H1. unfold Sec in H1.
    exists (fun x n => proj1_sig (H1 x) n).
    intros x. apply (proj2_sig (H1 x)).
Qed.


Set Implicit Arguments.
(* Load the CFML library. *)
Require Import CFML.CFLib.
(* Load the examples CF definitions. *)
Require Import CFML.Stdlib.Array_proof.
Require Import CFML.Stdlib.Pervasives_proof.
Require Import Challenge2_ml.

Require Import TLC.LibInt TLC.LibTactics.
Require Import TLC.LibList TLC.LibListZ .
Require Import TLC.LibWf.
Require Import Sorting Permutation.

Open Scope Z_scope.

Hint Constructors LocallySorted.
Hint Constructors Permutation.
Ltac auto_tilde ::= (* try unfold LibListZ.length in *;  *)rew_list in *; eauto with maths.

Inductive color := R | B.
Definition coloring := list color.

(* Z_lt_le_dec: forall x y : int, {x < y} + {y <= x} *)

Fixpoint coloring_valid (aux: int) (c : coloring) : bool :=
  match c with
  | B :: cs => if Z_lt_le_dec aux 3 then false else coloring_valid 0 cs
  | R :: cs => coloring_valid (aux + 1) cs
  | nil => if Z_lt_le_dec aux 3 then false else true
  end.

Definition invariant (n: int) (counts: list int) (colorings: list (list coloring)) :=
  length counts = n /\
  length colorings = n /\
  forall i, 0 <= i < n ->
    counts[i] = length colorings[i] /\
    Forall (fun c => length c = i) colorings[i].

Lemma docount_spec : forall (a: array int) (L: list int),
  length L >= 4 ->
  app docount [a]
    PRE (a ~> Array L)
    POST (fun (tt:unit) =>
            Hexists L' C,
            a ~> Array L' \* \[ invariant (length L') L' C ]).
Proof.
  introv. xcf.
  xapps. xapps. { apply~ index_of_inbound.  }
  xapps. { apply~ index_of_inbound. rewrite length_update. math. }
  xapps. { apply~ index_of_inbound. rewrite !length_update. math. }
  xapps. { apply~ index_of_inbound. rewrite !length_update. math. }
  xfor_inv (fun n => Hexists L0 Ljunk C,
                     a ~> Array (L0 ++ Ljunk) \*
                     \[ length L0 = n /\
                        length L0 + length Ljunk = length L /\
                        invariant n L0 C ]).
  { math. }
  { do 4 (destruct L as [|? L];  try solve [ false~ ]).

    hsimpl (>> (1 :: 1 :: 1 :: 2 :: nil) L
               ((nil :: nil) :: ((B :: nil) :: nil) :: ((B :: B :: nil) :: nil) ::
                             ((B::B::B::nil) :: (R::R::R::nil) :: nil) :: nil)).
    rew_list. rewrite update_zero. rewrite~ update_cons_pos.
    rewrite update_zero. repeat (try rewrite update_zero; rewrite~ update_cons_pos).
    repeat f_equal. rewrite update_zero. f_equal.
    splits~. unfolds~ invariant. splits~.
    { intros i Hi.
      admit. } }
  { intros n (Hilo & Hihi).
    xpull. intros L0 Ljunk C (? & (I1 & I2)).
    xapps. { apply~ index_of_inbound. }
    xapps. { apply~ index_of_inbound. }
    destruct Ljunk as [| ? Ljunk']. { false~. math. }
    rewrite update_middle with (l1 := L0) (l2 := Ljunk'); [| auto_tilde].
    rew_list in I1.
    pose (C' := map (cons B) C[n-1]).
    assert ((L0 ++ z :: Ljunk')[n-1] = L0[n-1]) as ->.
    { rewrite read_app. case_if~. }
    xfor_inv (fun (k:int) =>
      Hexists (count: int) (C': list coloring),
        a ~> Array (L0 ++ count :: Ljunk') \*
        \[ count = length C' /\
           Forall (fun c => length c = n) C'
        ]).
    { math. }
    { hsimpl L0[n-1] C'.
      { rew_list. reflexivity. }
      { splits~.
        - unfold invariant in I2. unpack.
          subst C'. rewrite length_map. apply~ H3.
        - unfold invariant in I2. unpack.
          subst C'.
          forwards~: H3 (n-1). unpack.

          Lemma Forall_map {A B : Type} { P : B -> Prop} {f : A -> B} {l: list A} :
            Forall (fun x => P (f x)) l ->
            Forall P (map f l).
          Proof. induction 1; now constructor. Qed.
          apply Forall_map.

          apply (Forall_pred_incl H5). unfold pred_incl.
          intros. auto_tilde. } }
    { intros k (Hk1 & Hk2). xpull. intros count C'0 (II1 & II2).
      xapps. { apply~ index_of_inbound. }
      xapps. { apply~ index_of_inbound. }
      xapps. { apply~ index_of_inbound. }
      hsimpl
        (count + L0[n-k-1])
        ((map (fun c => ((make k R) ++ B :: c)) C[n-k-1]) ++ C'0).
      { rewrite read_middle with (x := count); [|auto_tilde].
        rewrite update_middle with (w := count); [| auto_tilde].
        assert ((L0 ++ count :: Ljunk')[(n-k)-1] = L0[n-k-1]) as ->. {
          rewrite read_app. case_if~. }
        rew_list~. }
      { splits~.
        { rewrite length_map. unfold invariant in I2. unpack.
          rewrite II1. forwards~: H3 ((n-k)-1). unpack.
          rewrite H4. rewrite Z.add_comm. reflexivity. }
        { admit. } } }
    { admit. } }
  { admit. }
Qed.


(** * MoreCoq: More About Coq's Tactics *)

Require Export Poly.

(** This chapter introduces several more proof strategies and
    tactics that, together, allow us to prove theorems about the
    functional programs we have been writing. In particular, we'll
    reason about functions that work with natural numbers and lists.

    In particular, we will see:
    - how to use auxiliary lemmas, in both forwards and backwards reasoning;
    - how to reason about data constructors, which are injective and disjoint;
    - how to create a strong induction hypotheses (and when
      strengthening is required); and
    - how to reason by case analysis.
 *)

(* ###################################################### *)
(** * The [apply] Tactic *)

(** We often encounter situations where the goal to be proved is
    exactly the same as some hypothesis in the context or some
    previously proved lemma. *)

Theorem silly1 : forall (n m o p : nat),
     n = m  ->
     [n;o] = [n;p] ->
     [n;o] = [m;p].
Proof.
  intros n m o p eq1 eq2.
  rewrite <- eq1.
  (* At this point, we could finish with
     "[rewrite -> eq2. reflexivity.]" as we have
     done several times above. But we can achieve the
     same effect in a single step by using the
     [apply] tactic instead: *)
  apply eq2.  Qed.

(** The [apply] tactic also works with _conditional_ hypotheses
    and lemmas: if the statement being applied is an implication, then
    the premises of this implication will be added to the list of
    subgoals needing to be proved. *)

Theorem silly2 : forall (n m o p : nat),
     n = m  ->
     (forall (q r : nat), q = r -> [q;o] = [r;p]) ->
     [n;o] = [m;p].
Proof.
  intros n m o p eq1 eq2.
  apply eq2. apply eq1.  Qed.

(** You may find it instructive to experiment with this proof
    and see if there is a way to complete it using just [rewrite]
    instead of [apply]. *)

(** Typically, when we use [apply H], the statement [H] will
    begin with a [forall] binding some _universal variables_.  When
    Coq matches the current goal against the conclusion of [H], it
    will try to find appropriate values for these variables.  For
    example, when we do [apply eq2] in the following proof, the
    universal variable [q] in [eq2] gets instantiated with [n] and [r]
    gets instantiated with [m]. *)

Theorem silly2a : forall (n m : nat),
     (n,n) = (m,m)  ->
     (forall (q r : nat), (q,q) = (r,r) -> [q] = [r]) ->
     [n] = [m].
Proof.
  intros n m eq1 eq2.
  apply eq2. apply eq1.  Qed.

(** **** Exercise: 2 stars, optional (silly_ex)  *)
(** Complete the following proof without using [simpl]. *)

Theorem silly_ex :
     (forall n, evenb n = true -> oddb (S n) = true) ->
     evenb 3 = true ->
     oddb 4 = true.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** To use the [apply] tactic, the (conclusion of the) fact
    being applied must match the goal _exactly_ -- for example, [apply]
    will not work if the left and right sides of the equality are
    swapped. *)

Theorem silly3_firsttry : forall (n : nat),
     true = beq_nat n 5  ->
     beq_nat (S (S n)) 7 = true.
Proof.
  intros n H.
  simpl.
  (* Here we cannot use [apply] directly *)
Abort.

(** In this case we can use the [symmetry] tactic, which switches the
    left and right sides of an equality in the goal. *)

Theorem silly3 : forall (n : nat),
     true = beq_nat n 5  ->
     beq_nat (S (S n)) 7 = true.
Proof.
  intros n H.
  symmetry.
  simpl. (* Actually, this [simpl] is unnecessary, since
            [apply] will perform simplification first. *)
  apply H.  Qed.

(** **** Exercise: 3 stars (apply_exercise1)  *)
(** Hint: you can use [apply] with previously defined lemmas, not
    just hypotheses in the context.  Remember that [SearchAbout] is
    your friend. *)

Theorem rev_exercise1 : forall (l l' : list nat),
     l = rev l' ->
     l' = rev l.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 1 star, optional (apply_rewrite)  *)
(** Briefly explain the difference between the tactics [apply] and
    [rewrite].  Are there situations where both can usefully be
    applied?
  (* FILL IN HERE *)
*)
(** [] *)

(* ###################################################### *)
(** * The [apply ... with ...] Tactic *)

(** The following silly example uses two rewrites in a row to
    get from [[a,b]] to [[e,f]]. *)

Example trans_eq_example : forall (a b c d e f : nat),
     [a;b] = [c;d] ->
     [c;d] = [e;f] ->
     [a;b] = [e;f].
Proof.
  intros a b c d e f eq1 eq2.
  rewrite -> eq1. rewrite -> eq2. reflexivity.  Qed.

(** Since this is a common pattern, we might
    abstract it out as a lemma recording once and for all
    the fact that equality is transitive. *)

Theorem trans_eq : forall (X:Type) (n m o : X),
  n = m -> m = o -> n = o.
Proof.
  intros X n m o eq1 eq2. rewrite -> eq1. rewrite -> eq2.
  reflexivity.  Qed.

(** Now, we should be able to use [trans_eq] to
    prove the above example.  However, to do this we need
    a slight refinement of the [apply] tactic. *)

Example trans_eq_example' : forall (a b c d e f : nat),
     [a;b] = [c;d] ->
     [c;d] = [e;f] ->
     [a;b] = [e;f].
Proof.
  intros a b c d e f eq1 eq2.
  (* If we simply tell Coq [apply trans_eq] at this point,
     it can tell (by matching the goal against the
     conclusion of the lemma) that it should instantiate [X]
     with [[nat]], [n] with [[a,b]], and [o] with [[e,f]].
     However, the matching process doesn't determine an
     instantiation for [m]: we have to supply one explicitly
     by adding [with (m:=[c,d])] to the invocation of
     [apply]. *)
  apply trans_eq with (m:=[c;d]). apply eq1. apply eq2.   Qed.

(**  Actually, we usually don't have to include the name [m]
    in the [with] clause; Coq is often smart enough to
    figure out which instantiation we're giving. We could
    instead write: [apply trans_eq with [c,d]]. *)

(** **** Exercise: 3 stars, optional (apply_with_exercise)  *)
Example trans_eq_exercise : forall (n m o p : nat),
     m = (minustwo o) ->
     (n + p) = m ->
     (n + p) = (minustwo o).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ###################################################### *)
(** * The [inversion] tactic *)

(** Recall the definition of natural numbers:
     Inductive nat : Type :=
       | O : nat
       | S : nat -> nat.
    It is clear from this definition that every number has one of two
    forms: either it is the constructor [O] or it is built by applying
    the constructor [S] to another number.  But there is more here than
    meets the eye: implicit in the definition (and in our informal
    understanding of how datatype declarations work in other
    programming languages) are two other facts:

    - The constructor [S] is _injective_.  That is, the only way we can
      have [S n = S m] is if [n = m].

    - The constructors [O] and [S] are _disjoint_.  That is, [O] is not
      equal to [S n] for any [n]. *)

(** Similar principles apply to all inductively defined types: all
    constructors are injective, and the values built from distinct
    constructors are never equal.  For lists, the [cons] constructor is
    injective and [nil] is different from every non-empty list.  For
    booleans, [true] and [false] are unequal.  (Since neither [true]
    nor [false] take any arguments, their injectivity is not an issue.) *)

(** Coq provides a tactic called [inversion] that allows us to exploit
    these principles in proofs.

    The [inversion] tactic is used like this.  Suppose [H] is a
    hypothesis in the context (or a previously proven lemma) of the
    form
      c a1 a2 ... an = d b1 b2 ... bm
    for some constructors [c] and [d] and arguments [a1 ... an] and
    [b1 ... bm].  Then [inversion H] instructs Coq to "invert" this
    equality to extract the information it contains about these terms:

    - If [c] and [d] are the same constructor, then we know, by the
      injectivity of this constructor, that [a1 = b1], [a2 = b2],
      etc.; [inversion H] adds these facts to the context, and tries
      to use them to rewrite the goal.

    - If [c] and [d] are different constructors, then the hypothesis
      [H] is contradictory.  That is, a false assumption has crept
      into the context, and this means that any goal whatsoever is
      provable!  In this case, [inversion H] marks the current goal as
      completed and pops it off the goal stack. *)

(** The [inversion] tactic is probably easier to understand by
    seeing it in action than from general descriptions like the above.
    Below you will find example theorems that demonstrate the use of
    [inversion] and exercises to test your understanding. *)

Theorem eq_add_S : forall (n m : nat),
     S n = S m ->
     n = m.
Proof.
  intros n m eq. inversion eq. reflexivity.  Qed.

Theorem silly4 : forall (n m : nat),
     [n] = [m] ->
     n = m.
Proof.
  intros n o eq. inversion eq. reflexivity.  Qed.

(** As a convenience, the [inversion] tactic can also
    destruct equalities between complex values, binding
    multiple variables as it goes. *)

Theorem silly5 : forall (n m o : nat),
     [n;m] = [o;o] ->
     [n] = [m].
Proof.
  intros n m o eq. inversion eq. reflexivity. Qed.

(** **** Exercise: 1 star (sillyex1)  *)
Example sillyex1 : forall (X : Type) (x y z : X) (l j : list X),
     x :: y :: l = z :: j ->
     y :: l = x :: j ->
     x = y.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

Theorem silly6 : forall (n : nat),
     S n = O ->
     2 + 2 = 5.
Proof.
  intros n contra. inversion contra. Qed.

Theorem silly7 : forall (n m : nat),
     false = true ->
     [n] = [m].
Proof.
  intros n m contra. inversion contra.  Qed.

(** **** Exercise: 1 star (sillyex2)  *)
Example sillyex2 : forall (X : Type) (x y z : X) (l j : list X),
     x :: y :: l = [] ->
     y :: l = z :: j ->
     x = z.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** While the injectivity of constructors allows us to reason
    [forall (n m : nat), S n = S m -> n = m], the reverse direction of
    the implication is an instance of a more general fact about
    constructors and functions, which we will often find useful: *)

Theorem f_equal : forall (A B : Type) (f: A -> B) (x y: A),
    x = y -> f x = f y.
Proof. intros A B f x y eq. rewrite eq.  reflexivity.  Qed.

(** **** Exercise: 2 stars, optional (practice)  *)
(** A couple more nontrivial but not-too-complicated proofs to work
    together in class, or for you to work as exercises. *)

Theorem beq_nat_0_l : forall n,
   beq_nat 0 n = true -> n = 0.
Proof.
  (* FILL IN HERE *) Admitted.

Theorem beq_nat_0_r : forall n,
   beq_nat n 0 = true -> n = 0.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ###################################################### *)
(** * Using Tactics on Hypotheses *)

(** By default, most tactics work on the goal formula and leave
    the context unchanged.  However, most tactics also have a variant
    that performs a similar operation on a statement in the context.

    For example, the tactic [simpl in H] performs simplification in
    the hypothesis named [H] in the context. *)

Theorem S_inj : forall (n m : nat) (b : bool),
     beq_nat (S n) (S m) = b  ->
     beq_nat n m = b.
Proof.
  intros n m b H. simpl in H. apply H.  Qed.

(** Similarly, the tactic [apply L in H] matches some
    conditional statement [L] (of the form [L1 -> L2], say) against a
    hypothesis [H] in the context.  However, unlike ordinary
    [apply] (which rewrites a goal matching [L2] into a subgoal [L1]),
    [apply L in H] matches [H] against [L1] and, if successful,
    replaces it with [L2].

    In other words, [apply L in H] gives us a form of "forward
    reasoning" -- from [L1 -> L2] and a hypothesis matching [L1], it
    gives us a hypothesis matching [L2].  By contrast, [apply L] is
    "backward reasoning" -- it says that if we know [L1->L2] and we
    are trying to prove [L2], it suffices to prove [L1].

    Here is a variant of a proof from above, using forward reasoning
    throughout instead of backward reasoning. *)

Theorem silly3' : forall (n : nat),
  (beq_nat n 5 = true -> beq_nat (S (S n)) 7 = true) ->
     true = beq_nat n 5  ->
     true = beq_nat (S (S n)) 7.
Proof.
  intros n eq H.
  symmetry in H. apply eq in H. symmetry in H.
  apply H.  Qed.

(** Forward reasoning starts from what is _given_ (premises,
    previously proven theorems) and iteratively draws conclusions from
    them until the goal is reached.  Backward reasoning starts from
    the _goal_, and iteratively reasons about what would imply the
    goal, until premises or previously proven theorems are reached.
    If you've seen informal proofs before (for example, in a math or
    computer science class), they probably used forward reasoning.  In
    general, Coq tends to favor backward reasoning, but in some
    situations the forward style can be easier to use or to think
    about.  *)

(** **** Exercise: 3 stars (plus_n_n_injective)  *)
(** Practice using "in" variants in this exercise. *)

Theorem plus_n_n_injective : forall n m,
     n + n = m + m ->
     n = m.
Proof.
  intros n. induction n as [| n'].
    (* Hint: use the plus_n_Sm lemma *)
    (* FILL IN HERE *) Admitted.
(** [] *)

(* ###################################################### *)
(** * Varying the Induction Hypothesis *)

(** Sometimes it is important to control the exact form of the
    induction hypothesis when carrying out inductive proofs in Coq.
    In particular, we need to be careful about which of the
    assumptions we move (using [intros]) from the goal to the context
    before invoking the [induction] tactic.  For example, suppose
    we want to show that the [double] function is injective -- i.e.,
    that it always maps different arguments to different results:
    Theorem double_injective: forall n m, double n = double m -> n = m.
    The way we _start_ this proof is a little bit delicate: if we
    begin it with
      intros n. induction n.
]]
    all is well.  But if we begin it with
      intros n m. induction n.
    we get stuck in the middle of the inductive case... *)

Theorem double_injective_FAILED : forall n m,
     double n = double m ->
     n = m.
Proof.
  intros n m. induction n as [| n'].
  Case "n = O". simpl. intros eq. destruct m as [| m'].
    SCase "m = O". reflexivity.
    SCase "m = S m'". inversion eq.
  Case "n = S n'". intros eq. destruct m as [| m'].
    SCase "m = O". inversion eq.
    SCase "m = S m'".  apply f_equal.
      (* Here we are stuck.  The induction hypothesis, [IHn'], does
         not give us [n' = m'] -- there is an extra [S] in the
         way -- so the goal is not provable. *)
      Abort.

(** What went wrong? *)

(** The problem is that, at the point we invoke the induction
    hypothesis, we have already introduced [m] into the context --
    intuitively, we have told Coq, "Let's consider some particular
    [n] and [m]..." and we now have to prove that, if [double n =
    double m] for _this particular_ [n] and [m], then [n = m].

    The next tactic, [induction n] says to Coq: We are going to show
    the goal by induction on [n].  That is, we are going to prove that
    the proposition

      - [P n]  =  "if [double n = double m], then [n = m]"

    holds for all [n] by showing

      - [P O]

         (i.e., "if [double O = double m] then [O = m]")

      - [P n -> P (S n)]

        (i.e., "if [double n = double m] then [n = m]" implies "if
        [double (S n) = double m] then [S n = m]").

    If we look closely at the second statement, it is saying something
    rather strange: it says that, for a _particular_ [m], if we know

      - "if [double n = double m] then [n = m]"

    then we can prove

       - "if [double (S n) = double m] then [S n = m]".

    To see why this is strange, let's think of a particular [m] --
    say, [5].  The statement is then saying that, if we know

      - [Q] = "if [double n = 10] then [n = 5]"

    then we can prove

      - [R] = "if [double (S n) = 10] then [S n = 5]".

    But knowing [Q] doesn't give us any help with proving [R]!  (If we
    tried to prove [R] from [Q], we would say something like "Suppose
    [double (S n) = 10]..." but then we'd be stuck: knowing that
    [double (S n)] is [10] tells us nothing about whether [double n]
    is [10], so [Q] is useless at this point.) *)

(** To summarize: Trying to carry out this proof by induction on [n]
    when [m] is already in the context doesn't work because we are
    trying to prove a relation involving _every_ [n] but just a
    _single_ [m]. *)

(** The good proof of [double_injective] leaves [m] in the goal
    statement at the point where the [induction] tactic is invoked on
    [n]: *)

Theorem double_injective : forall n m,
     double n = double m ->
     n = m.
Proof.
  intros n. induction n as [| n'].
  Case "n = O". simpl. intros m eq. destruct m as [| m'].
    SCase "m = O". reflexivity.
    SCase "m = S m'". inversion eq.
  Case "n = S n'".
    (* Notice that both the goal and the induction
       hypothesis have changed: the goal asks us to prove
       something more general (i.e., to prove the
       statement for _every_ [m]), but the IH is
       correspondingly more flexible, allowing us to
       choose any [m] we like when we apply the IH.  *)
    intros m eq.
    (* Now we choose a particular [m] and introduce the
       assumption that [double n = double m].  Since we
       are doing a case analysis on [n], we need a case
       analysis on [m] to keep the two "in sync." *)
    destruct m as [| m'].
    SCase "m = O".
      (* The 0 case is trivial *)
      inversion eq.
    SCase "m = S m'".
      apply f_equal.
      (* At this point, since we are in the second
         branch of the [destruct m], the [m'] mentioned
         in the context at this point is actually the
         predecessor of the one we started out talking
         about.  Since we are also in the [S] branch of
         the induction, this is perfect: if we
         instantiate the generic [m] in the IH with the
         [m'] that we are talking about right now (this
         instantiation is performed automatically by
         [apply]), then [IHn'] gives us exactly what we
         need to finish the proof. *)
      apply IHn'. inversion eq. reflexivity. Qed.

(** What this teaches us is that we need to be careful about using
    induction to try to prove something too specific: If we're proving
    a property of [n] and [m] by induction on [n], we may need to
    leave [m] generic. *)

(** The proof of this theorem (left as an exercise) has to be treated similarly: *)

(** **** Exercise: 2 stars (beq_nat_true)  *)
Theorem beq_nat_true : forall n m,
    beq_nat n m = true -> n = m.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, advanced (beq_nat_true_informal)  *)
(** Give a careful informal proof of [beq_nat_true], being as explicit
    as possible about quantifiers. *)

(* FILL IN HERE *)
(** [] *)

(** The strategy of doing fewer [intros] before an [induction] doesn't
    always work directly; sometimes a little _rearrangement_ of
    quantified variables is needed.  Suppose, for example, that we
    wanted to prove [double_injective] by induction on [m] instead of
    [n]. *)

Theorem double_injective_take2_FAILED : forall n m,
     double n = double m ->
     n = m.
Proof.
  intros n m. induction m as [| m'].
  Case "m = O". simpl. intros eq. destruct n as [| n'].
    SCase "n = O". reflexivity.
    SCase "n = S n'". inversion eq.
  Case "m = S m'". intros eq. destruct n as [| n'].
    SCase "n = O". inversion eq.
    SCase "n = S n'".  apply f_equal.
        (* Stuck again here, just like before. *)
Abort.

(** The problem is that, to do induction on [m], we must first
    introduce [n].  (If we simply say [induction m] without
    introducing anything first, Coq will automatically introduce
    [n] for us!)   *)

(** What can we do about this?  One possibility is to rewrite the
    statement of the lemma so that [m] is quantified before [n].  This
    will work, but it's not nice: We don't want to have to mangle the
    statements of lemmas to fit the needs of a particular strategy for
    proving them -- we want to state them in the most clear and
    natural way. *)

(**  What we can do instead is to first introduce all the
    quantified variables and then _re-generalize_ one or more of
    them, taking them out of the context and putting them back at
    the beginning of the goal.  The [generalize dependent] tactic
    does this. *)

Theorem double_injective_take2 : forall n m,
     double n = double m ->
     n = m.
Proof.
  intros n m.
  (* [n] and [m] are both in the context *)
  generalize dependent n.
  (* Now [n] is back in the goal and we can do induction on
     [m] and get a sufficiently general IH. *)
  induction m as [| m'].
  Case "m = O". simpl. intros n eq. destruct n as [| n'].
    SCase "n = O". reflexivity.
    SCase "n = S n'". inversion eq.
  Case "m = S m'". intros n eq. destruct n as [| n'].
    SCase "n = O". inversion eq.
    SCase "n = S n'". apply f_equal.
      apply IHm'. inversion eq. reflexivity. Qed.

(** Let's look at an informal proof of this theorem.  Note that
    the proposition we prove by induction leaves [n] quantified,
    corresponding to the use of generalize dependent in our formal
    proof.

_Theorem_: For any nats [n] and [m], if [double n = double m], then
  [n = m].

_Proof_: Let [m] be a [nat]. We prove by induction on [m] that, for
  any [n], if [double n = double m] then [n = m].

  - First, suppose [m = 0], and suppose [n] is a number such
    that [double n = double m].  We must show that [n = 0].

    Since [m = 0], by the definition of [double] we have [double n =
    0].  There are two cases to consider for [n].  If [n = 0] we are
    done, since this is what we wanted to show.  Otherwise, if [n = S
    n'] for some [n'], we derive a contradiction: by the definition of
    [double] we would have [double n = S (S (double n'))], but this
    contradicts the assumption that [double n = 0].

  - Otherwise, suppose [m = S m'] and that [n] is again a number such
    that [double n = double m].  We must show that [n = S m'], with
    the induction hypothesis that for every number [s], if [double s =
    double m'] then [s = m'].

    By the fact that [m = S m'] and the definition of [double], we
    have [double n = S (S (double m'))].  There are two cases to
    consider for [n].

    If [n = 0], then by definition [double n = 0], a contradiction.
    Thus, we may assume that [n = S n'] for some [n'], and again by
    the definition of [double] we have [S (S (double n')) = S (S
    (double m'))], which implies by inversion that [double n' = double
    m'].

    Instantiating the induction hypothesis with [n'] thus allows us to
    conclude that [n' = m'], and it follows immediately that [S n' = S
    m'].  Since [S n' = n] and [S m' = m], this is just what we wanted
    to show. [] *)

(** Here's another illustration of [inversion] and using an
    appropriately general induction hypothesis.  This is a slightly
    roundabout way of stating a fact that we have already proved
    above.  The extra equalities force us to do a little more
    equational reasoning and exercise some of the tactics we've seen
    recently. *)

Theorem length_snoc' : forall (X : Type) (v : X)
                              (l : list X) (n : nat),
     length l = n ->
     length (snoc l v) = S n.
Proof.
  intros X v l. induction l as [| v' l'].

  Case "l = []".
    intros n eq. rewrite <- eq. reflexivity.

  Case "l = v' :: l'".
    intros n eq. simpl. destruct n as [| n'].
    SCase "n = 0". inversion eq.
    SCase "n = S n'".
      apply f_equal. apply IHl'. inversion eq. reflexivity. Qed.

(** It might be tempting to start proving the above theorem
    by introducing [n] and [eq] at the outset.  However, this leads
    to an induction hypothesis that is not strong enough.  Compare
    the above to the following (aborted) attempt: *)

Theorem length_snoc_bad : forall (X : Type) (v : X)
                              (l : list X) (n : nat),
     length l = n ->
     length (snoc l v) = S n.
Proof.
  intros X v l n eq. induction l as [| v' l'].

  Case "l = []".
    rewrite <- eq. reflexivity.

  Case "l = v' :: l'".
    simpl. destruct n as [| n'].
    SCase "n = 0". inversion eq.
    SCase "n = S n'".
      apply f_equal. Abort. (* apply IHl'. *) (* The IH doesn't apply! *)

(** As in the double examples, the problem is that by
    introducing [n] before doing induction on [l], the induction
    hypothesis is specialized to one particular natural number, namely
    [n].  In the induction case, however, we need to be able to use
    the induction hypothesis on some other natural number [n'].
    Retaining the more general form of the induction hypothesis thus
    gives us more flexibility.

    In general, a good rule of thumb is to make the induction hypothesis
    as general as possible. *)

(** **** Exercise: 3 stars (gen_dep_practice)  *)
(** Prove this by induction on [l]. *)

Theorem index_after_last: forall (n : nat) (X : Type) (l : list X),
     length l = n ->
     index n l = None.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, advanced, optional (index_after_last_informal)  *)
(** Write an informal proof corresponding to your Coq proof
    of [index_after_last]:

     _Theorem_: For all sets [X], lists [l : list X], and numbers
      [n], if [length l = n] then [index n l = None].

     _Proof_:
     (* FILL IN HERE *)
[]
*)

(** **** Exercise: 3 stars, optional (gen_dep_practice_more)  *)
(** Prove this by induction on [l]. *)

Theorem length_snoc''' : forall (n : nat) (X : Type)
                              (v : X) (l : list X),
     length l = n ->
     length (snoc l v) = S n.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, optional (app_length_cons)  *)
(** Prove this by induction on [l1], without using [app_length]
    from [Lists]. *)

Theorem app_length_cons : forall (X : Type) (l1 l2 : list X)
                                  (x : X) (n : nat),
     length (l1 ++ (x :: l2)) = n ->
     S (length (l1 ++ l2)) = n.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 4 stars, optional (app_length_twice)  *)
(** Prove this by induction on [l], without using app_length. *)

Theorem app_length_twice : forall (X:Type) (n:nat) (l:list X),
     length l = n ->
     length (l ++ l) = n + n.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, optional (double_induction)  *)
(** Prove the following principle of induction over two naturals. *)

Theorem double_induction: forall (P : nat -> nat -> Prop),
  P 0 0 ->
  (forall m, P m 0 -> P (S m) 0) ->
  (forall n, P 0 n -> P 0 (S n)) ->
  (forall m n, P m n -> P (S m) (S n)) ->
  forall m n, P m n.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ###################################################### *)
(** * Using [destruct] on Compound Expressions *)

(** We have seen many examples where the [destruct] tactic is
    used to perform case analysis of the value of some variable.  But
    sometimes we need to reason by cases on the result of some
    _expression_.  We can also do this with [destruct].

    Here are some examples: *)

Definition sillyfun (n : nat) : bool :=
  if beq_nat n 3 then false
  else if beq_nat n 5 then false
  else false.

Theorem sillyfun_false : forall (n : nat),
  sillyfun n = false.
Proof.
  intros n. unfold sillyfun.
  destruct (beq_nat n 3).
    Case "beq_nat n 3 = true". reflexivity.
    Case "beq_nat n 3 = false". destruct (beq_nat n 5).
      SCase "beq_nat n 5 = true". reflexivity.
      SCase "beq_nat n 5 = false". reflexivity.  Qed.

(** After unfolding [sillyfun] in the above proof, we find that
    we are stuck on [if (beq_nat n 3) then ... else ...].  Well,
    either [n] is equal to [3] or it isn't, so we use [destruct
    (beq_nat n 3)] to let us reason about the two cases.

    In general, the [destruct] tactic can be used to perform case
    analysis of the results of arbitrary computations.  If [e] is an
    expression whose type is some inductively defined type [T], then,
    for each constructor [c] of [T], [destruct e] generates a subgoal
    in which all occurrences of [e] (in the goal and in the context)
    are replaced by [c].

*)

(** **** Exercise: 1 star (override_shadow)  *)
Theorem override_shadow : forall (X:Type) x1 x2 k1 k2 (f : nat->X),
  (override (override f k1 x2) k1 x1) k2 = (override f k1 x1) k2.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, optional (combine_split)  *)
(** Complete the proof below *)

Theorem combine_split : forall X Y (l : list (X * Y)) l1 l2,
  split l = (l1, l2) ->
  combine l1 l2 = l.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** Sometimes, doing a [destruct] on a compound expression (a
    non-variable) will erase information we need to complete a proof. *)
(** For example, suppose
    we define a function [sillyfun1] like this: *)

Definition sillyfun1 (n : nat) : bool :=
  if beq_nat n 3 then true
  else if beq_nat n 5 then true
  else false.

(** And suppose that we want to convince Coq of the rather
    obvious observation that [sillyfun1 n] yields [true] only when [n]
    is odd.  By analogy with the proofs we did with [sillyfun] above,
    it is natural to start the proof like this: *)

Theorem sillyfun1_odd_FAILED : forall (n : nat),
     sillyfun1 n = true ->
     oddb n = true.
Proof.
  intros n eq. unfold sillyfun1 in eq.
  destruct (beq_nat n 3).
  (* stuck... *)
Abort.

(** We get stuck at this point because the context does not
    contain enough information to prove the goal!  The problem is that
    the substitution peformed by [destruct] is too brutal -- it threw
    away every occurrence of [beq_nat n 3], but we need to keep some
    memory of this expression and how it was destructed, because we
    need to be able to reason that since, in this branch of the case
    analysis, [beq_nat n 3 = true], it must be that [n = 3], from
    which it follows that [n] is odd.

    What we would really like is to substitute away all existing
    occurences of [beq_nat n 3], but at the same time add an equation
    to the context that records which case we are in.  The [eqn:]
    qualifier allows us to introduce such an equation (with whatever
    name we choose). *)

Theorem sillyfun1_odd : forall (n : nat),
     sillyfun1 n = true ->
     oddb n = true.
Proof.
  intros n eq. unfold sillyfun1 in eq.
  destruct (beq_nat n 3) eqn:Heqe3.
  (* Now we have the same state as at the point where we got stuck
    above, except that the context contains an extra equality
    assumption, which is exactly what we need to make progress. *)
    Case "e3 = true". apply beq_nat_true in Heqe3.
      rewrite -> Heqe3. reflexivity.
    Case "e3 = false".
     (* When we come to the second equality test in the body of the
       function we are reasoning about, we can use [eqn:] again in the
       same way, allow us to finish the proof. *)
      destruct (beq_nat n 5) eqn:Heqe5.
        SCase "e5 = true".
          apply beq_nat_true in Heqe5.
          rewrite -> Heqe5. reflexivity.
        SCase "e5 = false". inversion eq.  Qed.

(** **** Exercise: 2 stars (destruct_eqn_practice)  *)
Theorem bool_fn_applied_thrice :
  forall (f : bool -> bool) (b : bool),
  f (f (f b)) = f b.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars (override_same)  *)
Theorem override_same : forall (X:Type) x1 k1 k2 (f : nat->X),
  f k1 = x1 ->
  (override f k1 x1) k2 = f k2.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ################################################################## *)
(** * Review *)

(** We've now seen a bunch of Coq's fundamental tactics.  We'll
    introduce a few more as we go along through the coming lectures,
    and later in the course we'll introduce some more powerful
    _automation_ tactics that make Coq do more of the low-level work
    in many cases.  But basically we've got what we need to get work
    done.

    Here are the ones we've seen:

      - [intros]:
        move hypotheses/variables from goal to context

      - [reflexivity]:
        finish the proof (when the goal looks like [e = e])

      - [apply]:
        prove goal using a hypothesis, lemma, or constructor

      - [apply... in H]:
        apply a hypothesis, lemma, or constructor to a hypothesis in
        the context (forward reasoning)

      - [apply... with...]:
        explicitly specify values for variables that cannot be
        determined by pattern matching

      - [simpl]:
        simplify computations in the goal

      - [simpl in H]:
        ... or a hypothesis

      - [rewrite]:
        use an equality hypothesis (or lemma) to rewrite the goal

      - [rewrite ... in H]:
        ... or a hypothesis

      - [symmetry]:
        changes a goal of the form [t=u] into [u=t]

      - [symmetry in H]:
        changes a hypothesis of the form [t=u] into [u=t]

      - [unfold]:
        replace a defined constant by its right-hand side in the goal

      - [unfold... in H]:
        ... or a hypothesis

      - [destruct... as...]:
        case analysis on values of inductively defined types

      - [destruct... eqn:...]:
        specify the name of an equation to be added to the context,
        recording the result of the case analysis

      - [induction... as...]:
        induction on values of inductively defined types

      - [inversion]:
        reason by injectivity and distinctness of constructors

      - [assert (e) as H]:
        introduce a "local lemma" [e] and call it [H]

      - [generalize dependent x]:
        move the variable [x] (and anything else that depends on it)
        from the context back to an explicit hypothesis in the goal
        formula
*)

(* ###################################################### *)
(** * Additional Exercises *)

(** **** Exercise: 3 stars (beq_nat_sym)  *)
Theorem beq_nat_sym : forall (n m : nat),
  beq_nat n m = beq_nat m n.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, advanced, optional (beq_nat_sym_informal)  *)
(** Give an informal proof of this lemma that corresponds to your
    formal proof above:

   Theorem: For any [nat]s [n] [m], [beq_nat n m = beq_nat m n].

   Proof:
   (* FILL IN HERE *)
[]
 *)

(** **** Exercise: 3 stars, optional (beq_nat_trans)  *)
Theorem beq_nat_trans : forall n m p,
  beq_nat n m = true ->
  beq_nat m p = true ->
  beq_nat n p = true.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, advanced (split_combine)  *)
(** We have just proven that for all lists of pairs, [combine] is the
    inverse of [split].  How would you formalize the statement that
    [split] is the inverse of [combine]? When is this property true?

    Complete the definition of [split_combine_statement] below with a
    property that states that [split] is the inverse of
    [combine]. Then, prove that the property holds. (Be sure to leave
    your induction hypothesis general by not doing [intros] on more
    things than necessary.  Hint: what property do you need of [l1]
    and [l2] for [split] [combine l1 l2 = (l1,l2)] to be true?)  *)

Definition split_combine_statement : Prop :=
(* FILL IN HERE *) admit.

Theorem split_combine : split_combine_statement.
Proof.
(* FILL IN HERE *) Admitted.

(** [] *)

(** **** Exercise: 3 stars (override_permute)  *)
Theorem override_permute : forall (X:Type) x1 x2 k1 k2 k3 (f : nat->X),
  beq_nat k2 k1 = false ->
  (override (override f k2 x2) k1 x1) k3 = (override (override f k1 x1) k2 x2) k3.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, advanced (filter_exercise)  *)
(** This one is a bit challenging.  Pay attention to the form of your IH. *)

Theorem filter_exercise : forall (X : Type) (test : X -> bool)
                             (x : X) (l lf : list X),
     filter test l = x :: lf ->
     test x = true.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 4 stars, advanced (forall_exists_challenge)  *)
(** Define two recursive [Fixpoints], [forallb] and [existsb].  The
    first checks whether every element in a list satisfies a given
    predicate:
      forallb oddb [1;3;5;7;9] = true

      forallb negb [false;false] = true

      forallb evenb [0;2;4;5] = false

      forallb (beq_nat 5) [] = true
    The second checks whether there exists an element in the list that
    satisfies a given predicate:
      existsb (beq_nat 5) [0;2;3;6] = false

      existsb (andb true) [true;true;false] = true

      existsb oddb [1;0;0;0;0;3] = true

      existsb evenb [] = false
    Next, define a _nonrecursive_ version of [existsb] -- call it
    [existsb'] -- using [forallb] and [negb].

    Prove theorem [existsb_existsb'] that [existsb'] and [existsb] have
    the same behavior.
*)

(* FILL IN HERE *)
(** [] *)

(** $Date: 2014-12-31 16:01:37 -0500 (Wed, 31 Dec 2014) $ *)


Require Import GeoCoq.Axioms.beeson_s_axioms.
Require Import GeoCoq.Axioms.tarski_axioms.

Section Proof_of_eq_stability_in_IT.

Context `{BTn:intuitionistic_Tarski_neutral_dimensionless}.

Lemma cong_stability_eq_stability : forall A B : ITpoint, ~ A <> B -> A = B.
Proof.
intros A B HAB.
apply Icong_identity with A.
apply Cong_stability.
intro HNCong.
apply HAB.
intro HEq.
subst.
apply HNCong.
apply Icong_pseudo_reflexivity.
Qed.

End Proof_of_eq_stability_in_IT.

Require Import Classical.

Section Intuitionistic_Tarski_to_Tarski.

Context `{BTn:intuitionistic_Tarski_neutral_dimensionless}.

Lemma col_dec : forall A B C, ICol A B C \/ ~ ICol A B C.
Proof.
intros.
tauto.
Qed.

Lemma eq_dec : forall A B :ITpoint, A=B \/ A<>B.
Proof.
intros.
tauto.
Qed.

Definition BetT A B C := IBet A B C \/ A=B \/ B=C.

Lemma bet_id : forall A B : ITpoint, BetT A B A -> A = B.
Proof.
intros.
unfold BetT in H.
decompose [or] H.
apply Ibetween_identity in H0.
elim H0.
assumption.
intuition.
Qed.

Lemma IT_chara : forall A B C,
 IT A B C <-> A=B \/ B=C \/ IBet A B C.
Proof.
intros.
unfold IT.
tauto. (* classical *)
Qed.

Lemma BetT_symmetry : forall A B C, BetT A B C -> BetT C B A.
Proof.
intros.
unfold BetT in *.
intuition.
left.
apply Ibetween_symmetry.
assumption.
Qed.

Lemma BetT_id : forall A B, BetT A B A -> A=B.
Proof.
intros.
unfold BetT in *.
intuition.
apply Ibetween_identity in H0.
elim H0.
Qed.

(* Lemma 4.1 page 22 *)

Lemma pasch_col_case : forall A B C P Q : ITpoint,
        BetT A P C ->
        BetT B Q C -> ICol A B C -> exists x : ITpoint, BetT P x B /\ BetT Q x A.
Proof.
intros.
elim (eq_dec A B);intro.
 subst.
 exists B.
 unfold BetT;auto.
elim (eq_dec A C);intro.
 subst.
 apply BetT_id in H.
 subst.
 exists P.
 unfold BetT;auto.
elim (eq_dec B C);intro.
 subst.
 apply BetT_id in H0.
 subst.
 exists Q.
 unfold BetT;auto.
elim (eq_dec B Q);intro.
 subst.
 exists Q.
 unfold BetT;auto.
elim (eq_dec C Q);intro.
 subst.
 exists P.
 split.
 unfold BetT;auto.
 apply BetT_symmetry.
 auto.
elim (eq_dec A P);intro.
 subst.
 exists P.
 unfold BetT;auto.
elim (eq_dec C P);intro.
 subst.
 exists Q.
 split.
 apply BetT_symmetry.
 auto.
 unfold BetT;auto.

unfold ICol in H1.
spliter.
apply not_and_or in H1.
induction H1.
apply NNPP in H1.
unfold IT in *.
apply not_and_or in H1.
induction H1.
apply NNPP in H1.
subst.
intuition.
apply not_and_or in H1.
induction H1.
apply NNPP in H1.
subst.
intuition.
apply NNPP in H1.
exists A.
split.
apply Ibetween_symmetry in H1.
induction H.
assert (T:=Ibetween_inner_transitivity B A P C H1 H).
unfold BetT.
left.
apply Ibetween_symmetry;auto.
induction H;subst.
unfold BetT;auto.
left.
apply Ibetween_symmetry;auto.
unfold BetT;auto.
apply not_and_or in H1.
induction H1.
apply NNPP in H1.
unfold IT in H1.
apply not_and_or in H1.
induction H1.
apply NNPP in H1.
subst.
intuition.
apply not_and_or in H1.
induction H1.
apply NNPP in H1.
subst.
intuition.
apply NNPP in H1.

exists C.

unfold BetT in H.
induction H;induction H0.
split.
apply BetT_symmetry.
left.

apply Ibetween_inner_transitivity with A.
apply Ibetween_symmetry;auto.
apply Ibetween_symmetry;auto.
apply BetT_symmetry.
left.
apply Ibetween_inner_transitivity with B.
assumption.
apply Ibetween_symmetry;auto.
induction H0;subst;intuition.
induction H;subst;intuition.
induction H;subst;intuition.

apply NNPP in H1.
induction H;induction H0.

exists B.
split.
unfold BetT;auto.

left.
apply Ibetween_symmetry.
apply Ibetween_inner_transitivity with C.
unfold IT in H1.
apply not_and_or in H1.
induction H1.
apply NNPP in H1.
subst.
intuition.
apply not_and_or in H1.
induction H1.
apply NNPP in H1.
subst.
intuition.
apply NNPP in H1.
assumption.
assumption.

induction H0;subst;intuition.
induction H;subst;intuition.
induction H;subst;intuition.
Qed.

Lemma pasch : forall A B C P Q : ITpoint,
        BetT A P C ->
        BetT B Q C -> exists x : ITpoint, BetT P x B /\ BetT Q x A.
Proof.
intros.
induction (col_dec A B C).
eapply pasch_col_case;eauto.

unfold BetT in *.
decompose [or] H;clear H.
decompose [or] H0;clear H0.

elim (Iinner_pasch A B C P Q H2 H H1).
intros.
spliter.
exists x.
split.
tauto.
tauto.

subst.
exists Q;auto.
subst.
exists P.
split.
auto.
left.
apply Ibetween_symmetry.
auto.
subst.
exists P;auto.
subst.
decompose [or] H0;clear H0.
exists Q.
split.
left.
apply Ibetween_symmetry.
auto.
auto.
subst.
exists Q;auto.
subst.
exists C;auto.
Qed.

Lemma five_segment:
 forall A A' B B' C C' D D' : ITpoint,
        ICong A B A' B' ->
        ICong B C B' C' ->
        ICong A D A' D' ->
        ICong B D B' D' ->
        BetT A B C -> BetT A' B' C' -> A <> B -> ICong C D C' D'.
Proof.
intros.
apply Ifive_segment with A A' B B' ;try assumption.
unfold IT.
intro.
spliter.
unfold BetT in *.
intuition.
unfold BetT in *.
unfold IT.
intro.
intuition.
Qed.

Lemma IT_trivial : forall A B, IT A A B.
Proof.
intros.
unfold IT.
intro.
spliter.
intuition.
Qed.

Lemma IT_trivial2 : forall A B, IT A B B.
Proof.
intros.
unfold IT.
intro.
spliter.
intuition.
Qed.

Lemma another_point : forall A, exists B:ITpoint, A<>B.
Proof.
intros.
assert (T:=Ilower_dim).
elim (eq_dec A beeson_s_axioms.PA);intro.
subst.
elim (eq_dec beeson_s_axioms.PA beeson_s_axioms.PB);intro.
rewrite <- H in *.
exfalso.
apply T.
apply IT_trivial.
exists beeson_s_axioms.PB.
assumption.
exists beeson_s_axioms.PA.
assumption.
Qed.

Lemma segment_construction :
 forall A B C D : ITpoint,
        exists E : ITpoint, BetT A B E /\ ICong B E C D.
Proof.
intros.
induction (eq_dec A B).
subst.
elim (another_point B);intros.
elim (Isegment_construction x B C D);intros.
exists x0.
split.
unfold BetT.
intuition.
intuition.
intuition.
elim (Isegment_construction A B C D H).
intros.
exists x.
spliter.
split;try assumption.
unfold IT in *.
unfold BetT.
tauto.
Qed.

Lemma lower_dim :
  ~ (BetT beeson_s_axioms.PA beeson_s_axioms.PB beeson_s_axioms.PC \/
     BetT beeson_s_axioms.PB beeson_s_axioms.PC beeson_s_axioms.PA \/
     BetT beeson_s_axioms.PC beeson_s_axioms.PA beeson_s_axioms.PB).
Proof.
assert (T:=Ilower_dim).
unfold BetT in *.
unfold ICol in  *.
unfold IT in *.
firstorder using Ibetween_symmetry.
Qed.

Lemma eq_dec_points_from_classic : forall A B : ITpoint, A = B \/ A <> B.
Proof.
intros.
apply classic.
Qed.

Instance IT_to_T : Tarski_neutral_dimensionless.
exact
(Build_Tarski_neutral_dimensionless
   ITpoint BetT ICong
   Icong_pseudo_reflexivity Icong_inner_transitivity Icong_identity
   segment_construction five_segment
   bet_id pasch beeson_s_axioms.PA beeson_s_axioms.PB beeson_s_axioms.PC lower_dim).
Defined.

Instance IT_to_T_PED :
  Tarski_neutral_dimensionless_with_decidable_point_equality IT_to_T.
Proof. split; apply eq_dec_points_from_classic. Defined.

End Intuitionistic_Tarski_to_Tarski.


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

Require Import List Arith Lia Bool Eqdep_dec.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils_list finite.

Set Default Proof Using "Type".

Set Implicit Arguments.

(* * Utilities for the Full Trakhtenbrot project *)

(* ** Proof irrelevance *)

Fact eq_bool_pirr (b1 b2 : bool) (H1 H2 : b1 = b2) : H1 = H2.
Proof. apply UIP_dec, bool_dec. Qed.

Fact eq_nat_uniq (n : nat) (H : n = n ) : H = eq_refl.
Proof. apply UIP_dec, eq_nat_dec. Qed.

Fact eq_nat_pirr (x y : nat) (H1 H2 : x = y) : H1 = H2.
Proof. apply UIP_dec, eq_nat_dec. Qed.

(* ** Type casting *)

Definition cast (P : nat -> Type) n k (v : P n) (H : n = k) : P k := eq_rect _ P v _ H.

Arguments cast {P n k} v H.

Lemma cast_refl P n (v : P n) : cast v eq_refl = v.
Proof. reflexivity. Qed.

Lemma cast_fun P Q (f : forall n, P n -> Q n) n k (v : P n) (H : n = k) :
        f _ (cast v H) = cast (f _ v) H.
Proof. subst; auto. Qed.

Tactic Notation "solve" "ite" :=
  match goal with _ : ?x < ?y |- context[if le_lt_dec ?y ?x then _ else _]
        => let G := fresh in destruct (le_lt_dec y x) as [ G | _ ]; [ exfalso; lia | ]
  end.

(* ** functions as graphs/relations *)

Section graphs.

  Variable (X Y : Type) (R : X -> Y -> Prop).

  Definition graph_tot := forall x, ex (R x).
  Definition graph_fun := forall x y1 y2, R x y1 -> R x y2 -> y1 = y2.

  Definition is_graph_function := graph_fun /\ graph_tot.

  Hypothesis (H1 : finite_t Y)
             (H3 : forall x y, { R x y } + { ~ R x y }).

  Definition graph_tot_reif : is_graph_function -> { f | forall x y, R x y <-> y = f x }.
  Proof using H3 H1.
    intros (H2 & H4).
    destruct finite_t_dec_choice with (3 := H4) as (f & Hf); auto.
    exists f; intros x y; split.
    + intros H; generalize H (Hf x); apply H2.
    + intros ->; auto.
  Qed.

End graphs.

Section graphs_equiv.

  Variable (X Y : Type) (R : X -> Y -> Prop) (equiv : Y -> Y -> Prop).

  Infix "≈" := equiv (at level 70, no associativity).

  Definition graph_equiv_tot := forall x, ex (R x).
  Definition graph_equiv_fun := forall x y1 y2, R x y1 -> R x y2 -> y1 ≈ y2.

  Definition is_graph_equiv_function := graph_equiv_fun /\ graph_equiv_tot.

  Hypothesis (H1 : finite_t Y)
             (H3 : forall x y, { R x y } + { ~ R x y })
             (H6 : forall x y1 y2, y1 ≈ y2 -> R x y2 -> R x y1).

  Definition graph_equiv_function_reif : is_graph_equiv_function -> { f | forall x y, R x y <-> y ≈ f x }.
  Proof using H6 H3 H1.
    intros (H2 & H4).
    destruct finite_t_dec_choice with (3 := H4) as (f & Hf); auto.
    exists f; intros x y; split.
    + intros H; generalize H (Hf x); apply H2.
    + intros H; generalize (Hf x); apply H6; auto.
  Qed.

End graphs_equiv.


From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div.
From mathcomp Require Import choice fintype tuple finfun bigop prime binomial.
From mathcomp Require Import ssralg finset fingroup finalg matrix.
Require Import Reals Fourier ProofIrrelevance FunctionalExtensionality.
Require Import ssrR Reals_ext ssr_ext ssralg_ext logb Rbigop.
Require Import proba.

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

Section interval.

Definition convex_interval (D : R -> Prop) := forall x y t,
  D x -> D y -> 0 <= t <= 1 -> D (t * x + (1-t) * y).

Record interval := mkInterval {
  mem_interval :> R -> Prop;
  interval_convex : convex_interval mem_interval }.

End interval.

Section convex.

Definition convex_leq (f : R -> R) (x y t : R) :=
  f (t * x + (1 - t) * y) <= t * f x + (1 - t) * f y.

Definition convex (f : R -> R) := forall x y t : R,
  0 <= t <= 1 -> convex_leq f x y t.

Definition convex_in (D : interval) (f : R -> R) := forall x y t : R,
  D x -> D y -> 0 <= t <= 1 -> convex_leq f x y t.

Definition strictly_convex (f : R -> R) := forall x y t : R,
  x != y -> 0 < t < 1 -> convex_leq f x y t.

End convex.

Section concave.

Definition concave_leq (f : R -> R) (x y t : R) :=
  t * f x + (1 - t) * f y <=  f (t * x + (1 - t) * y).

Definition concave (f : R -> R) := forall x y t : R,
  0 <= t <= 1 -> concave_leq f x y t.

Definition concave_in (D : interval) (f : R -> R) := forall x y t : R,
  D x -> D y -> 0 <= t <= 1 -> concave_leq f x y t.

Definition strictly_concave (f : R -> R) := forall x y t : R,
  x != y -> 0 < t < 1 -> concave_leq f x y t.

End concave.

Lemma dist_ind (A : finType) (P : dist A -> Prop) :
  (forall n : nat, (forall X, #|dist_supp X| = n -> P X) ->
    forall X b, #|dist_supp X| = n.+1 -> X b != 0 -> P X) ->
  forall X, P X.
Proof.
move=> H1 d.
move: {-2}(#|dist_supp d|) (erefl (#|dist_supp d|)) => n; move: n d.
elim=> [d /esym /card0_eq Hd0|].
  move: (pmf1 d).
  rewrite -[X in X = _]mul1R big_distrr rsum_dist_supp.
  rewrite big1 => [H01|a].
    by elim: (gtR_eqF _ _ Rlt_0_1).
  by rewrite Hd0.
move=> n IH d n13.
have [b Hb] : exists b : A, d b != 0.
  suff : {x | x \in dist_supp d} by case => a; rewrite inE => ?; exists a.
  apply/sigW/set0Pn; by rewrite -cards_eq0 -n13.
by refine (H1 n _ _ _ _ Hb) => // d' A2; apply IH.
Qed.

Section jensen_inequality.

Variable f : R -> R.
Variable D : interval.
Hypothesis convex_f : convex_in D f.
Variables A : finType.

Lemma dist_supp_singleP (X : dist A) a :
  reflect (X a = 1) (dist_supp X == [set a]).
Proof.
apply: (iffP idP).
  move/eqP => Ha.
  rewrite -(pmf1 X).
  rewrite (eq_bigr (fun i => 1 * X i)); last by move=> *; rewrite mul1R.
  by rewrite rsum_dist_supp Ha big_set1 mul1R.
move=> Xa1.
have H : forall b : A, b != a -> X b = 0.
  apply/(@prsumr_eq0P _ [pred x | x != a] X).
    move=> ? _; exact/dist_ge0.
  move/eqP : (pmf1 X).
  by rewrite (bigD1 a) //= Xa1 eq_sym addRC -subR_eq subRR => /eqP <-.
apply/eqP/setP => b.
rewrite !inE.
case/boolP: (b == a) => Hb.
  rewrite (eqP Hb) Xa1; apply/eqP => Hb'.
  apply (ltRR 1).
  by rewrite {1}Hb'.
by rewrite H // eqxx.
Qed.

Local Hint Resolve leRR.

Lemma jensen_dist (r : A -> R) (X : dist A) :
  (forall a, D (r a)) ->
  f (\rsum_(a in A) r a * X a) <= \rsum_(a in A) f (r a) * X a.
Proof.
move=> HDr.
apply (@proj1 _ (D (\rsum_(a in dist_supp X) r a * X a))).
rewrite [in X in _ <= X]rsum_dist_supp [in X in X <= _]rsum_dist_supp /=.
apply: (@dist_ind A (fun X =>
   f (\rsum_(a in dist_supp X) r a * X a) <=
   \rsum_(a in dist_supp X) f (r a) * X a /\ _)) => //.
move=> n IH {X}X b cardA Hb.
case/boolP : (X b == 1) => Xb1.
  move/dist_supp_singleP: (eqP Xb1) => /eqP ->.
  by rewrite !big_set1 (eqP Xb1) !mulR1.
have HXb1: 1 - X b != 0.
  by apply: contra Xb1; rewrite subR_eq0 eq_sym.
set d := D1Dist.d Xb1.
have HsumD1 q:
  \rsum_(a in dist_supp d) q a * d a =
  /(1 - X b) * \rsum_(a in dist_supp d) q a * X a.
  rewrite (eq_bigr (fun a => /(1-X b) * (q a * X a))); last first.
    move=> i.
    rewrite inE /= /d /D1Dist.f /=.
    case: ifP => Hi; first by rewrite eqxx.
    by rewrite /Rdiv (mulRC (/ _)) mulRA.
  by rewrite -big_distrr.
have {HsumD1}HsumXD1 q:
  \rsum_(a in dist_supp X) q a * X a =
  q b * X b + (1 - X b) * (\rsum_(a in dist_supp d) q a * d a).
  rewrite HsumD1 /d /D1Dist.f /= mulRA mulRV // mul1R (bigD1 b) ?inE //=.
  rewrite (eq_bigl (fun a : A => a \in dist_supp d)) //= => i.
  rewrite !inE /=.
  case HXi: (X i == 0) => //=.
    by rewrite (D1Dist.f_0 _ (eqP HXi)) eqxx.
  by rewrite D1Dist.f_eq0 // ?HXi // eq_sym.
rewrite 2!{}HsumXD1.
have /IH {IH}[IH HDd] : #|dist_supp d| = n.
  by rewrite D1Dist.card_dist_supp // cardA.
have HXb: 0 <= X b <= 1 by split; [exact/dist_ge0|exact/dist_max].
split; last by rewrite mulRC; apply interval_convex.
rewrite mulRC.
refine (leR_trans
  (@convex_f (r b) (\rsum_(i in dist_supp d) r i * d i) _ _ HDd HXb) _) => //.
rewrite mulRC.
apply /leR_add2l /leR_wpmul2l => //.
rewrite leR_subr_addr add0R; by apply HXb.
Qed.

Local Open Scope proba_scope.

Lemma Jensen (X : rvar A) : (forall x, D (X x)) ->
  f (`E X) <= `E (mkRvar (`p_ X) (fun x => f (X x))).
Proof. move=> HDX; rewrite !ExE /=; by apply jensen_dist. Qed.

End jensen_inequality.

Section jensen_concave.

Variable f : R -> R.
Variable D : interval.
Hypothesis concave_f : concave_in D f.
Variable A : finType.

Let g x := - f x.

Lemma convex_g : convex_in D g.
Proof.
move=> x y t Hx Hy Ht.
rewrite /convex_leq /g.
rewrite !mulRN -oppRD leR_oppr oppRK.
exact: concave_f.
Qed.

Lemma jensen_dist_concave (r : A -> R) (X : dist A) :
  (forall x, D (r x)) ->
  \rsum_(a in A) f (r a) * X a <= f (\rsum_(a in A) r a * X a).
Proof.
move=> HDr.
rewrite -[X in _ <= X]oppRK leR_oppr.
move: (jensen_dist convex_g X HDr).
rewrite /g.
rewrite [in X in _ <= X](eq_bigr (fun a => -1 * (f (r a) * X a))).
  rewrite -[in X in _ <= X]big_distrr /=.
  by rewrite mulNR mul1R.
move=> i _.
by rewrite !mulNR mul1R.
Qed.

End jensen_concave.


Require Import ZArith.
Require Import QArith.
Require Import Qabs.

Require Import remedial.
Require Import rearrange_tactic.
Require Import is_integer.
Require Import floor_and_ceiling.
Require Import qpos.
Require Import twopower.
Require Import twopower_tactics.
Require Import binade.
Require Import cobinade.
Require Import binary_float.

Set Implicit Arguments.

Local Open Scope Q.

Lemma nonzero_product_is_nonzero (x y : Q) :
  ~(x == 0)%Q -> ~(y == 0)%Q -> ~(x * y == 0)%Q.
Proof.
  intros; contradict H; scale_by y; now ring_simplify.
Qed.

(* Notation to ease working with elements of subsets.

     For a nonzero float f, "[ f ]" is the corresponding element
     of nonzero_float, and the notation hides the (often complicated)
     proof term.

     Conversely, given a nonzero_float g, !g is the corresponding float. *)

Notation "[ e ]" := (exist _ e _).
Notation "! x" := (proj1_sig x) (at level 20, right associativity).

Local Open Scope float.

Lemma float_lt_nge p (f g : binary_float p) : f < g  <->  ~(g <= f).
Proof.
  apply Qlt_nge.
Qed.

Lemma float_le_ngt p (f g : binary_float p) : f <= g  <->  ~(g < f).
Proof.
  unfold float_le, float_lt.
  split; intro.
  now apply Qle_not_lt.
  now apply Qnot_lt_le.
Qed.

Definition nonzero_float p := { x : binary_float p | ~(x == 0) }.

Definition nonzero_float_eq p (f g : nonzero_float p) :=
  ! f == ! g.

Lemma nonzero_float_eq_reflexivity p (x : nonzero_float p) :
  nonzero_float_eq x x.
Proof.
  apply Qeq_refl.
Qed.

Lemma nonzero_float_eq_symmetry p (x y : nonzero_float p) :
  nonzero_float_eq x y -> nonzero_float_eq y x.
Proof.
  apply Qeq_sym.
Qed.

Lemma nonzero_float_eq_transitivity p (x y z : nonzero_float p) :
  nonzero_float_eq x y -> nonzero_float_eq y z -> nonzero_float_eq x z.
Proof.
  apply Qeq_trans.
Qed.

Add Parametric Relation (p : positive) : (nonzero_float p)
                                           (nonzero_float_eq (p:=p))
    reflexivity proved by (nonzero_float_eq_reflexivity (p:=p))
    symmetry proved by (nonzero_float_eq_symmetry (p:=p))
    transitivity proved by (nonzero_float_eq_transitivity (p:=p))
    as EqualNonzeroFloat.

Definition nonzero_float_opp p (f : nonzero_float p) : nonzero_float p.
Proof.
  refine [- !f]; destruct f as [x nonzero_x]; unfold float_opp, float_eq in *;
  simpl in *; contradict nonzero_x; rearrange.
Defined.

Lemma nonzero_float_opp_opp p (f : nonzero_float p) :
  !nonzero_float_opp (nonzero_float_opp f) == !f.
Proof.
  unfold nonzero_float_opp, float_eq, float_opp; simpl; ring.
Qed.

Lemma nonzero_float_opp_lt_switch p (f g : nonzero_float p) :
  !nonzero_float_opp f < !g  <->  !nonzero_float_opp g < !f.
Proof.
  unfold nonzero_float_opp, float_lt; simpl; split; intro; rearrange.
Qed.

Lemma nonzero_float_lt_opp_switch p (f g : nonzero_float p) :
  !f < !nonzero_float_opp g  <->  !g < !nonzero_float_opp f.
Proof.
  unfold nonzero_float_opp, float_lt; simpl; split; intro; rearrange.
Qed.

Lemma nonzero_float_le_opp_switch p (f g : nonzero_float p) :
  !f <= !nonzero_float_opp g  <->  !g <= !nonzero_float_opp f.
Proof.
  unfold nonzero_float_opp, float_le; simpl; split; intro; rearrange.
Qed.

Lemma nonzero_float_opp_negative_is_positive p (f : nonzero_float p) :
  !f < 0  ->  0 < !nonzero_float_opp f.
Proof.
  unfold nonzero_float_opp, float_lt; simpl; intro; rearrange.
Qed.

Lemma nonzero_float_opp_positive_is_negative p (f : nonzero_float p) :
  0 < !f  -> !nonzero_float_opp f < 0.
Proof.
  unfold nonzero_float_opp, float_lt; simpl; intro; rearrange.
Qed.

(* It's convenient to define a way to decompose our nonzero float
     into either a positive or negative float. *)

Definition float_by_sign p (f : nonzero_float p) : QPos + QPos.
Proof.
  destruct f as [[q q_representable] x_nonzero];
  destruct (Q_dec 0 q) as [[q1 | q2] | q3].
  - left; exact (exist _ q q1).
  - right; refine (exist _ (-q)%Q _); rearrange.
  - contradict x_nonzero; now symmetry.
Defined.

Lemma float_by_sign_spec p (f : nonzero_float p) :
  (!!f == match float_by_sign f with
          | inl x => !x
          | inr x => -(!x)
          end)%Q.
Proof.
  unfold float_by_sign; destruct f as [[q q_representable] x_nonzero];
  destruct (Q_dec 0 q) as [[q1 | q2] | q3];
  (simpl; ring || contradict x_nonzero).
Qed.

Definition low_exponent p (f : nonzero_float p) : Z :=
  match float_by_sign f with
  | inl x => (binade x - 'p + 1)%Z
  | inr x => (cobinade x - 'p)%Z
  end.

Definition low_significand_Q p (f : nonzero_float p) : Q :=
  match float_by_sign f with
  | inl x => !x / twopowerQ (low_exponent f)
  | inr x => -(!x / twopowerQ (low_exponent f))
  end%Q.

Lemma low_significand_is_integer p (f : nonzero_float p) :
  is_integer (low_significand_Q f).
Proof.
  pose proof (float_by_sign_spec f) as H;
  unfold low_significand_Q, low_exponent; destruct (float_by_sign f);
  destruct f as [[x x_representable] x_nonzero];
  simpl in H.
  - apply (large_representable_is_integer p).
    + apply scaled_representable_is_representable_div;
      now rewrite <- H.
    + twopower_left; rewrite Qabs_pos.
      * apply twopower_binade_le; omega.
      * apply Qlt_le_weak. now destruct q.
  - apply is_integer_neg, (large_representable_is_integer p).
    + apply scaled_representable_is_representable_div;
      assert (!q == -x)%Q as H0 by rearrange;
      rewrite H0; now apply neg_representable_is_representable.
    + twopower_left; rewrite Qabs_pos.
      * apply Qlt_le_weak, twopower_cobinade_lt; omega.
      * apply Qlt_le_weak; now destruct q.
Qed.

Definition low_significand p (f : nonzero_float p) :=
  floor (low_significand_Q f).

Lemma reconstruct_float p (f : nonzero_float p) :
  (inject_Z (low_significand f) * twopowerQ (low_exponent f) == !!f)%Q.
Proof.
  pose proof (low_significand_is_integer f);
  unfold low_significand, low_significand_Q, low_exponent in *;
  rewrite float_by_sign_spec; destruct float_by_sign.
  - twopower_right; now apply floorQ_eq.
  - twopower_right; setoid_replace (- !q / twopowerQ (cobinade q - 'p))
                    with (- (!q / twopowerQ (cobinade q - 'p)))%Q
      by (field; apply twopowerQ_nonzero); now apply floorQ_eq.
Qed.

Lemma low_significand_bound p (f : nonzero_float p) :
  match float_by_sign f with
  | inl x => twopowerQ ('p - 1) <= low_significand_Q f < twopowerQ (' p)
  | inr x => -twopowerQ ('p) <= low_significand_Q f < -twopowerQ ('p - 1)
  end.
Proof.
  unfold low_significand_Q, low_exponent; destruct float_by_sign; split.
  - twopower_left; apply twopower_binade_le; omega.
  - twopower_right; apply twopower_binade_lt; omega.
  - rewrite <- Qopp_le_mono; twopower_right; apply twopower_cobinade_le; omega.
  - rewrite <- Qopp_lt_mono; twopower_left; apply twopower_cobinade_lt; omega.
Qed.

Lemma next_up_significand_bound p (f : nonzero_float p) :
  match float_by_sign f with
  | inl x => twopowerQ ('p - 1) < low_significand_Q f + 1 <= twopowerQ (' p)
  | inr x => -twopowerQ ('p) < low_significand_Q f + 1 <= -twopowerQ ('p - 1)
  end.
Proof.
  pose proof (low_significand_bound f) as H;
  destruct float_by_sign; destruct H as [Hlower Hupper]; split.
  - apply Qle_lt_trans with (1 := Hlower); now rearrange_goal (0 < 1)%Q.
  - apply Qlt_le_succ.
    + apply low_significand_is_integer.
    + now apply is_integer_twopowerQ.
    + easy.
  - apply Qle_lt_trans with (1 := Hlower); now rearrange_goal (0 < 1)%Q.
  - apply Qlt_le_succ.
    + apply low_significand_is_integer.
    + apply is_integer_neg, is_integer_twopowerQ; now destruct p.
    + easy.
Qed.

Lemma next_up_significand_abs_upper_bound p (f : nonzero_float p) :
  (Qabs (inject_Z (low_significand f + 1)) <= twopowerQ (' p))%Q.
Proof.
  rewrite inject_Z_plus; change (inject_Z 1) with 1;
  setoid_replace (inject_Z (low_significand f))
  with (low_significand_Q f) by
      (unfold low_significand;
       apply floorQ_eq, low_significand_is_integer);
  pose proof (next_up_significand_bound f) as H;
  destruct float_by_sign; destruct H as [Hlower Hupper].
  - rewrite Qabs_pos.
    + easy.
    + apply Qlt_le_weak, Qlt_trans with (2 := Hlower), twopowerQ_positive.
  - rewrite Qabs_neg.
    + apply Qlt_le_weak; rearrange.
    + apply Qle_trans with (1 := Hupper), Qlt_le_weak.
      rearrange_goal (0 < twopowerQ ('p - 1))%Q.
      apply twopowerQ_positive.
Qed.

Lemma next_up_significand_abs_lower_bound p (f : nonzero_float p) :
  (twopowerQ ('p - 1) <= Qabs (inject_Z (low_significand f + 1)))%Q.
Proof.
  rewrite inject_Z_plus; change (inject_Z 1) with 1;
  setoid_replace (inject_Z (low_significand f))
  with (low_significand_Q f) by
      (unfold low_significand;
       apply floorQ_eq, low_significand_is_integer).
  pose proof (next_up_significand_bound f) as H.
  destruct float_by_sign; destruct H as [Hlower Hupper].
  - rewrite Qabs_pos.
    + now apply Qlt_le_weak.
    + apply Qlt_le_weak, Qlt_trans with (2 := Hlower), twopowerQ_positive.
  - rewrite Qabs_neg.
    + rearrange.
    + apply Qle_trans with (1 := Hupper).
      rearrange_goal (0 <= twopowerQ ('p - 1))%Q.
      apply twopowerQ_nonnegative.
Qed.

Definition next_up p (f : nonzero_float p) : nonzero_float p.
Proof.
  refine
    [float_from_significand_and_exponent
       p (low_significand f + 1) (low_exponent f)
       (next_up_significand_abs_upper_bound f)].
  (* Left with showing that we're nonzero. *)
  unfold float_from_significand_and_exponent.
  apply nonzero_product_is_nonzero.
  - apply Qabs_nonzero_inv, Qlt_le_trans with (y := twopowerQ ('p - 1)).
    + apply twopowerQ_positive.
    + apply next_up_significand_abs_lower_bound.
  - apply twopowerQ_nonzero.
Defined.

(* Theorem characterizing next_up. *)

Theorem next_up_spec p (f g : nonzero_float p) :
  proj1_sig (next_up f) <= proj1_sig g  <->  proj1_sig f < proj1_sig g.
Proof.
  split.
  - (* the easy direction: if next_up f <= g, then f < next_up f <= g *)
    intro.
    apply float_lt_le_trans with (2 := H).
    unfold next_up, float_lt; simpl.
    rewrite <- reconstruct_float.
    twopower_right.
    rewrite <- Zlt_Qlt.
    omega.
  - pose proof (low_significand_bound f).
    pose proof (float_by_sign_spec f).
    assert (low_exponent f = low_exponent f).
    easy.
    unfold low_exponent at 2 in H1.
    assert (low_significand_Q f == low_significand_Q f)%Q.
    easy.
    unfold low_significand_Q at 2 in H2.
    destruct float_by_sign; intro.
    + (* Case f positive. *)
      unfold next_up, float_from_significand_and_exponent, float_le; simpl.
      twopower_right.
      rewrite inject_Z_plus.
      apply Qlt_le_succ.
      * apply is_integer_inject_Z.
      * apply large_representable_is_integer with (p := p).
        apply scaled_representable_is_representable_div.
        destruct g as [[g_as_q g_as_q_representable] g_nonzero].
        easy.
        rewrite H1.
        twopower_left.
        rewrite Qabs_pos.
        apply Qle_trans with (y := !!f).
        rewrite H0.
        apply twopower_binade_le; omega.
        now apply Qlt_le_weak.
        apply Qlt_le_weak, Qlt_trans with (y := !!f).
        rewrite H0; now destruct q.
        easy.
      * twopower_left.
        apply Qle_lt_trans with (y := !!f).
        twopower_right.
        unfold low_significand.
        setoid_replace (inject_Z (floor (low_significand_Q f)))
        with (low_significand_Q f).
        rewrite H2.
        twopower_left.
        rewrite H0.
        apply Qle_refl.
        apply floorQ_eq.
        apply low_significand_is_integer.
        easy.
    + (* Case f negative. *)
      unfold next_up, float_from_significand_and_exponent, float_le; simpl.
      (* We have -twopowerQ (cobinade q) <= f < -twopowerQ (cobinade q - 1) *)
      (* Divide into cases: either g < -twopowerQ (cobinade q - 1),
         or -twopower (cobinade q - 1) <= g. *)
      destruct (Qlt_le_dec (!!g) (-twopowerQ (cobinade q - 1))).
      * (* Case where g is within the same (weak) binade. *)
        twopower_right.
        rewrite inject_Z_plus.
        apply Qlt_le_succ.
        apply is_integer_inject_Z.
        apply large_representable_is_integer with (p := p).
        apply scaled_representable_is_representable_div.
        now destruct g as [[c d] b].
        rewrite H1.
        twopower_left.
        rewrite Qabs_neg.
        apply Qlt_le_weak; rearrange.
        apply Qlt_le_weak,
        Qlt_trans with (y := (-twopowerQ (cobinade q - 1))%Q).
        easy.
        rearrange_goal (0 < twopowerQ (cobinade q - 1))%Q.
        apply twopowerQ_positive.
        unfold low_significand.
        setoid_replace (inject_Z (floor (low_significand_Q f)))
        with (low_significand_Q f).
        rewrite H2.
        twopower_right.
        rewrite <- H0.
        easy.
        apply floorQ_eq.
        apply low_significand_is_integer.
      * (* Case where g is not in the same binade. *)
        apply Qle_trans with (2 := q0).
        rewrite H1.
        (* twopower_right should work in place of the next three *)
        apply le_neg_switch_r.
        twopower_left.
        apply le_neg_switch_r.
        rewrite inject_Z_plus.
        apply Qlt_le_succ.
        apply is_integer_inject_Z.
        apply is_integer_neg.
        apply is_integer_twopowerQ.
        assert (0 < 'p)%Z by easy.
        omega.
        unfold low_significand.
        setoid_replace (inject_Z (floor (low_significand_Q f)))
        with (low_significand_Q f).
        rewrite H2.
        rewrite <- Qopp_lt_mono.
        rewrite H1.
        twopower_left.
        apply twopower_cobinade_lt.
        omega.
        apply floorQ_eq.
        apply low_significand_is_integer.
Qed.

Theorem next_up_spec_alt p (f g : nonzero_float p) :
  !g < !next_up f  <->  !g <= !f.
Proof.
  rewrite float_le_ngt, float_lt_nge; apply negate_iff, next_up_spec.
Qed.

Theorem next_up_positive p (f : nonzero_float p) :
  0 < !f  ->  0 < !next_up f.
Proof.
  intro; apply float_lt_trans with (1 := H), next_up_spec, float_le_refl.
Qed.

Theorem next_up_negative p (f : nonzero_float p) :
  !f < 0  ->  !next_up f < 0.
Proof.
  pose proof (next_up_significand_bound f);
  pose proof (float_by_sign_spec f);
  intro; unfold next_up, low_significand, float_lt;
  unfold float_from_significand_and_exponent;
  destruct float_by_sign; simpl.
  - (* Case f positive; should get a contradiction. *)
    assert (0 < !f) by (unfold float_lt; rewrite H0; now destruct q);
    assert (float_lt (p:=p) 0 0) as zero_lt_zero
        by (now apply float_lt_trans with (y := !f)).
    now contradict zero_lt_zero.
  - (* Case f negative. *)
    twopower_right.
    rewrite inject_Z_plus.
    setoid_replace (inject_Z (floor (low_significand_Q f)))
    with (low_significand_Q f).
    apply Qle_lt_trans with (y := (- twopowerQ ('p - 1))%Q).
    easy.
    rearrange_goal (0 < twopowerQ ('p - 1))%Q.
    apply twopowerQ_positive.
    apply floorQ_eq.
    apply low_significand_is_integer.
Qed.

Definition next_down p (f : nonzero_float p) :=
  nonzero_float_opp (next_up (nonzero_float_opp f)).

Theorem next_down_spec p (f g : nonzero_float p) :
  !f <= !next_down g  <->  !f < !g.
Proof.
  unfold next_down.
  rewrite <- nonzero_float_opp_opp at 2.
  rewrite nonzero_float_opp_lt_switch.
  rewrite nonzero_float_le_opp_switch.
  apply next_up_spec.
Qed.

Theorem next_down_spec_alt p (f g : nonzero_float p) :
  !next_down g < !f  <->  !g <= !f.
Proof.
  rewrite float_le_ngt, float_lt_nge; apply negate_iff, next_down_spec.
Qed.

Theorem next_down_positive p (f : nonzero_float p) :
  0 < !f  ->  0 < !next_down f.
Proof.
  intro; unfold next_down;
  now apply nonzero_float_opp_negative_is_positive,
  next_up_negative, nonzero_float_opp_positive_is_negative.
Qed.

Theorem next_down_negative p (f : nonzero_float p) :
  !f < 0  ->  !next_down f < 0.
Proof.
  intro; unfold next_down.
  now apply nonzero_float_opp_positive_is_negative,
  next_up_positive, nonzero_float_opp_negative_is_positive.
Qed.

Theorem next_up_next_down p (f : nonzero_float p) :
  !next_up (next_down f) == !f.
Proof.
  apply float_le_antisymm.
  - apply next_up_spec, next_down_spec, float_le_refl.
  - apply next_down_spec_alt, next_up_spec_alt, float_le_refl.
Qed.

Theorem next_down_next_up p (f : nonzero_float p) :
  !next_down (next_up f) == !f.
Proof.
  apply float_le_antisymm.
  - apply next_up_spec_alt, next_down_spec_alt, float_le_refl.
  - apply next_down_spec, next_up_spec, float_le_refl.
Qed.

(* next_up and next_down are monotonic and injective. *)

Theorem next_up_eq p (f g : nonzero_float p) :
  !f == !g  <->  !next_up f == !next_up g.
Proof.
  split; intro H.
  - apply float_le_antisymm; apply next_up_spec, next_up_spec_alt;
    rewrite H; apply float_le_refl.
  - apply float_le_antisymm; apply next_up_spec_alt, next_up_spec;
    rewrite H; apply float_le_refl.
Qed.

Theorem next_up_le p (f g : nonzero_float p) :
  !f <= !g  <->  !next_up f <= !next_up g.
Proof.
  split; intro.
  - now apply next_up_spec, next_up_spec_alt.
  - now apply next_up_spec_alt, next_up_spec.
Qed.

Theorem next_up_lt p (f g : nonzero_float p) :
  !f < !g  <->  !next_up f < !next_up g.
Proof.
  split; intro.
  - now apply next_up_spec_alt, next_up_spec.
  - now apply next_up_spec, next_up_spec_alt.
Qed.

Theorem next_down_eq p (f g : nonzero_float p) :
  !f == !g  <->  !next_down f == !next_down g.
Proof.
  split; intro H; apply float_le_antisymm;
  (apply next_down_spec, next_down_spec_alt
                           || apply next_down_spec_alt, next_down_spec);
  rewrite H; apply float_le_refl.
Qed.

Theorem next_down_le p (f g : nonzero_float p) :
  !f <= !g  <->  !next_down f <= !next_down g.
Proof.
  split; intro;
  (
    apply next_down_spec, next_down_spec_alt
    ||
    apply next_down_spec_alt, next_down_spec
  );
  easy.
Qed.

Theorem next_down_lt p (f g : nonzero_float p) :
  !f < !g  <->  !next_down f < !next_down g.
Proof.
  split; intro;
  (
    apply next_down_spec_alt, next_down_spec
    ||
    apply next_down_spec, next_down_spec_alt
  );
  easy.
Qed.

Add Parametric Morphism (p : positive) : (next_up (p:=p))
    with signature nonzero_float_eq (p:=p) ==> nonzero_float_eq (p:=p)
      as next_up_morphism.
Proof.
  intros; unfold nonzero_float_eq; now rewrite <- next_up_eq.
Qed.

Add Parametric Morphism (p : positive) : (next_down (p:=p))
    with signature nonzero_float_eq (p:=p) ==> nonzero_float_eq (p:=p)
      as next_down_morphism.
Proof.
  intros; unfold nonzero_float_eq; now rewrite <- next_down_eq.
Qed.

(* Example computations with next_up. *)

Definition tiny_precision_neg_one : nonzero_float 53.
Proof.
  refine [[(-(1))%Q]].
  easy.
  Grab Existential Variables.
  now exists ((-1)%Z), (0%Z).
Defined.

Example next_up_of_neg_one :
  (!!next_up tiny_precision_neg_one == -9007199254740991 # 9007199254740992)%Q.
Proof. now compute. Qed.

Example next_down_of_neg_one :
  (!!next_down tiny_precision_neg_one ==
   -4503599627370497 # 4503599627370496)%Q.
Proof. now compute. Qed.


Require Import A1_Plan A2_Orientation A5_Cercle A7_Tactics .
Require Import B7_Tactics .
Require Import C1_Distance C5_TriangularInequality C7_Tactics.

Section BUILDING_CLOCKWISE.

Lemma  EquilateralInequality : forall A B : Point,
	TriangularInequality A B A B A B.
Proof.
	unfold TriangularInequality in |- *; intros.
	immediate2.
Qed.

Lemma EquilateralTriangleSpec : forall A B : Point,
	TriangleSpec A B A B A B.
Proof.
	intros; unfold TriangleSpec in |- *.
	assert (H := EquilateralInequality A B); intuition.
Qed.

Definition ExistsClockwise (A B : Point) : A <> B -> Point.
Proof.
	intros.
	setCircle0 A A B ipattern:(gamma1).
	setCircle0 B A B ipattern:(gamma2).
	setInterCircles gamma1 gamma2 ipattern:(C).
	  exact (EquilateralTriangleSpec A B).
	 exact C.
Defined.

Ltac destructExistsClockwise A B H := unfold ExistsClockwise in |- *;
	destruct (InterCirclesPointDef (Compass A A B) (Compass B A B)) as (C, ((H1, (H2, H3)), H4)); simpl in *.

Lemma NotOpenRayABExistsClockwise : forall (A B : Point) (H : A <> B),
	~OpenRay A B (ExistsClockwise A B H).
Proof.
	intros; destructExistsClockwise ipattern:(A) ipattern:(B) ipattern:(H).
	setLine0 A B ipattern:(ab).
	setCircle0 A A B ipattern:(g).
	setInterDiameter ab g ipattern:(D).
	 intro; elim (DistinctEqDistanceDistinct A B B C H (sym_eq H2)).
	   apply trans_eq with (y := D).
	  apply sym_eq; apply Hun; split; immediate2.
	  apply Hun; split; immediate2.
Qed.

Lemma NotOpenRayBAExistsClockwise : forall (A B : Point) (H : A <> B),
	~OpenRay B A (ExistsClockwise A B H).
Proof.
	intros; destructExistsClockwise ipattern:(A) ipattern:(B) ipattern:(H).
	setLine0 B A ipattern:(ba).
	setCircle0 B A B ipattern:(g).
	setInterDiameter ba g ipattern:(D).
	 intro; elim (DistinctEqDistanceDistinct A B A C H (sym_eq H1)).
	   apply trans_eq with (y := D).
	  apply sym_eq; apply Hun; split; immediate2.
	  apply Hun; split; immediate2.
Qed.

Lemma NotClockwiseExistsClockwise : forall (A B : Point) (H : A <> B),
	~Clockwise A B (ExistsClockwise A B H).
Proof.
	intros; destructExistsClockwise ipattern:(A) ipattern:(B) ipattern:(H).
	intro; elim H3; immediate2.
Qed.

Lemma ClockwiseExistsClockwise : forall (A B : Point) (H : A <> B),
	Clockwise A (ExistsClockwise A B H) B.
Proof.
	intros; by4Cases1 ipattern:(A) ipattern:(B) (ExistsClockwise A B H).
	 elim (NotClockwiseExistsClockwise A B H); immediate2.
	 immediate2.
	 elim (NotOpenRayABExistsClockwise A B H); immediate2.
	 elim (NotOpenRayBAExistsClockwise A B H); immediate2.
Qed.

End BUILDING_CLOCKWISE.