Load loadpath.
Permutation Coq.MSets.MSetAVL.
veristar.compare veristar.redblack.
(** The clause datatype and related definitions and lemmas *)
(** pure_atom: pure atoms *)
Inductive pure_atom := Eqv : expr -> expr -> pure_atom.
Let var1 : var := Z2id 1.
Let var0 : var := Z2id 0.
Let var2 : var := Z2id 2.
Fixpoint list_prio {A} (weight: var) (l: list A) (p: var) : var :=
match l with
| nil => p
| _::l' => list_prio weight l' (add_id weight p)
end.
(** Weight the positive atoms 1 each, and the negative atoms 2 each. Then the highest-priority terms will be the positive unit clauses *)
Definition prio (gamma delta: list pure_atom) : var :=
list_prio var2 gamma (list_prio var1 delta var0).
(** clause: clauses are either pure (no spatial atoms), negative spatial (spatial atom on the left) or positive spatial. *)
Inductive clause : Type :=
| PureClause : forall (gamma : list pure_atom) (delta : list pure_atom)
(priority : var)
(prio_ok: prio gamma delta = priority), clause
| PosSpaceClause : forall (gamma : list pure_atom) (delta : list pure_atom)
(sigma : list space_atom), clause
| NegSpaceClause : forall (gamma : list pure_atom) (sigma : list space_atom)
(delta : list pure_atom), clause.
Definition expr_cmp e e' :=
match e, e' with
| Nil , Nil => Eq
| Nil, _ => Lt
| _, Nil => Gt
| Var v, Var v' => Ident.compare v v'
end.
Hint Resolve expr_cspec.
Definition pure_atom_cmp (a a': pure_atom) : comparison :=
match a, a' with
| Eqv e1 e2, Eqv e1' e2' =>
match expr_cmp e1 e1' with
Eq => expr_cmp e2 e2' | c => c
end
end.
Hint Rewrite @comp_refl using solve[auto] : comp.
Ltac comp_tac :=
progress (autorewrite with comp in *; auto)
|| discriminate
|| solve [eapply comp_trans;  eauto]
|| subst
|| match goal with
| H: Lt = ?A |- context [?A] => rewrite <- H
| H: Gt = ?A |- context [?A] => rewrite <- H
| H: Eq = ?A |- context [?A] => rewrite <- H
end.
Proof with repeat comp_tac.
repeat split; repeat intro.
destruct x; simpl in H...
destruct x; destruct y; destruct z; simpl in *...
do_comp expr_cspec e e1...
do_comp expr_cspec e1 e3...
do_comp expr_cspec e1 e3...
rewrite <- (comp_trans _ expr_cspec _ _ _ e5 e6)...
destruct x; destruct y.
simpl.
do_comp expr_cspec e e1...
do_comp expr_cspec e0 e2; econstructor; eauto; simpl...
econstructor; simpl...
econstructor; simpl...
Qed.
Hint Resolve pure_atom_cspec.
Hint Resolve pure_atom_cmp_eq.
(** ordering expressions, atoms and clauses *)
Definition expr_order (t t': expr) := isGe (expr_cmp t t').
Inductive max_expr (t : expr) : pure_atom -> Prop :=
| mexpr_left : forall t', expr_order t t' -> max_expr t (Eqv t t')
| mexpr_right : forall t', expr_order t t' -> max_expr t (Eqv t' t).
Definition order_eqv_pure_atom (a: pure_atom) :=
match a with
| Eqv i j => match expr_cmp i j with Lt => Eqv j i | _ => Eqv i j end
end.
Definition nonreflex_atom a :=
match a with Eqv i j => match expr_cmp i j with Eq => false | _ => true end
end.
Definition normalize_atoms pa :=
rsort_uniq pure_atom_cmp (map order_eqv_pure_atom pa).
Definition mkPureClause (gamma delta: list pure_atom) : clause :=
PureClause gamma delta _ (eq_refl _).
Definition order_eqv_clause (c: clause) :=
match c with
| PureClause pa pa' _ _ =>
mkPureClause (normalize_atoms (filter nonreflex_atom pa)) (normalize_atoms pa')
| PosSpaceClause pa pa' sa' =>
PosSpaceClause (normalize_atoms (filter nonreflex_atom pa))
(normalize_atoms pa') sa'
| NegSpaceClause pa sa pa' =>
NegSpaceClause (normalize_atoms (filter nonreflex_atom pa)) sa
(normalize_atoms pa')
end.
Definition mk_pureL (a: pn_atom) : clause :=
match a with
| Equ x y => mkPureClause nil (order_eqv_pure_atom(Eqv x y)::nil)
| Nequ x y => mkPureClause (order_eqv_pure_atom(Eqv x y)::nil) nil
end.
Fixpoint mk_pureR (al: list pn_atom) : list pure_atom * list pure_atom :=
match al with
| nil => (nil,nil)
| Equ x y :: l' => match mk_pureR l' with (p,n) =>
(order_eqv_pure_atom(Eqv x y)::p, n) end
| Nequ x y :: l' => match mk_pureR l' with (p,n) =>
(p, order_eqv_pure_atom(Eqv x y)::n) end
end.
(** cnf: clausal normal form *)
Definition cnf (en: entailment) : list clause :=
match en with
Entailment (Assertion pureL spaceL) (Assertion pureR spaceR) =>
match mk_pureR pureR with (p,n) =>
map mk_pureL pureL ++ (PosSpaceClause nil nil spaceL :: nil) ++
match spaceL, spaceR with
| nil, nil => mkPureClause p n :: nil
| _, _ => NegSpaceClause p spaceR n :: nil
end
end
end.
(** various comparison functions *)
Definition pure_atom_geq a b := isGeq (pure_atom_cmp a b).
Definition pure_atom_gt a b := match pure_atom_cmp a b with Gt => true | _ => false end.
Definition pure_atom_eq a b := match pure_atom_cmp a b with Eq => true | _ => false end.
Definition expr_lt a b := match expr_cmp a b with Lt => true | _ => false end.
Definition expr_eq a b := match expr_cmp a b with Eq => true | _ => false end.
Definition expr_geq a b := match expr_cmp a b with Lt => false | _ => true end.
Definition norm_pure_atom (a : pure_atom) :=
match a with
| Eqv i j => if expr_lt i j then Eqv j i else Eqv i j
end.
Definition subst_pure (i: var) (t: expr) (a: pure_atom) :=
match a with
| Eqv t1 t2 => Eqv (subst_expr i t t1) (subst_expr i t t2)
end.
Definition subst_pures (i: var) (t: expr) (pa: list pure_atom)
: list pure_atom := map (subst_pure i t) pa.
Definition compare_space_atom (a b : space_atom) : comparison :=
match a , b with
| Next i j , Next i' j' => match expr_cmp i i' with Eq => expr_cmp j j' | c => c end
| Next i j, Lseg i' j' =>
match expr_cmp i i' with
| Lt => Lt
| Eq => Lt
| Gt => Gt
end
| Lseg i j, Next i' j' =>
match expr_cmp i i' with
| Lt => Lt
| Eq => Gt
| Gt => Gt
end
| Lseg i j , Lseg i' j' => match expr_cmp i i' with Eq => expr_cmp j j' | c => c end
end.
Proof with (repeat (comp_tac || solve [econstructor; simpl; repeat comp_tac])).
repeat constructor; repeat intro.
destruct x; simpl in *...
destruct x; destruct y; simpl in *...
do_comp expr_cspec e e1...
destruct z; simpl in *...
do_comp expr_cspec e1 e...
destruct z; simpl in *...
do_comp expr_cspec e1 e4...
rewrite <- (comp_trans _ expr_cspec _ _ _ e3 e6)...
do_comp expr_cspec e1 e4...
rewrite <- (comp_trans _ expr_cspec _ _ _ e3 e6)...
do_comp expr_cspec e e1...
destruct z; simpl in *.
do_comp expr_cspec e1 e...
do_comp expr_cspec e1 e...
destruct z; simpl in *.
do_comp expr_cspec e1 e4...
rewrite <- (comp_trans _ expr_cspec _ _ _ e3 e6)...
do_comp expr_cspec e1 e4...
rewrite <- (comp_trans _ expr_cspec _ _ _ e3 e6)...
destruct z; simpl in *.
do_comp expr_cspec e e1...
do_comp expr_cspec e1 e3...
rewrite <- (comp_trans _ expr_cspec _ _ _ e5 e6)...
do_comp expr_cspec e e1...
do_comp expr_cspec e1 e3...
rewrite <- (comp_trans _ expr_cspec _ _ _ e5 e6)...
do_comp expr_cspec e e1...
destruct z; simpl in *.
do_comp expr_cspec e1 e...
do_comp expr_cspec e1 e...
destruct z; simpl in *.
do_comp expr_cspec e1 e4...
rewrite <- (comp_trans _ expr_cspec _ _ _ e3 e6)...
do_comp expr_cspec e1 e4...
rewrite <- (comp_trans _ expr_cspec _ _ _ e3 e6)...
destruct x; destruct y; simpl...
do_comp expr_cspec e e1; simpl...
do_comp expr_cspec e0 e2...
do_comp expr_cspec e e1...
do_comp expr_cspec e e1...
do_comp expr_cspec e e1...
do_comp expr_cspec e0 e2...
Qed.
Hint Resolve space_atom_cspec.
Definition compare_clause (cl1 cl2 : clause) : comparison :=
match cl1 , cl2 with
| PureClause neg pos _ _ , PureClause neg' pos' _ _ =>
match compare_list pure_atom_cmp neg neg' with
| Eq => compare_list pure_atom_cmp pos pos'
| c => c
end
| PureClause _ _ _ _ , _ => Lt
| _ , PureClause _ _ _ _ => Gt
| PosSpaceClause gamma delta sigma , PosSpaceClause gamma' delta' sigma'
| NegSpaceClause gamma sigma delta , NegSpaceClause gamma' sigma' delta' =>
match compare_list pure_atom_cmp gamma gamma' with
| Eq => match compare_list pure_atom_cmp delta delta' with
| Eq => compare_list compare_space_atom sigma sigma'
| c => c
end
| c => c
end
| PosSpaceClause _ _ _ , NegSpaceClause _ _ _ => Lt
| NegSpaceClause _ _ _ , PosSpaceClause _ _ _ => Gt
end.

Lemma clause_cspec: CompSpec' compare_clause.