Require Import List Logic Nat Arith Bool Omega.
Require Import Compare_dec EqNat Decidable ListDec FinFun.
Require Fin.
Import ListNotations.
From Block
Require Import lib definitions finite ramsey.

(** Proving the finiteness of block cancellable with k languages
    without the Axiom of Choice **)

(** Step 1 : Building a computable unshear function **)

(* Word-specific membership checking function *)
Fixpoint is_member (w : word) (l : list word) : bool :=
  match l with
  | [] => false
  | hd :: tl => if (word_eq w hd)
               then true
               else is_member w tl
  end.

Definition is_member_prop (w : word) (l : list word) : Prop :=
  In w l.

Lemma is_member_correct : forall l w, is_member w l = true <-> is_member_prop w l.
Proof.
  intros l w.
  induction l as [|hd tl IHl].
  - split; intro H.
    + unfold is_member in H; inversion H.
    + inversion H.
  - split; intro H.
    + simpl in H.
      assert (H_dec := word_eq_dec w hd).
      destruct H_dec as [eq | neq].
      rewrite eq in H.
      simpl. left. apply word_eq_refl in eq.
      symmetry; assumption.
      apply (Bool.not_true_is_false (word_eq w hd)) in neq.
      rewrite neq in H.
      simpl. right. apply IHl; assumption.
    + apply in_inv in H.
      destruct H as [eq | neq].
      rewrite eq.
      simpl.
      assert (word_eq w w = true).
      { rewrite word_eq_refl. reflexivity. }
      rewrite H. reflexivity.
      simpl.
      assert (H_dec := word_eq_dec w hd).
      destruct H_dec as [Heq | Hneq].
      rewrite Heq. reflexivity.
      apply (Bool.not_true_is_false (word_eq w hd)) in Hneq.
      rewrite Hneq.
      apply IHl. exact neq.
Qed.

Lemma is_member_correct' : forall l w, is_member w l = false <-> ~ In w l.
Proof.
  intros.
  apply mirror_reflect.
  intros; apply is_member_correct.
Qed.

(* List of all k-size breakpoint sets for a word *)
Definition get_k_bps (w : word) (k : nat) : list (list nat) :=
  choose (iota 0 (S (length w))) k.

(* For correctness proof about get_k_bps *)
(* Any iota of good length can form a breakpoint set *)
Lemma iota_bps :
  forall (w : word) (n : nat) (about_n : p_predicate n),
    n <= S (length w) ->
    breakpoint_set_predicate (iota 0 n) w (exist p_predicate n about_n).
Proof.
  intros w n about_n H_length.
  unfold breakpoint_set_predicate; repeat split.
  - (* Length obligation *)
    rewrite length_iota. reflexivity.
  - (* Increasing obligation *)
    now apply iota_increasing.
  - rewrite iota_last_nonzero.
    omega. destruct n.
    unfold p_predicate in about_n. inversion about_n.
    omega.
Qed.

(* Key lemma : choice function gives us breakpoint sets! *)
Lemma iota_gives_bps :
  forall (w : word) (k : block_pumping_constant) (l : list nat),
    length w >= k ->
    In l (choose (iota 0 (S (length w))) k) ->
    breakpoint_set_predicate l w k.
Proof.
  intros w k l H_length H_in.
  apply choose_spec in H_in.
  2 : { rewrite length_iota. omega. }
  destruct H_in as [H_eq H_subseq].
  assert (H_incr : increasing l).
  { assert (H_useful := subseq_incr (iota 0 (S (length w)))).
    spec H_useful definitions.d (iota_increasing 0 (S (length w)) definitions.d).
    spec H_useful l. apply H_useful; assumption.  }
  unfold breakpoint_set_predicate; repeat split.
  - (* Length obligation *)
    exact H_eq.
  - (* Increasing obligation! *)
    exact H_incr.
  - (* Last obligation *)
    assert (H_trans : last (iota 0 (S (length w))) definitions.d  = S (length w) - 1).
    { rewrite iota_last_nonzero. omega.
      intro absurd. rewrite absurd in H_subseq.
      simpl in H_subseq. inversion H_subseq. rewrite <- H in H_eq.
      unfold length in H_eq.
      destruct k; simpl in *.
      rewrite <- H_eq in p. unfold p_predicate in p; inversion p. }
    assert (H_useful := about_subseq_last l (iota 0 (S (length w)))).
    assert (length l >= 2).
    { destruct k. unfold p_predicate in p. simpl in *. omega. }
    assert (length (iota 0 (S (length w))) >= 2).
    { rewrite length_iota. destruct k. unfold p_predicate in p.
      simpl in *. omega. }
    spec H_useful definitions.d H H0.
    spec H_useful (iota_increasing 0 (S (length w)) definitions.d).
    spec H_useful H_subseq.
    omega.
Qed.

(* Condition checker : for one k-breakpoint set, all canceled words are in reference list *)
Fixpoint are_all_pumps_helper (w : word) (l : list word) (hd : nat) (tl : list nat) : bool :=
  match tl with
  | [] => true
  | h :: t => if is_member (cancelled_word w hd h) l
              then are_all_pumps_helper w l hd t
              else false
  end.

(* Correctness for are_all_pumps_helper *)
Definition are_all_pumps_helper_prop (w : word) (l : list word) (hd : nat) (tl : list nat) : Prop :=
  forall (j : nat),
    In j tl -> In (cancelled_word w hd j) l.

Theorem are_all_pumps_helper_correct :
  forall (w : word) (l : list word) (hd : nat) (tl : list nat),
    are_all_pumps_helper w l hd tl = true <->
    are_all_pumps_helper_prop w l hd tl.
Proof.
  intros w l hd tl.
  induction tl as [|hd' tl' IHtl].
  - (* Base case *)
    split; intro H.
    + intros j H_absurd; inversion H_absurd.
    + simpl; reflexivity.
  - (* Induction step *)
    split; intro H.
    + (* First direction, computational -> propositional *)
      simpl in H.
      case_eq (is_member (cancelled_word w hd hd') l).
      ++ (* When the new head forms a pump *)
        intro H_true.
        rewrite H_true in H.
        rewrite IHtl in H.
        intros j H_in.
        destruct H_in.
        subst j. apply is_member_correct in H_true.
        exact H_true.
        spec H j H0. exact H.
      ++ (* When the new head doesn't form a pump *)
        intro H_false.
        rewrite H_false in H.
        inversion H.
    + (* Second direction, propositional -> computational *)
      simpl.
      case_eq (is_member (cancelled_word w hd hd') l).
      ++ (* When the new head forms a pump *)
        intro H_true.
        rewrite IHtl.
        intros j H_in.
        spec H j.
        assert (In j (hd' :: tl')). apply in_cons. exact H_in.
        spec H H0; clear H0. exact H.
      ++ (* When the new head doesn't form a pump *)
        intro H_false.
        (* Now we find a contradiction *)
        spec H hd' (in_eq hd' tl').
        rewrite is_member_correct' in H_false.
        contradiction.
Qed.

Theorem are_all_pumps_helper_correct' :
  forall (w : word) (l : list word) (hd : nat) (tl : list nat),
    are_all_pumps_helper w l hd tl = false <->
    ~ (are_all_pumps_helper_prop w l hd tl).
Proof.
  intros w l hd tl.
  eapply mirror_reflect.
  apply are_all_pumps_helper_correct.
Qed.

Fixpoint are_all_pumps (w : word) (l : list word) (bps : list nat) : bool :=
  match bps with
  | [] => true
  | hd :: tl => if are_all_pumps_helper w l hd tl
               then are_all_pumps w l tl
               else false
  end.

Definition are_all_pumps_prop (w : word) (l : list word) (bps : list nat) : Prop :=
  forall (i j : nat),
    i < j < (length bps) ->
    In (cancelled_word w (nth i bps d) (nth j bps d)) l.

Lemma are_all_pumps_correct :
  forall (w : word) (l : list word) (bps : list nat),
    are_all_pumps w l bps = true <->
    are_all_pumps_prop w l bps.
Proof.
  intros w l bps.
  induction bps as [|bp tl IHbps].
  - (* Base case *)
    split; intro H.
    + intros i j H_lt. unfold length in H_lt; inversion H_lt.
      inversion H1.
    + simpl. reflexivity.
  - (* Induction step *)
    split; intro H.
    + intros i j H_lt.
      simpl in H.
      (* Critically, the case distinction has to happen here! *)
      destruct j.
      inversion H_lt; omega.
      assert (H_about_j : In (nth j tl definitions.d) tl).
      { destruct H_lt. simpl in H1.
        apply lt_S_n in H1.
        now apply nth_In. }
      (* Critically, this fact has to enter here : *)
      assert (i = j \/ i < j) by omega.
      assert (j < length tl).
      { rewrite unfold_length_S in H_lt. destruct H_lt; omega. }
      destruct H0 as [eq | lt].
      (* Critically, now destruct! *)
      * (* When i = j *)
        (* Critically, now destruct again! *)
        case_eq (are_all_pumps_helper w l bp tl); [intro H_yes | intro H_no].
        ** (* When i = j and the new list is all pumps *)
            rewrite H_yes in H;
            rewrite IHbps in H;
            rewrite are_all_pumps_helper_correct in H_yes.
          unfold are_all_pumps_helper_prop in H_yes.
          rewrite unfold_nth_Sn_tl. subst i.
          destruct j.
          spec H_yes (nth 0 tl definitions.d).
          spec H_yes H_about_j.
          exact H_yes.
          spec H j (S j).
          assert (j < S j < length tl).
          { split. omega. exact H1. }
          spec H H0; clear H0.
          rewrite unfold_nth_Sn_tl. exact H.
        ** (* When i = j and the new list is not all pumps *)
          (* We find a contradiction *)
            rewrite H_no in H; inversion H.
      *  (* When i < j *)
        (* Critically, now destruct again! *)
        case_eq (are_all_pumps_helper w l bp tl); [intro H_yes | intro H_no].
        ** (* When i < j and the new list is all pumps *)
            rewrite H_yes in H;
            rewrite IHbps in H;
            rewrite are_all_pumps_helper_correct in H_yes.
          unfold are_all_pumps_helper_prop in H_yes.
          rewrite unfold_nth_Sn_tl.
          destruct i. rewrite nth_zero.
          now apply (H_yes (nth j tl definitions.d)).
          rewrite unfold_nth_Sn_tl.
          (* Now the i-th element is not in tl *)
          spec H i j.
          assert (i < j < length tl).
          { split. destruct H_lt; omega. exact H1. }
          spec H H0; clear H0. assumption.
        ** (* When i < j and the new list is not all pumps. *)
            rewrite H_no in H. inversion H.
    + (* Propositional -> computational *)
      (* Basically the same thing but in reverse. *)
      simpl.
      case_eq (are_all_pumps_helper w l bp tl); [intro H_yes | intro H_no].
      ** (* When all pumps, *)
        rewrite are_all_pumps_helper_correct in H_yes;
          rewrite IHbps.
        unfold are_all_pumps_helper_prop in H_yes.
        intros i j H_lt.
        assert (In (nth j tl definitions.d) tl).
        { apply nth_In; omega. }
        destruct i. spec H 1 (S j).
        assert (1 < S j < length (bp :: tl)).
        { rewrite unfold_length_S. omega. }
        spec H H1; clear H1.
        simpl in *; exact H.
        spec H (S (S i)) (S j).
        assert (S (S i) < (S j) < length (bp :: tl)).
        { destruct H_lt; split. apply lt_n_S; exact H1.
          rewrite unfold_length_S; omega. }
        spec H H1. do 2 rewrite unfold_nth_Sn_tl in H. exact H.
      ** (* When not all pumps, *)
        exfalso (* We find a contradiction *).
        rewrite are_all_pumps_helper_correct' in H_no.
        apply H_no. intros i j.
        unfold are_all_pumps_prop in H.
        spec H 0.
        apply (In_nth _ _ definitions.d) in j.
        destruct j as [i_pos [i_length i_nth]].
        destruct i_pos.
        destruct tl. inversion i_length.
        rewrite nth_zero in i_nth. subst n.
        spec H 1.
        assert (0 < 1 < length (bp :: i :: tl)).
        { split; simpl; omega. }
        spec H H0. unfold nth in H.
        exact H. rewrite nth_zero in H. subst i. spec H (S (S i_pos)).
        assert (0 < S (S i_pos) < length (bp :: tl)).
        { split. omega. rewrite unfold_length_S. omega. }
        spec H H0. exact H.
Qed.

(* Check that some k-size breakpoint set contains all pumps *)
Definition exists_all_pumps_bps (w : word) (l : list word) (k : nat) : bool :=
  existsb (are_all_pumps w l) (get_k_bps w k).

Definition exists_all_pumps_bps_prop (w : word) (l : list word) (k : nat) : Prop :=
  exists lp : list nat,
    are_all_pumps_prop w l lp /\ In lp (get_k_bps w k).

Lemma exists_all_pumps_bps_correct :
  forall (w : word) (l : list word) (k : nat),
    exists_all_pumps_bps w l k = true <-> exists_all_pumps_bps_prop w l k.
Proof.
  intros w l k.
  split; intro H.
  - unfold exists_all_pumps_bps in H.
    rewrite (existsb_exists (are_all_pumps w l) (get_k_bps w k)) in H.
    destruct H as [bps [bps_in about_bps]].
    unfold exists_all_pumps_bps_prop.
    exists bps. split.
    apply are_all_pumps_correct. exact about_bps. exact bps_in.
  - unfold exists_all_pumps_bps.
    rewrite (existsb_exists (are_all_pumps w l) (get_k_bps w k)).
    destruct H as [bps [about_bps bps_in]].
    exists bps.
    split. exact bps_in.
    rewrite are_all_pumps_correct. exact about_bps.
Qed.
(* And this is the condition we are looking for! *)

(* This is the namespace for our algorithm condition *)
Definition check (w : word) (l : list word) (k : nat) :=
  exists_all_pumps_bps w l k.

(* Generating words of a certain length *)
Fixpoint app_map (l : list word) : list word :=
  match l with
  | [] => []
  | hd :: tl => (aa::hd) :: (bb::hd) :: (cc::hd) :: app_map tl
  end.

Fixpoint repeatedly_apply {X : Type} (n : nat) (f : X -> X) (x : X) : X :=
  match n with
  | 0 => x
  | S n' => repeatedly_apply n' f (f x)
  end.

Definition generate_words_of_length (n : nat) : list word :=
  repeatedly_apply n (app_map) [[]].

Lemma app_map_grow1: forall n l,
  (forall w, In w l -> length w = n) ->
  (forall w, In w (app_map l) -> length w = S n).
Proof.
  induction l; intros. inversion H0.
  simpl in *. destruct H0 as [? | [? | [? | ?]]]; subst; simpl;
  try (f_equal; apply H; left; reflexivity).
  apply IHl. intros. apply H. right. apply H1.
  apply H0.
Qed.

Lemma app_map_grow2: forall n l,
  (forall w, length w = n -> In w l) ->
  (forall w, length w = S n -> In w (app_map l)).
Proof.
  destruct w; inversion 1.
  specialize (H w H2).
  clear -H.
  induction l. inversion H.
  destruct H. subst w.
  destruct t. left. reflexivity.
  right. left. reflexivity.
  right. right. left. reflexivity.
  right. right. right. apply IHl. apply H.
Qed.

Theorem app_map_grow: forall n l,
  (forall w, In w l <-> length w = n) ->
  (forall w, In w (app_map l) <-> length w = S n).
Proof.
  intros n l H w. split; intro;
  [apply app_map_grow1 with l | apply app_map_grow2 with n];
  intros; try assumption; apply H; assumption.
Qed.

Lemma repeatedly_apply_app_map :
  forall (n : nat) (L : list (list T)) (j : nat),
    (forall w, In w L <-> length w = j) ->
    forall (w : word),
    In w (repeatedly_apply n app_map L)
    <-> length w = n + j.
Proof.
  induction n; simpl; intros. apply H.
  specialize (IHn (app_map L) (S j)).
  replace (S (n + j)) with (n + S j) by omega.
  apply IHn. apply app_map_grow. apply H.
Qed.

Theorem generate_words_length_correct :
  forall (n : nat) (w : word),
    In w (generate_words_of_length n) <-> length w = n.
Proof.
  unfold generate_words_of_length. intros.
  replace n with (n + 0) at 2 by omega.
  apply repeatedly_apply_app_map.
  destruct w0; simpl; split.
  * reflexivity.
  * left. reflexivity.
  * intros [? | []]. inversion H.
  * inversion 1.
Qed.

Fixpoint generate_words_upto (n : nat) :=
  match n with
  | 0 => [[]]
  | S n' => (generate_words_of_length (S n')) ++ generate_words_upto n'
  end.
Lemma generate_words_upto_correct : forall (n : nat) (w : word),
    In w (generate_words_upto n) <-> length w <= n.
Proof.
  intros n w.
  induction n as [|n IHn].
  - simpl. split; intro H.
    destruct H. rewrite <- H.
    unfold length; reflexivity.
    inversion H.
    left.
    inversion H. apply length_zero_iff_nil in H1.
    symmetry; assumption.
  - split; intro H.
    + simpl in H.
      apply in_app_or in H.
      destruct H as [left | right].
      * rewrite generate_words_length_correct in left.
        omega.
      * rewrite IHn in right. omega.
    + simpl.
      apply le_lt_or_eq in H.
      apply in_or_app.
      destruct H as [left | right].
      * right.  assert (length w <= n) by omega.
        apply IHn in H. assumption.
      * left.
        rewrite generate_words_length_correct.
        assumption.
Qed.

(* Begin detouring *)
Fixpoint words_to_add (lref : list word) (k : nat) (l : list word) : list word :=
  match l with
  | [] => []
  | hd :: tl => if check hd lref k
               then hd :: words_to_add lref k tl
               else words_to_add lref k tl
  end.

Definition words_to_add_prop (lref : list word) (k : nat) (l : list word) (w : word) :=
  exists_all_pumps_bps_prop w lref k /\ In w l.

Theorem words_to_add_correct :
  forall (l lref : list word) (k : nat),
  forall (w : word),
    In w (words_to_add lref k l) <-> words_to_add_prop lref k l w.
Proof.
(* The following proof is when check = exists_all_pumps_bps *)
  intros l lref k w.
  induction l as [|hd tl IHl].
  - (* Base case *)
    split; intro H.
    + (* In -> properties *)
      simpl in H. inversion H.
    + (* Properties -> In *)
      destruct H. inversion H0.
  - (* Inductive step *)
    split; intro H.
    + (* In -> properties *)
      simpl in H.
      case_eq (check hd lref k); intro H_case;
        rewrite H_case in H.
      * destruct H as [H_eq | H_tl].
        ** (* w = hd *)
          subst hd. split.
          apply exists_all_pumps_bps_correct. exact H_case.
          apply in_eq.
        ** (* In w tl *)
          rewrite IHl in H_tl.
          destruct H_tl. split. assumption.
          apply in_cons. assumption.
      * rewrite IHl in H. destruct H.
        split. exact H. apply in_cons. exact H0.
    + (* Properties -> In *)
      simpl.
      case_eq (check hd lref k); intro H_case.
      (* Can't left/right yet! *)
      destruct H. destruct H0 as [H_eq | H_tl].
      rewrite <- H_eq. apply in_eq.
      right. apply IHl; split; assumption.
      apply IHl.
      destruct H.
      destruct H0 as [H_eq | H_tl].
      rewrite <- H_eq in H. rewrite <- exists_all_pumps_bps_correct in H.
      unfold check in H_case; rewrite H in H_case. inversion H_case.
      split; assumption.
Qed.

Theorem words_to_add_correct' :
  forall (l lref : list word) (k : nat),
  forall (w : word),
    ~ In w (words_to_add lref k l) <-> ~ words_to_add_prop lref k l w.
Proof.
  intros. apply not_iff_compat.
  apply words_to_add_correct.
Qed.

(* Add all words of a certain length that satisfy condition above: *)
Definition words_to_add_of_length (n : nat) (lref : list word) (k : nat) : list word :=
  words_to_add lref k (generate_words_of_length n).

Definition words_to_add_of_length_prop (n : nat) (lref : list word) (k : nat) (w : word) :=
  exists_all_pumps_bps_prop w lref k
  (* /\ all_exists_pumps_bps_prop w lref k *)
  /\ length w = n.

Theorem words_to_add_of_length_correct :
  forall (n : nat) (lref : list word) (k : nat),
  forall (w : word),
    In w (words_to_add_of_length n lref k) <-> words_to_add_of_length_prop n lref k w.
Proof.
  intros n lref k w.
  split; intro H.
  - (* In -> properties *)
    unfold words_to_add_of_length in H.
    rewrite (words_to_add_correct (generate_words_of_length n) lref k w) in H.
    destruct H as [H_correct H_in].
    split. exact H_correct.
    rewrite generate_words_length_correct in H_in.
    assumption.
  - (* Properties -> In *)
    unfold words_to_add_of_length.
    rewrite (words_to_add_correct (generate_words_of_length n) lref k w).
    split. destruct H.
    exact H. destruct H as [H_correct H_length].
    rewrite generate_words_length_correct. exact H_length.
Qed.
(* End detouring *)

(* Chuck in all the words of a length that pass check *)
Definition to_chuck (k : nat) (lref : list word) (n : nat) :=
  filter (fun w => check w lref k) (generate_words_of_length n).

Definition chuck (k rk n : nat) (lref : list word) :=
  filter (fun w => check w lref k) (generate_words_of_length (n + rk)) ++ lref.

Definition to_chuck_prop (n : nat) (lref : list word) (k : nat) (w : word) :=
  exists_all_pumps_bps_prop w lref k
  /\ length w = n.

Definition chuck_prop (k rk n : nat) (lref : list word) (w : word) :=
  (exists_all_pumps_bps_prop w lref k /\ length w = n + rk)
\/ In w lref.

(* Some detouring is done here, but oh well *)
Theorem filter_equiv :
  forall (k n : nat) (lref : list word),
    words_to_add_of_length n lref k =
    filter (fun w => check w lref k) (generate_words_of_length n).
Proof.
  intros k n lref.
  unfold words_to_add_of_length.
  induction (generate_words_of_length n).
  - compute; reflexivity.
  - simpl. case_eq (check a lref k); intro H_case.
    rewrite IHl. reflexivity.
    exact IHl.
Qed.

Theorem filter_add_correct :
  forall (lref : list word) (k : nat) (n : nat) (w : word),
    In w (to_chuck k lref n) <-> to_chuck_prop n lref k w.
Proof.
  intros. unfold to_chuck. rewrite <- filter_equiv.
  apply words_to_add_of_length_correct.
Qed.

Lemma chuck_correct :
  forall (lref : list word) (k rk n : nat) (w : word),
    In w (chuck k rk n lref) <-> chuck_prop k rk n lref w.
Proof.
  intros. unfold chuck. split; intro.
  apply in_app_or in H. destruct H.
  unfold chuck_prop. left.
  now apply filter_add_correct.
  right. assumption.
  destruct H. apply in_or_app. left.
  now apply filter_add_correct.
  apply in_or_app. right; assumption.
Qed.

Fixpoint chuck_length (k rk n : nat) (lref : list word) :=
  match n with
  | 0 => lref
  | S n' => chuck k rk n (chuck_length k rk n' lref)
  end.

(* The m here is protrusion length *)
Definition bc_language_dec_proj1 {k : block_pumping_constant} (bcl : bc_language_dec k) :=
  match bcl with
  | exist _ b _ => b
  end.

Definition agreement_upto (k rk : block_pumping_constant) (l : bc_language_dec k) (lw : list word) (m : nat) :=
  forall w, In w lw <-> (length w <= m + rk /\ bc_language_dec_proj1 l w).

(* Defining inverse function as word -> bool *)
Definition unshear_bool (k rk : nat) (lref : list word) : word -> bool :=
  fun w => is_member w (chuck_length k rk (length w) lref).

(* Defining inverse function as word -> Prop *)
Definition unshear (k rk : nat) (lref : list word) : word -> Prop :=
  fun w => unshear_bool k rk lref w = true.

(* Defining short languages *)
Definition shear_language (n : nat) (l : language) : language :=
  fun w => l w /\ length w <= n.

Theorem IH_agreement :
  forall (k : block_pumping_constant),
  exists (rk : block_pumping_constant),
  forall (l : bc_language_dec k)
    (lw : list word)
    (m : nat),
    agreement_upto k rk l lw m ->
    agreement_upto k rk l (words_to_add_of_length (S m + rk) lw k ++ lw) (S m).
Proof.
  intros k.
  destruct k as [k about_k];
    unfold p_predicate in about_k.
  assert (H_pre : k > 0) by omega.
  assert (H_ramsey := Ramsey_single_prop k H_pre).
  destruct H_ramsey as [rk [about_rk H_ramsey]].
  assert (about_rk_two : rk >= 2) by omega.
  exists (exist p_predicate rk about_rk_two); simpl in *.
  intros l lw m IH.
  intros w; split; intro H.
  - (* Either the word is in the old list or it's in the new list *)
    apply in_app_or in H.
    destruct H as [H_new | H_old].
    + (* In the case that the word is in the new list *)
      unfold words_to_add_of_length in H_new.
      rewrite words_to_add_correct in H_new.
      destruct H_new as [H_all H_in].
      rewrite generate_words_length_correct in H_in.
      split. simpl. omega.
      destruct l as [l about_l].
      assert (H_bc := about_l).
      destruct H_bc as [H_dec H_bc].
      spec H_bc w.
      destruct H_all as [lp [H_all H_chosen]].
      assert (about_lp : breakpoint_set_predicate lp w (exist p_predicate k about_k)).
      { apply iota_gives_bps.
        rewrite H_in.
        unfold p_predicate in about_k.
        simpl.  omega. assumption. }
      specialize (H_bc (exist _ lp about_lp)).
      destruct H_bc as [i [j [i_lt_j about_i_j]]].
      simpl in *. apply about_i_j.
      destruct i as [i about_i];
        destruct j as [j about_j].
      unfold breakpoint_predicate in *.
      simpl in *.
      unfold are_all_pumps_prop in H_all.
      assert (about_i_copy := about_i).
      assert (about_j_copy := about_j).
      apply (In_nth _ _ definitions.d) in about_i.
      apply (In_nth _ _ definitions.d) in about_j.
      destruct about_i as [i_pos [i_lt i_eq]].
      destruct about_j as [j_pos [j_lt j_eq]].
      spec H_all i_pos j_pos.
      assert (H_pre' : i_pos < j_pos < length lp).
      { split. destruct about_lp as [lp_length [lp_incr lp_last]].
        eapply increasing_nth_lt. exact lp_incr. assumption.
        assumption. rewrite <- i_eq in i_lt_j; rewrite <- j_eq in i_lt_j.
        assumption. assumption. }
      spec H_all H_pre'. clear H_pre'.
      unfold cancelled_word in H_all.
      subst i j.
      spec IH (firstn (nth i_pos lp definitions.d) w ++
                      skipn (nth j_pos lp definitions.d) w).
      rewrite IH in H_all. destruct H_all as [_ goal].
      simpl in *. assumption.
    + (* In the case that the word is in the old list *)
      spec IH w. rewrite IH in H_old.
      destruct H_old as [H_length H_mem].
      split. omega.
      assumption.
  - (* The new word is short and is in the language *)
    destruct H as [H_length H_bc].
    apply le_lt_or_eq in H_length.
    apply in_or_app.
    destruct H_length as [H_old | H_new].
    + (* In the case that the new word is too short to be new *)
      right.
      replace (S m + rk) with (S (m + rk)) in H_old by omega.
      apply lt_n_Sm_le in H_old.
      spec IH w. apply IH. split; assumption.
    + (* In the case that the new word is new *)
      left.
      unfold words_to_add_of_length.
      rewrite words_to_add_correct.
      (* Need Ramsey here *)
      (* Making sure to use the zero version *)
      split.
      2 : rewrite generate_words_length_correct; assumption.
      unfold exists_all_pumps_bps_prop.
      unfold get_k_bps.
      assert (about_big_bps : breakpoint_set_predicate (iota 0 rk) w (exist _ rk about_rk_two)).
      { apply iota_bps. simpl in *; omega. }
      spec H_ramsey (iota 0 rk).
      spec H_ramsey. apply length_iota.
      spec H_ramsey (fun i j => bc_language_dec_proj1 l (cancelled_word w i j)).
      destruct H_ramsey as [[bps_yes [bps_length [bps_subseq about_bps_yes]]] | [bps_no [bps_length [bps_subseq about_bps_no]]]].
      * (* Ramsey case yes *)
        exists bps_yes. split.
        ** (* Pump correctness *)
          unfold are_all_pumps_prop.
          intros.
          rewrite bps_length in H.
          spec about_bps_yes i j H.
          apply IH. split.
          (* Word is shorter obligation *)
          simpl.
          unfold cancelled_word.
          assert (H_useful := firstn_skipn_shortens w (nth i bps_yes d) (nth j bps_yes d)).
          assert (H_bps_incr : increasing bps_yes).
          { apply (subseq_incr (iota 0 rk) definitions.d).
            apply iota_increasing. assumption. }
          assert (bps_incr := H_bps_incr).
          spec H_bps_incr i j.
          rewrite bps_length in H_bps_incr.
          spec H_bps_incr H. spec H_useful. rewrite H_new.
          split. assumption. simpl.
          assert (H_last := about_subseq_last bps_yes (iota 0 rk) definitions.d).
          spec H_last. rewrite bps_length; omega.
          spec H_last. rewrite length_iota; omega.
          spec H_last. apply iota_increasing.
          spec H_last bps_subseq.
          replace (last (iota 0 rk) d) with (rk - 1) in H_last.
          2 : rewrite iota_last_nonzero; omega.
          assert (H_trans := about_incr_nth_last definitions.d bps_yes bps_incr j). spec H_trans. rewrite bps_length; omega.
          omega.
          rewrite H_new in H_useful.
          simpl in H_useful. omega.
          (* Language recognizes pumped word obligation *)
          assumption.
        ** (* In choose *)
          apply choose_spec.
          rewrite length_iota. rewrite H_new. simpl. omega.
          split. assumption.
          assert (H_trans : subseq (iota 0 rk) (iota 0 (S (length w)))).
          apply subseq_grow. rewrite H_new. simpl; omega.
          now apply (subseq_trans nat bps_yes (iota 0 rk) (iota 0 (S (length w)))).
      * (* Ramsey case no *)
        destruct l as [l about_l].
        assert (about_l_copy := about_l).
        assert (bps_incr : increasing bps_no).
        { apply (subseq_incr (iota 0 rk) definitions.d).
          apply iota_increasing. assumption. }
        assert (bps_bps_no : breakpoint_set_predicate bps_no w (exist _ k about_k)).
        { split. simpl. assumption.
          split. assumption.
          assert (H_last := about_subseq_last (iota 0 rk) bps_no definitions.d).
          rewrite bps_length in H_last.
          spec H_last. rewrite length_iota.
          assumption. spec H_last about_k.
          apply (Nat.le_trans (last bps_no d) (last (iota 0 rk) d) (length w)).
          apply about_subseq_last.
          omega. rewrite length_iota. assumption.
          apply iota_increasing. assumption.
          rewrite H_new. rewrite iota_last_nonzero.
          simpl. omega. omega. }
        destruct about_l_copy as [l_dec about_l_copy].
        spec about_l_copy w.
        specialize (about_l_copy (exist _ bps_no bps_bps_no)).
        destruct about_l_copy as [i [j [H_ij_lt H_in]]].
        destruct i as [i about_i];
          unfold breakpoint_predicate in about_i.
        destruct j as [j about_j];
          unfold breakpoint_predicate in about_j.
        simpl in *.
        apply (In_nth _ _ definitions.d) in about_i.
        apply (In_nth _ _ definitions.d) in about_j.
        destruct about_i as [i_pos [i_pos_lt i_pos_eq]].
        destruct about_j as [j_pos [j_pos_lt j_pos_eq]].
        spec about_bps_no i_pos j_pos.
        rewrite <- i_pos_eq in H_ij_lt.
        rewrite <- j_pos_eq in H_ij_lt.
        spec about_bps_no.
        split.
        now apply (increasing_nth_lt bps_no definitions.d bps_incr i_pos j_pos).
        omega.
        apply H_in in H_bc. unfold cancelled_word in about_bps_no.
        rewrite i_pos_eq, j_pos_eq in about_bps_no. contradiction.
Qed.
(* This lemma is done *)

(* Reminder to self: m in agreement_upto is protrusion *)
Lemma IH_chuck_step :
  forall (k : block_pumping_constant),
  exists (rk : block_pumping_constant),
  forall (l : bc_language_dec k) (lw : list word) (m : nat),
    agreement_upto k rk l lw m ->
    agreement_upto k rk l (chuck k rk (S m) lw) (S m).
Proof.
  intros k.
  assert (H_useful := IH_agreement k).
  destruct H_useful as [rk H_useful].
  exists rk. intros l lref m H_base.
  specialize (H_useful l lref m H_base).
  rewrite filter_equiv in H_useful.
  unfold chuck. assumption.
Qed.

(* For every k there exists an rk such that for all bc_k languages
   and lists that agree with them, we can safely chuck_length *)
Lemma IH_chuck :
  forall (k : block_pumping_constant),
  exists (rk : block_pumping_constant),
  forall (l : bc_language_dec k) (lw : list word),
    agreement_upto k rk l (chuck_length k rk 0 lw) 0 ->
    forall (m : nat),
      agreement_upto k rk l (chuck_length k rk m lw) m.
Proof.
  intros k.
  destruct (IH_chuck_step k) as [rk H_useful].
  exists rk. intros l lw H_base m.
  induction m.
  - (* Base case, assumption *)
    simpl in *.
    assumption.
  - (* Inductive step *)
    simpl.
    apply H_useful. assumption.
Qed.

Theorem unshear_correctness :
  forall (k : block_pumping_constant),
  exists (rk : block_pumping_constant),
  forall (l : bc_language_dec k) (lw : list word),
    agreement_upto k rk l (chuck_length k rk 0 lw) 0 ->
    (forall (w : word),
        In w lw <-> (shear_language rk (unshear k rk lw)) w)
    /\ unshear k rk lw = (bc_language_dec_proj1 l).
Proof.
  intros k.
  assert (H_chuck := IH_chuck k).
  destruct H_chuck as [rk H_chuck].
  exists rk.
  intros bcl lw H_base.
  split.
  - (* Proving theorem_the_first, essentially *)
    intro w.
    spec H_chuck bcl lw H_base.
    split; intro H.
    + (* --> *)
      unfold unshear, unshear_bool, shear_language.
      split.
      2 : { spec H_base w. apply H_base.
            simpl. exact H. }
      rewrite is_member_correct.
      spec H_chuck (length w).
      apply H_chuck. split. omega.
      spec H_base w.
      rewrite H_base in H.
      destruct H as [_ goal].
      exact goal.
    + (* <-- *)
      apply H_base.
      unfold unshear, unshear_bool, shear_language in H.
      rewrite is_member_correct in H.
      destruct H as [H_in H_length].
      split. omega.
      spec H_chuck (length w).
      spec H_chuck w. rewrite H_chuck in H_in.
      destruct H_in as [_ goal].
      exact goal.
  - (* Proving theorem_the_second, essentially *)
    spec H_chuck bcl lw H_base.
    apply language_equality; intro w.
    split; intro H.
    + (* --> *)
      spec H_chuck (length w).
      spec H_chuck w.
      unfold unshear, unshear_bool in H.
      rewrite is_member_correct in H.
      rewrite H_chuck in H.
      destruct H as [_ goal].
      exact goal.
    + (* <-- *)
      unfold unshear, unshear_bool. rewrite is_member_correct.
      spec H_chuck (length w). apply H_chuck.
      split. omega. assumption.
Qed.

(** Step 2 : Proving that well-formed short languages are finite **)
Definition is_finite {X : Type} (P : X -> Prop) : Prop :=
  exists L : list X, forall (x : X), In x L <-> P x.

(* Mini nifty subseq library *)
Theorem behead_eq :
  forall (hd d : word) (lw : list word),
    behead lw d = hd ->
    (lw = [] /\ d = hd) \/
    exists tl, lw = hd :: tl.
Proof.
  intros.
  destruct lw.
  left.
  split. reflexivity.
  compute in H. assumption.
  right.
  simpl in H. subst. exists lw. reflexivity.
Qed.

Theorem subseq_cons :
  forall (l : list word) (hd : word) (tl : list word),
    subseq (hd :: tl) l ->
    subseq tl l.
Proof.
  induction l as [|hd tl IHl]; intros.
  - apply subseq_nil_inversion in H.
    inversion H.
  - inversion H; subst. clear H.
    apply subseq_hn. assumption.
    apply subseq_hn.
    apply (IHl hd0 tl0). assumption.
Qed.

Theorem subseq_cons_or :
  forall (hd : word) (tl lw : list word),
    subseq lw (hd :: tl) ->
    subseq lw tl \/ exists tl', lw = hd :: tl' /\ subseq tl' tl.
Proof.
  intros hd tl lw H_subseq.
  generalize dependent hd.
  generalize dependent tl.
  induction lw; intros.
  left; constructor.
  inversion H_subseq; subst.
  - apply (subseq_cons _ hd) in H_subseq.
    spec IHlw tl hd H_subseq.
    destruct IHlw.
    right. exists lw. split.
    reflexivity. exact H.
    destruct H.
    destruct H. right. exists lw.
    split. reflexivity. assumption.
  - left; assumption.
Qed.

Theorem subseq_finite :
  forall (l : list word),
    is_finite (fun s => subseq s l).
Proof.
  induction l as [|h tl IHl].
  - exists [ [] ].
    intro; split; intros.
    inversion H. subst; constructor.
    inversion H0. inversion H. unfold In. left; reflexivity.
  - destruct IHl as [llw IHl].
    exists (llw ++ map (fun lw => [h] ++ lw) llw).
    intro lw; split; intro H.
    + apply in_app_or in H.
      destruct H as [H_old | H_new].
      * rewrite IHl in H_old.
        apply subseq_hn. assumption.
      * apply in_map_iff in H_new.
        destruct H_new as [t [H_eq H_in]].
        subst lw.
        replace (h :: tl) with ([h] ++ tl) by easy.
        apply subseq_app. apply subseq_refl.
        apply IHl. assumption.
    + apply in_app_iff.
      replace (h :: tl) with ([h] ++ tl) in H by easy.
      apply subseq_cons_or in H.
      destruct H as [left | right].
      apply IHl in left. left; assumption.
      destruct right as [right_tl [H_split H_subseq]].
      subst. right.
      apply in_map_iff. exists right_tl.
      split. trivial.
      apply IHl. assumption.
Qed.

Theorem is_finite_shortwords :
  forall (n : nat),
    is_finite (fun lw => subseq lw (generate_words_upto n)).
Proof.
  intro n.
  now apply (subseq_finite (generate_words_upto n)).
Qed.

(* Languages that satisfy P in list L are finite *)
Lemma p_in_list_finite_dec : forall (P : word -> Prop) (L : list word) (Hdec : language_decidability P),
    is_finite (fun l => P l /\ In l L).
Proof.
  intros P LS Hdec.
  induction LS as [|new_x old_xes IHL].
  + (* In the base case, the candidate list is empty,
     so the finite list is also empty *)
    exists nil.
    intros x; split.
    intro H_in; split. inversion H_in. exact H_in.
    intro H; destruct H as [_ H_mem]; exact H_mem.
  + (* In the inductive step, the candidate list grows by one x,
       and the new finite list must include it if it satisfies P *)
    destruct IHL as [L' IHL].
    destruct (Hdec new_x).
    ++ (* When new_x satisfies P *)
      exists (new_x :: L').
      intros x; split; intros H_in.
      +++ apply in_inv in H_in;
            destruct H_in as [H_eq | H_in].
          split. rewrite H_eq in H; assumption.
          rewrite <- H_eq; apply in_eq.
          split. spec IHL x; destruct IHL as [left _];
                   spec left H_in. destruct left; assumption.
          apply in_cons.
          spec IHL x; destruct IHL as [left _].
          spec left H_in; destruct left; assumption.
      +++ destruct H_in.
          apply in_inv in H1.
          destruct H1. rewrite H1; apply in_eq.
          apply in_cons. spec IHL x.
          destruct IHL as [_ IHL].
          apply IHL; split; assumption.
    ++ (* When new_x doesn't satisfy P, toss it out *)
      exists L'.
      intro x; split; intros H_in.
      +++ split. spec IHL x; destruct IHL as [IHL _];
            spec IHL H_in; destruct IHL; assumption.
          apply in_cons.
          spec IHL x; destruct IHL as [IHL _];
            spec IHL H_in; destruct IHL; assumption.
      +++ destruct H_in as [H_P H_in].
          apply in_inv in H_in.
          destruct H_in as [H_absurd | H_in].
          subst x; contradiction.
          spec IHL x. apply IHL; split; assumption.
Qed.

Lemma is_finite_conj {X : Type} : forall (P : X -> Prop) (Q : X -> Prop),
    is_finite (fun l => P l) ->
    is_finite (fun l => P l /\ Q l).
Proof.
  intros P Q H_fin.
  destruct H_fin as [ls H_fin].
  assert (H_useful := p_in_list_finite Q ls).
  destruct H_useful as [LS H_useful].
  exists LS.
  intro l; spec H_fin l; spec H_useful l; split; intro H.
  - split;
    apply H_useful in H; destruct H as [H_Q H_in];
    apply H_fin in H_in; assumption.
  - destruct H as [H_P H_Q].
    apply H_fin in H_P.
    apply H_useful; split; assumption.
Qed.

Theorem is_finite_subseq_wf :
  forall (k rk : block_pumping_constant),
    is_finite (fun lw => subseq lw (generate_words_upto rk) /\
                      exists (l : bc_language_dec k), agreement_upto k rk l lw 0).
Proof.
  intros.
  now apply (is_finite_conj (fun lw => subseq lw (generate_words_upto rk))
                            (fun lw => exists (l : bc_language_dec k), agreement_upto k rk l lw 0)
                            (is_finite_shortwords rk)).
Qed.

(* Extracting a list of words from a decidable language *)
Theorem shear_language_decidable :
  forall (l : language) (rk : nat) (l_dec : language_decidability l),
  forall w, shear_language rk l w \/ ~ shear_language rk l w.
Proof.
  intros l rk l_dec w.
  unfold shear_language.
  assert (length w <= rk \/ length w > rk) by omega.
  destruct H. destruct (l_dec w); tauto.
  right. intro. omega.
Qed.

Theorem get_list_shear_language :
  forall (l : language) (Hdec : language_decidability l) (rk : nat),
  exists (L : list word),
    forall (w : word), In w L <-> shear_language rk l w.
Proof.
  intros l Hdec rk.
  remember (generate_words_upto rk) as W.
  assert (forall w, shear_language rk l w -> In w W).
  { intros. destruct H. subst.
    apply generate_words_upto_correct. trivial. }
  assert (forall W1 W2,
             (forall w, In w W <-> In w (W1 ++ W2)) ->
             (exists L, sublist L W1
                   /\ forall w : word,
                   (In w L -> shear_language rk l w)
                   /\ (shear_language rk l w -> (In w L \/ In w W2)))).
  { induction W1; intros.
    * exists nil. split. red. auto.
      intros. split; intro.
      inversion H1. right. simpl in H0. apply H0, H, H1.
    * simpl in H0. specialize (IHW1 (a :: W2)). spec IHW1.
      intros lw. spec H0 lw.
      split; intro. rewrite H0 in H1. destruct H1.
      subst. apply in_or_app. right. apply in_eq.
      apply in_or_app. apply in_app_or in H1.
      destruct H1. left; assumption. right.
      apply in_cons; assumption.
      apply in_app_or in H1. destruct H1.
      apply H0. right. apply in_or_app. left; assumption.
      destruct H1. apply H0. left; assumption.
      apply H0. right; apply in_or_app; right; assumption.
      destruct IHW1 as [L [? ?]].
      assert (Hsheardec := shear_language_decidable l rk Hdec a).
      destruct Hsheardec.
    + exists (a :: L). split. repeat intro.
      destruct H4. left. assumption. right. apply H1. assumption.
      intros. split. intro. destruct H4. subst. assumption.
      specialize (H2 w). destruct H2. apply H2, H4.
      specialize (H2 w). destruct H2. intro H5. spec H4 H5.
      destruct H4 as [? | [? | ?]].
      left. right. assumption.
      left. left. assumption.
      right. assumption.
    + exists L. split.
      right. apply H1, H4.
      intros. spec H2 w. destruct H2.
      split. assumption.
      intros. specialize (H4 H5).
      destruct H4. left. assumption.
      destruct H4. subst. contradiction.
      right. assumption. }
  specialize (H0 W nil). spec H0.
  rewrite app_nil_r. split; trivial.
  destruct H0 as [L [? ?]]. exists L.
  intro w. spec H1 w. destruct H1. split; intro.
  apply H1, H3.
  apply H2 in H3. destruct H3. assumption. inversion H3.
Qed.

Theorem filter_subseq_correct :
  forall (l : list word) (f : word -> bool),
    subseq (filter f l) l.
Proof.
  induction l as [|hd tl IHl]; intros.
  intros. compute; constructor.
  spec IHl f.
  simpl.
  case_eq (f hd); intros.
  constructor; assumption.
  constructor; assumption.
Qed.

Fixpoint intersect (l1 l2 : list word) :=
  match l1 with
  | hd :: tl => if is_member hd l2
               then hd :: intersect tl l2
               else intersect tl l2
  | [] => []
  end.

Theorem intersect_correctness :
  forall (l1 l2 : list word),
  forall w, In w (intersect l1 l2) ->
       In w l1 /\ In w l2.
Proof.
  intros l1 l2 w H_in.
  induction l1 as [|hd1 tl1 IHl1].
  - compute in H_in; inversion H_in.
  - simpl in H_in.
    case_eq (is_member hd1 l2); intro.
    + rewrite H in H_in.
      apply in_inv in H_in.
      destruct H_in as [H_eq | H_in].
      * subst.
        split.
        apply in_eq.
        apply is_member_correct in H.
        assumption.
      * spec IHl1 H_in.
        destruct IHl1.
        split. apply in_cons; assumption.
        assumption.
    + rewrite H in H_in.
      spec IHl1 H_in.
      destruct IHl1. split.
      apply in_cons; assumption. assumption.
Qed.

Theorem get_nodup_list_shear_language :
  forall (l : language) (Hdec : language_decidability l) (rk : nat),
  exists (L : list word),
    (subseq L (generate_words_upto rk)) /\
     forall (w : word), In w L <-> shear_language rk l w.
Proof.
  intros l Hdec rk.
  assert (H_useful := get_list_shear_language l Hdec rk).
  destruct H_useful as [L H_useful].
  exists (filter (fun w => andb (length w <=? rk) (is_member w L)) (generate_words_upto rk)).
  split.
  now apply filter_subseq_correct.
  intros w; split; intro.
  apply filter_In in H.
  destruct H.
  apply H_useful.
  apply andb_prop in H0.
  destruct H0.
  rewrite is_member_correct in H1.
  assumption.
  apply filter_In. split.
  unfold shear_language in H. destruct H.
  apply generate_words_upto_correct; assumption.
  assert (H_copy := H).
  apply H_useful in H.
  apply andb_true_intro. split.
  unfold shear_language in H_copy. destruct H_copy.
  apply Nat.leb_le. assumption.
  rewrite is_member_correct. assumption.
Qed.

Theorem get_list_shear_bc_language :
  forall (k rk : block_pumping_constant) (l : bc_language_dec k) (Hdec : language_decidability (bc_language_dec_proj1 l)),
  exists (L : list word),
    (subseq L (generate_words_upto rk))  /\
    forall (w : word), In w L <-> shear_language rk (bc_language_dec_proj1 l) w.
Proof.
  intros k rk l Hdec.
  assert (H_useful := get_nodup_list_shear_language (bc_language_dec_proj1 l) Hdec rk).
  destruct H_useful as [L H_useful].
  exists L. assumption.
Qed.

(** Step 3 : Grand finale! **)
Theorem bc_dec_k_is_finite_nochoice :
    forall (k : block_pumping_constant),
    is_finite (bc_sigma_dec k).
Proof.
  intros k.
  assert (H_blink := unshear_correctness k).
  destruct H_blink as [rk H_blink].
  assert (H_fin := is_finite_subseq_wf k rk).
  destruct H_fin as [llw about_llw].
  exists (map (unshear k rk) llw).
  intro l.
  split; intro H.
  + (* We have a language that's in our constructed list *)
    rewrite in_map_iff in H.
    destruct H as [wf_sl [H_eq H_in]].
    (* By that we know it must have come from some short list *)
    spec about_llw wf_sl.
    rewrite about_llw in H_in; clear about_llw.
    destruct H_in as [_ [bcl_witness H_witness]].
    (* And by some reasoning, we can build to bcl_witness *)
    spec H_blink bcl_witness wf_sl H_witness.
    destruct H_blink as [H1 H2].
    rewrite <- H_eq.
    rewrite H2.
    destruct bcl_witness.
    simpl.
    assumption.
  + rewrite in_map_iff.
    specialize (H_blink (exist _ l H)).
    assert (H_getlist := get_list_shear_bc_language k rk (exist _ l H)).
    destruct H_getlist as [wf_list [wf_subseq about_wf_list]].
    destruct H as [Hdec H]. simpl. red. now apply Hdec.
    exists wf_list.
    assert (H_pre : agreement_upto k rk (exist (bc_sigma_dec k) l H) wf_list 0).
    { intros w. spec about_wf_list w.
      split; intro H_tmp.
      rewrite about_wf_list in H_tmp.
      unfold shear_language in H_tmp.
      destruct H_tmp as [H_in H_length].
      split. omega. assumption.
      destruct H_tmp. apply about_wf_list.
      unfold shear_language; split. assumption. omega. }
    spec H_blink wf_list H_pre.
    destruct H_blink as [H1 H2].
    split. simpl in H2; assumption.
    apply about_llw. split.
    exact wf_subseq. exists (exist (bc_sigma_dec k) l H). assumption.
Qed.

Print Assumptions bc_dec_k_is_finite_nochoice.

(* Way 1 : definitional decidability of languages *)
(* Refer to lemma2nochoicebool.v *)

(* Way 2 : Law of Excluded Middle for language decidability *)
Require Import Classical.

Theorem bc_k_is_finite_lem :
    forall (k : block_pumping_constant),
    is_finite (bc_sigma k).
Proof.
  intro k.
  replace (bc_sigma k) with (bc_sigma_dec k).
  apply bc_dec_k_is_finite_nochoice.
  unfold bc_sigma_dec, bc_sigma.
  apply functional_extensionality.
  intro l.
  apply prop_ext.
  split; intro H.
  tauto. split. intro w; apply (classic (l w)).
  assumption.
Qed.

(* Way 3 : Explicit decision procedure for some language *)
Parameter decider : forall (l : language), forall (w : word), l w \/ ~ l w.

Theorem bc_k_is_finite_decider :
    forall (k : block_pumping_constant),
    is_finite (bc_sigma k).
Proof.
  intro k.
  replace (bc_sigma k) with (bc_sigma_dec k).
  apply bc_dec_k_is_finite_nochoice.
  unfold bc_sigma_dec, bc_sigma.
  apply functional_extensionality.
  intro l.
  apply prop_ext.
  split; intro H.
  tauto. split. intro w; apply decider.
  assumption.
Qed.


Require Export Dec_Word.

Module ElimE.

  Import Base Lists Definitions Symbols Derivation (*Dec_Empty*) (*Dec_word*).

  Section ElimE.

    Context {Tt Vt: Type}.
    Context {Tt_eqdec: eq_dec Tt}.
    Context {Vt_eqdec: eq_dec Vt}.

    (** * Nullable Variables *)
    Inductive nullable (G : @grammar Tt Vt) (s : symbol) : Prop :=
    | Null A u : s = Vs A -> R A u el G -> (forall s', s' el u -> nullable G s') -> nullable G s.
    Hint Constructors nullable.

    Lemma derE_nullable (G : grammar) (A : var) (u : phrase) :
      der G A u -> (forall s, s el u -> nullable G s) -> nullable G (Vs A).
    Proof.
      intros H U.
      induction H as [| u H | A B u w v H IH0 H0 IH1] ; eauto.
      apply IH0.
      intros s E.
      apply in_app_or in E.
      destruct E as [E | E].
      + auto.
      + destruct E as [E | E].
        * rewrite <- E. apply IH1. intros s' V. (apply U, in_or_app ; (try now left) ; (right ; apply in_or_app ; (try now left) ; try now right)).
        * apply in_app_or in E. destruct E as [E | E] ; firstorder. (apply U, in_or_app ; (try now left) ; (right ; apply in_or_app ; (try now left) ; try now right)).
    Qed.

    Hint Constructors der.
    Lemma nullable_derE (G : grammar) (s : symbol) :
      nullable G s -> exists A, s = Vs A /\ der G A [].
    Proof.
      induction 1 as [s A u H H0 H1 IH].
      exists A. split ; auto.
      clear H H1 s.
      apply rDer in H0.
      induction u as [|s u IHu] ; auto.
      apply IHu ; auto.
      assert (H3: s el s::u) by auto.
      destruct (IH s H3) as [B [H4 H5]]. rewrite H4 in *.
      replace u with ([] ++ [] ++ u) ; eauto.
    Qed.
    Ltac dupapply H1 lemma H2 := pose (H2:= H1) ; apply lemma in H2.

    Lemma nullable_derE_equi (G : grammar) (s : symbol) :
      (exists A, s = Vs A /\ der G A []) <-> nullable G s.
    Proof.
      split ; intro H.
      - destruct H as [A [H0 H1]].
        rewrite H0 in *.
        eapply derE_nullable ; eauto. firstorder.
      - now dupapply H nullable_derE H0.
    Qed.

    Global Instance nullable_dec G s : dec (nullable G s).
    Proof.
      destruct s as [a | A].
      - right. rewrite <- nullable_derE_equi. intros [A [H0 H1]]. inv H0.
      - decide (der G A []) ; [left | right] ; rewrite <- nullable_derE_equi.
    + exists A. split ; auto.
    + intros [A' [H0 H1]]. inv H0. tauto.
    Defined.

    (** * Epsilon closure *)

    Definition efree G := forall A u, (@R Tt Vt) A u el G -> u <> [].

    Fixpoint closure (p : symbol -> Prop) {pdec : forall x, dec (p x)} (G : @grammar Tt Vt) :=
      match G with
          [] => []
        | R A u :: Gr =>
          let
            u' := @slists _ p _ u
          in let
            G' := map (R A) u'
          in G' ++ closure Gr
      end.
    Arguments closure p {pdec} G.

    Section EClosure.
      Variable G : @grammar Tt Vt.

      Definition eclosure G:= closure (nullable G) G.
      Definition eclosed G := forall A u, R A u el G -> forall v, @slist _ (nullable G) _ v u -> R A v el G.

      Lemma closure_slist A v (p : symbol -> Prop) {pdec : forall s, dec (p s)} :
        R A v el closure p G -> exists u, R A u el G /\ slist v u.
      Proof.
        intros H.
        induction G as [| [B w] Gr IHGr] ; simpl in H ; [tauto|].
        apply in_app_or in H.
        destruct H as [H | H].
        - apply in_map_iff in H.
          destruct H as [x [H0 H1]].
          inv H0. exists w. split ; auto.
          now apply slists_slist.
        - destruct (IHGr H) as [u [H0 H1]]. exists u ; auto.
      Qed.

      Lemma slist_closure A v (p : symbol -> Prop) {pdec : forall s, dec (p s)} :
        (exists u, R A u el G /\ slist v u) -> R A v el closure p G.
      Proof.
        intros [u [H0 H1]].
        induction G as [| [B w] Gr IHGr] ; simpl in H0 ; auto.
        destruct H0 as [H0 | H0] ; simpl ; apply in_or_app.
        - inv H0. left. apply in_map_iff.
          exists v. split ; auto. now apply slists_slist.
        - right. auto.
      Qed.

      Lemma slist_closure_equiv A v (p : symbol -> Prop) {pdec : forall s, dec (p s)} :
        R A v el closure p G <-> exists u, R A u el G /\ slist v u.
      Proof.
        split ; [apply closure_slist | apply slist_closure].
      Qed.

      (** ** Epsilon closure is epsilon-closed **)
      Lemma nullable_eclosure s :
        nullable (eclosure G) s <-> nullable G s.
      Proof.
        split ; intros H.
        - induction H as [? ? ? ? H1 ? ?].
          apply slist_closure_equiv in H1.
          destruct H1 as [u' [H3 H4]].
          esplit ; eauto.
          eapply slist_inv ; eauto.
        - induction H as [? ? u ? ? ? ?].
          esplit ; eauto.
          apply slist_closure_equiv.
          exists u. split ; auto. apply slist_id.
      Qed.

      Lemma eclosed_eclosure : eclosed (eclosure G).
      Proof.
        intros A u H0 v H1.
        apply slist_closure_equiv in H0.
        apply slist_closure_equiv.
        destruct H0 as [u' [H2 H3]].
        exists u'. split ; auto.
        eapply (slist_equiv_pred nullable_eclosure) in H1.
        eapply slist_trans ; eauto.
      Qed.

      (** ** Epsilon closure preserves languages **)

      Hint Constructors derT.
      Lemma derT_slist u v :
        @slist _ (nullable G) _ v u -> derT G u v.
      Proof.
        induction 1 as [| ? v u H0 ? ? | s v u ? ?].
        - constructor.
        - apply nullable_derE_equi in H0.
          destruct H0 as [A [H1 H2]].
          apply derT_der_equiv in H2.
          rewrite H1.
          assert (H3 : derT G (Vs A :: u) ([] ++ [Vs A] ++ u)) by constructor.
          apply derT_trans with (v0 := [] ++ [] ++ u) ; eauto.
        - replace (s :: u) with ([s] ++ u) by auto.
          replace (s :: v) with ([s] ++ v) by auto.
          apply derT_concat ; eauto.
      Qed.

      Lemma eclosure_der u v :
        derT (eclosure G) u v -> derT G u v.
      Proof.
         intros H.
         induction H as [| ? ? H |] ; eauto.
         apply slist_closure_equiv in H.
         destruct H as [u' [H1 H2]].
         apply derTRule in H1.
         apply derT_slist in H2.
         eapply derT_trans ; eauto.
      Qed.

      Lemma der_eclosure_equiv u v :
        derT G u v <-> derT (eclosure G) u v.
      Proof.
        split.
        - induction 1 as [| A u |] ; eauto.
          constructor 2.
          apply slist_closure_equiv.
          exists u. split ; auto. apply slist_id.
        - apply eclosure_der.
      Qed.

    End EClosure.

    (** * Deletion of epsilon rules *)

    Section DelE.
      Variable G : @grammar Tt Vt.

      Definition delE (G: @grammar Tt Vt) :=
        filter (fun r => match r with R A u => u <> [] end) G.

      (** ** delE is epsilon-free *)
      Lemma delE_efree : efree (delE G).
      Proof.
        intros A u H.
        induction G as [| [B v] Gr] ; simpl in H.
        - tauto.
        - decide (v <> []) ; (try destruct H as [H|H]) ; (try now inv H) ; auto.
      Qed.

      (** ** delE preserves languages (except for epsion) *)

      Lemma delE_preserveG A u :
        R A u el G -> u <> [] -> R A u el delE G.
      Proof.
        intros H1 H2.
        induction G as [| [B v] Gr] ; simpl in H1 ; [tauto|].
        simpl. destruct H1 as [H1 | H1].
        - inv H1. decide (u <> []) ; [auto | contradiction].
        - decide (v <> []) ; [right |] ; auto.
      Qed.

      Hint Constructors derL.
      Lemma delE_rules A u :
        R A u el (delE G) -> R A u el G.
      Proof.
        intros H.
        induction G as [| [B v] Gr] ; simpl in H ; [tauto|].
        decide (v <> []) ; try destruct H ; try (inv H ; now left) ; try (right ; auto).
      Qed.
      Hint Constructors slist.
      Lemma der_G_delE A u v :
        eclosed G -> der G A u -> @slist _ (nullable G) _ v u -> v <> [] -> der (delE G) A v.
      Proof.
        intros E D Ss U.
        apply derL_der_equiv in D.
        apply derL_der_equiv.
        revert Ss U. revert v.
        induction D as [| B u v w H H0 IHD] ; intros v' Ss U.
        - assert (H0 : v' = [] \/ v' = [Vs A]). {
            inversion Ss as [| ? ? ? H H0 u' | ? u' ? H0] ; subst ; inv H0 ; auto. }
                                               destruct H0 ; subst ; [ tauto | eauto ].
        - apply slist_split with (xs1 := u) (xs2 := v ++ w) in Ss ; auto.
          destruct Ss as [u1 [hu [Ss0 [Ss1 Ss2]]]].
          apply slist_split with (xs1 := v) (xs2 := w) in Ss1 ; auto.
          destruct Ss1 as [v1 [w1 [Ss3 [Ss4 Ss5]]]].
          rewrite Ss2, Ss5 in *.
          assert (H1 : R B v1 el G) by eauto.
          decide (v1 = []) as [D0 | D0].
          + rewrite D0 in *.
            assert (H2 : nullable G (Vs B)).
            { apply nullable_derE_equi.
              exists B. split ; eauto. }
            apply IHD ; auto.
            repeat apply slist_append ; auto.
          + constructor 2 with (B := B) ; auto using delE_preserveG.
            assert (H2 : @slist _ (nullable G) _ (u1 ++ [Vs B] ++ w1) (u ++ [Vs B] ++ w)).
            { repeat apply slist_append ; auto. }
            apply IHD ; auto.
            intros H3. destruct u1 ; inv H3.
      Qed.

      Lemma delE_der_equiv A u :
        eclosed G -> (der G A u /\ u <> [] <-> der (delE G) A u).
      Proof.
        intros E.
        split ; intros H.
        - destruct H as [H U].
          assert (H0 : @slist _ (nullable G) _ u u) by apply slist_id.
          eapply der_G_delE ; eauto.
        - induction H as [| ? ? H | ? ? u v w H IH1 H0 IH2].
          + split ; [constructor | congruence].
          + split.
            * constructor 2. now apply delE_rules.
            * now apply delE_efree in H.
          + destruct IH1 as [IH11 IH12], IH2 as [IH21 IH22].
            split ; eauto.
            destruct u, v, w ; simpl ; congruence.
      Qed.

    End DelE.

    (** * Epsilon elimination *)

    Definition elimE G := delE (eclosure G).

    (** Epsilon elimination is epsilon-free *)
    Lemma efree_elimE G :
      efree (elimE G).
    Proof.
      apply delE_efree.
    Qed.

    (** Epsilon elimination preserves languages (except for epsilon) *)
    Lemma elimE_language G A u :
      u <> [] -> (language G A u <-> language (elimE G) A u).
    Proof.
      intros U. split ; intros [H1 H2] ; split ; auto.
      - apply (delE_der_equiv A u (eclosed_eclosure (G := G))).
        split ; auto.
        apply derT_der_equiv. now apply derT_der_equiv, der_eclosure_equiv in H1.
      - apply (delE_der_equiv A u (eclosed_eclosure (G := G))) in H1.
        destruct H1 as [H1 H3].
        apply derT_der_equiv. now apply derT_der_equiv, der_eclosure_equiv in H1.
    Qed.

  End ElimE.

End ElimE.


(**
「The Little Prover」のCoqでの実現
======
2017/08/02

2017/08/07 シンボルをstringを使うようにした。
2017/08/09 case: eqP を使うようにした。
2017/08/11 prove_nil タクティクを完成した。
2017/10/21 「定理証明手習い」発刊記念。
2019/07/24 Stringの定義をマージした。
2019/08/08 Proof Summit の発表に対応させる。

@suharahiromichi

- この文書のソースコードは以下にあります。

https://github.com/suharahiromichi/coq/blob/master/lisp/tlp_lisp_6.v

- バージョン

OCaml 4.07.1, Coq 8.9.0, MathComp 1.9.0
 *)

(**
# はじめに

「The Little Prover」（以下 TLP）[1] を読んで、
Coqの上でそれを実現しようとした話です。

TLPで証明しているプログラムをGallinaに移植して証明することは簡単です[2]。

しかし、これからやろうとするのは、
TLPの対象言語であるLispの「意味」をCoqで実現しようと思います。

それによって、

1. Coqはinductiveに定義したデータ型はinductionができることを原理としています。
   これに対して、TLPはinductionはハードコードされています。
   結果として、帰納法の公理からすべての定理を導くことができず、多くの「公理」を導入しています。
   帰納法の公理を使って、TLPの「公理」を証明することで、TLPの正しさが検証できるでしょう。

2. TLPはLispのプログラム（当然S式を返す）がnilでないことを証明する。
   これをもって、そのプログラムの意味する論理式が真であるとします。
   Coqは論理式（Prop型）でなければ証明できないので、
   これをLispのプログラムをCoqの論理式に埋め込むことで実現します。

CoqのMathcomp/SSReflect拡張を使用しているので、
それについては[3]を参照してください。
また、見ただけでは解らないようなタクティカル（"by case=> -> ->" など) の使用は避けています。
 *)

From mathcomp Require Import all_ssreflect.
Require Import String.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
(* Set Print All. *)

(**
# 文字列の定義

バニラCoqの定義を使用し、eqTypeのインスタンスにすることで、「==」が使えるようになります。
 *)
Definition string_eqMixin := @EqMixin string String.eqb String.eqb_spec.
Canonical string_eqType := @EqType string string_eqMixin.
Open Scope string_scope.

Check "aaa" = "aaa" : Prop.
Check "aaa" == "aaa" : bool.
Check "aaa" == "aaa" : Prop.

Section TLP.

(**
# S式の定義

S式をInductiveなデータ型として定義します。ここでは、
S式にことをTLPにあわせて Star型と呼ぶことにします。
*)

(**
##Atomic

アトムどうしのbooleanの等式を定義したうえで、それが、
論理式(ライプニッツの等式、Propの等式)と同値であることを証明することで、
boolとPropの間での行き来ができるようになります。
つまり、「==」と「=」の両方を使うことができるようになります。
これをリフレクションといいます[4]。

アトムとしては、シンボルの他に自然数もとれるようにします。
 *)

Inductive atomic : Type :=
| ATOM_NAT (n : nat)
| ATOM_SYM (s : string).

Definition eqAtom (a b : atomic) : bool :=
  match (a, b) with
  | (ATOM_NAT n, ATOM_NAT m) => n == m
  | (ATOM_SYM s, ATOM_SYM t) => s == t      (* eqString *)
  | _ => false
  end.

Lemma atomic_eqP : forall (x y : atomic), reflect (x = y) (eqAtom x y).
Proof.
  move=> x y.
  apply: (iffP idP).
  - case: x; case: y; rewrite /eqAtom => x y; move/eqP => H;
    by [rewrite H | | | rewrite H].
  - move=> H; rewrite H.
    case: y H => n H1;
    by rewrite /eqAtom.
Qed.

Definition atomic_eqMixin := @EqMixin atomic eqAtom atomic_eqP.
Canonical atomic_eqType := @EqType atomic atomic_eqMixin.

(**
##Star型 (S-EXP)

「Star型は、アトム、または、Star型のふたつ要素を連結(Cons)したもの」
と再帰的に定義できます。これがinductiveなデータ型です。
*)

Inductive star T : Type :=
| S_ATOM of T
| S_CONS of star T & star T.

(**
Coqはinductiveなデータ型に対して、inductionできるようになります。
そのために、star_ind という公理が自動的に定義されます。
これは、TLPの第7章で説明されている "star induction" と同じものです。

Coqによる証明でも、この公理を直接使用することはなく、
star型のデータに対して、
inductionタクティクまたはelimタクティクを使用すると、
この公理が適用されます。
 *)

Check star_ind : forall (T : Type) (P : star T -> Prop),
    (forall t : T, P (S_ATOM t)) ->
    (forall s : star T, P s -> forall s0 : star T, P s0 -> P (S_CONS s s0)) ->
    forall s : star T, P s.

(**
Star型についても、booleanの等号を定義して、論理式の等号にリフレク
ションできるようにします。
*)

Fixpoint eqStar {T : eqType} (x y : star T) : bool :=
  match (x, y) with
  | (S_ATOM a, S_ATOM b) => a == b          (* eqType *)
  | (S_CONS x1 y1, S_CONS x2 y2) => eqStar x1 x2 && eqStar y1 y2
  | _ => false
  end.

Lemma eqCons {T : eqType} (x y x' y' : star T) :
  (x = x' /\ y = y') -> S_CONS x y = S_CONS x' y'.
Proof.
  case=> Hx Hy.
    by rewrite Hx Hy.
Qed.

Lemma star_eqP : forall (T : eqType) (x y : star T), reflect (x = y) (eqStar x y).
Proof.
  move=> T x y.
  apply: (iffP idP).
  - elim: x y.
    + move=> x'.
      elim=> y.
      * by move/eqP => <-.                  (* ATOM と ATOM *)
      * done.                               (* ATOM と CONS *)
    + move=> x Hx y Hy.
      elim.
      * done.                               (* CONS と ATOM *)
      * move=> x' IHx y' IHy.               (* CONS と CONS *)
        move/andP.
        case=> Hxx' Hyy'.
        apply: eqCons.
        split.
        ** by apply: (Hx x').
        ** by apply: (Hy y').
  -  move=> <-.
     elim: x.
     * by move=> a /=.
     * move=> x Hx y' Hy /=.
         by apply/andP; split.
Qed.

Definition star_eqMixin (T : eqType) := EqMixin (@star_eqP T).
Canonical star_eqType (T : eqType) := EqType (star T) (star_eqMixin T).

(**
# 埋め込み

以降では、string型を要素（アトム）にもつS式だけを考えるので、その型を定義します。
*)

Definition star_exp := star atomic.

(**
S式を論理式(Prop)に埋め込めるようにします。このとき、Lispの真偽の定義から、

「真」 iff 「'NILでないS式」

としなければいけません。
実際には、S式からbooleanの等式 (x != 'NIL) へのコアーションを定義します。
これは、一旦boolを経由することで、論理式(Prop)の否定も扱えるようにするためです。
*)

Coercion is_not_nil (x : star_exp) : bool := x != (S_ATOM (ATOM_SYM "NIL")).

(**
さらに、S式の文脈で自然数とシンボルを直接書けるようにします。
次のコアーションで、S式のなかで、S_ATOM "ABC" の S_ATOM を省けるようになります。

これは、Lispの評価規則として正しくないかもしれませんが、
eval-quote式のLispの評価規則を実装することはTLPの範囲外と考え、
ここでは、書きやすさを優先することにします。

Set Printing Coercions.
を使うと、コアーションがどのように使われているか分かります。
*)

Coercion n_quote (n : nat) : star_exp := S_ATOM (ATOM_NAT n).
Coercion s_quote (s : string) : star_exp := S_ATOM (ATOM_SYM s).

Check "T" : string.
Check "T" : star_exp.
Check "T" : bool.
Check "T" : Prop.

Check 1 : nat.
Check 1 : star_exp.
Check 1 : bool.
Check 1 : Prop.

(**
アトムとの相互変換をする関数を用意します。
 *)

Definition s2n (x : star_exp) : nat :=
  match x with
  | S_ATOM (ATOM_NAT n) => n
  | _ => 0
  end.

Definition s2s (x : star_exp) : string :=
  match x with
  | S_ATOM (ATOM_SYM s) => s
  | _ => ""
  end.

(**
# 組込関数の定義
*)

Definition Cons (x y : star_exp) : star_exp := S_CONS x y.

Definition Car (x : star_exp) : star_exp :=
  match x with
  | S_ATOM _ => "NIL"
  | S_CONS x _ => x
  end.

Definition Cdr (x : star_exp) : star_exp :=
  match x with
  | S_ATOM _ => "NIL"
  | S_CONS _ y => y
  end.

Definition Atom (x : star_exp) : star_exp :=
  match x with
  | S_ATOM _ => "T"
  | S_CONS _ _ => "NIL"
  end.

(**
If と Equalは、booleanの等式で判定します。
 *)

Definition If (q a e : star_exp) : star_exp :=
  if q == s_quote "NIL" then e else a.
(* コアーションが機能しないので、左辺右辺どちらの型にあわせればよいか、指定する。 *)

Definition Equal (x y : star_exp) : star_exp :=
  if x == y then "T" else "NIL".

Fixpoint s_size (x : star_exp) : nat :=
  match x with
  | S_CONS a b => s_size a + s_size b + 1
  | _ => 0
  end.

Definition Size (x : star_exp) : star_exp := s_size x.
Eval compute in Size (Cons "T" (Cons "T" "T")). (* = S_ATOM (ATOM_NAT 2) *)

Definition Lt (x y : star_exp) : star_exp :=
  if s2n x < s2n y then "T" else "NIL".
Eval compute in Lt 2 3.                     (* = S_ATOM (ATOM_SYM "T") *)

Definition Plus (x y : star_exp) : star_exp := s2n x + s2n y.
Eval compute in Plus 2 3.                   (* = S_ATOM (ATOM_NAT 5) *)

(**
# 補題

のちの証明で便利なように、'NILに関する補題を証明しておきます。

``_ != _`` は ``~~(_ == _)`` の略記なので、次はis_not_nil と同じことです。
が、忘れがちなので定義しておきます。
 *)

Lemma not_nil_E q : ~~ (q == "NIL") = q.
Proof.
  done.
Qed.

(**
二重否定を解消するための補題です。
*)

Lemma not_not_nil__nil_E (q : star_exp) :
  ~~ (q != s_quote "NIL") = (q == s_quote "NIL").
(* コアーションが機能しないので、左辺右辺どちらの型にあわせればよいか、指定する。 *)
Proof.
    by case: eqP.
Qed.

Lemma not_q__q_nil_E (q : star_exp) : ~q <-> q = "NIL".
Proof.
  split.
  - rewrite /is_not_nil => /negP H.
    apply/eqP.
      by rewrite -not_not_nil__nil_E.
  - by move=> ->.
Qed.

Lemma q__q_not_nil_E (q : star_exp) : q <-> q <> "NIL".
Proof.
  rewrite /is_not_nil.
  split.
  - move=> H.
      by apply/eqP.
  - by move/eqP.
Qed.

(**
# タクティク
 *)

(**
## prove_nil

ゴールおよび前提の NIL に関する命題を q=NIL または q<>NIL に変換するものです。
前提とゴールが同じでなくても、
前提に q=NILとq<>NILの両方があるなら、矛盾からdoneで証明が終わることができます。

なお、~~(q==NIL) は q!=NIL と同じなので、条件としてあらわれません。
 *)

Ltac prove_nil :=
  repeat match goal with
         | [ H : is_true (?q != "NIL")     |- _ ] => move/eqP            in H
         | [ H : is_true (is_not_nil ?q)   |- _ ] => move/q__q_not_nil_E in H

         | [ H : is_true (?q == "NIL")     |- _ ] => move/eqP            in H
         | [ H : ~ is_true (is_not_nil ?q) |- _ ] => move/not_q__q_nil_E in H

         | [ |- is_true (?q != "NIL")           ] => apply/eqP
         | [ |- is_true (is_not_nil ?q)         ] => apply/q__q_not_nil_E

         | [ |- is_true (?q == "NIL")           ] => apply/eqP
         | [ |- ~ is_true (is_not_nil ?q)       ] => apply/not_q__q_nil_E

         end.

(**
# IFとEQUALの補題

TLPの定理は、(EQUAL X Y) または (IF Q 'T (EQUAL X Y)) または (IF Q (EQUAL X Y) 'T)
のかたちをしているので、
それをCoqの等式と同値であることを証明しておきます。
これらは、TLPの定理の証明や、その定理を使うときに使用します。
 *)

Lemma equal_eq {x y : star_exp} : (Equal x y) -> x = y.
Proof.
  rewrite /Equal.
    by case: eqP.
Qed.

Lemma ifAP {q x y : star_exp} : (If q (Equal x y) "T") <-> (q -> x = y).
Proof.
  split.
  - rewrite /If /Equal.
    case: eqP => Hq_nil.
    + move=> _ Hq.
        by prove_nil.
    + by case: eqP.

  - move=> H.
    rewrite /If; case: eqP => // Hnot_nil_q.    (* q <> NIL *)
    rewrite /Equal; case: ifP => // => Hx_ne_y. (* x <> y) *)
    exfalso.

    move/negbT/negP in Hx_ne_y.
    apply: Hx_ne_y.
    apply/eqP.
    apply: H.
      by prove_nil.
Qed.

Lemma ifEP {q x y : star_exp} : (If q "T" (Equal x y)) <-> (~q -> x = y).
Proof.
  split.
  - rewrite /If /Equal.
    case: eqP => Hq_nil.
    + by case: eqP.
    + move=> _ Hnq.
        by prove_nil.

  - move=> H.
    rewrite /If; case: eqP => // Hq_nil.        (* q = NIL  *)
    rewrite /Equal; case: eqP => // => Hx_ne_y. (* x <> y) *)
    exfalso.

    apply: Hx_ne_y.
    apply: H.
      by prove_nil.
Qed.

(*
    Set Printing Coercions.
 *)

(**
# J-Bobの「公理」の証明

ここまでに用意した道具を使って、証明をおこないます。
*)

Theorem equal_same (x : star_exp) :
  (Equal x x).
Proof.
    by rewrite /Equal eq_refl.
Qed.

Theorem atom_cons (x y : star_exp) :
  (Equal (Atom (Cons x y)) "NIL").
Proof.
  done.
Qed.

Theorem car_cons (x y : star_exp) :
  (Equal (Car (Cons x y)) x).
Proof.
  rewrite /Equal.
    by case: eqP.
Qed.

Theorem cdr_cons (x y : star_exp) :
  (Equal (Cdr (Cons x y)) y).
Proof.
  rewrite /Equal.
    by case: eqP.
Qed.

Theorem equal_swap (x y : star_exp) :
  (Equal (Equal x y) (Equal y x)).
Proof.
  rewrite {3}/Equal {2}/Equal {1}eq_sym.
    by rewrite /Equal eq_refl.
Qed.

Theorem equal_if (x y : star_exp) :
  (If (Equal x y) (Equal x y) "T").
Proof.
    by rewrite /If; case: eqP; move/eqP.
Qed.

Theorem if_true (x y : star_exp) :
  (Equal (If "T" x y) x).
Proof.
    by rewrite /Equal; case: eqP.
Qed.

Theorem if_false (x y : star_exp) :
  (Equal (If "NIL" x y) y).
Proof.
    by rewrite /Equal; case: eqP.
Qed.

Theorem if_same (x y : star_exp) :
  (Equal (If x y y) y).
Proof.
  rewrite /If.
  case: ifP;
    by rewrite /Equal eq_refl.
Qed.

Theorem if_nest_A (x y z : star_exp) :
  (If x (Equal (If x y z) y) "T").
Proof.
  rewrite /If; case: eqP => //.
    by rewrite /Equal eq_refl.
Qed.

Theorem if_nest_E (x y z : star_exp) :
  (If x "T" (Equal (If x y z) z)).
Proof.
  rewrite /If; case: eqP => //.
    by rewrite /Equal eq_refl.
Qed.

Lemma l_cons_car_cdr (x : star_exp) :
  (Atom x) = "NIL" -> (Cons (Car x) (Cdr x)) = x.
Proof.
  move=> Hn.
  case Hc: x; rewrite /Cons => //.
    by rewrite Hc in Hn.                    (* 前提の矛盾 *)
Qed.

Theorem cons_car_cdr (x : star_exp) :
  (If (Atom x) "T" (Equal (Cons (Car x) (Cdr x)) x)).
Proof.
  rewrite /If; case: eqP => Hq //.
  rewrite l_cons_car_cdr //.
    by rewrite /Equal eq_refl.
Qed.

Lemma l_size_car (x : star_exp) :
  Atom x = "NIL" -> s_size (Car x) < s_size x.
Proof.
  elim: x.
  - by move=> a Hc //.
  - move=> x Hx y Hy Hc /=.
    (* s_size x < s_size x + s_size y + 1 *)
      by rewrite addn1 ltnS leq_addr.
Qed.

Lemma l_size_cdr (x : star_exp) :
  Atom x = "NIL" -> s_size (Cdr x) < s_size x.
Proof.
  elim: x.
  - by move=> a Hc //.
  - move=> x Hx y Hy Hc /=.
    (* s_size y < s_size x + s_size y + 1 *)
    rewrite [s_size x + s_size y]addnC.
      by rewrite addn1 ltnS leq_addr.
Qed.

Theorem size_car (x : star_exp) :
  (If (Atom x) "T" (Equal (Lt (Size (Car x)) (Size x)) "T")).
Proof.
  apply/ifEP => Hq.
  rewrite /Lt /= l_size_car.
  - by [].
  - by apply/not_q__q_nil_E.
Qed.

Theorem size_cdr (x : star_exp) :
  (If (Atom x) "T" (Equal (Lt (Size (Cdr x)) (Size x)) "T")).
Proof.
  apply/ifEP => Hq.
  rewrite /Lt /= l_size_cdr.
  - by [].
  - by apply/not_q__q_nil_E.
Qed.

(**
# 「公理」を書換規則として使う

TLPでは、以上の「公理」を問題プログラムの 書換 に使用します。
Coqの場合、書換 は、X = Y または Q -> (X = Y) のかたちでなければなりません。
後者の場合、書換えにともなって、新しいゴールとしてQが追加されます。

## 「公理」の書換への変換

Equalのかたちをした「公理」を等式に変換するには、equal_eq を使います。
 *)
Section TLP_REWRITE_CHECK.

  Variables q x y : star_exp.

  Section TLP_REWRITE_CHECK_0.

    Variable e : (Equal x y).
    Check equal_eq e : x = y.
  End TLP_REWRITE_CHECK_0.

(**
If式のかたちをした「公理」を等式に変換するには、
(iffLR ifAP) または (iffLR ifEP) を使います。
 *)
  Section TLP_REWRITE_CHECK_1.
    (** (If Q (Equal X Y) "T") の場合。 *)

    Variable ifa : (If q (Equal x y) "T").
    Check iffLR ifAP ifa : q -> x = y.

  End TLP_REWRITE_CHECK_1.

  Section TLP_REWRITE_CHECK_2.
    (** (If Q "T" (Equal X Y)) の場合。 *)

    Variable ife : (If q "T" (Equal x y)).
    Check iffLR ifEP ife : ~ q -> x = y.

  End TLP_REWRITE_CHECK_2.
End TLP_REWRITE_CHECK.

(**
## 書換の例
 *)
Section TLP_REWRITE_SAMPLE.

  Variables x y z : star_exp.

  Check equal_eq (equal_same x)      : x = x.
  Check iffLR ifAP (if_nest_A x y z) : x -> (If x y z) = y.
  Check iffLR ifEP (size_cdr x)      : ~ Atom x -> (Lt (Size (Cdr x)) (Size x)) = "T".

End TLP_REWRITE_SAMPLE.

(**
# 定理の証明の例
*)

Require Import Program.
Require Import Recdef.

Function Ctxp (x : star_exp) {measure s_size x} : star_exp :=
  if (Atom x) then
    (Equal x "?")
  else
    (If (Ctxp (Car x)) "t" (Ctxp (Cdr x))).
Proof.
  - move=> x H.
    apply/ltP.
    apply: l_size_cdr.
    apply/eqP.
    move/eqP/eqP in H.
    done.
  - move=> x H.
    apply/ltP.
    apply: l_size_car.
    apply/eqP.
    move/eqP/eqP in H.
    done.
Defined.

Function Sub (x y : star_exp) {measure s_size y} : star_exp :=
  if (Atom y) then
    (If (Equal y "?") x y)
  else
    (Cons (Sub x (Car y))
          (Sub x (Cdr y))).
Proof.
  - move=> x y H.
    apply/ltP.
    apply: l_size_cdr.
    apply/eqP.
    move/eqP/eqP in H.
    done.
  - move=> x y H.
    apply/ltP.
    apply: l_size_car.
    apply/eqP.
    move/eqP/eqP in H.
    done.
Defined.

Lemma test1 (s1 s2 : star_exp) :
  (Ctxp s1) || (Ctxp s2) = (Ctxp (Cons s1 s2)).
Proof.
Admitted.

Lemma test (x s1 s2 : star_exp) :
  (Sub x (S_CONS s1 s2)) = (Cons (Sub x s1) (Sub x s2)).
Proof.
Admitted.

Lemma Ctxp_Sub (x y : star_exp) :
  (Ctxp x) -> (Ctxp y) -> (Ctxp (Sub x y)).
Proof.
  elim: y.
  - move=> t H1 H2.
    rewrite /Ctxp /= in H2.
    rewrite (equal_eq H2).
    rewrite /Sub /=.
    rewrite /Equal /=.
    rewrite /If /=.
    done.
  - move=> s1 IH1 s2 IH2 H4 H5.
    rewrite -test1 in H5.
    move/orP in H5.
    rewrite test.
    move: (IH1 H4)  => {IH1} IH1.
    move: (IH2 H4)  => {IH2} IH2.
    case: H5.
    + move=> Hs1.
      move: (IH1 Hs1) => {IH1} IH1.
      rewrite -test1.
      apply/orP.
      by left.
    + move=> Hs2.
      move: (IH2 Hs2) => {IH2} IH2.
      rewrite -test1.
      apply/orP.
      by right.
Qed.

(**
## より Gallina 風の定義

公理も組み込み関数も使わない。
*)

Fixpoint ctxp (x : star_exp) : star_exp :=
  match x with
  | S_CONS x1 x2 => if (ctxp x1) then (s_quote "T") else (ctxp x2)
  | _ => if x == (s_quote "?") then "T" else "F"
  end.

Fixpoint sub (x y : star_exp) : star_exp :=
  match y with
  | S_CONS y1 y2 => S_CONS (sub x y1) (sub x y2)
  | _ => if y == (s_quote "?") then x else y
  end.

Lemma test1' (s1 s2 : star_exp) :
  (ctxp s1) || (ctxp s2) = (ctxp (S_CONS s1 s2)).
Proof.
  rewrite /=.
    by case: ifP.
Qed.

Lemma test' (x s1 s2 : star_exp) :
  (sub x (S_CONS s1 s2)) = (S_CONS (sub x s1) (sub x s2)).
Proof.
  done.
Qed.

Lemma ctxp_sub (x y : star_exp) :
  (ctxp x) -> (ctxp y) -> (ctxp (sub x y)).
Proof.
  elim: y.
  - move=> t Hx Ht /=.
    by case: ifP.
  - move=> s1 IHs1 s2 IHs2 H4 H5 /=.
    rewrite -test1' in H5.
    move/orP in H5.
    move: (IHs1 H4)  => {IHs1} IHs1.
    move: (IHs2 H4)  => {IHs2} IHs2.
    case: H5.
    + move=> Hs1.
      move: (IHs1 Hs1) => {IHs1} IHs1.
      case: ifP.
      * done.
      * move=> H1.
        move/negbT in H1.
        move/negP in H1.
        done.
    + move=> Hs2.
      move: (IHs2 Hs2) => {IHs2} IHs2.
      case: ifP.
      * done.
      * move=> H2.
        move/negbT in H2.
        move/negP in H2.
        done.
Qed.

End TLP.

(**
# 参考文献

[1] Daniel P. Friedman, Carl Eastlund, "The Little Prover", MIT Press, 2015.

https://mitpress.mit.edu/books/little-prover

中野圭介監訳、「定理証明手習い」、ラムダノート、2017。

https://www.lambdanote.com/collections/littleprover

[2] 「The Little Prover の memb?/remb をCoqで解いてみる（サブリスト改訂版）」

https://github.com/suharahiromichi/coq/blob/master/prog/coq_membp_remb_3.v

[3] Mathematical Components resources

http://ssr.msr-inria.inria.fr/

[4] 「リフレクションのしくみをつくる」

http://qiita.com/suharahiromichi/items/9cd109386278b4a22a63
 *)

(* END *)


Require Import Game.
Require Import BaseGame.

Section TurnGame.

Variable g:Game.

Definition is_turn_function (turn:state g -> nat) : Prop :=
  turn (start g) = 0 /\
  forall s:state g, accessible_states g s ->
    forall dec:decision_fun g s, turn (rules g s dec) = S (turn s).

Definition is_strong_turn_function (turn:state g -> nat) : Prop :=
  turn (start g) = 0 /\
  forall s:state g,
  forall dec:decision_fun g s,
    turn (rules g s dec) = S (turn s).

Lemma strong_turn_is_turn : forall turn:state g -> nat, is_strong_turn_function turn -> is_turn_function turn.
Proof.
  intros.
  edestruct H.
  split.
  exact H0.
  intros.
  apply H1.
Qed.

Definition is_turned_game : Prop :=
  exists turn : state g -> nat, is_turn_function turn.

Definition is_strong_turned_game : Prop :=
  exists turn : state g -> nat, is_strong_turn_function turn.

Lemma strong_turned_is_turned : is_strong_turned_game -> is_turned_game.
Proof.
  intros.
  edestruct H.
  exists x.
  exact (strong_turn_is_turn x H0).
Qed.

Lemma turn_functions_coincide_on_accessible : forall t1 t2:state g -> nat, is_turn_function t1 -> is_turn_function t2 -> forall s:state g, accessible_states g s -> t1 s = t2 s.
Proof.
  intro.
  intro.
  intro.
  intro.
  edestruct H.
  edestruct H0.
  apply accessible_states_from_ind.
  rewrite H1, H3.
  auto.
  intros.
  rewrite (H2 s H5 dec).
  rewrite (H4 s H5 dec).
  rewrite H6.
  auto.
Qed.

End TurnGame.


(***************************************************************************
* Equivalence of big-step and small-step in call-by-value - Definitions    *
* Arthur Chargueraud, March 2009                                           *
***************************************************************************)

Set Implicit Arguments.
Require Import LibLN.

(* ********************************************************************** *)
(** ** Grammar of pre-terms *)

Inductive trm : Set :=
  | trm_bvar : nat -> trm
  | trm_fvar : var -> trm
  | trm_abs  : trm -> trm
  | trm_app  : trm -> trm -> trm.

(* ********************************************************************** *)
(** ** Operation to open up abstractions. *)

Fixpoint open_rec (k : nat) (u : trm) (t : trm) {struct t} : trm :=
  match t with
  | trm_bvar i    => If k = i then u else (trm_bvar i)
  | trm_fvar x    => trm_fvar x
  | trm_app t1 t2 => trm_app (open_rec k u t1) (open_rec k u t2)
  | trm_abs t1    => trm_abs (open_rec (S k) u t1)
  end.

Definition open t u := open_rec 0 u t.

Notation "t ^^ u" := (open t u) (at level 67).
Notation "t ^ x" := (open t (trm_fvar x)).

(* ********************************************************************** *)
(** ** Definition of well-formedness of a term *)

Inductive term : trm -> Prop :=
  | term_var : forall x,
      term (trm_fvar x)
  | term_app : forall t1 t2,
      term t1 -> term t2 -> term (trm_app t1 t2)
  | term_abs : forall L t1,
      (forall x, x \notin L -> term (t1 ^ x)) ->
      term (trm_abs t1).

(* ********************************************************************** *)
(** ** Definition of the body of an abstraction *)

Definition body t :=
  exists L, forall x, x \notin L -> term (t ^ x).

(* ********************************************************************** *)
(** ** Definition of the small-step semantics *)

Inductive value : trm -> Prop :=
  | value_abs : forall t1,
      term (trm_abs t1) -> value (trm_abs t1).

Inductive beta : trm -> trm -> Prop :=
  | beta_red : forall t1 t2,
      body t1 ->
      value t2 ->
      beta (trm_app (trm_abs t1) t2) (t1 ^^ t2)
  | beta_app1 : forall t1 t1' t2,
      term t2 ->
      beta t1 t1' ->
      beta (trm_app t1 t2) (trm_app t1' t2)
  | beta_app2 : forall t1 t2 t2',
      value t1 ->
      beta t2 t2' ->
      beta (trm_app t1 t2) (trm_app t1 t2').

Inductive beta_star : trm -> trm -> Prop :=
  | beta_star_refl : forall t,
      term t ->
      beta_star t t
  | beta_star_step : forall t2 t1 t3,
      beta t1 t2 ->
      beta_star t2 t3 ->
      beta_star t1 t3.

(* ********************************************************************** *)
(** ** Definition of the big-step semantics *)

Inductive reds : trm -> trm -> Prop :=
  | reds_val : forall t1,
      value t1 ->
      reds t1 t1
  | reds_red : forall t3 v2 v3 t1 t2,
      reds t1 (trm_abs t3) ->
      reds t2 v2 ->
      reds (t3 ^^ v2) v3 ->
      reds (trm_app t1 t2) v3.

(* ********************************************************************** *)
(** ** Definition of the big-step semantics *)

Definition equivalence := forall t v,
  reds t v <-> beta_star t v /\ value v.


(** Implementation of a typechecker for
    the trust calculus **)

Require Import Utils Context Tactics Syntax TypeSystem Subtype.
Require Import Wf Wellfounded.Lexicographic_Product Coq.Program.Tactics Omega.
Require Import Relation_Operators Transitive_Closure Recdef Program.
Require Import Ty.

(** security type ordering is decidable **)

Definition sec_ordering_dec : forall (s s' : secty), {sec_ordering s s'} + {~ sec_ordering s s'}.
   refine (
     fun (s s' : secty) =>
         match s, s' with
           | Trust, Untrust => _
           | Untrust, Trust => _
           | Trust, Trust => _
           | Untrust, Untrust => _
        end
    ) ; auto ; right ; intro H ; try solve by inversion.
Defined.

(** subtype relation is decidable **)

Definition typair_size (t t' : ty) := ty_size t + ty_size t'.

Ltac my_tac :=
  unfold typair_size ; intuition ; simpl in *; try subst ;
  try (match goal with
         | [H : subtype _ _ |- _] => inv H ; try contradiction
         | [H : arrow _ _ _ = ty_bool _ |- _] => inv H
         | [H : ty_bool _ = arrow _ _ _ |- _] => inv H
         | [|- _ /\ _] => split
         | [H : ex _ |- _] => destruct H
         | [H : Some _ = Some _ |- _] => inv H
         | [H : None = Some _ |- _] => congruence
         | [H : ?X -> False |- False] => apply H
       end) ; eauto.

Ltac s := try (repeat my_tac) ; (simpl ; try omega).

Obligation Tactic := s.

Program Fixpoint subtype_dec (t t' : ty) {measure (typair_size t t')} : {subtype t t'} + {~ subtype t t'} :=
  match t,t' with
    | ty_bool s, ty_bool s'
      => if sec_ordering_dec s s' then left _ else right _
    | arrow l r s, arrow l' r' s'
      => match (subtype_dec l' l), (subtype_dec r r'), sec_ordering_dec s s' with
            | left _, left _, left _ => left _
            | left _  , left _ , right _ => right _
            | left _ , right _ , left _ => right _
            | left _ , right _, right _ => right _
            | right _, left _, left _ => right _
            | right _, left _, right _ => right _
            | right _, right _, left _ => right _
            | right _, right _, right _ => right _
         end
    | _, _ => right _
  end.

Definition trustworth (t : ty) : {sectyof t = Trust} + {~ sectyof t = Trust}.
  decide equality.
Defined.

(** Defining the typechecker itself **)

Ltac start :=
     repeat
       (match goal with
         | [H : forall _, _ |- _] => intro ; start
         | [H : ~ _ |- _] => intro ; clear H
         | [H : ex _ |- _] => destruct H
         | [|- has_type_alg _ _ _] => econstructor (solve [eauto])
         | [H : (ty * ty)%type |- _] => destruct H
       end ; try subst ; simpl) ; eauto.

Definition var_dec : forall i (ctx : finite_map ty), {t | lookup i ctx = Some t} + {~ exists t, lookup i ctx = Some t}.
  intros i ctx.
  destruct (lookup i ctx) ; [left ; eexists | right ; intro] ; eauto.
  destruct H. inv H.
Defined.

Definition arrow_split (t : ty) : {(t1,t2) : ty * ty | exists s, t = arrow t1 t2 s} +
                                  {~ (exists t1, exists t2, exists s, t = arrow t1 t2 s)}.
  destruct t.
  right. intro H. destruct H as [t1 [t2 [s' H]]] ; inv H.
  left . exists (t1,t2). exists s. auto.
Defined.

Definition is_a_bool_ty : forall (t : ty), {exists s, subtype t (ty_bool s)} +
                                           {~ exists s, subtype t (ty_bool s)}.
   intros t ; destruct t.
   left. destruct s ; [exists Trust | exists Untrust] ; auto.
   right. intro H. destruct H as [s1 H1] ; inv H1.
Defined.

Definition typecheck_dec : forall(e : term) (ctx : finite_map ty),
  {t | has_type_alg ctx e t} + {forall t, ~ has_type_alg ctx e t}.
  refine (fix F (e : term) (ctx : finite_map ty) {struct e}:
     {t | has_type_alg ctx e t} + {forall t, ~ has_type_alg ctx e t} :=
     match e return {t | has_type_alg ctx e t} + {forall t, ~ has_type_alg ctx e t} with
       | tm_true => [|| (ty_bool Trust) ||]
       | tm_false => [|| (ty_bool Trust) ||]
       | tm_var i =>
           match var_dec i ctx with
             | inleft (exist t _) => [|| t ||]
             | inright _ => !!
           end
       | tm_abs i ty e =>
            ty' <-- F e (extend i ty ctx) ;
            [|| arrow ty ty' Trust ||]
       | tm_app l r =>
            tf <-- F l ctx ;
            ta <-- F r ctx ;
            p  <-- arrow_split tf ;
            subtype_dec ta (fst p) ;;;
            [|| update_secty (snd p) (sectyof tf) ||]
       | tm_trust t  =>
            ty <-- F t ctx ;
            [|| update ty Trust ||]
       | tm_distrust t =>
            ty <-- F t ctx ;
            [|| update ty Untrust ||]
       | tm_check t =>
            ty <-- F t ctx ;
            trustworth ty ;;;
            [|| ty ||]
     end) ; start.
     elim n ; inv H ; eexists ; eauto.
     simpl in *.
     destruct s1 as [[t2 t3] [s' He]] ; inv He.
     inv H.
     apply (has_type_alg_unique _ _ _ H2) in h ; inv h.
     apply (has_type_alg_unique _ _ _ h0) in H4 ; inv H4.
     contradiction.
     inv H ; elim n.
     apply (has_type_alg_unique _ _ _ H2) in h ; inv h.
     exists T11 ; exists T12 ; exists s1 ; auto.
     inv H ; apply n in H4 ; auto.
     inv H ; apply n in H2 ; auto.
     inv H ; apply n in H5 ; auto.
     inv H ; apply n in H2 ; auto.
     inv H ; apply n in H2 ; auto.
     inv H.
     apply (has_type_alg_unique _ _ _ h) in H1 ; subst.
     contradiction.
     inv H. apply n in H1 ; auto.
 Defined.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Nil : lst |Cons : natural -> lst -> lst .

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Fixpoint qreva (qreva_arg0 : lst) (qreva_arg1 : lst) : lst
           := match qreva_arg0, qreva_arg1 with
              | Nil, x => x
              | Cons z x, y => qreva x (Cons z y)
              end.
Lemma append_nil : forall (x : lst), append x Nil = x.
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma append_assoc : forall (x y z : lst), append (append x y) z = append x (append y z).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.
Theorem theorem0 : forall (x : lst) (y : lst), eq (rev (qreva x y)) (append (rev y) x).
Proof.
  induction x.
  - intros.  simpl. lfind.  reflexivity.
Admitted.


Require Import
  Coq.setoid_ring.Ring MathClasses.interfaces.naturals MathClasses.interfaces.abstract_algebra MathClasses.interfaces.orders
  MathClasses.orders.nat_int MathClasses.theory.integers MathClasses.theory.rings MathClasses.orders.rings.

Section contents.
Context `{Integers Z} `{Apart Z} `{!TrivialApart Z} `{!FullPseudoSemiRingOrder Zle Zlt} `{Naturals N}.

Add Ring Z : (rings.stdlib_ring_theory Z).

Lemma int_to_nat_unique_respectful {a b : IntAbs Z N} :
  ((=) ==> (=))%signature (int_to_nat Z N (ia:=a)) (int_to_nat Z N (ia:= b)).
Proof.
  intros x y E. unfold int_to_nat, int_abs_sig.
  apply (injective (naturals_to_semiring N Z)).
  destruct a as [[z1 A]|[z1 A]], b as [[z2 B]|[z2 B]].
     now rewrite A, B.
    destruct (naturals.to_ring_zero_sum z2 z1) as [? E2].
     now rewrite B, A, involutive.
    now rewrite E2.
   destruct (naturals.to_ring_zero_sum z1 z2) as [? E2].
    now rewrite B, A, involutive.
   now rewrite E2.
  reflexivity.
Qed.

Lemma int_to_nat_unique (a b : IntAbs Z N) (z : Z) :
  int_to_nat Z N (ia:=a) z = int_to_nat Z N (ia:=a) z.
Proof. now apply int_to_nat_unique_respectful. Qed.

Context `{!IntAbs Z N}.

Global Instance int_to_nat_proper: Setoid_Morphism (int_to_nat Z N) | 0.
Proof. split; try apply _. now apply int_to_nat_unique_respectful. Qed.

Context `{!SemiRing_Morphism (f : N → Z)}.

Lemma int_to_nat_spec x :
  { 0 ≤ x ∧ f (int_to_nat Z N x) = x } + { x ≤ 0 ∧ int_to_nat Z N x = 0 }.
Proof.
  unfold int_to_nat. destruct int_abs_sig as [[n E]|[n E]].
   left. rewrite <-E. split.
    now apply to_semiring_nonneg.
   apply (naturals.to_semiring_unique_alt _ _).
  right. intuition. apply flip_nonpos_negate. rewrite <-E.
  now apply to_semiring_nonneg.
Qed.

Lemma int_to_nat_nat n :
  int_to_nat Z N (f n) = n.
Proof.
  apply (injective f). destruct (int_to_nat_spec (f n)) as [[??]|[? E]]; intuition.
  rewrite E, preserves_0. apply (antisymmetry (≤)); intuition.
  now apply to_semiring_nonneg.
Qed.

Lemma int_to_nat_cancel_l x n :
  x = f n → int_to_nat Z N x = n.
Proof. intros E. now rewrite E, int_to_nat_nat. Qed.

Lemma int_to_nat_cancel_r x n :
  f n = x → n = int_to_nat Z N x.
Proof. intros E. now rewrite <-E, int_to_nat_nat. Qed.

Lemma int_to_nat_negate_nat n :
  int_to_nat Z N (-f n) = 0.
Proof.
  apply (injective f). destruct (int_to_nat_spec (-f n)) as [[? E]|[? E]].
   rewrite E, preserves_0. apply (antisymmetry (≤)); intuition.
   apply rings.flip_nonneg_negate. now apply to_semiring_nonneg.
  now rewrite E.
Qed.

Lemma int_to_nat_0 : int_to_nat Z N 0 = 0.
Proof. apply int_to_nat_cancel_l. now rewrite preserves_0. Qed.

Lemma int_to_nat_of_nonneg x :
  0 ≤ x → f (int_to_nat Z N x) = x.
Proof.
  intros E1. destruct (int_to_nat_spec x) as [[? E2]|[? E2]]; intuition.
  rewrite E2, preserves_0. now apply (antisymmetry (≤)).
Qed.

Lemma int_to_nat_of_nonpos x :
  x ≤ 0 → int_to_nat Z N x = 0.
Proof.
  intros E. destruct (int_to_nat_spec x) as [[? E2]|]; intuition.
  apply int_to_nat_cancel_l. rewrite preserves_0.
  now apply (antisymmetry (≤)).
Qed.

Lemma int_to_nat_nonneg_plus x y :
  0 ≤ x → 0 ≤ y → int_to_nat Z N (x + y) = int_to_nat Z N x + int_to_nat Z N y.
Proof.
  intros. apply (injective f).
  rewrite preserves_plus, !int_to_nat_of_nonneg; intuition.
  now apply nonneg_plus_compat.
Qed.

Lemma int_to_nat_mult_nonneg_l x y :
  0 ≤ x → int_to_nat Z N (x * y) = int_to_nat Z N x * int_to_nat Z N y.
Proof.
  intros E. apply (injective f). rewrite preserves_mult.
  rewrite (int_to_nat_of_nonneg x) by easy.
  destruct (int_to_nat_spec y) as [[? Ey]|[? Ey]]; rewrite Ey, ?preserves_0.
   rewrite int_to_nat_of_nonneg. easy. now apply nonneg_mult_compat.
  rewrite int_to_nat_of_nonpos, preserves_0. ring. now apply nonneg_nonpos_mult.
Qed.

Lemma int_to_nat_mult_nonneg_r x y :
  0 ≤ y → int_to_nat Z N (x * y) = int_to_nat Z N x * int_to_nat Z N y.
Proof.
  rewrite (commutativity x), (commutativity (int_to_nat Z N x)).
  now apply int_to_nat_mult_nonneg_l.
Qed.

Lemma int_to_nat_1 : int_to_nat Z N 1 = 1.
Proof. apply int_to_nat_cancel_l. now rewrite preserves_1. Qed.

Context `{Apart N} `{!TrivialApart N} `{!FullPseudoSemiRingOrder (A:=N) Nle Nlt}.

Global Instance int_to_nat_nonneg x :
  PropHolds (0 ≤ int_to_nat Z N x).
Proof.
  destruct (int_to_nat_spec x) as [[? E]|[? E]].
   apply (order_reflecting f). now rewrite preserves_0, E.
  rewrite E. solve_propholds.
Qed.

Global Instance int_to_nat_pos x :
  PropHolds (0 < x) → PropHolds (0 < int_to_nat Z N x).
Proof.
  rewrite !lt_iff_le_ne. intros [??]. split.
   solve_propholds.
  apply (setoids.morphism_ne f).
  now rewrite preserves_0, int_to_nat_of_nonneg.
Qed.

Lemma int_to_nat_le_l x y :
  0 ≤ x → x ≤ y → f (int_to_nat Z N x) ≤ y.
Proof. intros. now rewrite int_to_nat_of_nonneg. Qed.

Lemma int_to_nat_le_cancel_l x n :
  0 ≤ x → x ≤ f n → int_to_nat Z N x ≤ n.
Proof. intros. now apply (order_reflecting f), int_to_nat_le_l. Qed.

Lemma int_to_nat_le_r x y :
  x ≤ y → x ≤ f (int_to_nat Z N y).
Proof.
  intros E1. destruct (int_to_nat_spec y) as [[? E2]|[? E2]].
   now rewrite E2.
  rewrite E2, preserves_0. now transitivity y.
Qed.

Lemma int_to_nat_le_cancel_r x n :
  f n ≤ x → n ≤ int_to_nat Z N x.
Proof. intros. now apply (order_reflecting f), int_to_nat_le_r. Qed.

Global Instance: OrderPreserving (int_to_nat Z N).
Proof.
  repeat (split; try apply _). intros x y E.
  destruct (total (≤) 0 x).
   now apply int_to_nat_le_cancel_r, int_to_nat_le_l.
  rewrite int_to_nat_of_nonpos. solve_propholds. easy.
Qed.

Lemma int_to_nat_le_back x y :
  0 ≤ y → int_to_nat Z N x ≤ int_to_nat Z N y → x ≤ y.
Proof.
  intros. rewrite <-(int_to_nat_of_nonneg y) by easy.
  transitivity (f (int_to_nat Z N x)).
   now apply int_to_nat_le_r.
  now apply (order_preserving f).
Qed.

Lemma int_to_nat_lt_l x y :
  0 ≤ x → x < y → f (int_to_nat Z N x) < y.
Proof. intros. now rewrite int_to_nat_of_nonneg. Qed.

Lemma int_to_nat_lt_cancel_l x n :
  0 ≤ x → x < f n → int_to_nat Z N x < n.
Proof. intros. now apply (strictly_order_reflecting f), int_to_nat_lt_l. Qed.

Lemma int_to_nat_lt_r x y :
  x < y → x < f (int_to_nat Z N y).
Proof.
  intros E1. destruct (int_to_nat_spec y) as [[? E2]|[? E2]].
   now rewrite E2.
  rewrite E2, preserves_0. now apply lt_le_trans with y.
Qed.

Lemma int_to_nat_lt_cancel_r x n :
  f n < x → n < int_to_nat Z N x.
Proof. intros. now apply (strictly_order_reflecting f), int_to_nat_lt_r. Qed.

Lemma int_to_nat_lt x y :
  0 < y → x < y → int_to_nat Z N x < int_to_nat Z N y.
Proof.
  intros Ey Exy. destruct (total (≤) 0 x).
   now apply int_to_nat_lt_cancel_r, int_to_nat_lt_l.
  rewrite int_to_nat_of_nonpos by easy. now apply int_to_nat_pos.
Qed.

Lemma int_to_nat_lt_back x y :
  0 ≤ y → int_to_nat Z N x < int_to_nat Z N y → x < y.
Proof.
  intros. rewrite <-(int_to_nat_of_nonneg y) by easy.
  apply le_lt_trans with (f (int_to_nat Z N x)).
   now apply int_to_nat_le_r.
  now apply (strictly_order_preserving f).
Qed.
End contents.


Require Import stdpp.base stdpp.list.

Fixpoint find_index {A} (P: A -> Prop) {H': forall x, Decision (P x)}
         (l: list A): option nat :=
  match l with
  | nil => None
  | cons x l => if decide (P x) then Some 0%nat
               else option_map S (find_index P l)
  end.

From Coq Require Import ssreflect.

Lemma find_index_Some {A} (P: A -> Prop) {H': forall x, Decision (P x)}:
  forall l i, find_index P l = Some i ->
         (exists v, l !! i = Some v /\ P v) /\
         (forall i', (i' < i)%nat -> exists v', l !! i' = Some v' /\ not (P v')).
Proof.
  induction l; first done; simpl in *.
  case; simpl; destruct (decide (P a)).
  by intros _; split; [eauto|intros i; lia].
  by destruct (find_index P l).
  done.
  destruct (find_index P l); try done.
  simpl in *.
  intros n' ?; simplify_eq.
  destruct (IHl _ eq_refl) as [HEl HRst].
  split; first done.
  case; simpl; first by eauto.
  intros. apply HRst. lia.
Qed.

Lemma find_index_None {A} (P: A -> Prop) {H': forall x, Decision (P x)}:
  forall l, find_index P l = None -> forall v, In v l -> not (P v).
Proof.
  induction l; simpl; first done.
  destruct (decide (P a)); first done.
  destruct (find_index P l); first done.
  intros _ ? HEv; subst.
  inversion HEv; subst; eauto.
Qed.