(**
  Inspired by:
  - "Cyclic Lists, Purely": https://gallais.github.io/blog/cyclic-list-purely.html
  - "Representing Cyclic Structures as Nested Data Types":
    https://www.cs.gunma-u.ac.jp/~hamana/Papers/tfp06.pdf
*)

Require Import Recdef Nat String Coq.Program.Equality.
Require Import List.
Import ListNotations.

(** * CoLists *)

(** We need CoLists (Coinductive Lists) to express some things for which the
    original blogpost uses ordinary Haskell lists. *)

Inductive CoListF (A R : Type) : Type :=
| CoNilF
| CoConsF (h : A) (t : R).

Arguments CoNilF  {A R}.
Arguments CoConsF {A R} _ _.

CoInductive CoList (A : Type) : Type :=
{
  uncons : CoListF A (CoList A);
}.

Arguments uncons {A} _.

Definition CoNil {A : Type} : CoList A :=
{|
  uncons := CoNilF;
|}.

Definition CoCons {A : Type} (h : A) (t : CoList A) : CoList A :=
{|
  uncons := CoConsF h t;
|}.

Inductive FiniteCoList {A : Type} (l : CoList A) : Type :=
| FiniteCoNil :
    uncons l = CoNilF -> FiniteCoList l
| FiniteCoCons :
    forall (h : A) (t: CoList A),
      uncons l = CoConsF h t ->
        FiniteCoList t -> FiniteCoList l.

Inductive simF {A : Type} (l1 l2 : CoList A) (R : CoList A -> CoList A -> Type) : Type :=
| CoNilsF (H1 : uncons l1 = CoNilF) (H2 : uncons l2 = CoNilF)
| CoConssF :
    forall (h1 h2 : A) (t1 t2 : CoList A),
      uncons l1 = CoConsF h1 t1 -> uncons l2 = CoConsF h2 t2 ->
        h1 = h2 -> R t1 t2 -> simF l1 l2 R.

CoInductive sim {A : Type} (l1 l2 : CoList A) : Type :=
{
  sim' : simF l1 l2 sim;
}.

Lemma sim_refl :
  forall {A : Type} (l : CoList A),
    sim l l.
Proof.
  cofix CH.
  destruct l as [[| h t]].
    do 2 constructor; cbn; reflexivity.
    constructor. econstructor 2; try reflexivity. apply CH.
Qed.

(** The first part is inspired by "Cyclic Lists, Purely":
    https://gallais.github.io/blog/cyclic-list-purely.html'>
*)

(** * Fegaras and Sheard's solution *)

Module HOAS_Like.

Unset Positivity Checking.
Inductive CList (A : Type) : Type :=
| Nil
| Cons (h : A) (t : CList A)
| Rec  (h : A) (r : CList A -> CList A).
Set Positivity Checking.

Arguments Nil  {A}.
Arguments Cons {A} _ _.
Arguments Rec  {A} _.

Function unwind {A : Type} (l : CList A) : CoList A :=
match l with
| Nil => CoNil
| Cons h t => CoCons h (unwind t)
| Rec h r => CoCons h (unwind (r l))
end.

Inductive FiniteCList {A : Type} : CList A -> Type :=
| FNil  : FiniteCList Nil
| FCons :
    forall (h : A) (t : CList A),
      FiniteCList t -> FiniteCList (Cons h t).

Lemma Finite_check :
  forall {A : Type} (l : CList A),
    FiniteCList l -> FiniteCoList (unwind l).
Proof.
  induction 1; cbn.
    constructor. cbn. reflexivity.
    econstructor 2.
      reflexivity.
      assumption.
Qed.

(** ** The limitations of this representation *)

(** *** There is no guarantee on the way pointers are used (if at all). *)

(** Explanation: [FiniteCList] is a syntactic definition of finiteness.
    [FiniteCoList] is, on the other hand, a semantic definition of
    finiteness.

    It turns out that there are some semantically finite CLists which
    are not finite according to the syntactic definition. This is caused
    by the misuse of the [Rec] constructor to construct phony cycles. *)

Definition finite : CList nat :=
  Cons 1 (Rec 2 (fun _ => Nil)).

Lemma finite_not_FiniteCList :
  FiniteCList finite -> False.
Proof.
  inversion 1. subst.
  inversion H1.
Qed.

Lemma FiniteCoList_unwind_finite :
  FiniteCoList (unwind finite).
Proof.
  cbn.
  econstructor 2; try reflexivity.
  econstructor 2; try reflexivity.
  constructor; reflexivity.
Defined.

(** Nice observation: problems are caused by not using the name bound
    by [Rec] (or possibly also by using it more that once). So maybe
    this could be fixed by a type of linear functions? *)

(** *** Normal forms are not guaranteed *)

Definition ex1 : CList nat :=
  Cons 4 (Rec 2 (fun l => l)).

Definition ex2 : CList nat :=
  Rec 4 (fun _ => Rec 2 (fun l => l)).

(** Here we have two syntactically distinct [CList]s whose normal forms are the
    same. *)

Lemma syntactically_different :
  ex1 <> ex2.
Proof.
  inversion 1.
Qed.

Lemma semantically_equal :
  sim (unwind ex1) (unwind ex2).
Proof.
  cofix CH.
  constructor. econstructor 2.
    unfold ex1. rewrite unwind_equation. reflexivity.
    unfold ex2. rewrite unwind_equation. reflexivity.
    reflexivity.
    apply sim_refl.
Qed.

Fixpoint take (n : nat) {A : Type} (l : CList A) : list A :=
match n with
| 0    => []
| S n' =>
  match l with
  | Nil => []
  | Cons h t => h :: take n' t
  | Rec h r => h :: take n' (r l)
  end
end.

Fixpoint app {A : Type} (l1 l2 : CList A) : CList A :=
match l1 with
| Nil => l2
| Cons h t => Cons h (app t l2)
| Rec h r => Rec h (fun l => (app (r l) l2))
end.

(** *** Useful functions cannot be written without unfolding the cycle *)

(** It's probably impossible to define [map]. *)
Unset Guard Checking.
Fixpoint mapS (l : CList nat) : CList nat :=
match l with
| Nil      => Nil
| Cons h t => Cons (S h) (mapS t)
| Rec  h r => Rec (S h) (fun l => r (mapS l))
(*  | Rec  h r => Cons (S h) (mapS (r l)) *) (* Does not terminate *)
end.
Set Guard Checking.

(** If we try, mapping successor over a recursive list results in computing
    powers of two... *)
Compute take 10 (mapS ex1).
(* ===> [6; 4; 6; 10; 18; 34; 66; 130; 258; 514] : list nat *)

End HOAS_Like.

(** * Calling the type system to the rescue *)

Module Phantom.

Inductive Closed : SProp := closed.

Unset Positivity Checking.
Inductive CList' (A : Type) : SProp -> Type :=
| Nil  : CList' A Closed
| Cons : forall {B : SProp} (h : A) (t : CList' A B), CList' A B
| Rec  : forall (h : A) (r : forall {B : SProp}, CList' A B -> CList' A B), CList' A Closed.
Set Positivity Checking.

Arguments Nil  {A}.
Arguments Cons {A B} _ _.
Arguments Rec  {A} _ _.

Definition CList (A : Type) : Type := CList' A Closed.

(** Our previous problems with illegal uses of the pointer are gone. *)

Fail Definition finite : CList nat :=
  Cons 1 (Rec 2 (fun _ _ => Nil)).
(* The command has indeed failed with message:
   In environment [P : SProp], [c : CList' nat P]
   The term [Nil] has type
   [CList' nat Closed]
   while it is expected to have type
   [CList' nat P]
   (cannot unify [Closed] and [P]).
*)

(** As we see, we can't use [Nil] while omitting the argument, as this results
    in a type error. *)

Definition ex1 : CList nat :=
  Cons 4 (Rec 2 (fun _ l => l)).

(** The correct definition is still correct. *)

Fail Definition ex2 : CList nat :=
  Rec 4 (fun _ _ => Rec 2 (fun _ l => l)).
(* In environment
   [P : SProp], [c : CList' nat P]
   The term
   [Rec 2 (fun (B : SProp) (l : CList' nat B) => l)]
   has type
   [CList' nat Closed]
   while it is expected to have type
   [CList' nat P]
*)

(** We also can't use one pointer while ignoring another one. Thus, we see that
    using a phantom type argument has effects similar to using a type of linear
    functions. *)

Unset Guard Checking.
Fixpoint stopRec
  {A : Type} {R : SProp -> Type}
  (nil  : R Closed)
  (cons : forall (B : SProp), A -> R B -> R B)
  (rec  : A -> (forall B : SProp, R B -> R B) -> R Closed)
  (l    : CList' A Closed)
  {B : SProp}
  (ih : R B) {struct l} : R B.
Proof.
  destruct l as [| B' h t | h r].
    exact ih.
    exact (cons _ h (stopRec A R nil cons rec t B ih)).
    exact ih.
Defined.
Set Guard Checking.

Unset Guard Checking.
Fixpoint cfold
  {A : Type} {R : SProp -> Type}
  (nil  : R Closed)
  (cons : forall (B : SProp), A -> R B -> R B)
  (rec  : A -> (forall B : SProp, R B -> R B) -> R Closed)
  (l    : CList' A Closed) {struct l}
        : R Closed.
Proof.
  destruct l as [| B h t | h r].
    exact nil.
    exact (cons _ h (cfold A R nil cons rec t)).
    exact (rec h (@stopRec A R nil cons rec (r _ (Rec h r)))).
Defined.
Set Guard Checking.

Definition cmap {A B : Type} (f : A -> B) (l : CList A) : CList B.
Proof.
  eapply cfold.
    exact Nil.
    intros B' h t. exact (Cons (f h) t).
    intros h r. exact (Rec (f h) r).
    exact l.
Defined.

Compute cmap S ex1.

(** We can define a non-dependent eliminator (i.e. the recursion principle). *)

Definition cfoldRec
  {A R : Type} (nil : R) (cons : A -> R -> R) (rec : A -> (R -> R) -> R)
  (l : CList A) : R :=
    @cfold A (fun _ => R) nil (fun _ => cons) (fun a r => rec a (r Closed)) l.

(** We can define a [show] function which displays a (representation of a)
    cycli list as a finite string. *)
Definition show {A : Type} (sh : A -> string) (l : CList A) : string :=
  cfoldRec
    "[]"%string
    (fun h t => append (sh h) (append " :: " t))
    (fun h r => append "rec X. " (append (sh h) (append " :: " (r "X"))))%string
    l.

Definition wut : CList string :=
  (Cons "a" (Cons "b" (Rec "c" (fun _ l => Cons "d" l))))%string.

Compute show (fun x => x) wut.

(** Contrary to what's possible in Haskell (as described in the original
    blogpost), in Coq we can't recover a fold-like function for [CList], as
    that would basically require unwinding the [CList] into a [CoList] and then
    folding the CoList, but that's impossible because [CoList]s are coinductive.

    But a mere conversion to a CoList is of course still possible. *)

CoFixpoint unwind {A : Type} {B : SProp} (l : CList' A B) : CoList A :=
{|
  uncons :=
    match l with
    | Nil      => CoNilF
    | Cons h t => CoConsF h (unwind t)
    | Rec h r  => CoConsF h (unwind (r _ l))
    end;
|}.

Fixpoint cotake {A : Type} (n : nat) (l : CoList A) : list A :=
match n with
| 0    => []
| S n' =>
  match uncons l with
  | CoNilF => []
  | CoConsF h t => h :: cotake n' t
  end
end.

Compute cotake 10 (unwind wut).

End Phantom.

(** The second part is inspired by "Representing Cyclic Structures as Nested Data Types":
    https://www.cs.gunma-u.ac.jp/~hamana/Papers/tfp06.pdf
*)

Module HOAS_Unique.

(** The HOAS-like representation wasn't unique and that was bad. We can make a
    better representation with unique normal forms by getting rid of [Cons] and
    leaving just [Rec]. *)

Unset Positivity Checking.
Inductive CList (A : Type) : Type :=
| Nil
| RCons (h : A) (r : CList A -> CList A).
Set Positivity Checking.

Arguments Nil   {A}.
Arguments RCons {A} _ _.

Function unwind {A : Type} (l : CList A) : CoList A :=
match l with
| Nil       => CoNil
| RCons h r => CoCons h (unwind (r l))
end.

(** But it's hard to prove that normal forms are unique in this representation. *)

Lemma unique :
  forall {A : Type} (l1 l2 : CList A),
    sim (unwind l1) (unwind l2) -> l1 = l2.
Proof.
  intros A l1.
  functional induction unwind l1.
    destruct l2.
      reflexivity.
      inversion 1. inversion sim'0.
        inversion H2.
        inversion H.
    intro l2. functional induction unwind l2.
      inversion 1. inversion sim'0.
        inversion H1.
        inversion H0.
      inversion 1. inversion sim'0.
        inversion H1.
        cbn in *. inversion H; inversion H0; subst. f_equal.
Abort.

End HOAS_Unique.

(** We can do better: we can defunctionalize the higher-order repsentation to
    arrive at a first-order representation that is basically just de Bruijn
    levels. *)

Module Nested.

Inductive CList (A V : Type) : Type :=
| Var : V -> CList A V
| Nil : CList A V
| RCons : A -> CList A (option V) -> CList A V.

Arguments Var   {A V} _.
Arguments Nil   {A V}.
Arguments RCons {A V} _ _.

(** Technically, this is realized using a nested inductive type. The type
    family [CList] has two type parameters, [A] and [V]. [A] is the type of
    elements held in the list, while [V] represents pointers that can be used
    to close a cycle. Our intention is that when [V] is nonempty, [CList A V]
    represents cyclic lists "with free variables", whereas for empty [V],
    [CList A V] represents "closed" cyclic lists. *)

Fixpoint map {A B V : Type} (f : A -> B) (l : CList A V) : CList B V :=
match l with
| Var v     => Var v
| Nil       => Nil
| RCons h t => RCons (f h) (map f t)
end.

(** [map] is easy. *)

Fixpoint shift {A V : Type} (l : CList A V) : CList A (option V) :=
match l with
| Var v     => Var (Some v)
| Nil       => Nil
| RCons h t => RCons h (shift t)
end.

(** [shift] is a very important auxiliary function which shifts all pointers
    one place to the right, i.e. a pointer that referred to the list's zeroth
    element now refers to the first one and so on. *)

Lemma map_shift :
  forall {A B V : Type} (f : A -> B) (l : CList A V),
    map f (shift l) = shift (map f l).
Proof.
  induction l as [| | h t]; cbn.
    1-2: reflexivity.
    f_equal. exact IHl.
Qed.

Lemma map_map :
  forall {A B C V : Type} (f : A -> B) (g : B -> C) (l : CList A V),
    map g (map f l) = map (fun x => g (f x)) l.
Proof.
  induction l as [| | h t]; cbn; intros.
    1-2: reflexivity.
    rewrite IHl. reflexivity.
Qed.

Lemma map_id :
  forall {A V : Type} (l : CList A V),
    map (fun x => x) l = l.
Proof.
  induction l as [| | h t]; cbn; intros.
    1-2: reflexivity.
    rewrite IHl. reflexivity.
Qed.

Fixpoint app {A V : Type} (l1 l2 : CList A V) : CList A V :=
match l1 with
| Var v     => Var v
| Nil       => l2
| RCons h t => RCons h (app t (shift l2))
end.

(** [app] is also easy, but we need to [shift] the pointers when appending [l2]
    to the tail of [l1]. When we hit a variable we drop [l2], because it means
    that we have arrived in a location where a pointer to an earlier location
    in the list is used, i.e. the first list is cyclic and thus "infinite". *)

Lemma map_app :
  forall {A B V : Type} (f : A -> B) (l1 l2 : CList A V),
    map f (app l1 l2) = app (map f l1) (map f l2).
Proof.
  induction l1 as [| | h t]; cbn; intros.
    1-2: reflexivity.
    rewrite IHl1, map_shift. reflexivity.
Qed.

Lemma app_shift :
  forall {A V : Type} (l1 l2 : CList A V),
    app (shift l1) (shift l2) = shift (app l1 l2).
Proof.
  induction l1 as [| | h t]; cbn; intros.
    1-2: reflexivity.
    rewrite IHl1. reflexivity.
Qed.

Lemma app_assoc :
  forall {A V : Type} (l1 l2 l3 : CList A V),
    app (app l1 l2) l3 = app l1 (app l2 l3).
Proof.
  induction l1 as [| | h t]; cbn; intros.
    1-2: reflexivity.
    rewrite IHl1, app_shift. reflexivity.
Qed.

Fixpoint snoc {A V : Type} (x : A) (l : CList A V) : CList A V :=
match l with
| Var v     => Var v
| Nil       => RCons x Nil
| RCons h t => RCons h (snoc x t)
end.

Lemma snoc_shift :
  forall {A V : Type} (x : A) (l : CList A V),
    snoc x (shift l) = shift (snoc x l).
Proof.
  induction l as [| | h t]; cbn.
    1-2: reflexivity.
    rewrite IHl. reflexivity.
Qed.

Lemma snoc_app :
  forall {A V : Type} (x : A) (l1 l2 : CList A V),
    snoc x (app l1 l2) = app l1 (snoc x l2).
Proof.
  induction l1 as [| | h t]; cbn; intros.
    1-2: reflexivity.
    rewrite IHl1, snoc_shift. reflexivity.
Qed.

Fixpoint replicate {A V : Type} (n : nat) (x : A) : CList A V :=
match n with
| 0    => Nil
| S n' => RCons x (replicate n' x)
end.

Definition repeat {A V : Type} (x : A) : CList A V :=
  RCons x (Var None).

Inductive Finite {A V : Type} : CList A V -> Type :=
| FNil   : Finite Nil
| FRCons : forall (h : A) (t : CList A (option V)),
             Finite t -> Finite (RCons h t).

Lemma shift_replicate :
  forall (n : nat) {A V : Type} (x : A),
    @shift A V (replicate n x) = replicate n x.
Proof.
  induction n as [| n']; cbn; intros.
    reflexivity.
    rewrite IHn'. reflexivity.
Qed.

Lemma Finite_replicate :
  forall (n : nat) {A V : Type} (x : A),
    @Finite A V (@replicate A V n x).
Proof.
  induction n as [| n']; cbn; intros.
    constructor.
    constructor. apply IHn'.
Qed.

Lemma not_Finite_repeat :
  forall {A V : Type} (x : A),
    @Finite A V (repeat x) -> False.
Proof.
  inversion 1. subst. inversion X0.
Qed.

Definition CList' (A : Type) : Type := CList A False.

Definition cons {A V : Type} (h : A) (t : CList' A) : CList' A :=
  RCons h (shift t).

Fixpoint recycle {A V : Type} (x : A) (l : CList A (option V)) : CList A V :=
match l with
| Var None     => RCons x (Var None)
| Var (Some v) => Var v
| Nil          => Nil
| RCons h t    => RCons h (recycle x t)
end.

Definition cuncons {A : Type} (l : CList' A) : option (A * CList' A) :=
match l with
| Var v     => match v with end
| Nil       => None
| RCons h t => Some (h, recycle h t)
end.

CoFixpoint unwind {A : Type} (l : CList' A) : CoList A :=
{|
  uncons :=
    match cuncons l with
    | None => CoNilF
    | Some (h, t) => CoConsF h (unwind t)
    end
|}.

Fixpoint ctake (n : nat) {A : Type} (l : CoList A) : list A :=
match n with
| 0    => []
| S n' =>
  match uncons l with
  | CoNilF      => []
  | CoConsF h t => h :: ctake n' t
  end
end.

Definition example : CList' nat :=
  RCons 1 (RCons 2 (Var None)).

Definition take (n : nat) {A : Type} (l : CList' A) : list A :=
  ctake n (unwind l).

Definition example' : CList' nat :=
  RCons 1 (RCons 2 Nil).

Compute take 10 example'.

Definition example'' : CList' nat :=
  RCons 1 (RCons 2 (RCons 3 (RCons 4 (Var (Some (Some None)))))).

Compute take 10 example''.

Fixpoint drop (n : nat) {A : Type} (l : CList' A) : CList' A :=
match n with
| 0    => l
| S n' =>
  match cuncons l with
  | None => Nil
  | Some (_, t) => drop n' t
  end
end.

Compute drop 11 example.

Fixpoint take' (n : nat) {A : Type} (l : CList' A) : list A :=
match n with
| 0    => []
| S n' =>
  match cuncons l with
  | None => []
  | Some (h, t) => h :: take' n' t
  end
end.

Compute take' 10 example.

Fail Fixpoint bind {A B V : Type} (l : CList A V) (f : A -> CList B V) : CList B V :=
match l with
| Var v     => Var v
| Nil       => Nil
| RCons h t => app (f h) (bind t (fun l => shift (f l)))
end.

Fixpoint rev {A V : Type} (l : CList A V) : CList A V :=
match l with
| Var v     => Var v
| Nil       => Nil
| RCons h t => recycle h (rev t)
end.

Definition from1to5 : CList' nat :=
  RCons 1 (RCons 2 (RCons 3 (RCons 4 (RCons 5 (Var None))))).

Compute rev from1to5.

Fixpoint nth (n : nat) {A : Type} (l : CList' A) : option A :=
match n, cuncons l with
| _   , None        => None
| 0   , Some (h, t) => Some h
| S n', Some (h, t) => nth n' t
end.

Compute List.map (fun n => nth n from1to5) [0; 1; 2; 3; 4; 5; 6; 7].

Fixpoint cycle (n : nat) {A : Type} (l : CList' A) : CList' A :=
match n, cuncons l with
| 0   , _           => l
| _   , None        => l
| S n', Some (h, t) => cycle n' t
end.

Compute List.map (fun n => cycle n from1to5) [0; 1; 2; 3; 4; 5; 6; 7].

Fixpoint any {A V : Type} (p : A -> bool) (l : CList A V) : bool :=
match l with
| Var v     => false
| Nil       => false
| RCons h t => p h || any p t
end.

Fixpoint wut {A V : Type} (l : CList A (option V)) : CList A V :=
match l with
| Var None     => Nil
| Var (Some v) => Var v
| Nil          => Nil
| RCons h t    => RCons h (wut t)
end.

Fixpoint filter {A V : Type} (p : A -> bool) (l : CList A V) : CList A V :=
match l with
| Var v     => Var v
| Nil       => Nil
| RCons h t => if p h then RCons h (filter p t) else wut (filter p t)
end.

Compute from1to5.
Compute filter Nat.even from1to5.
Compute filter Nat.even (RCons 1 (RCons 2 (Var None))).

Fixpoint shift' {A V : Type} (l : CList A V) : CList A (option (option V)) :=
match l with
| Var v     => Var (Some (Some v))
| Nil          => Nil
| RCons h t    => RCons h (shift' t)
end.

Fail Fixpoint intersperse {A V : Type} (x : A) (l : CList A V) : CList A V :=
match l with
| Var v       => Var v
| Nil         => Nil
| RCons h t   => RCons h (shift' (RCons x (intersperse x t)))
end.

Fail Compute take 20 (intersperse 0 from1to5).

(** * Relations *)

Inductive Elem {A V : Type} (x : A) : CList A V -> Type :=
| Zero :
    forall l : CList A (option V), Elem x (RCons x l)
| Succ :
    forall (h : A) (t : CList A (option V)),
      Elem x t -> Elem x (RCons h t).

Inductive Dup {A V : Type} : CList A V -> Type :=
| DupVar :
    forall v : V, Dup (Var v)
| DupHere :
    forall (h : A) (t : CList A (option V)),
      Elem h t -> Dup (RCons h t)
| DupThere :
    forall (h : A) (t : CList A (option V)),
      Dup t -> Dup (RCons h t).

Lemma NoDup_Finite :
  forall {A V : Type} (l : CList A V),
    (Dup l -> False) -> Finite l.
Proof.
  induction l as [| | h t]; cbn; intros.
    contradiction H. constructor.
    constructor.
    constructor. apply IHl. intro. apply H. constructor 3. assumption.
Qed.

Lemma NoFinite_Dup :
  forall {A V : Type} (l : CList A V),
    (Finite l -> False) -> Dup l.
Proof.
  induction l as [| | h t]; intros.
    constructor.
    contradict H. constructor.
    constructor 3. apply IHl. intro. apply H. constructor. assumption.
Qed.

Inductive Ex {A V : Type} (P : A -> Type) : CList A V -> Type :=
| ExHere :
    forall (x : A) (l : CList A (option V)),
      P x -> Ex P (RCons x l)
| ExThere :
    forall (h : A) (t : CList A (option V)),
      Ex P t -> Ex P (RCons h t).

Fixpoint takeWhile {A V : Type} (p : A -> bool) (l : CList A V) : CList A V :=
match l with
| Var v     => Var v
| Nil       => Nil
| RCons h t => if p h then RCons h (takeWhile p t) else Nil
end.

Compute takeWhile (fun n => n <? 6) from1to5.

Fail Fixpoint dropWhile {A V : Type} (p : A -> bool) (l : CList A V) : CList A V :=
match l with
| Var v     => Var v
| Nil       => Nil
| RCons h t => if p h then dropWhile p t else Nil
end.

End Nested.

Module CyclicBinaryTree.

Inductive CBin (A V : Type) : Type :=
| Var : V -> CBin A V
| E   : CBin A V
| N   : A -> CBin A (option V) -> CBin A (option V) -> CBin A V.

Arguments Var {A V} _.
Arguments E   {A V}.
Arguments N   {A V} _ _ _.

Definition CBin' (A : Type) : Type :=
  CBin A False.

Definition example : CBin' nat :=
  N 1
    (N 2
      (N 3 (Var None) E)
      E)
    (N 4
      (N 5 E E)
      (N 6 E E)).

Fixpoint recycle {A V : Type} (x : A) (t : CBin A (option V)) : CBin A V :=
match t with
| Var None     => N x (Var None) (Var None)
| Var (Some v) => Var v
| E            => E
| N y l r      => N y (recycle x l) (recycle x r)
end.

Definition unN {A : Type} (t : CBin' A) : option (A * CBin' A * CBin' A) :=
match t with
| Var v   => match v with end
| E       => None
| N x l r => Some (x, recycle x l, recycle x r)
end.

Fixpoint map {A B V : Type} (f : A -> B) (t : CBin A V) : CBin B V :=
match t with
| Var v   => Var v
| E       => E
| N x l r => N (f x) (map f l) (map f r)
end.

Fixpoint mirror {A V : Type} (t : CBin A V) : CBin A V :=
match t with
| Var v   => Var v
| E       => E
| N x l r => N x (mirror r) (mirror l)
end.

Definition complete {A : Type} (x : A) : CBin' A :=
  N x (Var None) (Var None).

Fixpoint index {A : Type} (l : list bool) (t : CBin' A) : option A :=
match l, unN t with
| _, None     => None
| []         , Some (x, _ , _ ) => Some x
| false :: l', Some (_, t', _ ) => index l' t'
| true  :: l', Some (_, _ , t') => index l' t'
end.

Compute example.
Compute index [false; false; false; false] example.

(* Parameter iterate : forall A : Type, (A -> A) -> nat -> A -> BTree A. *)

Fixpoint shift {A V : Type} (t : CBin A V) : CBin A (option V) :=
match t with
| Var v   => Var (Some v)
| E       => E
| N x l r => N x (shift l) (shift r)
end.

Fixpoint take (n : nat) {A : Type} (t : CBin' A) : CBin' A :=
match n, unN t with
| _   , None           => E
| 0   , _              => E
| S n', Some (x, l, r) => N x (shift (take n' l)) (shift (take n' r))
end.

Compute take 5 example.

Fixpoint any {A V : Type} (p : A -> bool) (t : CBin A V) : bool :=
match t with
| Var v   => false
| E       => false
| N x l r => p x || any p l || any p r
end.

Fixpoint all {A V : Type} (p : A -> bool) (t : CBin A V) : bool :=
match t with
| Var v   => false
| E       => false
| N x l r => p x && all p l && all p r
end.

(* Parameter count : forall A : Type, (A -> bool) -> BTree A -> nat. *)

Fixpoint takeWhile {A V : Type} (p : A -> bool) (t : CBin A V) : CBin A V :=
match t with
| Var v   => Var v
| E       => E
| N x l r => if p x then N x (takeWhile p l) (takeWhile p r) else E
end.

Compute takeWhile (fun x => x <? 3) example.

(* Need to compute lcm somewhere.
Fixpoint zipWith {A B C : Type} (f : A -> B -> C) (ta : CBin A V) (tb : CBin B V) : CBin C V :=
match ta, tb with
| Var va, Var vn => V
 *)

End CyclicBinaryTree.

Module GeneralCyclicStructures.

(** The above approach can be generalized even more, to a Fixpoint-with-Cycles
    inductive type like. But for this to work in Coq, we need to turn off the
    positivity checker and then the termination checker each time we want to
    implement a recursive function, so we're not going to pursue the generalized
    approach here.

    Anyway, for more details see
    #<a class='link' href='https://www.cs.gunma-u.ac.jp/~hamana/Papers/tfp06.pdf'>
    Representing Cyclic Structures as Nested Data Types</a>#, section 4. *)

End GeneralCyclicStructures.


Set Implicit Arguments.
Unset Strict Implicit.

Require Import NArith QArith Reals Rpower Ranalysis Fourier Lra Permutation.

Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import all_ssreflect.
From mathcomp Require Import all_algebra.

Require Import OUVerT.numerics.

Delimit Scope R_scope with R.

Fixpoint big_sum (T : Type) (cs : seq T) (f : T -> R) : R :=
  if cs is [:: c & cs'] then (f c + big_sum cs' f)%R
  else 0%R.

Lemma big_sum_nmul (T : Type) (cs : seq T) (f : T -> R) :
  (big_sum cs (fun c => - f c) = - big_sum cs [eta f])%R.
Proof.
  elim: cs=> /=; first by rewrite Ropp_0.
    by move=> a l IH; rewrite Ropp_plus_distr IH.
Qed.

Lemma big_sum_ext' T U (cs : seq T) (cs' : seq U) f f' :
  length cs = length cs' ->
  (List.Forall
     (fun p =>
        let: (c, c') := p in
        f c = f' c')
     (zip cs cs')) ->
  big_sum cs f = big_sum cs' f'.
Proof.
  move=> H H2; elim: cs cs' H H2; first by case.
  move => a l IH; case => // a' l' H H2; case: H => /= H3.
  by inversion H2; subst; rewrite H1 (IH l').
Qed.

Lemma big_sum_ext T (cs cs' : seq T) f f' :
  cs = cs' -> f =1 f' -> big_sum cs f = big_sum cs' f'.
Proof. by move=> <- H; elim: cs=> //= a l ->; f_equal; apply: H. Qed.

Lemma big_sum_scalar T (cs : seq T) r f :
  (big_sum cs (fun c => r * f c) = r * big_sum cs (fun c => f c))%R.
Proof.
  elim: cs=> /=; first by rewrite Rmult_0_r.
    by move=> a l IH; rewrite IH /=; rewrite Rmult_plus_distr_l.
Qed.

Lemma big_sum_plus T (cs : seq T) f g :
  (big_sum cs (fun c => f c + g c) =
   big_sum cs (fun c => f c) + big_sum cs (fun c => g c))%R.
Proof.
  elim: cs=> /=; first by rewrite Rplus_0_r.
  move=> a l IH; rewrite IH /=.
  rewrite [((_ + big_sum l (fun c => f c) + _))%R]Rplus_assoc.
  rewrite [(big_sum l (fun c => f c) + (_ + _))%R]Rplus_comm.
  rewrite Rplus_assoc.
  rewrite Rplus_assoc.
  f_equal.
  f_equal.
  by rewrite Rplus_comm.
Qed.

Lemma big_sum_cat T (cs1 cs2 : seq T) f :
  (big_sum (cs1++cs2) (fun c => f c) =
   big_sum cs1 (fun c => f c) + big_sum cs2 (fun c => f c))%R.
Proof.
  elim: cs1 => /=; first by rewrite Rplus_0_l.
  move=> a l IH; rewrite IH /=.
  rewrite [((_ + big_sum l (fun c => f c) + _))%R]Rplus_assoc //.
Qed.

Lemma big_sum_perm T (cs1 cs2 : seq T) (H : Permutation cs1 cs2) f :
  (big_sum cs1 (fun c => f c) = big_sum cs2 (fun c => f c))%R.
Proof.
  elim: H => //=.
  { move => x l l' H -> //. }
  { by move => x y l; rewrite -Rplus_assoc [f y + f x]Rplus_comm Rplus_assoc. }
  move => l l' l'' H /= -> H2 -> //.
Qed.

Lemma big_sum_split T (cs : seq T) f (p : pred T) :
  (big_sum cs f = big_sum (filter p cs) f + big_sum (filter (predC p) cs) f)%R.
Proof.
  rewrite ->big_sum_perm with (cs2 := filter p cs ++ filter (predC p) cs); last first.
  { elim: cs => // a l /= H; case: (p a) => /=.
    { by constructor. }
      by apply: Permutation_cons_app. }
  by rewrite big_sum_cat.
Qed.

Lemma big_sum_ge0 (T:eqType) (cs : seq T) f (H : forall x, x \in cs -> 0 <= f x)
  : 0 <= big_sum cs f.
Proof.
  elim: cs H => /=; first by move => _; apply: Rle_refl.
  move => a l IH H2; rewrite -[0]Rplus_0_l; apply: Rplus_le_compat => //.
  by apply: H2 => /=; apply: mem_head.
  by apply: IH => // x H3; apply: H2; rewrite/=/in_mem/=; apply/orP; right.
Qed.

Lemma rat_to_R_sum T (cs : seq T) (f : T -> rat) :
  rat_to_R (\sum_(c <- cs) (f c)) =
  big_sum cs (fun c => (rat_to_R (f c)))%R.
Proof.
  elim: cs=> //=; first by rewrite big_nil rat_to_R0.
  move=> a' l IH; rewrite big_cons.
  rewrite rat_to_R_plus IH.
    by f_equal; rewrite rat_to_R_plus rat_to_R_opp rat_to_R_mul.
Qed.

Lemma big_sum_constant T (cs : seq T) n :
  (big_sum cs (fun _ => n) = INR (size cs) * n)%R.
Proof.
  elim: cs => //=.
  { by rewrite Rmult_0_l. }
  move => t0 l ->.
  case: (size l).
  { by rewrite /INR Rmult_0_l Rmult_1_l Rplus_0_r. }
  move => x.
  field.
Qed.

(*DUPLICATE: REMOVE*)
Lemma big_sum_mult_left T (cs : seq T) c f :
  c * big_sum cs f = big_sum cs (fun x => c * f x).
Proof.
  elim: cs => //=.
  { by rewrite Rmult_0_r. }
  move => a l /=; rewrite Rmult_plus_distr_l => -> //.
Qed.

Lemma big_sum_mult_right T (cs : seq T) c f :
  big_sum cs f * c = big_sum cs (fun x => f x * c).
Proof.
  elim: cs => //=.
  { by rewrite Rmult_0_l. }
  move => a l /=; rewrite Rmult_plus_distr_r => -> //.
Qed.

Fixpoint big_product (T : Type) (cs : seq T) (f : T -> R) : R :=
  if cs is [:: c & cs'] then (f c * big_product cs' f)%R
  else 1%R.

Lemma big_product_ext T (cs cs' : seq T) f f' :
  cs = cs' -> f =1 f' -> big_product cs f = big_product cs' f'.
Proof. by move=> <- H; elim: cs=> //= a l ->; f_equal; apply: H. Qed.

Lemma big_product_ge0 (T : eqType) (cs : seq T) (f : T -> R) :
  (forall c, c \in cs -> 0 <= f c)%R ->
  (0 <= big_product cs f)%R.
Proof.
  elim: cs=> /=.
  { move=> _; apply: Rle_0_1. }
  move=> a l IH H.
  have H2: (0 = 0 * 0)%R by rewrite Rmult_0_l.
  rewrite H2; apply: Rmult_le_compat.
  by apply: Rle_refl.
  by apply: Rle_refl.
  by apply: H; rewrite in_cons; apply/orP; left.
  apply: IH=> c H3; apply: H.
  by rewrite in_cons; apply/orP; right.
Qed.

Lemma big_product_gt0 (T : eqType) (cs : seq T) (f : T -> R) :
  (forall c, c \in cs -> 0 < f c)%R ->
  (0 < big_product cs f)%R.
Proof.
  elim: cs=> /=.
  { move=> _; apply: Rlt_0_1. }
  move=> a l IH H.
  have H2: (0 = 0 * 0)%R by rewrite Rmult_0_l.
  apply: Rmult_lt_0_compat.
  by apply: H; rewrite in_cons; apply/orP; left.
  by apply: IH=> c H3; apply: H; rewrite in_cons; apply/orP; right.
Qed.

Lemma ln_big_product_sum (T : eqType) (cs : seq T) (f : T -> R) :
  (forall t : T, 0 < f t)%R ->
  ln (big_product cs f) = big_sum cs (fun c => ln (f c)).
Proof.
  elim: cs=> /=; first by rewrite ln_1.
  move=> a l IH H; rewrite ln_mult=> //; first by rewrite IH.
    by apply: big_product_gt0.
Qed.

Lemma big_product_exp_sum (T : eqType) (cs : seq T) (f : T -> R) :
  big_product cs (fun x => exp (f x)) = exp (big_sum cs f).
Proof.
  elim: cs => //=; first by rewrite exp_0.
  by move => a l IH; rewrite IH exp_plus.
Qed.

Lemma big_product_le (T : eqType) (cs : seq T) (f : T -> R) g :
  (forall c, c \in cs -> 0 <= f c)%R ->
  (forall c, c \in cs -> 0 <= g c)%R ->
  (forall c, c \in cs -> f c <= g c)%R ->
  (big_product cs f <= big_product cs g)%R.
Proof.
  elim: cs=> //=.
  { move=> _ _ _; apply: Rle_refl. }
  move=> a l IH H1 H2 H3; apply Rmult_le_compat.
  { by apply: H1; rewrite in_cons; apply/orP; left. }
  { apply: big_product_ge0.
      by move=> c H4; apply: H1; rewrite in_cons; apply/orP; right. }
  { by apply: H3; rewrite in_cons; apply/orP; left. }
  apply: IH.
  { by move=> c H; apply: H1; rewrite in_cons; apply/orP; right. }
  { by move=> c H; apply: H2; rewrite in_cons; apply/orP; right. }
    by move=> c H; apply: H3; rewrite in_cons; apply/orP; right.
Qed.

Lemma big_product_assoc (T: finType) (F G : T -> R) :
  big_product (enum T) (fun i : T => F i) *
  big_product (enum T) (fun i : T => G i) =
  big_product (enum T) (fun i : T => F i * G i).
Proof.
  clear - F G; elim: (enum T) => //=.
  { by rewrite Rmult_1_r. }
  move => i l /= IH; symmetry; rewrite -IH; lra.
Qed.

Lemma big_sum_lt_aux (T : eqType) (cs : seq T) (f : T -> R) g :
  (forall c, c \in cs -> f c < g c)%R ->
  cs=[::] \/ (big_sum cs f < big_sum cs g)%R.
Proof.
  elim: cs=> //=.
  { by move=> _; left. }
  move=> a l IH H1; right; apply Rplus_lt_le_compat.
  { by apply: H1; rewrite in_cons; apply/orP; left. }
  have H2: (forall c : T, c \in l -> f c < g c).
  { by move => c Hin; move: (H1 c); rewrite in_cons; apply; apply/orP; right. }
  case: (IH H2) => //.
  { move => -> /=; apply: Rle_refl. }
  by move => H3; left.
Qed.

Lemma big_sum_lt (T : eqType) (cs : seq T) (f : T -> R) g :
  (forall c, c \in cs -> f c < g c)%R ->
  cs<>[::] ->
  (big_sum cs f < big_sum cs g)%R.
Proof.
  move => H H1; case: (big_sum_lt_aux H) => //.
Qed.

Lemma big_product_perm T (cs1 cs2 : seq T) (H : Permutation cs1 cs2) f :
  (big_product cs1 (fun c => f c) = big_product cs2 (fun c => f c))%R.
Proof.
  elim: H => //=.
  { move => x l l' H -> //. }
  { by move => x y l; rewrite -Rmult_assoc [f y * f x]Rmult_comm Rmult_assoc. }
  move => l l' l'' H /= -> H2 -> //.
Qed.

Lemma big_product_cat T (cs1 cs2 : seq T) f :
  (big_product (cs1++cs2) (fun c => f c) =
   big_product cs1 (fun c => f c) * big_product cs2 (fun c => f c))%R.
Proof.
  elim: cs1 => /=; first by rewrite Rmult_1_l.
  move=> a l IH; rewrite IH /=.
  rewrite [((_ * big_product l (fun c => f c) * _))%R]Rmult_assoc //.
Qed.

Lemma big_product_split T (cs : seq T) f (p : pred T) :
  (big_product cs f = big_product (filter p cs) f * big_product (filter (predC p) cs) f)%R.
Proof.
  rewrite ->big_product_perm with (cs2 := filter p cs ++ filter (predC p) cs); last first.
  { elim: cs => // a l /= H; case: (p a) => /=.
    { by constructor. }
      by apply: Permutation_cons_app. }
  by rewrite big_product_cat.
Qed.

Lemma big_product0 (T : eqType) (cs : seq T) c :
  c \in cs ->
  big_product cs (fun _ => 0) = 0.
Proof. by elim: cs c => // a l IH c /= _; rewrite Rmult_0_l. Qed.

Lemma rat_to_R_prod T (cs : seq T) (f : T -> rat) :
  rat_to_R (\prod_(c <- cs) (f c)) =
  big_product cs (fun c => (rat_to_R (f c)))%R.
Proof.
  elim: cs=> //=; first by rewrite big_nil rat_to_R1.
  move=> a' l IH; rewrite big_cons.
  rewrite rat_to_R_mul IH.
    by f_equal; rewrite rat_to_R_plus rat_to_R_opp rat_to_R_mul.
Qed.

Lemma big_sum_lift (T : Type) (ts : seq T) f g
      (g_zero : g 0 = 0)
      (g_plus : forall x y, g (x + y) = g x + g y) :
  big_sum ts (fun x => g (f x)) = g (big_sum ts (fun x => f x)).
Proof. by elim: ts => //= a l ->. Qed.

Lemma big_product_lift (T : Type) (ts : seq T) f g
      (g_zero : g 1 = 1)
      (g_mult : forall x y, g (x * y) = g x * g y) :
  big_product ts (fun x => g (f x)) = g (big_product ts (fun x => f x)).
Proof. by elim: ts => //= a l ->. Qed.

Lemma big_product_constant T (cs : seq T) n :
  (big_product cs (fun _ => n) = n ^ size cs)%R.
Proof. elim: cs => //= _ l -> //. Qed.

(*MOVE: numerics.v*)
(*Monoid instance for Coq R*)
Program Definition Rtimes_law : @Monoid.law R 1 :=
  @Monoid.Law R 1 Rmult _ _ _.
Next Obligation. by move => x y z; rewrite Rmult_assoc. Qed.
Next Obligation. by move => x; rewrite Rmult_1_l. Qed.
Next Obligation. by move => x; rewrite Rmult_1_r. Qed.
Lemma Rtimes_com : commutative Rtimes_law.
Proof. by move => x y /=; rewrite Rmult_comm. Qed.
Definition Rtimes_com_law : @Monoid.com_law R 1 :=
  @Monoid.ComLaw _ _ Rtimes_law Rtimes_com.
Program Definition Rtimes : Monoid.mul_law 0 :=
  @Monoid.MulLaw _ 0 Rtimes_com_law _ _.
Next Obligation. by move => x; rewrite Rmult_0_l. Qed.
Next Obligation. by move => x; rewrite Rmult_0_r. Qed.

Program Definition Rplus_law : @Monoid.law R 0 :=
  @Monoid.Law R 0 Rplus _ _ _.
Next Obligation. by move => x y z; rewrite Rplus_assoc. Qed.
Next Obligation. by move => x; rewrite Rplus_0_l. Qed.
Next Obligation. by move => x; rewrite Rplus_0_r. Qed.
Lemma Rplus_com : commutative Rplus_law.
Proof. by move => x y /=; rewrite Rplus_comm. Qed.
Definition Rplus_com_law : @Monoid.com_law R 0 :=
  @Monoid.ComLaw _ _ Rplus_law Rplus_com.
Program Definition Rplus : Monoid.add_law 0 Rtimes :=
  @Monoid.AddLaw _ 0 Rmult Rplus_com_law _ _.
Next Obligation. by move => x y z; rewrite Rmult_plus_distr_r. Qed.
Next Obligation. by move => x y z; rewrite Rmult_plus_distr_l. Qed.
(*END MOVE*)

Section SSR_RBigops.
  Variable I : finType.
  Variable F : I -> R.
  Variable P : pred I.

  Lemma big_sum_sum : big_sum (enum I) F = \big[Rplus/0]_i F i.
  Proof.
    rewrite BigOp.bigopE /index_enum enumT.
    by elim: (Finite.enum I) => //= a l ->.
  Qed.

  Lemma big_sum_sumP : big_sum [seq x <- enum I | P x] F = \big[Rplus/0]_(i | P i) F i.
  Proof.
    rewrite BigOp.bigopE /index_enum enumT.
    by elim: (Finite.enum I) => //= a l; case Heq: (P a) => //= ->.
  Qed.

  Lemma big_product_prod : big_product (enum I) F = \big[Rtimes/1]_i F i.
  Proof.
    rewrite BigOp.bigopE /index_enum enumT.
    by elim: (Finite.enum I) => //= a l ->.
  Qed.

  Lemma big_product_prodP : big_product [seq x <- enum I | P x] F = \big[Rtimes/1]_(i | P i) F i.
  Proof.
    rewrite BigOp.bigopE /index_enum enumT.
    by elim: (Finite.enum I) => //= a l; case Heq: (P a) => //= ->.
  Qed.
End SSR_RBigops.

(*ssreflect: bigA_distr_bigA*)
Lemma big_product_distr_sum (I J : finType) (F : I -> J -> R) :
  big_product (enum I) (fun i => big_sum (enum J) (fun j => F i j)) =
  big_sum (enum [finType of {ffun I -> J}])
          (fun f : {ffun I -> J} => big_product (enum I) (fun i => F i (f i))).
Proof.
  rewrite big_sum_sum big_product_prod.
  have ->:
    \big[Rtimes/1]_i big_sum (enum J) [eta F i]
  = \big[Rtimes/1]_i \big[Rplus/0]_j F i j.
  { by apply: eq_big => // i _; rewrite big_sum_sum. }
  by rewrite bigA_distr_bigA; apply: eq_big => // f _; rewrite big_product_prod.
Qed.

Lemma marginal_unfoldR N i (A : finType) (F : {ffun 'I_N -> A} -> R) :
  let P t (p : {ffun 'I_N -> A}) := p i == t in
  \big[Rplus/0]_(p : [finType of (A * {ffun 'I_N -> A})] | P p.1 p.2) (F p.2) =
  \big[Rplus/0]_(p : {ffun 'I_N -> A}) (F p).
Proof.
  move => P.
  set (G (x : A) y := F y).
  have ->:
    \big[Rplus/0]_(p | P p.1 p.2) F p.2 =
    \big[Rplus/0]_(p | predT p.1 && P p.1 p.2) G p.1 p.2 by apply: eq_big.
  rewrite -pair_big_dep /= /G /P.
  have ->:
    \big[Rplus/0]_i0 \big[Rplus/0]_(j : {ffun 'I_N -> A} | j i == i0) F j =
    \big[Rplus/0]_i0 \big[Rplus/0]_(j : {ffun 'I_N -> A} | predT j && (j i == i0)) F j.
  { by apply: eq_big. }
  rewrite -partition_big //.
Qed.

Lemma prod_splitR N (i : 'I_N) (A : finType) (y : {ffun 'I_N -> A}) f :
  \big[Rtimes/1]_(j in [set i]) (f j) (y j) *
  \big[Rtimes/1]_(j in [set~ i]) (f j) (y j) = \big[Rtimes/1]_(j < N) (f j) (y j).
Proof.
  have ->:
    \big[Rtimes/1]_(j < N) (f j) (y j) =
    \big[Rtimes/1]_(j in [predU (pred1 i) & [set~ i]]) (f j) (y j).
  { apply: congr_big => // j; rewrite /in_mem /=.
    case H: (j == i).
    { by have ->: j \in pred1 i = true by rewrite /pred1 /in_mem /= H. }
    have ->: j \in [set~ i] by rewrite in_setC1 H.
      by rewrite orbC. }
  set (F j := f j (y j)).
  rewrite (@bigU R 1 _) /=; last first.
  { by rewrite disjoint1 in_setC1; apply/negP; rewrite eq_refl. }
  f_equal.
  apply: congr_big => //; first by move => j; rewrite in_set1.
Qed.

Lemma sum_splitR N (i : 'I_N) (A : finType) (y : {ffun 'I_N -> A}) f :
  \big[Rplus/0]_(j in [set i]) (f j) (y j) +
  \big[Rplus/0]_(j in [set~ i]) (f j) (y j) = \big[Rplus/0]_(j < N) (f j) (y j).
Proof.
  have ->:
    \big[Rplus/0]_(j < N) (f j) (y j) =
    \big[Rplus/0]_(j in [predU (pred1 i) & [set~ i]]) (f j) (y j).
  { apply: congr_big => // j; rewrite /in_mem /=.
    case H: (j == i).
    { by have ->: j \in pred1 i = true by rewrite /pred1 /in_mem /= H. }
    have ->: j \in [set~ i] by rewrite in_setC1 H.
      by rewrite orbC. }
  rewrite bigU /=; last first.
  { by rewrite disjoint1 in_setC1; apply/negP; rewrite eq_refl. }
  f_equal.
  apply: congr_big => //; first by move => j; rewrite in_set1.
Qed.

Lemma big_sum_le (T : eqType) (cs : seq T) (f : T -> R) g :
  (forall c, c \in cs -> f c <= g c)%R ->
  (big_sum cs f <= big_sum cs g)%R.
Proof.
  elim: cs=> //=.
  { move=> _; apply: Rle_refl. }
  move=> a l IH H1; apply Rplus_le_compat.
  { by apply: H1; rewrite in_cons; apply/orP; left. }
    by apply: IH=> c H; apply: H1; rewrite in_cons; apply/orP; right.
Qed.

Lemma perm_eq_nil (T:eqType) (cs : seq T) : perm_eq [::] cs -> cs=[::].
Proof.
  move => H; apply: perm_eq_small => //.
  by rewrite perm_eq_sym.
Qed.

Lemma In_mem (T:eqType) (a:T) (cs : seq T) : List.In a cs <-> a \in cs.
Proof.
  elim: cs a => // a l IH ax; split.
  { inversion 1; subst; first by rewrite mem_head.
    by rewrite /in_mem/=; apply/orP; right; rewrite -(IH ax). }
  rewrite /in_mem/=; case/orP; first by move/eqP => <-; left.
  by move => H; right; rewrite IH.
Qed.

Lemma uniq_NoDup (T:eqType) (cs : seq T) : uniq cs -> List.NoDup cs.
Proof.
  elim: cs.
  { move => _; constructor. }
  move => a l IH; rewrite cons_uniq; case/andP => H1 H2; constructor; last by apply: IH.
  by move => Hnin; rewrite /in_mem/= in H1; apply: (negP H1); rewrite -In_mem.
Qed.

Lemma perm_eqi (T:eqType) (cs1 cs2 : seq T) :
  uniq cs1 ->
  uniq cs2 ->
  cs1 =i cs2 -> Permutation cs1 cs2.
Proof.
  move => U1 U2 H; apply: NoDup_Permutation.
  by apply: uniq_NoDup.
  by apply: uniq_NoDup.
  move => x; split => H2.
  { by rewrite In_mem; rewrite -(H x); rewrite -In_mem. }
  by rewrite In_mem; rewrite (H x); rewrite -In_mem.
Qed.

Lemma perm_sub (T:eqType) (cs1 cs2 : seq T) :
  uniq cs1 ->
  uniq cs2 ->
  {subset cs1 <= cs2} ->
  Permutation cs1 [seq x <- cs2 | x \in cs1].
Proof.
  move => U1 U2 H.
  have H2: Permutation cs1 [seq x <- cs1 | x \in cs2].
  { elim: cs1 cs2 H {U1 U2} => // a l IH cs2 H /=.
    case Hin: (a \in cs2) => //.
    { by constructor; apply: IH => x H2; apply: H; rewrite /in_mem/=; apply/orP; right. }
    by move: H; move/(_ a); rewrite mem_head; move/(_ erefl); rewrite Hin. }
  apply: (Permutation_trans H2); move {H2}.
  apply: perm_eqi; try apply: filter_uniq => //.
  by move => x; rewrite 2!mem_filter andbC.
Qed.

Lemma big_sum_le2 (T : eqType) (cs1 cs2 : seq T) (f : T -> R) :
  uniq cs1 ->
  uniq cs2 ->
  (forall c, c \in cs2 -> 0 <= f c)%R ->
  (forall c, c \in cs1 -> c \in cs2)%R ->
  (big_sum cs1 f <= big_sum cs2 f)%R.
Proof.
  move => U1 U2 H1 H2.
  rewrite [big_sum cs2 _](big_sum_split _ _ [pred x | x \in cs1]).
  rewrite -[big_sum cs1 _]Rplus_0_r; apply: Rplus_le_compat.
  { have Hperm: Permutation cs1 [seq x <- cs2 | [pred x in cs1] x].
    { by apply: perm_sub. }
    rewrite (big_sum_perm Hperm); apply: Rle_refl. }
  by apply: big_sum_ge0 => x; rewrite mem_filter; case/andP => _ H; apply: H1.
Qed.

Lemma big_sum_le3 (T : eqType) (cs1 cs2 : seq T) (f g : T -> R) :
  uniq cs1 ->
  uniq cs2 ->
  (forall c, c \in cs2 -> 0 <= g c)%R ->
  (forall c, c \in cs1 -> c \in cs2)%R ->
  (forall c, c \in cs1 -> f c <= g c)%R ->
  (big_sum cs1 f <= big_sum cs2 g)%R.
Proof.
  move => U1 U2 H1 H2 H.
  rewrite [big_sum cs2 _](big_sum_split _ _ [pred x | x \in cs1]).
  rewrite -[big_sum cs1 _]Rplus_0_r; apply: Rplus_le_compat.
  { have Hperm: Permutation cs1 [seq x <- cs2 | [pred x in cs1] x].
    { by apply: perm_sub. }
    rewrite (big_sum_perm Hperm).
    apply: big_sum_le => c /= Hin; apply: H.
    rewrite mem_filter in Hin; case: (andP Hin) => Hx Hy //. }
  apply: big_sum_ge0 => x; rewrite mem_filter; case/andP => Hx Hy; apply: H1 => //.
Qed.

Lemma big_sum_pred (T:eqType) (cs:seq T) (f:T -> R) (p:pred T) :
  big_sum cs (fun t => if p t then f t else 0) =
  big_sum [seq t <- cs | p t] f.
Proof.
  elim: cs => // a l IH /=; case H: (p a) => /=.
  { by rewrite IH. }
  by rewrite IH Rplus_0_l.
Qed.

Lemma big_sum_pred2 (T:eqType) (cs:seq T) (f g:T -> R) (p:pred T) :
  big_sum cs (fun t => f t * if p t then g t else 0) =
  big_sum [seq t <- cs | p t] (fun t => f t * g t).
Proof.
  elim: cs => // a l IH /=; case H: (p a) => /=.
  { by rewrite IH. }
  by rewrite IH Rmult_0_r Rplus_0_l.
Qed.

(*TODO: All these bigops should really be consolidated at some point...sigh*)

(** Q bigops *)

Delimit Scope Q_scope with Q.

Fixpoint big_sumQ (T : Type) (cs : seq T) (f : T -> Q) : Q :=
  if cs is [:: c & cs'] then (f c + big_sumQ cs' f)%Q
  else 0%Q.

Lemma big_sumQ_nmul (T : Type) (cs : seq T) (f : T -> Q) :
  Qeq (big_sumQ cs (fun c => - f c))%Q (- big_sumQ cs [eta f])%Q.
Proof.
  elim: cs=> /=; first by [].
    by move => a l IH; rewrite IH Qopp_plus.
Qed.

Lemma big_sumQ_ext T (cs cs' : seq T) f f' :
  cs = cs' -> f =1 f' -> big_sumQ cs f = big_sumQ cs' f'.
Proof. by move=> <- H; elim: cs=> //= a l ->; f_equal; apply: H. Qed.

Lemma big_sumQ_scalar T (cs : seq T) r f :
  Qeq (big_sumQ cs (fun c => r * f c))%Q (r * big_sumQ cs (fun c => f c))%Q.
Proof.
  elim: cs=> /=. rewrite Qmult_0_r. apply Qeq_refl.
    by move => a l IH; rewrite IH Qmult_plus_distr_r.
Qed.

(** N bigops *)

Fixpoint big_sumN (T : Type) (cs : seq T) (f : T -> N) : N :=
  if cs is [:: c & cs'] then (f c + big_sumN cs' f)%num
  else 0%num.

Lemma big_sumN_ext T (cs cs' : seq T) f f' :
  cs = cs' -> f =1 f' -> big_sumN cs f = big_sumN cs' f'.
Proof. by move=> <- H; elim: cs=> //= a l ->; f_equal; apply: H. Qed.

Lemma big_sumN_scalar T (cs : seq T) r f :
  eq (big_sumN cs (fun c => r * f c))%num (r * big_sumN cs (fun c => f c))%num.
Proof.
  elim: cs=> /=. rewrite N.mul_0_r. apply N.eq_refl.
  by move => a l IH; rewrite IH Nmult_plus_distr_l.
Qed.


From Coq Require Import ZArith Reals Psatz.
From Flocq Require Import Binary.
From mathcomp Require Import ssreflect ssralg all_algebra seq.

Import List ListNotations.

From vcfloat Require Import FPLang FPLangOpt RAux Rounding Reify Float_notations Automate.
Set Bullet Behavior "Strict Subproofs".

Section WITHNANS.
Context {NANS: Nans}.

Definition sum ty (a b : ftype ty) : ftype ty := BPLUS a b.

Fixpoint sum_fixF ty (L1: list (ftype ty)) : ftype ty :=
  match L1 with
   | hd :: tl => match tl with
                 | [] => hd
                 | _ => sum ty hd (sum_fixF ty tl)
                 end
   | [] => (Zconst ty 0)
  end.

Fixpoint sum_fixR (L1: list R) : R :=
  match L1 with
   | hd :: tl =>  Rplus hd (sum_fixR tl)
   | [] => 0%R
  end.

Definition _a := 1%positive. (* represents current element from list *)
Definition _b := 2%positive. (* represents accumulator of sum *)

Definition vmap_list ty (a b : ftype ty) :=
   [(_a, existT ftype _ a); (_b, existT ftype _ b)].

Definition vmap {ty} (a b : ftype ty) : valmap :=
 ltac:(let z := compute_PTree (valmap_of_list (vmap_list ty a b)) in exact z).

Definition F_max:= powerRZ 2 (femax Tsingle).

Definition F' := F_max * (1-  / (Raux.bpow Zaux.radix2 (fprec Tsingle -1))).

(** a < F'/n * (1+d)^n  **)
(** b < (n-1)* F' / n  + 2 * e/d **)

Definition bmap_list {ty} (n : nat) : list varinfo :=
  let nr := INR n in
  let e  := / 2 * Raux.bpow Zaux.radix2 (3 - femax ty - fprec ty) in
  let d := / 2 * Raux.bpow Zaux.radix2 (- fprec ty + 1) in
  [ Build_varinfo Tsingle _a
      (- (F' / (nr * (1+d)^n) + 2* e/d) ) ((F' / (nr * (1+d)^n)) + 2* e/d) ;
    Build_varinfo Tsingle _b
      (- (F' * (nr - 1) / nr + 2*  e/d))
      (F' * (nr - 1) / nr + 2* e/d ) ].

Definition bmap {ty} (n: nat) : boundsmap :=
 ltac:(let z := compute_PTree (boundsmap_of_list (@bmap_list ty n) ) in exact z).

Definition sum_expr {ty} (a b : ftype ty) := ltac :( let e' :=
  HO_reify_float_expr constr:([_a; _b]) (sum ty) in exact e').

(*** Product***)
Definition prod ty (a b : ftype ty) : ftype ty := BMULT a b.

Definition bmap_list_prod {ty} (n: nat) : list varinfo :=
  let nr := INR n in
  let e  := / 2 * Raux.bpow Zaux.radix2 (3 - femax ty - fprec ty) in
  let d := / 2 * Raux.bpow Zaux.radix2 (- fprec ty + 1) in
  [ Build_varinfo Tsingle _a
      (- sqrt(F' / (nr * (1+d)^n) - e ) )
        ( sqrt( F' / (nr * (1+d)^n) - e )) ;
    Build_varinfo Tsingle _b
      (- sqrt(F' / (nr * (1+d)^n) - e  ))
        ( sqrt( F' / (nr * (1+d)^n) - e ))  ].

Definition bmap_prod {ty} (n: nat) : boundsmap :=
 ltac:(let z := compute_PTree (boundsmap_of_list (@bmap_list_prod ty n) ) in exact z).

Definition prod_expr {ty} (a b : ftype ty) := ltac :( let e' :=
  HO_reify_float_expr constr:([_a; _b]) (prod ty) in exact e').

(** List of product of two lists **)

Fixpoint prod_fixF ty (L: list ((ftype ty) * (ftype ty))) : list (ftype ty) :=
  match L with
  | h :: t => [prod _ (fst h) (snd h)] ++ prod_fixF _ t
  | _ => []
  end.

Fixpoint prod_fixR (L: list (R * R)) : list R :=
  match L with
  | h :: t => [Rmult (fst h) (snd h)] ++ prod_fixR  t
  | _ => []
  end.

Definition dot_prodF ty (L: list ((ftype ty) * (ftype ty))) : ftype ty :=
  sum_fixF _ (prod_fixF _ L).

Definition dot_prodR (L : list (R * R)) : R :=
  sum_fixR (prod_fixR L).

End WITHNANS.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e256m2e32m977_8limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition opp :
  { opp : feBW_small -> feBW_small
  | forall a, phiM_small (opp a) = F.opp (phiM_small a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_opp ().
  Show Ltac Profile.
Time Defined.

Print Assumptions opp.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect.
Require Import ssrbool.
Require Import funs.
Require Import dataset.
Require Import ssrnat.
Require Import znat.
Require Import frac.
Require Import Setoid.
Require Import real.

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

(* Construcion of R = complete totally ordered field.         *)
(* We use the standard Dedekind cut construction.             *)
(* We actually make R into a setoid, taking non-comparability *)
(* as equality. This allows the construction of an internal   *)
(* model in the calculus of constructions, assuming only the  *)
(* classical excluded middle.                                 *)

Section DedekindReals.

Hypothesis Hclassical : excluded_middle.

(* We use nontrivial open upper order ideals of frac to represent the reals. *)

Notation ddseg := (frac -> Prop).

Definition ideals (x : ddseg) := forall f1 f2, leqf f1 f2 -> x f1 -> x f2.

Definition opens (x : ddseg) := forall f, x f -> exists2 f', ltf f' f & x f'.

Definition hass (x : ddseg) := exists f, x f.

Definition hasNs (x : ddseg) := exists f, ~ x f.

Record dreal : Type := Dreal {
  dd_seg : ddseg;
  dd_ideal : ideals dd_seg;
  dd_open : opens dd_seg;
  dd_ub : hass dd_seg;
  dd_lb : hasNs dd_seg
}.

Coercion dd_seg : dreal >-> Funclass.

Definition leqdr (x1 x2 : dreal) := forall f, x2 f -> x1 f.

Definition eqdr (x1 x2 : dreal) := leqdr x1 x2 /\ leqdr x2 x1.

Lemma leqdrr : forall x, leqdr x x. Proof. by move=> x f. Qed.
Implicit Arguments leqdrr [].
Hint Resolve leqdrr.

Lemma eqdr_refl : forall x, eqdr x x. Proof. by split. Qed.
Hint Resolve eqdr_refl.

Lemma eqdr_sym : forall x1 x2, eqdr x1 x2 -> eqdr x2 x1.
Proof. by move=> x1 x2 [Hx12 Hx21]; split. Qed.
Hint Immediate eqdr_sym.

Lemma leqdr_trans : forall x1 x2 x3, leqdr x1 x2 -> leqdr x2 x3 -> leqdr x1 x3.
Proof. by rewrite /leqdr; auto. Qed.

Lemma eqdr_trans : forall x1 x2 x3, eqdr x1 x2 -> eqdr x2 x3 -> eqdr x1 x3.
Proof.
by move=> x1 x2 x3 [Hx12 Hx21] [Hx23 Hx32]; split; apply leqdr_trans with x2.
Qed.

Lemma eqdr_theory : Setoid_Theory dreal eqdr.
Proof. split; auto; exact eqdr_trans. Qed.

Add Setoid dreal eqdr eqdr_theory.

Add Morphism dd_seg : dd_seg_morphism.
Proof. by move=> x y f [_ Hyx]; auto. Qed.

Add Morphism leqdr : leqdr_morphism.
Proof. by move=> x1 y1 x2 y2 Dx1 Dx2 H f; move: (H f); rewrite Dx1 Dx2. Qed.

Lemma eqf_dr : forall (x : dreal) f1 f2, eqf f1 f2 -> (x f1 <-> x f2).
Proof. by move=> x f1 f2; case/andP; split; apply: dd_ideal. Qed.

Section RealFrac.

Variable f : frac.

Definition fracs : ddseg := fun f' => ltf f f'.

Lemma ideals_frac : ideals fracs.
Proof. rewrite /fracs; move=> f1 f2 /= *; eapply ltf_leq_trans; eauto. Qed.

Lemma opens_frac : opens fracs.
Proof. by move=> f3; case/frac_dense=> f2; exists f2. Qed.

Lemma hass_frac : hass fracs.
Proof.
by exists (addf F1 f); rewrite addfC /fracs /ltf -{2}[f]addF0 leqf_add2l.
Qed.

Lemma hasNs_frac : hasNs fracs.
Proof. by exists f; rewrite /fracs ltff. Qed.

Definition fracdr := Dreal ideals_frac opens_frac hass_frac hasNs_frac.

End RealFrac.

Coercion fracdr : frac >-> dreal.

Section RealSup.

Variable E : dreal -> Prop.

Definition supds0 : ddseg := fun f => exists2 f', ltf f' f & forall x, E x -> x f'.

Definition has_supdr0 := hass supds0 /\ hasNs supds0.

Definition supds : ddseg := fun f => IF has_supdr0 then supds0 f else ltf F0 f.

Lemma ideals_sup : ideals supds.
Proof.
move=> f1 f2 Hf12 [] [HE Hf1]; [ left | right ]; split; auto.
  by move: Hf1 => [f Hf HfE]; exists f; first by apply: ltf_leq_trans Hf12.
by apply: ltf_leq_trans Hf12.
Qed.

Lemma opens_sup : opens supds.
Proof.
move=> f [] [HE Hf].
case: Hf => [f2 Hff2 Hf2]; case: (frac_dense Hff2) => [f1 Hff1 Hf12].
  by exists f1; first done; left; split; first done; exists f2.
by case: (frac_dense Hf) => [f1 Hff1 Hf1]; exists f1; first done; right; split.
Qed.

Lemma hass_sup : hass supds.
Proof.
case: (Hclassical has_supdr0) => HE; last by exists F1; right; split.
by case: (HE) => [] [f Hf] _; exists f; left; split.
Qed.

Lemma hasNs_sup : hasNs supds.
Proof.
case: (Hclassical has_supdr0) => HE; last by exists F0; do 2 case; auto.
by case: (HE) => _ [f Hf]; exists f; do 2 case; auto.
Qed.

Definition supdr : dreal := Dreal ideals_sup opens_sup hass_sup hasNs_sup.

End RealSup.

Lemma eqdr_sup : forall E E',
  (forall x x', eqdr x x' -> (E x <-> E' x')) -> eqdr (supdr E) (supdr E').
Proof.
move=> E E' DE; have Esup: forall f, supds0 E f <-> supds0 E' f.
  move=> f; rewrite /supds0; split=> [] [f' Hff' Hf'];
  by exists f'; last by move=> x; case (DE x x); auto.
have Ehas: hass (supds0 E) <-> hass (supds0 E').
  by split=> [] [f Hf]; exists f; move: Hf; rewrite (Esup f).
have EhasN: (hasNs (supds0 E) <-> hasNs (supds0 E')).
  by split=> [][f Hf]; exists f; move: Hf; rewrite (Esup f).
by split=> f;
  rewrite /leqdr /= /supds /has_supdr0 /IF_then_else Ehas EhasN (Esup f).
Qed.

Let hasdr E := exists x : dreal, E x.

Let ubdr E z :=  forall y, (E y : Prop) -> leqdr y z.

Let has_supdr E := hasdr E /\ hasdr (ubdr E).

Let boundeddr x E :=  exists2 y, E y & leqdr x y.

Remark has_supdr0I : forall E, has_supdr E -> has_supdr0 E.
Proof.
move=> E [[x Hx] [z Hz]]; split.
move: (dd_ub z) {x Hx} => [f Hf]; case: (dd_ub f) => [f1].
  move/dd_open=> [f2 Hf12 Hff2]; exists f1; exists f2; first done.
  by move=> x Hx; apply Hz; last by apply: dd_ideal Hf; exact: ltfW.
move: (dd_lb x) {z Hz} => [f Hf]; exists f=> [] [f1 Hff1 Hf1]; case: Hf.
by apply: dd_ideal (Hf1 _ Hx); exact: ltfW.
Qed.
Hint Resolve has_supdr0I.

Lemma ubdr_sup : forall E, has_supdr E -> ubdr E (supdr E).
Proof.
move=> E HE x Hx f [[_ [f' Hff' Hf']]|[[]]]; auto.
apply: (dd_ideal (ltfW Hff')); auto.
Qed.

Lemma leqdr_sup_ub : forall E, has_supdr E ->
  forall x, ubdr E x -> leqdr (supdr E) x.
Proof.
move=> E HE x Hx f; move/dd_open=> [f1 Hff1 Hf1].
by left; split; auto; exists f1; last by move=> y Hy; exact: Hx.
Qed.

Lemma supdr_total : forall x E, has_supdr E -> boundeddr x E \/ leqdr (supdr E) x.
Proof.
move=> x E HE; case: (Hclassical (boundeddr x E)); first by left.
move=> HxE; right; apply leqdr_sup_ub; auto; move=> y Hy f Hxf.
case: (Hclassical (exists2 f', ltf f' f & y f')) => [[f' Hf'f]|Hxy].
  by apply: dd_ideal; apply ltfW.
case: HxE; exists y; move=> // f' Hyf'.
by case: (leqf_cases f f') => *; [ apply: dd_ideal Hxf | case Hxy; exists f' ].
Qed.

Section RealSelect.

(* definition by cases *)

Variables (P : Prop) (x1 x2 : dreal).

Definition selectdr_set x := IF P then eqdr x x1 else eqdr x x2.
Definition selectdr := supdr selectdr_set.

Lemma selectdr_cases : IF P then eqdr selectdr x1 else eqdr selectdr x2.
Proof.
case: (Hclassical P) => HP; [ left | right ]; split=> //.
  have Hsup: has_supdr0 selectdr_set.
    case: (dd_lb x1) (dd_ub x1) => [f1 Hf1] [f2 Hf2]; split.
      case/dd_open: Hf2 => [f3 Hf23 Hf3]; exists f2; exists f3; first done.
      by move=> x [[_ Dx]|[[]]] //; rewrite Dx.
    exists f1; move=> [f3 Hf13 Hf3]; case: Hf1; apply: (dd_ideal (ltfW Hf13)).
    by apply Hf3; left; split.
  split=> f.
    case/dd_open=> [f1 Hff1 Hf1]; left; split=> //; exists f1 => //.
    by move=> x [[_ Dx]|[[]]] //; rewrite Dx.
  case=> [[_ [f1 Hf1f Hf1]]|[[]]] //; apply: (dd_ideal (ltfW Hf1f)).
  by apply Hf1; left; split.
have Hsup: has_supdr0 selectdr_set.
  case: (dd_lb x2) (dd_ub x2) => [f1 Hf1] [f2 Hf2]; split.
    case/dd_open: Hf2 => [f3 Hf23 Hf3]; exists f2; exists f3=> //.
    move=> x [[H _]|[_ Dx]]; try rewrite Dx; tauto.
  exists f1; move=> [f3 Hf13 Hf3]; case: Hf1; apply: (dd_ideal (ltfW Hf13)).
  by apply Hf3; right; split.
split; move=> f.
  case/dd_open=> [f1 Hff1 Hf1]; left; split=> //; exists f1=> //.
  move=> x [[H' _]|[_ Dx]]; rewrite ?Dx; tauto.
case=> [[_ [f1 Hf1f Hf1]]|[[]]] //; apply: (dd_ideal (ltfW Hf1f)).
by apply Hf1; right; split.
Qed.

End RealSelect.

Add Morphism selectdr : selectdr_morphism.
Proof.
move=> P Q x1 y1 x2 y2 DP Dx1 Dx2; apply: eqdr_sup => [x3 y3 Dx3].
rewrite /selectdr_set /IF_then_else DP Dx1 Dx2 Dx3; tauto.
Qed.

Section RealSign.

(* opposite and absolute value. *)

Variable x : dreal.

(* opposite *)

Definition oppds : ddseg := fun f => exists2 f', ltf f' f & ~ x (oppf f').

Lemma ideals_opp : ideals oppds.
Proof.
by move=> f1 f2 Hf12 [f3 Hf23 Hf3]; exists f3; first exact: ltf_leq_trans Hf12.
Qed.

Lemma opens_opp : opens oppds.
Proof.
move=> f1 [f3 Hf13 Hf3]; case/frac_dense: Hf13 => [f2 Hf12 Hf23].
by exists f2; last by exists f3.
Qed.

Lemma hass_opp : hass oppds.
Proof.
move: (dd_lb x) => [f1]; exists (oppf (addf (oppf F1) f1)).
exists (oppf f1); last by rewrite /= oppf_opp.
by rewrite /ltf leqf_opp2 -{1}[f1]addF0 addfC leqf_add2r.
Qed.

Lemma hasNs_opp : hasNs oppds.
Proof.
move: (dd_ub x) => [f Hxf]; exists (oppf f); move=> [f1 Hff1 []].
by apply: dd_ideal Hxf; rewrite -leqf_opp2 oppf_opp ltfW.
Qed.

Definition oppdr := Dreal ideals_opp opens_opp hass_opp hasNs_opp.

(* absolute value *)

Definition absds : ddseg := fun f => x f /\ oppdr f.

Lemma ideals_abs : ideals absds.
Proof.
move=> f1 f2 Hf12 [Hf1 Hf1'].
split; [ exact: dd_ideal Hf1 | exact: ideals_opp Hf1' ].
Qed.

Lemma opens_abs : opens absds.
Proof.
move=> f; case; move/dd_open=> [f1 Hff1 Hf1]; move/opens_opp=> [f2 Hff2 Hf2].
case: (leqf_cases f1 f2) => Hf12.
  by exists f2; last by split; first exact: dd_ideal Hf1.
by exists f1; last by split; last by apply: ideals_opp Hf2; exact: ltfW.
Qed.

Lemma hass_abs : hass absds.
Proof.
move: (dd_ub x) hass_opp => [f1 Hf1] [f2 Hf2].
case: (leqf_cases f1 f2) => Hf12.
  by exists f2; split; first exact: dd_ideal Hf1.
by exists f1; split; last by apply: ideals_opp Hf2; exact: ltfW.
Qed.

Lemma posf_absdr : forall f, absds f -> posf f.
Proof.
move=> f [Hf [f1 Hff1 Hf1]]; rewrite -posfI; apply/idP => [Hf0]; case: Hf1.
apply: dd_ideal Hf; apply: (leqf_trans Hf0); rewrite -oppF0 leqf_opp2.
by apply: leqf_trans Hf0; exact: ltfW.
Qed.

Lemma hasNs_abs : hasNs absds.
Proof. by exists F0; move; move/posf_absdr. Qed.

Definition absdr := Dreal ideals_abs opens_abs hass_abs hasNs_abs.

End RealSign.

Add Morphism oppdr : oppdr_morphism.
Proof.
move=> x y Dx.
split=> f [f' Hff' Hf']; by exists f'; last by move: Hf'; rewrite Dx.
Qed.

Add Morphism absdr : absdr_moprphism.
Proof. move=> x y Dx; split; move=> f; rewrite /= /absds Dx; tauto. Qed.

Lemma oppdr_opp : forall x, eqdr (oppdr (oppdr x)) x.
Proof.
move=> x; split=> f.
  move/dd_open=> [f1 Hff1 Hf1]; exists f1=> // [] [f2 Hf12 []].
  by apply: dd_ideal Hf1; rewrite -leqf_opp2 oppf_opp ltfW.
case: (Hclassical (x f)) => Hf // [f1 Hff1 []].
by exists (oppf f); rewrite /ltf ?leqf_opp2 ?oppf_opp.
Qed.

Lemma absdr_opp : forall x, eqdr (absdr (oppdr x)) (absdr x).
Proof. move=> x; split; move=> f; rewrite /= /absds (oppdr_opp x); tauto. Qed.

Section RealArith.

Variable x1 x2 : dreal.

Definition addds : ddseg := fun f => exists2 f1, x1 f1 & x2 (addf (oppf f1) f).

Lemma ideals_add : ideals addds.
Proof.
move=> f1 f2 Hf12 [f11 Hf11 Hf1']; exists f11=> //.
by apply: dd_ideal Hf1'; rewrite leqf_add2l.
Qed.

Lemma opens_add : opens addds.
Proof.
move=> f2 [f1 Hf1]; move/dd_open=> [f3 Hf23 Hf3]; exists (addf f1 f3).
  by rewrite /ltf -(leqf_eql (addf_inv f1 f2)) addfCA leqf_add2l.
by exists f1; rewrite // (eqf_dr x2 (addf_inv f1 f3)).
Qed.

Lemma hass_add : hass addds.
Proof.
move: (dd_ub x1) (dd_ub x2) => [f1 Hf1] [f2 Hf2]; exists (addf f1 f2).
by exists f1; auto; apply: dd_ideal Hf2; case/andP: (addf_inv f1 f2).
Qed.

Lemma hasNs_add : hasNs addds.
Proof.
move: (dd_lb x1) (dd_lb x2) => [f1 Hf1] [f2 Hf2].
exists (addf f1 f2)=> [] [f3 Hf3 Hf312]; case: Hf2; apply: dd_ideal Hf312.
rewrite -(leqf_eqr (addf_inv f3 f2)) leqf_add2l leqf_add2r.
by apply ltfW; apply/idP => [Hf13]; case Hf1; exact: dd_ideal Hf3.
Qed.

(* x1 + x2 *)
Definition adddr := Dreal ideals_add opens_add hass_add hasNs_add.

Definition amulds : ddseg :=
  fun f => exists2 f1, absdr x1 f1 & absdr x2 (mulf (invf f1) f).

Lemma ideals_amul : ideals amulds.
Proof.
move=> f1 f2 Hf12 [f Hx1f Hx2f]; exists f => //; apply: ideals_abs Hx2f.
rewrite leqf_pmul2l // posf_inv; exact (posf_absdr Hx1f).
Qed.

Lemma opens_amul : opens amulds.
Proof.
move=> f2 [f1 Hxf1]; move/dd_open=> [f3 Hf23 Hf3]; have Hf1 := posf_absdr Hxf1.
exists (mulf f1 f3).
  by rewrite /ltf -(leqf_eql (pmulf_inv f2 Hf1)) mulfCA leqf_pmul2l.
by exists f1; rewrite // (eqf_dr (absdr x2) (pmulf_inv f3 Hf1)).
Qed.

Lemma hass_amul : hass amulds.
Proof.
move: (hass_abs x1) (hass_abs x2) => [f1 Hxf1] [f2 Hxf2].
have Hf1 := posf_absdr Hxf1; exists (mulf f1 f2); exists f1=> //.
by apply: ideals_abs Hxf2; case/andP: (pmulf_inv f2 Hf1).
Qed.

Lemma hasNs_amul : hasNs amulds.
Proof.
by exists F0 => [[f _]]; move/posf_absdr; rewrite -posfI /ltf (leqf_eql (mulF0 _)).
Qed.

(* |x1| * |x2| *)
Definition amuldr := Dreal ideals_amul opens_amul hass_amul hasNs_amul.

Definition pos_muldr := x1 F0 <-> x2 F0.

(* x1 * x2 *)
Definition muldr : dreal := selectdr pos_muldr amuldr (oppdr amuldr).

End RealArith.

(* 1 / |x1| *)
Definition ainvdr x1 := supdr (fun x => amuldr x x1 F1).

(* 1 / x1 *)
Definition invdr (x1 : dreal) := selectdr (x1 F0) (oppdr (ainvdr x1)) (ainvdr x1).

Add Morphism adddr : adddr_morphism.
Proof.
move=> x1 y1 x2 y2 Dx1 Dx2.
by split; move=> f [f' Hf1 Hf2]; exists f'; move: Hf1 Hf2; rewrite ?Dx1 ?Dx2.
Qed.

Add Morphism amuldr : amuldr_morphism.
Proof.
move=> x1 y1 x2 y2 Dx1 Dx2.
by split; move=> f [f' Hf1 Hf2]; exists f'; move: Hf1 Hf2; rewrite ?Dx1 ?Dx2.
Qed.

Add Morphism pos_muldr : pos_muldr_morphism.
Proof. by move=> x1 y1 x2 y2 Dx1 Dx2; rewrite /pos_muldr Dx1 Dx2. Qed.

Add Morphism muldr : muldr_morphism.
Proof. move=> x1 y1 x2 y2 Dx1 Dx2; split=> f; rewrite /muldr Dx1 Dx2; tauto. Qed.

Lemma adddrC : forall x1 x2 : dreal, eqdr (adddr x1 x2) (adddr x2 x1).
Proof.
suffice: forall x1 x2, leqdr (adddr x2 x1) (adddr x1 x2) by split.
move=> x1 x2 f [f' Hf' Hf]; exists (addf (oppf f') f) => //.
apply: dd_ideal Hf'; rewrite oppf_add oppf_opp -addfA addfC -addfA.
by case/andP: (addf_inv f f').
Qed.

Lemma adddrA : forall x1 x2 x3,
  eqdr (adddr x1 (adddr x2 x3)) (adddr (adddr x1 x2) x3).
Proof.
suffice: forall x1 x2 x3, leqdr (adddr (adddr x1 x2) x3) (adddr x1 (adddr x2 x3)).
  split; auto; rewrite (adddrC x1 (adddr x2 x3)) (adddrC (adddr x1 x2) x3).
  by rewrite (adddrC x1 x2) (adddrC x2 x3); auto.
move=> x1 x2 x3 f3 [f1 Hf1 [f2 Hf2 Hf3]].
exists (addf f1 f2); last by rewrite oppf_add -addfA addfCA.
by exists f1=> //; apply: dd_ideal Hf2; case/andP: (addf_inv f1 f2).
Qed.

Lemma adddrI : forall x, eqdr (adddr x (oppdr x)) F0.
Proof.
move=> x; apply eqdr_sym; split=> f.
  move=> [f1 Hf1 [f2 Hf12 Hf2]]; apply/idP => [Hf]; case: Hf2; apply: dd_ideal Hf1.
  rewrite -leqf_opp2 oppf_opp; apply: (leqf_trans (ltfW Hf12)).
  by rewrite -{2}[oppf f1]addF0 leqf_add2l.
rewrite /= /fracs posfI; move=> Hf; pose fn (n : nat) := Frac 0 n.
have [n Hn]: exists n, absdr x (mulf f (fn n)).
  case: (hass_abs x) => [f1 Hxf1].
  case Dn: (mulf (invf f) f1) => [d [n|n]].
    exists n; apply: ideals_abs Hxf1.
    rewrite -(leqf_eql (pmulf_inv f1 Hf)) mulfCA leqf_pmul2l // {}Dn /fn /=.
    by rewrite scalez_pos leqz_nat /= leq_addr.
  by move: (posf_absdr Hxf1); rewrite -(@posf_pmull (invf f) f1) ?posf_inv ?Dn.
elim: n Hn => [|n].
  by move/posf_absdr; rewrite /fn -/F0 -posfI /ltf (leqf_eql (mulF0 f)).
set f' := mulf f (fn n) => Hrec Hn.
have Hff': absdr x (addf f f').
  by apply: dd_ideal Hn; rewrite -{2}[f]mulf1; case/andP: (mulf_addr f F1 (fn n)).
case/dd_open: Hff' => [f1 Hff1 [Hf1 Hf1']]; set f2 := addf (oppf f) f1.
case: (Hclassical (x f')) {Hn Hf} => Hf'.
  case: (Hclassical (x (oppf f2))) => Hf2.
    exists (oppf f2) => //.
    by rewrite oppf_opp addfC /f2 addfCA (eqf_dr (oppdr x) (addf_inv f f1)).
  apply Hrec; split=> //.
  by exists f2; rewrite // /ltf -(leqf_eql (addf_inv f f')) /f2 leqf_add2l.
exists f1 => //; exists (oppf f'); last by rewrite oppf_opp.
rewrite /ltf -[f]oppf_opp -oppf_add leqf_opp2 addfC.
by rewrite -(leqf_eql (addf_inv f f')) leqf_add2l.
Qed.

Lemma add0dr : forall x, eqdr (adddr F0 x) x.
Proof.
move=> x; split=> f.
  move/dd_open=> [f1 Hf1 Hxf1]; exists (addf (oppf f1) f).
    by rewrite /= /fracs /ltf -(leqf_eqr (addf_inv f1 F0)) addF0 leqf_add2l.
  by rewrite oppf_add oppf_opp -addfA addfC -addfA (eqf_dr x (addf_inv f f1)).
move=> [f1 Hf1]; apply: dd_ideal; rewrite -{2}[f]addF0 addfC leqf_add2l.
by rewrite -oppF0 leqf_opp2 ltfW.
Qed.

Lemma oppdr_add : forall x1 x2,
   eqdr (oppdr (adddr x1 x2)) (adddr (oppdr x1) (oppdr x2)).
Proof.
move=> x1 x2; set y1 := oppdr x1; set y2 := oppdr x2.
set y := oppdr (adddr x1 x2); rewrite -(add0dr (adddr y1 y2)) -(adddrI y).
rewrite -(adddrA y (oppdr y) (adddr y1 y2)) (adddrA (oppdr y) y1 y2).
rewrite {3}/y (oppdr_opp (adddr x1 x2)) (adddrC x1 x2) -(adddrA x2 x1 y1).
rewrite /y1 (adddrI x1) (adddrC x2 F0) (add0dr x2) /y2 (adddrI x2).
by rewrite (adddrC y F0) (add0dr y).
Qed.

Lemma adddr_monotony : forall x1 x2 x3, leqdr x2 x3 ->
  leqdr (adddr x1 x2) (adddr x1 x3).
Proof. move=> x1 x2 x3 Hx12 f2 [f1 Hf1 Hf2]; exists f1; auto. Qed.

Lemma amuldrC : forall x1 x2 : dreal, eqdr (amuldr x1 x2) (amuldr x2 x1).
Proof.
suffice: forall x1 x2, leqdr (amuldr x2 x1) (amuldr x1 x2) by split.
move=> x1 x2 f [f' Hf' Hf]; exists (mulf (invf f') f) => //.
apply: dd_ideal (Hf'); move/posf_absdr: Hf => Hf.
rewrite -(leqf_pmul2l Hf) mulfCA (leqf_eqr (pmulf_inv f Hf)).
by rewrite mulfC mulfCA; case/andP: (pmulf_inv f (posf_absdr Hf')).
Qed.

Lemma pos_muldrC : forall x1 x2, pos_muldr x1 x2 <-> pos_muldr x2 x1.
Proof. by split; case; split. Qed.

Lemma muldrC : forall x1 x2, eqdr (muldr x1 x2) (muldr x2 x1).
Proof. by move=> x1 x2; rewrite /muldr (pos_muldrC x1 x2) (amuldrC x1 x2). Qed.

Lemma amuldr_opp : forall x1 x2, eqdr (amuldr (oppdr x1) x2) (amuldr x1 x2).
Proof.
suffice: forall x1 x2, leqdr (amuldr x1 x2) (amuldr (oppdr x1) x2).
  by move=> Hrec x1 x2; split=> // f Hf; apply Hrec; rewrite (oppdr_opp x1).
by move=> x1 x2 f [f' Hf' Hf]; exists f'; rewrite // -(absdr_opp x1).
Qed.

Lemma pos_absdr : forall x : dreal, ~ x F0 -> eqdr (absdr x) x.
Proof.
move=> x Hx; split=> f Hf; last by case Hf.
by split=> //; exists F0=> //; apply/idP => Hf0; case: Hx; exact: dd_ideal Hf.
Qed.

Lemma oppdr0 : eqdr (oppdr F0) F0.
Proof. by set f0 := oppdr F0; rewrite -(adddrI F0) -/f0 (add0dr f0). Qed.

Lemma leqdr_opp2 : forall x1 x2, leqdr x1 x2 -> leqdr (oppdr x2) (oppdr x1).
Proof. move=> x1 x2 Hx12 f1 [f2 Hf12 Hf2]; exists f2; auto. Qed.

Lemma pos_leqdr : forall x : dreal, ~ x F0 -> leqdr F0 x.
Proof. by move=> x Hx f Hxf; apply/idP => Hf; case: Hx; exact: dd_ideal Hxf. Qed.

Lemma pos_oppdr1 : forall x : dreal, x F0 -> ~ oppdr x F0.
Proof.
by move=> x Hx [f Hf []]; apply: dd_ideal Hx; rewrite -oppF0 leqf_opp2 ltfW.
Qed.

Lemma pos_oppdr2 : forall x : dreal, ~ x F0 -> ~ oppdr x F0 -> eqdr x F0.
Proof.
move: pos_leqdr; split; auto.
by rewrite -(oppdr_opp x) -oppdr0; apply leqdr_opp2; auto.
Qed.

Lemma pos_amuldr : forall x1 x2, ~ amuldr x1 x2 F0.
Proof.
move=> x1 x2 [] f _; move/posf_absdr; rewrite -posfI; case/idP.
by case/andP: (mulF0 (invf f)).
Qed.

Lemma oppdr_cases : forall P : dreal -> Prop,
   (forall x, P (oppdr x) -> P x) -> (forall x : dreal, ~ x F0 -> P x) ->
  forall x, P x.
Proof. move=> P Hopp H0 x; case: (Hclassical (x F0)) pos_oppdr1; auto. Qed.

Lemma amul0dr : forall x, eqdr (amuldr F0 x) F0.
Proof.
move=> x; split=> f; last by apply pos_leqdr; apply pos_amuldr.
case: (dd_ub (absdr x)) => [f1 Hxf1] Hf.
have Hf1 := posf_absdr Hxf1; pose f2 := mulf (invf f1) f.
have Hf2: posf f2 by rewrite /f2 posf_pmull ?posf_inv // -posfI.
exists f2; first by rewrite /= /absds oppdr0; rewrite -posfI in Hf2; split.
apply: dd_ideal Hxf1; rewrite -(leqf_eql (pmulf_inv f1 Hf2)).
rewrite leqf_pmul2l ?posf_inv // /f2 mulfC mulfCA.
by case/andP: (pmulf_inv f Hf1).
Qed.

Lemma muldr_oppl : forall x1 x2, eqdr (muldr (oppdr x1) x2) (oppdr (muldr x1 x2)).
Proof.
move=> x1 x2; elim/oppdr_cases: x1 => x1 Hx1.
  by rewrite -(oppdr_opp (muldr (oppdr x1) x2)) -Hx1 (oppdr_opp x1).
rewrite /muldr (amuldr_opp x1 x2); set y := amuldr x1 x2.
case: (selectdr_cases (pos_muldr x1 x2) y (oppdr y)) => [] [Hx12 Dy];
  case: (selectdr_cases (pos_muldr (oppdr x1) x2) y (oppdr y)) => [] [Hx21 Dy'];
  rewrite Dy Dy' ?(oppdr_opp y) //; rewrite /pos_muldr /= -/F0 in Hx12 Hx21.
- have Dx1: eqdr x1 F0 by apply: pos_oppdr2; rewrite //= Hx21 -Hx12.
  by rewrite /y Dx1 (amul0dr x2) oppdr0.
have Dx1: eqdr x1 F0 by apply: pos_oppdr2 => // Hx1'; case: Hx12; tauto.
by rewrite /y Dx1 (amul0dr x2) oppdr0.
Qed.

Lemma muldr_oppr : forall x1 x2, eqdr (muldr x1 (oppdr x2)) (oppdr (muldr x1 x2)).
Proof.
by move=> x1 x2; rewrite (muldrC x1 (oppdr x2)) (muldr_oppl x2 x1) (muldrC x2 x1).
Qed.

Lemma absdr_amul : forall x1 x2, eqdr (absdr (amuldr x1 x2)) (amuldr x1 x2).
Proof.
move=> x1 x2; split=> f Hf; last by case Hf.
split=> //; case/dd_open: Hf => [f' Hff' Hf']; exists f' => //.
case=> f1; move/posf_absdr=> Hf1; move/posf_absdr.
rewrite posf_pmull ?posf_inv // posf_opp nnegf_0Vpos; case/orP; right.
case: Hf' => f2; move/posf_absdr=> Hf2; move/posf_absdr.
by rewrite posf_pmull ?posf_inv.
Qed.

Lemma amuldrA : forall x1 x2 x3,
  eqdr (amuldr x1 (amuldr x2 x3)) (amuldr (amuldr x1 x2) x3).
Proof.
suffice: forall x1 x2 x3,
   leqdr (amuldr (amuldr x1 x2) x3) (amuldr x1 (amuldr x2 x3)).
- move=> Hrec x1 x2 x3; split=> //.
  rewrite (amuldrC (amuldr x1 x2) x3) (amuldrC x1 (amuldr x2 x3)).
  by rewrite (amuldrC x2 x3) (amuldrC x1 x2).
move=> x1 x2 x3 f3 [f1 Hf1 [[f2 Hf2 Hf3] _]]; exists (mulf f1 f2).
  rewrite (absdr_amul x1 x2); exists f1 => //.
  by apply: ideals_abs Hf2; case/andP: (pmulf_inv f2 (posf_absdr Hf1)).
move/posf_absdr: Hf1 => Hf1; move/posf_absdr: Hf2 => Hf2.
apply: ideals_abs Hf3; rewrite -(leqf_pmul2l Hf2) mulfCA.
rewrite (leqf_eql (pmulf_inv _ Hf2)) -(leqf_pmul2l Hf1) mulfCA.
rewrite (leqf_eql (pmulf_inv f3 Hf1)) mulfA mulfCA.
by rewrite -(posf_pmull f2 Hf1) in Hf2; case/andP: (pmulf_inv f3 Hf2).
Qed.

Lemma eqdr_opp2 : forall x1 x2, eqdr (oppdr x1) (oppdr x2) -> eqdr x1 x2.
Proof. move=> x1 x2 Hx12; rewrite -(oppdr_opp x1) Hx12; exact: oppdr_opp. Qed.

Lemma pos_muldr2 : forall x1 x2 : dreal, ~ x1 F0 -> ~ x2 F0 ->
  eqdr (muldr x1 x2) (amuldr x1 x2).
Proof.
move=> x1 x2 Hx1 Hx2; rewrite /muldr; move: (amuldr x1 x2) => y.
case: (selectdr_cases (pos_muldr x1 x2) y (oppdr y)) => [[_ Dy]|[[]]] //.
split; tauto.
Qed.

Lemma muldrA : forall x1 x2 x3,
  eqdr (muldr x1 (muldr x2 x3)) (muldr (muldr x1 x2) x3).
Proof.
elim/oppdr_cases=> x1 Hx1 x2 x3.
  apply eqdr_opp2; rewrite -(muldr_oppl x1 (muldr x2 x3)).
  by rewrite -(muldr_oppl (muldr x1 x2) x3) -(muldr_oppl x1 x2).
elim/oppdr_cases: x2 => x2 Hx2.
  apply eqdr_opp2; rewrite -(muldr_oppr x1 (muldr x2 x3)).
  rewrite -(muldr_oppl (muldr x1 x2) x3) -(muldr_oppr x1 x2).
  by rewrite -(muldr_oppl x2 x3).
elim/oppdr_cases: x3 => x3 Hx3.
  apply eqdr_opp2; rewrite -(muldr_oppr x1 (muldr x2 x3)).
  by rewrite -(muldr_oppr (muldr x1 x2) x3) -(muldr_oppr x2 x3).
rewrite (pos_muldr2 Hx2 Hx3) (pos_muldr2 Hx1 (@pos_amuldr x2 x3)).
rewrite (pos_muldr2 Hx1 Hx2) (pos_muldr2 (@pos_amuldr x1 x2) Hx3); apply amuldrA.
Qed.

Lemma muldr_addr : forall x1 x2 x3,
 eqdr (muldr x1 (adddr x2 x3)) (adddr (muldr x1 x2) (muldr x1 x3)).
Proof.
move=> x1 x2 x3; set x := adddr x2 x3; elim/oppdr_cases: x1 => x1 Hx1.
  rewrite -(oppdr_opp x1); set y1 := oppdr x1.
  rewrite (muldr_oppl y1 x) (muldr_oppl y1 x2) (muldr_oppl y1 x3).
  rewrite /y1 {}Hx1; exact: oppdr_add.
have Dx: eqdr x (adddr x2 x3) by done.
elim/oppdr_cases: {x2 x3}x (x2) (x3) Dx => x Hx x2 x3 Dx.
  have Dnx: eqdr (oppdr x) (adddr (oppdr x2) (oppdr x3)).
    rewrite Dx; exact: oppdr_add.
  rewrite -(oppdr_opp x) (muldr_oppr x1 (oppdr x)) (Hx _ _ Dnx).
  rewrite (muldr_oppr x1 x2) (muldr_oppr x1 x3).
  rewrite -(oppdr_add (muldr x1 x2) (muldr x1 x3)); exact: oppdr_opp.
move: Hx; rewrite {x}Dx; move: x2 x3.
suffice Hrec: forall x2 x3 : dreal, ~ x2 F0 -> ~ x3 F0 ->
    eqdr (muldr x1 (adddr x2 x3)) (adddr (muldr x1 x2) (muldr x1 x3)).
- suffice Hneg: forall x2 x3 : dreal, x2 F0 -> ~ adddr x2 x3 F0 ->
      eqdr (muldr x1 (adddr x2 x3)) (adddr (muldr x1 x2) (muldr x1 x3)).
  + move=> x2 x3; case (Hclassical (x3 F0)); case (Hclassical (x2 F0)); eauto.
    move=> Hx2 Hx3; rewrite (adddrC (muldr x1 x2) (muldr x1 x3)) (adddrC x2 x3).
    by eauto.
  move=> x2 x3; set x := adddr x2 x3; move/pos_oppdr1=> Hx2 Hx.
  rewrite -(add0dr x3) -(adddrI x2) (adddrC x2 (oppdr x2)).
  rewrite -(adddrA (oppdr x2) x2 x3) -/x (Hrec _ _ Hx2 Hx) (muldr_oppr x1 x2).
  move: (muldr x1 x2) (muldr x1 x) => y2 y.
  by rewrite (adddrA y2 (oppdr y2) y) (adddrI y2) (add0dr y).
move=> x2 x3 Hx2 Hx3; have Hx23: ~ adddr x2 x3 F0.
  move=> [f1 Hx2f1 Hx3f1]; case: Hx3; apply: dd_ideal Hx3f1.
  rewrite addF0 -oppF0 leqf_opp2; apply ltfW; apply/idP => [Hf1].
  by case: Hx2; exact: dd_ideal Hx2f1.
rewrite (pos_muldr2 Hx1 Hx23) (pos_muldr2 Hx1 Hx2) (pos_muldr2 Hx1 Hx3).
apply eqdr_sym; split=> f.
  case=> f1; rewrite (pos_absdr Hx23); move=> Hxf1 [f2 Hf2 Hf3].
  have Hf1 := posf_absdr Hxf1; exists (mulf f1 f2).
    by exists f1; rewrite // (pos_absdr Hx2) (eqf_dr x2 (pmulf_inv f2 Hf1)).
  exists f1; rewrite // (pos_absdr Hx3); apply: dd_ideal Hf3.
  rewrite (leqf_eqr (mulf_addr (invf f1) (oppf (mulf f1 f2)) f)) leqf_add2r.
  by rewrite -mulf_oppr; case/andP: (pmulf_inv (oppf f2) Hf1).
case=> f2; case=> f12; rewrite (pos_absdr Hx2) => Hxf12 Hxf2.
case=> f13; rewrite (pos_absdr Hx3) => Hxf13 Hxf3.
have [f1 Hxf1 [Hf12 Hf13]]: exists2 f1, absdr x1 f1 & leqf f1 f12 /\ leqf f1 f13.
  case: (leqf_cases f12 f13) => Hf123.
    by exists f12; last by split; first exact: leqff.
  by exists f13; last by split; [ exact: ltfW | exact: leqff ].
exists f1; rewrite // (pos_absdr Hx23); have Hf1 := posf_absdr Hxf1.
exists (mulf (invf f1) f2).
  have Hf120 := posf_absdr Hxf12; have Hf2: posf f2.
    move: Hxf2; rewrite -(pos_absdr Hx2); move/posf_absdr.
    by rewrite posf_pmull ?posf_inv.
  apply: dd_ideal Hxf2; rewrite -(leqf_pmul2l Hf120) mulfCA.
  rewrite (leqf_eql (pmulf_inv f2 Hf120)) -(leqf_pmul2l Hf1) !mulfA -!(mulfC f2).
  by rewrite (leqf_pmul2l Hf2) mulfC (leqf_eqr (pmulf_inv f12 Hf1)).
apply: dd_ideal (Hxf3); move: Hxf3; rewrite -(pos_absdr Hx3); move/posf_absdr.
rewrite -mulf_oppr -(leqf_eqr (mulf_addr (invf f1) (oppf f2) f)).
move: (addf (oppf f2) f) => f3 Hf3'; have Hf130 := posf_absdr Hxf13.
have Hf3: posf f3 by move: Hf3'; rewrite posf_pmull ?posf_inv.
rewrite -(leqf_pmul2l Hf130) mulfCA.
rewrite (leqf_eql (pmulf_inv f3 Hf130)) -(leqf_pmul2l Hf1) !mulfA -!(mulfC f3).
by rewrite (leqf_pmul2l Hf3) mulfC (leqf_eqr (pmulf_inv f13 Hf1)).
Qed.

Lemma mul1dr : forall x, eqdr (muldr F1 x) x.
Proof.
elim/oppdr_cases=> x Hx; first by apply eqdr_opp2; rewrite -Hx (muldr_oppr F1 x).
have HpF1: ~ fracdr F1 F0 by done.
rewrite (pos_muldr2 HpF1 Hx); split=> f.
  move/dd_open=> [f1 Hff1 Hx1]; rewrite (amuldrC F1 x).
  exists f1; first by rewrite (pos_absdr Hx).
  have Hf1: (posf f1) by move: Hx1; rewrite -(pos_absdr Hx); exact: posf_absdr.
  rewrite (pos_absdr HpF1) /= /fracs /ltf -(leqf_eqr (pmulf_inv F1 Hf1)).
  by rewrite mulf1 leqf_pmul2l ?posf_inv.
case=> [f1 Hxf1 Hxf]; move: (Hxf); rewrite (pos_absdr Hx); apply: dd_ideal.
rewrite -(leqf_eqr (pmulf_inv f (posf_absdr Hxf1))) mulfCA.
move: (mulf (invf f1) f) (posf_absdr Hxf) Hxf1 => y Hy.
rewrite (pos_absdr HpF1) mulfC -{1}[y]mulf1 leqf_pmul2l //; exact: ltfW.
Qed.

Lemma muldr_monotony : forall x x1 x2, leqdr F0 x -> leqdr x1 x2 ->
  leqdr (muldr x x1) (muldr x x2).
Proof.
move=> /= x x1 x2 Hx Hx12; set y1 := muldr x x1; set y2 := muldr x x2.
rewrite -(add0dr y2) -(adddrI y1) -(adddrA y1 (oppdr y1) y2) {2 3}/y1 -(add0dr y1).
rewrite -(muldr_oppr x x1) -/y1 (adddrC F0 y1); apply adddr_monotony.
move: {y1 Hx12}(adddr_monotony (x1 := oppdr x1) Hx12).
rewrite {}/y2 -(muldr_addr x (oppdr x1) x2) (adddrC (oppdr x1) x1) (adddrI x1).
move: {x1 x2}(adddr (oppdr x1) x2) => y Hy.
have Hp0: forall z, leqdr F0 z -> ~ z F0.
  by move=> z Hz Hz0; move: (Hz _ Hz0); rewrite /= /fracs ltff.
rewrite (pos_muldr2 (Hp0 _ Hx) (Hp0 _ Hy)); apply pos_leqdr; exact: pos_amuldr.
Qed.

Lemma invdr_opp : forall x, eqdr (invdr (oppdr x)) (oppdr (invdr x)).
Proof.
move=> x; rewrite /invdr; set y := ainvdr x.
have Dy': eqdr (ainvdr (oppdr x)) y.
  apply: {y}eqdr_sup => y z Dy.
  rewrite (amuldrC y (oppdr x)) (amuldr_opp x y) (amuldrC x y) Dy; tauto.
rewrite {}Dy'; case: (selectdr_cases (x F0) (oppdr y) y) => [] [Hx Ey];
  case: (selectdr_cases (oppdr x F0) (oppdr y) y) => [] [Hx' Ey'];
  rewrite {}Ey {}Ey' ?(oppdr_opp y) //; try by case/pos_oppdr1: Hx.
suffice ->: eqdr y F0 by rewrite oppdr0.
suffice HxF1: ~ has_supdr0 (fun z => amuldr z x F1).
  split=> f; rewrite /y /ainvdr /= /supds /IF_then_else; tauto.
move=> [[f [f' Hff' Hf']] _]; case/idP: Hff'; apply ltfW; apply (Hf' f).
by rewrite (amuldrC f x) (pos_oppdr2 Hx Hx') (amul0dr f).
Qed.

Lemma muldrI : forall x, ~ eqdr x F0 -> eqdr (muldr x (invdr x)) F1.
Proof.
elim/oppdr_cases=> x Hx Hx0.
  rewrite -(oppdr_opp (invdr x)) -(invdr_opp x) (muldr_oppr x (invdr (oppdr x))).
  rewrite -(muldr_oppl x (invdr (oppdr x))); apply: Hx => Hx'.
  by case: Hx0; apply: eqdr_opp2; rewrite oppdr0.
rewrite /invdr; set y := ainvdr x.
case: (selectdr_cases (x F0) (oppdr y) y) => [[Hx' _]|[_ Dy]]; first by case Hx.
rewrite Dy; case: (Hclassical (exists2 f, posf f & ~ x f));
  last by move=> Hx'; case: Hx0; apply: (pos_oppdr2 Hx) => [[f Hf Hxf]];
          case: Hx'; exists (oppf f); first by rewrite posf_opp -nnegfI.
move=> [f0 Hf0 Hxf0]; pose aix z := amuldr z x F1.
have Haix0: aix F0 by rewrite /aix (amul0dr x).
have Haix: has_supdr aix.
  split; first by exists (F0 : dreal).
  exists (invf f0 : dreal)=> x'; rewrite /aix (amuldrC x' x).
  move=> [f Hxf]; have Hf := posf_absdr Hxf.
  move=> [H _] f' Hf'; apply: dd_ideal H; move/ltfW: Hf'; apply: leqf_trans.
  rewrite mulf1 -(leqf_pmul2l Hf) -(leqf_pmul2l Hf0) mulfC -mulfA mulfCA.
  rewrite (leqf_eql (pmulf_inv f0 Hf)) (mulfC f) mulfCA.
  rewrite (leqf_eqr (pmulf_inv f Hf0)); apply ltfW; apply/idP => [Hff0].
  by case: Hxf0; case: Hxf => [H _]; exact: dd_ideal H.
have Hyub: ubdr aix y by exact: ubdr_sup.
have Hysup: forall z, ubdr aix z -> leqdr y z by move=> z Hz; exact: leqdr_sup_ub.
have Hy0: ~ y F0.
  by move/dd_open=> [f' Hf'0 Hyf']; case/idP: (Hyub _ Haix0 _ Hyf'); exact: ltfW.
rewrite (pos_muldr2 Hx Hy0); split=> f.
  move=> Hf; have Hpf: posf f by rewrite -posfI; exact: leqf_lt_trans Hf.
  pose e := addf F1 (oppf (invf f)); have He: posf e.
    rewrite -posfI /ltf /e addfC -(leqf_eqr (addf_inv (invf f) F0)) leqf_add2l.
    rewrite addF0 -[invf f]mulf1 -(leqf_pmul2l Hpf) mulf1 mulfCA.
    by rewrite (leqf_eqr (pmulf_inv F1 Hpf)).
  pose e0 := mulf e f0.
  have: fracdr F0 e0 by rewrite /= /fracs posfI /e0 posf_pmull.
  rewrite -(adddrI x); move=> [f1 Hxf1 [f2 Hf12 Hxf2]].
  have Hf10: ltf f0 f1 by apply/idP => [Hf10]; case: Hxf0; exact: dd_ideal Hxf1.
  exists f1; first by rewrite (pos_absdr Hx).
  have Hf1: posf f1.
    by move: Hf0 (ltfW Hf10); rewrite -!posfI; exact: ltf_leq_trans.
  have Hf2: posf (oppf f2).
    rewrite posf_opp -nnegfI; apply: (ltf_leq_trans Hf12).
    rewrite -(leqf_eqr (addf_inv f1 F0)) addF0 leqf_add2l.
    apply: leqf_trans (ltfW Hf10); rewrite -[f0]addF0 /e0 mulfC.
    rewrite /e (leqf_eql (mulf_addr f0 F1 (oppf (invf f)))) mulf1 leqf_add2l.
    rewrite mulf_oppr -oppF0 leqf_opp2; apply ltfW.
    by rewrite posfI posf_pmull ?posf_inv.
  suffice: ubdr aix (invf (oppf f2)).
    rewrite (pos_absdr Hy0); move/Hysup; apply.
    rewrite /= /fracs /ltf -(leqf_pmul2l Hf1) mulfCA (leqf_eql (pmulf_inv f Hf1)).
    rewrite mulfC -(leqf_eql (pmulf_inv f Hf2)) leqf_pmul2l ?posf_inv //.
    rewrite mulfC -(leqf_eqr (pmulf_inv f1 Hpf)) mulfCA leqf_pmul2l ?posf_inv //.
    rewrite -leqf_opp2 oppf_opp -mulf_oppl mulfC; apply: (ltf_leq_trans Hf12).
    rewrite -(leqf_add2l f1) addfCA (leqf_eql (addf_inv f1 e0)).
    rewrite -{1}[f1]mulf1 -(leqf_eqr (mulf_addr f1 F1 (oppf (invf f)))) -/e.
    by rewrite mulfC /e0 leqf_pmul2l // ltfW.
  move=> z; rewrite /aix (amuldrC z x); move=> [f3 Hxf3 [Hf3 _]] f4 Hf4.
  apply: dd_ideal Hf3; move/ltfW: Hf4; apply: {f4}leqf_trans.
  have Hf3 := posf_absdr Hxf3; rewrite -(leqf_pmul2l Hf3) mulfCA.
  rewrite (leqf_eql (pmulf_inv F1 Hf3)) mulfC -(leqf_eql (pmulf_inv F1 Hf2)).
  rewrite mulf1 leqf_pmul2l ?posf_inv //; apply ltfW; apply/idP => Hf23.
  by case: Hxf2; apply: (dd_ideal Hf23); case: Hxf3.
move=> [f1 Hxf1]; set f2 := mulf (invf f1) f => Hyf2; apply/idP => Hf.
have Hf1 := posf_absdr Hxf1; have Hf2 := posf_absdr Hyf2.
suffice: aix f2.
  by case: Hyf2 => [Hyf2 _] Hxf2; case/idP: (Hyub _ Hxf2 _ Hyf2); exact: leqff.
rewrite /aix (amuldrC f2 x); move/dd_open: Hxf1 => [f3 Hf13 Hxf3].
have Hf3 := posf_absdr Hxf3.
have Hf20: ~ f2 F0 by case/idP; apply ltfW; rewrite posfI.
exists f3; rewrite // (pos_absdr Hf20) /= /fracs /ltf.
rewrite -(leqf_pmul2l Hf3) mulfCA (leqf_eql (pmulf_inv F1 Hf3)).
apply: ltf_leq_trans Hf; rewrite /ltf -(leqf_eql (pmulf_inv f Hf1)) mulfCA -/f2.
by rewrite -!(mulfC f2) leqf_pmul2l.
Qed.

Theorem dedekind_reals : real_model.
Proof.
apply: (RealModel
          (@RealAxioms (RealStructure _ _ _ _ _ _ _ _) leqdrr leqdr_trans
             ubdr_sup supdr_total adddr_monotony adddrC adddrA add0dr adddrI
             muldr_monotony muldrC muldrA muldr_addr mul1dr muldrI _)) => /=.
by case=> [H _]; move: (H (invf F2) (erefl _)).
Qed.

End DedekindReals.

Set Strict Implicit.
Unset Implicit Arguments.