  (***************************************************************)
  (*   This file is part of the static analyses developement -   *)
  (*   specification of kildall's algorithm, and proof it is a   *)
  (*   bytecode verifier -                                       *)
  (*						  	         *)
  (*   File : kildall.v					         *)
  (*   Authors : S. Coupet-Grimal, W. Delobel 		         *)
  (*   Content :	specification of kildall's algorithm     *)
  (***************************************************************)

Unset Standard Proposition Elimination Names.

Section kildall.

  Require Export itera.

  Variable Sigma : Set. (* state set *)
  Variable n : nat. (* bytecode size *)
  Variable succs : forall p:nat, p<n->nb_list n. (* successor function *)
  Variable step : forall p:nat, p<n->Sigma->list Sigma. (* flow function *)
  Variable wi : vector Sigma n -> nat -> Prop. (* correct state for instruction predicate *)
  Variable r : relation Sigma. (* order on state set *)
  Variable T : Sigma. 		(* Top element *)
  Variable sup : binop Sigma. (* sup on state set *)

  Hypothesis step_succs_same_length : forall (q:nat) (C:q<n) (s : Sigma),
    nb_length (succs q C) = length (step q C s).
  Hypothesis eq_Sigma_dec : forall x y : Sigma, {x = y} + {x <> y}.
  Hypothesis r_is_semilattice : semilattice Sigma r sup.
  Hypothesis wfr : ascending_chain r.
  Hypothesis succs_equiv : forall (p : nat) (C C' : p<n),
    (succs p C) =nb= (succs p C').
  Hypothesis step_equiv : forall (p:nat) (C C' : p<n) (s:Sigma),
    (step p C s) = (step p C' s).

  Notation Itera := (itera Sigma n succs step r sup step_succs_same_length
    eq_Sigma_dec r_is_semilattice wfr).
  Notation Step' := (step' Sigma n succs step step_succs_same_length).

  (* returns true if the list ss is stable *)
  Fixpoint is_stable (ss:vector Sigma n) (p:nat) (C:p < n) (succs':m_list n Sigma)
    {struct succs'} : bool :=
    match succs' with
      | pred_nil => true
      | pred_cons (q,t) Cq succsq =>
        match
          eq_Sigma_dec (sup t (ss[q|Cq])) (ss[q|Cq])
          with
      	  | left _ => is_stable ss p C succsq
      	  | right _ => false
        end
    end.

  Require Import Arith.

  Definition le_lt_Sn_m (p n:nat) (C:le (S p) n) := lt_S_n p n (le_lt_n_Sm (S p) n C).

  (* computes work list, i.e. list of unstable elements *)
  Fixpoint work_list (ss : vector Sigma n) (l : nat) {struct l} :
    (le l n)->nb_list n :=
    match l return (le l n)->(nb_list n) with
      | O => fun (h: le 0 n)=>(pred_nil (P n))
      |  S p => fun (C : le (S p) n)=> match (is_stable ss p (le_lt_Sn_m p n C)
        (Step' p (le_lt_Sn_m p n C) (ss[p|(le_lt_Sn_m p n C)]))) with
      	                                 | true => work_list ss p (le_Sn_le p n C)
       	                                 | false => nb_cons p (le_lt_Sn_m p n C) (work_list ss p (le_Sn_le p n C))
	                               end
    end.

  (* results about stable : *)
  Lemma is_stable_irrel :
    forall (ss:vector Sigma n) (p:nat) (l:m_list n Sigma) (C C':p<n),
      is_stable ss p C l=is_stable ss p C' l.
  Proof.
    induction l.
    intros.
    simpl; trivial.
    intros.
    simpl.
    rewrite (IHl C C').
    trivial.
  Qed.

  Lemma is_stable_list_irrel :
    forall (ss:vector Sigma n) (p:nat) (l l':m_list n Sigma) (C:p<n),
      m_list_equiv l l' -> is_stable ss p C l'=is_stable ss p C l.
  Proof.
    induction l; destruct l'; simpl.
    trivial.
    intros C Hsame.
    inversion Hsame.
    intros C Hsame.
    inversion Hsame.
    destruct a as [qa ta].
    destruct a0 as [qa0 ta0].
    intros C Hsame.
    inversion Hsame.
    subst qa0 ta0.
    rewrite (element_at_irrel Sigma n ss qa p0 q).
    elim (eq_Sigma_dec (sup ta (ss[qa|q])) (ss[qa|q])); intro comp.
    apply IHl.
    assumption.
    trivial.
  Qed.

  (* results about work list : *)
  Lemma  work_list_irrel_inc : forall (ss:vector Sigma n) (p q:nat) (C0 C1:p <= n),
    q INnb (work_list ss p C0) -> q INnb (work_list ss p C1).
  Proof.
    induction p; simpl.
    intros; trivial.
    intros q C0 C1.
    rewrite (is_stable_irrel ss p (Step' p (le_lt_Sn_m p n C0)
      (ss[p|(le_lt_Sn_m p n C0)])) (le_lt_Sn_m p n C0) (le_lt_Sn_m p n C1)).
    rewrite (element_at_irrel Sigma n ss p (le_lt_Sn_m p n C0) (le_lt_Sn_m p n C1)).
    rewrite (is_stable_list_irrel ss p (Step' p (le_lt_Sn_m p n C0)
      (ss[p|(le_lt_Sn_m p n C1)])) (Step' p (le_lt_Sn_m p n C1)
        (ss[p|(le_lt_Sn_m p n C1)]))).
    elim (is_stable ss p (le_lt_Sn_m p n C1) (Step' p (le_lt_Sn_m p n C0)
      (ss[p|(le_lt_Sn_m p n C1)]))).
    apply IHp.
    simpl.
    compare p q; intro comp.
    intros; left.
    symmetry; assumption.
    intro H.
    right.
    elim H.
    intro h; symmetry in h; contradiction.
    apply IHp.
    unfold step'; unfold m_list_equiv; apply m_list_equiv_combine; try auto.
    apply succs_equiv.
  Qed.

  Lemma aug_wl : forall (ss : vector Sigma n) (l : nat) (k:nat)
    (C : l<=n) (Ck:k>=0) (Ckl:k+l<=n) (q : nat),
    q INnb (work_list ss l C) ->q INnb (work_list ss (k+l) Ckl).
  Proof.
    induction k.
    simpl.
    intros until q.
    apply work_list_irrel_inc.
    simpl.
    intros.
    elim (is_stable ss (k + l) (le_lt_Sn_m (k + l) n Ckl)
      (Step' (k + l) (le_lt_Sn_m (k+l) n Ckl) (ss[k+l|(le_lt_Sn_m (k + l) n Ckl)]))).
    cut (k>=0).
    intro h.
    apply (IHk C h (le_Sn_le (k + l) n Ckl)).
    assumption.
    auto with arith.
    simpl.
    right.
    cut (k>=0).
    intro h.
    apply (IHk C h (le_Sn_le (k + l) n Ckl)).
    assumption.
    auto with arith.
  Qed.

  Remark aux : forall (ss : vector Sigma n) (l q : nat) (C : l<=n),
    l = n -> q INnb (work_list ss l C) -> q INnb (work_list ss n (le_refl n)).
  Proof.
    intros ss l q C H.
    subst l.
    apply work_list_irrel_inc.
  Qed.

  Remark aux2 : forall p q : nat, p=q->p<=q.
  Proof.
    intros p q H; rewrite H; apply le_refl.
  Qed.

  Lemma up_wl : forall (ss : vector Sigma n) (l : nat) (C : l<=n) (q : nat),
    q INnb (work_list ss l C) -> q INnb (work_list ss n (le_refl n)).
  Proof.
    intros.
    cut ((n-l)+l<=n).
    intro h.
    cut (q INnb (work_list ss ((n-l)+l) h)).
    apply aux.
    rewrite plus_comm.
    apply le_plus_minus_r.
    assumption.
    apply (aug_wl ss l (n-l) C).
    auto with arith.
    assumption.
    apply aux2.
    rewrite plus_comm.
    apply le_plus_minus_r.
    assumption.
  Qed.

  (* definition of function kildall : *)
  Definition Kildall (ss : vector Sigma n) : vector Sigma n :=
    Itera (ss, work_list ss n (le_refl n)).

End kildall.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Functor.Functor Functor.Functor_Ops
        Functor.Representable.Hom_Func_Prop.
From Categories Require Import Functor.Functor_Extender.
From Categories Require Import Ext_Cons.Prod_Cat.Prod_Cat.
From Categories Require Import NatTrans.NatTrans NatTrans.Operations
     NatTrans.Func_Cat.
From Categories Require Import Adjunction.Adjunction Adjunction.Duality
     Adjunction.Adj_Facts.
From Categories Require Import KanExt.Global KanExt.Local
     KanExt.LocalFacts.Uniqueness KanExt.GlobalDuality.

Local Open Scope functor_scope.

(** This module contains conversion from local to global kan extensions.
That is, we show that if we have all local kan extensions, we also have
the global kan extension.
 *)

(** To do this, we need to build a functor from (Func_Cat C D) to
(Func_Cat C' D). That means we have to provide a natural transformation
(a cone morph) from the local kan extension of one functor to the local
kan extension of another functor. Of course, this is easy as each local
right kan extension is the terminal object of the category of cones there
always is a cone morph to it. The only practical difficulty is converting
the local kan extension of a functor (which is a cone for that functor) to
the cone of another functor – and provide necessary tools for conversion.
This is waht we do below.
*)
Section Local_to_Global_Right.
  Context {C C' : Category}
          (p : C --> C')
          (D : Category)
          (rke : ∀ F : C --> D,  Local_Right_KanExt p F).

  (** Conversion from a cone of a functor to the cone of another functor.
The appex remains the same (the objects in D are not changed) but the
cone_edge does – see below. *)
  Section Cone_conv.
    Context {F G : C --> D} (N : (F --> G)%nattrans) (Cn : LoKan_Cone p F).

    Definition Cone_conv : LoKan_Cone p G :=
      {|
        cone_apex := Cn;
        cone_edge := NatTrans_compose Cn N
      |}.

  End Cone_conv.

  Section Cone_conv_Morph_for_compose.
    Context {F G H : C --> D}
            (N : (F --> G)%nattrans)
            (N' : (G --> H)%nattrans)
            (Cn : LoKan_Cone p F).

    (** If we convert using the composition of two natural transformations it is
        the same as converting twice. We show this by building a cone morph from
        the former to the latter which is simply an identity natural
        transformation. In cases such as this, proving equality requires
        destruction of equality proofs in terms whereas composing with the
        identity natural transformation gives a composition with identity
        morphism at the level of the terms produced. *)
    Program Definition Cone_conv_Morph_for_compose :
      LoKan_Cone_Morph (Cone_conv (N' ∘ N) Cn) (Cone_conv N' (Cone_conv N Cn))
      :=
      {|
        cone_morph := NatTrans_id Cn
      |}.
    Next Obligation.
    Proof.
      rewrite NatTrans_hor_comp_ids.
      rewrite NatTrans_id_unit_right.
      rewrite NatTrans_compose_assoc; trivial.
    Qed.

  End Cone_conv_Morph_for_compose.

  Section Cone_Morph_conv.
    Context {F G : C --> D}
            (N : (F --> G)%nattrans)
            {Cn Cn' : LoKan_Cone p F}
            (h : LoKan_Cone_Morph Cn Cn').

    (** Conversion of cone morphs. *)
    Program Definition Cone_Morph_conv :
      LoKan_Cone_Morph (Cone_conv N Cn) (Cone_conv N Cn') :=
      {|
        cone_morph := h
      |}.

    Next Obligation.
    Proof.
      unfold Cone_conv; cbn.
      rewrite NatTrans_compose_assoc.
      rewrite (cone_morph_com h).
      trivial.
    Qed.

  End Cone_Morph_conv.

  (** For any functor (that can be the functor of a cone), there is a functor
for which it is cone trivially. *)
  Section Trivial_Cone.
    Context (F : C' --> D).

    Definition Trivial_Cone : LoKan_Cone p (Functor_compose p F) :=
      {|
        cone_apex := F;
        cone_edge := ((NatTrans_id F) ∘_h (NatTrans_id p))%nattrans
      |}.

  End Trivial_Cone.

  Section Trivial_Cone_Morph.
    Context {F G : C' --> D} (N : (F --> G)%nattrans).

    (** If N : F -> G is a natural transformation, then there is a trivial cone
        morphism from trivial cone of F to trivial cone of G – after
        conversion. *)
    Program Definition Trivial_Cone_Morph :
      LoKan_Cone_Morph
        (Cone_conv (N ∘_h (NatTrans_id p)) (Trivial_Cone F))
        (Trivial_Cone G) :=
      {|
        cone_morph := N
      |}.

    Next Obligation.
    Proof.
      repeat rewrite NatTrans_hor_comp_ids.
      rewrite NatTrans_id_unit_left.
      rewrite NatTrans_id_unit_right.
      trivial.
    Qed.

  End Trivial_Cone_Morph.

  Section Cone_Morph_to_other_Cone.
    Context {L : C' --> D}
            {F : C --> D}
            (Cn : LoKan_Cone p F)
            (N : (L --> Cn)%nattrans)
    .

    (** Given a natural transformation from some functor L : C' -> D to a cone
        (the underlying functor) we construct a cone morphism from trivial cone
        of L (after conversion) to the given cone. *)
    Program Definition Cone_Morph_to_other_Cone :
      LoKan_Cone_Morph
        (Cone_conv (Cn ∘ (N ∘_h (NatTrans_id p))) (Trivial_Cone L))
        Cn :=
      {|
        cone_morph := N
      |}.

    Next Obligation.
      rewrite NatTrans_hor_comp_ids.
      rewrite NatTrans_id_unit_right.
      trivial.
    Qed.

  End Cone_Morph_to_other_Cone.

  Local Obligation Tactic := idtac.

  (** The functor (mapping functors to their kan extensions) for global
      kan extension. *)
  Program Definition Local_to_Global_Right_Functor :
    (Func_Cat C D) --> (Func_Cat C' D) :=
    {|
      FO := fun F => LRKE (rke F);
      FA := fun F G N => LRKE_morph_ex (rke G) (Cone_conv N (LRKE (rke F)))
    |}.

  Next Obligation.
  Proof.
    intros F; cbn.
    unfold Cone_conv.
    rewrite NatTrans_id_unit_left.
    change (NatTrans_id (LRKE (rke F)))
    with (cone_morph (LoKan_id_Cone_Morph _ _ (LRKE (rke F)))).
    apply LRKE_morph_unique.
  Qed.

  Next Obligation.
  Proof.
    intros F G H N N'; cbn.
    match goal with
      [|- _ = ?A] =>
      match A with
      | ((cone_morph ?Y) ∘ (cone_morph ?X))%nattrans =>
        replace A with (A ∘(NatTrans_id _))%nattrans;
          [|apply NatTrans_id_unit_right];
        set (V := (LoKan_Cone_Morph_compose _ _ (Cone_Morph_conv N' X) Y));
        set (Z := Cone_conv_Morph_for_compose N N' (LRKE (rke F)));
        set (U := cone_morph (LoKan_Cone_Morph_compose _ _ Z V));
        unfold V, Z in U; clear V Z
      end
    end.
    match goal with
      [|- _ = ?A] =>
      change A with U
    end.
    apply (LRKE_morph_unique (rke H) (Cone_conv (N' ∘ N) (LRKE (rke F)))).
  Qed.

  (** The unit of adjunction for global kan extension. *)
  Program Definition Local_to_Global_Right_adj_unit :
      ((Functor_id (Func_Cat C' D))
         --> (Functor_compose
               (Left_Functor_Extender p D)
               Local_to_Global_Right_Functor))%nattrans
    :=
    {|
      Trans := fun F => LRKE_morph_ex (rke (F ∘ p)) (Trivial_Cone F)
    |}.

  Next Obligation.
  Proof.
    intros F G N.
    cbn.
    change N with (cone_morph (Trivial_Cone_Morph N)).
    match goal with
      [|- ?X = ?Y] =>
      match X with
        ((cone_morph ?B) ∘ (cone_morph ?A))%nattrans =>
        change X with (cone_morph (LoKan_Cone_Morph_compose _ _ A B))
      end;
        match Y with
          ((cone_morph ?B) ∘ (cone_morph ?A))%nattrans =>
          change Y
          with (cone_morph
                  (LoKan_Cone_Morph_compose
                     _ _ (Cone_Morph_conv (N ∘_h (NatTrans_id p)) A) B
                  )
               )
        end
    end.
    apply (LRKE_morph_unique
             (rke (Functor_compose p G))
             (Cone_conv (N ∘_h (NatTrans_id p)) (Trivial_Cone F))
          ).
  Qed.

  Next Obligation.
  Proof.
    symmetry.
    apply Local_to_Global_Right_adj_unit_obligation_1.
  Qed.

  (** Existence of conversion for adjunction – see definition of Adjunct. *)
  Definition Local_to_Global_Right_adj_morph_ex
             (L : C' --> D)
             (F : C --> D)
             (N : (L --> (LRKE (rke F)))%nattrans)
    : ((L ∘ p) --> F)%nattrans :=
    ((cone_edge (LRKE (rke F))) ∘ (N ∘_h (NatTrans_id p)))%nattrans.

  (** Conversion from local kan extensions (if we have all of them) to the
      global kan extension. *)
  Program Definition Local_to_Global_Right : Right_KanExt p D :=
    {|
      right_kan_ext := Local_to_Global_Right_Functor;
      right_kan_ext_adj := {|
                            adj_unit := Local_to_Global_Right_adj_unit;
                            adj_morph_ex := Local_to_Global_Right_adj_morph_ex|}
    |}.

  Next Obligation.
  Proof.
    intros L F h.
    unfold Local_to_Global_Right_adj_morph_ex.
    cbn in *.
    match goal with
      [|- ?X = ?Y] =>
        match Y with
          ((cone_morph ?B) ∘ (cone_morph ?A))%nattrans =>
          change Y
          with (cone_morph
                  (LoKan_Cone_Morph_compose
                     _ _
                     (Cone_Morph_conv
                        ((LRKE (rke F) ∘ (h ∘_h (NatTrans_id p)))) A) B
                  )
               )
        end
    end.
    change h with (cone_morph (Cone_Morph_to_other_Cone (LRKE (rke F)) h)).
    apply (LRKE_morph_unique
             (rke F)
             (Cone_conv ((LRKE (rke F))
                           ∘ (h ∘_h (NatTrans_id p))) (Trivial_Cone L))
          ).
  Qed.

  Next Obligation.
  Proof.
    intros L F h g g' H1 H2.
    cbn in *.
    match type of H1 with
      _ = ?X =>
      match X with
          NatTrans_compose (cone_morph ?A) (cone_morph ?B) =>
          change X with
          (cone_morph(LoKan_Cone_Morph_compose _ _ (Cone_Morph_conv g A) B))
            in H1
      end
    end.
    match type of H2 with
      _ = ?X =>
      match X with
          NatTrans_compose (cone_morph ?A) (cone_morph ?B) =>
          change X with
          (cone_morph (LoKan_Cone_Morph_compose _ _ (Cone_Morph_conv g' A) B))
            in H2
      end
    end.
    match type of H1 with
      _ = cone_morph ?X =>
      set (H4 := cone_morph_com X); rewrite <- H1 in H4; cbn in H4;
      match type of H2 with
        _ = cone_morph ?Y =>
        set (H3 := cone_morph_com Y); rewrite <- H2 in H3; cbn in H3
      end;
      rewrite <- H4 in H3; clear H4
    end.
    rewrite NatTrans_hor_comp_ids in H3.
    repeat rewrite NatTrans_id_unit_right in H3.
    symmetry; trivial.
  Qed.

End Local_to_Global_Right.

(** The conversion from local left kan extensions to global left kan extensions
    is just the daul of that for right. *)
Section Local_to_Global_Left.
  Context {C C' : Category} (p : C --> C') (D : Category).

  Context (lke : ∀ F : C --> D,  Local_Left_KanExt p F).

  Definition Local_to_Global_Left : Left_KanExt p D :=
    KanExt_Right_to_Left
      _ _ (Local_to_Global_Right _ _ (fun (F : C^op --> D^op) => (lke (F^op)))).

End Local_to_Global_Left.


Require Import List.

Require Import fl.cfg.Base fl.cfg.Definitions fl.cfg.Dec_Empty fl.cfg.Binarize fl.cfg.Chomsky.
Require Import (* fl.int.Base2 *) (* INT.DFA*) fl.int.ChomskyInduction .
Require Import Fin.
Require Import fl.int.DFA fl.int.Union.

From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype bigop fingraph finfun finset.

Module Intersection.

  Import ListNotations Dec_Empty Base Symbols DFA Base2.Base
         ChomskyInduction Definitions Derivation Chomsky.

  (* Feed tactic -- exploit with multiple arguments.
     (taken from http://comments.gmane.org/gmane.science.mathematics.logic.coq.club/7013) *)
  Ltac feed H :=
    match type of H with
      | ?foo -> _ =>
        let FOO := fresh in
        assert foo as FOO; [|specialize (H FOO); clear FOO]
    end.

  Ltac feed_n n H :=
    match n with
    | O => idtac
    | (S ?m) => feed H ; [| feed_n m H]
    end.

  (** * Util *)
  (** In this section we prove a few useful facts. *)
  Section Util.

    Section Projections.

      Context {A B C: Type}.

      Definition fst3 (t: A * B * C): A := let '(from, _, _) := t in from.
      Definition snd3 (t: A * B * C): B := let '(_, r,_) := t in r.
      Definition thi3 (t: A * B * C): C := let '(_, _, to) := t in to.

    End Projections.

    Section Packing.

      Definition unVar {Vt: Type} (v: @var Vt) := let '(V e) := v in e.

      Section ToWordFunction.

        Context {T V: Type}.

        Fixpoint to_word (phrase: @phrase T V): list ter :=
          match phrase with
            | Ts x :: sx => x :: to_word sx
            | _ => []
          end.

        Lemma to_word_to_phraseK:
          forall word, to_word (to_phrase word) = word.
        Proof.
          intros w.
          induction w; auto.
          simpl; rewrite IHw; reflexivity.
        Qed.

      End ToWordFunction.

      Section EqSection.

        Context {T V1 V2: Type}.

        Variable F: V1 -> V2.

        Definition trans_var v :=
          V (F (unVar v)).

        Definition trans_symb symb: @symbol T V2 :=
          match symb with
            | Ts t => Ts t
            | Vs v => Vs (trans_var v)
          end.

        Definition trans_phrase p: @phrase T V2 :=
          map trans_symb p.

      End EqSection.

    End Packing.

    Section TerminalProp.

      Context {T V: Type}.

      Variable word word1 word2: @phrase T V.

      Lemma word_remains_terminal:
        forall word, terminal (@to_phrase T V word).
      Proof.
        intros w.
        induction w.
        - intros s IN; inversion IN.
        - intros s IN.
          inversion IN; auto.
          subst s; exists a; auto.
      Qed.

      Lemma to_word_cat:
        terminal word1 ->
        terminal word2 ->
        to_word (word1 ++ word2) = to_word word1 ++ to_word word2.
      Proof.
        intros.
        induction word1 as [|a w]; auto.
        destruct a as [t|v]; simpl in *.
        rewrite IHw; [reflexivity|].
        intros s EL.
        apply H; right; exact EL.
        exfalso.
        unfold terminal in *.
        assert(EL: In (Vs v) (Vs v :: w)); auto.
        destruct  (H _ EL).
        inversion H1.
      Qed.

    End TerminalProp.

    Section Normalize.

      Context {Tt Vt: eqType}.

      Hypothesis H_T_eq_dec: eq_dec Tt.
      Hypothesis H_V_eq_dec: eq_dec Vt.

      Variable TToNat: Tt -> nat.
      Variable UToNat: Vt -> nat.
      Variable NatToU: nat -> Vt.

      Hypothesis bijection: forall x : nat, UToNat (NatToU x) = x.

      (* Consider an arbitrary grammar  *)
      Variable G: @grammar Tt Vt.
      Variable S: @var Vt.
      Hypothesis H_S_el_of_G: Vs S el dom G.

      Let normalize G := @normalize Tt Vt _ _ TToNat UToNat NatToU bijection G.

      Lemma epsilon_is_not_derivable_in_normalized_grammar:
        ~ language (normalize G) S [].
      Proof.
        intros NLANG.
        move: NLANG => [DER TER].
        apply empty_is_not_derivable in DER.
        - by done.
        - by apply chomsky_normalform.
      Qed.

    End Normalize.

    Section EpsilonGrammar.

      Context {Tt Vt: Type}.

      Hypothesis H_syntactic_analysis: syntactic_analysis_is_possible.

      (* Grammar which has only one epsilon rule. *)
      Variable var: @var Vt.
      Let epsilon_grammar: @grammar Tt Vt := [R var []].

      Lemma non_epsilon_is_not_derivable_in_epsilon_grammar:
        forall ter word,
          ~ der epsilon_grammar var (Ts ter :: to_phrase word).
      Proof.
        unfold syntactic_analysis_is_possible in *.
        intros ? ? ?.
        apply H_syntactic_analysis in H.
        move: H => [H | H].
        - by inversion H.
        - move: H => [rhs [EQ DER]].
          inversion EQ; inversion H; subst; clear H EQ.
          apply derivability_from_empty in DER.
            by inversion DER.
      Qed.

    End EpsilonGrammar.

  End Util.

  (** * Definitions and lemmas *)
  (** In this section we define a function that creates a intersection-grammar and prove the necessary lemmas. *)
  Section Lemmas.

    Variable Tt Vt: Type.

    (* In this section we define a function which generates a list of states.
       This list of states represents a set of states of a dfa. *)
    Section DFAListOfStates.

      Fixpoint values_list_gen number_of_states: list (t number_of_states) :=
        match number_of_states with
          | O => nil
          | S n' => F1 :: (map FS (values_list_gen n'))
        end.

      Theorem all_values_in_list:
        forall (number_of_states: nat) (state: t number_of_states),
          state el values_list_gen number_of_states.
      Proof.
        intros.
        induction state; first by left.
          by right; apply in_map.
      Qed.

    End DFAListOfStates.

    (* Consider some list of dfa states. The dfa itself we will use later in this file. *)
    Variable number_of_states: nat.
    Let DfaState: Type := t number_of_states.
    Let list_of_states: list DfaState := values_list_gen number_of_states.

    (** In this section we define a function that creates a intersection-grammar out of a list of grammars and DFA.  *)
    Section Conversion.

      Context {T1 T2: Type}.

      Let TripleRule := @rule T1 (DfaState * @var T2 * DfaState).

      Definition convert_nonterm_rule_2 (r r1 r2: _) (s1 s2 : _): seq TripleRule :=
        map (fun s3 => R (V (s1, r, s3)) [Vs (V (s1, r1, s2)); Vs (V (s2, r2, s3))]) list_of_states.

      Definition convert_nonterm_rule_1  (r r1 r2: _) (s1 : _) :=
        flat_map (convert_nonterm_rule_2 r r1 r2 s1) list_of_states.

      Definition convert_nonterm_rule (r r1 r2: _) :=
        flat_map (convert_nonterm_rule_1 r r1 r2) list_of_states.

      Definition convert_terminal_rule (next: _) (r: _) (t: _): list TripleRule :=
        map (fun s1 => R (V (s1, r, next s1 t)) [Ts t]) list_of_states.

      Definition convert_rule (next: _) (r: _ ) :=
        match r with
          | R r [Vs r1; Vs r2] => convert_nonterm_rule r r1 r2
          | R r [Ts t] => convert_terminal_rule next r t
          | _  => []
        end.

      Definition convert_rules (rules: list rule) (next: _): list rule :=
        flat_map (convert_rule next) rules.

      Definition convert_grammar (g: grammar) (s_dfa: s_dfa): @grammar _ (_ * _ * _):=
        convert_rules g (s_next s_dfa).

    End Conversion.

    (** Next, we prove a few useful lemmas about the conversion function. *)
    (* In this section we prove that if an initial grammar contains some terminal rule,
       then the triple grammar contains the corresponding triple rule. We can simply get
       the triple rule using application of the "convert_rule" function. *)
    Section ForwardTerminalRuleInclusion.

      Variable G: @grammar Tt Vt.

      (* We prove the lemma using the induction by the grammar (list of rules).
         (1) "Base" case is trivial (G = []).
         (2) "Step" case splits into two subcases (G ~> a::G):
           a) R r [Ts te] = a: We just unfold definition convert_rules,
               after some evaluation we will get the identity.
           b) R r [Ts te] el G: We use induction hypothesis. *)
      Lemma forward_terminal_rule_inclusion:
        forall (r: var) (te: ter) (next: _) (from to: DfaState),
          R r [Ts te] el G ->
          next from te = to ->
          R (V (from, r, to)) [Ts te] el convert_rules G next.
      Proof.
        intros r te next from to EL STEP.
        induction G; first by done.
        destruct EL as [EQ | EL].
        - clear IHg. subst a.
          apply in_or_app; left; simpl.
          apply in_map_iff.
          exists from; split.
          + by rewrite STEP.
          + by apply all_values_in_list.
        - by simpl; apply in_or_app; right; auto.
      Qed.

    End ForwardTerminalRuleInclusion.

    (* In this section we prove that if an initial grammar contains some nonterminal rule,
       then the triple grammar contains the corresponding triple rule. We can simply get
       the triple rule using application of the "convert_rule" function. *)
    Section ForwardNonterminalRuleInclusion.

      Variable G: @grammar Tt Vt.
      Variable next: @dfa_rule DfaState Tt.

      Variable from mid to: DfaState.
      Variable r r1 r2: @var Vt.

      Let R := @R Tt.

      Lemma forward_nonterminal_rule_inclusion'':
        R (V (from, r, to)) [Vs (V(from, r1, mid)); Vs (V (mid, r2, to))] el
          convert_nonterm_rule_2 r r1 r2 from mid.
      Proof.
        set (rule := (R (V (from, r, to)) [Vs (V(from, r1, mid)); Vs (V (mid, r2, to))])).
        unfold convert_nonterm_rule_2.
        set (vals := list_of_states).
        assert (H2: to el vals).
        apply all_values_in_list.
        induction vals.
        simpl in H2.
        contradiction.
        simpl.
        simpl in H2.
        destruct H2.
        left.
        rewrite H.
        auto.
        right.
        apply IHvals.
        exact H.
      Qed.

      Lemma forward_nonterminal_rule_inclusion':
        R (V (from, r, to)) [Vs (V(from, r1, mid)); Vs (V (mid, r2, to))] el
          convert_nonterm_rule_1 r r1 r2 from.
      Proof.
        set (rule := (R (V (from, r, to)) [Vs (V(from, r1, mid)); Vs (V (mid, r2, to))])).
        unfold convert_nonterm_rule_1.
        set (vals := list_of_states).
        assert (H2: mid el vals).
        apply all_values_in_list.
        induction vals.
        simpl in H2.
        contradiction.
        simpl.
        simpl in H2.
        apply in_or_app.
        destruct H2.
        left.
        rewrite H.
        apply forward_nonterminal_rule_inclusion''.
        right.
        apply IHvals.
        apply H.
      Qed.

      (* We can prove this lemma simply by induction by grammar
         (as in the case of the lemma forward_terminal_rule_inclusion) *)
      Lemma forward_nonterminal_rule_inclusion:
        R r [Vs r1; Vs r2] el G ->
        R (V (from, r, to)) [Vs (V (from, r1, mid)); Vs (V (mid, r2, to))] el convert_rules G next.
      Proof.
        intros EL.
        induction G; first by done.
        destruct EL as [ | EL]; subst.
        { clear IHg.
          apply in_or_app; left; simpl.
          set (rule := (R (V (from, r, to)) [Vs (V(from, r1, mid)); Vs (V (mid, r2, to))])).
          unfold convert_nonterm_rule.
          set (vl := list_of_states).
          assert (EL: from el vl).
          apply all_values_in_list.
          apply in_flat_map.
          exists from.
          split; [exact EL | apply forward_nonterminal_rule_inclusion']. }
        { apply in_app_iff; right.
          apply IHg.
          exact EL. }
      Qed.

    End ForwardNonterminalRuleInclusion.

    (* In this section we prove that if a triple grammar contains some rule,
       then the initial grammar contains corresponding "single" rule. *)
    Section BackwardRuleInclusion.

      Variable G: @grammar Tt Vt.
      Hypothesis H_G_in_chomsky_normal_form: chomsky G.

      Variable next: @dfa_rule DfaState Tt.

      (* For simplicity, let's define a local name. *)
      Let projection (s: @symbol Tt (DfaState * var * DfaState)): @symbol Tt Vt :=
        match s with
          | Vs (V (_, r, _)) => Vs r
          | Ts (T r) => Ts (T r)
        end.

      (* We prove that we can simply project a triple rule into an initial one. *)
      Lemma backward_rule_inclusion:
        forall rhs lhs,
          R rhs lhs el convert_rules G next ->
          R (snd3 (unVar rhs)) (map projection lhs) el G.
      Proof.
        intros.
        destruct rhs as [[[from r] to]]; simpl in *.
        unfold convert_rules in *.
        apply in_flat_map in H.
        destruct H as [[r' rhs'] [RIN EL]].
        unfold convert_rule in *.
        destruct rhs' as [ | [[t1]|v1] ].
        - inversion EL.
        - destruct rhs'.
          + unfold convert_terminal_rule in *.
            apply in_map_iff in EL.
            destruct EL as [s [EQ EL]].
            inversion EQ; subst; exact RIN.
          + inversion EL.
        - destruct rhs' as [ | [ | ]]; try inversion EL.
          destruct rhs'; try inversion EL.
          unfold convert_nonterm_rule in EL.
          apply in_flat_map in EL.
          destruct EL as [st [_ EL]].
          unfold convert_nonterm_rule_1 in EL.
          apply in_flat_map in EL.
          destruct EL as [st' [_ EL]].
          unfold convert_nonterm_rule_2 in EL.
          apply in_map_iff in EL.
          destruct EL as [st'' [EQ _]].
          inversion EQ.
            by subst; simpl.
      Qed.

      Corollary backward_terminal_rule_inclusion:
        forall from r to t,
          R (V (from, r, to)) [Ts t] el convert_rules G next ->
          R r [Ts t] el G.
      Proof.
        intros; destruct t as [t].
        apply backward_rule_inclusion in H; simpl in *; exact H.
      Qed.

      Corollary backward_nonterminal_rule_inclusion:
        forall from from1 from2 r r1 r2 to to1 to2,
          R (V (from, r, to)) [Vs (V (from1, r1, to1)); Vs (V (from2, r2, to2))]
            el convert_rules G next ->
          R r [Vs r1; Vs r2] el G.
      Proof.
          by intros; apply backward_rule_inclusion in H.
      Qed.

    End BackwardRuleInclusion.

    (* In this section, we prove that after transformation grammar remains in chomsky normal form. *)
    Section RemainsInChomskyNormalForm.

      Variable G: @grammar Tt Vt.
      Hypothesis H_G_in_chomsky_normal_form: chomsky G.

      Variable next: @dfa_rule DfaState Tt.

      (* Note that the initial grammar is in chomsky normal form.
         After the transformation:
         1) There are no (new) epsilon rules
         2) The terminal rules remain terminal and uniform
             (see the definition of grammar to be in chomsky normal form)
         3) Rules remain in binarize form
         4) And unitfree. *)
      Lemma remains_chomsky:
        chomsky (convert_rules G next).
      Proof.
        destruct H_G_in_chomsky_normal_form as [EF [UN [BIN UF]]].
        repeat split.
        { intros v rhs EL CONTR; subst rhs.
          destruct v as [[[from r] to]].
          apply backward_rule_inclusion in EL; simpl in *.
            by apply EF in EL.
        }
        { unfold Separate.uniform.
          intros v rhs EL t TEL.
          destruct t as [t].
          unfold Separate.uniform in UN.
          destruct v as [[[from v] to]].
          apply backward_rule_inclusion in EL; simpl in *.
          apply UN with (a := T t) in EL.
          destruct rhs as [ | [[t'] | []]]; simpl in *.
          + by inversion TEL.
          + inversion EL; apply map_eq_nil in H1.
              by subst; auto.
          + inversion EL; apply map_eq_nil in H1.
            subst.
              by destruct TEL as [TEL | TEL]; inversion TEL.
          + apply in_map_iff.
              by exists (Ts (T t)); split; auto. }
        { unfold Binarize.binary.
          intros v phs EL.
          destruct v as [[[from v] to]].
          apply backward_rule_inclusion in EL.
          apply BIN in EL.
            by rewrite map_length in EL.
        }
        { unfold ElimU.unitfree. intros v CONTR.
          destruct v as [[[from r] to]].
          destruct CONTR as [[[[from' r'] to']] EL].
          apply backward_rule_inclusion in EL; simpl in *.
          unfold ElimU.unitfree in *.
          eapply UF.
            by exists r'; eauto. }
      Qed.

    End RemainsInChomskyNormalForm.

    (* In this section, we prove that the triple-rules have certain consistent structure. *)
    Section ConsistensyOfTripleRules.

      Variable G: @grammar Tt Vt.
      Variable next: @dfa_rule DfaState Tt.

      Lemma consistensy_of_triple_nonterm_rules:
        forall from from1 from2 r r1 r2 to to1 to2,
          R (V (from, r, to)) [Vs (V (from1, r1, to1)); Vs (V (from2, r2, to2))]
            el convert_rules G next ->
          from = from1 /\ to1 = from2 /\ to = to2.
      Proof.
        intros r r1 r2 from from1 from2 to to1 to2 EL.
        unfold convert_rules in EL.
        apply in_flat_map in EL.
        destruct EL as [rule [_ EL]].
        destruct rule as [v rhs].
        destruct rhs; simpl in *; first by done.
        destruct s; simpl in *.
        { destruct rhs; [| inversion EL].
          unfold convert_terminal_rule in *.
            by apply in_map_iff in EL; destruct EL as [st [EQ _]]. }
        { destruct rhs; [inversion EL | ].
          destruct s; [ inversion EL | ].
          destruct rhs; [ | inversion EL].
          unfold convert_nonterm_rule in EL.
          unfold convert_nonterm_rule_1 in EL.
          unfold convert_nonterm_rule_2 in EL.
          apply in_flat_map in EL. destruct EL as [st1 [_ EL]].
          apply in_flat_map in EL; destruct EL as [st2 [_ EL]].
          apply in_map_iff in EL; destruct EL as [st3 [EQ _]].
            by inversion EQ. }
      Qed.

      Lemma consistensy_of_triple_term_rules:
        forall from r to te,
          R (V (from, r, to)) [Ts te] el convert_rules G next ->
          next from te = to.
      Proof.
        intros r from to te EL.
        unfold convert_rules in EL.
        apply in_flat_map in EL.
        destruct EL as [rule [_ EL]].
        destruct rule as [v rhs].
        destruct rhs; first by done.
        destruct s; simpl in *.
        { destruct rhs; [| inversion EL].
          unfold convert_terminal_rule in *.
          apply in_map_iff in EL; destruct EL as [st [EQ _]].
            by inversion EQ. }
        { destruct rhs; [inversion EL | ].
          destruct s; [ inversion EL | ].
          destruct rhs; [ | inversion EL].
          unfold convert_nonterm_rule in EL.
          unfold convert_nonterm_rule_1 in EL.
          unfold convert_nonterm_rule_2 in EL.
          apply in_flat_map in EL. destruct EL as [st1 [_ EL]].
          apply in_flat_map in EL; destruct EL as [st2 [_ EL]].
          apply in_map_iff in EL; destruct EL as [st3 [EQ _]].
            by inversion EQ. }
      Qed.

      Corollary consistensy_of_triple_nonterm_rules':
        forall r r1 r2,
          R (V r) [Vs (V r1); Vs (V r2)] el convert_rules G next ->
          fst3 r = fst3 r1 /\ thi3 r1 = fst3 r2 /\ thi3 r = thi3 r2.
      Proof.
        intros.
        destruct r as [[from r] to].
        destruct r1 as [[from1 r1] to1].
        destruct r2 as [[from2 r2] to2].
        simpl in *.
        eapply consistensy_of_triple_nonterm_rules; eauto.
      Qed.

      Corollary consistensy_of_triple_term_rules':
        forall (r : _) (te : ter),
          R (V r) [Ts te] el (convert_rules G next) ->
          next (fst3 r) te = thi3 r.
      Proof.
        intros r te H0.
        destruct r as [[from0 r0] to0].
        simpl in *.
        eapply consistensy_of_triple_term_rules; eauto.
      Qed.

    End ConsistensyOfTripleRules.

    (** * Main implications *)
    (** In this section we prove two main lemmas. Derivability in an initial grammar
        and a dfa implies a derivability in the triple (intersection) grammar. And the other way
        around a derivability in a triple grammar implies a derivability in the initial grammar
        and the dfa. *)
    Section MainImplications.

      Variable G: @grammar Tt Vt.
      Hypothesis H_G_in_chomsky_normal_form: chomsky G.
      Hypothesis H_syntactic_analysis: syntactic_analysis_is_possible.

      (* We need two fictive functions for changing types. *)
      Hypothesis F1: DfaState * @var Vt * DfaState -> Vt.
      Hypothesis F2: Vt -> DfaState * @var Vt * DfaState.

      (* It this section we prove that derivability in an initial grammar
         and a dfa implies a derivability in the triple grammar. *)
      Section MainForward.

        (* Note that we cannot use simple induction by derivation in grammar G, in this
           case we will get a phrase (list of terminals and nonterminals) instead of a word.
           Therefore we should use another way to use induction. For grammar in chomsky
           normal form it is possible (see the file chomsky_induction). Briefly, we can
           split the word into two subwords, each of which can be derived from some nonterminal. *)
        Theorem der_in_initial_grammar_and_dfa_implies_der_in_triple_grammar:
          forall (next: dfa_rule) (r: var) (from to: DfaState) (word: _),
            der G r (to_phrase word) ->
            final_state next from word = to ->
            der (convert_rules G next) (V (from, r, to)) (to_phrase word).
        Proof.
          intros next r from to w DER FIN.
          rewrite <- (@to_word_to_phraseK Tt Vt w) in FIN.
          set (wp1 := to_phrase (T:=Tt) (V:= _ * @var Vt * _) w) in *.
          set (wp2 := trans_phrase F2 (to_phrase w)) in *.
          assert (D: wp1 = wp2).
          { clear; induction w; simpl in *.
            reflexivity.
            unfold wp1, wp2.
            rewrite <- IHw; auto. }
          rewrite D; clear D.
          generalize dependent FIN.
          generalize dependent from.
          generalize dependent to.
          generalize dependent next.
          apply chomsky_derivability_induction with
          (P := fun r phr =>
                  forall (next : dfa_rule) (from to : DfaState),
                    final_state next from (to_word phr) = to ->
                    der (convert_rules G next) (V (from, r, to)) (trans_phrase F2 phr)) in DER; auto.
          { intros r0 t IN next from to FIN; simpl in *.
              by apply rDer, forward_terminal_rule_inclusion; auto. }
          { intros r0 r1 r2 w1 w2 IN Ind1 Ind2 TER1 TER2 DER1 DER2 next from to FIN0.
            set (newG := convert_rules G next).
            set (m := final_state next from (to_word w1)).
            assert (H1: der newG (V (from, r1, m)) (trans_phrase F2 w1)); eauto.
            assert (H2: der newG (V (m, r2, to)) (trans_phrase F2 w2)).
            { apply Ind2, test0.
              rewrite <- to_word_cat; auto. }
            assert (in_H: In (R (V (from, r0, to)) [Vs (V(from, r1, m)); Vs (V (m, r2, to))]) newG).
            { apply forward_nonterminal_rule_inclusion; auto. }
            unfold trans_phrase.
            rewrite map_cat.
              by eapply derivability_step; eauto. }
          { by apply word_remains_terminal. }
        Qed.

        (* We use the lemma above to prove this lemma. *)
        Theorem main_forward:
          forall sdfa var word,
            s_dfa_language sdfa word /\ language G var (to_phrase word) ->
            language (convert_grammar G sdfa) (V (s_start sdfa, var, s_final sdfa)) (to_phrase word).
        Proof.
          intros ? ? ? INT.
          destruct INT as [DFA [DER TER]].
            by split; [apply der_in_initial_grammar_and_dfa_implies_der_in_triple_grammar | apply word_remains_terminal].
        Qed.

      End MainForward.

      (* In this section we prove that derivability in a triple grammar
         implies derivability in the initial grammar and the dfa. *)
      Section MainBackward.

        Section DerivabilityInTripleGrammarImpliesAcceptanceInDFA.

          Variable next: @dfa_rule DfaState Tt.
          Variable from to: DfaState.

          (* Here we also should use "chomsky_induction". Proof is quite similar to the proof
             of the der_in_initial_grammar_and_dfa_implies_der_in_triple_grammar lemma. *)
          Lemma der_in_triple_grammar_implies_dfa_accepts':
            forall var word,
              der (convert_rules G next) (V (from, var, to)) (to_phrase word) ->
              final_state next (fst3 (from, var, to)) word = thi3 (from, var, to).
          Proof.
            intros r w H.
            assert (EQ: w = to_word (to_phrase(T:=Tt) (V:=DfaState * @var Vt * DfaState) w)).
            { clear.
              induction w; simpl.
              - reflexivity.
              - rewrite <- IHw; reflexivity.
            } rewrite EQ; clear EQ.
            assert (P1: fst3 (from, r, to) = fst3 (unVar (V (from, r, to)))). simpl; reflexivity.
            assert (P2: thi3 (from, r, to) = thi3 (unVar (V (from, r, to)))). simpl; reflexivity.
            rewrite P1; rewrite P2; clear P1 P2.
            apply chomsky_derivability_induction
            with (w0 := to_phrase w) (r0 := V (from, r, to)) (G0 := convert_rules G next); auto; simpl.
            { apply remains_chomsky; auto. }
            { clear H r.
              intros.
              eapply consistensy_of_triple_term_rules'.
              destruct r; eauto. }
            { clear H r from to.
              intros r r1 r2 w1 w2 IN FIN1 FIN2 TER1 TER2 DER1 DER2.
              rewrite to_word_cat; auto.
              apply test0_1.
              destruct r as [[[fr r] to]].
              destruct r1 as [[[fr1 r1] to1]].
              destruct r2 as [[[fr2 r2] to2]].
              simpl in *.
              assert (EQ:= @consistensy_of_triple_nonterm_rules' G next (fr, r, to) (fr1, r1, to1) (fr2, r2, to2) IN).
              destruct EQ as [EQ1 [EQ2 EQ3]]; simpl in *.
              subst fr to1 to2.
                by rewrite EQ2 EQ3. }
            { by apply word_remains_terminal. }
          Qed.

          Lemma der_in_triple_grammar_implies_dfa_accepts:
            forall var word,
              der (convert_rules G next) (V (from, var , to)) (to_phrase word) ->
              final_state next from word = to.
          Proof.
            intros w r DER.
            set (rule := (from, r, to)) in *.
            assert (H1: from = fst3 rule); auto.
            assert (H2: to = thi3 rule); auto.
            rewrite H1 H2.
            eapply der_in_triple_grammar_implies_dfa_accepts'; eauto 1.
          Qed.

        End DerivabilityInTripleGrammarImpliesAcceptanceInDFA.

        Section DerivabilityInTripleGrammarImpliesDerivabilityInInitialGrammar.

          Variable next: @dfa_rule DfaState Tt.

          Lemma der_in_triple_gr_implies_der_in_initial_gr':
            forall (r: var) word,
              der (convert_rules G next) r (to_phrase word) ->
              der G (snd3 (unVar r)) (to_phrase word).
          Proof.
            intros r w H.
            assert (EQ: trans_phrase F1 (to_phrase  w) = to_phrase w).
            { clear.
              induction w; simpl.
              - reflexivity.
              - rewrite IHw. reflexivity. }
            rewrite <- EQ.
            apply chomsky_derivability_induction with (G0 := convert_rules G next) (r0 := r) (w0 := to_phrase w); auto.
            { apply remains_chomsky; auto. }
            { intros r' t IN.
              destruct r' as [[[from r'] to]]; simpl in *.
              apply rDer; apply backward_terminal_rule_inclusion in IN; auto. }
            { intros r' r1 r2 w1 w2 IN DER1 DER2 TER1 TER2 DER3 DER4.
              destruct r' as [[[from r'] to]].
              destruct r1 as [[[from1 r1] to1]].
              destruct r2 as [[[from2 r2] to2]]; simpl in *.
              unfold trans_phrase.
              rewrite map_cat.
              apply @derivability_step with (r1 := r1) (r2 := r2) (T := Tt) (V := Vt); auto.
                by apply backward_nonterminal_rule_inclusion in IN. }
            { by apply word_remains_terminal. }
          Qed.

          Lemma der_in_triple_gr_implies_der_in_initial_gr:
            forall (s_start s_final: DfaState) (grammar_start: _) (word: word),
              der (convert_rules G next) (V (s_start, grammar_start, s_final)) (to_phrase word) ->
              der G grammar_start (to_phrase word).
          Proof.
            intros start final g_start w.
            set (s := (start, g_start, final)).
            assert (g_start = snd3 s); auto.
            rewrite H.
            eapply der_in_triple_gr_implies_der_in_initial_gr'.
          Qed.

        End DerivabilityInTripleGrammarImpliesDerivabilityInInitialGrammar.

        (* Now we can split the conclusion of the lemma and use the lemmas above to finish the proof. *)
        Theorem main_backward:
          forall sdfa var word,
            language (convert_grammar G sdfa) (V (s_start sdfa, var, s_final sdfa)) (to_phrase word) ->
            s_dfa_language sdfa word /\ language G var (to_phrase word).
        Proof.
          intros ? ? ? TR.
          destruct TR as [DER TER].
          unfold convert_grammar in DER.
          destruct sdfa; simpl in *.
          split.
          unfold s_dfa_language, s_accepts; simpl.
          eapply der_in_triple_grammar_implies_dfa_accepts; eauto 1.
          split.
          - by eapply der_in_triple_gr_implies_der_in_initial_gr; eauto 1.
          - by apply word_remains_terminal.
        Qed.

      End MainBackward.

    End MainImplications.

  End Lemmas.

  (** * Main Theorem *)
  (** In this section we prove the main theorem about existence of grammar of intersection. *)
  Section Main.

    Context {Terminal Nonterminal: eqType}.
    Hypothesis H_T_eq_dec: eq_dec Terminal.
    Hypothesis H_V_eq_dec: eq_dec Nonterminal.

    Variables (TToNat: Terminal -> nat) (UToNat: Nonterminal -> nat) (NatToU: nat -> Nonterminal).
    Hypothesis bijection: forall x : nat, UToNat (NatToU x) = x.

    Hypothesis H_syntactic_analysis: syntactic_analysis_is_possible.

    Variable number_of_states: nat.
    Let DfaState: Type := t number_of_states.
    Let list_of_states: list DfaState := values_list_gen number_of_states.

    (* Consider an arbitrary dfa with n states. *)
    Variable dfa: @dfa DfaState Terminal.

    (* Consider an arbitrary grammar G with start symbol S. *)
    Variable G: @grammar Terminal Nonterminal.
    Variable S: @var Nonterminal.
    Hypothesis H_S_el_of_G: Vs S el dom G.

    (* We prove that there exists grammar intersection. *)
    Theorem grammar_of_intersection_exists:
      exists (NewNonterminal: Type) (IntersectionGrammar: @grammar Terminal NewNonterminal) St,
        forall word,
          dfa_language dfa word /\ language G S (to_phrase word) <->
          language IntersectionGrammar St (to_phrase word).
    Proof.
      have Alt: forall n, n == 0 \/ n > 0.
      { by move => m; case m; [left|right]. }
      move: (Alt number_of_states) => [/eqP ZERO | POS]; clear Alt.
      { exfalso; subst number_of_states.
        destruct dfa.
        have C0 := case0 (fun _ => false).
          by apply C0 in start0.
      }
      intros.
      set (NG := @normalize Terminal Nonterminal _ _ TToNat UToNat NatToU bijection G).
      set (SDFAS := split_dfa dfa).
      set (TRS :=
             map (fun s_dfa =>
                    (V (s_start s_dfa, S, s_final s_dfa), @convert_grammar _ _ _ NG s_dfa)) SDFAS).
      set (I := (V (Union.start (t number_of_states * @var Nonterminal * t number_of_states)), Union.grammar_union TRS)).
      set (I1 := fst I).
      set (I2 := snd I).
      have ALT:
        (@dfa_language DfaState Terminal dfa [] /\ language G S []) \/
        (~ @dfa_language DfaState Terminal dfa [] \/ ~ language G S []).
      { have DECDFA: {dfa_language dfa []} + {~ dfa_language dfa []}.
        { apply list_in_dec.
          unfold DfaState.
          intros x y.
          unfold dec.
          apply Fin.eq_dec.
        }
        have DECLANG: {language G S []} + {~ language G S []}.
        { intros. have DER := @Dec_Word.der_dec _ _ H_T_eq_dec H_V_eq_dec G S [].
          move: DER => [DER|DER].
          - by left; split.
          - right; intros CONTR; apply: DER.
              by move: CONTR => [DER _].
        }
        move: DECDFA DECLANG => [H1|H1] [H2|H2]; [left|right|right|right].
        - by done.
        - by right.
        - by left.
        - by left.
      }
      move: ALT => [EPS|EPS].
      { set (II :=
               (V (Union.start (Union.labeled_Vt (t number_of_states * @var Nonterminal * t number_of_states))),
                @Union.grammar_union Terminal (Union.labeled_Vt (t number_of_states * var * t number_of_states))
                                     [:: (I1, [R I1 []]); (I1, I2)])).
        set (II1 := fst II).
        set (II2 := snd II).
        exists ((Union.labeled_Vt (Union.labeled_Vt (t number_of_states * @var Nonterminal * t number_of_states)))), II2, II1.
        intros w.
        case: w => [|].
        { split; intros.
          - apply Union.correct_union.
            exists (I1, [R I1 []]); simpl; split.
            + split; last by done.
                by apply rDer.
            + by left.
          - by simpl.
        }
        {
          intros a w.
          split; [move => [DL GL]| move => IL].
          apply Union.correct_union.
          exists (I1, I2).
          split; last by right.
          { apply correct_split in DL.
            move: DL => [s_dfa [EL LANG]].
            have MF := @main_forward Terminal Nonterminal number_of_states NG _ _ _ s_dfa S (a::w).
            feed_n 4 MF; try done.
            { by apply chomsky_normalform. }
            { intros; repeat split.
              - destruct number_of_states; [by done | by apply F1].
              - by done.
              - destruct number_of_states; [by done | by apply F1].
            }
            { by split; last apply language_normalform. }
            eapply Union.correct_union.
            exists ((V (s_start s_dfa, S, s_final s_dfa)), convert_grammar NG s_dfa); simpl.
            split.
            - by done.
            - unfold TRS.
              apply in_map_iff.
              exists s_dfa; split; by done.
          }
          {
            intros.
            unfold I2, I1, I in IL.
            eapply Union.correct_union in IL.
            move: IL => [[gr v] [LANG EL]]; simpl in *.
            unfold TRS in EL.
            move: EL => [EL | [EL| EL ]].
            { exfalso.
              inversion EL; subst gr; subst v; clear EL.
              move: LANG => [DER _].
                by apply non_epsilon_is_not_derivable_in_epsilon_grammar in DER. }
            { inversion EL; subst gr; subst v; clear EL.
              have CORRECT := Union.correct_union _ (a::w).
              apply CORRECT in LANG.
              move: LANG => [[v gr] [LANG EL]].
              unfold I2, I in EL.
              unfold TRS in EL; apply in_map_iff in EL.
              move: EL => [s_dfa [EQ EL]].
              inversion EQ; subst gr; subst v; clear EQ.
              have MB := @main_backward Terminal Nonterminal number_of_states NG _ _ _ s_dfa S (a::w).
              feed_n 4 MB; try done.
              { by apply chomsky_normalform. }
              { by intros; apply NatToU. }
              clear LANG.
              move: MB => [SDFA LANG].
              split.
              - unfold SDFAS in EL.
                apply correct_split.
                exists s_dfa; split; by done.
              - eapply (@language_normalform) with (Id3 := bijection) (TtToNat := TToNat); eauto 2.
                intros CONTR; inversion CONTR.
            }
            { by done. }
          }
        }
      }
      {
        exists (((Union.labeled_Vt (t number_of_states * @var Nonterminal * t number_of_states)))), I2, I1.
        intros w.
        case: w => [ | ].
        {
          split; intros.
          - exfalso.
            move: H => [H1 H2].
              by move: EPS => [H|H]; apply: H.
          - clear EPS; exfalso; simpl in H.
            unfold I2, I1, I in H.
            have CORRECT := Union.correct_union _ [].
            apply CORRECT in H.
            move: H => [[v gr] [LANG EL]]; simpl in LANG.
            unfold TRS in EL; apply in_map_iff in EL.
            move: EL => [s_dfa [EQ EL]].
            inversion EQ; subst v; subst gr; clear EQ.
            have MB := @main_backward Terminal Nonterminal number_of_states NG _ _ _ s_dfa S ([]).
            feed_n 4 MB; try done.
            { by apply chomsky_normalform. }
            { by intros; apply NatToU. }
            clear LANG.
            move: MB => [DLANG LANG].
            simpl in LANG.
            unfold NG in LANG.
              by apply epsilon_is_not_derivable_in_normalized_grammar in LANG.
        }
        {
          intros a w.
          split; [move => [DL GL]| move => IL].
          { apply correct_split in DL.
            move: DL => [s_dfa [EL LANG]].
            have MF := @main_forward Terminal Nonterminal number_of_states NG _ _ _ s_dfa S (a::w).
            feed_n 4 MF; try done.
            { by apply chomsky_normalform. }
            { intros; repeat split.
              - destruct number_of_states; [by done | by apply F1].
              - by done.
              - destruct number_of_states; [by done | by apply F1].
            }
            { by split; last apply language_normalform. }
            eapply Union.correct_union.
            exists ((V (s_start s_dfa, S, s_final s_dfa)), convert_grammar NG s_dfa); simpl.
            split.
            - by done.
            - unfold TRS.
              apply in_map_iff.
              exists s_dfa; split; by done.
          }
          { intros.
            unfold I2, I1, I in IL.
            eapply Union.correct_union in IL.
            move: IL => [[gr v] [LANG EL]]; simpl in *.
            unfold TRS in EL.
            apply in_map_iff in EL.
            move: EL => [s_dfa [EQ EL]].
            inversion EQ; subst gr; subst v; clear EQ.
            have MB := @main_backward Terminal Nonterminal number_of_states NG _ _ _ s_dfa S (a::w).
            feed_n 4 MB; try done.
            { by apply chomsky_normalform. }
            { by intros; apply NatToU. }
            clear LANG.
            move: MB => [SDFA LANG].
            split.
            - unfold SDFAS in EL.
              apply correct_split.
              exists s_dfa; split; by done.
            - eapply (@language_normalform) with (Id3 := bijection) (TtToNat := TToNat); eauto 2.
              intros CONTR; inversion CONTR.
          }
        }
      }
    Qed.

  End Main.

End Intersection.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

 This defines the formal syntax, pg. 61.

*)

Set Implicit Arguments.
Require Export LanguageModuleDef.

Fixpoint subst_Tau (t : Tau) (tau : Tau) (alpha : TVar) {struct t} : Tau :=
  match t with
    | tv_t beta  =>
       if TV.eqb alpha beta then tau else T.tv_t beta
    | T.cint               => T.cint
    | T.cross t0 t1        => T.cross (subst_Tau t0 tau alpha) (subst_Tau t1 tau alpha)
    | T.arrow t0 t1        => T.arrow (subst_Tau t0 tau alpha) (subst_Tau t1 tau alpha)
    | T.ptype t0           => T.ptype (subst_Tau t0 tau alpha)
(* Bug 41, assuming beta != alpha ! Block not alpha convert.*)
    | T.utype   beta k t'  =>
       if TV.eqb alpha beta then t else T.utype beta k (subst_Tau t' tau alpha)
    | T.etype p beta k t'  =>
       if TV.eqb alpha beta then t else T.etype p beta k (subst_Tau t' tau alpha)
end.

Fixpoint subst_E (e : E) (tau : Tau) (alpha : TVar) {struct e} : E :=
 match e with
   | i_e i        => i_e i
   | p_e x p      => p_e x p
   | f_e f        =>        (f_e (subst_F   f  tau alpha))
   | amp e'       => amp    (subst_E   e'     tau alpha)
   | star e'      => star   (subst_E   e'     tau alpha)
   | cpair e1 e2  => cpair  (subst_E   e1     tau alpha) (subst_E e2 tau alpha)
   | dot e' i     => dot    (subst_E   e'     tau alpha) i
   | assign e1 e2 => assign (subst_E   e1     tau alpha) (subst_E e2 tau alpha)
   | appl  e1 e2  => appl   (subst_E   e1     tau alpha) (subst_E e2 tau alpha)
   | call s       => call   (subst_St  s      tau alpha)
   | inst e' t    => inst   (subst_E   e'     tau alpha) (subst_Tau t tau alpha)
   | pack t e' t' => pack   (subst_Tau t tau alpha) (subst_E e' tau alpha) (subst_Tau t' tau alpha)
 end
with subst_St (s: St) (tau : Tau) (alpha : TVar) {struct s} : St :=
  match s with
    | e_s e                => e_s      (subst_E e tau alpha)
    | retn e                => retn      (subst_E e tau alpha)
    | seq s1 s2            => seq      (subst_St s1 tau alpha) (subst_St s2 tau alpha)
    | if_s e s1 s2         => if_s     (subst_E e tau alpha)  (subst_St s1 tau alpha) (subst_St s2 tau alpha)
    | while e s            => while    (subst_E e tau alpha)  (subst_St s tau alpha)
    | letx x e s           => letx  x  (subst_E e tau alpha)  (subst_St s tau alpha)
    | open     e beta x s  => open     (subst_E e tau alpha) beta x (subst_St s tau alpha)
    | openstar e beta x s  => openstar (subst_E e tau alpha) beta x (subst_St s tau alpha)
end
with subst_F (f : F) (tau : Tau) (alpha : TVar) {struct f} : F  :=
 match f with
   | (dfun tau1 x tau2 s) =>
     (dfun (subst_Tau tau1 tau alpha) x (subst_Tau tau2 tau alpha) (subst_St s tau alpha))
   (* Bug 7 from test. *)
   | ufun (TV.var b) k f =>
     match alpha with
         (TV.var a) =>
         if (beq_nat a b)
         then (ufun alpha k f)
         else  (ufun (TV.var b) k (subst_F f tau alpha))
     end
end.

Fixpoint subst_Gamma (g : Gamma) (tau : Tau) (alpha : TVar) : Gamma :=
  match g with
   | G.dot => G.dot
   | (G.ctxt x tau' g') =>
     (G.ctxt x (subst_Tau tau' tau alpha) (subst_Gamma g' tau alpha))
end.
Functional Scheme subst_Gamma_ind := Induction for subst_Gamma Sort Prop.

(* Probably should be in the tau module. *)
Function NotFreeInTau (beta : TVar) (tau : Tau) : Prop :=
  match tau with
    | T.tv_t alpha =>
      if TV.eqb beta alpha then False else True
    | cint        => True
    | cross t0 t1 =>
       (NotFreeInTau beta t0) /\ (NotFreeInTau beta t1)
    | arrow t0 t1 =>
        (NotFreeInTau beta t0) /\ (NotFreeInTau beta t1)
    | ptype t     => NotFreeInTau beta t
    | utype alpha _ t =>
      if TV.eqb beta alpha then True else NotFreeInTau beta t
    | etype _ alpha _ t =>
      if TV.eqb beta alpha then True else NotFreeInTau beta t
  end.


From Nominal Require Import Nominal.

(* Pair *)

(* #[global] Instance pair_equiv: Equiv (X * Y) := λ x y, (fst x) ≡@{X} (fst y) /\ (snd x) ≡@{Y} (snd y). *)
#[global] Instance fst_proper `{Equiv X} `{Equiv Y}: Proper ((≡@{(X * Y)}) ==> (≡@{X})) fst. Proof. intros ? ? []; auto. Qed.
#[global] Instance snd_proper `{Equiv X} `{Equiv Y}: Proper ((≡@{(X * Y)}) ==> (≡@{Y})) snd. Proof. intros ? ? []; auto. Qed.
#[global] Instance ProdAct `{PAct X, PAct Y}: PAct (X * Y) := λ (p : perm) '(x, y), (p • x, p • y).

#[global] Instance ProdPerm `{Perm X} `{Perm Y}: Perm (X * Y).
Proof.
  split.
  - apply PermGrp.
  - apply prod_relation_equiv; typeclasses eauto.
  - intros x y ? [] [] []; simpl in *; split; simpl; apply gact_proper; auto.
  - intros []; split; simpl; apply gact_id.
  - intros ? ? []; split; simpl; apply gact_compat.
Qed.

Lemma prod_act_compat `{Perm X, Perm Y} (p : perm) (a : X) (b : Y) : p • (a, b) = (p • a, p • b).
Proof. unfold "•", pact; simpl; auto. Qed.

(* Group Action equivariant *)
(* Lemma perm_action_empty p: p ∙ ε ≡ p.
Proof. unfold action, action_perm, perm_comp_action, "+", perm_operator; simpl; auto. Qed. *)

(* Section LOL.
  Context X `{Perm X}.
  Instance action_equivar `{Perm X} : EquivarF (perm * X) X := λ p, p.1 ∙ p.2.
  Instance g : Equivariant (perm * X) X.
  Proof.
    split.
    - intros [] [] []; simpl in *; unfold equivar, action_equivar; rewrite H1, H2; auto.
    - unfold equivar, action_equivar; intros p []; simpl.
      rewrite action_compat, <-(action_id x), <-1!(perm_inv_empty p), <-(action_compat (-p) (p)),
        (action_compat (l + p) _ _) at 1;
      unfold action, action_perm, perm_conj_action; reflexivity.
  Qed.
End LOL.

f1: A ~> (B ~> C);
~> {
  f: A -> B;
  equivar : ...;
}.

f1 (a: A) => f1.1 a

Coercion f: Set --> Funclass.

Section Test.
  Context `{Perm A, Perm B}.
  (* Context `{EquivarF (A * B) C}. *)
  Context `{Equivariant A X}.
  Let f := uncurry (@equivar _ _ H7).
  Check f.
  Lemma lll: forall p a b, p ∙ (f a b) ≡ f (p ∙ a) (p ∙ b).
  Proof.
    intros; simpl in *; cbv [f uncurry Datatypes.curry].
  destruct H8. specialize (equivariance p (a,b)). unfold equivar in *.
  rewrite <-pair_action_compat in *.

  unfold action, action_perm, pair_action in *.
  rewrite <-pair_action_compat.
  unfold action, action_perm, pair_action.
  apply equivariance.

  unfold equivar, action, action_perm in *.
  rewrite <-pair_action_compat.

  apply equivariance. unfold f; simpl.

End Test. *)

(* (* A -> B *) *)
(* Record SetoidMorphism `{Equiv A, Equiv B}  := { *)
(*   (* equiv_a : Equivalence (≡@{A}); *) *)
(*   (* equiv_b : Equivalence (≡@{B}); *) *)
(*   morphism :> A -> B; *)
(*   m_proper :> Proper ((≡@{A}) ==> (≡@{B})) morphism *)
(* }. *)

(* Arguments SetoidMorphism (_) {_} (_) {_}: assert. *)

(* Section FPerm. *)
(*   Context `{Perm A, Perm B}. *)

(*   #[global] Instance morphism_equiv: Equiv (SetoidMorphism A B) := *)
(*     λ f g, forall x, (morphism f) x ≡@{B} (morphism g) x. *)

(*   #[global] Program Instance f_action: PermAction (SetoidMorphism A B) := *)
(*     λ p f, {| morphism := λ x, p ∙ (f (-p ∙ x)) |}. *)
(*   Next Obligation. *)
(*     repeat intro; f_equiv; destruct f; rewrite H3; reflexivity. *)
(*   Qed. *)

(*   #[global] Instance f_perm: Perm (SetoidMorphism A B). *)
(*   Proof. *)
(*     split. *)
(*     - unfold action, action_perm, f_action, equiv; intros f a; simpl. *)
(*       rewrite action_id; destruct f; simpl. *)
(*       rewrite <-inv_neutral, action_id; reflexivity. *)
(*     - admit. *)
(*     - admit. *)
(*     - admit. *)
(*   Admitted. *)

(* End FPerm. *)


From Undecidability Require Import Shared.ListAutomation.
Import ListAutomationNotations.
From Undecidability Require Import FOL.Syntax.Core.
Import FullSyntax.
Export FullSyntax.

Local Set Implicit Arguments.

Section ND_def.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.

  Reserved Notation "A ⊢ phi" (at level 61).

  (* ** Definition *)

  Implicit Type p : peirce.
  Implicit Type ff : falsity_flag.

  Inductive prv : forall (ff : falsity_flag) (p : peirce), list form -> form -> Prop :=
  | II {ff} {p} A phi psi : phi::A ⊢ psi -> A ⊢ phi → psi
  | IE {ff} {p} A phi psi : A ⊢ phi → psi -> A ⊢ phi -> A ⊢ psi
  | AllI {ff} {p} A phi : map (subst_form ↑) A ⊢ phi -> A ⊢ ∀ phi
  | AllE {ff} {p} A t phi : A ⊢ ∀ phi -> A ⊢ phi[t..]
  | ExI {ff} {p} A t phi : A ⊢ phi[t..] -> A ⊢ ∃ phi
  | ExE {ff} {p} A phi psi : A ⊢ ∃ phi -> phi::(map (subst_form ↑) A) ⊢ psi[↑] -> A ⊢ psi
  | Exp {p} A phi : prv p A falsity -> prv p A phi
  | Ctx {ff} {p} A phi : phi el A -> A ⊢ phi
  | CI {ff} {p} A phi psi : A ⊢ phi -> A ⊢ psi -> A ⊢ phi ∧ psi
  | CE1 {ff} {p} A phi psi : A ⊢ phi ∧ psi -> A ⊢ phi
  | CE2 {ff} {p} A phi psi : A ⊢ phi ∧ psi -> A ⊢ psi
  | DI1 {ff} {p} A phi psi : A ⊢ phi -> A ⊢ phi ∨ psi
  | DI2 {ff} {p} A phi psi : A ⊢ psi -> A ⊢ phi ∨ psi
  | DE {ff} {p} A phi psi theta : A ⊢ phi ∨ psi -> phi::A ⊢ theta -> psi::A ⊢ theta -> A ⊢ theta
  | Pc {ff} A phi psi : prv class A (((phi → psi) → phi) → phi)
  where "A ⊢ phi" := (prv _ A phi).

  Definition tprv `{falsity_flag} `{peirce} (T : form -> Prop) phi :=
    exists A, (forall psi, psi el A -> T psi) /\ A ⊢ phi.

End ND_def.

Arguments ExI {_} {_} {_} {_} {A} t {phi}.

Arguments prv {_ _ _ _} _ _.
Notation "A ⊢ phi" := (prv A phi) (at level 55).
Notation "A ⊢C phi" := (@prv _ _ _ class A phi) (at level 55).
Notation "A ⊢I phi" := (@prv _ _ _ intu A phi) (at level 55).
Notation "A ⊢M phi" := (@prv _ _ falsity_off intu A phi) (at level 55).
Notation "T ⊢T phi" := (tprv T phi) (at level 55).
Notation "T ⊢TI phi" := (@tprv _ _ _ intu T phi) (at level 55).
Notation "T ⊢TC phi" := (@tprv _ _ _ class T phi) (at level 55).


(** * QuickChickInterface: QuickChick Reference Manual *)

From QuickChick Require Import QuickChick.
Require Import ZArith Strings.Ascii Strings.String.

From ExtLib.Structures Require Import Functor Applicative.

(** QuickChick provides a large collection of combinators and
    notations for writing property-based random tests.  This file
    documents the entire public interface (the module type
    [QuickChickSig]). *)

Module Type QuickChickSig.

(* ################################################################# *)
(** * The [Show] Typeclass *)

(** [Show] typeclass allows the test case to be printed as a string.

    Class Show (A : Type) : Type :=
      {
        show : A -> string
      }.
*)

(** Here are some [Show] instances for some basic types: *)
#[export] Declare Instance showNat    : Show nat.
#[export] Declare Instance showBool   : Show bool.
#[export] Declare Instance showZ      : Show Z.
#[export] Declare Instance showString : Show string.

#[export] Declare Instance showList :
  forall {A : Type} `{Show A}, Show (list A).
#[export] Declare Instance showPair :
  forall {A B : Type} `{Show A} `{Show B}, Show (A * B).
#[export] Declare Instance showOpt :
  forall {A : Type} `{Show A}, Show (option A).
#[export] Declare Instance showEx :
  forall {A} `{Show A} P, Show ({x : A | P x}).

(** When defining [Show] instance for your own datatypes, you sometimes need to
    start a new line for better printing. [nl] is a shorthand for it. *)
Definition nl : string := String (ascii_of_nat 10) EmptyString.

(* ################################################################# *)
(** * Generators *)

(* ================================================================= *)
(** ** Fundamental Types *)

(** A [RandomSeed] represents a particular starting point in a
    pseudo-random sequence. *)
Parameter RandomSeed : Type.

(** [G A] is the type of random generators for type [A]. *)
Parameter G : Type -> Type.

(** Run a generator with a size parameter (a natural number denoting
    the maximum depth of the generated A) and a random seed. *)
Parameter run  : forall {A : Type}, G A -> nat -> RandomSeed -> A.

(** The semantics of a generator is its set of possible outcomes. *)
Parameter semGen : forall {A : Type} (g : G A), set A.
Parameter semGenSize : forall {A : Type} (g : G A) (size : nat), set A.

(* ================================================================= *)
(** ** Structural Combinators *)

(** Generators are also instances of several generic typeclasses.
    Many handy generator combinators can be found in the [Monad],
    [Functor], [Applicative], [Foldable], and [Traversable] modules in
    the [ExtLib.Structures] library from [coq-ext-lib]. *)

#[export] Declare Instance Monad_G : Monad G.
#[export] Declare Instance Functor_G : Functor G.
#[export] Declare Instance Applicative_G : Applicative G.

(** A variant of bind for the [(G (option --))] monad.  Useful for
    chaining generators that can fail / backtrack. *)
Parameter bindGenOpt : forall {A B : Type},
    G (option A) -> (A -> G (option B)) -> G (option B).

(* ================================================================= *)
(** ** Basic Generator Combinators *)

(** The [listOf] and [vectorOf] combinators construct generators for
    [list A], provided a generator [g] for type [A]: [listOf g] yields
    an arbitrary-sized list (which might be empty), while [vectorOf n
    g] yields a list of fixed size [n]. *)
Parameter listOf : forall {A : Type}, G A -> G (list A).
Parameter vectorOf : forall {A : Type}, nat -> G A -> G (list A).

(** [elems_ a l] constructs a generator from a list [l] and a
    default element [a]. If [l] is non-empty, the generator picks an
    element from [l] uniformly; otherwise it always yields [a]. *)
Parameter elems_ : forall {A : Type}, A -> list A -> G A.

(** Similar to [elems_], instead of choosing from a list of [A]s,
    [oneOf_ g l] returns [g] if [l] is empty; otherwise it uniformly
    picks a generator for [A] in [l]. *)
Parameter oneOf_ : forall {A : Type}, G A -> list (G A) -> G A.

(** We can also choose generators with distributions other than the
    uniform one. [freq_ g l] returns [g] if [l] is empty;
    otherwise it chooses a generator from [l], where the first field
    indicates the chance that the second field is chosen. For example,
    [freq_ z [(2, x); (3, y)]] has 40%% probability of choosing
    [x] and 60%% probability of choosing [y]. *)
Parameter freq_ :
  forall {A : Type}, G A -> list (nat * G A) -> G A.

(** Try all generators until one returns a [Some] value or all failed once with
    [None]. The generators are picked at random according to their weights
    (like [frequency]), and each one is run at most once. *)
Parameter backtrack :
  forall {A : Type}, list (nat * G (option A)) -> G (option A).

(** Internally, the G monad hides a [size] parameter that can be accessed by
    generators. The [sized] combinator provides such access. The [resize]
    combinator sets it. *)
Parameter sized : forall {A: Type}, (nat -> G A) -> G A.
Parameter resize : forall {A: Type}, nat -> G A -> G A.

(** Generate-and-test approach to generate data with preconditions. *)
Parameter suchThatMaybe :
  forall {A : Type}, G A -> (A -> bool) -> G (option A).
Parameter suchThatMaybeOpt :
  forall {A : Type}, G (option A) -> (A -> bool) -> G (option A).

(** The [elems_], [oneOf_], and [freq_] combinators all take
    default values; these are only used if their list arguments are
    empty, which should not normally happen. The [QcDefaultNotation]
    sub-module exposes notation (without the underscores) to hide this default.
*)

Module QcDefaultNotation.

  (** [elems] is a shorthand for [elems_] without a default argument. *)
  Notation " 'elems' [ x ] " :=
    (elems_ x (cons x nil)) : qc_scope.
  Notation " 'elems' [ x ; y ] " :=
    (elems_ x (cons x (cons y nil))) : qc_scope.
  Notation " 'elems' [ x ; y ; .. ; z ] " :=
    (elems_ x (cons x (cons y .. (cons z nil) ..))) : qc_scope.
  Notation " 'elems' ( x ;; l ) " :=
    (elems_ x (cons x l)) (at level 1, no associativity) : qc_scope.

  (** [oneOf] is a shorthand for [oneOf_] without a default argument. *)
  Notation " 'oneOf' [ x ] " :=
    (oneOf_ x (cons x nil)) : qc_scope.
  Notation " 'oneOf' [ x ; y ] " :=
    (oneOf_ x (cons x (cons y nil))) : qc_scope.
  Notation " 'oneOf' [ x ; y ; .. ; z ] " :=
    (oneOf_ x (cons x (cons y .. (cons z nil) ..))) : qc_scope.
  Notation " 'oneOf' ( x ;; l ) " :=
    (oneOf_ x (cons x l))  (at level 1, no associativity) : qc_scope.

  (** [freq] is a shorthand for [freq_] without a default argument. *)
  Notation " 'freq' [ x ] " :=
    (freq_ x (cons x nil)) : qc_scope.
  Notation " 'freq' [ ( n , x ) ; y ] " :=
    (freq_ x (cons (n, x) (cons y nil))) : qc_scope.
  Notation " 'freq' [ ( n , x ) ; y ; .. ; z ] " :=
    (freq_ x (cons (n, x) (cons y .. (cons z nil) ..))) : qc_scope.
  Notation " 'freq' ( ( n , x ) ;; l ) " :=
    (freq_ x (cons (n, x) l)) (at level 1, no associativity) : qc_scope.

End QcDefaultNotation.

(** The original version of QuickChick used [elements], [oneof] and [frequency]
    as the default-argument versions of the corresponding combinators.
    These have since been deprecated in favor of a more consistent
    naming scheme.
*)

(* ================================================================= *)
(** ** Choosing from Intervals *)

(** The combinators above allow us to generate elements by enumeration
    and lifting. However, for numeric data types, we sometimes hope to
    choose from an interval without writing down all the possible
    values.

    Such intervals can be defined on ordered data types, instances of
    [OrdType], whose ordering [leq] satisfies reflexive, transitive,
    and antisymmetric predicates. *)

Existing Class OrdType.

#[export] Declare Instance OrdBool : OrdType bool.
#[export] Declare Instance OrdNat  : OrdType nat.
#[export] Declare Instance OrdZ    : OrdType Z.

(** We also expect the random function to be able to pick every element in any
    given interval. *)

Existing Class ChoosableFromInterval.

(** QuickChick has provided some instances for ordered data types that are
    choosable from intervals, including [bool], [nat], and [Z]. *)
#[export] Declare Instance ChooseBool : ChoosableFromInterval bool.
#[export] Declare Instance ChooseNat : ChoosableFromInterval nat.
#[export] Declare Instance ChooseZ : ChoosableFromInterval Z.

(** [choose l r] generates a value between [l] and [r], inclusive the two
    extremes. It causes a runtime error if [r < l]. *)
Parameter choose :
  forall {A : Type} `{ChoosableFromInterval A}, (A * A) -> G A.

(* ================================================================= *)
(** ** The [Gen] and [GenSized] Typeclasses *)

(** [GenSized] and [Gen] are typeclasses whose instances can be generated
    randomly. More specifically, [GenSized] depends on a generator for any given
    natural number that indicate the size of output.

    Class GenSized (A : Type) := { arbitrarySized : nat -> G A }.
    Class Gen (A : Type) := { arbitrary : G A }.
*)

(** Given an instance of [GenSized], we can convert it to [Gen] automatically,
    using [sized] function. *)
#[export] Declare Instance GenOfGenSized {A} `{GenSized A} : Gen A.

(** Here are some basic instances for generators: *)
#[export] Declare Instance genBoolSized : GenSized bool.
#[export] Declare Instance genNatSized  : GenSized nat.
#[export] Declare Instance genZSized    : GenSized Z.

#[export] Declare Instance genListSized :
  forall {A : Type} `{GenSized A}, GenSized (list A).
#[export] Declare Instance genList :
  forall {A : Type} `{Gen A}, Gen (list A).
#[export] Declare Instance genOption :
  forall {A : Type} `{Gen A}, Gen (option A).
#[export] Declare Instance genPairSized :
  forall {A B : Type} `{GenSized A} `{GenSized B}, GenSized (A*B).
#[export] Declare Instance genPair :
  forall {A B : Type} `{Gen A} `{Gen B}, Gen (A * B).

(* ================================================================= *)
(** ** Generators for Data Satisfying Inductive Predicates *)

(** Just as QuickChick provides the [GenSized] and [Gen] typeclasses
    for generators of type [A], it provides constrained variants for
    generators of type [A] such that [P : A -> Prop] holds of all
    generated values.  Since it is not guaranteed that any such [A]
    exist, these generators are partial.

     Class GenSizedSuchThat (A : Type) (P : A -> Prop) :=
       {
         arbitrarySizeST : nat -> G (option A)
       }.

     Class GenSuchThat (A : Type) (P : A -> Prop) :=
       {
         arbitraryST : G (option A)
       }.
*)

(** So, for example, if you have a typing relation
    [has_type : exp -> type -> Prop] for some language, you could,
    given some type [T] as input, write (or derive as we will see later on)
    an instance of [GenSizedSuchThat (fun e => has_type e T)], that produces
    an expression of with type [T].

    Calling [arbitraryST] through such an instance would require
    making an explicit application to [@arbitraryST] as follows:

    @arbitraryST _ (fun e => has_type e T) _
]]
    where the first placeholder is the type of expressions [exp]
    and the second placeholder is the actual instance to be inferred.

    To avoid this, QuickChick also provides convenient notation to call
    by providing only the predicate [P] that constraints the generation.
    The typeclass constraint is inferred. *)

(*
Notation "'genST' x" := (@arbitraryST _ x _) (at level 70).
 *)

(* ################################################################# *)
(** * Shrinking *)

(* ================================================================= *)
(** ** The [Shrink] Typeclass *)

(** [Shrink] is a typeclass whose instances have an operation for
    shrinking larger elements to smaller ones, allowing QuickChick to
    search for a minimal counter example when errors occur.

    Class Shrink (A : Type) :=
      {
        shrink : A -> list A
      }.
*)

(** Default shrinkers for some basic datatypes: *)
#[export] Declare Instance shrinkBool : Shrink bool.
#[export] Declare Instance shrinkNat : Shrink nat.
#[export] Declare Instance shrinkZ : Shrink Z.

#[export] Declare Instance shrinkList {A : Type} `{Shrink A} : Shrink (list A).
#[export] Declare Instance shrinkPair {A B} `{Shrink A} `{Shrink B} : Shrink (A * B).
#[export] Declare Instance shrinkOption {A : Type} `{Shrink A} : Shrink (option A).

(* ================================================================= *)
(** ** The [Arbitrary] Typeclass *)

(** The [Arbitrary] typeclass combines generation and shrinking.

    Class Arbitrary (A : Type) `{Gen A} `{Shrink A}.
*)

(* ================================================================= *)
(** ** The Generator Typeclass Hierarchy *)

(**
                            GenSized
                               |
                               |
                              Gen   Shrink
                                \    /
                                 \  /
                               Arbitrary
*)

(** If a type has a [Gen] and a [Shrink] instance, it automatically gets
    an [Arbitrary] one. *)
#[export] Declare Instance ArbitraryOfGenShrink :
  forall {A} `{Gen A} `{Shrink A}, Arbitrary A.

(* ################################################################# *)
(** * Checkers *)

(* ================================================================= *)
(** ** Basic Definitions *)

(** [Checker] is the opaque type of QuickChick properties. *)
Parameter Checker : Type.

(** The [Checkable] class indicates we can check a type A.

    Class Checkable (A : Type) : Type :=
      {
        checker : A -> Checker
      }.
*)

(** Boolean checkers always pass or always fail. *)
#[export] Declare Instance testBool : Checkable bool.

(** The unit checker is always discarded (that is, it represents a
    useless test).  It is used, for example, in the implementation of
    the "implication [Checker]" combinator [==>]. *)
#[export] Declare Instance testUnit : Checkable unit.

(** Given a generator for showable [A]s, construct a [Checker]. *)
Parameter forAll :
  forall {A prop : Type} `{Checkable prop} `{Show A}
         (gen : G A)  (pf : A -> prop), Checker.

(** A variant of [forAll] that provides evidence that the generated
    values are members of the semantics of the generator. (Such evidence
    can be useful when constructing dependently typed data, such as
    bounded integers.) *)
Parameter forAllProof :
  forall {A prop : Type} `{Checkable prop} `{Show A}
         (gen : G A)  (pf : forall (x : A), semGen gen x -> prop), Checker.

(** Given a generator and a shrinker for showable [A]s, construct a
    [Checker]. *)
Parameter forAllShrink :
  forall {A prop : Type} `{Checkable prop} `{Show A}
         (gen : G A) (shrinker : A -> list A) (pf : A -> prop), Checker.

(** Lift ([Show], [Gen], [Shrink]) instances for [A]
    to a [Checker] for functions [A] -> prop.  This is what makes it
    possible to write (for some example property [foo := fun x => x >?
    0], say) [QuickChick foo] instead of [QuickChick (forAllShrink
    arbitrary shrink foo)]. *)
#[export] Declare Instance testFun :
  forall {A prop : Type} `{Show A} `{Arbitrary A} `{Checkable prop},
    Checkable (A -> prop).

(** Lift products similarly. *)
#[export] Declare Instance testProd :
  forall {A : Type} {prop : A -> Type} `{Show A} `{Arbitrary A}
         `{forall x : A, Checkable (prop x)},
    Checkable (forall (x : A), prop x).

(** Lift polymorphic functions by instantiating to 'nat'. :-) *)
#[export] Declare Instance testPolyFun :
  forall {prop : Type -> Type} `{Checkable (prop nat)},
    Checkable (forall T, prop T).

(* ================================================================= *)
(** ** Checker Combinators *)

(** Print a specific string if the property fails. *)
Parameter whenFail :
  forall {prop : Type} `{Checkable prop} (str : string), prop -> Checker.

(** Record an expectation that a property should fail, i.e.
    the property will fail if all the tests succeed. *)
Parameter expectFailure :
  forall {prop: Type} `{Checkable prop} (p: prop), Checker.

(** Collect statistics across all tests. *)
Parameter collect :
  forall {A prop : Type} `{Show A} `{Checkable prop} (x : A),
    prop -> Checker.

(** Set the reason for failure.  Will only count shrinks as valid if
    they preserve the tag. *)
Parameter tag :
  forall {prop : Type} `{Checkable prop} (t : string), prop -> Checker.

(** Form the conjunction / disjunction of a list of checkers. *)
Parameter conjoin : forall (l : list Checker), Checker.
Parameter disjoin : forall (l : list Checker), Checker.

(** Define a checker for a conditional property. Invalid generated
    inputs (ones for which the antecedent fails) are discarded. *)
Parameter implication :
  forall {prop : Type} `{Checkable prop} (b : bool) (p : prop), Checker.

(** Notation for implication. Clashes with many other notations in
    other libraries, so it lives in its own module. Note that this
    includes the notations for the generator combinators above
    to avoid needing to import two modules.
 *)
Module QcNotation.
  Export QcDefaultNotation.

  Notation "x ==> y" :=
    (implication x y) (at level 55, right associativity)
    : Checker_scope.
End QcNotation.

(* ################################################################# *)
(** * Decidability *)

(* ================================================================= *)
(** ** The [Dec] Typeclass

    Decidability typeclass using ssreflect's 'decidable'.

     Class Dec (P : Prop) : Type := { dec : decidable P }.
*)

(** Decidable properties are Checkable. *)
#[export] Declare Instance testDec {P} `{H : Dec P} : Checkable P.

(** Logic Combinator instances. *)
#[export] Declare Instance Dec_neg {P} {H : Dec P} : Dec (~ P).
#[export] Declare Instance Dec_conj {P Q} {H : Dec P} {I : Dec Q} : Dec (P /\ Q).
#[export] Declare Instance Dec_disj {P Q} {H : Dec P} {I : Dec Q} : Dec (P \/ Q).

(** A convenient notation for coercing a decidable proposition to a [bool]. *)
Notation "P '?'" := (match (@dec P _) with
                     | left _ => true
                     | right _ => false
                     end) (at level 100).

(* ================================================================= *)
(** ** The [Dec_Eq] Typeclass *)

(**
     Class Dec_Eq (A : Type) :=
       {
         dec_eq : forall (x y : A), decidable (x = y)
       }.
*)

(** Automation and conversions for Dec. *)
#[export] Declare Instance Eq__Dec {A} `{H : Dec_Eq A} (x y : A) : Dec (x = y).

(** Since deciding equalities is a very common requirement in testing,
    QuickChick provides a tactic that can define instances of the form
    [Dec (x = y)].
*)
(**
     Ltac dec_eq.
*)

(** QuickChick also lifts common decidable instances to the [Dec] typeclass. *)
#[export] Declare Instance Dec_eq_bool (x y : bool) : Dec (x = y).
#[export] Declare Instance Dec_eq_nat (m n : nat) : Dec (m = n).
#[export] Declare Instance Dec_eq_opt (A : Type) (m n : option A)
`{_ : forall (x y : A), Dec (x = y)} : Dec (m = n).
#[export] Declare Instance Dec_eq_prod (A B : Type) (m n : A * B)
`{_ : forall (x y : A), Dec (x = y)}
`{_ : forall (x y : B), Dec (x = y)}
: Dec (m = n).
#[export] Declare Instance Dec_eq_list (A : Type) (m n : list A)
`{_ : forall (x y : A), Dec (x = y)} : Dec (m = n).

#[export] Declare Instance Dec_ascii (m n : Ascii.ascii) : Dec (m = n).
#[export] Declare Instance Dec_string (m n : string) : Dec (m = n).

(* ################################################################# *)
(** * Automatic Instance Derivation *)

(** QuickChick allows the automatic derivation of typeclass instances
    for simple types:

       Derive <class> for T.

    Here [<class>] must be one of [GenSized], [Shrink], [Arbitrary],
    or [Show], and [T] must be an inductive defined datatype (think
    Haskell/OCaml).

    To derive multiple classes at once, write:

       Derive (<class>,...,<class>) for T.
*)

(** QuickChick also allows for the automatic derivation of generators
    satisfying preconditions in the form of inductive relations:

     Derive ArbitrarySizedSuchThat for (fun x => P x1 ... x .... xn).

    <P> must be an inductively defined relation.
    <x> is the function to be generated.
    <x1...xn> are (implicitly universally quantified) variable names.
*)

(** QuickChick also allows automatic derivations of proofs of
    correctness of its derived generators! For more, look
    at:

    - A paper on deriving QuickChick generators for a large class of
      inductive relations.
      {https://lemonidas.github.io/pdf/GeneratingGoodGenerators.pdf}

    - Leo's PhD dissertation.
      {https://lemonidas.github.io/pdf/Leo-PhD-Thesis.pdf}

    - examples/DependentTest.v

*)

(* ################################################################# *)
(** * Top-level Commands and Settings *)

(** QuickChick provides a series of toplevel commands to sample
    generators, test properties, and derive useful typeclass
    instances. *)

(** The [Sample] command samples a generator. The argument [g] needs
    to have type [G A] for some showable type [A].

    Sample g.
*)

(** The main testing command, [QuickChick], runs a test. The argument
    [prop] must belong to a type that is an instance of [Checkable].

     QuickChick prop.
*)

(** QuickChick uses arguments to customize execution. *)
Record Args :=
  MkArgs
    {
      (* Re-execute a test. *)
      (* Default: None *)
      replay     : option (RandomSeed * nat);
      (* Maximum number of successful tests to run. *)
      (* Default: 10000 *)
      maxSuccess : nat;
      (* Maximum number of discards to accept. *)
      (* Default: 20000 *)
      maxDiscard : nat;
      (* Maximum number of shrinks to perform before terminating. *)
      (* Default : 1000 *)
      maxShrinks : nat;
      (* Maximum size of terms to generate (depth). *)
      (* Default : 7 *)
      maxSize    : nat;
      (* Verbosity. Note: Doesn't do much... *)
      (* Default true. *)
      chatty     : bool
    }.

(** Instead of record updates, you should overwrite extraction constants.

   Extract Constant defNumTests    => "10000".
   Extract Constant defNumDiscards => "(2 * defNumTests)".
   Extract Constant defNumShrinks  => "1000".
   Extract Constant defSize        => "7".
*)

(* ################################################################# *)
(** * The [quickChick] Command-Line Tool *)

(** QuickChick comes with a command-line tool that supports:
      - Batch processing, compilation and execution of tests
      - Mutation testing
      - Sectioning of tests and mutants

    Comments that begin with an exclamation mark are special to the
    QuickChick command-line tool parser and signify a test, a section,
    or a mutant. *)

(* ================================================================= *)
(** ** Test Annotations *)

(** A test annotation is just a [QuickChick] command wrapped inside
    a comment with an exclamation mark.

    (*! QuickChick prop. *)

   Only tests that are annotated this way will be processed. Only property
   names are allowed. *)

(* ================================================================= *)
(** ** Mutant Annotations *)

(** A mutant annotation consists of 4 components. First an anottation
    that signifies the beginning of the mutant [(*! *)]. That is followed
    by the actual code. Then, we can include an optional annotation
    (in a comment with double exclamation marks) that corresponds to
    the mutant names. Finally, we can add a list of mutations inside
    normal annotated comments. Each mutant should be able to be
    syntactically substituted in for the normal code.

    (*! *)
    Normal code
    (*!! mutant-name *)
    (*! mutant 1 *)
    (*! mutant 2 *)
    ... etc ...
*)

(* ================================================================= *)
(** ** Section Annotations *)

(** To organize larger developments better, we can group together
    different tests and mutants in sections. A section annotation is
    a single annotation that defines the beginning of the section
    (which lasts until the next section or the end of the file).

      (*! Section section-name *)

    Optionally, one can include an extends clause

      (*! Section section-name *)(*! extends other-section-name *)

   This signifies that the section being defined also
   contains all tests and mutants from [other-section-name].
*)

(* ================================================================= *)
(** ** Command-Line Tool Flags *)

(** The QuickChick command line tool can be passed the following options:
    - [-s <section>]: Specify which sections properties and mutants to test
    - [-v]: Verbose mode for debugging
    - [-failfast]: Stop as soon as a problem is detected
    - [-color]: Use colors on an ANSI-compatible terminal
    - [-cmd <command>]: What compile command is used to compile the current directory
      if it is not [make]
    - [-top <name>]: Specify the name of the top-level logical module. That should
      be the same as the [-Q] or [-R] directive in [_CoqProject] or [Top]
      which is the default
    - [-ocamlbuild <args>]: Any arguments necessary to pass to ocamlbuild when
      compiling the extracted code (e.g. linked libraries)
    - [-nobase]: Pass this option to not test the base mutant
    - [-m <number>]: Pass this to only test a mutant with a specific id number
    - [-tag <name>]: Pass this to only test a mutant with a specific tag
    - [-include <name>]: Specify a to include in the compilation
    - [-exclude <names>]: Specify files to be excluded from compilation. Must be the last argument passed.
*)

End QuickChickSig.

(* 2022-08-27 08:36 *)


(* (c) Copyright Christian Doczkal, Saarland University                   *)
(* Distributed under the terms of the CeCILL-B license                    *)
Require Import Relations Omega.
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import all_ssreflect.
From libs Require Import edone bcase fset base modular_hilbert sltype.
Require Import Kstar_def demo.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Implicit Types (C D : clause).

(** * Hilbert Refutations *)

Arguments decomp_ab {_ _ _} _.

Section RefPred.
  Variable (F : {fset sform}).
  Hypothesis (sfc_F : sf_closed F).

  Local Notation S0 := (S0 F).
  Local Notation U := (U F).
  Local Notation xaf := (fun C => [af C]).

  Definition ref C := prv ([af C] ---> Bot).

  Lemma refI1n s C : prv ([af C] ---> s) -> ref (s^- |` C).
  Proof.
    move => H. rewrite /ref. rewrite -> andU,H,bigA1,axAC.
    rule axAcase. exact: axContra.
  Qed.

  Lemma refE1n s C : ref (s^- |` C) -> prv ([af C] ---> s).
  Proof.
    move => H. rewrite /ref in H. rewrite -> andU,bigA1 in H.
    Intro. ApplyH axDN. Intro. ApplyH H. by ApplyH axAI.
  Qed.

  Definition base0 C := [fset L in U | literalC L && suppC L C].

  Ltac Lbase_aux := move => D; rewrite !inE; (try case/orP) =>/eqP->.
  Ltac Lbase1 := Lbase_aux; by rewrite /= ?fsubUset ?fsub1 ?powersetE ?fsubUset ?fsub1 ?inE ?ssub_refl.
  Ltac Lbase3 := Lbase_aux; rewrite /weight /= ?fsumU !fsum1 /= /sltype.f_weight /= -?(plusE,minusE); apply/leP; omega.
  Ltac Lbase4 := move => L; Lbase_aux; by rewrite /sltype.supp /= ?suppCU ?suppC1 /=; bcase.

  Lemma base0P C : C \in U ->
     prv ([af C] ---> \or_(L <- base [fset D in U | literalC D] C) [af L]).
  Proof with try solve [Lbase1|Lbase3|Lbase4].
    apply: (@supp_aux _ ssub) => /= {C} ; last by move => ?; exact: sf_ssub.
    - move => [[|p|s t|s|s] [|]] //=; try exact: decomp_lit.
      + apply: (decomp_ab [fset [fset s^-]; [fset t^+]]) => /=...
        rewrite -[fImp s t]/(s ---> t). rewrite -> (axIO s t).
        rule axOE.
        * rewrite -> af1n. apply: (bigOI xaf). by rewrite !inE eqxx.
        * rewrite -> (af1p t) at 1. apply: (bigOI xaf). by rewrite !inE eqxx.
      + apply: (decomp_ab [fset [fset s^+; t^-]]) => /=...
        rewrite -[fImp s t]/(s ---> t). rewrite -> dmI.
        rewrite -> (af1p s),(af1n t), <- andU at 1.
        apply: (bigOI xaf). by rewrite inE.
      + apply: (decomp_ab [fset [fset s^+;fAX (fAG s)^+]]) => /=...
        rewrite -> axAGE at 1. rewrite -> (af1p s),(af1p (AX (AG s))), <- andU at 1.
        apply: (bigOI xaf). by rewrite !inE.
      + apply: (decomp_ab [fset [fset s^-]; [fset fAX (fAG s)^-]]) => /=...
        rewrite -> axAGEn. rewrite -> (af1n s),(af1n (AX (AG s))) at 1.
        rule axOE; apply: (bigOI xaf); by rewrite !inE eqxx.
  Qed.

  Lemma ax_lcons C : ~~ lcons C -> prv ([af C] ---> Bot).
  Proof.
    rewrite negb_and -has_predC negbK.
    case/orP => [inC|/hasP [[[] //= p [|] //]]].
    - rewrite -> (bigAE _ inC). exact: axI.
    - rewrite negbK => pP pN.
      rewrite -> (axA2 [af C]). rewrite -> (bigAE _ pP) at 2.
      rewrite -> (bigAE _ pN). simpl. rule axAcase. exact: axI.
  Qed.

  Lemma R2 C s : ref (s^- |` R C) -> ref (fAX s^- |` C).
  Proof.
    rewrite /ref. do 2 rewrite -> andU,bigA1.
    rewrite -[_ (s^-)]/(~~: s) -[_ (fAX s^-)]/(~~: AX s) => H.
    rewrite -> dmAX,box_request.
    rewrite /=. rewrite <- axDF. rewrite <- H.
    rule axAcase. apply axDBD.
  Qed.

  Section ContextRefutations.
  Variable S : {fset clause}.
  Hypothesis sub_S : S `<=` S0.
  Hypothesis coref_S : coref F ref S.

  Lemma baseP C : C \in U ->
     prv ([af C] ---> \or_(D <- base S C) [af D]).
  Proof.
    move => inU. rewrite -> base0P => //.
    apply: bigOE => L. rewrite !inE andbC => /and3P [L1 L2 L3].
    case: (boolP (L \in S)) => LS; first by apply: (bigOI xaf); rewrite inE LS.
    case: (boolP (lcons L)) => LL; last by rewrite -> (ax_lcons LL); exact: axBE.
    have H : L \in S0 `\` S by rewrite !inE LS LL L2 L3.
    Intro. ApplyH axBE. Rev. exact: (coref_S H).
  Qed.

  Lemma R1 C : C \in U -> ~~ suppS S C -> ref C.
  Proof.
    rewrite /ref => H1 H2. rewrite -> baseP => //.
    apply: bigOE => D. rewrite inE => /andP [D1 D2]. case:notF.
    apply: contraNT H2 => _. by apply/hasP; exists D.
  Qed.

  Lemma R3 C s : C \in S -> fAX (fAG s)^- \in C -> ~ fulfillAG S s C -> ref C.
  Proof.
    move => CinS inC nsupp_s. rewrite (fset1U inC). apply: refI1n.
    pose I := [fset D in S | D \notin fulfillAGb s S].
    pose u := \or_(D <- I) [af D].
    have IP D : D \in I -> ~~ suppS S (s^- |` R D) /\ {subset base S (R D) <= I}.
      case/sepP => inS. rewrite fulfillAGE inE inS /= => /hasPn H. split.
      + apply/hasPn => D' inS'. move: (H _ inS'). rewrite suppCU suppC1 /rtrans.
        by apply contraNN => /andP [-> ->].
      + move => D' /sepP [D1 D2]. rewrite inE D1 /=. move: (H _ D1).
        rewrite /rtrans D2 /= negb_or. by case/andP.
    Cut u; first by apply: (bigOI xaf); rewrite inE CinS /=; apply/negP => /fulfillAGP; tauto.
    apply: rAGp_ind. apply: bigOE => D inI.
    rewrite -> box_request. apply: rNorm.
    have HR : R D \in U.
      rewrite RinU //. rewrite inE in inI. case/andP : inI => /(subP sub_S) H _.
      rewrite inE /U in H. by case/and3P: H.
    ApplyH axAI.
    - rewrite -> baseP => //. apply: or_sub. by apply IP.
    - apply: refE1n. apply: R1; last by apply IP.
      rewrite powersetU HR powersetE fsub1 andbT.
      move/(subP sub_S) : CinS. rewrite inE => /and3P [X _ _].
      rewrite powersetE in X. move/(subP X) : inC.
      move => /sfc_F /= /sfc_F /=. by case/andP => _ ->.
  Qed.

  End ContextRefutations.

  Theorem href_of C : demo.ref F C -> ref C.
  Proof. elim => *;[ apply: R1 | apply: R2 | apply: R3]; eassumption. Qed.

End RefPred.

(** ** Completeness *)

Lemma prf_ref_sound C : prv ([af C] ---> Bot) -> ~ (exists M : fmodel, sat M C).
Proof.  move => H [M] [w] X. apply satA in X. exact: finite_soundness H M w X. Qed.

Theorem informative_completeness s :
    prv (fImp s fF)
  + (exists2 M:fmodel, #|M| <= 2^(2 * f_size s) & exists w:M, eval s w).
Proof.
  set F := ssub (s^+). have ? := @sfc_ssub (s^+).
  case: (@pruning_completeness F _ [fset s^+]) => //.
  - by rewrite powersetE fsub1 ssub_refl.
  - move => /href_of H. left. rewrite /ref in H. rewrite <- af1p in H. exact: H.
  - move => H. right. move: H => [M] [w] /(_ (s^+) (fset11 _)) /= ? S.
    exists M; last by exists w.
    apply: leq_trans S _. by rewrite leq_exp2l ?size_ssub.
Qed.

Corollary prv_dec s : decidable (prv s).
Proof.
  case: (informative_completeness (~~: s)) => H;[left|right].
  - by rule axDN.
  - move => prv_s. case: H => M _ [w]. apply. exact: (@soundness _ prv_s M).
Qed.

Corollary sat_dec s : decidable (exists (M:cmodel) (w:M), eval s w).
Proof.
  case: (informative_completeness s) => H;[right|left].
  - case => M [w] Hw. exact: (@soundness _ H M).
  - case: H => M _ [w] ?. by exists M; exists w.
Qed.

Corollary valid_dec s : decidable (forall (M:cmodel) (w:M), eval s w).
Proof.
  case (sat_dec (fImp s fF)) => /= H;[by firstorder|left => M w].
  by case (modelP s w); firstorder.
Qed.

(** ** Small Model Theorem *)

Corollary small_models s:
  (exists (M:cmodel) (w:M), eval s w) ->
  (exists2 M:fmodel, #|M| <= 2^(2 * f_size s) & exists w:M, eval s w).
Proof.
  case: (informative_completeness s) => // /(soundness) H [M] [w] w_s.
  exfalso. exact: H w_s.
Qed.