Fixpoint xcnf {TX : kind -> Type} {AF: Type} (pol : bool) (k: kind) (f : TFormula TX AF k)  {struct f}: cnf :=
match f with
| TT _ => if pol then cnf_tt else cnf_ff
| FF _ => if pol then cnf_ff else cnf_tt
| X _ p => if pol then cnf_ff else cnf_ff (* This is not complete - cannot negate any proposition *)
| A _ x t => if pol then normalise x  t else negate x  t
| NOT e  => xcnf (negb pol) e
| AND e1 e2 => mk_and xcnf pol e1 e2
| OR e1 e2  => mk_or xcnf pol e1 e2
| IMPL e1 _ e2 => mk_impl xcnf pol e1 e2
| IFF e1 e2 => match is_bool e2 with
| Some isb => xcnf (if isb then pol else negb pol) e1
| None  => mk_iff xcnf pol e1 e2
end
| EQ e1 e2 =>
match is_bool e2 with
| Some isb => xcnf (if isb then pol else negb pol) e1
| None  => mk_iff xcnf pol e1 e2
end
end.
Section CNFAnnot.
(** Records annotations used to optimise the cnf. Those need to be kept when pruning the formula. For efficiency, this is a separate function. *)
Fixpoint radd_term (t : Term' * Annot) (cl : clause) : clause + Trace :=
match cl with
| nil => (* if t is unsat, the clause is empty BUT t is needed. *)
match deduce (fst t) (fst t) with
| Some u => if unsat u then inr (push (snd t) null) else inl (t::nil)
| None   => inl (t::nil)
end
| t'::cl => (* if t /\ t' is unsat, the clause is empty BUT t & t' are needed *)
match deduce (fst t) (fst t') with
| Some u => if unsat u then inr (push (snd t) (push (snd t') null))
else match radd_term t cl with
| inl cl' => inl (t'::cl')
| inr l   => inr l
end
| None  => match radd_term t cl  with
| inl cl' => inl (t'::cl')
| inr l   => inr l
end
end
end.
Fixpoint ror_clause cl1 cl2 :=
match cl1 with
| nil => inl cl2
| t::cl => match radd_term t cl2 with
| inl cl' => ror_clause cl cl'
| inr l   => inr l
end
end.
Definition xror_clause_cnf t f :=
List.fold_left (fun '(acc,tg) e  =>
match ror_clause t e with
| inl cl => (cl :: acc,tg)
| inr l => (acc,merge tg l)
end) f (nil, null).
Definition ror_clause_cnf t f :=
match t with
| nil => (f, null)
| _   => xror_clause_cnf t f
end.
Fixpoint ror_cnf (f f':list clause) :=
match f with
| nil => (cnf_tt, null)
| e :: rst =>
let (rst_f',t) := ror_cnf rst f' in
let (e_f', t') := ror_clause_cnf e f' in
(rst_f' +++ e_f', merge t t')
end.
Definition annot_of_clause (l : clause) : list Annot :=
List.map snd l.
Definition annot_of_cnf (f : cnf) : list Annot :=
List.fold_left (fun acc e => annot_of_clause e +++ acc ) f nil.
Definition ror_cnf_opt f1 f2 :=
if is_cnf_tt f1
then (cnf_tt, null)
else if is_cnf_tt f2
then (cnf_tt, null)
else if is_cnf_ff f2
then (f1, null)
else ror_cnf f1 f2.
Definition ocons {A : Type} (o : option A) (l : list A) : list A :=
match o with
| None => l
| Some e => e ::l
end.
Definition ratom (c : cnf) (a : Annot) : cnf * Trace :=
if is_cnf_ff c || is_cnf_tt c
then (c,push a null)
else (c,null). (* t is embedded in c *)
Section REC.
Context {TX : kind -> Type} {AF : Type}.
Variable RXCNF : forall (polarity: bool) (k: kind) (f: TFormula TX AF k) , cnf * Trace.
Definition rxcnf_and (polarity:bool) (k: kind) (e1 e2 : TFormula TX AF k) :=
let '(e1,t1) := RXCNF polarity e1 in
let '(e2,t2) := RXCNF polarity e2 in
if polarity
then  (and_cnf_opt e1  e2, merge t1 t2)
else let (f',t') := ror_cnf_opt e1 e2 in
(f', merge t1 (merge t2 t')).
Definition rxcnf_or (polarity:bool) (k: kind) (e1 e2 : TFormula TX AF k) :=
let '(e1,t1) := RXCNF polarity e1 in
let '(e2,t2) := RXCNF polarity e2 in
if polarity
then let (f',t') := ror_cnf_opt e1 e2 in
(f', merge t1 (merge t2 t'))
else (and_cnf_opt e1 e2, merge t1 t2).
Definition rxcnf_impl (polarity:bool) (k: kind) (e1 e2 : TFormula TX AF k) :=
let '(e1 , t1) := (RXCNF (negb polarity) e1) in
if polarity
then
if is_cnf_tt e1
then (e1,t1)
else if is_cnf_ff e1
then
RXCNF polarity e2
else (* compute disjunction *)
let '(e2 , t2) := (RXCNF polarity e2) in
let (f',t') := ror_cnf_opt e1 e2 in
(f', merge t1 (merge t2 t')) (* record the hypothesis *)
else
let '(e2 , t2) := (RXCNF polarity e2) in
(and_cnf_opt e1 e2, merge t1 t2).
Definition rxcnf_iff (polarity:bool) (k: kind) (e1 e2 : TFormula TX AF k) :=
let '(c1,t1) := RXCNF (negb polarity) e1 in
let '(c2,t2) := RXCNF false e2 in
let '(c3,t3) := RXCNF polarity e1 in
let '(c4,t4) := RXCNF true e2 in
let (f',t') := ror_cnf_opt (and_cnf_opt c1 c2) (and_cnf_opt c3 c4) in
(f', merge t1 (merge t2 (merge t3 (merge t4 t'))))
.
End REC.
Fixpoint rxcnf {TX : kind -> Type} {AF: Type}(polarity : bool) (k: kind) (f : TFormula TX AF k) : cnf * Trace :=
match f with
| TT _ => if polarity then (cnf_tt, null) else (cnf_ff, null)
| FF _  => if polarity then (cnf_ff, null) else (cnf_tt, null)
| X b p => if polarity then (cnf_ff, null) else (cnf_ff, null)
| A _ x t  => ratom (if polarity then normalise x t else negate x t) t
| NOT e  => rxcnf (negb polarity) e
| AND e1 e2 => rxcnf_and rxcnf polarity e1 e2
| OR e1 e2  => rxcnf_or rxcnf polarity e1 e2
| IMPL e1 a e2 => rxcnf_impl rxcnf polarity e1 e2
| IFF e1 e2 => rxcnf_iff rxcnf polarity e1 e2
| EQ e1 e2  => rxcnf_iff rxcnf polarity e1 e2
end.
Section Abstraction.
Variable TX : kind -> Type.
Variable AF : Type.
Class to_constrT : Type :=
{
mkTT   : forall (k: kind), TX k;
mkFF   : forall (k: kind), TX k;
mkA    : forall (k: kind), Term -> Annot -> TX k;
mkAND  : forall (k: kind), TX k -> TX k -> TX k;
mkOR   : forall (k: kind), TX k -> TX k -> TX k;
mkIMPL : forall (k: kind), TX k -> TX k -> TX k;
mkIFF  : forall (k: kind), TX k -> TX k -> TX k;
mkNOT  : forall (k: kind), TX k -> TX k;
mkEQ   : TX isBool -> TX isBool -> TX isProp
}.
Context {to_constr : to_constrT}.
Fixpoint aformula (k: kind) (f : TFormula TX AF k) : TX k :=
match f with
| TT b => mkTT b
| FF b => mkFF b
| X b p => p
| A b x t => mkA b x t
| AND f1 f2 => mkAND  (aformula f1) (aformula f2)
| OR  f1 f2 => mkOR (aformula f1) (aformula f2)
| IMPL f1 o f2 => mkIMPL  (aformula f1) (aformula f2)
| IFF f1 f2 => mkIFF  (aformula f1) (aformula f2)
| NOT f     => mkNOT  (aformula f)
| EQ f1 f2  => mkEQ (aformula f1) (aformula f2)
end.
Definition is_X (k: kind) (f : TFormula TX AF k) : option (TX k) :=
match f with
| X _ p => Some p
| _   => None
end.

(* Specifications: *)
Lemma is_X_inv : forall (k: kind) (f: TFormula TX AF k) x,
is_X f = Some x -> f = X k x.