(*  TODO
  - add support to F_True and F_False
  - cut rules
  - optimize autorewrite
  - subst in fsetform (to speed up the decision procedure)
  - optimize br_ext_single
*)

(*  Proof by reflection implementation of
    Anisimov, Alexander. Proof Automation for Typed Finite Sets. 2015. *)
(* -------------------------------------------------------------------- *)
From mathcomp Require Import all_ssreflect.
From elpi     Require Export elpi.
(* ------- *) Require Import BinPos Number Decimal.

(* -------------------------------------------------------------------- *)
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Unset SsrOldRewriteGoalsOrder.

(* -------------------------------------------------------------------- *)

(*
  The tactic fsetdec solves goals of the form F :

  F ::=
  | P
  | ~ F
  | F /\ F'
  | F \/ F'
  | F -> F'
  | F <-> F'

  P ::=
  | X = X'
  | S = S'
  | X \in S
  | S \subset S'

  S ::=
  | V
  | set0
  | setT
  | set1 X
  | setC S
  | setU F F'
  | setI F F'
  | setD F F'

  X ::= x1 | ... | xm (element variables)
  V ::= v1 | ... | vn (set variables)

  The tactic fsetdec_bool solves goals of the form Fb :

  Fb ::=
  | Pb
  | ~~ Fb
  | Fb && Fb'
  | Fb || Fb'
  | Fb ==> Fb'

  Pb ::=
  | X == X'
  | S == S'
  | X \in S
  | S \subset S'
*)

Notation eltvar := positive.

Inductive fsetsyn : Type :=
| FSS_empty
| FSS_full
| FSS_single of eltvar
| FSS_var   of positive
| FSS_union of fsetsyn & fsetsyn
| FSS_diff  of fsetsyn & fsetsyn
| FSS_inter of fsetsyn & fsetsyn
.

Variant fsetelt : Type :=
  | FE_var of eltvar
  | FE_exvar of fsetsyn & fsetsyn.

Variant fsetpred : Type :=
  | FSP_In    of fsetelt & fsetsyn
  | FSP_Eqelt of fsetelt & fsetelt
  | FSP_Eqset of fsetsyn & fsetsyn
  | FSP_Sub   of fsetsyn & fsetsyn.

Inductive fsetform : Type :=
| F_Pred  of fsetpred
| F_Not   of fsetform
| F_And   of fsetform & fsetform
| F_Or    of fsetform & fsetform
| F_Imply of fsetform & fsetform
| F_False
| F_True
.

(* eqType of syntax terms *)

Fixpoint eqp (x y : positive) :=
  match x, y with
  | xH, xH => true
  | xO a, xO b => eqp a b
  | xI a, xI b => eqp a b
  | _, _ => false
  end.

Lemma eqpP : Equality.axiom eqp.
Proof.
  move=> x y; apply: (iffP idP).
  elim: x y.
  - by move=> p Hp [] //= => p0 /Hp ->.
  - by move=> p Hp [] //= => p0 /Hp ->.
  - by case.
  - by move=> ->; elim: y => //=.
Qed.

Canonical positive_eqMixin := EqMixin eqpP.
Canonical positive_eqType := Eval hnf in EqType positive positive_eqMixin.

Fixpoint eq_fsetsyn x y :=
  match x, y with
  | FSS_empty, FSS_empty => true
  | FSS_full, FSS_full => true
  | FSS_single a, FSS_single b => a == b
  | FSS_var a, FSS_var b => a == b
  | FSS_union a b, FSS_union a' b' => eq_fsetsyn a a' && eq_fsetsyn b b'
  | FSS_diff a b, FSS_diff a' b' => eq_fsetsyn a a' && eq_fsetsyn b b'
  | FSS_inter a b, FSS_inter a' b' => eq_fsetsyn a a' && eq_fsetsyn b b'
  | _, _ => false
  end.

Lemma eq_eq_fsetsyn a :
  forall b, (a = b -> eq_fsetsyn a b).
Proof.
  elim: a.
  - by move=> b <-.
  - by move=> b <-.
  - move=> v b <- /=; exact: eqxx.
  - move=> v b <- /=; exact: eqxx.
    all: move=> x Hx y Hy b <- /=; by rewrite Hx // Hy.
Qed.

Lemma eq_fsetsyn_eq a :
  forall b, (eq_fsetsyn a b -> a = b).
Proof.
  elim: a.
  - by case.
  - by case.
  - by move=> x [] //= y /eqP ->.
  - by move=> x [] //= y /eqP ->.
    all: by move=> x Hx y Hy [] //= x' y' /andP [] /Hx -> /Hy ->.
Qed.

Lemma eq_fsetsynP : Equality.axiom eq_fsetsyn.
Proof.
  move=> a b; apply: (iffP idP); [apply: eq_fsetsyn_eq | apply: eq_eq_fsetsyn].
Qed.

Canonical fsetsyn_eqMixin := EqMixin eq_fsetsynP.
Canonical fsetsyn_eqType := Eval hnf in EqType fsetsyn fsetsyn_eqMixin.

Definition eq_fsetelt x y :=
  match x, y with
  | FE_var a, FE_var b => a == b
  | FE_exvar a b, FE_exvar a' b' => (a == a') && (b == b')
  | _, _ => false
  end.

Lemma eq_fseteltP : Equality.axiom eq_fsetelt.
Proof.
  move=> a b; apply: (iffP idP).
  - move: a => []; move: b => [] //= x y. by move/eqP=> ->.
  - by move=> a b /andP [] /eqP -> /eqP ->.
  - move=> ->; case: b => //= x y; by rewrite !eqxx.
Qed.

Canonical fsetelt_eqMixin := EqMixin eq_fseteltP.
Canonical fsetelt_eqType := Eval hnf in EqType fsetelt fsetelt_eqMixin.

Definition eq_fsetpred a b :=
  match a, b with
  | FSP_In x y, FSP_In x' y' => (x == x') && (y == y')
  | FSP_Eqelt x y, FSP_Eqelt x' y' => (x == x') && (y == y')
  | FSP_Eqset x y, FSP_Eqset x' y' => (x == x') && (y == y')
  | FSP_Sub x y, FSP_Sub x' y' => (x == x') && (y == y')
  | _, _ => false
  end.

Lemma eq_fsetpredP : Equality.axiom eq_fsetpred.
Proof.
  move=> a b; apply: (iffP idP).
  - case: a; by case: b => //= x x' y y' => /andP [] /eqP -> /eqP ->.
  - move=> -> //=; case: b => //=; move=> x y; by rewrite !eqxx.
Qed.

Canonical fsetpred_eqMixin := EqMixin eq_fsetpredP.
Canonical fsetpred_eqType := Eval hnf in EqType fsetpred fsetpred_eqMixin.

Fixpoint eq_fsetform a b :=
  match a, b with
  | F_Pred x, F_Pred y => x == y
  | F_Not x, F_Not y => eq_fsetform x y
  | F_And a b, F_And a' b'  => eq_fsetform a a' && eq_fsetform b b'
  | F_Or a b, F_Or a' b'  => eq_fsetform a a' && eq_fsetform b b'
  | F_Imply a b, F_Imply a' b'  => eq_fsetform a a' && eq_fsetform b b'
  | F_False, F_False => true
  | F_True, F_True => true
  | _, _ => false
  end.

Lemma eq_fsetformP : Equality.axiom eq_fsetform.
Proof.
  move=> a b; apply (iffP idP).
  - elim: a b; try by move=> x Hx y Hy [] //= x' y' /andP [] /Hx -> /Hy ->.
    + by move=> x [] //= y /eqP ->.
    + by move=> x Hx [] //= y /Hx ->.
    + by case.
    + by case.
  - move=> ->; elim: b => //=; by move=> x -> y ->.
Qed.

Canonical fsetform_eqMixin := EqMixin eq_fsetformP.
Canonical fsetform_eqType := Eval hnf in EqType fsetform fsetform_eqMixin.

Section fsetform_interp.
  Context {T : finType}.

  (*
    setvar_lst collects fset variables,
    var_lst collects T variables.
  *)
  Variable (setvar_lst : seq {set T}).
  Variable (var_lst : seq T).

  (* assignment of existential variables introduced by (S3) *)
  Variable asn : fsetsyn -> fsetsyn -> option T.

  Definition sem_eltvar (x : eltvar) :=
    List.nth_error var_lst (nat_of_pos x - 1).

  Definition sem_singleton (x : eltvar) :=
    match (sem_eltvar x) with
    | Some e => Some (set1 e)
    | None => None
    end.

  Fixpoint sem_fsetsyn (x : fsetsyn) : option {set T} :=
    match x with
    | FSS_empty => Some set0
    | FSS_full => Some setT
    | FSS_single e => sem_singleton e
    | FSS_var k => List.nth_error setvar_lst (nat_of_pos k - 1)
    | FSS_union a b =>
        match (sem_fsetsyn a), (sem_fsetsyn b) with
        | Some x, Some y => Some (setU x y)
        | _, _ => None
        end
    | FSS_diff a b =>
        match (sem_fsetsyn a), (sem_fsetsyn b) with
        | Some x, Some y => Some (setD x y)
        | _, _ => None
        end
    | FSS_inter a b =>
        match (sem_fsetsyn a), (sem_fsetsyn b) with
        | Some x, Some y => Some (setI x y)
        | _, _ => None
        end
    end.

  Definition sem_fsetelt x :=
    match x with
    | FE_var a => sem_eltvar a
    | FE_exvar a b => asn a b (* existential variable introduced by (S3) *)
    end.

  Definition sem_FSP_In (a : fsetelt) (A : fsetsyn) :=
    match (sem_fsetelt a), (sem_fsetsyn A) with
    | Some a, Some A => Some (a \in A)
    | _, _ => None
    end.

  Definition sem_FSP_Eqelt (a : fsetelt) (b : fsetelt) :=
    match (sem_fsetelt a), (sem_fsetelt b) with
    | Some x, Some y => Some (x == y)
    | _, _ => None
    end.

  Definition sem_FSP_Eqset (A : fsetsyn) (B : fsetsyn) :=
    match (sem_fsetsyn A), (sem_fsetsyn B) with
    | Some A, Some B => Some (A == B)
    | _, _ => None
    end.

  Definition sem_FSP_Sub (A : fsetsyn) (B : fsetsyn) :=
    match (sem_fsetsyn A), (sem_fsetsyn B) with
    | Some A, Some B => Some (A \subset B)
    | _, _ => None
    end.

  Definition sem_fsetpred (p : fsetpred) : option bool :=
    match p with
    | FSP_In a b => sem_FSP_In a b
    | FSP_Eqelt a b => sem_FSP_Eqelt a b
    | FSP_Eqset a b => sem_FSP_Eqset a b
    | FSP_Sub a b => sem_FSP_Sub a b
    end.

  Fixpoint sem_fsetform (f : fsetform) : option bool :=
    match f with
    | F_Pred p => (sem_fsetpred p)
    | F_Not f =>
        if (sem_fsetform f) is Some g then Some (~~ g) else None
    | F_And a b =>
        match (sem_fsetform a), (sem_fsetform b) with
        | Some a, Some b => Some (a && b)
        | _, _ => None
        end
    | F_Or a b =>
        match (sem_fsetform a), (sem_fsetform b) with
        | Some a, Some b => Some (a || b)
        | _, _ => None
        end
    | F_Imply a b =>
        match (sem_fsetform a), (sem_fsetform b) with
        | Some a, Some b => Some (a ==> b)
        | _, _ => None
        end
    | F_False => Some false
    | F_True => Some true
    end.

  (* check if there is an existential variable *)

  Definition elt_hasex (x y : fsetsyn) (e : fsetelt) :=
    match e with
    | FE_var _  => true
    | FE_exvar a b => (a == x) && (b == y)
    end.

  Definition pred_hasex x y (p : fsetpred) :=
    match p with
    | FSP_In a b => elt_hasex x y a
    | FSP_Eqelt a b => elt_hasex x y a || elt_hasex x y b
    | _ => false
    end.

  Fixpoint form_hasex x y (f : fsetform) :=
    match f with
    | F_Pred p => (pred_hasex x y p)
    | F_Not f => (form_hasex x y f)
    | F_And a b => (form_hasex x y a) || (form_hasex x y b)
    | F_Or a b => (form_hasex x y a) || (form_hasex x y b)
    | F_Imply a b => (form_hasex x y a) || (form_hasex x y b)
    | F_False => false
    | F_True => false
    end.

  Definition add_asn a b c :=
    fun x y =>
      match (x == a) && (y == b) with
      | true => Some c
      | false => asn x y
      end.

End fsetform_interp.

Section fsetform_decide.

  Variable T : finType.
  Variable (setvar_lst : seq {set T}).
  Variable (var_lst : seq T).

  Local Notation sem_elt := (@sem_fsetelt T var_lst).
  Local Notation sem_syn := (@sem_fsetsyn T setvar_lst var_lst).
  Local Notation sem_pred := (@sem_fsetpred T setvar_lst var_lst).
  Local Notation sem_form := (@sem_fsetform T setvar_lst var_lst).
  Definition valid_form asn f :=
    if (sem_form asn f) is Some b then b else false.

  Local Notation branch := (seq fsetform).
  Local Notation exasn := (fsetsyn -> fsetsyn -> option T).

  Lemma noex_sem_elt (e : fsetelt) x y z asn :
    ~~ elt_hasex x y e -> sem_elt (add_asn asn x y z) e = sem_elt asn e.
  Proof.
    by case: e => //= a b /negbTE H; rewrite /add_asn H.
  Qed.

  Lemma noex_sem_pred (p : fsetpred) x y z asn :
    ~~ pred_hasex x y p -> sem_pred (add_asn asn x y z) p = sem_pred asn p.
  Proof.
    case: p; try by [].
    - move=> a b /= H. by rewrite /sem_FSP_In noex_sem_elt.
    - move=> a b /=.
      rewrite negb_or => /andP [] /noex_sem_elt Ha /noex_sem_elt Hb.
      rewrite /sem_FSP_Eqelt Ha Hb //=.
  Qed.

  Lemma noex_sem_form (f : fsetform) x y z asn :
    ~~ form_hasex x y f -> sem_form (add_asn asn x y z) f = sem_form asn f.
  Proof.
    elim: f; try by move=> a Ha b Hb /=; rewrite negb_or => /andP [Pa Pb]; rewrite (Ha Pa) (Hb Pb).
    - move=> p Hp; by apply: noex_sem_pred.
    - by move=> f Hf /= /Hf ->.
    - by [].
    - by [].
  Qed.

  Lemma noex_valid_form (f : fsetform) x y z asn :
    ~~ form_hasex x y f -> valid_form (add_asn asn x y z) f = valid_form asn f.
  Proof.
    move/noex_sem_form => /(_ z asn). rewrite /valid_form.
    case: (sem_form _); case: (sem_form _) => //.
    by move=> ? ? [] ->.
  Qed.

  Lemma add_asnE asn a b c :
    sem_elt (add_asn asn a b c) (FE_exvar a b) = Some c.
  Proof.
    by rewrite /sem_elt /add_asn !eqxx.
  Qed.

  Notation F_NotSub a b := (F_Not (F_Pred (FSP_Sub a b))).

  Definition ext_nsub (a b : fsetsyn) :=
    [:: F_Pred (FSP_In (FE_exvar a b) a);
     (F_Not (F_Pred (FSP_In (FE_exvar a b) b)))].

  Lemma ext_nsub_sound a b :
    forall asn, valid_form asn (F_Not (F_Pred (FSP_Sub a b))) ->
                (exists c, all (valid_form (add_asn asn a b c)) (ext_nsub a b)).
  Proof.
    move=> asn. rewrite /valid_form /ext_nsub.
    remember (sem_form asn (F_NotSub a b)) as sf.
    case: sf Heqsf => //= ?.
    remember (sem_FSP_Sub setvar_lst var_lst a b) as sf.
    case: sf Heqsf => //= ?.
    rewrite /sem_FSP_Sub /sem_FSP_In.
    case: (sem_syn a) => // A.
    case: (sem_syn b) => // B [] -> [] ->.
    move/subsetPn=> [x xin xnin].
    exists x. by rewrite !add_asnE xin xnin.
  Qed.

  Definition is_nsub f : (prod fsetsyn fsetsyn) + (unit) :=
    match f with
    | F_Not (F_Pred (FSP_Sub a b)) => inl (a, b)
    | _ => inr tt
    end.

  (* S3 introduce existential variable *)

  Lemma is_nsubE f a b :
    (is_nsub f) = inl (a, b) -> f = (F_Not (F_Pred (FSP_Sub a b))).
  Proof.
    case: f => //=. move=> [] //= [] //= x y H.
    injection H. by move=> -> ->.
  Qed.

  Fixpoint br_ext_nsub_aux  (br res : branch) :=
    match br with
    | nil => res
    | f :: br =>
        match (is_nsub f) with
        | inl (a, b) =>
            match has (form_hasex a b) res with
            | true => br_ext_nsub_aux br res
            | false => br_ext_nsub_aux br ((ext_nsub a b) ++ res)
            end
        | inr _ => br_ext_nsub_aux br res
        end
    end.

  Lemma not_has_all_not {S : Type} f (s : seq S) :
    ~~ has f s -> all (fun x => ~~ f x) s.
  Proof.
    elim: s => //=; by move=> a s IH; rewrite negb_or => /andP [] -> /IH ->.
  Qed.

  Lemma noex_dont_change x y asn br c :
    ~~ has (form_hasex x y) br ->
    all (valid_form asn) br ->
    all (valid_form (add_asn asn x y c)) br.
  Proof.
    move=> /not_has_all_not.
    elim: br => //.
    move=> f br IH /= /andP [Hf] /IH Hbr /andP [].
    by rewrite -(noex_valid_form c asn Hf) => -> /Hbr ->.
  Qed.

  Lemma br_ext_nsub_aux_cat asn x y br:
    valid_form asn (F_Not (F_Pred (FSP_Sub x y))) ->
    ~~ has (form_hasex x y) br ->
    all (valid_form asn) br ->
    exists asn', all (valid_form asn') ((ext_nsub x y) ++ br).
  Proof.
    elim: br.
    - move=> /ext_nsub_sound [c Hc] _.
      exists (add_asn asn x y c). by [].
    - move=> f br IH /ext_nsub_sound [c Hc1].
      move=> /(@noex_dont_change x y asn (f::br) c) H /H Hc2.
      exists (add_asn asn x y c).
      by rewrite all_cat Hc1 Hc2.
  Qed.

  Lemma in_mem_all (S : eqType) P (A : seq S) x:
    x \in A -> all P A -> P x.
  Proof.
    elim: A => //. move=> a A IH. rewrite in_cons => /orP [].
    - by move=> /eqP -> /andP [].
    - by move=> {}/IH IH /andP [_] /IH.
  Qed.

  Lemma sub_mem_all {S : eqType} P (A B : seq S) :
    {subset A <= B} -> all P B -> all P A.
  Proof.
    elim: A B => //=.
    - move=> a A IH B Hsub PB.
      assert (aincons : a \in a :: A). by apply: mem_head.
      assert (ainB := Hsub _ aincons).
      rewrite (in_mem_all ainB PB).
      assert (AsB : {subset A <= B}).
    - move=> x xinA. apply: Hsub. by rewrite in_cons xinA orbT.
      by rewrite (IH _ AsB PB).
  Qed.

  Lemma subseq_all {S : eqType} P (A B : seq S) :
    subseq A B -> all P B -> all P A.
  Proof.
    by move=> /mem_subseq /sub_mem_all; apply.
  Qed.

  Lemma br_ext_nsub_aux_subseq br res :
    subseq res (br_ext_nsub_aux br res).
  Proof.
    elim: br res.
    - by move=> res; apply: subseq_refl.
    - move=> f br IH res /=.
      case: (is_nsub f).
      + move=> [a b]. case: (has (form_hasex a b) res).
        * apply: IH.
        * eapply (subseq_trans (subseq_cons _ _)).
          eapply (subseq_trans (subseq_cons _ _)).
          apply IH.
        * move=> _; apply: IH.
  Qed.

  Lemma br_ext_nsub_aux_sound br res asn:
    subseq br res ->
    all (valid_form asn) res ->
    exists asn', all (valid_form asn') (br_ext_nsub_aux br res).
  Proof.
    elim: br res asn.
    - move=> res asn _ H; exists asn; by [].
    - move=> f br IH res asn Hbr Hres.
      change (br_ext_nsub_aux (f :: br) res) with
        match (is_nsub f) with
        | inl (a, b) =>
            match has (form_hasex a b) res with
            | true => br_ext_nsub_aux br res
            | false => br_ext_nsub_aux br ((ext_nsub a b) ++ res)
            end
        | inr _ => br_ext_nsub_aux br res
        end.
      move: (@is_nsubE f); case: (is_nsub f).
      + move=> [a b] Hab.
        move: (@br_ext_nsub_aux_cat asn a b res).
        assert (sbr : subseq br res).
        by eapply (subseq_trans (subseq_cons _ _)); apply: Hbr.
        case: (has (form_hasex a b) res).
        * move=> _; apply: IH. apply: sbr. apply: Hres.
        * move=> Hext.
          assert (allfbr : all (valid_form asn) (f :: br)).
          by apply: subseq_all; [apply: Hbr | apply: Hres].
          assert (Hf : valid_form asn f).
          by move: allfbr => /andP [].
          assert (eqf: f = (F_Not (F_Pred (FSP_Sub a b)))). by apply: Hab.
          rewrite eqf in Hf.
          move: (Hext Hf erefl Hres) => [asn' Hasn'].
          apply (IH _ asn').
          assert (sres : subseq res (ext_nsub a b ++ res)).
          by apply : suffix_subseq.
          apply (subseq_trans sbr sres).
          apply Hasn'.
      + move=> _ _. apply: IH.
        assert (H1 : subseq br (f :: br)). apply: subseq_cons.
        eapply (subseq_trans H1 Hbr).
        apply Hres.
  Qed.

  (* Eval cbv in
    (br_ext_nsub_aux [:: F_Not (F_Pred (FSP_Sub (FSS_var xH) (FSS_var xH)))]
                     [:: F_Not (F_Pred (FSP_Sub (FSS_var xH) (FSS_var xH)))]
    ). *)

  Definition br_ext_nsub br := br_ext_nsub_aux br br.

  Lemma br_ext_nsub_sound asn br :
    all (valid_form asn) br -> exists asn', all (valid_form asn') (br_ext_nsub br).
  Proof.
    move=> H.
    rewrite /br_ext_nsub.
    apply: br_ext_nsub_aux_sound. apply: subseq_refl. apply: H.
  Qed.

  (*
Definition nodup_cons {S : eqType} x (s : seq S) :=
  if (x \in s) then s else (x :: s).

Fixpoint nodup_cat {S : eqType} (a b : seq S) :=
  match a with
  | nil => b
  | x :: xs => nodup_cons x (nodup_cat xs b)
  end.

Lemma all_nodup_cons {S : eqType} (p : S -> bool) x (s : seq S) :
  p x -> all p s -> all p (nodup_cons x s).
Proof.
  elim: s.
  - by rewrite /nodup_cons => /= ->.
  - move=> a s IH IHx IHs.
    rewrite /nodup_cons.
    case: (x \in a :: s).
    + by apply IHs.
    + move=> /=.
      rewrite IHx => /=.
      change (p a && all p s) with (all p (a :: s)).
      by rewrite IHs.
Qed.

Lemma all_nodup_cat {S : eqType} (p : S -> bool) (a b : seq S) :
  all p a -> all p b -> all p (nodup_cat a b).
Proof.
  elim: a => //=.
  move=> x s IH /andP [Hx Hs] Hb.
  apply: all_nodup_cons. apply: Hx. by apply: IH.
  Qed.
   *)

  Definition all_undup {S : eqType} (p : S -> bool) (s : seq S) :
    all p (undup s) = all p s
    := (eq_all_r (mem_undup s) p).

  (* P1 P5 P6 P7 S4 S8 S9 S10 S11 S13 S14 *)

  Fixpoint ext_single (ext : fsetform -> seq fsetform) (br : branch) :=
    match br with
    | nil => nil
    | f :: fs => (ext f) ++ (ext_single ext fs)
    end.

  Definition br_ext_single ext (br : branch) :=
    (ext_single ext br) ++ br.

  Lemma ext_single_sound ext br asn :
    (forall f, (valid_form asn f) -> all (valid_form asn) (ext f)) ->
    all (valid_form asn) br -> all (valid_form asn) (ext_single ext br).
  Proof.
    move=> H.
    elim: br => //.
    move=> f br IH /andP [IHf IHbr] /=. move: (H f) => {H}.
    move=> H. by rewrite all_cat (H IHf) /= (IH IHbr).
  Qed.

  Lemma br_ext_single_sound ext br asn :
    (forall f, (valid_form asn f) -> all (valid_form asn) (ext f)) ->
    all (valid_form asn) br -> all (valid_form asn) (br_ext_single ext br).
  Proof. move=> H Hbr. by rewrite all_cat Hbr ext_single_sound. Qed.

  (* P1 *)

  Definition ext_and (f : fsetform) :=
    match f with
    | F_And a b => [:: a; b]
    | _ => nil
    end.

  Lemma ext_and_sound asn f :
    (valid_form asn f) -> all (valid_form asn) (ext_and f).
  Proof.
    rewrite /ext_and /valid_form. case: f => //. move=> a b /=.
    do 2 (case: (sem_form _) => //). by move=> ? ?; rewrite andbT.
  Qed.

  (* P5 *)

  Definition ext_nor (f : fsetform) :=
    match f with
    | F_Not (F_Or a b) => [:: F_Not a; F_Not b]
    | _ => nil
    end.

  Lemma ext_nor_sound asn f:
    (valid_form asn f) -> all (valid_form asn) (ext_nor f).
  Proof.
    rewrite /ext_nor /valid_form. case: f => //. case => //. move=> a b /=.
    do 2 (case: (sem_form _) => //). by move=> ? ?; rewrite negb_or andbT.
  Qed.

  (* P6 *)

  Definition ext_nimp (f : fsetform) :=
    match f with
    | F_Not (F_Imply a b) => [:: a; F_Not b]
    | _ => nil
    end.

  Lemma ext_nimp_sound asn f:
    (valid_form asn f) -> all (valid_form asn) (ext_nimp f).
  Proof.
    rewrite /ext_nor /valid_form. case: f => //. case => //. move=> a b /=.
    do 2 (case: (sem_form _) => //). by move=> ? ?; rewrite negb_imply andbT.
  Qed.

  (* P7 *)

  Definition ext_nnot(f : fsetform) :=
    match f with
    | F_Not (F_Not a) => [:: a]
    | _ => nil
    end.

  Lemma ext_nnot_sound asn f:
    (valid_form asn f) -> all (valid_form asn) (ext_nnot f).
  Proof.
    rewrite /ext_nor /valid_form. case: f => //. case => //. move=> f /=.
    case: (sem_form _) => //. by move=> ? /negbNE ->.
  Qed.

  (* S4 *)

  Definition ext_fseteq (f : fsetform) :=
    match f with
    | F_Pred (FSP_Eqset a b) => [:: F_Pred (FSP_Sub a b); F_Pred (FSP_Sub b a)]
    | _ => nil
    end.

  Lemma ext_fseteq_sound asn f:
    (valid_form asn f) -> all (valid_form asn) (ext_fseteq f).
  Proof.
    rewrite /ext_fseteq /valid_form. case: f => //. case=> //.
    move=> a b /=. rewrite /sem_FSP_Eqset /sem_FSP_Sub.
    case: (sem_syn _) => //; case: (sem_syn _) => //.
    move=> ? ? /eqP ->. by rewrite !subxx.
  Qed.

  (* S8 *)

  Definition ext_elteq (f : fsetform) :=
    match f with
    | F_Pred (FSP_Eqelt a b) => [:: F_Pred (FSP_Eqelt b a)]
    | _ => nil
    end.

  Lemma ext_elteq_sound asn f:
    (valid_form asn f) -> all (valid_form asn) (ext_elteq f).
  Proof.
    rewrite /ext_elteq /valid_form. case: f => //. case=> //.
    move=> a b /=. rewrite /sem_FSP_Eqelt.
    case: (sem_elt asn a); case: (sem_elt asn b) => //.
    move=> x y /eqP ->; by rewrite eqxx.
  Qed.

  (* S9 *)

  Definition ext_insingle (f : fsetform) :=
    match f with
    | F_Pred (FSP_In a (FSS_single b)) => [:: F_Pred (FSP_Eqelt a (FE_var b))]
    | _ => nil
    end.

  Lemma ext_insingle_sound asn f:
    (valid_form asn f) -> all (valid_form asn) (ext_insingle f).
  Proof.
    rewrite /ext_insingle /valid_form. case: f => //. case=> //=.
    move=> a. case=> // b /=.
    rewrite /sem_FSP_In /sem_FSP_Eqelt. case: (sem_elt asn a) => //= x.
    rewrite /sem_singleton. case: (sem_eltvar _) => // y.
    by rewrite in_set1 => ->.
  Qed.

  (* S10 *)

  Definition ext_ninsingle (f : fsetform) :=
    match f with
    | F_Not (F_Pred (FSP_In a (FSS_single b))) =>
        [:: F_Not (F_Pred (FSP_Eqelt a (FE_var b)))]
    | _ => nil
    end.

  Lemma ext_ninsingle_sound asn f:
    (valid_form asn f) -> all (valid_form asn) (ext_ninsingle f).
  Proof.
    rewrite /ext_insingle /valid_form. case: f => //. case=>//=. case=>//=.
    move=> a. case=> // b /=.
    rewrite /sem_FSP_In /sem_FSP_Eqelt. case: (sem_elt asn a) => //= x.
    rewrite /sem_singleton. case: (sem_eltvar _) => // y.
    by rewrite in_set1 => ->.
  Qed.

  (* S11 *)

  Definition ext_singlesub (f : fsetform) :=
    match f with
    | (F_Pred (FSP_Sub (FSS_single a) b)) => [:: (F_Pred (FSP_In (FE_var a) b))]
    | _ => nil
    end.

  Lemma ext_singlesub_sound asn f:
    (valid_form asn f) -> all (valid_form asn) (ext_singlesub f).
  Proof.
    rewrite /ext_singlesub /valid_form. case: f => //. case=> //. case=> //.
    move=> a b /=. rewrite /sem_FSP_Sub /= /sem_FSP_In /sem_singleton /sem_elt.
    case: (sem_eltvar var_lst a) => // x. case: (sem_syn _) => // B.
    by rewrite sub1set => ->.
  Qed.

  (* S13 *)

  Definition ext_ninunion (f : fsetform) :=
    match f with
    | F_Not (F_Pred (FSP_In a (FSS_union b c))) =>
        [:: F_Not (F_Pred (FSP_In a b)); F_Not (F_Pred (FSP_In a c))]
    | _ => nil
    end.

  Lemma ext_ninunion_sound asn f:
    (valid_form asn f) -> all (valid_form asn) (ext_ninunion f).
  Proof.
    rewrite /ext_ninunion /valid_form. case: f => //. case=> //. case=> //.
    move=> a. case=> // b c /=.
    rewrite /sem_FSP_In. case: (sem_elt asn a) => // x /=.
    case: (sem_syn _) => // B. case: (sem_syn _) => // C.
    by rewrite in_setU negb_or => /andP [] -> ->.
  Qed.

  (* S14 *)

  Definition ext_indiff (f : fsetform) :=
    match f with
    | (F_Pred (FSP_In a (FSS_diff b c))) =>
        [:: (F_Pred (FSP_In a b)); F_Not (F_Pred (FSP_In a c))]
    | _ => nil
    end.

  Lemma ext_indiff_sound asn f:
    (valid_form asn f) -> all (valid_form asn) (ext_indiff f).
  Proof.
    rewrite /ext_indiff /valid_form. case: f => // [] // [] //.
    move=> a. case=> // b c /=.
    rewrite /sem_FSP_In. case: (sem_elt asn a) => // {a} x /=.
    case: (sem_syn _) => // B. case: (sem_syn _) => // C.
    by rewrite in_setD => /andP [] -> ->.
  Qed.

  (* S16 in_fsetI *)

  Definition ext_ininter (f : fsetform) :=
    match f with
    | (F_Pred (FSP_In a (FSS_inter b c))) =>
        [:: (F_Pred (FSP_In a b)); (F_Pred (FSP_In a c))]
    | _ => nil
    end.

  Lemma ext_ininter_sound asn f:
    (valid_form asn f) -> all (valid_form asn) (ext_ininter f).
  Proof.
    rewrite /ext_ininter /valid_form. case: f => // [] // [] //.
    move=> a. case=> // b c /=.
    rewrite /sem_FSP_In. case: (sem_elt asn a) => // {a} ? /=.
    case: (sem_syn _) => // B. case: (sem_syn _) => // C.
    by rewrite in_setI => /andP [] -> ->.
  Qed.

  (* all single premise extension *)

  Definition br_ext_single_all br :=
    let br := (br_ext_single ext_and br) in
    let br := (br_ext_single ext_nor br) in
    let br := (br_ext_single ext_nimp br) in
    let br := (br_ext_single ext_nnot br) in
    let br := (br_ext_single ext_fseteq br) in
    let br := (br_ext_single ext_elteq br) in
    let br := (br_ext_single ext_insingle br) in
    let br := (br_ext_single ext_ninsingle br) in
    let br := (br_ext_single ext_singlesub br) in
    let br := (br_ext_single ext_ninunion br) in
    let br := (br_ext_single ext_indiff br) in
    let br := (br_ext_single ext_ininter br) in
    br.

  Lemma br_ext_single_all_sound asn br :
    all (valid_form asn) br -> all (valid_form asn) (br_ext_single_all br).
  Proof.
    move=> H.
    rewrite /br_ext_single_all.
    apply: (br_ext_single_sound (@ext_ininter_sound _)).
    apply: (br_ext_single_sound (@ext_indiff_sound _)).
    apply: (br_ext_single_sound (@ext_ninunion_sound _)).
    apply: (br_ext_single_sound (@ext_singlesub_sound _)).
    apply: (br_ext_single_sound (@ext_ninsingle_sound _)).
    apply: (br_ext_single_sound (@ext_insingle_sound _)).
    apply: (br_ext_single_sound (@ext_elteq_sound _)).
    apply: (br_ext_single_sound (@ext_fseteq_sound _)).
    apply: (br_ext_single_sound (@ext_nnot_sound _)).
    apply: (br_ext_single_sound (@ext_nimp_sound _)).
    apply: (br_ext_single_sound (@ext_nor_sound _)).
    apply: (br_ext_single_sound (@ext_and_sound _)).
    exact: H.
  Qed.

  (* nonbranching rules with two premises *)
  (* S1 S2 S6 S7 *)

  Fixpoint ext_pair
           (ext : (fsetform * fsetform) -> seq fsetform)
           (ps : seq (fsetform * fsetform)) :=
    match ps with
    | nil => nil
    | p :: ps => (ext p) ++ (ext_pair ext ps)
    end.

  Definition br_ext_pair ext br :=
    (ext_pair ext (List.list_prod br br)) ++ br.

  Lemma ext_pair_sound asn ext ps :
    (forall p, (valid_form asn (fst p) && valid_form asn (snd p)) ->
               all (valid_form asn) (ext p)) ->
    all (fun p => (valid_form asn (fst p)) && (valid_form asn (snd p))) ps ->
    all (valid_form asn) (ext_pair ext ps).
  Proof.
    elim: ps => //.
    move=> p ps IH Hext /= /andP [Hsem Hps].
    by rewrite all_cat (Hext _ Hsem) (IH Hext Hps).
  Qed.

  Lemma List_In_in_mem {S : eqType} a (s : seq S) :
    List.In a s <-> a \in s.
  Proof.
    rewrite /iff. split.
    - elim: s => //. move=> x s IH H. move: (List.in_inv H) => [].
      + by rewrite in_cons => ->; rewrite eqxx.
      + by rewrite in_cons => /IH ->; rewrite orbT.
    - elim: s => //. move=> x s IH. rewrite in_cons => /orP [].
      + move=> /eqP -> //=. by left.
      + move=> /IH //=. by right.
  Qed.

  Lemma br_ext_pair_sound asn ext br:
    (forall p, (valid_form asn (fst p) && valid_form asn (snd p)) ->
               all (valid_form asn) (ext p)) ->
    all (valid_form asn) br ->
    all (valid_form asn) (br_ext_pair ext br).
  Proof.
    move=> Hext Hbr. rewrite all_cat Hbr andbT ext_pair_sound => //.
    apply/allP=> p. move: p => [p1 p2].
    rewrite -List_In_in_mem List.in_prod_iff !List_In_in_mem.
    move=> [Hp1 Hp2].
    by rewrite (in_mem_all Hp1 Hbr) (in_mem_all Hp2 Hbr).
  Qed.

  (* S1 *)
  Definition ext_insub (p : fsetform * fsetform):=
    let (p1, p2) := p in
    match p1, p2 with
    | F_Pred (FSP_In a A), (F_Pred (FSP_Sub A' B)) =>
        if A == A' then [:: F_Pred (FSP_In a B)] else nil
    | _, _ => nil
    end.

  Lemma ext_insub_sound asn p :
    valid_form asn (fst p) && valid_form asn (snd p) ->
    all (valid_form asn) (ext_insub p).
  Proof.
    move: p => [p1 p2]. rewrite /ext_insub /valid_form /=.
    case: p1 => //. case => //= => a A. case: p2 => //. case => //= => A' B.
    rewrite /sem_FSP_In /sem_FSP_Sub.
    remember (A == A') as eqA.
    move: HeqeqA. case: eqA => //= /esym /eqP <-. rewrite /sem_FSP_In.
    case: (sem_elt _) => // x.
    case: (sem_syn _) => // X. case: (sem_syn _) => //; last by rewrite andbF.
    move=> Y /andP [] xin /subsetP /(_ x xin). by rewrite andbT.
  Qed.

  (* S2 *)
  Definition ext_ninsub (p : fsetform * fsetform):=
    let (p1, p2) := p in
    match p1, p2 with
    | F_Not (F_Pred (FSP_In a A)), (F_Pred (FSP_Sub B A')) =>
        if A == A' then [:: F_Not (F_Pred (FSP_In a B))] else nil
    | _, _ => nil
    end.

  Lemma ext_ninsub_sound asn p :
    valid_form asn (fst p) && valid_form asn (snd p) ->
    all (valid_form asn) (ext_ninsub p).
  Proof.
    move: p => [p1 p2]. rewrite /ext_ninsub /valid_form /=.
    case: p1 => //. case => //.
    case => //= => a A. case: p2 => //. case => //= => B A'.
    rewrite /sem_FSP_In /sem_FSP_Sub.
    remember (A == A') as eqA.
    move: HeqeqA. case: eqA => //= /esym /eqP <-. rewrite /sem_FSP_In.
    case: (sem_elt _) => // x.
    case: (sem_syn _) => // X. case: (sem_syn _) => //; last by rewrite andbF.
    move=> Y /andP [] xnin HYX. rewrite andbT. move: xnin. apply: contraNN.
    by move=> xin; move: HYX => /subsetP /(_ _ xin).
  Qed.

  (* S6 *)
  Definition ext_eqin (p : fsetform * fsetform):=
    let (p1, p2) := p in
    match p1, p2 with
    | (F_Pred (FSP_Eqelt a b)), (F_Pred (FSP_In b' B)) =>
        if b == b' then [:: (F_Pred (FSP_In a B))] else nil
    | _, _ => nil
    end.

  Lemma ext_eqin_sound asn p :
    valid_form asn (fst p) && valid_form asn (snd p) ->
    all (valid_form asn) (ext_eqin p).
  Proof.
    move: p => [p1 p2]. rewrite /ext_eqin /valid_form.
    case: p1 => //. case=> //= a0 b0.
    case: p2 => //. case=> //= b'0 B.
    case: (@eqP _ b0 b'0) => // <- /=.
    rewrite /sem_FSP_Eqelt /sem_FSP_In.
    case: (sem_elt asn a0) => // a.
    case: (sem_elt asn b0) => // b.
    case: (sem_syn _) => //; last by rewrite andbF.
    move=> Y /andP [] /eqP ->. by rewrite andbT.
  Qed.

  (* S7 *)
  Definition ext_eqtrans (p : fsetform * fsetform):=
    let (p1, p2) := p in
    match p1, p2 with
    | (F_Pred (FSP_Eqelt a b)), (F_Pred (FSP_Eqelt b' c)) =>
        if b == b' then [:: (F_Pred (FSP_Eqelt a c))] else nil
    | _, _ => nil
    end.

  Lemma ext_eqtrans_sound asn p :
    valid_form asn (fst p) && valid_form asn (snd p) ->
    all (valid_form asn) (ext_eqtrans p).
  Proof.
    move: p => [p1 p2]. rewrite /ext_eqin /valid_form.
    case: p1 => //. case=> //= a0 b0.
    case: p2 => //. case=> //= b'0 b.
    case: (@eqP _ b0 b'0) => // <- /=.
    rewrite /sem_FSP_Eqelt /sem_FSP_In.
    case: (sem_elt asn a0) => // x.
    case: (sem_elt asn b0) => // y.
    case: (sem_elt _) => //; last by rewrite andbF.
    move=> Y /andP [] /eqP -> /eqP ->. by rewrite eqxx.
  Qed.

  Definition br_ext_pair_all br :=
    let br := br_ext_pair ext_insub br in
    let br := br_ext_pair ext_ninsub br in
    let br := br_ext_pair ext_eqin br in
    let br := br_ext_pair ext_eqtrans br in
    br.

  Lemma br_ext_pair_all_sound asn br :
    all (valid_form asn) br -> all (valid_form asn) (br_ext_pair_all br).
  Proof.
    move=> H.
    rewrite /br_ext_pair_all.
    apply: (br_ext_pair_sound (@ext_eqtrans_sound _)).
    apply: (br_ext_pair_sound (@ext_eqin_sound _)).
    apply: (br_ext_pair_sound (@ext_ninsub_sound _)).
    apply: (br_ext_pair_sound (@ext_insub_sound _)).
    exact: H.
  Qed.

  (* branching rules *)
  (* P2 P3 P4 S5 S12 S15 S17 *)

  (* Eval compute in (1 \in [:: 1; 2; 3]). *)

  Fixpoint get_form_branching_aux
           (ext : fsetform -> option (fsetform * fsetform))
           (fs br : branch) :=
    match fs with
    | nil => None
    | f :: fs =>
        match (ext f) with
        | Some (a, b) =>
            match ((a \in br) || (b \in br)) with
            | true => get_form_branching_aux ext fs br
            | false => Some (a, b)
            end
        | None => get_form_branching_aux ext fs br
        end
    end.

  Lemma get_form_branching_aux_sound asn ext fs br:
    (forall f a b, ext f = Some (a, b) -> valid_form asn f ->
                   valid_form asn a || valid_form asn b) ->
    all (valid_form asn) fs ->
    forall a b, get_form_branching_aux ext fs br = Some (a, b) ->
                valid_form asn a || valid_form asn b.
  Proof.
    move=> Hext.
    elim: fs => //.
    move=> f fs IH /= /andP [Hf Hfs] a b.
    move: (Hext f) => /=.
    case: (ext f); last by move=> _; apply: (IH Hfs).
    move=> [a0 b0] H /=.
    case: ((a0 \in br) || (b0 \in br)); first by apply: (IH Hfs a b).
    move=> [] <- <-. by apply: (H a0 b0 _ Hf).
  Qed.

  Definition get_form_branching ext br :=
    get_form_branching_aux ext br br.

  Lemma get_form_branching_sound asn ext br:
    (forall f a b, ext f = Some (a, b) -> valid_form asn f ->
                   valid_form asn a || valid_form asn b) ->
    all (valid_form asn) br ->
    forall a b, get_form_branching ext br = Some (a, b) ->
                valid_form asn a || valid_form asn b.
  Proof.
    move=> H Hbr. rewrite /get_form_branching.
    by apply: get_form_branching_aux_sound.
  Qed.

  (* P2 *)

  Definition ext_or f :=
    match f with
    | F_Or a b => Some (a, b)
    | _ => None
    end.

  Lemma ext_or_sound asn f a b :
    ext_or f = Some (a, b) -> valid_form asn f -> valid_form asn a || valid_form asn b.
  Proof.
    case: f => //. move=> x y /= [] -> ->. rewrite /valid_form /=.
    by case: (sem_form _) => //; case: (sem_form _) => //.
  Qed.

  (* P3 *)

  Definition ext_imp f :=
    match f with
    | F_Imply a b => Some (F_Not a, b)
    | _ => None
    end.

  Lemma ext_imp_sound asn f a b :
    ext_imp f = Some (a, b) -> valid_form asn f ->
    valid_form asn a || valid_form asn b.
  Proof.
    case: f => //. move=> a0 b0 /= [] <- <- /=.
    rewrite /valid_form /=. case: (sem_form _) => //. case: (sem_form _) => //.
    by move=> x y; rewrite implybE.
  Qed.

  (* P4 *)

  Definition ext_nand f :=
    match f with
    | F_Not (F_And a b) => Some (F_Not a, F_Not b)
    | _ => None
    end.

  Lemma ext_nand_sound asn f a b :
    ext_nand f = Some (a, b) -> valid_form asn f ->
    valid_form asn a || valid_form asn b.
  Proof.
    case: f => //. case => //. move=> a0 b0 /= [] <- <- /=.
    rewrite /valid_form /=. case: (sem_form _) => //. case: (sem_form _) => //.
    by move=> x y; rewrite negb_and.
  Qed.

  (* S5 *)

  Definition ext_fsetneq f :=
    match f with
    | F_Not (F_Pred (FSP_Eqset a b)) =>
        Some (F_Not (F_Pred (FSP_Sub a b)), F_Not (F_Pred (FSP_Sub b a)))
    | _ => None
    end.

  Lemma ext_fsetneq_sound asn f a b :
    ext_fsetneq f = Some (a, b) -> valid_form asn f ->
    valid_form asn a || valid_form asn b.
  Proof.
    case: f => //. case => //. case => //. move=> a0 b0 /= [] <- <- /=.
    rewrite /valid_form /= /sem_FSP_Eqset /sem_FSP_Sub.
    case: (sem_syn _) => //. case: (sem_syn _) => //.
    by move=> x y; rewrite eqEsubset negb_and.
  Qed.

  (* S12 *)

  Definition ext_inunion f :=
    match f with
    | (F_Pred (FSP_In x (FSS_union A B))) =>
        Some ((F_Pred (FSP_In x A)), (F_Pred (FSP_In x B)))
    | _ => None
    end.

  Lemma ext_inunion_sound asn f a b :
    ext_inunion f = Some (a, b) -> valid_form asn f ->
    valid_form asn a || valid_form asn b.
  Proof.
    case: f => //. case => //. move=> x. case => //.
    move=> a0 b0 /= [] <- <- /=.
    rewrite /valid_form /= /sem_FSP_In /=. case: (sem_elt asn x) => // y.
    case: (sem_syn _) => //. case: (sem_syn _) => //.
    by move=> c d; rewrite in_setU.
  Qed.

  (* S15 *)

  Definition ext_nindiff f :=
    match f with
    | F_Not (F_Pred (FSP_In x (FSS_diff A B))) =>
        Some (F_Not (F_Pred (FSP_In x A)), (F_Pred (FSP_In x B)))
    | _ => None
    end.

  Lemma ext_nindiff_sound asn f a b :
    ext_nindiff f = Some (a, b) -> valid_form asn f ->
    valid_form asn a || valid_form asn b.
  Proof.
    case: f => //. case => //. case => //. move=> x. case => //.
    move=> a0 b0 /= [] <- <- /=. rewrite /valid_form /= /sem_FSP_In /=.
    case: (sem_elt asn x) => // y.
    case: (sem_syn _) => //. case: (sem_syn _) => //.
    by move=> c d; rewrite in_setD negb_and Bool.negb_involutive orbC.
  Qed.

  (* S17 *)

  Definition ext_nininter f :=
    match f with
    | F_Not (F_Pred (FSP_In x (FSS_inter A B))) =>
        Some (F_Not (F_Pred (FSP_In x A)), F_Not (F_Pred (FSP_In x B)))
    | _ => None
    end.

  Lemma ext_nininter_sound asn f a b :
    ext_nininter f = Some (a, b) -> valid_form asn f ->
    valid_form asn a || valid_form asn b.
  Proof.
    case: f => //. case => //. case => //. move=> x. case => //.
    move=> a0 b0 /= [] <- <- /=. rewrite /valid_form /= /sem_FSP_In /=.
    case: (sem_elt asn x) => // y.
    case: (sem_syn _) => //. case: (sem_syn _) => //.
    by move=> c d; rewrite in_setI negb_and orbC.
  Qed.

  Fixpoint pick_some {A B : Type} (f : A -> option B) (s : seq A) :=
    match s with
    | nil => None
    | x :: xs =>
        match (f x) with
        | Some b => Some b
        | None => pick_some f xs
        end
    end.

  Definition br_branching br :=
    pick_some (fun f => (get_form_branching f br))
              [:: ext_or; ext_imp; ext_nand; ext_fsetneq; ext_inunion;
               ext_nindiff; ext_nininter].

  Lemma br_branching_sound asn br :
    all (valid_form asn) br ->
    forall a b, br_branching br = Some (a, b) ->
                valid_form asn a || valid_form asn b.
  Proof.
    move=> Hbr a b.
    rewrite /br_branching /=.
    move: (get_form_branching_sound (@ext_or_sound _) Hbr).
    case: (get_form_branching ext_or br); first by case => ? ?; apply.
    move=> _; move: (get_form_branching_sound (@ext_imp_sound _) Hbr).
    case: (get_form_branching ext_imp br); first by case => ? ?; apply.
    move=> _; move: (get_form_branching_sound (@ext_nand_sound _) Hbr).
    case: (get_form_branching ext_nand br); first by case => ? ?; apply.
    move=> _; move: (get_form_branching_sound (@ext_fsetneq_sound _) Hbr).
    case: (get_form_branching ext_fsetneq br); first by case => ? ?; apply.
    move=> _; move: (get_form_branching_sound (@ext_inunion_sound _) Hbr).
    case: (get_form_branching ext_inunion br); first by case => ? ?; apply.
    move=> _; move: (get_form_branching_sound (@ext_nindiff_sound _) Hbr).
    case: (get_form_branching ext_nindiff br); first by case => ? ?; apply.
    move=> _; move: (get_form_branching_sound (@ext_nininter_sound _) Hbr).
    case: (get_form_branching ext_nininter br); first by case => ? ?; apply.
    by [].
  Qed.

  (* closing branches *)

  Lemma cons_br_branching asn br :
    all (valid_form asn) br ->
    forall a b, br_branching br = Some (a, b) ->
                all (valid_form asn) (a :: br) || all (valid_form asn) (b :: br).
  Proof.
    move=> Hbr a b Hab.
    move: (br_branching_sound Hbr Hab) => /orP [].
    - by move=> /= ->; rewrite Hbr => /=.
    - by move=> /= ->; rewrite Hbr orbT.
  Qed.

  Fixpoint br_contra (br : branch) :=
    match br with
    | nil => false
    | f :: fs => has (fun x => (x == F_Not f) || (F_Not x == f)) fs
                 || br_contra fs
    end.

  Lemma all_false {S : eqType} x (s : seq S) p :
    (x \in s) && ~~ (p x) -> ~~ (all p s).
  Proof.
    move=> H. rewrite -has_predC.
    apply/hasP. exists x; by move: H => /andP [].
  Qed.

  Lemma all_contra {S : eqType} (s : seq S) f x y :
    (x \in s) && (y \in s) && (f x == ~~ f y) ->
    ~~ (all f s).
  Proof.
    remember (f x) as fx. move: fx Heqfx. case.
    - move=> eqfx /andP [] /andP [_ Hy] Hfy.
      apply (@all_false _ y). move: Hfy => /eqP <-. by rewrite Hy.
    - move=> eqfx /andP [] /andP [Hx _] _.
      apply (@all_false _ x). by rewrite -eqfx Hx.
  Qed.

  Lemma br_contra_sound_aux br :
    br_contra br ->
    exists x y, (x \in br) && (y \in br) && (x == (F_Not y)).
  Proof.
    elim: br => //.
    move=> f br IH /orP [].
    - move=> /hasP [x xin] /orP [Hx | Hx].
      + exists x. exists f.
        by rewrite in_cons xin orbT mem_head /=.
      + exists f. exists x.
        by rewrite !in_cons xin eqxx orbT /= eq_sym.
    - move=> /IH [x [y]] /andP [] /andP [] xin yin H. exists x. exists y.
      by rewrite !in_cons xin yin H !orbT.
  Qed.

  Lemma br_contra_sound br asn :
    br_contra br -> ~~ all (valid_form asn) br.
  Proof.
    move=> /br_contra_sound_aux [x [y]] /andP [] /andP [] xin yin /eqP eqx.
    move: (@all_contra _ br (valid_form asn) x y).
    move: (@all_false _ y br (valid_form asn)).
    rewrite /valid_form eqx /=.
    case: (sem_form asn y) => //=; last by rewrite yin => /= /(_ erefl).
    move=> b _; rewrite yin /=.
    by rewrite -eqx xin eqxx => /(_ erefl).
  Qed.

  Definition is_in_empty (f : fsetform) :=
    match f with
    | F_Pred (FSP_In x FSS_empty) => true
    | _ => false
    end.

  Lemma in_empty_false asn f :
    is_in_empty f -> ~~ valid_form asn f.
  Proof.
    case: f => //. case => //. move=> x. case => //= _.
    rewrite /valid_form /= /sem_FSP_In.
    case: (sem_elt asn x) => //= => a.
    by rewrite in_set0.
  Qed.

  Lemma br_has_in_empty_contra asn br :
    has is_in_empty br -> ~~ (all (valid_form asn) br).
  Proof.
    move=> /hasP [] f finbr /in_empty_false Hf.
    apply: (@all_false _ f).
    rewrite finbr. by rewrite (Hf asn).
  Qed.

  (* Eval cbv in
    (has is_in_empty
         [:: F_Pred (FSP_In (FE_var xH) FSS_empty)]). *)

  Definition is_nin_full (f : fsetform) :=
    match f with
    | F_Not (F_Pred (FSP_In a FSS_full)) => true
    | _ => false
    end.

  Lemma nin_full_false asn f :
    is_nin_full f -> ~~ valid_form asn f.
  Proof.
    case: f => //. case => //. case => //. case => //.
    - move=> a. case=> //= _.
      rewrite /valid_form /= /sem_FSP_In /sem_elt.
      case: (sem_eltvar var_lst a) => //=.
      move=> x. apply/negPn => /=. by rewrite in_setT.
    - move=> A B. case=> //= _.
      rewrite /valid_form /= /sem_FSP_In /sem_elt.
      case: (asn _) => //=.
      move=> x. apply/negPn => /=. by rewrite in_setT.
  Qed.

  Lemma br_has_nin_full_contra asn br :
    has is_nin_full br -> ~~ (all (valid_form asn) br).
  Proof.
    move=> /hasP [] f finbr /nin_full_false Hf.
    apply: (@all_false _ f).
    rewrite finbr. by rewrite (Hf asn).
  Qed.

  Definition is_neg_refl (f : fsetform) :=
    match f with
    | F_Not (F_Pred (FSP_Eqelt a b)) => a == b
    | _ => false
    end.

  Lemma neg_refl_false asn f :
    is_neg_refl f -> ~~ valid_form asn f.
  Proof.
    case: f => //. case => //. case => //.
    move=> a b. rewrite /is_neg_refl => /= /eqP ->.
    rewrite /valid_form /= /sem_FSP_Eqelt /sem_elt.
    case: b => /=.
    - move=> x. case: (sem_eltvar _) => // y. by rewrite eqxx.
    - move=> A B. case: (asn _) => // y. by rewrite eqxx.
  Qed.

  Lemma br_has_neg_refl_contra asn br :
    has is_neg_refl br -> ~~ (all (valid_form asn) br).
  Proof.
    move=> /hasP [] f finbr /neg_refl_false Hf.
    apply: (@all_false _ f).
    rewrite finbr. by rewrite (Hf asn).
  Qed.

  Definition close_branch (br : branch) :=
    match (br_contra br) || (has is_in_empty br) || (has is_nin_full br)
          || (has is_neg_refl br) with
    | true => [:: F_False]
    | false => br
    end.

  (* Eval cbv in
    (close_branch
       [:: F_Not (F_Pred (FSP_Eqset (FSS_var xH) (FSS_var xH)));
        (F_Pred (FSP_Eqset (FSS_var xH) (FSS_var xH)))]). *)

  (* Eval cbv in
    (close_branch
       [:: F_Pred (FSP_In (FE_var xH) FSS_empty)]). *)

  Definition is_closed_branch (br : branch) :=
    match br with
    | [:: F_False] => true
    | _ => false
    end.

  Lemma is_closed_branchE br :
    is_closed_branch br -> br = [:: F_False].
  Proof.
    rewrite /is_closed_branch. case: br => //. case => //. by case.
  Qed.

  Lemma close_branch_sound br asn :
    all (valid_form asn) br -> all (valid_form asn) (close_branch br).
  Proof.
    move=> Hbr. rewrite /close_branch.
    move: (@br_contra_sound br asn).
    case: (br_contra br) => //; first by move=> /(_ erefl); rewrite Hbr.

    move=> _; move: (@br_has_in_empty_contra asn br).
    case: (has is_in_empty br) => //=; first by move=> /(_ erefl); rewrite Hbr.

    move=> _; move: (@br_has_nin_full_contra asn br).
    case: (has is_nin_full br) => //=; first by move=> /(_ erefl); rewrite Hbr.

    move=> _; move: (@br_has_neg_refl_contra asn br).
    case: (has is_neg_refl br) => //=; by move=> /(_ erefl); rewrite Hbr.
  Qed.

  Inductive has_valid_branch : seq branch -> Prop :=
  | HVB_one br asn :
    all (valid_form asn) br -> forall brs, has_valid_branch (br :: brs)
  | HVB_cons br brs : has_valid_branch brs -> has_valid_branch (br :: brs).

  Definition remove_closed_branch brs : seq branch :=
    match brs with
    | nil => nil
    | br :: brs =>
        if (is_closed_branch br)
        then brs
        else br :: brs
    end.

  Lemma remove_closed_branch_sound brs :
    has_valid_branch brs -> has_valid_branch (remove_closed_branch brs).
  Proof.
    case => //.
    - move=> br asn H bs.
      rewrite /remove_closed_branch.
      move: (@is_closed_branchE br).
      case: (is_closed_branch br);
        first by move=> /(_ erefl) eqbr; move: eqbr H => -> //=.
      move=> _; apply: HVB_one. exact: H.
    - move=> br bs H.
      rewrite /remove_closed_branch.
      case: (is_closed_branch br); first exact: H.
      apply: HVB_cons; exact: H.
  Qed.

  (* Eval cbv in (remove_closed_branch [:: [:: F_False]; [:: F_False; F_False]]). *)

  Definition br_ext_nonbranching br :=
    let newbr := br_ext_nsub br in
    let newbr := br_ext_single_all newbr in
    let newbr := br_ext_pair_all newbr in
    let newbr := undup newbr in
    let newbr := close_branch newbr in
    newbr.

  Lemma br_ext_nonbranching_sound asn br :
    all (valid_form asn) br ->
    exists asn', all (valid_form asn') (br_ext_nonbranching br).
  Proof.
    move=> H.
    assert (Hnsub : exists asn', all (valid_form asn') (br_ext_nsub br))
      by apply: br_ext_nsub_sound H.
    move: Hnsub => [asn' Hasn'].
    exists asn'.
    rewrite /br_ext_nonbranching.
    apply: close_branch_sound.
    rewrite all_undup.
    apply: br_ext_pair_all_sound.
    by apply: br_ext_single_all_sound.
  Qed.

  Fixpoint saturate
           (n : nat)
           (brs : seq branch) :=
    match n with
    | O => brs
    | S n =>
        match brs with
        | nil => nil
        | br :: brs =>
            let newbr := br_ext_nonbranching br in
            if newbr == br
            then
              match br_branching br with
              | Some (a, b) => saturate n ((a :: br) :: (b :: br) :: brs)
              | None => br :: brs
              end
            else saturate n (remove_closed_branch (newbr :: brs))
        end
    end.

  Lemma saturate_Sn_brbrs n br brs :
    saturate (S n) (br :: brs) =
      let newbr := br_ext_nonbranching br in
      if newbr == br
      then
        match br_branching br with
        | Some (a, b) => saturate n ((a :: br) :: (b :: br) :: brs)
        | None => br :: brs
        end
      else saturate n (remove_closed_branch (newbr :: brs)).
  Proof. reflexivity. Qed.

  Lemma saturate_sound n brs :
    has_valid_branch brs -> has_valid_branch (saturate n brs).
  Proof.
    elim: n brs => //.
    move=> n IH brs Hbrs.
    case: Hbrs.
    - move=> br asn Hbr bs.
      rewrite saturate_Sn_brbrs.
      rewrite (lock br_ext_nonbranching).
      cbv zeta.
      case: (locked br_ext_nonbranching br == br).
      + move: (cons_br_branching Hbr).
        case: (br_branching br); last by move=> _; apply: (HVB_one Hbr).
        move=> [a b] /(_ a b erefl) /orP [].
        * move=> Ha. apply IH. apply: (HVB_one Ha).
        * move=> Hb. apply IH. apply: HVB_cons. apply: (HVB_one Hb).
      + apply: IH. apply: remove_closed_branch_sound.
        assert (Hbr' := (br_ext_nonbranching_sound Hbr)).
        move: Hbr' => [asn' Hasn']. apply: HVB_one.
        rewrite -lock. apply: Hasn'.
    - move=> br bs Hbs.
      rewrite saturate_Sn_brbrs.
      rewrite (lock br_ext_nonbranching).
      cbv zeta.
      case: (locked br_ext_nonbranching br == br).
      + case: (br_branching br).
        * move=> [a b]. apply: IH. apply: HVB_cons. by apply: HVB_cons.
        * by apply: HVB_cons.
      + apply: IH. apply: remove_closed_branch_sound. by apply: HVB_cons.
  Qed.

  Lemma has_not_valid_branch_nil :
    ~ has_valid_branch nil.
  Proof. move=> H. inversion H. Qed.

  Lemma valid_formNN f asn :
    forall b, Some b = sem_form asn f ->
    ~~ (valid_form asn (F_Not f)) -> valid_form asn f.
  Proof.
    move=> b. rewrite /valid_form => /= <-. by apply: negbNE. Qed.

  Lemma has_not_valid_branch_single f asn :
    ~ has_valid_branch [:: [:: f]] -> ~~ (valid_form asn f).
  Proof.
    move=> H. apply/negP.
    have g : valid_form asn f -> has_valid_branch [:: [:: f]]
      by move=> Hbr; apply: (@HVB_one [:: f] asn) => /=; rewrite Hbr.
    by move=> /g /H.
  Qed.

  Lemma saturate_has_not_valid_branch n f :
    saturate n [:: [:: f]] == nil -> ~ has_valid_branch [:: [:: f]].
  Proof.
    move=> /eqP H hvb. move: (saturate_sound n hvb).
    rewrite H. apply: has_not_valid_branch_nil.
  Qed.

  Definition fset_decide asn n f :=
    match (sem_form asn f) with
    | Some _ => saturate n [:: [:: F_Not f]] == nil
    | None => false
    end.

  Lemma fset_decide_sound n f asn :
    fset_decide asn n f -> valid_form asn f.
  Proof.
    rewrite /fset_decide /valid_form.
    remember (sem_form asn f) as sf.
    case: sf Heqsf => // a Ha.
    move=> /saturate_has_not_valid_branch /has_not_valid_branch_single.
    move=> /(_ asn) /(valid_formNN Ha).
    by rewrite /valid_form -Ha.
  Qed.

End fsetform_decide.

Example E0 (T : finType) (A B : {set T}) {x y : T} asn :
  valid_form [:: A; B] [:: x; y] asn
               (F_Pred (FSP_Sub (FSS_var (xO xH)) (FSS_var xH)))
  =
    (B \subset A).
Proof.
  by [].
Qed.

Example E1 (T : finType) (A B : {set T}) {x y : T} asn :
  valid_form [:: A; B] [:: x; y] asn
               (F_Pred (FSP_Eqset (FSS_var (xO xH)) (FSS_var xH)))
  =
    (B == A).
Proof.
  by [].
Qed.

(* rewrite Props to boolean expressions *)

Global Hint Rewrite <- setTD setI_eq0 : fsetdec_unfold.

Lemma rwPeqP (T : eqType) (x y : T) : x = y <-> x == y.
Proof. by rewrite (rwP eqP). Qed.

Lemma rwPorP (x y : bool) : x \/ y <-> x || y.
Proof. by rewrite (rwP orP). Qed.

Lemma rwPandP (x y : bool) : x /\ y <-> x && y.
Proof. by rewrite (rwP andP). Qed.

Lemma rwPimplyP (x y : bool) : (x -> y) <-> x ==> y.
Proof. by rewrite (rwP implyP). Qed.

Lemma rwPnegP (x : bool) : (x -> False) <-> ~~ x.
Proof.  by move: (rwP (@negP x)); rewrite /not. Qed.

Global Hint Rewrite rwPeqP rwPorP rwPandP rwPimplyP rwPnegP : fsetdec_prop_to_bool.

Global Hint Rewrite orbF orFb andTb andbT implyTb Bool.negb_involutive : fsetdec_bool_simp.

Elpi Tactic fsetform_reify.
Elpi Accumulate lp:{{
    pred mem o:term, o:term, o:term.
    mem {{ lp:X :: _     }} X {{ xH      }} :- !.
    mem {{ _    :: lp:XS }} X {{ BinPos.Pos.succ lp:N }} :- mem XS X N.

    pred close o:term.
    close {{ nil }} :- !.
    close {{ _ :: lp:XS }} :- close XS.

    pred quote-elt o:term, i:term, o:term.
    quote-elt Eltvars X {{ lp:N }} :-
      mem Eltvars X RN,
      coq.reduction.cbv.norm RN N.

    pred quote-syn o:term, o:term, i:term, o:term.
    quote-syn Setvars Eltvars {{ setU lp:X lp:Y }} {{ FSS_union lp:SX lp:SY}} :- !,
      quote-syn Setvars Eltvars X SX,
      quote-syn Setvars Eltvars Y SY.
    quote-syn Setvars Eltvars {{ setD lp:X lp:Y }} {{ FSS_diff lp:SX lp:SY}} :- !,
      quote-syn Setvars Eltvars X SX,
      quote-syn Setvars Eltvars Y SY.
    quote-syn Setvars Eltvars {{ setI lp:X lp:Y }} {{ FSS_inter lp:SX lp:SY}} :- !,
      quote-syn Setvars Eltvars X SX,
      quote-syn Setvars Eltvars Y SY.
    quote-syn _Setvars Eltvars {{ set1 lp:X }} {{ FSS_single lp:EX }} :- !,
      quote-elt Eltvars X EX.
    quote-syn _Setvars _Eltvars {{ lp:X }} {{ FSS_empty }} :-
      coq.unify-eq X {{ set0 }} ok.
    quote-syn _Setvars _Eltvars {{ lp:X }} {{ FSS_full }} :-
      coq.unify-eq X {{ setT }} ok.
    quote-syn Setvars _Eltvars X {{ FSS_var lp:N }} :-
      mem Setvars X RN,
      coq.reduction.cbv.norm RN N.

    pred quote-form i:term, o:term, o:term, i:term, o:term.
    quote-form _T Setvars Eltvars
        {{ @eq_op lp:S lp:X lp:Y }} {{ F_Pred (FSP_Eqset lp:PX lp:PY)}}:-
      coq.unify-eq S {{ set_of_eqType _ }} ok,
      quote-syn Setvars Eltvars X PX,
      quote-syn Setvars Eltvars Y PY.
    quote-form T _Setvars Eltvars
        {{ @eq_op lp:T lp:X lp:Y }} {{ F_Pred (FSP_Eqelt (FE_var lp:PX) (FE_var lp:PY)) }}:- !,
      quote-elt Eltvars X PX,
      quote-elt Eltvars Y PY.
    quote-form _T Setvars Eltvars
        {{ in_mem lp:X (mem (@SetDef.pred_of_set _ lp:Y)) }} {{ F_Pred (FSP_In (FE_var lp:PX) lp:PY)}}:- !,
      quote-elt Eltvars X PX,
      quote-syn Setvars Eltvars Y PY.
    quote-form _T Setvars Eltvars
        {{ subset (mem (@SetDef.pred_of_set _ lp:X)) (mem (@SetDef.pred_of_set _ lp:Y)) }} {{ F_Pred (FSP_Sub lp:PX lp:PY)}}:- !,
      quote-syn Setvars Eltvars X PX,
      quote-syn Setvars Eltvars Y PY.
    quote-form T Setvars Eltvars {{ negb lp:X }} {{ F_Not lp:FX }}:- !,
      quote-form T Setvars Eltvars X FX.
    quote-form T Setvars Eltvars {{ andb lp:X lp:Y }} {{ F_And lp:FX lp:FY }}:- !,
      quote-form T Setvars Eltvars X FX,
      quote-form T Setvars Eltvars Y FY.
    quote-form T Setvars Eltvars {{ orb lp:X lp:Y }} {{ F_Or lp:FX lp:FY }}:- !,
      quote-form T Setvars Eltvars X FX,
      quote-form T Setvars Eltvars Y FY.
    quote-form T Setvars Eltvars {{ implb lp:X lp:Y }} {{ F_Imply lp:FX lp:FY }}:- !,
      quote-form T Setvars Eltvars X FX,
      quote-form T Setvars Eltvars Y FY.
    quote-form  _ _ _ _ _ :- !,
      coq.say "Wrong fset formula".

    solve (goal _Ctx _ {{ is_true lp:Goal }} _ [] as G) GL :-
    coq.elaborate-skeleton Goal {{ bool }} EGoal ok,
    quote-form _FT Setvars Eltvars EGoal FGoal,
    close Setvars,
    close Eltvars,
    coq.elaborate-skeleton
        {{ _ : valid_form lp:Setvars lp:Eltvars (fun x y => None) lp:FGoal}} _ Res ok,
    refine Res G GL.
}}.
Elpi Typecheck.

(*
  fsetdec_bool is about 5-10x faster than the fsetdec implemented in MSetDecide.v
  while the fsetdec here is 2-3x slower than fsetdec_bool.
  Maybe the performance of the autorewrite tactic or even the rewrite tactic
  is the bottleneck in simple cases.
*)

(* T is not used currently *)
Ltac fsetdec_bool T :=
  autorewrite with fsetdec_unfold;
  elpi fsetform_reify;
  apply: (@fset_decide_sound _ _ _ (Nat.of_num_uint 10000%uint)); vm_compute;
  reflexivity.

Ltac fsetdec T :=
  autorewrite with fsetdec_unfold;
  unfold not;
  unfold iff;
  autorewrite with fsetdec_prop_to_bool;
  autorewrite with fsetdec_bool_simp;
  elpi fsetform_reify;
  apply: (@fset_decide_sound _ _ _ (Nat.of_num_uint 10000%uint)); vm_compute;
  reflexivity.

(* test cases *)

Lemma tb0 (T : finType) (A B : {set T}) (x : T) :
  (A \subset B) ==> (x \in A) ==> (x \in B).
Proof.
  time fsetdec_bool T.
Defined.

Lemma t0 (T : finType) (A B : {set T}) (x : T) :
  (A \subset B) -> (x \in A) -> (x \in B).
Proof.
  time fsetdec T.
Defined.

Lemma tb1 (T : finType) (x y : T) :
  [set x;y] == [set y;x;x].
Proof.
  time fsetdec_bool T.
Qed.

Lemma t1 (T : finType) (x y : T) :
  [set x;y] = [set y;x;x].
Proof.
  time fsetdec T.
Qed.

(* seq not supported
Lemma t2 (T : finType) (x y : T) :
[fset e in [:: y;x]] = [fset e in [:: x;y;x]].
Proof.
fsetdec.
Abort.
  *)

Lemma tb2 (A B : {set 'I_3}) : (A :|: B == A) ==> (B \subset A).
Proof.
  time fsetdec_bool ('I_3).
Qed.

Lemma t2 (A B : {set 'I_3}) : (A :|: B == A) -> (B \subset A).
Proof.
  time fsetdec ('I_3).
Qed.

Local Definition o0 := @Ordinal 3 0 erefl.
Local Definition o1 := @Ordinal 3 1 erefl.
Local Definition o2 := @Ordinal 3 2 erefl.

Lemma tb3 (A B : {set 'I_3}) (x y : 'I_3):
  (([set o0; x] \subset A) && ([set o1; y] \subset B))
    ==> (([set o0; x; y] \subset (setU B A))).
Proof.
  time fsetdec_bool ('I_3).
Qed.

Lemma t3 (A B : {set 'I_3}) (x y : 'I_3):
  (([set o0; x] \subset A) /\ ([set o1; y] \subset B))
    -> (([set o0; x; y] \subset (setU B A))).
Proof.
  time fsetdec ('I_3).
Qed.

Lemma tb4 (T : finType) (A B : {set T}) :
  [disjoint A & B] ==> [disjoint B & A].
(* A `&` B = fset0 -> B `&` A = fset0. *)
Proof.
  time fsetdec_bool T.
Qed.

Lemma t4 (T : finType) (A B : {set T}) :
  [disjoint A & B] -> [disjoint B & A].
(* A `&` B = fset0 -> B `&` A = fset0. *)
Proof.
  time fsetdec T.
Qed.

Lemma tb5 (T : finType) (f2 f4 f0 : {set T}) :
  (f2 :&: f2 == set0) ==>
  (f0 :&: (f2 :|: f4) == set0) ==>
  (f0 :&: f2 == set0) ==>
  ~~ ((f0 :|: f2) :&: f4 != set0).
Proof.
  time fsetdec_bool T.
Qed.

Lemma t5 (T : finType) (f2 f4 f0 : {set T}) :
  (f2 :&: f2 = set0) ->
  (f0 :&: (f2 :|: f4) = set0) ->
  (f0 :&: f2 = set0) ->
  ~ ((f0 :|: f2) :&: f4 <> set0).
Proof.
  time fsetdec T.
Qed.

Section Examples.
Variable (T : finType).

Lemma test_eq_trans_1 : forall x y z (s : {set T}),
  x = y ->
  ~ ~ z = y ->
  x \in s ->
  z \in s.
Proof.
  move=> x y z s.
  fsetdec T.
Qed.

Lemma test_eq_trans_2 : forall (x y z : T) (r s : {set T}),
  x \in (set1 y) ->
  ~ z \in r ->
  ~ ~ z \in (y |: r) ->
  x \in s ->
  z \in s.
Proof.
  move=> x y z r s.
  fsetdec T.
Qed.

Lemma test_eq_neq_trans_1 : forall w x y z (s : {set T}),
  x = w ->
  ~ ~ x = y ->
  ~ y = z ->
  w \in s ->
  w \in (s :\ z).
Proof.
  move=> w x y z s.
  fsetdec T.
Qed.

(*
  The performance on this example is much worse than the Ltac implementation of
  the same decision procedure.
  Maybe the reason is the lack of substitution in fsetforms.
*)
Lemma test_eq_neq_trans_2 : forall w x y z (r1 r2 s : {set T}),
  x \in (set1 w) ->
  ~ x \in r1 ->
  x \in (y |: r1) ->
  y \in  r2 ->
  y \in (r2 :\ z) ->
  w \in s ->
  w \in (s :\ z).
Proof.
  move=> w x y z r1 r2 s.
  unfold not.
  autorewrite with fsetdec_prop_to_bool.
  time fsetdec_bool T.
Qed.

Lemma test_In_singleton : forall (x : T),
  x \in (set1 x).
Proof. move=> x. fsetdec T. Qed.

Lemma test_add_In : forall x y (s : {set T}),
  x \in (y |: s) ->
  ~ x = y ->
  x \in s.
Proof. move=> x y s. fsetdec T. Qed.

Lemma test_Subset_add_remove : forall x (s : {set T}),
  s \subset (x |: (s :\ x)).
Proof. move=> x s. fsetdec T. Qed.

Lemma test_eq_disjunction : forall w x y z : T,
  w \in (x |: (y |: (set1 z))) ->
  w = x \/ w = y \/ w = z.
Proof. move=> w x y z. fsetdec T. Qed.

Lemma test_not_In_disj : forall x y s1 s2 s3 (s4 : {set T}),
  ~ x \in (setU s1 (setU s2 (setU s3 (y |: s4)))) ->
  ~ (x \in s1 \/ x \in s4 \/ y = x).
Proof. move=> x y s1 s2 s3 s4. fsetdec T. Qed.

Lemma test_not_In_conj : forall x y s1 s2 s3 (s4 : {set T}),
  ~ x \in (setU s1 (setU s2 (setU s3 (y |: s4)))) ->
  ~ x \in s1 /\ ~ x \in s4 /\ ~ x = y.
Proof. move=> x y s1 s2 s3 s4. fsetdec T. Qed.

Lemma test_iff_conj : forall a x (s s' : {set T}),
(a \in s' <-> x = a \/ a \in s) ->
(a \in s' <-> a \in (x |: s)).
Proof. move=> a x s s'. fsetdec T. Qed.

(* cut rule needed *)
(* Lemma test_set_ops_1 : forall x q r (s : {set T}),
  (set1 x) \subset s ->
  (setU q r) = set0 ->
  (setI (setD s q) (setD s r)) = set0 ->
  ~ x \in s.
Proof.
  move=> x q r s.
  unfold not.
  autorewrite with fsetdec_prop_to_bool.
  elpi fsetform_reify. *)

(* cut rule needed *)
(* Lemma eq_chain_test : forall x1 x2 x3 x4 (s1 s2 s3 s4 : {set T}),
  s1 = set0 ->
  x2 \in (x1 |: s1) ->
  x3 \in s2 ->
  ~ x3 \in (s2 :\ x2) ->
  ~ x4 \in s3 ->
  x4 \in (x3 |: s3) ->
  x1 \in s4 ->
  (x4 |: s4) \subset s4.
Proof.
  move=> x1 x2 x3 x4 s1 s2 s3 s4. *)

Lemma test_too_complex : forall (x y z : T) (r s : {set T}),
  x = y ->
  (x \in (set1 y) -> r \subset s) ->
  z \in r ->
  z \in s.
Proof.
  (** [fsetdec] is not intended to solve this directly. *)
  intros until s; fsetdec T.
Qed.

Lemma function_test_1 :
  forall (f : {set T} -> {set T}),
  forall (g : T -> T),
  forall (s1 s2 : {set T}),
  forall (x1 x2 : T),
  s1 = (f s2) ->
  x1 = (g (g x2)) ->
  x1 \in s1 ->
  (g (g x2)) \in (f s2).
Proof.
  move=> f g s1 s2 x1 x2.
  fsetdec T.
Qed.

(* fsetdec in MSetDecide.v cannot solve this directly *)
Lemma function_test_2 :
  forall (f : {set T} -> {set T}),
  forall (g : T -> T),
  forall (s1 s2 : {set T}),
  forall (x1 x2 : T),
  s1 = (f s2) ->
  x1 = (g x2) ->
  x1 \in s1 ->
  g x2 = g (g x2) ->
  (g (g x2)) \in (f s2).
Proof.
  move=> f g s1 s2 x1 x2.
  fsetdec T.
Qed.

Lemma test_baydemir :
  forall (f : {set T} -> {set T}),
  forall (s : {set T}),
  forall (x y : T),
  x \in (y |: (f s)) ->
  ~ x = y ->
  x \in (f s).
Proof. move=> f s x y. fsetdec T. Qed.

Lemma test_seq (a b c : T):
  [set b; b; c; a; a; a; b] :\: (set1 a) :|: (set1 a) \subset [set a; b; c] .
Proof. fsetdec T. Qed.

Lemma test_comp_comp (A : {set T}) :
  ~: (~: A) = A.
  Proof. fsetdec T. Qed.

Lemma test_union_comp (A : {set T}) :
  A :|: (~: A) = setT.
  Proof. fsetdec T. Qed.

Lemma test_inter_comp (A : {set T}) :
  A :&: (~: A) = set0.
  Proof. fsetdec T. Qed.

Lemma test_diff_comp (A : {set T}) :
  A :\: (~: A) = A.
  Proof. fsetdec T. Qed.

Lemma test_comp_setT (A : {set T}) :
  ~: setT = (set0 : {set T}).
  Proof. fsetdec T. Qed.

Lemma test_comp_set0 (A : {set T}) :
  ~: set0 = (setT : {set T}).
  Proof. fsetdec T. Qed.

End Examples.


Require Import ExtLib.Data.HList.
Require Import ExtLib.Tactics.
Require Import MirrorCore.Util.Compat.
Require Import MirrorCore.ExprI.
Require Import MirrorCore.ExprDAs.
Require Import MirrorCore.Util.ListMapT.

Set Implicit Arguments.
Set Strict Implicit.
Set Primitive Projections.

Section lem.
  Variable typ : Set.
  Variable expr : Set.
  Context {RType_typ : RType typ}.
  Context {Expr_expr : Expr _ expr}.
  Context {ExprOk_expr : ExprOk Expr_expr}.
  Variable conclusion : Set.

  Record lemma : Set := mkLemma
  { vars : list typ
  ; premises : list expr
  ; concl : conclusion
  }.

  Variable conclusionD : forall us vs, conclusion -> option (exprT us vs Prop).

  Context {Typ0_Prop : Typ0 _ Prop}.

  Fixpoint foralls (ls : list typ) : (OpenT typD ls Prop) -> Prop :=
    match ls as ls return (OpenT typD ls Prop) -> Prop with
      | nil => fun P => P Hnil
      | l :: ls => fun P => foralls (fun z => forall x : typD l, P (Hcons x z))
    end.

  Lemma foralls_sem : forall ls P,
    foralls (ls := ls) P <-> forall h, P h.
  Proof.
    clear.
    induction ls; simpl; intros.
    { intuition; rewrite hlist_eta; auto. }
    { intuition.
      { rewrite hlist_eta.
        eapply IHls in H. eapply H. }
      { eapply IHls. eauto. } }
  Qed.

  Lemma foralls_iff
  : forall ls F G,
      (forall x, (F x) <-> (G x)) ->
      ((@foralls ls F) <-> (@foralls ls G)).
  Proof.
    intros.
    rewrite foralls_sem. rewrite foralls_sem.
    intuition; eapply H; eauto.
  Qed.

  Lemma foralls_impl
  : forall ls (F G : _ -> Prop),
      (forall x, (F x) -> (G x)) ->
      ((@foralls ls F) -> (@foralls ls G)).
  Proof.
    intros.
    rewrite foralls_sem. rewrite foralls_sem in H0.
    intuition; eapply H; eauto.
  Qed.

  Fixpoint impls (ls : list Prop) (P : Prop) :=
    match ls with
      | nil => P
      | l :: ls => l -> impls ls P
    end.

  Lemma impls_sem : forall ps x,
    impls ps x <->
    (Forall (fun x => x) ps -> x).
  Proof.
    induction ps; simpl; intuition.
    { inversion H0; clear H0; subst.
      eapply IHps; auto. }
    { eapply IHps. intros. eapply H. constructor; auto. }
  Qed.

  Lemma impls_iff : forall ps ps' p q,
                      Forall2 (fun P Q => P <-> Q) ps ps' ->
                      (p <-> q) ->
                      (@impls ps p <-> @impls ps' q).
  Proof.
    clear.
    induction 1; simpl; intros; auto.
    rewrite H. rewrite IHForall2; eauto. reflexivity.
  Qed.

  Definition lemmaD' (tus tvs : tenv typ) (l : lemma)
  : option (exprT tus tvs Prop) :=
    match
        Traversable.mapT (T := list) (F := option)
                         (fun e : expr => exprD_typ0 tus (vars l ++ tvs) e)
                         (premises l)
      , conclusionD tus (vars l ++ tvs) (concl l)
    with
      | Some prems , Some concl =>
        Some (fun us vs =>
                foralls (fun h : hlist (typD) (vars l) =>
                           let vs' := hlist_app h vs in
                           impls (map (fun x => x us vs') prems)
                                 (concl us vs')))
      | _ , _ => None
    end.

  Hypothesis conclusionD_weaken
  : forall tus tvs l lD,
      conclusionD tus tvs l = Some lD ->
      forall tus' tvs',
        exists lD',
          conclusionD (tus ++ tus') (tvs ++ tvs') l = Some lD' /\
          forall us us' vs vs',
            lD us vs <-> lD' (hlist_app us us') (hlist_app vs vs').

  Opaque Traversable.mapT.

  Lemma Forall2_map1
  : forall T U V (f : T -> V) (R : V -> U -> Prop)
           ls ls',
      Forall2 R (map f ls) ls' <->
      Forall2 (fun x y => R (f x) y) ls ls'.
  Proof.
    clear. induction ls; simpl.
    { split; inversion 1; subst; auto. }
    { split; inversion 1; subst.
      { inversion H. subst. constructor; auto. eapply IHls. eauto. }
      { inversion H. subst. constructor; auto. eapply IHls. eauto. } }
  Qed.

  Lemma Forall2_map2
  : forall T U V (f : T -> _) (R : V -> U -> Prop)
           ls ls',
      Forall2 R ls (map f ls') <->
      Forall2 (fun x y => R x (f y)) ls ls'.
  Proof.
    clear. induction ls; simpl.
    { split; inversion 1; subst; auto.
      destruct ls'. auto. inversion H0. constructor. }
    { split; inversion 1; subst. destruct ls'; [ inversion H2 | ].
      simpl in *. inversion H2; clear H2; subst.
      { inversion H. subst. constructor; auto. eapply IHls. eauto. }
      { inversion H. subst. constructor; auto. eapply IHls. eauto. } }
  Qed.

  Set Printing Universes.

  Lemma lemmaD'_weaken
  : forall tus tvs l lD,
      lemmaD' tus tvs l = Some lD ->
      forall tus' tvs',
        exists lD',
          lemmaD' (tus ++ tus') (tvs ++ tvs') l = Some lD' /\
          forall us us' vs vs',
            lD us vs <-> lD' (hlist_app us us') (hlist_app vs vs').
  Proof.
    unfold lemmaD'; simpl; intros.
    forward.
    inv_all; subst.
    generalize (fun H' =>
                  @mapT_Forall2 _ _
                                 (fun e v =>
                                    exists v',
                                      exprD_typ0 (tus ++ tus') (vars l ++ tvs ++ tvs') e = Some v' /\
                                      forall a b c d e,
                                        v a (hlist_app b c) = v' (hlist_app a e) (hlist_app b (hlist_app c d)))
                   _
                   H'
                   _ _ H).
    match goal with
      | |- (?X -> _) -> _ =>
        let H := fresh in
        assert (H : X) ;
          [ | intro XXX; specialize (XXX H) ]
    end.
    { simpl. intros.
      eapply (exprD_typ0_weaken tus' tvs') in H1;
        eauto with typeclass_instances.
      forward_reason.
      rewrite exprD_typ0_conv with (pfu := eq_refl)
                                    (pfv := eq_sym (app_ass_trans@{Set} (vars l) tvs tvs')) in H1.
      autorewrite_with_eq_rw_in H1. forward.
      inv_all; subst.
      eexists; split; eauto.
      intros. specialize (H2 a0 (hlist_app b c) e1 d).
      rewrite H2.
      autorewrite with eq_rw.
      rewrite hlist_app_assoc.
      generalize (app_ass_trans (vars l) tvs tvs').
      generalize (hlist_app b (hlist_app c d)).
      clear. destruct e. reflexivity. }
    eapply mapT_Forall
    with (P := fun e =>
                 exists v,
                   exprD_typ0 (tus ++ tus') (vars l ++ tvs ++ tvs') e = Some v) in H.
    { eapply mapT_Forall2'
      with (f := fun e : expr => exprD_typ0 (tus ++ tus') (vars l ++ tvs ++ tvs') e)
           (ls := l.(premises))
           (R :=
              fun e (v' : exprT (tus ++ tus') (vars l ++ tvs ++ tvs') Prop) =>
                forall v : exprT tus (vars l ++ tvs) Prop,
                  exprD_typ0 tus (vars l ++ tvs) e = Some v ->
                  forall us us' vs vs' vs'',
                    v us (hlist_app vs vs') = v' (hlist_app us us')  (hlist_app vs (hlist_app vs' vs''))) in H.
    { destruct H as [ ? [ ? ? ] ].
      rewrite H.
      eapply conclusionD_weaken with (tus' := tus') (tvs' := tvs') in H0.
      forward_reason.
      Cases.rewrite_all_goal.
      assert (conclusionD (tus ++ tus') (vars l ++ tvs ++ tvs') (concl l) =
              Some match app_ass_trans (vars l) tvs tvs' in _ = tvs
                         return hlist _ (tus ++ tus') -> hlist _ tvs -> Prop
                   with
                     | eq_refl => x0
                   end).
      { clear - H0.
        generalize dependent (app_ass_trans@{Set} (vars l) tvs tvs').
        generalize dependent ((vars l ++ tvs) ++ tvs').
        generalize dependent (vars l ++ tvs ++ tvs').
        intros. subst. assumption. }
      rewrite H4.
      intros.
      eexists; split; eauto. intros.
      simpl. eapply foralls_iff. intros.
      eapply impls_iff.
      { rewrite Forall2_map2. rewrite Forall2_map1.
        generalize dependent x.
        clear H4 conclusionD_weaken.
        induction XXX.
        { inversion 2; subst; auto. }
        { intros.
          inversion H4; clear H4; subst.
          rewrite list_mapT_cons in H2.
          destruct H as [ ? [ ? ? ] ].
          rewrite H in H2.
          forward. inv_all. subst.
          specialize (IHXXX _ eq_refl H9).
          constructor; eauto.
          { rewrite <- H4. reflexivity. } } }
      { autorewrite with eq_rw.
        rewrite H3.
        rewrite (hlist_app_assoc@{Set Urefl} x1 vs vs').
        reflexivity. } }
    { intros. destruct H2.
      rewrite H2. eexists; split; eauto.
      intros.
      eapply (exprD_typ0_weaken tus' tvs') in H3.
      destruct H3 as [ ? [ ? ? ] ].
      rewrite H4 with (us' := us') (vs' := vs''); clear H4.
      rewrite hlist_app_assoc.
      rewrite exprD_typ0_conv with (pfu := eq_refl) (pfv := app_ass_trans _ _ _) in H2.
      autorewrite_with_eq_rw_in H2.
      rewrite H3 in *. inv_all; subst.
      autorewrite with eq_rw.
      reflexivity. } }
    { intros.
      eapply (exprD_typ0_weaken tus' tvs') in H2.
      destruct H2 as [ ? [ ? ? ] ].
      rewrite exprD_typ0_conv with (pfu := eq_refl)
                                      (pfv := eq_sym (app_ass_trans _ _ _)) in H2.
      autorewrite_with_eq_rw_in H2.
      forward. eauto. }
  Qed.

  Lemma lemmaD'_conv
  : forall tus tvs tus' tvs' (pfu : tus' = tus) (pfv : tvs' = tvs),
      lemmaD' tus tvs =
      match pfu in _ = X , pfv in _ = Y return _ -> option (exprT X Y Prop) with
        | eq_refl , eq_refl => lemmaD' tus' tvs'
      end.
  Proof. destruct pfu; destruct pfv; reflexivity. Qed.

  Lemma lemmaD'_weakenU
  : forall tus tvs l lD,
      lemmaD' tus tvs l = Some lD ->
      forall tus',
        exists lD',
          lemmaD' (tus ++ tus') tvs l = Some lD' /\
          forall us us' vs,
            lD us vs <-> lD' (hlist_app us us') vs.
  Proof.
    intros.
    eapply lemmaD'_weaken with (tus' := tus') (tvs' := nil) in H.
    destruct H as [ ? [ ? ? ] ].
    rewrite lemmaD'_conv with (pfu := eq_refl) (pfv := app_nil_r_trans tvs).
    autorewrite_with_eq_rw.
    rewrite H. eexists; split; eauto.
    intros.
    etransitivity.
    eapply H0 with (us' := us') (vs' := Hnil).
    rewrite hlist_app_nil_r.
    autorewrite with eq_rw.
    reflexivity.
  Qed.

  Lemma lemmaD'_weakenV
  : forall tus tvs l lD,
      lemmaD' tus tvs l = Some lD ->
      forall tvs',
        exists lD',
          lemmaD' tus (tvs ++ tvs') l = Some lD' /\
          forall us vs vs',
            lD us vs <-> lD' us (hlist_app vs vs').
  Proof.
    intros.
    eapply lemmaD'_weaken with (tvs' := tvs') (tus' := nil) in H.
    destruct H as [ ? [ ? ? ] ].
    rewrite lemmaD'_conv with (pfv := eq_refl) (pfu := app_nil_r_trans tus).
    autorewrite_with_eq_rw.
    rewrite H. eexists; split; eauto.
    intros.
    etransitivity.
    eapply H0 with (vs' := vs') (us' := Hnil).
    rewrite hlist_app_nil_r.
    autorewrite with eq_rw.
    reflexivity.
  Qed.

  Definition lemmaD (us vs : env) (l : lemma) : Prop :=
    let (tus,us) := split_env us in
    let (tvs,vs) := split_env vs in
    match lemmaD' tus tvs l with
      | None => False
      | Some P => P us vs
    end.

  Lemma lemmaD_weakenU
  : forall us us' vs l,
      lemmaD us vs l ->
      lemmaD (us ++ us') vs l.
  Proof.
    intros.
    unfold lemmaD in H. forward.
    red. rewrite split_env_app.
    Cases.rewrite_all_goal.
    forward. inv_all. subst. subst.
    eapply lemmaD'_weakenU with (tus' := x2) in H1.
    destruct H1 as [ ? [ ? ? ] ].
    rewrite H1. apply H4. assumption.
  Qed.

  Lemma lemmaD_weakenV
  : forall us vs vs' l,
      lemmaD us vs l ->
      lemmaD us (vs ++ vs') l.
  Proof.
    intros.
    unfold lemmaD in H. forward.
    red. rewrite split_env_app.
    Cases.rewrite_all_goal.
    forward. inv_all. subst. subst.
    eapply lemmaD'_weakenV with (tvs' := x2) in H1.
    destruct H1 as [ ? [ ? ? ] ].
    rewrite H1. apply H4. assumption.
  Qed.

  Lemma lemmaD_lemmaD' : forall (l : lemma),
      lemmaD nil nil l <->
      exists pf, lemmaD' nil nil l = Some pf /\
                 pf Hnil Hnil.
  Proof using.
    clear. unfold lemmaD. simpl. intros.
    destruct (lemmaD' nil nil l).
    { split; eauto. intros; forward_reason.
      inv_all. subst. assumption. }
    { split; intros. inversion H. forward_reason. inversion H. }
  Qed.

End lem.

Require Import MirrorCore.Reify.ReifyClass.

Section rlemma.
  Context {ty pr c : Set}.
  Context {rT : Reify ty}.
  Context {rU : Reify pr}.
  Context {rV : Reify c}.

  Definition add_var (v : ty) (x : lemma ty pr c) : lemma ty pr c :=
    {| vars := vars x ++ v :: nil
     ; premises := premises x
     ; concl := concl x |}.

  Definition add_prem (v : pr) (x : lemma ty pr c) : lemma ty pr c :=
    {| vars := vars x
     ; premises := v :: premises x
     ; concl := concl x |}.

  Definition reify_lemma : Command@{Set} (lemma ty pr c) :=
    Eval unfold CPattern in
    CFix
      (CFirst (   CPattern (ls:=(pr : Type)::(lemma ty pr c : Type)::nil)
                           (RImpl (RGet 0 RIgnore) (RGet 1 RIgnore))
                           (fun (x : function (CCall (reify_scheme _))) (y : function (CRec 0)) => add_prem x y)
               :: CPattern (ls:=(ty : Type)::(lemma ty pr c : Type)::nil)
                           (RPi (RGet 0 RIgnore) (RGet 1 RIgnore))
                           (fun (x : function (CCall (reify_scheme _))) (y : function (CRec 0)) => add_var x y)
               :: CMap (fun x => {| vars := nil
                                  ; premises := nil
                                  ; concl := x |}) (reify_scheme _)
               :: nil)).

  Global Instance Reify_rlemma : Reify (lemma ty pr c) :=
  { reify_scheme := CCall reify_lemma }.

End rlemma.


Require Export Fiat.Common.Coq__8_4__8_5__Compat.
Require Import Coq.Strings.String Coq.Lists.List.
Require Import Coq.ZArith.ZArith.
Require Import Fiat.Parsers.ContextFreeGrammar.Core.
Require Import Fiat.Parsers.BaseTypes.
Require Import Fiat.Common.List.Operations.
Require Import Fiat.Common.
Require Import Fiat.Common.List.ListFacts.
Require Import Fiat.Common.Enumerable.
Require Import Fiat.Common.LogicFacts.
Require Import Fiat.Common.Equality.
Import ListNotations.

Set Implicit Arguments.

Local Open Scope string_like_scope.
Local Open Scope type_scope.

Section cfg.
  Context {Char} {HSLM : StringLikeMin Char} {predata : @parser_computational_predataT Char} {HEC : Enumerable Char}.

  Class paren_balanced_hiding_dataT :=
    { is_open : Char -> bool;
      is_close : Char -> bool;
      is_bin_op : Char -> bool }.

  Context {pdata : paren_balanced_hiding_dataT}.

  Context (G : grammar Char).

  (**
<<
pb' ch n "" = (n == 0)
pb' ch n (ch :: s) = n > 0 && pb' ch n s
pb' ch n ('(' :: s) = pb' ch (n + 1) s
pb' ch n (')' :: s) = n > 0 && pb' ch (n - 1) s
pb' ch n (_ :: s) = pb' ch n s

pb = pb' '+' 0
>>
*)

  Definition pb_check_level (hiding : bool) (ch : Char) (start_level : nat) : bool
    := if is_bin_op ch
       then if hiding
            then Compare_dec.gt_dec start_level 0 : bool
            else true
       else if is_open ch
            then true
            else if is_close ch
                 then (Compare_dec.gt_dec start_level 0 : bool)
                 else true.

  Definition pb_new_level (ch : Char) (start_level : nat) : nat
    := if is_bin_op ch
       then start_level
       else if is_open ch
            then (S start_level)
            else if is_close ch
                 then (pred start_level)
                 else start_level.

  (** We can check the level for a function [Char -> bool] by enumerating through all the booleans *)
  Definition pb_check_level_fun (hiding : bool) (P : Char -> bool) (start_level : nat) : bool
    := List.fold_right
         andb
         true
         (List.map
            (fun ch => pb_check_level hiding ch start_level)
            (List.filter
               P
               (enumerate Char))).

  Lemma pb_check_level_fun_correct hiding P start_level
  : pb_check_level_fun hiding P start_level
    <-> (forall ch, P ch -> pb_check_level hiding ch start_level).
  Proof.
    unfold pb_check_level_fun.
    setoid_rewrite fold_right_andb_map_in_iff.
    setoid_rewrite filter_In.
    setoid_rewrite (fun x => @and_TrueP_L (In x (enumerate Char)) (P x = true) (enumerate_correct x)).
    reflexivity.
  Qed.

  Definition pb_new_level_fun (P : Char -> bool) (start_level : nat) : list nat
    := List.uniquize
         EqNat.beq_nat
         (List.map
            (fun ch => pb_new_level ch start_level)
            (List.filter
               P
               (enumerate Char))).

  Lemma pb_new_level_fun_correct P start_level new_level
  : pb_new_level_fun P start_level = [new_level]
    <-> ((exists ch, P ch) /\ forall ch, P ch -> new_level = pb_new_level ch start_level).
  Proof.
    unfold pb_new_level_fun.
    rewrite (uniquize_singleton (beq := EqNat.beq_nat) bl lb).
    setoid_rewrite in_map_iff.
    setoid_rewrite filter_In.
    setoid_rewrite (fun x => @and_TrueP_L (In x (enumerate Char)) (P x = true) (enumerate_correct _)).
    split; intro H;
    repeat match goal with
             | _ => split
             | _ => intro
             | _ => progress subst
             | _ => progress destruct_head ex
             | _ => progress split_and
             | _ => progress split_iff
             | [ H : forall x, _ = x -> _ |- _ ] => specialize (H _ eq_refl)
             | [ H : forall x, x = _ -> _ |- _ ] => specialize (H _ eq_refl)
             | [ H : forall x, _ -> _ = _ |- _ ] => unique pose proof (fun x H' => eq_sym (H x H'))
             | _ => solve [ eauto ]
           end.
  Qed.

  Section generic.
    Context (transform_valid : nonterminals_listT -> nonterminal_carrierT -> nonterminals_listT).

    Inductive generic_pb'_productions : nonterminals_listT -> productions Char -> Type :=
    | PBNil : forall valid,
                 generic_pb'_productions valid nil
    | PBCons : forall valid pat pats,
                  generic_pb'_production valid 0 pat
                  -> generic_pb'_productions valid pats
                  -> generic_pb'_productions valid (pat::pats)
    with generic_pb'_production : nonterminals_listT -> nat -> production Char -> Type :=
    | PBProductionNil : forall valid,
                           generic_pb'_production valid 0 nil
    | PBProductionConsNonTerminal : forall valid start_level nt its,
                                       is_valid_nonterminal valid (of_nonterminal nt)
                                       -> generic_pb'_productions (transform_valid valid (of_nonterminal nt)) (Lookup G nt)
                                       -> generic_pb'_production valid start_level its
                                       -> generic_pb'_production valid start_level (NonTerminal nt :: its)
    | PBProductionConsTerminal : forall valid start_level new_level P its,
                                   (forall ch, is_true (P ch) -> pb_check_level false ch start_level)
                                   -> (forall ch, is_true (P ch) -> pb_new_level ch start_level = new_level)
                                    -> generic_pb'_production valid new_level its
                                    -> generic_pb'_production valid start_level (Terminal P :: its).
  End generic.

  Definition minimal_pb'_productions := generic_pb'_productions remove_nonterminal.
  Definition minimal_pb'_production := generic_pb'_production remove_nonterminal.

  Definition pb'_productions := generic_pb'_productions (fun valid _ => valid).
  Definition pb'_production := generic_pb'_production (fun valid _ => valid).

  Lemma pb_check_level_le {ch b} {n n'} (Hle : n <= n')
  : pb_check_level b ch n -> pb_check_level b ch n'.
  Proof.
    unfold pb_check_level.
    do 2 edestruct Compare_dec.gt_dec; trivial; try omega; simpl.
    destruct b;
    edestruct is_bin_op; trivial;
    edestruct is_close;
    edestruct is_open;
    unfold is_true;
    trivial.
  Qed.

  Global Instance pb_new_level_Proper {ch}
  : Proper (le ==> le) (pb_new_level ch).
  Proof.
    intros ???.
    unfold pb_new_level.
    edestruct is_bin_op; trivial;
    edestruct is_close;
    edestruct is_open;
    unfold is_true;
    trivial;
    omega.
  Qed.

  Global Instance pb_new_level_flip_Proper {ch}
  : Proper (Basics.flip le ==> Basics.flip le) (pb_new_level ch).
  Proof.
    unfold Basics.flip, pb_new_level.
    intros ???.
    edestruct is_bin_op; trivial;
    edestruct is_close;
    edestruct is_open;
    unfold is_true;
    trivial;
    omega.
  Qed.
End cfg.

Global Arguments paren_balanced_hiding_dataT : clear implicits.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(*****************************************************************************)
(*          Projet Formel - Calculus of Inductive Constructions V5.10        *)
(*****************************************************************************)
(*									     *)
(*	                       SET is CCC                		     *)
(*									     *)
(*****************************************************************************)
(*									     *)
(*                     A. SAIBI	  May 95                  		     *)
(*									     *)
(*****************************************************************************)

Require Export SET_Terminal.
Require Export SET_Exponents.
Require Export CCC.

Set Implicit Arguments.
Unset Strict Implicit.

(* SET est Cartesian *)

Definition SET_is_Cartesian := Build_IsCartesian SET_Terminal SET_hasBinProd.

Definition SET_is_CCC :=
  Build_IsCCC (CCC_isCar:=SET_is_Cartesian) SET_hasExponent.


Require Import HypotheticalExternLib .
Require Import implementation_6 .
Require Import Coq.Numbers.BinNums.
Require Import Coq.PArith.BinPosDef.
Require Import Logic.lib.PTree.
Require Import Coq.Sets.Ensembles.
Require Import Coq.Lists.List.
Import ListNotations.

Module ___LogicTheorem___ :=  T .
Module EXPO.
Import ___LogicTheorem___.
  Section EXPO_SECTION.
  Context `{ para }.

  Declare Scope EXPO_scope.
  Local Open Scope EXPO_scope.

  Definition expr : Type := ltac:(let x0 := eval unfold expr in expr in exact x0).
  Ltac unfold_tac x :=
    let x0 :=
    eval cbv beta delta [
       expr
      ] in x
      in exact x0.

  Local Notation "'UNFOLD' x" := ltac:(unfold_tac x) (only parsing, at level 99): EXPO_scope.

  Definition provable : UNFOLD (expr -> Prop) := provable .
  Definition impp : UNFOLD (expr -> expr -> expr) := impp .
  Definition andp : UNFOLD (expr -> expr -> expr) := andp .
  Definition sepcon : UNFOLD (expr -> expr -> expr) := ltac:(let x0 := eval unfold sepcon in sepcon in exact x0).
  Definition emp : UNFOLD expr := ltac:(let x0 := eval unfold emp in emp in exact x0).

  Ltac unfold2_tac x :=
    let x0 :=
    eval cbv beta delta [
       expr
       sepcon
       emp
    ] in x
    in exact x0.
  Local Notation "'UNFOLD2' x" := ltac:(unfold2_tac x) (only parsing, at level 99): EXPO_scope.

  Definition derivable1 := UNFOLD2 (fun x y : expr => provable (impp x y)) .
  Definition logic_equiv := UNFOLD2 (fun x y : expr => provable (impp x y) /\ provable (impp y x)) .
  Definition iffp := UNFOLD2 (fun x y : expr => andp (impp x y) (impp y x)) .
  Definition multi_imp := UNFOLD2 (fun (xs : list expr) (y : expr) => fold_right impp y xs) .
  Definition sepcon_emp : UNFOLD2 (forall x : expr, provable (iffp (sepcon x emp) x)) := sepcon_emp .
  Definition sepcon_comm : UNFOLD2 (forall x y : expr, provable (iffp (sepcon x y) (sepcon y x))) := sepcon_comm .
  Definition sepcon_assoc : UNFOLD2 (forall x y z : expr, provable (iffp (sepcon x (sepcon y z)) (sepcon (sepcon x y) z))) := sepcon_assoc .
  Definition sepcon_mono : UNFOLD2 (forall x1 x2 y1 y2 : expr, provable (impp x1 x2) -> provable (impp y1 y2) -> provable (impp (sepcon x1 y1) (sepcon x2 y2))) := sepcon_mono .
  Definition andp_intros : UNFOLD2 (forall x y : expr, provable (impp x (impp y (andp x y)))) := andp_intros .
  Definition andp_elim1 : UNFOLD2 (forall x y : expr, provable (impp (andp x y) x)) := andp_elim1 .
  Definition andp_elim2 : UNFOLD2 (forall x y : expr, provable (impp (andp x y) y)) := andp_elim2 .
  Definition modus_ponens : UNFOLD2 (forall x y : expr, provable (impp x y) -> provable x -> provable y) := modus_ponens .
  Definition axiom1 : UNFOLD2 (forall x y : expr, provable (impp x (impp y x))) := axiom1 .
  Definition axiom2 : UNFOLD2 (forall x y z : expr, provable (impp (impp x (impp y z)) (impp (impp x y) (impp x z)))) := axiom2 .
Definition tree_pos : Type := tree_pos.
  Definition logic_equiv_derivable1 : UNFOLD2 (forall x y : expr, logic_equiv x y <-> derivable1 x y /\ derivable1 y x) := logic_equiv_derivable1 .
  Definition logic_equiv_impp : UNFOLD2 (forall x1 x2 y1 y2 : expr, logic_equiv x1 x2 -> logic_equiv y1 y2 -> logic_equiv (impp x1 y1) (impp x2 y2)) := logic_equiv_impp .
  Definition logic_equiv_refl : UNFOLD2 (forall x : expr, logic_equiv x x) := logic_equiv_refl .
  Definition logic_equiv_symm : UNFOLD2 (forall x y : expr, logic_equiv x y -> logic_equiv y x) := logic_equiv_symm .
  Definition logic_equiv_trans : UNFOLD2 (forall x y z : expr, logic_equiv x y -> logic_equiv y z -> logic_equiv x z) := logic_equiv_trans .
  Definition sepcon_emp_left : UNFOLD2 (forall x : expr, derivable1 (sepcon x emp) x) := sepcon_emp_left .
  Definition sepcon_emp_right : UNFOLD2 (forall x : expr, derivable1 x (sepcon x emp)) := sepcon_emp_right .
  Definition derivable1_sepcon_comm : UNFOLD2 (forall x y : expr, derivable1 (sepcon x y) (sepcon y x)) := derivable1_sepcon_comm .
  Definition derivable1_sepcon_assoc1 : UNFOLD2 (forall x y z : expr, derivable1 (sepcon x (sepcon y z)) (sepcon (sepcon x y) z)) := derivable1_sepcon_assoc1 .
  Definition derivable1_sepcon_mono : UNFOLD2 (forall x1 x2 y1 y2 : expr, derivable1 x1 x2 -> derivable1 y1 y2 -> derivable1 (sepcon x1 y1) (sepcon x2 y2)) := derivable1_sepcon_mono .
  Definition derivable1_refl : UNFOLD2 (forall x : expr, derivable1 x x) := derivable1_refl .
  Definition derivable1_trans : UNFOLD2 (forall x y z : expr, derivable1 x y -> derivable1 y z -> derivable1 x z) := derivable1_trans .
  Definition sepcon_emp1 : UNFOLD2 (forall x : expr, provable (impp (sepcon x emp) x)) := sepcon_emp1 .
  Definition sepcon_emp2 : UNFOLD2 (forall x : expr, provable (impp x (sepcon x emp))) := sepcon_emp2 .
  Definition sepcon_comm_impp : UNFOLD2 (forall x y : expr, provable (impp (sepcon x y) (sepcon y x))) := sepcon_comm_impp .
  Definition sepcon_assoc1 : UNFOLD2 (forall x y z : expr, provable (impp (sepcon x (sepcon y z)) (sepcon (sepcon x y) z))) := sepcon_assoc1 .
  Definition iffp_intros : UNFOLD2 (forall x y : expr, provable (impp (impp x y) (impp (impp y x) (iffp x y)))) := iffp_intros .
  Definition iffp_elim1 : UNFOLD2 (forall x y : expr, provable (impp (iffp x y) (impp x y))) := iffp_elim1 .
  Definition iffp_elim2 : UNFOLD2 (forall x y : expr, provable (impp (iffp x y) (impp y x))) := iffp_elim2 .
  Definition provable_impp_refl : UNFOLD2 (forall x : expr, provable (impp x x)) := provable_impp_refl .
  Definition provable_impp_refl' : UNFOLD2 (forall x y : expr, x = y -> provable (impp x y)) := provable_impp_refl' .
  Definition provable_impp_arg_switch : UNFOLD2 (forall x y z : expr, provable (impp (impp x (impp y z)) (impp y (impp x z)))) := provable_impp_arg_switch .
  Definition provable_impp_trans : UNFOLD2 (forall x y z : expr, provable (impp (impp x y) (impp (impp y z) (impp x z)))) := provable_impp_trans .
  Definition provable_multi_imp_shrink : UNFOLD2 (forall (xs : list expr) (x y : expr), provable (impp (impp x (multi_imp xs (impp x y))) (multi_imp xs (impp x y)))) := provable_multi_imp_shrink .
  Definition provable_multi_imp_arg_switch1 : UNFOLD2 (forall (xs : list expr) (x y : expr), provable (impp (impp x (multi_imp xs y)) (multi_imp xs (impp x y)))) := provable_multi_imp_arg_switch1 .
  Definition provable_multi_imp_arg_switch2 : UNFOLD2 (forall (xs : list expr) (x y : expr), provable (impp (multi_imp xs (impp x y)) (impp x (multi_imp xs y)))) := provable_multi_imp_arg_switch2 .
  Definition provable_add_multi_imp_left_head : UNFOLD2 (forall (xs1 xs2 : list expr) (y : expr), provable (impp (multi_imp xs2 y) (multi_imp (xs1 ++ xs2) y))) := provable_add_multi_imp_left_head .
  Definition provable_add_multi_imp_left_tail : UNFOLD2 (forall (xs1 xs2 : list expr) (y : expr), provable (impp (multi_imp xs1 y) (multi_imp (xs1 ++ xs2) y))) := provable_add_multi_imp_left_tail .
  Definition provable_multi_imp_modus_ponens : UNFOLD2 (forall (xs : list expr) (y z : expr), provable (impp (multi_imp xs y) (impp (multi_imp xs (impp y z)) (multi_imp xs z)))) := provable_multi_imp_modus_ponens .
  Definition provable_multi_imp_weaken : UNFOLD2 (forall (xs : list expr) (x y : expr), provable (impp x y) -> provable (impp (multi_imp xs x) (multi_imp xs y))) := provable_multi_imp_weaken .
  Definition provable_impp_refl_instance : UNFOLD2 (RelationClasses.Reflexive (fun x y : expr => provable (impp x y))) := provable_impp_refl_instance .
  Definition provable_proper_impp : UNFOLD2 (Morphisms.Proper (Morphisms.respectful (fun x y : expr => provable (impp x y)) Basics.impl) provable) := provable_proper_impp .
  Definition impp_proper_impp : UNFOLD2 (Morphisms.Proper (Morphisms.respectful (Basics.flip (fun x y : expr => provable (impp x y))) (Morphisms.respectful (fun x y : expr => provable (impp x y)) (fun x y : expr => provable (impp x y)))) impp) := impp_proper_impp .
  Definition andp_comm : UNFOLD2 (forall x y : expr, provable (iffp (andp x y) (andp y x))) := andp_comm .
  Definition andp_assoc : UNFOLD2 (forall x y z : expr, provable (iffp (andp (andp x y) z) (andp x (andp y z)))) := andp_assoc .
  Definition impp_curry : UNFOLD2 (forall x y z : expr, provable (impp (impp x (impp y z)) (impp (andp x y) z))) := impp_curry .
  Definition impp_uncurry : UNFOLD2 (forall x y z : expr, provable (impp (impp (andp x y) z) (impp x (impp y z)))) := impp_uncurry .
  Definition solve_impp_trans : UNFOLD2 (forall x y z : expr, provable (impp x y) -> provable (impp y z) -> provable (impp x z)) := solve_impp_trans .
  Definition andp_proper_impp : UNFOLD2 (Morphisms.Proper (Morphisms.respectful (fun x y : expr => provable (impp x y)) (Morphisms.respectful (fun x y : expr => provable (impp x y)) (fun x y : expr => provable (impp x y)))) andp) := andp_proper_impp .
  Definition provable_iffp_equiv : UNFOLD2 (RelationClasses.Equivalence (fun x y : expr => provable (iffp x y))) := provable_iffp_equiv .
  Definition provable_proper_iffp : UNFOLD2 (Morphisms.Proper (Morphisms.respectful (fun x y : expr => provable (iffp x y)) iff) provable) := provable_proper_iffp .
  Definition impp_proper_iffp : UNFOLD2 (Morphisms.Proper (Morphisms.respectful (fun x y : expr => provable (iffp x y)) (Morphisms.respectful (fun x y : expr => provable (iffp x y)) (fun x y : expr => provable (iffp x y)))) impp) := impp_proper_iffp .
  Definition andp_proper_iffp : UNFOLD2 (Morphisms.Proper (Morphisms.respectful (fun x y : expr => provable (iffp x y)) (Morphisms.respectful (fun x y : expr => provable (iffp x y)) (fun x y : expr => provable (iffp x y)))) andp) := andp_proper_iffp .
  Definition iffp_proper_iffp : UNFOLD2 (Morphisms.Proper (Morphisms.respectful (fun x y : expr => provable (iffp x y)) (Morphisms.respectful (fun x y : expr => provable (iffp x y)) (fun x y : expr => provable (iffp x y)))) iffp) := iffp_proper_iffp .
  Definition cancel_ready : UNFOLD2 (forall x y : expr, provable (impp (sepcon x emp) y) -> provable (impp x y)) := cancel_ready .
  Definition cancel_one_succeed : UNFOLD2 (forall u x y z : expr, provable (impp (sepcon x y) z) -> provable (impp (sepcon (sepcon u x) y) (sepcon u z))) := cancel_one_succeed .
  Definition cancel_one_giveup : UNFOLD2 (forall x y z w v : expr, provable (impp (sepcon x (sepcon y z)) (sepcon w v)) -> provable (impp (sepcon (sepcon y x) z) (sepcon w v))) := cancel_one_giveup .
  Definition cancel_rev : UNFOLD2 (forall x y z w : expr, provable (impp (sepcon (sepcon y x) z) w) -> provable (impp (sepcon x (sepcon y z)) w)) := cancel_rev .
  Definition cancel_finish : UNFOLD2 (forall x : expr, provable (impp (sepcon x emp) x)) := cancel_finish .
  Definition sepcon_proper_impp : UNFOLD2 (Morphisms.Proper (Morphisms.respectful (fun x y : expr => provable (impp x y)) (Morphisms.respectful (fun x y : expr => provable (impp x y)) (fun x y : expr => provable (impp x y)))) sepcon) := sepcon_proper_impp .
  Definition sepcon_proper_iffp : UNFOLD2 (Morphisms.Proper (Morphisms.respectful (fun x y : expr => provable (iffp x y)) (Morphisms.respectful (fun x y : expr => provable (iffp x y)) (fun x y : expr => provable (iffp x y)))) sepcon) := sepcon_proper_iffp .
  Definition expr_deep : UNFOLD2 Set := expr_deep .
  Definition impp_deep : UNFOLD2 (expr_deep -> expr_deep -> expr_deep) := impp_deep .
  Definition sepcon_deep : UNFOLD2 (expr_deep -> expr_deep -> expr_deep) := sepcon_deep .
  Definition emp_deep : UNFOLD2 expr_deep := emp_deep .
  Definition varp_deep : UNFOLD2 (nat -> expr_deep) := varp_deep .
  Definition var_pos : UNFOLD2 (expr -> option positive -> tree_pos) := var_pos .
  Definition sepcon_pos : UNFOLD2 (tree_pos -> tree_pos -> tree_pos) := sepcon_pos .
  Definition cancel_mark : UNFOLD2 (expr_deep -> expr_deep -> tree_pos -> tree_pos -> tree_pos * tree_pos) := cancel_mark .
  Definition cancel_different : UNFOLD2 (tree_pos -> tree_pos -> expr) := cancel_different .
  Definition cancel_same : UNFOLD2 (tree_pos -> tree_pos -> Prop) := cancel_same .
  Definition restore : UNFOLD2 (tree_pos -> tree_pos -> expr) := restore .
  Definition cancel_sound : UNFOLD2 (forall tep teq : tree_pos, cancel_same tep teq -> provable (cancel_different tep teq) -> provable (restore tep teq)) := cancel_sound .
  Definition impp_proper_equiv : UNFOLD2 (Morphisms.Proper (Morphisms.respectful logic_equiv (Morphisms.respectful logic_equiv logic_equiv)) impp) := impp_proper_equiv .
  Definition sepcon_proper_logic_equiv : UNFOLD2 (Morphisms.Proper (Morphisms.respectful logic_equiv (Morphisms.respectful logic_equiv logic_equiv)) sepcon) := sepcon_proper_logic_equiv .
  Definition provable_proper_equiv : UNFOLD2 (Morphisms.Proper (Morphisms.respectful logic_equiv iff) provable) := provable_proper_equiv .
  Definition logic_equiv_refl_instance : UNFOLD2 (RelationClasses.Reflexive logic_equiv) := logic_equiv_refl_instance .
  Definition logic_equiv_symm_instance : UNFOLD2 (RelationClasses.Symmetric logic_equiv) := logic_equiv_symm_instance .
  Definition logic_equiv_trans_instance : UNFOLD2 (RelationClasses.Transitive logic_equiv) := logic_equiv_trans_instance .
  Definition sepcon_comm_logic_equiv : UNFOLD2 (forall x y : expr, logic_equiv (sepcon x y) (sepcon y x)) := sepcon_comm_logic_equiv .
  Definition sepcon_assoc_logic_equiv : UNFOLD2 (forall x y z : expr, logic_equiv (sepcon x (sepcon y z)) (sepcon (sepcon x y) z)) := sepcon_assoc_logic_equiv .
  Definition sepcon_emp_logic_equiv : UNFOLD2 (forall x : expr, logic_equiv (sepcon x emp) x) := sepcon_emp_logic_equiv .

  End EXPO_SECTION.

  Existing Instance provable_impp_refl_instance .
  Existing Instance provable_proper_impp .
  Existing Instance impp_proper_impp .
  Existing Instance andp_proper_impp .
  Existing Instance provable_iffp_equiv .
  Existing Instance provable_proper_iffp .
  Existing Instance impp_proper_iffp .
  Existing Instance andp_proper_iffp .
  Existing Instance iffp_proper_iffp .
  Existing Instance sepcon_proper_impp .
  Existing Instance sepcon_proper_iffp .
  Existing Instance impp_proper_equiv .
  Existing Instance sepcon_proper_logic_equiv .
  Existing Instance provable_proper_equiv .
  Existing Instance logic_equiv_refl_instance .
  Existing Instance logic_equiv_symm_instance .
  Existing Instance logic_equiv_trans_instance .

End EXPO.

Module EXPO_TRANSPARENTS.
Import EXPO.
Declare Scope expo_transparent_scope.
Notation
  "'expr'"
    := (ltac:(let x0 := eval unfold expr in expr in exact x0)) (only parsing, at level 99): expo_transparent_scope.
Notation
  "'sepcon'"
    := (ltac:(let x0 := eval unfold sepcon in sepcon in exact x0)) (only parsing, at level 99): expo_transparent_scope.
Notation
  "'emp'"
    := (ltac:(let x0 := eval unfold emp in emp in exact x0)) (only parsing, at level 99): expo_transparent_scope.
End EXPO_TRANSPARENTS.