Require Import Setoid.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Classes.Morphisms.

Set Implicit Arguments.
Set Strict Implicit.

Class Order (T : Type) : Type :=
{ le : T -> T -> Prop
; Refl_le :> Reflexive le
; Trans_le :> Transitive le }.
Arguments le {_ _} _ _.
Arguments Refl_le {_ _} _.
Arguments Trans_le {_ _} _ _ _ _ _.

Record otype : Type :=
{ T :> Type
; order :> Order T }.
(* 'equality' is defined as 'a <= b /\ b <= a' *)

Existing Instance order.

Definition ole {T : otype} (a b : T) : Prop :=
  le a b.

Global Instance Reflexive_ole {T} : Reflexive (@ole T).
Proof. red. intros. red. destruct T0. eapply Refl_le. Qed.
Global Instance Transitive_ole {T} : Transitive (@ole T).
Proof. red. intros. red. destruct T0. eapply Trans_le; eauto. Qed.

Instance Proper_ole_impl {A : otype}
: Morphisms.Proper (ole --> ole ==> Basics.impl) (@ole A).
Proof.
  do 4 red. intros.
  etransitivity. eapply H. etransitivity; eauto.
Qed.

Definition oequiv {T : otype} (a b : T) : Prop :=
  ole a b /\ ole b a.

Global Instance Reflexive_oequiv {T} : Reflexive (@oequiv T).
Proof. red. intros. red. destruct T0. split; eapply Refl_le. Qed.
Global Instance Symmetric_oequiv {A} : Symmetric (@oequiv A).
Proof. red. unfold oequiv. tauto. Qed.
Global Instance Transitive_oequiv {T} : Transitive (@oequiv T).
Proof. do 2 red. intros.
       destruct T0. destruct H; destruct H0; split; etransitivity; eauto.
Qed.

Instance Proper_oequiv_iff {A : otype}
: Morphisms.Proper (oequiv ==> oequiv ==> iff) (@oequiv A).
Proof.
  red. red. red. intros.
  split; intros.
  etransitivity. symmetry; eauto. etransitivity; eauto.
  etransitivity. eauto. etransitivity; eauto. symmetry; eauto.
Qed.

Instance Proper_ole_oequiv_iff {A : otype}
: Morphisms.Proper (oequiv ==> oequiv ==> iff) (@ole A).
Proof.
  red. red. red. intros.
  split; intros.
  etransitivity. eapply H. etransitivity; eauto. eapply H0.
  etransitivity. eapply H. etransitivity; eauto. eapply H0.
Qed.

(* The discrete ordering *)
Definition otype_eq (T : Type) : otype :=
{| T := T
 ; order := {| le := @eq T |}
 |}.

(** * Ordered Products **)
Definition Order_prod (A B : Type) `{OA : Order A} `{OB : Order B}
: Order (A * B).
refine
{| le := fun a b => @le _ OA (fst a) (fst b) /\ @le _ OB(snd a) (snd b) |}.
{ split; apply Refl_le. }
{ red. destruct 1; destruct 1; split; eapply Trans_le; eassumption. }
Defined.

Canonical Structure otype_prod (a b : otype) : otype :=
{| T := a.(T) * b.(T)
; order := @Order_prod a.(T) b.(T) a.(order) b.(order) |}.

(** * Ordered Unit **)
Definition Order_unit : Order unit.
refine
  {| le := fun _ _ => True |}.
compute; auto.
compute; auto.
Defined.

Canonical Structure otype_unit : otype :=
{| T := unit ; order := @Order_unit |}.

(** * Ordered Functions **)
Record PFun (A B : otype) : Type :=
{ function : A -> B
; Proper_function : Proper (ole ==> ole) function }.

Local Definition Order_fun (A B : otype)
: Order (PFun A B).
refine
{| le := fun a b => (ole ==> ole)%signature (function a) (function b) |}.
{ red. red. intros. destruct x. simpl. apply Proper_function0. assumption. }
{ red. red. intros.
  eapply Trans_le.
  eapply H. eassumption.
  eapply H0. eapply Refl_le. }
Defined.

Definition otype_fun (a b : otype) : otype :=
{| T := PFun a b
; order := @Order_fun a b |}.

Definition otype_apply {a b : otype} (f : otype_fun a b) (x : a) : b :=
  f.(function) x.

Global Instance Proper_otype_apply_ole {a b : otype}
: Proper (ole ==> ole ==> ole) (@otype_apply a b).
Proof.
  red. red. red. intros.
  red in H. unfold le in H. unfold order in H. simpl in H.
  eapply H. assumption.
Defined.

Global Instance Proper_otype_apply_oequiv {A B}
: Morphisms.Proper (oequiv ==> oequiv ==> oequiv) (@otype_apply A B).
Proof.
  do 3 red. intros.
  unfold otype_apply.
  destruct H.
  split.
  eapply H; eapply H0.
  eapply H1; eapply H0.
Qed.

Lemma otype_ext_eq : forall {A B : otype} (f g : otype_fun A  B),
    (forall x, oequiv (otype_apply f x) (otype_apply g x)) ->
    oequiv f g.
Proof.
  intros.
  destruct f; destruct g; simpl in *.
  split.
  { red. simpl. red. intros.
    etransitivity.
    eapply Proper_function0. eassumption.
    eapply H. }
  { red. simpl. red. intros.
    etransitivity.
    eapply Proper_function1. eassumption.
    eapply H. }
Qed.

Definition otype_abs {a b : otype} (f : a -> b) (pf : Proper (@le _ a.(order) ==> @le _ b.(order)) f) : otype_fun a b.
  exists f. assumption.
Defined.
Arguments otype_abs {_ _} _ {_} : clear implicits.

(** * A Shallow Encoding using Eddy's 'ProperInCtx' phrasing **)
(**************************************************************)
Require Import Coq.Lists.List.
Fixpoint otype_tuple (ls : list otype) : otype :=
  match ls with
  | nil => otype_unit
  | l :: ls => otype_prod l (otype_tuple ls)
  end.

Definition InCtx (ls : list otype) (t : otype) : otype :=
  otype_fun (otype_tuple ls) t.

Definition App_ctx {ls a b} (f : InCtx ls (otype_fun a b)) (x : InCtx ls a)
: InCtx ls b.
eapply otype_abs.
instantiate (1 := fun ctx =>
                    otype_apply (otype_apply f ctx)
                                (otype_apply x ctx)).
red. red. intros.
repeat simple eapply Proper_otype_apply_ole; try eassumption; reflexivity.
Defined.

Definition Lift_ctx {ls} {a : otype} (x : a) : InCtx ls a.
eapply otype_abs.
instantiate (1 := fun _ => x). red. red. intros. eapply Refl_le.
Defined.

Definition ToCtx {a} (x : InCtx nil a) : a := x.(function) tt.

Definition Abs_ctx {ls a b} (x : InCtx (a :: ls) b) : InCtx ls (otype_fun a b).
eapply otype_abs.
instantiate (1:=fun ctx => otype_abs _).
Unshelve.
Focus 2.
intro. eapply x. constructor. apply X. apply ctx.
Focus 2.
abstract (simpl; do 2 red; intros; destruct x; simpl; eapply Proper_function0; constructor;
          [ eassumption | eapply Refl_le ]).
abstract (do 2 red; unfold le; simpl; do 2 red; intros; simpl; destruct x; apply Proper_function0; constructor; auto).
Defined.

Definition tuple_hd {x xs} : otype_fun (otype_tuple (x :: xs)) x.
exists (@fst _ _).
abstract (do 2 red; fold otype_tuple; intros; red in H; unfold le in H; simpl in H; tauto).
Defined.

Definition tuple_tl {x xs} : otype_fun (otype_tuple (x :: xs)) (otype_tuple xs).
exists (@snd _ _).
abstract (do 2 red; fold otype_tuple; intros; red in H; unfold le in H; simpl in H; tauto).
Defined.

Definition otype_compose {a b c} : otype_fun a b -> otype_fun b c -> otype_fun a c.
intros.
red. simpl.
exists (fun x => function X0 (function X x)).
abstract (do 2 red; intros; eapply (Proper_function X0); eapply (Proper_function X); eassumption).
Defined.

Fixpoint Var_ctx {a} (n : nat) {ls} {struct n}
: nth_error ls n = Some a -> InCtx ls a :=
  match ls as ls , n as n
        return nth_error ls n = Some a -> InCtx ls a
  with
  | l :: _ , 0 => fun pf : Some l = Some a =>
                    match pf in _ = X return match X with
                                             | Some y => _
                                             | _ => unit
                                             end
                    with
                    | eq_refl => tuple_hd
                    end
  | _ :: ls , S n => fun pf : nth_error ls n = Some a =>
    otype_compose tuple_tl(@Var_ctx _ _ _ pf)
  | nil , 0
  | nil , S _ => fun x : None = Some a => match x with eq_refl => tt end
  end.

(** * Instances **)
Global Instance Proper_App_ctx G A B
: Morphisms.Proper (oequiv ==> oequiv ==> oequiv) (@App_ctx G A B).
Proof.
  red. red. red. simpl. intros.
  unfold App_ctx. simpl. split; red; simpl; red; intros.
  { eapply H; eauto.
    eapply H0; eauto. }
  { eapply H; eauto.
    eapply H0; eauto. }
Qed.

Global Instance Proper_Abs_ctx G B A
: Morphisms.Proper (oequiv ==> oequiv) (@Abs_ctx G A B).
Proof.
  unfold Abs_ctx. red. red. simpl. intros.
  simpl. apply otype_ext_eq; intros.
  simpl. unfold otype_abs. split; red; simpl; red; intros; eapply H; eauto.
  constructor; simpl; eauto. reflexivity.
  constructor; simpl; eauto. reflexivity.
Qed.

Global Instance Proper_Lift_ctx A G
: Morphisms.Proper (oequiv ==> oequiv) (@Lift_ctx A G).
Proof.
  do 2 red. simpl. unfold Lift_ctx. intros.
  eapply otype_ext_eq.
  intros. assumption.
Qed.


(**
整数除算と剰余演算について - ユーグリッド除法 Euclidean division を中心に
========================

@suharahiromichi

2020/08/25
 *)

(**
# はじめに

## 形式化

小学校で習う整数の剰余付き除算は、次に示す式(1.1)から(1.3)を満たす
整数 m, d, q, r に対して、与えられた m, d から q, r を求めること、と形式化できます。

```math
\begin{eqnarray}
d &\ne& 0               \tag{1.1} \\

m &=& q d + r           \tag{1.2} \\

| r | &\lt& | d |       \tag{1.3} \\
\end{eqnarray}

```

ここで、m を被除数、d を除数、q を商、r を剰余または余り、と呼びます。

## 一意性の問題

しかし、式(1.3)から分かるとおり、この定式化では d, rは一意に決まりません。

具体的にいうと、$ 10 \div 3 $ の結果が 3 余り 1 でも、4 余り -2 であっても
式を満たすからです。
このことが、プログラミング言語の C と Python と Pascal とで、
剰余計算の結果が異なることの理由です。

一意性を担保するには、剰余の範囲をより狭く制限する必要があります。
たとえば、教科書に記載されるのは、

$$ 0 \le r \lt | d | \tag{1.3'} $$

のように、剰余を正の範囲に制限することで、これをユーグリッド除法と呼びます。
これは、プログラミング言語Pascalの ``mod`` 演算で採用されています。
また Coq/MathComp の ``divz`` もこの定義です。

## 商と剰余の求める方法

一方、商 q を求めるには、いくつかの方法があります。

- ``m / d`` を実数で求め、切り捨てまたは切り上げして、qとする。
- ``|m| / |d|`` と絶対値で求め、切り捨てまたは切り上げ(注1)して、
符号を復元して(注2)、qとする。

(注1) 自然数の除算における切り捨てと切り上げは後で定義します。

(注2) m と d と q の負号は、偶数個の関係にあります。

剰余 r は式(1.2)から求めます。

このほか 減算を繰り返す方法もありますが、自然数の除算自体は減算で定義されるものとして、
それに含めることにします。

## ユーグリッド除法

ここでは、剰余が式(1.3')を満たすものとし、ユーグリッド除法、すなわち、
計算式としては、絶対値の除算を使う方法を採用します。そして、

- 式(1.3')の制限を加えると、qとrが一意に決まることを証明する。

- q と r を求める式を具体的に定義して、式(1.2)と式(1.3')が成り立つことを証明する。

これによって、整数除算が持つ意味の健全性を示すことができるはずです。
証明には Coq/MathComp を使います。
MathCompにも``intdiv.v``で整数除算が定義されていますが、ここでは独自に実装してみます。

最後に、ここで示した以外の整除法について言及します。

このファイルは、以下にあります。

https://github.com/suharahiromichi/coq/blob/master/math/ssr_ediv.v

証明スクリプトは模範回答ではなく、一例として参考程度にしてください。
 *)
From mathcomp Require Import all_ssreflect.
From mathcomp Require Import all_algebra.

Require Import ssromega.                    (* ssromega タクティク *)

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

Import GRing.Theory.         (* mulrA などを使えるようにする。 *)
Import Num.Theory.           (* unitf_gt0 などを使えるようにする。 *)
Import intZmod.              (* addz など *)
Import intRing.              (* mulz など *)
Open Scope ring_scope.       (* 環の四則演算を使えるようにする。 *)

(**
# 整数について

## 概説

int は、natとちがって、MathCompの型クラス階層の中で、zmodType、ringType、comRingType
のインスタンスとして定義されています。int_ZmodType、int_Ring、int_ComRing。

そのため、以下に注意が必要です。

- 四則演算や剰余算については、当然定義がことなり、文脈（スコープ）によって選ばれます。

- 加算、負号、乗算は環などの演算のインスタンスですから、環についての補題が使えます。

- 減算は ``x - y = x + (- y)`` のように、加算の構文糖衣なので、加算についての補題が使えます。

さらにに注意するべきなのは絶対値記号です。``ssrint.v``で定義される絶対値記号は、
``absz : int -> nat`` の型で nat_scope で定義されています。
そのため、整数の文脈では `` `|n|%N `` と記載する必要があります。

一方、整数の文脈のディフォルト `` `|x|%Z `` は、環で定義された ``normr T:R : T -> T`` に
整数を適用した ``normr : int -> int`` です。

本資料では、絶対値は absz の方を使うことにして、`` `|n|%N `` のように ``%N``を必ず付ける
ことにします。
 *)
(**
### m n : nat のときの m = n とはどういう意味か

等号 ``=`` は、自然数の文脈では ``eq nat``、整数の文脈では ``eq int`` です。
m と n が自然数なので、整数文脈では、自然数から正整数へのコアーションが行われます。
つまり Posz (``%:Z`` とおなじ) が埋め込まれるわけです。
 *)
Section INTRO.
  Variables m n : nat.

  (* 自然数文脈 *)
  Check @eq nat m n.
  Check (m = n)%N.

  (* 整数文脈、つぎの四者は同じ式の構文糖衣 *)
  Check @eq int (Posz m) (Posz n).
  Check Posz m = Posz n.
  Check m%:Z = n%:Z.
  Check m = n :> int.

(**
自然数文脈で等しければ整数文脈でも等しいので、両者は同値です（eqz_nat 補題）。
*)
  Check eqz_nat m n : (m == n :> int) = (m == n)%N.

(**
自然数型の式を整数型の式に書き換えることはできませんが（型が違うので）、
この補題を使って、
自然数の文脈の等式を整数の文脈の等式に書き換えるとは可能です。
等式はどちらもbool型だからです。
 *)
End INTRO.

(**
### 整数演算と自然数演算の変換（``%:Z``の分配則）

整数の文脈の中で自然数を書くと、自然数から正整数のコアーションが起きます。
（Posz あるいは ``%:Z`` が補われます）。

%Nで自然数のスコープを明示できますが、この外に出た時点で、
同様にコアーションで正整数になります。
また、自然数でも正整数でも演算の結果は同じですから、``%:Z`` は分配できるわけです。

ただし、addやsubやleやltやdivやmodの演算は、定義そのものは、
整数と自然数でまったく別であることに注意してください。
 *)

Section INT.
  Variables m n d : nat.

  (* 左辺は自然数の加算、右辺は整数の加算であり、ディフォルトの環（整数）で比較している。 *)
  Check PoszD m n : (m + n)%N%:Z = m%:Z + n%:Z. (* m + n = (m + n)%N と見える。 *)
  Check PoszM m n : (m * n)%N%:Z = m%:Z * n%:Z. (* (m * n)%N = m * n *)

  Check subzn : forall m n : nat, (n <= m)%N -> m%:Z - n%:Z = (m - n)%N%:Z.
  Check divz_nat n d : (n %/ d)%Z = (n %/ d)%N%:Z.
  Check modz_nat m d : (m %% d)%Z = (m %% d)%N%:Z.
  Check lez_nat m n : (m%:Z <= n%:Z) = (m <= n)%N. (* 両辺はbool *)
  Check ltz_nat m n : (m%:Z < n%:Z) = (m < n)%N.   (* 両辺はbool *)

  Variables x y : int.
  Check oppz_add x y : - (x + y) = -x + -y.
End INT.

(**
## 補題

MathCompで整数に扱いになれていないひとのために（大抵のひとはそうでしょう）
再利用性のありそうなスクリプトを補題としてまとめておきます。
*)

(**
### ありがちな補題
 *)

(* 符号を移項するだけの補題 *)
Lemma opptr (x y : int) : x = - y -> - x = y.
Proof.
  move=> ->.
    by rewrite opprK.
Qed.

(* 絶対値を付けるだけの補題 *)
Lemma eq_eqabsabs (x y : int) : x = y -> `|x|%N = `|y|%N.
Proof. by move=> ->. Qed.

(* いつも欲しくなる補題の整数版 *)
Lemma lt_le (x y : int) : x < y -> x <= y.
Proof.
  move=> H.
  rewrite ler_eqVlt.
    by apply/orP/or_intror.
Qed.

Lemma nge_lt (m n : int) : (m <= n) = false -> n < m.
Proof.
  move/negbT.
    by rewrite -ltrNge.
Qed.

Lemma eq_subn (n : nat) : (n - n = 0)%N.    (* 自然数の補題 *)
Proof. apply/eqP. by rewrite subn_eq0. Qed.

Lemma eq_subz (x : int) : x - x = 0.        (* 整数の補題 *)
Proof. by rewrite addrC addNr. Qed.

(**
自然数の除算について、商と被除数の積と剰余の和が除数になる補題が証明されています。
*)
Check divn_eq : forall m d : nat, m = (m %/ d * d + m %% d)%N.
(**
同じ補題を整数スコープで証明しておくと便利です。
*)
Lemma divn_eq' (m d : nat) : m = (m %/ d * d)%N%:Z + (m %% d)%N%:Z :> int.
Proof.
  apply/eqP.
    by rewrite eqz_nat -divn_eq.
Qed.

(**
### 絶対値を操作する補題
 *)
Section ABS.
  Variable m : nat.
  Variable x : int.
(**
自然数の文脈と整数の文脈とで関数が異なるので、注意が必要です。
 *)
  Check absz : int -> nat.                  (* |x|%N *)
  Check Num.Def.normr : int -> int.         (* |x|%Z *)
(**
normr は、環一般について定義されています。
 *)

(**
両者の結果は、自然数から正整数へのコアーションで等しい。
*)
  Check abszE x : `|x|%N%:Z = `|x|%:Z.      (* `|x|%N = `|x| *)

(**
- absz
*)
  (* 自然数 *)
  Check absz_nat m : `| m%:Z |%N = m.       (* `|m|%N = m *)
  (* 正整数 *)
  Check gez0_abs : forall x : int, 0 <= x -> `|x|%N = x :> int. (* `|x|%N = x *)
  Check gtz0_abs : forall x : int, 0 < x -> `|x|%N = x :> int.
  (* 負整数 *)
  Check lez0_abs : forall x : int, x <= 0 -> `|x|%N = - x :> int.
  Check ltz0_abs : forall x : int, x < 0 -> `|x|%N = - x :> int.
End ABS.

Lemma abseq0_eq (x y : int) : (`|x - y| = 0)%N  <-> x = y.
Proof.
  split=> H.
  Check absz_eq0 : forall m : int, (`|m|%N == 0%N) = (m == 0).
  Check subr_eq0 : forall (V : zmodType) (x y : V), (x - y == 0) = (x == y).
  - move/eqP in H.
    rewrite absz_eq0 subr_eq0 in H.
      by apply/eqP.
  - apply/eqP.
    rewrite absz_eq0 subr_eq0.
      by apply/eqP.
Qed.

Section NORM.
  Variable x : int.
(**
- norm

実際の証明では、norm は使わないようにしたので、以下は不使用である。
*)
  (* 自然数 *)
  Lemma norm_nat (n : nat) : `| n%:Z | = n%:Z. (* `|n| = n *)
  Proof. by rewrite -abszE absz_nat. Qed.
  (* 正整数 *)
  Check @ger0_norm int_numDomainType x : 0 <= x -> `|x| = x :> int. (* `|x| = x *)
  Check @gtr0_norm int_numDomainType x : 0 < x -> `|x| = x :> int.
  (* 負整数 *)
  Check @ler0_norm int_numDomainType x : x <= 0 -> `|x| = - x :> int.
  Check @ltr0_norm int_numDomainType x : x < 0 -> `|x| = - x :> int.
End NORM.

Lemma normq0_eq (x y : int) : `|x - y| = 0  <-> x = y.
Proof.
  split=> H.
  Check @normr0P : forall (R : numDomainType) (x : R), reflect (`|x| = 0) (x == 0).
  - move/normr0P in H.
    rewrite subr_eq0 in H.
      by apply/eqP.
  - apply/normr0P.
    rewrite subr_eq0.
      by apply/eqP.
Qed.

(**
# ユーグリッド除法の定義
*)
(**
## 準備

### 自然数の除算

最初に、自然数の除算を定義します。

切り捨て(floor)除算と、切り上げ(ceil)除算の二種類です。

切り捨て除算は、自然数で定義された除算 (divn) とおなじです。

```math
\lfloor m / d \rfloor = divn(m, d)

```

切り上げ除算は、divn の結果に``+1``します。ただし、mがdで割り切れる場合はそのまま、
mがdで割りきれない場合は``+1``します。
$ d \setminus m $ は、 m は dで割りきれることを示し、
$ d \not \setminus m $ は、m は dで割りきれないことを示します。
``除数 \ 被除数`` の順番であることに注意してください。

```math
\lceil m / d \rceil =
\left\{
\begin{array}{ll}
divn(m, d) & (但し d \setminus m) \\
divn(m, d) + 1 & (但し d \not \setminus m)
\end{array}
\right.
```

 *)
Definition edivn_floor (m d : nat) : nat := (m %/ d)%N.

Definition edivn_ceil (m d : nat) : nat :=
  if (d %| m)%N then (m %/ d)%N else ((m %/ d).+1)%N.

(**
検算してみます。
*)
Compute edivn_floor  9 3.                   (* 3 *)
Compute edivn_floor 10 3.                   (* 3 *)
Compute edivn_ceil  9 3.                    (* 3 *)
Compute edivn_ceil 10 3.                    (* 4 *)

(**
### 自然数の除算の補題

自然数の除算の結果（商）に除数を掛けると、

- 切り捨て除算の場合は被除数以下
- 切り上げ除算の場合は被除数以上

になります。
切り上げにおいて、等号が成立するのはmがdで割り切れる場合で、
そうでない場合は被除数未満となります。このふたつの条件をあわせて補題にしています。

```math
\lfloor m / d \rfloor d \le m \\
\lceil m / d \rceil d \ge m
```

これを補題として証明しておきます。
*)
Lemma edivn_floorp (m d : nat) : (edivn_floor m d * d <= m)%N.
Proof.
  rewrite /edivn_floor.
    by apply: leq_trunc_div.
Qed.

Lemma edivn_ceilp (m d : nat) : (0 < d)%N -> (m <= edivn_ceil m d * d)%N.
Proof.
  move=> Hd.
  rewrite /edivn_ceil.
  rewrite leq_eqVlt eq_sym.
  case: ifP => Hmd.
  (* m が d で、割りきれる場合 *)
  - apply/orP/or_introl.
      by rewrite -dvdn_eq.
  (* m が d で、割りきれない場合 *)
  - apply/orP/or_intror.
      by rewrite ltn_ceil //.
Qed.

(**
ついで、商と除数の積と被除数の差が、除数未満であることを証明します。

```math
m - \lfloor m / d \rfloor d \lt d \\
\lceil m / d \rceil d - m   \lt d
```
*)
Lemma edivn_floor_ltd (m d : nat) : (0 < d)%N ->
                                    m%:Z - (edivn_floor m d * d)%:Z < d.
Proof.
  move=> Hd.
  rewrite /edivn_floor.
  rewrite {1}(divn_eq' m d).
  rewrite -addrAC eq_subz add0r.
  Check ltn_pmod : forall m d : nat, (0 < d)%N -> (m %% d < d)%N.
    by apply: ltn_pmod.
Qed.

Lemma edivn_ceil_ltd (m d : nat) : (0 < d)%N ->
                                   (edivn_ceil m d)%:Z * d - m%:Z < d.
Proof.
  move=> Hd.
  rewrite /edivn_ceil.
  rewrite {1}(divn_eq' m d).
  case: ifP => H.
  (* m が d で、割り切れるので m %% d = 0 の場合 *)
  - move/eqP in H.
    rewrite H /= addr0.
      by rewrite eq_subz.
  (* m が d で、割りきれない場合 *)
  - rewrite opprD addrCA addrA -addn1.
    have l_dist (m' : nat) : (m' + 1)%N%:Z * d = (m' * d)%N%:Z + d
      by apply/eqP; rewrite eqz_nat mulnDl mul1n.
    rewrite l_dist //= addrA [- _ + _]addrC.
    rewrite eq_subz add0r ltr_subl_addl ltr_addr.
    rewrite ltz_nat lt0n.
    (* Goal : (m %% d)%N != 0 *)
    rewrite /dvdn in H.
      by move/negbT in H.
Qed.

(**
## ユーグリッド除算の定義

直感的に説明するのが難しいので、数直線でも書いて納得してほしいのですが、
整数のユーグリッド除算を絶対値の除算で求める場合、
商は次のように求めると、剰余を正とすることができます。

- 被除数が正なら絶対値の除算で切り捨てしたあと除数の符号を反映します。
- 被除数が負なら絶対値の除算で切り上げしたあと除数の符号を反映し、さらに符号を反転します。

```math
m / d =
\left\{
\begin{array}{ll}
(sgz\ d) \lfloor |m| / |d| \rfloor & (m \ge 0) \\
- (sgz\ d) \lceil |m| / |d| \rceil & (m \lt 0) \\
\end{array}
\right.
```

ここで、sgz は符号関数です。

剰余は、被除数から商と除数の積を引いて求めます。これは整数で計算します。

```math
m\ mod\ d = m - (m / d) d
```
 *)
Definition edivz (m d : int) : int :=
  if (0 <= m) then
    sgz d * (edivn_floor `|m|%N `|d|%N)
  else
    - (sgz d * (edivn_ceil `|m|%N `|d|%N)).

Definition emodz (m d : int) : int := m - (edivz m d) * d.

(**
検算してみます。あっているようですね。
*)
Compute edivz 10 3.                         (* 3 *)
Compute edivz 10 (- 3%:Z).                  (* -3 *)
Compute edivz (- 10%:Z) 3.                  (* -4 *)
Compute edivz (- 10%:Z) (- 3%:Z).           (* 4 *)

Compute emodz 10 3.                         (* 1 *)
Compute emodz 10 (- 3%:Z).                  (* 1 *)
Compute emodz (- 10%:Z) 3.                  (* 2 *)
Compute emodz (- 10%:Z) (- 3%:Z).           (* 2 *)

(**
定義から自明ですが、式(1.2)も成り立っています。
*)
Lemma edivz_eq (m d : int) : m = (edivz m d)%Z * d + (emodz m d)%Z.
Proof.
    by rewrite addrC subrK.
Qed.

(**
# 式(1.3')の証明

先に、比較的やさしいほうの証明をします。証明するべきは以下です。

```math
0 \le m\ mod\ d \lt | d |
```
*)

(**
## 定理 - 剰余は正
 *)
(**
証明はmの正負、すなわち、自然数の除算の切り捨てか切り上げで場合分けしたのち、
自然数の除算の補題を適用するだけの単純なものです。
*)
Lemma ediv_mod_ge0 (m d : int) : d != 0 -> 0 <= emodz m d.
Proof.
  move=> Hd.
  rewrite /emodz /edivz.
  case: ifP => H.
  (* 0 <= m の場合 *)
  - rewrite -mulrAC -abszEsg mulrC subr_ge0.
    move/gez0_abs in H.
    rewrite -{2}H.
      (* edivn_floor `|m| `|d| * `|d|%N <= `|m| *)
      by apply: edivn_floorp.

  (* 0 > m の場合 *)
  (* よく見るとわかりますが、右辺の負号は括弧だけに掛かっているので、
     右から掛けるdを中に入れます。 *)
    Check m - (- (sgz d * edivn_ceil `|m| `|d|)) * d.
    Check mulNr : forall (R : ringType) (x y : R), - x * y = - (x * y).
  - rewrite mulNr.
    (* m - - X は m + (- - X) なので、二重の負号 oppz を消します。 *)
    rewrite [- - _]oppzK -mulrAC -abszEsg mulrC.
    move/nge_lt in H.
    Check opptr (ltz0_abs H) : - `|m|%N%:Z = m.
    rewrite -{1}(opptr (ltz0_abs H)).
    rewrite addrC subr_ge0.
    (* `|m| <= edivn_ceil `|m| `|d| * `|d|%N *)
    apply: edivn_ceilp.
      (* (0 < `|d|)%N *)
      by rewrite lt0n absz_eq0.
Qed.

(**
## 定理 - 剰余は除数より小
 *)
Lemma ediv_mod_ltd (m d : int) : d != 0 -> emodz m d < `|d|%N.
Proof.
  move=> Hd.
  rewrite /emodz /edivz.
  case: ifP => Hm; case H : (0 <= d).
  (* m が、0 <= m か 0 > m か、
     d が、0 <= d か 0 > d か、で場合分けする。 *)

  (* Goal : m - sgz d * edivn_floor `|m| `|d| * d < `|d| *)
  - rewrite mulrAC -abszEsg mulrC.          (* 商*除数の部分 *)
    rewrite -{1}(gez0_abs Hm).              (* 被除数の部分 *)
    apply: edivn_floor_ltd.                 (* 自然数割算の補題 *)
      by rewrite -absz_gt0 in Hd.

  (* Goal : m - sgz d * edivn_floor `|m| `|d| * d < `|d| *)
  - rewrite mulrAC -abszEsg mulrC.
    rewrite -{1}(gez0_abs Hm).
    apply: edivn_floor_ltd.
      by rewrite -absz_gt0 in Hd.
      (* by rewrite -normr_gt0 in Hd. *)

  (* Goal : m - - (sgz d * edivn_ceil `|m| `|d|) * d < `|d| *)
  - rewrite mulNr mulrAC -abszEsg mulrC opprK.
    move/nge_lt in Hm.
    rewrite -{1}(opptr (ltz0_abs Hm)) addrC.
    apply: edivn_ceil_ltd.
      by rewrite -absz_gt0 in Hd.

  (* Goal : m - - (sgz d * edivn_ceil `|m| `|d|) * d < `|d| *)
  - rewrite mulNr mulrAC -abszEsg mulrC opprK.
    move/nge_lt in Hm.
    rewrite -{1}(opptr (ltz0_abs Hm)) addrC.
    apply: edivn_ceil_ltd.
      by rewrite -absz_gt0 in Hd.
Qed.

(**
まとめると、式(1.3')が成り立つことが証明できます。
*)
Lemma ediv_mod_ge0_ltd (m d : int) : d != 0 -> 0 <= emodz m d < `|d|%N.
Proof.
  move=> hd.
  apply/andP; split.
  - by apply: ediv_mod_ge0.
  - by apply: ediv_mod_ltd.
Qed.

(**
# 一意性の証明

式(1.2)と式(1.3)を満たす商qと剰余rがふたつあったとして、それが等しいことを証明します。
すなわち、

```math
\left\{
\begin{array}{ll}
m = q_{1} d + r_{1} \\
m = q_{2} d + r_{2} \\
\end{array}
\right.
```

のとき、

```math
\left\{
\begin{array}{ll}
q_{1} = q_{2} \\
r_{1} = r_{2} \\
\end{array}
\right.
```

であることを証明します。先に $ q_{1} = q_{2} $ を証明し、
ついで、$ r_{1} = r_{2} $ を証明します。
*)

(**
補題： 自然数 q と d の積が d より小さいなら、q は0である。

実数なら q は 1未満となるわけですが、自然数なので q は0になります。
*)
Lemma lemma1 (q d : nat) : (q * d < d)%N -> (q = 0)%N.
Proof.
  rewrite -{2}[d]mul1n.
  Check ltn_mul2r
    : forall m n1 n2 : nat, (n1 * m < n2 * m)%N = (0 < m)%N && (n1 < n2)%N.
  rewrite ltn_mul2r.
  move/andP => [Hd Hq].
    by ssromega.
Qed.

(**
補題：``q1 * d + r1 = q2 * d + r2`` のとき、移項して絶対値で``=``をとる。
*)
Lemma lemma3 (q1 q2 r1 r2 d : int) :
  q1 * d + r1 = q2 * d + r2 -> `|((q1 - q2) * d)%R|%N = `|r1 - r2|%N.
Proof.
  (* 前提 *)
  move/eqP.
  Check subr_eq : forall (V : zmodType) (x y z : V), (x - z == y) = (x == y + z).
  rewrite -subr_eq -addrA addrC eq_sym -subr_eq -mulrBl -[(q2 - q1)]opprB.
  (* Goal : - (q1 - q2) * d = r1 - r2 *)

  move/eqP/eq_eqabsabs.           (* 前提の両辺に絶対値記号をつける。 *)
  rewrite mulNr abszN.            (* 前提左辺の絶対値の負号を消す。 *)
  done.
Qed.

(**
補題：
*)
Lemma lemma2 (r1 r2 : int) (d : nat) :
  0 <= r1 < d -> 0 <= r2 < d -> `|r1 - r2|%N < d :> int.
Proof.
  move=> Hr1 Hr2.
  move/andP : Hr1 => [Hr1 Hr1d].
  move/andP : Hr2 => [Hr2 Hr2d].

  move: (ltr_paddr Hr1 Hr1d) => Hr1dr1.     (* Hr1dr1 : r1 < d + r1 *)
  move: (ltr_paddr Hr2 Hr1d) => Hr1dr2.     (* Hr1dr2 : r1 < d + r2 *)
  move: (ltr_paddr Hr1 Hr2d) => Hr2dr1.     (* Hr2dr1 : r2 < d + r1 *)
  move: (ltr_paddr Hr2 Hr2d) => Hr2dr2.     (* Hr2dr2 : r2 < d + r2 *)

  (* r1 と r2 は0以上なので、絶対値記号をつけます。 *)
  Check gez0_abs Hr1 : `|r1|%N%:Z = r1.
  rewrite -(gez0_abs Hr1) in Hr1d.         (* `|r1|%N < d *)
  rewrite -(gez0_abs Hr2) in Hr2d.         (* `|r2|%N < d *)
  rewrite -(gez0_abs Hr1) in Hr1dr1.       (* `|r1|%N < d + `|r1|%N *)
  rewrite -(gez0_abs Hr1) -(gez0_abs Hr2) in Hr1dr2. (* `|r1|%N < d + `|r2|%N *)
  rewrite -(gez0_abs Hr1) -(gez0_abs Hr2) in Hr2dr1. (* `|r2|%N < d + `|r1|%N *)
  rewrite -(gez0_abs Hr2) in Hr2dr2.       (* `|r2|%N < d + `|r2|%N *)

  case H : (r1 - r2 >= 0).
  (* r2 <= r1 の場合 *)
  - move: {+}H => H'.                       (* 複製する。 *)
    rewrite -(gez0_abs Hr1) -(gez0_abs Hr2) in H'.
    (* H' : (0 <= `|r1|%N - `|r2|%N) = true *)

    move/gez0_abs in H.
    rewrite H -(gez0_abs Hr1) -(gez0_abs Hr2).
    (* H : `|r1 - r2|%N = r1 - r2 *)

    have H2 := @ltn_sub2r `|r2| `|r1| (d + `|r2|) Hr2dr2 Hr1dr2.
    rewrite -addnBA in H2 ; last done.
    rewrite (eq_subn `|r2|) in H2.
    rewrite addn0 in H2.
    (* H2 : (`|r1| - `|r2| < d)%N *)

    rewrite -ltz_nat -subzn // in H2.
      (* Goal : (`|r2| <= `|r1|)%N *)
      by rewrite -lez_nat -subr_ge0.

  (* r1 < r2 の場合 *)
  - move: {+}H => H'.
    rewrite -(gez0_abs Hr1) -(gez0_abs Hr2) in H'.
    (* H' : (0 <= `|r1|%N - `|r2|%N) = false *)

    move/negbT in H.
    rewrite -ltrNge in H.
    move/lt_le/lez0_abs in H.
    rewrite H opprB -(gez0_abs Hr1) -(gez0_abs Hr2).
    (* H : `|r1 - r2|%N = - (r1 - r2) *)

    have H1 := @ltn_sub2r `|r1| `|r2| (d + `|r1|) Hr1dr1 Hr2dr1.
    rewrite -addnBA in H1 ; last done.
    rewrite (eq_subn `|r1|) in H1.
    rewrite addn0 in H1.
    (* H1 : (`|r2| - `|r1| < d)%N *)

    rewrite -ltz_nat -subzn // in H1.
    (* Goal : (`|r1| <= `|r2|)%N *)
    move/nge_lt in H'.
    rewrite subr_lt0 in H'.
    rewrite -lez_nat.
      by apply: lt_le.
Qed.

(**
定理：商 q は一意である。
*)
Lemma edivz_uniqness_q (r1 r2 q1 q2 m d : int) :
  0 <= r1 < `|d| ->
                 0 <= r2 < `|d| ->
                                m = q1 * d + r1 ->
                                m = q2 * d + r2 ->
                                q1 = q2.
Proof.
  move=> Hr1 Hr2 Hq1 Hq2.
  rewrite Hq1 in Hq2.
  apply/abseq0_eq.

  Check @lemma1 `|q1 - q2| `|d| : (`|q1 - q2| * `|d| < `|d|)%N -> `|q1 - q2|%N = 0%N.
  apply: (@lemma1 `|q1 - q2| `|d|).

  Check abszM : forall m1 m2 : int, `|(m1 * m2)%R|%N = (`|m1| * `|m2|)%N.
  rewrite -abszM.

  Check @lemma3 q1 q2 r1 r2 d Hq2 : `|((q1 - q2) * d)%R|%N = `|r1 - r2|%N.
  rewrite (@lemma3 q1 q2 r1 r2 d Hq2).

    by apply: lemma2.
Qed.

(**
定理：剰余 r は一意である。
*)
Lemma edivz_uniqness_r (r1 r2 q m d : int) :
  m = q * d + r1 ->
  m = q * d + r2 ->
  r1 = r2.
Proof.
  move=> -> H.
  rewrite [RHS]addrC [LHS]addrC in H.
  move/eqP in H.
  rewrite -subr_eq in H.
  move/eqP in H.
  rewrite -[LHS]addrA eq_subz addr0 in H.
  done.
Qed.

(**
# 整除法の一覧
*)

(**
式(1.3)の絶対値の記号を外すと、つぎの式を得る。

```math
\begin{eqnarray}
0 &\le& r \lt d         \tag{2.1} \\

0 &\le& -r \lt d        \tag{2.2} \\

d &\lt& -r \le 0        \tag{2.3} \\

d &\lt& r \le 0         \tag{2.4} \\

\end{eqnarray}

```

d は与えられるので、それを踏まえて、(2.1)〜(2.4)の式を選ぶことになる。
*)

(**
## 剰余が正（Pascal の ``mod``演算子、ユーグリッド除法）

```math
\begin{eqnarray}
0 \le r \lt d, ただし d \ge 0 \\
d \lt -r \le 0, ただし d \lt 0 \\
\end{eqnarray}

```

このふたつの式は、$|d|$を使ってひとつにまとめられる。これが式(1.3')です。

$$ 0 \le r \lt | d | \tag{1.3'} $$

| m  |  d | q  | r  | 実数除算 | 絶対値除算 | 例    |商  | 余  |
|:--:|:--:|:--:|:--:|:-------:|:----------:|:-----:|:--:|:---:|
| 正 | 正 | 正 | 正 | floor   | floor      |  10÷3  | 3 |  1  |
| 正 | 負 | 負 | 正 | ceil    | floor      | 10÷-3  |-3 |  1  |
| 負 | 正 | 負 | 正 | floor   | ceil       | -10÷3  |-4 |  2  |
| 負 | 負 | 正 | 正 | ceil    | ceil       | -10÷-3 | 4 |  2  |
 *)

(**
## 剰余が被除数と同符号（C の ``%``演算子）

```math
\begin{eqnarray}
0 \le r \lt d, ただし m \ge 0 \\
d \lt -r \le 0, ただし m \lt 0 \\
\end{eqnarray}

```

| m  |  d | q  | r  | 実数除算 | 絶対値除算 | 例    |商  | 余  |
|:--:|:--:|:--:|:--:|:-------:|:----------:|:-----:|:--:|:---:|
| 正 | 正 | 正 | 正 | floor   | floor      |  10÷3  | 3 |  1  |
| 正 | 負 | 負 | 正 | ceil    | floor      | 10÷-3  |-3 |  1  |
| 負 | 正 | 負 | 負 | ceil    | floor      | -10÷3  |-3 | -1  |
| 負 | 負 | 正 | 負 | floor   | floor      | -10÷-3 | 3 | -1  |

実数除算は、0方向への切り捨て(tranc)になる。
 *)

(**
## 剰余が除数と同符号（Python ``%``演算子）

```math
\begin{eqnarray}
0 \le  r \lt d \\
d \lt  r \le 0 \\
\end{eqnarray}

```

| m  |  d | q  | r  | 実数除算 | 絶対値除算 | 例    |商  | 余  |
|:--:|:--:|:--:|:--:|:-------:|:----------:|:-----:|:--:|:---:|
| 正 | 正 | 正 | 正 | floor   | floor      |  10÷3  | 3 |  1  |
| 正 | 負 | 負 | 負 | floor   | ceil       | 10÷-3  |-4 | -2  |
| 負 | 正 | 負 | 正 | floor   | ceil       | -10÷3  |-4 |  2  |
| 負 | 負 | 正 | 負 | floor   | floor      | -10÷-3 | 3 | -1  |
*)

(**
## 剰余が商と同符号

```math
\begin{eqnarray}
0 \le  r \lt d, ただし q \ge 0 \\
d \lt -r \le 0, ただし q \lt 0 \\
\end{eqnarray}

```

| m  |  d | q  | r  | 実数除算 | 絶対値除算 | 例    |商  | 余  |
|:--:|:--:|:--:|:--:|:-------:|:----------:| -----:|:--:|:---:|
| 正 | 正 | 正 | 正 | floor   | floor      |  10÷3  | 3 |  1  |
| 正 | 負 | 負 | 負 | floor   | ceil       | 10÷-3  |-4 | -2  |
| 負 | 正 | 負 | 負 | ceil    | floor      | -10÷3  |-3 | -1  |
| 負 | 負 | 正 | 正 | ceil    | ceil       | -10÷-3 | 4 |  2  |
*)

(**
## 剰余が負（使えない）

これは、式(2.2)と式(2.4)を使う。これをまとめると、次の式になる。
$$ | d | \lt r \le 0 $$

| m  |  d | q  | r  | 実数除算 | 絶対値除算 | 例    |商  | 余  |
|:--:|:--:|:--:|:--:|:-------:|:----------:| -----:|:--:|:---:|
| 正 | 正 | 正 | 負 | ceil    | ceil       |  10÷3  | 4 | -2  |
| 正 | 負 | 負 | 負 | floor   | ceil       | 10÷-3  |-4 | -2  |
| 負 | 正 | 負 | 負 | ceil    | floor      | -10÷3  |-3 | -1  |
| 負 | 負 | 正 | 負 | floor   | floor      | -10÷-3 | 3 | -1  |
*)

(**
## 剰余が絶対値で最小（Cの``remainder``関数）

| m  |  d | q  | r  | 実数除算 |
|:--:|:--:|:--:|:--:|:-------:|
| 正 | 正 | 正 | * | round    |
| 正 | 負 | 負 | * | round    |
| 負 | 正 | 負 | * | round    |
| 負 | 負 | 正 | * | round    |

* 余りは、正または負で、絶対値が最小となる値。
*)

(**
# 使用しなかった補題
 *)
Section OPT.

  (* edivz と emodz についても、整数演算から自然数演算に変換できる。 *)
  Lemma edivz_nat (m d : nat) : edivz m d = (m %/ d)%N.
  Proof.
      by case: d => // d; rewrite /edivz /= mul1r.
  Qed.

  Lemma emodz_nat (m d : nat) : emodz m d = (m %% d)%N.
  Proof.
    rewrite /emodz edivz_nat.
    rewrite {1}(divn_eq' m d).
    rewrite addrAC eq_subz add0r.
    done.
  Qed.

  (* %:Z の分配とみると： *)
  Check edivz_nat : forall (m d : nat), edivz m%:Z d%:Z = (m %/ d)%N%:Z.
  Check emodz_nat : forall (m d : nat), emodz m%:Z d%:Z = (m %% d)%N%:Z.

  (* *** *)
  (* *** *)

  (* intidiv.v の補題 を使って証明する。 *)
  Lemma divn_eq'' (m d : nat) : m = (m %/ d * d)%N%:Z + (m %% d)%N :> int.
  Proof.
    Check divz_eq : forall m d : int, m = (m %/ d)%Z * d + (m %% d)%Z.

    rewrite {1}(divz_eq m d).
    Search _ (_ + _ = _%N + _%N).

    f_equal.
    - by rewrite divz_nat.
    - by rewrite modz_nat.
  Qed.

  (* ssrnum の norm の補題を直接使用することにした。 *)
  (* さらに、`|x|%N に統一して、norm を使わないようにした。 *)
  Lemma eq_abs (x : int) : 0 <= x -> x = `|x|.
  Proof. by move/normr_idP. Qed.

  Lemma ltz_m_abs (x : int) : x < 0 -> x = - `|x|.
  Proof.
    move=> H.
    rewrite ltr0_norm //=.
      by rewrite opprK.
  Qed.

  (* divn_eq の整数版の別証明 *)
  Lemma divn_eq''' (m d : nat) : m = (m %/ d * d)%N%:Z + (m %% d)%N :> int.
  Proof.
    rewrite /divn modn_def.
    case: edivnP => q r //= Heq Hd.
    rewrite Heq.
    (* Goal : (q * d + r)%N = (q * d)%N + r *)
    done.
  Qed.

  (* edivn_ceil_ltd のミニ補題。自然数の文脈にすると簡単である。 *)
  Lemma l_distr (d m : nat) : (m %/ d + 1)%N%:Z * d = (m %/ d * d)%N%:Z + d.
  Proof.
    apply/eqP.
    rewrite eqz_nat.
    rewrite mulnDl.
    rewrite mul1n.
    done.
  Qed.
End OPT.

(**
# 参考文献

参考になりそうな wikipeida の項目を記載します。

- https://ja.wikipedia.org/wiki/除法

- https://ja.wikipedia.org/wiki/剰余演算

- https://en.wikipedia.org/wiki/Euclidean_division
*)

(* END *)


Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export lemma__TGflip.
Require Export lemma__TGsymmetric.
Require Export logic.
Definition lemma__TTflip : forall A B C D E F G H, (euclidean__defs.TT A B C D E F G H) -> (euclidean__defs.TT B A D C E F G H).
Proof.
intro A.
intro B.
intro C.
intro D.
intro E.
intro F.
intro G.
intro H.
intro H0.
assert (exists J, (euclidean__axioms.BetS E F J) /\ ((euclidean__axioms.Cong F J G H) /\ (euclidean__defs.TG A B C D E J))) as H1 by exact H0.
destruct H1 as [J H2].
destruct H2 as [H3 H4].
destruct H4 as [H5 H6].
assert (* Cut *) (euclidean__defs.TG B A C D E J) as H7.
- assert (* Cut *) ((euclidean__defs.TG B A C D E J) /\ (euclidean__defs.TG A B C D J E)) as H7.
-- apply (@lemma__TGflip.lemma__TGflip A C E B D J H6).
-- destruct H7 as [H8 H9].
exact H8.
- assert (* Cut *) (euclidean__defs.TG C D B A E J) as H8.
-- apply (@lemma__TGsymmetric.lemma__TGsymmetric B C E A D J H7).
-- assert (* Cut *) (euclidean__defs.TG D C B A E J) as H9.
--- assert (* Cut *) ((euclidean__defs.TG D C B A E J) /\ (euclidean__defs.TG C D B A J E)) as H9.
---- apply (@lemma__TGflip.lemma__TGflip C B E D A J H8).
---- destruct H9 as [H10 H11].
exact H10.
--- assert (* Cut *) (euclidean__defs.TG B A D C E J) as H10.
---- apply (@lemma__TGsymmetric.lemma__TGsymmetric D B E C A J H9).
---- assert (* Cut *) (euclidean__defs.TT B A D C E F G H) as H11.
----- exists J.
split.
------ exact H3.
------ split.
------- exact H5.
------- exact H10.
----- exact H11.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

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

Inductive lst : Type := Nil : lst |Cons : natural -> lst -> lst .

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Fixpoint qreva (qreva_arg0 : lst) (qreva_arg1 : lst) : lst
           := match qreva_arg0, qreva_arg1 with
              | Nil, x => x
              | Cons z x, y => qreva x (Cons z y)
              end.

Lemma append_assoc : forall (x y z : lst), append (append x y) z = append x (append y z).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : lst), eq (append (rev x) y) (qreva x y).
Proof.
   induction x.
   - reflexivity.
   - intros. simpl. lfind. Admitted.


Require Import List.

Inductive Ty : Set :=
| Bool : Ty
| Stream : Ty
| Nat : Ty
| Arr : Ty -> Ty -> Ty.

Notation "T ==> S" := (Arr T S) (at level 30, right associativity).

Inductive Term : Set :=
| v : nat -> Term
| f : nat -> Term
| succ : Term -> Term
| zero : Term
| natcase : Term -> Term -> Term -> Term
| snil : Term
| scons : Term -> Term -> Term
| streamcase : Term -> Term -> Term -> Term
| true : Term
| false : Term
| boolcase : Term -> Term  -> Term -> Term
| lam : Ty -> Term -> Term
| app : Term -> Term -> Term.

Definition Ctx := list Ty.

Inductive Holds (G : Ctx) (t : Term) (ty : Ty) : Set :=
| holds : Holds G t ty.

Notation "G |= t @ ty" := (Holds G t ty) (at level 40, no associativity).

Check forall G t ty P, P (G |= t @ ty).

Variable Delta : nat -> Term.

CoInductive Deduction : Set -> Set :=
| ImpElim : forall G A B r s,
  Deduction ( G |= r @ A ==> B) -> Deduction ( G |= s @ A ) ->
  Deduction ( G |= app r s @ B )
| ImpIntro : forall G A B r, Deduction ( (A::G) |=  r @ B) ->
  Deduction ( G |= lam A r @ A ==> B )
| BoolIntroTrue : forall G, Deduction ( G |= true @ Bool )
| BoolIntroFalse : forall G, Deduction ( G |= false @ Bool )
| BoolElim : forall G C r s t,
  Deduction ( G |= r @ Bool ) -> Deduction ( G |= s @ C ) -> Deduction ( G |= t @ C  ) ->
  Deduction ( G |= boolcase r s t @ C)
| NatIntroS : forall G r, Deduction ( G |= r @ Nat ) -> Deduction ( G |= succ r @ Nat )
| NatIntroZ : forall G, Deduction ( G |= zero @ Nat )
| NatElim : forall G C r s t,
  Deduction ( G |= r @ Nat ) -> Deduction ( G |= s @ C ) -> Deduction ( (Nat::G) |= t @ C ) ->
  Deduction ( G |= natcase r s t @ C)
| StreamIntroNil : forall G,  Deduction ( G |= snil @ Stream )
| StreamIntroCons : forall G n s, ( G |= n @ Nat ) -> Deduction ( G |= s @ Stream ) -> Deduction ( G |= scons n s @ Stream )
| StreamElim : forall G C r s t,
  Deduction ( G |= r @ Stream ) -> Deduction ( G |= s @ C ) -> Deduction ( (Nat::G) |= t @ C ) ->
  Deduction ( G |= natcase r s t @ C)
| DeltaRule : forall G C r s t, Deduction (G |= s @ C ) -> Deduction (G |= s @ C).


Definition dbselect_spec_gt :=
fun (i j : nat) (eqT gtT ltT : Term) =>
nat_ind (fun j0 : nat => forall i0 : nat, S j0 <= i0 -> dbselect i0 j0 eqT gtT ltT = gtT)
  (fun (i0 : nat) (H : 1 <= i0) =>
   match i0 as n return (1 <= n -> dbselect n 0 eqT gtT ltT = gtT) with
   | 0 =>
       fun H0 : 1 <= 0 =>
       let H1 : 0 = 0 -> eqT = gtT :=
         match H0 in (_ <= n) return (n = 0 -> eqT = gtT) with
         | le_n _ =>
             fun H1 : 1 = 0 =>
             (fun H2 : 1 = 0 =>
              let H3 : False :=
                eq_ind 1 (fun e : nat => match e with
                                         | 0 => False
                                         | S _ => True
                                         end) I 0 H2 in
              False_ind (eqT = gtT) H3) H1
         | le_S _ m H1 =>
             fun H2 : S m = 0 =>
             (fun H3 : S m = 0 =>
              let H4 : False :=
                eq_ind (S m) (fun e : nat => match e with
                                             | 0 => False
                                             | S _ => True
                                             end) I 0 H3 in
              False_ind (1 <= m -> eqT = gtT) H4) H2 H1
         end in
       H1 eq_refl
   | S i1 => fun _ : 1 <= S i1 => eq_refl
   end H)
  (fun (j0 : nat) (IHj : forall i0 : nat, S j0 <= i0 -> dbselect i0 j0 eqT gtT ltT = gtT)
     (i0 : nat) (H : S (S j0) <= i0) =>
   match i0 as n return (S (S j0) <= n -> dbselect n (S j0) eqT gtT ltT = gtT) with
   | 0 =>
       fun H0 : S (S j0) <= 0 =>
       let H1 : 0 = 0 -> ltT = gtT :=
         match H0 in (_ <= n) return (n = 0 -> ltT = gtT) with
         | le_n _ =>
             fun H1 : S (S j0) = 0 =>
             (fun H2 : S (S j0) = 0 =>
              let H3 : False :=
                eq_ind (S (S j0)) (fun e : nat => match e with
                                                  | 0 => False
                                                  | S _ => True
                                                  end) I 0 H2 in
              False_ind (ltT = gtT) H3) H1
         | le_S _ m H1 =>
             fun H2 : S m = 0 =>
             (fun H3 : S m = 0 =>
              let H4 : False :=
                eq_ind (S m) (fun e : nat => match e with
                                             | 0 => False
                                             | S _ => True
                                             end) I 0 H3 in
              False_ind (S (S j0) <= m -> ltT = gtT) H4) H2 H1
         end in
       H1 eq_refl
   | S i1 => fun H0 : S (S j0) <= S i1 => IHj i1 (le_S_n (S j0) i1 H0)
   end H) j i
     : forall (i j : nat) (eqT gtT ltT : Term), i > j -> dbselect i j eqT gtT ltT = gtT.


(****************************************************************************

          IEEE754  :  FroundPlus

          Laurent Thery

  ******************************************************************************)
Require Export Finduct.
Require Export FroundProp.

Section FRoundP.
Variable b : Fbound.
Variable radix : Z.
Variable precision : nat.

Let FtoRradix := FtoR radix.
Coercion FtoRradix : float >-> R.
Hypothesis radixMoreThanOne : (1 < radix)%Z.

Let radixMoreThanZERO := Zlt_1_O _ (Zlt_le_weak _ _ radixMoreThanOne).
Hint Resolve radixMoreThanZERO: zarith.
Hypothesis precisionGreaterThanOne : 1 < precision.
Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix precision.

Theorem plusExpMin :
 forall P,
 RoundedModeP b radix P ->
 forall p q pq : float,
 P (p + q)%R pq ->
 exists s : float,
   Fbounded b s /\ s = pq :>R /\ (Zmin (Fexp p) (Fexp q) <= Fexp s)%Z.
intros P H' p q pq H'0.
case
 (RoundedModeRep b radix precision)
  with (p := Fplus radix p q) (q := pq) (P := P); auto with float arith.
rewrite Fplus_correct; auto with float arith.
simpl in |- *; intros x H'1.
case
 (eqExpLess _ radixMoreThanOne b)
  with (p := pq) (q := Float x (Fexp (Fplus radix p q)));
 auto.
apply (RoundedModeBounded b radix) with (P := P) (r := (p + q)%R); auto.
simpl in |- *; intros x0 H'2; elim H'2; intros H'3 H'4; elim H'4;
 intros H'5 H'6; clear H'4 H'2.
exists x0; split; [ idtac | split ]; auto.
unfold FtoRradix in |- *; rewrite H'5; auto.
apply le_IZR; auto.
Qed.

Theorem plusExpUpperBound :
 forall P,
 RoundedModeP b radix P ->
 forall p q pq : float,
 P (p + q)%R pq ->
 Fbounded b p ->
 Fbounded b q ->
 exists r : float,
   Fbounded b r /\ r = pq :>R /\ (Fexp r <= Zsucc (Zmax (Fexp p) (Fexp q)))%Z.
intros P H' p q pq H'0 H'1 H'2.
replace (Zsucc (Zmax (Fexp p) (Fexp q))) with
 (Fexp (Float (pPred (vNum b)) (Zsucc (Zmax (Fexp p) (Fexp q)))));
 [ idtac | simpl in |- *; auto ].
unfold FtoRradix in |- *; apply eqExpMax; auto.
apply RoundedModeBounded with (radix := radix) (P := P) (r := (p + q)%R);
 auto with float arith.
unfold pPred in |- *; apply maxFbounded; auto.
apply Zle_trans with (Fexp p); auto with float.
apply Zle_trans with (Zsucc (Fexp p)); auto with float zarith.
replace
 (FtoR radix (Float (pPred (vNum b)) (Zsucc (Zmax (Fexp p) (Fexp q))))) with
 (radix * Float (pPred (vNum b)) (Zmax (Fexp p) (Fexp q)))%R.
rewrite Fabs_correct; auto with zarith.
unfold FtoRradix in |- *;
 apply
  RoundedModeMultAbs
   with (b := b) (precision := precision) (P := P) (r := (p + q)%R);
 auto.
unfold pPred in |- *; apply maxFbounded; auto.
apply Zle_trans with (Fexp p); auto with float zarith.
apply Rle_trans with (Rabs p + Rabs q)%R.
apply Rabs_triang; auto.
apply
 Rle_trans
  with
    (2%nat * FtoR radix (Float (pPred (vNum b)) (Zmax (Fexp p) (Fexp q))))%R;
 auto.
cut (forall r : R, (2%nat * r)%R = (r + r)%R);
 [ intros tmp; rewrite tmp; clear tmp | intros; simpl in |- *; ring ].
apply Rplus_le_compat; auto.
rewrite <- (Fabs_correct radix); auto with arith; apply maxMax1; auto;
 apply ZmaxLe1.
rewrite <- (Fabs_correct radix); auto with arith; apply maxMax1; auto;
 apply ZmaxLe2.
apply Rmult_le_compat; auto with real arith.
replace 0%R with (INR 0); auto with real arith.
apply LeFnumZERO; simpl in |- *; auto; replace 0%Z with (Z_of_nat 0);
 auto with zarith.
unfold pPred in |- *; apply Zle_Zpred; auto with zarith.
rewrite INR_IZR_INZ; apply Rle_IZR; simpl in |- *; auto with zarith.
cut (1 < radix)%Z; auto with zarith;intros.
unfold FtoRradix, FtoR in |- *; simpl in |- *.
rewrite powerRZ_Zs; auto with real zarith; ring.
Qed.

Theorem plusExpBound :
 forall P,
 RoundedModeP b radix P ->
 forall p q pq : float,
 P (p + q)%R pq ->
 Fbounded b p ->
 Fbounded b q ->
 exists r : float,
   Fbounded b r /\
   r = pq :>R /\
   (Zmin (Fexp p) (Fexp q) <= Fexp r)%Z /\
   (Fexp r <= Zsucc (Zmax (Fexp p) (Fexp q)))%Z.
intros P H' p q pq H'0 H'1 H'2.
case (plusExpMin P H' _ _ _ H'0).
intros r' H'3; elim H'3; intros H'4 H'5; elim H'5; intros H'6 H'7;
 clear H'5 H'3.
case (Zle_or_lt (Fexp r') (Zsucc (Zmax (Fexp p) (Fexp q)))); intros Zl1.
exists r'; repeat (split; auto).
case (plusExpUpperBound P H' _ _ _ H'0); auto.
intros r'' H'3; elim H'3; intros H'5 H'8; elim H'8; intros H'9 H'10;
 clear H'8 H'3.
exists
 (Fshift radix (Zabs_nat (Fexp r' - Zsucc (Zmax (Fexp p) (Fexp q)))) r');
 split.
apply FboundedShiftLess with (n := Zabs_nat (Fexp r' - Fexp r'')); auto.
apply ZleLe; auto.
repeat rewrite <- Zabs_absolu.
repeat rewrite Zabs_eq; auto with zarith.
rewrite FshiftCorrectInv; auto.
apply trans_eq with (FtoRradix pq); auto.
apply Zle_trans with (1 := H'10); auto with zarith.
split.
unfold FtoRradix in |- *; rewrite FshiftCorrect; auto.
split.
simpl in |- *.
repeat rewrite inj_abs; auto with zarith arith.
apply Zle_trans with (Zmax (Fexp p) (Fexp q)); auto with zarith.
apply Zmin_Zmax; auto.
simpl in |- *.
repeat rewrite inj_abs; auto with zarith arith.
Qed.

Theorem minusRoundRep :
 forall P,
 RoundedModeP b radix P ->
 forall p q qmp qmmp : float,
 (0 <= p)%R ->
 (p <= q)%R ->
 P (q - p)%R qmp ->
 Fbounded b p ->
 Fbounded b q -> exists r : float, Fbounded b r /\ r = (q - qmp)%R :>R.
intros P H' p q qmp H'0 H'1 H'2 H'3 H'4 H'5.
case (Rle_or_lt (/ 2%nat * q) p); intros Rle1.
exists p; split; auto.
replace (FtoRradix qmp) with (FtoRradix (Fminus radix q p)).
rewrite (Fminus_correct radix); auto with arith; unfold FtoRradix in |- *;
 ring.
apply (RoundedModeProjectorIdemEq b radix precision) with (P := P); auto.
rewrite <- Fopp_Fminus.
apply oppBounded; auto.
apply Sterbenz; auto.
apply Rle_trans with (FtoRradix q); auto with real.
apply Rledouble; auto.
apply Rle_trans with (FtoRradix p); auto with real.
cut (CompatibleP b radix P);
 [ intros Cp | apply RoundedModeP_inv2 with (1 := H'); auto ].
apply (Cp (q - p)%R (Fminus radix q p) qmp); auto.
rewrite (Fminus_correct radix); auto with arith.
apply RoundedModeBounded with (radix := radix) (P := P) (r := (q - p)%R);
 auto; auto.
exists (Fminus radix q qmp); split.
rewrite <- Fopp_Fminus.
apply oppBounded; auto.
apply Sterbenz; auto.
apply RoundedModeBounded with (radix := radix) (P := P) (r := (q - p)%R);
 auto; auto.
case MaxEx with (r := (/ 2%nat * FtoR radix q)%R) (3 := pGivesBound);
 auto with arith.
intros max H'6.
apply Rle_trans with (FtoRradix max);
 [ apply isMax_inv1 with (1 := H'6); auto | idtac ].
apply (RleBoundRoundl b radix precision) with (P := P) (r := (q - p)%R); auto;
 fold FtoRradix in |- *.
case H'6; auto.
case MinEx with (r := (/ 2%nat * FtoR radix q)%R) (3 := pGivesBound);
 auto with arith.
intros min H'7.
replace (FtoRradix max) with (q - min)%R.
apply Rplus_le_reg_l with (r := (- q)%R).
cut (forall p q : R, (- p + (p - q))%R = (- q)%R);
 [ intros tmp; repeat rewrite tmp; clear tmp | intros; ring ].
apply Ropp_le_contravar.
case H'7.
intros H'8 H'9; elim H'9; intros H'10 H'11; apply H'11; clear H'9; auto.
apply Rlt_le; auto.
unfold FtoRradix in |- *;
 rewrite (div2IsBetween b radix precision) with (5 := H'7) (6 := H'6);
 auto.
ring.
apply Rle_trans with (FtoRradix q); auto with real.
apply (RleBoundRoundr b radix precision) with (P := P) (r := (q - p)%R); auto;
 fold FtoRradix in |- *.
apply Rplus_le_reg_l with (r := (- q)%R).
cut (forall p q : R, (- p + (p - q))%R = (- q)%R);
 [ intros tmp; repeat rewrite tmp; clear tmp | intros; ring ].
replace (- q + q)%R with (-0)%R; [ auto with real | ring ].
apply Rle_trans with (FtoRradix q); auto with real.
apply Rledouble; auto.
apply Rle_trans with (FtoRradix p); auto with real.
apply (Fminus_correct radix); auto with arith.
Qed.

Theorem radixRangeBoundExp :
 forall p q : float,
 Fcanonic radix b p ->
 Fcanonic radix b q ->
 (0 <= p)%R ->
 (p < q)%R -> (q < radix * p)%R -> Fexp p = Fexp q \/ Zsucc (Fexp p) = Fexp q.
intros p q H' H'0 H'1 H'2 H'3.
case (FcanonicLtPos _ radixMoreThanOne b precision) with (p := p) (q := q);
 auto with arith.
2: intros H'4; elim H'4; intros H'5 H'6; clear H'4; auto.
intros H'4; right.
Casec H'; intros H'.
case
 (FcanonicLtPos _ radixMoreThanOne b precision)
  with (p := q) (q := Float (Fnum p) (Zsucc (Fexp p)));
 auto with arith.
left.
case H'; intros H1 H2.
repeat split; simpl in |- *; auto with float.
apply Zle_trans with (Fexp p); auto with float zarith.
apply Rle_trans with (FtoRradix p); auto; apply Rlt_le; auto.
unfold FtoR in |- *; simpl in |- *.
rewrite powerRZ_Zs; auto with real zarith; auto.
rewrite <- Rmult_assoc;
 rewrite (fun (x : R) (y : Z) => Rmult_comm x y);
 rewrite Rmult_assoc; auto.
simpl in |- *; intros; apply Zle_antisym; auto with zarith.
simpl in |- *; auto.
intros H'5; elim H'5; intros H'6 H'7; auto.
case
 (FcanonicLtPos _ radixMoreThanOne b precision)
  with (p := q) (q := Float (nNormMin radix precision) (Zsucc (Fexp p)));
 auto with arith.
left; repeat split; simpl in |- *.
rewrite Zabs_eq; auto with float zarith.
apply ZltNormMinVnum; auto with zarith.
apply Zlt_le_weak; auto with zarith.
apply nNormPos; auto with zarith.
case H'; auto with zarith float.
rewrite (PosNormMin radix b precision); auto with zarith.
apply Rle_trans with (1 := H'1); auto with real.
apply Rlt_trans with (1 := H'3).
unfold FtoR in |- *; simpl in |- *.
rewrite powerRZ_Zs; auto with real arith; auto.
rewrite <- Rmult_assoc;
 rewrite (fun (x : R) (y : Z) => Rmult_comm x y);
 rewrite Rmult_assoc; auto.
apply Rmult_lt_compat_l; auto with real arith.
replace (Fexp p) with (- dExp b)%Z.
change (p < firstNormalPos radix b precision)%R in |- *.
apply (FsubnormalLtFirstNormalPos radix); auto with arith.
case H'; intros Z1 (Z2, Z3); auto.
auto with real zarith.
simpl in |- *; auto.
intros H; apply Zle_antisym; auto with zarith.
intros H'5; elim H'5; intros H'6 H'7; rewrite H'6; clear H'5; auto.
Qed.

Theorem ExactMinusIntervalAux :
 forall P,
 RoundedModeP b radix P ->
 forall p q : float,
 (0 < p)%R ->
 (2%nat * p < q)%R ->
 Fcanonic radix b p ->
 Fcanonic radix b q ->
 (exists r : float, Fbounded b r /\ r = (q - p)%R :>R) ->
 forall r : float,
 Fcanonic radix b r ->
 (2%nat * p < r)%R ->
 (r <= q)%R -> exists r' : float, Fbounded b r' /\ r' = (r - p)%R :>R.
intros P H' p q H'0 H'1 H'2 H'3 H'4 r H'5 H'6 H'7.
cut (0 <= p)%R; [ intros Rle0 | apply Rlt_le; auto ].
cut (0 <= r)%R; [ intros Rle1 | apply Rle_trans with (2%nat * p)%R; auto ].
2: apply Rle_trans with (FtoRradix p); auto with float arith.
2: apply Rledouble; auto.
2: apply Rlt_le; auto.
generalize H'6; clear H'6; pattern r in |- *;
 apply (FinductNeg b radix precision) with (p := q);
 auto with arith.
apply Rle_trans with (FtoRradix r); auto.
intros q0 H'6 H'8 H'9 H'10 H'11.
elim H'10;
 [ intros r' E; elim E; intros H'13 H'14; clear E H'10 | clear H'10 ];
 auto.
2: apply Rlt_trans with (1 := H'11); auto; apply (FPredLt b radix precision);
    auto with arith.
cut (0 <= Fnormalize radix b precision r')%R; [ intros Rle2 | idtac ].
2: rewrite (FnormalizeCorrect radix); auto with arith.
2: unfold FtoRradix in H'14; rewrite H'14.
2: apply Rplus_le_reg_l with (r := FtoR radix p).
2: replace (FtoR radix p + 0)%R with (FtoR radix p); [ idtac | ring ].
2: replace (FtoR radix p + (FtoR radix q0 - FtoR radix p))%R with
    (FtoR radix q0); [ idtac | ring ].
2: apply Rle_trans with (2%nat * p)%R; auto.
2: apply Rledouble; auto with real arith.
2: apply Rlt_le; apply Rlt_trans with (1 := H'11); auto with float.
2: apply (FPredLt b radix precision); auto with arith.
cut (Fnormalize radix b precision r' < q0)%R; [ intros Rle3 | idtac ].
2: rewrite (FnormalizeCorrect radix); auto with arith.
2: unfold FtoRradix in H'14; rewrite H'14.
2: apply Rplus_lt_reg_l with (r := (- q0)%R).
2: replace (- q0 + (FtoR radix q0 - FtoR radix p))%R with (- p)%R;
    [ idtac | unfold FtoRradix in |- *; ring; ring ].
2: replace (- q0 + q0)%R with (-0)%R; [ auto with real | ring ].
case radixRangeBoundExp with (p := Fnormalize radix b precision r') (q := q0);
 auto with float arith; fold FtoRradix in |- *.
rewrite (FnormalizeCorrect radix); auto with arith.
apply Rlt_le_trans with (2%nat * r')%R; auto.
rewrite H'14.
rewrite Rmult_minus_distr_l.
pattern (FtoRradix q0) at 1 in |- *;
 (replace (FtoRradix q0) with (2%nat * q0 - q0)%R;
   [ idtac | simpl in |- *; ring ]).
unfold Rminus in |- *; apply Rplus_lt_compat_l; apply Ropp_lt_contravar.
apply Rlt_trans with (1 := H'11).
apply (FPredLt b radix precision); auto with arith.
apply Rmult_le_compat_r; auto with real arith.
unfold FtoRradix in Rle2; rewrite (FnormalizeCorrect radix) in Rle2;
 auto with arith.
rewrite INR_IZR_INZ; cut (2 <= radix)%Z; auto with real zarith.
cut (1 < radix)%Z; auto with zarith.
intros H'10.
case
 (FcanonicLtPos _ radixMoreThanOne b precision)
  with (p := Fnormalize radix b precision r') (q := q0);
 auto with arith.
apply FnormalizeCanonic; auto with arith.
intros; Contradict H'10; auto with zarith.
intros H'12; elim H'12; intros H'15 H'16; clear H'12.
exists
 (Float (Zpred (Fnum (Fnormalize radix b precision r')))
    (Fexp (Fnormalize radix b precision r'))).
split.
cut (Fbounded b (Fnormalize radix b precision r')); [ intros Fb0 | idtac ].
repeat split; simpl in |- *; auto with float.
case Rle2; intros Z1.
apply Zle_lt_trans with (Zabs (Fnum (Fnormalize radix b precision r')));
 auto with float zarith.
repeat rewrite Zabs_eq; auto with zarith.
apply (LeR0Fnum radix); auto with zarith.
apply Zle_Zpred; apply (LtR0Fnum radix); auto with zarith.
replace (Fnum (Fnormalize radix b precision r')) with 0%Z; simpl in |- *;
 auto with zarith.
apply (vNumbMoreThanOne radix) with (precision := precision);
 auto with zarith.
apply sym_equal; change (is_Fzero (Fnormalize radix b precision r')) in |- *;
 apply (is_Fzero_rep2 radix); auto with zarith.
apply FcanonicBound with (radix := radix); auto.
apply FnormalizeCanonic; auto with arith.
replace
 (Float (Zpred (Fnum (Fnormalize radix b precision r')))
    (Fexp (Fnormalize radix b precision r'))) with
 (Fminus radix (Fnormalize radix b precision r')
    (Fminus radix q0 (FPred b radix precision q0))).
repeat rewrite (Fopp_correct radix); repeat rewrite (Fminus_correct radix);
 auto with arith.
rewrite (FnormalizeCorrect radix); auto with arith.
unfold FtoRradix in H'14; rewrite H'14.
unfold FtoRradix in |- *; ring; ring.
replace (FPred b radix precision q0) with (Float (Zpred (Fnum q0)) (Fexp q0));
 auto.
unfold Fminus, Fopp, Fplus in |- *; simpl in |- *.
repeat rewrite Zmin_n_n; repeat rewrite <- Zminus_diag_reverse; simpl in |- *;
 auto.
rewrite H.
repeat rewrite Zmin_n_n; repeat rewrite <- Zminus_diag_reverse; simpl in |- *;
 auto.
repeat rewrite Zmult_1_r.
apply floatEq; simpl in |- *; auto; unfold Zpred in |- *; ring.
case (Z_eq_dec (Fnum q0) (nNormMin radix precision)); intros Zeq2.
case (Z_eq_dec (Fexp q0) (- dExp b)); intros Zeq1.
rewrite Zeq1; rewrite Zeq2; rewrite <- (FPredSimpl3 b radix); auto with arith;
 rewrite <- Zeq1; rewrite <- Zeq2; auto.
Contradict H'16.
apply Zle_not_lt.
rewrite Zeq2.
rewrite <- (Zabs_eq (Fnum (Fnormalize radix b precision r')));
 auto with zarith.
apply pNormal_absolu_min with (b := b); auto with arith.
cut (Fcanonic radix b (Fnormalize radix b precision r'));
 [ intros Ca1; case Ca1; auto | auto with float arith ].
intros H'12; case Zeq1; rewrite <- H.
case H'12; auto.
intros Hbis H0; case H0; auto.
apply (LeR0Fnum radix); auto.
rewrite FPredSimpl4; auto.
Contradict H'16; rewrite H'16.
apply Zle_not_lt.
unfold pPred in |- *; rewrite Zopp_Zpred_Zs; apply Zlt_le_succ.
apply Zlt_Zabs_inv1.
cut (Fbounded b (Fnormalize radix b precision r'));
 [ auto with float | idtac ].
apply (FcanonicBound radix b); auto with float arith.
intros H'10.
case (Z_eq_dec (Fnum q0) (nNormMin radix precision)); intros Zeq2.
exists
 (Float (Zpred (Fnum (Fnormalize radix b precision r')))
    (Fexp (Fnormalize radix b precision r'))).
cut (Fbounded b (Fnormalize radix b precision r')); [ intros Fb1 | idtac ].
repeat split; simpl in |- *; auto with float.
case Rle2; intros Z1.
apply Zlt_trans with (Zabs (Fnum (Fnormalize radix b precision r'))).
repeat rewrite Zabs_eq; auto with zarith.
apply (LeR0Fnum radix); auto.
apply Zle_Zpred; apply (LtR0Fnum radix); auto.
case Fb1; auto.
replace (Fnum (Fnormalize radix b precision r')) with 0%Z.
simpl in |- *; apply (vNumbMoreThanOne radix) with (precision := precision);
 auto with zarith.
apply sym_equal; change (is_Fzero (Fnormalize radix b precision r')) in |- *;
 apply (is_Fzero_rep2 radix); auto with zarith.
rewrite FPredSimpl2; auto with zarith.
rewrite <- H'10.
cut (forall z : Z, Zpred (Zsucc z) = z);
 [ intros tmp; rewrite tmp; clear tmp
 | intros; unfold Zsucc, Zpred in |- *; ring ].
unfold FtoRradix, FtoR in |- *; simpl in |- *.
cut (forall x : Z, Zpred x = (x - 1%nat)%Z);
 [ intros tmp; rewrite tmp; clear tmp
 | intros; unfold Zpred in |- *; simpl in |- *; ring ].
unfold FtoRradix, FtoR in |- *; simpl in |- *.
rewrite <- Z_R_minus; auto.
rewrite (fun x y => Rmult_comm (x - y)); rewrite Rmult_minus_distr_l;
 repeat rewrite (fun x y => Rmult_comm (powerRZ x y)).
replace
 (Fnum (Fnormalize radix b precision r') *
  powerRZ radix (Fexp (Fnormalize radix b precision r')))%R with
 (FtoRradix (Fnormalize radix b precision r')).
rewrite (FnormalizeCorrect radix); auto.
unfold FtoRradix in H'14; rewrite H'14.
unfold FtoR in |- *; simpl in |- *.
pattern (Fexp q0) at 1 in |- *; rewrite <- H'10.
rewrite Zeq2; rewrite powerRZ_Zs; auto with real zarith.
rewrite <- Rmult_assoc.
replace (nNormMin radix precision * radix)%R with (powerRZ radix precision).
unfold pPred, nNormMin, Zpred in |- *; rewrite pGivesBound.
rewrite plus_IZR; repeat rewrite Zpower_nat_Z_powerRZ; simpl in |- *; try ring.
rewrite <- Zpower_nat_Z_powerRZ; auto with zarith; rewrite <- Rmult_IZR;
 rewrite Zmult_comm; rewrite <- (PosNormMin radix b precision);
 auto with real zarith.
auto.
red in |- *; intros H'12;
 absurd (- dExp b <= Fexp (Fnormalize radix b precision r'))%Z;
 auto with float.
apply Zlt_not_le.
rewrite <- H'12; rewrite <- H'10; unfold Zsucc in |- *;
 auto with float zarith.
apply (FcanonicBound radix b); auto with arith.
apply FnormalizeCanonic; auto with arith.
exists
 (Float (Fnum (Fnormalize radix b precision r') - radix)
    (Fexp (Fnormalize radix b precision r'))).
cut (Fbounded b (Fnormalize radix b precision r')); [ intros Fb1 | idtac ].
repeat split; simpl in |- *; auto with float.
case (Zle_or_lt (Fnum (Fnormalize radix b precision r')) radix); intros Z1.
apply Zle_lt_trans with radix.
rewrite Zabs_eq_opp; auto with zarith.
cut (0 <= Fnum (Fnormalize radix b precision r'))%Z; auto with zarith.
apply (LeR0Fnum radix); auto.
rewrite <- (Zpower_nat_1 radix); rewrite pGivesBound; auto with zarith.
apply Zle_lt_trans with (Zabs (Fnum (Fnormalize radix b precision r'))).
repeat rewrite Zabs_eq; auto with zarith.
case Fb1; auto.
rewrite FPredSimpl4; auto with arith.
rewrite <- H'10.
unfold FtoRradix, FtoR in |- *; simpl in |- *.
cut (forall x : Z, Zpred x = (x - 1%nat)%Z);
 [ intros tmp; rewrite tmp; clear tmp
 | intros; unfold Zpred in |- *; simpl in |- *; ring ].
repeat rewrite <- Z_R_minus; auto.
repeat rewrite (fun x y => Rmult_comm (x - y));
 repeat rewrite Rmult_minus_distr_l;
 repeat rewrite (fun x y => Rmult_comm (powerRZ x y)).
replace
 (Fnum (Fnormalize radix b precision r') *
  powerRZ radix (Fexp (Fnormalize radix b precision r')))%R with
 (FtoRradix (Fnormalize radix b precision r')).
rewrite (FnormalizeCorrect radix); auto.
unfold FtoRradix in H'14; rewrite H'14.
unfold FtoR in |- *; simpl in |- *.
rewrite <- H'10.
repeat rewrite powerRZ_Zs; auto with real arith.
ring.
auto with real zarith.
unfold FtoR in |- *; simpl in |- *; auto.
red in |- *; intros H'12; absurd (0 <= Fnum q0)%Z; auto.
apply Zlt_not_le.
rewrite H'12.
replace 0%Z with (- 0%nat)%Z; [ apply Zlt_Zopp | simpl in |- *; auto ].
unfold pPred in |- *; apply Zlt_succ_pred; simpl in |- *; auto with zarith.
apply (vNumbMoreThanOne radix) with (precision := precision);
 auto with zarith.
apply (LeR0Fnum radix); auto.
apply Rlt_le; auto.
apply (FcanonicBound radix b); auto with arith.
apply FnormalizeCanonic; auto with arith.
Qed.

Theorem ExactMinusIntervalAux1 :
 forall P,
 RoundedModeP b radix P ->
 forall p q : float,
 (0 <= p)%R ->
 (p <= q)%R ->
 Fcanonic radix b p ->
 Fcanonic radix b q ->
 (exists r : float, Fbounded b r /\ r = (q - p)%R :>R) ->
 forall r : float,
 Fcanonic radix b r ->
 (p <= r)%R ->
 (r <= q)%R -> exists r' : float, Fbounded b r' /\ r' = (r - p)%R :>R.
intros P H' p q H'0 H'1 H'2 H'3 H'4 r H'5 H'6 H'7.
Casec H'0; intros H'0.
case (Rle_or_lt q (2%nat * p)); intros Rl1.
exists (Fminus radix r p); split; auto.
rewrite <- Fopp_Fminus.
apply oppBounded.
apply Sterbenz; auto.
apply (FcanonicBound radix b); auto with arith.
apply (FcanonicBound radix b); auto with arith.
apply Rmult_le_reg_l with (r := INR 2); auto with real.
rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real arith;
 rewrite Rmult_1_l; auto.
apply Rle_trans with (1 := H'7); auto.
apply Rle_trans with (1 := H'6); auto.
apply Rledouble; auto.
apply Rle_trans with (2 := H'6); apply Rlt_le; auto.
rewrite (Fminus_correct radix); auto with arith.
case (Rle_or_lt r (2%nat * p)); intros Rl2.
exists (Fminus radix r p); split; auto.
rewrite <- Fopp_Fminus.
apply oppBounded.
apply Sterbenz; auto.
apply (FcanonicBound radix b); auto with arith.
apply (FcanonicBound radix b); auto with arith.
apply Rmult_le_reg_l with (r := INR 2); auto with real.
rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real arith;
 rewrite Rmult_1_l; auto.
apply Rle_trans with (1 := H'6); auto.
apply Rledouble; auto.
apply Rle_trans with (2 := H'6); apply Rlt_le; auto.
rewrite (Fminus_correct radix); auto with arith.
apply ExactMinusIntervalAux with (P := P) (q := q); auto.
exists r; split; auto.
apply (FcanonicBound radix b); auto with arith.
rewrite <- H'0; ring.
Qed.

Theorem ExactMinusInterval :
 forall P,
 RoundedModeP b radix P ->
 forall p q : float,
 (0 <= p)%R ->
 (p <= q)%R ->
 Fbounded b p ->
 Fbounded b q ->
 (exists r : float, Fbounded b r /\ r = (q - p)%R :>R) ->
 forall r : float,
 Fbounded b r ->
 (p <= r)%R ->
 (r <= q)%R -> exists r' : float, Fbounded b r' /\ r' = (r - p)%R :>R.
intros P H' p q H'0 H'1 H'2 H'3 H'4 r H'5 H'6 H'7.
replace (FtoRradix r) with (FtoRradix (Fnormalize radix b precision r));
 [ idtac | apply (FnormalizeCorrect radix) ]; auto.
replace (FtoRradix p) with (FtoRradix (Fnormalize radix b precision p));
 [ idtac | apply (FnormalizeCorrect radix) ]; auto.
apply
 ExactMinusIntervalAux1 with (P := P) (q := Fnormalize radix b precision q);
 auto; try repeat rewrite (FnormalizeCorrect radix);
 auto; apply FnormalizeCanonic; auto with arith.
Qed.
(* Properties concerning LSB MSB *)

Theorem MSBroundLSB :
 forall P : R -> float -> Prop,
 RoundedModeP b radix P ->
 forall f1 f2 : float,
 P f1 f2 ->
 ~ is_Fzero (Fminus radix f1 f2) ->
 (MSB radix (Fminus radix f1 f2) < LSB radix f2)%Z.
intros P H' f1 f2 H'0 HZ.
apply (oneExp_Zlt radix); auto.
apply Rlt_le_trans with (Fulp b radix precision f2).
apply Rle_lt_trans with (FtoRradix (Fabs (Fminus radix f1 f2))).
unfold FtoRradix in |- *; apply MSB_le_abs; auto.
unfold FtoRradix in |- *; rewrite Fabs_correct; auto with arith;
 rewrite Fminus_correct; auto with arith.
apply RoundedModeUlp with (4 := H'); auto.
apply FUlp_Le_LSigB; auto.
apply RoundedModeBounded with (1 := H') (2 := H'0); auto.
Qed.

Theorem LSBMinus :
 forall p q : float,
 ~ is_Fzero (Fminus radix p q) ->
 (Zmin (LSB radix p) (LSB radix q) <= LSB radix (Fminus radix p q))%Z.
intros p q H'1.
elim (LSB_rep_min radix) with (p := p); auto; intros z E.
elim (LSB_rep_min radix) with (p := q); auto; intros z0 E0.
replace (LSB radix (Fminus radix p q)) with
 (LSB radix (Fminus radix (Float z (LSB radix p)) (Float z0 (LSB radix q)))).
replace (Zmin (LSB radix p) (LSB radix q)) with
 (Fexp (Fminus radix (Float z (LSB radix p)) (Float z0 (LSB radix q))));
 [ idtac | simpl in |- *; auto ].
apply Fexp_le_LSB; auto.
apply sym_equal; apply LSB_comp; auto.
repeat rewrite Fminus_correct; auto with arith.
unfold FtoRradix in E; unfold FtoRradix in E0; rewrite E; rewrite E0; auto.
Qed.

Theorem LSBPlus :
 forall p q : float,
 ~ is_Fzero (Fplus radix p q) ->
 (Zmin (LSB radix p) (LSB radix q) <= LSB radix (Fplus radix p q))%Z.
intros p q H'.
elim (LSB_rep_min _ radixMoreThanOne p); intros z E.
elim (LSB_rep_min _ radixMoreThanOne q); intros z0 E0.
replace (LSB radix (Fplus radix p q)) with
 (LSB radix (Fplus radix (Float z (LSB radix p)) (Float z0 (LSB radix q)))).
replace (Zmin (LSB radix p) (LSB radix q)) with
 (Fexp (Fplus radix (Float z (LSB radix p)) (Float z0 (LSB radix q))));
 [ idtac | simpl in |- *; auto ].
apply Fexp_le_LSB; auto.
apply sym_equal; apply LSB_comp; auto.
repeat rewrite Fplus_correct; auto with arith.
unfold FtoRradix in E; unfold FtoRradix in E0; rewrite E; rewrite E0; auto.
Qed.

End FRoundP.


Require Import Complex Geobase Geoline.

Definition Is_parallel ( a b : Line ):= Lshib a = Lshib b.

Infix " ||| " := Is_parallel ( at level 20 ).

Lemma Parallel_def : forall m n : Line , m ||| n -> forall a : Complex , on_line a m -> on_line a n -> Larz n = Larz m.
Proof.
  intros.
  unfold Is_parallel in H.
  SearchAbout Line .
  unfold on_line in H0.
  unfold on_line in H1.
  rewrite H in H0.
  rewrite H0 in H1.
  replace (Larz m) with ( fst (Larz m, 0%R) ).
  rewrite H1.
  auto.
  auto.
Qed.

Definition Line_intersect ( l1 l2 : Line ) := (((Larz l1,0)%R*l1-(Larz l2,0)%R*l2)/(l1*l1-l2*l2))%C.

Lemma Ccojabs2 : forall x : Complex , ( x*Ccoj x = ((Cabs x)^2,0)%R )%C.
Proof.
  intros.
  unfold Cabs.
  simpl.
  replace ( (sqrt (real_p x * real_p x + imag_p x * imag_p x) *
  (sqrt (real_p x * real_p x + imag_p x * imag_p x) * 1) ) )%R with
  (real_p x * real_p x + imag_p x * imag_p x)%R.
  remember (x * Ccoj x)%C as z.
  rewrite Cdecompose with (z:=x) in Heqz.
  unfold Ccoj in Heqz.
  simpl in Heqz.
  rewrite Heqz.
  apply injective_projections.
  simpl.
  ring.
  simpl.
  ring.
  replace ( (sqrt (real_p x * real_p x + imag_p x * imag_p x) *
 (sqrt (real_p x * real_p x + imag_p x * imag_p x) * 1)) )%R
  with ( (sqrt (real_p x * real_p x + imag_p x * imag_p x) *
 (sqrt (real_p x * real_p x + imag_p x * imag_p x) )) )%R.
  rewrite sqrt_def.
  auto.
  apply Ra2b2pos.
  ring.
Qed.

Lemma line_eq_help1 : forall x : Complex , forall l1 : Line , (l1 * x + Ccoj l1 * Ccoj x)%C = (Larz l1, 0%R) -> (x)%C = (Ccoj l1 * (Larz l1, 0%R) - Ccoj l1 * Ccoj l1 * Ccoj x)%C.
Proof.
  intros.
  assert (Ccoj l1 * (l1 * x + Ccoj l1 * Ccoj x)%C = Ccoj l1 * (Larz l1, 0%R))%C.
  rewrite H.
  auto.
  ring_simplify in H0.
  replace ( Ccoj l1 * l1 * x )%C with x in H0.
  rewrite <- H0.
  ring.
  replace (Ccoj l1 * l1 )%C with (C1)%C.
  ring.
  rewrite Cmult_comm.
  rewrite Ccojabs2.
  rewrite Lshib_len1.
  apply injective_projections.
  simpl.
  ring.
  simpl.
  ring.
Qed.

Lemma Ccojreal : forall x:R , Ccoj ( x , 0 )%R = (x , 0 )%R.
Proof.
  intros.
  unfold Ccoj.
  simpl.
  replace (-0)%R with 0%R ; [ idtac | ring ].
  auto.
Qed.

Lemma Cabsargeq : forall a b : Complex , Cabs a = Cabs b -> Carg a = Carg b -> a = b.
Proof.
  intros.
  rewrite Cdecompose.
  rewrite Cdecompose with (z:=a).
  rewrite ! Creal_arg.
  rewrite ! Cimag_arg.
  rewrite H.
  rewrite H0.
  auto.
Qed.

Lemma not_parallel_intersect_uniq : forall l1 l2 : Line , ~ (l1 ||| l2) -> forall x : Complex , on_line x l1 -> on_line x l2 -> x=Line_intersect l1 l2.
Proof.
  intros.
  unfold Line_intersect.
  unfold on_line in H0,H1.
  apply line_eq_help1 in H0.
  apply line_eq_help1 in H1.
  rewrite <- Ccojreal in H0,H1.
  rewrite ! Ccojmult in H0,H1.
  rewrite Ccojminus in H0,H1.
  assert ( Ccoj (l1 * (Larz l1, 0%R) - l1 * l1 * x)%C
 = Ccoj (l2 * (Larz l2, 0%R) - l2 * l2 * x)%C ).
  rewrite <- H0.
  auto.
  apply Ccojeq in H2.
  assert ( (((Larz l1, 0%R) * l1 - (Larz l2, 0%R) * l2) = (x*(l1 * l1 - l2 * l2)))%C ).
  apply Ceq_side2 in H2.
  apply Ceq_side.
  rewrite <- H2.
  ring.
  assert ( forall a b c : Complex , a * b = c -> b <> C0 -> a = c / b )%C.
  intros.
  rewrite <- H4.
  field.
  auto.
  apply H4.
  auto.
  unfold not.
  intros.
  apply Ceq_side in H5.
  assert ( Carg (l1 * l1)%C = Carg (l2 * l2)%C ).
  f_equal.
  auto.
  rewrite <- ! Cmultarg in H6.
  rewrite ! argplus1 in H6.
  ring_simplify in H6.
  apply Rmult_eq_reg_l in H6.
  elim H.
  unfold Is_parallel.
  apply Cabsargeq.
  rewrite ! Lshib_len1.
  auto.
  auto.
  auto with real.
  apply Cineq0_arg.
  apply Lshib_gt_C0.
  apply Cineq0_arg.
  apply Lshib_gt_C0.
  apply Cineq0_arg.
  apply Lshib_gt_C0.
  apply Cineq0_arg.
  apply Lshib_gt_C0.
  apply not_eq_sym.
  apply Cineq_eq.
  apply Lshib_gt_C0.
  apply not_eq_sym.
  apply Cineq_eq.
  apply Lshib_gt_C0.
  apply not_eq_sym.
  apply Cineq_eq.
  apply Lshib_gt_C0.
  apply not_eq_sym.
  apply Cineq_eq.
  apply Lshib_gt_C0.
Qed.

Lemma moadele2majhool : forall a b c d e f : R , ( b*d <> a*e )%R -> exists x y : R , (a * x + b * y = c /\ d * x + e * y = f )%R.
Proof.
  intros.
  assert ( b*d - a*e <> 0 )%R.
  unfold not.
  intros.
  elim H.
  apply Rminus_diag_uniq.
  auto.
  exists ( (b*f-c*e)/(b*d-a*e) )%R.
  exists ( (c*d-a*f)/(b*d-a*e) )%R.
  split.
  field.
  auto.
  field.
  auto.
Qed.

Lemma Creal_coj : forall a : Complex , (a + Ccoj a)%C = ( 2 * real_p a , 0 )%R.
Proof.
  intros.
  rewrite Cdecompose with (z:=a).
  unfold Ccoj.
  simpl.
  apply injective_projections.
  simpl.
  ring.
  simpl.
  ring.
Qed.

Lemma Cineq0_real : forall x : Complex , (C0 < x)%C -> (0<=real_p x)%R.
Proof.
  intros.
  rewrite Cdecompose in H.
  simpl in H.
  destruct ( Real_eq_dec 0 (real_p x) ).
  right ; auto.
  left ; auto.
Qed.

Lemma not_parallel_help : forall l1 l2 : Line , (real_p l2 * imag_p l1)%R = (real_p l1 * imag_p l2)%R -> (l1 ||| l2).
Proof.
  intros.
  apply Peirce.
  intros.
  assert ( C0 < l1 )%C.
  apply Lshib_gt_C0.
  assert ( C0 < l2 )%C.
  apply Lshib_gt_C0.
  rewrite Cdecompose in H1,H2.
  simpl in H1,H2.
  destruct (Real_eq_dec 0 (real_p l1)).
  destruct (Real_eq_dec 0 (real_p l2)).
  assert (Cabs l1 = 1 )%R.
  apply Lshib_len1.
  unfold Cabs in H3.
  rewrite <- e in H3.
  replace (0 * 0 + imag_p l1 * imag_p l1)%R with ( imag_p l1 * imag_p l1 )%R in H3; [ idtac | ring ].
  rewrite sqrt_square in H3.
  assert (Cabs l2 = 1 )%R.
  apply Lshib_len1.
  unfold Cabs in H4.
  rewrite <- e0 in H4.
  replace (0 * 0 + imag_p l2 * imag_p l2)%R with ( imag_p l2 * imag_p l2 )%R in H4; [ idtac | ring ].
  rewrite sqrt_square in H4.
  unfold imag_p,real_p in e,e0,H3,H4.
  apply injective_projections.
  rewrite <- e,e0.
  auto.
  rewrite H3,H4.
  auto.
  left; auto.
  left; auto.
  rewrite <- e in H.
  ring_simplify in H.
  apply Rmult_integral in H.
  case H.
  intros.
  elim n.
  auto.
  intros.
  assert ( (0 <> imag_p l1)%R ).
  auto with real.
  elim H4.
  auto.
  destruct ( Real_eq_dec 0 (real_p l2) ).
  rewrite <- e in H.
  ring_simplify in H.
  apply eq_sym in H.
  apply Rmult_integral in H.
  case H.
  intros.
  elim n.
  auto.
  intros.
  assert ( (0 <> imag_p l2)%R ).
  auto with real.
  elim H4.
  auto.
  unfold Is_parallel.
  assert ( imag_p l1 = imag_p l2 /\ real_p l1 = real_p l2).
  apply unique_arg.
  auto.
  auto.
  field [ H ].
  auto with real.
  replace ( (imag_p l1 * imag_p l1 + real_p l1 * real_p l1)%R ) with
  (real_p l1 * real_p l1 +imag_p l1 * imag_p l1)%R ; [ idtac | ring ].
  rewrite <- Cabs2.
  rewrite Lshib_len1.
  replace ( (imag_p l2 * imag_p l2 + real_p l2 * real_p l2)%R ) with
  (real_p l2 * real_p l2 +imag_p l2 * imag_p l2)%R ; [ idtac | ring ].
  rewrite <- Cabs2.
  rewrite Lshib_len1.
  auto.
  unfold imag_p,real_p in H3.
  apply injective_projections.
  apply H3.
  apply H3.
Qed.

Lemma not_parallel_intersect_exists : forall l1 l2 : Line , ~ (l1 ||| l2) -> exists x : Complex , on_line x l1 /\ on_line x l2.
Proof.
  intros.
  unfold on_line.
  remember (real_p l1) as rl1.
  remember (real_p l2) as rl2.
  remember (imag_p l1) as il1.
  remember (imag_p l2) as il2.
  assert ( exists x y : R , rl1 * x + (- il1) * y = (Larz l1)/2 /\ rl2 * x + (- il2) * y = (Larz l2)/2 )%R.
  apply moadele2majhool.
  unfold not.
  intros.
  assert ( (il1 * rl2)%R = (rl1 * il2)%R ).
  rewrite Ropp_mult_distr_l_reverse in H0.
  replace ( (il1 * rl2)%R ) with ( ( - - (il1 * rl2) )%R ).
  rewrite H0.
  ring.
  ring.
  rewrite Rmult_comm in H1.
  rewrite Heqrl1 in H1.
  rewrite Heqrl2 in H1.
  rewrite Heqil1 in H1.
  rewrite Heqil2 in H1.
  apply not_parallel_help in H1.
  auto.
  elim H0.
  intros.
  elim H1.
  intros.
  clear H0 H1.
  destruct H2.
  exists (x,x0).
  rewrite ! Ccojmult.
  rewrite ! Creal_coj.
  split.
  apply injective_projections.
  simpl.
  rewrite Cdecompose with (z:=Lshib l1).
  simpl.
  rewrite <- Heqrl1.
  rewrite <- Heqil1.
  ring_simplify in H0.
  rewrite H0.
  field.
  auto.
  apply injective_projections.
  simpl.
  rewrite Cdecompose with (z:=Lshib l2).
  simpl.
  rewrite <- Heqrl2.
  rewrite <- Heqil2.
  ring_simplify in H1.
  rewrite H1.
  field.
  auto.
Qed.

Infix " |x| " := Line_intersect ( at level 20 ).

Lemma not_parallel_intersect : forall l1 l2 : Line , ~ (l1 ||| l2) -> on_line (l1 |x| l2) l1 /\ on_line (l1 |x| l2) l2.
Proof.
  intros.
  assert ( bk2:=H ).
  apply not_parallel_intersect_exists in H.
  elim H.
  intros.
  assert (bk:=H0).
  destruct H0.
  apply not_parallel_intersect_uniq with (l2:=l2) in H0.
  rewrite <- H0.
  destruct bk.
  auto.
  auto.
  auto.
Qed.

Lemma intersect_sym : forall l1 l2 : Line , ~ (l1 ||| l2) -> l1 |x| l2 = l2 |x| l1.
Proof.
  intros.
  assert ( bk2:=H ).
  apply not_parallel_intersect_exists in H.
  elim H.
  intros.
  apply eq_trans with (y:=x).
  apply eq_sym.
  apply not_parallel_intersect_uniq.
  auto.
  apply H0.
  apply H0.
  apply not_parallel_intersect_uniq.
  unfold Is_parallel.
  apply not_eq_sym.
  auto.
  apply H0.
  apply H0.
Qed.

Lemma Rineq_case : forall a b : R , (a<b \/ b<=a)%R.
Proof.
  intros.
  assert ( { a < b } + { a = b } + { a > b } )%R.
  apply total_order_T.
  destruct H.
  destruct s.
  left; auto.
  right; right; auto.
  right; left; auto.
Qed.

Definition Unitarg ( x : R ) := ( cos x , sin x ).

Lemma Cabs_Unitarg : forall x : R , Cabs (Unitarg x) = 1%R.
Proof.
  intros.
  unfold Unitarg.
  unfold Cabs.
  simpl.
  rewrite sin2c1.
  apply sqrt_1.
Qed.

Lemma Carg_Unitarg : forall x : R , (-PI<x<=PI)%R -> Carg (Unitarg x) = x.
Proof.
  intros.
  apply eq_sym.
  apply Carg_uniq.
  apply Cneq0.
  rewrite Cabs_Unitarg.
  auto with real.
  split.
  auto.
  rewrite Cabs_Unitarg.
  apply injective_projections.
  simpl; ring.
  simpl; ring.
Qed.

Lemma argminusfactor : forall a b : R , (-PI<a<=PI)%R -> (-PI<b<=PI)%R -> -^ ( a +^ b ) = (-^ a) +^ (-^ b).
Proof.
  intros.
  rewrite <- Carg_Unitarg with (x:=a).
  rewrite <- Carg_Unitarg with (x:=b).
  rewrite ! Cmultarg.
  rewrite <- ! Ccojarg.
  rewrite ! Cmultarg.
  f_equal.
  apply eq_sym.
  apply Ccojmult.
  apply Ccoj0.
  apply Cneq0.
  rewrite Cabs_Unitarg.
  auto with real.
  apply Ccoj0.
  apply Cneq0.
  rewrite Cabs_Unitarg.
  auto with real.
  apply Cneq0.
  rewrite Cabs_Unitarg.
  auto with real.
  apply Cneq0.
  rewrite Cabs_Unitarg.
  auto with real.
  apply C0mult.
  auto with real.
  apply Cneq0.
  rewrite Cabs_Unitarg.
  auto with real.
  apply Cneq0.
  rewrite Cabs_Unitarg.
  auto with real.
  auto with real.
  apply Cneq0.
  rewrite Cabs_Unitarg.
  auto with real.
  apply Cneq0.
  rewrite Cabs_Unitarg.
  auto with real.
  auto.
  auto.
Qed.

Lemma argnegPI : -^ PI = PI.
Proof.
  unfold argneg.
  destruct (Real_eq_dec PI PI).
  auto.
  contradiction.
Qed.

Theorem Parallel_angle : forall l1 l2 : Line , l1 ||| l2 -> forall a b c d : Complex , b <> c -> (a<b)%C -> (c<d)%C -> on_line a l1 -> on_line b l1 -> on_line c l2 -> on_line d l2 -> DAngle a b c = DAngle d c b.
Proof.
  intros.
  unfold DAngle.
  assert ( imag_p l1 < 0 \/ 0<= imag_p l1 )%R.
  apply Rineq_case.
  case H7.
  intros.
  replace (a-b)%C with (-(b-a))%C ; [ idtac | ring ].
  rewrite Carg_neg.
  rewrite line_Carg_c2 with (l:=l1).
  rewrite line_Carg_c2 with (l:=l2) (a:=d) (b:=c).
  rewrite H.
  replace (b-c)%C with (-(c-b))%C ; [ idtac | ring ].
  rewrite Carg_neg.
  unfold argminus.
  rewrite argplus_comm.
  rewrite argplus_assoc.
  rewrite argplus_assoc.
  rewrite argminusfactor.
  rewrite argplus_assoc.
  rewrite argnegPI.
  f_equal.
  apply eq_sym.
  rewrite argplus_comm.
  rewrite argplus_assoc.
  auto.
  apply argnegineq.
  apply Carg_def.
  apply argstan_nPI2.
  apply argnegineq.
  apply Carg_def.
  apply argplusineq.
  apply argstan_nPI2.
  apply argnegineq.
  apply Carg_def.
  apply argnegineq.
  apply Carg_def.
  apply argnegineq.
  apply argstan_PI.
  apply Carg_def.
  apply argstan_PI.
  apply argnegineq.
  apply Carg_def.
  apply argstan_nPI2.
  apply argnegineq.
  apply Carg_def.
  apply argnegineq.
  apply Carg_def.
  apply argplusineq.
  apply argstan_nPI2.
  apply argnegineq.
  apply Carg_def.
  apply argstan_PI.
  unfold not; intros.
  apply Ceq_side in H9.
  elim H0.
  auto.
  rewrite <- H.
  auto.
  auto.
  auto.
  auto.
  auto.
  auto.
  auto.
  auto.
  apply not_eq_sym.
  apply Cineq_eq.
  apply Cineq_plus with ( c := (-a)%C ) in H1.
  ring_simplify in H1.
  replace ( - a + b )%C with ( b - a )%C in H1; [ idtac | ring ].
  auto.
  (* Similiar Case :*)
Admitted.


Require Import Coq.ZArith.ZArith Coq.micromega.Lia.
Require Import Crypto.Util.ZUtil.
Require Import Crypto.Util.ZUtil.Definitions.
Require Import Crypto.Util.ZUtil.Hints.ZArith.
Require Import Crypto.Util.Prod.
Require Import Crypto.Util.ZUtil.Tactics.PullPush.Modulo.
Require Import Crypto.Util.ZUtil.Tactics.DivModToQuotRem.
Require Import Crypto.Util.ZUtil.Tactics.LtbToLt.
Require Import Crypto.Util.LetIn.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Tactics.RewriteHyp.
Local Open Scope Z_scope.

Local Notation eta x := (fst x, snd x).

Module Z.
  Section with_bitwidth.
    Context (bitwidth : Z).

    Local Notation ADD := (Z.add_get_carry bitwidth).
    Local Notation ADC := (Z.add_with_get_carry bitwidth).

    Local Arguments Z.pow : simpl never.

    Lemma add_get_carry_to_add_with_get_carry_cps_gen {T} c a b (P : Z -> Z -> Z -> Z -> Z -> T)
      : (let '(a', c1) := ADD a b in
         let '(s, c2) := ADD c a' in
         dlet c := c1 + c2 in
         P a' c1 c2 s c)
        = let '(a', c1) := eta (ADD a b) in
          let '(s, c2) := eta (ADD c a') in
          let '(s, c) := ADC c a b in
          P a' c1 c2 s c.
    Proof.
      unfold Let_In, ADD, ADC, Z.get_carry, Z.add_with_carry; simpl.
      destruct (Z_dec bitwidth 0) as [ [?|?] | ? ].
      { rewrite Z.pow_neg_r by assumption.
        autorewrite with zsimplify.
        reflexivity. }
      { f_equal.
        { push_Zmod; pull_Zmod; apply f_equal2; omega. }
        { Z.div_mod_to_quot_rem; nia. } }
      { subst; autorewrite with zsimplify; f_equal; omega. }
    Qed.

    Lemma add_get_carry_to_add_with_get_carry_cps {T} c a b (P : Z -> Z -> T)
      : (let '(a', c1) := ADD a b in
         let '(s, c2) := ADD c a' in
         dlet c := c1 + c2 in
         P s c)
        = let '(s, c) := ADC c a b in
          P s c.
    Proof.
      apply add_get_carry_to_add_with_get_carry_cps_gen.
    Qed.
  End with_bitwidth.

  Local Ltac easypeasy :=
    repeat progress autounfold;
    break_match; Z.ltb_to_lt; rewrite_hyp ?*; autorewrite with cancel_pair zsimplify;
    solve [repeat (f_equal; try ring)].

  Local Hint Unfold Z.get_carry Z.get_borrow
        Z.add_get_carry_full Z.add_with_get_carry_full
        Z.add_get_carry Z.add_with_get_carry Z.add_with_carry
        Z.sub_get_borrow_full Z.sub_with_get_borrow_full
        Z.sub_get_borrow Z.sub_with_get_borrow Z.sub_with_borrow.

  Lemma add_get_carry_full_mod s x y :
    fst (Z.add_get_carry_full s x y)  = (x + y) mod s.
  Proof. easypeasy. Qed.
  Hint Rewrite add_get_carry_full_mod : to_div_mod.

  Lemma add_get_carry_full_div s x y :
    snd (Z.add_get_carry_full s x y)  = (x + y) / s.
  Proof. easypeasy. Qed.
  Hint Rewrite add_get_carry_full_div : to_div_mod.

  Lemma add_with_get_carry_full_mod s c x y :
    fst (Z.add_with_get_carry_full s c x y)  = (c + x + y) mod s.
  Proof. easypeasy. Qed.
  Hint Rewrite add_with_get_carry_full_mod : to_div_mod.

  Lemma add_with_get_carry_full_div s c x y :
    snd (Z.add_with_get_carry_full s c x y)  = (c + x + y) / s.
  Proof. easypeasy. Qed.
  Hint Rewrite add_with_get_carry_full_div : to_div_mod.

  Lemma sub_with_borrow_to_add_get_carry c x y
    : Z.sub_with_borrow c x y = Z.add_with_carry (-c) x (-y).
  Proof. reflexivity. Qed.

  Lemma sub_get_borrow_full_mod s x y :
    fst (Z.sub_get_borrow_full s x y)  = (x - y) mod s.
  Proof. easypeasy. Qed.
  Hint Rewrite sub_get_borrow_full_mod : to_div_mod.

  Lemma sub_get_borrow_full_div s x y :
    snd (Z.sub_get_borrow_full s x y)  = - ((x - y) / s).
  Proof. easypeasy. Qed.
  Hint Rewrite sub_get_borrow_full_div : to_div_mod.

  Lemma sub_with_get_borrow_full_mod s c x y :
    fst (Z.sub_with_get_borrow_full s c x y)  = (x - y - c) mod s.
  Proof. easypeasy. Qed.
  Hint Rewrite sub_with_get_borrow_full_mod : to_div_mod.

  Lemma sub_with_get_borrow_full_div s c x y :
    snd (Z.sub_with_get_borrow_full s c x y)  = - ((x - y - c) / s).
  Proof. easypeasy. Qed.
  Hint Rewrite sub_with_get_borrow_full_div : to_div_mod.

End Z.


Require Import Common.
Inductive type :=
| Tregfile : forall (size : nat) (base : type0) , type
| Tfifo : nat -> type0 -> type
| Tbase : type0 -> type
| Tinput  : type0 -> type
| Toutput : type0 -> type.

Fixpoint eval_type (t : type) : Type :=
  match t with
    | Tregfile size bt => Regfile.T size (eval_type0 bt)
    | Tfifo n bt => FIFO.T n (eval_type0 bt)
    | Tbase bt => eval_type0 bt
    | Tinput bt => eval_type0 bt
    | Toutput bt => eval_type0 bt
  end.

Definition eval_list_type := eval_env eval_type.

Section expr.
  Variable Env : list type.

  Inductive expr : type0 -> Type :=
  | Eprim : forall f (args: expr_vector (args (f))), expr ( (res (f)))
  | Eget : forall t (v : var Env (Tbase t)), expr t
  (* operations on arrays *)
  | Eget_array : forall size  n t (v : var Env (Tregfile size t)), expr (Tint n) -> expr t
  (* operations on fifo *)
  | Efirst : forall n t (v : var Env (Tfifo n t)), expr t
  | Eisfull : forall n t (v : var Env (Tfifo n t)), expr (Tbool)
  | Eisempty : forall n t (v : var Env (Tfifo n t)), expr (Tbool)
  (* operations on Inputs *)
  | Eget_input : forall t (v : var Env (Tinput t)), expr t
  (* operations on Outputs *)
  | Eget_output : forall t (v : var Env (Toutput t)), expr t

   with expr_vector : list type0 -> Type :=
  | expr_vector_nil : expr_vector nil
  | expr_vector_cons : forall t q, expr  (t) -> expr_vector q -> expr_vector (t::q).

  (* top level expressions *)
  Inductive expr2 : type -> Type :=
  | Eset : forall t , expr t ->  expr2 (Tbase t)
  | Eset_array : forall size n t,
                   expr (Tint n) -> expr t -> expr2 (Tregfile size t)
  (* operations on fifos *)
  | Epush : forall n t, expr t -> expr2 (Tfifo n t)
  | Epop  : forall n t, expr2 (Tfifo n t) (* forgets the first element *)
  | Epushpop : forall n t, expr t -> expr2 (Tfifo n t)
  | Eclear : forall n t, expr2 (Tfifo n t)

  (* set an output *)
  | Eset_output : forall t,  expr t -> expr2 (Toutput t)

  (* do nothing *)
  | Enop : forall t, expr2 t.

  Variable ENV : eval_list_type Env.

  Fixpoint  eval_expr t (e : expr t) : option (eval_type0 t) :=
    match e with
      | Eprim f args =>
          let eval_expr_vector :=
              fix eval_expr_vector l (v : expr_vector l) {struct v} :  option (eval_type0_list l) :=
              match v with
                | expr_vector_nil => Some tt
                | expr_vector_cons hd q e vq =>
                    do hd <- eval_expr hd e;
                    do tl <- eval_expr_vector q vq;
                    Some (hd,tl)
              end
          in
            do args <-  (eval_expr_vector _ args);
          Some (value (f) args)
      | Eget t v => Some (get Env (Tbase t) v ENV)
      | Efirst n bt fifo =>
          let fifo := (get Env (Tfifo n bt) fifo ENV ) in
            @FIFO.first (eval_type0 bt) n  fifo
      | Eisfull n bt fifo =>
          let fifo := (get Env (Tfifo n bt) fifo ENV ) in
            Some (@FIFO.isfull _ n fifo)
      | Eisempty n bt fifo =>
          let fifo := (get  Env (Tfifo n bt) fifo ENV ) in
            Some  (@FIFO.isempty _ n fifo)
      | Eget_input bt x =>
          let x := get  Env (Tinput bt) x ENV in
            Some x
      | Eget_output bt x =>
          let x := get  Env (Toutput bt) x ENV in
            Some x
      | Eget_array size n bt v idx  =>
          let v := get  Env (Tregfile size bt) v ENV in
            do idx <- eval_expr _ idx;
          @Regfile.get size _ v (Word.unsigned idx)
    end.

  Fixpoint eval_expr2 t (e : expr2 t) : eval_type t ->  option (eval_type t) :=
    match e with
      | Eset t e =>
          fun r => eval_expr t e
      | Eset_array size n t adr e =>
          fun v =>
            do adr <- eval_expr _ adr;
            do e <- eval_expr _ e;
            let adr := Word.unsigned adr in
            (* Since Regfile.set silently erases out of bounds
            accesses, we add an extra check here *)
            check (lt_nat_bool adr size);
            Some (@Regfile.set size (eval_type0 t) v adr e)
      | Epush n t e =>
          fun f =>
            do e <- eval_expr t e;
            Some (FIFO.push e f)
      | Epop n t =>
          fun f =>
            @FIFO.pop _ n f
      | Epushpop n t e =>
          fun f =>
            do f <- @FIFO.pop _ n  f;
            do e <- eval_expr t e;
            Some (FIFO.push  e f)
      | Eclear n t =>
          fun f => Some (FIFO.clear  f)
      | Eset_output t e =>
          fun _ => eval_expr t e
      | Enop t => fun x => Some x
    end.
End expr.

(* A transition is parametrized by a memory environment.
   It contains a guard (a boolean expression), and a dependtly-typed list, which ensure that every memory location is updated.  *)

Record transition Env :=
  { pi : expr Env Tbool;
    alpha : dlist (expr2 Env) Env}.

Definition eval_alpha E (alpha : dlist  (expr2 E) E) :
  eval_list_type E -> option (eval_list_type E) :=
  fun  (X : eval_list_type E) =>
    dlist_fold type (expr2 E) eval_type (eval_expr2 E X) E alpha X.

Record ATS :=
  {
    memory : list type;
    transitions : list (transition (memory))
  }.

Definition eval_transition (mem: list type) (tr : transition mem) :
  eval_list_type mem -> option (eval_list_type mem) :=
  fun (E : eval_list_type mem) =>
    let guard := eval_expr mem E Tbool (pi mem tr) in
      match guard with
        | Some true => eval_alpha mem (alpha mem tr) E
        | Some false => None
        | None => None
      end.

Fixpoint eval_transitions mem (l : list (transition mem))  :=
  match l with
    | nil => fun _ _  => True
    | cons t q => union (fun x y => eval_transition mem t x = Some y)
                       (eval_transitions mem q)
  end.

Definition eval (X : ATS) :=
  eval_transitions (memory X) (transitions X).