Section AlmostField.
Variable AFth : almost_field_theory.
Let ARth := (AF_AR AFth).
Let rI_neq_rO := (AF_1_neq_0 AFth).
Let rdiv_def := (AFdiv_def AFth).
Let rinv_l := (AFinv_l AFth).
Add Morphism radd with signature (req ==> req ==> req) as radd_ext.
(* Power coefficients : Cpow *)
Variable Cpow : Type.
Variable Cp_phi : N -> Cpow.
Variable rpow : R -> Cpow -> R.
Variable pow_th : power_theory rI rmul req Cp_phi rpow.
(* sign function *)
Variable get_sign : C -> option C.
Variable get_sign_spec : sign_theory copp ceqb get_sign.
Variable cdiv:C -> C -> C*C.
Variable cdiv_th : div_theory req cadd cmul phi cdiv.
Let rpow_pow := (rpow_pow_N pow_th).
(* Polynomial expressions : (PExpr C) *)
Declare Scope PE_scope.
Bind Scope PE_scope with PExpr.
Delimit Scope PE_scope with poly.
Notation NPEeval := (PEeval rO rI radd rmul rsub ropp phi Cp_phi rpow).
Notation "P @ l" := (NPEeval l P) (at level 10, no associativity).
Arguments PEc _ _%coef.
Notation "0" := (PEc 0) : PE_scope.
Notation "1" := (PEc 1) : PE_scope.
Infix "+" := PEadd : PE_scope.
Infix "-" := PEsub : PE_scope.
Infix "*" := PEmul : PE_scope.
Notation "- e" := (PEopp e) : PE_scope.
Infix "^" := PEpow : PE_scope.
Definition NPEequiv e e' := forall l, e@l == e'@l.
Infix "===" := NPEequiv (at level 70, no associativity) : PE_scope.
Instance NPEequiv_eq : Equivalence NPEequiv.
Instance NPEeval_ext : Proper (eq ==> NPEequiv ==> req) NPEeval.
Notation Nnorm :=
(norm_subst cO cI cadd cmul csub copp ceqb cdiv).
Notation NPphi_dev :=
(Pphi_dev rO rI radd rmul rsub ropp cO cI ceqb phi get_sign).
Notation NPphi_pow :=
(Pphi_pow rO rI radd rmul rsub ropp cO cI ceqb phi Cp_phi rpow get_sign).
(* add abstract semi-ring to help with some proofs *)
Add Ring Rring : (ARth_SRth ARth).
(* additional ring properties *)
(***************************************************************************  Properties of division  ***************************************************************************)
Instance rdiv_ext: Proper (req ==> req ==> req) rdiv.
(* Results about [pow_pos] and [pow_N] *)
Instance pow_ext : Proper (req ==> eq ==> req) (pow_pos rmul).
Instance pow_N_ext : Proper (req ==> eq ==> req) (pow_N rI rmul).
(* === is a morphism *)
Instance PEadd_ext : Proper (NPEequiv ==> NPEequiv ==> NPEequiv) (@PEadd C).
(***************************************************************************  Some equality test  ***************************************************************************)
Local Notation "a &&& b" := (if a then b else false)
(at level 40, left associativity).
(* equality test *)
Fixpoint PExpr_eq (e e' : PExpr C) {struct e} : bool :=
match e, e' with
| PEc c, PEc c' => ceqb c c'
| PEX _ p, PEX _ p' => Pos.eqb p p'
| e1 + e2, e1' + e2' => PExpr_eq e1 e1' &&& PExpr_eq e2 e2'
| e1 - e2, e1' - e2' => PExpr_eq e1 e1' &&& PExpr_eq e2 e2'
| e1 * e2, e1' * e2' => PExpr_eq e1 e1' &&& PExpr_eq e2 e2'
| - e, - e' => PExpr_eq e e'
| e ^ n, e' ^ n' => N.eqb n n' &&& PExpr_eq e e'
| _, _ => false
end%poly.
(** Smart constructors for polynomial expression, with reduction of constants *)
Definition NPEadd e1 e2 :=
match e1, e2 with
| PEc c1, PEc c2 => PEc (c1 + c2)
| PEc c, _ => if (c =? 0)%coef then e2 else e1 + e2
|  _, PEc c => if (c =? 0)%coef then e1 else e1 + e2
(* Peut t'on factoriser ici ??? *)
| _, _ => (e1 + e2)
end%poly.
Infix "++" := NPEadd (at level 60, right associativity).
Definition NPEsub e1 e2 :=
match e1, e2 with
| PEc c1, PEc c2 => PEc (c1 - c2)
| PEc c, _ => if (c =? 0)%coef then - e2 else e1 - e2
|  _, PEc c => if (c =? 0)%coef then e1 else e1 - e2
(* Peut-on factoriser ici *)
| _, _ => e1 - e2
end%poly.
Infix "--" := NPEsub (at level 50, left associativity).
Definition NPEopp e1 :=
match e1 with PEc c1 => PEc (- c1) | _ => - e1 end%poly.
Definition NPEpow x n :=
match n with
| N0 => 1
| Npos p =>
if (p =? 1)%positive then x else
match x with
| PEc c =>
if (c =? 1)%coef then 1
else if (c =? 0)%coef then 0
else PEc (pow_pos cmul c p)
| _ => x ^ n
end
end%poly.
Infix "^^" := NPEpow (at level 35, right associativity).
Fixpoint NPEmul (x y : PExpr C) {struct x} : PExpr C :=
match x, y with
| PEc c1, PEc c2 => PEc (c1 * c2)
| PEc c, _ => if (c =? 1)%coef then y else if (c =? 0)%coef then 0 else x * y
| _, PEc c => if (c =? 1)%coef then x else if (c =? 0)%coef then 0 else x * y
| e1 ^ n1, e2 ^ n2 => if (n1 =? n2)%N then (NPEmul e1 e2)^^n1 else x * y
| _, _ => x * y
end%poly.
Infix "**" := NPEmul (at level 40, left associativity).
(* simplification *)
Fixpoint PEsimp (e : PExpr C) : PExpr C :=
match e with
| e1 + e2 => (PEsimp e1) ++ (PEsimp e2)
| e1 * e2 => (PEsimp e1) ** (PEsimp e2)
| e1 - e2 => (PEsimp e1) -- (PEsimp e2)
| - e1 => NPEopp (PEsimp e1)
| e1 ^ n1 => (PEsimp e1) ^^ n1
| _ => e
end%poly.
(****************************************************************************  Datastructure  ***************************************************************************)
(* The input: syntax of a field expression *)
Inductive FExpr : Type :=
| FEO : FExpr
| FEI : FExpr
| FEc: C ->  FExpr
| FEX: positive ->  FExpr
| FEadd: FExpr -> FExpr ->  FExpr
| FEsub: FExpr -> FExpr ->  FExpr
| FEmul: FExpr -> FExpr ->  FExpr
| FEopp: FExpr ->  FExpr
| FEinv: FExpr ->  FExpr
| FEdiv: FExpr -> FExpr ->  FExpr
| FEpow: FExpr -> N -> FExpr .
Fixpoint FEeval (l : list R) (pe : FExpr) {struct pe} : R :=
match pe with
| FEO       => rO
| FEI       => rI
| FEc c     => phi c
| FEX x     => BinList.nth 0 x l
| FEadd x y => FEeval l x + FEeval l y
| FEsub x y => FEeval l x - FEeval l y
| FEmul x y => FEeval l x * FEeval l y
| FEopp x   => - FEeval l x
| FEinv x   => / FEeval l x
| FEdiv x y => FEeval l x / FEeval l y
| FEpow x n => rpow (FEeval l x) (Cp_phi n)
end.
Strategy expand [FEeval].
(* The result of the normalisation *)
Record linear : Type := mk_linear {
num : PExpr C;
denum : PExpr C;
condition : list (PExpr C) }.
(***************************************************************************  Semantics and properties of side condition  ***************************************************************************)
Fixpoint PCond (l : list R) (le : list (PExpr C)) {struct le} : Prop :=
match le with
| nil => True
| e1 :: nil => ~ req (e1 @ l) rO
| e1 :: l1 => ~ req (e1 @ l) rO /\ PCond l l1
end.
(* An unsatisfiable condition: issued when a division by zero is detected *)
Definition absurd_PCond := cons 0%poly nil.
(***************************************************************************  Normalisation  ***************************************************************************)
Definition default_isIn e1 p1 e2 p2 :=
if PExpr_eq e1 e2 then
match Z.pos_sub p1 p2 with
| Zpos p => Some (Npos p, 1%poly)
| Z0 => Some (N0, 1%poly)
| Zneg p => Some (N0, e2 ^^ Npos p)
end
else None.
Fixpoint isIn e1 p1 e2 p2 {struct e2}: option (N * PExpr C) :=
match e2 with
| e3 * e4 =>
match isIn e1 p1 e3 p2 with
| Some (N0, e5) => Some (N0, e5 ** (e4 ^^ Npos p2))
| Some (Npos p, e5) =>
match isIn e1 p e4 p2 with
| Some (n, e6) => Some (n, e5 ** e6)
| None => Some (Npos p, e5 ** (e4 ^^ Npos p2))
end
| None =>
match isIn e1 p1 e4 p2 with
| Some (n, e5) => Some (n, (e3 ^^ Npos p2) ** e5)
| None => None
end
end
| e3 ^ N0 => None
| e3 ^ Npos p3 => isIn e1 p1 e3 (Pos.mul p3 p2)
| _ => default_isIn e1 p1 e2 p2
end%poly.
Definition ZtoN z := match z with Zpos p => Npos p | _ => N0 end.
Definition NtoZ n := match n with Npos p => Zpos p | _ => Z0 end.
Ltac npe_simpl := rewrite ?NPEmul_ok, ?NPEpow_ok, ?PEpow_mul_l.
Ltac npe_ring := intro l; simpl; ring.
Record rsplit : Type := mk_rsplit {
rsplit_left : PExpr C;
rsplit_common : PExpr C;
rsplit_right : PExpr C}.
(* Stupid name clash *)
Notation left := rsplit_left.
Notation right := rsplit_right.
Notation common := rsplit_common.
Fixpoint split_aux e1 p e2 {struct e1}: rsplit :=
match e1 with
| e3 * e4 =>
let r1 := split_aux e3 p e2 in
let r2 := split_aux e4 p (right r1) in
mk_rsplit (left r1 ** left r2)
(common r1 ** common r2)
(right r2)
| e3 ^ N0 => mk_rsplit 1 1 e2
| e3 ^ Npos p3 => split_aux e3 (Pos.mul p3 p) e2
| _ =>
match isIn e1 p e2 1 with
| Some (N0,e3) => mk_rsplit 1 (e1 ^^ Npos p) e3
| Some (Npos q, e3) => mk_rsplit (e1 ^^ Npos q) (e1 ^^ Npos (p - q)) e3
| None => mk_rsplit (e1 ^^ Npos p) 1 e2
end
end%poly.
Definition split e1 e2 := split_aux e1 xH e2.
Fixpoint Fnorm (e : FExpr) : linear :=
match e with
| FEO => mk_linear 0 1 nil
| FEI => mk_linear 1 1 nil
| FEc c => mk_linear (PEc c) 1 nil
| FEX x => mk_linear (PEX C x) 1 nil
| FEadd e1 e2 =>
let x := Fnorm e1 in
let y := Fnorm e2 in
let s := split (denum x) (denum y) in
mk_linear
((num x ** right s) ++ (num y ** left s))
(left s ** (right s ** common s))
(condition x ++ condition y)%list
| FEsub e1 e2 =>
let x := Fnorm e1 in
let y := Fnorm e2 in
let s := split (denum x) (denum y) in
mk_linear
((num x ** right s) -- (num y ** left s))
(left s ** (right s ** common s))
(condition x ++ condition y)%list
| FEmul e1 e2 =>
let x := Fnorm e1 in
let y := Fnorm e2 in
let s1 := split (num x) (denum y) in
let s2 := split (num y) (denum x) in
mk_linear (left s1 ** left s2)
(right s2 ** right s1)
(condition x ++ condition y)%list
| FEopp e1 =>
let x := Fnorm e1 in
mk_linear (NPEopp (num x)) (denum x) (condition x)
| FEinv e1 =>
let x := Fnorm e1 in
mk_linear (denum x) (num x) (num x :: condition x)
| FEdiv e1 e2 =>
let x := Fnorm e1 in
let y := Fnorm e2 in
let s1 := split (num x) (num y) in
let s2 := split (denum x) (denum y) in
mk_linear (left s1 ** right s2)
(left s2 ** right s1)
(num y :: condition x ++ condition y)%list
| FEpow e1 n =>
let x := Fnorm e1 in
mk_linear ((num x)^^n) ((denum x)^^n) (condition x)
end.
(* Example *)
(* Eval compute in (Fnorm (FEdiv (FEc cI) (FEadd (FEinv (FEX xH%positive)) (FEinv (FEX (xO xH)%positive))))). *)
(***************************************************************************  Main theorem  ***************************************************************************)
Ltac uneval :=
repeat match goal with
| |- context [ ?x @ ?l * ?y @ ?l ] => change (x@l * y@l) with ((x*y)@l)
| |- context [ ?x @ ?l + ?y @ ?l ] => change (x@l + y@l) with ((x+y)@l)
end.

Theorem Fnorm_crossproduct l fe1 fe2 :
let nfe1 := Fnorm fe1 in
let nfe2 := Fnorm fe2 in
(num nfe1 * denum nfe2) @ l == (num nfe2 * denum nfe1) @ l ->
PCond l (condition nfe1 ++ condition nfe2) ->
FEeval l fe1 == FEeval l fe2.