(************************************************************************)
(*  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: Ring_abstract.v 14641 2011-11-06 11:59:10Z herbelin $ *)

Require Import LegacyRing_theory.
Require Import Quote.
Require Import Ring_normalize.

Unset Boxed Definitions.

Section abstract_semi_rings.

Inductive aspolynomial : Type :=
  | ASPvar : index -> aspolynomial
  | ASP0 : aspolynomial
  | ASP1 : aspolynomial
  | ASPplus : aspolynomial -> aspolynomial -> aspolynomial
  | ASPmult : aspolynomial -> aspolynomial -> aspolynomial.

Inductive abstract_sum : Type :=
  | Nil_acs : abstract_sum
  | Cons_acs : varlist -> abstract_sum -> abstract_sum.

Fixpoint abstract_sum_merge (s1:abstract_sum) :
 abstract_sum -> abstract_sum :=
  match s1 with
  | Cons_acs l1 t1 =>
      (fix asm_aux (s2:abstract_sum) : abstract_sum :=
         match s2 with
         | Cons_acs l2 t2 =>
             if varlist_lt l1 l2
             then Cons_acs l1 (abstract_sum_merge t1 s2)
             else Cons_acs l2 (asm_aux t2)
         | Nil_acs => s1
         end)
  | Nil_acs => fun s2 => s2
  end.

Fixpoint abstract_varlist_insert (l1:varlist) (s2:abstract_sum) {struct s2} :
 abstract_sum :=
  match s2 with
  | Cons_acs l2 t2 =>
      if varlist_lt l1 l2
      then Cons_acs l1 s2
      else Cons_acs l2 (abstract_varlist_insert l1 t2)
  | Nil_acs => Cons_acs l1 Nil_acs
  end.

Fixpoint abstract_sum_scalar (l1:varlist) (s2:abstract_sum) {struct s2} :
 abstract_sum :=
  match s2 with
  | Cons_acs l2 t2 =>
      abstract_varlist_insert (varlist_merge l1 l2)
        (abstract_sum_scalar l1 t2)
  | Nil_acs => Nil_acs
  end.

Fixpoint abstract_sum_prod (s1 s2:abstract_sum) {struct s1} : abstract_sum :=
  match s1 with
  | Cons_acs l1 t1 =>
      abstract_sum_merge (abstract_sum_scalar l1 s2)
        (abstract_sum_prod t1 s2)
  | Nil_acs => Nil_acs
  end.

Fixpoint aspolynomial_normalize (p:aspolynomial) : abstract_sum :=
  match p with
  | ASPvar i => Cons_acs (Cons_var i Nil_var) Nil_acs
  | ASP1 => Cons_acs Nil_var Nil_acs
  | ASP0 => Nil_acs
  | ASPplus l r =>
      abstract_sum_merge (aspolynomial_normalize l)
        (aspolynomial_normalize r)
  | ASPmult l r =>
      abstract_sum_prod (aspolynomial_normalize l) (aspolynomial_normalize r)
  end.

Variable A : Type.
Variable Aplus : A -> A -> A.
Variable Amult : A -> A -> A.
Variable Aone : A.
Variable Azero : A.
Variable Aeq : A -> A -> bool.
Variable vm : varmap A.
Variable T : Semi_Ring_Theory Aplus Amult Aone Azero Aeq.

Fixpoint interp_asp (p:aspolynomial) : A :=
  match p with
  | ASPvar i => interp_var Azero vm i
  | ASP0 => Azero
  | ASP1 => Aone
  | ASPplus l r => Aplus (interp_asp l) (interp_asp r)
  | ASPmult l r => Amult (interp_asp l) (interp_asp r)
  end.

(* Local *) Definition iacs_aux :=
              (fix iacs_aux (a:A) (s:abstract_sum) {struct s} : A :=
                 match s with
                 | Nil_acs => a
                 | Cons_acs l t =>
                     Aplus a (iacs_aux (interp_vl Amult Aone Azero vm l) t)
                 end).

Definition interp_acs (s:abstract_sum) : A :=
  match s with
  | Cons_acs l t => iacs_aux (interp_vl Amult Aone Azero vm l) t
  | Nil_acs => Azero
  end.

Hint Resolve (SR_plus_comm T).
Hint Resolve (SR_plus_assoc T).
Hint Resolve (SR_plus_assoc2 T).
Hint Resolve (SR_mult_comm T).
Hint Resolve (SR_mult_assoc T).
Hint Resolve (SR_mult_assoc2 T).
Hint Resolve (SR_plus_zero_left T).
Hint Resolve (SR_plus_zero_left2 T).
Hint Resolve (SR_mult_one_left T).
Hint Resolve (SR_mult_one_left2 T).
Hint Resolve (SR_mult_zero_left T).
Hint Resolve (SR_mult_zero_left2 T).
Hint Resolve (SR_distr_left T).
Hint Resolve (SR_distr_left2 T).
(*Hint Resolve (SR_plus_reg_left T).*)
Hint Resolve (SR_plus_permute T).
Hint Resolve (SR_mult_permute T).
Hint Resolve (SR_distr_right T).
Hint Resolve (SR_distr_right2 T).
Hint Resolve (SR_mult_zero_right T).
Hint Resolve (SR_mult_zero_right2 T).
Hint Resolve (SR_plus_zero_right T).
Hint Resolve (SR_plus_zero_right2 T).
Hint Resolve (SR_mult_one_right T).
Hint Resolve (SR_mult_one_right2 T).
(*Hint Resolve (SR_plus_reg_right T).*)
Hint Resolve refl_equal sym_equal trans_equal.
(*Hints Resolve refl_eqT sym_eqT trans_eqT.*)
Hint Immediate T.

Remark iacs_aux_ok :
 forall (x:A) (s:abstract_sum), iacs_aux x s = Aplus x (interp_acs s).
Proof.
  simple induction s; simpl in |- *; intros.
  trivial.
  reflexivity.
Qed.

Hint Extern 10 (_ = _ :>A) => rewrite iacs_aux_ok: core.

Lemma abstract_varlist_insert_ok :
 forall (l:varlist) (s:abstract_sum),
   interp_acs (abstract_varlist_insert l s) =
   Aplus (interp_vl Amult Aone Azero vm l) (interp_acs s).

  simple induction s.
  trivial.

  simpl in |- *; intros.
  elim (varlist_lt l v); simpl in |- *.
  eauto.
  rewrite iacs_aux_ok.
  rewrite H; auto.

Qed.

Lemma abstract_sum_merge_ok :
 forall x y:abstract_sum,
   interp_acs (abstract_sum_merge x y) = Aplus (interp_acs x) (interp_acs y).

Proof.
  simple induction x.
  trivial.
  simple induction y; intros.

  auto.

  simpl in |- *; elim (varlist_lt v v0); simpl in |- *.
  repeat rewrite iacs_aux_ok.
  rewrite H; simpl in |- *; auto.

  simpl in H0.
  repeat rewrite iacs_aux_ok.
  rewrite H0. simpl in |- *; auto.
Qed.

Lemma abstract_sum_scalar_ok :
 forall (l:varlist) (s:abstract_sum),
   interp_acs (abstract_sum_scalar l s) =
   Amult (interp_vl Amult Aone Azero vm l) (interp_acs s).
Proof.
  simple induction s.
  simpl in |- *; eauto.

  simpl in |- *; intros.
  rewrite iacs_aux_ok.
  rewrite abstract_varlist_insert_ok.
  rewrite H.
  rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T).
  auto.
Qed.

Lemma abstract_sum_prod_ok :
 forall x y:abstract_sum,
   interp_acs (abstract_sum_prod x y) = Amult (interp_acs x) (interp_acs y).

Proof.
  simple induction x.
  intros; simpl in |- *; eauto.

  destruct y as [| v0 a0]; intros.

  simpl in |- *; rewrite H; eauto.

  unfold abstract_sum_prod in |- *; fold abstract_sum_prod in |- *.
  rewrite abstract_sum_merge_ok.
  rewrite abstract_sum_scalar_ok.
  rewrite H; simpl in |- *; auto.
Qed.

Theorem aspolynomial_normalize_ok :
 forall x:aspolynomial, interp_asp x = interp_acs (aspolynomial_normalize x).
Proof.
  simple induction x; simpl in |- *; intros; trivial.
  rewrite abstract_sum_merge_ok.
  rewrite H; rewrite H0; eauto.
  rewrite abstract_sum_prod_ok.
  rewrite H; rewrite H0; eauto.
Qed.

End abstract_semi_rings.

Section abstract_rings.

(* In abstract polynomials there is no constants other
   than 0 and 1. An abstract ring is a ring whose operations plus,
   and mult are not functions but  constructors. In other words,
   when c1 and c2 are closed,  (plus c1 c2) doesn't reduce to a closed
   term. "closed" mean here "without plus and mult". *)

(* this section is not parametrized by a (semi-)ring.
   Nevertheless, they are two different types for semi-rings and rings
   and there will be 2 correction theorems *)

Inductive apolynomial : Type :=
  | APvar : index -> apolynomial
  | AP0 : apolynomial
  | AP1 : apolynomial
  | APplus : apolynomial -> apolynomial -> apolynomial
  | APmult : apolynomial -> apolynomial -> apolynomial
  | APopp : apolynomial -> apolynomial.

(* A canonical "abstract" sum is a list of varlist with the sign "+" or "-".
   Invariant : the list is sorted and there is no varlist is present
   with both signs. +x +x +x -x is forbidden => the canonical form is +x+x *)

Inductive signed_sum : Type :=
  | Nil_varlist : signed_sum
  | Plus_varlist : varlist -> signed_sum -> signed_sum
  | Minus_varlist : varlist -> signed_sum -> signed_sum.

Fixpoint signed_sum_merge (s1:signed_sum) : signed_sum -> signed_sum :=
  match s1 with
  | Plus_varlist l1 t1 =>
      (fix ssm_aux (s2:signed_sum) : signed_sum :=
         match s2 with
         | Plus_varlist l2 t2 =>
             if varlist_lt l1 l2
             then Plus_varlist l1 (signed_sum_merge t1 s2)
             else Plus_varlist l2 (ssm_aux t2)
         | Minus_varlist l2 t2 =>
             if varlist_eq l1 l2
             then signed_sum_merge t1 t2
             else
              if varlist_lt l1 l2
              then Plus_varlist l1 (signed_sum_merge t1 s2)
              else Minus_varlist l2 (ssm_aux t2)
         | Nil_varlist => s1
         end)
  | Minus_varlist l1 t1 =>
      (fix ssm_aux2 (s2:signed_sum) : signed_sum :=
         match s2 with
         | Plus_varlist l2 t2 =>
             if varlist_eq l1 l2
             then signed_sum_merge t1 t2
             else
              if varlist_lt l1 l2
              then Minus_varlist l1 (signed_sum_merge t1 s2)
              else Plus_varlist l2 (ssm_aux2 t2)
         | Minus_varlist l2 t2 =>
             if varlist_lt l1 l2
             then Minus_varlist l1 (signed_sum_merge t1 s2)
             else Minus_varlist l2 (ssm_aux2 t2)
         | Nil_varlist => s1
         end)
  | Nil_varlist => fun s2 => s2
  end.

Fixpoint plus_varlist_insert (l1:varlist) (s2:signed_sum) {struct s2} :
 signed_sum :=
  match s2 with
  | Plus_varlist l2 t2 =>
      if varlist_lt l1 l2
      then Plus_varlist l1 s2
      else Plus_varlist l2 (plus_varlist_insert l1 t2)
  | Minus_varlist l2 t2 =>
      if varlist_eq l1 l2
      then t2
      else
       if varlist_lt l1 l2
       then Plus_varlist l1 s2
       else Minus_varlist l2 (plus_varlist_insert l1 t2)
  | Nil_varlist => Plus_varlist l1 Nil_varlist
  end.

Fixpoint minus_varlist_insert (l1:varlist) (s2:signed_sum) {struct s2} :
 signed_sum :=
  match s2 with
  | Plus_varlist l2 t2 =>
      if varlist_eq l1 l2
      then t2
      else
       if varlist_lt l1 l2
       then Minus_varlist l1 s2
       else Plus_varlist l2 (minus_varlist_insert l1 t2)
  | Minus_varlist l2 t2 =>
      if varlist_lt l1 l2
      then Minus_varlist l1 s2
      else Minus_varlist l2 (minus_varlist_insert l1 t2)
  | Nil_varlist => Minus_varlist l1 Nil_varlist
  end.

Fixpoint signed_sum_opp (s:signed_sum) : signed_sum :=
  match s with
  | Plus_varlist l2 t2 => Minus_varlist l2 (signed_sum_opp t2)
  | Minus_varlist l2 t2 => Plus_varlist l2 (signed_sum_opp t2)
  | Nil_varlist => Nil_varlist
  end.

Fixpoint plus_sum_scalar (l1:varlist) (s2:signed_sum) {struct s2} :
 signed_sum :=
  match s2 with
  | Plus_varlist l2 t2 =>
      plus_varlist_insert (varlist_merge l1 l2) (plus_sum_scalar l1 t2)
  | Minus_varlist l2 t2 =>
      minus_varlist_insert (varlist_merge l1 l2) (plus_sum_scalar l1 t2)
  | Nil_varlist => Nil_varlist
  end.

Fixpoint minus_sum_scalar (l1:varlist) (s2:signed_sum) {struct s2} :
 signed_sum :=
  match s2 with
  | Plus_varlist l2 t2 =>
      minus_varlist_insert (varlist_merge l1 l2) (minus_sum_scalar l1 t2)
  | Minus_varlist l2 t2 =>
      plus_varlist_insert (varlist_merge l1 l2) (minus_sum_scalar l1 t2)
  | Nil_varlist => Nil_varlist
  end.

Fixpoint signed_sum_prod (s1 s2:signed_sum) {struct s1} : signed_sum :=
  match s1 with
  | Plus_varlist l1 t1 =>
      signed_sum_merge (plus_sum_scalar l1 s2) (signed_sum_prod t1 s2)
  | Minus_varlist l1 t1 =>
      signed_sum_merge (minus_sum_scalar l1 s2) (signed_sum_prod t1 s2)
  | Nil_varlist => Nil_varlist
  end.

Fixpoint apolynomial_normalize (p:apolynomial) : signed_sum :=
  match p with
  | APvar i => Plus_varlist (Cons_var i Nil_var) Nil_varlist
  | AP1 => Plus_varlist Nil_var Nil_varlist
  | AP0 => Nil_varlist
  | APplus l r =>
      signed_sum_merge (apolynomial_normalize l) (apolynomial_normalize r)
  | APmult l r =>
      signed_sum_prod (apolynomial_normalize l) (apolynomial_normalize r)
  | APopp q => signed_sum_opp (apolynomial_normalize q)
  end.

Variable A : Type.
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 vm : varmap A.
Variable T : Ring_Theory Aplus Amult Aone Azero Aopp Aeq.

(* Local *) Definition isacs_aux :=
              (fix isacs_aux (a:A) (s:signed_sum) {struct s} : A :=
                 match s with
                 | Nil_varlist => a
                 | Plus_varlist l t =>
                     Aplus a (isacs_aux (interp_vl Amult Aone Azero vm l) t)
                 | Minus_varlist l t =>
                     Aplus a
                       (isacs_aux (Aopp (interp_vl Amult Aone Azero vm l)) t)
                 end).

Definition interp_sacs (s:signed_sum) : A :=
  match s with
  | Plus_varlist l t => isacs_aux (interp_vl Amult Aone Azero vm l) t
  | Minus_varlist l t => isacs_aux (Aopp (interp_vl Amult Aone Azero vm l)) t
  | Nil_varlist => Azero
  end.

Fixpoint interp_ap (p:apolynomial) : A :=
  match p with
  | APvar i => interp_var Azero vm i
  | AP0 => Azero
  | AP1 => Aone
  | APplus l r => Aplus (interp_ap l) (interp_ap r)
  | APmult l r => Amult (interp_ap l) (interp_ap r)
  | APopp q => Aopp (interp_ap q)
  end.

Hint Resolve (Th_plus_comm T).
Hint Resolve (Th_plus_assoc T).
Hint Resolve (Th_plus_assoc2 T).
Hint Resolve (Th_mult_comm T).
Hint Resolve (Th_mult_assoc T).
Hint Resolve (Th_mult_assoc2 T).
Hint Resolve (Th_plus_zero_left T).
Hint Resolve (Th_plus_zero_left2 T).
Hint Resolve (Th_mult_one_left T).
Hint Resolve (Th_mult_one_left2 T).
Hint Resolve (Th_mult_zero_left T).
Hint Resolve (Th_mult_zero_left2 T).
Hint Resolve (Th_distr_left T).
Hint Resolve (Th_distr_left2 T).
(*Hint Resolve (Th_plus_reg_left T).*)
Hint Resolve (Th_plus_permute T).
Hint Resolve (Th_mult_permute T).
Hint Resolve (Th_distr_right T).
Hint Resolve (Th_distr_right2 T).
Hint Resolve (Th_mult_zero_right2 T).
Hint Resolve (Th_plus_zero_right T).
Hint Resolve (Th_plus_zero_right2 T).
Hint Resolve (Th_mult_one_right T).
Hint Resolve (Th_mult_one_right2 T).
(*Hint Resolve (Th_plus_reg_right T).*)
Hint Resolve refl_equal sym_equal trans_equal.
(*Hints Resolve refl_eqT sym_eqT trans_eqT.*)
Hint Immediate T.

Lemma isacs_aux_ok :
 forall (x:A) (s:signed_sum), isacs_aux x s = Aplus x (interp_sacs s).
Proof.
  simple induction s; simpl in |- *; intros.
  trivial.
  reflexivity.
  reflexivity.
Qed.

Hint Extern 10 (_ = _ :>A) => rewrite isacs_aux_ok: core.

Ltac solve1 v v0 H H0 :=
  simpl in |- *; elim (varlist_lt v v0); simpl in |- *; rewrite isacs_aux_ok;
   [ rewrite H; simpl in |- *; auto | simpl in H0; rewrite H0; auto ].

Lemma signed_sum_merge_ok :
 forall x y:signed_sum,
   interp_sacs (signed_sum_merge x y) = Aplus (interp_sacs x) (interp_sacs y).

  simple induction x.
  intro; simpl in |- *; auto.

  simple induction y; intros.

  auto.

  solve1 v v0 H H0.

  simpl in |- *; generalize (varlist_eq_prop v v0).
  elim (varlist_eq v v0); simpl in |- *.

  intro Heq; rewrite (Heq I).
  rewrite H.
  repeat rewrite isacs_aux_ok.
  rewrite (Th_plus_permute T).
  repeat rewrite (Th_plus_assoc T).
  rewrite
   (Th_plus_comm T (Aopp (interp_vl Amult Aone Azero vm v0))
      (interp_vl Amult Aone Azero vm v0)).
  rewrite (Th_opp_def T).
  rewrite (Th_plus_zero_left T).
  reflexivity.

  solve1 v v0 H H0.

  simple induction y; intros.

  auto.

  simpl in |- *; generalize (varlist_eq_prop v v0).
  elim (varlist_eq v v0); simpl in |- *.

  intro Heq; rewrite (Heq I).
  rewrite H.
  repeat rewrite isacs_aux_ok.
  rewrite (Th_plus_permute T).
  repeat rewrite (Th_plus_assoc T).
  rewrite (Th_opp_def T).
  rewrite (Th_plus_zero_left T).
  reflexivity.

  solve1 v v0 H H0.

  solve1 v v0 H H0.

Qed.

Ltac solve2 l v H :=
  elim (varlist_lt l v); simpl in |- *; rewrite isacs_aux_ok;
   [ auto | rewrite H; auto ].

Lemma plus_varlist_insert_ok :
 forall (l:varlist) (s:signed_sum),
   interp_sacs (plus_varlist_insert l s) =
   Aplus (interp_vl Amult Aone Azero vm l) (interp_sacs s).
Proof.

  simple induction s.
  trivial.

  simpl in |- *; intros.
  solve2 l v H.

  simpl in |- *; intros.
  generalize (varlist_eq_prop l v).
  elim (varlist_eq l v); simpl in |- *.

  intro Heq; rewrite (Heq I).
  repeat rewrite isacs_aux_ok.
  repeat rewrite (Th_plus_assoc T).
  rewrite (Th_opp_def T).
  rewrite (Th_plus_zero_left T).
  reflexivity.

  solve2 l v H.

Qed.

Lemma minus_varlist_insert_ok :
 forall (l:varlist) (s:signed_sum),
   interp_sacs (minus_varlist_insert l s) =
   Aplus (Aopp (interp_vl Amult Aone Azero vm l)) (interp_sacs s).
Proof.

  simple induction s.
  trivial.

  simpl in |- *; intros.
  generalize (varlist_eq_prop l v).
  elim (varlist_eq l v); simpl in |- *.

  intro Heq; rewrite (Heq I).
  repeat rewrite isacs_aux_ok.
  repeat rewrite (Th_plus_assoc T).
  rewrite
   (Th_plus_comm T (Aopp (interp_vl Amult Aone Azero vm v))
      (interp_vl Amult Aone Azero vm v)).
  rewrite (Th_opp_def T).
  auto.

  simpl in |- *; intros.
  solve2 l v H.

  simpl in |- *; intros; solve2 l v H.

Qed.

Lemma signed_sum_opp_ok :
 forall s:signed_sum, interp_sacs (signed_sum_opp s) = Aopp (interp_sacs s).
Proof.

  simple induction s; simpl in |- *; intros.

  symmetry  in |- *; apply (Th_opp_zero T).

  repeat rewrite isacs_aux_ok.
  rewrite H.
  rewrite (Th_plus_opp_opp T).
  reflexivity.

  repeat rewrite isacs_aux_ok.
  rewrite H.
  rewrite <- (Th_plus_opp_opp T).
  rewrite (Th_opp_opp T).
  reflexivity.

Qed.

Lemma plus_sum_scalar_ok :
 forall (l:varlist) (s:signed_sum),
   interp_sacs (plus_sum_scalar l s) =
   Amult (interp_vl Amult Aone Azero vm l) (interp_sacs s).
Proof.

  simple induction s.
  trivial.

  simpl in |- *; intros.
  rewrite plus_varlist_insert_ok.
  rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T).
  repeat rewrite isacs_aux_ok.
  rewrite H.
  auto.

  simpl in |- *; intros.
  rewrite minus_varlist_insert_ok.
  repeat rewrite isacs_aux_ok.
  rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T).
  rewrite H.
  rewrite (Th_distr_right T).
  rewrite <- (Th_opp_mult_right T).
  reflexivity.

Qed.

Lemma minus_sum_scalar_ok :
 forall (l:varlist) (s:signed_sum),
   interp_sacs (minus_sum_scalar l s) =
   Aopp (Amult (interp_vl Amult Aone Azero vm l) (interp_sacs s)).
Proof.

  simple induction s; simpl in |- *; intros.

  rewrite (Th_mult_zero_right T); symmetry  in |- *; apply (Th_opp_zero T).

  simpl in |- *; intros.
  rewrite minus_varlist_insert_ok.
  rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T).
  repeat rewrite isacs_aux_ok.
  rewrite H.
  rewrite (Th_distr_right T).
  rewrite (Th_plus_opp_opp T).
  reflexivity.

  simpl in |- *; intros.
  rewrite plus_varlist_insert_ok.
  repeat rewrite isacs_aux_ok.
  rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T).
  rewrite H.
  rewrite (Th_distr_right T).
  rewrite <- (Th_opp_mult_right T).
  rewrite <- (Th_plus_opp_opp T).
  rewrite (Th_opp_opp T).
  reflexivity.

Qed.

Lemma signed_sum_prod_ok :
 forall x y:signed_sum,
   interp_sacs (signed_sum_prod x y) = Amult (interp_sacs x) (interp_sacs y).
Proof.

  simple induction x.

  simpl in |- *; eauto 1.

  intros; simpl in |- *.
  rewrite signed_sum_merge_ok.
  rewrite plus_sum_scalar_ok.
  repeat rewrite isacs_aux_ok.
  rewrite H.
  auto.

  intros; simpl in |- *.
  repeat rewrite isacs_aux_ok.
  rewrite signed_sum_merge_ok.
  rewrite minus_sum_scalar_ok.
  rewrite H.
  rewrite (Th_distr_left T).
  rewrite (Th_opp_mult_left T).
  reflexivity.

Qed.

Theorem apolynomial_normalize_ok :
 forall p:apolynomial, interp_sacs (apolynomial_normalize p) = interp_ap p.
Proof.
  simple induction p; simpl in |- *; auto 1.
  intros.
    rewrite signed_sum_merge_ok.
    rewrite H; rewrite H0; reflexivity.
  intros.
    rewrite signed_sum_prod_ok.
    rewrite H; rewrite H0; reflexivity.
  intros.
    rewrite signed_sum_opp_ok.
    rewrite H; reflexivity.
Qed.

End abstract_rings.


(** * Well-founded relation on [parse_of] *)
Require Import Coq.Strings.String Coq.Lists.List Coq.Program.Program Coq.Program.Wf Coq.Arith.Wf_nat Coq.Relations.Relation_Definitions.
Require Import ParsingParses.Parsers.ContextFreeGrammar.

Section rel.
  Context {CharType} {String : string_like CharType} {G : grammar CharType}.

  Section size.

    Definition size_of_parse_item'
               (size_of_parse : forall {str pats} (p : parse_of String G str pats), nat)
               {str it} (p : parse_of_item String G str it) : nat
      := match p with
           | ParseTerminal _ => 0
           | ParseNonTerminal _ _ p' => S (size_of_parse p')
         end.

    Fixpoint size_of_parse {str pats} (p : parse_of String G str pats) : nat
      := match p with
           | ParseHead _ _ _ p' => S (size_of_parse_production p')
           | ParseTail _ _ _ p' => S (size_of_parse p')
         end
    with size_of_parse_production {str pat} (p : parse_of_production String G str pat) : nat
         := match p with
              | ParseProductionNil => 0
              | ParseProductionCons _ _ _ _ p' p''
                => S (size_of_parse_item' (@size_of_parse) p' + size_of_parse_production p'')
            end.

    Definition size_of_parse_item
               {str it} (p : parse_of_item String G str it) : nat
      := @size_of_parse_item' (@size_of_parse) str it p.
  End size.

  Definition parse_of_lt {str pats} : relation (parse_of String G str pats)
    := ltof _ size_of_parse.
  Definition parse_of_production_lt {str pat} : relation (parse_of_production String G str pat)
    := ltof _ size_of_parse_production.
  Definition parse_of_item_lt {str it} : relation (parse_of_item String G str it)
    := ltof _ size_of_parse_item.

  Definition parse_of_wf {str pats} : well_founded (@parse_of_lt str pats)
    := well_founded_ltof _ _.
  Definition parse_of_production_wf {str pat} : well_founded (@parse_of_production_lt str pat)
    := well_founded_ltof _ _.
  Definition parse_of_item_wf {str it} : well_founded (@parse_of_item_lt str it)
    := well_founded_ltof _ _.
End rel.


(***************************************************************************)
(* Formalization of the Chou, Gao and Zhang's decision procedure.          *)
(* Julien Narboux (Julien@narboux.fr)                                      *)
(* LIX/INRIA FUTURS 2004-2006                                              *)
(* University of Strasbourg 2008                                           *)
(***************************************************************************)

Require Export pythagoras_difference_lemmas.
Require Export ratios_elimination_lemmas.

Theorem elim_py_on_parallel_d_middle :
 forall (A B W U V Y : Point) (r : F),
 on_parallel_d Y W U V r ->
 Py A Y B = Py A W B + r* (Py A V B - Py A U B  + 2* Py W U V  )-r*(1-r)*(Py U V U).
Proof.
intros.
cases_equality W Y.

subst.
unfold on_parallel_d in H.
use H.
basic_simpl.
symmetry in H3.
assert (r= 0).
IsoleVar r H3.
rewrite H3.
field;auto with Geom.
auto with Geom.
rewrite H.
basic_simpl;auto.

assert (parallel W Y U V).
unfold on_parallel_d in H.
use H.
auto with Geom.
elim ( on_line_dex_spec_strong_f W Y U V H1 H0).
intros S HS.
use HS.

assert (Py A Y B =
       W ** Y / W ** S * Py A S B + Y ** S / W ** S * Py A W B -
       W ** Y / W ** S * (Y ** S / W ** S) * Py W S W).
apply  (l3_5_py A B W S Y).
unfold not;intro;subst.
basic_simpl.
assert (U=V) by auto with Geom.
unfold on_parallel_d in *.
use H;auto.
auto with Geom.

assert (W ** Y / W ** S = r).
unfold on_parallel_d in *.
use H.
rewrite H9.
rewrite H4.
field.
auto with Geom.
rewrite H6 in H3.
assert ( Y ** S / W ** S  = 1 - r).
unfold on_parallel_d in *.
use H.
replace (Y**S) with (Y**W + W**S) by auto with Geom.
uniformize_dir_seg.
rewrite H10.
rewrite H4.
field;auto with Geom.
rewrite H7 in H3.
assert (weak_3_parallelogram U V S W) by auto with Geom.

assert  (T:= l_27_c U V S W A B H8).

revert T.
revert H3.
uniformize_pys.
intros.
IsoleVar (Py A S B) T.
rewrite T in H3.
rewrite H3.
replace (Py W S W) with (Py U V U).
2:unfold Py;basic_simpl;uniformize_dir_seg;rewrite H4;ring.
ring.
Qed.

Theorem elim_py_on_parallel_d_right :
 forall (A B W U V Y : Point) (r : F),
 on_parallel_d Y W U V r ->
 Py A B Y = Py A B W + r  * (Py A B V - Py A B U).
Proof.
intros.

cases_equality W Y.
subst.
unfold on_parallel_d in H.
use H.
basic_simpl.
symmetry in H3.
assert (r= 0).
IsoleVar r H3.
rewrite H3.
field;auto with Geom.
auto with Geom.
rewrite H.
basic_simpl;auto.

assert (parallel W Y U V).
unfold on_parallel_d in H.
use H.
auto with Geom.
elim ( on_line_dex_spec_strong_f W Y U V H1 H0).
intros S HS.
use HS.
assert (Py A B Y = W ** Y / W ** S * Py A B S + Y ** S / W ** S * Py A B W).
apply (l_28_b A B W S Y).
 intro;subst.
 basic_simpl.
 assert (U=V) by auto with Geom.
 subst.
 unfold on_parallel_d in H.
 intuition.
 auto with Geom.
unfold on_parallel_d in H.
use H.
assert (W ** Y / W ** S = r).
rewrite H9.
rewrite H4.
field.
auto with Geom.
rewrite H in H3.
assert ( Y ** S / W ** S  = 1 - r).
replace (Y**S) with (Y**W + W**S) by auto with Geom.
uniformize_dir_seg.
rewrite H9.
rewrite H4.
field;auto with Geom.
rewrite H7 in H3.

assert (weak_3_parallelogram U V S W) by auto with Geom.

assert (T:= l_27_a U V S W B A H10).
revert T.
revert H3.
uniformize_pys.
intros.
IsoleVar (Py S B A) T.
rewrite T in H3.
rewrite H3.
ring.
Qed.

Theorem elim_py_on_parallel_d_left_right :
 forall (B W U V Y : Point) (r : F),
 on_parallel_d Y W U V r ->
 Py Y B Y = Py W B W + r * r * Py V B V - 2 * r * r * Py V B U + r * r * Py U B U +
2 * r * Py V B W - 2 * r * Py U B W.
Proof.
intros.
rewrite (elim_py_on_parallel_d_right Y B W U V Y r H).
rewrite pyth_sym.
replace ( Py Y B V) with (Py V B Y) by (apply pyth_sym;auto).
replace ( Py Y B U) with (Py U B Y) by (apply pyth_sym;auto).
rewrite (elim_py_on_parallel_d_right W B W  U V Y r H).
rewrite (elim_py_on_parallel_d_right V B W  U V Y r H).
rewrite (elim_py_on_parallel_d_right U B W  U V Y r H).
replace (Py W B U) with (Py U B W) by auto with Geom.
replace (Py W B V) with (Py V B W) by auto with Geom.
replace (Py U B V) with (Py V B U) by auto with Geom.
ring.
Qed.

Theorem elim_py_on_line_d_right :
 forall (A B P Q Y : Point) (f : F),
 on_line_d Y P Q f ->
 Py A B Y = f * Py A B Q + (1 - f) * Py A B P.
Proof.
intros.
apply -> on_line_d_iff_on_parallel_d in H.
rewrite (elim_py_on_parallel_d_right A B P Q P Y (0-f) H).
ring.
Qed.

Theorem elim_py_on_line_d_left_right :
 forall (A P Q Y : Point) (f : F),
 on_line_d Y P Q f -> Py Y A Y = f* (f * Py Q A Q + (1 - f) * Py Q A P) +
(1 - f) * (f * Py P A Q + (1 - f) * Py P A P) .
Proof.
intros.
rewrite (elim_py_on_line_d_right Y A P Q Y f H).
rewrite pyth_sym.
replace ( Py Y A P) with (Py P A Y) by (apply pyth_sym;auto).
rewrite (elim_py_on_line_d_right Q A P Q Y f H).
rewrite (elim_py_on_line_d_right P A P Q Y f H).
auto.
Qed.

Lemma elim_py_midpoint_left_right : forall A B C M : Point,
on_line_d M B C (1 / 2) ->
       Py M A M = - (1)/(2+2) * (Py B C B - 2* Py A C A - 2 *Py A B A).
Proof.
intros.
rewrite (elim_py_on_line_d_left_right A B C M (1/2)) by auto.
field_simplify.
unfold Py.
basic_simpl.
uniformize_dir_seg.
field_simplify_eq.
auto.
solve_conds.
solve_conds.
solve_conds.
Qed.

Theorem elim_py_on_line_right :
 forall A B P Q Y : Point,
 on_line Y P Q ->
 Py A B Y = P ** Y / P ** Q * Py A B Q + (1 - P ** Y / P ** Q) * Py A B P.
Proof with Geometry.
intros.
assert (on_line_d Y P Q (P ** Y / P ** Q)).
apply on_line_to_on_line_d...
apply elim_py_on_line_d_right...
Qed.

Theorem elim_py_on_line_d_middle :
 forall A B P Q Y r,
 on_line_d Y P Q r ->
 Py A Y B = - Py A P B * r + Py A P B + r * r * Py Q P Q + r * Py A Q B- r * Py Q P Q .
Proof.
intros.
apply -> on_line_d_iff_on_parallel_d in H.
rewrite (elim_py_on_parallel_d_middle A B P Q P Y (0-r) H).
replace (Py P Q P) with (Py Q P Q) by auto with Geom.
ring.
Qed.

(* shows that we need A<>B in elim_py_on_line_d_middle
Lemma essai : forall A P Q Y : Point, forall r:F,
 r<> 0 -> on_line_d Y P Q r -> False.
Proof.
intros.
assert (Py A Y A = Py A Y A).
reflexivity.
rewrite (elim_py_on_line_d_middle A A P Q Y r) in H1 at 1.
2:auto.
replace (Py A Y A) with (Py Y A Y) in H1 by auto with Geom.
rewrite (elim_py_on_line_d_left_right A P Q Y r) in H1 by auto.
unfold Py in *.
uniformize_dir_seg.
basic_simpl.
field_simplify_eq in H1.
set (
- (2) * A ** P * A ** P * r + 2 * A ** P * A ** P +
2 * r * r * P ** Q * P ** Q) in H1.
set (2 * r * A ** Q * A ** Q) in H1.
assert (f + f0 - (f  + f0) = f - 2 * r * P ** Q * P ** Q + f0 - (f  + f0)).
rewrite H1.
ring.
ring_simplify in H2.
assert (P**Q <> 0).
unfold on_line_d in H0.
use H0.
auto with Geom.
assert (P ** Q * P ** Q <> 0).
apply nonzeromult; auto.
cut (r<>0).
intro.
assert (- (2) * r * P ** Q * P ** Q <> 0).
repeat (apply nonzeromult);
auto with Geom.
rewrite <- H2 in H6.
intuition.
auto.
Qed.
*)

Theorem elim_py_on_line_middle :
 forall A B P Q Y : Point,
 on_line Y P Q ->
 Py A Y B = Py A P B + P ** Y / Q ** P * (Py A P B - Py A Q B + 2* Py Q P Q) -
P ** Y / Q ** P * (1 - P ** Y / Q ** P) * Py Q P Q.
Proof.
intros.
apply -> on_line_iff_on_parallel in H.
apply on_parallel_to_on_parallel_d in H.
rewrite (elim_py_on_parallel_d_middle A B P Q P Y (P ** Y / Q ** P) H).
replace (Py P Q P) with (Py Q P Q) by auto with Geom.
ring.
Qed.

Theorem elim_py_inter_ll_right :
 forall A B P Q U V Y : Point,
 inter_ll Y P Q U V ->
 Py A B Y = 1 / S4 P U Q V * (S P U V * Py A B Q + S Q V U * Py A B P).
Proof.
intros.
unfold inter_ll in H.
decompose [and] H; clear H.
assert (P<>Q).
eauto with Geom.
rewrite (l_28_b A B P Q Y).
3:auto with Geom.
replace (Y ** Q / P ** Q) with (- (Q ** Y/ P**Q )).
rewrite (co_side_bis U V P Q Y H3) by auto with Geom.
replace (P ** Y / P ** Q) with (- (P ** Y / Q ** P)).
rewrite (co_side_bis V U Q P Y).
replace (S4 Q V P U) with (S4 P U Q V) by (auto with Geom).
uniformize_signed_areas.
field.
auto with Geom.
unfold not;intro.
assert (parallel P Q U V).
auto with Geom.
intuition.
auto with Geom.
auto with Geom.
rewrite dirseg_4 at 1.
ring.
auto with Geom.
rewrite dirseg_3 at 1.
ring.
auto with Geom.
auto.
Qed.

Theorem elim_py_inter_ll_right_invariant :
 forall A B P Q U V Y : Point,
 inter_ll Y P Q U V -> S4 P U Q V <> 0.
Proof.
intros.
unfold inter_ll, parallel in H.
intuition.
Qed.

Theorem elim_py_inter_ll_left_right :
 forall B P Q U V Y : Point,
 inter_ll Y P Q U V ->
 Py Y B Y = 1 / S4 P U Q V *
(S P U V * (1 / S4 P U Q V * (S P U V * Py Q B Q + S Q V U * Py Q B P)) +
 S Q V U * (1 / S4 P U Q V * (S P U V * Py P B Q + S Q V U * Py P B P))).
Proof.
intros.
rewrite (elim_py_inter_ll_right Y B P Q U V Y H).
replace (Py Y B P) with (Py P B Y) by auto with Geom.
replace (Py Y B Q) with (Py Q B Y) by auto with Geom.
rewrite (elim_py_inter_ll_right Q B P Q U V Y H).
rewrite (elim_py_inter_ll_right P B P Q U V Y H).
auto.
Qed.

Theorem elim_py_inter_ll_left_right_invariant :
 forall B P Q U V Y : Point,
 inter_ll Y P Q U V -> S4 P U Q V <> 0.
Proof.
intros.
unfold inter_ll, parallel in H.
intuition.
Qed.

Theorem elim_py_inter_ll_middle :
 forall A B P Q U V Y : Point,
 inter_ll Y P Q U V ->
 Py A Y B = - (S P V U / S4 P U Q V) * Py A Q B + - (S Q U V / S4 P U Q V) * Py A P B -
- (S P V U / S4 P U Q V) * - (S Q U V / S4 P U Q V) * Py P Q P.
Proof.
intros.
unfold inter_ll in H.
decompose [and] H; clear H.
assert (P<>Q).
eauto with Geom.
rewrite (l3_5_py A B P Q Y) by auto.
replace (Y ** Q / P ** Q) with (- (Q ** Y/ P**Q )).
rewrite (co_side_bis U V P Q Y H3) by auto with Geom.
replace (P ** Y / P ** Q) with (- (P ** Y / Q ** P)).
rewrite (co_side_bis V U Q P Y).
replace (S4 Q V P U) with (S4  P U Q V) by auto with Geom.
auto.
intro.
assert (parallel P Q U V); auto with Geom.
auto with Geom.
auto with Geom.
rewrite dirseg_4 at 1.
ring.
auto with Geom.
rewrite dirseg_3 at 1.
ring.
auto with Geom.
Qed.

Theorem elim_py_inter_ll_middle_invariant :
 forall A B P Q U V Y : Point,
 inter_ll Y P Q U V -> S4  P U Q V <> 0.
Proof.
exact elim_py_inter_ll_right_invariant.
Qed.

Theorem elim_py_on_foot_right :
 forall A B P U V Y : Point,
 on_foot Y P U V ->
 Py A B Y = (Py P U V * Py A B V + Py P V U * Py A B U) / (Py U V U).
Proof.
intros.
unfold on_foot in *.
use H.
rewrite (l_28_b A B U V) by auto with Geom.
assert (U**Y/U**V = Py P U V / Py U V U).
apply l_24_c_on_foot.
unfold on_foot;auto.
assert (V**Y/V**U = Py P V U / Py V U V).
apply l_24_c_on_foot.
unfold on_foot;auto with Geom.
replace (Y ** V / U ** V) with (V**Y/V**U) by auto with Geom.
rewrite H.
rewrite H1.
replace (Py V U V) with (Py U V U) by auto with Geom.
field;auto with Geom.
Qed.

Theorem elim_py_on_foot_left_right :
 forall B P U V Y : Point,
 on_foot Y P U V ->
 Py Y B Y =
 (Py P U V * Py P U V * Py V B V + Py P U V * Py P V U * Py V B U +
 Py P U V * Py P V U * Py U B V + Py P V U * Py P V U * Py U B U) / (Py U V U *  Py U V U).
Proof.
intros.
rewrite (elim_py_on_foot_right Y B P U V Y H).
replace (Py Y B V) with (Py V B Y) by auto with Geom.
replace (Py Y B U) with (Py U B Y) by auto with Geom.
rewrite (elim_py_on_foot_right V B P U V Y H).
rewrite (elim_py_on_foot_right U B P U V Y H).
field.
unfold on_foot in H.
use H.
unfold Py.
basic_simpl.
uniformize_dir_seg.
replace (U ** V * U ** V + - U ** V * - U ** V) with (2* U ** V * U ** V) by ring.
repeat (apply nonzeromult);auto with Geom.
Qed.

Theorem elim_py_on_foot_left_right_invariant :
forall B P U V Y : Point,
 on_foot Y P U V -> (Py U V U *  Py U V U) <> 0.
Proof.
intros.
unfold on_foot in H.
use H.
unfold Py.
basic_simpl.
uniformize_dir_seg.
replace (U ** V * U ** V + - U ** V * - U ** V) with (2* U ** V * U ** V) by ring.
repeat (apply nonzeromult);auto with Geom.
Qed.

Theorem elim_py_on_foot_right_invariant :
 forall A B P U V Y : Point,
 on_foot Y P U V -> Py U V U <> 0.
Proof.
intros.
unfold on_foot in *.
unfold Py.
uniformize_dir_seg.
basic_simpl.
 replace (U ** V * U ** V + U ** V * U ** V) with
(2 * U ** V * U ** V) by ring.
decompose [and] H; clear H.
repeat apply nonzeromult;auto with Geom.
Qed.

Theorem elim_py_on_foot_middle :
 forall A B P U V Y : Point,
 on_foot Y P U V ->
 Py A Y B = (Py P U V / Py U V U) * Py A V B +
                  (Py P V U) / (Py  U V U) * Py A U B -
                  (Py P U V * Py P V U) / Py U V U.
Proof.
intros.
rewrite (l3_5_py A B U V) by
 (unfold on_foot in  *;intuition).
assert (U**Y/U**V = Py P U V / Py U V U).
apply l_24_c_on_foot.
unfold on_foot;auto.
assert (V**Y/V**U = Py P V U / Py V U V).
apply l_24_c_on_foot.
unfold on_foot in *;intuition.
rewrite H0.
unfold on_foot in *;use H.
replace (Y ** V / U ** V) with (V**Y/V**U) by auto with Geom.
rewrite H1.
replace (Py V U V) with (Py U V U).
field.
auto with Geom.
auto with Geom.
Qed.

Theorem elim_py_on_foot_middle_invariant :
 forall A B P U V Y : Point,
 on_foot Y P U V -> Py U V U <> 0.
Proof.
exact elim_py_on_foot_right_invariant.
Qed.

Theorem elim_py_on_perp_d_right :
forall A B P Q Y : Point, forall r: F,
on_perp_d Y P Q r ->
Py A B Y = Py A B P - (2+2) * r * S4 P A Q B.
Proof.
intros.
unfold on_perp_d in H.
use H.
assert (P<>Y).
intro;subst;basic_simpl.
IsoleVar (Py Y Q Y) H1.
replace (0/r) with 0 in H1 by (field;auto with Geom).
intuition.

elim (proj_ex A P Y H).
intros A1 HA1.
elim (proj_ex B P Y H).
intros B1 HB1.

assert (Py4 B P A Y / Py Y P Y = S4 P A Q B / S P Q Y).

replace (Py4 B P A Y) with (Py4 B1 P A1 Y).

assert (parallel A1 B1 P Y).
   unfold on_foot in *.
   use HA1.
   use HB1.
   cut (parallel Y P A1 B1).
   auto with Geom.
   unfold parallel, S4.
   unfold Col in *.
   uniformize_signed_areas.
   rewrite H6, H9.
   ring.

replace (Py Y P Y) with (Py P Y P) by auto with Geom.
rewrite <- (l3_10b A1 B1 P Y) by assumption.

replace (A1 ** B1 / P ** Y) with ((S4 P A1 Q B1) / (S P Q Y)).
replace (S4 P A1 Q B1) with (S4 P A Q B).
auto.
unfold S4.
unfold on_foot in *.
use HA1.
use HB1.

assert (parallel P Q B B1).
apply (perp_perp_para P Q Y P B B1);auto with Geom.
assert (parallel P Q A A1).
apply (perp_perp_para P Q Y P A A1);auto with Geom.
unfold parallel, S4 in *.
uniformize_signed_areas.
IsoleVar (S P A Q) H12;rewrite H12.
IsoleVar (S P B Q) H9;rewrite H9.
ring.
unfold S4.
replace (A1**B1) with (A1**P + P**B1).
2:apply chasles.
assert (~ (Col P Q Y)).
intro.
rewrite H5 in H1.
basic_simpl.
IsoleVar r H1.
replace (0/ Py P Q P) with 0 in H1.
intuition.
field;auto with Geom.
auto with Geom.

replace ((A1 ** P + P ** B1) / P ** Y) with (- (P**A1 / P**Y) + P ** B1/ P**Y).
2:uniformize_dir_seg;field;auto with Geom.
rewrite (A6 P A1 Y Q H).
rewrite (A6 P B1 Y Q H).
uniformize_signed_areas.
field;solve_conds;auto with Geom.
auto with Geom.
unfold on_foot in *.
use HA1.
use HB1.
auto with Geom.
auto with Geom.
unfold on_foot in *.
use HA1.
use HB1.
auto with Geom.
unfold on_foot in *.
use HA1.
use HB1.
assert (Col P A1 B1).
apply (col_trans_1 P Y A1 B1 H11);auto with Geom.
auto with Geom.

unfold Py4.
unfold on_foot in *.
use HA1.
use HB1.
unfold perp, Py4 in *.
IsoleVar (Py A1 P Y) H3.
IsoleVar (Py B1 P Y) H5.
rewrite H3, H5.
ring.

(* ** *)
assert (T:=herron_qin P Q Y).
unfold perp, Py4 in H2.
basic_simpl.
replace (Py Q P Y) with 0 in T
 by (replace (Py Q P Y) with (Py Y P Q) by auto with Geom;auto).
basic_simpl.
assert (Py Y P Y = (2*2)*r* S P Q Y).
IsoleVar r H1.
rewrite H1.
field_simplify_eq.
2:auto with Geom.
2:auto with Geom.
replace (2 * (2 * (2 * 2)) * S P Q Y * S P Q Y) with
        ((2 * (2 * (2 * 2))) * (S P Q Y * S P Q Y)) by ring.
rewrite T.
uniformize_pys.
field;solve_conds.
replace (Py A B Y) with (Py A B P - Py4 B P A Y).
IsoleVar (Py4 B P A Y) H3.
rewrite H3.
rewrite H5.
field.
2:auto with Geom.
intro.
assert (Col Y P Q) by auto with Geom.
rewrite col_pyth in H2 by assumption.
IsoleVar (P**Q) H2.
2:solve_conds;auto with Geom.
replace (0 / (2 * P ** Y)) with (0) in H2.
2:field;solve_conds;auto with Geom.
assert (P=Q) by auto with Geom.
intuition.

replace (Py4 B P A Y) with (- Py4 Y B P A) by auto with Geom.

unfold  Py4.
uniformize_pys.
ring.
Qed.

Theorem elim_py_on_perp_d_middle :
forall A B U V Y : Point, forall r: F,
on_perp_d Y U V r ->
Py A Y B = Py A U B + r * r * Py U V U - (2+2)*r*(S A U V + S B U V).
Proof.
intros.
rename U into P.
rename V into Q.
replace (Py A Y B) with (Py A P B - Py A P Y - Py B P Y + Py Y P Y)
       by (unfold Py; uniformize_dir_seg;basic_simpl;ring).
rewrite (elim_py_on_perp_d_right A P P Q Y r H).
rewrite (elim_py_on_perp_d_right B P P Q Y r H).
basic_simpl.
unfold on_perp_d in H.
use H.
assert (T:=herron_qin P Q Y).
unfold perp in H2.
unfold Py4 in H2.
basic_simpl.
replace (Py Q P Y) with (Py Y P Q) in * by auto with Geom.
rewrite H2 in T.
basic_simpl.
replace (Py P Y P) with (Py Y P Y) in  * by auto with Geom.
IsoleVar (Py Y P Y) T.
2:auto with Geom.
IsoleVar r H1.
rewrite H1.
rewrite T.
uniformize_signed_areas.
field;solve_conds.
auto with field_hints.
solve_conds.
auto with field_hints.
Qed.

(* elimination of area for euclidean constructions *)

Theorem elim_area_on_perp_d :
forall A B U V Y : Point, forall r: F,
on_perp_d Y U V r ->
S A B Y = S A B U - r / (2+2)  * Py4 U A V B.
Proof.
intros A B U V Y r.
intros.

assert (S A B Y = S A B U + S A U Y + S U B Y) by auto with Geom.
rewrite H0.

assert (Hyuv :~ Col Y U V).
unfold on_perp_d in H.
use H.

intro.
assert (Col U V Y) by auto with Geom.
rewrite H4 in H2.
basic_simpl.
IsoleVar r H2.
replace (0 / Py U V U) with 0 in H2.
2:field;auto.
2:auto with Geom.
intuition.

elim (proj_ex A U V).
intros A1 HA1.
2:unfold on_perp_d in H;intuition.

assert (S U A Y = Py A U V / Py U V U * S U V Y).

assert (S U A Y / S U  V Y = S U A1 Y / S U V Y).
replace (S U A Y) with (S U A1 Y).
auto.

unfold on_foot in *.
use HA1.
unfold on_perp_d in *.
use H.
assert (parallel A1 A Y U).
apply (perp_perp_para A1 A U V Y U);auto with Geom.
assert (parallel Y U A1 A) by auto with Geom.
unfold parallel, S4 in H7.
uniformize_signed_areas.
IsoleVar (S Y A1 U) H7.
rewrite H7.
ring.

assert ( S U A1 Y / S U V Y = U**A1 / U**V).

rewrite (A6 U A1 V Y).
uniformize_signed_areas.
auto with Geom.
unfold on_perp_d in H.
use H;auto.
unfold on_perp_d in H.
use H.
auto.
unfold on_foot in *.
use HA1.
auto with Geom.

assert (U**A1 / U**V = Py A1 U V / Py U V U).
rewrite col_pyth.
unfold Py.
uniformize_dir_seg.
basic_simpl.
replace (U ** V * U ** V + U ** V * U ** V) with (2*U**V*U**V) by ring.
field;solve_conds;unfold on_perp_d in *;auto with Geom.
unfold on_perp_d in *;use H;auto with Geom.
unfold on_foot in *;use HA1;auto with Geom.
assert (Py A1 U V = Py A U V).

unfold on_foot in *.
use HA1.
unfold perp, Py4 in H4.
IsoleVar (Py A1 U V) H4.
rewrite H4.
ring.

rewrite H2 in H1.
rewrite H3 in H1.
rewrite H4 in H1.
IsoleVar (S U A Y) H1.
rewrite H1.
field.
unfold on_perp_d in *.
intuition.

auto with Geom.

(* cases B *)
assert (S U B Y = Py B U V / Py U V U * S U V Y).

elim (proj_ex B U V).
intros B1 HB1.
2:unfold on_perp_d in H;intuition.

assert (S U B Y / S U  V Y = S U B1 Y / S U V Y).
replace (S U B Y) with (S U B1 Y).
auto.

unfold on_foot in *.
use HB1.
unfold on_perp_d in *.
use H.
assert (parallel B1 B Y U).
apply (perp_perp_para B1 B U V Y U);auto with Geom.
assert (parallel Y U B1 B) by auto with Geom.
unfold parallel, S4 in H8.
uniformize_signed_areas.
IsoleVar (S Y B1 U) H8.
rewrite H8.
ring.

assert ( S U B1 Y / S U V Y = U**B1 / U**V).

rewrite (A6 U B1 V Y).
uniformize_signed_areas.
auto with Geom.
unfold on_perp_d in H.
use H;auto.
unfold on_perp_d in H.
use H.
auto.
unfold on_foot in *.
use HB1.
auto with Geom.

assert (U**B1 / U**V = Py B1 U V / Py U V U).
rewrite col_pyth.
unfold Py.
uniformize_dir_seg.
basic_simpl.
replace (U ** V * U ** V + U ** V * U ** V) with (2*U**V*U**V) by ring.
field;solve_conds;unfold on_perp_d in *;auto with Geom.
unfold on_perp_d in *;use H;auto with Geom.
unfold on_foot in *;use HB1;auto with Geom.
assert (Py B1 U V = Py B U V).

unfold on_foot in *.
use HB1.
unfold perp, Py4 in H5.
IsoleVar (Py B1 U V) H5.
rewrite H5.
ring.

rewrite H3 in H2.
rewrite H4 in H2.
rewrite H5 in H2.
IsoleVar (S U B Y) H2.
rewrite H2.
field.
unfold on_perp_d in *.
intuition.

auto with Geom.

(* *** *)
assert (S U A Y = r / (2+2) * Py A U V).
rewrite H1.
unfold on_perp_d in H.
use H.
IsoleVar  (S U V Y) H4.
rewrite H4.
field;solve_conds.
auto with Geom.
replace (2+2) with (2*2) by ring.
solve_conds.
assert (S U B Y = r / (2+2) * Py B U V).
unfold on_perp_d in H.
use H.
rewrite H2.
IsoleVar  (S U V Y) H5.
rewrite H5.
field;solve_conds.
auto with Geom.
replace (2+2) with (2*2) by ring.
solve_conds.

replace (S A U Y) with (- S U A Y) by auto with Geom.
rewrite H3, H4.
replace (Py4 U A V B) with( Py A U V - Py B U V).
ring.
symmetry.
replace ( Py A U V - Py B U V) with  (Py4 A U B V) by auto.
auto with Geom.
Qed.

Theorem elim_py_on_perp_d_left_right :
forall B U V Y : Point, forall r: F,
on_perp_d Y U V r ->
Py Y B Y = Py U B U - (2 + 2) * r * S U V B -
(2 + 2) * r * (0 - r / (2 + 2) * Py U V U + S U V B).
Proof.
intros.
rewrite (elim_py_on_perp_d_right Y B U V Y r H).
replace (Py Y B U) with (Py U B Y) by auto with Geom.
rewrite (elim_py_on_perp_d_right U B U V Y r H).
unfold S4.
basic_simpl.
replace (S U Y V) with (S V U Y) by auto with Geom.
rewrite (elim_area_on_perp_d V U U V Y r H).
unfold Py4.
basic_simpl.
auto.
Qed.

Theorem elim_area_on_foot :
forall A B P U V Y : Point,
 on_foot Y P U V ->
 S A B Y = (Py P U V * S A B V + Py P V U * S A B U) / (Py U V U).
Proof.
intros.
unfold on_foot in *.
use H.
replace (S A B Y) with (S Y A B) by auto with Geom.
rewrite (l2_9 A B U V Y) by auto with Geom.
assert (U**Y/U**V = Py P U V / Py U V U).
apply l_24_c_on_foot.
unfold on_foot;auto.
assert (V**Y/V**U = Py P V U / Py V U V).
apply l_24_c_on_foot.
unfold on_foot;auto with Geom.
replace (Y ** V / U ** V) with (V**Y/V**U) by auto with Geom.
rewrite H.
rewrite H1.
replace (Py V U V) with (Py U V U) by auto with Geom.
uniformize_signed_areas.
field;auto with Geom.
Qed.

Theorem elim_area_on_foot_invariant :
forall A B P U V Y : Point,
 on_foot Y P U V ->
 Py U V U <> 0.
Proof.
exact elim_py_on_foot_right_invariant.
Qed.

(* elimination of ratios for euclidean constructions *)
(* the condition A<>Y is required *)

Theorem elim_ratio_on_foot_a :
forall Y P U V A C D : Point,
on_foot Y P U V ->
Col A U V ->
parallel A Y C D ->
C <> D ->
A <> Y ->
A**Y / C**D = Py4 P C A D / Py C D C.
Proof.
intros.

cases_equality A U.
subst U.
cases_equality A V.
subst V.
unfold on_foot in H.
use H;intuition.
clear H0.
unfold on_foot in H.
use H.

pose (d := C**D/A**V).
assert ({T : Point | Col T A V /\ A ** T = d * A**V}).
apply (on_line_dex A V);assumption.
elim H;intros T HT; clear H.
use HT.
unfold d in H5.

assert (A**T = C**D).
rewrite H5.
field;auto with Geom.
rewrite <- H8.
clear H5.
rewrite ( l_24_b A T P Y).
replace (2 * A ** T * A ** T) with (Py A T A)
 by (unfold Py;basic_simpl;uniformize_dir_seg;ring).
replace (Py A T A) with (Py C D C) by
(unfold Py;
uniformize_dir_seg;
rewrite H8;
ring).
replace (Py P A T) with (Py4 P C A D).
auto.
rewrite (l3_8_a A T D C P);auto.

apply parallel_side_eq_weak_weak_weak_para;auto with Geom.
assert (Col A Y T).
apply (col_trans_1 A V Y T H4); auto with Geom.

cut ( parallel C D A T).
auto with Geom.
apply (parallel_transitivity C D A Y A T);auto with Geom.
unfold parallel, S4;basic_simpl.
auto.

apply (col_trans_1 A V Y T H7);auto with Geom.

apply (perp_para_perp A V P Y A T); auto.
auto with Geom.
unfold parallel, S4;basic_simpl.
assert (Col A V T);auto with Geom;auto.

unfold not;intro.
subst.
basic_simpl.
assert (C=D).
auto with Geom.
intuition.

(* case A<>U *)

unfold on_foot in H.
use H.
pose (d := C**D/A**U).
assert ({T : Point | Col T A U /\ A ** T = d * A**U}).
apply (on_line_dex A U);assumption.
elim H;intros T HT; clear H.
use HT.
unfold d in H6.

assert (A**T = C**D).
rewrite H6.
field;auto with Geom.
rewrite <- H9.
clear H6.
rewrite ( l_24_b A T P Y).
replace (2 * A ** T * A ** T) with (Py A T A)
 by (unfold Py;basic_simpl;uniformize_dir_seg;ring).
replace (Py A T A) with (Py C D C) by
(unfold Py;
uniformize_dir_seg;
rewrite H9;
ring).
replace (Py P A T) with (Py4 P C A D).
auto.
rewrite (l3_8_a A T D C P);auto.

assert (Col U Y A).
apply (col_trans_1 U V Y A H8);auto with Geom.
assert (Col U Y T).
apply (col_trans_1 U A Y T);auto with Geom.
assert (Col A Y T).
apply (col_trans_1 A U Y T H4); auto with Geom.
assert (parallel C D T A).
apply (parallel_transitivity C D A Y T A);auto with Geom.
unfold parallel;basic_simpl.
assert (Col A T Y) by auto with Geom.
auto.

apply parallel_side_eq_weak_weak_weak_para;auto with Geom.

assert (Col U Y A).
apply (col_trans_1 U V Y A H8);auto with Geom.
assert (Col U Y T).
apply (col_trans_1 U A Y T);auto with Geom.
assert (Col A Y T).
apply (col_trans_1 A U Y T H4); auto with Geom.
auto.

assert (Col U Y A).
apply (col_trans_1 U V Y A H8);auto with Geom.
assert (Col U Y T).
apply (col_trans_1 U A Y T);auto with Geom.
assert (Col A Y T).
apply (col_trans_1 A U Y T H4); auto with Geom.
auto.
assert (Col U V T).
apply (col_trans_1 U A V T);auto with Geom.
assert (parallel U V A T).
unfold parallel, S4.
basic_simpl.
replace (S U A V) with 0.
rewrite H12.
ring.
assert (Col U A V) by auto with Geom.
symmetry;auto with Geom.

cut (perp A T Y P).
auto with Geom.
apply (perp_para_perp U V Y P A T);auto with Geom.

unfold not;intro.
subst.
basic_simpl.
assert (C=D).
auto with Geom.
intuition.
Qed.

Theorem elim_ratio_on_foot_a_invariant : forall C D,
C<>D -> Py C D C <> 0.
Proof.
auto with Geom.
Qed.

Theorem elim_ratio_on_foot_spec_a :
forall Y P U V A C D : Point,
on_foot Y P U V ->
Col A U V ->
parallel A Y C Y ->
C <> Y ->
A <> Y ->
A**Y / C**Y = (Py P U V * Py4 P C A V + Py P V U * Py4 P C A U) /
(Py P U V * Py C V C + Py P V U * Py C U C - Py P U V * Py P V U).
Proof.
intros.
rewrite (elim_ratio_on_foot_a Y P U V) by auto.
assert (T:= (elim_ratio_on_foot_a_invariant C Y H2)).

unfold Py4.
rewrite (elim_py_on_foot_right P C P U V) in * by auto.
rewrite (elim_py_on_foot_right A C P U V) in * by auto.
rewrite (pyth_simpl_4 C Y) in *.
rewrite (elim_py_on_foot_left_right C P U V Y) in * by auto.
replace (((Py P U V * Py P C V + Py P V U * Py P C U) / Py U V U -
 (Py P U V * Py A C V + Py P V U * Py A C U) / Py U V U) /
((Py P U V * Py P U V * Py V C V + Py P U V * Py P V U * Py V C U +
  Py P U V * Py P V U * Py U C V + Py P V U * Py P V U * Py U C U) /
 (Py U V U * Py U V U)))
with
(((Py P U V * Py P C V + Py P V U * Py P C U) -
 (Py P U V * Py A C V + Py P V U * Py A C U) ) /
((Py P U V * Py P U V * Py V C V + Py P U V * Py P V U * Py V C U +
  Py P U V * Py P V U * Py U C V + Py P V U * Py P V U * Py U C U) /
 ( Py U V U))) in *.
replace (Py P U V * Py P C V + Py P V U * Py P C U -
 (Py P U V * Py A C V + Py P V U * Py A C U))
with (Py P U V * Py P C V + Py P V U * Py P C U -
Py P U V * Py A C V - Py P V U * Py A C U) in * by ring.
replace (Py P U V * Py P C V + Py P V U * Py P C U - Py P U V * Py A C V -
 Py P V U * Py A C U)
with
(Py P U V * Py4 P C A V + Py P V U * Py4 P C A U) in * by (unfold Py4;ring).
replace ((Py P U V * Py P U V * Py V C V + Py P U V * Py P V U * Py V C U +
  Py P U V * Py P V U * Py U C V + Py P V U * Py P V U * Py U C U) /
 Py U V U)
with (
 Py P U V * Py C V C +
Py P V U * Py C U C - Py P U V * Py P V U) in *.

trivial.

unfold Py.
uniformize_dir_seg.
field.
basic_simpl.
replace(U ** V * U ** V + U ** V * U ** V)
with (2*U ** V * U ** V) by ring.
unfold on_foot in H;use H.
repeat (apply nonzeromult);auto with Geom.

field.
split.
unfold on_foot in H.
use H.
auto with Geom.
intro Ha.
rewrite Ha in *.
replace ( 0 / (Py U V U * Py U V U) ) with 0 in *.
intuition.
field.
unfold on_foot in H.
use H.
auto with Geom.
Qed.

Theorem elim_ratio_on_foot_b :
forall Y P U V A C D : Point,
on_foot Y P U V ->
~ Col A U V ->
parallel A Y C D ->
C <> D ->
A**Y / C**D = S A U V / S4 C U D V.
Proof.
intros.
cases_equality Y P.

subst Y.
unfold S4.
unfold on_foot in H.
use H.
clear H3.
eapply elim_length_ratio_inter_ll_1 with (P:=A) (Q:=P);auto with Geom.
unfold inter_ll.
repeat split;auto with Geom.
intro.
assert (parallel V U P A) by auto with Geom.
unfold parallel, S4 in H3.
replace (S V P U) with (S P U V) in H3 by auto with Geom.
rewrite H5 in H3.
basic_simpl.
assert (Col A U V).
auto with Geom.
intuition.

eapply elim_length_ratio_inter_ll_1 with (P:=P) (Q:=Y); auto with Geom.
unfold inter_ll, on_foot in *.
use H.
repeat split; auto with Geom.
cut (~ parallel Y P U V).
auto with Geom.
apply perp_not_parallel; auto with Geom.
Qed.

Theorem elim_ratio_on_foot_spec_b :
forall Y P U V A C : Point,
on_foot Y P U V ->
~ Col A U V ->
parallel A Y C Y ->
C <> Y ->
A**Y / C**Y = S A U V / S C U V.
Proof.
intros.
rewrite (elim_ratio_on_foot_b Y P U V A C) by assumption.
unfold S4.
replace (S C Y V) with (S V C Y) by auto with Geom.
rewrite (elim_area_on_foot C U P U V Y) by assumption.
rewrite (elim_area_on_foot V C P U V Y) by assumption.
basic_simpl.
uniformize_signed_areas.
replace (Py P U V * S C U V / Py U V U + Py P V U * S C U V / Py U V U)
with (S C U V).
trivial.
unfold Py.
uniformize_dir_seg.
basic_simpl.
field.
replace (U ** V * U ** V + U ** V * U ** V) with (2*U ** V * U ** V) by ring.
unfold on_foot in H;decompose [and] H.
repeat (apply nonzeromult);auto with Geom.
Qed.

Theorem elim_ratio_on_foot_b_invariant :
forall Y P U V A C D : Point,
on_foot Y P U V ->
~ Col A U V ->
parallel A Y C D ->
C<>D ->
S4 C U D V <> 0.
Proof.
intros.
intro.
assert (parallel C D U V) by auto with Geom.
unfold on_foot in *.
use H.
assert  (T:=parallel_transitivity A Y C D U V H2 H1 H4).
assert (parallel U V A Y) by auto with Geom.
unfold parallel, S4 in H.
replace (S U V Y) with (0) in H.
basic_simpl.
assert (Col A U V) by auto with Geom.
intuition.
assert (Col U V Y) by auto with Geom.
auto with Geom.
Qed.

Theorem elim_ratio_on_perp_d_a_invariant :
  forall Y P Q A C D : Point, forall r: F,
  on_perp_d Y P Q r->
  Col A P Y  ->
  parallel A Y C D ->
  A<>Y ->
  C<>D ->
  S4 C P D Q <> 0.
Proof.
intros.
unfold on_perp_d in H.
use H.
intro.
assert (parallel C D P Q) by auto with Geom.
clear H.
assert (T:=parallel_transitivity A Y C D P Q H3 H1 H7).

assert (parallel Y P P Q).
apply (parallel_transitivity Y P A Y P Q H2);
auto with Geom.
unfold parallel.
basic_simpl.
assert (Col Y A P) by auto with Geom.
auto with Geom.
assert (~ perp Y P P Q).
apply (parallel_not_perp Y P P Q H).
2:auto.
2:intuition.
intro;subst.
basic_simpl.
IsoleVar (Py P Q P) H5.
replace (0/r) with (0) in H5.
2:field.
2:auto.
assert (P=Q).
auto with Geom.
intuition.
Qed.

Theorem elim_ratio_on_perp_d_a_aux :
 forall Y P Q A C D : Point, forall r: F,
on_perp_d Y P Q r->
Col A P Y  ->
parallel A Y C D ->
C<>D ->
A<>Y ->
A<>P ->
A**Y / C**D = (S A P Q -r/(2+2) * Py P Q P)/(S4 C P D Q).
Proof.
intros.

rename H4 into Hap.
assert (T:= (elim_ratio_on_perp_d_a_invariant Y P Q A C D r H H0 H1 H3 H2)).

assert (Hr: r<> 0).
unfold on_perp_d in *;use H;auto.

replace  (A**Y) with (A**P + P**Y) by
  (auto with Geom).
replace ((A ** P + P ** Y) / C ** D) with (A**P/C**D + P**Y/C**D) by (field;auto with Geom).
replace (A**P / C**D) with (S A P Q / S4 C P D Q).
replace (P**Y / C**D) with (- r / (2+2) * Py P Q P / S4 C P D Q).
field;solve_conds.

(* deux exprs *)

assert (P**Y / C**D = S P Y Q / S4 C P D Q).
assert (Y ** P / C ** D = S Y P Q / S4 C P D Q).
apply (elim_length_ratio_inter_ll_2 Y C D P A P Q P).
unfold inter_ll.
repeat split;auto with Geom.

intro.
unfold on_perp_d in H.
use H.

assert (parallel P Q P Y).
apply (parallel_transitivity P Q P A P Y).

auto.

auto.
unfold parallel, S4.
basic_simpl.
unfold Col in H0.
uniformize_signed_areas.
rewrite H0.
ring.
assert (parallel Y P P Q) by auto with Geom.
apply (perp_not_parallel Y P P Q H7).
intro.
subst Y.
basic_simpl.
IsoleVar r H6.
replace (0 / Py P Q P) with 0 in H6.
auto.
field.
auto with Geom.
auto with Geom.
auto.
auto.
unfold Col in *.
uniformize_signed_areas.
rewrite H0;ring.
auto.

assert (parallel C D P Y).
apply (parallel_transitivity C D A Y P Y); auto with Geom.
auto with Geom.

intro.
subst.
unfold on_perp_d in H.
use H.
basic_simpl.
IsoleVar r H5.
replace (0 / Py P Q P) with 0 in H5.
auto.
field;solve_conds.
auto with Geom.

assert (parallel C D Y P).
apply (parallel_transitivity C D A Y Y P H3).
auto with Geom.
auto with Geom.

replace (P ** Y / C ** D) with (- ( Y**P / C**D)).
rewrite H4.
uniformize_signed_areas.
field.
auto.
uniformize_dir_seg.
field.
auto with Geom.

rewrite H4.
unfold on_perp_d in H.
use H.
IsoleVar r H6.
rewrite H6.
uniformize_signed_areas.
field.
repeat split;auto with Geom.
solve_conds.
auto with Geom.

cases_equality A P.
subst P.
basic_simpl.
field;solve_conds.
auto with Geom.

rewrite (elim_length_ratio_inter_ll_2 A C D P Y P Q P).
auto.
unfold inter_ll.
repeat split;auto with Geom.
apply perp_not_parallel.
unfold on_perp_d in H.
use H.
auto with Geom.
unfold on_perp_d in H.
use H.
auto.
unfold on_perp_d in H.
use H.
intro.
subst P.
basic_simpl.
IsoleVar (Py Y Q Y) H6.
replace (0/r) with 0 in H6 by (field;solve_conds).

assert (Py Y Q Y <> 0).
auto with Geom.
intuition.

auto with Geom.
auto.
assert (parallel C D P A).
apply (parallel_transitivity C D A Y P A H3).
auto with Geom.
unfold parallel, S4.
basic_simpl.
auto with Geom.
auto with Geom.
auto.
Qed.

Theorem elim_ratio_on_perp_d_a :
 forall Y P Q A C D : Point, forall r: F,
on_perp_d Y P Q r->
Col A P Y  ->
parallel A Y C D ->
C<>D ->
A<>Y ->
A**Y / C**D = (S A P Q -r/(2+2) * Py P Q P)/(S4 C P D Q).
Proof.
intros.
cases_equality A P.
subst A.
clear H0.
basic_simpl.
unfold on_perp_d in H.
use H.
replace (0 - r / (2 + 2) * Py P Q P) with (S Q P Y).
replace (P ** Y / C ** D) with (- (Y**P / C**D)).
rewrite (elim_length_ratio_inter_ll_1 Y C D  P Q P Y P).
uniformize_signed_areas.
field.
cut (~ parallel C D P Q).
auto with Geom.
assert (perp C D P Q).
apply (perp_para_perp P Y P Q C D);auto with Geom.
intro.
assert  (T:=parallel_not_perp C D P Q H6 H2 H0).
intuition.

unfold inter_ll.
repeat split;auto with Geom.
intro.
assert (T:=parallel_not_perp P Y P Q H H3 H0).
assert (perp P Y P Q) by auto with Geom.
intuition.
intro.
uniformize_signed_areas.
rewrite H in H4.
basic_simpl.
assert (r * Py P Q P <> 0) by (apply nonzeromult;auto with Geom).
intuition.
auto.
auto with Geom.
uniformize_dir_seg.
field.
auto with Geom.
uniformize_signed_areas.
IsoleVar (S P Q Y) H4.
rewrite H4.
field.
apply nonzeromult;auto with Geom.
replace (2+2) with (2*2) by ring.
apply nonzeromult;auto with Geom.

apply elim_ratio_on_perp_d_a_aux;auto.
Qed.

Theorem elim_ratio_on_perp_d_spec_a :
 forall Y P Q A C : Point, forall r: F,
on_perp_d Y P Q r->
Col A P Y  ->
parallel A Y C Y ->
C<>Y ->
A<>Y ->
A**Y / C**Y = (S A P Q - r / (2 + 2) * Py P Q P) /
(S Q C P -r/(2+2) * Py P Q P).
Proof.
intros.
rewrite (elim_ratio_on_perp_d_a Y P Q A C Y r); try assumption.
unfold S4.
replace (S C Y Q) with (S Q C Y) by auto with Geom.
rewrite (elim_area_on_perp_d C P P Q Y r) by assumption.
rewrite (elim_area_on_perp_d Q C P Q Y r) by assumption.
basic_simpl.
unfold Py4.
basic_simpl.
uniformize_signed_areas.
replace (0 - r / (2 + 2) * (Py P C P - Py Q C P) + (S Q C P - r / (2 + 2) * Py P Q C))
with (S Q C P - r / (2 + 2) * (Py P C P - Py Q C P) - r / (2 + 2) * Py P Q C) by ring.
replace (Py P C P - Py Q C P) with (Py C P Q) by
(unfold Py;uniformize_dir_seg;basic_simpl;ring).
replace (S Q C P - r / (2 + 2) * Py C P Q - r / (2 + 2) * Py P Q C) with
(S Q C P -r/(2+2) * Py P Q P).
2:unfold Py.
2:uniformize_dir_seg.
2:basic_simpl.
2:field.
2:apply nonzeromult; auto with Geom.
trivial.
Qed.

Lemma elim_ratio_on_perp_d_b_auxi :
  forall A Y C D P Q : Point,
  on_parallel_d Y A C D 1 ->
  Py C P Q - Py D P Q = Py A P Q - Py Y P Q.
Proof.
intros.
replace (Py Y P Q) with (Py Q P Y) by apply pyth_sym.
rewrite (elim_py_on_parallel_d_right Q P A C D Y 1) by assumption.
replace (Py A P Q) with (Py Q P A) by apply pyth_sym.
replace (Py Q P D) with (Py D P Q) by apply pyth_sym.
replace (Py Q P C) with (Py C P Q) by apply pyth_sym.
ring.
Qed.

Theorem elim_ratio_on_perp_d_b_aux :
 forall Y P Q A C D : Point, forall r: F,
 on_perp_d Y P Q r->
 ~ Col A P Y  ->
 parallel A Y C D ->
 C<>D -> C**D <>A**Y ->
 A**Y / C**D = Py A P Q / Py4 C P D Q.
Proof.
intros.
unfold on_perp_d in H.
assert (A<>Y).
unfold not;intro.
subst.
intuition.

assert (T:=on_line_dex_spec_strong_f A Y C D H1 H4).

elim T;intros D' HD'.
clear T.
decompose [and] HD'; clear HD'.
rewrite <- H7.

assert (A<>D').
unfold not;intro.
subst.
basic_simpl.
assert (C=D).
auto with Geom.
subst.
intuition.

assert (D'<>Y).
unfold not;intro;subst.
subst.
rewrite H7 in H3.
intuition.

rewrite (l_25_b P Q A D' Y H6 H9).
assert (Py4 A P D' Q = Py4 C P D Q).
apply l_27_b; auto.

rewrite H10.
reflexivity.
unfold not;intro.
assert (parallel Y P D' P).
decompose [and] H;clear H.
apply (perp_perp_para Y P P Q D' P); auto with Geom.
assert (Col Y P D').
unfold parallel,S4 in H11.
basic_simpl.
auto with Geom.
assert (Col Y A P).
apply (col_trans_1 Y D' A P);
auto with Geom.
intuition.

unfold on_inter_line_perp.
decompose [and] H.
repeat split.
auto with Geom.
auto with Geom.

intro.
assert (parallel A D' Y P).
apply (perp_perp_para A D' P Q Y P);auto with Geom.
assert (Col A P Y).
assert (Col P A D').
apply (par_col_col_3 Y P A D');auto with Geom.

assert (parallel Y P A P).
apply (col_par_par Y P A D' P);
auto with Geom.
unfold parallel, S4 in H17.
basic_simpl.
auto with Geom.

intuition.
Qed.

Theorem elim_ratio_on_perp_d_b_invariant :
 forall Y P Q A C D : Point, forall r: F,
 on_perp_d Y P Q r ->
 ~ Col A P Y ->
 parallel A Y C D ->
 C<>D ->
 Py4 C P D Q <> 0.
Proof.
intros.
unfold on_perp_d in H.
use H.
intro.
assert (perp C D P Q) by auto with Geom.
clear H.
assert (parallel Y P C D)
 by (eapply perp_perp_para;eauto).
assert (parallel Y P A Y)
 by (apply (parallel_transitivity Y P C D A Y); auto with Geom).
assert (Col A P Y).
unfold parallel in *.
basic_simpl.
auto with Geom.
intuition.
Qed.

Theorem elim_ratio_on_perp_d_b :
 forall Y P Q A C D : Point, forall r: F,
 on_perp_d Y P Q r->
 ~ Col A P Y  ->
 parallel A Y C D ->
 C<>D ->
 A**Y / C**D = Py A P Q / Py4 C P D Q.
Proof.
intros.
elim (classic (A**Y=C**D)).
intro.
assert (on_parallel_d Y A C D 1).
unfold on_parallel_d;repeat split;auto with Geom.
ring_simplify;auto.
rewrite H3.
replace (C ** D / C ** D) with 1 by (field;auto with Geom).
assert (T:=elim_ratio_on_perp_d_b_auxi A Y C D P Q H4).
assert (Py A P Q = Py4 C P D Q).
unfold Py4.
assert (Py Y P Q = 0).
unfold on_perp_d in H;use H; unfold perp, Py4 in *.
basic_simpl;assumption.
rewrite H5 in T.
ring_simplify in T.
rewrite <- T.
ring.
rewrite H5.
field.
eapply elim_ratio_on_perp_d_b_invariant;eauto.
intros.
eapply elim_ratio_on_perp_d_b_aux;eauto.
Qed.

Theorem elim_ratio_on_perp_d_spec_b :
 forall Y P Q A C : Point, forall r: F,
 on_perp_d Y P Q r->
 ~ Col A P Y  ->
 parallel A Y C Y ->
 C<>Y ->
 A**Y / C**Y = Py A P Q / Py C P Q.
Proof.
intros.
rewrite (elim_ratio_on_perp_d_b Y P Q A C Y r) by assumption.
unfold Py4.
replace (Py Y P Q) with (Py Q P Y) by auto with Geom.
rewrite (elim_py_on_perp_d_right Q P P Q Y r) by assumption.
basic_simpl.
trivial.
Qed.


Require Import Classical.

Axiom classic : forall P : Prop, P \/ ~P.

Theorem peirce : forall P : Prop, ((P -> False) -> P) -> P.
Proof.
  intros P H.
  destruct (classic P).
  apply H0.
  apply H.
  apply H0.
Qed.

Theorem peirce1 : forall P Q : Prop, ((P -> Q) -> P) -> P.
Proof.
  intros P Q H.
  destruct (classic P).
  - apply H0.
  - apply H.
    unfold not in H0.
    destruct (classic Q).
    + auto.
    + unfold not in H1.
      tauto.
Qed.

Inductive MyInd : term := ident|&: term|&.


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

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

Print Assumptions sub.


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

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

Print Assumptions add.


Require Import Coq.Reals.Reals.
Require Import Coq.omega.Omega.
Require Import Coq.Arith.Minus.
Require Import Coq.micromega.Lra.
Require Import RRR.Lang.Syntax.
Require Import RRR.Lang.Bindings.
Require Import RRR.Lang.BindingsFacts.
Require Import RRR.Lang.Entropy.
Require Import RRR.Lang.SmallStep.
Require Import RRR.Lang.Evaluation.
Require Import RRR.Lebesgue.Lebesgue.
Require Import FunctionalExtensionality.

Set Implicit Arguments.

Definition μNS_inf := λ e, inf (λ N, μNS N e).

(** The value measure induced by [ρTV] *)
Definition μTV (N : nat) (e : exp0) : Meas val0 :=
λ V, ∫ (λ t, ρTV N t e V) μentropy.

Definition μTV_sup := λ e V, sup (λ N, μTV N e V).

(** The measure induced by [ρNT] *)
Definition μNT (N : nat) (e : exp0) : Meas val0 :=
λ V, ∫ (λ t, ρNT N t e V) μentropy.

Lemma ρNS_decompose (N : nat) (t : entropy) (e : exp0) :
ρNS N t e = ρTV N t e full_event + ρNT N t e full_event.
Proof.
unfold ρNS, ρTV, ρNT.
destruct (eval N t e) as [ [[t' e'] w] | ].
2:{ ring. }
destruct e'; cbn; ring.
Qed.

Lemma μNS_decompose (N : nat) (e : exp0) :
μNS N e = μTV N e full_event + μNT N e full_event.
Proof.
unfold μNS, μTV, μNT.
rewrite integration_linear_plus.
integrand_extensionality t.
apply ρNS_decompose.
Qed.

Lemma ρTV_monotone_in_V (V' V : Event val0) :
(∀ v, if V' v then V v = true else True) →
∀ N t e, ρTV N t e V' ≤ ρTV N t e V.
Proof.
intros HV N t e.
unfold ρTV.
repeat match goal with
| [ |- context[match ?x with _ => _ end] ] =>
  match type of x with
  | bool => destruct x eqn:?
  | _ => destruct x
  end
| [ |- ?x ≤ ?x ] => apply ennr_le_refl
| [ |- _ * ?x ≤ _ * ?x ] => apply ennr_mult_le_compat_r
| [ |- 0 ≤ _ ] => apply ennr_le_0
end.
unfold indicator.
specialize (HV v) ; destruct (V' v) eqn:? ; crush.
Qed.

Lemma μNT_monotone_in_V (V' V : Event val0) :
(∀ v, if V' v then V v = true else True) →
∀ N e, μTV N e V' ≤ μTV N e V.
Proof.
intros HV N e.
unfold μNT.
apply integrand_extensionality_le ; intro t.
apply ρTV_monotone_in_V ; apply HV.
Qed.

Lemma ρTV_le_full_event N t e V :
ρTV N t e V ≤ ρTV N t e full_event.
Proof.
apply ρTV_monotone_in_V.
intro v. destruct (V v); reflexivity.
Qed.

Lemma μTV_le_full_event N e V :
μTV N e V ≤ μTV N e full_event.
Proof.
apply integrand_extensionality_le.
intro; apply ρTV_le_full_event.
Qed.

Lemma μTV_le_μNS N e V :
μTV N e V ≤ μNS N e.
Proof.
eapply ennr_le_trans ; [ apply μTV_le_full_event |].
rewrite μNS_decompose. apply ennr_add_le_compat_1.
Qed.

Lemma μNT_le_μNS N e :
μNT N e full_event ≤ μNS N e.
Proof.
rewrite μNS_decompose. apply ennr_add_le_compat_2.
Qed.

Lemma μNT_as_diff N e :
μNT N e full_event = μNS N e - μTV N e full_event.
Proof.
apply eq_sym.
apply ennr_plus_minus. 2:{ apply μNS_decompose. }
apply μTV_le_μNS.
Qed.

Lemma μNS_inf_le e C N : μNS N e ≤ C → μNS_inf e ≤ C.
Proof.
intro NS. unfold μNS_inf.
specialize (inf_is_glb (λ N, μNS N e)) as H.
destruct H as [H _]. unfold is_lower_bound in H.
eapply ennr_le_trans. 2:{ apply NS. }
apply H. repeat eexists.
Qed.

Lemma μNS_inf_le_μNS e N : μNS_inf e ≤ μNS N e.
Proof.
  eapply μNS_inf_le. unfold ennr_le. auto.
Qed.

Lemma μTV_sup_ge_μTV e N A : μTV N e A ≤ μTV_sup e A.
Proof.
  unfold μTV_sup. pose proof sup_is_lub. specialize H with (λ N0 : nat, μTV N0 e A).
  destruct H. unfold is_upper_bound in H. specialize H with (μTV N e A).
  eapply H. exists N. reflexivity.
Qed.

Lemma μNS_inf_is_glb e C :
(∀ N, C ≤ μNS N e) →
C ≤ μNS_inf e.
Proof.
intro H. unfold μNS_inf.
specialize (inf_is_glb (λ N, μNS N e)) as Q.
destruct Q as [_ Q]. apply Q.
unfold is_lower_bound. intros r [n Hr]. subst r. apply H.
Qed.

Lemma μTV_sup_is_lub e V C :
(∀ N, μTV N e V ≤ C) →
μTV_sup e V ≤ C.
Proof.
intro H. unfold μTV_sup.
specialize (sup_is_lub (λ N, μTV N e V)) as Q.
destruct Q as [_ Q]. apply Q.
unfold is_lower_bound. intros r [n Hr]. subst r. apply H.
Qed.

Section section_eval_weight_positive_finite_aux.
Context (N: nat).
Context (eval_weight_positive_finite :
  ∀ t e t' e' w,
  eval N t e = Some (t', e', w) → 0 < w < ∞).

Fact ρNS_finite_aux t e : ρNS_aux (eval N) t e < ∞.
Proof.
unfold ρNS_aux.
destruct (eval N t e) as [ [[t' e'] w] | ] eqn:Heval.
2:{ simpl; lra. }
apply eval_weight_positive_finite in Heval.
destruct Heval; assumption.
Qed.

Fact μNS_finite_aux e : μNS_aux (eval N) e < ∞.
Proof.
unfold μNS_aux.
apply ennr_lt_le_trans with (r2 := ∫ (λ t, ∞) μentropy).
2:{
  setoid_rewrite integration_of_const; try reflexivity.
  rewrite μentropy_is_a_probability_measure.
  rewrite ennr_mul_comm, ennr_mul_1_l.
  apply ennr_le_refl.
}
apply integrand_extensionality_lt.
intro; apply ρNS_finite_aux.
Qed.

Fact sss_weight_positive_finite_aux t e t' e' w :
(eval N) ⟨t|e⟩ ⤳ ⟨t'|e'⟩ • w  → 0 < w < ∞.
Proof.
induction 1;
try match goal with
| [ |- 0 < 1 < ∞ ] =>
  split; simpl; lra
| [ H : ?P |- ?P ] => exact H
end.
+ apply ennr_inv_0_lt_finite_compat. 2:{ apply μNS_finite_aux. }
  assumption.
+ simpl; auto.
Qed.
End section_eval_weight_positive_finite_aux.

Lemma eval_weight_positive_finite N : ∀ t e t' e' w,
eval N t e = Some (t', e', w) → 0 < w < ∞.
Proof.
induction N as [ | N IHN ]; do 5 intro.
+ simpl eval.
  intro H ; inversion H ; subst ; clear H.
  simpl ; split ; lra.
+ intro eval_S.
  apply unfold_eval_S_to_Some in eval_S.
  destruct eval_S as [
    [ [v [? [? ?]]] | [K [? [? ?]]] ] |
    [t''[e''[w'[Hsss[w''[Hw Heval]]]]]]
  ].
  1:{ subst. simpl; split; lra. }
  1:{ subst. simpl; split; lra. }
  1:{
    subst.
    apply sss_weight_positive_finite_aux in Hsss; [ | apply IHN ].
    apply IHN in Heval.
    apply ennr_mult_0_lt_and_finite; assumption.
  }
Qed.

Lemma sss_weight_positive_finite N t e t' e' w :
(eval N) ⟨t|e⟩ ⤳ ⟨t'|e'⟩ • w → 0 < w < ∞.
Proof.
eapply sss_weight_positive_finite_aux; try eassumption.
apply eval_weight_positive_finite.
Qed.

Corollary sss_weight_finite N t e t' e' w :
(eval N) ⟨t|e⟩ ⤳ ⟨t'|e'⟩ • w → w < ∞.
Proof.
intro H; apply sss_weight_positive_finite in H. crush.
Qed.

Corollary sss_weight_positive N t e t' e' w :
(eval N) ⟨t|e⟩ ⤳ ⟨t'|e'⟩ • w → 0 < w.
Proof.
intro H; apply sss_weight_positive_finite in H. crush.
Qed.

Lemma μNS_finite N e : μNS N e < ∞.
Proof.
apply μNS_finite_aux.
apply eval_weight_positive_finite.
Qed.

Lemma μNS_inf_finite : ∀ e, μNS_inf e < ∞.
Proof.
  intro e.
  eapply ennr_le_lt_trans.
  apply μNS_inf_le_μNS.
  apply μNS_finite.
  Unshelve. exact 0%nat.
Qed.

Lemma μTV_O_val v V :
μTV O (exp_val v) V = if V v then 1 else 0.
Proof.
destruct (V v) eqn:Hv.
+ unfold μTV.
  replace 1 with (μentropy full_event).
  2:{ rewrite μentropy_is_a_probability_measure ; reflexivity. }
  rewrite <- integration_of_indicator.
  unfold indicator.
  integrand_extensionality t.
  cbn.
  unfold indicator, const.
  rewrite Hv ; cbn ; ring.
+ unfold μTV.
  erewrite <- integration_of_0.
  integrand_extensionality t.
  cbn.
  unfold indicator, const.
  rewrite Hv ; cbn ; ring.
Qed.

Lemma μTV_S_val N (v : val0) V :
μTV (S N) v V = μTV N v V.
Proof.
unfold μTV.
integrand_extensionality t.
unfold ρTV.
rewrite eval_val_S.
destruct N ; simpl ; ring.
Qed.

Lemma μTV_val N v V :
μTV N (exp_val v) V = if V v then 1 else 0.
Proof.
induction N.
+ apply μTV_O_val.
+ rewrite μTV_S_val ; apply IHN.
Qed.

Lemma ρNT_O_val t v V : ρNT O t (exp_val v) V = if V v then 0 else 1.
Proof.
cbn.
destruct (V v) ; ring.
Qed.

Lemma μNT_O_val v V : μNT O (exp_val v) V = if V v then 0 else 1.
Proof.
destruct (V v) eqn:Hv.
+ erewrite <- integration_of_0.
  integrand_extensionality t.
  rewrite ρNT_O_val, Hv; ring.
+ rewrite <- μentropy_is_a_probability_measure.
  rewrite <- ennr_mul_1_l.
  erewrite <- integration_of_const.
  - integrand_extensionality t.
    reflexivity.
  - intro; simpl.
    rewrite ρNT_O_val, Hv; ring.
Qed.

Lemma ρNT_S_val N t v : ρNT (S N) t (exp_val v) full_event = 0.
Proof.
cbn; ring.
Qed.

Lemma μNT_S_val N v : μNT (S N) (exp_val v) full_event = 0.
Proof.
erewrite <- integration_of_0.
integrand_extensionality t.
apply ρNT_S_val.
Qed.

Lemma μNT_val N v : μNT N (exp_val v) full_event = 0.
Proof.
destruct N.
+ apply μNT_O_val.
+ apply μNT_S_val.
Qed.

Lemma μNS_val N v : μNS N (exp_val v) = 1.
Proof.
rewrite μNS_decompose.
rewrite μTV_val, μNT_val.
cbn; ring.
Qed.

Lemma μNS_inf_val v : μNS_inf (exp_val v) = 1.
Proof.
  unfold μNS_inf.
  apply inf_of_constant.
  intro n.
  apply μNS_val.
Qed.

Lemma ρTV_O_nonval t e V : (∀ v, e = exp_val v → False) → ρTV O t e V = 0.
Proof.
intro H.
unfold ρTV.
destruct (eval 0 t e) as [ [[t' e'] w] | ] eqn:Heval.
+ unfold ρTV.
  simpl eval in Heval |- *.
  inversion Heval ; subst ; clear Heval.
  repeat match goal with
  | [ |- context[match ?x with _ => _ end] ] => destruct x
  | [ |- ?x = ?x ] => reflexivity
  end.
  exfalso ; eapply H ; reflexivity.
+ unfold ρTV.
  simpl eval in Heval.
  inversion Heval.
Qed.

Lemma μTV_O_nonval e V : (∀ v, e = exp_val v → False) → μTV O e V = 0.
Proof.
intro H.
unfold μTV.
erewrite <- integration_of_0.
integrand_extensionality t.
apply ρTV_O_nonval ; apply H.
Qed.

Lemma μTV_stuck_S N e V :
stop N e →
(∀ v, e = exp_val v → False) →
0 = μTV (S N) e V.
Proof.
intros Hstop e_not_val.
replace 0 with (0 * μentropy full_event) ; [ | ring ].
erewrite <- integration_of_const with (f := λ _, 0) ; [ | intro ; ring ].
integrand_extensionality t.
unfold ρTV.
simpl eval.
destruct (exp_val_dec e) as [ [v Hv] | ].
1:{ subst; exfalso. eapply e_not_val. reflexivity. }
destruct (exp_ktx_exn_dec e) as [ [K ?] | ].
1:{
  subst. destruct (ktx_plug K exp_exn); try ring.
  exfalso. eapply e_not_val. reflexivity.
}
destruct (sss_det (eval N) t e) as [ [?[?[?[? ?]]]] |]; [| ring ].
exfalso.
destruct Hstop as [Sss_False _].
specialize (Sss_False t).
eapply Sss_False.
eassumption.
Qed.

Lemma μNS_stuck N e :
stop N e →
(∀ v, e = exp_val v → False) →
0 = (μNS (S N)) e.
Proof.
intros Hstop e_not_val.
replace 0 with (0 * μentropy full_event) ; [ | ring ].
erewrite <- integration_of_const with (f := λ _, 0) ; [ | intro ; ring ].
integrand_extensionality t.
unfold ρNS.
simpl eval.
destruct (exp_val_dec e) as [ [v Hv] | ].
1:{ subst; exfalso. eapply e_not_val. reflexivity. }
destruct Hstop as [e_stuck e_not_exn].
destruct (exp_ktx_exn_dec e) as [ [K ?] | ].
1:{ exfalso. eapply e_not_exn. eassumption. }
destruct (sss_det (eval N) t e) as [ [?[?[?[? ?]]]] |]; [| ring ].
exfalso.
specialize (e_stuck t).
eapply e_stuck.
eassumption.
Qed.

Lemma μNS_inf_stuck N e :
stop N e →
(∀ v, e = exp_val v → False) →
0 = μNS_inf e.
Proof.
intros Stop Notval_e.
apply ennr_le_antisym. 1:{ apply ennr_le_0. }
eapply μNS_inf_le with (N := S N).
erewrite μNS_stuck by eassumption.
apply ennr_le_refl.
Qed.

Lemma ρNT_O_nonval t e V : (∀ v, e = exp_val v → False) → ρNT O t e V = 1.
Proof.
intro H.
unfold ρNT.
destruct (eval 0 t e) as [ [[t' e'] w] | ] eqn:Heval.
+ simpl eval in Heval.
  inversion Heval ; subst ; clear Heval.
  repeat match goal with
  | [ |- context[match ?x with _ => _ end] ] => destruct x
  | [ |- ?x = ?x ] => reflexivity
  end.
  exfalso ; eapply H ; reflexivity.
+ simpl eval in Heval.
  inversion Heval.
Qed.

Lemma μNT_O_nonval e V : (∀ v, e = exp_val v → False) → μNT O e V = 1.
Proof.
intro H.
replace 1 with (μentropy full_event).
2:{ rewrite μentropy_is_a_probability_measure ; reflexivity. }
unfold μNT.
replace (μentropy full_event) with (1 * μentropy full_event).
2:{ rewrite ennr_mul_1_l ; reflexivity. }
erewrite <- integration_of_const.
2:{ reflexivity. }
integrand_extensionality t.
apply ρNT_O_nonval ; apply H.
Qed.

Lemma μNS_O_nonval e : (∀ v, e = exp_val v → False) → μNS O e = 1.
Proof.
intro H.
rewrite μNS_decompose.
rewrite μTV_O_nonval, μNT_O_nonval; try assumption.
ring.
Qed.

Lemma μNS_O e : μNS O e = 1.
Proof.
destruct (exp_val_dec e) as [[v Hv] | ]; [subst | ].
+ apply μNS_val.
+ apply μNS_O_nonval. assumption.
Qed.

Lemma μTV_exn N K V : 0 = μTV N (K[/exp_exn]) V.
Proof.
unfold μTV. rewrite integration_const_entropy with (v := 0). 1:{ ring. }
intro t. apply eq_sym. apply ρTV_exn.
Qed.

Lemma μNT_exn N K V : 1 = μNT N (K[/exp_exn]) V.
Proof.
unfold μNT. rewrite integration_const_entropy with (v := 1). 1:{ ring. }
intro t. apply eq_sym. apply ρNT_exn.
Qed.

Lemma ρNS_exn N t K : 1 = ρNS N t (K[/exp_exn]).
Proof.
unfold ρNS. rewrite eval_ktx_exn. reflexivity.
Qed.

Lemma μNS_exn N K : 1 = μNS N (K[/exp_exn]).
Proof.
unfold μNS. rewrite integration_const_entropy with (v := 1). 1:{ ring. }
intro t. apply eq_sym. apply ρNS_exn.
Qed.

Lemma sss_preserves_ρTV N t t' e e' w:
(eval N) ⟨t|e⟩ ⤳ ⟨t'|e'⟩ • w →
∀ V, ρTV (S N) t e V = (ρTV N t' e' V) * w.
Proof.
intros Hsss V.
apply sss_eval in Hsss.
unfold ρTV.
rewrite Hsss.
destruct (eval N t' e') as [[[T E] W] | ] ; [ | ring ].
repeat match goal with
| [ |- context[ match ?x with _ => _ end ] ] => destruct x
end ; ring.
Qed.

Lemma sss_preserves_μTV N e e' w:
(∀ t, (eval N) ⟨t|e⟩ ⤳ ⟨t|e'⟩ • w ) →
∀ V, μTV (S N) e V = unif_score_meas w (μTV N e') V.
Proof.
intros Hsss V.
unfold μTV.
simpl unif_score_meas.
rewrite <- integration_linear_mult_r.
integrand_extensionality t.
apply sss_preserves_ρTV ; apply Hsss.
Qed.

Lemma sss_preserves_ρNT N t e t' e' w:
(eval N) ⟨t|e⟩ ⤳ ⟨t'|e'⟩ • w →
∀ V, ρNT (S N) t e V = (ρNT N t' e' V) * w.
Proof.
intros Hsss V.
apply sss_eval in Hsss.
unfold ρNT.
rewrite Hsss.
destruct (eval N t' e') as [[[T E] W] | ] ; [ | ring ].
repeat match goal with
| [ |- context[ match ?x with _ => _ end ] ] => destruct x
end ; ring.
Qed.

Lemma sss_preserves_μNT N e e' w:
(∀ t, (eval N) ⟨t|e⟩ ⤳ ⟨t|e'⟩ • w) →
∀ V, μNT (S N) e V = unif_score_meas w (μNT N e') V.
Proof.
intros Hsss V.
unfold μNT.
simpl unif_score_meas.
rewrite <- integration_linear_mult_r.
integrand_extensionality t.
eapply sss_preserves_ρNT ; apply Hsss.
Qed.

Lemma sss_preserves_ρNS N t e t' e' w:
(eval N) ⟨t|e⟩ ⤳ ⟨t'|e'⟩ • w →
ρNS (S N) t e = (ρNS N t' e') * w.
Proof.
intro Hsss.
apply sss_eval in Hsss.
unfold ρNS.
rewrite Hsss.
destruct (eval N t' e') as [[[T E] W] | ] ; [ | ring ].
repeat match goal with
| [ |- context[ match ?x with _ => _ end ] ] => destruct x
end ; ring.
Qed.

Lemma sss_preserves_μNS N e e' w:
(∀ t, (eval N) ⟨t|e⟩ ⤳ ⟨t|e'⟩ • w) →
μNS (S N) e = (μNS N e') * w.
Proof.
intros Hsss.
unfold μNS.
rewrite <- integration_linear_mult_r.
integrand_extensionality t.
eapply sss_preserves_ρNS ; apply Hsss.
Qed.

Lemma ktx_sample_unif_preserves_μTV N K V:
μTV (S N) (K[/(exp_sample val_unif)]) V =
∫ (λ r, μTV N (K[/val_real r]) V * if (Rinterval_dec 0 1 r) then 1 else 0) lebesgue_measure.
Proof.
unfold μTV.
rewrite <- integration_πU_lebesgue.
replace (λ t, ρTV (S N) t (K[/exp_sample val_unif]) V)
  with (λ t, ρTV N (πR t) (K[/val_real (πU t)]) V).
2:{
  extensionality t.
  erewrite sss_preserves_ρTV with (w := 1).
  1:{ rewrite ennr_mul_1_r; reflexivity. }
  apply ktx_congruence.
  apply sss_sample_unif.
}
setoid_rewrite <- integration_πL_πR.
reflexivity.
Qed.

Lemma sample_unif_preserves_μTV N V:
μTV (S N) (exp_sample val_unif) V =
∫ (λ r, μTV N (val_real r) V * if (Rinterval_dec 0 1 r) then 1 else 0) lebesgue_measure.
Proof.
assert (∀ e, e = ktx_hole[/e]) as H by trivial.
setoid_rewrite H.
apply ktx_sample_unif_preserves_μTV.
Qed.

Lemma ktx_sample_unif_preserves_μNT N K V :
μNT (S N) (K[/exp_sample val_unif]) V =
∫ (λ r, μNT N (K[/val_real r]) V * if (Rinterval_dec 0 1 r) then 1 else 0) lebesgue_measure.
Proof.
unfold μNT.
rewrite <- integration_πU_lebesgue.
replace (λ t, ρNT (S N) t (K[/exp_sample val_unif]) V)
  with (λ t, ρNT N (πR t) (K[/val_real (proj1_sig (πL t 0%nat))]) V).
2:{
  extensionality t.
  erewrite sss_preserves_ρNT with (w := 1).
  1:{ rewrite ennr_mul_comm, ennr_mul_1_l; reflexivity. }
  apply ktx_congruence.
  apply sss_sample_unif.
}
setoid_rewrite <- integration_πL_πR.
reflexivity.
Qed.

Lemma sample_unif_preserves_μNT N V:
μNT (S N) (exp_sample val_unif) V =
∫ (λ r, μNT N (val_real r) V * if (Rinterval_dec 0 1 r) then 1 else 0) lebesgue_measure.
Proof.
assert (∀ e, e = ktx_hole[/e]) as H by trivial.
setoid_rewrite H.
apply ktx_sample_unif_preserves_μNT.
Qed.

Lemma ktx_sample_unif_preserves_μNS N K :
μNS (S N) (K[/exp_sample val_unif]) =
∫ (λ r, μNS N (K[/val_real r]) * if (Rinterval_dec 0 1 r) then 1 else 0) lebesgue_measure.
Proof.
unfold μNS.
rewrite <- integration_πU_lebesgue.
replace (λ t, ρNS (S N) t (K[/exp_sample val_unif]))
  with (λ t, ρNS N (πR t) (K[/val_real (proj1_sig (πL t 0%nat))])).
2:{
  extensionality t.
  erewrite sss_preserves_ρNS with (w := 1).
  1:{ rewrite ennr_mul_comm, ennr_mul_1_l; reflexivity. }
  apply ktx_congruence.
  apply sss_sample_unif.
}
setoid_rewrite <- integration_πL_πR.
reflexivity.
Qed.

Lemma sample_unif_preserves_μNS N :
μNS (S N) (exp_sample val_unif) =
∫ (λ r, μNS N (val_real r) * if (Rinterval_dec 0 1 r) then 1 else 0) lebesgue_measure.
Proof.
assert (∀ e, e = ktx_hole[/e]) as H by trivial.
setoid_rewrite H.
apply ktx_sample_unif_preserves_μNS.
Qed.

Lemma ev2v_None_then_ρNS_Ke_is_ρNT_e N : ∀ t K e,
ev2v N t e = None →
(ρNS N) t (K[/e]) = ρNT N t e full_event.
Proof.
induction N as [|N IHN]; do 3 intro; intro H.
1:{
  cbn in H |- *.
  destruct (exp_val_dec e) as [[u ?]|Notval_e] eqn:Dec_val_e; inversion H; subst.
  destruct e; try ring; try inversion Dec_val_e.
}
destruct (exp_val_dec e) as [[u ?]|Notval_e] eqn:Dec_val_e.
1:{ subst. cbn in H. inversion H. }
unfold ρNS. unfold ρNT.
apply ev2v_None_eval in H as [Q | [? [e' [? [Q Notval_e']]]]]; rewrite Q.
+ rewrite eval_None_ktx_plug by assumption. ring.
+ erewrite eval_Some_ktx_plug by eassumption. cbn.
  destruct e'; try reflexivity.
  1:{ exfalso. eapply Notval_e'. reflexivity. }
Qed.

(** * Helper densities *)

Definition ρNS_ktx N t K e :=
match ev2v N t e with
| Some (k, t', v, w) => w * ρNS (N - k)%nat t' (K[/v])
| None => ρNT N t e full_event
end.

Lemma ρNS_ktx_rewrite (N : nat) (t : entropy) (K : ktx) (e : exp0) :
ρNS N t (K[/e]) = ρNS_ktx N t K e.
Proof.
unfold ρNS_ktx.
destruct (ev2v N t e) as [ [[[n t'] v] w] | ] eqn:H.
2:{ rewrite ev2v_None_then_ρNS_Ke_is_ρNT_e; auto. }
generalize N t K e n t' v w H; clear N t K e n t' v w H.
induction N; intros t K e n t' v w H.
1:{
  simpl Nat.sub. simpl in H.
  destruct (exp_val_dec e) as [ [u Hu] | Nonval_e ] eqn: He; inversion H; subst.
  ring.
}
simpl in H.
destruct (exp_val_dec e) as [ [u Hu] | Nonval_e ] eqn: He.
1:{
  subst. simpl in H. inversion H; subst.
  rewrite ennr_mul_1_l, <- minus_n_O. reflexivity.
}
destruct (sss_det (eval N) t e) as [ [t'' [e'' [w' [Step_e _]]]] | Stop_e ].
2:{ inversion H. }
destruct (ev2v N t'' e'') as [ [[[n_ t'_] v_] w_] | ] eqn:H'.
2:{ inversion H. }
inversion H; clear H. subst.
simpl minus.
apply ktx_congruence with (K := K) in Step_e as Step_Ke.
erewrite sss_preserves_ρNS; [ | exact Step_Ke ].
rewrite <- ennr_mul_assoc, ennr_mul_comm.
erewrite <- IHN; [ reflexivity | ].
apply H'.
Qed.

(* This lemma suggests entropy is correctly split between the redex and the
surrounding evaluation context *)
Lemma μNS_ktx_rewrite (N : nat) (K : ktx) (e : exp0) :
μNS N (K[/e]) =
∫ (λ t, match ev2v N t e with
  | Some (k, _, v, w) => w * μNS (N - k)%nat (K[/v])
  | None => 0
end) μentropy + μNT N e full_event.
Proof.
generalize K e; clear K e; induction N as [|N IHN]; intros K e.
1:{
  rewrite μNS_O.
  destruct (exp_val_dec e) as [[v Hv]|Nonval_e] eqn:dec_val_e.
  + subst. rewrite μNT_O_val. cbn.
    rewrite ennr_add_0_r. rewrite ennr_mul_1_l.
    erewrite integration_const_entropy; [reflexivity|].
    intro. unfold μNS_aux.
    erewrite integration_const_entropy; [reflexivity|].
    intro. unfold ρNS_aux. ring.
  + rewrite μNT_O_nonval; try assumption.
    match goal with | [ |- 1 = ?x + 1 ] => replace x with 0; [ring|] end.
    erewrite integration_const_entropy; [reflexivity|]. intro.
    simpl ev2v. rewrite dec_val_e. ring.
}
unfold μNT. rewrite integration_linear_plus.
(* setoid_rewrite ρNS_ktx_rewrite. *)
destruct (exp_val_dec e) as [ [v ?] | Nonval_e ] eqn:dec_val_e.
1:{
  subst.
  setoid_rewrite unfold_ev2v_val.
  rewrite <- minus_n_O. setoid_rewrite ennr_mul_1_l.
  setoid_rewrite ρNT_S_val. rewrite ennr_add_0_r.
  match goal with | [ |- _ = ∫ (λ _, ?x) _ ] =>
    erewrite integration_const_entropy with (f := (λ _, x));
    reflexivity
  end.
}
destruct (exp_ktx_exn_dec e) as [ [J ?] | Nonexn_e ].
1:{
  subst. rewrite ktx_plug_comp. rewrite <-μNS_exn.
  setoid_rewrite ev2v_ktx_exn. setoid_rewrite ennr_add_0_l.
  erewrite μNT_exn. reflexivity.
}
destruct (sss_exp_dec N e) as [ Step_e_N | Stop_e_N ].
2:{
  unfold μNS. setoid_rewrite ρNS_ktx_rewrite. unfold ρNS_ktx.
  integrand_extensionality t.
  rewrite ev2v_stuck.
  3:{ assumption. }
  2:{ split; assumption. }
  1:{ ring. }
}

specialize (Step_e_N entropy0) as [t' [e' [w Step_e_N]]].
destruct (sss_bifurcate Step_e_N) as [H | H].
+ erewrite sss_preserves_μNS.
  2:{ intro t. apply ktx_congruence. apply H. }
  rewrite IHN. unfold μNT. rewrite integration_linear_plus.
  rewrite <- integration_linear_mult_r. integrand_extensionality t.
  erewrite sss_ev2v with (e := e). 2:{ apply H. }
  erewrite sss_preserves_ρNT with (e := e). 2:{ apply H. }
  repeat match goal with
  | [ |- context[match ?x with _ => _ end] ] => destruct x
  | [ |- context[(_ - _)%nat] ] => simpl Nat.sub
  end; ring.
+ destruct H as [J [? [? [? ?]]]]. subst.
  rewrite ktx_plug_comp. erewrite ktx_sample_unif_preserves_μNS.
  setoid_rewrite <- ktx_plug_comp. setoid_rewrite IHN.
  rewrite <- integration_πU_lebesgue.
  unfold μNT. setoid_rewrite integration_linear_plus.
  rewrite <- integration_πL_πR.
  integrand_extensionality t.
  erewrite sss_ev2v.
  2:{ apply ktx_congruence. apply sss_sample_unif. }
  erewrite sss_preserves_ρNT.
  2:{ apply ktx_congruence. apply sss_sample_unif. }
  repeat match goal with
  | [ |- context[match ?x with _ => _ end] ] => destruct x; simpl
  end; ring.
Qed.

Lemma μNS_le_1 N : ∀ e, μNS N e ≤ 1.
Proof.
induction N as [N IHN] using (well_founded_induction lt_wf).
intro e. destruct N as [ | N ].
1:{ rewrite μNS_O. apply ennr_le_refl. }
destruct (exp_val_dec e) as [ [v Hv] | Nonval_e ].
1:{ subst. rewrite μNS_val. apply ennr_le_refl. }
destruct (exp_ktx_exn_dec e) as [ [K ?] | Nonexn_e ].
1:{ subst. rewrite <-μNS_exn. apply ennr_le_refl. }
destruct (sss_exp_dec N e) as [ Step_e_N | Stop_e_N ].
2:{ rewrite <- μNS_stuck.
    - apply ennr_le_0.
    - split; assumption.
    - assumption. }
specialize (Step_e_N entropy0) as [t' [e' [w Step_e_N]]].
apply sss_quadfurcate in Step_e_N.
destruct Step_e_N as [ [Step_e_N Hw] | [ Step_e_N | [ Step_e_N | Step_e_N ]]].
+ erewrite sss_preserves_μNS; try apply Step_e_N.
  apply ennr_mult_le_1_compat; [|apply Hw].
  apply IHN. omega.
+ destruct Step_e_N as [K [f [? [? [? [? ?]]]]]]. subst.
  erewrite sss_preserves_μNS.
  2:{ intro. apply ktx_congruence. apply sss_sample_query. assumption. }
  apply ennr_mult_inv_le_1_compat.
  rewrite μNS_ktx_rewrite.
  rewrite μNS_decompose with (e := f).
  apply ennr_add_le_compat_r.
  apply integrand_extensionality_le. intro t.
  rewrite <- ev2v_ρTV_same_weight.
  destruct (ev2v N t f) as [ [[[? ?] ?] ?] | ]; [cbn|apply ennr_le_0].
  rewrite <- ennr_mul_1_r. apply ennr_mult_le_compat_l.
  apply IHN. omega.
+ destruct Step_e_N as [K [f [? [? [? [? ?]]]]]]. subst.
  erewrite sss_preserves_μNS.
  2:{ intro. apply ktx_congruence. apply sss_sample_query_exn; assumption. }
  rewrite ennr_mul_1_r. apply IHN. omega.
+ destruct Step_e_N as [K [? [? [? ?]]]]. subst.
  rewrite ktx_sample_unif_preserves_μNS.
  rewrite <- integration_πU_lebesgue.
  rewrite <- integration_const_entropy with (f := λ t, 1).
  2:{ intro. ring. }
  apply integrand_extensionality_le. intro t.
  apply IHN. omega.
Qed.

Lemma μNS_inf_le_1 e : μNS_inf e ≤ 1.
Proof.
eapply μNS_inf_le with (N := O). apply μNS_le_1.
Qed.

Lemma μNS_ktx_plug_le N K e : μNS N (K[/e]) ≤ μNS N e.
Proof.
generalize K e; clear K e. induction N as [|N IH]; intros K e.
1:{ repeat rewrite μNS_O. apply ennr_le_refl. }
destruct (exp_val_dec e) as [ [v Hv] | Nonval_e ].
1:{ subst. rewrite μNS_val. apply μNS_le_1. }
destruct (exp_ktx_exn_dec e) as [ [J ?] | Nonexn_e ].
1:{ subst. rewrite ktx_plug_comp. setoid_rewrite <-μNS_exn. apply ennr_le_refl. }
destruct (sss_exp_dec N e) as [ Step_e_N | Stop_e_N ].
2:{
  rewrite <- μNS_stuck with (e := K[/e]); try apply ennr_le_0.
  + split.
    - do 4 intro; intro Step_Ke_N.
      eapply sss_ktx_inv in Step_Ke_N as [? [? ?]]; try reflexivity; try eassumption.
      eapply Stop_e_N; eassumption.
    - intros J Q. apply ktx_plug_is_K_exn_inv in Q as [? [? ?]].
      2:{ apply Nonval_e. }
      subst. eapply Nonexn_e. reflexivity.
  + intros v H. apply ktx_plug_is_val_inv in H as [? ?]. subst.
    eapply Nonval_e. reflexivity.
}
specialize (Step_e_N entropy0) as [t' [e' [w Step_e_N]]].
apply sss_bifurcate in Step_e_N.
destruct Step_e_N as [ Step_e_N | Step_e_N ].
+ repeat erewrite sss_preserves_μNS; try apply Step_e_N.
  2:{ intro t. specialize (Step_e_N t). apply ktx_congruence. apply Step_e_N. }
  apply ennr_mult_le_compat_r. apply IH.
+ destruct Step_e_N as [J [? [? [? ?]]]]. subst.
  rewrite ktx_plug_comp. repeat rewrite ktx_sample_unif_preserves_μNS.
  apply integrand_extensionality_le. intro r.
  apply ennr_mult_le_compat_r. rewrite <- ktx_plug_comp. apply IH.
Qed.

Lemma μNS_inf_ktx_plug_le K e : μNS_inf (K[/e]) ≤ μNS_inf e.
Proof.
apply μNS_inf_is_glb. intro N.
eapply μNS_inf_le. apply μNS_ktx_plug_le.
Qed.

Lemma μNS_inf_ktx_stuck N e K :
stop N e →
(∀ v, e = exp_val v → False) →
0 = μNS_inf (K [/e]).
Proof.
intros Stop Notval_e.
apply ennr_le_0_is_0.
eapply ennr_le_trans.
apply μNS_inf_ktx_plug_le.
rewrite <- (μNS_inf_stuck Stop Notval_e).
auto.
Qed.

Lemma nat_eq_dec : ∀ n m : nat, {n = m} + {n ≠ m}.
Proof. decide equality. Defined.

Lemma μNS_ktx_rewrite_S (N : nat) (K : ktx) (e : exp0) :
μNS (S N) (K[/e]) =
∫ (λ t, match ev2v (S N) t e with
  | Some (k, _, v, w) => if lt_dec k (S N) then w * μNS (S N - k)%nat (K[/v]) else 0
  | None => 0
end) μentropy +
(∫ (λ t, match ev2v (S N) t e with
  | Some (k, _, _, w) => if nat_eq_dec k (S N) then w else 0
  | None => 0
end) μentropy +
μNT (S N) e full_event).
Proof.
rewrite μNS_ktx_rewrite. rewrite ennr_add_assoc. apply ennr_add_eq_compat_r.
rewrite integration_linear_plus.
integrand_extensionality t.
destruct (ev2v (S N) t e) as [[[[k ?] ?] ?] |] eqn:Ev2v. 2:{ ring. }
destruct (lt_eq_lt_dec k (S N)) as [[|]|], (lt_dec k (S N)), (nat_eq_dec k (S N)); subst; try omega; try ring.
{ simpl minus. rewrite <- minus_diag_reverse. rewrite μNS_O. ring. }
{ apply ev2v_index_bounded in Ev2v. omega. }
Qed.


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

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

Print Assumptions add.


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

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

Print Assumptions add.


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

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

Print Assumptions add.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

Require Import Nat.

Inductive lst : Type :=
  | Nil : lst
  | Cons : nat -> lst -> lst.

Inductive queue : Type :=
  | Queue : lst -> lst -> queue.

Fixpoint len (l : lst) : nat :=
match l with
  | Nil => 0
  | Cons a l1 => 1 + (len l1)
end.

Lemma len_pos: forall l, (len l) >= 0.
Proof.
  induction l.
  - simpl. apply le_0_n.
  - simpl. apply le_0_n.
Qed.

Definition qlen (q : queue) : nat :=
match q with
  | Queue l1 l2 => (len l1) + (len l2)
end.

Fixpoint app (l : lst) (m: lst): lst :=
match l with
  | Nil => m
  | Cons a l1 => Cons a (app l1 m)
end.

Fixpoint rev (l: lst): lst :=
match l with
  | Nil => Nil
  | Cons a l1 => app (rev l1) (Cons a Nil)
end.

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

Definition amortizeQueue (l1 l2 : lst) : queue :=
  if leb (len l2)  (len l1) then Queue l1 l2
  else Queue (app l1 (rev l2)) Nil.

Lemma len_app : forall l1 l2, len (app l1 l2) = (len l1) + (len l2).
Proof.
  intros. induction l1.
  - reflexivity.
  - simpl. rewrite IHl1. reflexivity.
Qed.

Lemma plus_comm: forall m n, m + n = n + m.
Proof.
induction m.
- intros. simpl. rewrite <- plus_n_O. reflexivity.
- intros. simpl. rewrite IHm. rewrite plus_n_Sm. reflexivity.
Qed.

Lemma len_rev : forall l, len (rev l) = len l.
Proof.
induction l.
- reflexivity.
- simpl. lfind. Admitted.


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

(* TODO : change this to field once field isomorphism happens *)
Definition carry :
  { carry : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (carry a) = (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_carry ().
  Show Ltac Profile.
Time Defined.

Print Assumptions carry.