(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(* $Id: Setoid_ring_normalize.v 14641 2011-11-06 11:59:10Z herbelin $ *)

Require Import Setoid_ring_theory.
Require Import Quote.

Set Implicit Arguments.
Unset Boxed Definitions.

Lemma index_eq_prop : forall n m:index, Is_true (index_eq n m) -> n = m.
Proof.
  simple induction n; simple induction m; simpl in |- *;
   try reflexivity || contradiction.
  intros; rewrite (H i0); trivial.
  intros; rewrite (H i0); trivial.
Qed.

Section setoid.

Variable A : Type.
Variable Aequiv : A -> A -> Prop.
Variable Aplus : A -> A -> A.
Variable Amult : A -> A -> A.
Variable Aone : A.
Variable Azero : A.
Variable Aopp : A -> A.
Variable Aeq : A -> A -> bool.

Variable S : Setoid_Theory A Aequiv.

Add Setoid A Aequiv S as Asetoid.

Variable plus_morph :
 forall a a0:A, Aequiv a a0 ->
   forall a1 a2:A, Aequiv a1 a2 ->
     Aequiv (Aplus a a1)  (Aplus a0 a2).
Variable mult_morph :
 forall a a0:A, Aequiv a a0 ->
   forall a1 a2:A, Aequiv a1 a2 ->
     Aequiv (Amult a a1) (Amult a0 a2).
Variable opp_morph : forall a a0:A, Aequiv a a0 -> Aequiv (Aopp a) (Aopp a0).

Add Morphism Aplus : Aplus_ext.
intros; apply plus_morph; assumption.
Qed.

Add Morphism Amult : Amult_ext.
intros; apply mult_morph; assumption.
Qed.

Add Morphism Aopp : Aopp_ext.
exact opp_morph.
Qed.

Let equiv_refl := Seq_refl A Aequiv S.
Let equiv_sym := Seq_sym A Aequiv S.
Let equiv_trans := Seq_trans A Aequiv S.

Hint Resolve equiv_refl equiv_trans.
Hint Immediate equiv_sym.

Section semi_setoid_rings.

(* Section definitions. *)

(******************************************)
(* Normal abtract Polynomials             *)
(******************************************)
(* DEFINITIONS :
- A varlist is a sorted product of one or more variables : x, x*y*z
- A monom is a constant, a varlist or the product of a constant by a varlist
  variables. 2*x*y, x*y*z, 3 are monoms : 2*3, x*3*y, 4*x*3 are NOT.
- A canonical sum is either a monom or an ordered sum of monoms
  (the order on monoms is defined later)
- A normal polynomial it either a constant or a canonical sum or a constant
  plus a canonical sum
*)

(* varlist is isomorphic to (list var), but we built a special inductive
   for efficiency *)
Inductive varlist : Type :=
  | Nil_var : varlist
  | Cons_var : index -> varlist -> varlist.

Inductive canonical_sum : Type :=
  | Nil_monom : canonical_sum
  | Cons_monom : A -> varlist -> canonical_sum -> canonical_sum
  | Cons_varlist : varlist -> canonical_sum -> canonical_sum.

(* Order on monoms *)

(* That's the lexicographic order on varlist, extended by :
  - A constant is less than every monom
  - The relation between two varlist is preserved by multiplication by a
  constant.

  Examples :
  3 < x < y
  x*y < x*y*y*z
  2*x*y < x*y*y*z
  x*y < 54*x*y*y*z
  4*x*y < 59*x*y*y*z
*)

Fixpoint varlist_eq (x y:varlist) {struct y} : bool :=
  match x, y with
  | Nil_var, Nil_var => true
  | Cons_var i xrest, Cons_var j yrest =>
      andb (index_eq i j) (varlist_eq xrest yrest)
  | _, _ => false
  end.

Fixpoint varlist_lt (x y:varlist) {struct y} : bool :=
  match x, y with
  | Nil_var, Cons_var _ _ => true
  | Cons_var i xrest, Cons_var j yrest =>
      if index_lt i j
      then true
      else andb (index_eq i j) (varlist_lt xrest yrest)
  | _, _ => false
  end.

(* merges two variables lists *)
Fixpoint varlist_merge (l1:varlist) : varlist -> varlist :=
  match l1 with
  | Cons_var v1 t1 =>
      (fix vm_aux (l2:varlist) : varlist :=
         match l2 with
         | Cons_var v2 t2 =>
             if index_lt v1 v2
             then Cons_var v1 (varlist_merge t1 l2)
             else Cons_var v2 (vm_aux t2)
         | Nil_var => l1
         end)
  | Nil_var => fun l2 => l2
  end.

(* returns the sum of two canonical sums  *)
Fixpoint canonical_sum_merge (s1:canonical_sum) :
 canonical_sum -> canonical_sum :=
  match s1 with
  | Cons_monom c1 l1 t1 =>
      (fix csm_aux (s2:canonical_sum) : canonical_sum :=
         match s2 with
         | Cons_monom c2 l2 t2 =>
             if varlist_eq l1 l2
             then Cons_monom (Aplus c1 c2) l1 (canonical_sum_merge t1 t2)
             else
              if varlist_lt l1 l2
              then Cons_monom c1 l1 (canonical_sum_merge t1 s2)
              else Cons_monom c2 l2 (csm_aux t2)
         | Cons_varlist l2 t2 =>
             if varlist_eq l1 l2
             then Cons_monom (Aplus c1 Aone) l1 (canonical_sum_merge t1 t2)
             else
              if varlist_lt l1 l2
              then Cons_monom c1 l1 (canonical_sum_merge t1 s2)
              else Cons_varlist l2 (csm_aux t2)
         | Nil_monom => s1
         end)
  | Cons_varlist l1 t1 =>
      (fix csm_aux2 (s2:canonical_sum) : canonical_sum :=
         match s2 with
         | Cons_monom c2 l2 t2 =>
             if varlist_eq l1 l2
             then Cons_monom (Aplus Aone c2) l1 (canonical_sum_merge t1 t2)
             else
              if varlist_lt l1 l2
              then Cons_varlist l1 (canonical_sum_merge t1 s2)
              else Cons_monom c2 l2 (csm_aux2 t2)
         | Cons_varlist l2 t2 =>
             if varlist_eq l1 l2
             then Cons_monom (Aplus Aone Aone) l1 (canonical_sum_merge t1 t2)
             else
              if varlist_lt l1 l2
              then Cons_varlist l1 (canonical_sum_merge t1 s2)
              else Cons_varlist l2 (csm_aux2 t2)
         | Nil_monom => s1
         end)
  | Nil_monom => fun s2 => s2
  end.

(* Insertion of a monom in a canonical sum *)
Fixpoint monom_insert (c1:A) (l1:varlist) (s2:canonical_sum) {struct s2} :
 canonical_sum :=
  match s2 with
  | Cons_monom c2 l2 t2 =>
      if varlist_eq l1 l2
      then Cons_monom (Aplus c1 c2) l1 t2
      else
       if varlist_lt l1 l2
       then Cons_monom c1 l1 s2
       else Cons_monom c2 l2 (monom_insert c1 l1 t2)
  | Cons_varlist l2 t2 =>
      if varlist_eq l1 l2
      then Cons_monom (Aplus c1 Aone) l1 t2
      else
       if varlist_lt l1 l2
       then Cons_monom c1 l1 s2
       else Cons_varlist l2 (monom_insert c1 l1 t2)
  | Nil_monom => Cons_monom c1 l1 Nil_monom
  end.

Fixpoint varlist_insert (l1:varlist) (s2:canonical_sum) {struct s2} :
 canonical_sum :=
  match s2 with
  | Cons_monom c2 l2 t2 =>
      if varlist_eq l1 l2
      then Cons_monom (Aplus Aone c2) l1 t2
      else
       if varlist_lt l1 l2
       then Cons_varlist l1 s2
       else Cons_monom c2 l2 (varlist_insert l1 t2)
  | Cons_varlist l2 t2 =>
      if varlist_eq l1 l2
      then Cons_monom (Aplus Aone Aone) l1 t2
      else
       if varlist_lt l1 l2
       then Cons_varlist l1 s2
       else Cons_varlist l2 (varlist_insert l1 t2)
  | Nil_monom => Cons_varlist l1 Nil_monom
  end.

(* Computes c0*s *)
Fixpoint canonical_sum_scalar (c0:A) (s:canonical_sum) {struct s} :
 canonical_sum :=
  match s with
  | Cons_monom c l t => Cons_monom (Amult c0 c) l (canonical_sum_scalar c0 t)
  | Cons_varlist l t => Cons_monom c0 l (canonical_sum_scalar c0 t)
  | Nil_monom => Nil_monom
  end.

(* Computes l0*s  *)
Fixpoint canonical_sum_scalar2 (l0:varlist) (s:canonical_sum) {struct s} :
 canonical_sum :=
  match s with
  | Cons_monom c l t =>
      monom_insert c (varlist_merge l0 l) (canonical_sum_scalar2 l0 t)
  | Cons_varlist l t =>
      varlist_insert (varlist_merge l0 l) (canonical_sum_scalar2 l0 t)
  | Nil_monom => Nil_monom
  end.

(* Computes c0*l0*s  *)
Fixpoint canonical_sum_scalar3 (c0:A) (l0:varlist)
 (s:canonical_sum) {struct s} : canonical_sum :=
  match s with
  | Cons_monom c l t =>
      monom_insert (Amult c0 c) (varlist_merge l0 l)
        (canonical_sum_scalar3 c0 l0 t)
  | Cons_varlist l t =>
      monom_insert c0 (varlist_merge l0 l) (canonical_sum_scalar3 c0 l0 t)
  | Nil_monom => Nil_monom
  end.

(* returns the product of two canonical sums *)
Fixpoint canonical_sum_prod (s1 s2:canonical_sum) {struct s1} :
 canonical_sum :=
  match s1 with
  | Cons_monom c1 l1 t1 =>
      canonical_sum_merge (canonical_sum_scalar3 c1 l1 s2)
        (canonical_sum_prod t1 s2)
  | Cons_varlist l1 t1 =>
      canonical_sum_merge (canonical_sum_scalar2 l1 s2)
        (canonical_sum_prod t1 s2)
  | Nil_monom => Nil_monom
  end.

(* The type to represent concrete semi-setoid-ring polynomials *)

Inductive setspolynomial : Type :=
  | SetSPvar : index -> setspolynomial
  | SetSPconst : A -> setspolynomial
  | SetSPplus : setspolynomial -> setspolynomial -> setspolynomial
  | SetSPmult : setspolynomial -> setspolynomial -> setspolynomial.

Fixpoint setspolynomial_normalize (p:setspolynomial) : canonical_sum :=
  match p with
  | SetSPplus l r =>
      canonical_sum_merge (setspolynomial_normalize l)
        (setspolynomial_normalize r)
  | SetSPmult l r =>
      canonical_sum_prod (setspolynomial_normalize l)
        (setspolynomial_normalize r)
  | SetSPconst c => Cons_monom c Nil_var Nil_monom
  | SetSPvar i => Cons_varlist (Cons_var i Nil_var) Nil_monom
  end.

Fixpoint canonical_sum_simplify (s:canonical_sum) : canonical_sum :=
  match s with
  | Cons_monom c l t =>
      if Aeq c Azero
      then canonical_sum_simplify t
      else
       if Aeq c Aone
       then Cons_varlist l (canonical_sum_simplify t)
       else Cons_monom c l (canonical_sum_simplify t)
  | Cons_varlist l t => Cons_varlist l (canonical_sum_simplify t)
  | Nil_monom => Nil_monom
  end.

Definition setspolynomial_simplify (x:setspolynomial) :=
  canonical_sum_simplify (setspolynomial_normalize x).

Variable vm : varmap A.

Definition interp_var (i:index) := varmap_find Azero i vm.

Definition ivl_aux :=
  (fix ivl_aux (x:index) (t:varlist) {struct t} : A :=
     match t with
     | Nil_var => interp_var x
     | Cons_var x' t' => Amult (interp_var x) (ivl_aux x' t')
     end).

Definition interp_vl (l:varlist) :=
  match l with
  | Nil_var => Aone
  | Cons_var x t => ivl_aux x t
  end.

Definition interp_m (c:A) (l:varlist) :=
  match l with
  | Nil_var => c
  | Cons_var x t => Amult c (ivl_aux x t)
  end.

Definition ics_aux :=
  (fix ics_aux (a:A) (s:canonical_sum) {struct s} : A :=
     match s with
     | Nil_monom => a
     | Cons_varlist l t => Aplus a (ics_aux (interp_vl l) t)
     | Cons_monom c l t => Aplus a (ics_aux (interp_m c l) t)
     end).

Definition interp_setcs (s:canonical_sum) : A :=
  match s with
  | Nil_monom => Azero
  | Cons_varlist l t => ics_aux (interp_vl l) t
  | Cons_monom c l t => ics_aux (interp_m c l) t
  end.

Fixpoint interp_setsp (p:setspolynomial) : A :=
  match p with
  | SetSPconst c => c
  | SetSPvar i => interp_var i
  | SetSPplus p1 p2 => Aplus (interp_setsp p1) (interp_setsp p2)
  | SetSPmult p1 p2 => Amult (interp_setsp p1) (interp_setsp p2)
  end.

(* End interpretation. *)

Unset Implicit Arguments.

(* Section properties. *)

Variable T : Semi_Setoid_Ring_Theory Aequiv Aplus Amult Aone Azero Aeq.

Hint Resolve (SSR_plus_comm T).
Hint Resolve (SSR_plus_assoc T).
Hint Resolve (SSR_plus_assoc2 S T).
Hint Resolve (SSR_mult_comm T).
Hint Resolve (SSR_mult_assoc T).
Hint Resolve (SSR_mult_assoc2 S T).
Hint Resolve (SSR_plus_zero_left T).
Hint Resolve (SSR_plus_zero_left2 S T).
Hint Resolve (SSR_mult_one_left T).
Hint Resolve (SSR_mult_one_left2 S T).
Hint Resolve (SSR_mult_zero_left T).
Hint Resolve (SSR_mult_zero_left2 S T).
Hint Resolve (SSR_distr_left T).
Hint Resolve (SSR_distr_left2 S T).
Hint Resolve (SSR_plus_reg_left T).
Hint Resolve (SSR_plus_permute S plus_morph T).
Hint Resolve (SSR_mult_permute S mult_morph T).
Hint Resolve (SSR_distr_right S plus_morph T).
Hint Resolve (SSR_distr_right2 S plus_morph T).
Hint Resolve (SSR_mult_zero_right S T).
Hint Resolve (SSR_mult_zero_right2 S T).
Hint Resolve (SSR_plus_zero_right S T).
Hint Resolve (SSR_plus_zero_right2 S T).
Hint Resolve (SSR_mult_one_right S T).
Hint Resolve (SSR_mult_one_right2 S T).
Hint Resolve (SSR_plus_reg_right S T).
Hint Resolve refl_equal sym_equal trans_equal.
(*Hints Resolve refl_eqT sym_eqT trans_eqT.*)
Hint Immediate T.

Lemma varlist_eq_prop : forall x y:varlist, Is_true (varlist_eq x y) -> x = y.
Proof.
  simple induction x; simple induction y; contradiction || (try reflexivity).
  simpl in |- *; intros.
  generalize (andb_prop2 _ _ H1); intros; elim H2; intros.
  rewrite (index_eq_prop _ _ H3); rewrite (H v0 H4); reflexivity.
Qed.

Remark ivl_aux_ok :
 forall (v:varlist) (i:index),
   Aequiv (ivl_aux i v) (Amult (interp_var i) (interp_vl v)).
Proof.
  simple induction v; simpl in |- *; intros.
  trivial.
  rewrite (H i); trivial.
Qed.

Lemma varlist_merge_ok :
 forall x y:varlist,
   Aequiv (interp_vl (varlist_merge x y)) (Amult (interp_vl x) (interp_vl y)).
Proof.
  simple induction x.
  simpl in |- *; trivial.
  simple induction y.
  simpl in |- *; trivial.
  simpl in |- *; intros.
  elim (index_lt i i0); simpl in |- *; intros.

  rewrite (ivl_aux_ok v i).
  rewrite (ivl_aux_ok v0 i0).
  rewrite (ivl_aux_ok (varlist_merge v (Cons_var i0 v0)) i).
  rewrite (H (Cons_var i0 v0)).
  simpl in |- *.
  rewrite (ivl_aux_ok v0 i0).
  eauto.

  rewrite (ivl_aux_ok v i).
  rewrite (ivl_aux_ok v0 i0).
  rewrite
   (ivl_aux_ok
      ((fix vm_aux (l2:varlist) : varlist :=
          match l2 with
          | Nil_var => Cons_var i v
          | Cons_var v2 t2 =>
              if index_lt i v2
              then Cons_var i (varlist_merge v l2)
              else Cons_var v2 (vm_aux t2)
          end) v0) i0).
  rewrite H0.
  rewrite (ivl_aux_ok v i).
  eauto.
Qed.

Remark ics_aux_ok :
 forall (x:A) (s:canonical_sum),
   Aequiv (ics_aux x s) (Aplus x (interp_setcs s)).
Proof.
 simple induction s; simpl in |- *; intros; trivial.
Qed.

Remark interp_m_ok :
 forall (x:A) (l:varlist), Aequiv (interp_m x l) (Amult x (interp_vl l)).
Proof.
  destruct l as [| i v]; trivial.
Qed.

Hint Resolve ivl_aux_ok.
Hint Resolve ics_aux_ok.
Hint Resolve interp_m_ok.

(* Hints Resolve ivl_aux_ok ics_aux_ok interp_m_ok. *)

Lemma canonical_sum_merge_ok :
 forall x y:canonical_sum,
   Aequiv (interp_setcs (canonical_sum_merge x y))
     (Aplus (interp_setcs x) (interp_setcs y)).
Proof.
simple induction x; simpl in |- *.
trivial.

simple induction y; simpl in |- *; intros.
eauto.

generalize (varlist_eq_prop v v0).
elim (varlist_eq v v0).
intros; rewrite (H1 I).
simpl in |- *.
rewrite (ics_aux_ok (interp_m a v0) c).
rewrite (ics_aux_ok (interp_m a0 v0) c0).
rewrite (ics_aux_ok (interp_m (Aplus a a0) v0) (canonical_sum_merge c c0)).
rewrite (H c0).
rewrite (interp_m_ok (Aplus a a0) v0).
rewrite (interp_m_ok a v0).
rewrite (interp_m_ok a0 v0).
setoid_replace (Amult (Aplus a a0) (interp_vl v0)) with
 (Aplus (Amult a (interp_vl v0)) (Amult a0 (interp_vl v0)));
 [ idtac | trivial ].
setoid_replace
 (Aplus (Aplus (Amult a (interp_vl v0)) (Amult a0 (interp_vl v0)))
    (Aplus (interp_setcs c) (interp_setcs c0))) with
 (Aplus (Amult a (interp_vl v0))
    (Aplus (Amult a0 (interp_vl v0))
       (Aplus (interp_setcs c) (interp_setcs c0))));
 [ idtac | trivial ].
setoid_replace
 (Aplus (Aplus (Amult a (interp_vl v0)) (interp_setcs c))
    (Aplus (Amult a0 (interp_vl v0)) (interp_setcs c0))) with
 (Aplus (Amult a (interp_vl v0))
    (Aplus (interp_setcs c)
       (Aplus (Amult a0 (interp_vl v0)) (interp_setcs c0))));
 [ idtac | trivial ].
auto.

elim (varlist_lt v v0); simpl in |- *.
intro.
rewrite
 (ics_aux_ok (interp_m a v) (canonical_sum_merge c (Cons_monom a0 v0 c0)))
 .
rewrite (ics_aux_ok (interp_m a v) c).
rewrite (ics_aux_ok (interp_m a0 v0) c0).
rewrite (H (Cons_monom a0 v0 c0)); simpl in |- *.
rewrite (ics_aux_ok (interp_m a0 v0) c0); auto.

intro.
rewrite
 (ics_aux_ok (interp_m a0 v0)
    ((fix csm_aux (s2:canonical_sum) : canonical_sum :=
        match s2 with
        | Nil_monom => Cons_monom a v c
        | Cons_monom c2 l2 t2 =>
            if varlist_eq v l2
            then Cons_monom (Aplus a c2) v (canonical_sum_merge c t2)
            else
             if varlist_lt v l2
             then Cons_monom a v (canonical_sum_merge c s2)
             else Cons_monom c2 l2 (csm_aux t2)
        | Cons_varlist l2 t2 =>
            if varlist_eq v l2
            then Cons_monom (Aplus a Aone) v (canonical_sum_merge c t2)
            else
             if varlist_lt v l2
             then Cons_monom a v (canonical_sum_merge c s2)
             else Cons_varlist l2 (csm_aux t2)
        end) c0)).
rewrite H0.
rewrite (ics_aux_ok (interp_m a v) c);
 rewrite (ics_aux_ok (interp_m a0 v0) c0); simpl in |- *;
 auto.

generalize (varlist_eq_prop v v0).
elim (varlist_eq v v0).
intros; rewrite (H1 I).
simpl in |- *.
rewrite (ics_aux_ok (interp_m (Aplus a Aone) v0) (canonical_sum_merge c c0));
 rewrite (ics_aux_ok (interp_m a v0) c);
 rewrite (ics_aux_ok (interp_vl v0) c0).
rewrite (H c0).
rewrite (interp_m_ok (Aplus a Aone) v0).
rewrite (interp_m_ok a v0).
setoid_replace (Amult (Aplus a Aone) (interp_vl v0)) with
 (Aplus (Amult a (interp_vl v0)) (Amult Aone (interp_vl v0)));
 [ idtac | trivial ].
setoid_replace
 (Aplus (Aplus (Amult a (interp_vl v0)) (Amult Aone (interp_vl v0)))
    (Aplus (interp_setcs c) (interp_setcs c0))) with
 (Aplus (Amult a (interp_vl v0))
    (Aplus (Amult Aone (interp_vl v0))
       (Aplus (interp_setcs c) (interp_setcs c0))));
 [ idtac | trivial ].
setoid_replace
 (Aplus (Aplus (Amult a (interp_vl v0)) (interp_setcs c))
    (Aplus (interp_vl v0) (interp_setcs c0))) with
 (Aplus (Amult a (interp_vl v0))
    (Aplus (interp_setcs c) (Aplus (interp_vl v0) (interp_setcs c0))));
 [ idtac | trivial ].
setoid_replace (Amult Aone (interp_vl v0)) with (interp_vl v0);
 [ idtac | trivial ].
auto.

elim (varlist_lt v v0); simpl in |- *.
intro.
rewrite
 (ics_aux_ok (interp_m a v) (canonical_sum_merge c (Cons_varlist v0 c0)))
 ; rewrite (ics_aux_ok (interp_m a v) c);
 rewrite (ics_aux_ok (interp_vl v0) c0).
rewrite (H (Cons_varlist v0 c0)); simpl in |- *.
rewrite (ics_aux_ok (interp_vl v0) c0).
auto.

intro.
rewrite
 (ics_aux_ok (interp_vl v0)
    ((fix csm_aux (s2:canonical_sum) : canonical_sum :=
        match s2 with
        | Nil_monom => Cons_monom a v c
        | Cons_monom c2 l2 t2 =>
            if varlist_eq v l2
            then Cons_monom (Aplus a c2) v (canonical_sum_merge c t2)
            else
             if varlist_lt v l2
             then Cons_monom a v (canonical_sum_merge c s2)
             else Cons_monom c2 l2 (csm_aux t2)
        | Cons_varlist l2 t2 =>
            if varlist_eq v l2
            then Cons_monom (Aplus a Aone) v (canonical_sum_merge c t2)
            else
             if varlist_lt v l2
             then Cons_monom a v (canonical_sum_merge c s2)
             else Cons_varlist l2 (csm_aux t2)
        end) c0)); rewrite H0.
rewrite (ics_aux_ok (interp_m a v) c); rewrite (ics_aux_ok (interp_vl v0) c0);
 simpl in |- *.
auto.

simple induction y; simpl in |- *; intros.
trivial.

generalize (varlist_eq_prop v v0).
elim (varlist_eq v v0).
intros; rewrite (H1 I).
simpl in |- *.
rewrite (ics_aux_ok (interp_m (Aplus Aone a) v0) (canonical_sum_merge c c0));
 rewrite (ics_aux_ok (interp_vl v0) c);
 rewrite (ics_aux_ok (interp_m a v0) c0); rewrite (H c0).
rewrite (interp_m_ok (Aplus Aone a) v0); rewrite (interp_m_ok a v0).
setoid_replace (Amult (Aplus Aone a) (interp_vl v0)) with
 (Aplus (Amult Aone (interp_vl v0)) (Amult a (interp_vl v0)));
 [ idtac | trivial ].
setoid_replace
 (Aplus (Aplus (Amult Aone (interp_vl v0)) (Amult a (interp_vl v0)))
    (Aplus (interp_setcs c) (interp_setcs c0))) with
 (Aplus (Amult Aone (interp_vl v0))
    (Aplus (Amult a (interp_vl v0))
       (Aplus (interp_setcs c) (interp_setcs c0))));
 [ idtac | trivial ].
setoid_replace
 (Aplus (Aplus (interp_vl v0) (interp_setcs c))
    (Aplus (Amult a (interp_vl v0)) (interp_setcs c0))) with
 (Aplus (interp_vl v0)
    (Aplus (interp_setcs c)
       (Aplus (Amult a (interp_vl v0)) (interp_setcs c0))));
 [ idtac | trivial ].
auto.

elim (varlist_lt v v0); simpl in |- *; intros.
rewrite
 (ics_aux_ok (interp_vl v) (canonical_sum_merge c (Cons_monom a v0 c0)))
 ; rewrite (ics_aux_ok (interp_vl v) c);
 rewrite (ics_aux_ok (interp_m a v0) c0).
rewrite (H (Cons_monom a v0 c0)); simpl in |- *.
rewrite (ics_aux_ok (interp_m a v0) c0); auto.

rewrite
 (ics_aux_ok (interp_m a v0)
    ((fix csm_aux2 (s2:canonical_sum) : canonical_sum :=
        match s2 with
        | Nil_monom => Cons_varlist v c
        | Cons_monom c2 l2 t2 =>
            if varlist_eq v l2
            then Cons_monom (Aplus Aone c2) v (canonical_sum_merge c t2)
            else
             if varlist_lt v l2
             then Cons_varlist v (canonical_sum_merge c s2)
             else Cons_monom c2 l2 (csm_aux2 t2)
        | Cons_varlist l2 t2 =>
            if varlist_eq v l2
            then Cons_monom (Aplus Aone Aone) v (canonical_sum_merge c t2)
            else
             if varlist_lt v l2
             then Cons_varlist v (canonical_sum_merge c s2)
             else Cons_varlist l2 (csm_aux2 t2)
        end) c0)); rewrite H0.
rewrite (ics_aux_ok (interp_vl v) c); rewrite (ics_aux_ok (interp_m a v0) c0);
 simpl in |- *; auto.

generalize (varlist_eq_prop v v0).
elim (varlist_eq v v0); intros.
rewrite (H1 I); simpl in |- *.
rewrite
 (ics_aux_ok (interp_m (Aplus Aone Aone) v0) (canonical_sum_merge c c0))
 ; rewrite (ics_aux_ok (interp_vl v0) c);
 rewrite (ics_aux_ok (interp_vl v0) c0); rewrite (H c0).
rewrite (interp_m_ok (Aplus Aone Aone) v0).
setoid_replace (Amult (Aplus Aone Aone) (interp_vl v0)) with
 (Aplus (Amult Aone (interp_vl v0)) (Amult Aone (interp_vl v0)));
 [ idtac | trivial ].
setoid_replace
 (Aplus (Aplus (Amult Aone (interp_vl v0)) (Amult Aone (interp_vl v0)))
    (Aplus (interp_setcs c) (interp_setcs c0))) with
 (Aplus (Amult Aone (interp_vl v0))
    (Aplus (Amult Aone (interp_vl v0))
       (Aplus (interp_setcs c) (interp_setcs c0))));
 [ idtac | trivial ].
setoid_replace
 (Aplus (Aplus (interp_vl v0) (interp_setcs c))
    (Aplus (interp_vl v0) (interp_setcs c0))) with
 (Aplus (interp_vl v0)
    (Aplus (interp_setcs c) (Aplus (interp_vl v0) (interp_setcs c0))));
[ idtac | trivial ].
setoid_replace (Amult Aone (interp_vl v0)) with (interp_vl v0); auto.

elim (varlist_lt v v0); simpl in |- *.
rewrite
 (ics_aux_ok (interp_vl v) (canonical_sum_merge c (Cons_varlist v0 c0)))
 ; rewrite (ics_aux_ok (interp_vl v) c);
 rewrite (ics_aux_ok (interp_vl v0) c0); rewrite (H (Cons_varlist v0 c0));
 simpl in |- *.
rewrite (ics_aux_ok (interp_vl v0) c0); auto.

rewrite
 (ics_aux_ok (interp_vl v0)
    ((fix csm_aux2 (s2:canonical_sum) : canonical_sum :=
        match s2 with
        | Nil_monom => Cons_varlist v c
        | Cons_monom c2 l2 t2 =>
            if varlist_eq v l2
            then Cons_monom (Aplus Aone c2) v (canonical_sum_merge c t2)
            else
             if varlist_lt v l2
             then Cons_varlist v (canonical_sum_merge c s2)
             else Cons_monom c2 l2 (csm_aux2 t2)
        | Cons_varlist l2 t2 =>
            if varlist_eq v l2
            then Cons_monom (Aplus Aone Aone) v (canonical_sum_merge c t2)
            else
             if varlist_lt v l2
             then Cons_varlist v (canonical_sum_merge c s2)
             else Cons_varlist l2 (csm_aux2 t2)
        end) c0)); rewrite H0.
rewrite (ics_aux_ok (interp_vl v) c); rewrite (ics_aux_ok (interp_vl v0) c0);
 simpl in |- *; auto.
Qed.

Lemma monom_insert_ok :
 forall (a:A) (l:varlist) (s:canonical_sum),
   Aequiv (interp_setcs (monom_insert a l s))
     (Aplus (Amult a (interp_vl l)) (interp_setcs s)).
Proof.
simple induction s; intros.
simpl in |- *; rewrite (interp_m_ok a l); trivial.

simpl in |- *; generalize (varlist_eq_prop l v); elim (varlist_eq l v).
intro Hr; rewrite (Hr I); simpl in |- *.
rewrite (ics_aux_ok (interp_m (Aplus a a0) v) c);
 rewrite (ics_aux_ok (interp_m a0 v) c).
rewrite (interp_m_ok (Aplus a a0) v); rewrite (interp_m_ok a0 v).
setoid_replace (Amult (Aplus a a0) (interp_vl v)) with
 (Aplus (Amult a (interp_vl v)) (Amult a0 (interp_vl v)));
 [ idtac | trivial ].
auto.

elim (varlist_lt l v); simpl in |- *; intros.
rewrite (ics_aux_ok (interp_m a0 v) c).
rewrite (interp_m_ok a0 v); rewrite (interp_m_ok a l).
auto.

rewrite (ics_aux_ok (interp_m a0 v) (monom_insert a l c));
 rewrite (ics_aux_ok (interp_m a0 v) c); rewrite H.
auto.

simpl in |- *.
generalize (varlist_eq_prop l v); elim (varlist_eq l v).
intro Hr; rewrite (Hr I); simpl in |- *.
rewrite (ics_aux_ok (interp_m (Aplus a Aone) v) c);
 rewrite (ics_aux_ok (interp_vl v) c).
rewrite (interp_m_ok (Aplus a Aone) v).
setoid_replace (Amult (Aplus a Aone) (interp_vl v)) with
 (Aplus (Amult a (interp_vl v)) (Amult Aone (interp_vl v)));
 [ idtac | trivial ].
setoid_replace (Amult Aone (interp_vl v)) with (interp_vl v);
 [ idtac | trivial ].
auto.

elim (varlist_lt l v); simpl in |- *; intros; auto.
rewrite (ics_aux_ok (interp_vl v) (monom_insert a l c)); rewrite H.
rewrite (ics_aux_ok (interp_vl v) c); auto.
Qed.

Lemma varlist_insert_ok :
 forall (l:varlist) (s:canonical_sum),
   Aequiv (interp_setcs (varlist_insert l s))
     (Aplus (interp_vl l) (interp_setcs s)).
Proof.
simple induction s; simpl in |- *; intros.
trivial.

generalize (varlist_eq_prop l v); elim (varlist_eq l v).
intro Hr; rewrite (Hr I); simpl in |- *.
rewrite (ics_aux_ok (interp_m (Aplus Aone a) v) c);
 rewrite (ics_aux_ok (interp_m a v) c).
rewrite (interp_m_ok (Aplus Aone a) v); rewrite (interp_m_ok a v).
setoid_replace (Amult (Aplus Aone a) (interp_vl v)) with
 (Aplus (Amult Aone (interp_vl v)) (Amult a (interp_vl v)));
 [ idtac | trivial ].
setoid_replace (Amult Aone (interp_vl v)) with (interp_vl v); auto.

elim (varlist_lt l v); simpl in |- *; intros; auto.
rewrite (ics_aux_ok (interp_m a v) (varlist_insert l c));
 rewrite (ics_aux_ok (interp_m a v) c).
rewrite (interp_m_ok a v).
rewrite H; auto.

generalize (varlist_eq_prop l v); elim (varlist_eq l v).
intro Hr; rewrite (Hr I); simpl in |- *.
rewrite (ics_aux_ok (interp_m (Aplus Aone Aone) v) c);
 rewrite (ics_aux_ok (interp_vl v) c).
rewrite (interp_m_ok (Aplus Aone Aone) v).
setoid_replace (Amult (Aplus Aone Aone) (interp_vl v)) with
 (Aplus (Amult Aone (interp_vl v)) (Amult Aone (interp_vl v)));
 [ idtac | trivial ].
setoid_replace (Amult Aone (interp_vl v)) with (interp_vl v); auto.

elim (varlist_lt l v); simpl in |- *; intros; auto.
rewrite (ics_aux_ok (interp_vl v) (varlist_insert l c)).
rewrite H.
rewrite (ics_aux_ok (interp_vl v) c); auto.
Qed.

Lemma canonical_sum_scalar_ok :
 forall (a:A) (s:canonical_sum),
   Aequiv (interp_setcs (canonical_sum_scalar a s))
     (Amult a (interp_setcs s)).
Proof.
simple induction s; simpl in |- *; intros.
trivial.

rewrite (ics_aux_ok (interp_m (Amult a a0) v) (canonical_sum_scalar a c));
 rewrite (ics_aux_ok (interp_m a0 v) c).
rewrite (interp_m_ok (Amult a a0) v); rewrite (interp_m_ok a0 v).
rewrite H.
setoid_replace (Amult a (Aplus (Amult a0 (interp_vl v)) (interp_setcs c)))
 with (Aplus (Amult a (Amult a0 (interp_vl v))) (Amult a (interp_setcs c)));
 [ idtac | trivial ].
auto.

rewrite (ics_aux_ok (interp_m a v) (canonical_sum_scalar a c));
 rewrite (ics_aux_ok (interp_vl v) c); rewrite H.
rewrite (interp_m_ok a v).
auto.
Qed.

Lemma canonical_sum_scalar2_ok :
 forall (l:varlist) (s:canonical_sum),
   Aequiv (interp_setcs (canonical_sum_scalar2 l s))
     (Amult (interp_vl l) (interp_setcs s)).
Proof.
simple induction s; simpl in |- *; intros; auto.
rewrite (monom_insert_ok a (varlist_merge l v) (canonical_sum_scalar2 l c)).
rewrite (ics_aux_ok (interp_m a v) c).
rewrite (interp_m_ok a v).
rewrite H.
rewrite (varlist_merge_ok l v).
setoid_replace
 (Amult (interp_vl l) (Aplus (Amult a (interp_vl v)) (interp_setcs c))) with
 (Aplus (Amult (interp_vl l) (Amult a (interp_vl v)))
    (Amult (interp_vl l) (interp_setcs c)));
 [ idtac | trivial ].
auto.

rewrite (varlist_insert_ok (varlist_merge l v) (canonical_sum_scalar2 l c)).
rewrite (ics_aux_ok (interp_vl v) c).
rewrite H.
rewrite (varlist_merge_ok l v).
auto.
Qed.

Lemma canonical_sum_scalar3_ok :
 forall (c:A) (l:varlist) (s:canonical_sum),
   Aequiv (interp_setcs (canonical_sum_scalar3 c l s))
     (Amult c (Amult (interp_vl l) (interp_setcs s))).
Proof.
simple induction s; simpl in |- *; intros.
rewrite (SSR_mult_zero_right S T (interp_vl l)).
auto.

rewrite
 (monom_insert_ok (Amult c a) (varlist_merge l v)
    (canonical_sum_scalar3 c l c0)).
rewrite (ics_aux_ok (interp_m a v) c0).
rewrite (interp_m_ok a v).
rewrite H.
rewrite (varlist_merge_ok l v).
setoid_replace
 (Amult (interp_vl l) (Aplus (Amult a (interp_vl v)) (interp_setcs c0))) with
 (Aplus (Amult (interp_vl l) (Amult a (interp_vl v)))
    (Amult (interp_vl l) (interp_setcs c0)));
 [ idtac | trivial ].
setoid_replace
 (Amult c
    (Aplus (Amult (interp_vl l) (Amult a (interp_vl v)))
       (Amult (interp_vl l) (interp_setcs c0)))) with
 (Aplus (Amult c (Amult (interp_vl l) (Amult a (interp_vl v))))
    (Amult c (Amult (interp_vl l) (interp_setcs c0))));
 [ idtac | trivial ].
setoid_replace (Amult (Amult c a) (Amult (interp_vl l) (interp_vl v))) with
 (Amult c (Amult a (Amult (interp_vl l) (interp_vl v))));
 [ idtac | trivial ].
auto.

rewrite
 (monom_insert_ok c (varlist_merge l v) (canonical_sum_scalar3 c l c0))
 .
rewrite (ics_aux_ok (interp_vl v) c0).
rewrite H.
rewrite (varlist_merge_ok l v).
setoid_replace
 (Aplus (Amult c (Amult (interp_vl l) (interp_vl v)))
    (Amult c (Amult (interp_vl l) (interp_setcs c0)))) with
 (Amult c
    (Aplus (Amult (interp_vl l) (interp_vl v))
       (Amult (interp_vl l) (interp_setcs c0))));
 [ idtac | trivial ].
auto.
Qed.

Lemma canonical_sum_prod_ok :
 forall x y:canonical_sum,
   Aequiv (interp_setcs (canonical_sum_prod x y))
     (Amult (interp_setcs x) (interp_setcs y)).
Proof.
simple induction x; simpl in |- *; intros.
trivial.

rewrite
 (canonical_sum_merge_ok (canonical_sum_scalar3 a v y)
    (canonical_sum_prod c y)).
rewrite (canonical_sum_scalar3_ok a v y).
rewrite (ics_aux_ok (interp_m a v) c).
rewrite (interp_m_ok a v).
rewrite (H y).
setoid_replace (Amult a (Amult (interp_vl v) (interp_setcs y))) with
 (Amult (Amult a (interp_vl v)) (interp_setcs y));
 [ idtac | trivial ].
setoid_replace
 (Amult (Aplus (Amult a (interp_vl v)) (interp_setcs c)) (interp_setcs y))
 with
 (Aplus (Amult (Amult a (interp_vl v)) (interp_setcs y))
    (Amult (interp_setcs c) (interp_setcs y)));
 [ idtac | trivial ].
trivial.

rewrite
 (canonical_sum_merge_ok (canonical_sum_scalar2 v y) (canonical_sum_prod c y))
 .
rewrite (canonical_sum_scalar2_ok v y).
rewrite (ics_aux_ok (interp_vl v) c).
rewrite (H y).
trivial.
Qed.

Theorem setspolynomial_normalize_ok :
 forall p:setspolynomial,
   Aequiv (interp_setcs (setspolynomial_normalize p)) (interp_setsp p).
Proof.
simple induction p; simpl in |- *; intros; trivial.
rewrite
 (canonical_sum_merge_ok (setspolynomial_normalize s)
    (setspolynomial_normalize s0)).
rewrite H; rewrite H0; trivial.

rewrite
 (canonical_sum_prod_ok (setspolynomial_normalize s)
    (setspolynomial_normalize s0)).
rewrite H; rewrite H0; trivial.
Qed.

Lemma canonical_sum_simplify_ok :
 forall s:canonical_sum,
   Aequiv (interp_setcs (canonical_sum_simplify s)) (interp_setcs s).
Proof.
simple induction s; simpl in |- *; intros.
trivial.

generalize (SSR_eq_prop T a Azero).
elim (Aeq a Azero).
simpl in |- *.
intros.
rewrite (ics_aux_ok (interp_m a v) c).
rewrite (interp_m_ok a v).
rewrite (H0 I).
setoid_replace (Amult Azero (interp_vl v)) with Azero;
 [ idtac | trivial ].
rewrite H.
trivial.

intros; simpl in |- *.
generalize (SSR_eq_prop T a Aone).
elim (Aeq a Aone).
intros.
rewrite (ics_aux_ok (interp_m a v) c).
rewrite (interp_m_ok a v).
rewrite (H1 I).
simpl in |- *.
rewrite (ics_aux_ok (interp_vl v) (canonical_sum_simplify c)).
rewrite H.
auto.

simpl in |- *.
intros.
rewrite (ics_aux_ok (interp_m a v) (canonical_sum_simplify c)).
rewrite (ics_aux_ok (interp_m a v) c).
rewrite H; trivial.

rewrite (ics_aux_ok (interp_vl v) (canonical_sum_simplify c)).
rewrite H.
auto.
Qed.

Theorem setspolynomial_simplify_ok :
 forall p:setspolynomial,
   Aequiv (interp_setcs (setspolynomial_simplify p)) (interp_setsp p).
Proof.
intro.
unfold setspolynomial_simplify in |- *.
rewrite (canonical_sum_simplify_ok (setspolynomial_normalize p)).
exact (setspolynomial_normalize_ok p).
Qed.

End semi_setoid_rings.

Implicit Arguments Cons_varlist.
Implicit Arguments Cons_monom.
Implicit Arguments SetSPconst.
Implicit Arguments SetSPplus.
Implicit Arguments SetSPmult.

Section setoid_rings.

Set Implicit Arguments.

Variable vm : varmap A.
Variable T : Setoid_Ring_Theory Aequiv Aplus Amult Aone Azero Aopp Aeq.

Hint Resolve (STh_plus_comm T).
Hint Resolve (STh_plus_assoc T).
Hint Resolve (STh_plus_assoc2 S T).
Hint Resolve (STh_mult_comm T).
Hint Resolve (STh_mult_assoc T).
Hint Resolve (STh_mult_assoc2 S T).
Hint Resolve (STh_plus_zero_left T).
Hint Resolve (STh_plus_zero_left2 S T).
Hint Resolve (STh_mult_one_left T).
Hint Resolve (STh_mult_one_left2 S T).
Hint Resolve (STh_mult_zero_left S plus_morph mult_morph T).
Hint Resolve (STh_mult_zero_left2 S plus_morph mult_morph T).
Hint Resolve (STh_distr_left T).
Hint Resolve (STh_distr_left2 S T).
Hint Resolve (STh_plus_reg_left S plus_morph T).
Hint Resolve (STh_plus_permute S plus_morph T).
Hint Resolve (STh_mult_permute S mult_morph T).
Hint Resolve (STh_distr_right S plus_morph T).
Hint Resolve (STh_distr_right2 S plus_morph T).
Hint Resolve (STh_mult_zero_right S plus_morph mult_morph T).
Hint Resolve (STh_mult_zero_right2 S plus_morph mult_morph T).
Hint Resolve (STh_plus_zero_right S T).
Hint Resolve (STh_plus_zero_right2 S T).
Hint Resolve (STh_mult_one_right S T).
Hint Resolve (STh_mult_one_right2 S T).
Hint Resolve (STh_plus_reg_right S plus_morph T).
Hint Resolve refl_equal sym_equal trans_equal.
(*Hints Resolve refl_eqT sym_eqT trans_eqT.*)
Hint Immediate T.

(*** Definitions *)

Inductive setpolynomial : Type :=
  | SetPvar : index -> setpolynomial
  | SetPconst : A -> setpolynomial
  | SetPplus : setpolynomial -> setpolynomial -> setpolynomial
  | SetPmult : setpolynomial -> setpolynomial -> setpolynomial
  | SetPopp : setpolynomial -> setpolynomial.

Fixpoint setpolynomial_normalize (x:setpolynomial) : canonical_sum :=
  match x with
  | SetPplus l r =>
      canonical_sum_merge (setpolynomial_normalize l)
        (setpolynomial_normalize r)
  | SetPmult l r =>
      canonical_sum_prod (setpolynomial_normalize l)
        (setpolynomial_normalize r)
  | SetPconst c => Cons_monom c Nil_var Nil_monom
  | SetPvar i => Cons_varlist (Cons_var i Nil_var) Nil_monom
  | SetPopp p =>
      canonical_sum_scalar3 (Aopp Aone) Nil_var (setpolynomial_normalize p)
  end.

Definition setpolynomial_simplify (x:setpolynomial) :=
  canonical_sum_simplify (setpolynomial_normalize x).

Fixpoint setspolynomial_of (x:setpolynomial) : setspolynomial :=
  match x with
  | SetPplus l r => SetSPplus (setspolynomial_of l) (setspolynomial_of r)
  | SetPmult l r => SetSPmult (setspolynomial_of l) (setspolynomial_of r)
  | SetPconst c => SetSPconst c
  | SetPvar i => SetSPvar i
  | SetPopp p => SetSPmult (SetSPconst (Aopp Aone)) (setspolynomial_of p)
  end.

(*** Interpretation *)

Fixpoint interp_setp (p:setpolynomial) : A :=
  match p with
  | SetPconst c => c
  | SetPvar i => varmap_find Azero i vm
  | SetPplus p1 p2 => Aplus (interp_setp p1) (interp_setp p2)
  | SetPmult p1 p2 => Amult (interp_setp p1) (interp_setp p2)
  | SetPopp p1 => Aopp (interp_setp p1)
  end.

(*** Properties *)

Unset Implicit Arguments.

Lemma setspolynomial_of_ok :
 forall p:setpolynomial,
   Aequiv (interp_setp p) (interp_setsp vm (setspolynomial_of p)).
simple induction p; trivial; simpl in |- *; intros.
rewrite H; rewrite H0; trivial.
rewrite H; rewrite H0; trivial.
rewrite H.
rewrite
 (STh_opp_mult_left2 S plus_morph mult_morph T Aone
    (interp_setsp vm (setspolynomial_of s))).
rewrite (STh_mult_one_left T (interp_setsp vm (setspolynomial_of s))).
trivial.
Qed.

Theorem setpolynomial_normalize_ok :
 forall p:setpolynomial,
   setpolynomial_normalize p = setspolynomial_normalize (setspolynomial_of p).
simple induction p; trivial; simpl in |- *; intros.
rewrite H; rewrite H0; reflexivity.
rewrite H; rewrite H0; reflexivity.
rewrite H; simpl in |- *.
elim
 (canonical_sum_scalar3 (Aopp Aone) Nil_var
    (setspolynomial_normalize (setspolynomial_of s)));
 [ reflexivity
 | simpl in |- *; intros; rewrite H0; reflexivity
 | simpl in |- *; intros; rewrite H0; reflexivity ].
Qed.

Theorem setpolynomial_simplify_ok :
 forall p:setpolynomial,
   Aequiv (interp_setcs vm (setpolynomial_simplify p)) (interp_setp p).
intro.
unfold setpolynomial_simplify in |- *.
rewrite (setspolynomial_of_ok p).
rewrite setpolynomial_normalize_ok.
rewrite
 (canonical_sum_simplify_ok vm
    (Semi_Setoid_Ring_Theory_of A Aequiv S Aplus Amult Aone Azero Aopp Aeq
       plus_morph mult_morph T)
    (setspolynomial_normalize (setspolynomial_of p)))
 .
rewrite
 (setspolynomial_normalize_ok vm
    (Semi_Setoid_Ring_Theory_of A Aequiv S Aplus Amult Aone Azero Aopp Aeq
       plus_morph mult_morph T) (setspolynomial_of p))
 .
trivial.
Qed.

End setoid_rings.

End setoid.


(* $Id: CPoly_ApZero.v,v 1.14 2003/03/11 13:36:15 lcf Exp $ *)

Require Export CReals1.
Require Export CPoly_Degree.

(* Tex_Prose
\chapter{Polynomials apart from zero}
*)

(* Begin_Tex_Verb *)
Definition distinct1 :=
  [A:CSetoid; f:nat->A](i,j:nat)(~i=j) -> ((f i) [#] (f j)).
(* End_Tex_Verb *)

Implicits distinct1 [1].

Section Poly_Representation.
(* Tex_Prose
\section{Representation of polynomials}
\begin{convention}
Let \verb!R! be a field, \verb!a_ : nat->R! with
\verb!(distinct1 a_)! and \verb!f : (cpoly_cring R)! and
\verb!n : nat! with \verb!(degree_le n f)!.
\end{convention}
*)

Variable R : CField.
Variable a_ : nat->R.
Hypothesis distinct_a_ : (distinct1 a_).
Variable f : (cpoly_cring R).
Variable n : nat.
Hypothesis degree_f : (degree_le n f).

Load Transparent_algebra.

(* Begin_Tex_Verb *)
Lemma poly_linear_shifted :
  (a:R)(f:(cpoly_cring R))
    {f':(cpoly_cring R) & {f'':R | f [=] (_X_[-](_C_ a))[*]f'[+](_C_ f'')}}.
(* End_Tex_Verb *)
Intros.
Induction f0; Intros.
Exists (cpoly_zero R).
Exists (Zero::R).
Simpl.
Algebra.
Elim Hrecf0. Intro g'. Intros H.
Elim H. Intro g''. Intros H0.
Exists _X_[*]g'[+](_C_ g'').
Exists a[*]g''[+]s.
Step _X_[*]f0[+](_C_ s).
Step _X_[*]((_X_[-](_C_ a))[*]g'[+](_C_ g''))[+](_C_ s).
Apply eq_symmetric_unfolded.
Cut (_C_ a[*]g''[+]s) [=] (_C_ a)[*](_C_ g'')[+](_C_ s). Intro.
Step (_X_[-](_C_ a))[*](_X_[*]g'[+](_C_ g''))[+]
  ((_C_ a)[*](_C_ g'')[+](_C_ s)).
Rational.
Step_final (_C_ a[*]g'')[+](_C_ s).
Qed.
Load Opaque_algebra.

(* Begin_Tex_Verb *)
Lemma poly_linear_factor :
  (f:(cpoly_cring R))(a:R)(f!a [=] Zero) ->
    {f':(cpoly_cring R) | f [=] (_X_[-](_C_ a))[*]f'}.
(* End_Tex_Verb *)
Intros.
Elim (poly_linear_shifted a f0). Intro f'. Intros H0.
Elim H0. Intro f''. Intros H1.
Exists f'.
Cut (_C_ f'') [=] Zero. Intro.
Step (_X_[-](_C_ a))[*]f'[+](_C_ f'').
Step_final (_X_[-](_C_ a))[*]f'[+]Zero.
Step_rht (_C_ (Zero::R)).
Apply cpoly_const_eq.
Step Zero[+]f''.
Step Zero[*]f'!a[+]f''.
Step (a[-]a)[*]f'!a[+]f''.
Step (_X_!a[-](_C_ a)!a)[*]f'!a[+]f''.
Step (_X_[-](_C_ a))!a[*]f'!a[+]f''.
Step ((_X_[-](_C_ a))[*]f')!a[+]f''.
Step ((_X_[-](_C_ a))[*]f')!a[+](_C_ f'')!a.
Step ((_X_[-](_C_ a))[*]f'[+](_C_ f''))!a.
Step_final f0!a.
Qed.

(* Begin_Tex_Verb *)
Lemma zero_poly :
  (n:nat)
  (f:(cpoly_cring R))(degree_le n f) ->
  ((i:nat)(le i n) -> (f!(a_ i) [=] Zero)) ->
    (f [=] Zero).
(* End_Tex_Verb *)
Intro.
Induction n0; Intros.
Elim (degree_le_zero ? ? H). Intros.
Step (_C_ x).
Step_rht (_C_ (Zero::R)).
Apply cpoly_const_eq.
Apply eq_transitive_unfolded with f0!(a_ (0)).
Step_final (_C_ x)!(a_ (0)).
Apply H0.
Auto.
Cut f0!(a_ (S n0)) [=] Zero. Intro.
Elim (poly_linear_factor f0 (a_ (S n0)) H1). Intro f'. Intros.
Step (_X_[-](_C_ (a_ (S n0))))[*]f'.
Cut f' [=] Zero. Intro.
Step_final (_X_[-](_C_ (a_ (S n0))))[*]Zero.
Apply Hrecn0.
Apply degree_le_mult_imp with (1) (_X_[-](_C_ (a_ (S n0)))).
Apply degree_invus_lft with (0).
Apply degree_le_c_.
Apply degree_x_.
Auto.
Apply degree_le_wd with f0.
Auto.
Auto.
Intros.
Apply mult_cancel_lft with ((a_ i)[-](a_ (S n0))).
Apply minus_ap_zero.
Apply distinct_a_.
Intro; Rewrite H3 in H2; Exact (le_Sn_n ? H2).
Step_rht (Zero::R).
Cut (a_ i)[-](a_ (S n0)) [=] (_X_[-](_C_ (a_ (S n0))))!(a_ i). Intro.
Step (_X_[-](_C_ (a_ (S n0))))!(a_ i)[*]f'!(a_ i).
Step ((_X_[-](_C_ (a_ (S n0))))[*]f')!(a_ i).
Step f0!(a_ i).
Apply H0.
Auto with arith.
Step_final (_X_!(a_ i))[-]((_C_ (a_ (S n0)))!(a_ i)).
Apply H0.
Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma identical_poly :
  (f,g:(cpoly_cring R))(degree_le n f) -> (degree_le n g) ->
  ((i:nat)(le i n) -> (f!(a_ i) [=] g!(a_ i))) ->
    (f [=] g).
(* End_Tex_Verb *)
Intros.
Apply cg_inv_unique_2.
Apply zero_poly with n.
Apply degree_le_invus; Auto.
Intros.
Step f0!(a_ i)[-]g!(a_ i).
Step_final f0!(a_ i)[-]f0!(a_ i).
Qed.

(* Begin_Tex_Verb *)
Definition poly_01_factor' := [n:nat](_X_[-](_C_ (a_ n))).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma poly_01_factor'_degree :
  (n:nat)(degree_le (1) (poly_01_factor' n)).
(* End_Tex_Verb *)
Intros.
Unfold poly_01_factor'.
Apply degree_imp_degree_le.
Apply degree_invus_lft with (0).
Apply degree_le_c_.
Apply degree_x_.
Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma poly_01_factor'_zero :
  (n:nat)((poly_01_factor' n)!(a_ n) [=] Zero).
(* End_Tex_Verb *)
Intros.
Unfold poly_01_factor'.
Step (_X_!(a_ n0))[-]((_C_ (a_ n0))!(a_ n0)).
Step_final (a_ n0)[-](a_ n0).
Qed.

(* Begin_Tex_Verb *)
Lemma poly_01_factor'_apzero :
  (n,i:nat)(~i = n) -> ((poly_01_factor' n)!(a_ i) [#] Zero).
(* End_Tex_Verb *)
Intros.
Unfold poly_01_factor'.
Step (_X_!(a_ i))[-]((_C_ (a_ n0))!(a_ i)).
Step (a_ i)[-](a_ n0).
Qed.

Hints Resolve poly_01_factor'_zero.

(* Begin_Tex_Verb *)
Definition poly_01_factor :=
  [n,i:nat; H:(~i = n)]
    (poly_01_factor' n)[*](_C_ One[/]((poly_01_factor' n)!(a_ i))[//]
      (poly_01_factor'_apzero n i H)).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma poly_01_factor_degree :
  (n,i:nat; H:(~i = n))(degree_le (1) (poly_01_factor n i H)).
(* End_Tex_Verb *)
Intros.
Unfold poly_01_factor.
Replace (1) with (plus (1) (0)).
Apply degree_le_mult.
Apply poly_01_factor'_degree.
Apply degree_le_c_.
Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma poly_01_factor_zero :
  (n,i:nat; H:(~i = n))((poly_01_factor n i H)!(a_ n) [=] Zero).
(* End_Tex_Verb *)
Intros.
Unfold poly_01_factor.
Step ((poly_01_factor' n0)!(a_ n0))[*]
  ((_C_ One[/](poly_01_factor' n0)!(a_ i)[//]
    (poly_01_factor'_apzero n0 i H))!(a_ n0)).
Step_final Zero[*]((_C_ One[/](poly_01_factor' n0)!(a_ i)[//]
  (poly_01_factor'_apzero n0 i H))!(a_ n0)).
Qed.

(* Begin_Tex_Verb *)
Lemma poly_01_factor_one :
  (n,i:nat; H:(~i = n))((poly_01_factor n i H)!(a_ i) [=] One).
(* End_Tex_Verb *)
Intros.
Unfold poly_01_factor.
Step ((poly_01_factor' n0)!(a_ i))[*]
  ((_C_ One[/](poly_01_factor' n0)!(a_ i)[//]
    (poly_01_factor'_apzero n0 i H))!(a_ i)).
Step ((poly_01_factor' n0)!(a_ i))[*]
  (One[/](poly_01_factor' n0)!(a_ i)[//](poly_01_factor'_apzero n0 i H)).
Rational.
Qed.

Hints Resolve poly_01_factor_zero poly_01_factor_one : algebra.

(* Begin_Tex_Verb *)
Fixpoint poly_01 [i,n:nat] : (cpoly_cring R) :=
    Cases (eq_nat_dec i n) of
      (left _) => One
    | (right ne) => (poly_01_factor n i ne)
    end
  [*]
    Cases n of
      O => One
    | (S m) => (poly_01 i m)
    end.
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma poly_01_degree' :
  (n,i:nat)(degree_le (S n) (poly_01 i n)).
(* End_Tex_Verb *)
Intros.
Induction n0. Intros.
Simpl.
Elim (eq_nat_dec i (0)); Intro y.
Apply degree_le_wd with (_C_ (One::R)).
Step_final (One::(cpoly_cring R)).
Apply degree_le_mon with (0).
Auto with arith.
Apply degree_le_c_.
Apply degree_le_wd with (poly_01_factor (0) i y).
Algebra.
Apply poly_01_factor_degree.
Simpl.
Elim (eq_nat_dec i (S n0)); Intro.
Apply degree_le_mon with (S n0).
Auto.
Apply degree_le_wd with (poly_01 i n0).
Algebra.
Auto.
Replace (S (S n0)) with (plus (1) (S n0)).
Apply degree_le_mult.
Apply poly_01_factor_degree.
Auto.
Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma poly_01_degree :
  (n,i:nat)(le i n) -> (degree_le n (poly_01 i n)).
(* End_Tex_Verb *)
Intros.
Induction n0; Intros.
Simpl.
Elim (eq_nat_dec i (0)); Intro y.
Apply degree_le_wd with (_C_ (One::R)).
Step_final (One::(cpoly_cring R)).
Apply degree_le_c_.
Cut i=(0). Intro.
Elim (y H0).
Auto with arith.
Simpl.
Elim (eq_nat_dec i (S n0)); Intro.
Apply degree_le_wd with (poly_01 i n0).
Algebra.
Apply poly_01_degree'.
Pattern 1 (S n0).
Replace (S n0) with (plus (1) n0).
Apply degree_le_mult.
Apply poly_01_factor_degree.
Apply Hrecn0.
Elim (le_lt_eq_dec ?? H); Auto with arith.
Intro; Elim (b b0).
Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma poly_01_zero :
  (n,i,j:nat)(le j n) -> (~j = i) -> ((poly_01 i n)!(a_ j) [=] Zero).
(* End_Tex_Verb *)
Intros.
Induction n0; Intros.
Rewrite <- (le_n_O_eq j H).
Rewrite <- (le_n_O_eq j H) in H0.
Simpl.
Elim (eq_nat_dec i (0)); Intro y.
Rewrite y in H0.
Elim (H0 (refl_equal ? (0))).
Step ((poly_01_factor (0) i y)!(a_ (0)))[*](One!(a_ (0))).
Step ((poly_01_factor (0) i y)!(a_ (0)))[*]One.
Step ((poly_01_factor (0) i y)!(a_ (0))).
Apply poly_01_factor_zero.
Elim (eq_nat_dec j (S n0)); Intro y.
Simpl.
Rewrite <- y.
Elim (eq_nat_dec i j); Intro y0.
Rewrite y0 in H0.
Elim (H0 (refl_equal ? j)).
Step ((poly_01_factor j i y0)!(a_ j))[*]((poly_01 i n0)!(a_ j)).
Step_final Zero[*]((poly_01 i n0)!(a_ j)).
Cut (le j n0). Intro.
Simpl.
Elim (eq_nat_dec i (S n0)); Intro y0.
Step (One!(a_ j))[*]((poly_01 i n0)!(a_ j)).
Step_final (One!(a_ j))[*]Zero.
Step ((poly_01_factor (S n0) i y0)!(a_ j))[*]((poly_01 i n0)!(a_ j)).
Step_final ((poly_01_factor (S n0) i y0)!(a_ j))[*]Zero.
Elim (le_lt_eq_dec ?? H); Auto with arith.
Intro; Elim (y b).
Qed.

(* Begin_Tex_Verb *)
Lemma poly_01_one :
  (n,i:nat)(poly_01 i n)!(a_ i) [=] One.
(* End_Tex_Verb *)
Intros.
Induction n0; Intros.
Simpl.
Elim (eq_nat_dec i (0)); Intro y.
Step (One!(a_ i))[*](One!(a_ i)).
Step_final One[*](One::R).
Step ((poly_01_factor (0) i y)!(a_ i))[*](One!(a_ i)).
Step ((poly_01_factor (0) i y)!(a_ i))[*]One.
Step (poly_01_factor (0) i y)!(a_ i).
Apply poly_01_factor_one.
Simpl.
Elim (eq_nat_dec i (S n0)); Intro y.
Step (One!(a_ i))[*]((poly_01 i n0)!(a_ i)).
Step One[*]((poly_01 i n0)!(a_ i)).
Step_final One[*](One::R).
Step ((poly_01_factor (S n0) i y)!(a_ i))[*]((poly_01 i n0)!(a_ i)).
Step ((poly_01_factor (S n0) i y)!(a_ i))[*]One.
Step (poly_01_factor (S n0) i y)!(a_ i).
Apply poly_01_factor_one.
Qed.

Hints Resolve poly_01_zero poly_01_one : algebra.

(* Begin_Tex_Verb *)
Lemma poly_representation'' :
  (a:nat->R)(i:nat)(le i n) ->
  ((j:nat)(~j = i) -> (a j) [=] Zero) ->
    (Sum (0) n a) [=] (a i).
(* End_Tex_Verb *)
Intro. Intro.
Elim i.
Intros.
Step (a (0))[+](Sum (1) n a).
Step_rht (a (0))[+]Zero.
Apply bin_op_wd_unfolded.
Algebra.
Apply Sum_zero.
Auto with arith.
Intros.
Apply H0.
Intro; Rewrite H3 in H1; Inversion H1.
Intro i'.
Intros.
Step (Sum (0) i' a)[+](Sum (S i') n a).
Step_rht Zero[+](a (S i')).
Apply bin_op_wd_unfolded.
Apply Sum_zero.
Auto with arith.
Intros.
Apply H1.
Intro; Rewrite H4 in H3; Exact (le_Sn_n ? H3).
Step (a (S i'))[+](Sum (S (S i')) n a).
Step_rht (a (S i'))[+]Zero.
Apply bin_op_wd_unfolded.
Algebra.
Apply Sum_zero.
Auto with arith.
Intros.
Apply H1.
Intro; Rewrite H4 in H2; Exact (le_Sn_n ? H2).
Qed.

(* Begin_Tex_Verb *)
Lemma poly_representation' :
  (f_:nat->(cpoly_cring R))(k:nat)(le k n) ->
    (Sum (0) n [i:nat]((f_ i)[*](poly_01 i n)))!(a_ k) [=] (f_ k)!(a_ k).
(* End_Tex_Verb *)
Intros.
Apply eq_transitive_unfolded with
  (Sum (0) n [i:nat]((f_ i)[*](poly_01 i n))!(a_ k)).
Apply Sum_cpoly_ap with f := [i:nat](f_ i)[*](poly_01 i n).
Step (Sum (0) n [i:nat](f_ i)!(a_ k)[*](poly_01 i n)!(a_ k)).
Step_rht (f_ k)!(a_ k)[*]One.
Step_rht (f_ k)!(a_ k)[*](poly_01 k n)!(a_ k).
Apply poly_representation'' with
  a := [i:nat](f_ i)!(a_ k)[*](poly_01 i n)!(a_ k).
Auto.
Intros.
Step_final (f_ j)!(a_ k)[*]Zero.
Qed.

(* Begin_Tex_Verb *)
Lemma poly_representation :
  f [=] (Sum (0) n [i:nat](_C_ f!(a_ i))[*](poly_01 i n)).
(* End_Tex_Verb *)
Apply identical_poly.
Auto.
Apply Sum_degree_le. Auto with arith. Intros.
Replace n with (plus (0) n).
Apply degree_le_mult.
Apply degree_le_c_.
Apply poly_01_degree.
Auto.
Auto with arith.
Intros.
Apply eq_symmetric_unfolded.
Step_rht (_C_ f!(a_ i))!(a_ i).
Apply poly_representation' with f_ := [i:nat](_C_ f!(a_ i)).
Auto.
Qed.

Hints Resolve poly_representation : algebra.

(* Begin_Tex_Verb *)
Lemma Cpoly_choose_apzero :
  (f [#] Zero) -> { i:nat | (le i n) & (f!(a_ i) [#] Zero)}.
(* End_Tex_Verb *)
Intros.
Cut (Sum (0) n [i:nat](_C_ f!(a_ i))[*](poly_01 i n)) [#] Zero. Intros.
Elim (Sum_apzero ? [i:nat](_C_ f!(a_ i))[*](poly_01 i n) (0) n (le_O_n n) H0).
Intro i. Intro H1.
Elim H1. Intros H2 H3. Intro H4.
Exists i.
Auto.
Apply poly_c_apzero.
Apply cring_mult_ap_zero with (poly_01 i n).
Auto.
Step f.
Qed.

End Poly_Representation.

(* Tex_Prose
\section{Polynomials are nonzero on any interval}
*)
Section Poly_ApZero_Interval.

Variable R: COrdField.

(* Begin_Tex_Verb *)
Lemma Cpoly_apzero_interval :
  (f:(cpoly_cring R))(f [#] Zero) ->
  (a,b:R)(a [<] b) ->
    { c:R | (a [<=] c) /\ (c [<=] b) & (f!c [#] Zero)}.
(* End_Tex_Verb *)
Intros.
Elim (Cpoly_ex_degree ? f). Intro n. Intro H1.
Cut Zero [<] ((nring (plus n (2)))::R). Intros.
Cut (nring (plus n (2))) [#] (Zero::R). Intros.
Cut (distinct1
  [i:nat](((nring (plus i (1)))[*]a[+]
    ((nring (plus n (2)))[-](nring (plus i (1))))[*]b)[/]
    (nring (plus n (2)))[//]H3)).
Intro.
Elim (Cpoly_choose_apzero ?
  [i:nat](((nring (plus i (1)))[*]a[+]
    ((nring (plus n (2)))[-](nring (plus i (1))))[*]b)[/]
    (nring (plus n (2)))[//]H3)
  H4 f n H1 H).
Intro i. Intros H6 H7.
Exists (((nring (plus i (1)))[*]a[+]
  ((nring (plus n (2)))[-](nring (plus i (1))))[*]b)[/]
    (nring (plus n (2)))[//]H3).
Split.
Apply less_leEq.
Apply shift_less_div.
Auto.
Apply less_wdl with (nring (plus i (1)))[*]a[+]
  ((nring (plus n (2)))[-](nring (plus i (1))))[*]a.
Apply plus_resp_less_lft.
Apply mult_resp_less_lft.
Auto.
Apply shift_zero_less_minus.
Apply nring_less.
Omega.
Rational.
Apply less_leEq.
Apply shift_div_less.
Auto.
Apply less_wdr with (nring (plus i (1)))[*]b[+]
  ((nring (plus n (2)))[-](nring (plus i (1))))[*]b.
Apply plus_resp_less_rht.
Apply mult_resp_less_lft.
Auto.
Step ((nring (0))::R).
Apply nring_less.
Auto with arith.
Rational.
Auto.
Unfold distinct1.
Intros.
Apply zero_minus_apart.
RStep (((nring (plus i (1)))[-](nring (plus j (1))))[*](a[-]b))[/]
  (nring (plus n (2)))[//]H3.
Apply div_resp_ap_zero_rev.
Apply mult_resp_ap_zero.
Apply minus_ap_zero.
Apply nring_apart.
Repeat Rewrite <- plus_n_Sm; Repeat Rewrite <- plus_n_O.
Apply not_eq_S; Auto.
Apply minus_ap_zero.
Apply less_imp_ap.
Auto.
Apply ap_symmetric_unfolded.
Apply less_imp_ap.
Auto.
Step ((nring (0))::R).
Apply nring_less.
Auto with arith.
Qed.

End Poly_ApZero_Interval.


(**Parameter int : Type.
(**Extract Inlined Constant int => "int".*)

Parameter Abs : int -> Z.
Axiom Abs_inj: forall (n m : int), Abs n = Abs m -> n = m.

Parameter ltb: int -> int -> bool.
Extract Inlined Constant ltb => "( < )".
Axiom ltb_lt : forall (n m : int), ltb n m = true <-> Abs n < Abs m.
Parameter leb: int \u2192 int \u2192 bool.
Extract Inlined Constant leb \u21d2 "( <= )".
Axiom leb_le : \u2200 (n m : int), leb n m = true \u2194 Abs n \u2264 Abs m.
**)

From Coq Require Import String.
From Coq Require Export Arith.
From Coq Require Export Lia.

Notation  "a >=? b" := (Nat.leb b a) (at level 70) : nat_scope.
Notation  "a >? b"  := (Nat.ltb b a) (at level 70) : nat_scope.

Definition key := nat.

Inductive color := Red | Black.

Inductive tree (V : Type) : Type :=
| E : tree V
| T : color -> tree V -> key -> V -> tree V -> tree V.

Arguments E {V}.
Arguments T {V}.

Definition empty_tree (V : Type) : tree V :=
  E.

Fixpoint lookup {V : Type} (d : V) (x: key) (t : tree V) : V :=
  match t with
  | E => d
  | T _ tl k v tr => if k >? x then lookup d x tl
                    else if x >? k then lookup d x tr
                         else v
  end.

Definition balance
           {V : Type} (c : color) (t1 : tree V) (k : key) (vk : V)
           (t2 : tree V) : tree V :=
  match c with
  | Red => T Red t1 k vk t2
  | _ => match t1 with
        | T Red (T Red a x vx b) y vy c =>
            T Red (T Black a x vx b) y vy (T Black c k vk t2)
        | T Red a x vx (T Red b y vy c) =>
            T Red (T Black a x vx b) y vy (T Black c k vk t2)
        | _ => match t2 with
              | T Red (T Red b y vy c) z vz d =>
                  T Red (T Black t1 k vk b) y vy (T Black c z vz d)
              | T Red b y vy (T Red c z vz d) =>
                  T Red (T Black t1 k vk b) y vy (T Black c z vz d)
              | _ => T Black t1 k vk t2
              end
        end
  end.

Fixpoint ins {V : Type} (x : key) (vx : V) (t : tree V) : tree V :=
  match t with
  | E => T Red E x vx E
  | T c a y vy b => if y >? x then balance c (ins x vx a) y vy b
                   else if x >? y then balance c a y vy (ins x vx b)
                        else T c a x vx b
  end.

Definition make_black {V : Type} (t : tree V) : tree V :=
  match t with
  | E => E
  | T _ a x vx b => T Black a x vx b
  end.

Definition insert {V : Type} (x : key) (vx : V) (t : tree V) :=
  make_black (ins x vx t).

Fixpoint elements_aux {V : Type} (t : tree V) (acc: list (key * V))
  : list (key * V) :=
  match t with
  | E => acc
  | T _ l k v r => elements_aux l ((k, v) :: elements_aux r acc)
  end.

Notation "[ ]" := nil.

Definition elements {V : Type} (t : tree V) : list (key * V) :=
  elements_aux t [].

Lemma ins_not_E : forall (V : Type) (x : key) (vx : V) (t : tree V),
    not (ins x vx t = E).
Proof.
   intros. destruct t; simpl.
  - discriminate.
  - unfold balance.
    repeat
      match goal with
      | |- (if ?x then _ else _) <> _ => destruct x
      | |- match ?c with Red => _ | Black => _ end <> _=> destruct c
      | |- match ?t with E => _ | T _ _ _ _ _ => _ end <> _=> destruct t
      | |- T _ _ _ _ _ <> E => discriminate
      end.
Qed.

Fixpoint ForallT {V : Type} (P: nat -> V -> Prop) (t : tree V) : Prop :=
  match t with
  | E => True
  | T c l k v r => P k v /\ ForallT P l /\ ForallT P r
  end.

Lemma balanceP : forall (V : Type) (P : key -> V -> Prop) (c : color) (l r : tree V)
                   (k : key) (v : V),
    ForallT P l ->
    ForallT P r ->
    P k v ->
    ForallT P (balance c l k v r).
Proof.
  intros. unfold balance.
    repeat
      match goal with
      | |- match ?c with Red => _ | Black => _ end => destruct c
      | |- match ?l with E => _ | T _ _ _ _ _ => _ end => destruct l
      | |- T _ _ _ _ _ => repeat split
      | |- P k v => auto
      | |- ForallT _ _ => auto
      end.
  Admitted.

Inductive reflect (P : Prop) : bool -> Set :=
  | reflectT :   P -> reflect P true
  | reflectF : ~ P -> reflect P false.

Theorem iff_reflect : forall P b, (P <-> b = true) -> reflect P b.
Proof.
  intros P b H. destruct b.
  - inversion H. apply reflectT. simpl in H1. rewrite H. reflexivity.
  - inversion H. apply reflectF. unfold not. rewrite H. intros. discriminate H2.
Qed.

Theorem reflect_iff : forall P b, reflect P b -> (P <-> b = true).
Proof.
  intros P b H. split.
  - inversion H.
    * intros. reflexivity.
    * intros. unfold not in H0. apply H0 in H2. contradiction.
  - intros. subst. inversion H. apply H0.
Qed.

Lemma eqb_reflect : forall x y, reflect (x = y) (x =? y).
Proof.
  intros. apply iff_reflect. symmetry. apply Nat.eqb_eq.
Qed.

Lemma ltb_reflect : forall x y, reflect (x < y) (x <? y).
Proof.
  intros. apply iff_reflect. symmetry. apply Nat.ltb_lt.
Qed.

Lemma leb_reflect : forall x y, reflect (x <= y) (x <=? y).
Proof.
  intros. apply iff_reflect. symmetry. apply Nat.leb_le.
Qed.

Hint Resolve ltb_reflect leb_reflect eqb_reflect : bdestruct.

Ltac bdestruct X :=
  let H := fresh in let e := fresh "e" in
   evar (e: Prop);
   assert (H: reflect e X); subst e;
    [eauto with bdestruct
    | destruct H as [H|H];
       [ | try first [apply not_lt in H | apply not_le in H]]].

Lemma insP : forall (V : Type) (P : key -> V -> Prop) (t : tree V) (k : key) (v : V),
    ForallT P t ->
    P k v ->
    ForallT P (ins k v t).
Proof.
  intros. induction t.
    - simpl. repeat split.
      * apply H0.
    - simpl. bdestruct (k0 >? k).
      * apply balanceP.
        ++ inversion H. destruct H3. apply IHt1 in H3. apply H3.
        ++ inversion H. destruct H3. apply H4.
        ++ inversion H. apply H2.
      * bdestruct (k >? k0).
        ++ apply balanceP.
          ** inversion H. destruct H4. apply H4.
          ** inversion H. destruct H4. apply IHt2 in H5. apply H5.
          ** inversion H. apply H3.
        ++ assert (k0 = k). lia. simpl. repeat split.
          ** apply H0.
          ** inversion H. destruct H5. apply H5.
          ** inversion H. destruct H5. apply H6.
Qed.

Inductive BST {V : Type} : tree V -> Prop :=
| ST_E : BST E
| ST_T : forall (c : color) (l : tree V) (k : key) (v : V) (r : tree V),
    ForallT (fun k' _ => k'< k) l ->
    ForallT (fun k' _ => k'> k) r ->
    BST l ->
    BST r ->
    BST (T c l k v r).

Lemma ForallT_imp : forall (V : Type) (P Q : nat -> V -> Prop) t,
    ForallT P t ->
    (forall k v, P k v -> Q k v) ->
    ForallT Q t.
Proof.
  induction t; intros.
  - auto.
  - destruct H as [? [? ?]]. repeat split; auto.
Qed.
Lemma ForallT_greater : forall (V : Type) (t : tree V) (k k0 : key),
    ForallT (fun k' _ => k' > k) t ->
    k > k0 ->
    ForallT (fun k' _ => k' > k0) t.
Proof.
  intros. eapply ForallT_imp; eauto.
  intros. simpl in H1. lia.
Qed.
Lemma ForallT_less : forall (V : Type) (t : tree V) (k k0 : key),
    ForallT (fun k' _ => k' < k) t ->
    k < k0 ->
    ForallT (fun k' _ => k' < k0) t.
Proof.
  intros; eapply ForallT_imp; eauto.
  intros. simpl in H1. lia.
Qed.

Lemma balance_BST: forall (V : Type) (c : color) (l : tree V) (k : key)
                     (v : V) (r : tree V),
    ForallT (fun k' _ => k' < k) l ->
    ForallT (fun k' _ => k' > k) r ->
    BST l ->
    BST r ->
    BST (balance c l k v r).
Proof.
  intros. unfold balance.
  repeat
    match goal with
    | H: ForallT _ (T _ _ _ _ _) |- _ => destruct H as [? [? ?] ]
    | H: BST (T _ _ _ _ _) |- _ => inversion H; clear H; subst
    | |- BST (T _ _ _ _ _) => constructor
    | |- BST (match ?c with Red => _ | Black => _ end) => destruct c
    | |- BST (match ?t with E => _ | T _ _ _ _ _ => _ end) => destruct t
    | |- ForallT _ (T _ _ _ _ _) => repeat split
    end;
    auto; try lia.
  all: try eapply ForallT_greater; try eapply ForallT_less; eauto; try lia.
Qed.

Lemma ins_BST : forall (V : Type) (t : tree V) (k : key) (v : V),
    BST t ->
    BST (ins k v t).
Proof.
  intros. induction t.
  - simpl. apply ST_T.
    * reflexivity.
    * reflexivity.
    * apply H.
    * apply ST_E.
  - simpl. bdestruct (k0 >? k).
    * apply balance_BST.
      ** apply insP.
        + inversion H. apply H5.
        + apply H0.
      ** inversion H. apply H7.
      ** inversion H. apply IHt1 in H8. apply H8.
      ** inversion H. apply H9.
    * bdestruct (k >? k0).
      ** apply balance_BST.
         + inversion H. apply H6.
         + apply insP. inversion H.
           ++ apply H8.
           ++ apply H1.
         + inversion H. apply H9.
         + inversion H. apply IHt2 in H10. apply H10.
      ** apply ST_T. inversion H. assert (k = k0). lia.
          + rewrite H11. apply H6.
          + inversion H. assert (k = k0). lia. rewrite H11. apply H8.
          + inversion H. apply H9.
          + inversion H. apply H10.
Qed.

Theorem helper : forall (V: Type) (t : tree V) (v : V) (k : key),
    BST t ->
    BST (make_black t).
  intros. unfold make_black. induction t.
    - apply ST_E.
    - apply ST_T. inversion H.
      * apply H4.
      * inversion H. apply H6.
      * inversion H. apply H7.
      * inversion H. apply H8.
Qed.

Theorem insert_BST : forall (V : Type) (t : tree V) (v : V) (k : key),
    BST t ->
    BST (insert k v t).
Proof.
  intros. unfold insert. apply helper.
    - apply v.
    - apply k.
      - apply ins_BST. apply H.
Qed.

Lemma balance_lookup: forall (V : Type) (d : V) (c : color) (k k' : key) (v : V)
                        (l r : tree V),
    BST l ->
    BST r ->
    ForallT (fun k' _ => k' < k) l ->
    ForallT (fun k' _ => k' > k) r ->
    lookup d k' (balance c l k v r) =
      if k' <? k
      then lookup d k' l
      else if k' >? k
           then lookup d k' r
           else v.
Proof.
  (* FILL IN HERE *) Admitted.

Lemma lookup_ins_eq: forall (V : Type) (d : V) (t : tree V) (k : key) (v : V),
    BST t ->
    lookup d k (ins k v t) = v.
Proof.

  intros. induction H.
  - simpl. bdestruct (k >? k).
    * lia.
    * reflexivity.
  - simpl. bdestruct (k0 >? k).
    * rewrite balance_lookup.
      + bdestruct (k0 >? k).
        ++ apply IHBST1.
        ++ lia.
      + apply ins_BST. apply H1.
      + apply H2.
      + apply insP.
        ++ apply H.
        ++ lia.
      + apply H0.
    * bdestruct (k >? k0).
      + rewrite balance_lookup.
        ++ bdestruct (k0 >? k). lia. bdestruct (k >? k0). apply IHBST2. lia.
        ++ apply H1.
        ++ apply ins_BST. apply H2.
        ++ apply H.
        ++ apply insP. apply H0. apply H4.
      + assert (k = k0). lia. simpl. bdestruct (k >? k).
        ++ lia.
        ++ reflexivity.
Qed.

Theorem lookup_ins_neq: forall (V : Type) (d : V) (t : tree V) (k k' : key)
                          (v : V),
    BST t ->
    not (k = k') ->
    lookup d k' (ins k v t) = lookup d k' t.
Proof.
  intros. induction H.
  - simpl. bdestruct (k >? k'). reflexivity. bdestruct (k' >? k). reflexivity. lia.
  - simpl. bdestruct (k0 >? k).
    * rewrite balance_lookup.
      ** bdestruct (k0 >? k').
        + apply IHBST1.
        + bdestruct (k' >? k0). reflexivity. reflexivity.
      ** apply ins_BST. apply H2.
      ** apply H3.
      ** apply insP. apply H. apply H4.
      ** apply H1.
     * bdestruct (k >? k0).
      ** rewrite balance_lookup.
        + bdestruct (k0 >? k'). reflexivity.
        bdestruct (k' >? k0). apply IHBST2. reflexivity.
        + apply H2.
        + apply ins_BST. apply H3.
        + apply H.
        + apply insP. apply H1. apply H5.
      ** bdestruct (k0 >? k').
        + simpl. bdestruct (k >? k'). reflexivity. bdestruct (k' >? k). lia. lia.
        + bdestruct (k' >? k0).
          ++ simpl. bdestruct (k >? k'). lia. bdestruct (k' >? k). reflexivity.
          lia.
          ++ simpl. bdestruct (k >? k'). lia. bdestruct (k' >? k). lia. lia.
Qed.

Theorem helper_lookup : forall (V: Type) (d: V) (t : tree V) (k : key) (v : V) ,
    lookup d k t = v ->
    lookup d k (make_black t) = v.
Proof.
  intros. unfold make_black. induction t.
   - apply H.
   - apply H.
Qed.

Theorem helper_lookup2 : forall (V: Type) (d: V) (t2 : tree V) (t : tree V) (k : key) (v : V) ,
    lookup d k t = lookup d k t2  ->
    lookup d k (make_black t) = lookup d k t2.
Proof.
  intros. unfold make_black. induction t.
   - apply H.
   - apply H.
Qed.

Theorem lookup_insert_eq : forall (V : Type) (d : V) (t : tree V) (k : key)
                             (v : V),
    BST t ->
    lookup d k (insert k v t) = v.
Proof.
  intros. unfold insert. rewrite helper_lookup with (V) (d) ((ins k v t)) (k) (v).
  - reflexivity.
  - apply lookup_ins_eq. apply H.
Qed.

Theorem lookup_insert_neq: forall (V : Type) (d : V) (t : tree V) (k k' : key)
                             (v : V),
    BST t ->
    not (k = k') ->
    lookup d k' (insert k v t) = lookup d k' t.
Proof.
  intros. unfold insert. apply helper_lookup2.
  - apply v.
  - apply lookup_ins_neq.
    * apply H.
    * apply H0.
Qed.

Inductive RB {V : Type} : tree V -> color -> nat -> Prop :=
| RB_leaf: forall (c : color), RB E c 0
| RB_r: forall (l r : tree V) (k : key) (v : V) (n : nat),
    RB l Red n ->
    RB r Red n ->
    RB (T Red l k v r) Black n
| RB_b: forall (c : color) (l r : tree V) (k : key) (v : V) (n : nat),
    RB l Black n ->
    RB r Black n ->
    RB (T Black l k v r) c (S n).

Lemma RB_blacken_parent : forall (V : Type) (t : tree V) (n : nat),
    RB t Red n -> RB t Black n.
Proof.
  intros. induction H.
  - apply RB_leaf.
  - apply RB_r.
   * apply H.
   * apply H0.
  - apply RB_b.
   * apply H.
   * apply H0.
Qed.

Inductive NearlyRB {V : Type} : tree V -> nat -> Prop :=
| NearlyRB_r : forall (l r : tree V) (k : key) (v : V) (n : nat),
    RB l Black n ->
    RB r Black n ->
    NearlyRB (T Red l k v r) n
| NearlyRB_b : forall (l r : tree V) (k : key) (v : V) (n : nat),
    RB l Black n ->
    RB r Black n ->
    NearlyRB (T Black l k v r) (S n).

Ltac prove_RB := admit.
Lemma ins_RB : forall (V : Type) (k : key) (v : V) (t : tree V) (n : nat),
    (RB t Black n -> NearlyRB (ins k v t) n) /\
      (RB t Red n -> RB (ins k v t) Black n).
Proof.
  induction t; split; intros; inversion H; repeat constructor; simpl.
  - (* Instantiate the inductive hypotheses. *)
    specialize (IHt1 n). specialize (IHt2 n).
    (* Derive what propositional facts we can from the hypotheses. *)
    intuition.
    (* Get rid of some extraneous hypotheses. *)
    clear H H1.
    (* Finish with automation. *)
    prove_RB.
  - specialize (IHt1 n0). specialize (IHt2 n0). intuition.
    clear H0 H2.
    prove_RB.
  - specialize (IHt1 n0). specialize (IHt2 n0). intuition.
    clear H0 H2.
    prove_RB.
    (* FILL IN HERE *) Admitted.

Lemma RB_blacken_root : forall (V : Type) (t : tree V) (n : nat),
    RB t Black n ->
    exists (n' : nat), RB (make_black t) Red n'.
Proof.
   intros. induction H.
    - simpl. exists 0. apply RB_leaf.
    - simpl. exists (S n). apply RB_b.
      * apply RB_blacken_parent. apply H.
      * apply RB_blacken_parent. apply H0.
    - simpl. exists (S n). apply RB_b.
      * apply H.
      * apply H0.
Qed.

Lemma insert_RB : forall (V : Type) (t : tree V) (k : key) (v : V) (n : nat),
    RB t Red n ->
    exists (n' : nat), RB (insert k v t) Red n'.
Proof.
  intros. unfold insert. apply RB_blacken_root with n. apply ins_RB. apply H.
Qed.


  (** Pierre Castéran, Univ. Bordeaux and LaBRI *)

From hydras Require Import Hydra_Lemmas  Epsilon0_Needed_Free
     Epsilon0_Needed_Std  Hydra_Termination L_alpha Battle_length Ack.
Import E0 Large_Sets Hprime Paths MoreLists  O2H Hydra_Definitions Iterates.
Export Hydra_Definitions.

(** ** Liveness

  If the hydra is not reduced to one  head, then Hercules can chop off
  some head
 *)

(* begin snippet AliveThms *)
Corollary Alive_free : Alive free. (* .no-out *)
(*| .. coq:: none |*)
Proof.
  red;intros.
  destruct (next_round i h).
  -  destruct s as [h' H'];  exists h'; now  exists i.
  - tauto.
Qed.
(*||*)

Corollary Alive_standard : Alive standard. (* .no-out *)
(*|
.. coq:: none
|*)
Proof.
  red;intros.
  destruct (next_round i h).
  -  destruct s as [h' H'];  exists h'.
     assumption.
  - now destruct H.
Qed.
(*||*)

(* end snippet AliveThms *)

(** ** Termination of free battles
 *)

Theorem Variant_LT_free_0 :  @Hvariant  _ _ T1_wf free Hydra_Termination.m.
Proof. split; intros; now apply round_decr. Qed.

Theorem Variant_lt_free:  @Hvariant _ _ E0lt_wf free Hydra_Termination.var.
Proof. split; intros; now apply round_decr. Qed.

Theorem Variant_LT_standard : @Hvariant _ _ T1_wf standard Hydra_Termination.m.
Proof.
 split; intros i h h' H H0; apply round_decr; now exists i.
Qed.

Theorem Variant_lt_standard : @Hvariant _ _ E0lt_wf standard Hydra_Termination.var.
Proof.
  split; intros i h h' H H0;  apply round_decr; now exists i.
Qed.

(*

Print Assumptions Variant_lt_standard.
 *)

(** ** Impossibility theorems

  Termination of free battles cannot be proven with a variant from hydras into a segment $[0, alpha]$ with $alpha < \_epsilon0$

*)

(**  Impossiblity to define a variant bounded by some ordinal less than
     [epsilon0] *)

Check Impossibility_free.
(*
Impossibility_free
     : BoundedVariant free -> False
 *)

About  battle_length_std.

Open Scope nat_scope.

(* begin snippet battleLengthStdHardy *)

(*| .. coq:: no-out |*)
Theorem battle_length_std_Hardy (alpha : E0) :
  alpha <> E0zero ->
  forall k , 1 <= k ->
             exists l: nat,
               H'_ alpha k - k <= l /\
               battle_length standard k (iota (cnf alpha)) l.
Proof.
  intros H k  H0; exists (L_ alpha (S k) - k); split.
  - generalize (H'_L_ alpha k); lia.
  - now apply battle_length_std.
Qed.
(*||*)
(* end snippet battleLengthStdHardy *)

(*
Print Assumptions battle_length_std.
 *)

(** ** Battle length is not PR *)

Require Import primRec F_alpha  AckNotPR PrimRecExamples.
Require Import F_omega.
Import E0.

(* begin snippet battleLengthNotPRa *)

Section battle_length_notPR.

  Hypothesis H: forall alpha, isPR 1 (l_std alpha).

  (* end snippet battleLengthNotPRa *)

  (** A counter example *)

  (* begin snippet battleLengthNotPRb *)

  Let alpha := E0phi0 E0omega.
  Let h := iota (cnf alpha).

   (* end snippet battleLengthNotPRb *)

  (** let us get rid of the substraction ... *)

  (* begin snippet battleLengthNotPRc *)

  Let m k := L_ alpha (S k).

  Remark m_eqn : forall k, m k = (l_std alpha k + k)%nat. (* .no-out *)
  (* end snippet battleLengthNotPRc *)

  Proof.
    intro k; assert (k <= L_ alpha (S k)).
    { assert (S k < L_ alpha (S k)).
      { apply L_ge_S; unfold alpha; intro H0; injection H0.
        intro; discriminate.
      }
      lia.
    }
    unfold m,l_std ; lia.
  Qed.

  (* begin snippet battleLengthNotPRd *)

  Remark mIsPR : isPR 1 m. (* .no-out *)

   (* end snippet battleLengthNotPRd *)
  Proof.
    destruct (H alpha) as [x Hx].
    apply isPR_extEqual_trans with (fun k => (l_std alpha  k + k)%nat).
    - apply compose1_2IsPR; auto.
      + apply idIsPR.
      + apply plusIsPR.
    - intro k; unfold m, l_std; assert (k <=  L_ alpha (S k))%nat.
      transitivity (S k).
      + auto with arith.
      + apply Nat.lt_le_incl.
        apply L_ge_S.
        unfold alpha; intro H0; injection H0; discriminate.
      + now replace (L_ alpha ( S k) -k + k)%nat with (L_ alpha (S k))
          by lia.
  Qed.

  (* begin snippet mGeFOmega *)

  Remark m_ge_F_omega k: F_ E0omega (S k) <= m (S k). (* .no-out *)
  (* end snippet mGeFOmega *)

  Proof.
    rewrite m_eqn; transitivity (H'_ alpha (S k)).
    - apply H'_F.
    - unfold l_std;  generalize (H'_L_ alpha (S k)); lia.
  Qed.

  (** We compare [m] with the Ackermann function *)

  Remark m_ge_Ack:  forall n, 2 <= n -> Ack (S n) (S n) <= m (S n).
  Proof.
    intros n H0; transitivity (F_ E0omega (S n)).
    - apply F_vs_Ack; auto.
    - apply m_ge_F_omega.
  Qed.

  Remark m_dominates_Ack_from_3 : forall n, 3 <= n -> Ack n n <= m n.
  Proof.
    destruct n.
    - lia.
    - intro; apply m_ge_Ack; auto with arith.
  Qed.

  (* begin snippet mDominatesAck *)

  Remark m_dominates_Ack :
    dominates (fun n =>  S (m n)) (fun n => Ack.Ack n n). (* .no-out *)

    (* end snippet mDominatesAck *)

  Proof.
    exists 3; red; intros.
    apply Nat.le_lt_trans with (m p).
    - apply m_dominates_Ack_from_3; auto.
    - auto with arith.
  Qed.

  (* begin snippet SmNotPR *)

  Remark SmNotPR : isPR 1 (fun n => S (m n)) -> False. (* .no-out *)
 (* end snippet SmNotPR *)

  Proof.
    intro; eapply dom_AckNotPR; eauto.
    apply m_dominates_Ack; auto.
  Qed.

  (* begin snippet LNotPR *)

  (*|
.. coq:: no-out
|*)

  Theorem LNotPR : False.
  Proof.
    apply SmNotPR, compose1_1IsPR.
    - apply mIsPR.
    - apply succIsPR.
  Qed.

End battle_length_notPR.

(*||*)
Check l_std_ok.

Check LNotPR.

Search L_ F_.
(* end snippet LNotPR *)


(* Copyright (c) 2012-2015, Robbert Krebbers. *)
(* This file is distributed under the terms of the BSD license. *)
(** This file collects theorems, definitions, tactics, related to propositions
with a decidable equality. Such propositions are collected by the [Decision]
type class. *)
From prelude Require Export proof_irrel.

Hint Extern 200 (Decision _) => progress (lazy beta) : typeclass_instances.

Lemma dec_stable `{Decision P} : ¬¬P → P.
Proof. firstorder. Qed.

Lemma Is_true_reflect (b : bool) : reflect b b.
Proof. destruct b. left; constructor. right. intros []. Qed.
Instance: Inj (=) (↔) Is_true.
Proof. intros [] []; simpl; intuition. Qed.

(** We introduce [decide_rel] to avoid inefficienct computation due to eager
evaluation of propositions by [vm_compute]. This inefficiency occurs if
[(x = y) := (f x = f y)] as [decide (x = y)] evaluates to [decide (f x = f y)]
which then might lead to evaluation of [f x] and [f y]. Using [decide_rel]
we hide [f] under a lambda abstraction to avoid this unnecessary evaluation. *)
Definition decide_rel {A B} (R : A → B → Prop) {dec : ∀ x y, Decision (R x y)}
  (x : A) (y : B) : Decision (R x y) := dec x y.
Lemma decide_rel_correct {A B} (R : A → B → Prop) `{∀ x y, Decision (R x y)}
  (x : A) (y : B) : decide_rel R x y = decide (R x y).
Proof. reflexivity. Qed.

Lemma decide_True {A} `{Decision P} (x y : A) :
  P → (if decide P then x else y) = x.
Proof. destruct (decide P); tauto. Qed.
Lemma decide_False {A} `{Decision P} (x y : A) :
  ¬P → (if decide P then x else y) = y.
Proof. destruct (decide P); tauto. Qed.
Lemma decide_iff {A} P Q `{Decision P, Decision Q} (x y : A) :
  (P ↔ Q) → (if decide P then x else y) = (if decide Q then x else y).
Proof. intros [??]. destruct (decide P), (decide Q); tauto. Qed.

(** The tactic [destruct_decide] destructs a sumbool [dec]. If one of the
components is double negated, it will try to remove the double negation. *)
Tactic Notation "destruct_decide" constr(dec) "as" ident(H) :=
  destruct dec as [H|H];
  try match type of H with
  | ¬¬_ => apply dec_stable in H
  end.
Tactic Notation "destruct_decide" constr(dec) :=
  let H := fresh in destruct_decide dec as H.

(** The tactic [case_decide] performs case analysis on an arbitrary occurrence
of [decide] or [decide_rel] in the conclusion or hypotheses. *)
Tactic Notation "case_decide" "as" ident(Hd) :=
  match goal with
  | H : context [@decide ?P ?dec] |- _ =>
    destruct_decide (@decide P dec) as Hd
  | H : context [@decide_rel _ _ ?R ?x ?y ?dec] |- _ =>
    destruct_decide (@decide_rel _ _ R x y dec) as Hd
  | |- context [@decide ?P ?dec] =>
    destruct_decide (@decide P dec) as Hd
  | |- context [@decide_rel _ _ ?R ?x ?y ?dec] =>
    destruct_decide (@decide_rel _ _ R x y dec) as Hd
  end.
Tactic Notation "case_decide" :=
  let H := fresh in case_decide as H.

(** The tactic [solve_decision] uses Coq's [decide equality] tactic together
with instance resolution to automatically generate decision procedures. *)
Ltac solve_trivial_decision :=
  match goal with
  | |- Decision (?P) => apply _
  | |- sumbool ?P (¬?P) => change (Decision P); apply _
  end.
Ltac solve_decision := intros; first
  [ solve_trivial_decision
  | unfold Decision; decide equality; solve_trivial_decision ].

(** The following combinators are useful to create Decision proofs in
combination with the [refine] tactic. *)
Notation swap_if S := (match S with left H => right H | right H => left H end).
Notation cast_if S := (if S then left _ else right _).
Notation cast_if_and S1 S2 := (if S1 then cast_if S2 else right _).
Notation cast_if_and3 S1 S2 S3 := (if S1 then cast_if_and S2 S3 else right _).
Notation cast_if_and4 S1 S2 S3 S4 :=
  (if S1 then cast_if_and3 S2 S3 S4 else right _).
Notation cast_if_and5 S1 S2 S3 S4 S5 :=
  (if S1 then cast_if_and4 S2 S3 S4 S5 else right _).
Notation cast_if_and6 S1 S2 S3 S4 S5 S6 :=
  (if S1 then cast_if_and5 S2 S3 S4 S5 S6 else right _).
Notation cast_if_or S1 S2 := (if S1 then left _ else cast_if S2).
Notation cast_if_or3 S1 S2 S3 := (if S1 then left _ else cast_if_or S2 S3).
Notation cast_if_not_or S1 S2 := (if S1 then cast_if S2 else left _).
Notation cast_if_not S := (if S then right _ else left _).

(** We can convert decidable propositions to booleans. *)
Definition bool_decide (P : Prop) {dec : Decision P} : bool :=
  if dec then true else false.

Lemma bool_decide_reflect P `{dec : Decision P} : reflect P (bool_decide P).
Proof. unfold bool_decide. destruct dec; [left|right]; assumption. Qed.

Tactic Notation "case_bool_decide" "as" ident (Hd) :=
  match goal with
  | H : context [@bool_decide ?P ?dec] |- _ =>
    destruct_decide (@bool_decide_reflect P dec) as Hd
  | |- context [@bool_decide ?P ?dec] =>
    destruct_decide (@bool_decide_reflect P dec) as Hd
  end.
Tactic Notation "case_bool_decide" :=
  let H := fresh in case_bool_decide as H.

Lemma bool_decide_spec (P : Prop) {dec : Decision P} : bool_decide P ↔ P.
Proof. unfold bool_decide. destruct dec; simpl; tauto. Qed.
Lemma bool_decide_unpack (P : Prop) {dec : Decision P} : bool_decide P → P.
Proof. rewrite bool_decide_spec; trivial. Qed.
Lemma bool_decide_pack (P : Prop) {dec : Decision P} : P → bool_decide P.
Proof. rewrite bool_decide_spec; trivial. Qed.
Lemma bool_decide_true (P : Prop) `{Decision P} : P → bool_decide P = true.
Proof. case_bool_decide; tauto. Qed.
Lemma bool_decide_false (P : Prop) `{Decision P} : ¬P → bool_decide P = false.
Proof. case_bool_decide; tauto. Qed.
Lemma bool_decide_iff (P Q : Prop) `{Decision P, Decision Q} :
  (P ↔ Q) → bool_decide P = bool_decide Q.
Proof. repeat case_bool_decide; tauto. Qed.

(** * Decidable Sigma types *)
(** Leibniz equality on Sigma types requires the equipped proofs to be
equal as Coq does not support proof irrelevance. For decidable we
propositions we define the type [dsig P] whose Leibniz equality is proof
irrelevant. That is [∀ x y : dsig P, x = y ↔ `x = `y]. *)
Definition dsig `(P : A → Prop) `{∀ x : A, Decision (P x)} :=
  { x | bool_decide (P x) }.

Definition proj2_dsig `{∀ x : A, Decision (P x)} (x : dsig P) : P (`x) :=
  bool_decide_unpack _ (proj2_sig x).
Definition dexist `{∀ x : A, Decision (P x)} (x : A) (p : P x) : dsig P :=
  x↾bool_decide_pack _ p.
Lemma dsig_eq `(P : A → Prop) `{∀ x, Decision (P x)}
  (x y : dsig P) : x = y ↔ `x = `y.
Proof. apply (sig_eq_pi _). Qed.
Lemma dexists_proj1 `(P : A → Prop) `{∀ x, Decision (P x)} (x : dsig P) p :
  dexist (`x) p = x.
Proof. apply dsig_eq; reflexivity. Qed.

(** * Instances of Decision *)
(** Instances of [Decision] for operators of propositional logic. *)
Instance True_dec: Decision True := left I.
Instance False_dec: Decision False := right (False_rect False).
Instance Is_true_dec b : Decision (Is_true b).
Proof. destruct b; apply _. Defined.

Section prop_dec.
  Context `(P_dec : Decision P) `(Q_dec : Decision Q).

  Global Instance not_dec: Decision (¬P).
  Proof. refine (cast_if_not P_dec); intuition. Defined.
  Global Instance and_dec: Decision (P ∧ Q).
  Proof. refine (cast_if_and P_dec Q_dec); intuition. Defined.
  Global Instance or_dec: Decision (P ∨ Q).
  Proof. refine (cast_if_or P_dec Q_dec); intuition. Defined.
  Global Instance impl_dec: Decision (P → Q).
  Proof. refine (if P_dec then cast_if Q_dec else left _); intuition. Defined.
End prop_dec.
Instance iff_dec `(P_dec : Decision P) `(Q_dec : Decision Q) :
  Decision (P ↔ Q) := and_dec _ _.

(** Instances of [Decision] for common data types. *)
Instance bool_eq_dec (x y : bool) : Decision (x = y).
Proof. solve_decision. Defined.
Instance unit_eq_dec (x y : unit) : Decision (x = y).
Proof. solve_decision. Defined.
Instance prod_eq_dec `(A_dec : ∀ x y : A, Decision (x = y))
  `(B_dec : ∀ x y : B, Decision (x = y)) (x y : A * B) : Decision (x = y).
Proof. solve_decision. Defined.
Instance sum_eq_dec `(A_dec : ∀ x y : A, Decision (x = y))
  `(B_dec : ∀ x y : B, Decision (x = y)) (x y : A + B) : Decision (x = y).
Proof. solve_decision. Defined.

Instance curry_dec `(P_dec : ∀ (x : A) (y : B), Decision (P x y)) p :
    Decision (curry P p) :=
  match p as p return Decision (curry P p) with
  | (x,y) => P_dec x y
  end.
Instance uncurry_dec `(P_dec : ∀ (p : A * B), Decision (P p)) x y :
  Decision (uncurry P x y) := P_dec (x,y).

Instance sig_eq_dec `(P : A → Prop) `{∀ x, ProofIrrel (P x)}
  `{∀ x y : A, Decision (x = y)} (x y : sig P) : Decision (x = y).
Proof. refine (cast_if (decide (`x = `y))); rewrite sig_eq_pi; trivial. Defined.

(** Some laws for decidable propositions *)
Lemma not_and_l {P Q : Prop} `{Decision P} : ¬(P ∧ Q) ↔ ¬P ∨ ¬Q.
Proof. destruct (decide P); tauto. Qed.
Lemma not_and_r {P Q : Prop} `{Decision Q} : ¬(P ∧ Q) ↔ ¬P ∨ ¬Q.
Proof. destruct (decide Q); tauto. Qed.
Lemma not_and_l_alt {P Q : Prop} `{Decision P} : ¬(P ∧ Q) ↔ ¬P ∨ (¬Q ∧ P).
Proof. destruct (decide P); tauto. Qed.
Lemma not_and_r_alt {P Q : Prop} `{Decision Q} : ¬(P ∧ Q) ↔ (¬P ∧ Q) ∨ ¬Q.
Proof. destruct (decide Q); tauto. Qed.


Set Implicit Arguments.
Set Contextual Implicit.
Set Primitive Projections.

From Equations Require Import Equations.

From OGS Require Import CatD Utils EventD.

Section itree.

  Context {I : Type} {E : event I I} {R : I -> Type}.

  Variant itreeF (ind : I -> Type) (i : I) :=
  | RetF (r : R i)
  | TauF (t : ind i)
  | VisF (e : E.(qry) i) (k : forall r : E.(rsp) e, ind (E.(nxt) e r))
  .

  CoInductive itree (i : I) : Type := go
  { _observe : itreeF itree i }.

End itree.

Bind Scope itree_scope with itree.
Delimit Scope itree_scope with itree.
Local Open Scope itree_scope.

Arguments itree {_} _ _ _.
Arguments itreeF {_} _ _ _ _.

Notation itree' E R := (itreeF E R (itree E R)).

Definition observe {I E R i} (t : @itree I E R i) : itree' E R i :=
  @_observe I E R i t.

Notation Ret x := (go (RetF x)).
Notation Tau t := (go (TauF t)).
Notation Vis e k := (go (VisF e k)).

Section a.
Context {I} {E : event I I} {R : I -> Type}.
Definition ret {i} x : itree E R i := Ret x.
Definition tau {i} t : itree E R i := Tau t.
Definition vis {i} e k : itree E R i := Vis e k.
Definition vis'' : ⟦ E ⟧ (itree E R) ⇒ᵢ itree E R := fun _ x => Vis _ (projT2 x).
End a.

Definition vis' {I} (E : event I I) {R i} e k : itree E R i := @vis I E R i e k.
Arguments vis' : clear implicits.
Arguments vis' {I} E {R i} e k.

Definition fmap {I} {E : event I I} {X Y} (f : X ⇒ᵢ Y) : itree E X ⇒ᵢ itree E Y :=
  cofix _fmap _ u :=
    match (observe u) with
    | RetF r => Ret (f _ r)
    | TauF t => Tau (_fmap _ t)
    | VisF e k => Vis e (fun r => _fmap _ (k r))
    end.

Definition subst {I} {E : event I I} {X Y} (f : X ⇒ᵢ itree E Y)
                 : itree E X ⇒ᵢ itree E Y :=
  cofix _subst _ u :=
    match observe u with
    | RetF r => f _ r
    | TauF t => Tau (_subst _ t)
    | VisF e k => Vis e (fun r => _subst _ (k r))
    end.

(* McBride's "daemonic" bind: [f] has to be defined at every state [i] *)
Definition bind {I E X Y i} x f := @subst I E X Y f i x.
(*Notation "x ?>= f" := (bind x f) (at level 20).*)

Instance FunctorItree {I} (E : event I I) : Functor (itree E) :=
  Build_Functor _ (fun X Y => @fmap I E X Y).

Instance MonadItree {I} (E : event I I) : Monad (itree E) :=
  Build_Monad _ (fun X => @ret I E X) (fun X Y => @subst I E X Y).