(*
  Copyright 2022 ZhengPu Shi
  This file is part of CoqMatrix. It is distributed under the MIT
  "expat license". You should have recieved a LICENSE file with it.

  purpose   : Matrix implemented with Function.
  author    : ZhengPu Shi
  date      : 2021.12
 *)

Require Export MatrixTheory.
Require Import Sequence NatFun.Matrix.

(* ######################################################################### *)
(** * Basic matrix theory implemented with NatFun *)

Module BasicMatrixTheoryNF (E : ElementType) <: BasicMatrixTheory E.

  (** Basic library *)
  Export BasicConfig TupleExt SetoidListListExt HierarchySetoid.

  (* ==================================== *)
  (** ** Matrix element type *)
  Export E.

  Global Infix "==" := Aeq : A_scope.
  Global Infix "==" := (eqlistA (eqlistA Aeq)) : dlist_scope.

  Open Scope nat_scope.
  Open Scope A_scope.
  Open Scope mat_scope.

  (* ==================================== *)
  (** ** Matrix type and basic operations *)

  (** We define a _matrix_ as a simple function from two nats
      (corresponding to a row and a column) to a value.
      Note that, r and c are dummy parameters, it is designed to
      represent shape of matrix. *)
  Definition mat (r c : nat) := @mat A r c.

  (* (** matrix equality *) *)
  Definition meq {r c : nat} (m1 m2 : mat r c) : Prop := @meq A Aeq r c m1 m2.
  Global Infix "==" := meq : mat_scope.

  Lemma meq_equiv : forall {r c}, Equivalence (meq (r:=r) (c:=c)).
  Proof.
    intros. apply meq_equiv.
  Qed.

  Global Existing Instance meq_equiv.

  (** Get n-th element of a matrix *)
  Definition mnth {r c} (m : mat r c) (ri ci : nat) := @mnth A r c m ri ci.
  Notation "m ! i ! j" := (mnth m i j).

  (** meq and mnth should satisfy this constraint *)
  Lemma meq_iff_mnth : forall {r c : nat} (m1 m2 : mat r c),
      m1 == m2 <-> (forall ri ci, ri < r -> ci < c -> (m1!ri!ci == m2!ri!ci)%A).
  Proof.
    intros. apply meq_iff_mnth.
  Qed.

  (* ==================================== *)
  (** ** Convert between list list and matrix *)

  (** *** list list to mat *)

  Definition l2m {r c} (dl : list (list A)) : mat r c := @l2m A A0 r c dl.

  (** l2m is a proper morphism *)
  Lemma l2m_aeq_mor : forall r c, Proper (eqlistA (eqlistA Aeq) ==> meq) (@l2m r c).
  Proof.
    Admitted.

  Global Existing Instance l2m_aeq_mor.

  Lemma l2m_inj : forall {r c} (d1 d2 : list (list A)),
      length d1 = r -> width d1 c ->
      length d2 = r -> width d2 c ->
      ~(d1 == d2)%dlist -> ~(@l2m r c d1 == l2m d2).
  Proof.
    intros. apply l2m_inj; auto.
  Qed.

  Lemma l2m_surj : forall {r c} (m : mat r c),
      (exists d, l2m d == m).
  Proof.
    intros. apply l2m_surj.
  Qed.

  (** *** mat to list list *)
  Definition m2l {r c} (m : mat r c) : list (list A) := @m2l A r c m.

  (** m2l is a proper morphism *)
  Lemma m2l_aeq_mor : forall r c, Proper (meq ==> eqlistA (eqlistA Aeq)) (@m2l r c).
  Proof.
    Admitted.

  Global Existing Instance m2l_aeq_mor.

  Lemma m2l_length : forall {r c} (m : mat r c), length (m2l m) = r.
  Proof.
    intros. apply m2l_length.
  Qed.

  Global Hint Resolve m2l_length : mat.

  Lemma m2l_width : forall {r c} (m : mat r c), width (m2l m) c.
  Proof.
    intros. apply m2l_width.
  Qed.

  Global Hint Resolve m2l_width : mat.

  Lemma m2l_l2m_id : forall {r c} (dl : list (list A)) (H1 : length dl = r)
                       (H2 : width dl c), (@m2l r c (l2m dl) == dl)%dlist.
  Proof.
    intros. apply m2l_l2m_id; auto.
  Qed.

  Lemma l2m_m2l_id : forall {r c} (m : mat r c), l2m (m2l m) == m.
  Proof.
    intros. apply l2m_m2l_id; auto.
  Qed.

  Lemma m2l_inj : forall {r c} (m1 m2 : mat r c),
      ~(m1 == m2) -> ~(m2l m1 == m2l m2)%dlist.
  Proof.
    intros. apply (m2l_inj (A0:=A0)). easy.
  Qed.

  Lemma m2l_surj : forall {r c} (d : list (list A)),
      length d = r -> width d c ->
      (exists m, @m2l r c m == d)%dlist.
  Proof.
    intros. apply (m2l_surj (A0:=A0)); auto.
  Qed.

  (* ==================================== *)
  (** ** Specific matrix *)

  Definition mk_mat_1_1 (a11 : A) : mat 1 1 := mk_mat_1_1 (A0:=A0) a11.

  Definition mk_mat_3_1 (a1 a2 a3 : A) : mat 3 1 := mk_mat_3_1 (A0:=A0) a1 a2 a3.

  Definition mk_mat_4_1 (a1 a2 a3 a4 : A) : mat 4 1 :=
    mk_mat_4_1 (A0:=A0) a1 a2 a3 a4.

  Definition mk_mat_3_3 (a11 a12 a13 a21 a22 a23 a31 a32 a33 : A) : mat 3 3
    := mk_mat_3_3 (A0:=A0) a11 a12 a13 a21 a22 a23 a31 a32 a33.

  Definition mk_mat_4_4 (a11 a12 a13 a14 a21 a22 a23 a24
                           a31 a32 a33 a34 a41 a42 a43 a44 : A) : mat 4 4
    := mk_mat_4_4 (A0:=A0)
         a11 a12 a13 a14 a21 a22 a23 a24
         a31 a32 a33 a34 a41 a42 a43 a44.

  Definition mk_mat_2_2 (a11 a12 a21 a22 : A) : mat 2 2
    := mk_mat_2_2 (A0:=A0) a11 a12 a21 a22.

  (* ==================================== *)
  (** ** Convert between tuples and matrix *)

  (** tuple_3x3 -> mat_3x3 *)
  Definition t2m_3x3 (t : @T_3x3 A) : mat 3 3 := t2m_3x3 (A0:=A0) t.

  (** mat_3x3 -> tuple_3x3 *)
  Definition m2t_3x3 (m : mat 3 3) : @T_3x3 A := m2t_3x3 m.

  (** m[0,0] : mat_1x1 -> A *)
  Definition scalar_of_mat (m : mat 1 1) := m!0!0.

  (* ==================================== *)
  (** ** Matrix transposition *)

  Definition mtrans {r c} (m : mat r c): mat c r :=
    @mtrans A r c m.

  Global Notation "m \T" := (mtrans m) : mat_scope.

  Lemma mtrans_trans : forall {r c} (m : mat r c), mtrans (mtrans m) == m.
  Proof.
    intros. apply mtrans_trans.
  Qed.

  (* ==================================== *)
  (** ** Mapping of matrix *)

  (** Mapping of a matrix *)
  Definition mmap {r c} (f : A -> A) (m : mat r c) : mat r c := @mmap A r c f m.

  Definition mmap2 {r c} (f: A -> A -> A) (m1 m2: mat r c) : mat r c :=
    @mmap2 A r c f m1 m2.

  Lemma mmap2_comm : forall {r c} (f : A -> A -> A)
                       (f_comm : forall a b : A, (f a b == f b a)%A)
                       (m1 m2 : mat r c),
      mmap2 f m1 m2 == mmap2 f m2 m1.
  Proof.
    (* lma. (* this tactic is enough too. *) *)
    intros. apply mmap2_comm. auto.
  Qed.

  Lemma mmap2_assoc : forall {r c} (f : A -> A -> A)
                        (f_assoc : forall a b c, (f (f a b) c == f a (f b c))%A)
                        (m1 m2 m3 : mat r c),
      mmap2 f (mmap2 f m1 m2) m3 == mmap2 f m1 (mmap2 f m2 m3).
  Proof.
    intros. apply mmap2_assoc. auto.
  Qed.

  (** Auto unfold these definitions *)
  Global Hint Unfold meq mmap mmap2 : mat.

  (** linear matrix arithmetic tactic for equation: split goal to every element *)
  Global Ltac lma :=
    autounfold with mat;
    Matrix.lma.

End BasicMatrixTheoryNF.

(* ######################################################################### *)
(** * Decidable matrix theory implemented with NatFun *)

Module DecidableMatrixTheoryNF (E : DecidableElementType) <: DecidableMatrixTheory E.

  (* Export E. *)
  Include BasicMatrixTheoryNF E.

  (** linear matrix arithmetic tactic for equation: split goal to every element *)

  (** meq is decidable *)
  Lemma meq_dec : forall {r c}, Decidable (meq (r:=r)(c:=c)).
  Proof.
    intros. apply @meq_dec. apply Dec_Aeq.
  Qed.

End DecidableMatrixTheoryNF.

(* ######################################################################### *)
(** * Ring matrix theory implemented with NatFun *)

Module RingMatrixTheoryNF (E : RingElementType) <: RingMatrixTheory E.

  (* Export E. *)
  Include BasicMatrixTheoryNF E.

  Add Ring ring_thy_inst : Ring_thy.

  (** Zero matrix *)
  Definition mat0 r c : mat r c := @mat0 A A0 r c.

  (** Unit matrix *)
  Definition mat1 n : mat n n := @mat1 A A0 A1 n.

  (** *** Addition of matrix *)

  (** Tips, we must write the full signature, especially the explicit parameter {r c}
      and the return type {mat r c}, to maintain a type inference relation.
      Because only {m1 m2 : mat r c} havn't any information of {r} and {c}.
      Otherwise, the "+" notation will useless.
   *)
  Definition madd {r c} (m1 m2 : mat r c) : mat r c := @madd A Aadd r c m1 m2.
  Infix "+" := madd : mat_scope.

  (** m1 + m2 = m2 + m1 *)
  Lemma madd_comm : forall {r c} (m1 m2 : mat r c), m1 + m2 == m2 + m1.
  Proof.
    intros. apply madd_comm.
  Qed.

  (** (m1 + m2) + m3 = m1 + (m2 + m3) *)
  Lemma madd_assoc : forall {r c} (m1 m2 m3 : mat r c), (m1 + m2) + m3 == m1 + (m2 + m3).
  Proof.
    intros. apply madd_assoc.
  Qed.

  (** 0 + m = m *)
  Lemma madd_0_l : forall {r c} (m : mat r c), (mat0 r c) + m == m.
  Proof.
    intros. apply madd_0_l.
  Qed.

  (** m + 0 = m *)
  Lemma madd_0_r : forall {r c} (m : mat r c), m + (mat0 r c) == m.
  Proof.
    intros. apply madd_0_r.
  Qed.

  (** *** Opposite of matrix *)

  Definition mopp {r c} (m : mat r c) : mat r c := @mopp A Aopp r c m.
  Global Notation "- m" := (mopp m) : mat_scope.

  (** - - m = m *)
  Lemma mopp_opp : forall {r c} (m : mat r c), - - m == m.
  Proof.
    intros. apply mopp_opp.
  Qed.

  (** m + (-m) = 0 *)
  Lemma madd_opp : forall {r c} (m : mat r c), m + (-m) == mat0 r c.
  Proof.
    intros. apply madd_opp.
  Qed.

  (** *** Subtraction of matrix *)

  Definition msub {r c} (m1 m2 : mat r c) : mat r c := @msub A Aadd Aopp r c m1 m2.
  Infix "-" := msub : mat_scope.

  (** m1 - m2 = - (m2 - m1) *)
  Lemma msub_comm : forall {r c} (m1 m2 : mat r c), m1 - m2 == - (m2 - m1).
  Proof.
    intros. apply msub_comm.
  Qed.
  (** (m1 - m2) - m3 = m1 - (m2 + m3) *)
  Lemma msub_assoc : forall {r c} (m1 m2 m3 : mat r c), (m1 - m2) - m3 == m1 - (m2 + m3).
  Proof.
    intros. apply msub_assoc.
  Qed.

  (** 0 - m = - m *)
  Lemma msub_0_l : forall {r c} (m : mat r c), (mat0 r c) - m == - m.
  Proof.
    intros. apply msub_0_l.
  Qed.

  (** m - 0 = m *)
  Lemma msub_0_r : forall {r c} (m : mat r c), m - (mat0 r c) == m.
  Proof.
    intros. apply msub_0_r.
  Qed.

  (** m - m = 0 *)
  Lemma msub_self : forall {r c} (m : mat r c), m - m == (mat0 r c).
  Proof.
    intros. apply msub_self.
  Qed.

  (** *** Scalar multiplication of matrix *)

  (** Left scalar multiplication of matrix *)
  Definition mcmul {r c} (a : A) (m : mat r c) : mat r c :=
    @mcmul A Amul r c a m.
  Notation "a c* m" := (mcmul a m) : mat_scope.

  (** Right scalar multiplication of matrix *)
  Definition mmulc {r c} (m : mat r c) (a : A) : mat r c :=
    @mmulc A Amul r c m a.
  Notation "m *c a" := (mmulc m a) : mat_scope.

  (** m *c a = a c* m *)
  Lemma mmulc_eq_mcmul : forall {r c} (a : A) (m : mat r c), m *c a == a c* m.
  Proof.
    intros. apply mmulc_eq_mcmul.
  Qed.

  (** a * (b * m) = (a * b) * m *)
  Lemma mcmul_assoc : forall {r c} (a b : A) (m : mat r c), a c* (b c* m) == (a * b)%A c* m.
  Proof.
    intros. apply mcmul_assoc.
  Qed.

  (** a * (b * m) = b * (a * m) *)
  Lemma mcmul_perm : forall {r c} (a b : A) (m : mat r c), a c* (b c* m) == b c* (a c* m).
  Proof.
    intros. apply mcmul_perm.
  Qed.

  (** a * (m1 + m2) = (a * m1) + (a * m2) *)
  Lemma mcmul_add_distr_l : forall {r c} (a : A) (m1 m2 : mat r c),
      a c* (m1 + m2) == (a c* m1) + (a c* m2).
  Proof.
    intros. apply mcmul_add_distr_l.
  Qed.

  (** (a + b) * m = (a * m) + (b * m) *)
  Lemma mcmul_add_distr_r : forall {r c} (a b : A) (m : mat r c),
      (a + b)%A c* m == (a c* m) + (b c* m).
  Proof.
    intros. apply mcmul_add_distr_r.
  Qed.

  (** 0 * m = 0 *)
  Lemma mcmul_0_l : forall {r c} (m : mat r c), A0 c* m == mat0 r c.
  Proof.
    intros. apply mcmul_0_l.
  Qed.

  (** 1 * m = m *)
  Lemma mcmul_1_l : forall {r c} (m : mat r c), A1 c* m == m.
  Proof.
    intros. apply mcmul_1_l.
  Qed.

  (** *** Multiplication of matrix *)

  Definition mmul {r c s} (m1 : mat r c) (m2 : mat c s) : mat r s :=
    @mmul A Aadd A0 Amul r c s m1 m2.

  Global Infix "*" := mmul : mat_scope.

  (** m1 * (m2 + m3) = (m1 * m2) + (m1 * m3) *)
  Lemma mmul_add_distr_l : forall {r c s} (m1 : mat r c) (m2 m3 : mat c s),
      m1 * (@madd c s m2 m3) == @madd r s (m1 * m2) (m1 * m3).
  Proof.
    intros. apply mmul_add_distr_l.
  Qed.

  (** (m1 + m2) * m3 = (m1 * m3) + (m2 * m3) *)
  Lemma mmul_add_distr_r : forall {r c s} (m1 m2 : mat r c) (m3 : mat c s),
      (@madd r c m1 m2) * m3 == @madd r s (m1 * m3) (m2 * m3).
  Proof.
    intros. apply mmul_add_distr_r.
  Qed.

  (** (m1 * m2) * m3 = m1 * (m2 * m3) *)
  Lemma mmul_assoc : forall {r c s t} (m1 : mat r c) (m2 : mat c s) (m3 : mat s t),
      (m1 * m2) * m3 == m1 * (m2 * m3).
  Proof.
    intros. apply mmul_assoc.
  Qed.

  (** mat0 * m = mat0 *)
  Lemma mmul_0_l : forall {r c s} (m : mat c s), (mat0 r c) * m == mat0 r s.
  Proof.
    intros. apply mmul_0_l.
  Qed.

  (** m * mat0 = mat0 *)
  Lemma mmul_0_r : forall {r c s} (m : mat r c), m * (mat0 c s) == mat0 r s.
  Proof.
    intros. apply mmul_0_r.
  Qed.

  (** mat1 * m = m *)
  Lemma mmul_1_l : forall {r c} (m : mat r c), (mat1 r) * m == m.
  Proof.
    intros. apply mmul_1_l.
  Qed.

  (** m * mat1 = m *)
  Lemma mmul_1_r : forall {r c} (m : mat r c), m * (mat1 c) == m.
  Proof.
    intros. apply mmul_1_r.
  Qed.

  (** Auto unfold these definitions *)
  Global Hint Unfold madd mopp msub mcmul mmul : mat.

End RingMatrixTheoryNF.

(* ######################################################################### *)
(** * Decidable Field matrix theory implemented with NatFun *)

Module DecidableFieldMatrixTheoryNF (E : DecidableFieldElementType)
<: DecidableFieldMatrixTheory E.

  (* Export E. *)
  Include RingMatrixTheoryNF E.
  (* Module Export DecMT := DecidableMatrixTheoryNF E. *)

  (** meq is decidable *)
  Lemma meq_dec : forall (r c : nat), Decidable (meq (r:=r) (c:=c)).
  Proof.
    intros. apply meq_dec.
  Qed.

  (** ** matrix theory *)

End DecidableFieldMatrixTheoryNF.

(** Test *)
Module Test.
  (* Export QArith. *)
  Module Export MatrixQ := RingMatrixTheoryNF RingElementTypeQ.
  Open Scope Q.
  Open Scope mat_scope.

  Definition m3 := mk_mat_3_3 1 2 3 4 5 6 7 8 9.
  (* Compute m2l (m3 + m3). *)
  (* Compute m2l (m3 * m3). *)

End Test.


Set Implicit Arguments.
Unset Strict Implicit.

Require Export basics.

Section enat.

Ltac G x := generalize x.

Ltac BAD := intros BAD; inversion BAD.

(*
 * extended nat
 *)
Inductive inat :=
 | Fix : nat -> inat
 | Inf : inat
.

Lemma not_inf_eq_fix x : (Inf = Fix x) <-> False.
split; [BAD|tauto].
Qed.

Lemma eq_fix x y: (Fix x)=(Fix y) <-> x=y.
split; auto.
intros EQ; inversion EQ; auto.
Qed.

Lemma fix_eq_fix x y : (Fix x)=(Fix y) <-> (x=y).
split; intros EQ; inversion EQ; auto.
Qed.

Lemma contra_inf x : ~(exists t, x=(Fix t)) -> x=Inf.
apply contra.
rewrite not_not.
case x; [|intros BAD;exfalso; apply BAD; auto].
intros n _; exists n; auto.
Qed.

(* ilt *)
Definition ilt (x y : inat) : Prop := match x,y with
 | (Fix n),(Fix m) => n<m
 | (Fix n),Inf => True
 | Inf,_ => False
end.

Lemma inat_compare x y : (ilt x y) \/ (x=y) \/ (ilt y x).
case x; case y; intros; simpl; auto.
G (nat_compare n0 n); intros [LT|[EQ|GT]].
- left; auto.
- right; left; auto.
- right; right; auto.
Qed.

Lemma ilt__0 (x:inat) : ~(ilt x (Fix 0)).
case x as [x|]; simpl; [auto with arith|auto].
Qed.

Lemma ilt_left_is_fix x y :  (ilt x y) -> (exists n, x=(Fix n)).
case x;[intros n _|BAD].
exists n; auto.
Qed.

Lemma ilt__inf x : (ilt (Fix x) Inf).
simpl; auto.
Qed.

Lemma not_ilt_inf_left x : ~(ilt Inf x).
case x; auto.
Qed.

Lemma ilt_irrefl x : ~(ilt x x).
case x; [apply lt_irrefl|auto].
Qed.

Lemma ilt_asym x y : (ilt x y) -> (ilt y x) -> False.
case x as [x |]; case y as [y |]; simpl; auto.
apply lt_asym.
Qed.

Lemma lt_ilt x y : (x < y) -> (ilt (Fix x) (Fix y)).
auto.
Qed.

Lemma lt_0ilt x y : (x < y) -> (ilt (Fix 0) (Fix y)).
intros LT.
apply (lt_ilt (lt_0lt LT)).
Qed.

(* ile *)
Definition ile (x y : inat) : Prop := (ilt x y) \/ (x=y).

Lemma ile__not_ilt x y : (ile x y) <-> ~(ilt y x).
unfold ile; case x as [x|]; case y as [y|]; simpl; auto; try tauto.
- rewrite eq_fix, <- le_fix_def.
  apply le__not_lt.
- rewrite not_inf_eq_fix; tauto.
Qed.

Lemma ile0 (x:inat) : (ile (Fix 0) x).
case x as [n|]; [|left;simpl;auto].
case n; [right|left];simpl;[auto|auto with arith].
Qed.

Lemma ile_inf x : (ile x Inf).
unfold ile.
case x as [|x];[left | right]; simpl; auto.
Qed.

Lemma ile_refl x : (ile x x).
unfold ile; case x as [n|]; simpl; auto.
Qed.

Lemma ile_antisym x y : (ile x y) -> (ile y x) -> x=y.
unfold ile.
intros [LT1 | EQ1] [LT2|EQ2]; auto.
exfalso; apply (ilt_asym LT1 LT2).
Qed.

Lemma eq_ile x y : (x=y) -> (ile x y).
intros EQ; rewrite EQ; apply ile_refl.
Qed.

Lemma eq_ile2 x y : (y=x) -> (ile x y).
intros EQ; rewrite EQ; apply ile_refl.
Qed.

Lemma ile_fix x y : (ile (Fix x) (Fix y)) <-> (x<=y).
unfold ile. simpl.
rewrite fix_eq_fix, le_fix_def; tauto.
Qed.

Lemma ilt_ile x y : (ilt x y) -> (ile x y).
unfold ile; auto.
Qed.

Lemma ilt__not_ile x y : (ilt x y) <-> ~(ile y x).
rewrite ile__not_ilt, not_not; tauto.
Qed.

Lemma not_ile_inf_left x : ~ (ile Inf (Fix x)).
unfold ile.
intros [LT|EQ]; auto.
inversion EQ.
Qed.

Lemma diff_ile_ilt x y :
 (y<>x) ->
 (ile x y) ->
 (ilt x y).
unfold ile. intros DI [LT|EQ]; [auto|exfalso]; auto.
Qed.

Lemma inat_compare_lt_le x y : (ilt x y) \/ (ile y x).
G (inat_compare x y);intros [LT|[EQ|GT]];
[left|right;rewrite EQ;apply ile_refl|right;apply ilt_ile]; auto.
Qed.

Lemma ilt_ileS x y : (ilt (Fix x) y) -> (ile (Fix (S x)) y).
unfold ile; case y as [y|]; simpl; auto.
rewrite eq_fix.
rewrite <- le_fix_def.
auto with arith.
Qed.

Lemma ilt_succ (x:nat) (y:inat) : (ilt (Fix (S x)) y) -> (ilt (Fix x) y).
case y as [y|]; auto; simpl; auto with arith.
Qed.

Lemma ilt_trans  x y z : (ilt x y) -> (ilt y z) -> (ilt x z).
case x; case y; case z; simpl; auto; intros a b c.
- apply lt_trans.
- BAD.
Qed.

Lemma ile_trans x y z : (ile x y) -> (ile y z) -> (ile x z).
unfold ile.
intros [LT1 | EQ1] [LT2 | EQ2];[left|left|left|right].
- apply (ilt_trans LT1 LT2).
- rewrite <- EQ2; auto.
- rewrite EQ1; auto.
- rewrite EQ1; auto.
Qed.

Lemma ile_ilt_trans x y z : (ile x y) -> (ilt y z) -> (ilt x z).
unfold ile.
intros [LT | EQ].
- apply ilt_trans; auto.
- rewrite EQ; auto.
Qed.

Lemma le_ilt_trans x y z : (x <= y) -> (ilt (Fix y) z) -> (ilt (Fix x) z).
unfold ilt.
case z; auto.
apply le_lt_trans.
Qed.

Lemma lt_ilt_trans x y z : (x<y) -> (ilt (Fix y) z) -> (ilt (Fix x) z).
case z as [z|]; [apply lt_trans | auto].
Qed.

Lemma le_ile_trans x y z : (le x y) -> (ile (Fix y) z) -> (ile (Fix x) z).
unfold ile; rewrite le_fix_def.
intros [LT1 | EQ1] [LT2 | EQ2];[left|left|left|right].
- apply (lt_ilt_trans LT1 LT2).
- rewrite <- EQ2; auto.
- rewrite EQ1; auto.
- rewrite EQ1; auto.
Qed.

Lemma ilt_ile_trans x y z : (ilt x y) -> (ile y z) -> (ilt x z).
unfold ile.
intros LT1 [LT | EQ].
- apply (ilt_trans LT1 LT); auto.
- rewrite <- EQ; auto.
Qed.

Lemma lt_iltS_trans x y z :
(x < y) ->
(y < z) ->
(ilt (Fix (S x)) (Fix z)).
simpl.
intros LT1 LT2.
apply (le_lt_trans (lt_leS LT1) LT2).
Qed.

(* fiadd *)
Definition fiadd (x:nat) (y:inat) := match y with
 | (Fix y) => (Fix (x+y))
 | Inf => Inf
end.

End enat.


Definition T := nat.

Definition le := le.

Hint Unfold le.

Lemma le_refl : forall n : nat, le n n.
  auto.
Qed.

Require Import Le.

Lemma le_trans : forall n m k : nat, le n m -> le m k -> le n k.
   eauto with arith.
Qed.

Lemma le_antis : forall n m : nat, le n m -> le m n -> n = m.
   eauto with arith.
Qed.


From Ordinal Require Import sflib Basics.
From Ordinal Require Import ClassicalOrdinal WfRel.
From Ordinal Require Export Ordinal.

Require Import FunctionalExtensionality PropExtensionality.
Require Import Program. (* Axiom K *)

Set Implicit Arguments.
Set Primitive Projections.

Module ToSet.
  Definition union_set (A: Type) (Ts: A -> Type): Type := @sigT A (fun a => option (Ts a)).

  Inductive union_rel (A: Type)
            (Ts: A -> Type) (R: forall a, Ts a -> Ts a -> Prop):
    union_set Ts -> union_set Ts -> Prop :=
  | union_rel_top
      a x
    :
      union_rel R (existT _ a (Some x)) (existT _ a None)
  | union_rel_normal
      a x0 x1
      (LT: R a x0 x1)
    :
      union_rel R (existT _ a (Some x0)) (existT _ a (Some x1))
  .

  (* TODO: axiom K necessary? *)
  Lemma union_rel_well_founded (A: Type) (Ts: A -> Type)
        (R: forall a, Ts a -> Ts a -> Prop)
        (WF: forall a, well_founded (R a))
    :
      well_founded (union_rel R).
  Proof.
    assert (forall a x, Acc (union_rel R) (existT _ a (Some x))).
    { intros a. eapply (well_founded_induction (WF a)); auto.
      i. econs. i. dependent destruction H0. eapply H; eauto. }
    ii. destruct a as [a [x|]]; eauto.
    econs. i. inv H0; eauto.
  Qed.

  Lemma from_wf_union (A: Type) (Ts: A -> Type)
        (R: forall a, Ts a -> Ts a -> Prop)
        (WF: forall a, well_founded (R a))
        (a: A) (x: Ts a)
    :
      Ord.eq (Ord.from_wf (WF a) x)
             (Ord.from_wf (union_rel_well_founded R WF) (existT _ a (Some x))).
  Proof.
    revert x. eapply (well_founded_induction (WF a)).
    i. split.
    { eapply Ord.from_wf_supremum. i. specialize (H _ LT). inv H.
      eapply Ord.le_lt_lt; eauto. eapply Ord.lt_from_wf. econs; eauto. }
    { eapply Ord.from_wf_supremum. i. dependent destruction LT.
      specialize (H _ LT). inv H.
      eapply Ord.le_lt_lt; eauto. eapply Ord.lt_from_wf. auto. }
  Qed.

  Lemma from_wf_set_union (A: Type) (Ts: A -> Type)
        (R: forall a, Ts a -> Ts a -> Prop)
        (WF: forall a, well_founded (R a))
    :
      Ord.eq (@Ord.build A (fun a => Ord.from_wf_set (WF a)))
             (Ord.from_wf_set (union_rel_well_founded R WF)).
  Proof.
    Local Transparent Ord.from_wf_set.
    split.
    { econs. i. exists (existT _ a0 None). eapply Ord.build_supremum. i.
      eapply (@Ord.le_lt_lt (Ord.from_wf (union_rel_well_founded R WF) (existT _ a0 (Some a)))).
      { eapply from_wf_union. }
      { eapply Ord.lt_from_wf. econs. }
    }
    { econs. i. destruct a0 as [a0 [x|]].
      { exists a0. transitivity (Ord.from_wf (WF a0) x).
        { eapply from_wf_union. }
        { eapply Ord.lt_le. eapply Ord.from_wf_set_upperbound. }
      }
      { exists a0. eapply Ord.from_wf_supremum. i.
        dependent destruction LT.
        eapply (@Ord.le_lt_lt (Ord.from_wf (WF a0) x)).
        { eapply from_wf_union. }
        { eapply Ord.from_wf_set_upperbound. }
      }
    }
  Qed.

  Fixpoint to_set (o: Ord.t): @sigT Type (fun A => A -> A -> Prop) :=
    match o with
    | @Ord.build A os => existT
                           _
                           (union_set (fun a => projT1 (to_set (os a))))
                           (union_rel (fun a => projT2 (to_set (os a))))
    end.

  Lemma to_set_well_founded: forall o, well_founded (projT2 (to_set o)).
  Proof.
    induction o. ss. eapply union_rel_well_founded; auto.
  Defined.

  Lemma to_set_eq o:
    Ord.eq o (Ord.from_wf_set (to_set_well_founded o)).
  Proof.
    induction o. etransitivity.
    2: { eapply from_wf_set_union. }
    split.
    { econs. i. exists a0. eapply H. }
    { econs. i. exists a0. eapply H. }
  Qed.

  Section TOTALIFY.
    Variable A: Type.
    Variable R: A -> A -> Prop.
    Hypothesis WF: well_founded R.

    Definition equiv_class: Type :=
      @sig (A -> Prop) (fun s => (exists a, s a) /\
                                 (forall a0 a1 (IN0: s a0), s a1 <-> Ord.eq (Ord.from_wf WF a0) (Ord.from_wf WF a1))).

    Lemma equiv_class_same_ord (s: equiv_class) (a0 a1: A)
          (IN0: proj1_sig s a0) (IN1: proj1_sig s a1)
      :
        Ord.eq (Ord.from_wf WF a0) (Ord.from_wf WF a1).
    Proof.
      destruct s. ss. des. eapply a2; auto.
    Qed.

    Program Definition to_equiv_class (a0: A): equiv_class :=
      exist _ (fun a1 => Ord.eq (Ord.from_wf WF a0) (Ord.from_wf WF a1)) _.
    Next Obligation.
      split.
      { exists a0. reflexivity. }
      { i. split; i.
        - transitivity (Ord.from_wf WF a0); eauto. symmetry. auto.
        - transitivity (Ord.from_wf WF a1); eauto.
      }
    Qed.

    Let to_equiv_class_equiv a (s: equiv_class) (IN: proj1_sig s a):
      s = to_equiv_class a.
    Proof.
      destruct s. ss. unfold to_equiv_class.
      assert (x = (fun a1 : A => Ord.eq (Ord.from_wf WF a) (Ord.from_wf WF a1))).
      { extensionality a1. eapply propositional_extensionality. des. split.
        { i. eapply a2; eauto. }
        { i. eapply a2; eauto. }
      }
      subst. f_equal. eapply proof_irrelevance.
    Qed.

    Definition equiv_class_rel: equiv_class -> equiv_class -> Prop :=
      fun s0 s1 => exists a0 a1, (proj1_sig s0) a0 /\ (proj1_sig s1) a1 /\ Ord.lt (Ord.from_wf WF a0) (Ord.from_wf WF a1).

    Lemma to_equiv_class_preserve a0 a1 (LT: R a0 a1):
      equiv_class_rel (to_equiv_class a0) (to_equiv_class a1).
    Proof.
      exists a0, a1. ss. splits.
      - reflexivity.
      - reflexivity.
      - eapply Ord.lt_from_wf; auto.
    Qed.

    Lemma equiv_class_rel_trans s0 s1 s2
          (LT0: equiv_class_rel s0 s1) (LT1: equiv_class_rel s1 s2)
      :
        equiv_class_rel s0 s2.
    Proof.
      unfold equiv_class_rel in *. des. esplits; eauto.
      transitivity (Ord.from_wf WF a3); auto.
      eapply Ord.eq_lt_lt; eauto.
      eapply equiv_class_same_ord; eauto.
    Qed.

    Let _equiv_class_extensional s0 s1
          (EXT: forall s, equiv_class_rel s s0 <-> equiv_class_rel s s1)
          a
          (IN: proj1_sig s0 a)
      :
        proj1_sig s1 a.
    Proof.
      Local Transparent Ord.from_wf.
      assert (exists a', proj1_sig s1 a').
      { eapply (proj2_sig s1). }
      des. eapply (proj2_sig s1); eauto.
      eapply Ord.eq_ext. i. split.
      { i. unfold Ord.from_wf in H0. destruct (WF a').
        eapply Ord.lt_proj in H0. des. ss. destruct a1; ss.
        hexploit to_equiv_class_preserve; eauto. i.
        assert (equiv_class_rel (to_equiv_class x) s0).
        { eapply EXT. replace s1 with (to_equiv_class a'); auto.
          apply to_equiv_class_equiv in H. auto. }
        unfold equiv_class_rel in H2. des. ss.
        eapply Ord.lt_eq_lt.
        { eapply (proj2_sig s0); eauto. }
        eapply Ord.le_lt_lt; eauto.
        eapply Ord.le_lt_lt; eauto.
        eapply Ord.le_eq_le.
        { symmetry. eauto. }
        eapply Ord.same_acc_le.
      }
      { i. unfold Ord.from_wf in H0. destruct (WF a).
        eapply Ord.lt_proj in H0. des. ss. destruct a1; ss.
        hexploit to_equiv_class_preserve; eauto. i.
        assert (equiv_class_rel (to_equiv_class x) s1).
        { eapply EXT. replace s0 with (to_equiv_class a); auto.
          apply to_equiv_class_equiv in IN. auto. }
        unfold equiv_class_rel in H2. des. ss.
        eapply Ord.lt_eq_lt.
        { eapply (proj2_sig s1); eauto. }
        eapply Ord.le_lt_lt; eauto.
        eapply Ord.le_lt_lt; eauto.
        eapply Ord.le_eq_le.
        { symmetry. eauto. }
        eapply Ord.same_acc_le.
      }
    Qed.

    Lemma equiv_class_extensional s0 s1
          (EXT: forall s, equiv_class_rel s s0 <-> equiv_class_rel s s1)
      :
        s0 = s1.
    Proof.
      assert (proj1_sig s0 = proj1_sig s1).
      { extensionality a. eapply propositional_extensionality. split; i.
        - eapply _equiv_class_extensional; eauto.
        - eapply _equiv_class_extensional; eauto.
          i. symmetry. auto.
      }
      destruct s0, s1. ss. subst. f_equal. eapply proof_irrelevance.
    Qed.

    Lemma equiv_class_well_founded: well_founded equiv_class_rel.
    Proof.
      assert (forall (o: Ord.t), forall (s: equiv_class) a0 (IN: proj1_sig s a0) (LT: Ord.lt (Ord.from_wf WF a0) o), Acc equiv_class_rel s).
      { eapply (well_founded_induction Ord.lt_well_founded (fun o => forall (s: equiv_class) a0 (IN: proj1_sig s a0) (LT: Ord.lt (Ord.from_wf WF a0) o), Acc equiv_class_rel s)).
        i. econs. i. unfold equiv_class_rel in H0. des.
        hexploit (proj2 (proj2_sig s) a0 a2); auto. i. dup H1.
        eapply H3 in H4. clear H3. eapply (H (Ord.from_wf WF a0)); eauto.
        eapply Ord.lt_eq_lt; eauto.
      }
      ii. hexploit (proj2_sig a); eauto. i. des.
      hexploit (H (Ord.S (Ord.from_wf WF a0))); eauto. eapply Ord.S_lt.
    Qed.

    Lemma to_equiv_class_eq a:
      Ord.eq (Ord.from_wf WF a) (Ord.from_wf equiv_class_well_founded (to_equiv_class a)).
    Proof.
      assert (forall (o: Ord.t), forall a (LT: Ord.lt (Ord.from_wf WF a) o), Ord.eq (Ord.from_wf WF a) (Ord.from_wf equiv_class_well_founded (to_equiv_class a))).
      { eapply (well_founded_induction Ord.lt_well_founded (fun o => forall a (LT: Ord.lt (Ord.from_wf WF a) o), Ord.eq (Ord.from_wf WF a) (Ord.from_wf equiv_class_well_founded (to_equiv_class a)))).
        i. split.
        { eapply Ord.from_wf_supremum. i. dup LT0. eapply (Ord.lt_from_wf WF) in LT0; eauto.
          hexploit H; eauto. i. eapply Ord.le_lt_lt; [eapply H0|].
          eapply Ord.lt_from_wf. eapply to_equiv_class_preserve. auto.
        }
        { eapply Ord.from_wf_supremum. i. unfold equiv_class_rel in LT0. des. ss.
          hexploit (H _ LT a2).
          { eapply Ord.lt_eq_lt; eauto. } i.
          eapply Ord.lt_eq_lt; eauto. eapply Ord.le_lt_lt; eauto.
          etransitivity; [|eapply H0].
          eapply to_equiv_class_equiv in LT0. subst. reflexivity.
        }
      }
      eapply (H (Ord.S (Ord.from_wf WF a))). eapply Ord.S_lt.
    Qed.

    Lemma from_wf_set_equiv_class:
      Ord.eq (Ord.from_wf_set WF) (Ord.from_wf_set equiv_class_well_founded).
    Proof.
      split.
      { eapply Ord.build_supremum. i. eapply Ord.eq_lt_lt.
        { eapply to_equiv_class_eq. }
        { eapply Ord.from_wf_set_upperbound. }
      }
      { eapply Ord.build_supremum. i. hexploit (proj2_sig a). i. des.
        eapply to_equiv_class_equiv in H. subst.
        eapply Ord.eq_lt_lt.
        { symmetry. eapply to_equiv_class_eq. }
        { eapply Ord.from_wf_set_upperbound. }
      }
    Qed.

    Lemma equiv_class_total:
      forall s0 s1, equiv_class_rel s0 s1 \/ s0 = s1 \/ equiv_class_rel s1 s0.
    Proof.
      i. hexploit (proj2_sig s0). i. des. hexploit (proj2_sig s1). i. des.
      destruct (ClassicOrd.trichotomy (Ord.from_wf WF a) (Ord.from_wf WF a0)) as [|[]].
      - left. unfold equiv_class_rel. esplits; eauto.
      - right. left. assert (proj1_sig s0 = proj1_sig s1).
        { extensionality x. eapply propositional_extensionality. split; i.
          - eapply H2; eauto. transitivity (Ord.from_wf WF a); eauto.
            + symmetry. auto.
            + eapply (H0 a x); auto.
          - eapply H0; eauto. transitivity (Ord.from_wf WF a0); eauto.
            eapply (H2 a0 x); auto.
        }
        destruct s0, s1. ss. subst. f_equal. eapply proof_irrelevance.
      - right. right. unfold equiv_class_rel. esplits; eauto.
    Qed.
  End TOTALIFY.

  Definition to_total_set (o: Ord.t): Type := equiv_class (to_set_well_founded o).
  Definition to_total_rel (o: Ord.t): (to_total_set o) -> (to_total_set o) -> Prop :=
    @equiv_class_rel _ _ (to_set_well_founded o).
  Arguments to_total_rel: clear implicits.

  Lemma to_total_well_founded (o: Ord.t): well_founded (to_total_rel o).
  Proof.
    eapply equiv_class_well_founded.
  Defined.
  Arguments to_total_well_founded: clear implicits.

  Lemma to_total_eq (o: Ord.t):
    Ord.eq o (Ord.from_wf_set (@to_total_well_founded o)).
  Proof.
    etransitivity.
    - eapply to_set_eq.
    - eapply (from_wf_set_equiv_class (@to_set_well_founded o)).
  Qed.

  Lemma to_total_total (o: Ord.t):
    forall (x0 x1: to_total_set o), to_total_rel o x0 x1 \/ x0 = x1 \/ to_total_rel o x1 x0.
  Proof.
    eapply equiv_class_total.
  Qed.

  Lemma to_total_exists (o: Ord.t):
    exists (A: Type) (R: A -> A -> Prop) (WF: well_founded R),
      Ord.eq o (Ord.from_wf_set WF) /\
      (forall a0 a1, R a0 a1 \/ a0 = a1 \/ R a1 a0).
  Proof.
    eexists _, _, (to_total_well_founded o). splits.
    { eapply to_total_eq. }
    { eapply to_total_total. }
  Qed.
End ToSet.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

Definition synth (x : natural) (y : natural) : natural := plus (Succ y) x.


From algebra Require Import preamble semigroup.
From HB Require Import structures.
From Coq Require Import ZArith.

HB.mixin Record semigroup_is_monoid M of is_semigroup M :=
  { zero  : M;
    add0r : left_id zero add;
    addr0 : right_id zero add }.

HB.factory Record is_monoid M :=
  { zero  : M;
    add   : M -> M -> M;
    addrA : associative add;
    add0r : left_id zero add;
    addr0 : right_id zero add }.

HB.builders Context (M : Type) of is_monoid M.
  HB.instance Definition _ := is_semigroup.Build M add addrA.
  HB.instance Definition _ := semigroup_is_monoid.Build M zero add0r addr0.
HB.end.

HB.structure Definition Monoid := { M of is_monoid M }.

HB.mixin Record subsemigroup_is_submonoid (M : Monoid.type) S of Subsemigroup M S :=
  { has_zero : S zero }.

HB.structure Definition Submonoid (M : Monoid.type) := {S of subsemigroup_is_submonoid M S &}.

Section Submonoid.
  Context (M : Monoid.type) (S : Submonoid.type M).

  Definition zero' : {x : M | S x}.
  Proof. by esplit; apply: has_zero. Defined.

  Fact add0r' : left_id zero' add.
  Proof.
    move=> u; apply: sigE=> //=.
    by rewrite add0r.
  Qed.

  Fact addr0' : right_id zero' add.
  Proof.
    move=> u; apply: sigE=> //=.
    by rewrite addr0.
  Qed.

  HB.instance Definition _ := semigroup_is_monoid.Build {x : M | S x} zero' add0r' addr0'.
End Submonoid.

HB.instance Definition _ := semigroup_is_monoid.Build Z 0%Z  Z.add_0_l Z.add_0_r.


(*
  This file proves that the width used by the
  rem register in Hausner's implementation if
  large enough to store any intermediate value
  that may result while computing the square
  root of a floating point binary number having
  an even exponent.
*)

Require Import base.
Require Import aux.
Require Import Reals.
Require Import micromega.Lra.

Open Scope R_scope.

Axiom lt_sqrt_div_3_2 : sqrt 2 < 3 / 2.

(**
  Represents the mantissa of the number that we
  are computing the square root of.
*)
Parameter a : R.

(**
  We require that [a] correspond to a binary
  floating point number of the form 1.b1b2...bn,
  where bi represents an arbitrary bit. For
  example: 1.01011.

  Accordingly, the smallest possible value
  that [a] can represent is 1. The largest is
  infinitesimally less than 2.
*)
Axiom a_lower_bound : 1 <= a.
Axiom a_upper_bound : a < 2.

(**
  Accepts a natural number, [n], and returns the
  value of the n-th bit in our approximation of
  the square root of [a].
*)
Parameter b : nat -> R.

(** Asserts that b returns a binary value. *)
Axiom b_is_bit : forall n : nat, {b n = 0}+{b n = 1}.

(**
  Accepts a natural number, [n], and returns our
  n-th approximation of the square root of [a].
*)
Parameter approx : nat -> R.

(**
  Asserts that our initial approximation of the
  square root of [a] is 0.
*)
Axiom approx_0 : approx 0 = 0.

(**
  Asserts that we generate the n-th approximation
  by appending the n-th bit onto our previous
  approximation.
*)
Axiom approx_Sn : forall n : nat, approx (S n) = approx n + (b n)/(2^n).

(**
  Accepts a natural number, [n], and returns
  the difference between [a] and the square of
  our n-th approximation.
*)
Parameter error : nat -> R.

(** Asserts that the error is always positive. *)
Axiom error_is_positive : forall n : nat, 0 <= error (n).

(**
  Asserts the relationship between [a], our
  approximation for the square root of [a],
  and the discrepancy between the square of our
  approximation and [a].
*)
Axiom spec : forall n : nat, a = (approx n)^2 + error n.

(**
  Proves that the discrepancy between the square
  of our initial approximation and [a] equals
  [a].
*)
Lemma error_0
  :  error 0 = a.
Proof.
  exact
    (eq_sym
      (spec 0
        || a = (X)^2 + error 0 @X by <- approx_0
        || a = X + error 0 @X by <- Rmult_0_l (0 * 1)
        || a = X @X by <- Rplus_0_l (error 0))).
Qed.

(**
  Represents [error] in terms of [a] and
  [approx].
*)
Lemma error_n
  :  forall n : nat, a - (approx n)^2 = error n.
Proof.
  exact
    (fun n
      => Rplus_eq_compat_r (- (approx n)^2) a ((approx n)^2 + (error n)) (spec n)
           || a - (approx n)^2 = X                @X by <- Rplus_assoc ((approx n)^2) (error n) (- (approx n)^2)
           || a - (approx n)^2 = (approx n)^2 + X @X by <- Rplus_comm (error n) (- (approx n)^2)
           || a - (approx n)^2 = X                @X by Rplus_assoc ((approx n)^2) (- (approx n)^2) (error n)
           || a - (approx n)^2 = X + error n      @X by <- Rplus_opp_r ((approx n)^2)
           || a - (approx n)^2 = X                @X by <- Rplus_0_l (error n)).
Qed.

(**
  Provides an algebraic expansion for [error].
*)
Lemma error_Sn
  :  forall n : nat, error (S n) = error n - (b n)/(2^n) * (2 * approx n + (b n)/(2^n)).
Proof.
  exact
    (fun n =>
      eq_sym (error_n (S n))
      || error (S n) = a - X^2 @X by <- approx_Sn n
      || _ = a - (approx n + b n/2^n) * X @X by <- Rmult_1_r (approx n + b n/2^n)
      || _ = _ - X @X by <- Rmult_plus_distr_r (approx n) ((b n)/(2^n)) (approx n + b n/2^n)
      || _ = _ - (X + _) @X by <- Rmult_plus_distr_l (approx n) (approx n) (b n/2^n)
      || _ = _ - (_ + X) @X by <- Rmult_plus_distr_l (b n/2^n) (approx n) (b n/2^n)
      || _ = _ - ((X + _) + _) @X by pow2 (approx n)
      || _ = _ - X @X by Rplus_assoc ((approx n)^2 + approx n * (b n/2^n)) (b n/2^n * approx n) ((b n/2^n) * (b n/2^n))
      || _ = _ - (X + _) @X by <- Rplus_assoc ((approx n)^2) (approx n * (b n/2^n)) (b n/2^n * approx n)
      || _ = _ - (_ + (_ + X) + _) @X by <- Rmult_comm (b n/2^n) (approx n)
      || _ = _ - (_ + X + _) @X by double (approx n * (b n/2^n))
      || _ = _ - X @X by <- Rplus_assoc ((approx n)^2) (2 * ((approx n) * (b n/2^n))) ((b n/2^n)*(b n/2^n))
      || _ = _ + X @X by <- Ropp_plus_distr ((approx n)^2) (2 * (approx n * (b n/2^n)) + (b n/2^n)*(b n/2^n))
      || _ = X @X by Rplus_assoc a (- (approx n)^2) (- (2*(approx n * (b n/2^n)) + (b n/2^n)*(b n/2^n)))
      || _ = X + _ @X by <- error_n n
      || _ = _ - (X + _) @X by Rmult_assoc 2 (approx n) (b n/2^n)
      || _ = _ - X @X by Rmult_plus_distr_r (2 * (approx n)) (b n/2^n) (b n/2^n)
      || _ = _ - X @X by <- Rmult_comm (2 * approx n + b n/2^n) (b n/2^n)).
Qed.

(*
  In each iteration [n], we try to append a 1
  bit onto [approx]. If the result is larger than
  [a], we append a 0 instead.
*)
Axiom bn : forall n : nat, (approx n + 1/2^n)^2 > a <-> b n = 0.

(*
  Asserts bounds for [error] and [approx] based
  on the value of a given bit.

  a < (approx (n) + 1/2^n)^2
  approx (n)^2 + error (n) < (apporx (n) + 1/2^n)^2
  approx (n)^2 + error (n) < approx (n)^2 + 1/2^n (2 approx (n) + 1/2^n)
  error (n) < approx (n)^2 + 1/2^n (2 approx (n) + 1/2^n)
*)
Lemma b_0 : forall n : nat, b n = 0 -> error n < 1/2^n * (2 * approx n + 1/2^n).
Proof.
  exact
    (fun n H =>
      Rplus_lt_compat_l
        (- (approx n)^2)
        ((approx n)^2 + error n)
        ((approx n)^2 + (1/2^n * (2 * approx n + 1/2^n)))
        (Rgt_lt _ _ (proj2 (bn n) H)
          || X < (approx n + 1/2^n)^2 @X by <- spec n
          || _ < X @X by <- sqr_expand (approx n) (1/2^n))
      || X < _ @X by Rplus_assoc (- (approx n)^2) ((approx n)^2) (error n)
      || _ < X @X by Rplus_assoc (- (approx n)^2) ((approx n)^2) (1/2^n * (2 * approx n + 1/2^n))
      || X + _ < _ @X by <- Rplus_opp_l ((approx n)^2)
      || X < _ @X by <- Rplus_0_l (error n)
      || _ < X + _ @X by <- Rplus_opp_l ((approx n)^2)
      || _ < X @X by <- Rplus_0_l _).
Qed.

(*
  0 <= error (n + 1)
  0 <= error (n) + b (n)/2^n (2 approx (n) + b (n)/2^n)
  b (n)/2^n (2 approx (n) + b (n)/2^n) <= error (n)
*)
Lemma b_1 : forall n : nat, b n = 1 -> 1/2^n * (2 * approx n + 1/2^n) <= error n.
Proof.
  exact
    (fun n H =>
      Rplus_le_compat_r
        (b n/2^n * (2 * approx n + b n/2^n)) 0
        (error n - b n/2^n * (2 * approx n + b n/2^n))
        (error_is_positive (S n)
         || 0 <= X @X by <- error_Sn n)
      || X <= _ @X by <- Rplus_0_l (b n/2^n * (2 * approx n + b n/2^n))
      || _ <= X @X by <-
        Rplus_assoc (error n)
          (- (b n/2^n * (2 * approx n + b n/2^n)))
          (b n/2^n * (2 * approx n + b n/2^n))
      || _ <= _ + X @X by <- Rplus_opp_l (b n / 2 ^ n * (2 * approx n + b n / 2 ^ n))
      || _ <= X @X by <- Rplus_0_r (error n)
      || X @X by ltac:(rewrite H; reflexivity)).
Qed.

(*
  Proves that every bit is greater than or equal
  to 0.
*)
Lemma b_lower_bound
  :  forall n : nat, 0 <= b n.
Proof.
  exact
    (fun n
      => sumbool_ind
           (fun _ => 0 <= b n)
           (fun H : b n = 0
             => Req_le_sym 0 (b n) H)
           (fun H : b n = 1
             => Rle_0_1 || 0 <= X @X by H)
           (b_is_bit n)).
Qed.

(**
  Proves that [approx] is always positive.
*)
Lemma approx_is_positive
  :  forall n : nat, 0 <= approx n.
Proof.
  induction n as [|m H].
  + exact (Req_le_sym 0 (approx 0) approx_0).
  + rewrite (approx_Sn m).
    apply (Rle_trans 0 (approx m + 0) (approx m + (b m)/(2^m))).
    - rewrite (Rplus_0_r (approx m)); assumption.
    - apply (Rplus_le_compat_l (approx m) 0 ((b m)/(2^m))).
      rewrite <- (Rmult_0_l (/2^m)).
      apply (Rmult_le_compat_r (/2^m) 0 (b m)).
      * exact (Rlt_le 0 (/(2^m)) (Rinv_0_lt_compat (2^m) (pow_lt 2 m Rlt_0_2))).
      * exact (b_lower_bound m).
Qed.

(**
  Expresses the square of [approx] in terms of
  [a] and [error].
*)
Lemma approx_n_sqr
  :  forall n : nat, a - error n = (approx n)^2.
Proof.
  exact
    (fun n
      => Rplus_eq_compat_r (- error n) a ((approx n)^2 + error n) (spec n)
           || a - error n = X                @X by <- Rplus_assoc ((approx n)^2) (error n) (- (error n))
           || a - error n = (approx n)^2 + X @X by <- Rplus_opp_r (error n)
           || a - error n = X                @X by <- Rplus_0_r ((approx n)^2)).
Qed.

(**
  Represents the [approx] in terms of [a] and
  [error].
*)
Lemma approx_n
  :  forall n : nat, sqrt (a - error n) = approx n.
Proof.
  exact
    (fun n
      => f_equal sqrt (approx_n_sqr n)
           || sqrt (a - error n) = X @X by <- sqrt_pow2 (approx n) (approx_is_positive n)).
Qed.

Lemma approx_sqr_is_positive_alt
  :  forall n : nat, 0 <= a - error n.
Proof.
  exact
    (fun n
      => pow_le (approx n) 2 (approx_is_positive n)
           || 0 <= X @X by approx_n_sqr n).
Qed.

Lemma approx_sqr_is_positive : forall n : nat, 0 <= (approx n)^2.
Proof.
  intro n.
  apply (pow_le (approx n) 2 (approx_is_positive n)).
Qed.

Lemma error_upper_bound_a : forall n : nat, error n <= a.
Proof.
  intro n.
  apply (le_eq ((approx n)^2) (error n) a (approx_sqr_is_positive n)).
  exact (eq_sym (spec n)).
Qed.

(**
  Asserts a weak constant upper bound for
  [approx].

  approx n = sqrt(a - error n) < sqrt(2)
*)
Lemma approx_upper_bound
  :  forall n : nat, approx n < sqrt 2.
Proof.
  intro n.
  rewrite <- (sqrt_square (approx n) (approx_is_positive n)).
  rewrite <- (pow2 (approx n)).
  apply (sqrt_lt_1_alt ((approx n)^2) 2).
  split.
  + exact (approx_sqr_is_positive n).
  + refine (Rle_lt_trans ((approx n)^2) a 2 _ a_upper_bound).
    apply (le_eq_comm ((approx n)^2) (error n) a (error_is_positive n) (eq_sym (spec n))).
Qed.

Lemma a_upper_bound_0
  : forall n : nat, approx n + 1/2^n + 1/2^n = approx n + 2/2^n.
Proof.
  intro n.
  rewrite (Rplus_assoc (approx n) (1/2^n) (1/2^n)).
  unfold Rdiv.
  rewrite <- (Rmult_plus_distr_r 1 1 (/2^n)).
  reflexivity.
Qed.

Lemma a_upper_bound_1
  : forall n : nat, 2/2^(S n) = 1/2^n.
Proof.
  intro n.
  simpl.
  unfold Rdiv.
  rewrite (Rinv_mult_distr 2 (2^n) neq_2_0 (pow_nonzero 2 n neq_2_0)).
  rewrite <- (Rmult_assoc 2 (/2) (/2^n)).
  rewrite (Rinv_r_simpl_r 2 (/2^n) neq_2_0).
  exact (eq_sym (Rmult_1_l (/2^n))).
Qed.

Lemma b_is_positive : forall n : nat, 0 <= b n.
Proof.
  intro n.
  destruct (b_is_bit n) as [H|H]; rewrite H.
  + exact (Rle_refl 0).
  + exact Rle_0_1.
Qed.

(* Proves that [approx] is monotonically increasing. *)
Lemma approx_inc : forall n : nat, approx n <= approx (S n).
Proof.
  intro n.
  exact
    (le_eq_comm (approx n) (b n/2^n) (approx (S n))
      (Rle_mult_inv_pos (b n) (2^n) (b_is_positive n) (pow_lt 2 n Rlt_0_2))
      (eq_sym (approx_Sn n))).
Qed.

(*
  (approx n + 1/2^n)^2 <= (approx (S n) + 1/2^n)^2
                       <= (approx n + b n/2^n + 1/2^n)^2
  b n = 0
                       <= (approx n + 1/2^n)^2
                       reflexivity
  b n = 1
                       <= (approx n + 1/2^n + 1/2^n)^2
                       trivial
*)
Lemma a_upper_bound_2
  : forall n : nat, (approx n + 1/2^n)^2 <= (approx (S n) + 2/2^(S n))^2.
Proof.
  intro n.
  rewrite (a_upper_bound_1 n).
  rewrite (approx_Sn n).
  destruct (b_is_bit n) as [H|H]; rewrite H.
  + unfold Rdiv; rewrite (Rmult_0_l (/2^n)); rewrite (Rplus_0_r (approx n));
    exact (Rle_refl ((approx n + 1/2^n)^2)).
  + rewrite (a_upper_bound_0 n).
    apply (pow_incr (approx n + 1/2^n) (approx n + 2/2^n) 2).
    split.
    - apply (Rplus_le_le_0_compat (approx n) (1/2^n)).
      * exact (approx_is_positive n).
      * exact (Rle_mult_inv_pos 1 (2^n) Rle_0_1 (pow_lt 2 n Rlt_0_2)).
    - apply (Rplus_le_compat_l (approx n) (1/2^n) (2/2^n)).
      unfold Rdiv.
      apply (Rmult_le_compat_r (/2^n) 1 2).
      * rewrite <- (Rmult_1_l (/2^n)).
        exact (Rle_mult_inv_pos 1 (2^n) Rle_0_1 (pow_lt 2 n Rlt_0_2)).
      * exact (le_1_2).
Qed.

Theorem a_upper_bound_approx
  :  forall n : nat, a < (approx n + 2/2^n)^2.
Proof.
  exact
    (nat_ind _
      ((Rlt_trans a 2 4
        a_upper_bound
        (ltac:(lra)))
        || a < X @X by (ltac:(field) : (0 + 2/2^0)^2 = 4)
        || a < (X + 2/2^0)^2 @X by approx_0)
      (fun n (H : a < (approx n + 2/2^n)^2)
        => sumbool_ind
             (fun _ => a < (approx (S n) + 2/2^(S n))^2)
             (fun H0 : b n = 0
               => Rlt_le_trans a
                    ((approx n + 1/2^n)^2)
                    ((approx (S n) + 2/2^(S n))^2)
                    (Rle_lt_trans a
                      ((approx n)^2 + error n)
                      ((approx n)^2 + 1/2^n*(2*approx (n) + 1/2^n))
                      (Req_le a
                        ((approx n)^2 + error n)
                        (spec n))
                      (Rplus_lt_compat_l
                        ((approx n)^2)
                        (error n)
                        (1/2^n*(2*approx (n) + 1/2^n))
                        (b_0 n H0))
                      || a < X @X by (ltac:(ring) : ((approx (n) + 1/2^n)^2) = (approx (n)^2 + 1/2^n*(2*approx (n) + 1/2^n))))
                    (a_upper_bound_2 n))
             (fun H0 : b n = 1
               => let H1
                    :  approx (S n) = approx n + 1/2^n
                    := approx_Sn n
                         || approx (S n) = approx n + (X/2^n) @X by <- H0 in
                  H
                  || a < X^2 @X by a_upper_bound_0 n
                  || a < (X + 1/2^n)^2 @X by H1
                  || a < (approx (S n) + X)^2 @X by a_upper_bound_1 n)
             (b_is_bit n))).
Qed.

Lemma error_Sn_plus
  :  forall n : nat, error (S n) + (b n/2^n) * (2 * approx n + (b n/2^n)) = error n.
Proof.
  intro n.
  rewrite (error_Sn n).
  unfold Rminus.
  rewrite
    (Rplus_assoc
      (error n)
      (- ((b n/2^n) * (2 * approx n + (b n/2^n))))
         ((b n/2^n) * (2 * approx n + (b n/2^n)))).
  rewrite (Rplus_opp_l ((b n/2^n) * (2 * approx n + (b n/2^n)))).
  exact (Rplus_0_r (error n)).
Qed.

Lemma error_upper_bound_const_0
  : forall n : nat, - ((b n)/(2^n) * (2 * approx n + (b n)/(2^n))) <= 0.
Proof.
  intro n.
  apply (Rle_minus_0 ((b n/2^n) * (2 * approx n + (b n/2^n)))).
  destruct (b_is_bit n) as [H|H]; rewrite H; unfold Rdiv.
  + rewrite (Rmult_0_l (/2^n)).
    rewrite (Rmult_0_l (2 * approx n + 0)).
    exact (Rle_refl 0).
  + rewrite (Rmult_1_l (/2^n)).
    apply (Rmult_le_pos (/2^n) (2 * approx n + /2^n) (Rle_inv_2n n)).
    refine (Rplus_le_le_0_compat (2 * approx n) (/2^n) _ (Rle_inv_2n n)).
    exact (Rmult_le_pos 2 (approx n) le_0_2 (approx_is_positive n)).
Qed.

(** Proves that [error] is always less than 4. *)
Theorem error_upper_bound_const
  :  forall n : nat, error n < 4.
Proof.
  exact
    (nat_ind _
      (Rlt_trans
        (error 0) 2 4
        (a_upper_bound
          || X < 2 @X by error_0)
        (ltac:(lra) : 2 < 4))
      (fun n (H : error n < 4)
        => Rlt_le_trans
             (error (S n))
             (4 - ((b n)/(2^n) * (2 * approx n + (b n)/(2^n))))
             (4 + 0)
             ((Rplus_lt_compat_r
               (- ((b n)/(2^n) * (2 * approx n + (b n)/(2^n))))
               (error n)
               4
               H)
               || X < 4 - ((b n)/(2^n) * (2 * approx n + (b n)/(2^n))) @X by error_Sn n)
             (Rplus_le_compat_l
               4
               (- ((b n)/(2^n) * (2 * approx n + (b n)/(2^n))))
               0
               (error_upper_bound_const_0 n))
           || error (S n) < X @X by <- Rplus_0_r 4)).
Qed.

Lemma error_upper_bound_approx_0
  :  forall n : nat, (approx n)^2 + (4/2^n)*(approx n + 1/2^n) = (approx n + 2/2^n)^2.
Proof.
  intro n.
  rewrite (sqr_expand (approx n) (2/2^n)).
  unfold Rdiv.
  rewrite <- (Rmult_1_r 2) at 6.
  rewrite (Rmult_assoc 2 1 (/2^n)).
  rewrite <- (Rmult_plus_distr_l 2 (approx n) (1 * /2^n)).
  rewrite (Rmult_assoc 2 (/2^n) _).
  rewrite <- (Rmult_assoc (/2^n) 2 (approx n + (1 * /2^n))).
  rewrite (Rmult_comm (/2^n) 2).
  rewrite (Rmult_assoc 2 (/2^n) (approx n + (1 * /2^n))).
  rewrite <- (Rmult_assoc 2 2 (/2^n * (approx n + (1 * /2^n)))).
  rewrite eq_2_2_4.
  rewrite <- (Rmult_assoc 4 (/2^n) (approx n + 1 * /2^n)).
  reflexivity.
Qed.

(**
  Proves a significant constraint on [error]
  and [approx].
*)
Theorem error_upper_bound_approx
  :  forall n : nat, error n < (4/2^n)*(approx n + 1/2^n).
Proof.
  exact
    (fun n
      => Rplus_lt_compat_r
           (- ((approx n)^2))
           a
           ((4/2^n)*(approx n + 1/2^n) + (approx n)^2)
           (a_upper_bound_approx n
             || a < X @X by error_upper_bound_approx_0 n
             || a < X @X by <- Rplus_comm ((approx n)^2) ((4/2^n)*(approx n + 1/2^n)))
         || X < ((4/2^n)*(approx n + 1/2^n) + (approx n)^2) - ((approx n)^2) @X by <- error_n n
         || error n < X                              @X by <- Rplus_assoc ((4/2^n)*(approx n + 1/2^n)) ((approx n)^2) (- ((approx n)^2))
         || error n < (4/2^n)*(approx n + 1/2^n) + X @X by <- Rplus_opp_r ((approx n)^2)
         || error n < X                              @X by <- Rplus_0_r ((4/2^n)*(approx n + 1/2^n))).
Qed.

Lemma rem_register_even_exp_0
  :  forall n : nat, (4/2^n)*(approx n + 1/2^n) < (4/2^n)*(sqrt 2 + 1/2^n).
Proof.
  intro n.
  apply (Rmult_lt_compat_l (4/2^n) (approx n + 1/2^n) (sqrt 2 + 1/2^n)).
  + unfold Rdiv.
    apply (Rlt_mult_inv_pos 4 (2^n) lt_0_4 (pow_lt 2 n Rlt_0_2)).
  + apply (Rplus_lt_compat_r (1/2^n) (approx n) (sqrt 2) (approx_upper_bound n)).
Qed.

(**
  Is equivalent to:
  1/2^(n+1) + sqrt(2) < 2
  1/2^(n+1) + sqrt(2) < 1/2^(n+1) + 1.5 <= 2
                        1/2^(n+1)       <= 2 - 1.5
                        1/2^(n+1)       <= 1/2

*)
Lemma rem_register_even_exp_1
  :  forall n : nat, (4/2^(S n))*(sqrt 2 + 1/2^(S n)) < 8/2^(S n).
Proof.
  intro n.
  unfold Rdiv.
  simpl.
  rewrite (Rinv_mult_distr 2 (2^n) neq_2_0 (pow_nonzero 2 n neq_2_0)).
  rewrite <- (Rmult_assoc 4 (/2) (/2^n)). fold (Rdiv 4 2). rewrite div_eq_4_2.
  rewrite <- (Rmult_assoc 8 (/2) (/2^n)). fold (Rdiv 8 2). rewrite div_eq_8_2.
  rewrite (Rmult_assoc 2 (/2^n) (sqrt 2 + 1 * (/2 * /2^n))).
  rewrite (Rmult_comm (/2^n) (sqrt 2 + 1 * (/2 * /2^n))).
  rewrite <- (Rmult_assoc 2 (sqrt 2 + 1 * (/2 * /2^n)) (/2^n)).
  apply (Rmult_lt_compat_r (/2^n) (2 * (sqrt 2 + 1 * (/2 * /2^n))) 4).
  + exact (Rlt_inv_2n n).
  + rewrite <- eq_2_2_4.
    apply (Rmult_lt_compat_l 2 (sqrt 2 + 1 * (/2 * /2^n)) 2).
    - exact lt_0_2.
    - refine
        (Rlt_le_trans
          (sqrt 2 + 1 * (/2 * /2^n))
          (3/2 + 1 * (/2 * /2^n))
          2 _ _).
      * apply (Rplus_lt_compat_r (1 * (/2 * /2^n))).
        exact (lt_sqrt_div_3_2).
      * rewrite (Rmult_1_l (/2 * /2^n)).
        rewrite <- (Rmult_1_l (/2)).
        unfold Rdiv.
        induction n as [m|m].
        ** rewrite (pow_O 2).
           rewrite Rinv_1.
           rewrite (Rmult_1_r (1 * /2)).
           rewrite <- (Rmult_plus_distr_r 3 1 (/2)).
           rewrite eq_3_1_4.
           fold (Rdiv 4 2).
           rewrite div_eq_4_2.
           exact (Rle_refl 2).
        ** simpl.
           apply
             (Rle_trans
               (3 * / 2 + 1 * / 2 * / (2 * 2 ^ m))
               (3 * / 2 + 1 * / 2 * / 2 ^ m)
               2).
           *** apply
                 (Rplus_le_compat_l
                   (3*/2)
                   (1 * /2 * /(2 * 2^m))
                   (1 * /2 * /2^m)).
               rewrite (Rmult_1_l (/2)).
               apply (Rmult_le_compat_l (/2) (/(2 * 2 ^ m)) (/2^m)).
               apply (neq_inv_2_0).
               rewrite (Rinv_mult_distr 2 (2^m) neq_2_0 (pow_nonzero 2 m neq_2_0)).
               rewrite <- (Rmult_1_l (/2^m)) at 2.
               refine (Rmult_le_compat_r (/2^m) (/2) 1 (Rle_inv_2n m) _).
               apply (Rmult_le_reg_l 2 (/2) 1).
               **** exact lt_0_2.
               **** rewrite (Rinv_r 2); [rewrite (Rmult_1_r 2); exact le_1_2|exact neq_2_0].
           *** assumption.
Qed.

(**
  Proves that the width used to store
  intermediate error values is large enough to
  accomodate every possible value without a loss
  of precision.
*)
Theorem rem_register_even_exp
  :  forall n : nat, error n < 8/2^n.
Proof.
  exact
    (nat_ind _
      (Rlt_trans
        (error 0)
        4
        (8/2^0)
        (error_upper_bound_const 0)
        ((ltac:(lra) : 4 < 8)
          || 4 < X @X by (ltac:(field) : 8/2^0 = 8)))
      (fun n (H : error n < 8/2^n)
        => Rlt_trans
             (error (S n))
             ((4/2^(S n))*(approx (S n) + 1/2^(S n)))
             (8/2^(S n))
             (error_upper_bound_approx (S n))
             (Rlt_trans
               ((4/2^(S n))*(approx (S n) + 1/2^(S n)))
               ((4/2^(S n))*(sqrt 2 + 1/2^(S n)))
               (8/2^(S n))
               (rem_register_even_exp_0 (S n))
               (rem_register_even_exp_1 n)))).
Qed.

Close Scope R_scope.