(* ---------------------------------------------------------------------
   This file contains definitions and proof scripts related to
   (i) closure operations for context-free grammars,
   (ii) context-free grammars simplification
   (iii) context-free grammar Chomsky normalization and
   (iv) pumping lemma for context-free languages.

   More information can be found in the paper "Formalization of the
   Pumping Lemma for Context-Free Languages", submitted to JFR.

   Marcus Vinícius Midena Ramos
   mvmramos@gmail.com
   --------------------------------------------------------------------- *)

(* --------------------------------------------------------------------- *)
(* CHOMSKY NORMAL FORM                                                   *)
(* --------------------------------------------------------------------- *)

Require Import List.
Require Import Ring.
Require Import Omega.
Require Import Program.

Require Import misc_arith.
Require Import misc_list.
Require Import cfg.
Require Import inaccessible.
Require Import useless.
Require Import unitrules.
Require Import emptyrules.
Require Import simplification.
Require Import allrules.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Import ListNotations.
Open Scope list_scope.

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

Section Chomsky_Definitions_1.

Variables non_terminal terminal: Type.

Notation sf:= (list (non_terminal + terminal)).

Definition is_cnf_rule (left: non_terminal) (right: sf): Prop:=
(exists s1 s2: non_terminal, right = [inl s1; inl s2]) \/
(exists t: terminal, right = [inr t]).

Definition is_cnf (g: cfg non_terminal terminal): Prop:=
forall left: non_terminal,
forall right: sf,
rules g left right -> is_cnf_rule left right.

Definition is_cnf_with_empty_rule (g: cfg non_terminal terminal): Prop:=
forall left: non_terminal,
forall right: sf,
rules g left right ->
(left = (start_symbol g) /\ right = []) \/
is_cnf_rule left right.

End Chomsky_Definitions_1.

Section Chomsky_Definitions_2.

Variables non_terminal terminal: Type.

Notation sentence := (list terminal).
Notation sf := (list (non_terminal + terminal)).
Notation ntlist:= (list non_terminal).
Notation term_lift:= ((terminal_lift non_terminal) terminal).
Notation symbol:= (non_terminal + terminal)%type.
Notation slist:= (list sf).
Notation vlist:= (list symbol).

Inductive non_terminal': Type:=
| Lift_r: sf -> non_terminal'.

Lemma nt_eqdec':
 (forall (x y:terminal), {x=y}+{x<>y}) ->
 (forall (x y:non_terminal), {x=y}+{x<>y}) ->
 forall (x y:non_terminal'), {x=y}+{x<>y}.
Proof.
intros.
assert (forall (l1 l2:vlist), {l1=l2}+{l1<>l2}).
 apply list_eq_dec; decide equality.
decide equality.
Qed.

Notation sf':= (list (non_terminal' + terminal)).
Notation ntlist':= (list non_terminal').
Notation tlist:= (list terminal).

Definition non_terminal_lift (n: non_terminal): (non_terminal + terminal):= inl n.
Definition non_terminal'_lift (n: non_terminal'): (non_terminal' + terminal):= inl n.
Definition terminal_lift' (t: terminal): (non_terminal' + terminal):= inr t.
Definition symbol_lift (s: non_terminal + terminal): non_terminal' + terminal:=
match s with
| inr t => inr t
| inl n => inl (Lift_r [inl n])
end.

Inductive g_cnf_rules (g: cfg non_terminal terminal): non_terminal' -> sf' -> Prop:=
| Lift_cnf_t:  forall t: terminal,
               forall left: non_terminal,
               forall s1 s2: sf,
               rules g left (s1++[inr t]++s2) ->
               g_cnf_rules g (Lift_r [inr t]) [inr t]
| Lift_cnf_1:  forall left: non_terminal,
               forall t: terminal,
               rules g left [inr t] ->
               g_cnf_rules g (Lift_r [inl left]) [inr t]
| Lift_cnf_2:  forall left: non_terminal,
               forall s1 s2: symbol,
               forall beta: sf,
               rules g left (s1 :: s2 :: beta) ->
               g_cnf_rules g (Lift_r [inl left]) [inl (Lift_r [s1]); inl (Lift_r (s2 :: beta))]
| Lift_cnf_3:  forall left: sf,
               forall s1 s2 s3: symbol,
               forall beta: sf,
               g_cnf_rules g (Lift_r left) [inl (Lift_r [s1]); inl (Lift_r (s2 :: s3 :: beta))] ->
               g_cnf_rules g (Lift_r (s2 :: s3 :: beta)) [inl (Lift_r [s2]); inl (Lift_r (s3 :: beta))].

(* --------------------------------------------------------------------- *)
(* ALL NTS (non-terminals)                                               *)
(* --------------------------------------------------------------------- *)

Fixpoint all_nts (l: slist): ntlist':=
match l with
| [] => []
| s :: l' => Lift_r s :: all_nts l'
end.

Lemma all_nts_app:
forall l1 l2: slist,
all_nts (l1 ++ l2) = all_nts l1 ++ all_nts l2.
Proof.
induction l1.
- simpl.
  reflexivity.
- intros l2.
  simpl.
  rewrite (IHl1 l2).
  reflexivity.
Qed.

Lemma all_nts_single:
forall s: symbol,
forall l1 l2: vlist,
forall n: nat,
n >= 1 ->
In (Lift_r [s]) (all_nts (all_sf_up_to n (l1 ++ s :: l2))).
Proof.
intros s l1 l2 n.
revert l2.
revert l1.
revert s.
induction n.
- intros s l1 l2 H1.
  omega.
- intros s l1 l2 H1.
  assert (H2: n = 0 \/ n >= 1) by omega.
  destruct H2 as [H2 | H2].
  + subst.
    simpl.
    rewrite all_nts_app.
    apply in_or_app.
    left.
    rewrite concat_list_app_left.
    rewrite all_nts_app.
    apply in_or_app.
    right.
    simpl.
    left.
    reflexivity.
  + simpl.
    rewrite all_nts_app.
    apply in_or_app.
    right.
    apply IHn.
    exact H2.
Qed.

Fixpoint all_nts_up_to (n: nat) (v: vlist): ntlist':=
match n with
| 0 => [Lift_r []]
| S n' => all_nts (all_sf_with n v) ++ all_nts_up_to n' v
end.

Lemma all_nts_up_to_correct_aux:
forall n: nat,
forall s: symbol,
forall v: vlist,
forall s0: sf,
In s v ->
In s0 (all_sf_with n v) ->
In (Lift_r (s :: s0)) (all_nts (concat_list v (all_sf_with n v))).
Proof.
induction n.
- intros s v s0 H1 H2.
  simpl in H2.
  destruct H2 as [H2 | H2].
  + subst.
    simpl.
    apply in_split in H1.
    destruct H1 as [l1 [l2 H1]].
    subst.
    assert (H: In [s] (concat_list (l1 ++ s :: l2) [[]])).
      {
      apply concat_list_empty.
      }
    apply in_split in H.
    destruct H as [l0 [l3 H]].
    rewrite H.
    rewrite all_nts_app.
    apply in_or_app.
    right.
    simpl.
    left.
    reflexivity.
  + contradiction.
- intros s v s0 H1 H2.
  simpl.
  simpl in H2.
  apply in_split in H2.
  destruct H2 as [l1 [l2 H2]].
  rewrite H2.
  apply in_split in H1.
  destruct H1 as [l1' [l2' H1]].
  rewrite H1.
  assert (H3: In (s :: s0) (concat_list (l1' ++ s :: l2') (l1 ++ s0 :: l2))).
    {
    apply concat_list_non_empty.
    }
  apply in_split in H3.
  destruct H3 as [l0 [l3 H3]].
  rewrite H3.
  rewrite all_nts_app.
  apply in_or_app.
  right.
  simpl.
  left.
  reflexivity.
Qed.

Lemma all_nts_up_to_correct:
forall n: nat,
forall s: sf,
forall v: vlist,
(forall e: symbol, In e s -> In e v) ->
length s <= n ->
In (Lift_r s) (all_nts_up_to n v).
Proof.
induction n.
- intros s v H1 H2.
  assert (length s = 0) by omega.
  apply length_zero in H.
  subst.
  simpl.
  left.
  reflexivity.
- intros s v H1 H2.
  simpl.
  apply in_or_app.
  assert (H3: length s = S n \/ length s <= n) by omega.
  clear H2.
  destruct H3 as [H3 | H3].
  + left.
    destruct s.
    * simpl in H3.
      omega.
    * {
      apply all_nts_up_to_correct_aux.
      - apply H1.
        simpl.
        left.
        reflexivity.
      - simpl in H3.
        apply eq_add_S in H3.
        apply all_sf_with_correct.
        + intros e H4.
          apply H1.
          simpl.
          right.
          exact H4.
        + exact H3.
      }
  + right.
    apply IHn.
    * exact H1.
    * exact H3.
Qed.

Lemma rules_g_cnf_to_rules_g_right:
forall g: cfg _ _,
forall right2: sf,
forall n1 n2: non_terminal',
forall s1 s2: symbol,
g_cnf_rules g n1 [inl n2; inl (Lift_r (s1 :: s2 :: right2))] ->
exists left: non_terminal,
exists right1: sf,
rules g left (right1 ++ s1 :: s2 :: right2).
Proof.
intros g right2 n1 n2 s1 s2 H.
remember [inl n2; inl (Lift_r (s1 :: s2 :: right2))] as w.
generalize n2 s1 s2 right2 Heqw.
clear n2 s1 s2 right2 Heqw.
induction H.
- intros n2 s1' s2' right2 H'.
  inversion H'.
- intros n2 s1' s2' right2 H2'.
  inversion H2'.
- intros n2 s0 s3 right2 H2.
  inversion H2.
  destruct n2.
  inversion H1.
  destruct beta.
  + inversion H4.
  + inversion H4.
    subst.
    exists left.
    exists [s1].
    exact H.
- intros n2 s0 s4 right2 H1.
  inversion H1.
  destruct n2.
  destruct beta.
  + inversion H4.
  + inversion H4.
    subst.
    inversion H1.
    subst.
    clear H H1 H2 H4.
    specialize (IHg_cnf_rules (Lift_r [s1]) s2 s0 (s4 :: right2)).
    specialize (IHg_cnf_rules (eq_refl ([inl (Lift_r [s1]); inl (Lift_r (s2 :: s0 :: s4 :: right2))]))).
    destruct IHg_cnf_rules as [left0 [right1 H]].
    exists left0.
    exists (right1 ++ [s2]).
    rewrite <- app_assoc.
    exact H.
Qed.

Lemma rules_g_cnf_to_rules_g_left:
forall g: cfg _ _,
forall s1: sf,
forall s2: sf',
g_cnf_rules g (Lift_r s1) s2 ->
(exists t: terminal, s1 = [inr t]
  /\ exists left s1 s2, rules g left (s1++[inr t]++s2)
) \/
(exists n: non_terminal, s1 = [inl n]
  /\ exists right, rules g n right
) \/
(exists left: non_terminal,
 exists right s3 s4: sf,
 rules g left right /\
 right = s3 ++ s1 ++ s4).
Proof.
intros g s1 s2 H.
inversion H.
- subst.
  left.
  exists t.
  split; [reflexivity|].
  eauto.
- subst.
  right.
  left.
  exists left.
  split; [reflexivity|eauto].
- subst.
  right.
  left.
  exists left.
  split; [reflexivity|eauto].
- subst.
  right.
  right.
  apply rules_g_cnf_to_rules_g_right in H1.
  destruct H1 as [left0 [right1 H1]].
  exists left0.
  exists (right1 ++ s3 :: s4 :: beta).
  exists right1.
  exists (@nil (non_terminal + terminal)).
  split.
  + exact H1.
  + rewrite app_nil_r.
    reflexivity.
Qed.

Lemma g_cnf_right_formats:
forall g: cfg _ _,
forall left: non_terminal',
forall right: sf',
g_cnf_rules g left right ->
(exists t: terminal, right = [inr t]) \/
(exists s1: symbol,
 exists s: sf,
 right = [inl (Lift_r [s1]); inl (Lift_r s)]).
Proof.
intros g left right H.
inversion H.
- subst.
  left.
  exists t.
  reflexivity.
- subst.
  left.
  exists t.
  reflexivity.
- subst.
  right.
  destruct s1.
  + exists (inl terminal n).
    exists (s2 :: beta).
    simpl.
    reflexivity.
  + exists (inr non_terminal t).
    exists (s2 :: beta).
    simpl.
    reflexivity.
- subst.
  right.
  destruct s2.
  + exists (inl terminal n).
    exists (s3 :: beta).
    simpl.
    reflexivity.
  + exists (inr non_terminal t).
    exists (s3 :: beta).
    simpl.
    reflexivity.
Qed.

Lemma is_cnf_right_formats_v1:
forall g: cfg non_terminal' terminal,
forall left: non_terminal',
forall right: sf',
is_cnf g ->
rules g left right ->
(exists t: terminal, right = [inr t]) \/
(exists s1 s2: sf,
 right = [inl (Lift_r s1); inl (Lift_r s2)]).
Proof.
intros g left right H1 H2.
specialize (H1 left right H2).
destruct H1 as [H1 | H1].
- destruct H1 as [s1 [s2 H1]].
  right.
  destruct s1, s2.
  exists l.
  exists l0.
  exact H1.
- destruct H1 as [t H1].
  left.
  exists t.
  exact H1.
Qed.

Lemma cnf_rules_not_empty:
forall g: cfg _ _,
forall n: non_terminal,
forall s: sf,
is_cnf g \/ is_cnf_with_empty_rule g ->
n <> start_symbol g ->
rules g n s ->
s <> [].
Proof.
intros g n s H1 H2 H3.
destruct H1 as [H1 | H1].
- specialize (H1 n s H3).
  destruct H1 as [H1 | H1].
  + destruct H1 as [s1 [s2 H1]].
    rewrite H1.
    apply not_eq_sym.
    apply nil_cons.
  + destruct H1 as [t H1].
    rewrite H1.
    apply not_eq_sym.
    apply nil_cons.
- specialize (H1 n s H3).
  destruct H1 as [H1 | H1].
  + destruct H1 as [H1 _].
    contradiction.
  + destruct H1 as [H1 | H1].
    * destruct H1 as [s1 [s2 H1]].
      rewrite H1.
      apply not_eq_sym.
      apply nil_cons.
    * destruct H1 as [t H1].
      rewrite H1.
      apply not_eq_sym.
      apply nil_cons.
Qed.

Lemma cnf_derives_not_empty:
forall g: cfg _ _,
forall s1 s2: sf,
is_cnf g \/ is_cnf_with_empty_rule g ->
start_symbol_not_in_rhs g ->
~ In (inl (start_symbol g)) s1 ->
s1 <> [] ->
derives g s1 s2 ->
s2 <> [].
Proof.
intros g s1 s2 H1 H2 H3 H4 H5.
apply derives_equiv_derives6 in H5.
destruct H5 as [n0 H5].
revert s1 s2 H3 H4 H5.
induction n0.
- intros n s H3 H4 H5.
  inversion H5.
  subst.
  exact H4.
- intros s1 s2 H3 H4 H5.
  inversion H5.
  subst.
  clear H4 H5.
  specialize (IHn0 (s0 ++ right ++ s3) s2).
  assert (H7: ~ In (inl (start_symbol g)) (s0 ++ right ++ s3)).
    {
    intros H4.
    apply H3.
    apply in_app_or in H4.
    destruct H4 as [H4 | H4].
    - apply in_or_app.
      left.
      exact H4.
    - apply in_app_or in H4.
      destruct H4 as [H4 | H4].
      + specialize (H2 left right H0).
        contradiction.
      + apply in_or_app.
        right.
        apply in_or_app.
        right.
        exact H4.
    }
  assert (H8: right <> []).
    {
    destruct H1 as [H1 | H1].
    - specialize (H1 left right H0).
      destruct H1 as [H1 | H1].
      + destruct H1 as [s1' [s2' H1]].
        rewrite H1.
        apply not_eq_sym.
        apply nil_cons.
      + destruct H1 as [t H1].
        rewrite H1.
        apply not_eq_sym.
        apply nil_cons.
    - specialize (H1 left right H0).
      destruct H1 as [H1 | H1].
      + destruct H1 as [H1a H1b].
        subst.
        intros _.
        apply H3.
        apply in_or_app.
        right.
        simpl.
        left.
        reflexivity.
      + destruct H1 as [H1 | H1].
        * destruct H1 as [s1' [s2' H1]].
          rewrite H1.
          apply not_eq_sym.
          apply nil_cons.
        * destruct H1 as [t H1].
          rewrite H1.
          apply not_eq_sym.
          apply nil_cons.
    }
  assert (H9: s0 ++ right ++ s3 <> []).
    {
    apply app_not_nil_inv.
    right.
    apply app_not_nil_inv.
    left.
    exact H8.
    }
  specialize (IHn0 H7 H9 H6).
  exact IHn0.
Qed.

(*
Lemma cnf_derives_not_empty_v2:
forall g: cfg _ _,
forall s1 s2: sf,
is_cnf g \/ is_cnf_with_empty_rule g ->
start_symbol_not_in_rhs g ->
~ In (inl (start_symbol g)) s1 ->
s1 <> [] ->
derives g s1 s2 ->
s2 <> [].
Proof.
intros g s1 s2 H1 H2 H3 H4 H5.
destruct s1.
- destruct H3.
  destruct H4.
  reflexivity.
- change (s :: s1) with ([s] ++ s1) in H5.
  apply derives_split in H5.
  destruct H5 as [s1' [s2' [H5 [H6 H7]]]].
  destruct s.
  + apply cnf_derives_not_empty_v1 in H6.
    * {
      destruct s1'.
      - destruct H6.
        reflexivity.
      - rewrite H5.
        apply app_not_nil_inv.
        left.
        apply not_eq_sym.
        apply nil_cons.
      }
    * exact H1.
    * exact H2.
    * intros H8.
      apply H3.
      rewrite H8.
      simpl.
      left.
      reflexivity.
  + change [inr t] with (map (@inr non_terminal terminal) [t]) in H6.
    apply derives_sentence_left in H6.
    rewrite H6 in H5.
    rewrite H5.
    simpl.
    apply not_eq_sym.
    apply nil_cons.
Qed.
*)

Lemma is_cnf_right_formats_v2:
forall g: cfg non_terminal' terminal,
forall left: non_terminal',
forall right: sf',
is_cnf g \/ is_cnf_with_empty_rule g ->
rules g left right ->
right <> [] ->
(exists t: terminal, right = [inr t]) \/
(exists s1 s2: sf,
 right = [inl (Lift_r s1); inl (Lift_r s2)]).
Proof.
intros g left right H1 H2 H3.
destruct H1 as [H1 | H1].
- specialize (H1 left right H2).
  destruct H1 as [H1 | H1].
  + destruct H1 as [s1 [s2 H1]].
    right.
    destruct s1, s2.
    exists l.
    exists l0.
    exact H1.
  + destruct H1 as [t H1].
    left.
    exists t.
    exact H1.
- specialize (H1 left right H2).
  destruct H1 as [H1 | H1].
  + destruct H1 as [H1 H4].
    contradiction.
  + destruct H1 as [H1 | H1].
    * destruct H1 as [s1 [s2 H1]].
      right.
      destruct s1, s2.
      exists l l0.
      exact H1.
    * destruct H1 as [t H1].
      left.
      exists t.
      exact H1.
Qed.

Lemma g_cnf_finite:
forall g: cfg non_terminal terminal,
exists n: nat,
exists ntl: ntlist',
exists tl: tlist,
In (Lift_r [inl (start_symbol g)]) ntl /\
forall left: non_terminal',
forall right: sf',
g_cnf_rules g left right ->
(length right <= n) /\
(In left ntl) /\
(forall s: non_terminal', In (inl s) right -> In s ntl) /\
(forall s: terminal, In (inr s) right -> In s tl).
Proof.
intros g.
destruct (rules_finite g) as [n [ntl [tl H1]]].
exists 2.
exists (all_nts_up_to (S n) (map non_terminal_lift ntl ++ map term_lift tl)).
exists tl.
split.
- (* start_symbol is in the list *)
  destruct H1 as [H1 _].
  apply all_nts_up_to_correct.
  + intros e H2.
    simpl in H2.
    destruct H2 as [H2 | H2].
    * subst.
      apply in_or_app.
      left.
      apply in_map.
      exact H1.
    * contradiction.
  + simpl.
    omega.
- split.
  + (* length rhs <= 2 *)
    inversion H.
    * simpl.
      omega.
    * simpl.
      omega.
    * simpl.
      omega.
    * simpl.
      omega.
  + split.
    * (* non-terminals in the lhs are in the list *)
      destruct left.
      {
      apply all_nts_up_to_correct.
      - intros e H2.
        apply rules_g_cnf_to_rules_g_left in H.
        destruct H as [H | [H | H]].
        + destruct H as [t [H [left [s1 [s2 Hg]]]]].
          subst.
          simpl in H2.
          destruct H2 as [H2 | H2].
          * subst.
            apply in_or_app; right.
            apply in_map.
            destruct H1 as [_ H1].
            specialize (H1 left (s1 ++ [inr t] ++ s2) Hg).
            apply H1.
            apply in_or_app.
            right.
            simpl.
            left.
            reflexivity.
          * contradiction.
        + destruct H as [n0 [H [r Hright]]].
          subst.
          simpl in H2.
          destruct H2 as [H2 | H2].
          * subst.
            unfold rules_finite_def in H1.
            apply in_or_app; left.
            apply in_map.
            destruct H1 as [_ H1].
            specialize (H1 n0 r Hright).
            destruct H1 as [_ [H1 _]].
            exact H1.
          * contradiction.
        + destruct H as [left [right0 [s3 [s4 [H3 H4]]]]].
          apply in_split in H2.
          destruct H2 as [l1 [l2 H2]].
          subst.
          rewrite <- app_assoc in H3.
          unfold rules_finite_def in H1.
          destruct H1 as [_ H1].
          specialize (H1 left (s3 ++ l1 ++ (e :: l2) ++ s4) H3).
          destruct H1 as [_ [_ [H1 H2]]].
          destruct e.
          * apply in_or_app.
            left.
            apply in_map.
            apply H1.
            apply in_or_app.
            right.
            apply in_or_app.
            right.
            simpl.
            left.
            reflexivity.
          * apply in_or_app.
            right.
            apply in_map.
            apply H2.
            apply in_or_app.
            right.
            apply in_or_app.
            right.
            simpl.
            left.
            reflexivity.
      - apply rules_g_cnf_to_rules_g_left in H.
        destruct H as [H | [H | H]].
        + destruct H as [t [H _]].
          subst.
          simpl.
          omega.
        + destruct H as [n0 [H _]].
          subst.
          simpl.
          omega.
        + destruct H as [left [right0 [s3 [s4 [H H2]]]]].
          subst.
          unfold rules_finite_def in H1.
          destruct H1 as [_ H1].
          specialize (H1 left (s3 ++ l ++ s4) H).
          destruct H1 as [H1 _].
          repeat rewrite app_length in H1.
          omega.
      }
    * {
      split.
      - (* non-terminals in the rhs are in the list *)
        destruct H1 as [_ H1].
        inversion H.
        + subst.
          intros s H2.
          simpl in H2.
          destruct H2 as [H2 | H2].
          * inversion H2.
          * contradiction.
        + subst.
          intros s H2.
          simpl in H2.
          destruct H2 as [H2 | H2].
          * inversion H2.
          * contradiction.
        + subst.
          intros s H2.
          simpl in H2.
          destruct H2 as [H2 | [H2 | H2]].
          * inversion H2.
            {
            apply all_nts_up_to_correct.
            - intros e H5.
              destruct e, s1.
              + simpl in H5.
                destruct H5 as [H5 | H5].
                * inversion H5.
                  subst.
                  apply in_or_app.
                  left.
                  apply in_map.
                  specialize (H1 left0 (inl n0 :: s2 :: beta) H0).
                  destruct H1 as [_ [_ [H1 _]]].
                  apply H1.
                  simpl.
                  left.
                  reflexivity.
                * contradiction.
              + simpl in H5.
                destruct H5 as [H5 | H5].
                * inversion H5.
                * contradiction.
              + simpl in H5.
                destruct H5 as [H5 | H5].
                * inversion H5.
                * contradiction.
              + simpl in H5.
                destruct H5 as [H5 | H5].
                * inversion H5.
                  subst.
                  apply in_or_app.
                  right.
                  apply in_map.
                  specialize (H1 left0 (inr t :: s2 :: beta) H0).
                  destruct H1 as [_ [_ [_ H1]]].
                  apply H1.
                  simpl.
                  left.
                  reflexivity.
                * contradiction.
            - simpl.
              omega.
            }
          * inversion H2.
            {
            apply all_nts_up_to_correct.
            - intros e H3.
              simpl in H3.
              destruct H3 as [H3 | H3].
              + subst.
                destruct e.
                * apply in_or_app.
                  left.
                  apply in_map.
                  specialize (H1 left0 (s1 :: inl n0 :: beta) H0).
                  destruct H1 as [_ [_ [H1 _]]].
                  apply H1.
                  simpl.
                  right.
                  left.
                  reflexivity.
                * apply in_or_app.
                  right.
                  apply in_map.
                  specialize (H1 left0 (s1 :: inr t :: beta) H0).
                  destruct H1 as [_ [_ [_ H1]]].
                  apply H1.
                  simpl.
                  right.
                  left.
                  reflexivity.
              + apply in_split in H3.
                destruct H3 as [l1 [l2 H3]].
                subst.
                apply in_or_app.
                destruct e.
                * left.
                  apply in_map.
                  specialize (H1 left0 (s1 :: s2 :: l1 ++ inl n0 :: l2) H0).
                  destruct H1 as [_ [_ [H1 _]]].
                  apply H1.
                  simpl.
                  right.
                  right.
                  apply in_or_app.
                  right.
                  simpl.
                  left.
                  reflexivity.
                * right.
                  apply in_map.
                  specialize (H1 left0 (s1 :: s2 :: l1 ++ inr t :: l2) H0).
                  destruct H1 as [_ [_ [_ H1]]].
                  apply H1.
                  simpl.
                  right.
                  right.
                  apply in_or_app.
                  right.
                  simpl.
                  left.
                  reflexivity.
            - specialize (H1 left0 (s1 :: s2 :: beta) H0).
              destruct H1 as [H1 _].
              simpl in H1.
              simpl.
              omega.
            }
          * contradiction.
        + apply rules_g_cnf_to_rules_g_right in H0.
          destruct H0 as [left1 [right1 H0]].
          intros s H4.
          simpl in H4.
          destruct H4 as [H4 | [H4 | H4]].
          * inversion H4.
            {
            apply all_nts_up_to_correct.
            - intros e H7.
              destruct e, s2.
              + apply in_or_app.
                left.
                apply in_map.
                simpl in H7.
                destruct H7 as [H7 | H7].
                * inversion H7.
                  subst.
                  specialize (H1 left1 (right1 ++ inl n0 :: s3 :: beta) H0).
                  destruct H1 as [_ [_ [H1 _]]].
                  apply H1.
                  apply in_or_app.
                  right.
                  simpl.
                  left.
                  reflexivity.
                * contradiction.
              + simpl in H7.
                destruct H7 as [H7 | H7].
                * inversion H7.
                * contradiction.
              + simpl in H7.
                destruct H7 as [H7 | H7].
                * inversion H7.
                * contradiction.
              + simpl in H7.
                destruct H7 as [H7 | H7].
                * inversion H7.
                  subst.
                  apply in_or_app.
                  right.
                  specialize (H1 left1 (right1 ++ inr t :: s3 :: beta) H0).
                  destruct H1 as [_ [_ [_ H1]]].
                  apply in_map.
                  apply H1.
                  apply in_or_app.
                  right.
                  simpl.
                  left.
                  reflexivity.
                * contradiction.
            - simpl.
              omega.
            }
          * inversion H4.
            {
            apply all_nts_up_to_correct.
            - intros e H7.
              destruct e.
              + apply in_or_app.
                left.
                apply in_map.
                simpl in H7.
                destruct H7 as [H7 | H7].
                * {
                  destruct s3.
                  - inversion H7.
                    subst.
                    specialize (H1 left1 (right1 ++ s2 :: inl n0 :: beta) H0).
                    destruct H1 as [_ [_ [H1 _]]].
                    apply H1.
                    apply in_or_app.
                    right.
                    simpl.
                    right.
                    left.
                    reflexivity.
                  - inversion H7.
                  }
                * apply in_split in H7.
                  destruct H7 as [l1 [l2 H7]].
                  subst.
                  specialize (H1 left1 (right1 ++ s2 :: s3 :: l1 ++ inl n0 :: l2) H0).
                  destruct H1 as [_ [_ [H1 _]]].
                  apply H1.
                  apply in_or_app.
                  right.
                  simpl.
                  right.
                  right.
                  apply in_or_app.
                  right.
                  simpl.
                  left.
                  reflexivity.
              + apply in_or_app.
                right.
                apply in_map.
                simpl in H7.
                destruct H7 as [H7 | H7].
                * {
                  destruct s3.
                  - inversion H7.
                  - inversion H7.
                    subst.
                    specialize (H1 left1 (right1 ++ s2 :: inr t :: beta) H0).
                    destruct H1 as [_ [_ [_ H1]]].
                    apply H1.
                    apply in_or_app.
                    right.
                    simpl.
                    right.
                    left.
                    reflexivity.
                  }
                * apply in_split in H7.
                  destruct H7 as [l1 [l2 H7]].
                  subst.
                  specialize (H1 left1 (right1 ++ s2 :: s3 :: l1 ++ inr t :: l2) H0).
                  destruct H1 as [_ [_ [_ H1]]].
                  apply H1.
                  apply in_or_app.
                  right.
                  simpl.
                  right.
                  right.
                  apply in_or_app.
                  right.
                  simpl.
                  left.
                  reflexivity.
            - simpl.
              specialize (H1 left1 (right1 ++ s2 :: s3 :: beta) H0).
              destruct H1 as [H1 _].
              rewrite app_length in H1.
              simpl in H1.
              omega.
            }
          * contradiction.
      - (* terminals in the rhs are in the list *)
        destruct H1 as [_ H1].
        inversion H.
        + subst.
          intros s H2.
          simpl in H2.
          destruct H2 as [H2 | H2].
          * inversion H2.
            subst.
            specialize (H1 left0 (s1 ++ [inr s] ++ s2) H0).
            apply H1.
            apply in_or_app.
            right.
            simpl.
            left.
            reflexivity.
          * contradiction.
        + subst.
          intros s H2.
          simpl in H2.
          destruct H2 as [H2 | H2].
          * inversion H2.
            subst.
            specialize (H1 left0 [inr s] H0).
            destruct H1 as [_ [_ [_ H1]]].
            apply H1.
            simpl.
            left.
            reflexivity.
          * contradiction.
        + intros s H4.
          simpl in H4.
          destruct H4 as [H4 | [H4 | H4]].
          * inversion H4.
          * inversion H4.
          * contradiction.
        + intros s H4.
          simpl in H4.
          destruct H4 as [H4 | [H4 | H4]].
          * inversion H4.
          * inversion H4.
          * contradiction.
      }
Qed.

Definition g_cnf (g: cfg non_terminal terminal): cfg non_terminal' terminal := {|
start_symbol:= Lift_r [inl (start_symbol g)];
rules:= g_cnf_rules g;
t_eqdec:= t_eqdec g;
nt_eqdec:= nt_eqdec' (t_eqdec g) (nt_eqdec g);
rules_finite:= g_cnf_finite g
|}.

Inductive g_cnf'_rules (g: cfg non_terminal terminal): non_terminal' -> sf' -> Prop:=
| Lift_cnf'_all:
       forall left: non_terminal',
       forall right: sf',
       g_cnf_rules g left right ->
       g_cnf'_rules g left right
| Lift_cnf'_new:
       g_cnf'_rules g (start_symbol (g_cnf g)) [].

Lemma g_cnf'_finite:
forall g: cfg non_terminal terminal,
exists n: nat,
exists ntl: ntlist',
exists tl: tlist,
In (Lift_r [inl (start_symbol g)]) ntl /\
forall left: non_terminal',
forall right: sf',
g_cnf'_rules g left right ->
(length right <= n) /\
(In left ntl) /\
(forall s: non_terminal', In (inl s) right -> In s ntl) /\
(forall s: terminal, In (inr s) right -> In s tl).
Proof.
intros g.
destruct (rules_finite (g_cnf g)) as [n [ntl [tl H1]]].
destruct H1 as [H H1].
exists n.
exists ntl.
exists tl.
split.
- simpl in H.
  exact H.
- intros left right H2.
  inversion H2.
  + subst.
    specialize (H1 left right H0).
    destruct H1 as [H1 [H3 [H4 H5]]].
    split.
    * exact H1.
    * {
      split.
      - exact H3.
      - split.
        + exact H4.
        + exact H5.
      }
  + subst.
    split.
    * simpl.
      omega.
    * {
      split.
      - exact H.
      - split.
        + intros s H3.
          simpl in H3.
          contradiction.
        + intros s H3.
          simpl in H3.
          contradiction.
      }
Qed.

Definition g_cnf' (g: cfg non_terminal terminal) : cfg non_terminal' terminal:= {|
start_symbol:= start_symbol (g_cnf g);
rules:= g_cnf'_rules g;
t_eqdec:= t_eqdec g;
nt_eqdec:= nt_eqdec' (t_eqdec g) (nt_eqdec g);
rules_finite:= g_cnf'_finite g
|}.

End Chomsky_Definitions_2.

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

Section Chomsky_1_Lemmas.

Variables non_terminal non_terminal_1 non_terminal_2 terminal: Type.

Notation sf := (list (non_terminal + terminal)).
Notation sentence := (list terminal).
Notation ntlist:= (list non_terminal).
Notation term_lift:= ((terminal_lift non_terminal) terminal).
Notation term_lift':= ((terminal_lift (non_terminal' non_terminal terminal)) terminal).
Notation symbol:= (non_terminal + terminal)%type.
Notation slist:= (list sf).
Notation vlist:= (list symbol).
Notation sf':= (list (non_terminal' non_terminal terminal + terminal)).
Notation ntlist':= (list non_terminal').
Notation tlist:= (list terminal).

Fixpoint flat_sf (l: sf'): sf :=
match l with
| nil => nil
| inl (Lift_r x) :: xs => x ++ flat_sf xs
| inr x :: xs => inr x :: flat_sf xs
end.

Lemma flat_sf_cat:
forall l1 l2: sf',
flat_sf (l1 ++ l2) = flat_sf l1 ++ flat_sf l2.
Proof.
induction l1.
- intros l2.
  simpl.
  reflexivity.
- intros l2.
  destruct a.
  + destruct n.
    simpl.
    rewrite IHl1.
    rewrite <- app_assoc.
    reflexivity.
  + simpl.
    rewrite IHl1.
    reflexivity.
Qed.

Lemma flat_sf_symbol_lift:
forall l: sf,
flat_sf (map (@symbol_lift _ _) l) = l.
Proof.
induction l.
- simpl.
  reflexivity.
- destruct a.
  + simpl.
    rewrite IHl.
    reflexivity.
  + simpl.
    rewrite IHl.
    reflexivity.
Qed.

Lemma derives_g_cnf_g_aux:
forall g: cfg _ _,
forall l r: sf',
derives (g_cnf g) l r ->
derives g (flat_sf l) (flat_sf r).
Proof.
induction 1.
- apply derives_refl.
- inversion H0.
  + subst.
    repeat rewrite flat_sf_cat in *.
    simpl in *.
    exact IHderives.
  + subst.
    repeat rewrite flat_sf_cat in *.
    simpl in *.
    change (inr t :: flat_sf s3) with ([inr t] ++ flat_sf s3).
    apply derives_trans with (s2:= (flat_sf s2 ++ inl left0 :: flat_sf s3)).
    * exact IHderives.
    * change (flat_sf s2 ++ inl left0 :: flat_sf s3) with (flat_sf s2 ++ [inl left0] ++ flat_sf s3).
      {
      apply derives_subs with (s3:= [inl left0]).
      - apply derives_refl.
      - apply derives_start.
        exact H1.
      }
  + subst.
    repeat rewrite flat_sf_cat in *.
    simpl in *.
    rewrite app_nil_r.
    change (s0 :: s4 :: beta ++ flat_sf s3) with ((s0 :: s4 :: beta) ++ flat_sf s3).
    apply derives_trans with (s2:= (flat_sf s2 ++ inl left0 :: flat_sf s3)).
    * exact IHderives.
    * change (flat_sf s2 ++ inl left0 :: flat_sf s3) with (flat_sf s2 ++ [inl left0] ++ flat_sf s3).
      {
      apply derives_subs with (s3:= [inl left0]).
      - apply derives_refl.
      - apply derives_start.
        exact H1.
      }
  + subst.
    repeat rewrite flat_sf_cat in *.
    simpl in *.
    rewrite app_nil_r.
    exact IHderives.
Qed.

Lemma derives_g_cnf_g:
forall g: cfg _ _,
forall s: sentence,
derives (g_cnf g) [inl (start_symbol (g_cnf g))] (map (@symbol_lift _ _) (map term_lift s)) ->
derives g [inl (start_symbol g)] (map term_lift s).
Proof.
intros g s H.
apply derives_g_cnf_g_aux in H.
simpl in H.
rewrite flat_sf_symbol_lift in H.
exact H.
Qed.

Lemma rules_g_derives_g_cnf:
forall g: cfg _ _,
forall left: non_terminal,
forall right: sf,
has_no_unit_rules g ->
right <> [] ->
rules g left right ->
derives (g_cnf g) [inl (Lift_r [inl left])] (map (@symbol_lift _ _) right).
Proof.
intros g left right H1 H2 H3.
destruct right.
- destruct H2.
  reflexivity.
- destruct right.
  + destruct s.
    * specialize (H1 left n [inl n] H3).
      destruct H1.
      reflexivity.
    * simpl.
      apply Lift_cnf_1 in H3.
      apply derives_start.
      exact H3.
  + apply Lift_cnf_2 in H3.
    generalize H3.
    clear H1 H2 H3.
    simpl.
    generalize s s0 [inl terminal left].
    clear s s0 left.
    elim right.
    * simpl.
      {
      destruct s, s0.
      - intros l H.
        apply derives_start.
         exact H.
      - intros l H.
        apply derives_trans with (s2:= [inl (Lift_r [inl n]); inl (Lift_r [inr t])]).
        + apply derives_start.
           exact H.
        + change ([inl (Lift_r [inl n]); inl (Lift_r [inr t])]) with ([inl (Lift_r [inl n])] ++ [inl terminal (Lift_r [inr t])]).
          change ([symbol_lift (inl n); symbol_lift (inr t)]) with ([symbol_lift (inl n)] ++ [symbol_lift (inr t)]).
          apply derives_combine.
          split.
          * simpl.
            apply derives_refl.
          * simpl.
            apply derives_start.
            {
            inversion H.
            - subst.
              apply Lift_cnf_t with (left:= left) (s1:= [inl n]) (s2:= []).
              exact H2.
            - subst.
              apply rules_g_cnf_to_rules_g_left in H.
              destruct H as [H | [H | H]].
              + destruct H as [t' [H _]].
                inversion H.
              + destruct H as [nt' [H _]].
                inversion H.
              + destruct H as [left0 [right0 [s3 [s4 [H3 H4]]]]].
                subst.
                apply Lift_cnf_t with (left:= left0) (s1:= s3 ++ [inl n]) (s2:= s4).
                rewrite <- app_assoc.
                exact H3.
            }
      - intros l H.
        apply derives_trans with (s2:= [inl (Lift_r [inr t]); inl (Lift_r [inl n])]).
        + apply derives_start.
          exact H.
        + change ([inl (Lift_r [inr t]); inl (Lift_r [inl n])]) with ([inl (Lift_r [inr t])] ++ [inl terminal (Lift_r [inl n])]).
          change ([symbol_lift (inr t); symbol_lift (inl n)]) with ([symbol_lift (inr t)] ++ [symbol_lift (inl n)]).
          apply derives_combine.
          split.
          * simpl.
            apply derives_start.
            {
            inversion H.
            - subst.
              apply Lift_cnf_t with (left:= left) (s1:= []) (s2:= [inl n]).
              exact H2.
            - subst.
              apply rules_g_cnf_to_rules_g_left in H.
              destruct H as [H | [H | H]].
              + destruct H as [t0 [H _]].
                inversion H.
              + destruct H as [n0 [H _]].
                inversion H.
              + destruct H as [left0 [right0 [s3 [s4 [H3 H4]]]]].
                subst.
                apply Lift_cnf_t with (left:= left0) (s1:= s3) (s2:= [inl n] ++ s4).
                simpl.
                exact H3.
            }
          * simpl.
            apply derives_refl.
      - intros l H.
        apply derives_trans with (s2:= [inl (Lift_r [inr t]); inl (Lift_r [inr t0])]).
        + apply derives_start.
          exact H.
        + change ([inl (Lift_r [inr t]); inl (Lift_r [inr t0])]) with ([inl (Lift_r [inr t])] ++ [inl terminal (Lift_r [inr non_terminal t0])]).
          change ([symbol_lift (inr t); symbol_lift (inr t0)]) with ([symbol_lift (inr t)] ++ [symbol_lift (inr non_terminal t0)]).
          apply derives_combine.
          split.
          * simpl.
            apply derives_start.
            {
            inversion H.
            - subst.
              apply Lift_cnf_t with (left:= left) (s1:= []) (s2:= [inr t0]).
              exact H2.
            - subst.
              apply rules_g_cnf_to_rules_g_left in H.
              destruct H as [H | [H | H]].
              + destruct H as [t1 [H _]].
                inversion H.
              + destruct H as [n [H _]].
                inversion H.
              + destruct H as [left0 [right0 [s3 [s4 [H3 H4]]]]].
                subst.
                apply Lift_cnf_t with (left:= left0) (s1:= s3) (s2:= [inr t0] ++ s4).
                simpl.
                exact H3.
            }
          * simpl.
            apply derives_start.
            {
            inversion H.
            - subst.
              apply Lift_cnf_t with (left:= left) (s1:= [inr t]) (s2:= []).
              exact H2.
            - subst.
              apply rules_g_cnf_to_rules_g_left in H.
              destruct H as [H | [H | H]].
              + destruct H as [t1 [H _]].
                inversion H.
              + destruct H as [n [H _]].
                inversion H.
              + destruct H as [left0 [right0 [s3 [s4 [H3 H4]]]]].
                subst.
                apply Lift_cnf_t with (left:= left0) (s1:= s3 ++ [inr t]) (s2:= s4).
                rewrite <- app_assoc.
                exact H3.
            }
      }
    * intros a l H s s0 l0 H0.
      {
      apply derives_trans with (s2:= [inl (Lift_r [s]); inl (Lift_r (s0 :: a :: l))]).
      - apply derives_start.
        exact H0.
      - simpl.
        change [inl (Lift_r [s]); inl (Lift_r (s0 :: a :: l))] with ([inl (Lift_r [s])]++[inl terminal (Lift_r (s0 :: a :: l))]).
        change (symbol_lift s :: symbol_lift s0 :: symbol_lift a :: map (symbol_lift (terminal:=terminal)) l) with ([symbol_lift s]++(symbol_lift s0 :: symbol_lift a :: map (symbol_lift (terminal:=terminal)) l)).
        apply derives_combine.
        split.
        + destruct s.
          * simpl.
            apply derives_refl.
          * simpl.
            apply derives_start.
            {
            inversion H0.
            - subst.
              apply Lift_cnf_t with (left:= left) (s1:= []) (s2:= s0 :: a :: l).
              exact H3.
            - subst.
              apply rules_g_cnf_to_rules_g_left in H0.
              destruct H0 as [H0 | [H0 | H0]].
              + destruct H0 as [t0 [H0 _]].
                inversion H0.
              + destruct H0 as [n [H0 _]].
                inversion H0.
              + destruct H0 as [left0 [right0 [s3 [s4 [H4 H5]]]]].
                subst.
                apply Lift_cnf_t with (left:= left0) (s1:= s3) (s2:= s0 :: a :: l ++ s4).
                exact H4.
            }
        + apply H.
          apply Lift_cnf_3 in H0.
          exact H0.
      }
Qed.

Lemma derives_g_g_cnf_v1:
forall g: cfg _ _,
forall s: sf,
has_no_unit_rules g ->
has_no_empty_rules g ->
derives g [inl (start_symbol g)] s ->
derives (g_cnf g) [inl (start_symbol (g_cnf g))] (map (@symbol_lift _ _) s).
Proof.
intros g s H1 H2 H3.
remember [inl (start_symbol g)] as w.
induction H3.
- rewrite Heqw.
  simpl.
  constructor.
- specialize (IHderives Heqw).
  apply derives_trans with (s2:= (map (symbol_lift (terminal:=terminal)) (s2 ++ inl left :: s3))).
  + exact IHderives.
  + clear Heqw H3 IHderives.
    apply rules_g_derives_g_cnf in H.
    * repeat rewrite map_app.
      apply derives_context_free_add_left.
      change (inl left :: s3) with ([inl left] ++ s3).
      rewrite map_app.
      apply derives_context_free_add_right.
      exact H.
    * exact H1.
    * specialize (H2 left right H).
      exact H2.
Qed.

Lemma derives_g_g_cnf_v2:
forall g: cfg _ _,
forall s: sf,
has_no_unit_rules g ->
has_one_empty_rule g ->
s <> [] ->
start_symbol_not_in_rhs g ->
derives g [inl (start_symbol g)] s ->
derives (g_cnf g) [inl (start_symbol (g_cnf g))] (map (@symbol_lift _ _) s).
Proof.
intros g s H1 H2 H3 H4 H5.
remember [inl (start_symbol g)] as w.
induction H5.
- rewrite Heqw.
  simpl.
  constructor.
- assert (H6: s2 ++ inl left :: s3 <> []).
    {
    apply not_eq_sym.
    apply app_cons_not_nil.
    }
  specialize (IHderives H6 Heqw).
  apply derives_trans with (s2:= (map (symbol_lift (terminal:=terminal)) (s2 ++ inl left :: s3))).
  + exact IHderives.
  + clear H6 IHderives.
    assert (H6:= H2).
    specialize (H6 left right H).
    destruct H6 as [H6 | H7].
    * destruct H6 as [H6 H7].
      subst.
      {
      apply not_derives_start_symbol in H5.
      - destruct H5.
        apply in_or_app.
        right.
        simpl.
        left.
        reflexivity.
      - exact H4.
      - simpl in H3.
        apply app_not_nil in H3.
        destruct H3 as [H3 | H3].
        + intros H6.
          destruct s2.
          * destruct H3.
            reflexivity.
          * inversion H6.
            {
            destruct s2.
            - inversion H8.
            - inversion H8.
            }
        + intros H6.
          destruct s2.
          * inversion H6.
            subst.
            destruct H3.
            reflexivity.
          * inversion H6.
            {
            destruct s2.
            - inversion H8.
            - inversion H8.
            }
      }
    * repeat rewrite map_app.
      apply derives_context_free_add_left.
      change (inl left :: s3) with ([inl left] ++ s3).
      rewrite map_app.
      apply derives_context_free_add_right.
      {
      apply rules_g_derives_g_cnf in H.
      - exact H.
      - exact H1.
      - exact H7.
      }
Qed.

Lemma map_split:
forall s: sentence,
map ((terminal_lift (non_terminal' _ _)) terminal) s = map (@symbol_lift _ _) (map ((terminal_lift non_terminal) terminal) s).
Proof.
intros s.
induction s.
- simpl.
  reflexivity.
- simpl.
  change (terminal_lift (non_terminal' _ _) a) with (@inr (non_terminal' non_terminal terminal) terminal a).
  apply app_eq.
  exact IHs.
Qed.

Lemma remove_empty_rule:
forall g: cfg non_terminal terminal,
forall s: sentence,
s <> [] ->
derives g [inl (start_symbol g)] (map term_lift s) ->
exists g': cfg (emptyrules.non_terminal' non_terminal) terminal,
g_equiv_without_empty g' g /\
has_no_unit_rules g' /\
has_no_empty_rules g'.
Proof.
intros g s H1 H2.
assert (H3: exists s: sentence, produces g s /\ s <> []).
  {
  exists s.
  exact (conj H2 H1).
  }
apply g_simpl_exists_v2 in H3.
destruct H3 as [g' [H3 [_ [_ [H4 [H5 _]]]]]].
exists g'.
exact (conj H3 (conj H5 H4)).
Qed.

End Chomsky_1_Lemmas.

Section Chomsky_2_Lemmas.

Variables non_terminal non_terminal_1 non_terminal_2 terminal: Type.

Notation sf := (list (non_terminal + terminal)).
Notation sentence := (list terminal).
Notation ntlist:= (list non_terminal).
Notation term_lift:= ((terminal_lift non_terminal) terminal).
Notation symbol:= (non_terminal + terminal)%type.
Notation slist:= (list sf).
Notation vlist:= (list symbol).
Notation sf':= (list (non_terminal' non_terminal terminal + terminal)).
Notation ntlist':= (list non_terminal').
Notation tlist:= (list terminal).

Lemma g_cnf_preserves_start:
forall g: cfg non_terminal terminal,
start_symbol_not_in_rhs g ->
start_symbol_not_in_rhs (g_cnf g).
Proof.
unfold start_symbol_not_in_rhs.
intros g H1 left right H2 H3.
simpl in H3.
destruct H2.
- simpl in H3.
  destruct H3 as [H3 | H3].
  + inversion H3.
  + contradiction.
- simpl in H3.
  destruct H3 as [H3 | H3].
  + inversion H3.
  + contradiction.
- specialize (H1 left (s1 :: s2 :: beta) H).
  apply H1.
  destruct H3 as [H3 | [H3 | H3]].
  + simpl.
    left.
    inversion H3.
    reflexivity.
  + inversion H3.
    simpl.
    right.
    left.
    reflexivity.
  + contradiction.
- apply rules_g_cnf_to_rules_g_right in H2.
  destruct H2 as [left0 [right H2]].
  specialize (H1 left0 (right ++ s2 :: s3 :: beta) H2).
  clear H2.
  simpl in H3.
  destruct H3 as [H3 | [H3 | H3]].
  + inversion H3.
    subst.
    apply H1.
    apply in_or_app.
    right.
    simpl.
    left.
    reflexivity.
  + inversion H3.
    subst.
    apply H1.
    apply in_or_app.
    right.
    simpl.
    right.
    left.
    reflexivity.
  + contradiction.
Qed.

Lemma g_cnf'_preserves_start:
forall g: cfg non_terminal terminal,
start_symbol_not_in_rhs g ->
start_symbol_not_in_rhs (g_cnf' g).
Proof.
unfold start_symbol_not_in_rhs.
intros g H1 left right H2 H3.
inversion H2.
- subst.
  clear H2.
  simpl in H3.
  assert (H4: start_symbol_not_in_rhs (g_cnf g)).
    {
    apply g_cnf_preserves_start.
    exact H1.
    }
  specialize (H4 left right H).
  apply in_split in H3.
  apply H4.
  destruct H3 as [l1 [l2 H3]].
  subst.
  simpl.
  apply in_or_app.
  right.
  left.
  reflexivity.
- subst.
  inversion H3.
Qed.

Lemma g_cnf_correct_v1:
forall g: cfg non_terminal terminal,
has_no_unit_rules g /\
has_no_empty_rules g /\
start_symbol_not_in_rhs g ->
is_cnf (g_cnf g) /\
g_equiv_without_empty (g_cnf g) g /\
start_symbol_not_in_rhs (g_cnf g).
Proof.
intros g [H1 [H2 HH]].
split.
- unfold is_cnf.
  intros left right H3.
  simpl in H3.
  inversion H3; subst; unfold is_cnf_rule.
  + right; exists t; reflexivity.
  + right; exists t; reflexivity.
  + left; exists (Lift_r [s1]). exists (Lift_r (s2 :: beta)); reflexivity.
  + left; exists (Lift_r [s2]). exists (Lift_r (s3 :: beta)); reflexivity.
- split.
  + unfold g_equiv_without_empty.
    unfold produces.
    unfold generates.
    intros s H3.
    split.
    * intros H4.
      apply derives_g_cnf_g.
      rewrite map_split in H4.
      exact H4.
    * intros H4.
      rewrite map_split.
      {
      apply derives_g_g_cnf_v1.
      - exact H1.
      - exact H2.
      - exact H4.
      }
  + apply g_cnf_preserves_start.
    exact HH.
Qed.

Lemma g_cnf_correct_v2:
forall g: cfg non_terminal terminal,
has_no_unit_rules g /\
has_one_empty_rule g /\
start_symbol_not_in_rhs g ->
is_cnf (g_cnf g) /\
g_equiv_without_empty (g_cnf g) g /\
start_symbol_not_in_rhs (g_cnf g).
Proof.
intros g [H1 [H2 HH]].
split.
- unfold is_cnf.
  intros left right H3.
  simpl in H3.
  inversion H3; subst; unfold is_cnf_rule.
  + right; exists t; reflexivity.
  + right; exists t; reflexivity.
  + left; exists (Lift_r [s1]). exists (Lift_r (s2 :: beta)); reflexivity.
  + left; exists (Lift_r [s2]). exists (Lift_r (s3 :: beta)); reflexivity.
- split.
  + unfold g_equiv_without_empty.
    unfold produces.
    unfold generates.
    intros s H3.
    split.
    * intros H4.
      apply derives_g_cnf_g.
      rewrite map_split in H4.
      exact H4.
    * intros H4.
      rewrite map_split.
      {
      apply derives_g_g_cnf_v2.
      - exact H1.
      - exact H2.
      - destruct s.
        + destruct H3.
          reflexivity.
        + simpl.
          apply not_eq_sym.
          apply nil_cons.
      - exact HH.
      - exact H4.
      }
  + apply g_cnf_preserves_start.
    exact HH.
Qed.

Lemma start_g_cnf'_not_in_rhs:
forall g: cfg _ _,
forall s1 s2: sf',
s1 ++ s2 <> [] ->
start_symbol_not_in_rhs g ->
~ derives (g_cnf' g) [inl (start_symbol (g_cnf' g))] (s1 ++ inl (start_symbol (g_cnf' g)) :: s2).
Proof.
intros g s1 s2 H1 H2 H3.
assert (H4: start_symbol_not_in_rhs (g_cnf' g)).
  {
  apply g_cnf'_preserves_start.
  exact H2.
  }
apply exists_rule' in H3.
destruct H3 as [H3 | H3].
- destruct H3 as [_ [H3 H5]].
  subst.
  destruct H1.
  reflexivity.
- destruct H3 as [left [right [H5 H6]]].
  specialize (H4 left right H5).
  simpl in H4.
  contradiction.
Qed.

Lemma g_cnf'_equiv_g_cnf_aux:
forall g: cfg _ _,
forall s: sf',
s <> [] ->
start_symbol_not_in_rhs g ->
(generates (g_cnf' g) s <-> generates (g_cnf g) s).
Proof.
intros g s H HH.
unfold generates.
split.
- intros H1.
  simpl in H1.
  simpl.
  remember [inl (Lift_r [inl (start_symbol g)])] as w.
  induction H1.
  + apply derives_refl.
  + apply derives_trans with (s2:= (s2 ++ inl left :: s3)).
    * {
      apply IHderives.
      - apply not_eq_sym.
        apply app_cons_not_nil.
      - exact Heqw.
      }
    * clear IHderives.
      apply derives_rule.
      {
      inversion H0.
      - exact H2.
      - subst.
        simpl in H1.
        apply start_g_cnf'_not_in_rhs in H1.
        + contradiction.
        + exact H.
        + exact HH.
      }
- clear H.
  intros H1.
  simpl in H1.
  simpl.
  remember [inl (Lift_r [inl (start_symbol g)])] as w.
  induction H1.
  + apply derives_refl.
  + apply derives_trans with (s2:= (s2 ++ inl left :: s3)).
    * apply IHderives.
      exact Heqw.
    * apply derives_rule.
      apply Lift_cnf'_all.
      exact H.
Qed.

Lemma g_cnf'_equiv_g_cnf:
forall g: cfg non_terminal terminal,
start_symbol_not_in_rhs g ->
g_equiv_without_empty (g_cnf' g) (g_cnf g).
Proof.
intros g H1 s H2.
unfold produces.
apply g_cnf'_equiv_g_cnf_aux.
- apply map_not_nil_inv.
  exact H2.
- exact H1.
Qed.

Lemma g_cnf_rule_is_cnf:
forall g: cfg _ _,
forall left: non_terminal' non_terminal terminal,
forall right: sf',
g_cnf_rules g left right ->
is_cnf_rule left right.
Proof.
intros g left right H.
unfold is_cnf_rule.
inversion H.
- right.
  exists t.
  reflexivity.
- right.
  exists t.
  reflexivity.
- left.
  exists (Lift_r [s1]) (Lift_r (s2 :: beta)).
  reflexivity.
- left.
  exists (Lift_r [s2]) (Lift_r (s3 :: beta)).
  reflexivity.
Qed.

Lemma g_cnf'_correct:
forall g: cfg non_terminal terminal,
has_no_unit_rules g /\
has_no_empty_rules g /\
start_symbol_not_in_rhs g ->
is_cnf_with_empty_rule (g_cnf' g) /\
g_equiv_without_empty (g_cnf' g) g /\
start_symbol_not_in_rhs (g_cnf' g).
Proof.
intros g [H1 [H2 HH]].
split.
- unfold is_cnf_with_empty_rule.
  intros left right H5.
  inversion H5.
  + right.
    apply g_cnf_rule_is_cnf with (g:= g).
    exact H.
  + left.
    split.
    * simpl.
      reflexivity.
    * reflexivity.
- split.
  + apply g_equiv_without_empty_trans with (g2:= g_cnf g).
    split.
    * apply g_cnf'_equiv_g_cnf.
      exact HH.
    * apply g_cnf_correct_v1.
      {
      split.
      - exact H1.
      - split.
        + exact H2.
        + exact HH.
      }
  + apply g_cnf'_preserves_start.
    exact HH.
Qed.

Lemma g_cnf_has_no_empty_rules:
forall g: cfg non_terminal terminal,
has_no_empty_rules (g_cnf g).
Proof.
intros g.
unfold has_no_empty_rules.
intros left right H.
inversion H.
- apply not_eq_sym.
  apply nil_cons.
- apply not_eq_sym.
  apply nil_cons.
- apply not_eq_sym.
  apply nil_cons.
- apply not_eq_sym.
  apply nil_cons.
Qed.

Lemma g_cnf'_produces_empty:
forall g: cfg non_terminal terminal,
produces (g_cnf' g) [].
Proof.
intros g.
unfold produces.
unfold generates.
simpl.
apply derives_start.
apply Lift_cnf'_new.
Qed.

End Chomsky_2_Lemmas.

Section Chomsky_3_Lemmas.

Variables non_terminal terminal: Type.

Notation sf:= (list (non_terminal + terminal)).
Notation sf':= (list ((non_terminal' non_terminal) terminal + terminal)).
Notation ntlist':= (list ((non_terminal' non_terminal) terminal)).
Notation tlist:= (list terminal).
Notation sentence:= (list terminal).

Lemma g_cnf_exists_v1:
forall g: cfg non_terminal terminal,
~ produces_empty g ->
produces_non_empty g ->
exists g': cfg (non_terminal' (emptyrules.non_terminal' non_terminal) terminal) terminal,
(g_equiv g' g /\ is_cnf g' /\ start_symbol_not_in_rhs g').
Proof.
intros g H0 H.
apply produces_non_empty_equiv_non_empty in H.
apply g_simpl_exists_v1 in H.
destruct H as [g' [H1 [H2 [H3 [H4 [H5 [H6 H7]]]]]]].
assert (H8: g_equiv (g_cnf g') g <-> g_equiv (g_cnf g') g' /\ g_equiv g' g).
  {
  split.
  - intros H.
    split.
    + apply g_equiv_trans with (g2:= g).
      apply g_equiv_sym in H1.
      exact (conj H H1).
    + exact H1.
  - apply g_equiv_trans.
  }
exists (g_cnf g').
split.
- rewrite H8.
  split.
  + assert (H9: has_no_empty_rules (g_cnf g')).
      {
      apply g_cnf_has_no_empty_rules.
      }
    apply with_without_empty.
    * exact H9.
    * specialize (H5 H0).
      exact H5.
    * apply g_cnf_correct_v1.
      {
      split.
      - exact H6.
      - split.
        + exact (H5 H0).
        + exact H7.
      }
  + exact H1.
- split.
  + apply g_cnf_correct_v1.
    split.
    * exact H6.
    * {
      split.
      - exact (H5 H0).
      - exact H7.
      }
   + apply g_cnf_preserves_start.
     exact H7.
Qed.

Lemma g_cnf_exists_v2:
forall g: cfg non_terminal terminal,
produces_empty g ->
produces_non_empty g ->
exists g': cfg (non_terminal' (emptyrules.non_terminal' non_terminal) terminal) terminal,
(g_equiv g' g /\ is_cnf_with_empty_rule g' /\ start_symbol_not_in_rhs g').
Proof.
intros g H0 H1.
apply g_simpl_exists_v2 in H1.
destruct H1 as [g' [H1 [H2 [H3 [H4 [H5 H6]]]]]].
exists (g_cnf' g').
split.
- rewrite g_equiv_split with (g1:= g_cnf' g').
  split.
  + split.
    * intros _.
      exact H0.
    * intros _.
      apply g_cnf'_produces_empty.
  + apply g_equiv_without_empty_trans with (g2:= g').
    split.
    * apply g_cnf'_correct.
      {
      split.
      - exact H5.
      - split.
        + exact H4.
        + exact H6.
      }
    * exact H1.
- split.
  + apply g_cnf'_correct.
    split.
    * exact H5.
    * {
      split.
      - exact H4.
      - exact H6.
      }
  + apply g_cnf'_preserves_start.
    exact H6.
Qed.

Lemma g_cnf_exists_v3:
forall g: cfg non_terminal terminal,
produces_empty g ->
~ produces_non_empty g ->
exists g': cfg (non_terminal' (emptyrules.non_terminal' non_terminal) terminal) terminal,
(g_equiv g' g /\ is_cnf_with_empty_rule g' /\ start_symbol_not_in_rhs g').
Proof.
intros g H0 H1.
pose (ss:= @Lift_r _ terminal [inl (emptyrules.Lift_nt (start_symbol g))]).
pose (rr:= fun nt rhs => nt=ss /\ rhs=(@nil ((non_terminal' (emptyrules.non_terminal' non_terminal) terminal) + terminal))).
assert (rf: exists n: nat,
            exists ntl: _,
            exists tl: _,
            rules_finite_def ss rr n ntl tl).
  {
  exists 0.
  exists [ss].
  exists (@nil terminal).
  unfold rules_finite_def.
  split.
  - simpl.
    left.
    reflexivity.
  - split.
    + inversion H.
      subst.
      simpl.
      omega.
    + split.
      * inversion H.
        subst.
        simpl.
        left.
        reflexivity.
      * {
        split.
        - intros s H2.
          inversion H.
          subst.
          simpl in H2.
          contradiction.
        - intros s H2.
          inversion H.
          subst.
          simpl in H2.
          contradiction.
        }
  }
exists {| start_symbol:= ss;
          rules:= rr;
          t_eqdec:= t_eqdec g;
          nt_eqdec:= nt_eqdec' (t_eqdec g) (emptyrules.nt_eqdec' (nt_eqdec g));
          rules_finite:= rf |}.
split.
- apply g_equiv_split.
  split.
  + split.
    * intros _.
      exact H0.
    * intros _.
      apply derives_start.
      simpl.
      red.
      {
      split.
      - reflexivity.
      - reflexivity.
      }
  + intros s H2.
    split.
    * intros H3.
      unfold produces in H3.
      unfold generates in H3.
      simpl in H3.
      apply exists_rule in H3.
      {
      destruct H3 as [H3 | H3].
      - inversion H3.
        destruct s.
        + destruct H2.
          reflexivity.
        + simpl in H4.
          inversion H4.
      - destruct H3 as [right [H3 H4]].
        inversion H3.
        subst.
        apply not_derives in H4.
        + contradiction.
        + destruct s.
          * destruct H2.
            reflexivity.
          * simpl.
            apply not_eq_sym.
            apply nil_cons.
      }
    * intros H3.
      assert (H4: exists s: sentence, produces g s /\ s <> []).
        {
        exists s.
        exact (conj H3 H2).
        }
      contradiction.
- split.
  + left.
    simpl.
    auto.
  + intros left right H2 H3.
    simpl in H2.
    simpl in H3.
    inversion H2.
    rewrite H4 in H3.
    simpl in H3.
    contradiction.
Qed.

Lemma g_cnf_exists_v4:
forall g: cfg non_terminal terminal,
~ produces_empty g ->
~ produces_non_empty g ->
exists g': cfg (non_terminal' (emptyrules.non_terminal' non_terminal) terminal) terminal,
(g_equiv g' g /\ is_cnf g' /\ start_symbol_not_in_rhs g').
Proof.
intros g H0 H1.
pose (ss:= @Lift_r _ terminal [inl (emptyrules.Lift_nt (start_symbol g))]).
pose (rr:= fun (nt: (non_terminal' (emptyrules.non_terminal' non_terminal) terminal))
               (rhs: list ((non_terminal' (emptyrules.non_terminal' non_terminal) terminal) + terminal)) =>
               False).
assert (rf: exists n: nat,
            exists ntl: _,
            exists tl: _,
            rules_finite_def ss rr n ntl tl).
  {
  exists 0.
  exists [ss].
  exists (@nil terminal).
  unfold rules_finite_def.
  split.
  - simpl.
    left.
    reflexivity.
  - split.
    + inversion H.
    + split.
      * inversion H.
      * {
        split.
        - inversion H.
        - inversion H.
        }
  }
exists {| start_symbol:= ss;
          rules:= rr;
          t_eqdec:= t_eqdec g;
          nt_eqdec:= nt_eqdec' (t_eqdec g) (emptyrules.nt_eqdec' (nt_eqdec g));
          rules_finite:= rf |}.
split.
- unfold g_equiv.
  intros s.
  split.
  + intros H.
    destruct s.
    * inversion H.
      simpl in H5.
      inversion H5.
    * inversion H.
      simpl in H5.
      inversion H5.
  + intros H.
    destruct s.
    * unfold produces_empty in H0.
      contradiction.
    * unfold produces_non_empty in H1.
      destruct H1.
      exists (t :: s).
      {
      split.
      - exact H.
      - apply not_eq_sym.
        apply nil_cons.
      }
- split.
  + unfold is_cnf.
    intros left right H2.
    inversion H2.
  + intros left right H2 H3.
    simpl in H2.
    simpl in H3.
    inversion H2.
Qed.

Theorem g_cnf_exists:
forall g: cfg non_terminal terminal,
(produces_empty g \/ ~ produces_empty g) /\ (produces_non_empty g \/ ~ produces_non_empty g) ->
exists g': cfg (non_terminal' (emptyrules.non_terminal' non_terminal) terminal) terminal,
g_equiv g' g /\ (is_cnf g' \/ is_cnf_with_empty_rule g') /\ start_symbol_not_in_rhs g'.
Proof.
intros g [Ha Hb].
destruct Ha, Hb.
- assert (H2: exists g': cfg (non_terminal' (emptyrules.non_terminal' non_terminal) terminal) terminal, g_equiv g' g /\ is_cnf_with_empty_rule g' /\ start_symbol_not_in_rhs g').
    {
    apply g_cnf_exists_v2.
    - exact H.
    - exact H0.
    }
  destruct H2 as [g' [H2 [H3 H4]]].
  exists g'.
  split.
  + exact H2.
  + split.
    * right.
      exact H3.
    * exact H4.
- assert (H2: exists g': cfg (non_terminal' (emptyrules.non_terminal' non_terminal) terminal) terminal, g_equiv g' g /\ is_cnf_with_empty_rule g' /\ start_symbol_not_in_rhs g').
    {
    apply g_cnf_exists_v3.
    - exact H.
    - exact H0.
    }
  destruct H2 as [g' [H2 [H3 H4]]].
  exists g'.
  split.
  + exact H2.
  + split.
    * right.
      exact H3.
    * exact H4.
- assert (H2: exists g': cfg (non_terminal' (emptyrules.non_terminal' non_terminal) terminal) terminal, g_equiv g' g /\ is_cnf g' /\ start_symbol_not_in_rhs g').
    {
    apply g_cnf_exists_v1.
    - exact H.
    - exact H0.
    }
  destruct H2 as [g' [H2 [H3 H4]]].
  exists g'.
  split.
  + exact H2.
  + split.
    * left.
      exact H3.
    * exact H4.
- assert (H2: exists g': cfg (non_terminal' (emptyrules.non_terminal' non_terminal) terminal) terminal, g_equiv g' g /\ is_cnf g' /\ start_symbol_not_in_rhs g').
    {
    apply g_cnf_exists_v4.
    - exact H.
    - exact H0.
    }
  destruct H2 as [g' [H2 [H3 H4]]].
  exists g'.
  split.
  + exact H2.
  + split.
    * left.
      exact H3.
    * exact H4.
Qed.

End Chomsky_3_Lemmas.


Require Export Iron.Language.SystemF2Effect.Value.Exp.
Require Export Iron.Language.SystemF2Effect.Type.

(********************************************************************)
(* Well formed expressions are closed under the given environment. *)
Inductive WfV (kn tn sn: nat) : val -> Prop :=
 | WfV_VVar
   :  forall ti
   ,  ti < tn
   -> WfV kn tn sn (VVar ti)

 | WfV_VLoc
   :  forall li
   ,  li < sn
   -> WfV kn tn sn (VLoc li)

 | WfV_VLam
   :  forall t1 x2
   ,  WfT kn t1 -> WfX kn (S tn) sn x2
   -> WfV kn tn sn (VLam t1 x2)

 | WfV_VLAM
   :  forall k1 x
   ,  WfX (S kn) tn sn x
   -> WfV kn tn sn (VLAM k1 x)

 | WfV_VConst
   :  forall c
   ,  WfV kn tn sn (VConst c)

with   WfX (kn tn sn: nat) : exp -> Prop :=

 | WfX_XVal
   :  forall v
   ,  WfV kn tn sn v
   -> WfX kn tn sn (XVal v)

 | WfX_XLet
   :  forall t1 x1 x2
   ,  WfT kn t1
   -> WfX kn tn sn x1
   -> WfX kn (S tn) sn x2
   -> WfX kn tn sn (XLet t1 x1 x2)

 | WfX_XApp
   :  forall v1 v2
   ,  WfV kn tn sn v1 -> WfV kn tn sn v2
   -> WfX kn tn sn (XApp v1 v2)

 | WfX_VAPP
   :  forall x1 t2
   ,  WfV kn tn sn x1 -> WfT kn t2
   -> WfX kn tn sn (XAPP x1 t2)

 | WfX_XOp1
   :  forall op1 v1
   ,  WfV kn tn sn v1
   -> WfX kn tn sn (XOp1 op1 v1)

 | WfX_XPrivate
   :  forall x
   ,  WfX (S kn) tn sn x
   -> WfX kn     tn sn (XPrivate x)

 | WfX_XExtend
   :  forall t1 x2
   ,  WfT kn t1
   -> WfX (S kn) tn sn x2
   -> WfX kn     tn sn (XExtend t1 x2)

 | WfX_XAlloc
   :  forall tR v1
   ,  WfT kn tR
   -> WfV kn tn sn v1
   -> WfX kn tn sn (XAlloc tR v1)

 | WfX_XRead
   :  forall tR v1
   ,  WfT kn tR
   -> WfV kn tn sn v1
   -> WfX kn tn sn (XRead tR v1)

 | WfX_XWrite
   :  forall tR v1 v2
   ,  WfT kn tR
   -> WfV kn tn sn v1
   -> WfV kn tn sn v2
   -> WfX kn tn sn (XWrite tR v1 v2).

Hint Constructors WfX.
Hint Constructors WfV.

(* Closed expressions are well formed under
   empty type and kind environments, but may contain store locations. *)
Notation ClosedX X := (exists sn, WfX O O sn X).


(*******************************************************************************
*                                                                              *
*   DistSubtyping.v                                                            *
*   Xuejing Huang 2021                                                         *
*   Distributed under the terms of the GPL-v3 license                          *
*                                                                              *
*   This file is part of DistributingTypes.                                    *
*                                                                              *
*   DistributingTypes is free software: you can redistribute it and/or modify  *
*   it under the terms of the GNU General Public License as published by       *
*   the Free Software Foundation, either version 3 of the License, or          *
*   (at your option) any later version.                                        *
*                                                                              *
*   DistributingTypes is distributed in the hope that it will be useful,       *
*   but WITHOUT ANY WARRANTY; without even the implied warranty of             *
*   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the              *
*   GNU General Public License for more details.                               *
*                                                                              *
*   You should have received a copy of the GNU General Public License          *
*   along with DistributingTypes.  If not, see <https://www.gnu.org/licenses/>.*
*                                                                              *
*******************************************************************************)

(** This file contains the declarative and algorithmic subtyping formalization.
    The algorithmic system is proved to be sound and complete w.r.t the
    declarative one (in Thereoem dsub2asub).
    Some inversion lemmas (end with _inv) are provided to justify the algorithm.
    The formulation is the same as ../coq/syntax_ott.v.
    We hope this stand-alone file can make your work simpler if you are going to
    use the subtyping part (but not the duotyping) only.
 *)

Require Import LibTactics.
Require Import Coq.micromega.Lia.

Create HintDb AllHd.
Create HintDb SizeHd.
Create HintDb FalseHd.

Inductive typ : Set :=  (* types *)
 | t_int : typ (* int *)
 | t_top : typ (* top type *)
 | t_bot : typ (* bottom type *)
 | t_arrow (A:typ) (B:typ) (* function types *)
 | t_and (A:typ) (B:typ) (* intersection *)
 | t_or (A:typ) (B:typ) (* union *).

Inductive declarative_subtyping : typ -> typ -> Prop :=    (* defn declarative_subtyping *)
 | DS_refl : forall (A:typ),
     declarative_subtyping A A
 | DS_trans : forall (A C B:typ),
     declarative_subtyping A B ->
     declarative_subtyping B C ->
     declarative_subtyping A C
 | DS_top : forall (A:typ),
     declarative_subtyping A t_top
 | DS_bot : forall (A:typ),
     declarative_subtyping t_bot A
 | DS_arrow : forall (A C B D:typ),
     declarative_subtyping B A ->
     declarative_subtyping C D ->
     declarative_subtyping (t_arrow A C) (t_arrow B D)
 | DS_and : forall (A B C:typ),
     declarative_subtyping A B ->
     declarative_subtyping A C ->
     declarative_subtyping A (t_and B C)
 | DS_andl : forall (A B:typ),
     declarative_subtyping (t_and A B) A
 | DS_andr : forall (A B:typ),
     declarative_subtyping (t_and A B) B
 | DS_or : forall (A B C:typ),
     declarative_subtyping A C ->
     declarative_subtyping B C ->
     declarative_subtyping (t_or A B) C
 | DS_orl : forall (A B:typ),
     declarative_subtyping A (t_or A B)
 | DS_orr : forall (B A:typ),
     declarative_subtyping B (t_or A B)
 | DS_distArr : forall (A B1 B2:typ),
     declarative_subtyping (t_and  (t_arrow A B1)   (t_arrow A B2) ) (t_arrow A (t_and B1 B2))
 | DS_distArrRev : forall (A B1 B2:typ),
     declarative_subtyping (t_arrow A (t_and B1 B2)) (t_and  (t_arrow A B1)   (t_arrow A B2) )
 | DS_distArrU : forall (A1 B A2:typ),
     declarative_subtyping (t_and  (t_arrow A1 B)   (t_arrow A2 B) ) (t_arrow (t_or A1 A2) B)
 | DS_distArrURev : forall (A1 A2 B:typ),
     declarative_subtyping (t_arrow (t_or A1 A2) B) (t_and  (t_arrow A1 B)   (t_arrow A2 B) )
 | DS_distOr : forall (A1 B A2:typ),
     declarative_subtyping (t_and  (t_or A1 B)   (t_or A2 B) ) (t_or  (t_and A1 A2)  B)
 | DS_distAnd : forall (A1 A2 B:typ),
     declarative_subtyping (t_and  (t_or A1 A2)  B) (t_or  (t_and A1 B)   (t_and A2 B) ).
(** definitions *)

(* defns Ordinary *)
Inductive ordu : typ -> Prop :=    (* defn ordu *)
 | OU_top :
     ordu t_top
 | OU_bot :
     ordu t_bot
 | OU_int :
     ordu t_int
 | OU_arrow : forall (A B:typ),
     ordu (t_arrow A B)
 | OU_and : forall (A B:typ),
     ordu A ->
     ordu B ->
     ordu (t_and A B).
Inductive ordi : typ -> Prop :=    (* defn ordi *)
 | OI_top :
     ordi t_top
 | OI_bot :
     ordi t_bot
 | OI_int :
     ordi t_int
 | OI_arrow : forall (A B:typ),
     ordu A ->
     ordi B ->
     ordi (t_arrow A B)
 | OI_or : forall (A B:typ),
     ordi A ->
     ordi B ->
     ordi (t_or A B).
(** definitions *)

(* defns Split *)
Inductive spli : typ -> typ -> typ -> Prop :=    (* defn spli *)
 | SpI_and : forall (A B:typ),
     spli (t_and A B) A B
 | SpI_arrow : forall (A B C D:typ),
     spli B C D ->
     spli (t_arrow A B) (t_arrow A C) (t_arrow A D)
 | SpI_arrowUnion : forall (A D B C:typ),
     ordi D ->
     splu A B C ->
     spli (t_arrow A D) (t_arrow B D) (t_arrow C D)
 | SpI_orl : forall (A B A1 A2:typ),
     spli A A1 A2 ->
     spli (t_or A B) (t_or A1 B) (t_or A2 B)
 | SpI_orr : forall (A B B1 B2:typ),
     ordi A ->
     spli B B1 B2 ->
     spli (t_or A B) (t_or A B1) (t_or A B2)
with splu : typ -> typ -> typ -> Prop :=    (* defn splu *)
 | SpU_or : forall (A B:typ),
     splu (t_or A B) A B
 | SpU_andl : forall (A B A1 A2:typ),
     splu A A1 A2 ->
     splu (t_and A B) (t_and A1 B) (t_and A2 B)
 | SpU_andr : forall (A B B1 B2:typ),
     ordu A ->
     splu B B1 B2 ->
     splu (t_and A B) (t_and A B1) (t_and A B2).
(** definitions *)

(* defns SSub *)
Inductive algorithmic_sub : typ -> typ -> Prop :=    (* defn algorithmic_sub *)
 | AS_int :
     algorithmic_sub t_int t_int
 | AS_top : forall (A:typ),
     algorithmic_sub A t_top
 | AS_bot : forall (A:typ),
     algorithmic_sub t_bot A
 | AS_arrow : forall (A1 A2 B1 B2:typ),
     ordi (t_arrow A1 A2) ->
     ordi (t_arrow B1 B2) ->
     algorithmic_sub B1 A1 ->
     algorithmic_sub A2 B2 ->
     algorithmic_sub (t_arrow A1 A2) (t_arrow B1 B2)
 | AS_and : forall (A B B1 B2:typ),
     spli B B1 B2 ->
     algorithmic_sub A B1 ->
     algorithmic_sub A B2 ->
     algorithmic_sub A B
 | AS_andl : forall (A B A1 A2:typ),
     ordi B ->
     spli A A1 A2 ->
     algorithmic_sub A1 B ->
     algorithmic_sub A B
 | AS_andr : forall (A B A1 A2:typ),
     ordi B ->
     spli A A1 A2 ->
     algorithmic_sub A2 B ->
     algorithmic_sub A B
 | AS_or : forall (A B A1 A2:typ),
     ordi A ->
     ordi B ->
     splu A A1 A2 ->
     algorithmic_sub A1 B ->
     algorithmic_sub A2 B ->
     algorithmic_sub A B
 | AS_orl : forall (A B B1 B2:typ),
     ordi A ->
     ordi B ->
     ordu A ->
     splu B B1 B2 ->
     algorithmic_sub A B1 ->
     algorithmic_sub A B
 | AS_orr : forall (A B B1 B2:typ),
     ordi A ->
     ordi B ->
     ordu A ->
     splu B B1 B2 ->
     algorithmic_sub A B2 ->
     algorithmic_sub A B.

(** * Size *)
Fixpoint size_typ (A1 : typ) {struct A1} : nat :=
  match A1 with
    | t_int => 1
    | t_top => 1
    | t_bot => 1
    | t_arrow A2 B1 => 1 + (size_typ A2) + (size_typ B1)
    | t_and A2 B1 => 1 + (size_typ A2) + (size_typ B1)
    | t_or A2 B1 => 1 + (size_typ A2) + (size_typ B1)
  end.

Lemma size_typ_min :
  forall A1, 1 <= size_typ A1.
Proof.
  induction A1; simpl in *; eauto; try lia.
Qed.

#[local] Hint Resolve OI_top OI_bot OI_int OU_top OU_bot OU_int OU_arrow SpI_and SpU_or : core.
#[local] Hint Resolve AS_int AS_top AS_bot : AllHd.

(* Types are Either Ordinary or Splittable *)
#[local] Hint Constructors ordi ordu spli splu : FalseHd AllHd.

Lemma ordu_or_split: forall A,
    ordu A \/ exists B C, splu A B C.
Proof with (eauto with * ; intros).
  intros. induction A...
  - (* and *)
    lets [?|(?&?&?)]: IHA1;
      lets [?|(?&?&?)]: IHA2...
Qed.

Lemma ordi_or_split: forall A,
    ordi A \/ exists B C, spli A B C.
Proof with (eauto with AllHd ; intros).
  intros. induction A...
  - (* arrow *)
    lets [?|(?&?&?)]: ordu_or_split A1;
      lets [?|(?&?&?)]: IHA2...
  - (* and *)
    lets [?|(?&?&?)]: IHA1;
      lets [?|(?&?&?)]: IHA2...
Qed.

(********************************************)
(*                                          *)
(*            Ltac solve_false              *)
(*  try solve the goal by contradiction     *)
(*                                          *)
(********************************************)
Ltac solve_false := try intro; try solve [false; eauto 4 with FalseHd].

Lemma and_or_mismatch: forall A B C D,
    t_and A B = t_or C D -> False.
Proof.
  intros.
  inverts H.
Qed.

Lemma ordi_and_false : forall A B,
    ordi (t_and A B) -> False.
Proof.
  intros.
  inverts H.
Qed.

Lemma ordu_or_false : forall A B,
    ordu (t_or A B) -> False.
Proof.
  intros.
  inverts H.
Qed.

(* splittable types and disjoint types are not overlapping *)

Lemma splu_ord_false : forall A B C,
    splu A B C -> ordu A -> False.
Proof.
  introv. gen B C.
  induction A; intros B C s o;
    try solve [inverts* s];
    try solve [inverts* o];
    inverts o;
    inverts* s.
Qed.

Lemma spli_ord_false : forall A B C,
    spli A B C -> ordi A -> False.
Proof.
  introv. gen B C.
  induction A; intros B C s o;
    try solve [inverts* s];
    try solve [inverts* o];
    inverts o;
    inverts* s.
  applys splu_ord_false; eassumption.
Qed.

#[local] Hint Resolve ordu_or_split and_or_mismatch ordi_and_false
     ordu_or_false spli_ord_false splu_ord_false : FalseHd.

(* lemmas for ordinary *)
Lemma spli_keep_ordu_l : forall A B C,
   ordu A -> spli A B C -> ordu B.
Proof.
  introv Hord Hspl.
  inductions Hspl; try destruct m; inverts Hord; eauto with *.
Qed.

Lemma spli_keep_ordu_r : forall A B C,
   ordu A -> spli A B C -> ordu C.
Proof.
  introv Hord Hspl.
  inductions Hspl; try destruct m; inverts Hord; eauto with *.
Qed.

Lemma splu_keep_ord_l : forall A B C,
   ordi A -> splu A B C -> ordi B.
Proof.
  introv Hord Hspl.
  inductions Hspl; try destruct m; inverts Hord; eauto with *.
Qed.

Lemma splu_keep_ord_r : forall A B C,
   ordi A -> splu A B C -> ordi C.
Proof.
  introv Hord Hspl.
  inductions Hspl; try destruct m; inverts Hord; eauto with *.
Qed.

#[local] Hint Resolve spli_keep_ordu_l spli_keep_ordu_r
     splu_keep_ord_l splu_keep_ord_r : AllHd.

(* Subtyping *)
Lemma typ_size_lg_z : forall T, size_typ T > 0.
Proof.
  introv.
  pose proof (size_typ_min) T.
  inverts~ H.
Qed.

#[local] Hint Resolve typ_size_lg_z : SizeHd.

Lemma splu_decrease_size: forall A B C,
    splu A B C -> size_typ B < size_typ A /\ size_typ C < size_typ A.
Proof with (pose proof (typ_size_lg_z); simpl in *; try lia).
  introv H.
  induction H; simpl in *; eauto...
Qed.

Lemma spli_decrease_size: forall A B C,
    spli A B C -> size_typ B < size_typ A /\ size_typ C < size_typ A.
Proof with (pose proof (typ_size_lg_z); simpl in *; try lia).
  introv H.
  induction H; simpl in *; eauto...
  forwards (?&?): splu_decrease_size H0...
Qed.

Ltac s_spl_size :=
  try repeat match goal with
         | [ H: spli _ _ _ |- _ ] =>
           ( lets (?&?): spli_decrease_size H; clear H)
         | [ H: splu _ _ _ |- _ ] =>
           ( lets (?&?): splu_decrease_size H; clear H)
             end.

(********************************************)
(*                                          *)
(*               Ltac eomg2                 *)
(*  enhanced lia with split_decrease_size   *)
(*                                          *)
(********************************************)
Ltac s_elia :=
  try solve [pose proof (typ_size_lg_z);
             s_spl_size; simpl in *; try lia].

Ltac indTypSize s :=
  assert (SizeInd: exists i, s < i) by eauto with SizeHd;
  destruct SizeInd as [i SizeInd];
  repeat match goal with | [ h : typ |- _ ] => (gen h) end;
  induction i as [|i IH]; [
    intros; match goal with | [ H : _ < 0 |- _ ] => inverts H end
  | intros ].

(* Splitting types is deterministic *)
(********************************************)
(*                                          *)
(*          Lemma split_unique              *)
(*                                          *)
(********************************************)
Lemma splu_unique : forall T A1 A2 B1 B2,
    splu T A1 B1 -> splu T A2 B2 -> A1 = A2 /\ B1 = B2.
Proof with (try eassumption; solve_false; subst~).
  intro T.
  induction T; intros;
    inverts H; inverts H0...
  - forwards (?&?): IHT1 H4 H5...
  - forwards (?&?): IHT2 H6 H7...
Qed.

Lemma spli_unique : forall T A1 A2 B1 B2,
    spli T A1 B1 -> spli T A2 B2 -> A1 = A2 /\ B1 = B2.
Proof with (try eassumption; solve_false; subst~).
  intro T.
  induction T; intros;
    inverts H; inverts H0...
  - forwards (?&?): IHT2 H4 H5...
  - forwards (?&?): splu_unique H6 H7...
  - forwards (?&?): IHT1 H4 H5...
  - forwards (?&?): IHT2 H6 H7...
Qed.

(********************************************)
(*                                          *)
(*             Ltac auto_unify              *)
(*                                          *)
(*  extends choose_unify                    *)
(*  no solve_false at the end                *)
(*                                          *)
(********************************************)
Ltac s_auto_unify :=
  simpl in *;
  try solve [applys SpI_and];
  try solve [applys SpU_or];
  try repeat match goal with
         | [ H1: spli ?A  _ _ , H2: spli ?A _ _ |- _ ] =>
           (forwards (?&?): spli_unique H1 H2;
            subst; clear H2)
         | [ H1: splu ?A  _ _ , H2: splu ?A _ _ |- _ ] =>
           (forwards (?&?): splu_unique H1 H2;
            subst; clear H2)
         end.

(*****************************************************************************)
Inductive single_part : typ -> typ -> Prop :=
| SP_refl  : forall A, single_part A A
| SP_spl   : forall A B C B', spli A B C -> single_part B B' -> single_part A B'
| SP_spr   : forall A B C C', spli A B C -> single_part C C' -> single_part A C'
.

Inductive u_part : typ -> typ -> Prop :=
| UP_refl  : forall A, u_part A A
| UP_spl   : forall A B C B', splu A B C -> u_part B B' -> u_part A B'
| UP_spr   : forall A B C C', splu  A B C -> u_part C C' -> u_part A C'
.

#[local] Hint Constructors single_part u_part : AllHd.
#[local] Hint Resolve SP_refl UP_refl : AllHd.

Lemma single_part_spl : forall A B B1 B2,
    single_part A B -> spli B B1 B2 -> single_part A B1 /\ single_part A B2.
Proof with (eauto with AllHd).
  introv Hp Hspl.
  induction Hp; try forwards~ (?&?): IHHp; split;
    eauto with AllHd.
Qed.

Lemma u_part_spl : forall A B B1 B2,
    u_part A B -> splu B B1 B2 -> u_part A B1 /\ u_part A B2.
Proof with (eauto with AllHd).
  introv Hp Hspl.
  induction Hp; try forwards~ (?&?): IHHp; split;
    eauto with AllHd.
Qed.

#[local] Hint Resolve single_part_spl u_part_spl : AllHd.

#[local] Hint Constructors algorithmic_sub : AllHd.

Ltac s_sub_part_autoIH :=
  match goal with
  | [ IH: forall A B : typ, _ < _ -> _ |- algorithmic_sub ?A ?B ] =>
  (forwards (IH1&IH2): IH A B; auto 4 with *; eauto 4 with AllHd; s_elia)
end.

Lemma s_sub_part : forall A B,
    (single_part A B -> algorithmic_sub A B)
    /\ (ordi A -> ordi B -> u_part B A -> algorithmic_sub A B).
Proof with (try eassumption; auto 4 with *; try solve [s_sub_part_autoIH]; eauto 3 with *).
  introv.
  indTypSize (size_typ A + size_typ B).
  split.

  --
  introv Hp.
  lets [Hi|(?&?&Hi)]: ordi_or_split B.
  - (* ord B *)
    inverts Hp.
    + lets [Hu|(?&?&Hu)]: ordu_or_split B.
      * destruct B; s_auto_unify; solve_false...
        **(* arrow *)
          constructor...
      * applys~ AS_or Hu...
    + applys AS_andl...
    + applys AS_andr...
  - (* spl B *)
    lets~ (?&?): single_part_spl Hp Hi.
    applys AS_and Hi...

    --
    introv Ho1 Ho2 Hp.
    lets [Hu|(?&?&Hu)]: ordu_or_split A.
    + inverts Hp; s_auto_unify.
      * (* ord B *)
      destruct A; s_auto_unify; auto; solve_false...
      ** (* arrow case, non-ord types involved *)
        constructor...
      * applys AS_orl...
      * applys AS_orr...
    +
      lets~ (?&?): u_part_spl Hp Hu.
      applys AS_or...
Qed.

Theorem s_sub_refl : forall A, algorithmic_sub A A.
Proof.
  introv.
  pose proof (s_sub_part A A).
  destruct H; auto with *.
Qed.

Lemma s_sub_part1 : forall A B,
    single_part A B -> algorithmic_sub A B.
Proof.
  introv.
  pose proof (s_sub_part A B).
  destruct* H.
Qed.

Lemma s_sub_part2 : forall A B,
    ordi A -> ordi B -> u_part B A -> algorithmic_sub A B.
Proof.
  introv.
  pose proof (s_sub_part A B).
  destruct* H.
Qed.

#[local] Hint Resolve s_sub_refl : MulHd.
#[local] Hint Resolve s_sub_part1 s_sub_part2 : AllHd.

(* algorithm correctness *)
Lemma s_rule_and_inv : forall A B B1 B2,
    algorithmic_sub A B -> spli B B1 B2 -> algorithmic_sub A B1 /\ algorithmic_sub A B2.
Proof.
  intros.
  induction H; solve_false; s_auto_unify; jauto; auto with *.
Qed.

(* previous and_inv spl_inv *)
Lemma s_rule_andlr_inv : forall A B A1 A2,
    algorithmic_sub A B -> spli A A1 A2 -> ordi B ->
    algorithmic_sub A1 B \/ algorithmic_sub A2 B.
Proof.
  introv Hsub Hord Hspl.
  inverts Hsub; solve_false; s_auto_unify; auto with *.
Qed.

Lemma s_rule_or_inv : forall A A1 A2 B,
    algorithmic_sub A B -> splu A A1 A2 ->
    algorithmic_sub A1 B /\ algorithmic_sub A2 B.
Proof with (s_auto_unify; try eassumption; s_elia; eauto 4 with AllHd ).
  introv Hsub Hspl.
  indTypSize (size_typ A + size_typ B).
   lets [Hi|(?&?&Hi)]: ordi_or_split B.
  - inverts Hsub; solve_false; s_auto_unify; auto with AllHd.
    + (* double split A *)
      inverts Hspl; inverts H0...
      * forwards* (?&?): IH (t_or A0 A2) A0 A2 B...
      * forwards* (?&?): IH (t_or A1 B1) A1 B1 B...
      * forwards* (?&?): IH H2 B...
    + (* double split A *)
      inverts Hspl; inverts H0...
      * forwards* (?&?): IH (t_or A5 A2) A5 A2 B...
      * forwards* (?&?): IH (t_or A1 B2) A1 B2 B...
      * forwards* (?&?): IH H1...
  - forwards (?&?): s_rule_and_inv Hsub Hi.
    forwards (?&?): IH H...
    forwards (?&?): IH H0...
Qed.

Lemma s_rule_orlr_inv : forall A B B1 B2,
    algorithmic_sub A B -> ordu A -> splu B B1 B2 ->
    algorithmic_sub A B1 \/ algorithmic_sub A B2.
Proof with (solve_false; s_auto_unify; try eassumption; s_elia; eauto 3 with AllHd).
  introv Hsub Hord Hspl.
  indTypSize (size_typ A + size_typ B).
  inverts Hsub...
  + (* double split *)
    inverts Hspl; inverts H...
    * forwards [?|?]: IH H0...
      forwards [?|?]: IH H1...
    * forwards [?|?]: IH H0...
      forwards [?|?]: IH H1...
    * forwards [?|?]: IH H2...
    * forwards [?|?]: IH H1 H3...
  + forwards [?|?]: IH H1... eauto 4 with AllHd. eauto 4 with AllHd.
  + forwards* [?|?]: IH H1...  eauto 4 with AllHd. eauto 4 with AllHd.
Qed.

(********************************************)
(*                                          *)
(*             Ltac auto_inv                *)
(*                                          *)
(*  extends choose_unify                    *)
(*  no solve_false at the end               *)
(*                                          *)
(********************************************)
Ltac s_auto_inv :=
  repeat try match goal with
         | [ H1: algorithmic_sub ?A ?B, H2: spli ?B _ _ |- _ ] =>
           try (forwards~ (?&?): s_rule_and_inv H1 H2; clear H1)
         | [ H1: algorithmic_sub ?A (t_and _ _) |- _ ] =>
           try (forwards~ (?&?): s_rule_and_inv H1; clear H1)
      end;
  repeat try match goal with
         | [ Hord: ordi ?B, H1: algorithmic_sub ?A ?B, H2: spli ?A _ _ |- _ ] =>
           try (forwards~ [?|?]: s_rule_andlr_inv H1 H2 Hord; clear H1)
         | [ Hord: ordi ?B, H1: algorithmic_sub (t_and  _ _)  ?B |- _ ] =>
           try (forwards~ [?|?]: s_rule_andlr_inv H1 Hord; clear H1)
      end;
  repeat try match goal with
         | [ H1: algorithmic_sub ?A ?B, H2: splu ?A _ _ |- _ ] =>
           try (forwards~ (?&?): s_rule_or_inv H1 H2; clear H1)
         | [ H1: algorithmic_sub (t_or _ _) ?B |- _ ] =>
           try (forwards~ (?&?): s_rule_or_inv H1; clear H1)
         end;
  repeat try match goal with
         | [ Hord: ordu ?A, H1: algorithmic_sub ?A ?B, H2: splu ?B _ _ |- _ ] =>
           try (forwards~ [?|?]: s_rule_orlr_inv H1 Hord H2; clear H1)
         | [ Hord: ordu ?A, H1: algorithmic_sub ?A (t_or _ _) |- _ ] =>
           try (forwards~ [?|?]: s_rule_orlr_inv H1 Hord; clear H1)
             end.

Lemma algorithmic_sub_or : forall A A1 A2 B,
    splu A A1 A2 -> algorithmic_sub A1 B -> algorithmic_sub A2 B -> algorithmic_sub A B.
Proof with (s_auto_unify; try eassumption; s_auto_inv; s_elia).
  introv Hspli Hs1 Hs2.
  indTypSize (size_typ A + size_typ B).
  lets [Hi|(?&?&Hi)]: ordi_or_split B...
  lets [Hi'|(?&?&Hi')]: ordi_or_split A...
  - applys AS_or...
  - (* double spliit A *)
    inverts keep Hspli; inverts keep Hi'...
    + applys~ AS_andl Hi'... applys IH...
    + applys~ AS_andr Hi'... applys IH...
    + applys~ AS_andl Hi'... applys IH...
    + applys~ AS_andr Hi'... applys IH...
    + applys~ AS_andl Hi'... applys IH...
    + applys~ AS_andr Hi'...
    + applys~ AS_andr Hi'...
    + applys~ AS_andr Hi'...
    + applys~ AS_andl Hi'...
    + applys~ AS_andl Hi'...
    + applys~ AS_andl Hi'...
    + applys~ AS_andr Hi'... applys IH; eauto; try eassumption; s_elia.
  - applys~ AS_and Hi...
    applys IH... applys IH...
Qed.

#[local] Hint Resolve algorithmic_sub_or : AllHd.

Ltac s_trans_autoIH :=
  match goal with
  | [ IH: forall A B : typ, _ , H1: algorithmic_sub ?A  ?B , H2: algorithmic_sub ?B  ?C |- algorithmic_sub ?A  ?C ] =>
    (applys~ IH H1 H2; s_elia; auto)
  | [ IH: forall A B : typ, _ , H1: algorithmic_sub ?A  ?B  |- algorithmic_sub ?A  ?C ] =>
    (applys~ IH H1; s_elia; constructor~)
  | [ IH: forall A B : typ, _ , H2: algorithmic_sub ?B  ?C |- algorithmic_sub ?A  ?C ] =>
    (applys~ IH H2; s_elia; constructor~)
  end.

Lemma s_trans : forall A B C, algorithmic_sub A B -> algorithmic_sub B C -> algorithmic_sub A C.
Proof with (solve_false; s_auto_unify; try eassumption; auto with *; s_auto_inv; try solve s_trans_autoIH).
  introv s1 s2.
  indTypSize (size_typ A + size_typ B + size_typ C).
  lets [Hi|(?&?&Hi)]: ordi_or_split C...
  - lets [Hu|(?&?&Hu)]: ordu_or_split A...
    + lets [Hi'|(?&?&Hi')]: ordi_or_split B...
      lets [Hu'|(?&?&Hu')]: ordu_or_split B...
      lets [Hi''|(?&?&Hi'')]: ordi_or_split A...
      * (* double ord A B *)
        inverts s1; s_auto_unify...
        ** (* top *)
          inverts~ s2...
          *** applys~ AS_orl H2...
          *** applys~ AS_orr H2...
        ** (* arrow *)
          inverts~ s2...
          *** applys~ AS_arrow...
          *** applys~ AS_orl H6...
          *** applys~ AS_orr H6...
      * applys AS_andl...
      * applys AS_andr...
    + lets [Hi'|(?&?&Hi')]: ordi_or_split A...
      * applys AS_or Hu...
      * assert (algorithmic_sub x C)...
        assert (algorithmic_sub x0 C)...
        applys algorithmic_sub_or...
  - applys AS_and Hi...
Qed.

#[local] Hint Resolve s_trans : AllHd.

Lemma s_sub_arrow : forall A1 A2 B1 B2,
    algorithmic_sub B1 A1 -> algorithmic_sub A2 B2 -> algorithmic_sub (t_arrow A1 A2) (t_arrow B1 B2).
Proof with (try eassumption; s_auto_unify; s_auto_inv; solve_false; s_elia; try solve [constructor; auto with AllHd]).
  introv Hs1 Hs2.
  indTypSize (size_typ (t_arrow A1 A2) + size_typ (t_arrow B1 B2)).
  lets [Hi1|(?&?&Hi1)]: ordi_or_split (t_arrow A1 A2)...
  lets [Hi2|(?&?&Hi2)]: ordi_or_split (t_arrow B1 B2)...
  lets [Hu1|(?&?&Hu1)]: ordu_or_split (t_arrow A1 A2)...
  lets [Hu2|(?&?&Hu2)]: ordu_or_split (t_arrow B1 B2)...
  - inverts Hi2.
    + forwards (?&?): s_rule_and_inv Hs2 H3...
      applys AS_and.
      econstructor; try eassumption.
      applys~ IH. s_elia.
      applys~ IH. s_elia.
    + forwards (?&?): s_rule_or_inv Hs1 H4.
      applys AS_and. applys SpI_arrowUnion; try eassumption.
      applys~ IH; s_elia. applys~ IH; s_elia.
  - inverts Hi1.
    + lets [Hi2|(?&?&Hi2)]: ordi_or_split (t_arrow B1 B2).
      * forwards~ [?|?]: s_rule_andlr_inv Hs2 H3. inverts~ Hi2.
        applys AS_andl; try eassumption.
        econstructor. apply H3.
        applys~ IH. s_elia.
        applys AS_andr; try eassumption.
        econstructor. apply H3.
        applys~ IH. s_elia.
      * inverts Hi2.
        ** forwards (?&?): s_rule_and_inv Hs2 H4.
           applys AS_and. econstructor; try eassumption.
           applys~ IH; s_elia. applys~ IH; s_elia.
        ** forwards (?&?): s_rule_or_inv Hs1 H5.
           applys AS_and. applys SpI_arrowUnion; try eassumption.
           applys~ IH; s_elia. applys~ IH; s_elia.
    + lets [Hi2|(?&?&Hi2)]: ordi_or_split (t_arrow B1 B2).
      * forwards~ [?|?]: s_rule_orlr_inv Hs1 H4. inverts~ Hi2.
        1: { applys AS_andl; try eassumption.
        applys SpI_arrowUnion; try eassumption.
        applys~ IH. s_elia. }
        1: { applys AS_andr; try eassumption.
        applys SpI_arrowUnion; try eassumption.
        applys~ IH. s_elia. }
      * inverts Hi2.
        ** forwards (?&?): s_rule_and_inv Hs2 H5.
           applys AS_and. econstructor; try eassumption.
           applys~ IH; s_elia. applys~ IH; s_elia.
        ** forwards (?&?): s_rule_or_inv Hs1 H6.
           applys AS_and. applys SpI_arrowUnion; try eassumption.
           applys~ IH; s_elia. applys~ IH; s_elia.
Qed.

Lemma s_sub_orl : forall A B B1 B2,
    splu B B1 B2 -> algorithmic_sub A B1 -> algorithmic_sub A B.
Proof with (eauto 3 with AllHd).
  introv Hspli Hs.
  indTypSize (size_typ A + size_typ B).
  lets [Hi|(?&?&Hi)]: ordi_or_split B.
  lets [Hi'|(?&?&Hi')]: ordi_or_split A.
  lets [Hu|(?&?&Hu)]: ordu_or_split A.
  - applys~ AS_orl Hspli.
  - applys~ algorithmic_sub_or Hu; applys IH Hspli; s_elia; applys s_trans Hs; applys s_sub_part2...
  - forwards~ [?|?]: s_rule_andlr_inv Hs Hi'...
      applys~ AS_andl Hi'. applys~ IH Hspli. s_elia.
      applys~ AS_andr Hi'. applys~ IH Hspli. s_elia.
  - inverts Hspli; inverts Hi; solve_false; s_auto_unify.
    + applys AS_and...
      applys IH; s_elia. 2: {eauto. } applys s_trans Hs...
      applys IH; s_elia. 2: {eauto. } applys s_trans Hs...
    + applys AS_and...
      applys IH; s_elia. 2: {eauto. } applys s_trans Hs...
      applys IH; s_elia. 2: {eauto. } applys s_trans Hs...
    + s_auto_inv.
      applys AS_and. eauto.
      applys~ IH H; s_elia.
      try eassumption.
    + s_auto_inv.
      applys AS_and. eauto.
      try eassumption.
      applys~ IH H0; s_elia.
Qed.

Lemma s_sub_orr : forall A B B1 B2,
    splu B B1 B2 -> algorithmic_sub A B2 -> algorithmic_sub A B.
Proof with (eauto 3 with AllHd).
  introv Hspli Hs.
  indTypSize (size_typ A + size_typ B).
  lets [Hi|(?&?&Hi)]: ordi_or_split B.
  lets [Hi'|(?&?&Hi')]: ordi_or_split A.
  lets [Hu|(?&?&Hu)]: ordu_or_split A.
  - applys~ AS_orr Hspli.
  - applys~ algorithmic_sub_or Hu; applys IH Hspli; s_elia; applys s_trans Hs; applys s_sub_part2...
  - forwards~ [?|?]: s_rule_andlr_inv Hs Hi'...
      applys~ AS_andl Hi'. applys~ IH Hspli. s_elia.
      applys~ AS_andr Hi'. applys~ IH Hspli. s_elia.
  - inverts Hspli; inverts Hi; solve_false; s_auto_unify.
    + applys AS_and...
      applys IH; s_elia. eauto. applys s_trans Hs...
      applys IH; s_elia. eauto. applys s_trans Hs...
    + applys AS_and...
      applys IH; s_elia. eauto. applys s_trans Hs...
      applys IH; s_elia. eauto. applys s_trans Hs...
    + s_auto_inv.
      applys AS_and. eauto.
      applys~ IH H; s_elia.
      try eassumption.
    + s_auto_inv.
      applys AS_and. eauto.
      try eassumption.
      applys~ IH H0; s_elia.
Qed.

Lemma s_sub_distArrU: forall A B C,
    algorithmic_sub (t_and (t_arrow A C) (t_arrow B C)) (t_arrow (t_or A B) C).
Proof with (s_auto_unify; try eassumption).
  introv.
  indTypSize (size_typ C).
  lets [Hi1|(?&?&Hi1)]: ordi_or_split C.
  - applys AS_and; eauto with *.
  - (* split C x x0 *)
    forwards Hs1: IH A B x. s_elia.
    forwards Hs2: IH A B x0. s_elia.
    applys AS_and. eauto with *.
    + applys s_trans Hs1. applys AS_and; eauto with *.
    + applys s_trans Hs2. applys AS_and; eauto with *.
Qed.

#[local] Hint Resolve s_sub_arrow s_sub_orl s_sub_orr s_sub_distArrU : AllHd.

Lemma arrow_inv : forall A B C D,
    algorithmic_sub (t_arrow A B) (t_arrow C D) -> (algorithmic_sub C A) /\ (algorithmic_sub B D).
Proof with (simpl in *; solve_false; s_auto_unify; try eassumption; s_auto_inv; eauto 3 with AllHd).
  introv s.
  indTypSize (size_typ (t_arrow A B) + size_typ (t_arrow C D)).
  lets [Hi2|(?&?&Hi2)]: ordi_or_split (t_arrow C D).
  lets [Hi1|(?&?&Hi1)]: ordi_or_split (t_arrow A B).
  - inverts s...
  - inverts keep Hi1;
      forwards~ [?|?]: s_rule_andlr_inv s Hi1;
      forwards(IH1&IH2): IH H; try solve [s_elia];
        split; try eassumption; inverts~ Hi2...
  - (* uses and_inv_1 and_inv_2 *)
    forwards (?&?): s_rule_and_inv s Hi2.
    inverts keep Hi2;
      forwards (?&?): IH H; try solve [s_elia];
        forwards (?&?): IH H0; try solve [s_elia];
          split...
Qed.

Theorem decidability : forall A B,
    algorithmic_sub A B \/ not (algorithmic_sub A B).
Proof with (simpl in *; solve_false; jauto; s_elia; try solve [right; intros HF; s_auto_inv; inverts HF; simpl in *; solve_false]; eauto 3 with AllHd).
  introv.
  indTypSize (size_typ A + size_typ B).
  lets [Hi|(?&?&Hi)]: ordi_or_split B.
  - lets [Hi'|(?&?&Hi')]: ordi_or_split A.
    + lets [Hu|(?&?&Hu)]: ordu_or_split A.
      * lets [Hu'|(?&?&Hu')]: ordu_or_split B.
        ** (* all ordinary *)
          destruct A; destruct B...
          *** forwards [IHA1|IHA1] : IH B1 A1...
              forwards [IHA2|IHA2] : IH A2 B2...
        ** (* spl > B, S-orl/r *)
          forwards [IHA1|IHA1] : IH A x...
          forwards [IHA2|IHA2] : IH A x0...
      * forwards [IHA1|IHA1] : IH x B...
        forwards [IHA2|IHA2] : IH x0 B...
    + (* spl < A, S-andl/r *)
      forwards [IHA1|IHA1] : IH x B...
      forwards [IHA2|IHA2] : IH x0 B...
  - (* spl < B, S-and *)
    forwards [IHA1|IHA1] : IH A x...
    forwards [IHA2|IHA2] : IH A x0...
Qed.

#[local] Hint Constructors declarative_subtyping : AllHd.
#[local] Hint Resolve s_sub_refl : core.

Lemma dsub_splu: forall A B C,
    splu A B C -> declarative_subtyping B A /\ declarative_subtyping C A.
Proof with intuition.
  introv H.
  induction H; try intuition; eauto 3 with AllHd.
Qed.

Lemma dsub_spl: forall A B C,
    spli A B C -> declarative_subtyping A B /\ declarative_subtyping A C.
Proof with intuition.
  introv H.
  induction H; try forwards: dsub_splu H0; try intuition; eauto 4 with AllHd.
Qed.

#[local] Hint Resolve dsub_splu dsub_spl : AllDb.

Lemma dsub_symm_and: forall A B,
    declarative_subtyping (t_and A B) (t_and B A).
Proof.
  introv.
  applys DS_and; eauto with *.
Qed.

Lemma dsub_symm_or: forall A B,
    declarative_subtyping (t_or A B) (t_or B A).
Proof.
  introv.
  applys DS_or; eauto with *.
Qed.

#[local] Hint Resolve dsub_symm_and dsub_symm_or : AllHd.

Lemma dsub_or: forall A B C,
    splu A B C -> declarative_subtyping A (t_or B C).
Proof with (eauto 3 with AllHd).
  introv H.
  induction H; try intuition; eauto 3 with AllHd.
  - applys DS_trans.
    2: { applys DS_distAnd. }
    eauto 3 with AllHd.
  - applys DS_trans. applys dsub_symm_and.
    applys DS_trans (t_or (t_and B1 A) (t_and B2 A)).
    1: { applys DS_trans.
        2: { applys DS_distAnd. }
        eauto 3 with AllHd. }
    applys DS_or.
    applys DS_trans (t_and A B1)...
    applys DS_trans (t_and A B2)...
Qed.

Lemma dsub_and: forall A B C,
    spli A B C -> declarative_subtyping (t_and B C) A.
Proof with (eauto 3 with AllHd).
  introv H.
  induction H; try intuition...
  - forwards: dsub_or H0...
  - applys DS_trans.
    1: { applys DS_distOr. }
    eauto 3 with AllHd.
  - applys DS_trans. 2: { applys dsub_symm_or. }
    applys DS_trans (t_and (t_or B1 A) (t_or B2 A)).
    2: { applys DS_trans.
         applys DS_distOr.
        eauto 3 with AllHd. }
    applys DS_and.
    applys DS_trans (t_or A B1)...
    applys DS_trans (t_or A B2)...
Qed.

#[local] Hint Resolve dsub_and dsub_or : AllHd.

Theorem dsub2asub: forall A B,
    declarative_subtyping A B <-> algorithmic_sub A B.
Proof with (simpl in *; try eassumption; eauto 3 with *).
  split; introv H.
  - induction H; try solve [constructor; eauto 3 with AllHd]; eauto.
    + applys s_trans...
    + applys s_sub_arrow...
    + applys* AS_and.
    + applys s_sub_part1...
    + applys s_sub_part1...
    + applys algorithmic_sub_or. eauto 4 with *. auto. auto.
    + applys s_sub_orl...
    + applys s_sub_orr...
    + applys AS_and...
    + applys AS_and... eauto 4 with *. eauto 4 with *.
    + applys s_sub_distArrU.
    + applys* AS_and...
    + applys algorithmic_sub_or. eauto 4 with *.
      applys AS_and... applys s_sub_orl... applys s_sub_orr...
    + applys algorithmic_sub_or. eauto 4 with *.
      applys s_sub_orl... applys s_sub_orr...
  - induction H; auto with *.
    + (* and *)
      applys DS_trans (t_and B1 B2)...
    + (* andl *)
      forwards (?&?): dsub_spl H0. applys DS_trans IHalgorithmic_sub...
    + (* andr *)
      forwards (?&?): dsub_spl H0. applys DS_trans IHalgorithmic_sub...
    +  (* or *)
      applys DS_trans (t_or A1 A2)...
    + (* orl *)
      forwards (?&?): dsub_splu H2. applys DS_trans IHalgorithmic_sub...
    + (* orr *)
      forwards (?&?): dsub_splu H2. applys DS_trans IHalgorithmic_sub...
Qed.


(* Chapter 5: Untyped Lambda Calculus *)
Require Import String.

Definition name := string.

Inductive term : Type :=
| tvar : name -> term
| tabs : name -> term -> term
| tapp : term -> term -> term
.

Fixpoint size t :=
  match t with
  | tvar _ => 1
  | tabs x t' => 1 + size t'
  | tapp t1 t2 => size t1 + size t2
  end.