(***************************************************************************)
(* 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 geometry_tools_lemmas.
Require Export general_tactics.
Inductive AVars : Type :=
| PVar : Point -> AVars
| FVar : F -> AVars.
Inductive AP : Type :=
| APvar : nat -> AP.
Inductive AF : Type :=
| AS : nat -> nat -> nat -> AF
| AD : nat -> nat -> AF
| AFvar : nat -> AF
| AF0 : AF
| AF1 : AF
| AFplus : AF -> AF -> AF
| AFmult : AF -> AF -> AF
| AFopp : AF -> AF
| AFinv : AF -> AF.
(* Checks if var is in lvar *)
Ltac List_mem var lvar :=
match constr:(lvar) with
| nil => constr:(false)
| cons ?X1 ?X2 =>
match constr:(X1 = var) with
| (?X1 = ?X1) => constr:(true)
| _ => List_mem var X2
end
end.
(* Build the list of variables  *)
Ltac build_var_point_list_aux lvar point :=
let res := List_mem (PVar point) lvar in
match constr:(res) with
| true => lvar
| false => constr:(cons (PVar point) lvar)
end.
Ltac build_var_list_aux lvar trm :=
match constr:(trm) with
| F0 => lvar
| F1 => lvar
| (Fplus ?X1 ?X2) =>
let l2 := build_var_list_aux lvar X2 in
build_var_list_aux  l2 X1
| (Fmult ?X1 ?X2) =>
let l2 := build_var_list_aux  lvar X2 in
build_var_list_aux l2 X1
| (Fopp ?X1) => build_var_list_aux lvar X1
| (Finv ?X1) => build_var_list_aux lvar X1
| (S ?X1 ?X2 ?X3) =>
let l1 := build_var_point_list_aux lvar X3 in
let l2 := build_var_point_list_aux l1 X2 in
build_var_point_list_aux l2 X1
| (DSeg ?X1 ?X2) =>
let l1 := build_var_point_list_aux lvar X2 in
build_var_point_list_aux l1 X1
| (?X1 = ?X2) =>
let l2 := build_var_point_list_aux lvar X2 in
build_var_point_list_aux l2 X1
| ?X1 =>
let res := List_mem (FVar X1) lvar in
match constr:(res) with
| true => lvar
| false => constr:(cons (FVar X1) lvar)
end
end.
Ltac build_var_list trm :=
build_var_list_aux (@nil AVars) trm.
Ltac List_assoc elt lst :=
match constr:(lst) with
| nil => fail
| (cons (@pairT AVars nat ?X1 ?X2) ?X3) =>
match constr:(elt = X1) with
| (?X1 = ?X1) => constr:(X2)
| _ => List_assoc elt X3
end
end.
Ltac number_aux lvar cpt :=
match constr:(lvar) with
| nil => constr:(@nil (prodT AVars nat))
| cons ?X2 ?X3 =>
let l2 := number_aux X3 (Datatypes.S cpt) in
constr:(cons (@pairT  AVars nat X2 cpt) l2)
end.
Ltac number lvar := number_aux lvar (Datatypes.O).
Ltac build_numbered_var_list trm := let lvar := build_var_list trm in
number lvar.
Definition list_assoc_inv :=
(fix list_assoc_inv_rec (A:Type) (B:Set)
(eq_dec:forall e1 e2:B, {e1 = e2} + {e1 <> e2})
(lst:list (prodT A B)) {struct lst} :
B -> A -> A :=
fun (key:B) (default:A) =>
match lst with
| nil => default
| cons (pairT v e) l =>
match eq_dec e key with
| left _ => v
| right _ => list_assoc_inv_rec A B eq_dec l key default
end
end).
(* Interpretation *)
Parameter SomeValue :AVars.
Parameter SomePoint :Point.
Definition interp_AP_to_Point (lvar:list (prodT AVars nat)) (e:nat) : Point :=
match(list_assoc_inv  AVars nat eq_nat_dec lvar e SomeValue) with
| PVar p => p
| _ => SomePoint
end
.
Fixpoint interp_AF_to_F (lvar:list (prodT AVars nat)) (e:AF) {struct e} : F :=
match e with
| AF0 => F0
| AF1 => F1
| AS e1 e2 e3 => let idx1 := (interp_AP_to_Point lvar e1) in
S idx1 (interp_AP_to_Point lvar e2) (interp_AP_to_Point lvar e3)
| AD e1 e2 => DSeg (interp_AP_to_Point lvar e1) (interp_AP_to_Point lvar e2)
| AFplus e1 e2 => Fplus (interp_AF_to_F lvar e1) (interp_AF_to_F lvar e2)
| AFmult e1 e2 => Fmult (interp_AF_to_F lvar e1) (interp_AF_to_F lvar e2)
| AFopp e => Fopp (interp_AF_to_F lvar e)
| AFinv e => Finv (interp_AF_to_F lvar e)
| AFvar n =>
match(list_assoc_inv  AVars nat eq_nat_dec lvar n SomeValue) with
| FVar f => f
| _ => F0
end
end.
(* Metaification *)
Ltac interp_A lvar trm :=
match constr:(trm) with
| F0 => constr:(AF0)
| F1 => constr:(AF1)
| (Fplus ?X1 ?X2) =>
let e1 := interp_A lvar X1 with e2 := interp_A lvar X2 in
constr:(AFplus e1 e2)
| (Fmult ?X1 ?X2) =>
let e1 := interp_A lvar X1 with e2 := interp_A lvar X2 in
constr:(AFmult e1 e2)
| (Fopp ?X1) =>
let e := interp_A lvar X1 in
constr:(AFopp e)
| (Finv ?X1) =>
let e := interp_A lvar X1 in
constr:(AFinv e)
| (S ?X1 ?X2 ?X3) =>
let idx1 := List_assoc (PVar X1) lvar with
idx2 := List_assoc (PVar X2) lvar with
idx3 := List_assoc (PVar X3) lvar in
constr:(AS idx1 idx2 idx3)
| (DSeg ?X1 ?X2) =>
let idx1 := List_assoc (PVar X1) lvar with
idx2 := List_assoc (PVar X2) lvar in
constr:(AD idx1 idx2)
| ?X1 => let idx := List_assoc (FVar X1) lvar in
constr:(AFvar idx)
end.
Fixpoint nateq (n m:nat) {struct m} : bool :=
match n, m with
| O, O => true
| Datatypes.S n', Datatypes.S m' => nateq n' m'
| _, _ => false
end.

Lemma nateq_prop : forall n m:nat, (Is_true (nateq n m))-> n=m.
Fixpoint simplif (e:AF) {struct e} : AF :=
match e with
| AFplus e1 e2 =>
let s1 := (simplif e1) in
let s2 := (simplif e2) in
match s1 with
AF0 => s2
|_ => match s2 with
AF0 => s1
|_ =>  AFplus s1 s2
end
end
| AFmult e1 e2 =>
let s1 := (simplif e1) in
let s2 := (simplif e2) in
match s1 with
AF0 => AF0
|AF1 => s2
|_ => match s2 with
AF0 => AF0
|AF1 => s1
|_ =>  AFmult s1 s2
end
end
| AFopp e =>
let s := (simplif e) in
match s with
AF0 => AF0
| AFopp e1 => e1
| _ => AFopp s
end
| AS e1 e2 e3 => if (nateq e1 e2) then AF0 else
(if (nateq e1 e3) then AF0 else (if (nateq e2 e3) then AF0 else e))
| AD e1 e2 => if (nateq e1 e2) then AF0 else e
| _ => e
end.