Require Import PCP.Definitions Shared.Prelim.

(** * Post grammars are context-free *)

Hint Rewrite concat_app map_app map_map : list.
Hint Rewrite <- map_rev  : list.

Lemma nil_app_nil X (A : list X) :
  A = [] ++ A ++ [].
Proof.
(* Goal: @eq (list X) A (@app X (@nil X) (@app X A (@nil X))) *)
  now autorewrite with list.
Qed.

Definition gamma (A : SRS) := map (fun '(x,y) => (x, rev y)) A.

Lemma sigma_eq  s A :
  sigma s A = tau1 A ++ [s] ++ rev (tau2 (gamma A)).
Proof.
  induction A  as [ | [u v] ].
  - reflexivity.
  - cbn. rewrite IHA. now simpl_list. 
Qed.

Lemma tau2_gamma s A :
  s el rev (tau2 (gamma A)) <-> s el tau2 A.
Proof.
(* Goal: iff (Post_G (@pair (prod (list (PCP.card nat)) symbol) (list symbol) (@pair (list (PCP.card nat)) symbol l s) l0)) (CFG (@pair (prod symbol (list (prod symbol (list symbol)))) (list symbol) (G l s) l0)) *)
  induction A as [ | [u v] ]; cbn.
  - reflexivity.
  - simpl_list. rewrite !in_app_iff, IHA. firstorder.
Qed.

Lemma sigma_inv A s1 s x y :
  sigma s1 A = x ++ [s] ++ y -> ~ s el x -> ~ s el y -> ~ s el sym A ->
  s1 = s.
Proof.
(* Goal: not (@In symbol S (sigma a A)) *)
  rewrite sigma_eq. intros.
(* Goal: @eq nat (count (@tau1 nat A) s) O *)
  cbn in H. assert (s el  tau1 A ++ s1 :: rev (tau2 (gamma A))) by (rewrite H; eauto).
(* Goal: @eq symbol s1 s *)
  eapply in_app_iff in H3 as [ | [ | ? % tau2_gamma]]; try firstorder using tau1_sym, tau2_sym.
Qed.

Lemma sigma_snoc A x y u v s s' :
  sigma s A = x ++ [s] ++ y -> ~ s el x -> ~ s el y ->
  sigma s' (A ++ [u/v]) = x ++ u ++ s' ++ v ++ y.
Proof.
(* Goal: iff (Post_G (@pair (prod (list (PCP.card nat)) symbol) (list symbol) (@pair (list (PCP.card nat)) symbol l s) l0)) (CFG (@pair (prod symbol (list (prod symbol (list symbol)))) (list symbol) (G l s) l0)) *)
  rewrite !sigma_eq. unfold gamma. cbn. simpl_list. cbn. simpl_list. cbn.
  intros. eapply list_prefix_inv in H as [-> <-]; eauto.
(* Goal: @eq nat (count l S) O *)
  eapply notInZero.
  eapply (f_equal (fun a => count a s)) in H. rewrite <- !countSplit in H. cbn in H.
(* Goal: @eq nat (count (@tau1 nat A) s) O *)
  rewrite !Nat.eqb_refl in H. eapply notInZero in H0. eapply notInZero in H1.
(* Goal: @eq nat (count (@tau1 nat A) s) O *)
  rewrite H0, H1 in *. omega.
Qed.

Section CFGs.

  Notation sig := nat.
  Definition rule : Type := sig * list sig.
  Definition cfg : Type := sig * list rule.

  Definition rules (G : cfg) := snd G.
  Definition startsym (G : cfg) := fst G.

  Inductive rew_cfg : cfg -> list sig -> list sig -> Prop:=
  |rewR R x a y v : (a,v) el rules R -> rew_cfg R (x++[a]++y) (x++v++y).
  Hint Constructors rew_cfg.

  Lemma rewrite_sing R a x :
    (a, x) el rules R -> rew_cfg R [a] x.
  Proof.
(* Goal: forall _ : @incl (PCP.card nat) (@cons (PCP.card nat) a0 A) R, or (@eq (list (PCP.card nat)) (@cons (PCP.card nat) a0 A) (@nil (PCP.card nat))) (rewt G (@cons symbol S (@nil symbol)) (sigma a (@cons (PCP.card nat) a0 A))) *)
    intros. rewrite nil_app_nil, (nil_app_nil [a]). now econstructor.
  Qed.
  
  Inductive rewt (S: cfg) (x: list sig) : list sig -> Prop :=
  |rewtRefl : rewt S x x
  |rewtRule y z : rewt S x y -> rew_cfg S y z -> rewt S x z.
  Hint Constructors rewt.

  Global Instance rewtTrans R :
    PreOrder (rewt R).
  Proof.
(* Goal: and (L (G R a) (sigma a A)) (@eq (list nat) (sigma a A) (@rev nat (sigma a A))) *)
    split.
    - hnf. econstructor.
    - induction 2; eauto.
  Qed.

  Global Instance rewrite_proper R :
    Proper (rewt R ==> rewt R ==> rewt R) (@app sig).
  Proof.
    intros x1 y1 H1 x2 y2 H2.
    induction H1.
    - induction H2.
(* Goal: rewt G (@app nat u (@app symbol (@cons symbol a (@nil symbol)) v)) (sigma a (@cons (PCP.card nat) (@pair (PCP.string nat) (PCP.string nat) u v) (@nil (PCP.card nat)))) *)
(* Goal: @In (prod nat (list nat)) (@pair nat (list nat) S (@app nat u (@app symbol (@cons symbol a (@nil symbol)) v))) (rules G) *)
      + reflexivity.
      + rewrite IHrewt. inv H. eapply rewtRule.
(* Goal: @eq (list X) A (@app X (@nil X) (@app X A (@nil X))) *)
        replace (x1 ++ x ++ [a] ++ y0) with ( (x1 ++ x) ++ [a] ++ y0) by now autorewrite with list.
(* Goal: @eq (list X) A (@app X (@nil X) (@app X A (@nil X))) *)
        eauto. replace (x1 ++ x ++ v ++ y0) with ( (x1 ++ x) ++ v ++ y0) by now autorewrite with list. eauto.
    - rewrite IHrewt. inv H. autorewrite with list. eauto.
  Qed.

  Global Instance subrel R :
    subrelation (rew_cfg R) (rewt R).
  Proof.
(* Goal: rewt G (@app nat u (@app symbol (@cons symbol a (@nil symbol)) v)) (sigma a (@cons (PCP.card nat) (@pair (PCP.string nat) (PCP.string nat) u v) (@nil (PCP.card nat)))) *)
(* Goal: @In (prod nat (list nat)) (@pair nat (list nat) S (@app nat u (@app symbol (@cons symbol a (@nil symbol)) v))) (rules G) *)
    intros x y H. econstructor. reflexivity. eassumption.
  Qed.
    
  Definition terminal G x := ~ exists y, rew_cfg G x y.

  Lemma terminal_iff G x :
    terminal G x <-> forall s y, s el x -> ~ (s, y) el rules G.
  Proof.
(* Goal: and (L (G R a) (sigma a A)) (@eq (list nat) (sigma a A) (@rev nat (sigma a A))) *)
    split.
    - intros H s y A B. apply H. destruct (@in_split _ _ _ A) as (l1 & l2 & ->).
(* Goal: rew_cfg G (@app nat l1 (@app nat (@cons nat s (@nil nat)) l2)) (@app nat l1 (@app nat y l2)) *)
      exists (l1 ++ y ++ l2). change (s :: l2) with ([s] ++ l2). now econstructor.
    - intros H1 [y H2]. inv H2. eapply (H1 _ v); eauto.
  Qed.

  Definition L (G : cfg) x := rewt G [startsym G] x /\ terminal G x.

  Definition sym_G (G : cfg) :=
    startsym G :: flat_map (fun '(a, x) => a :: x) (rules G).
  
  Lemma sym_G_rewt x G y :
    x <<= sym_G G -> rewt G x y -> y <<= sym_G G.
  Proof.
(* Goal: forall _ : @incl (PCP.card nat) (@cons (PCP.card nat) a0 A) R, or (@eq (list (PCP.card nat)) (@cons (PCP.card nat) a0 A) (@nil (PCP.card nat))) (rewt G (@cons symbol S (@nil symbol)) (sigma a (@cons (PCP.card nat) a0 A))) *)
    intros. induction H0.
    - eauto.
    - destruct H1. destruct R. cbn in *.
(* Goal: @eq (list nat) (sigma a A) (@rev nat (sigma a A)) *)
      eapply incl_app; eauto.  eapply incl_app; eauto.
(* Goal: @incl nat v (sym_G (@pair nat (list rule) n l)) *)
      unfold sym_G. intros ? ?.
(* Goal: @eq (list nat) (sigma a A) (@rev nat (sigma a A)) *)
      right. eapply in_flat_map.  exists (a / v). eauto.
  Qed.
  
End CFGs.

Definition CFP' (G : cfg) := exists x, L G x /\ x = List.rev x.

Definition CFI' '(G1, G2) :=
  exists x, L G1 x /\ L G2 x.

Section Post_CFG.

  Variable R : SRS.
  Variable a : symbol.

  Definition Sigma := sym R ++ [a].
  Definition S : symbol := fresh Sigma.

  Definition G := (S, (S,[S]) :: map (fun '(u / v) => (S, u ++ [S] ++ v)) R ++ map (fun '(u / v) => (S, u ++ [a] ++ v)) R).

  Lemma terminal_iff_G y :
    terminal G y <-> ~ S el y.
  Proof.
(* Goal: iff (terminal G y) (not (@In symbol S y)) *)
    unfold terminal.
    enough ((exists y0, rew_cfg G y y0) <-> S el y). firstorder. split.
    - intros [y0 ?]. inv H. cbn in H0.
(* Goal: @eq (list nat) (sigma a A) (@rev nat (sigma a A)) *)
      destruct H0 as [ | [ [[] []] % in_map_iff | [[] []] % in_map_iff ] % in_app_iff]; inv H; eauto.
    - intros (u' & v' & ?) % List.in_split.
(* Goal: iff (Post_G (@pair (prod (list (PCP.card nat)) symbol) (list symbol) (@pair (list (PCP.card nat)) symbol l s) l0)) (CFG (@pair (prod symbol (list (prod symbol (list symbol)))) (list symbol) (G l s) l0)) *)
      subst. exists (u' ++ [S] ++ v'). econstructor. cbn. eauto.
  Qed.

  Lemma rewt_count x :
    rewt G [S] x -> count x S <= 1.
  Proof.
(* Goal: forall _ : rewt G (@cons symbol S (@nil symbol)) x, le (count x S) (Datatypes.S O) *)
    induction 1.
    - cbn. now rewrite Nat.eqb_refl.
    - inv H0. destruct H1 as [ | [ [[] []] % in_map_iff | [[] []] % in_map_iff ] % in_app_iff]; inv H0.
      + eauto.
      + unfold Sigma. simpl_list. rewrite <- !countSplit in *. cbn in *.
(* Goal: le (Init.Nat.add (count x S) (Init.Nat.add (count l S) (Init.Nat.add (if Nat.eqb S a then Datatypes.S (count l0 S) else count l0 S) (count y0 S)))) (Datatypes.S O) *)
        rewrite Nat.eqb_refl in *.
        enough (count l S = 0) as ->. enough (count l0 S = 0) as ->. omega.
(* Goal: @eq nat (count l S) O *)
        * eapply notInZero. intros D.
(* Goal: rewt G (@app nat u (@app symbol (@cons symbol a (@nil symbol)) v)) (sigma a (@cons (PCP.card nat) (@pair (PCP.string nat) (PCP.string nat) u v) (@nil (PCP.card nat)))) *)
(* Goal: @In (prod nat (list nat)) (@pair nat (list nat) S (@app nat u (@app symbol (@cons symbol a (@nil symbol)) v))) (rules G) *)
          edestruct (fresh_spec) with (l := Sigma); try reflexivity.
(* Goal: @eq (list nat) (sigma a A) (@rev nat (sigma a A)) *)
          eapply sym_word_R in H1. unfold Sigma. eauto. 
(* Goal: @eq nat (count l S) O *)
        * eapply notInZero. intros D.
(* Goal: rewt G (@app nat u (@app symbol (@cons symbol a (@nil symbol)) v)) (sigma a (@cons (PCP.card nat) (@pair (PCP.string nat) (PCP.string nat) u v) (@nil (PCP.card nat)))) *)
(* Goal: @In (prod nat (list nat)) (@pair nat (list nat) S (@app nat u (@app symbol (@cons symbol a (@nil symbol)) v))) (rules G) *)
          edestruct (fresh_spec) with (l := Sigma); try reflexivity.
(* Goal: @eq (list nat) (sigma a A) (@rev nat (sigma a A)) *)
          eapply sym_word_l in H1. unfold Sigma. eauto. 
      + unfold Sigma. simpl_list. rewrite <- !countSplit in *. cbn in *.
(* Goal: le (Init.Nat.add (count x S) (Init.Nat.add (count l S) (Init.Nat.add (if Nat.eqb S a then Datatypes.S (count l0 S) else count l0 S) (count y0 S)))) (Datatypes.S O) *)
        rewrite Nat.eqb_refl in *.
        assert (S =? a = false) as ->. eapply Nat.eqb_neq. intros D.
(* Goal: rewt G (@app nat u (@app symbol (@cons symbol a (@nil symbol)) v)) (sigma a (@cons (PCP.card nat) (@pair (PCP.string nat) (PCP.string nat) u v) (@nil (PCP.card nat)))) *)
(* Goal: @In (prod nat (list nat)) (@pair nat (list nat) S (@app nat u (@app symbol (@cons symbol a (@nil symbol)) v))) (rules G) *)
        edestruct fresh_spec with (l := Sigma); try reflexivity.
(* Goal: @eq (list nat) (sigma a A) (@rev nat (sigma a A)) *)
        unfold S in *. rewrite D. unfold Sigma; eauto.
        enough (count l S = 0) as ->. enough (count l0 S = 0) as ->. omega.
(* Goal: @eq nat (count l S) O *)
        * eapply notInZero. intros D.
(* Goal: rewt G (@app nat u (@app symbol (@cons symbol a (@nil symbol)) v)) (sigma a (@cons (PCP.card nat) (@pair (PCP.string nat) (PCP.string nat) u v) (@nil (PCP.card nat)))) *)
(* Goal: @In (prod nat (list nat)) (@pair nat (list nat) S (@app nat u (@app symbol (@cons symbol a (@nil symbol)) v))) (rules G) *)
          edestruct (fresh_spec) with (l := Sigma); try reflexivity.
(* Goal: @eq (list nat) (sigma a A) (@rev nat (sigma a A)) *)
          eapply sym_word_R in H1. unfold Sigma. eauto. 
(* Goal: @eq nat (count l S) O *)
        * eapply notInZero. intros D.
(* Goal: rewt G (@app nat u (@app symbol (@cons symbol a (@nil symbol)) v)) (sigma a (@cons (PCP.card nat) (@pair (PCP.string nat) (PCP.string nat) u v) (@nil (PCP.card nat)))) *)
(* Goal: @In (prod nat (list nat)) (@pair nat (list nat) S (@app nat u (@app symbol (@cons symbol a (@nil symbol)) v))) (rules G) *)
          edestruct (fresh_spec) with (l := Sigma); try reflexivity.
(* Goal: @eq (list nat) (sigma a A) (@rev nat (sigma a A)) *)
          eapply sym_word_l in H1. unfold Sigma. eauto. 
  Qed.
  
  Lemma Post_CFG_1' A :
    A <<= R -> A = [] \/ rewt G [S] (sigma a A).
  Proof.
(* Goal: forall _ : @incl (PCP.card nat) A R, or (@eq (list (PCP.card nat)) A (@nil (PCP.card nat))) (rewt G (@cons symbol S (@nil symbol)) (sigma a A)) *)
    induction A.
    - cbn. eauto.
    - intros.  assert (A <<= R) by eauto. eapply IHA in H0.
(* Goal: or (@eq (list (PCP.card nat)) (@cons (PCP.card nat) a0 A) (@nil (PCP.card nat))) (rewt G (@cons symbol S (@nil symbol)) (sigma a (@cons (PCP.card nat) a0 A))) *)
      destruct a0 as [u v]. destruct H0.
(* Goal: rewt G (@app nat u (@app symbol (@cons symbol a (@nil symbol)) v)) (sigma a (@cons (PCP.card nat) (@pair (PCP.string nat) (PCP.string nat) u v) (@nil (PCP.card nat)))) *)
(* Goal: @In (prod nat (list nat)) (@pair nat (list nat) S (@app nat u (@app symbol (@cons symbol a (@nil symbol)) v))) (rules G) *)
      + subst. right. erewrite rewrite_sing with (x := u ++ [a] ++ v). reflexivity.
(* Goal: @eq (list nat) (sigma a A) (@rev nat (sigma a A)) *)
        right. eapply in_app_iff. right. eapply in_map_iff. exists (u,v); eauto.
      + right. erewrite rewrite_sing with (x := u ++ [S] ++ v). 
(* Goal: @eq (list nat) (sigma a A) (@rev nat (sigma a A)) *)
        now rewrite H0. right. eapply in_app_iff. left. eapply in_map_iff. exists (u,v); eauto.
  Qed.

  Lemma Post_CFG_2 x :
    rewt G [S] x ->
    exists A m, A <<= R /\ sigma m A = x /\ (m = S \/ m = a /\ A <> []).
  Proof.
(* Goal: forall _ : @incl (PCP.card nat) (@cons (PCP.card nat) a0 A) R, or (@eq (list (PCP.card nat)) (@cons (PCP.card nat) a0 A) (@nil (PCP.card nat))) (rewt G (@cons symbol S (@nil symbol)) (sigma a (@cons (PCP.card nat) a0 A))) *)
    intros. induction H.
    - cbn.  exists [], S. eauto.
    - inv H0. destruct H1 as [ | [(? & ? & ?) % in_map_iff | (? & ? & ?) % in_map_iff] % in_app_iff]; inv H0.
      + eassumption.
      + destruct x0 as [u' v']. inv H3.
        destruct IHrewt as (A & m & HA & IHA & Hm).
(* Goal: and (L (G R a) (sigma a A)) (@eq (list nat) (sigma a A) (@rev nat (sigma a A))) *)
        exists (A ++ [u'/v']), S. repeat split.
(* Goal: @eq (list nat) (sigma a A) (@rev nat (sigma a A)) *)
        * eauto.
(* Goal: iff (Post_G (@pair (prod (list (PCP.card nat)) symbol) (list symbol) (@pair (list (PCP.card nat)) symbol l s) l0)) (CFG (@pair (prod symbol (list (prod symbol (list symbol)))) (list symbol) (G l s) l0)) *)
        * simpl_list. cbn.
          enough (~ S el x). enough (~ S el y0).
(* Goal: @eq (list nat) (sigma a A) (@rev nat (sigma a A)) *)
          eapply sigma_snoc with (s := S); eauto.
          -- assert (IH2 := IHA).
(* Goal: @eq (list nat) (sigma a A) (@rev nat (sigma a A)) *)
          eapply sigma_inv in IHA; eauto. subst. eauto.
(* Goal: not (@In nat S l) *)
          intros D. 
(* Goal: rewt G (@app nat u (@app symbol (@cons symbol a (@nil symbol)) v)) (sigma a (@cons (PCP.card nat) (@pair (PCP.string nat) (PCP.string nat) u v) (@nil (PCP.card nat)))) *)
(* Goal: @In (prod nat (list nat)) (@pair nat (list nat) S (@app nat u (@app symbol (@cons symbol a (@nil symbol)) v))) (rules G) *)
          edestruct fresh_spec with (l := sym R ++ [a]); try reflexivity.
(* Goal: @eq (list nat) (sigma a A) (@rev nat (sigma a A)) *)
          eapply in_app_iff. left. eapply sym_mono. eauto. eauto.
          -- eapply rewt_count in H. rewrite <- !countSplit in H. cbn in H.
(* Goal: @eq nat (count l S) O *)
             rewrite Nat.eqb_refl in H. eapply notInZero. omega.
          -- eapply rewt_count in H. rewrite <- !countSplit in H. cbn in H.
(* Goal: @eq nat (count l S) O *)
             rewrite Nat.eqb_refl in H. eapply notInZero. omega.
(* Goal: @eq (list nat) (sigma a A) (@rev nat (sigma a A)) *)
        * eauto.
      + destruct x0 as [u' v']. inv H3.
        destruct IHrewt as (A & m & HA & IHA & Hm).
(* Goal: and (L (G R a) (sigma a A)) (@eq (list nat) (sigma a A) (@rev nat (sigma a A))) *)
        exists (A ++ [u'/v']), a. repeat split.
(* Goal: @eq (list nat) (sigma a A) (@rev nat (sigma a A)) *)
        * eauto.
(* Goal: iff (Post_G (@pair (prod (list (PCP.card nat)) symbol) (list symbol) (@pair (list (PCP.card nat)) symbol l s) l0)) (CFG (@pair (prod symbol (list (prod symbol (list symbol)))) (list symbol) (G l s) l0)) *)
        * simpl_list. cbn.
          enough (~ S el x). enough (~ S el y0).
(* Goal: @eq (list nat) (sigma a A) (@rev nat (sigma a A)) *)
          eapply sigma_snoc with (s := S); eauto.
          -- assert (IH2 := IHA).
(* Goal: @eq (list nat) (sigma a A) (@rev nat (sigma a A)) *)
          eapply sigma_inv in IHA; eauto. subst. eauto.
(* Goal: not (@In nat S l) *)
          intros D. 
(* Goal: rewt G (@app nat u (@app symbol (@cons symbol a (@nil symbol)) v)) (sigma a (@cons (PCP.card nat) (@pair (PCP.string nat) (PCP.string nat) u v) (@nil (PCP.card nat)))) *)
(* Goal: @In (prod nat (list nat)) (@pair nat (list nat) S (@app nat u (@app symbol (@cons symbol a (@nil symbol)) v))) (rules G) *)
          edestruct fresh_spec with (l := sym R ++ [a]); try reflexivity.
(* Goal: @eq (list nat) (sigma a A) (@rev nat (sigma a A)) *)
          eapply in_app_iff. left. eapply sym_mono. eauto. eauto.
          -- eapply rewt_count in H. rewrite <- !countSplit in H. cbn in H.
(* Goal: @eq nat (count l S) O *)
             rewrite Nat.eqb_refl in H. eapply notInZero. omega.
          -- eapply rewt_count in H. rewrite <- !countSplit in H. cbn in H.
(* Goal: @eq nat (count l S) O *)
             rewrite Nat.eqb_refl in H. eapply notInZero. omega.
(* Goal: iff (not (@ex (list nat) (fun y0 : list nat => rew_cfg G y y0))) (not (@In symbol S y)) *)
(* Goal: iff (@ex (list nat) (fun y0 : list nat => rew_cfg G y y0)) (@In symbol S y) *)
        * destruct A; firstorder.
  Qed.

  Lemma reduction_full x :
    (exists A, A <<= R /\ A <> [] /\ sigma a A = x) <->  L G x.
  Proof.
(* Goal: and (L (G R a) (sigma a A)) (@eq (list nat) (sigma a A) (@rev nat (sigma a A))) *)
    split.
    - intros (A & ? & ? & ?). subst. destruct Post_CFG_1' with (A := A); intuition.
(* Goal: and (L (G R a) (sigma a A)) (@eq (list nat) (sigma a A) (@rev nat (sigma a A))) *)
      split.
      + eassumption.
(* Goal: not (@In symbol S (sigma a A)) *)
      + eapply terminal_iff_G. rewrite sigma_eq. intros E.
(* Goal: rewt G (@app nat u (@app symbol (@cons symbol a (@nil symbol)) v)) (sigma a (@cons (PCP.card nat) (@pair (PCP.string nat) (PCP.string nat) u v) (@nil (PCP.card nat)))) *)
(* Goal: @In (prod nat (list nat)) (@pair nat (list nat) S (@app nat u (@app symbol (@cons symbol a (@nil symbol)) v))) (rules G) *)
        edestruct fresh_spec with (l := sym R ++ [a]); try reflexivity.        
(* Goal: @In symbol (fresh (@app nat (sym R) (@cons symbol a (@nil symbol)))) (@app nat (sym R) (@cons symbol a (@nil symbol))) *)
        eapply in_app_iff in E as [ | [ | ? % tau2_gamma ] % in_app_iff].
(* Goal: @eq (list nat) (sigma a A) (@rev nat (sigma a A)) *)
        * eapply in_app_iff. left. eapply sym_mono; eauto. now eapply tau1_sym.
(* Goal: @eq (list nat) (sigma a A) (@rev nat (sigma a A)) *)
        * eapply in_app_iff. right. eauto.
(* Goal: @eq (list nat) (sigma a A) (@rev nat (sigma a A)) *)
        * eapply in_app_iff. left. eapply sym_mono; eauto. now eapply tau2_sym.
    - intros [(A & m & HA & HE & Hm) % Post_CFG_2 ?].
      subst. destruct Hm as [-> | [-> ?]].
      + eapply terminal_iff_G in H.  exfalso. rewrite sigma_eq in H.
(* Goal: @eq (list nat) (sigma a A) (@rev nat (sigma a A)) *)
        eapply H. eauto.        
      + exists A. eauto.
  Qed.
  
End Post_CFG.

Definition Post_G '(R, a, x) := exists A, A <<= R /\ A <> [] /\ sigma a A = x.
Definition CFG '(G, x) := L G x.

Lemma reduce_grammars :
  Post_G ⪯ CFG.
Proof.
(* Goal: iff (Post_G (@pair (prod (list (PCP.card nat)) symbol) (list symbol) (@pair (list (PCP.card nat)) symbol l s) l0)) (CFG (@pair (prod symbol (list (prod symbol (list symbol)))) (list symbol) (G l s) l0)) *)
  exists (fun '(R, a, x) => (G R a, x)). intros ((? & ?) & ?). cbn. eapply reduction_full.
Qed.

Lemma reduce_CFP :
  CFP ⪯ CFP'.
Proof.
(* Goal: @reduces (prod (list (PCP.card nat)) symbol) cfg CFP CFP' *)
  exists (fun '(R, a) => (G R a)). intros [R a].
(* Goal: le (Init.Nat.add (count x S) (Init.Nat.add (count l S) (Init.Nat.add (count (@cons symbol a l0) S) (count y0 S)))) (Datatypes.S O) *)
  intuition; cbn in *.
  - destruct H as (A & HR & HA & H).
(* Goal: and (L (G R a) (sigma a A)) (@eq (list nat) (sigma a A) (@rev nat (sigma a A))) *)
    exists (sigma a A). split. eapply reduction_full; eauto.
(* Goal: @eq (list nat) (sigma a A) (@rev nat (sigma a A)) *)
    eauto.
  - destruct H as (x & Hx & H).
(* Goal: @ex SRS (fun A : SRS => and (@incl (PCP.card nat) A R) (and (not (@eq SRS A (@nil (PCP.card nat)))) (@eq (list symbol) (sigma a A) (@rev symbol (sigma a A))))) *)
    eapply reduction_full in Hx as (A & HR & HA & H1).
(* Goal: @eq (list nat) (sigma a A) (@rev nat (sigma a A)) *)
    exists A. subst; eauto.
Qed.

Lemma reduce_CFI :
  CFI ⪯ CFI'.
Proof.
(* Goal: @reduces (prod (prod (list (PCP.card nat)) (list (PCP.card nat))) symbol) (prod cfg cfg) CFI CFI' *)
  exists (fun '(R1, R2, a) => (G R1 a, G R2 a)). intros [[R1 R2] a].
(* Goal: le (Init.Nat.add (count x S) (Init.Nat.add (count l S) (Init.Nat.add (count (@cons symbol a l0) S) (count y0 S)))) (Datatypes.S O) *)
  intuition; cbn in *.
  - destruct H as (A1 & A2 & HR1 & HR2 & HA1 & HA2 & H).
(* Goal: @eq (list nat) (sigma a A) (@rev nat (sigma a A)) *)
    exists (sigma a A1). split; eapply reduction_full; eauto.
  - destruct H as (x & HR1 & HR2).
(* Goal: @ex stack (fun A1 : stack => @ex stack (fun A2 : stack => and (@incl (PCP.card nat) A1 R1) (and (@incl (PCP.card nat) A2 R2) (and (not (@eq stack A1 (@nil (PCP.card nat)))) (and (not (@eq stack A2 (@nil (PCP.card nat)))) (@eq (list symbol) (sigma a A1) (sigma a A2))))))) *)
    eapply reduction_full in HR1 as (A1 & HR1 & HA1 & H1).
(* Goal: @ex stack (fun A1 : stack => @ex stack (fun A2 : stack => and (@incl (PCP.card nat) A1 R1) (and (@incl (PCP.card nat) A2 R2) (and (not (@eq stack A1 (@nil (PCP.card nat)))) (and (not (@eq stack A2 (@nil (PCP.card nat)))) (@eq (list symbol) (sigma a A1) (sigma a A2))))))) *)
    eapply reduction_full in HR2 as (A2 & HR2 & HA2 & H2).
(* Goal: @eq (list nat) (sigma a A) (@rev nat (sigma a A)) *)
    exists A1, A2. subst; eauto.
Qed.
