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.(** 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).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'))))
      .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.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

        }.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

        }.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

        }.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

        }.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

        }.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

        }.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

        }.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

        }.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

        }.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

        }.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.Ltac is_X t :=
        match goal with
        | |-context[is_X ?X] =>
          let f := fresh "EQ" in
          destruct (is_X X) as [t|] eqn:f ;
          [apply is_X_inv in f|]
        end.

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