(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(** %\subsection*{ support :  cast\_seq\_lengths.v }%*)
Set Implicit Arguments.
Unset Strict Implicit.
Require Export finite.

(** - An important and annoying obstacle when dealing with seqs is that
 v and w belong to the same setoid only if their types are convertible.
 This means that v:(seq n A) and w:(seq k A) cannot be compared, even if
 we have a proof that n=k. We cannot even %{\em state}% the equality because
 the expression v='w is ill-typed!
 - In this file we provide tools to convert between sequences (and their indices)
 of the same length, if only we are given a proof of the fact. Note that these
 casting-functions get in the way of many useful lemmas, unfortunately... *)

Section MAIN.
Lemma lt_comp : forall m n n' : Nat, m < n -> n =' n' in _ -> m < n'.
intros.
rewrite <- H0.
auto.
Qed.

(** %\label{castfin}% *)
Definition cast_fin : forall n n' : Nat, fin n -> n =' n' in _ -> fin n'.
intros.
destruct X.
exact (Build_finiteT (lt_comp in_range_prf H)).
Defined.

Lemma cast_fin_comp :
 forall (n n' : Nat) (i i' : fin n) (H H' : n =' n' in _),
 i =' i' in _ -> cast_fin i H =' cast_fin i' H' in _.
intros until H'.
unfold cast_fin in |- *.
case i; case i'.
simpl in |- *.
auto.
Qed.

Hint Resolve cast_fin_comp: algebra.

Variable A : Setoid.

Definition cast_seq : forall n n' : Nat, seq n A -> n =' n' in _ -> seq n' A.
intros.
destruct X.
set (Ap' := fun i : fin n' => Ap (cast_fin i (sym_eq H))) in *.
assert (Mcp' : fun_compatible Ap').
red in |- *; red in Map_compatible_prf.
unfold Ap' in |- *.
intros.
apply Map_compatible_prf; auto with algebra.
exact (Build_Map Mcp').
Defined.

Lemma cast_seq_comp :
 forall (n n' : Nat) (v v' : seq n A) (H H' : n =' n' in _),
 v =' v' in _ -> cast_seq v H =' cast_seq v' H' in _.
unfold cast_seq in |- *.
intros until H'.
case v; case v'.
simpl in |- *.
red in |- *.
simpl in |- *.
intros.
red in H0.
simpl in H0.
apply Trans with (Ap0 (cast_fin x (sym_eq H'))); auto with algebra.
Qed.

Hint Resolve cast_seq_comp: algebra.

Variable n n' : Nat.
Variable v : seq n A.

Lemma cast_seq_cast_fin :
 forall (i : fin n) (H H' : n =' n' in _),
 v i =' cast_seq v H (cast_fin i H') in _.
intros.
unfold cast_seq, cast_fin in |- *.
destruct v.
simpl in |- *.
destruct i.
apply Map_compatible_prf; auto with algebra.
Qed.

Lemma cast_seq_cast_fin' :
 forall (i : fin n') (H : n =' n' in _) (H' : n' =' n in _),
 cast_seq v H i =' v (cast_fin i H') in _.
intros.
unfold cast_seq, cast_fin in |- *.
destruct v.
simpl in |- *.
destruct i.
apply Map_compatible_prf; auto with algebra.
Qed.

Hint Resolve cast_seq_cast_fin cast_seq_cast_fin': algebra.
End MAIN.
Hint Resolve cast_fin_comp: algebra.
Hint Resolve cast_seq_comp: algebra.
Hint Resolve cast_seq_cast_fin cast_seq_cast_fin': algebra.


From BF Require Import Base Byte RelVM AST.

Inductive relir : Type :=
  | RMove (n : Z) (r : relir)
  | RAdd (n : byte) (off : Z) (r : relir)
  | ROutput (off : Z) (r : relir)
  | RInput (off : Z) (r : relir)
  | RLoop (body : relir) (r : relir)
  | REnd.

Inductive execute : relir -> vm -> vm -> Prop :=
  | E_RMove n r v v' v'' :
      RelVM.move n v = Some v' ->
      execute r v' v'' ->
      execute (RMove n r) v v''
  | E_RAdd n off r v v' v'' :
      RelVM.add_cell n off v = Some v' ->
      execute r v' v'' ->
      execute (RAdd n off r) v v''
  | E_ROutput off r v v' v'' :
      RelVM.output off v = Some v' ->
      execute r v' v'' ->
      execute (ROutput off r) v v''
  | E_RInput off r v v' v'' :
      RelVM.input off v = Some v' ->
      execute r v' v'' ->
      execute (RInput off r) v v''
  | E_RLoop body r v v' v'' :
      RelVM.cell v =? #00 = false ->
      execute body v v' ->
      execute (RLoop body r) v' v'' ->
      execute (RLoop body r) v v''
  | E_RLoop_0 body r v v' :
      RelVM.cell v =? #00 = true ->
      execute r v v' ->
      execute (RLoop body r) v v'
  | E_REnd v v' :
      RelVM.eq v v' = true ->
      execute REnd v v'.

Fixpoint lower_ast (a : ast) : relir :=
  match a with
  | ARight a' => RMove 1 (lower_ast a')
  | ALeft a' => RMove (-1) (lower_ast a')
  | AInc a' => RAdd #01 0 (lower_ast a')
  | ADec a' => RAdd #ff 0 (lower_ast a')
  | AOutput a' => ROutput 0 (lower_ast a')
  | AInput a' => RInput 0 (lower_ast a')
  | ALoop body a' => RLoop (lower_ast body) (lower_ast a')
  | AEnd => REnd
  end.

Theorem lower_ast_sound : forall a v v',
  AST.execute_rel a v v' <-> execute (lower_ast a) v v'.
Proof.
  split.
  - intros. induction H; cbn; econstructor; eassumption.
  - generalize dependent v'; generalize dependent v.
    induction a; cbn; intros;
    try (inversion H; subst; econstructor; try apply IHa; eassumption).
    dependent induction H.
    + eapply ER_ALoop. assumption. apply IHa1. eassumption.
      apply IHexecute2. apply IHa2. apply IHa1. reflexivity.
    + apply ER_ALoop_0, IHa2; assumption.
Qed.


(************************************************************************
 * SubSem
 *)

Equations SubSem {Γ Γ'} (s : Sub Γ Γ') (se : SemEnv Γ) : SemEnv Γ' :=
  SubSem NoSub      _  := tt;
  SubSem (Push t σ) se := (SemExp t se, SubSem σ se).

Lemma SubSem_inil (s : Sub [] []) :
  SubSem s () = ().
Proof. now dependent elimination s. Qed.

Lemma SubSem_ScR {Γ Γ' Γ''} (s : Sub Γ' Γ'') (r : Ren Γ Γ') (se : SemEnv Γ) :
  SubSem (ScR s r) se = SubSem s (RenSem r se).
Proof.
  generalize dependent Γ''.
  generalize dependent Γ'.
  destruct Γ, se; simpl; intros; auto.
  - dependent elimination r; simp RenSem.
    rewrite NoRen_idRen.
    now rewrite ScR_idRen.
  - clear.
    dependent induction s1; simp ScR.
    + now simp SubSem.
    + simp SubSem.
      f_equal.
      * now rewrite SemExp_RenSem.
      * dependent elimination r; simp RenSem;
        now rewrite IHs1.
Qed.

Lemma SubSem_idSub {Γ} (se : SemEnv Γ) :
  SubSem idSub se = se.
Proof.
  induction Γ; destruct se; simpl; simp SubSem; simpl; intros; auto.
  rewrite SubSem_ScR.
  rewrite RenSem_skip1.
  now rewrite IHΓ.
Qed.

Lemma SemVar_SubSem {Γ Γ' τ} (v : Var Γ τ) (s : Sub Γ' Γ) (se : SemEnv Γ') :
  SemVar v (SubSem s se) = SemExp (SubVar s v) se.
Proof.
  intros.
  induction s; simp SubSem; simp SubVar; simpl.
  - now inversion v.
  - now dependent elimination v; simpl; simp RenVar.
Qed.

Lemma SemExp_SubSem {Γ Γ' τ} (e : Exp Γ τ) (s : Sub Γ' Γ) (se : SemEnv Γ') :
  SemExp e (SubSem s se) = SemExp (SubExp s e) se.
Proof.
  generalize dependent Γ'.
  induction e; simpl; intros; auto.
  (* - now rewrite IHe1, IHe2, IHe3. *)
  (* - now rewrite IHe1, IHe2. *)
  (* - now rewrite IHe. *)
  (* - now rewrite IHe. *)
  (* - now rewrite IHe1, IHe2. *)
  (* - now rewrite IHe1, IHe2. *)
  (* - now rewrite IHe. *)
  (* - now rewrite IHe. *)
  - now rewrite SemVar_SubSem.
  - extensionality z.
    fold SemTy in z.
    rewrite <- IHe; clear IHe.
    simpl.
    unfold Keepₛ, Dropₛ; simp SubSem.
    repeat f_equal.
    rewrite SubSem_ScR.
    now rewrite RenSem_skip1.
  - now rewrite IHe1, IHe2.
Qed.

Lemma SubSem_ScS {Γ Γ' Γ''} (s : Sub Γ' Γ'') (t : Sub Γ Γ') (se : SemEnv Γ) :
  SubSem (ScS s t) se = SubSem s (SubSem t se).
Proof.
  generalize dependent Γ''.
  induction s; intros; simpl; simp SubSem; auto.
  now rewrite <- SemExp_SubSem, IHs.
Qed.

Lemma SubSem_RcS {Γ Γ' Γ''} (r : Ren Γ' Γ'') (s : Sub Γ Γ') (se : SemEnv Γ) :
  SubSem (RcS r s) se = RenSem r (SubSem s se).
Proof.
  generalize dependent Γ.
  induction r; intros; simpl; simp RcS; simp RenSem; auto;
  dependent elimination s; simp RcS; simp SubSem; simp RenSem.
  now rewrite IHr.
Qed.
*)

(*
Inductive SubSem {Γ Γ'} (s : Sub Γ Γ') (se : SemEnv Γ) : SemEnv Γ' → Set :=
  SubSem NoSub      _  := inr tt;
  SubSem (Push t σ) se := t' <- SemExp t se ;
                          ρ' <- SubSem σ se ;
                          pure (t', ρ').

Equations SubSem {Γ Γ'} (s : Sub Γ Γ') (se : SemEnv Γ) : Err + SemEnv Γ' :=
  SubSem NoSub      _  := inr tt;
  SubSem (Push t σ) se := t' <- SemExp t se ;
                          ρ' <- SubSem σ se ;
                          pure (t', ρ').

Lemma SubSem_inil (s : Sub [] []) :
  SubSem s () = inr ().
Proof. now dependent elimination s. Qed.

Lemma SubSem_ScR {Γ Γ' Γ''} (s : Sub Γ' Γ'') (r : Ren Γ Γ') (se : SemEnv Γ) :
  SubSem (ScR s r) se = SubSem s (RenSem r se).
Proof.
  generalize dependent Γ''.
  generalize dependent Γ'.
  destruct Γ, se; simpl; intros; auto.
  - dependent elimination r; simp RenSem.
    rewrite NoRen_idRen.
    now rewrite ScR_idRen.
  - clear.
    dependent induction s1; simp ScR; simp SubSem; auto.
    repeat f_equal; simpl.
    + extensionality z.
      now repeat f_equal.
    + dependent elimination r; simpl in *; simp RenSem in *;
      now rewrite <- SemExp_RenSem.
Qed.

Lemma SubSem_idSub {Γ} (se : SemEnv Γ) :
  SubSem idSub se = inr se.
Proof.
  induction Γ; destruct se; simpl; simp SubSem; simpl; intros; auto.
  rewrite SubSem_ScR.
  rewrite RenSem_skip1.
  now rewrite IHΓ.
Qed.

Lemma SemVar_SubSem {Γ Γ' τ} (v : Var Γ τ) (s : Sub Γ' Γ) (se : SemEnv Γ') :
  SemVar v <$> SubSem s se = SemExp (SubVar s v) se.
Proof.
  intros.
  induction s; simp SubSem; simp SubVar; simpl.
  - now inversion v.
  - dependent elimination v;
    simp SubVar in *; simp SubSem in *; simpl in *.
    rewrite H0 in *; simpl in *.
(*
    dependent elimination v; simpl; simp RenVar; simp SubVar.
    simpl in *.
    destruct (SemExp e se); simpl; auto.
    destruct (SubSem s se); simpl; auto.
    simpl in *.
    cbv.
Qed.
*)

Notation "f =<< x" := (x >>= f) (at level 42, right associativity).

Lemma SemExp_SubSem {Γ Γ' τ} (e : Exp Γ τ) (s : Sub Γ' Γ) (se : SemEnv Γ') :
  SemExp e =<< SubSem s se = SemExp (SubExp s e) se.
Proof.
  generalize dependent Γ'.
  induction e; simpl; intros; auto.
  (* - destruct (HostExpSem_valid h) as [? H1]. *)
  (*   rewrite H1; simpl. *)
  -
  (* - now rewrite IHe1, IHe2, IHe3. *)
  (* - now rewrite IHe1, IHe2. *)
  (* - now rewrite IHe. *)
  (* - now rewrite IHe. *)
  (* - now rewrite IHe1, IHe2. *)
  (* - now rewrite IHe. *)
  (* - now rewrite IHe. *)
  (* - now rewrite IHe. *)
  (* - now rewrite IHe. *)
  - now rewrite SemVar_SubSem.
  - extensionality z.
    fold SemTy in z.
    rewrite <- IHe; clear IHe.
    simpl.
    unfold Keepₛ, Dropₛ; simp SubSem.
    repeat f_equal.
    rewrite SubSem_ScR.
    now rewrite RenSem_skip1.
  - now rewrite IHe1, IHe2.
Qed.

Lemma SubSem_ScS {Γ Γ' Γ''} (s : Sub Γ' Γ'') (t : Sub Γ Γ') (se : SemEnv Γ) :
  SubSem (ScS s t) se = SubSem s (SubSem t se).
Proof.
  generalize dependent Γ''.
  induction s; intros; simpl; simp SubSem; auto.
  now rewrite <- SemExp_SubSem, IHs.
Qed.

Lemma SubSem_RcS {Γ Γ' Γ''} (r : Ren Γ' Γ'') (s : Sub Γ Γ') (se : SemEnv Γ) :
  SubSem (RcS r s) se = RenSem r (SubSem s se).
Proof.
  generalize dependent Γ.
  induction r; intros; simpl; simp RcS; simp RenSem; auto;
  dependent elimination s; simp RcS; simp SubSem; simp RenSem.
  now rewrite IHr.
Qed.


(** * Metric Spaces *)

From Coq Require Import
  Lia Reals.Reals.
From DEZ.Has Require Export
  Operations OrderRelations Decisions Forms Distances ArithmeticOperations.
From DEZ.Is Require Export
  Irrelevant
  Equivalence Commutative Toeplitz Nonnegative Subadditive Indiscernible
  TotalOrder Bounded Monoid Monotonic Inflationary.
From DEZ.Justifies Require Export
  RTheorems.
From DEZ.Provides Require Import
  TypeclassTactics.
From DEZ.Supports Require Import
  EquivalenceNotations (* DistanceBarNotations *)
  OrderNotations AdditiveNotations ArithmeticNotations.

#[local] Open Scope R_scope.

(** TODO The rest is not in the diagram yet. *)

(** ** Real Pseudometric Space *)

Class IsRealPseudometric (B : Type) (X : B -> B -> Prop)
  (d : B -> B -> R) : Prop := {
  real_pseudometric_is_equiv :> IsEquiv X;
  real_pseudometric_is_comm_form :> IsCommForm _=_ d;
  real_pseudometric_is_toeplitz_form :> IsToeplitzForm _=_ 0 d;
  real_pseudometric_is_nonneg_form :> IsNonnegForm _<=_ 0 d;
  real_pseudometric_is_subadd_form :> IsSubaddForm _<=_ _+_ d;
  real_pseudometric_is_indisc_id_form :> IsIndiscIdForm _=_ X 0 d;
}.

Section Context.

Context (B : Type) (X : B -> B -> Prop)
  (d : B -> B -> R) `{!IsRealPseudometric X d}.

#[local] Instance real_pseudometric_has_equiv_rel : HasEquivRel B := X.
#[local] Instance real_pseudometric_has_dist : HasDist R B := d.

Ltac notations f := progress (
  f X (equiv_rel (A := B));
  f d (dist (A := R) (B := B))).

#[export] Instance real_pseudometric_is_proper :
  IsProper (X ==> X ==> _=_) d.
Proof with notations enabled.
  intros a0 b0 s0 a1 b1 s1...
  pose proof indisc_id_form a0 b0 s0 as t0.
  pose proof indisc_id_form a1 b1 s1 as t1.
  apply Rle_le_eq. split.
  - pose proof subadd_form a0 b0 a1 as u0.
    pose proof subadd_form b0 b1 a1 as u1.
    rewrite comm_form in t1.
    rewrite t0 in u0. rewrite unl_elem_l in u0.
    rewrite t1 in u1. rewrite unl_elem_r in u1.
    etransitivity.
    + apply u0.
    + etransitivity.
      * apply u1.
      * reflexivity.
  - pose proof subadd_form b0 a0 b1 as u0.
    pose proof subadd_form a0 a1 b1 as u1.
    rewrite comm_form in t0.
    rewrite t0 in u0. rewrite unl_elem_l in u0.
    rewrite t1 in u1. rewrite unl_elem_r in u1.
    etransitivity.
    + apply u0.
    + etransitivity.
      * apply u1.
      * reflexivity.
Qed.

End Context.

(** ** Real Metric Space *)

Class IsRealMetric (B : Type) (X : B -> B -> Prop)
  (d : B -> B -> R) : Prop := {
  real_metric_is_equiv :> IsEquiv X;
  real_metric_is_comm_form :> IsCommForm _=_ d;
  real_metric_is_subadd_form :> IsSubaddForm _<=_ _+_ d;
  real_metric_is_indisc_id_form :> IsIndiscIdForm _=_ X 0 d;
  real_metric_is_id_indisc_form :> IsIdIndiscForm _=_ X 0 d;
}.

Section Context.

Context (B : Type) (X : B -> B -> Prop)
  (d : B -> B -> R) `{!IsRealMetric X d}.

#[local] Instance real_metric_has_equiv_rel : HasEquivRel B := X.
#[local] Instance real_metric_has_dist : HasDist R B := d.

Ltac notations f := progress (
  f X (equiv_rel (A := B));
  f d (dist (A := R) (B := B))).

#[export] Instance real_metric_is_toeplitz_form :
  IsToeplitzForm _=_ 0 d.
Proof with notations enabled.
  intros a... apply indisc_id_form. reflexivity.
Qed.

#[export] Instance real_metric_is_nonneg_form :
  IsNonnegForm _<=_ 0 d.
Proof with notations enabled.
  intros a b...
  pose proof subadd_form a b a as s. rewrite toeplitz_form in s.
  apply (Rmult_le_reg_r 2).
  - apply IZR_lt. lia.
  - rewrite absorb_elem_l.
    replace 2%Z with (1 + 1)%Z by lia. rewrite plus_IZR.
    rewrite distr_l. rewrite unl_elem_r.
    rewrite (comm_form b a) in s.
    apply s.
Qed.

#[export] Instance real_metric_is_real_pseudometric :
  IsRealPseudometric X d.
Proof. esplit; typeclasses eauto. Qed.

End Context.

(** ** Cauchy Sequence in a Real Metric Space *)

(** TODO We should probably put a modulus of convergence here. *)

Class IsRealMetricCauchy (B : Type) (X : B -> B -> Prop)
  (d : B -> B -> R) (f : N -> B) : Prop := {
  real_metric_cauchy_is_real_metric :> IsRealMetric X d;
  real_metric_cauchy_bounded :
    forall e : posreal, exists n : N, forall i j : N,
    (n <= i)%N -> (n <= j)%N -> d (f i) (f j) < e;
}.

(** TODO Define limits of real numbers. *)
(** TODO Define complete real metric spaces
    as metric spaces whose Cauchy sequences have limits in the space. *)
(** TODO Specialize strict short maps as short maps over [<]. *)
(** TODO Prove the Banach fixed-point theorem for strict short maps. *)

Module Arbitrary.

#[export] Instance R_has_dist : HasDist R R := R_dist.

#[export] Instance R_dist_is_comm_form : IsCommForm _=_ R_dist.
Proof. intros x y. apply R_dist_sym. Qed.

#[export] Instance R_dist_is_subadd_form : IsSubaddForm _<=_ _+_ R_dist.
Proof. intros x y z. apply R_dist_tri. Qed.

#[export] Instance R_dist_is_indisc_id_form : IsIndiscIdForm _=_ _=_ 0 R_dist.
Proof. intros x y. apply R_dist_refl. Qed.

#[export] Instance R_dist_is_id_indisc_form : IsIdIndiscForm _=_ _=_ 0 R_dist.
Proof. intros x y. apply R_dist_refl. Qed.

#[export] Instance R_dist_is_real_metric : IsRealMetric _=_ R_dist.
Proof. esplit; typeclasses eauto. Qed.

End Arbitrary.

Equations nonnegreal_dist (x y : R) : nonnegreal :=
  nonnegreal_dist x y := mknonnegreal (R_dist x y) _.
Next Obligation. intros x y. apply Rge_le. apply R_dist_pos. Qed.

#[export] Instance R_has_dist : HasDist nonnegreal R := nonnegreal_dist.

#[export] Instance R_has_eq_dec : HasEqDec R := Req_EM_T.

#[export] Instance R_is_set : IsSet R.
Proof. typeclasses eauto. Qed.

#[export] Instance R_nonneg_dist_is_comm_form :
  IsCommForm (A := R) _=_ nonnegreal_dist.
Proof. intros x y. Admitted.

#[export] Instance R_nonneg_dist_is_subadd_form :
  IsSubaddForm (A := R) _<=_ _+_ nonnegreal_dist.
Proof. intros x y z. Admitted.

#[export] Instance R_nonneg_dist_is_indisc_id_form :
  IsIndiscIdForm (A := R) _=_ _=_ 0 nonnegreal_dist.
Proof. intros x y. Admitted.

#[export] Instance R_nonneg_dist_is_id_indisc_form :
  IsIdIndiscForm (A := R) _=_ _=_ 0 nonnegreal_dist.
Proof. intros x y. Admitted.

#[export] Instance R_nonneg_dist_is_real_metric :
  IsRealMetric (B := R) _=_ nonnegreal_dist.
Proof. esplit; try typeclasses eauto. Qed.

Section Context.

Context (e : posreal).

Equations Rlt_eps (x y : nonnegreal) : Prop :=
  Rlt_eps x y := x < e + y.

#[export] Instance Rlt_eps_wf : WellFounded Rlt_eps.
Proof.
  intros x. constructor. intros y. unfold Rlt_eps at 1.
  assert (a : exists n : nat, e < 1 / 2 ^ n).
  { admit. }
  (** Now use a limit process of the form [1 / 2 ^ n] to access [x]. *)
  intros i. destruct a as [n j].
  pose proof Rplus_lt_compat_r x _ _ j as k.
  pose proof Rlt_trans _ _ _ i k as m.
  clear i j k. revert x y m. induction n as [| p]; intros x y m.
  - rewrite pow_O in m.
    rewrite (Fdiv_def Rfield) in m.
    rewrite Rmult_1_l in m.
    rewrite Rinv_1 in m.
    constructor. intros z i. unfold Rlt_eps in i.
Admitted.

End Context.

Section Context.

Context (e : posreal).

Equations approach (x y : R) : R by wf (nonnegreal_dist x y) (Rlt_eps e) :=
  approach x y with Rlt_le_dec (R_dist x y) e := {
    | left _ => y
    | right _ => approach x ((x + y) / 2)
  }.
Next Obligation.
  intros x y i rec.
  unfold nonnegreal_dist. unfold Rlt_eps. cbn.
  unfold R_dist.
  rewrite (Fdiv_def Rfield).
  rewrite distr_r.
  unfold Rminus.
  rewrite Ropp_plus_distr.
  rewrite <- Rplus_assoc.
  rewrite (double_var x) at 1.
  rewrite (Rplus_assoc (x / 2)).
  rewrite Rplus_opp_r.
  rewrite Rplus_0_r.
  rewrite (Fdiv_def Rfield).
  repeat match goal with
  | |- context c [?x + - ?y] => change (x + - y) with (x - y)
  (* | |- context c [?x * / ?y] => change (x * / y) with (x / y) *)
  end.
  rewrite (Rmult_comm x).
  rewrite (Rmult_comm y).
  repeat match goal with
  | |- context c [Rabs (?x - ?y)] => change (Rabs (x - y)) with (R_dist x y)
  end.
  rewrite R_dist_mult_l.
  rewrite Rabs_Rinv.
  2: { intros a. apply eq_IZR in a. lia. }
  rewrite <- abs_IZR. unfold Z.abs.
  pose proof cond_pos e as p.
  destruct (Rle_lt_or_eq_dec 0 (R_dist x y)) as [f | f].
  - apply Rge_le. apply R_dist_pos.
  - transitivity (R_dist x y).
    + rewrite Rmult_comm.
      rewrite <- (Fdiv_def Rfield).
      apply Rlt_eps2_eps.
      apply Rlt_gt.
      apply f.
    + rewrite <- (Rplus_0_l (R_dist x y)) at 1.
      apply Rplus_lt_compat_r.
      apply p.
  - rewrite <- f. rewrite Rmult_0_r. rewrite Rplus_0_r. apply p.
Qed.

End Context.

(** Extraction is broken,
    so we need this to inspect [RbaseSymbolsImpl.coq_R]. *)

Equations slurp (x : R) : posreal :=
  slurp x := mkposreal x _.
Next Obligation. Admitted.

From Coq Require Import
  extraction.ExtrOcamlBasic extraction.Extraction
  extraction.ExtrOcamlNatBigInt Reals.ClassicalDedekindReals.

Extract Inductive posreal => "Float.t" [ "(fun x -> x)" ].
Extract Inductive negreal => "Float.t" [ "(fun x -> x)" ].
Extract Inductive nonnegreal => "Float.t" [ "(fun x -> x)" ].
Extract Inductive nonposreal => "Float.t" [ "(fun x -> x)" ].
Extract Constant pos => "(fun x -> x)".
Extract Constant neg => "(fun x -> x)".
Extract Constant nonneg => "(fun x -> x)".
Extract Constant nonpos => "(fun x -> x)".
Extract Constant DReal => "Float.t".
Extract Constant R => "Float.t".
Extract Constant RbaseSymbolsImpl.R => "Float.t".
Extract Inductive ConstructiveCauchyReals.CReal => "Unit.t" [ "()" ].
Extract Constant Rabst => "(fun _ -> 0.0)".
Extract Constant Rrepr => "(fun _ -> ())".
Extract Constant R0 => "Float.zero".
Extract Constant R1 => "Float.one".
Extract Constant Rabs => "Float.abs".
(* Extract Constant Rsqrt => "Float.sqrt". *)
Extract Constant Ropp => "Float.neg".
Extract Constant Rinv => "(Float.div Float.one)".
Extract Constant Req_EM_T => "(=)".
Extract Constant Req_appart_dec => "(=)".
Extract Constant Rlt_le_dec => "(<)".
Extract Constant Rle_lt_dec => "(<=)".
Extract Constant Rmult => "Float.mul".
Extract Constant Rplus => "Float.add".
Extract Constant Rminus => "Float.sub".
Extract Constant Rdiv => "Float.div".

Extraction "/tmp/metric.ml" approach slurp.

(** TODO The rest! *)

From DEZ.Supports Require Import
  OrderNotations ArithmeticNotations AdditiveNotations.

(** This generalization was thoroughly investigated by Gabe Conant. *)

Class IsDistMon (A : Type)
  (HR : HasOrdRel A) (Hx : HasNullOp A) (Hk : HasBinOp A) : Prop := {
  is_tot_ord :> IsTotOrd _=_ _<=_;
  is_lower_bnd :> IsLowerBnd _<=_ 0;
  is_mon :> IsMon _=_ 0 _+_;
  is_comm_bin_op :> IsCommBinOp _=_ _+_;
  is_mono_bin_op :> IsMonoBinOp _<=_ _+_;
}.

Module Alternative.

(** This generalization was thoroughly investigated by Matěj Konečný. *)

Class IsPartOrdCommSemigrp (A : Type)
  (HR : HasOrdRel A) (Hx : HasNullOp A) (Hk : HasBinOp A) : Prop := {
  is_part_ord :> IsPartOrd _=_ _<=_;
  is_refl :> IsRefl _<=_;
  is_infl :> IsInfl _<=_ _+_;
  is_semigrp :> IsSemigrp _=_ _+_;
  is_comm_bin_op :> IsCommBinOp _=_ _+_;
  is_mono_bin_op :> IsMonoBinOp _<=_ _+_;
}.

End Alternative.

Class IsMetric (A B : Type)
  (HR : HasOrdRel A) (Hx : HasNullOp A) (Hk : HasBinOp A)
  (Hd : HasDist A B) : Prop := {
  is_dist_mon :> IsDistMon _<=_ 0 _+_;
  is_subadd_form :> IsSubaddForm _<=_ _+_ dist;
}.

Section Context.

Context (A B : Type) (HR : HasOrdRel A) (Hx : HasNullOp A) (Hk : HasBinOp A)
  (Hd : HasDist A B) `{!IsMetric _<=_ 0 _+_ dist}.

#[local] Instance is_comm_tor_l : IsCommForm _=_ dist.
Proof.
  intros x y.
  pose proof subadd_form x y x as b.
  pose proof connex (X := _<=_) (dist x y) (dist y x) as [a | a];
  change bin_rel with _<=_ in a. Abort.

End Context.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal49.

From lfind Require Import LFind.
Require Import Arith.
Lemma lfind_state  (x:natural) (n:natural) (H:Bool.Is_true (eqb x n)):@eq natural x n.
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal49_mem_cons_96_eqb_elim/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Open Scope string_scope.

Parameter print : natural -> string -> natural.
Extract Constant print => "Extract.print".
Definition collect_data  (x:natural) (n:natural) :=
 let lfind_var := "x:" ++ "(" ++ show x ++ ")"++ "|" ++"n:" ++ "(" ++ show n ++ ")"
 in let lfind_v := print x lfind_var
 in lfind_state lfind_v  n.
QuickChick collect_data.
Success.