Definition scmp (s : sign) (c : coef) :=
  match s with S0 => czero | S1 => c | Sm1 => copp c end.Definition einsert0 (c1 : coef) (l1 : line) (e : expr) :=
  if czerop c1 then e else einsert c1 l1 e.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.Inductive rp (T : Type) := Stop (_ : T) | More (_ : T).Inductive rp (T : Type) := Stop (_ : T) | More (_ : T).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.

Lemma has_delta_in c l e : match has_delta c l e with None => True | Some (p,_) => In p e end.