Require Import util.
Require Import Fourier.
Require Export flow.
Set Implicit Arguments.
Open Local Scope R_scope.

Require Import Coq.Reals.Reals.

Section function_properties.

  Variable f: R -> R.

  Definition strongly_increasing: Prop :=
    forall x x', x < x' -> f x < f x'.
  Definition strongly_decreasing: Prop :=
    forall x x', x < x' -> f x' < f x.

  Lemma mildly_increasing:
    strongly_increasing -> forall x x', x <= x' -> f x <= f x'.
  Proof with auto with real.
    intros.
    destruct H0...
    subst...
  Qed.

  Lemma mildly_decreasing:
    strongly_decreasing -> forall x x', x <= x' -> f x' <= f x.
  Proof with auto with real.
    intros.
    destruct H0...
    subst...
  Qed.

  Lemma strongly_increasing_rev: strongly_increasing -> forall x x', f x < f x' -> x < x'.
  Proof with auto with real.
    unfold strongly_increasing.
    intros.
    destruct (Rlt_le_dec x x')...
    destruct (Rle_lt_or_eq_dec x' x r).
      elimtype False...
      apply (Rlt_asym _ _  H0)...
    subst.
    elimtype False.
    apply (Rlt_irrefl _ H0).
  Qed.

  Lemma strongly_decreasing_rev: strongly_decreasing -> forall x x', f x < f x' -> x' < x.
  Proof with auto with real.
    unfold strongly_decreasing.
    intros.
    destruct (Rlt_le_dec x x').
      elimtype False...
      apply (Rlt_asym _ _  H0)...
    destruct (Rle_lt_or_eq_dec x' x r)...
    subst.
    elimtype False.
    apply (Rlt_irrefl _ H0).
  Qed.

  Definition monotonic: Set := { strongly_increasing } + { strongly_decreasing }.

  Lemma mono_eq: monotonic -> forall x x', f x = f x' <-> x = x'.
  Proof with auto.
    split.
      intros.
      destruct (Rle_lt_dec x x').
        destruct r...
        elimtype False.
        destruct H; set (s _ _ H1); rewrite H0 in r; apply Rlt_irrefl with (f x')...
      elimtype False.
      destruct H; set (s _ _ r); rewrite H0 in r0; apply Rlt_irrefl with (f x')...
    intros. subst...
  Qed.

End function_properties.

Section single_inverses.

  Variable f: Flow R.

  Definition mono: Set :=
    { forall x, strongly_increasing (f x) } +
    { forall x, strongly_decreasing (f x) }.

  Variable fmono: mono.

  Lemma purify_mono: forall x, monotonic (f x).
  Proof.
    intros.
    unfold monotonic.
    destruct fmono; set (s x); [left | right]; assumption.
  Qed.

  Definition mle (x x': R): Prop := if fmono then x <= x' else x' <= x.
  Definition mlt (x x': R): Prop := if fmono then x < x' else x' < x.

  Lemma mle_refl x: mle x x.
  Proof. unfold mle. destruct fmono; simpl; auto with real. Qed.

  Lemma mle_trans x y z: mle x y -> mle y z -> mle x z.
  Proof.
    unfold mle.
    destruct fmono; simpl; intros; apply Rle_trans with y; assumption.
  Qed.

  Lemma mlt_le x x': mlt x x' -> mle x x'.
  Proof. unfold mlt, mle. destruct fmono; simpl; auto with real. Qed.

  Lemma mle_lt_or_eq_dec x x':
    mle x x' -> { mlt x x' } + { x = x' }.
  Proof with auto with real.
    unfold mle, mlt.
    destruct fmono; simpl; intros.
      apply Rle_lt_or_eq_dec...
    destruct (Rle_lt_or_eq_dec _ _ H)...
  Qed.

  Lemma mono_opp v t t': t' <= t -> mle (f v t') (f v t).
  Proof with auto with real.
    unfold mle.
    destruct fmono.
      intros.
      set (s v).
      unfold strongly_increasing in s0.
      destruct H...
      subst...
    intros.
    set (s v).
    unfold strongly_increasing in s0.
    destruct H...
    subst...
  Qed.

  Variables
    (inv: R -> R -> Time)
    (inv_correct: forall x x', f x (inv x x') = x').

  Definition f_eq x t t': f x t = f x t' <-> t = t'
    := mono_eq (purify_mono x) t t'.

  Lemma inv_correct' x t: inv x (f x t) = t.
  Proof.
    intros.
    destruct (f_eq x (inv x (f x t)) t).
    clear H0. apply H.
    rewrite inv_correct. reflexivity.
  Qed.

  Lemma inv_plus x y z: inv x z = inv x y + inv y z.
  Proof with auto.
    intros. destruct (f_eq x (inv x z) (inv x y + inv y z)).
    clear H0. apply H.
    rewrite flow_additive...
    repeat rewrite inv_correct...
  Qed.

  Lemma inv_refl x: inv x x = 0.
  Proof with auto.
    intros. destruct (f_eq x (inv x x) 0).
    clear H0. apply H.
    repeat rewrite inv_correct...
    rewrite flow_zero...
  Qed.

  Lemma f_lt x t t': mlt (f x t) (f x t') -> t < t'.
  Proof with auto with real.
    unfold mlt.
    destruct fmono; intros.
      apply strongly_increasing_rev with (f x)...
    apply strongly_decreasing_rev with (f x)...
  Qed.

  Lemma f_le x t t': mle (f x t) (f x t') -> t <= t'.
  Proof with auto with real.
    unfold mle.
    intros.
    set (f_lt x t t'). clearbody r.
    unfold mlt in r.
    destruct fmono; destruct H.
          apply Rlt_le...
        right. destruct (f_eq x t t')...
      apply Rlt_le...
    right. destruct (f_eq x t t')...
  Qed.

  Lemma inv_lt_right a x x': inv a x < inv a x' <-> mlt x x'.
  Proof with auto.
    unfold mlt.
    split; intros.
      replace x with (f a (inv a x))...
      replace x' with (f a (inv a x'))...
      destruct fmono; apply s...
    set f_lt. clearbody r.
    unfold mlt in r.
    destruct fmono; apply r with a; repeat rewrite inv_correct...
  Qed.

  Lemma inv_pos x x': 0 < inv x x' <-> mlt x x'.
  Proof with auto with real.
    unfold mlt.
    split; intros.
      set f_lt. clearbody r.
      intros.
      replace x with (f x 0)...
        replace x' with (f x (inv x x'))...
        destruct fmono; apply s...
      rewrite flow_zero...
    rewrite <- inv_refl with x.
    destruct (inv_lt_right x x x')...
  Qed.

  Lemma inv_very_correct t x: inv (f x t) x = -t.
  Proof with auto with real.
    intros.
    assert (inv x x = 0).
      apply inv_refl.
    rewrite (inv_plus x (f x t) x) in H.
    rewrite inv_correct' in H.
    replace (-t) with (0-t)...
    rewrite <- H.
    unfold Rminus.
    rewrite Rplus_comm.
    rewrite <- Rplus_assoc.
    rewrite Rplus_opp_l...
  Qed.

  Lemma inv_inv x y: inv x y = - inv y x.
  Proof with auto with real.
    intros.
    set (inv_very_correct (inv y x) y).
    rewrite inv_correct in e...
  Qed.

  Lemma inv_uniq_0 x x': inv x x' = - inv 0 x + inv 0 x'.
  Proof.
    intros.
    rewrite (inv_plus x 0 x').
    rewrite (inv_inv x 0).
    auto with real.
  Qed.
    (* hm, this shows that inv is uniquely determined by the values it
      takes with 0 as first argument. perhaps the reason we don't
      just take inv as a unary function is that it is problematic
      for flow functions with singularities at 0? *)

  Lemma inv_le a x x': mle x x' -> inv a x <= inv a x'.
  Proof with auto.
    intros.
    set f_le. clearbody r.
    apply r with a.
    do 2 rewrite inv_correct...
  Qed.

  Lemma inv_nonneg x x': 0 <= inv x x' <-> mle x x'.
  Proof with auto with real.
    unfold mle.
    split; intros.
      set f_le. clearbody r.
      intros.
      replace x with (f x 0)...
        replace x' with (f x (inv x x'))...
        apply mono_opp...
      apply flow_zero.
    rewrite <- inv_refl with x.
    apply inv_le...
  Qed.

  Lemma inv_zero x x': inv x x' = 0 <-> x = x'.
  Proof with auto.
    split; intros.
      replace x' with (f x (inv x x'))...
      rewrite H.
      rewrite flow_zero...
    subst.
    rewrite inv_refl...
  Qed.

  Lemma f_lt_left x x' t: x < x' <-> f x t < f x' t.
  Proof with auto with real.
    split.
      intros.
      replace x' with (f x (inv x x'))...
      rewrite <- flow_additive...
      destruct (inv_pos x x').
      destruct (inv_pos x' x).
      unfold mlt in *.
      destruct fmono.
        apply s.
        set (H1 H).
        fourier.
      apply s.
      rewrite inv_inv.
      set (H3 H).
      fourier.
    set f_lt. set inv_pos. clearbody r i.
    unfold mlt in r, i.
    destruct fmono; intros.
      replace (f x' t) with (f (f x (inv x x')) t) in H...
        rewrite <- flow_additive in H...
        set (r _ _ _ H).
        assert (0 < inv x x') by fourier.
        destruct (i x x').
        apply H1...
      rewrite inv_correct...
    replace (f x t) with (f (f x' (inv x' x)) t) in H...
      rewrite <- flow_additive in H...
      set (r _ _ _ H).
      assert (0 < inv x' x) by fourier.
      destruct (i x' x).
      apply H1...
    rewrite inv_correct...
  Qed.

  Lemma f_eq_left x x' t: f x t = f x' t <-> x = x'.
  Proof with auto with real.
    intros.
    split; intros.
      intros.
      destruct (Rlt_le_dec x x').
        elimtype False.
        destruct (f_lt_left x x' t).
        set (H0 r).
        rewrite H in r0.
        apply (Rlt_asym _ _ r0)...
      destruct (Rle_lt_or_eq_dec _ _ r)...
      elimtype False.
      destruct (f_lt_left x' x t).
      set (H0 r0).
      rewrite H in r1.
      apply (Rlt_asym _ _ r1)...
    subst...
  Qed.

  Lemma f_le_left x x' t: x <= x' <-> f x t <= f x' t.
  Proof with auto with real.
    intros.
    destruct (f_lt_left x x' t).
    split; intro.
      destruct H1...
      subst...
    destruct H1.
      destruct (f_lt_left x x' t)...
    replace x' with x...
    destruct (f_eq_left x x' t)...
  Qed.

  Lemma inv_lt_left a x x': mlt x x' <-> inv x' a < inv x a.
  Proof with auto with real.
    unfold mlt.
    intros.
    rewrite (inv_inv x' a).
    rewrite (inv_inv x a).
    destruct (inv_lt_right a x x').
    split...
    intros.
    apply H...
  Qed.

  Lemma inv_le_left a x x': mle x x' -> inv x' a <= inv x a.
  Proof with auto with real.
    unfold mle. intros.
    destruct (inv_lt_left a x x').
    unfold mlt in *.
    destruct fmono; intros; destruct H; subst...
  Qed.

  Lemma inv_eq_right a x x': inv a x = inv a x' <-> x = x'.
  Proof with auto with real.
    split.
      intros.
      replace x with (f a (inv a x))...
      replace x' with (f a (inv a x'))...
    intros...
  Qed.

  Lemma inv_le_right a x x': inv a x <= inv a x' <-> mle x x'.
  Proof with auto with real.
    intros.
    destruct (inv_lt_right a x x').
    split; intro.
      destruct H1.
        apply mlt_le...
      rewrite (conj_fst (inv_eq_right a x x') H1).
      apply mle_refl.
    destruct (mle_lt_or_eq_dec _ _ H1)...
    subst...
  Qed.

  Lemma mle_flow t x: 0 <= t -> mle x (f x t).
  Proof with auto.
    intros.
    apply mle_trans with (f x 0).
      rewrite flow_zero...
      apply mle_refl.
    apply mono_opp...
  Qed.

End single_inverses.


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

          IEEE754  :  Digit

          Laurent Thery

  *****************************************************************************
  Gives the number of digits necessary to write a number in a given base *)
Require Export ZArithRing.
Require Export Omega.
Require Export Faux.
Section Pdigit.
(* n is the base *)
Variable n : Z.
(* and it is greater or equal to 2 *)
Hypothesis nMoreThan1 : (1 < n)%Z.

Let nMoreThanOne := Zlt_1_O _ (Zlt_le_weak _ _ nMoreThan1).
Hint Resolve nMoreThanOne: zarith.

Theorem Zpower_nat_less : forall q : nat, (0 < Zpower_nat n q)%Z.
intros q; elim q; simpl in |- *;
auto with zarith.
Qed.
Hint Resolve Zpower_nat_less: zarith.

Theorem Zpower_nat_monotone_S :
 forall p : nat, (Zpower_nat n p < Zpower_nat n (S p))%Z.
intros p; rewrite <- (Zmult_1_l (Zpower_nat n p)); replace (S p) with (1 + p);
 [ rewrite Zpower_nat_is_exp | auto with zarith ].
rewrite Zpower_nat_1; auto with zarith.
apply Zmult_gt_0_lt_compat_r; auto with zarith.
apply Zlt_gt; auto with zarith.
Qed.

Theorem Zpower_nat_monotone_lt :
 forall p q : nat, p < q -> (Zpower_nat n p < Zpower_nat n q)%Z.
intros p q H'; elim H'; simpl in |- *; auto.
apply Zpower_nat_monotone_S.
intros m H H0; apply Zlt_trans with (1 := H0).
apply Zpower_nat_monotone_S.
Qed.
Hint Resolve Zpower_nat_monotone_lt: zarith.

Theorem Zpower_nat_anti_monotone_lt :
 forall p q : nat, (Zpower_nat n p < Zpower_nat n q)%Z -> p < q.
intros p q H'.
case (le_or_lt q p); auto; (intros H'1; generalize H'; case H'1).
intros H'0; Contradict H'0; auto with zarith.
intros m H'0 H'2; Contradict H'2; auto with zarith.
Qed.

Theorem Zpower_nat_monotone_le :
 forall p q : nat, p <= q -> (Zpower_nat n p <= Zpower_nat n q)%Z.
intros p q H'; case (le_lt_or_eq _ _ H'); auto with zarith.
intros H1; rewrite H1; auto with zarith.
Qed.

Theorem Zpower_nat_anti_monotone_le :
 forall p q : nat, (Zpower_nat n p <= Zpower_nat n q)%Z -> p <= q.
intros p q H'; case (le_or_lt p q); intros H'0; auto with arith.
Contradict H'; auto with zarith.
Qed.

Theorem Zpower_nat_anti_eq :
 forall p q : nat, Zpower_nat n p = Zpower_nat n q -> p = q.
intros p q H'; apply le_antisym; apply Zpower_nat_anti_monotone_le;
 rewrite H'; auto with zarith.
Qed.
(* To compute the number of digits structurally, we suppose that
   we know already an upper bound q. So we start from q down
   to 0 to find the bigger exponent r such that n^(r-1) < v *)

Fixpoint digitAux (v r : Z) (q : positive) {struct q} : nat :=
  match q with
  | xH => 0
  | xI q' =>
      match (n * r)%Z with
      | r' =>
          match (r ?= v)%Z with
          | Datatypes.Gt => 0
          | _ => S (digitAux v r' q')
          end
      end
  | xO q' =>
      match (n * r)%Z with
      | r' =>
          match (r ?= v)%Z with
          | Datatypes.Gt => 0
          | _ => S (digitAux v r' q')
          end
      end
  end.
(* As we know that log_n q < log_2 q we can define our function digit*)

Definition digit (q : Z) :=
  match q with
  | Z0 => 0
  | Zpos q' => digitAux (Zabs q) 1 (xO q')
  | Zneg q' => digitAux (Zabs q) 1 (xO q')
  end.
Hint Unfold digit.

Theorem digitAux1 :
 forall p r, (Zpower_nat n (S p) * r)%Z = (Zpower_nat n p * (n * r))%Z.
intros p r; replace (S p) with (1 + p);
 [ rewrite Zpower_nat_is_exp | auto with arith ].
rewrite Zpower_nat_1; ring.
Qed.

Theorem Zcompare_correct :
 forall p q : Z,
 match (p ?= q)%Z with
 | Datatypes.Gt => (q < p)%Z
 | Datatypes.Lt => (p < q)%Z
 | Datatypes.Eq => p = q
 end.
intros p q; unfold Zlt in |- *; generalize (Zcompare_EGAL p q);
 (CaseEq (p ?= q)%Z; simpl in |- *; auto).
intros H H0; case (Zcompare_Gt_Lt_antisym p q); auto.
Qed.

Theorem digitAuxLess :
 forall (v r : Z) (q : positive),
 match digitAux v r q with
 | S r' => (Zpower_nat n r' * r <= v)%Z
 | O => True
 end.
intros v r q; generalize r; elim q; clear r q; simpl in |- *; auto.
intros q' Rec r; generalize (Zcompare_correct r v); case (r ?= v)%Z; auto.
intros H1; generalize (Rec (n * r)%Z); case (digitAux v (n * r) q').
intros; rewrite H1; rewrite Zpower_nat_O; auto with zarith.
intros r'; rewrite digitAux1; auto.
intros H1; generalize (Rec (n * r)%Z); case (digitAux v (n * r) q').
intros; rewrite Zpower_nat_O; auto with zarith.
apply Zle_trans with (m := r); auto with zarith.
intros r'; rewrite digitAux1; auto.
intros q' Rec r; generalize (Zcompare_correct r v); case (r ?= v)%Z; auto.
intros H1; generalize (Rec (n * r)%Z); case (digitAux v (n * r) q').
intros; rewrite H1; rewrite Zpower_nat_O; auto with zarith.
intros r'; rewrite digitAux1; auto.
intros H1; generalize (Rec (n * r)%Z); case (digitAux v (n * r) q').
intros; rewrite Zpower_nat_O; auto with zarith.
apply Zle_trans with (m := r); auto with zarith.
intros r'; rewrite digitAux1; auto.
Qed.
(* digit is correct (first part) *)

Theorem digitLess :
 forall q : Z, q <> 0%Z -> (Zpower_nat n (pred (digit q)) <= Zabs q)%Z.
intros q; case q.
intros H; Contradict H; auto with zarith.
intros p H; unfold digit in |- *;
 generalize (digitAuxLess (Zabs (Zpos p)) 1 (xO p));
 case (digitAux (Zabs (Zpos p)) 1 (xO p)); simpl in |- *;
 auto with zarith.
intros p H; unfold digit in |- *;
 generalize (digitAuxLess (Zabs (Zneg p)) 1 (xO p));
 case (digitAux (Zabs (Zneg p)) 1 (xO p)); simpl in |- *;
 auto with zarith.
Qed.
Hint Resolve digitLess: zarith.
Hint Resolve Zmult_gt_0_lt_compat_r Zmult_gt_0_lt_compat_l: zarith.

Fixpoint pos_length (p : positive) : nat :=
  match p with
  | xH => 0
  | xO p' => S (pos_length p')
  | xI p' => S (pos_length p')
  end.

Theorem digitAuxMore :
 forall (v r : Z) (q : positive),
 (0 < r)%Z ->
 (v < Zpower_nat n (pos_length q) * r)%Z ->
 (v < Zpower_nat n (digitAux v r q) * r)%Z.
intros v r q; generalize r; elim q; clear r q; simpl in |- *.
intros p Rec r Hr; generalize (Zcompare_correct r v); case (r ?= v)%Z; auto.
intros H1 H2; rewrite <- H1.
apply Zle_lt_trans with (Zpower_nat n 0 * r)%Z; auto with zarith arith.
rewrite Zpower_nat_O; rewrite Zmult_1_l; auto with zarith.
intros H1 H2; rewrite digitAux1.
apply Rec.
apply Zlt_mult_ZERO; auto with zarith.
rewrite <- digitAux1; auto.
rewrite Zpower_nat_O; rewrite Zmult_1_l; auto with zarith.
intros p Rec r Hr; generalize (Zcompare_correct r v); case (r ?= v)%Z; auto.
intros H1 H2; rewrite <- H1.
apply Zle_lt_trans with (Zpower_nat n 0 * r)%Z; auto with zarith arith.
rewrite Zpower_nat_O; rewrite Zmult_1_l; auto with zarith.
intros H1 H2; rewrite digitAux1.
apply Rec.
apply Zlt_mult_ZERO; auto with zarith.
rewrite <- digitAux1; auto.
rewrite Zpower_nat_O; rewrite Zmult_1_l; auto with zarith.
auto.
Qed.

Theorem pos_length_pow :
 forall p : positive, (Zpos p < Zpower_nat n (S (pos_length p)))%Z.
intros p; elim p; simpl in |- *; auto.
intros p0 H; rewrite Zpos_xI.
apply Zlt_le_trans with (2 * (n * Zpower_nat n (pos_length p0)))%Z;
auto with zarith.
intros p0 H; rewrite Zpos_xO.
apply Zlt_le_trans with (2 * (n * Zpower_nat n (pos_length p0)))%Z;
auto with zarith.
auto with zarith.
Qed.
(* digit is correct (second part) *)

Theorem digitMore : forall q : Z, (Zabs q < Zpower_nat n (digit q))%Z.
intros q; case q.
easy.
intros q'; rewrite <- (Zmult_1_r (Zpower_nat n (digit (Zpos q')))).
unfold digit in |- *; apply digitAuxMore; auto with zarith.
rewrite Zmult_1_r.
simpl in |- *; apply pos_length_pow.
intros q'; rewrite <- (Zmult_1_r (Zpower_nat n (digit (Zneg q')))).
unfold digit in |- *; apply digitAuxMore; auto with zarith.
rewrite Zmult_1_r.
simpl in |- *; apply pos_length_pow.
Qed.
Hint Resolve digitMore: zarith.
(* if we find an r such that n^(r-1) =< q < n^r
   then r is the number of digits *)

Theorem digitInv :
 forall (q : Z) (r : nat),
 (Zpower_nat n (pred r) <= Zabs q)%Z ->
 (Zabs q < Zpower_nat n r)%Z -> digit q = r.
intros q r H' H'0; case (le_or_lt (digit q) r).
intros H'1; case (le_lt_or_eq _ _ H'1); auto; intros H'2.
absurd (Zabs q < Zpower_nat n (digit q))%Z; auto with zarith.
apply Zle_not_lt; auto with zarith.
apply Zle_trans with (m := Zpower_nat n (pred r)); auto with zarith.
apply Zpower_nat_monotone_le.
generalize H'2; case r; auto with arith.
intros H'1.
absurd (Zpower_nat n (pred (digit q)) <= Zabs q)%Z; auto with zarith.
apply Zlt_not_le; auto with zarith.
apply Zlt_le_trans with (m := Zpower_nat n r); auto.
apply Zpower_nat_monotone_le.
generalize H'1; case (digit q); auto with arith.
apply digitLess; auto with zarith.
generalize H'1; case q; unfold digit in |- *; intros tmp; intros; red in |- *;
 intros; try discriminate; Contradict tmp; auto with arith.
Qed.

Theorem digitO : digit 0 = 0.
unfold digit in |- *; simpl in |- *; auto with arith.
Qed.

Theorem digit1 : digit 1 = 1.
unfold digit in |- *; simpl in |- *; auto.
Qed.
(* digit is monotone *)

Theorem digit_monotone :
 forall p q : Z, (Zabs p <= Zabs q)%Z -> digit p <= digit q.
intros p q H; case (le_or_lt (digit p) (digit q)); auto; intros H1;
 Contradict H.
apply Zlt_not_le.
cut (p <> 0%Z); [ intros H2 | idtac ].
apply Zlt_le_trans with (2 := digitLess p H2).
cut (digit q <= pred (digit p)); [ intros H3 | idtac ].
apply Zlt_le_trans with (2 := Zpower_nat_monotone_le _ _ H3);
 auto with zarith.
generalize H1; case (digit p); simpl in |- *; auto with arith.
generalize H1; case p; simpl in |- *; intros tmp; intros; red in |- *; intros;
 try discriminate; Contradict tmp; auto with arith.
Qed.
Hint Resolve digit_monotone: arith.
(* if the number is not null so is the number of digits *)

Theorem digitNotZero : forall q : Z, q <> 0%Z -> 0 < digit q.
intros q H'.
apply lt_le_trans with (m := digit 1); auto with zarith.
apply digit_monotone.
generalize H'; case q; simpl in |- *; auto with zarith; intros q'; case q';
 simpl in |- *; auto with zarith arith; intros; red in |- *;
 simpl in |- *; red in |- *; intros; discriminate.
Qed.
Hint Resolve Zlt_gt: zarith.

Theorem digitAdd :
 forall (q : Z) (r : nat),
 q <> 0%Z -> digit (q * Zpower_nat n r) = digit q + r.
intros q r H0.
apply digitInv.
replace (pred (digit q + r)) with (pred (digit q) + r).
rewrite Zpower_nat_is_exp; rewrite Zabs_Zmult;
 rewrite (fun x => Zabs_eq (Zpower_nat n x)); auto with zarith arith.
generalize (digitNotZero _ H0); case (digit q); auto with arith.
intros H'; Contradict H'; auto with arith.
rewrite Zpower_nat_is_exp; rewrite Zabs_Zmult;
 rewrite (fun x => Zabs_eq (Zpower_nat n x)); auto with zarith arith.
Qed.

Theorem digit_minus1 : forall p : nat, digit (Zpower_nat n p - 1) = p.
intros p; case p; auto.
intros n0; apply digitInv; auto.
rewrite Zabs_eq.
cut (Zpower_nat n (pred (S n0)) < Zpower_nat n (S n0))%Z; auto with zarith.
cut (0 < Zpower_nat n (S n0))%Z; auto with zarith.
rewrite Zabs_eq; auto with zarith.
Qed.

Theorem digit_bound :
 forall (x y z : Z) (n : nat),
 (Zabs x <= Zabs y)%Z ->
 (Zabs y <= Zabs z)%Z -> digit x = n -> digit z = n -> digit y = n.
intros x y z n0 H' H'0 H'1 H'2; apply le_antisym.
rewrite <- H'2; auto with arith.
rewrite <- H'1; auto with arith.
Qed.

Theorem digit_abs : forall p : Z, digit (Zabs p) = digit p.
intros p; case p; simpl in |- *; auto.
Qed.
(* Strict comparison on the number of digits gives comparison on the numbers *)

Theorem digit_anti_monotone_lt :
 (1 < n)%Z -> forall p q : Z, digit p < digit q -> (Zabs p < Zabs q)%Z.
intros H' p q H'0.
case (Zle_or_lt (Zabs q) (Zabs p)); auto; intros H'1.
Contradict H'0.
case (Zle_lt_or_eq _ _ H'1); intros H'2.
apply le_not_lt; auto with arith.
rewrite <- (digit_abs p); rewrite <- (digit_abs q); rewrite H'2;
 auto with arith.
Qed.
End Pdigit.
Hint Resolve Zpower_nat_less: zarith.
Hint Resolve Zpower_nat_monotone_lt: zarith.
Hint Resolve Zpower_nat_monotone_le: zarith.
Hint Unfold digit.
Hint Resolve digitLess: zarith.
Hint Resolve digitMore: zarith.
Hint Resolve digit_monotone: arith.


Definition N := 2.

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

Fixpoint binary_tree c n :=
  match n with
  | 0 => Leaf
  | S n =>
    let t := binary_tree c n in
    Node c t t
  end.

Definition t0 := Eval vm_compute in binary_tree 0 N.
Definition t1 := Eval vm_compute in binary_tree 1 N.


Require Import compcert.lib.Coqlib.
Require Import msl.Coqlib2.
Require Import Coq.Lists.List.
Import ListNotations.

Require Import floyd.sublist.

(* from verif_revarray.v *)

Definition flip_between {A} lo hi (contents: list A) :=
  firstn (Z.to_nat lo) (rev contents)
  ++ firstn (Z.to_nat (hi-lo)) (skipn (Z.to_nat lo) contents)
  ++ skipn (Z.to_nat hi) (rev contents).

Lemma flip_fact_0: forall {A} size (contents: list A),
  Zlength contents = size ->
  contents = flip_between 0 (size - 0) contents.
Proof.
  intros.
  assert (length contents = Z.to_nat size).
    apply Nat2Z.inj. rewrite <- Zlength_correct, Z2Nat.id; auto.
    subst; rewrite Zlength_correct; omega.
  unfold flip_between.
  rewrite !Z.sub_0_r. change (Z.to_nat 0) with O; simpl. rewrite <- H0.
  rewrite skipn_short.
  rewrite <- app_nil_end.
  rewrite firstn_exact_length. auto.
  rewrite rev_length. omega.
Qed.

Lemma flip_fact_1: forall A size (contents: list A) j,
  Zlength contents = size ->
  0 <= j ->
  size - j - 1 <= j <= size - j ->
  flip_between j (size - j) contents = rev contents.
Proof.
  intros.
  assert (length contents = Z.to_nat size).
    apply Nat2Z.inj. rewrite <- Zlength_correct, Z2Nat.id; auto.
    subst; rewrite Zlength_correct; omega.
  unfold flip_between.
  symmetry.
  rewrite <- (firstn_skipn (Z.to_nat j)) at 1.
  f_equal.
  replace (Z.to_nat (size-j)) with (Z.to_nat j + Z.to_nat (size-j-j))%nat
    by (rewrite <- Z2Nat.inj_add by omega; f_equal; omega).
  rewrite <- skipn_skipn.
  rewrite <- (firstn_skipn (Z.to_nat (size-j-j)) (skipn (Z.to_nat j) (rev contents))) at 1.
  f_equal.
  rewrite firstn_skipn_rev.
Focus 2.
rewrite H2.
apply Nat2Z.inj_le.
rewrite Nat2Z.inj_add by omega.
rewrite !Z2Nat.id by omega.
omega.
  rewrite len_le_1_rev.
  f_equal. f_equal. f_equal.
  rewrite <- Z2Nat.inj_add by omega. rewrite H2.
  rewrite <- Z2Nat.inj_sub by omega. f_equal; omega.
  rewrite firstn_length, min_l.
  change 1%nat with (Z.to_nat 1). apply Z2Nat.inj_le; omega.
  rewrite skipn_length.  rewrite H2.
  rewrite <- Z2Nat.inj_sub by omega. apply Z2Nat.inj_le; omega.
Qed.

Lemma Zlength_flip_between:
 forall A i j (al: list A),
 0 <= i  -> i<=j -> j <= Zlength al ->
 Zlength (flip_between i j al) = Zlength al.
Proof.
intros.
unfold flip_between.
rewrite !Zlength_app, !Zlength_firstn, !Zlength_skipn, !Zlength_rev.
forget (Zlength al) as n.
rewrite (Z.max_comm 0 i).
rewrite (Z.max_l i 0) by omega.
rewrite (Z.max_comm 0 j).
rewrite (Z.max_l j 0) by omega.
rewrite (Z.max_comm 0 (j-i)).
rewrite (Z.max_l (j-i) 0) by omega.
rewrite (Z.max_comm 0 (n-i)).
rewrite (Z.max_l (n-i) 0) by omega.
rewrite Z.max_r by omega.
rewrite (Z.min_l i n) by omega.
rewrite Z.min_l by omega.
omega.
Qed.

Lemma flip_fact_3:
 forall A (al: list A) (d: A) j size,
  size = Zlength al ->
  0 <= j < size - j - 1 ->
firstn (Z.to_nat j)
  (firstn (Z.to_nat (size - j - 1)) (flip_between j (size - j) al) ++
   firstn (Z.to_nat 1) (skipn (Z.to_nat j) (flip_between j (size - j) al)) ++
   skipn (Z.to_nat (size - j - 1 + 1)) (flip_between j (size - j) al)) ++
firstn (Z.to_nat 1)
  (skipn (Z.to_nat (size - j - 1)) al) ++
skipn (Z.to_nat (j + 1))
  (firstn (Z.to_nat (size - j - 1)) (flip_between j (size - j) al) ++
   firstn (Z.to_nat 1) (skipn (Z.to_nat j) (flip_between j (size - j) al)) ++
   skipn (Z.to_nat (size - j - 1 + 1)) (flip_between j (size - j) al)) =
flip_between (Z.succ j) (size - Z.succ j) al.
Proof.
intros.
assert (Zlength (rev al) = size) by (rewrite Zlength_rev; omega).
unfold flip_between.
rewrite Zfirstn_app1.
Focus 2. {
rewrite Zlength_firstn, Z.max_r by omega.
rewrite !Zlength_app.
rewrite Zlength_firstn, Z.max_r by omega.
rewrite Zlength_firstn, Z.max_r by omega.
rewrite !Zlength_skipn.
rewrite (Z.max_r 0 j) by omega.
rewrite (Z.max_r 0 (size-j)) by omega.
rewrite Z.max_r by omega.
rewrite Z.max_r by omega.
rewrite (Z.min_l j) by omega.
rewrite (Z.min_l (size-j-j)) by omega.
rewrite Z.min_l by omega.
omega.
} Unfocus.
rewrite Zfirstn_app2
 by (rewrite Zlength_firstn, Z.max_r by omega;
      rewrite Z.min_l by omega; omega).
rewrite Zfirstn_app1
 by (rewrite Zlength_firstn, Z.max_r by omega;
      rewrite Z.min_l by omega; omega).
rewrite Zfirstn_firstn by omega.
rewrite Zskipn_app1.
Focus 2. {
rewrite Zlength_firstn, Z.max_r by omega.
rewrite Zlength_rev.
rewrite !Zlength_app.
rewrite Zlength_firstn, Z.max_r by omega.
rewrite Z.min_l by omega.
rewrite Zlength_firstn.
rewrite (Z.min_l j (Zlength al)) by omega.
rewrite Z.max_r by omega.
rewrite Zlength_app.
rewrite Zlength_firstn, Z.max_r by omega.
rewrite Zlength_skipn.
rewrite (Z.max_r 0 j)  by omega.
rewrite (Z.max_r 0 ) by omega.
rewrite (Z.min_l  (size-j-j)) by omega.
rewrite Zlength_skipn.
rewrite (Z.max_r 0 (size-j)) by omega.
rewrite Z.max_r by omega.
rewrite Z.min_l by omega.
omega.
} Unfocus.
rewrite Zskipn_app2
 by (rewrite Zlength_firstn, Z.max_r by omega;
       rewrite Z.min_l by omega; omega).
rewrite Zlength_firstn, Z.max_r by omega.
rewrite Z.min_l by omega.
rewrite Zfirstn_app1.
Focus 2. {
rewrite Zlength_firstn, Z.max_r by omega.
rewrite Zlength_skipn, (Z.max_r 0 j) by omega.
rewrite Z.max_r by omega.
rewrite Z.min_l by omega. omega.
} Unfocus.
rewrite Zfirstn_firstn by omega.
rewrite Zskipn_app2
 by (rewrite Zlength_firstn, Z.max_r by omega;
       rewrite Z.min_l by omega; omega).
rewrite Zskipn_app1.
Focus 2. {
rewrite Zlength_firstn, Z.max_r by omega.
rewrite Z.min_l by omega.
rewrite Zlength_firstn, Z.max_r by omega.
rewrite Zlength_skipn, (Z.max_r 0 j) by omega.
rewrite Z.max_r by omega.
rewrite Z.min_l by omega. omega.
} Unfocus.
rewrite Zfirstn_app1.
Focus 2. {
rewrite !Zlength_skipn, !Zlength_firstn.
rewrite (Z.max_r 0 j) by omega.
rewrite (Z.min_l j) by omega.
rewrite Zlength_skipn.
rewrite (Z.max_r 0 j) by omega.
rewrite (Z.max_r 0 (Zlength al - j)) by omega.
rewrite (Z.max_l 0 (j-j)) by omega.
rewrite (Z.max_r 0 (size-j-j)) by omega.
rewrite Z.min_l by omega.
rewrite Z.max_r by omega.
omega.
} Unfocus.
rewrite Zskipn_app2.
Focus 2. {
rewrite Zlength_firstn, Z.max_r by omega.
rewrite (Z.min_l j) by omega.
omega.
} Unfocus.
rewrite Zskipn_app2.
Focus 2. {
rewrite Zlength_firstn, Z.max_r by omega.
rewrite (Z.min_l j) by omega.
rewrite Zlength_firstn, Z.max_r by omega.
rewrite Zlength_skipn, (Z.max_r 0 j) by omega.
rewrite Z.max_r by omega.
rewrite Z.min_l by omega.
omega.
} Unfocus.
rewrite Zlength_firstn, Z.max_r by omega.
rewrite Zlength_firstn, Z.max_r by omega.
rewrite Zlength_skipn, (Z.max_r 0 j) by omega.
rewrite Z.max_r by omega.
rewrite Z.min_l by omega.
rewrite Z.min_l by omega.
rewrite Zskipn_skipn by omega.
rewrite !Zskipn_firstn by omega.
rewrite !Z.sub_diag.
rewrite Z.sub_0_r.
rewrite !Zskipn_skipn by omega.
rewrite Zfirstn_firstn by omega.
rewrite <- app_ass.
f_equal.
rewrite <- (firstn_skipn (Z.to_nat j) (rev al)) at 2.
rewrite Zfirstn_app2
  by (rewrite Zlength_firstn, Z.max_r by omega;
        rewrite Z.min_l by omega; omega).
rewrite Zlength_firstn, Z.max_r by omega;
rewrite Z.min_l by omega.
replace (Z.succ j - j) with 1 by omega.
f_equal.
rewrite app_nil_end.
rewrite app_nil_end at 1.
rewrite <- Znth_cons with (d0:=d) by omega.
rewrite <- Znth_cons with (d0:=d) by omega.
f_equal.
rewrite Znth_rev by omega.
f_equal. omega.
replace (size - j - 1 - j - (j + 1 - j))
  with (size- Z.succ j- Z.succ j) by omega.
replace (j+(j+1-j)) with (j+1) by omega.
f_equal.
rewrite Z.add_0_r.
rewrite <- (firstn_skipn (Z.to_nat 1) (skipn (Z.to_nat (size- Z.succ j)) (rev al))).
rewrite Zskipn_skipn by omega.
f_equal.
rewrite app_nil_end.
rewrite app_nil_end at 1.
rewrite <- Znth_cons with (d0:=d) by omega.
rewrite <- Znth_cons with (d0:=d) by omega.
f_equal.
rewrite Znth_rev by omega.
f_equal.
omega.
f_equal.
f_equal.
omega.
Qed.

Lemma flip_fact_2:
  forall {A} (al: list A) size j d,
 Zlength al = size ->
  j < size - j - 1 ->
   0 <= j ->
  Znth (size - j - 1) al d =
  Znth (size - j - 1) (flip_between j (size - j) al) d.
Proof.
intros.
unfold flip_between.
rewrite app_Znth2
 by (rewrite Zlength_firstn, Z.max_r by omega;
      rewrite Zlength_rev, Z.min_l by omega; omega).
rewrite Zlength_firstn, Z.max_r by omega;
rewrite Zlength_rev, Z.min_l by omega.
rewrite app_Znth1.
Focus 2. {
rewrite Zlength_firstn, Z.max_r by omega;
rewrite Zlength_skipn by omega.
rewrite (Z.max_r 0 j) by omega.
rewrite Z.max_r by omega.
rewrite Z.min_l by omega.
omega. } Unfocus.
rewrite Znth_firstn by omega.
rewrite Znth_skipn by omega.
f_equal; omega.
Qed.

Require Import msl.shares.
Require Import veric.shares.
Require Import compcert.lib.Integers.
Require Import compcert.common.Values.
Require Import compcert.cfrontend.Ctypes.
Require Import veric.expr.

Lemma verif_sumarray_example1:
forall (sh : share) (contents : list int) (size : Z) (a : val),
readable_share sh ->
0 <= size <= Int.max_signed ->
is_pointer_or_null a ->
@Zlength val (@map int val Vint contents) = size ->
0 <= 0 /\
(0 <= size /\ True) /\
a = a /\
Vint (Int.repr 0) = Vint (Int.repr 0) /\
Vint (Int.repr size) = Vint (Int.repr size) /\
Vint Int.zero = Vint (Int.repr 0) /\ True.
Abort.

Lemma verif_sumarray_example2:
forall (sh : share) (contents : list int) (size : Z) (a : val),
forall (sh : share) (contents : list int) (size a1 : Z) (a : val),
readable_share sh ->
0 <= size <= Int.max_signed ->
a1 < size ->
0 <= a1 <= size ->
is_pointer_or_null a ->
Zlength (map Vint contents) = size ->
is_int I32 Signed (Znth a1 (map Vint contents) Vundef).
Abort.

Require Import compcert.exportclight.Clightdefs.

Lemma verif_sumarray_example3:
forall (sum_int: list int -> int) (sh : share) (contents : list int) (size a1 : Z) (a : val) (x s : int),
(forall (contents0 : list int) (i : Z) (x0 : int),
 Znth i (map Vint contents0) Vundef = Vint x0 ->
 0 <= i ->
 sum_int (sublist 0 (Z.succ i) contents0) =
 Int.add (sum_int (sublist 0 i contents0)) x0) ->
readable_share sh ->
0 <= size <= Int.max_signed ->
a1 < size ->
0 <= a1 <= size ->
is_pointer_or_null a ->
force_val
  (sem_add_default tint tint (Vint (sum_int (sublist 0 a1 contents)))
     (Znth a1 (map Vint contents) Vundef)) = Vint s ->
Znth a1 (map Vint contents) Vundef = Vint x ->
Zlength (map Vint contents) = size ->
0 <= Z.succ a1 /\
(Z.succ a1 <= size /\ True) /\
a = a /\
Vint (Int.repr (Z.succ a1)) = Vint (Int.repr (a1 + 1)) /\
Vint (Int.repr size) = Vint (Int.repr size) /\
Vint (sum_int (sublist 0 (Z.succ a1) contents)) = Vint s /\ True.
Abort.

Require Import veric.Clight_lemmas.  (* just for nullval? *)

Lemma verif_reverse_example1:
forall (sum_int: list int -> int) (sh : share) (contents cts : list int) (t0 t_old t : val) (h : int),
readable_share sh ->
isptr t0 ->
t0 = t_old ->
is_pointer_or_null t ->
is_pointer_or_null t ->
(t = nullval <-> map Vint cts = []) ->
t = t /\
Vint (Int.sub (sum_int contents) (sum_int cts)) =
Vint (Int.add (Int.sub (sum_int contents) (Int.add h (sum_int cts))) h) /\
True.
Abort.

Lemma verif_reverse_example2:
forall (sh : share) (contents cts1 : list val) (w h : val) (r : list val)
  (w_ t_ : val),
writable_share sh ->
contents = rev cts1 ++ h :: r ->
is_pointer_or_null t_ ->
is_pointer_or_null w_ ->
isptr w_ ->
is_pointer_or_null t_ ->
is_pointer_or_null t_ ->
(t_ = nullval <-> r = []) ->
is_pointer_or_null w ->
(w = nullval <-> cts1 = []) ->
contents = (rev cts1 ++ [h]) ++ r /\ True /\ w_ = w_ /\ t_ = t_ /\ True.
Abort.


Require Import geometry2D.
Require Import Vector.
Require Import fastReals.misc.
Require Import MCInstances.
Require Import fastReals.interface.

Open Scope mc_scope.

Lemma Min_plusl: ∀ a b c : ℝ, min (c + a) (c + b) =  c + min a b.
Proof.
  intros.
  rewrite (plus_comm c).
  rewrite (plus_comm c).
  setoid_rewrite Min_plus.
  rewrite (plus_comm c).
  reflexivity.
Qed.

Lemma Max_plusl: ∀ a b c : ℝ, max (c + a) (c + b) =  c + max a b.
Proof.
  intros.
  rewrite (plus_comm c).
  rewrite (plus_comm c).
  setoid_rewrite max_plus.
  rewrite (plus_comm c).
  reflexivity.
Qed.

Lemma minCartSum : forall c a b : Cart2D IR,
  minCart (c+a) (c+b) = c + minCart a b.
Proof.
  intros. unfold minCart. simpl.
  rewrite Min_plusl.
  rewrite Min_plusl.
  split; reflexivity.
Qed.

Lemma maxCartSum : forall c a b : Cart2D IR,
  maxCart (c+a) (c+b) = c + maxCart a b.
Proof.
  intros. unfold maxCart. simpl.
  rewrite Max_plusl.
  rewrite Max_plusl.
  split; reflexivity.
Qed.

Global Instance ProperMinCart :
  Proper (equiv ==> equiv  ==> equiv) (@minCart IR _).
Proof.
  intros ? ? h1  ? ? h2.
  destruct h1. destruct h2.
  split; simpl; apply Max_AbsIR.Min_wd_unfolded; tauto.
Qed.

Global Instance ProperMaxCart :
  Proper (equiv ==> equiv  ==> equiv) (@maxCart IR _).
Proof.
  intros ? ? h1  ? ? h2.
  destruct h1. destruct h2.
  split; simpl; apply Max_AbsIR.Max_wd_unfolded; tauto.
Qed.

Global Instance AssociativeMinIR : `{Associative  (@min IR _)}.
  intros ? ? ?. apply MinAssoc.
Qed.

Global Instance AssociativeMaxIR : `{Associative  (@max IR _)}.
  intros ? ? ?. apply MaxAssoc.
Qed.

Global Instance AssociativeMinCart `{MinClass R} `{Associative _ (@min R _)}:
  Associative  (@minCart R _).
Proof.
  intros ? ? ?. split; simpl;
  apply simple_associativity.
Qed.

Global Instance AssociativeMaxCart `{MaxClass R} `{Associative _ (@max R _)}:
  Associative  (@maxCart R _).
Proof.
  intros ? ? ?. split; simpl;
  apply simple_associativity.
Qed.

Global Instance CommutativeMinIR : `{Commutative  (@min IR _)}.
  intros ? ?. apply Min_comm.
Qed.

Global Instance CommutativeMaxIR : `{Commutative  (@max IR _)}.
  intros ? ?. apply Max_comm.
Qed.

Global Instance CommutativeMinCart `{MinClass R} `{Commutative _ _ (@min R _)}:
  Commutative  (@minCart R _).
Proof.
  intros ? ?. split; simpl;
  apply commutativity.
Qed.

Global Instance CommutativeMaxCart `{MaxClass R} `{Commutative _ _ (@max R _)}:
  Commutative  (@maxCart R _).
Proof.
  intros ? ?. split; simpl;
  apply commutativity.
Qed.

Hint Unfold cos CosClassIR sin SinClassIR min MinClassIR max MaxClassIR: IRMC.

Require Import IRTrig.
Lemma unitVecNonNeg : forall θ, 0 ≤ θ ≤ (½ * π)
  -> 0 ≤ unitVec θ.
Proof.
  intros ? hh.
  pose proof (less_leEq ℝ [0] Pi pos_Pi) as h.
  apply nonneg_div_two' in h.
  autounfold with IRMC in hh.
  unfold Zero_instance_IR in hh.
  destruct hh as [x y].
  rewrite PiBy2DesugarIR in y.
  pose proof MinusPiBy2Le0.
  split; simpl;
  [apply Cos_nonneg | apply Sin_nonneg]; eauto 3 with CoRN.
Qed.

  Lemma unitVec90Minus :  ∀ θ:IR,
    unitVec (½ * π - θ) = {|X:= sin θ; Y:= cos θ|}.
  Proof using.
    intros ?. split; simpl;
    autounfold with IRMC.
    -  rewrite PiBy2DesugarIR.
      apply Cos_HalfPi_minus.
    - rewrite PiBy2DesugarIR.
      apply Sin_HalfPi_minus.
  Qed.

Local Opaque Sin.
Local Opaque Cos.

  Lemma unitVecMinus90 :  ∀ θ:IR,
    unitVec (θ - ½ * π) = {|X:= sin θ; Y:=- cos θ|}.
  Proof using.
    intros ?. unfold EquivCart, unitVec.
    autounfold with IRMC. simpl.
    rewrite <- Cos_inv.
    setoid_rewrite minusInvR.
    rewrite <- (cg_inv_inv _ (Sin (θ [+] [--] (½ [*] π)))).
    rewrite <- Sin_inv.
    setoid_rewrite minusInvR.
    split.
    - rewrite PiBy2DesugarIR.
      apply Cos_HalfPi_minus.
    - rewrite PiBy2DesugarIR.
      apply cg_inv_wd.
      apply Sin_HalfPi_minus.
  Qed.

Lemma unitVecMinDistr :  forall θ a b:IR, 0 ≤ θ ≤ (½ * π)
  ->
  minCart ((unitVec θ) * 'a) ((unitVec θ) * 'b)
     = (unitVec θ) * '(min a b).
Proof.
  intros ? ? ? hh.
  apply unitVecNonNeg in hh. unfold unitVec in hh.
  destruct hh as [x y]. simpl in x, y.
  unfold minCart. split; simpl;
  autounfold with IRMC;
  rewrite MinMultLeft; try reflexivity; try assumption.
Qed.

Lemma unitVecMaxDistr :  forall θ a b:IR, 0 ≤ θ ≤ (½ * π)
  ->
  maxCart ((unitVec θ) * 'a) ((unitVec θ) * 'b)
     = (unitVec θ) * '(max a b).
Proof.
  intros ? ? ? hh.
  apply unitVecNonNeg in hh. unfold unitVec in hh.
  destruct hh as [x y]. simpl in x, y.
  unfold maxCart. split; simpl;
  autounfold with IRMC;
  rewrite MaxMultLeft; try reflexivity; try assumption.
Qed.

Lemma minCart_leEq_lft: ∀ x y : Cart2D ℝ,
  minCart x y ≤ x.
Proof using .
  intros ? ?.
  split; apply Min_leEq_lft.
Qed.

Lemma minCart_leEq_rht: ∀ x y : Cart2D ℝ,
  minCart x y ≤ y.
Proof using .
  intros ? ?. rewrite commutativity.
  apply minCart_leEq_lft.
Qed.

Lemma lft_leEq_maxCart: ∀ x y : Cart2D ℝ,
  x ≤ maxCart x y.
Proof using .
  intros ? ?.
  split; apply lft_leEq_Max.
Qed.

Lemma rht_leEq_maxCart: ∀ x y : Cart2D ℝ,
  y ≤ maxCart x y.
Proof using .
  intros ? ?. rewrite commutativity.
  apply lft_leEq_maxCart.
Qed.

Lemma leEq_minCart : ∀ x y z : Cart2D ℝ,
  z ≤ x → z ≤ y → z ≤ minCart x y.
Proof using .
  intros ? ? ? Hab Hbc.
  destruct Hab, Hbc.
  split; apply leEq_Min; assumption.
Qed.

Lemma maxCart_leEq : ∀ x y z : Cart2D ℝ,
  x ≤ z → y ≤ z → maxCart x y ≤ z.
Proof using .
  intros ? ? ? Hab Hbc.
  destruct Hab, Hbc.
  split; apply Max_leEq; assumption.
Qed.

Hint Resolve minCart_leEq_lft
minCart_leEq_rht
lft_leEq_maxCart
rht_leEq_maxCart
leEq_minCart
maxCart_leEq
 : MinMaxCart.

Lemma boundingUnionIff: forall (a b c : Line2D IR),
  boundingUnion a b ⊆ c
  <-> (a ⊆ c /\ b ⊆ c).
Proof using .
  intros. unfold boundingUnion, le, LeAsSubset.
  simpl. split; intro hh.
  - repnd. split; split;
    eapply (@transitivity (Cart2D ℝ) le _);
    try apply hhl;
    try apply hhr;
    eauto using
      minCart_leEq_lft,
      minCart_leEq_rht,
      lft_leEq_maxCart,
      rht_leEq_maxCart.
  - repnd. split; eauto using
      leEq_minCart, maxCart_leEq.
Qed.

Global Instance CommBoundingUnion `{e:Equiv R} `{m:MinClass R}
`{M: MaxClass R} `{@Commutative R e R min} `{@Commutative R e R max}:
  Commutative boundingUnion.
Proof using.
  unfold BoundingRectangle. intros ? ?. split; simpl.
  - apply CommutativeMinCart.
  - apply CommutativeMaxCart.
Qed.

Lemma boundingUnionPlus : forall (a b c: Line2D IR),
  boundingUnion (b + a) (b + c)
  = b + (boundingUnion a c).
Proof using.
  intros ? ? ?.
  unfold boundingUnion.
  simpl.
  rewrite minCartSum.
  rewrite maxCartSum.
  reflexivity.
Qed.

Lemma  boundingUnionLeft:
  ∀ a b: Line2D ℝ, a ⊆ boundingUnion a b.
Proof.
  intros ? ?. unfold boundingUnion;
  split; simpl; eauto using minCart_leEq_lft,
    lft_leEq_maxCart.
Qed.

Lemma  boundingUnionRight:
  ∀ a b: Line2D ℝ, b ⊆ boundingUnion a b.
Proof.
  intros. rewrite commutativity.
  apply boundingUnionLeft.
Qed.

Global Instance ProperboundingUnion:
 Proper (equiv ==> equiv ==> equiv)
 (@boundingUnion IR _ _).
Proof.
  intros ? ? H1 ? ? H2.
  unfold boundingUnion.
  rewrite H1, H2. reflexivity.
Qed.

Ltac remCart2D c1min :=
  match goal with
    [|- context [{|
            X :=?x ; Y :=?y|} ]]
         => remember ({|
            X :=x ; Y :=y|}) as c1min
    end.

Require Import MCMisc.tactics.
Ltac simpRemCart2D c1min Heqc1min :=
  match goal with
    [|- context [{|
            X :=?x ; Y :=?y|} ]]
         => mcremember ({|
            X :=x ; Y :=y|}) c1min Heqc1min;
          ring_simplify x in Heqc1min;
          ring_simplify y in Heqc1min
    end.

Definition unitVecT `{SinClass R} `{CosClass R} (t:R) := transpose (unitVec t).

Definition flipAngle (c:Polar2D IR) : Polar2D IR:=
{| rad := rad c ; θ:= ½ * π -θ c|}.

Lemma minCartIsLeft : forall (a b : Cart2D IR),
  a ≤ b
  -> minCart a b = a.
Proof using.
  intros ? ? Hle.
  destruct Hle.
  split; simpl; apply leEq_imp_Min_is_lft; assumption.
Qed.

Lemma maxCartIsRight : forall (a b : Cart2D IR),
  a ≤ b
  -> maxCart a b = b.
Proof using.
  intros ? ? Hle.
  destruct Hle.
  split; simpl; apply leEq_imp_Max_is_rht; assumption.
Qed.

Require Import MCMisc.rings.

  Local Notation ConfineRect := (Line2D).
  Local Notation minxy := (lstart).
  Local Notation maxxy := (lend).

Lemma unionWithNonNegDisplacement : forall (a: ConfineRect IR) (d : Cart2D IR),
  0 ≤ d
  -> boundingUnion a (a+'d)
    = {| minxy := lstart a ; maxxy := lend a + d |}.
Proof using.
  intros ? ? Hle.
  split; simpl.
  - rewrite minCartIsLeft; auto.
    rewrite commutativity.
    apply RingLeProp1. assumption.
  - rewrite maxCartIsRight; auto.
    rewrite commutativity.
    apply RingLeProp1. assumption.
Qed.

Require Import MathClasses.interfaces.vectorspace.

Require Import IRMisc.LegacyIRRing.

Require Import CartIR.
(* Move *)
Lemma FFT2 : forall (θ:IR),
(Cos θ * Cos θ + Sin θ * Sin θ) = 1.
Proof using.
  intro.
  rewrite <- (FFT θ).
  simpl.
  IRring.
Qed.

Require Import fastReals.interface.

Lemma FFT3 : forall (θ:IR),
cos θ * cos θ  = 1 - sin θ * sin θ.
Proof using.
  intro.
  rewrite <- (FFT θ).
  simpl.
  IRring.
Qed.

Definition negY `{One A}`{Negate A} : Cart2D A:=
{|X:=1;Y:=-1|}.

Require Import geometry2D.
Lemma unitVNegate :
  forall (β : IR), unitVec (- β) = negY * unitVec β.
Proof using.
  intros.
  split; simpl.
  - rewrite mult_1_l. apply Cos_inv.
  - rewrite <- negate_mult_distr_l.
    rewrite mult_1_l. apply Sin_inv.
Qed.

Lemma rotateAxisInvSimpl :
forall (p : Cart2D IR) (θ:IR),
(rotateAxis (-θ) p) =
  {| X := X p * cos θ - Y p * sin θ;
    Y := Y p * cos θ + X p * sin θ
  |}.
Proof using.
  intros ? ?.  unfold rotateAxis. simpl.
  unfold inprod, InProductCart2D.
  split; simpl;
  autounfold with IRMC;
  rewrite Cos_inv;
  rewrite Sin_inv; ring.
Qed.

Lemma rotateAxisInvertibleIR :
forall (p : Cart2D IR) (θ:IR),
(rotateAxis (-θ)) ((rotateAxis θ) p) = p.
Proof using.
  intros ? ?. rewrite rotateAxisInvSimpl.
  unfold rotateAxis, inprod, InProductCart2D.
  split; simpl;
  autounfold with IRMC;
  ring_simplify.
  - setoid_rewrite <- (mult_1_r (X p)) at 3.
    rewrite <- (FFT θ).
    simpl. IRring.
  - setoid_rewrite <- (mult_1_r (Y p)) at 3.
    rewrite <- (FFT θ).
    simpl. IRring.
Qed.

Lemma nflipAsTranspose  `{Ring R} : forall (p : Cart2D R),
  nflip p = negY * transpose p.
Proof using.
  intros ?.
  split; simpl.
  - symmetry. apply mult_1_l.
  - rewrite <- negate_mult_distr_l.
    rewrite mult_1_l. reflexivity.
Qed.

Lemma nflipNegY `{Ring R} : forall (p : Cart2D R),
  nflip (negY * p) =  - transpose p.
Proof using.
  intros ?.
  split; simpl.
  - rewrite <- negate_mult_distr_l.
    rewrite mult_1_l. reflexivity.
  - symmetry. rewrite mult_1_l. reflexivity.
Qed.

Lemma multDotLeft `{Ring A}:
  ∀ (a:A) (b c : Cart2D A), a * (⟨ b, c ⟩) = ⟨ ' a * b, c ⟩.
Proof using.
  intros. unfold inprod, InProductCart2D.
  simpl.
  do 2 rewrite <- (@simple_associativity _ _ mult _ _).
  rewrite <- plus_mult_distr_l.
  reflexivity.
Qed.

Lemma  QNormSqrPosX : forall (q : Cart2D Q),
  0 < X q
  -> 0 < normSqr q.
Proof using.
  intros ? Hlt. unfold normSqr.
  pose proof Qpower.Qsqr_nonneg (Y q) as H1.
  simpl in H1.
  pose proof (@Q.Qmult_lt_0_compat _ _  Hlt Hlt).
  autounfold with QMC.
  lra.
Qed.

Lemma  QNormSqrPosY : forall (q : Cart2D Q),
  0 < Y q
  -> 0 < normSqr q.
Proof using.
  intros ? Hlt. unfold normSqr.
  pose proof Qpower.Qsqr_nonneg (X q) as H1.
  simpl in H1.
  pose proof (@Q.Qmult_lt_0_compat _ _  Hlt Hlt).
  autounfold with QMC.
  lra.
Qed.

Definition totalSpaceX (c : ConfineRect IR) :IR :=
  X (maxxy c) - X (minxy c).

Require Import MathClasses.interfaces.functors.

(* pointwise Norm *)
Definition pNorm `{NormSpace A A} (r: Rigid2DState A) :=
  sfmap CanonicalNotations.norm r.


Require Import Coq.ZArith.ZArith.
Require Import Coq.Classes.Morphisms.
Require Import Crypto.Util.ZRange.
Require Import Crypto.Util.ZRange.Operations.
Require Import Crypto.Util.ZRange.BasicLemmas.
Require Import Crypto.Util.ZRange.CornersMonotoneBounds.
Require Import Crypto.Util.ZRange.LandLorBounds.
Require Import Crypto.Util.ZUtil.Definitions.
Require Import Crypto.Util.ZUtil.Morphisms.
Require Import Crypto.Util.ZUtil.CC.
Require Import Crypto.Util.Notations.

Module ZRange.
  Local Ltac t :=
    lazymatch goal with
    | [ |- is_bounded_by_bool (?f _) (ZRange.two_corners ?f _) = true ]
      => apply (@ZRange.monotoneb_two_corners_gen f)
    | [ |- is_bounded_by_bool (?f _ _) (ZRange.four_corners ?f _ _) = true ]
      => apply (@ZRange.monotoneb_four_corners_gen f)
    | [ |- is_bounded_by_bool (?f _ _) (ZRange.four_corners_and_zero ?f _ _) = true ]
      => apply (@ZRange.monotoneb_four_corners_and_zero_gen f)
    end;
    eauto with zarith;
    repeat match goal with
           | [ |- forall x : Z, _ ] => let x := fresh "x" in intro x; destruct x
           end;
    eauto with zarith.

  Lemma is_bounded_by_bool_log2
        x x_bs
        (Hboundedx : is_bounded_by_bool x x_bs = true)
  : is_bounded_by_bool (Z.log2 x) (ZRange.log2 x_bs) = true.
  Proof. t. Qed.

  Lemma is_bounded_by_bool_log2_up
        x x_bs
        (Hboundedx : is_bounded_by_bool x x_bs = true)
  : is_bounded_by_bool (Z.log2_up x) (ZRange.log2_up x_bs) = true.
  Proof. t. Qed.

  Lemma is_bounded_by_bool_add
        x x_bs y y_bs
        (Hboundedx : is_bounded_by_bool x x_bs = true)
        (Hboundedy : is_bounded_by_bool y y_bs = true)
  : is_bounded_by_bool (Z.add x y) (ZRange.add x_bs y_bs) = true.
  Proof. t. Qed.

  Lemma is_bounded_by_bool_sub
        x x_bs y y_bs
        (Hboundedx : is_bounded_by_bool x x_bs = true)
        (Hboundedy : is_bounded_by_bool y y_bs = true)
  : is_bounded_by_bool (Z.sub x y) (ZRange.sub x_bs y_bs) = true.
  Proof. t. Qed.

  Lemma is_bounded_by_bool_mul
        x x_bs y y_bs
        (Hboundedx : is_bounded_by_bool x x_bs = true)
        (Hboundedy : is_bounded_by_bool y y_bs = true)
  : is_bounded_by_bool (Z.mul x y) (ZRange.mul x_bs y_bs) = true.
  Proof. t. Qed.

  Lemma is_bounded_by_bool_div
        x x_bs y y_bs
        (Hboundedx : is_bounded_by_bool x x_bs = true)
        (Hboundedy : is_bounded_by_bool y y_bs = true)
  : is_bounded_by_bool (Z.div x y) (ZRange.div x_bs y_bs) = true.
  Proof. t. Qed.

  Lemma is_bounded_by_bool_shiftr
        x x_bs y y_bs
        (Hboundedx : is_bounded_by_bool x x_bs = true)
        (Hboundedy : is_bounded_by_bool y y_bs = true)
  : is_bounded_by_bool (Z.shiftr x y) (ZRange.shiftr x_bs y_bs) = true.
  Proof. t. Qed.

  Lemma is_bounded_by_bool_shiftl
        x x_bs y y_bs
        (Hboundedx : is_bounded_by_bool x x_bs = true)
        (Hboundedy : is_bounded_by_bool y y_bs = true)
  : is_bounded_by_bool (Z.shiftl x y) (ZRange.shiftl x_bs y_bs) = true.
  Proof. t. Qed.

  Lemma is_bounded_by_bool_cc_m
        s x x_bs
        (Hboundedx : is_bounded_by_bool x x_bs = true)
  : is_bounded_by_bool (Z.cc_m s x) (ZRange.cc_m s x_bs) = true.
  Proof. t. Qed.

  Lemma is_bounded_by_bool_land
        x x_bs y y_bs
        (Hboundedx : is_bounded_by_bool x x_bs = true)
        (Hboundedy : is_bounded_by_bool y y_bs = true)
  : is_bounded_by_bool (Z.land x y) (ZRange.land x_bs y_bs) = true.
  Proof. now apply ZRange.is_bounded_by_bool_land_bounds. Qed.

  Lemma is_bounded_by_bool_lor
        x x_bs y y_bs
        (Hboundedx : is_bounded_by_bool x x_bs = true)
        (Hboundedy : is_bounded_by_bool y y_bs = true)
  : is_bounded_by_bool (Z.lor x y) (ZRange.lor x_bs y_bs) = true.
  Proof. now apply ZRange.is_bounded_by_bool_lor_bounds. Qed.
End ZRange.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
Require Import bigop ssralg poly polydiv.

(******************************************************************************)
(*   A proof that algebraically closed field enjoy quantifier elimination,    *)
(*   as described in                                                          *)
(*   ``A formal quantifier elimination for algebraically closed fields'',     *)
(*    proceedings of Calculemus 2010, by Cyril Cohen and Assia Mahboubi       *)
(*                                                                            *)
(* This file constructs an instance of quantifier elimination mixin,          *)
(* (see the ssralg library) from the theory of polynomials with coefficients  *)
(* is an algebraically closed field (see the polydiv library).                *)
(*                                                                            *)
(* This file hence deals with the transformation of formulae part, which we   *)
(* address by implementing one CPS style formula transformer per effective    *)
(* operation involved in the proof of quantifier elimination. See the paper   *)
(* for more details.                                                          *)
(******************************************************************************)

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

Import GRing.
Local Open Scope ring_scope.

Import Pdiv.Ring.
Import PreClosedField.

Section ClosedFieldQE.

Variable F : Field.type.

Variable axiom : ClosedField.axiom F.

Notation fF := (formula F).
Notation qf f := (qf_form f && rformula f).

Definition polyF := seq (term F).

Fixpoint eval_poly (e : seq F) pf :=
  if pf is c::q then (eval_poly e q)*'X + (eval e c)%:P else 0.

Definition rpoly (p : polyF) := all (@rterm F) p.

Fixpoint sizeT (k : nat -> fF) (p : polyF) :=
  if p is c::q then
    sizeT (fun n =>
      if n is m.+1 then k m.+2 else
        GRing.If (c == 0) (k 0%N) (k 1%N)) q
   else k O%N.

Lemma sizeTP (k : nat -> formula F) (pf : polyF) (e : seq F) :
  qf_eval e (sizeT k pf) = qf_eval e (k (size (eval_poly e pf))).
Proof.
elim: pf e k; first by move=> *; rewrite size_poly0.
move=> c qf Pqf e k; rewrite Pqf.
rewrite size_MXaddC -(size_poly_eq0 (eval_poly _ _)).
by case: (size (eval_poly e qf))=> //=; case: eqP; rewrite // orbF.
Qed.

Lemma sizeT_qf (k : nat -> formula F) (p : polyF) :
  (forall n, qf (k n)) -> rpoly p -> qf (sizeT k p).
Proof.
elim: p k => /= [|c q ihp] k kP rp; first exact: kP.
case/andP: rp=> rc rq.
apply: ihp; rewrite ?rq //; case=> [|n]; last exact: kP.
have [/andP[qf0 rf0] /andP[qf1 rf1]] := (kP 0, kP 1)%N.
by rewrite If_form_qf ?If_form_rf //= andbT.
Qed.

Definition isnull (k : bool -> fF) (p : polyF) :=
  sizeT (fun n => k (n == 0%N)) p.

Lemma isnullP (k : bool -> formula F) (p : polyF) (e : seq F) :
  qf_eval e (isnull k p) = qf_eval e (k (eval_poly e p == 0)).
Proof. by rewrite sizeTP size_poly_eq0. Qed.

Lemma isnull_qf (k : bool -> formula F) (p : polyF) :
  (forall b, qf (k b)) -> rpoly p -> qf (isnull k p).
Proof. by move=> *; apply: sizeT_qf. Qed.

Definition lt_sizeT (k : bool -> fF) (p q : polyF) : fF :=
  sizeT (fun n => sizeT (fun m => k (n<m)) q) p.

Definition lift (p : {poly F}) := let: q := p in map Const q.

Lemma eval_lift (e : seq F) (p : {poly F}) : eval_poly e (lift p) = p.
Proof.
elim/poly_ind: p => [|p c]; first by rewrite /lift polyseq0.
rewrite -cons_poly_def /lift polyseq_cons /nilp.
case pn0: (_ == _) => /=; last by move->; rewrite -cons_poly_def.
move=> _; rewrite polyseqC.
case c0: (_==_)=> /=.
  move: pn0; rewrite (eqP c0) size_poly_eq0; move/eqP->.
  by apply:val_inj=> /=; rewrite polyseq_cons // polyseq0.
by rewrite mul0r add0r; apply:val_inj=> /=; rewrite polyseq_cons // /nilp pn0.
Qed.

Fixpoint lead_coefT (k : term F -> fF) p :=
  if p is c::q then
    lead_coefT (fun l => GRing.If (l == 0) (k c) (k l)) q
  else k (Const 0).

Lemma lead_coefTP (k : term F -> formula F) :
 (forall x e, qf_eval e (k x) = qf_eval e (k (Const (eval e x)))) ->
  forall (p : polyF) (e : seq F),
  qf_eval e (lead_coefT k p) = qf_eval e (k (Const (lead_coef (eval_poly e p)))).
Proof.
move=> Pk p e; elim: p k Pk => /= [*|a p' Pp' k Pk]; first by rewrite lead_coef0.
rewrite Pp'; last by move=> *; rewrite //= -Pk.
rewrite GRing.eval_If /= lead_coef_eq0.
case p'0: (_ == _); first by rewrite (eqP p'0) mul0r add0r lead_coefC -Pk.
rewrite lead_coefDl ?lead_coefMX // polyseqC size_mul ?p'0 //; last first.
  by rewrite -size_poly_eq0 size_polyX.
rewrite size_polyX addnC /=; case: (_ == _)=> //=.
by rewrite ltnS lt0n size_poly_eq0 p'0.
Qed.

Lemma lead_coefT_qf (k : term F -> formula F) (p : polyF) :
 (forall c, rterm c -> qf (k c)) -> rpoly p -> qf (lead_coefT k p).
Proof.
elim: p k => /= [|c q ihp] k kP rp; first exact: kP.
move: rp; case/andP=> rc rq; apply: ihp; rewrite ?rq // => l rl.
have [/andP[qfc rfc] /andP[qfl rfl]] := (kP c rc, kP l rl).
by rewrite If_form_qf ?If_form_rf //= andbT.
Qed.

Fixpoint amulXnT (a : term F) (n : nat) : polyF :=
  if n is n'.+1 then (Const 0) :: (amulXnT a n') else [::a].

Lemma eval_amulXnT  (a : term F) (n : nat) (e : seq F) :
  eval_poly e (amulXnT a n) = (eval e a)%:P * 'X^n.
Proof.
elim: n=> [|n] /=; first by rewrite expr0 mulr1 mul0r add0r.
by move->; rewrite addr0 -mulrA -exprSr.
Qed.

Lemma ramulXnT: forall a n, rterm a -> rpoly (amulXnT a n).
Proof. by move=> a n; elim: n a=> [a /= -> //|n ihn a ra]; apply: ihn. Qed.

Fixpoint sumpT (p q : polyF) :=
  if p is a::p' then
    if q is b::q' then (Add a b)::(sumpT p' q')
      else p
    else q.

Lemma eval_sumpT (p q : polyF) (e : seq F) :
  eval_poly e (sumpT p q) = (eval_poly e p) + (eval_poly e q).
Proof.
elim: p q => [|a p Hp] q /=; first by rewrite add0r.
case: q => [|b q] /=; first by rewrite addr0.
rewrite Hp mulrDl -!addrA; congr (_+_); rewrite polyC_add addrC -addrA.
by congr (_+_); rewrite addrC.
Qed.

Lemma rsumpT (p q : polyF) : rpoly p -> rpoly q -> rpoly (sumpT p q).
Proof.
elim: p q=> [|a p ihp] q rp rq //; move: rp; case/andP=> ra rp.
case: q rq => [|b q]; rewrite /= ?ra ?rp //=.
by case/andP=> -> rq //=; apply: ihp.
Qed.

Fixpoint mulpT (p q : polyF) :=
  if p is a :: p' then sumpT (map (Mul a) q) (Const 0::(mulpT p' q)) else [::].

Lemma eval_mulpT (p q : polyF) (e : seq F) :
  eval_poly e (mulpT p q) = (eval_poly e p) * (eval_poly e q).
Proof.
elim: p q=> [|a p Hp] q /=; first by rewrite mul0r.
rewrite eval_sumpT /= Hp addr0 mulrDl addrC mulrAC; congr (_+_).
elim: q=> [|b q Hq] /=; first by rewrite mulr0.
by rewrite Hq polyC_mul mulrDr mulrA.
Qed.

Lemma rpoly_map_mul (t : term F) (p : polyF) (rt : rterm t) :
  rpoly (map (Mul t) p) = rpoly p.
Proof.
by rewrite /rpoly all_map /= (@eq_all _ _ (@rterm _)) // => x; rewrite /= rt.
Qed.

Lemma rmulpT (p q : polyF) : rpoly p -> rpoly q -> rpoly (mulpT p q).
Proof.
elim: p q=> [|a p ihp] q rp rq //=; move: rp; case/andP=> ra rp /=.
apply: rsumpT; last exact: ihp.
by rewrite rpoly_map_mul.
Qed.

Definition opppT := map (Mul (@Const F (-1))).

Lemma eval_opppT (p : polyF) (e : seq F) :
 eval_poly e (opppT p) = - eval_poly e p.
Proof.
by elim: p; rewrite /= ?oppr0 // => ? ? ->; rewrite !mulNr opprD polyC_opp mul1r.
Qed.

Definition natmulpT n := map (Mul (@NatConst F n)).

Lemma eval_natmulpT  (p : polyF) (n : nat) (e : seq F) :
  eval_poly e (natmulpT n p) = (eval_poly e p) *+ n.
Proof.
elim: p; rewrite //= ?mul0rn // => c p ->.
rewrite mulrnDl mulr_natl polyC_muln; congr (_+_).
by rewrite -mulr_natl mulrAC -mulrA mulr_natl mulrC.
Qed.

Fixpoint redivp_rec_loopT (q : polyF) sq cq (k : nat * polyF * polyF -> fF)
  (c : nat) (qq r : polyF) (n : nat) {struct n}:=
  sizeT (fun sr =>
    if sr < sq then k (c, qq, r) else
      lead_coefT (fun lr =>
        let m := amulXnT lr (sr - sq) in
        let qq1 := sumpT (mulpT qq [::cq]) m in
        let r1 := sumpT (mulpT r ([::cq])) (opppT (mulpT m q)) in
        if n is n1.+1 then redivp_rec_loopT q sq cq k c.+1 qq1 r1 n1
        else k (c.+1, qq1, r1)
      ) r
  ) r.

Fixpoint redivp_rec_loop (q : {poly F}) sq cq
   (k : nat) (qq r : {poly F})(n : nat) {struct n} :=
    if size r < sq then (k, qq, r) else
      let m := (lead_coef r) *: 'X^(size r - sq) in
      let qq1 := qq * cq%:P + m in
      let r1 := r * cq%:P - m * q in
      if n is n1.+1 then redivp_rec_loop q sq cq k.+1 qq1 r1 n1 else
        (k.+1, qq1, r1).

Lemma redivp_rec_loopTP (k : nat * polyF * polyF -> formula F) :
  (forall c qq r e,  qf_eval e (k (c,qq,r))
    = qf_eval e (k (c, lift (eval_poly e qq), lift (eval_poly e r))))
  -> forall q sq cq c qq r n e
    (d := redivp_rec_loop (eval_poly e q) sq (eval e cq)
      c (eval_poly e qq) (eval_poly e r) n),
    qf_eval e (redivp_rec_loopT q sq cq k c qq r n)
    = qf_eval e (k (d.1.1, lift d.1.2, lift d.2)).
Proof.
move=> Pk q sq cq c qq r n e /=.
elim: n c qq r k Pk e => [|n Pn] c qq r k Pk e; rewrite sizeTP.
  case ltrq : (_ < _); first by rewrite /= ltrq /= -Pk.
  rewrite lead_coefTP => [|a p]; rewrite Pk.
    rewrite ?(eval_mulpT,eval_amulXnT,eval_sumpT,eval_opppT) //=.
    by rewrite ltrq //= mul_polyC ?(mul0r,add0r).
  by symmetry; rewrite Pk ?(eval_mulpT,eval_amulXnT,eval_sumpT, eval_opppT).
case ltrq : (_<_); first by rewrite /= ltrq Pk.
rewrite lead_coefTP.
  rewrite Pn ?(eval_mulpT,eval_amulXnT,eval_sumpT,eval_opppT) //=.
  by rewrite ltrq //= mul_polyC ?(mul0r,add0r).
rewrite -/redivp_rec_loopT => x e'.
rewrite Pn; last by move=>*; rewrite Pk.
symmetry; rewrite Pn; last by move=>*; rewrite Pk.
rewrite Pk ?(eval_lift,eval_mulpT,eval_amulXnT,eval_sumpT,eval_opppT).
by rewrite mul_polyC ?(mul0r,add0r).
Qed.

Lemma redivp_rec_loopT_qf (q : polyF) (sq : nat) (cq : term F)
 (k : nat * polyF * polyF -> formula F) (c : nat) (qq r : polyF) (n : nat) :
  (forall r, [&& rpoly r.1.2 & rpoly r.2] -> qf (k r)) ->
  rpoly q -> rterm cq -> rpoly qq -> rpoly r ->
    qf (redivp_rec_loopT q sq cq k c qq r n).
Proof.
elim: n q sq cq k c qq r => [|n ihn] q sq cq k c qq r kP rq rcq rqq rr.
  apply: sizeT_qf=> // n; case: (_ < _); first by apply: kP; rewrite // rqq rr.
  apply: lead_coefT_qf=> // l rl; apply: kP.
  by rewrite /= ?(rsumpT,rmulpT,ramulXnT,rpoly_map_mul) //= rcq.
apply: sizeT_qf=> // m; case: (_ < _); first by apply: kP => //=; rewrite rqq rr.
apply: lead_coefT_qf=> // l rl; apply: ihn; rewrite //= ?rcq //.
  by rewrite ?(rsumpT,rmulpT,ramulXnT,rpoly_map_mul) //= rcq.
by rewrite ?(rsumpT,rmulpT,ramulXnT,rpoly_map_mul) //= rcq.
Qed.

Definition redivpT (p : polyF) (k : nat * polyF * polyF -> fF)
                   (q : polyF) : fF :=
  isnull (fun b =>
    if b then k (0%N, [::Const 0], p) else
      sizeT (fun sq =>
        sizeT (fun sp =>
          lead_coefT (fun lq =>
            redivp_rec_loopT q sq lq k 0 [::Const 0] p sp
          ) q
        ) p
      ) q
  ) q.

Lemma redivp_rec_loopP  (q : {poly F}) (c : nat) (qq r : {poly F}) (n : nat) :
  redivp_rec q c qq r n = redivp_rec_loop q (size q) (lead_coef q) c qq r n.
Proof. by elim: n c qq r => [| n Pn] c qq r //=; rewrite Pn. Qed.

Lemma redivpTP (k : nat * polyF * polyF -> formula F) :
  (forall c qq r e,
     qf_eval e (k (c,qq,r)) =
     qf_eval e (k (c, lift (eval_poly e qq), lift (eval_poly e r)))) ->
  forall p q e (d := redivp (eval_poly e p) (eval_poly e q)),
    qf_eval e (redivpT p k q) = qf_eval e (k (d.1.1, lift d.1.2, lift d.2)).
Proof.
move=> Pk p q e /=; rewrite isnullP unlock.
case q0 : (_ == _); first by rewrite Pk /= mul0r add0r polyC0.
rewrite !sizeTP lead_coefTP /=; last by move=> *; rewrite !redivp_rec_loopTP.
rewrite redivp_rec_loopTP /=; last by move=> *; rewrite Pk.
by rewrite mul0r add0r polyC0 redivp_rec_loopP.
Qed.

Lemma redivpT_qf (p : polyF) (k : nat * polyF * polyF -> formula F) (q : polyF) :
  (forall r, [&& rpoly r.1.2 & rpoly r.2] -> qf (k r)) ->
   rpoly p -> rpoly q -> qf (redivpT p k q).
Proof.
move=> kP rp rq; rewrite /redivpT; apply: isnull_qf=> // [[]]; first exact: kP.
apply: sizeT_qf => // sq; apply: sizeT_qf=> // sp.
by apply: lead_coefT_qf=> // lq rlq; apply: redivp_rec_loopT_qf.
Qed.

Definition rmodpT (p : polyF) (k : polyF -> fF) (q : polyF) : fF :=
  redivpT p (fun d => k d.2) q.
Definition rdivpT (p : polyF) (k:polyF -> fF) (q : polyF) : fF :=
  redivpT p (fun d => k d.1.2) q.
Definition rscalpT (p : polyF) (k: nat -> fF) (q : polyF) : fF :=
  redivpT p (fun d => k d.1.1) q.
Definition rdvdpT (p : polyF) (k:bool -> fF) (q : polyF) : fF :=
  rmodpT p (isnull k) q.

Fixpoint rgcdp_loop n (pp qq : {poly F}) {struct n} :=
  if rmodp pp qq == 0 then qq
    else if n is n1.+1 then rgcdp_loop n1 qq (rmodp pp qq)
         else rmodp pp qq.

Fixpoint rgcdp_loopT (pp : polyF) (k : polyF -> formula F) n (qq : polyF) :=
  rmodpT pp (isnull
    (fun b => if b then (k qq)
              else (if n is n1.+1
                    then rmodpT pp (rgcdp_loopT qq k n1) qq
                    else rmodpT pp k qq)
    )
            ) qq.

Lemma rgcdp_loopP (k : polyF -> formula F) :
  (forall p e, qf_eval e (k p) = qf_eval e (k (lift (eval_poly e p)))) ->
  forall n p q e,
    qf_eval e (rgcdp_loopT p k n q) =
    qf_eval e (k (lift (rgcdp_loop n (eval_poly e p) (eval_poly e q)))).
Proof.
move=> Pk n p q e.
elim: n p q e => /= [| m Pm] p q e.
  rewrite redivpTP; last by move=>*; rewrite !isnullP eval_lift.
  rewrite isnullP eval_lift; case: (_ == 0); first by rewrite Pk.
  by rewrite redivpTP; last by move=>*; rewrite Pk.
rewrite redivpTP; last by move=>*; rewrite !isnullP eval_lift.
rewrite isnullP eval_lift; case: (_ == 0); first by rewrite Pk.
by rewrite redivpTP; move=>*; rewrite ?Pm !eval_lift.
Qed.

Lemma rgcdp_loopT_qf (p : polyF) (k : polyF -> formula F) (q : polyF) (n : nat) :
  (forall r, rpoly r -> qf (k r)) ->
  rpoly p -> rpoly q -> qf (rgcdp_loopT p k n q).
elim: n p k q => [|n ihn] p k q kP rp rq.
  apply: redivpT_qf=> // r; case/andP=> _ rr.
  apply: isnull_qf=> // [[]]; first exact: kP.
  by apply: redivpT_qf=> // r'; case/andP=> _ rr'; apply: kP.
apply: redivpT_qf=> // r; case/andP=> _ rr.
apply: isnull_qf=> // [[]]; first exact: kP.
by apply: redivpT_qf=> // r'; case/andP=> _ rr'; apply: ihn.
Qed.

Definition rgcdpT (p : polyF) k (q : polyF) : fF :=
  let aux p1 k q1 := isnull
    (fun b => if b
      then (k q1)
      else (sizeT (fun n => (rgcdp_loopT p1 k n q1)) p1)) p1
    in (lt_sizeT (fun b => if b then (aux q k p) else (aux p k q)) p q).

Lemma rgcdpTP (k : seq (term F) -> formula F) :
  (forall p e, qf_eval e (k p) = qf_eval e (k (lift (eval_poly e p)))) ->
   forall p q e, qf_eval e (rgcdpT p k q) =
                 qf_eval e (k (lift (rgcdp (eval_poly e p) (eval_poly e q)))).
Proof.
move=> Pk p q e; rewrite /rgcdpT !sizeTP; case lqp: (_ < _).
  rewrite isnullP; case q0: (_ == _); first by rewrite Pk (eqP q0) rgcdp0.
  rewrite sizeTP rgcdp_loopP => [|e' p']; last by rewrite Pk.
  by rewrite /rgcdp lqp q0.
rewrite isnullP; case p0: (_ == _); first by rewrite Pk (eqP p0) rgcd0p.
rewrite sizeTP rgcdp_loopP => [|e' p']; last by rewrite Pk.
by rewrite /rgcdp lqp p0.
Qed.

Lemma rgcdpT_qf  (p : polyF) (k : polyF -> formula F) (q : polyF) :
  (forall r, rpoly r -> qf (k r)) -> rpoly p -> rpoly q -> qf (rgcdpT p k q).
Proof.
move=> kP rp rq; apply: sizeT_qf=> // n; apply: sizeT_qf=> // m.
by case:(_ < _);
   apply: isnull_qf=> //; case; do ?apply: kP=> //;
   apply: sizeT_qf=> // n'; apply: rgcdp_loopT_qf.
Qed.

Fixpoint rgcdpTs k (ps : seq polyF) : fF :=
  if ps is p::pr then rgcdpTs (rgcdpT p k) pr else k [::Const 0].

Lemma rgcdpTsP (k : polyF -> formula F) :
  (forall p e, qf_eval e (k p) = qf_eval e (k (lift (eval_poly e p)))) ->
  forall ps e,
    qf_eval e (rgcdpTs k ps) =
    qf_eval e (k (lift (\big[@rgcdp _/0%:P]_(i <- ps)(eval_poly e i)))).
Proof.
move=> Pk ps e.
elim: ps k Pk; first by move=> p Pk; rewrite /= big_nil Pk /= mul0r add0r.
move=> p ps Pps /= k Pk /=; rewrite big_cons Pps => [|p' e'].
  by rewrite rgcdpTP // eval_lift.
by rewrite !rgcdpTP // Pk !eval_lift .
Qed.

Definition rseq_poly ps := all rpoly ps.

Lemma rgcdpTs_qf (k : polyF -> formula F) (ps : seq polyF) :
  (forall r, rpoly r -> qf (k r)) -> rseq_poly ps -> qf (rgcdpTs k ps).
Proof.
elim: ps k=> [|c p ihp] k kP rps=> /=; first exact: kP.
by move: rps; case/andP=> rc rp; apply: ihp=> // r rr; apply: rgcdpT_qf.
Qed.

Fixpoint rgdcop_recT (q : polyF) k  (p : polyF) n :=
  if n is m.+1 then
    rgcdpT p (sizeT (fun sd =>
      if sd == 1%N then k p
      else rgcdpT p (rdivpT p (fun r => rgdcop_recT q k r m)) q
    )) q
  else isnull (fun b => k [::Const b%:R]) q.

Lemma rgdcop_recTP (k : polyF -> formula F) :
  (forall p e, qf_eval e (k p) = qf_eval e (k (lift (eval_poly e p))))
  -> forall p q n e, qf_eval e (rgdcop_recT p k q n)
    = qf_eval e (k (lift (rgdcop_rec (eval_poly e p) (eval_poly e q) n))).
Proof.
move=> Pk p q n e.
elim: n k Pk p q e => [|n Pn] k Pk p q e /=.
  rewrite isnullP /=.
  by case: (_ == _); rewrite Pk /= mul0r add0r ?(polyC0, polyC1).
rewrite rgcdpTP ?sizeTP ?eval_lift //.
  rewrite /rcoprimep; case se : (_==_); rewrite Pk //.
  do ?[rewrite (rgcdpTP,Pn,eval_lift,redivpTP) | move=> * //=].
by do ?[rewrite (sizeTP,eval_lift) | move=> * //=].
Qed.

Lemma rgdcop_recT_qf (p : polyF) (k : polyF -> formula F) (q : polyF) (n : nat) :
 (forall r, rpoly r -> qf (k r)) ->
 rpoly p -> rpoly q -> qf (rgdcop_recT p k q n).
Proof.
elim: n p k q => [|n ihn] p k q kP rp rq /=.
apply: isnull_qf=> //; first by case; rewrite kP.
apply: rgcdpT_qf=> // g rg; apply: sizeT_qf=> // n'.
case: (_ == _); first exact: kP.
apply: rgcdpT_qf=> // g' rg'; apply: redivpT_qf=> // r; case/andP=> rr _.
exact: ihn.
Qed.

Definition rgdcopT q k p := sizeT (rgdcop_recT q k p) p.

Lemma rgdcopTP (k : polyF -> formula F) :
  (forall p e, qf_eval e (k p) = qf_eval e (k (lift (eval_poly e p)))) ->
  forall p q e, qf_eval e (rgdcopT p k q) =
                qf_eval e (k (lift (rgdcop (eval_poly e p) (eval_poly e q)))).
Proof. by move=> *; rewrite sizeTP rgdcop_recTP 1?Pk. Qed.

Lemma rgdcopT_qf (p : polyF) (k : polyF -> formula F) (q : polyF) :
  (forall r, rpoly r -> qf (k r)) -> rpoly p -> rpoly q -> qf (rgdcopT p k q).
Proof.
by move=> kP rp rq; apply: sizeT_qf => // n; apply: rgdcop_recT_qf.
Qed.

Definition ex_elim_seq (ps : seq polyF) (q : polyF) :=
  (rgcdpTs (rgdcopT q (sizeT (fun n => Bool (n != 1%N)))) ps).

Lemma ex_elim_seqP (ps : seq polyF) (q : polyF) (e : seq F) :
  let gp := (\big[@rgcdp _/0%:P]_(p <- ps)(eval_poly e p)) in
  qf_eval e (ex_elim_seq ps q) = (size (rgdcop (eval_poly e q) gp) != 1%N).
Proof.
by do ![rewrite (rgcdpTsP,rgdcopTP,sizeTP,eval_lift) //= | move=> * //=].
Qed.

Lemma ex_elim_seq_qf  (ps : seq polyF) (q : polyF) :
  rseq_poly ps -> rpoly q -> qf (ex_elim_seq ps q).
Proof.
move=> rps rq; apply: rgcdpTs_qf=> // g rg; apply: rgdcopT_qf=> // d rd.
exact : sizeT_qf.
Qed.

Fixpoint abstrX (i : nat) (t : term F) :=
  match t with
    | (Var n) => if n == i then [::Const 0; Const 1] else [::t]
    | (Opp x) => opppT (abstrX i x)
    | (Add x y) => sumpT (abstrX i x) (abstrX i y)
    | (Mul x y) => mulpT (abstrX i x) (abstrX i y)
    | (NatMul x n) => natmulpT n (abstrX i x)
    | (Exp x n) => let ax := (abstrX i x) in
      iter n (mulpT ax) [::Const 1]
    | _ => [::t]
  end.

Lemma abstrXP  (i : nat) (t : term F) (e : seq F) (x : F) :
  rterm t -> (eval_poly e (abstrX i t)).[x] = eval (set_nth 0 e i x) t.
Proof.
elim: t => [n | r | n | t tP s sP | t tP | t tP n | t tP s sP | t tP | t tP n] h.
- move=> /=; case ni: (_ == _);
    rewrite //= ?(mul0r,add0r,addr0,polyC1,mul1r,hornerX,hornerC);
    by rewrite // nth_set_nth /= ni.
- by rewrite /= mul0r add0r hornerC.
- by rewrite /= mul0r add0r hornerC.
- by case/andP: h => *; rewrite /= eval_sumpT hornerD tP ?sP.
- by rewrite /= eval_opppT hornerN tP.
- by rewrite /= eval_natmulpT hornerMn tP.
- by case/andP: h => *; rewrite /= eval_mulpT hornerM tP ?sP.
- by [].
- elim: n h => [|n ihn] rt; first by rewrite /= expr0 mul0r add0r hornerC.
  by rewrite /= eval_mulpT exprSr hornerM ihn // mulrC tP.
Qed.

Lemma rabstrX (i : nat) (t : term F) : rterm t -> rpoly (abstrX i t).
Proof.
elim: t; do ?[ by move=> * //=; do ?case: (_ == _)].
- move=> t irt s irs /=; case/andP=> rt rs.
  by apply: rsumpT; rewrite ?irt ?irs //.
- by move=> t irt /= rt; rewrite rpoly_map_mul ?irt //.
- by move=> t irt /= n rt; rewrite rpoly_map_mul ?irt //.
- move=> t irt s irs /=; case/andP=> rt rs.
  by apply: rmulpT; rewrite ?irt ?irs //.
- move=> t irt /= n rt; move: (irt rt)=> {rt} rt; elim: n => [|n ihn] //=.
  exact: rmulpT.
Qed.

Implicit Types tx ty : term F.

Lemma abstrX_mulM (i : nat) : {morph abstrX i : x y / Mul x y >-> mulpT x y}.
Proof. done. Qed.

Lemma abstrX1 (i : nat) : abstrX i (Const 1) = [::Const 1].
Proof. done. Qed.

Lemma eval_poly_mulM e : {morph eval_poly e : x y / mulpT x y >-> mul x y}.
Proof. by move=> x y; rewrite eval_mulpT. Qed.

Lemma eval_poly1 e : eval_poly e [::Const 1] = 1.
Proof. by rewrite /= mul0r add0r. Qed.

Notation abstrX_bigmul := (big_morph _ (abstrX_mulM _) (abstrX1 _)).
Notation eval_bigmul := (big_morph _ (eval_poly_mulM _) (eval_poly1 _)).
Notation bigmap_id := (big_map _ (fun _ => true) id).

Lemma rseq_poly_map (x : nat) (ts : seq (term F)) :
  all (@rterm _) ts ->  rseq_poly (map (abstrX x) ts).
Proof.
by elim: ts => //= t ts iht; case/andP=> rt rts; rewrite rabstrX // iht.
Qed.

Definition ex_elim (x : nat) (pqs : seq (term F) * seq (term F)) :=
  ex_elim_seq (map (abstrX x) pqs.1)
  (abstrX x (\big[Mul/Const 1]_(q <- pqs.2) q)).

Lemma ex_elim_qf (x : nat) (pqs : seq (term F) * seq (term F)) :
  dnf_rterm pqs -> qf (ex_elim x pqs).
case: pqs => ps qs; case/andP=> /= rps rqs.
apply: ex_elim_seq_qf; first exact: rseq_poly_map.
apply: rabstrX=> /=.
elim: qs rqs=> [|t ts iht] //=; first by rewrite big_nil.
by case/andP=> rt rts; rewrite big_cons /= rt /= iht.
Qed.

Lemma holds_conj : forall e i x ps, all (@rterm _) ps ->
  (holds (set_nth 0 e i x) (foldr (fun t : term F => And (t == 0)) True ps)
  <-> all ((@root _)^~ x) (map (eval_poly e \o abstrX i) ps)).
Proof.
move=> e i x; elim=> [|p ps ihps] //=.
case/andP=> rp rps; rewrite rootE abstrXP //.
constructor; first by case=> -> hps; rewrite eqxx /=; apply/ihps.
by case/andP; move/eqP=> -> psr; split=> //; apply/ihps.
Qed.

Lemma holds_conjn (e : seq F) (i : nat) (x : F) (ps : seq (term F)) :
  all (@rterm _) ps ->
  (holds (set_nth 0 e i x) (foldr (fun t : term F => And (t != 0)) True ps) <->
  all (fun p => ~~root p x) (map (eval_poly e \o abstrX i) ps)).
Proof.
elim: ps => [|p ps ihps] //=.
case/andP=> rp rps; rewrite rootE abstrXP //.
constructor; first by case=> /eqP-> hps /=; apply/ihps.
by case/andP=> pr psr; split; first apply/eqP=> //; apply/ihps.
Qed.

Lemma holds_ex_elim : GRing.valid_QE_proj ex_elim.
Proof.
move=> i [ps qs] /= e; case/andP=> /= rps rqs.
rewrite ex_elim_seqP big_map.
have -> : \big[@rgcdp _/0%:P]_(j <- ps) eval_poly e (abstrX i j) =
          \big[@rgcdp _/0%:P]_(j <- (map (eval_poly e) (map (abstrX i) (ps)))) j.
  by rewrite !big_map.
rewrite -!map_comp.
  have aux I (l : seq I) (P : I -> {poly F}) :
    \big[(@gcdp F)/0]_(j <- l) P j %= \big[(@rgcdp F)/0]_(j <- l) P j.
    elim: l => [| u l ihl] /=; first by rewrite !big_nil eqpxx.
    rewrite !big_cons; move: ihl; move/(eqp_gcdr (P u)) => h.
    by apply: eqp_trans h _; rewrite eqp_sym; apply: eqp_rgcd_gcd.
case g0: (\big[(@rgcdp F)/0%:P]_(j <- map (eval_poly e \o abstrX i) ps) j == 0).
  rewrite (eqP g0) rgdcop0.
  case m0 : (_ == 0)=> //=; rewrite ?(size_poly1,size_poly0) //=.
    rewrite abstrX_bigmul eval_bigmul -bigmap_id in m0.
    constructor=> [[x] // []] //.
    case=> _; move/holds_conjn=> hc; move/hc:rqs.
    by rewrite -root_bigmul //= (eqP m0) root0.
  constructor; move/negP:m0; move/negP=>m0.
  case: (closed_nonrootP axiom _ m0) => x {m0}.
  rewrite abstrX_bigmul eval_bigmul -bigmap_id root_bigmul=> m0.
  exists x; do 2?constructor=> //; last by apply/holds_conjn.
  apply/holds_conj; rewrite //= -root_biggcd.
  by rewrite (eqp_root (aux _ _ _ )) (eqP g0) root0.
apply:(iffP (closed_rootP axiom _)); case=> x Px; exists x; move:Px => //=.
  rewrite (eqp_root (eqp_rgdco_gdco _ _)) root_gdco ?g0 //.
  rewrite -(eqp_root (aux _ _ _ )) root_biggcd  abstrX_bigmul eval_bigmul.
  rewrite -bigmap_id root_bigmul; case/andP=> psr qsr.
  do 2?constructor; first by apply/holds_conj.
  by apply/holds_conjn.
rewrite (eqp_root (eqp_rgdco_gdco _ _)) root_gdco ?g0 // -(eqp_root (aux _ _ _)).
rewrite root_biggcd abstrX_bigmul eval_bigmul -bigmap_id.
rewrite root_bigmul=> [[] // [hps hqs]]; apply/andP.
constructor; first by apply/holds_conj.
by apply/holds_conjn.
Qed.

Lemma wf_ex_elim : GRing.wf_QE_proj ex_elim.
Proof. by move=> i bc /= rbc; apply: ex_elim_qf. Qed.

Definition closed_fields_QEMixin :=
  QEdecFieldMixin wf_ex_elim holds_ex_elim.

End ClosedFieldQE.


Require Import List.
Import ListNotations.
Require Import LambekSyntax.

Fixpoint pullMultLeft (X: formula) (x: str) :=
  match x with
  | [] => X
  | X' :: x' => pullMultLeft (X ° X') x'
  end.

Fixpoint pullMultRight (X : formula) (x : str) :=
  match x with
  | [] => X
  | (X'::x') => X ° (pullMultRight X' x')
  end.

Lemma pullMultLeftSplit X x A:
  pullMultLeft X (x ++ [A]) = pullMultLeft X x ° A.
Proof.
  generalize dependent X.
  induction x as [| X' x].
  - auto.
  - intros X. simpl.
    apply (IHx (X ° X')).
Qed.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *         Copyright INRIA, CNRS and contributors             *)
(* <O___,, * (see version control and CREDITS file for authors & dates) *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Import Notations Logic Datatypes.
Require Decimal Hexadecimal Number.
Local Open Scope nat_scope.

(**********************************************************************)
(** * Peano natural numbers, definitions of operations *)
(**********************************************************************)

(** This file is meant to be used as a whole module,
    without importing it, leading to qualified definitions
    (e.g. Nat.pred) *)

Definition t := nat.

(** ** Constants *)

Local Notation "0" := O.
Local Notation "1" := (S O).
Local Notation "2" := (S (S O)).

Definition zero := 0.
Definition one := 1.
Definition two := 2.

(** ** Basic operations *)

Definition succ := S.

Definition pred n :=
  match n with
    | 0 => n
    | S u => u
  end.

Register pred as num.nat.pred.

Fixpoint add n m :=
  match n with
  | 0 => m
  | S p => S (p + m)
  end

where "n + m" := (add n m) : nat_scope.

Register add as num.nat.add.

Definition double n := n + n.

Fixpoint mul n m :=
  match n with
  | 0 => 0
  | S p => m + p * m
  end

where "n * m" := (mul n m) : nat_scope.

Register mul as num.nat.mul.

(** Truncated subtraction: [n-m] is [0] if [n<=m] *)

Fixpoint sub n m :=
  match n, m with
  | S k, S l => k - l
  | _, _ => n
  end

where "n - m" := (sub n m) : nat_scope.

Register sub as num.nat.sub.

(** ** Comparisons *)

Fixpoint eqb n m : bool :=
  match n, m with
    | 0, 0 => true
    | 0, S _ => false
    | S _, 0 => false
    | S n', S m' => eqb n' m'
  end.

Fixpoint leb n m : bool :=
  match n, m with
    | 0, _ => true
    | _, 0 => false
    | S n', S m' => leb n' m'
  end.

Definition ltb n m := leb (S n) m.

Infix "=?" := eqb (at level 70) : nat_scope.
Infix "<=?" := leb (at level 70) : nat_scope.
Infix "<?" := ltb (at level 70) : nat_scope.

Fixpoint compare n m : comparison :=
  match n, m with
   | 0, 0 => Eq
   | 0, S _ => Lt
   | S _, 0 => Gt
   | S n', S m' => compare n' m'
  end.

Infix "?=" := compare (at level 70) : nat_scope.

(** ** Minimum, maximum *)

Fixpoint max n m :=
  match n, m with
    | 0, _ => m
    | S n', 0 => n
    | S n', S m' => S (max n' m')
  end.

Fixpoint min n m :=
  match n, m with
    | 0, _ => 0
    | S n', 0 => 0
    | S n', S m' => S (min n' m')
  end.

(** ** Parity tests *)

Fixpoint even n : bool :=
  match n with
    | 0 => true
    | 1 => false
    | S (S n') => even n'
  end.

Definition odd n := negb (even n).

(** ** Power *)

Fixpoint pow n m :=
  match m with
    | 0 => 1
    | S m => n * (n^m)
  end

where "n ^ m" := (pow n m) : nat_scope.

(** ** Tail-recursive versions of [add] and [mul] *)

Fixpoint tail_add n m :=
  match n with
    | O => m
    | S n => tail_add n (S m)
  end.

(** [tail_addmul r n m] is [r + n * m]. *)

Fixpoint tail_addmul r n m :=
  match n with
    | O => r
    | S n => tail_addmul (tail_add m r) n m
  end.

Definition tail_mul n m := tail_addmul 0 n m.

(** ** Conversion with a decimal representation for printing/parsing *)

Local Notation ten := (S (S (S (S (S (S (S (S (S (S O)))))))))).

Fixpoint of_uint_acc (d:Decimal.uint)(acc:nat) :=
  match d with
  | Decimal.Nil => acc
  | Decimal.D0 d => of_uint_acc d (tail_mul ten acc)
  | Decimal.D1 d => of_uint_acc d (S (tail_mul ten acc))
  | Decimal.D2 d => of_uint_acc d (S (S (tail_mul ten acc)))
  | Decimal.D3 d => of_uint_acc d (S (S (S (tail_mul ten acc))))
  | Decimal.D4 d => of_uint_acc d (S (S (S (S (tail_mul ten acc)))))
  | Decimal.D5 d => of_uint_acc d (S (S (S (S (S (tail_mul ten acc))))))
  | Decimal.D6 d => of_uint_acc d (S (S (S (S (S (S (tail_mul ten acc)))))))
  | Decimal.D7 d => of_uint_acc d (S (S (S (S (S (S (S (tail_mul ten acc))))))))
  | Decimal.D8 d => of_uint_acc d (S (S (S (S (S (S (S (S (tail_mul ten acc)))))))))
  | Decimal.D9 d => of_uint_acc d (S (S (S (S (S (S (S (S (S (tail_mul ten acc))))))))))
  end.

Definition of_uint (d:Decimal.uint) := of_uint_acc d O.

Local Notation sixteen := (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S O)))))))))))))))).

Fixpoint of_hex_uint_acc (d:Hexadecimal.uint)(acc:nat) :=
  match d with
  | Hexadecimal.Nil => acc
  | Hexadecimal.D0 d => of_hex_uint_acc d (tail_mul sixteen acc)
  | Hexadecimal.D1 d => of_hex_uint_acc d (S (tail_mul sixteen acc))
  | Hexadecimal.D2 d => of_hex_uint_acc d (S (S (tail_mul sixteen acc)))
  | Hexadecimal.D3 d => of_hex_uint_acc d (S (S (S (tail_mul sixteen acc))))
  | Hexadecimal.D4 d => of_hex_uint_acc d (S (S (S (S (tail_mul sixteen acc)))))
  | Hexadecimal.D5 d => of_hex_uint_acc d (S (S (S (S (S (tail_mul sixteen acc))))))
  | Hexadecimal.D6 d => of_hex_uint_acc d (S (S (S (S (S (S (tail_mul sixteen acc)))))))
  | Hexadecimal.D7 d => of_hex_uint_acc d (S (S (S (S (S (S (S (tail_mul sixteen acc))))))))
  | Hexadecimal.D8 d => of_hex_uint_acc d (S (S (S (S (S (S (S (S (tail_mul sixteen acc)))))))))
  | Hexadecimal.D9 d => of_hex_uint_acc d (S (S (S (S (S (S (S (S (S (tail_mul sixteen acc))))))))))
  | Hexadecimal.Da d => of_hex_uint_acc d (S (S (S (S (S (S (S (S (S (S (tail_mul sixteen acc)))))))))))
  | Hexadecimal.Db d => of_hex_uint_acc d (S (S (S (S (S (S (S (S (S (S (S (tail_mul sixteen acc))))))))))))
  | Hexadecimal.Dc d => of_hex_uint_acc d (S (S (S (S (S (S (S (S (S (S (S (S (tail_mul sixteen acc)))))))))))))
  | Hexadecimal.Dd d => of_hex_uint_acc d (S (S (S (S (S (S (S (S (S (S (S (S (S (tail_mul sixteen acc))))))))))))))
  | Hexadecimal.De d => of_hex_uint_acc d (S (S (S (S (S (S (S (S (S (S (S (S (S (S (tail_mul sixteen acc)))))))))))))))
  | Hexadecimal.Df d => of_hex_uint_acc d (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (tail_mul sixteen acc))))))))))))))))
  end.

Definition of_hex_uint (d:Hexadecimal.uint) := of_hex_uint_acc d O.

Definition of_num_uint (d:Number.uint) :=
  match d with
  | Number.UIntDecimal d => of_uint d
  | Number.UIntHexadecimal d => of_hex_uint d
  end.

Fixpoint to_little_uint n acc :=
  match n with
  | O => acc
  | S n => to_little_uint n (Decimal.Little.succ acc)
  end.

Definition to_uint n :=
  Decimal.rev (to_little_uint n Decimal.zero).

Fixpoint to_little_hex_uint n acc :=
  match n with
  | O => acc
  | S n => to_little_hex_uint n (Hexadecimal.Little.succ acc)
  end.

Definition to_hex_uint n :=
  Hexadecimal.rev (to_little_hex_uint n Hexadecimal.zero).

Definition to_num_uint n := Number.UIntDecimal (to_uint n).

Definition to_num_hex_uint n := Number.UIntHexadecimal (to_hex_uint n).

Definition of_int (d:Decimal.int) : option nat :=
  match Decimal.norm d with
    | Decimal.Pos u => Some (of_uint u)
    | _ => None
  end.

Definition of_hex_int (d:Hexadecimal.int) : option nat :=
  match Hexadecimal.norm d with
    | Hexadecimal.Pos u => Some (of_hex_uint u)
    | _ => None
  end.

Definition of_num_int (d:Number.int) : option nat :=
  match d with
  | Number.IntDecimal d => of_int d
  | Number.IntHexadecimal d => of_hex_int d
  end.

Definition to_int n := Decimal.Pos (to_uint n).

Definition to_hex_int n := Hexadecimal.Pos (to_hex_uint n).

Definition to_num_int n := Number.IntDecimal (to_int n).

(** ** Euclidean division *)

(** This division is linear and tail-recursive.
    In [divmod], [y] is the predecessor of the actual divisor,
    and [u] is [y] minus the real remainder
*)

Fixpoint divmod x y q u :=
  match x with
    | 0 => (q,u)
    | S x' => match u with
                | 0 => divmod x' y (S q) y
                | S u' => divmod x' y q u'
              end
  end.

Definition div x y :=
  match y with
    | 0 => y
    | S y' => fst (divmod x y' 0 y')
  end.

Definition modulo x y :=
  match y with
    | 0 => x
    | S y' => y' - snd (divmod x y' 0 y')
  end.

Infix "/" := div : nat_scope.
Infix "mod" := modulo (at level 40, no associativity) : nat_scope.

(** ** Greatest common divisor *)

(** We use Euclid algorithm, which is normally not structural,
    but Coq is now clever enough to accept this (behind modulo
    there is a subtraction, which now preserves being a subterm)
*)

Fixpoint gcd a b :=
  match a with
   | O => b
   | S a' => gcd (b mod (S a')) (S a')
  end.

(** ** Square *)

Definition square n := n * n.

(** ** Square root *)

(** The following square root function is linear (and tail-recursive).
  With Peano representation, we can't do better. For faster algorithm,
  see Psqrt/Zsqrt/Nsqrt...

  We search the square root of n = k + p^2 + (q - r)
  with q = 2p and 0<=r<=q. We start with p=q=r=0, hence
  looking for the square root of n = k. Then we progressively
  decrease k and r. When k = S k' and r=0, it means we can use (S p)
  as new sqrt candidate, since (S k')+p^2+2p = k'+(S p)^2.
  When k reaches 0, we have found the biggest p^2 square contained
  in n, hence the square root of n is p.
*)

Fixpoint sqrt_iter k p q r :=
  match k with
    | O => p
    | S k' => match r with
                | O => sqrt_iter k' (S p) (S (S q)) (S (S q))
                | S r' => sqrt_iter k' p q r'
              end
  end.

Definition sqrt n := sqrt_iter n 0 0 0.

(** ** Log2 *)

(** This base-2 logarithm is linear and tail-recursive.

  In [log2_iter], we maintain the logarithm [p] of the counter [q],
  while [r] is the distance between [q] and the next power of 2,
  more precisely [q + S r = 2^(S p)] and [r<2^p]. At each
  recursive call, [q] goes up while [r] goes down. When [r]
  is 0, we know that [q] has almost reached a power of 2,
  and we increase [p] at the next call, while resetting [r]
  to [q].

  Graphically (numbers are [q], stars are [r]) :

<<
                    10
                  9
                8
              7   *
            6       *
          5           ...
        4
      3   *
    2       *
  1   *       *
0   *   *       *
>>

  We stop when [k], the global downward counter reaches 0.
  At that moment, [q] is the number we're considering (since
  [k+q] is invariant), and [p] its logarithm.
*)

Fixpoint log2_iter k p q r :=
  match k with
    | O => p
    | S k' => match r with
                | O => log2_iter k' (S p) (S q) q
                | S r' => log2_iter k' p (S q) r'
              end
  end.

Definition log2 n := log2_iter (pred n) 0 1 0.

(** Iterator on natural numbers *)

Definition iter (n:nat) {A} (f:A->A) (x:A) : A :=
 nat_rect (fun _ => A) x (fun _ => f) n.

(** Bitwise operations *)

(** We provide here some bitwise operations for unary numbers.
  Some might be really naive, they are just there for fulfilling
  the same interface as other for natural representations. As
  soon as binary representations such as NArith are available,
  it is clearly better to convert to/from them and use their ops.
*)

Fixpoint div2 n :=
  match n with
  | 0 => 0
  | S 0 => 0
  | S (S n') => S (div2 n')
  end.

Fixpoint testbit a n : bool :=
 match n with
   | 0 => odd a
   | S n => testbit (div2 a) n
 end.

Definition shiftl a := nat_rect _ a (fun _ => double).
Definition shiftr a := nat_rect _ a (fun _ => div2).

Fixpoint bitwise (op:bool->bool->bool) n a b :=
 match n with
  | 0 => 0
  | S n' =>
    (if op (odd a) (odd b) then 1 else 0) +
    2*(bitwise op n' (div2 a) (div2 b))
 end.

Definition land a b := bitwise andb a a b.
Definition lor a b := bitwise orb (max a b) a b.
Definition ldiff a b := bitwise (fun b b' => andb b (negb b')) a a b.
Definition lxor a b := bitwise xorb (max a b) a b.


From Nom Require Export Atom Group Swap.

(** *Permutation *)
Declare Scope perm_scope.
Delimit Scope perm_scope with perm.

Notation Perm := (list (Atom * Atom)).
(* Definition Perm := list (Atom * Atom). *)

Definition perm_act_atom (p: Perm) c: Atom :=
  fold_left (fun w q => swap (fst q) (snd q) w) p c.

Section PermEquiv.
  Definition perm_equiv (p q: Perm): Prop :=
    forall x, perm_act_atom p x ≡ perm_act_atom q x.
  Local Hint Unfold perm_equiv: core.

  Global Program Instance PermEquivRefl: Reflexive perm_equiv.
  Global Program Instance PermEquivSymm: Symmetric perm_equiv.
  Global Program Instance PermEquivTrans: Transitive perm_equiv.
  Next Obligation. unfold perm_equiv in *; intros; eapply eq_trans; eauto. Qed.
  Global Instance PermEquiv: Equiv Perm. exact perm_equiv. Defined.
  Global Program Instance PermSetoid: Setoid Perm.
  Next Obligation. split; typeclasses eauto. Qed.
End PermEquiv.
Arguments PermEquiv p q/.
Arguments perm_equiv /.

Section PermActProperties.
  Lemma perm_act_atom_concat (p: Perm): forall q x,
    perm_act_atom (p ++ q) x ≡ perm_act_atom q (perm_act_atom p x).
  Proof with (auto). induction p; intros; simpl... Qed.

  Lemma perm_act_atom_rev_left1 (p: Perm):
    forall x, perm_act_atom p (perm_act_atom (rev p) x) ≡ x.
  Proof with (auto).
    induction p; intros; simpl...
    rewrite perm_act_atom_concat; simpl; rewrite swap_involutive...
  Qed.

  Lemma perm_act_atom_rev_left (p: Perm) x:
    perm_act_atom (rev p ++ p) x ≡ x.
  Proof. rewrite perm_act_atom_concat; apply perm_act_atom_rev_left1. Qed.

  Lemma perm_act_atom_rev_right1 (p: Perm):
    forall x, perm_act_atom (rev p) (perm_act_atom p x) ≡ x.
  Proof with auto.
    induction p; intros; simpl...
    rewrite perm_act_atom_concat; simpl; rewrite IHp;
      apply swap_involutive.
  Qed.

  Lemma perm_act_atom_rev_right (p: Perm) x:
    perm_act_atom (p ++ rev p) x ≡ x.
  Proof. rewrite perm_act_atom_concat; apply perm_act_atom_rev_right1. Qed.

  Lemma perm_act_atom_rev_equiv (p q: Perm):
    p = q -> (rev p) = (rev q).
  Proof with auto.
    intros H x; transitivity (perm_act_atom (rev q ++ p ++ rev p) x);
      repeat rewrite perm_act_atom_concat.
    - rewrite H, perm_act_atom_rev_left1...
    - rewrite perm_act_atom_rev_right1...
  Qed.
End PermActProperties.

(** *Perm additive group  *)
Require Import Properties.

Instance perm_unit: Neutral Perm. exact (@nil (Atom * Atom)). Defined.
Instance perm_op: Binop Perm. exact (@app (Atom * Atom)). Defined.
Instance perm_inv: Negate Perm. exact (@rev (Atom * Atom)). Defined.
Arguments perm_unit /.
Arguments perm_op /.
Arguments perm_inv /.

Program Instance: Associative perm_op.
Next Obligation. rewrite app_assoc; auto. Qed.
Program Instance: RightIdentity perm_op perm_unit.
Next Obligation. rewrite app_nil_r; auto. Qed.
Program Instance: LeftInverse perm_op perm_inv perm_unit.
Next Obligation. unfold equiv; simpl; intros; rewrite perm_act_atom_rev_left; auto. Qed.
Program Instance: RightInverse perm_op perm_inv perm_unit.
Next Obligation. unfold equiv; simpl; intros; rewrite perm_act_atom_rev_right; auto. Qed.
Program Instance: LeftIdentity perm_op perm_unit.

Program Instance PermGroup: @Group Perm PermEquiv perm_unit perm_inv perm_op :=
  { g_setoid := PermSetoid }.
Next Obligation. (* perm_op preserve perm_equiv *)
  intros ? ? HE1 ? ? HE2; unfold equiv,"+" in *; simpl in *; intros;
    repeat rewrite perm_act_atom_concat; rewrite HE1,HE2; reflexivity.
Qed.
Next Obligation. (* perm_neg preserve perm_equiv *)
  intros ? ? HE; unfold negate,equiv in *; simpl in *; intros;
    apply perm_act_atom_rev_equiv; auto.
Qed.