(***************************************************************************)
(* 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.
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.
Ltac simplif_term exp :=
let lvar := build_numbered_var_list exp in
let trm := interp_A lvar exp in
let trm2 :=constr:(interp_AF_to_F lvar (simplif trm)) in
(replace exp with trm2 in *;[simpl|rewrite simplif_correct;trivial]).
Ltac Rbasic_simpl := match goal with
_:_ |- ?X1 = ?X2 => simplif_term X1;simplif_term X2;unfold interp_AP_to_Point;simpl
end.
Fixpoint natle (n m:nat) {struct m} : bool :=
match n, m with
| O, O => true
| O, Datatypes.S n' => true
| Datatypes.S n', Datatypes.S m' => natle n' m'
| _, _ => false
end.
Fixpoint uniformize_areas (e:AF) {struct e} : AF :=
match e with
| AFplus e1 e2 =>
let s1 := (uniformize_areas e1) in
let s2 := (uniformize_areas e2) in
AFplus s1 s2
| AFmult e1 e2 =>
let s1 := (uniformize_areas e1) in
let s2 := (uniformize_areas e2) in
AFmult s1 s2
| AFopp e1 =>
let s1 := (uniformize_areas e1) in
AFopp s1
| AFinv e1 =>
let s1 := (uniformize_areas e1) in
AFinv s1
| AS e1 e2 e3 => if (natle e1 e2) then
(if (natle e2 e3) then (AS e1 e2 e3) else
(if (natle e1 e3)  then  (AFopp (AS e1 e3 e2)) else (AS e3 e1 e2)))
else (if (natle e2 e3) then
(if (natle e1 e3) then (AFopp (AS e2 e1 e3)) else (AS e2 e3 e1))
else (AFopp (AS e3 e2 e1)))
| AD e1 e2 => if (natle e1 e2) then (AD e1 e2) else  (AFopp (AD e2 e1))
| _ => e
end.

Lemma uniformize_areas_correct :
forall (e:AF) (lvar:list (prodT AVars nat)),
interp_AF_to_F lvar (uniformize_areas e) =
interp_AF_to_F lvar e.