Fixpoint natc (m n : nat) :=
match m, n with 0, 0 => Eq | 0, _ => Lt | _, 0 => Gt | S m1, S n1 => natc m1 n1 end.
rewrite tvcompare_def.
generalize (natc_correct (tvarn v) (tvarn v)); case natc; auto.
intros H; contradict H; auto with arith.
intros H; contradict H; auto with arith.
Qed.
(* Proof *)
Variable interv : tvar -> point K.
Notation "{v[ x ]}" := (interv x).
(* Implementation of variable *)
Variable var : Type.
(* Implementation of coef *)
Variable coef : Type.
Variable cadd : coef -> coef -> coef.
Variable czerop : coef -> bool.
Variable czero : coef.
Variable conep : coef -> bool.
Variable cone : coef.
Variable copp : coef -> coef.
Variable cscale : var -> coef -> coef.
Variable interk : var -> K.
Notation "{k[ x ]}" := (interk x).
Variable interc : coef -> K.
Notation "{c[ x ]}" := (interc x).
Hypothesis cadd_c : forall x y, {c[cadd x y]} = ({c[x]} + {c[y]})%f.
Hypothesis cone_c : {c[cone]} = (1)%f.
Hypothesis conep_c : forall x,
if conep x then {c[x]} = (1)%f else True.
Hypothesis czero_c : {c[czero]} = (0)%f.
Hypothesis cscale_c : forall k x,
{c[cscale k x]} = ({k[k]} * {c[x]})%f.
Hypothesis czerop_c : forall x,
if czerop x then {c[x]} = (0)%f else True.
Hypothesis copp_c : forall x, {c[copp x]} = (- {c[x]})%f.
(* We want to reduce expression *)
Inductive tuple := Tuple (_ _ _: tvar).
Let  line := list tuple.
Let  expr := list (coef * line).
Definition intert (t : tuple) :=
let (p1,p2,p3) := t in '[{v[p1]},{v[p2]},{v[p3]}].
Notation "{t[ x ]}" := (intert x).
Fixpoint interl (l :line) :=
match l with nil => 1%f | t ::l1 => ({t[t]} * interl l1)%f end.
Notation "{l[ x ]}" := (interl x).
Fixpoint intere (e :expr) :=
match e with nil => 0%f | (c,l)::e1 =>
({c[c]} * {l[l]} + intere e1)%f
end.
Notation "{e[ x ]}" := (intere x).
Fixpoint intere1 (e :expr) :=
match e with nil => 0%f | (c,t ::nil)::nil =>
if conep c then {t[t]} else intere e
| _ => intere e end.
Notation "{e1[ x ]}" := (intere1 x).
(* Sign *)
Inductive sign := Sm1 | S0 | S1.
Definition sopp s := match s with Sm1 => S1 | S0 => S0 | S1 => Sm1 end.
Definition smult s1 s2 :=
match s1 with S0 => S0 | S1 => s2 | Sm1 => sopp s2 end.
Definition smult3 s1 s2 s3 :=
match s1 with S0 => S0
| S1 => smult s2 s3
| Sm1 => sopp (smult s2 s3) end.
(* Membership *)
Definition tin i (t : tuple) :=
let (j1,j2,j3) := t in
match tvcompare i j1 with Eq => true
| _ =>   match tvcompare i j2 with Eq => true
| _ =>   match tvcompare i j3 with Eq => true
| _ =>  false end end end.
(* Substitution *)
Definition tsubst i j (t : tuple) :=
let (i1,i2,i3) := t in
match tvcompare i i1 with
| Eq => Tuple j i2 i3
| _ =>
match tvcompare i i2 with
| Eq => Tuple i1 j i3
| _ =>
match tvcompare i i3 with
| Eq => Tuple i1 i2 j
| _ => t
end
end
end.
Definition s2k (s: sign) : K :=
match s with S0 => 0%f | S1 => 1%f | Sm1 => (-(1))%f end.
(* Add an element in a tuple  i1 [? i2 i3] *)
Definition mk_tuplel i1 i2 i3 :=
match tvcompare i1 i2 with
| Eq => (S0, Tuple i1 i2 i3)
| Lt => (S1, Tuple i1 i2 i3)
| Gt =>
match tvcompare i1 i3 with
| Eq => ( S0, Tuple i1 i2 i3)
| Lt => (Sm1, Tuple i2 i1 i3)
| Gt => ( S1, Tuple i2 i3 i1)
end
end.
(* Add an element in a tuple  [i1 i2 ?] i3 *)
Definition mk_tupler i1 i2 i3 :=
match tvcompare i2 i3 with
| Eq => (S0, Tuple i1 i2 i3)
| Lt => (S1, Tuple i1 i2 i3)
| Gt =>
match tvcompare i1 i3 with
| Eq => ( S0, Tuple i1 i2 i3)
| Lt => (Sm1, Tuple i1 i3 i2)
| Gt => ( S1, Tuple i3 i1 i2)
end
end.
Inductive sprod := SProd (s : sign) (t1 t2 : tuple).
Definition esprod (s : sprod) :=
let (s,t1,t2) := s in (s2k s * {t[t1]} * {t[t2]})%f.
Definition elsprod (l : list sprod) :=
fold_left (fun res s => (res + esprod s)%f) l 0%f.
(* i1 <= j1 *)
Definition tsplit3 (i1 i2 i3 j1 j2 j3 : tvar) :=
match tvcompare i2 j2 with
| Gt =>
(* [i1 j1 j2] [i2 i3 j3] - [i1 j1 j3] [i2 i3 j2] [i1 j2 j3] [i2 i3 j1] *)
let   (s1,t1) := mk_tuplel i1 j1 j2 in
let (s'1,t'1) := mk_tupler i2 i3 j3 in
let   (s2,t2) := mk_tuplel i1 j1 j3 in
let (s'2,t'2) := mk_tupler i2 i3 j2 in
let   (s3,t3) := mk_tuplel i1 j2 j3 in
let (s'3,t'3) := mk_tupler i2 i3 j1 in
SProd (smult s1 s'1) t1 t'1 ::
SProd (sopp (smult s2 s'2)) t2 t'2 ::
SProd (smult s3 s'3) t3 t'3 :: nil
| _  =>
match tvcompare i3 j3 with
| Gt =>
(* [i1 i2 j1] [i3 j2 j3] -[i1 i2 j2] [i3 j1 j3] [i1 i2 j3] [i3 j1 j2] *)
let   (s1,t1) := mk_tupler i1 i2 j1 in
let (s'1,t'1) := mk_tuplel i3 j2 j3 in
let   (s2,t2) := mk_tupler i1 i2 j2 in
let (s'2,t'2) := mk_tuplel i3 j1 j3 in
let   (s3,t3) := mk_tupler i1 i2 j3 in
let (s'3,t'3) := mk_tuplel i3 j1 j2 in
SProd (smult s1 s'1) t1 t'1 ::
SProd (sopp (smult s2 s'2)) t2 t'2 ::
SProd (smult s3 s'3) t3 t'3 :: nil
| _  => SProd S1 (Tuple i1 i2 i3) (Tuple j1 j2 j3)::nil
end
end.
Definition tsplit (t1 t2 : tuple) :=
Eval lazy beta delta [tsplit3] in
let (i1,i2,i3) := t1 in
let (j1,j2,j3) := t2 in
match tvcompare i1 j1 with
| Gt => (* tsplit3 j1 j2 j3 i1 i2 i3 *) SProd S1 t2 t1 :: nil
| _  => tsplit3 i1 i2 i3 j1 j2 j3
end.
(* Lexicographic comparison *)
Fixpoint list_compare (T : Type) (cmp : T -> T -> comparison)
(l1 l2 : list T) :=
match l1, l2 with
|   nil,   nil => Eq
|   nil,   _   => Lt
|     _,   nil => Gt
| a::l1, b::l2 => match cmp a b with
|  Eq => list_compare T cmp l1 l2
| res => res
end
end.
Definition tcompare (t1 t2 : tuple) :=
let (i1, i2, i3) := t1 in
let (j1, j2, j3) := t2 in
match tvcompare i1 j1 with
| Eq =>
match tvcompare i2 j2 with
| Eq => tvcompare i3 j3
|  r => r
end
|  r => r
end.
Definition lcompare : line -> line -> _ := list_compare _ tcompare.
Fixpoint linsert (t1 : tuple) (l : line) :=
match l with
|   nil => t1 :: l
| t2::l1 => match tcompare t1 t2 with
|  Gt => t2 :: linsert t1 l1
| res => t1 :: l
end
end.
Fixpoint lsort (l : line) :=
match l with
|   nil => l
| t ::l1 => linsert t (lsort l1)
end.
Fixpoint ltsort (c : sign) (l : line) :=
match l with
|   nil => (c,l)
| t ::l1 =>  let (c1,t1) := tsort t in
let (c2,l2) := ltsort (smult c1 c) l1 in
(c2, linsert t1 l2)
end.
Fixpoint einsert (c1 : coef) (l1 : line) (e : expr) :=
match e with
|   nil => (c1,l1) :: e
| (c2,l2)::e1 => match lcompare l1 l2 with
| Eq => let c := cadd c1 c2 in
if czerop c then e1 else (c,l1)::e1
| Gt => (c2,l2) :: einsert c1 l1 e1
| Lt => (c1,l1) :: e
end
end.
Definition scmp (s : sign) (c : coef) :=
match s with S0 => czero | S1 => c | Sm1 => copp c end.
Fixpoint etsort (e : expr) :=
match e with
|   nil => nil
| (c,l)::e1 => let (c1, l1) := ltsort S1 l in
einsert0 (scmp c1 c) l1 (etsort e1)
end.
(* Reverse a tuple in a tail recursive way *)
Fixpoint rev (T : Type) (t1 t2 : list T) :=
match t1 with nil => t2 | n1 :: t3 => rev _ t3 (n1 :: t2) end.
Definition lrev: line -> line -> _ := rev tuple.
Fixpoint iter_split (c1 : coef) (l l1 : line) (accu : line) (e : expr)
: expr :=
if czerop c1 then e else
match l with
| nil => einsert c1 (lrev accu nil) e
| _ :: l' =>
match l1 with
| nil => einsert c1 (lrev accu nil) e
| t1 ::nil => einsert c1 (lrev accu (t1 ::nil)) e
| t1 :: t2 :: l2 =>
fold_left (fun e (v: sprod) =>
let (s1, t1, t2) := v in
let l3 := linsert t2 l2 in
iter_split (scmp s1 c1) l' l3 (t1 ::accu) e)
(tsplit t1 t2) e
end
end.
Definition step (e : expr) : expr :=
fold_left (fun e l => match l with
| (c, l1) => iter_split c l1 l1 nil e
end
) e nil.
apply trans_equal with ({e[e]} + {e[nil]})%f.
2 : simpl; ring.
unfold step.
generalize (nil : expr); elim e; simpl; auto.
intros; ring.
intros (c,l1) e1 IH e2.
rewrite IH, iter_split_c, lrev_c; simpl; auto.
ring.
Qed.
Inductive rp (T : Type) := Stop (_ : T) | More (_ : T).
Definition rp_val (T : Type) (x : rp T) :=
match x with Stop _ y => y | More _ y => y end.
Fixpoint iter_rp (T : Type) n f (v : rp T) := match v with
| More _ r => match n with
| O => f r
| S n1 => iter_rp T n1 f (iter_rp T n1 f v)
end
| _ => v
end.
Definition iter_step (k : nat) (e : expr) :=
iter_rp _ k (fun e => let e1 := step e in
match ecompare e e1 with
Eq => @Stop _ e
| _ => More _ e1
end) (More _ e).
(* Elimination of an intersection from a line *)
Fixpoint inter_elim (cc : coef) (x a b c d: tvar) (l : list tuple)
(accu: list tuple) e : expr :=
match l with
| nil =>  einsert cc (rev _ accu l) e
| t :: l1 =>
if tin x t then
let (c1,t1) := tsort (tsubst x a t) in
let (c2,t2) := tsort (Tuple b c d) in
let (c3,t3) := tsort (tsubst x b t) in
let (c4,t4) := tsort (Tuple a c d) in
einsert0
(scmp (sopp (smult c1 c2)) cc)
(linsert t1 (linsert t2 (rev _ accu l1)))
(einsert0
(scmp (smult c3 c4) cc)
(linsert t3 (linsert t4 (rev _ accu l1)))
e)
else inter_elim cc x a b c d l1 (t ::accu) e
end.
Fixpoint ielim (x a b c d: tvar) e accu :=
match e with
| nil => accu
| (cc,l) :: e1 =>
ielim x a b c d e1
(inter_elim cc x a b c d l nil accu)
end.
Definition nielim x a b c d e :=
ielim x a b c d e nil.
Definition do_elim x a b c d (e : expr) :=
let e1 := nielim x a b c d e in
match ecompare e e1 with
| Eq => Stop _ e1
| _ =>  More _ e1
end.
Definition iter_elim n x a b c d e :=
iter_rp _ n (do_elim x a b c d) (More _ e).
(* Elimination of a semi-free point *)
Fixpoint free_elim (cc : coef) x a b c d (l : list tuple)
(accu: list tuple) e :=
match l with
| nil => einsert cc (rev _ accu l) e
| t ::l1 =>
if tin x t then
let (c1,t1) := tsort (tsubst x b t) in
let cc1 := cscale a (scmp c1 cc) in
let (c2,t2) := tsort (tsubst x d t) in
let cc2 := cscale c (scmp c2 cc) in
einsert0
cc1 (linsert t1 (rev _ accu l1))
(einsert0
cc2 (linsert t2 (rev _ accu l1))
e)
else free_elim cc x a b c d l1 (t ::accu) e
end.
Fixpoint felim x a b c d e accu :=
match e with
| nil => accu
| (cc,l)::e1 =>
felim x a b c d e1
(free_elim cc x a b c d l nil accu)
end.
Definition nfelim x a b c d e :=
felim x a b c d e nil.
Definition do_free x a b c d (e : expr) :=
let e1 := nfelim x a b c d e in
match ecompare e e1 with
| Eq => Stop _ e1
| _ =>  More _ e1
end.
Definition iter_free n x a b c d e :=
iter_rp _ n (do_free x a b c d) (More _ e).
(******************************************************************)
(*                                                                *)
(*        Implementation of contraction                           *)
(*                                                                *)
(******************************************************************)
Definition reorder (t1 t2 : tuple) :=
let (m1,m2,m3) := t1 in
let (n1,n2,n3) := t2 in
match tvcompare m1 n1 with
| Eq =>
match tvcompare m2 n2 with
| Eq => match tvcompare m3 n3 with
|Eq => None
| _ => Some (S1, S1, m1, m2, m3, n3)
end
| Lt =>
match tvcompare m3 n2 with
| Eq => Some (Sm1, S1, m1, m3, m2, n3)
| Lt => None
| Gt =>
match tvcompare m3 n3 with
| Eq => Some (Sm1, Sm1, m1, m3, m2, n2)
| _ => None
end
end
| Gt =>
match tvcompare m2 n3 with
| Eq => Some (S1, Sm1, m1, m2, m3, n2)
| Gt => None
| Lt =>
match tvcompare m3 n3 with
| Eq => Some (Sm1, Sm1, m1, m3, m2, n2)
| _ => None
end
end
end
| Lt =>
match tvcompare m2 n1 with
| Eq =>
match tvcompare m3 n2 with
| Eq => Some (S1, S1, m2, m3, m1, n3)
| Lt => None
| Gt =>
match tvcompare m3 n3 with
| Eq => Some (S1, Sm1, m2, m3, m1, n2)
| _ => None
end
end
| Lt => None
| Gt =>
match tvcompare m2 n2 with
| Eq =>
match tvcompare m3 n3 with
| Eq => Some (S1, S1, m2, m3, m1, n1)
| _ => None
end
| _ => None
end
end
| Gt =>
match tvcompare m1 n2 with
| Eq =>
match tvcompare m2 n3 with
| Eq => Some (S1, S1, m1, m2, m3, n1)
| Gt => None
| Lt =>
match tvcompare m3 n3 with
| Eq => Some (Sm1, S1, m1, m3, m2, n1)
| _ => None
end
end
| Gt => None
| Lt =>
match tvcompare m2 n2 with
| Eq =>
match tvcompare m3 n3 with
| Eq => Some (S1, S1, m2, m3, m1, n1)
| _ => None
end
| _ => None
end
end
end.
Definition contraction_rule c t1 t2 t3 t4 :=
match reorder t1 t2 with
| None => None
| Some (s1, s2, m1, m2, m3, m4) =>
match reorder t3 t4 with
| None => None
| Some (s3, s4, n1, n2, n3, n4) =>
let s1 := smult s1 s3 in
let s2 := smult c (smult s2 s4) in
match smult s1 s2 with
| S0 => None | S1 => None
| Sm1 =>
match tvcompare m3 n4 with
| Lt => None | Gt => None
| Eq =>
match tvcompare m4 n3 with
| Lt => None | Gt => None
| Eq =>
match tvcompare m1 n1 with
| Eq => (*
(m1,m2,m3)(m1,n2,m4)
(m1,m2,m4)(m1,n2,m3)
*)
let (s3,t3) := tsort (Tuple m1 m2 n2) in
let (s4,t4) := tsort (Tuple m1 m3 m4) in
Some (smult s1 (smult s3 s4), t3, t4)
| Lt => match tvcompare m2 n1 with
| Eq =>
(* (m2,m1,m3)(m2,n2,m4) (m2,m1,m4)(m2,n2,m3) *)
let (s3,t3) := tsort (Tuple m1 m2 n2) in
let (s4,t4) := tsort (Tuple m2 m3 m4) in
Some (smult s1 (smult s3 s4), t3, t4)
| Lt => None
| Gt =>
match tvcompare m2 n2 with
| Eq =>
(* (m2,m1,m3)(m2,n1,m4) (m2,m1,m4)(m2,n1,m3) *)
let (s3,t3) := tsort (Tuple m2 m1 n1) in
let (s4,t4) := tsort (Tuple m2 m3 m4) in
Some (smult s1 (smult s3 s4), t3, t4)
| _ => None
end
end
| Gt => match tvcompare m1 n2 with
| Eq =>
(* (m1,m2,m3)(m1,n1,m4) (m1,m2,m4)(m1,n1,m3) *)
let (s3,t3) := tsort (Tuple m1 m2 n1) in
let (s4,t4) := tsort (Tuple m3 m1 m4) in
Some (smult s1 (smult s3 s4), t3, t4)
| Gt => None
| Lt =>
match tvcompare m2 n2 with
| Eq =>
(* (m2,m1,m3)(m2,n1,m4) (m2,m1,m4)(m2,n1,m3) *)
let (s3,t3) := tsort (Tuple m2 m1 n1) in
let (s4,t4) := tsort (Tuple m2 m3 m4) in
Some (smult s1 (smult s3 s4), t3, t4)
| _ => None
end
end
end end end end end end.
Fixpoint delta (m n : nat) (l1 l2 al1 al2 al3: line) :
option (line * line * line) :=
match l1 with
| nil => match natc n (length l2) with
| Eq => Some (lrev al1 nil, lrev al2 l2, lrev al3 nil)
| _ => None
end
| t1 :: l3 =>
(fix delta1 n (l2 : list tuple) al2 :=
match  l2 with
| nil =>
match natc m (length l1) with
| Eq => Some (lrev al1 l1, lrev al2 nil, lrev al3 nil)
| _ => None
end
| t2 :: l4 =>
match tcompare t1 t2 with
| Eq => delta m n l3 l4 al1 al2 (t1 ::al3)
| Lt => match m with
|    O => None
| S m1 => delta m1 n l3 l2 (t1 ::al1) al2 al3
end
| Gt => match n with
|    O => None
| S n1 => delta1 n1 l4 (t2 ::al2)
end
end
end) n l2 al2
end.
Fixpoint has_delta (c : coef) (l : line) (e : expr) :=
match e with
| nil => None
| (c1,l1)::e1  =>
match delta 2 2 l l1 nil nil nil with
| Some (t1 :: t2 :: nil, t3 :: t4 :: nil, rl) =>
let s :=
if czerop (cadd c c1) then Sm1 else
if czerop (cadd c (copp c1)) then S1 else
S0 in
if match s with S0 => true | _ => false end then
has_delta c l e1
else
match contraction_rule s t1 t3 t2 t4 with
| None=> has_delta c l e1
| Some (c5, t5, t6) =>
Some ((c1,l1),
(scmp c5 c,
linsert t5 (linsert t6 rl)))
end
| _ => has_delta c l e1
end
end.
Fixpoint edelta (e : expr) :=
match e with
| nil => None
| (c,l) :: e1  =>
match has_delta c l e1 with
| None => edelta e1
| Some r => Some ((c,l), r) end
end.
Fixpoint eremove c l (e : expr) :=
match e with
| nil => None
| (c1,l1) :: e1  =>
if czerop (cadd c1 (copp c)) then
match lcompare l l1 with
| Eq => Some e1
| _  =>
match eremove c l e1 with
| Some e2 => Some ((c1,l1):: e2)
| _ => None
end
end
else
match eremove c l e1 with
| Some e2 => Some ((c1,l1):: e2)
| _ => None
end
end.
Definition do_contra (e : expr) :=
match edelta e with
| None  => Stop _ e
| Some ((c1,l1),((c2,l2),(c3,l3)))  =>
match eremove c2 l2 e with
| Some e1 =>
match eremove c1 l1 e1 with
| Some e2 =>
More _ (einsert c3 l3 e2)
| _ => Stop _ e
end
| _ => Stop _ e
end
end.

Lemma do_contra_c e :
{e[rp_val _ (do_contra e)]} = {e[e]}.