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

(**********************************************************************)
(*                    Abstraction.v                                   *)
(*                                                                    *)
(*                     Barry Jay                                      *)
(*                                                                    *)
(**********************************************************************)

Require Import Omega Max Bool List.
Require Import IntensionalLib.SF_calculus.Test.
Require Import IntensionalLib.SF_calculus.General.
Require Import IntensionalLib.Wave_as_SF.SF_Terms.
Require Import IntensionalLib.Wave_as_SF.SF_Tactics.
Require Import IntensionalLib.Wave_as_SF.SF_reduction.
Require Import IntensionalLib.Wave_as_SF.SF_Normal.
Require Import IntensionalLib.Wave_as_SF.SF_Closed.
Require Import IntensionalLib.Wave_as_SF.Substitution.
Require Import IntensionalLib.Wave_as_SF.SF_Eval.
Require Import IntensionalLib.Wave_as_SF.Star.
Require Import IntensionalLib.Wave_as_SF.Wait.
Require Import IntensionalLib.Wave_as_SF.Fixpoints.
Require Import IntensionalLib.Wave_as_SF.Wave_Factor.
Require Import IntensionalLib.Wave_as_SF.Wave_Factor2.
Require Import IntensionalLib.Wave_as_SF.Equal.
Require Import IntensionalLib.Wave_as_SF.Extensions.
Require Import IntensionalLib.Wave_as_SF.Wait2.

Definition h_fn :=
star_opt (star_opt (star_opt (star_opt
(App (App (Ref 3) (App (App (Ref 3) (Ref 2)) (Ref 1))) (Ref 0))))).

Definition h_op := app_comb (Y_k 4) h_fn .

Lemma h_red: forall M N P, sf_red (App (App (App h_op M) N) P) (App (App h_op (App (App h_op M) N)) P).
Proof.
intros. unfold h_op at 1.
eapply transitive_red.
eapply preserves_app_sf_red. eapply preserves_app_sf_red. eapply2 app_comb_red. all: auto.
eapply transitive_red.
eapply2 Y4_fix.
unfold h_fn at 1.
eapply transitive_red.
eapply preserves_app_sf_red.
eapply2 star_opt_beta3. auto.
unfold subst.
rewrite ! subst_rec_preserves_star_opt.
eapply transitive_red.
eapply2 star_opt_beta.
unfold subst;
unfold subst_rec; fold subst_rec.
insert_Ref_out.
unfold subst_rec; fold subst_rec.
insert_Ref_out.
unfold lift; rewrite ! lift_rec_lift_rec; try omega. unfold plus.
rewrite ! subst_rec_lift_rec; try omega.
unfold subst_rec; fold subst_rec.
insert_Ref_out.
unfold subst_rec; fold subst_rec.
insert_Ref_out.
unfold lift; rewrite ! subst_rec_lift_rec; try omega.
rewrite ! lift_rec_null.
eapply2 zero_red.
Qed.

Definition j_op := app_comb (Y_k 2) h_op.

Lemma j_red: forall M, sf_red (App j_op M) (App (App h_op j_op) M).
Proof.
intros. unfold j_op at 1.
eapply transitive_red. eapply2 app_comb_red.
eapply transitive_red. eapply2 Y2_fix.
eapply2 zero_red.
Qed.

Definition r_op := app_comb (Y_k 3) (app_comb compose h_op).

Lemma r_red : forall M N, sf_red (App (App r_op M) N) (App (App h_op (App r_op M)) N).
Proof.
intros. unfold r_op at 1.
eapply transitive_red. eapply preserves_app_sf_red. eapply2 app_comb_red. auto.
eapply transitive_red. eapply2 Y3_fix.
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply2 app_comb_red. all: auto.
eapply transitive_red. eapply preserves_app_sf_red. eapply2 compose_composes. auto.
 eapply2 zero_red.
Qed.

Lemma r_aux:
forall M N , sf_red (App (App (Y_k 3) M) N) (app_comb (app_comb (app_comb (omega_k 3) (omega_k 3)) M) N) .
Proof.
intros; unfold Y_k.
eapply transitive_red. eapply preserves_app_sf_red.
eapply2 app_comb_red. auto.
eapply transitive_red. eapply preserves_app_sf_red.  eapply preserves_app_sf_red.
eapply2 app_comb_red. all: auto.
eapply transitive_red. eapply preserves_app_sf_red.  eapply preserves_app_sf_red.
eapply2 A3_red. all: auto.
eapply transitive_red. eapply preserves_app_sf_red.
eapply2 app_comb_red. auto.
eapply transitive_red. eapply preserves_app_sf_red.
eapply2 A3_red. all: auto.
eapply transitive_red.
eapply2 app_comb_red.
unfold A_k.
eapply2 a_op2_red.
Qed.

Definition ab_fn b' := star_opt (star_opt (star_opt (App (App (App b' (Ref 0)) (Ref 2)) (Ref 1)))).
(* b' is presumed closed *)
Definition ab_op b' := app_comb (A_k 3) (ab_fn b').

Lemma a_aux: forall b' M N, sf_red (App (App (ab_op b') M) N)
  (app_comb (app_comb (ab_fn b') M) N).
Proof.
intros.  unfold a_op.
eapply transitive_red. eapply preserves_app_sf_red.
eapply2 app_comb_red. auto.
eapply transitive_red. eapply preserves_app_sf_red.
eapply2 A3_red. all: auto.
eapply transitive_red.
eapply2 app_comb_red.
unfold A_k. eapply transitive_red.
eapply2 a_op2_red. all: auto.
Qed.

Lemma Y4_aux : forall M N P, sf_red (App (App (app_comb (Y_k 4) M) N) P)
(app_comb (app_comb (app_comb (app_comb (omega_k 4) (omega_k 4)) M) N) P).
Proof.
intros.
eapply transitive_red. eapply preserves_app_sf_red.
eapply2 app_comb_red. auto.
unfold Y_k; fold Y_k.
eapply transitive_red. eapply preserves_app_sf_red.  eapply preserves_app_sf_red.
eapply2 app_comb_red. all: auto.
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply preserves_app_sf_red.
eapply2 app_comb_red. all: auto.
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply preserves_app_sf_red.
eapply2 A3_red. all: auto.
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply2 app_comb_red. all: auto.
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply2 A3_red. all: auto.
eapply transitive_red. eapply preserves_app_sf_red.
eapply2 app_comb_red. all: auto.
eapply transitive_red. eapply preserves_app_sf_red.
eapply2 A3_red. all: auto.
eapply transitive_red.
eapply2 app_comb_red.
unfold A_k.
eapply2 a_op2_red.
Qed.

Lemma pattern_size_app_comb: forall M N, pattern_size (app_comb M N) = pattern_size N + pattern_size M.
Proof. intros. unfold app_comb. simpl. auto. Qed.

Lemma omega_k_closed: forall k, maxvar(omega_k k) = 0.
Proof.
induction k; split_all.
unfold omega_k; fold omega_k.
rewrite ! maxvar_star_opt.
rewrite maxvar_app.
rewrite ! maxvar_app_comb.
rewrite A_k_closed.
simpl. auto.
Qed.

Definition b_fn :=
star_opt (star_opt (star_opt (
extension (app_comb (app_comb (app_comb (app_comb (omega_k 4) (omega_k 4)) h_fn) (Ref 0)) (Ref 1))
          (App (App (App (App (Ref 4) (Ref 3)) (Ref 2)) (Ref 0))   (* H (Ref 0) (Ref 1) *)
               (App (App (App (Ref 4) (Ref 3)) (Ref 2)) (Ref 1))) (
extension (app_comb (app_comb (app_comb (app_comb (omega_k 4) (omega_k 4)) (Ref 0)) (Ref 1)) (Ref 2)) (
          (App (App (app_comb (app_comb (app_comb (A_k 5) (omega_k 4)) (omega_k 4)) (Ref 0))
               (App (App (App (Ref 5) (Ref 4)) (Ref 3)) (Ref 1)))   (* B (Ref 0) (Ref 1) *)
               (App (App (App (Ref 5) (Ref 4)) (Ref 3)) (Ref 2))) ) (
extension (app_comb (app_comb (app_comb (omega_k 3) (omega_k 3)) (Ref 0)) (Ref 1)) (* R (Ref 1) *)
          (App (Ref 2) (Ref 1)) (
extension (app_comb (Y_k 2) (Ref 0)) (* J *)
          (Ref 2)  (
extension (app_comb (app_comb (Ref 0) (Ref 1)) (Ref 2))  (* A B' (Ref 1) (Ref 2) *)
                                                                 (* use (Ref 3) not (Ref 0) because ab_op binds three times *)

          (App (App (app_comb (A_k 3) (Ref 0)) (App (App (App (Ref 5) (Ref 4)) (Ref 3)) (Ref 1))) (Ref 2))
                     (* abs_op, as defined below *)

(* wrong
extension (app_comb a_op (app_comb (app_comb (Ref 0) (Ref 1)) (Ref 2))) (* A (Ref 1) (Ref 2) *)
          (app_comb a_op (app_comb (app_comb (Ref 0) (App (App (App (Ref 5) (Ref 4)) (Ref 3)) (Ref 1))) (Ref 2)))
*)
i_op)))))))
.

Definition b_op := app_comb (Y_k 4) b_fn .

Definition abs_op := ab_op b_op.

(* do a lemma here that confirms the matching wrt A *)

Lemma maxvar_ref: forall n, maxvar (Ref n) = S n. Proof. split_all.  Qed.

Lemma b_op_closed: maxvar b_op = 0.
Proof.
unfold b_op.
rewrite maxvar_app_comb.
rewrite Y_k_closed. 2: omega. unfold max.
unfold b_fn.
rewrite ! maxvar_star_opt.
rewrite ! maxvar_extension.
unfold pattern_size; fold pattern_size.
rewrite ! maxvar_app. rewrite ! maxvar_ref.
rewrite ! maxvar_app_comb.
rewrite ! (omega_k_closed).
rewrite ! pattern_size_app_comb.
rewrite A_k_closed.
rewrite  (pattern_size_closed (omega_k _)) at 1.
rewrite  (pattern_size_closed (omega_k _)) at 1.
rewrite  (pattern_size_closed (omega_k _)) at 1.
rewrite  (pattern_size_closed (omega_k _)) at 1.
rewrite  (pattern_size_closed (omega_k _)) at 1.
rewrite  (pattern_size_closed (omega_k _)) at 1.
rewrite  (pattern_size_closed (h_fn)).
rewrite  (pattern_size_closed (Y_k _)) at 1.
unfold pattern_size; fold pattern_size. unfold plus; fold plus.
 all : (try (rewrite omega_k_closed; auto)). 2: eapply2 Y_k_closed.
2: simpl; auto.
replace (pattern_size (ab_fn (Ref 3))) with 1.
replace (maxvar (Y_k 4)) with 0.
cbv. auto.
rewrite Y_k_closed. auto. omega.
unfold ab_fn.
unfold star_opt at 3. unfold occurs0. rewrite ! orb_false_l.
rewrite ! orb_true_l.
unfold_op; unfold subst, subst_rec. insert_Ref_out.
rewrite star_opt_occurs_true.
cbv. auto. cbv. auto. congruence.
Qed.

Lemma abs2_red : forall M N, sf_red (App (App abs_op M) N) (app_comb (app_comb (ab_fn b_op) M) N).
Proof.
intros. unfold abs_op, ab_op, ab_fn.
eapply transitive_red.  eapply preserves_app_sf_red.
 eapply2 app_comb_red. auto.
eapply transitive_red. eapply preserves_app_sf_red. eapply2 A3_red. auto.
eapply transitive_red. eapply2 app_comb_red. unfold A_k.
eapply transitive_red. eapply2 a_op2_red. auto.
Qed.

Lemma abs_red : forall M N P, sf_red (App (App (App abs_op M) N) P) (App (App (App b_op P) M) N).
Proof.
intros. unfold abs_op, ab_op.
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply2 app_comb_red. all: auto.
eapply transitive_red. eapply preserves_app_sf_red.  eapply preserves_app_sf_red.
eapply2 A3_red. all: auto.
eapply transitive_red.  eapply preserves_app_sf_red.
eapply2 app_comb_red. auto.
unfold A_k. eapply transitive_red. eapply preserves_app_sf_red.
eapply2 a_op2_red. auto.
eapply transitive_red. eapply2 app_comb_red.
eapply transitive_red. eapply preserves_app_sf_red.
eapply2 app_comb_red. auto.
unfold ab_fn.  eapply transitive_red.
eapply2 star_opt_beta3.
unfold subst, subst_rec, lift; fold subst_rec.
insert_Ref_out.
unfold lift; rewrite ! lift_rec_null.
unfold subst, subst_rec, lift; fold subst_rec.
insert_Ref_out.
unfold lift; rewrite ! lift_rec_null.
rewrite ! subst_rec_lift_rec; try omega.
unfold subst, subst_rec, lift; fold subst_rec.
insert_Ref_out.
unfold lift; rewrite ! lift_rec_null.
replace (subst_rec b_op (lift_rec P 0 2) 0) with b_op.
2: rewrite (subst_rec_closed b_op). 2: auto.
2: rewrite b_op_closed; omega.
replace (subst_rec b_op (lift_rec N 0 1) 0) with b_op.
2: rewrite (subst_rec_closed b_op). 2: auto.
2: rewrite b_op_closed; omega.
replace (subst_rec b_op M 0) with b_op.
2: rewrite (subst_rec_closed b_op). 2: auto.
2: rewrite b_op_closed; omega.   auto.
Qed.

Lemma Fop_closed: maxvar Fop = 0.
Proof.
unfold Fop.   unfold is_leaf, is_stem, is_fork, swap.
unfold tree_test; unfold_op.
rewrite ! maxvar_star_opt.
rewrite ! maxvar_app.
rewrite ! maxvar_star_opt.
rewrite ! maxvar_app.
cbv. auto.
Qed.


(* ---------------------------------------------------------------------

   This file is part of a repository containing the definitions and
   proof scripts related to the formalization of context-free language
   theory in Coq. Specifically, the following results were obtained:

   (i) closure operations for context-free grammars,
   (ii) context-free grammars simplification
   (iii) context-free grammar Chomsky normalization and
   (iv) pumping lemma for context-free languages.

   More information can be found in thesis "Formalization of
   Context-Free Language Theory", submitted to the Informatics
   Center of the Pernambuco Federal University (CIn/UFPE) in
   Brazil.

   The file README.md descbrides the contents of each file and
   provides instructions to compile them.

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

(* --------------------------------------------------------------------- *)
(* SIMPLIFICATION - INACESSIBLE SYMBOLS                                  *)
(* --------------------------------------------------------------------- *)

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

Require Import misc_arith.
Require Import misc_list.
Require Import cfg useless.

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

Import ListNotations.
Open Scope list_scope.

Section Inaccessible.

Variables terminal non_terminal: Type.
Notation sf := (list (non_terminal + terminal)).
Notation sentence := (list terminal).
Notation nlist:= (list non_terminal).
Notation tlist:= (list terminal).

(* --------------------------------------------------------------------- *)
(* SIMPLIFICATION - INACCESSIBLE SYMBOLS - DEFINITIONS                   *)
(* --------------------------------------------------------------------- *)

Definition accessible (g: cfg _ _) (s: non_terminal + terminal): Prop:=
exists s1 s2: sf, derives g [inl (start_symbol g)] (s1++s::s2).

Inductive g_acc_rules (g: cfg _ _): non_terminal -> sf -> Prop :=
| Lift_acc : forall left: non_terminal,
             forall right: sf,
             rules g left right -> accessible g (inl left) -> g_acc_rules g left right.

Lemma g_acc_finite:
forall g: cfg _ _,
exists n: nat,
exists ntl: nlist,
exists tl: tlist,
In (start_symbol g) ntl /\
forall left: non_terminal,
forall right: sf,
g_acc_rules g left right ->
(length right <= n) /\
(In left ntl) /\
(forall s: non_terminal, In (inl s) right -> In s ntl) /\
(forall s: terminal, In (inr s) right -> In s tl).
Proof.
intros g.
destruct (rules_finite g) as [n [ntl [tl H1]]].
exists n, ntl, tl.
split.
- destruct H1 as [H1 _].
  exact H1.
- destruct H1 as [_ H1].
  intros left right H2.
  inversion H2.
  subst.
  specialize (H1 left right H).
  destruct H1 as [H4 [H5 H6]].
  split.
  + exact H4.
  + split.
    * exact H5.
    * exact H6.
Qed.

Definition g_acc (g: cfg _ _): cfg _ _ := {|
start_symbol:= start_symbol g;
rules:= g_acc_rules g;
rules_finite:= g_acc_finite g
|}.

Definition has_no_inaccessible_symbols (g: cfg _ _): Prop:=
forall s: _, appears g s -> accessible g s.

(* --------------------------------------------------------------------- *)
(* SIMPLIFICATION - INACCESSIBLE SYMBOLS - LEMMAS AND THEOREMS           *)
(* --------------------------------------------------------------------- *)

Lemma accessible_g_g_acc:
forall g: cfg _ _,
forall s: non_terminal + terminal,
accessible g s -> accessible (g_acc g) s.
Proof.
intros g s H0.
unfold accessible in H0.
unfold accessible.
destruct H0 as [s1 [s2 H1]].
apply derives_sflist in H1.
destruct H1 as [l [H2 [H3 H4]]].
exists s1, s2.
simpl.
apply derives_sflist.
exists l.
split.
- assert (H5: length l >= 2 \/ length l < 2) by omega.
  destruct H5 as [H5 | H5].
  + assert (H5':=H5).
    apply sflist_rules with (g:=g) in H5.
    apply sflist_rules.
    * exact H5'.
    * intros i H6.
      destruct H5 as [H5 _].
      specialize (H5 H2 i H6).
      destruct H5 as [left [right [s3 [s' [H10 [H11 H12]]]]]].
      exists left, right, s3, s'.
      {
      split.
      - exact H10.
      - split.
        + exact H11.
        + simpl.
          apply Lift_acc.
          * exact H12.
          * exists s3, s'.
            rewrite <- (firstn_skipn (S i) l) in H2.
            apply sflist_app_r in H2.
            apply derives_sflist.
            exists (firstn (S i) l).
            {
            split.
            - exact H2.
            - split.
              + rewrite <- H3.
                rewrite hd_first.
                * reflexivity.
                * omega.
              + rewrite <- H10.
                apply last_first_nth.
                omega.
            }
      }
  + destruct l as [| s3 l].
    * apply sflist_empty.
    * {
      replace (s3::l) with ([s3]++l) in H5.
      - rewrite app_length in H5.
        simpl in H5.
        assert (H7: length l = 0) by omega.
        apply length_zero in H7.
        rewrite H7.
        apply sflist_start.
      - simpl.
        reflexivity.
      }
- split.
  + exact H3.
  + exact H4.
Qed.

Lemma sflist_g_acc_g:
forall g: cfg _ _,
forall l: list sf,
sflist (g_acc g) l -> sflist g l.
Proof.
intros g l H.
induction H.
- apply sflist_empty.
- apply sflist_start.
- apply sflist_step with (left:=left).
  exact IHsflist.
  exact H0.
  simpl in H1.
  inversion H1.
  exact H2.
Qed.

Lemma produces_g_acc_g:
forall g: cfg _ _,
forall s: sentence,
produces (g_acc g) s -> produces g s.
Proof.
unfold produces.
unfold generates.
intros g s H.
apply derives_sflist in H.
destruct H as [l [H1 [H2 H3]]].
simpl in H2.
apply derives_sflist.
exists l.
split.
- apply sflist_g_acc_g.
  exact H1.
- split.
  + exact H2.
  + exact H3.
Qed.

Lemma acc_step:
forall g: cfg _ _,
forall n: non_terminal,
forall right: sf,
accessible g (inl n) -> rules g n right ->
forall s: non_terminal + terminal,
In s right -> accessible g s.
Proof.
intros g n right H1 H2 s H3.
unfold accessible in H1.
unfold accessible.
destruct H1 as [s1 [s2 H4]].
apply derives_step with (right:=right) in H4.
- apply in_split in H3.
  destruct H3 as [l1 [l2 H5]].
  rewrite H5 in H4.
  rewrite <- app_assoc in H4.
  exists (s1++l1), (l2++s2).
  rewrite <- app_assoc.
  exact H4.
- exact H2.
Qed.

Lemma sflist_g_g_acc:
forall g: cfg _ _,
forall l: list sf,
sflist g l /\ hd [] l = [inl (start_symbol g)] -> sflist (g_acc g) l.
Proof.
intros g l [H1 H2].
assert (H3: length l >= 2 \/ length l < 2) by omega.
destruct H3 as [H3 | H3].
- assert (H3':=H3).
  apply sflist_rules with (g:=g) in H3.
  destruct H3 as [H3 _].
  specialize (H3 H1).
  apply sflist_rules.
  + exact H3'.
  + intros i H4.
    specialize (H3 i H4).
    destruct H3 as [left [right [s0 [s' [H5 [H6 H7]]]]]].
    exists left, right, s0, s'.
    split.
    * exact H5.
    * {
      split.
      - exact H6.
      - simpl.
        apply Lift_acc.
        + exact H7.
        + assert (H20: derives g [inl (start_symbol g)] (s0 ++ inl left :: s')).
            {
            apply derives_sflist.
            rewrite <- (firstn_skipn (S i) l) in H1.
            apply sflist_app_r in H1.
            exists (firstn (S i) l).
            split.
            - exact H1.
            - split.
              + rewrite hd_first.
                * exact H2.
                * omega.
              + rewrite <- H5.
                apply last_first_nth.
                omega.
            }
          exists s0, s'.
          exact H20.
      }
- destruct l as [| s l].
  + apply sflist_empty.
  + destruct l as [| s0 l].
    * apply sflist_start.
    * {
      replace (s :: s0 :: l) with ([s] ++ [s0] ++ l) in H3.
      - repeat rewrite app_length in H3.
        simpl in H3.
        repeat apply lt_S_n in H3.
        apply lt_n_0 in H3.
        contradiction.
      - simpl.
        reflexivity.
      }
Qed.

Lemma produces_g_g_acc:
forall g: cfg _ _,
forall s: sentence,
produces g s -> produces (g_acc g) s.
Proof.
unfold produces.
unfold generates.
intros g s H.
apply derives_sflist in H.
destruct H as [l [H1 [H2 H3]]].
apply derives_sflist.
exists l.
split.
- apply sflist_g_g_acc.
  split.
  + exact H1.
  + exact H2.
- split.
  + simpl.
    exact H2.
  + exact H3.
Qed.

Theorem g_equiv_acc:
forall g: cfg _ _,
g_equiv (g_acc g) g.
Proof.
unfold g_equiv.
intros g s.
split.
- apply produces_g_acc_g.
- apply produces_g_g_acc.
Qed.

Lemma g_acc_has_no_inaccessible_symbols:
forall g: cfg _ _,
has_no_inaccessible_symbols (g_acc g).
Proof.
unfold has_no_inaccessible_symbols.
intros g n H.
destruct n as [nt | t].
- inversion H.
  destruct H0 as [right [H1 H2]].
  destruct H2 as [H2 | H2].
  + subst.
    simpl in H1.
    inversion H1.
    subst.
    apply accessible_g_g_acc.
    exact H2.
  + subst.
    simpl in H1.
    inversion H1.
    apply accessible_g_g_acc.
    subst.
    apply acc_step with (s:=inl nt) (right:=right) in H3.
    * exact H3.
    * exact H0.
    * exact H2.
- inversion H.
  destruct H0 as [right [H1 H2]].
  simpl in H1.
  inversion H1.
  subst.
  apply acc_step with (s:=inr t) (right:=right) in H3.
  + apply accessible_g_g_acc.
    exact H3.
  + exact H0.
  + exact H2.
Qed.

Theorem g_acc_correct:
forall g: cfg _ _,
g_equiv (g_acc g) g /\
has_no_inaccessible_symbols (g_acc g).
Proof.
intro g.
split.
- apply g_equiv_acc.
- apply g_acc_has_no_inaccessible_symbols.
Qed.

End Inaccessible.


Require Import FcEtt.utils.
Require Import FcEtt.imports.

Require Export FcEtt.fset_facts.
Require Export FcEtt.ett_inf.
Require Export FcEtt.tactics.

(* This file contains:

   - Syntactic stuff that should be defined by lngen
     (and that we should get LNgen to generate in the future).

   - Induction principles for the relations.

   - Other tactics that are specialized to the relations.

 *)

Set Bullet Behavior "Strict Subproofs".
Set Implicit Arguments.

Lemma tm_subst_tm_tm_var : forall a x, tm_subst_tm_tm a x (a_Var_f x) = a.
Proof. intros. simpl. destruct (x == x). auto. done. Qed.

Lemma co_subst_co_co_var : forall a x, co_subst_co_co a x (g_Var_f x) = a.
Proof. intros. simpl. destruct (x == x). auto. done. Qed.

Lemma tm_subst_tm_tm_var_neq : forall a x y, x <> y ->
    tm_subst_tm_tm a y (a_Var_f x) = (a_Var_f x).
Proof. intros. simpl. destruct (x == y). contradiction. auto. Qed.

Lemma co_subst_co_co_var_neq : forall a x y, x <> y ->
    co_subst_co_co a y (g_Var_f x) = (g_Var_f x).
Proof. intros. simpl. destruct (x == y). contradiction. auto. Qed.

Hint Rewrite tm_subst_tm_tm_var co_subst_co_co_var.

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

(*
   Some rewriting hints so that we don't have to remember
   all of the various names of the functions/lemmas
   (and so that we can make the tactics more generic).

*)

Hint Rewrite tm_subst_tm_tm_open_tm_wrt_tm_var : subst_open_var.
Hint Rewrite tm_subst_tm_tm_open_tm_wrt_co_var : subst_open_var.
Hint Rewrite tm_subst_tm_co_open_co_wrt_tm_var : subst_open_var.
Hint Rewrite tm_subst_tm_co_open_co_wrt_co_var : subst_open_var.
Hint Rewrite co_subst_co_co_open_co_wrt_co_var : subst_open_var.
Hint Rewrite co_subst_co_co_open_co_wrt_tm_var : subst_open_var.
Hint Rewrite co_subst_co_tm_open_tm_wrt_co_var : subst_open_var.
Hint Rewrite co_subst_co_tm_open_tm_wrt_tm_var : subst_open_var.

Hint Rewrite <- tm_subst_tm_tm_open_tm_wrt_tm_var : open_subst_var.
Hint Rewrite <- co_subst_co_tm_open_tm_wrt_tm_var : open_subst_var.
Hint Rewrite <- tm_subst_tm_tm_open_tm_wrt_co_var : open_subst_var.
Hint Rewrite <- co_subst_co_co_open_co_wrt_co_var : open_subst_var.

Hint Rewrite tm_subst_tm_tm_open_tm_wrt_tm : subst_open.
Hint Rewrite tm_subst_tm_tm_open_tm_wrt_co : subst_open.
Hint Rewrite tm_subst_tm_co_open_co_wrt_tm : subst_open.
Hint Rewrite tm_subst_tm_co_open_co_wrt_co : subst_open.
Hint Rewrite co_subst_co_co_open_co_wrt_co : subst_open.
Hint Rewrite co_subst_co_co_open_co_wrt_tm : subst_open.
Hint Rewrite co_subst_co_tm_open_tm_wrt_co : subst_open.
Hint Rewrite co_subst_co_tm_open_tm_wrt_tm : subst_open.

Hint Rewrite <- tm_subst_tm_tm_open_tm_wrt_tm : open_subst.
Hint Rewrite <- tm_subst_tm_tm_open_tm_wrt_co : open_subst.
Hint Rewrite <- tm_subst_tm_co_open_co_wrt_tm : open_subst.
Hint Rewrite <- tm_subst_tm_co_open_co_wrt_co : open_subst.
Hint Rewrite <- co_subst_co_co_open_co_wrt_co : open_subst.
Hint Rewrite <- co_subst_co_co_open_co_wrt_tm : open_subst.
Hint Rewrite <- co_subst_co_tm_open_tm_wrt_co : open_subst.
Hint Rewrite <- co_subst_co_tm_open_tm_wrt_tm : open_subst.

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

(* lc support

   These are some general purpose tactics for solving local closure
   goals. The are used in the lc_mutual proofs, but may also
   be useful elsewhere in the development.

   These tactics generally support forward reasoning which is
   useful for exploratory proof development.

*)

(* apply a lc constructor for a term with binding. *)
Ltac apply_lc_exists x :=
  pick fresh x;
  ( apply lc_a_Abs_exists      with (x1 := x)
  || apply lc_a_Pi_exists       with (x1 := x)
  || apply lc_a_CPi_exists      with (c1 := x)
  || apply lc_a_CAbs_exists     with (c1 := x)
  || apply lc_a_UAbs_exists     with (x1:= x)
  || apply lc_a_UCAbs_exists    with (c1 := x)
  || apply lc_g_PiCong_exists   with (x1 := x)
  || apply lc_g_AbsCong_exists  with (x1 := x)
  || apply lc_g_CPiCong_exists  with (c1 := x)
  || apply lc_g_CAbsCong_exists with (c1 := x)
  || fail "invalid case for apply_lc_exists" );
  eauto 2.

(* This tactic assists local closure goals when
   we have a 'binds' assumption in the context. *)

(* TODO: replace basic_solve with something more primitive? *)
Ltac lc_solve_binds :=
  match goal with
  (* binds nil case *)
  | [ H : binds ?x ?s nil |- _ ] => inversion H; clear H
  (* binds cons case *)
  | [ H : binds _ ?s ([(_,_)] ++ _) |- _ ?s] =>
      destruct (binds_cons_1 _ _ _ _ _ _ H); basic_solve
  (* variable cases *)
  | [ b : binds ?x _ ?G, H : ∀ (x' : atom) _, binds x' _ ?G → _ |- _] =>
      by apply H in b; inversion b; try done;
          match goal with
            | [H' : lc_constraint _ |- _] => inversion H' ; clear H'
            | [H' : lc_tm         _ |- _] => inversion H' ; clear H'
          end
  end.

(* Invert all lc assumptions in the context, using the variable name
   "c" for any lc assumptions about the bodies of binders.  *)
(* TODO: remove split_hyp? *)
(* generalize first case to include context *)
Ltac lc_inversion c :=
  repeat match goal with
    (* inversion for binders *)
  | [ H : forall x, (x `in` ?L -> False) -> lc_tm _ /\ _ |- _ ] =>
    destruct (H c ltac:(auto)); split_hyp; clear H
  (* simple inversions *)
  | [ H : lc_constraint (_ _) |- _ ] =>
    inversion H; clear H
  | [ H : lc_tm (a_Abs _ _ _) |- _ ] =>
    inversion H; clear H
  | [ H : lc_tm (a_UAbs _ _) |- _ ] =>
    inversion H; clear H
  | [ H : lc_tm (a_App _ _ _) |- _ ] =>
    inversion H; clear H
  | [ H : lc_tm (a_Pi _ _ _) |- _ ] =>
    inversion H; clear H
  | [ H : lc_tm (a_Conv _ _) |- _ ] =>
    inversion H; clear H
  | [ H : lc_tm (a_CPi _ _) |- _ ] =>
    inversion H; clear H
  | [ H : lc_tm (a_CAbs _ _) |- _ ] =>
    inversion H; clear H
  | [ H : lc_tm (a_UCAbs _) |- _ ] =>
    inversion H; clear H
  | [ H : lc_tm (a_CApp _ _) |- _ ] =>
    inversion H; clear H
  | [ H : lc_tm (a_Case _ _) |- _ ] =>
    inversion H; clear H
 end.

Ltac apply_lc_body :=
  match goal with
  | |- lc_tm (open_tm_wrt_tm ?a ?b) => eapply lc_body_tm_wrt_tm; auto
  | |- lc_tm (open_tm_wrt_co ?a ?b) => eapply lc_body_tm_wrt_co; auto
  end.

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

(* This lemma is an inverse to

    co_subst_co_tm_lc_tm : ∀ (a1 : tm) (g1 : co) (c1 : covar),
       lc_tm a1 → lc_co g1 → lc_tm (co_subst_co_tm g1 c1 a1)

   It shows:

    co_subst_co_tm_lc_tm_inverse : ∀ (a1 : tm) (g1 : co) (c1 : covar),
       lc_co g1 -> lc_tm (co_subst_co_tm g1 c1 a1) -> tc_tm a1

    (Note, the other way around is not true because the variable c1
    may not actually appear in a1, so we cannot conclude anything
    about g1.)
 *)

Lemma co_subst_co_tm_lc_tm_inverse
  : ∀ (g1 : co) (c1 : covar),
      lc_co g1 ->
      (forall A,
          lc_tm A -> forall XX, A = (co_subst_co_tm g1 c1 XX) -> lc_tm XX)
      /\
      (forall b1,
          lc_brs b1 -> forall XX, b1 = (co_subst_co_brs g1 c1 XX) -> lc_brs XX)
      /\
      (forall co,
          lc_co co -> forall XX, co = (co_subst_co_co g1 c1 XX) -> lc_co XX)
      /\
      (forall phi,
          lc_constraint phi -> forall XX, phi = (co_subst_co_constraint g1 c1 XX) ->
          lc_constraint XX).
Proof.
  intros.
  apply lc_tm_lc_brs_lc_co_lc_constraint_mutind.
  all: intros.
  (* simple destruct and inversion. *)
  all: match goal with
       | [H0 : _ = _ ?g1 ?c1 ?XX |- _] =>
         destruct XX; simpl in H0; inversion H0; clear H0; subst; auto
       end.
  all: try apply_lc_exists xc;
    try match goal with
    | [ H1 : ∀ x XX,
          _ (_ ?g1 ?c1 ?XX2) (_ x) = _ ?g1 ?c1 XX → _ XX |- _ ] =>
      eapply (H1 xc); autorewrite with subst_open; auto
    end.
  all: try rewrite co_subst_co_co_var_neq; auto.
Qed.

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

Ltac invert_syntactic_equality :=
  repeat match goal with
  | [ H : a_Var_f _  = a_Var_f _ |- _ ] =>
    inversion H; subst; clear H
  | [ H : a_Abs _ _ = a_Abs _ _ |- _ ] =>
    inversion H; subst; clear H
  | [ H : a_UAbs _ _ = a_UAbs _ _ |- _ ] =>
    inversion H; subst; clear H
  | [ H : a_Pi _ _ _ = a_Pi _ _ _ |- _ ] =>
    inversion H; subst; clear H
  | [ H : a_App _ _ _ = a_App _ _ _ |- _ ] =>
    inversion H; subst; clear H
  | [ H : a_Fam _  = a_Fam _ |- _ ] =>
    inversion H; subst; clear H
  | [ H : a_Const _  = a_Const _ |- _ ] =>
    inversion H; subst; clear H
  | [ H : a_Conv _ _ = a_Conv _ _ |- _ ] =>
    inversion H; subst; clear H
  | [ H : a_UCAbs _ = a_UCAbs _ |- _ ] =>
    inversion H; subst; clear H
  | [ H : a_CAbs + _ = a_CAbs _ _ |- _ ] =>
    inversion H; subst; clear H
  | [ H : a_CApp _ _  = a_CApp _ _ |- _ ] =>
    inversion H; subst; clear H
  | [ H : a_CPi _ _ = a_CPi _ _ |- _ ] =>
    inversion H; subst; clear H
  | [ H : Eq _ _ _ = Eq _ _ _ |- _ ] =>
    inversion H; subst; clear H
  end.

(* Invert an "interesting" assumption in the typing context *)
Ltac ann_invert_clear :=
  match goal with
  | H : AnnTyping _ a_Star _ |- _ => inversion H; subst; clear H
  | H : AnnTyping _ (_ _) _ |- _ =>  inversion H; subst; clear H
  | H : AnnPropWff _ _ |- _ => inversion H; subst; clear H
  | H : AnnIso _ _ (_ _) _ _ |- _ => inversion H; subst; clear H
  | H : AnnDefEq _ _ (_ _) _ _  |- _ => inversion H; subst; clear H
  | H : AnnCtx ([(_,_)] ++ _) |- _ => inversion H; subst; clear H
  | H : AnnCtx (_ :: _) |- _ => inversion H; subst; clear H
  end.

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

(* By default, swaps apply to tm variables. *)

Lemma lc_swap : forall x x0 a,
    x `notin` fv_tm_tm_tm a ->
    lc_tm (open_tm_wrt_tm a (a_Var_f x)) ->
    lc_tm (open_tm_wrt_tm a (a_Var_f x0)).
Proof.
  intros. rewrite (tm_subst_tm_tm_intro x); auto with lngen.
Qed.

Lemma fv_swap : forall x x0 a,
    x `notin` fv_tm_tm_tm a ->
    x0 `notin` fv_tm_tm_tm a ->
    x `notin` fv_tm_tm_tm (open_tm_wrt_tm a (a_Var_f x)) ->
    x0 `notin` fv_tm_tm_tm (open_tm_wrt_tm a (a_Var_f x0)).
Proof.
  intros.
  destruct (x == x0); subst; auto;
  rewrite (tm_subst_tm_tm_intro x); autorewrite with lngen; auto;
  rewrite fv_tm_tm_tm_open_tm_wrt_tm_upper;
  simpl; fsetdec.
Qed.

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

(* Induction schemes *)

Scheme typing_ind' := Induction for Typing Sort Prop
   with wff_ind'   := Induction for PropWff Sort Prop
   with iso_ind'   := Induction for Iso Sort Prop
   with defeq_ind' := Induction for DefEq Sort Prop
   with ctx_ind'   := Induction for Ctx Sort Prop.

Combined Scheme typing_wff_iso_defeq_mutual from typing_ind', wff_ind', iso_ind', defeq_ind', ctx_ind'.

Scheme ann_typing_ind' := Induction for AnnTyping Sort Prop
   with ann_wff_ind'   := Induction for AnnPropWff Sort Prop
   with ann_iso_ind'   := Induction for AnnIso Sort Prop
   with ann_defeq_ind' := Induction for AnnDefEq Sort Prop
   with ann_ctx_ind'   := Induction for AnnCtx Sort Prop.

Combined Scheme ann_typing_wff_iso_defeq_mutual
from ann_typing_ind', ann_wff_ind', ann_iso_ind',
     ann_defeq_ind', ann_ctx_ind'.

Scheme CoercedValue_ind' := Induction for CoercedValue Sort Prop
                            with Value_ind' := Induction for Value Sort Prop.
Combined Scheme CoercedValue_Value_mutual from CoercedValue_ind', Value_ind'.

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

(* Apply the mutual induction hypothesis and add a marker to the
   context indicating the current case (and also making the associated
   data constructor for that case available) as the name 'CON'. *)

Ltac ext_induction CON :=
    apply typing_wff_iso_defeq_mutual;
    [ pose CON :=  E_Star       |
      pose CON :=  E_Var        |
      pose CON :=  E_Pi         |
      pose CON :=  E_Abs        |
      pose CON :=  E_App        |
      pose CON :=  E_IApp       |
      pose CON :=  E_Conv       |
      pose CON :=  E_CPi        |
      pose CON :=  E_CAbs       |
      pose CON :=  E_CApp       |
      pose CON :=  E_Const      |
      pose CON :=  E_Fam        |
      pose CON :=  E_Wff        |
      pose CON :=  E_PropCong   |
      pose CON :=  E_IsoConv    |
      pose CON :=  E_CPiFst     |
      pose CON :=  E_Assn       |
      pose CON :=  E_Refl       |
      pose CON :=  E_Sym        |
      pose CON :=  E_Trans      |
      pose CON :=  E_Beta       |
      pose CON :=  E_PiCong     |
      pose CON :=  E_AbsCong    |
      pose CON :=  E_AppCong    |
      pose CON :=  E_IAppCong   |
      pose CON :=  E_PiFst      |
      pose CON :=  E_PiSnd      |
      pose CON :=  E_CPiCong    |
      pose CON :=  E_CAbsCong   |
      pose CON :=  E_CAppCong   |
      pose CON :=  E_CPiSnd     |
      pose CON :=  E_Cast       |
      pose CON :=  E_EqConv     |
      pose CON :=  E_IsoSnd     |
      pose CON :=  E_EtaRel     |
      pose CON :=  E_EtaIrrel   |
      pose CON :=  E_EtaC       |
(*      pose CON :=  E_LeftRel    |
      pose CON :=  E_LeftIrrel  |
      pose CON :=  E_Right      |
      pose CON :=  E_CLeft      | *)
      pose CON :=  E_Empty      |
      pose CON :=  E_ConsTm     |
      pose CON :=  E_ConsCo     ].

Ltac ann_induction CON :=
    apply ann_typing_wff_iso_defeq_mutual;
    [ pose CON :=  An_Star       |
      pose CON :=  An_Var        |
      pose CON :=  An_Pi         |
      pose CON :=  An_Abs        |
      pose CON :=  An_App        |
      pose CON :=  An_Conv       |
      pose CON :=  An_CPi        |
      pose CON :=  An_CAbs       |
      pose CON :=  An_CApp       |
      pose CON :=  An_Const      |
      pose CON :=  An_Fam        |
      pose CON :=  An_Wff        |
      pose CON :=  An_PropCong   |
      pose CON :=  An_CPiFst     |
      pose CON :=  An_IsoSym     |
      pose CON :=  An_IsoConv    |
      pose CON :=  An_Assn       |
      pose CON :=  An_Refl       |
      pose CON :=  An_EraseEq      |
      pose CON :=  An_Sym        |
      pose CON :=  An_Trans      |
      pose CON :=  An_Beta       |
      pose CON :=  An_PiCong     |
      pose CON :=  An_AbsCong    |
      pose CON :=  An_AppCong    |
      pose CON :=  An_PiFst      |
      pose CON :=  An_PiSnd      |
      pose CON :=  An_CPiCong    |
      pose CON :=  An_CAbsCong   |
      pose CON :=  An_CAppCong   |
      pose CON :=  An_CPiSnd     |
      pose CON :=  An_Cast       |
      pose CON :=  An_IsoSnd     |
      pose CON :=  An_Eta        |
      pose CON :=  An_EtaC       |
(*      pose CON :=  An_Left       |
      pose CON :=  An_Right      |
      pose CON :=  An_CLeft      | *)
      pose CON :=  An_Empty      |
      pose CON :=  An_ConsTm     |
      pose CON :=  An_ConsCo     ].

Ltac ensure_case C :=
  match goal with [ CON := C : ?A |- _ ] => idtac end.

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

(* Tactic support for freshness *)
(*  What does "fresh" mean for variables? *)

Ltac gather_atoms ::=
  let A := gather_atoms_with (fun x : vars => x) in
  let B := gather_atoms_with (fun x : var => {{ x }}) in
  let C1 := gather_atoms_with (fun x : context => dom x) in
  let D1 := gather_atoms_with (fun x => fv_tm_tm_tm x) in
  let D2 := gather_atoms_with (fun x => fv_tm_tm_co x) in
  let D3 := gather_atoms_with (fun x => fv_tm_tm_constraint x) in
  let D4 := gather_atoms_with (fun x => fv_tm_tm_sort x) in
  let D5 := gather_atoms_with (fun x => fv_tm_tm_brs x) in
  let D6 := gather_atoms_with (fun x => fv_co_co_tm x) in
  let D7 := gather_atoms_with (fun x => fv_co_co_co x) in
  let D8 := gather_atoms_with (fun x => fv_co_co_constraint x) in
  let D9 := gather_atoms_with (fun x => fv_co_co_sort x) in
  let D10 := gather_atoms_with (fun x => fv_co_co_brs x) in
  constr:(A \u B \u C1 \u D1 \u D2 \u D3 \u D4 \u D5 \u D6 \u D7 \u D8 \u D9 \u D10).

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

(* Rewrite the goal based on a equation in the context
   (i.e. using an equation from an eta-equivalence rule or from
   one of the Cong rules)
 *)

Ltac rewrite_body :=
  match goal with
  | [ e : ∀ x : atom, (x `in` ?L → False)
      → open_tm_wrt_tm _ (a_Var_f x) = open_tm_wrt_tm _ (_ (a_Var_f x) _) |- _ ] =>
     rewrite e; auto
  | [ e : ∀ x : atom, (x `notin` ?L)
      → open_tm_wrt_tm _ (a_Var_f x) = open_tm_wrt_tm _ (_ (a_Var_f x) _) |- _ ] =>
    rewrite e; auto
  | [ e : ∀ c : atom, (c `notin` ?L)
      → open_tm_wrt_co _ (g_Var_f c) =
        open_tm_wrt_co _ (g_Cast (g_Var_f c) (g_Sym _)) |- _ ] =>
    rewrite e; auto
  | [ e : ∀ x : atom, (x `in` ?L → False) →  _ _ (a_Var_f x) = _ _ _ (a_Var_f x) |- _ ] =>
    rewrite e; auto
  | [ e : ∀ x : atom, (x `in` ?L → False) →  _ _ (a_Var_f x) = _ _ _ (a_Bullet) |- _ ] =>
    rewrite e; auto
  | [ e : ∀ x : atom, (x `notin` ?L) →  _ _ (a_Var_f x) = _ _ _ (a_Var_f x) |- _ ] =>
    rewrite e; auto
  | [ e : ∀ x : atom, (x `notin` ?L) →  _ _ (a_Var_f x) = _ _ _ (a_Bullet) |- _ ] =>
    rewrite e; auto
  | [ e: ∀ c : atom,
    (c `in` ?L → False) → _ _ (g_Var_f c) = a_CApp _ _ |- _ ] =>
    rewrite e; auto
  | [ e: ∀ c : atom,
    (c `notin` ?L) → _ _ (g_Var_f c) = a_CApp _ _ |- _ ] =>
    rewrite e; auto

  end.

(* Solver for the two lc_mutual proofs. *)
Ltac lc_solve :=
  let c := fresh in
  try lc_solve_binds;
  try apply_lc_exists c;
  lc_inversion c; auto;
  try rewrite_body;
  try apply_lc_body;
  eauto with lc.

(* without these two lines, ext_consist.v fails. *)
Hint Resolve lc_a_Pi_exists
     lc_a_CPi_exists lc_a_Abs_exists lc_a_CAbs_exists lc_a_UAbs_exists.
(* This hint is restricted to lngen in ett_inf. *)
Hint Resolve lc_body_tm_wrt_tm lc_body_tm_wrt_co. (* binds_cons_1 *)

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

(*

Lemma fv_tm_tm_tm_open_wrt_tm_mutual:
  (forall a1 a2 x n, x `in` fv_tm_tm_tm a1 ->
      x `in` fv_tm_tm_tm (open_tm_wrt_tm_rec n a2 a1)) /\
  (forall brs a2 x n, x `in` fv_tm_tm_brs brs ->
      x `in` fv_tm_tm_brs (open_brs_wrt_tm_rec n a2 brs)) /\
  (forall g a2 x n, x `in` fv_tm_tm_co g ->
      x `in` fv_tm_tm_co (open_co_wrt_tm_rec n a2 g)) /\
  (forall phi1 a2 x n, x `in` fv_tm_tm_constraint phi1 ->
      x `in` fv_tm_tm_constraint (open_constraint_wrt_tm_rec n a2 phi1)).
Proof.
  apply tm_brs_co_constraint_mutind; simpl; try fsetdec; intros; eauto.
  all: try solve [apply AtomSetFacts.union_iff in H1; case: H1 => H1; eauto].
  all: try solve [apply AtomSetFacts.union_iff in H2; case: H2 => H2;
    eauto; apply AtomSetFacts.union_iff in H2; case: H2 => H2; eauto].
Qed.

Lemma fv_tm_tm_tm_open_wrt_co_mutual:
  (forall a1 a2 x n, x `in` fv_tm_tm_tm a1 ->
     x `in` fv_tm_tm_tm (open_tm_wrt_co_rec n a2 a1)) /\
  (forall brs a2 x n, x `in` fv_tm_tm_brs brs ->
     x `in` fv_tm_tm_brs (open_brs_wrt_co_rec n a2 brs)) /\
  (forall g a2 x n, x `in` fv_tm_tm_co g ->
     x `in` fv_tm_tm_co (open_co_wrt_co_rec n a2 g)) /\
  (forall phi1 a2 x n, x `in` fv_tm_tm_constraint phi1 ->
     x `in` fv_tm_tm_constraint (open_constraint_wrt_co_rec n a2 phi1)).
Proof.
  apply tm_brs_co_constraint_mutind; simpl; try fsetdec; intros; eauto.
  all: try solve [apply AtomSetFacts.union_iff in H1; case: H1 => H1; eauto].
  all: try solve [apply AtomSetFacts.union_iff in H2; case: H2 => H2; eauto; apply AtomSetFacts.union_iff in H2; case: H2 => H2; eauto].
Qed.

Lemma fv_tm_tm_tm_open_tm_wrt_tm:
  forall a1 a2 x, x `in` fv_tm_tm_tm a1 ->
               x `in` fv_tm_tm_tm (open_tm_wrt_tm a1 a2).
Proof.
  intros.
  apply fv_tm_tm_tm_open_tm_wrt_tm_lower.
  auto.
Qed.

Lemma fv_tm_tm_tm_open_tm_wrt_co:
  forall a1 a2 x, x `in` fv_tm_tm_tm a1 ->
               x `in` fv_tm_tm_tm (open_tm_wrt_co a1 a2).
Proof.
  intros.
  apply fv_tm_tm_tm_open_tm_wrt_co_lower.
  auto.
Qed.

*)

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

(* TODO: These tactics may be a little loose when filtering the cases (to determine whether or not
         they should kick in). If the automation is too slow, this is something to keep an eye on *)
(* TODO: it may be possible to improve these tactics by matching on the production (return type) of
         the hyp in the context *)
(*
Ltac oh_c'mon :=
    let x := fresh in
    pick fresh x;
    multimatch goal with
      | [ H : forall _ : atom, _ |- _ ] => solve [destruct (H x); basic_solve]
    end.

Ltac invert_open_wrt :=
  subst;
  multimatch goal with
    | [ H : context [?A] |- _ ?A      ] => solve [inversion H; clear H; subst; basic_solve]
    | [ H : context [?A] |- lc_tm (_ ?A _)] => solve [inversion H; clear H; try solve_by_inv_hyp_about A; basic_solve]
  end.
*)
(*
Ltac des_bind_cons :=
  multimatch goal with
    (* So far, this hole ---↓ was only filled with lc_sort. *)
    | [ H : binds _ ?s _ |- _ ?s] => solve [destruct (binds_cons_1 _ _ _ _ _ _ H); basic_solve]
  end.
*)

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

Lemma rho_swap : forall rho x x0 a,
    x `notin` fv_tm_tm_tm a ->
    x0 `notin` fv_tm_tm_tm a ->
    RhoCheck rho x (open_tm_wrt_tm a (a_Var_f x)) ->
    RhoCheck rho x0 (open_tm_wrt_tm a (a_Var_f x0)).
Proof.
  intros rho x x0 a F1 F2 H0.
  inversion H0; subst; constructor.
  +  auto. (* eapply lc_swap with (x0 := x0) (x:= x); auto. *)
  +  eapply fv_swap with (x:=x); eauto.
Qed.

Lemma eta_swap: forall x y a' b rho,
    x `notin` fv_tm_tm_tm a' \u fv_tm_tm_tm b ->
    open_tm_wrt_tm a' (a_Var_f x) = a_App b rho (a_Var_f x) ->
    open_tm_wrt_tm a' (a_Var_f y) = a_App b rho (a_Var_f y).
Proof.
  intros.
  rewrite (tm_subst_tm_tm_intro x); auto.
  rewrite H0.
  simpl.
  rewrite tm_subst_tm_tm_fresh_eq; auto.
  destruct eq_dec. auto. done.
Qed.

Lemma eta_swap_irrel: forall x y a' b,
    x `notin` fv_tm_tm_tm a' \u fv_tm_tm_tm b ->
    open_tm_wrt_tm a' (a_Var_f x) = a_App b Irrel a_Bullet ->
    open_tm_wrt_tm a' (a_Var_f y) = a_App b Irrel a_Bullet.
Proof.
  intros.
  rewrite (tm_subst_tm_tm_intro x); auto.
  rewrite H0.
  simpl.
  rewrite tm_subst_tm_tm_fresh_eq; auto.
Qed.

Lemma eta_swap_c: forall x y a' b,
    x `notin` fv_co_co_tm a' \u fv_co_co_tm b ->
    open_tm_wrt_co a' (g_Var_f x) = a_CApp b g_Triv ->
    open_tm_wrt_co a' (g_Var_f y) = a_CApp b g_Triv.
Proof.
  intros.
  rewrite (co_subst_co_tm_intro x); auto.
  rewrite H0.
  simpl.
  rewrite co_subst_co_tm_fresh_eq; auto.
Qed.

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

(*
Lemma close_tm_fresh :
  forall x a, x `notin` fv_tm_tm_tm (close_tm_wrt_tm x a).
Proof.
  intros.
  autorewrite with lngen.
  auto.
Qed.

Lemma close_co_fresh :
  forall x a, x `notin` fv_tm_tm_co (close_co_wrt_tm x a).
Proof.
  intros. autorewrite with lngen. auto.
Qed.

Lemma close_co_fresh_co :
  forall x a, x `notin` fv_co_co_co (close_co_wrt_co x a).
Proof.
  intros. autorewrite with lngen. auto.
Qed.
 *)

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

(* Tactics for working with context in weakening proof *)

Ltac auto_rew_env :=
  multimatch goal with
    | [ |- context [([(?x, ?T)] ++ ?G1 ++ ?G2 ++ ?G3)] ] => rewrite_env (((x ~ (T)) ++ G1) ++ G2 ++ G3)
  end.

(* -------------- Pick fresh and apply for judgements with binding ----- *)

Ltac E_pick_fresh x :=
  match goal with
    | [ |- Typing _ ?shape _ ] =>
      let v := match shape with
            | a_Pi _ _ _ => E_Pi
            | a_UAbs _ _ => E_Abs
            | a_CPi _ _  => E_CPi
            | a_CAbs _ _ => E_CAbs
            | a_UCAbs _  => E_CAbs
           end
      in pick fresh x and apply v
    | [ |- DefEq _ _ ?shape ?s2 _ ] =>
      let v := match shape with
               | a_Pi _ _ _ => E_PiCong
               | a_UAbs Rel _ => match s2 with
                                | a_UAbs _ _ => E_AbsCong
                                | _ => E_EtaRel
                                end
               | a_UAbs Irrel _ => match s2 with
                                | a_UAbs _ _ =>  E_AbsCong
                                | _ => E_EtaIrrel
                                end
               | a_CPi _ _  => E_CPiCong
               | a_CAbs _ _ => E_CAbsCong
               | a_UCAbs _  => match s2 with
                                | a_UCAbs _ =>  E_CAbsCong
                                | _ => E_EtaC
                                end
               end
      in pick fresh x and apply v
  end.

Ltac Par_pick_fresh x :=
  match goal with
    | [ |- Par _ _ ?shape ?s2 ] =>
      let v := match shape with
            | a_Pi _ _ _ => Par_Pi
            | a_UAbs Rel _ =>  match s2 with
                                | a_UAbs _ _ => Par_Abs
                                | _ => Par_Eta
                                end
            | a_UAbs Irrel _ =>  match s2 with
                                | a_UAbs _ _ => Par_Abs
                                | _ => Par_EtaIrrel
                                end
            | a_UAbs _ _ =>  Par_Abs
            | a_CPi _ _  => Par_CPi
            | a_CAbs _ _ => Par_CAbs
            | a_UCAbs _  => match s2 with
                                | a_UCAbs _ => Par_CAbs
                                | _ => Par_EtaC
                                end
           end
      in pick fresh x and apply v
  end.

Ltac An_pick_fresh x :=
  let shape := match goal with
                 | [ |- AnnTyping _   ?shape _    ] => shape
                 | [ |- AnnDefEq  _ _ ?shape _  _ ] => shape
               end in
  let ctor  := match shape with
    | a_Pi     _ _ _ => An_Pi
    | a_Abs    _ _ _ => An_Abs
    | a_CPi      _ _ => An_CPi
    | a_CAbs     _ _ => An_CAbs
    | g_PiCong _ _ _ => An_PiCong
    | g_AbsCong _ _ _  => An_AbsCong
    | g_CPiCong  _ _   => An_CPiCong
    | g_CAbsCong _ _ _ => An_CAbsCong
    | g_Eta _          => An_Eta
               end in
  pick fresh x and apply ctor.

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

Ltac RhoCheck_inversion y :=
  match goal with
  | [ K : ∀ x : atom, x `notin` ?L → RhoCheck ?rho x ?b |- _ ] =>
    move: (K y ltac:(auto)); inversion 1; subst; clear K
  | [ K : ∀ x : atom, (x `in` ?L -> False) → RhoCheck ?rho x ?b |- _ ] =>
    move: (K y ltac:(auto)); inversion 1; subst; clear K
  end.

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

Lemma lc_open_switch_co :
  forall g t, lc_co g ->
  lc_tm (open_tm_wrt_co t g_Triv) ->
  lc_tm (open_tm_wrt_co t g).
Proof.
  intros.
  pick fresh c.
  rewrite (co_subst_co_tm_intro c); auto.
  eapply co_subst_co_tm_lc_tm; auto.
  rewrite (co_subst_co_tm_intro c) in H0.
  eapply (@co_subst_co_tm_lc_tm_inverse g_Triv c); eauto 2. auto.
Qed.

Hint Resolve lc_open_switch_co.

(* Putting this here because it's annoying to move elsewhere. *)

Lemma tm_subst_cast : forall a x g,
    tm_subst_tm_tm a x (a_Conv (a_Var_f x) g) = a_Conv a (tm_subst_tm_co a x g).
Proof.
  intros. simpl.
  destruct (x == x). auto.
  done.
Qed.

Hint Rewrite tm_subst_cast.


Require Import
        Coq.Strings.String
        Coq.Vectors.Vector.

Require Import
        Fiat.Common.SumType
        Fiat.Common.EnumType
        Fiat.Common.BoundedLookup
        Fiat.Common.ilist
        Fiat.Computation
        Fiat.QueryStructure.Specification.Representation.Notations
        Fiat.QueryStructure.Specification.Representation.Heading
        Fiat.QueryStructure.Specification.Representation.Tuple
        Fiat.Narcissus.BinLib.Core
        Fiat.Narcissus.Common.Specs
        Fiat.Narcissus.Common.WordFacts
        Fiat.Narcissus.Common.ComposeCheckSum
        Fiat.Narcissus.Common.ComposeIf
        Fiat.Narcissus.Common.ComposeOpt
        Fiat.Narcissus.Automation.Solver
        Fiat.Narcissus.Formats.FixListOpt
        Fiat.Narcissus.Stores.EmptyStore
        Fiat.Narcissus.Formats.Bool
        Fiat.Narcissus.Formats.NatOpt
        Fiat.Narcissus.Formats.Vector
        Fiat.Narcissus.Formats.EnumOpt
        Fiat.Narcissus.Formats.SumTypeOpt
        Fiat.Narcissus.Formats.IPChecksum
        Fiat.Narcissus.Formats.WordOpt.

Require Import Bedrock.Word.

Import Vectors.VectorDef.VectorNotations.
Open Scope string_scope.
Open Scope Tuple_scope.

(* Start Example Derivation. *)

Definition IPv4_Packet :=
  @Tuple <"TotalLength" :: word 16,
          "ID" :: word 16,
          "DF" :: bool, (* Don't fragment flag *)
          "MF" :: bool, (*  Multiple fragments flag *)
          "FragmentOffset" :: word 13,
          "TTL" :: char,
          "Protocol" :: EnumType ["ICMP"; "TCP"; "UDP"],
          (* So many to choose from: http://www.iana.org/assignments/protocol-numbers/protocol-numbers.xhtml*)
          "SourceAddress" :: word 32,
          "DestAddress" :: word 32,
          "Options" :: list (word 32)>.

Definition ProtocolTypeCodes : Vector.t char 3 :=
  [WO~0~0~0~0~0~0~0~1;
   WO~0~0~0~0~0~1~1~0;
   WO~0~0~0~1~0~0~0~1
  ].

Definition IPv4_Packet_Header_Len (ip4 : IPv4_Packet) := 5 + |ip4!"Options"|.

Definition format_IPv4_Packet_Spec (ip4 : IPv4_Packet)  :=
          (format_word (natToWord 4 4)
    ThenC format_nat 4 (IPv4_Packet_Header_Len ip4)
    ThenC format_unused_word 8 (* TOS Field! *)
    ThenC format_word ip4!"TotalLength"
    ThenC format_word ip4!"ID"
    ThenC format_unused_word 1 (* Unused flag! *)
    ThenC format_bool ip4!"DF"
    ThenC format_bool ip4!"MF"
    ThenC format_word ip4!"FragmentOffset"
    ThenC format_word ip4!"TTL"
    ThenC format_enum ProtocolTypeCodes ip4!"Protocol"
    DoneC)
    ThenChecksum IPChecksum_Valid OfSize 16
    ThenCarryOn (format_word ip4!"SourceAddress"
    ThenC format_word ip4!"DestAddress"
    ThenC format_list format_word ip4!"Options"
    DoneC).

Definition IPv4_Packet_OK (ipv4 : IPv4_Packet) :=
  lt (|ipv4!"Options"|) 11 /\
  lt (20 + 4 * |ipv4!"Options"|) (wordToNat ipv4!"TotalLength").

Definition IPv4_Packet_formatd_measure (ipv4_b : ByteString)
  : nat :=
  match (`(u, b') <- decode_unused_word' 4 ipv4_b;
           decode_word' 4 b') with
  | Some n => 32 * wordToNat (fst n)
  | None => 0
  end.

Arguments mult : simpl never.
Arguments decode_word' : simpl never.

Lemma IPv4_Packet_Headiner_Len_Bound
  : forall (a : IPv4_Packet) (a_OK : IPv4_Packet_OK a),
    BinNat.N.lt (BinNat.N.of_nat (IPv4_Packet_Header_Len a)) (Npow2 4).
Proof.
  unfold IPv4_Packet_Header_Len.
  intros; unfold IPv4_Packet_OK in a_OK.
  destruct a_OK.
  rewrite <- BinNat.N.compare_lt_iff.
  rewrite Nnat.N2Nat.inj_compare.
  rewrite Nnat.Nat2N.id.
  rewrite <- Compare_dec.nat_compare_lt.
  simpl.
  unfold BinPos.Pos.to_nat; simpl.
  auto with arith.
Qed.

Lemma IPv4_Packet_Header_Len_eq
  : forall data len,
    IPv4_Packet_Header_Len data = len
    -> ((|data!"Options" |) = len - 5).
Proof.
  unfold IPv4_Packet_Header_Len; intros.
  apply Minus.plus_minus.
  rewrite H; reflexivity.
Qed.

Lemma IPv4_Packet_Header_Len_OK
  : forall ip4 (ctx ctx' ctx'' : CacheFormat) c b b'' ext,
    (format_word (natToWord 4 4)
    ThenC format_nat 4 (IPv4_Packet_Header_Len ip4)
    ThenC format_unused_word 8 (* TOS Field! *)
    ThenC format_word ip4!"TotalLength"
    ThenC format_word ip4!"ID"
    ThenC format_unused_word 1 (* Unused flag! *)
    ThenC format_bool ip4!"DF"
    ThenC format_bool ip4!"MF"
    ThenC format_word ip4!"FragmentOffset"
    ThenC format_word ip4!"TTL"
    ThenC format_enum ProtocolTypeCodes ip4!"Protocol"
    DoneC) ctx ↝ (b, ctx') ->
    (format_word ip4!"SourceAddress"
    ThenC format_word ip4!"DestAddress"
    ThenC format_list format_word ip4!"Options"
    DoneC) ctx' ↝ (b'', ctx'') ->
    IPv4_Packet_OK ip4 ->
    (fun _ => 128) ip4 + (fun a => 16 + |ip4!"Options"| * 32) ip4 + (bin_measure mempty) + 16 = IPv4_Packet_formatd_measure (mappend (mappend b (mappend (format_checksum _ _ _ 16 c) b'')) ext).
Proof.
  intros.
  set (k := mempty); simpl in k; subst k.
  simpl bin_measure.
  rewrite length_ByteString_id.
  unfold IPv4_Packet_formatd_measure.
  pose proof mappend_assoc as H'; simpl in H';
    rewrite <- !H'.
  eapply computes_to_compose_decode_unused_word in H;
    let H' := fresh in
    destruct H as [? [? [? H'] ] ]; rewrite H'.
  unfold DecodeBindOpt, BindOpt, If_Opt_Then_Else.
  eapply computes_to_compose_decode_word in H;
    let H' := fresh in
    destruct H as [? [? [? H'] ] ]; rewrite H'.
  unfold fst.
  rewrite wordToNat_natToWord_idempotent; try reflexivity;
    eauto using IPv4_Packet_Headiner_Len_Bound.
  unfold IPv4_Packet_Header_Len.
  rewrite Mult.mult_plus_distr_l.
  omega.
Qed.

Hint Resolve IPv4_Packet_Header_Len_eq : data_inv_hints.

Local Arguments mempty / .
Local Arguments NPeano.modulo : simpl never.

Definition EthernetHeader_decoder
  : CorrectDecoderFor IPv4_Packet_OK format_IPv4_Packet_Spec.
Proof.
  start_synthesizing_decoder.

  normalize_compose monoid.

  apply_IPChecksum IPv4_Packet_Header_Len_OK.

  simpl; unfold IPv4_Packet_OK; clear. intros ? H'; destruct H' as [? ?]; repeat split.
  simpl; unfold IPv4_Packet_Header_Len.
  revert H; unfold StringId11; unfold pow2, mult; simpl; auto with arith.

  synthesize_cache_invariant.
  higher_order_reflexivity.

Defined.

Definition IPv4_decoder_impl :=
  Eval simpl in (fst (proj1_sig EthernetHeader_decoder)).

Definition pkt' : list char :=
  [WO~1~0~1~0~0~0~1~0;
   WO~0~0~0~0~0~0~0~0;

   WO~0~0~0~0~0~0~0~0;
   WO~0~0~0~0~0~0~0~0;

   WO~0~0~0~0~0~0~0~0;
   WO~0~0~0~0~0~0~0~0;

   WO~0~0~0~0~0~0~0~0;
   WO~0~0~0~0~0~0~0~0;

   WO~0~1~1~0~0~1~0~0;
   WO~1~0~0~0~0~0~0~0;

   WO~0~0~0~0~0~0~0~0;
   WO~0~0~0~0~0~0~0~0;

   WO~0~0~0~0~0~0~1~1;
   WO~0~0~0~1~0~1~0~1;

   WO~0~1~1~1~1~0~1~1;
   WO~0~1~0~1~0~0~0~0;

   WO~0~0~0~0~0~0~1~1;
   WO~0~0~0~1~0~1~0~1;

   WO~0~1~1~1~1~0~1~1;
   WO~1~0~0~0~0~0~0~0]%list.

Definition pkt : list char :=
    Eval compute in map (@natToWord 8) [69;0;100;0;0;0;0;0;38;1;243;159;192;168;222;10;192;168;222;1;0;0;0;0].

Compute (InternetChecksum.checksum pkt).

Definition address : list char :=
  Eval compute in map (@natToWord 8) [172;16;254;1].

Lemma zero_lt_eight : (lt 0 8)%nat.
Proof. omega. Qed.

Definition fiat_ipv4_decode (buffer: list char) : option (IPv4_Packet * list char) :=
  let bs := {| padding := 0; front := WO; paddingOK := zero_lt_eight; byteString := buffer |} in
  match IPv4_decoder_impl bs () with
  | Some (pkt', bs, _) => Some (pkt', bs.(byteString))
  | None => None
  end.

Compute (fiat_ipv4_decode pkt).

Compute (InternetChecksum.checksum pkt).


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^129 - 25
Base: 32
***)

Definition curve : CurveParameters :=
  {|
    sz := 5%nat;
    base := 32;
    bitwidth := 32;
    s := 2^129;
    c := [(1, 25)];
    carry_chains := None;

    a24 := None;
    coef_div_modulus := None;

    goldilocks := None;
    karatsuba := None;
    montgomery := true;
    freeze := Some false;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


From fae_gtlc_mu.refinements.gradual_static Require Export logical_relation.
From fae_gtlc_mu.backtranslation Require Export alternative_consistency.
From fae_gtlc_mu.backtranslation Require Export cast_help.general_def.
From fae_gtlc_mu.stlc_mu Require Export lang.

(* This file defines what needs to be proven for the compatibility lemma for casts. *)

Section defs.
  Context `{!implG Σ,!specG Σ}.

  (* Defines relatedness for a list of static values with respect A, a list of pairs of gradual types. *)

  Definition rel_cast_functions A (fs : list stlc_mu.lang.val) : iProp Σ :=
    ⌜length A = length fs⌝ ∗
    [∗ list] a ; f ∈ A ; fs , (
                           □ (∀ (v : cast_calculus.lang.val) (v' : stlc_mu.lang.val) ,
                                 ⟦ a.1 ⟧ (v , v') → ⟦ a.2 ⟧ₑ (Cast (v) a.1 a.2, (stlc_mu.lang.of_val f v'))
                             )
                         )%I.

  Global Instance rel_cast_functions_persistent A fs :
    Persistent (rel_cast_functions A fs).
  Proof.
    apply bi.sep_persistent; first by apply bi.pure_persistent.
    apply big_sepL2_persistent. intros _ (τi , τf) f. simpl.
    apply bi.intuitionistically_persistent.
  Qed.

  (** The (to-be-proven) statement that the -- closed up -- back-translated casts behave appropriately;
      it's a slightly adjusted version of the compatibility lemma for casts such that the proof is more ergonomic. *)

  Definition back_cast_ar {A} {τi τf} (pC : alternative_consistency A τi τf) :=
    ∀ ei' K' v v' fs,
      ( rel_cast_functions A fs ∧
        ⟦ τi ⟧ (v, v') ∧
        initially_inv ei' ∧
        currently_half (fill K' (𝓕c pC fs (stlc_mu.lang.of_val v')))
      )
        ⊢ (WP
             Cast v τi τf ?{{ w, ∃ w', currently_half (fill K' (stlc_mu.lang.of_val w')) ∧ ⟦ τf ⟧ (w, w') }})%I.

End defs.