Require Import FcEtt.sigs.

Require Import FcEtt.imports.
Require Import FcEtt.dep_prog.
Require Export FcEtt.ett_ind.
Require Export FcEtt.ett_par. (* FIXME: the axioms about toplevel shouldn't be there *)
Require Export FcEtt.erase_syntax.  (* lc_erase *)

Module fc_dec_aux (wf : fc_wf_sig) (weak : fc_weak_sig) (subst : fc_subst_sig) (unique: fc_unique_sig).

Import unique.

(**** Decision procedures for a few auxiliary relations ****)

Lemma eq_relflag_dec : forall t1 t2 : relflag, {t1 = t2} +  {~ t1 = t2}.
Proof.
  decide equality.
Defined.

Ltac nosub t2 :=  destruct t2; try solve[ left; auto]; right; done.

Ltac onesub t2 :=
    let h := fresh in
    destruct t2;
    try solve [right; done];
    match goal with
      [
         H0 : ∀ t2, {?B = t2} + {?B ≠ t2} |-
                    { ?C ?B = ?C ?e } + { ?F } ] =>
      destruct (H0 e); subst;
        try solve [left; auto];
        try solve [right; intro h; inversion h; done]
            end.
Ltac twosub t2 :=
    let h := fresh in
    destruct t2;
    try solve [right; done];
    match goal with
      [  H : ∀ t2, {?phi = t2} + {?phi ≠ t2},
         H0 : ∀ t2, {?B = t2} + {?B ≠ t2} |-
                    { ?C ?phi ?B = ?C ?d ?e } + { ?F } ] =>
      destruct (H d); subst; destruct (H0 e); subst;
        try solve [left; auto];
        try solve [right; intro h; inversion h; done]
         end.
Ltac threesub t2 :=
    let h := fresh in
    destruct t2;
    try solve [right; done];
    match goal with
      [  H : ∀ t2, {?phi = t2} + {?phi ≠ t2},
         H1 : ∀ t2, {?A = t2} + {?A ≠ t2},
         H0 : ∀ t2, {?B = t2} + {?B ≠ t2} |-
                    { ?C ?phi ?A ?B = ?C ?d ?e ?f} + { ?F } ] =>
      destruct (H d); subst; destruct (H1 e); subst;
      destruct (H0 f); subst;
        try solve [left; auto];
        try solve [right; intro h; inversion h; done]
         end.

Lemma tm_eq_dec_mutual :
  ((forall t1 t2 : tm, {t1 = t2} +  {~ t1 = t2}) *
   (forall t1 t2 : brs, {t1 = t2} +  {~ t1 = t2}) *
   (forall t1 t2 : co, {t1 = t2} +  {~ t1 = t2}) *
   (forall t1 t2 : constraint, {t1 = t2} +  {~ t1 = t2})).
Proof.
  eapply tm_brs_co_constraint_mutrec.
  all:  try solve [intros; onesub t2].
  all:  try solve [intros; twosub t2].
  all:  try solve [intros; threesub t2].
  all: try solve [intros; nosub t2].
  { intro n. destruct t2.
    all : try solve [right; done].
    edestruct (eq_nat_dec n n0). subst. left. auto. right.
    intro H. inversion H. done. }
  { intro x. destruct t2.
    all : try solve [right; done].
    edestruct (eq_atom_dec x x0). subst. left. auto. right.
    intro H. inversion H. done. }
  { intros rho A t2 b t3 t0.
    destruct t0.
    all : try solve [right; done].
    destruct (eq_relflag_dec rho rho0). subst.
    destruct (t2 t0_1). subst.
    destruct (t3 t0_2). subst.
    left. auto.
    all: right; intro H; inversion H; done. }
  { intros rho b H2 t2.
    destruct t2.
    all : try solve [right; done].
    destruct (eq_relflag_dec rho rho0). subst.
    destruct (H2 t2). subst.
    left. auto.
    all: right; intro H; inversion H; done. }
  { intros a H2 rho b H3 t2.
    destruct t2.
    all : try solve [right; done].
    destruct (eq_relflag_dec rho rho0). subst.
    destruct (H2 t2_1). subst.
    destruct (H3 t2_2). subst.
    left. auto.
    all: right; intro H; inversion H; done. }
  { intros F t2.
    destruct t2.
    all : try solve [right; done].
    destruct (eq_atom_dec F F0). subst.
    left. auto.
    right; intro H; inversion H; done. }
  { intros T t2.
    destruct t2.
    all : try solve [right; done].
    destruct (eq_atom_dec T T0). subst.
    left. auto.
    right; intro H; inversion H; done. }
  { intros.
    destruct t2.
    all : try solve [right; done].
    destruct (eq_relflag_dec rho rho0). subst.
    destruct (H t2_1). subst.
    destruct (H0 t2_2). subst.
    left. auto.
    all: right; intro h; inversion h; done. }
  { intros K t2.
    destruct t2.
    all : try solve [right; done].
    edestruct (eq_atom_dec K K0). subst. left. auto. right.
    intro H. inversion H. done. }
  { intros.
    destruct t2.
    all : try solve [right; done].
    destruct (eq_atom_dec K K0). subst.
    destruct (H a0). subst.
    destruct (H0 t2). subst.
    left. auto.
    all: right; intro h; inversion h; done. }
  { intro n. destruct t2.
    all : try solve [right; done].
    edestruct (eq_nat_dec n n0). subst. left. auto. right.
    intro H. inversion H. done. }
  { intro x. destruct t2.
    all : try solve [right; done].
    edestruct (eq_atom_dec x c). subst. left. auto. right.
    intro H. inversion H. done. }
  { intros.
    destruct t2.
    all : try solve [right; done].
    destruct (eq_relflag_dec rho rho0). subst.
    destruct (H t2_1). subst.
    destruct (H0 t2_2). subst.
    left. auto.
    all: right; intro h; inversion h; done. }
  { intros. destruct t2.
    all : try solve [right; done].
    destruct (eq_relflag_dec rho rho0). subst.
    destruct (H t2_1). subst.
    destruct (H0 t2_2). subst.
    left. auto.
    all: right; intro h; inversion h; done. }
  { intros.  destruct t2.
    all : try solve [right; done].
    destruct (eq_relflag_dec rho rho0). subst.
    destruct (H t2_1). subst.
    destruct (H0 t2_2). subst.
    left. auto.
    all: right; intro h; inversion h; done. }
Defined.

Lemma tm_eq_dec : forall t1 t2 : tm, {t1 = t2} + {~ t1 = t2}.
Proof.
  by move: tm_eq_dec_mutual => [[[? _] _]_].
Defined.

Lemma const_eq_dec : forall (phi1 phi2 : constraint), {phi1 = phi2} + {¬ phi1 = phi2}.
Proof.
  by move: tm_eq_dec_mutual => [_ ?].
Defined.

Lemma co_eq_dec : forall g1 g2 : co, {g1 = g2} + {~ g1 = g2}.
Proof.
  by move: tm_eq_dec_mutual => [[_ ?]_].
Defined.

Lemma in_dec : forall x L, {x `in` L} + {¬ x `in` L}.
Proof.
  intros.
  destruct (AtomSetProperties.In_dec x L); auto.
Qed.

Lemma not_in_dec : forall x L, {¬ x `in` L} + {x `in` L}.
Proof.
  intros.
  destruct (AtomSetProperties.In_dec x L); auto.
Qed.

Lemma uniq_binds_dec_tm : forall x G, uniq G -> {A | binds x (Tm A) G} + {(forall A, ¬ binds x (Tm A) G)}.
Proof.
  intros.
  destruct (binds_lookup _ x G).
  destruct s. destruct x0.
  econstructor.
  exists A. auto.
  eapply inright.
  intros A b0.
  assert (Co phi = Tm A). eapply binds_unique; eauto. inversion H0.
  eapply inright.
  intro A.
  eapply (n (Tm A)).
Qed.

Lemma binds_dec_tm : forall x G, {A | binds x (Tm A) G} + {(forall A, ¬ binds x (Tm A) G)}.
Proof.
  intros x G.
  induction G.
  - eapply inright.
    intros A I. inversion I.
  - destruct IHG.
    { eapply inleft.
      destruct s. exists x0. destruct a. auto. }
    { destruct a.
      destruct (x == a).
      destruct s.
      eapply inleft. exists A. auto.
      eapply inright. intros A H.
      apply binds_cons_1 in H. destruct H as [ [h0 h1]|b0].
      inversion h1. apply n in b0. done.
      eapply inright. intros A H.
      apply binds_cons_1 in H. destruct H as [ [h0 h1]|b0].
      done. apply n in b0. done. }
Qed.

Lemma binds_dec_co : forall x G, {AB, K | binds x (Co (Eq (fst AB) (snd AB) K)) G} + {(forall A B K, ¬ binds x (Co (Eq A B K)) G)}.
Proof.
  intros x G.
  induction G.
  - eapply inright.
    intros A B K I. inversion I.
  - destruct IHG.
    { eapply inleft.
    destruct s. exists x0 y. destruct a. auto. }
    { destruct a.
    destruct (x == a). subst.
    destruct s.

    eapply inright. intros A1 B K H.
    apply binds_cons_1 in H. destruct H as [ [h0 h1]|b0].
    inversion h1. apply n in b0. done.
    destruct phi.
    eapply inleft. exists (a0,b) A. auto.
    eapply inright. intros A B K H.
    apply binds_cons_1 in H. destruct H as [ [h0 h1]|b0].
    done. apply n in b0. done.
    }
Qed.

Lemma binds_dec_cs : forall x G, {C | binds x (Cs  C) G} + {(forall C, ¬ binds x (Cs  C) G)}.
Proof.
  intros x G.
  induction G.
  - eapply inright.
    intros C I. inversion I.
  - destruct IHG.
    { eapply inleft.
    destruct s. exists x0. destruct a. auto. }
    { destruct a.
    destruct (x == a). subst.
    destruct s.
    eapply inleft. exists A. auto.

    eapply inright. intros C H.
    apply binds_cons_1 in H. destruct H as [ [h0 h1]|b0].
    inversion h1. apply n in b0. done.

    eapply inright. intros C H.
    apply binds_cons_1 in H. destruct H as [ [h0 h1]|b0].
    done. apply n in b0. done.
    }
Qed.

Lemma Value_AbsIrrel_inversion : forall A a,
    Value (a_Abs Irrel A a)
    -> lc_tm A /\ forall x, x `notin` fv_tm a -> CoercedValue (open_tm_wrt_tm a (a_Var_f x)).
Proof.
  intros. inversion H. split. auto.
  intros x Fr.
  pick fresh y.
  rewrite (tm_subst_tm_tm_intro y); eauto.
  eapply CoercedValue_tm_subst_tm_tm; auto.
Qed.

Lemma Value_UAbsIrrel_inversion : forall a,
    Value (a_UAbs Irrel a)
    -> forall x, x `notin` fv_tm a -> Value (open_tm_wrt_tm a (a_Var_f x)).
Proof.
  intros. inversion H.
  pick fresh y.
  rewrite (tm_subst_tm_tm_intro y); eauto.
  eapply Value_tm_subst_tm_tm; auto.
Qed.

Ltac eauto_lc :=
  eauto using lc_tm_of_lc_set_tm,
  lc_co_of_lc_set_co,
  lc_constraint_of_lc_set_constraint.

Lemma decide_Value_mutual : forall a, lc_set_tm a -> ({ Value a } + { not (Value a) }) * ({ CoercedValue a } + { not (CoercedValue a) }).
Proof.
  intros a LC; induction LC.
  all: try destruct rho1.
  all: split; subst.

  all: try solve [apply left; econstructor; eauto_lc].
  all: try solve [apply right; move => h; inversion h;
           try inversion H].

  (* application cases *)
  all: try solve [try destruct IHLC as [[V|NV] [C|NC]];
                  try destruct IHLC1 as [[V|NV] [C|NC]];
                  try destruct (@Path_dec a1) as [[T P]|NP]; eauto_lc;
                  try solve [apply left; econstructor; eauto_lc];
                  try solve [apply right; move => h; inversion h;
                             try inversion H; unfold not in NP; eauto];
                  try solve [apply right; move => h; inversion h;
                             try inversion H; try done]].

  (* Only binding cases left *)
  all: pick fresh x; destruct (H x) as [[V |NV] [C | NC]].
  all: try solve [apply left; try apply CV; eapply (@Value_AbsIrrel_exists x);
                  eauto_lc].
  all: try solve [apply left; try apply CV; eapply (@Value_UAbsIrrel_exists x);
                  eauto_lc].

  all: try solve [apply right; move => h;
                  destruct (Value_AbsIrrel_inversion h) as [? ?];
                  apply NC; eauto].
  all: try solve [apply right; move => h; inversion h;
                  destruct (Value_AbsIrrel_inversion H0) as [? ?];
                  apply NC; eauto].
  all: try solve [apply right; move => h;
                  eapply Value_UAbsIrrel_inversion with (x:=x) in h; auto].
  all: try solve [apply right; move => h; inversion h;
                  eapply Value_UAbsIrrel_inversion with (x:=x) in H0; auto].
Qed.

Lemma Value_dec :  forall a, lc_tm a -> ({ Value a } + { not (Value a) }).
Proof.
  intros.
  apply decide_Value_mutual.
  apply lc_set_tm_of_lc_tm.
  auto.
Qed.

Lemma binds_dec_ax : forall x G, {A, B | binds x (Ax A B) G} + {(forall A B, ¬ binds x (Ax A B) G)}.
Proof.
  intros x G.
  induction G.
  - eapply inright.
    intros A B I. inversion I.
  - destruct IHG.
    { eapply inleft.
    destruct s. exists x0 y. destruct a. auto. }
    { destruct a.
    destruct (x == a). subst.
    destruct s.

    eapply inright. intros A0 B H.
    apply binds_cons_1 in H. destruct H as [ [h0 h1]|b0].
    inversion h1. apply n in b0. done.

    eapply inleft. exists a0 A. auto.

    eapply inright. intros A0 B H.
    apply binds_cons_1 in H. destruct H as [ [h0 h1]|b0].
    done. apply n in b0. done.
    }
Qed.

Definition rho_eq_dec : forall rho rho' : relflag, {rho = rho'} + {rho <> rho'}.
Proof. decide equality. Defined.

Lemma beta_dec : forall a1 a2, lc_tm a1 -> {Beta a1 a2} + {¬ Beta a1 a2}.
Proof.
  intros a1 a2 LC1.
  destruct a1.
  all: try solve [right; move=> h; inversion h].
  { destruct a1_1.
    all: try solve [right; move=> h; inversion h].
    destruct (rho_eq_dec rho0 rho).
    destruct (tm_eq_dec a2 (open_tm_wrt_tm a1_1 a1_2)).
    destruct (@Value_dec (a_UAbs rho0 a1_1)).
    { inversion LC1. auto. }
    { subst. left. eapply Beta_AppAbs; eauto; inversion LC1; auto. }
    { right. move => h. inversion h. subst. ok. }
    { right; move => h; inversion h. subst. ok. }
    { right; move => h; inversion h. subst. ok. }

  }
  {
    move: uniq_toplevel => h0.
    destruct (binds_lookup _ F toplevel) as [ [ss b] | h1].
    destruct ss.
    { right; move=>h; inversion h.
      apply (binds_unique _ _ _ _ _ b H0) in h0. inversion h0. }
    destruct (tm_eq_dec a2 a).
    { subst. left. eauto. }
    { right; move=>h; inversion h.
      apply (binds_unique _ _ _ _ _ b H0) in h0. inversion h0. ok. }
    { right; move=>h; inversion h.
      unfold not in h1. eapply h1. eauto.
    }
  }
  {
    destruct a1.
    all: try solve [right; move=> h; inversion h].
    destruct (co_eq_dec g g_Triv).
    destruct (tm_eq_dec a2 (open_tm_wrt_co a1 g_Triv)).
    { subst. left. eapply Beta_CAppCAbs. inversion LC1. auto. }
    { right; move=>h; inversion h. ok. }
    { right; move=>h; inversion h. ok. }
  }
Qed.

Unset Implicit Arguments.

Program Fixpoint RhoCheck_erase_dec rho x a (_ : lc_tm a) : {RhoCheck rho x (erase_tm a)} + {¬ RhoCheck rho x (erase_tm a)} :=
  let a' := erase a in
  match rho with
    | Rel   => yeah
    | Irrel => not_in_dec x (fv_tm_tm_tm a') >--> yeah
  end.

Next Obligation.
  clear Heq_anonymous.
  subst.
  inversion 1.
  ok.
Defined.

End fc_dec_aux.


(*interface (e) to show the difference
between SME-NI and the extended SIR-NNI*)

Require Export refine.
Require Export parser.
Require Import subsetconst.

Definition expr2e: IA := parse
"IA [s1,s2,s3,s4,s5] (s1) [h1,h2] [m1,m2] []
 [s1->(h1)s2, s1->(h2)s3, s2->(m1)s4, s3->(m2)s5]".

(*at m1: false*)
Definition expr2e_m1_rep: IA :=
 subset_construction
 ( IAutomaton.hiding
 ( IAutomaton.replacement expr2e (&"tau") (ASet.GenActs [&"h1",&"h2"]) )
 (ASet.GenActs [&"m2"]) ).
(*Eval compute in IAutomaton.display expr2e_m1_rep.*)

Definition expr2e_m1_hid: IA :=
IAutomaton.hiding expr2e (ASet.GenActs [&"h1",&"h2",&"m2"]).

(*Eval compute in IAutomaton.display expr2e_m1_rep.
Eval compute in IAutomaton.display expr2e_m1_hid.*)
Eval compute in SMENI_refinement expr2e_m1_rep expr2e_m1_hid.

(*at m2: false*)
Definition expr2e_m2_rep: IA :=
 subset_construction
 ( IAutomaton.hiding
 ( IAutomaton.replacement expr2e (&"tau") (ASet.GenActs [&"h1",&"h2"]) )
 (ASet.GenActs [&"m1"]) ).
(*Eval compute in IAutomaton.display expr2e_m2_rep.*)

Definition expr2e_m2_hid: IA :=
IAutomaton.hiding expr2e (ASet.GenActs [&"h1",&"h2",&"m1"]).

Eval compute in SMENI_refinement expr2e_m2_rep expr2e_m2_hid.

(*at l: true *)
Definition expr2e_l_rep: IA :=
 subset_construction
 ( IAutomaton.hiding
 ( IAutomaton.replacement expr2e (&"tau") (ASet.GenActs [&"h1",&"h2"]) )
 (ASet.GenActs [&"m1",&"m2"]) ).

Definition expr2e_l_hid: IA :=
 IAutomaton.hiding expr2e (ASet.GenActs [&"h1",&"h2",&"m1",&"m2"]).

Eval compute in SMENI_refinement expr2e_l_rep expr2e_l_hid.


(* Formulas with separated first- and second-order quantifiers *)

From Coq Require Import Lia.
From OLlibs Require Import List_more.
From Quantifiers Require Export foterms_ext.

Set Implicit Arguments.

(** * Formulas *)

Section Formulas.

Context {vatom : DecType} {tatom : Type}.
Notation term := (@term vatom tatom).
Arguments evar _ _ {T}.
Notation evar := (evar vatom tatom).

Notation "r ;; s" := (fecomp r s) (at level 20, format "r  ;;  s").
Notation tclosed t := (tvars t = nil).
Notation rtclosed r := (forall n, tclosed (r n)).
Notation "⇑" := fup.
Notation "⇑[ u ] r" := (felift u r) (at level 25, format "⇑[ u ] r").

Hint Rewrite (@tesubs_evar vatom tatom) : term_db.
Hint Rewrite (@tesubs_comp vatom tatom) : term_db.
Hint Rewrite (@tsubs_tsubs_eq vatom tatom) : term_db.
Hint Rewrite (@tsubs_tsubs vatom tatom)
                        using try tauto;
                              try apply closed_notvars; tauto : term_db.
Hint Rewrite (@tvars_tesubs_closed vatom tatom) using tauto : term_db.
Hint Rewrite (@tvars_tsubs_closed vatom tatom) using tauto : term_db.
Hint Rewrite (@notin_tsubs vatom tatom)
                         using try easy; try tauto;
                               try apply closed_notvars; tauto: term_db.
Hint Rewrite (@notin_tsubs_bivar vatom tatom)
                               using try easy; try tauto;
                                     try apply closed_notvars; tauto : term_db.
Hint Rewrite (@tsubs_tesubs vatom tatom) using try tauto : term_db.

Hint Resolve tesubs_ext : term_db.
Hint Resolve closed_notvars : term_db.

Context { satom : DecType }.  (* second-order variables *)
Context { fatom : Type }.  (* relation symbols for [formula] *)
(* Generic sets of connectives *)
Context { NCon : Type }. (* nullary connectives *)
Context { UCon : Type }. (* unary connectives *)
Context { BCon : Type }. (* binary connectives *)
Context { QFCon : Type }. (* first-order quantifiers *)
Context { QSCon : Type }. (* second-order quantifiers *)

(** formulas *)
Inductive formula U T :=
| sevar : U -> formula U T
| svar : satom -> formula U T
| fvar : fatom -> list (term T)-> formula U T
| fnul : NCon -> formula U T
| funa : UCon -> formula U T -> formula U T
| fbin : BCon -> formula U T -> formula U T -> formula U T
| fqtf : QFCon -> vatom -> formula U T -> formula U T
| sqtf : QSCon -> satom -> formula U T -> formula U T.
Arguments sevar {U T} _.
Arguments svar {U T} _.
Arguments fvar {U T} _.
Arguments fnul {U T} _.
(* Nullary connectives in [NCon] and [fnul] are mostly redundant with [fvar f nil] *)

Ltac formula_induction A :=
  (try intros until A) ;
  let nn := fresh "n" in
  let RR := fresh "R" in
  let XX := fresh "X" in
  let xx := fresh "x" in
  let ncon := fresh "ncon" in
  let ucon := fresh "ucon" in
  let bcon := fresh "bcon" in
  let qcon := fresh "qcon" in
  let A1 := fresh A in
  let A2 := fresh A in
  let ll := fresh "l" in
  let lll := fresh "l" in
  let tt := fresh "t" in
  let IHll := fresh "IHl" in
  let IH := fresh "IH" in
  let IH2 := fresh "IH" in
  induction A as [ n | XX | RR ll | ncon | ucon A IH | bcon A1 IH A2 IH2
                 | qcon xx A IH | qcon XX A IH ]; simpl; intros;
  [ try (apply (f_equal sevar)); try ((rnow idtac); fail)
  | try (apply (f_equal svar)); repeat case_analysis; try ((rnow idtac); fail)
  | rewrite ? flat_map_concat_map;
    try (apply (f_equal (fvar _)));
    try (induction ll as [ | tt lll IHll ]; simpl; intuition;
         rewrite IHll; f_equal; intuition)
  | try (try f_equal; intuition; fail)
  | try (apply (f_equal (funa _))); intuition
  | try (apply (f_equal2 (fbin _))); intuition
  | (try apply (f_equal (fqtf _ _))); repeat case_analysis; try (intuition; fail); try now rcauto
  | (try apply (f_equal (sqtf _ _))); repeat case_analysis; try (intuition; fail); try now rcauto ];
  try (rewrite ? IH, ? IH2; reflexivity);
  try now rcauto.

(** * Atomic formulas *)

Inductive atomic U T : formula U T -> Prop :=
| atomic_sevar u : atomic (sevar u)
| atomic_svar X : atomic (svar X)
| atomic_fvar f l : atomic (fvar f l).

(** * Size of [formula] *)

Fixpoint fsize U T (A : formula U T) :=
match A with
| sevar _ | svar _ | fvar _ _ | fnul _ => 1
| funa _ B => S (fsize B)
| fbin _ B C => S (fsize B + fsize C)
| fqtf _ _ B | sqtf _ _ B => S (fsize B)
end.

(** * Free variables in [formula] *)

Fixpoint freevars U T (A : formula U T) :=
match A with
| sevar _ => nil
| svar _ => nil
| fvar _ l => flat_map (@tvars _ _ _) l
| fnul _ => nil
| funa _ B => freevars B
| fbin _ B C => freevars B ++ freevars C
| fqtf _ x B => remove eq_dt_dec x (freevars B)
| sqtf _ x B => freevars B
end.
Notation fclosed A := (freevars A = nil).
Notation rfclosed r := (forall n, fclosed (r n)).

Lemma fclosed_nofreevars U T (A : formula U T) x : fclosed A -> ~ In x (freevars A).
Proof. intros -> []. Qed.

Lemma rfclosed_nofreevars U1 U2 T (r : U1 -> formula U2 T) n x : rfclosed r -> ~ In x (freevars (r n)).
Proof. intros -> []. Qed.

Fixpoint sfreevars U T (A : formula U T) :=
match A with
| sevar _=> nil
| svar X => X :: nil
| fvar _ l => nil
| fnul _ => nil
| funa _ B => sfreevars B
| fbin _ B C => sfreevars B ++ sfreevars C
| fqtf _ x B => sfreevars B
| sqtf _ X B => remove eq_dt_dec X (sfreevars B)
end.
Notation sclosed A := (sfreevars A = nil).
Notation rsclosed r := (forall n, sclosed (r n)).

Lemma sclosed_nosfreevars U T (A : formula U T) X : sclosed A -> ~ In X (sfreevars A).
Proof. intros -> []. Qed.

Lemma rsclosed_nosfreevars U1 U2 T (r : U1 -> formula U2 T) n x : rsclosed r -> ~ In x (sfreevars (r n)).
Proof. intros -> []. Qed.

(** * Substitution of first-order eigen variables in [formula] *)

(** substitutes the [term] [r n] for index [n] in [formula] [A] *)
(* capture is not avoided *)
Fixpoint esubs U T1 T2 (r : T1 -> term T2) (A : formula U T1) :=
match A with
| sevar e => sevar e
| svar X => svar X
| fvar R l => fvar R (map (tesubs r) l)
| fnul ncon => fnul ncon
| funa ucon B => funa ucon (esubs r B)
| fbin bcon B C => fbin bcon (esubs r B) (esubs r C)
| fqtf qcon x B => fqtf qcon x (esubs r B)
| sqtf qcon X B => sqtf qcon X (esubs r B)
end.
Notation "A ⟦ r ⟧" := (esubs r A) (at level 8, left associativity, format "A ⟦ r ⟧").

Lemma fsize_esubs U T1 T2 (r : T1 -> term T2) (A : formula U T1) : fsize A⟦r⟧ = fsize A.
Proof. formula_induction A. Qed.
Hint Rewrite fsize_esubs : term_db.

Lemma freevars_esubs_closed U T1 T2 (r : T1 -> term T2) (A : formula U T1) (Hc : rtclosed r) :
  freevars A⟦r⟧ = freevars A.
Proof. formula_induction A. Qed.
Hint Rewrite freevars_esubs_closed using tauto : term_db.

Lemma freevars_esubs U T1 T2 (r : T1 -> term T2) (A : formula U T1) : incl (freevars A) (freevars A⟦r⟧).
Proof. formula_induction A.
- clear. induction l as [|t l IHl]; cbn; [ intro; tauto | ].
  apply incl_app_app, IHl.
  apply tvars_tesubs.
- apply remove_incl. assumption.
Qed.
#[local] Hint Rewrite freevars_esubs : term_db.

Lemma sfreevars_esubs U T1 T2 (r : T1 -> term T2) (A : formula U T1) : sfreevars A⟦r⟧ = sfreevars A.
Proof. formula_induction A. Qed.
#[local] Hint Rewrite sfreevars_esubs : term_db.

Lemma esubs_evar U T (A : formula U T) : A⟦evar⟧ = A.
Proof. formula_induction A. Qed.
Hint Rewrite esubs_evar : term_db.

Lemma esubs_comp U T1 T2 T3 (r : T1 -> term T2) (s : T2 -> term T3) (A : formula U T1) :
  A⟦r⟧⟦s⟧ = A⟦r ;; s⟧.
Proof. formula_induction A. Qed.
Hint Rewrite esubs_comp : term_db.

(* the result of substitution depends extensionnaly on the substituting function *)
Lemma esubs_ext U T1 T2 (r1 r2 : T1 -> term T2) : r1 ~ r2 -> forall A : formula U T1, A⟦r1⟧ = A⟦r2⟧.
Proof. formula_induction A. Qed.

(** * Formula substitution *)

(** ** Substitution of second-order eigen variables in [formula] *)

(** substitutes the [formula] [r n] for index [n] in [formula] [A] *)
(* capture is not avoided *)
Fixpoint essubs U1 U2 T (r : U1 -> formula U2 T) (A : formula U1 T) :=
match A with
| sevar e => r e
| svar X => svar X
| fvar R l => fvar R l
| fnul ncon => fnul ncon
| funa ucon B => funa ucon (essubs r B)
| fbin bcon B C => fbin bcon (essubs r B) (essubs r C)
| fqtf qcon x B => fqtf qcon x (essubs r B)
| sqtf qcon X B => sqtf qcon X (essubs r B)
end.
Notation "A ⟦ r ⟧2" := (essubs r A) (at level 8, left associativity, format "A ⟦ r ⟧2").

Definition fescomp U1 U2 U3 T (r : U1 -> formula U2 T) (s : U2 -> formula U3 T) := fun x => (r x)⟦s⟧2.
Notation "r ;2; s" := (fescomp r s) (at level 20, format "r  ;2;  s").

Lemma fsize_essubs U1 U2 T (r : U1 -> formula U2 T) A : fsize A <= fsize A⟦r⟧2.
Proof. formula_induction A; (try (destruct (r n))); cbn; lia. Qed.
Hint Rewrite fsize_essubs : term_db.

Lemma freevars_essubs_closed U1 U2 T (r : U1 -> formula U2 T) (A : formula U1 T) (Hc : rfclosed r) :
  freevars A⟦r⟧2 = freevars A.
Proof. formula_induction A. Qed.
#[local] Hint Rewrite freevars_essubs_closed : term_db.

Lemma sfreevars_essubs_closed U1 U2 T (r : U1 -> formula U2 T) (A : formula U1 T) (Hc : rsclosed r) :
  sfreevars A⟦r⟧2 = sfreevars A.
Proof. formula_induction A. Qed.
#[local] Hint Rewrite sfreevars_essubs_closed : term_db.

Lemma essubs_evar U T (A : formula U T) : A⟦sevar⟧2 = A.
Proof. formula_induction A. Qed.
Hint Rewrite essubs_evar : term_db.

Lemma essubs_comp U1 U2 U3 T (r : U1 -> formula U2 T) (s : U2 -> formula U3 T) A :
  A⟦r⟧2⟦s⟧2 = A⟦r ;2; s⟧2.
Proof. formula_induction A. Qed.
Hint Rewrite essubs_comp : term_db.

(* the result of substitution depends extensionnaly on the substituting function *)
Lemma essubs_ext U1 U2 T (r1 r2 : U1 -> formula U2 T) : r1 ~ r2 -> forall A, A⟦r1⟧2 = A⟦r2⟧2.
Proof. formula_induction A. Qed.

(** ** Substitution of first-order variables in [formula] *)

(** substitutes [term] [u] for variable [x] in [formula] [A] *)
(* capture is not avoided *)
Fixpoint subs U T x u (A : formula U T) :=
match A with
| sevar n => sevar n
| svar X => svar X
| fvar X l => fvar X (map (tsubs x u) l)
| fnul ncon => fnul ncon
| funa ucon B => funa ucon (subs x u B)
| fbin bcon B C => fbin bcon (subs x u B) (subs x u C)
| fqtf qcon y B => fqtf qcon y (if eq_dt_dec y x then B else subs x u B)
| sqtf qcon X B => sqtf qcon X (subs x u B)
end.
Notation "A [ u // x ]" := (subs x u A) (at level 8, format "A [ u // x ]").

Lemma fsize_subs U T u x (A : formula U T) : fsize A[u//x] = fsize A.
Proof. formula_induction A. Qed.
#[local] Hint Rewrite fsize_subs : term_db.

Lemma nfree_subs U T x u (A : formula U T) : ~ In x (freevars A) -> subs x u A = A.
Proof. formula_induction A.
- apply notin_tsubs. intro. apply H. in_solve.
- apply H. in_solve.
- apply IH. intro. apply H. apply in_in_remove; auto.
Qed.
#[local] Hint Rewrite nfree_subs using try tauto;
                                       try (apply fclosed_nofreevars; tauto);
                                       try apply rfclosed_nofreevars; tauto : term_db.

(** ** Substitution of second-order variables in [formula] *)

(** substitutes [formula] [F] for variable [x] in [formula] [A] *)
(* capture is not avoided *)
Fixpoint ssubs U T X F (A : formula U T) :=
match A with
| sevar n => sevar n
| svar Y => if eq_dt_dec Y X then F else (svar Y)
| fvar R l => fvar R l
| fnul ncon => fnul ncon
| funa ucon B => funa ucon (ssubs X F B)
| fbin bcon B C => fbin bcon (ssubs X F B) (ssubs X F C)
| fqtf qcon y B => fqtf qcon y (ssubs X F B)
| sqtf qcon Y B => sqtf qcon Y (if eq_dt_dec Y X then B else ssubs X F B)
end.
Notation "A [ F // X ]2" := (ssubs X F A) (at level 8, format "A [ F // X ]2").

Lemma fsize_ssubs U T F X (A : formula U T) : fsize A <= fsize A[F//X]2.
Proof. formula_induction A; (try destruct F); cbn; lia. Qed.
#[local] Hint Rewrite fsize_ssubs : term_db.

Lemma fsize_ssubs_atomic U T F X (A : formula U T) : atomic F -> fsize A[F//X]2 = fsize A.
Proof. formula_induction A; (try destruct F; inversion H); cbn; lia. Qed.
#[local] Hint Rewrite fsize_ssubs_atomic : term_db.

(** ** Additional results with variable eigen type *)

Lemma nfree_ssubs U T X F (A : formula U T) : ~ In X (sfreevars A) -> A[F//X]2 = A.
Proof. formula_induction A. apply IH. intro. apply H. apply in_in_remove; auto. Qed.
#[local] Hint Rewrite nfree_ssubs using try tauto;
                                       try (apply sclosed_nosfreevars; tauto);
                                       try apply rsclosed_nosfreevars; tauto : term_db.

Lemma subs_esubs U T1 T2 (r : T1 -> term T2) x u (A : formula U T1): rtclosed r ->
  A[u//x]⟦r⟧ = A⟦r⟧[tesubs r u//x].
Proof. formula_induction A. Qed.
#[local] Hint Rewrite subs_esubs using tauto : term_db.

Lemma ssubs_esubs U T1 T2 (r : T1 -> term T2) X F (A : formula U T1): rtclosed r ->
  A[F//X]2⟦r⟧ = A⟦r⟧[F⟦r⟧//X]2.
Proof. formula_induction A. Qed.
#[local] Hint Rewrite ssubs_esubs using tauto : term_db.

Lemma subs_essubs U1 U2 T (r : U1 -> formula U2 T) x u A (Hc : rfclosed r) : A[u//x]⟦r⟧2 = A⟦r⟧2[u//x].
Proof. formula_induction A. Qed.
#[local] Hint Rewrite subs_essubs using tauto : term_db.

Lemma ssubs_essubs U1 U2 T (r : U1 -> formula U2 T) X F A (Hc : rsclosed r) : A[F//X]2⟦r⟧2 = A⟦r⟧2[F⟦r⟧2//X]2.
Proof. formula_induction A. Qed.
#[local] Hint Rewrite ssubs_essubs using tauto : term_db.

(* We restrict to [formula nat nat] *)
(** * Eigen variables *)

Notation "A ↑" := (A⟦⇑⟧) (at level 8, format "A ↑").
Notation "v ⇓" := (fesubs v) (at level 18, format "v ⇓").

Lemma freevars_fup T (A : formula T nat) : freevars A↑ = freevars A.
Proof. formula_induction A. Qed.
#[local] Hint Rewrite freevars_fup : term_db.

Lemma sfreevars_fup T (A : formula T nat) : sfreevars A↑ = sfreevars A.
Proof. formula_induction A. Qed.
#[local] Hint Rewrite sfreevars_fup : term_db.

Lemma esubs_fup T v (A : formula T nat) : A↑⟦v⇓⟧ = A.
Proof. rcauto. Qed.
#[local] Hint Rewrite esubs_fup : term_db.

Lemma felift_esubs T u r (A : formula T nat) : A↑⟦⇑[u]r⟧ = A⟦r⟧↑.
Proof. rcauto. Qed.
#[local] Hint Rewrite felift_esubs : term_db.

Definition sfup T := fun n => @sevar nat T (S n).
Notation "⇑2" := (sfup nat).
Notation "A ↑2" := (A⟦⇑2⟧2) (at level 8, format "A ↑2").

Lemma fclosed_sfup : rfclosed ⇑2.
Proof. reflexivity. Qed.
Hint Rewrite fclosed_sfup : term_db.

Lemma sclosed_sfup : rsclosed ⇑2.
Proof. reflexivity. Qed.
Hint Rewrite sclosed_sfup : term_db.

Lemma fsize_sfup A : fsize A↑2 = fsize A.
Proof. formula_induction A. Qed.
#[local] Hint Rewrite fsize_sfup : term_db.

Lemma freevars_sfup A : freevars A↑2 = freevars A.
Proof. formula_induction A. Qed.
#[local] Hint Rewrite freevars_sfup : term_db.

Lemma sfreevars_sfup A : sfreevars A↑2 = sfreevars A.
Proof. formula_induction A. Qed.
#[local] Hint Rewrite sfreevars_sfup : term_db.

Definition fessubs T (F : formula nat T) := fun n =>
  match n with
  | 0 => F
  | S n => sevar n
  end.
Notation "F ⇓2" := (fessubs F) (at level 18, format "F ⇓2").

Lemma fclosed_fessubs T (F : formula nat T) : fclosed F -> rfclosed (F⇓2).
Proof. now intros Hc [|]. Qed.
Hint Resolve fclosed_fessubs : term_db.

Lemma sclosed_fessubs T (F : formula nat T) : sclosed F -> rsclosed (F⇓2).
Proof. now intros Hc [|]. Qed.
Hint Resolve sclosed_fessubs : term_db.

Definition feslift F r := fun n =>
  match n with
  | 0 => F
  | S k => (r k)↑2
  end.
Notation "⇑2[ F ] r" := (feslift F r) (at level 25, format "⇑2[ F ] r").

Lemma fclosed_feslift F r : fclosed F -> rfclosed r -> rfclosed (⇑2[F]r).
Proof. rnow intros ? ? [|]. Qed.
Hint Resolve fclosed_feslift : term_db.

Lemma sclosed_feslift F r : sclosed F -> rsclosed r -> rsclosed (⇑2[F]r).
Proof. rnow intros ? ? [|]. Qed.
Hint Resolve sclosed_feslift : term_db.

Lemma essubs_fup F A : A↑2⟦F⇓2⟧2 = A.
Proof. rcauto. Qed.
#[local] Hint Rewrite essubs_fup : term_db.

Lemma felift_essubs (r : nat -> formula nat nat) A : A↑⟦fun n => (r n)↑⟧2 = A⟦r⟧2↑.
Proof. formula_induction A. Qed.
#[local] Hint Rewrite felift_essubs : term_db.

Lemma feslift_esubs r (A : formula nat nat) : A↑2⟦r⟧ = A⟦r⟧↑2.
Proof. formula_induction A. Qed.
#[local] Hint Rewrite feslift_esubs : term_db.

Lemma feslift_essubs F r A : A↑2⟦⇑2[F]r⟧2 = A⟦r⟧2↑2.
Proof. rcauto. Qed.
#[local] Hint Rewrite feslift_essubs : term_db.

End Formulas.

(* Some sets of connectives *)
Inductive Nocon := .
Inductive Icon := imp_con.
Inductive Qcon := frl_con | exs_con.

Notation imp := (fbin imp_con).
Notation frl := (fqtf frl_con).
Notation exs := (fqtf exs_con).

Ltac formula_induction A :=
  (try intros until A) ;
  let nn := fresh "n" in
  let RR := fresh "R" in
  let XX := fresh "X" in
  let xx := fresh "x" in
  let ncon := fresh "ncon" in
  let ucon := fresh "ucon" in
  let bcon := fresh "bcon" in
  let qcon := fresh "qcon" in
  let A1 := fresh A in
  let A2 := fresh A in
  let ll := fresh "l" in
  let lll := fresh "l" in
  let tt := fresh "t" in
  let IHll := fresh "IHl" in
  let IH := fresh "IH" in
  let IH2 := fresh "IH" in
  induction A as [ n | XX | RR ll | ncon | ucon A IH | bcon A1 IH A2 IH2
                 | qcon xx A IH | qcon XX A IH ]; simpl; intros;
  [ try (apply (f_equal sevar)); try ((rnow idtac); fail)
  | try (apply (f_equal svar)); repeat case_analysis; try ((rnow idtac); fail)
  | rewrite ? flat_map_concat_map;
    try (apply (f_equal (fvar _)));
    try (induction ll as [ | tt lll IHll ]; simpl; intuition;
         rewrite IHll; f_equal; intuition)
  | try (try f_equal; intuition; fail)
  | try (apply (f_equal (funa _))); intuition
  | try (apply (f_equal2 (fbin _))); intuition
  | (try apply (f_equal (fqtf _ _))); repeat case_analysis; try (intuition; fail); try now rcauto
  | (try apply (f_equal (sqtf _ _))); repeat case_analysis; try (intuition; fail); try now rcauto ];
  try (rewrite ? IH, ? IH2; reflexivity);
  try now rcauto.


Set Warnings "-notation-overridden,-parsing,-deprecated-hint-without-locality".
From Coq Require Import Bool.Bool.
From Coq Require Import Strings.String.
From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat. Import Nat.
From Coq Require Import Arith.PeanoNat.
From Coq Require Import Lia.
From Coq Require Import Lists.List. Import ListNotations.
From Coq Require Import Strings.String.
From Coq Require Import Logic.Eqdep_dec.
From Coq Require Import Logic.FunctionalExtensionality.
From PFPL Require Import PartialMap_Set.
From PFPL Require Import Definitions.
From PFPL Require Import Lemmas_Vars.
From PFPL Require Import Lemmas_Same_Structure.
From PFPL Require Import Induction_Expr.

Lemma rename_keeps_structure :
  forall e x x', same_structure e (rename e x x').
Proof.
  intros.
  induction e.
  all: simpl.
  all: try constructor.
  destruct (x =? x0); constructor.
  all: auto.
  destruct (x =? x0); constructor.
  all: auto.
  apply same_structure_refl.
Qed.

Lemma rename_the_same :
  forall e x, e = rename e x x.
Proof.
  intros.
  induction e.
  all: simpl.
  reflexivity.
  reflexivity.
  case_eq (x =? x0); intros.
  apply Nat.eqb_eq in H. subst.
  reflexivity. reflexivity.
  rewrite <- IHe1. rewrite <- IHe2. reflexivity.
  rewrite <- IHe1. rewrite <- IHe2. reflexivity.
  rewrite <- IHe1. rewrite <- IHe2. reflexivity.
  rewrite <- IHe. reflexivity.
  rewrite <- IHe1. rewrite <- IHe2.
  destruct (x =? x0).
  reflexivity. reflexivity.
Qed.

Lemma rename_non_existant : forall e x x',
  all_vars e x = false -> e = rename e x x'.
Proof.
  intros.
  induction e; simpl.
  - reflexivity.
  - reflexivity.
  - simpl in H. unfold singletonSet in H.
    assert(H1 := Nat.eqb_sym x0 x).
    rewrite <- H1.
    destruct (x0 =? x).
    discriminate. reflexivity.
  - simpl in H. unfold unionSet in H.
    apply orb_false_iff in H. destruct H.
    f_equal.
    apply IHe1. assumption.
    apply IHe2. assumption.
  - simpl in H. unfold unionSet in H.
    apply orb_false_iff in H. destruct H.
    f_equal.
    apply IHe1. assumption.
    apply IHe2. assumption.
  - simpl in H. unfold unionSet in H.
    apply orb_false_iff in H. destruct H.
    f_equal.
    apply IHe1. assumption.
    apply IHe2. assumption.
  - simpl in H.
    f_equal.
    apply IHe. assumption.
  - simpl in H. unfold unionSet in H.
    apply orb_false_iff in H. destruct H.
    unfold updateSet in H0.
    assert(H1 := Nat.eqb_sym x0 x).
    rewrite <- H1.
    destruct (x0 =? x).
    discriminate.
    f_equal.
    apply IHe1. assumption.
    apply IHe2. assumption.
Qed.

Lemma rename_non_existant_free : forall e x x',
  free_vars e x = false -> e = rename e x x'.
Proof.
  intros.
  induction e; simpl.
  - reflexivity.
  - reflexivity.
  - simpl in H. unfold singletonSet in H.
    assert(H1 := Nat.eqb_sym x0 x).
    rewrite <- H1.
    destruct (x0 =? x).
    discriminate. reflexivity.
  - simpl in H. unfold unionSet in H.
    apply orb_false_iff in H. destruct H.
    f_equal.
    apply IHe1. assumption.
    apply IHe2. assumption.
  - simpl in H. unfold unionSet in H.
    apply orb_false_iff in H. destruct H.
    f_equal.
    apply IHe1. assumption.
    apply IHe2. assumption.
  - simpl in H. unfold unionSet in H.
    apply orb_false_iff in H. destruct H.
    f_equal.
    apply IHe1. assumption.
    apply IHe2. assumption.
  - simpl in H.
    f_equal.
    apply IHe. assumption.
  - simpl in H. unfold unionSet in H.
    apply orb_false_iff in H. destruct H.
    unfold updateSet in H0.
    rewrite Nat.eqb_sym.
    case_eq (x0 =? x); intros.
    apply Nat.eqb_eq in H1. subst.
    f_equal.
    apply IHe1. assumption.
    f_equal.
    apply IHe1. assumption.
    apply IHe2. unfold removeFromSet in H0.
    rewrite H1 in H0.
    assumption.
Qed.

Lemma rename_non_existant_free_2 : forall e x x',
  (x =? x' = false) -> e = rename e x x' -> free_vars e x = false.
Proof.
  intros.
  induction e; simpl.
  - reflexivity.
  - reflexivity.
  - simpl in H0. unfold singletonSet.
    rewrite Nat.eqb_sym.
    case_eq (x =? x0); intros.
    rewrite H1 in H0.
    apply Nat.eqb_eq in H1. subst.
    inversion H0. subst.
    rewrite Nat.eqb_refl in H. discriminate.
    reflexivity.
  - simpl in H0. inversion H0.
    unfold unionSet.
    apply orb_false_iff. split.
    rewrite <- H2. apply IHe1. assumption.
    rewrite <- H3. apply IHe2. assumption.
  - simpl in H0. inversion H0.
    unfold unionSet.
    apply orb_false_iff. split.
    rewrite <- H2. apply IHe1. assumption.
    rewrite <- H3. apply IHe2. assumption.
  - simpl in H0. inversion H0.
    unfold unionSet.
    apply orb_false_iff. split.
    rewrite <- H2. apply IHe1. assumption.
    rewrite <- H3. apply IHe2. assumption.
  - simpl in H0. inversion H0.
    rewrite <- H2. apply IHe. assumption.
  - simpl in H0.
    unfold unionSet.
    apply orb_false_iff.
    case_eq (x =? x0); intros; rewrite H1 in H0; inversion H0.
    + apply Nat.eqb_eq in H1. subst.
      split.
      rewrite <- H3. apply IHe1. assumption.
      unfold removeFromSet.
      rewrite Nat.eqb_refl.
      reflexivity.
    + split.
      rewrite <- H3. apply IHe1. assumption.
      unfold removeFromSet.
      rewrite Nat.eqb_sym in H1.
      rewrite H1.
      rewrite <- H4.
      apply IHe2. assumption.
Qed.

Lemma rename_removes_free_vars : forall e x x',
  (x =? x' = false) -> free_vars (rename e x x') x = false.
Proof.
  intros e x x'.
  induction e using expr_ind; intros.
  - simpl. rewrite Nat.eqb_sym.
    case_eq (x0 =? x); intros.
    all: simpl.
    all: unfold singletonSet.
    rewrite Nat.eqb_sym.
    rewrite H.
    reflexivity.
    rewrite H0.
    reflexivity.
  - simpl.
    case_eq (x =? x0); intros;
    rewrite Nat.eqb_sym in H2.
    all: simpl; unfold unionSet.
    all: apply orb_false_iff; split.
    + apply H.
      apply same_structure_refl.
      assumption.
    + unfold removeFromSet.
      rewrite H2.
      reflexivity.
    + apply H.
      apply same_structure_refl.
      assumption.
    + unfold removeFromSet.
      rewrite H2.
      apply H0.
      apply same_structure_refl.
      assumption.
  - simpl. unfold emptySet. reflexivity.
  - simpl. unfold emptySet. reflexivity.
  - simpl. unfold unionSet.
    apply orb_false_iff. split.
    apply H.
    apply same_structure_refl.
    assumption.
    apply H0.
    apply same_structure_refl.
    assumption.
  - simpl. unfold unionSet.
    apply orb_false_iff. split.
    apply H.
    apply same_structure_refl.
    assumption.
    apply H0.
    apply same_structure_refl.
    assumption.
  - simpl. unfold unionSet.
    apply orb_false_iff. split.
    apply H.
    apply same_structure_refl.
    assumption.
    apply H0.
    apply same_structure_refl.
    assumption.
  - simpl.
    apply H.
    apply same_structure_refl.
    assumption.
Qed.

Lemma rename_keeps_other_free_vars : forall e x x' v,
  (v =? x = false) ->
  (v =? x' = false) ->
  free_vars e v = free_vars (rename e x x') v.
Proof.
  intros.
  case_eq (x =? x'); intros.
  - apply Nat.eqb_eq in H1. subst.
    rewrite <- rename_the_same.
    reflexivity.
  - induction e; simpl.
    + reflexivity.
    + reflexivity.
    + case_eq (x =? x0); intros.
      all: simpl.
      all: unfold singletonSet.
      all: case_eq (x0 =? v); intros.
      all: case_eq (x' =? v); intros.
      reflexivity.
      rewrite Nat.eqb_eq in H2. subst.
      rewrite Nat.eqb_eq in H3. subst.
      rewrite Nat.eqb_refl in H. discriminate.
      rewrite Nat.eqb_eq in H2. subst.
      rewrite Nat.eqb_eq in H4. subst.
      rewrite Nat.eqb_refl in H0. discriminate.
      all: reflexivity.
    + unfold unionSet.
      rewrite IHe1. rewrite IHe2. reflexivity.
    + unfold unionSet.
      rewrite IHe1. rewrite IHe2. reflexivity.
    + unfold unionSet.
      rewrite IHe1. rewrite IHe2. reflexivity.
    + assumption.
    + unfold unionSet. unfold removeFromSet.
      case_eq (x0 =? v); case_eq (x =? x0); intros.
      all: simpl.
      all: unfold unionSet.
      all: unfold removeFromSet.
      all: rewrite H3.
      rewrite IHe1. reflexivity.
      rewrite IHe1. reflexivity.
      rewrite IHe1. reflexivity.
      rewrite IHe1. rewrite IHe2. reflexivity.
Qed.

Lemma rename_keeps_other_vars : forall e x x' v,
  (v =? x = false) ->
  (v =? x' = false) ->
  all_vars e v = all_vars (rename e x x') v.
Proof.
  intros.
  case_eq (x =? x'); intros.
  - apply Nat.eqb_eq in H1. subst.
    rewrite <- rename_the_same.
    reflexivity.
  - induction e; simpl.
    + reflexivity.
    + reflexivity.
    + case_eq (x =? x0); intros.
      all: simpl.
      all: unfold singletonSet.
      all: case_eq (x0 =? v); intros.
      all: case_eq (x' =? v); intros.
      reflexivity.
      rewrite Nat.eqb_eq in H2. subst.
      rewrite Nat.eqb_eq in H3. subst.
      rewrite Nat.eqb_refl in H. discriminate.
      rewrite Nat.eqb_eq in H2. subst.
      rewrite Nat.eqb_eq in H4. subst.
      rewrite Nat.eqb_refl in H0. discriminate.
      all: reflexivity.
    + unfold unionSet.
      rewrite IHe1. rewrite IHe2. reflexivity.
    + unfold unionSet.
      rewrite IHe1. rewrite IHe2. reflexivity.
    + unfold unionSet.
      rewrite IHe1. rewrite IHe2. reflexivity.
    + assumption.
    + unfold unionSet. unfold removeFromSet.
      case_eq (x0 =? v); case_eq (x =? x0); intros.
      all: simpl.
      all: unfold updateSet.
      all: unfold unionSet.
      all: rewrite H3.
      rewrite IHe1. reflexivity.
      rewrite IHe1. reflexivity.
      rewrite IHe1. reflexivity.
      rewrite IHe1. rewrite IHe2. reflexivity.
Qed.

Lemma rename_the_free_var : forall e x x',
  free_vars e x = true -> all_vars e x' = false ->
  free_vars (rename e x x') x' = true.
Proof.
  intros.
  case_eq (x =? x'); intros.
  rewrite Nat.eqb_eq in H1. subst.
  assert (H2 : e = rename e x' x').
  apply rename_the_same.
  rewrite <- H2.
  assumption.
  induction e using expr_ind; intros.
  - simpl in H. unfold singletonSet in H.
    case_eq (x0 =? x); intros.
    apply Nat.eqb_eq in H2. subst.
    simpl. rewrite Nat.eqb_refl. simpl.
    unfold singletonSet.
    rewrite Nat.eqb_refl. reflexivity.
    rewrite H2 in H. discriminate.
  - simpl in H.
    unfold unionSet in H.
    apply orb_true_iff in H.
    simpl.
    unfold removeFromSet in H.
    simpl in H0.
    unfold unionSet in H0.
    apply orb_false_iff in H0.
    destruct H0.
    unfold updateSet in H4.
    case_eq (x0 =? x'); intros.
    rewrite H5 in H4. discriminate.
    rewrite H5 in H4.
    case_eq (x =? x0); intros.
    + apply Nat.eqb_eq in H6. subst.
      rewrite Nat.eqb_refl in H.
      simpl.
      apply orb_true_iff.
      destruct H.
      left.
      apply H2. apply same_structure_refl.
      assumption.
      assumption.
      discriminate.
    + rewrite Nat.eqb_sym in H.
      rewrite H6 in H.
      simpl.
      apply orb_true_iff.
      destruct H.
      left.
      apply H2. apply same_structure_refl.
      assumption. assumption.
      right.
      unfold removeFromSet.
      rewrite H5.
      apply H3. apply same_structure_refl.
      assumption. assumption.
  - inversion H.
  - inversion H.
  - simpl in H. unfold unionSet in H.
    apply orb_true_iff in H.
    simpl in H0. unfold unionSet in H0.
    apply orb_false_iff in H0.
    destruct H0.
    simpl. unfold unionSet.
    apply orb_true_iff.
    destruct H.
    left.
    apply H2. apply same_structure_refl.
    assumption. assumption.
    right.
    apply H3. apply same_structure_refl.
    assumption. assumption.
  - simpl in H. unfold unionSet in H.
    apply orb_true_iff in H.
    simpl in H0. unfold unionSet in H0.
    apply orb_false_iff in H0.
    destruct H0.
    simpl. unfold unionSet.
    apply orb_true_iff.
    destruct H.
    left.
    apply H2. apply same_structure_refl.
    assumption. assumption.
    right.
    apply H3. apply same_structure_refl.
    assumption. assumption.
  - simpl in H. unfold unionSet in H.
    apply orb_true_iff in H.
    simpl in H0. unfold unionSet in H0.
    apply orb_false_iff in H0.
    destruct H0.
    simpl. unfold unionSet.
    apply orb_true_iff.
    destruct H.
    left.
    apply H2. apply same_structure_refl.
    assumption. assumption.
    right.
    apply H3. apply same_structure_refl.
    assumption. assumption.
  - simpl in H.
    simpl in H0.
    simpl.
    apply H2. apply same_structure_refl.
    assumption. assumption.
Qed.

Lemma rename_commu : forall e a b c d,
  a =? c = false ->
  a =? d = false ->
  b =? c = false ->
  b =? d = false ->
  (rename (rename e a b) c d) = (rename (rename e c d) a b).
Proof.
  intros e.
  induction e using expr_ind; intros.
  - simpl.
    case_eq (a =? x); case_eq (c =? x); intros.
    + apply Nat.eqb_eq in H3. subst.
      rewrite H in H4. discriminate.
    + apply Nat.eqb_eq in H4. subst.
      simpl. rewrite Nat.eqb_sym.
      rewrite H1. rewrite Nat.eqb_refl.
      reflexivity.
    + apply Nat.eqb_eq in H3. subst.
      simpl. rewrite Nat.eqb_refl.
      rewrite H0.
      reflexivity.
    + simpl. rewrite H3. rewrite H4.
      reflexivity.
  - simpl.
    case_eq (a =? x); case_eq (c =? x); intros.
    + apply Nat.eqb_eq in H5. subst.
      rewrite H1 in H6. discriminate.
    + apply Nat.eqb_eq in H6. subst.
      simpl. rewrite H5. rewrite Nat.eqb_refl.
      f_equal.
      apply H.
      apply same_structure_refl.
      rewrite Nat.eqb_sym. assumption.
      assumption.
      assumption.
      assumption.
    + apply Nat.eqb_eq in H5. subst.
      simpl. rewrite H1. rewrite Nat.eqb_refl.
      f_equal.
      apply H.
      apply same_structure_refl.
      assumption. assumption.
      assumption. assumption.
    + simpl. rewrite H5. rewrite H6.
      f_equal.
      apply H.
      apply same_structure_refl.
      assumption. assumption.
      assumption. assumption.
      apply H0.
      apply same_structure_refl.
      assumption. assumption.
      assumption. assumption.
  - simpl. reflexivity.
  - simpl. reflexivity.
  - simpl. f_equal.
    apply (H e1 (same_structure_refl e1) a b c d H1 H2 H3 H4).
    apply (H0 e2 (same_structure_refl e2) a b c d H1 H2 H3 H4).
  - simpl. f_equal.
    apply (H e1 (same_structure_refl e1) a b c d H1 H2 H3 H4).
    apply (H0 e2 (same_structure_refl e2) a b c d H1 H2 H3 H4).
  - simpl. f_equal.
    apply (H e1 (same_structure_refl e1) a b c d H1 H2 H3 H4).
    apply (H0 e2 (same_structure_refl e2) a b c d H1 H2 H3 H4).
  - simpl. f_equal.
    apply (H e (same_structure_refl e) a b c d H0 H1 H2 H3).
Qed.

Lemma rename_does_not_add_new_var : forall e x x' z,
  x' =? z = false -> all_vars e z = false -> all_vars (rename e x x') z = false.
Proof.
  intros.
  rewrite Nat.eqb_sym in H.
  case_eq (z =? x); intro.
  - apply Nat.eqb_eq in H1. subst.
    rewrite <- rename_non_existant; assumption.
  - assert (T := rename_keeps_other_vars e x x' z H1 H).
    rewrite <- T. assumption.
Qed.

Lemma rename_keeps_bound_vars : forall e x x' v,
  bound_vars e v = bound_vars (rename e x x') v.
Proof.
  induction e; intros; simpl.
  - reflexivity.
  - reflexivity.
  - destruct (x0 =? x).
    all: simpl; reflexivity.
  - f_equal.
    all: apply functional_extensionality; intro.
    apply IHe1. apply IHe2.
  - f_equal.
    all: apply functional_extensionality; intro.
    apply IHe1. apply IHe2.
  - f_equal.
    all: apply functional_extensionality; intro.
    apply IHe1. apply IHe2.
  - apply IHe.
  - case_eq (x0 =? x); intro; simpl.
    + f_equal.
      all: apply functional_extensionality; intro.
      apply IHe1.
    + f_equal.
      all: apply functional_extensionality; intro.
      apply IHe1.
      unfold updateSet.
      destruct (x =? x1).
      reflexivity.
      apply IHe2.
Qed.

Lemma rename_twice : forall e a b c,
  (a =? b) = false ->
  all_vars e b = false ->
  (rename e a b) = (rename (rename e a b) a c).
Proof.
  intros.
  assert (T1 := rename_removes_free_vars e a b H).
  apply rename_non_existant_free.
  assumption.
Qed.


(* ** Reduction from PCP to deductive entailment *)

Require Import Undecidability.FOL.ZF.
Require Import Undecidability.FOL.Syntax.Facts.
Require Import Undecidability.FOL.Semantics.Tarski.FullFacts.
Require Import Undecidability.FOL.Sets.ZF.
Require Import Undecidability.FOL.Reductions.PCPb_to_ZF.

From Undecidability.PCP Require Import PCP Util.PCP_facts Reductions.PCPb_iff_dPCPb.

From Undecidability Require Import Shared.ListAutomation.
Import ListAutomationNotations ListAutomationHints.

Local Set Implicit Arguments.
Local Unset Strict Implicit.

Local Definition BSRS := list(card bool).
Local Notation "x / y" := (x, y).

Local Hint Constructors prv : core.

(* ** Simple derivations in ZF *)

Section ZF.

Context { p : peirce }.

Close Scope sem.

Lemma ZF_eset x :
  ZFeq' ⊢ ¬ (x ∈ ∅).
Proof.
  change (ZFeq' ⊢ (¬ ($0 ∈ ∅))[x..]).
  apply AllE. apply Ctx. firstorder.
Qed.

Lemma ZF_eset' T x :
  ZFeq' <<= T -> T ⊢ ¬ (x ∈ ∅).
Proof.
  intros H. now apply (Weak (ZF_eset x)).
Qed.

Fixpoint tnumeral n :=
  match n with
  | O => ∅
  | S n => σ (tnumeral n)
end.

Lemma ZF_numeral n :
  ZFeq' ⊢ tnumeral n ∈ ω.
Proof.
  induction n; cbn.
  - eapply CE1. apply Ctx. firstorder.
  - eapply IE; try apply IHn.
    change (ZFeq' ⊢ ($0 ∈ ω → σ ($0) ∈ ω)[(tnumeral n)..]).
    apply AllE. eapply CE2. apply Ctx. firstorder.
Qed.

Lemma ZF_refl' T x :
  ZFeq' <<= T -> T ⊢ x ≡ x.
Proof.
  intros H. change (T ⊢ ($0 ≡ $0)[x..]).
  apply AllE. apply Ctx. firstorder.
Qed.

Lemma ZF_refl x :
  ZFeq' ⊢ x ≡ x.
Proof.
  now apply ZF_refl'.
Qed.

Lemma ZF_sym' T x y :
  ZFeq' <<= T -> T ⊢ x ≡ y -> T ⊢ y ≡ x.
Proof.
  intros H1 H2. eapply IE; try apply H2.
  assert (H : T ⊢ ax_sym) by (apply Ctx; firstorder).
  apply (AllE x), (AllE y) in H; cbn in H. now subsimpl_in H.
Qed.

Lemma ZF_trans' T x y z :
  ZFeq' <<= T -> T ⊢ x ≡ y -> T ⊢ y ≡ z -> T ⊢ x ≡ z.
Proof.
  intros H1 H2 H3. eapply IE; try apply H3.
  eapply IE; try apply H2.
  assert (H : T ⊢ ax_trans) by (apply Ctx; firstorder).
  now apply (AllE x), (AllE y), (AllE z) in H; cbn in H; subsimpl_in H.
Qed.

Lemma ZF_eq_elem T x y x' y' :
  ZFeq' <<= T -> T ⊢ x ≡ x' -> T ⊢ y ≡ y' -> T ⊢ x ∈ y -> T ⊢ x' ∈ y'.
Proof.
  intros H1 H2 H3 H4. eapply IE; try apply H4.
  eapply IE; try apply H3. eapply IE; try apply H2.
  assert (H : T ⊢ ax_eq_elem) by (apply Ctx; firstorder).
  now apply (AllE x), (AllE y), (AllE x'), (AllE y') in H; cbn in H; subsimpl_in H.
Qed.

Lemma ZF_ext' T x y :
  ZFeq' <<= T -> T ⊢ sub x y -> T ⊢ sub y x -> T ⊢ x ≡ y.
Proof.
  intros H1 H2 H3. eapply IE; try apply H3.
  eapply IE; try apply H2.
  assert (H : T ⊢ ax_ext) by (apply Ctx; firstorder).
  apply (AllE x), (AllE y) in H; cbn in H.
  subsimpl_in H. apply H.
Qed.

Lemma ZF_pair_el' T x y z :
  ZFeq' <<= T -> T ⊢ (z ≡ x ∨ z ≡ y) <-> T ⊢ z ∈ {x; y}.
Proof.
  intros HT; split; intros H; eapply IE; try apply H.
  all: assert (HP : T ⊢ ax_pair) by (apply Ctx; firstorder).
  all: apply (AllE y), (AllE x), (AllE z) in HP; cbn in HP; subsimpl_in HP.
  - eapply CE2, HP.
  - eapply CE1, HP.
Qed.

Lemma ZF_pair_el x y z :
  ZFeq' ⊢ (z ≡ x ∨ z ≡ y) -> ZFeq' ⊢ z ∈ {x; y}.
Proof.
  now apply ZF_pair_el'.
Qed.

Lemma ZF_sub_pair T x y x' y' :
  ZFeq' <<= T -> T ⊢ x ≡ x' -> T ⊢ y ≡ y' -> T ⊢ {x; y} ⊆ {x'; y'}.
Proof.
  intros HT H1 H2. prv_all z.
  apply II. apply ZF_pair_el'; auto. eapply DE.
  - apply ZF_pair_el'; auto.
  - apply DI1. eapply ZF_trans'; auto. eapply Weak; eauto.
  - apply DI2. eapply ZF_trans'; auto. eapply Weak; eauto.
Qed.

Lemma ZF_eq_pair T x y x' y' :
  ZFeq' <<= T -> T ⊢ x ≡ x' -> T ⊢ y ≡ y' -> T ⊢ {x; y} ≡ {x'; y'}.
Proof.
  intros HT H1 H2. apply ZF_ext'; trivial.
  - now apply ZF_sub_pair.
  - apply ZF_sub_pair; trivial. all: now apply ZF_sym'.
Qed.

Lemma ZF_eq_opair T x y x' y' :
  ZFeq' <<= T -> T ⊢ x ≡ x' -> T ⊢ y ≡ y' -> T ⊢ opair x y ≡ opair x' y'.
Proof.
  intros HT H1 H2. repeat apply ZF_eq_pair; trivial.
Qed.

Definition sing x :=
  {x; x}.

Lemma ZF_sing_el x :
  ZFeq' ⊢ x ∈ sing x.
Proof.
  apply ZF_pair_el. apply DI1. apply ZF_refl.
Qed.

Lemma ZF_sing_iff T x y :
  ZFeq' <<= T -> T ⊢ x ∈ sing y <-> T ⊢ x ≡ y.
Proof.
  intros HT. unfold sing.
  rewrite <- ZF_pair_el'; trivial.
  split; intros H.
  - apply (DE H); auto.
  - now apply DI1.
Qed.

Lemma ZF_union_el' T x y z :
  ZFeq' <<= T -> T ⊢ y ∈ x ∧ z ∈ y -> T ⊢ z ∈ ⋃ x.
Proof.
  intros HT H.
  assert (HU : T ⊢ ax_union) by (apply Ctx; firstorder).
  apply (AllE x), (AllE z) in HU; cbn in HU. subsimpl_in HU.
  apply CE2 in HU. eapply IE; try apply HU.
  apply ExI with y. cbn. subsimpl. apply H.
Qed.

Lemma ZF_union_el x y z :
  ZFeq' ⊢ y ∈ x ∧ z ∈ y -> ZFeq' ⊢ z ∈ ⋃ x.
Proof.
  now apply ZF_union_el'.
Qed.

Lemma ZF_sub_union T x y :
  ZFeq' <<= T -> T ⊢ x ≡ y -> T ⊢ sub (⋃ x) (⋃ y).
Proof.
  intros HT H. prv_all z.
  apply II. assert1 H'.
  assert (HU : (z ∈ ⋃ x :: T) ⊢ ax_union) by (apply Ctx; firstorder).
  apply (AllE x), (AllE z) in HU; cbn in HU; subsimpl_in HU.
  apply CE1 in HU. eapply (IE HU) in H'.
  use_exists H' u. clear H' HU.
  eapply ZF_union_el'; auto. apply CI.
  - eapply ZF_eq_elem. auto. apply ZF_refl'; auto.
    apply (Weak H); auto. eapply CE1; auto.
  - eapply CE2; auto.
Qed.

Lemma ZF_eq_union T x y :
  ZFeq' <<= T -> T ⊢ x ≡ y -> T ⊢ ⋃ x ≡ ⋃ y.
Proof.
  intros HT H. apply ZF_ext'; try apply ZF_sub_union; trivial.
  now apply ZF_sym'.
Qed.

Lemma ZF_bunion_el' T x y z :
  ZFeq' <<= T -> T ⊢ (z ∈ x ∨ z ∈ y) -> T ⊢ z ∈ x ∪ y.
Proof.
  intros HT H. apply (DE H).
  - eapply ZF_union_el' with x. auto. apply CI; auto.
    apply ZF_pair_el'. auto. apply DI1. apply ZF_refl'. auto.
  - eapply ZF_union_el' with y. auto. apply CI; auto.
    apply ZF_pair_el'. auto. apply DI2. apply ZF_refl'. auto.
Qed.

Lemma ZF_bunion_el x y z :
  ZFeq' ⊢ (z ∈ x ∨ z ∈ y) -> ZFeq' ⊢ z ∈ x ∪ y.
Proof.
  now apply ZF_bunion_el'.
Qed.

Lemma ZF_bunion_inv' x y z :
   ZFeq' ⊢ z ∈ x ∪ y → z ∈ x ∨ z ∈ y.
Proof.
  assert (TU : ZFeq' ⊢ ax_union) by (apply Ctx; firstorder). unfold ax_union in TU.
  eapply (AllE ({x; y})), (AllE z), CE1 in TU; cbn in TU; subsimpl_in TU.
  rewrite imps in *. use_exists TU u.
  eapply DE. apply ZF_pair_el'; auto.
  - eapply CE1. auto.
  - apply DI1. eapply ZF_eq_elem; auto.
    + apply ZF_refl'. auto.
    + eapply CE2. auto.
  - apply DI2. eapply ZF_eq_elem; auto.
    + apply ZF_refl'. auto.
    + eapply CE2. auto.
Qed.

Lemma ZF_bunion_inv T x y z :
   ZFeq' <<= T -> T ⊢ z ∈ x ∪ y -> T ⊢ z ∈ x ∨ z ∈ y.
Proof.
  intros HT H. eapply IE; try apply H.
  eapply Weak; try apply HT. apply ZF_bunion_inv'.
Qed.

Lemma ZF_eq_bunion T x y x' y' :
  ZFeq' <<= T -> T ⊢ x ≡ x' -> T ⊢ y ≡ y' -> T ⊢ x ∪ y ≡ x' ∪ y'.
Proof.
  intros HT H1 H2. now apply ZF_eq_union, ZF_eq_pair.
Qed.

Lemma ZF_sig_el T x :
   ZFeq' <<= T -> T ⊢ x ∈ σ x.
Proof.
  intros H. apply ZF_bunion_el'; trivial.
  apply DI2. apply ZF_sing_iff; trivial.
  apply ZF_refl'. trivial.
Qed.

Lemma ZF_eq_sig T x y :
  ZFeq' <<= T -> T ⊢ x ≡ y -> T ⊢ σ x ≡ σ y.
Proof.
  intros HT H. now apply ZF_eq_bunion, ZF_eq_pair.
Qed.

Lemma sing_pair1 T x y z :
  ZFeq' <<= T -> T ⊢ sing x ≡ {y; z} -> T ⊢ x ≡ y.
Proof.
  intros HT H. apply ZF_sym'; trivial.
  apply ZF_sing_iff; trivial. eapply ZF_eq_elem; trivial.
  apply ZF_refl'; trivial. apply ZF_sym'; eauto.
  apply ZF_pair_el'; trivial. apply DI1. now apply ZF_refl'.
Qed.

Lemma sing_pair2 T x y z :
  ZFeq' <<= T -> T ⊢ sing x ≡ {y; z} -> T ⊢ x ≡ z.
Proof.
  intros HT H. apply ZF_sym'; trivial.
  apply ZF_sing_iff; trivial. eapply ZF_eq_elem; trivial.
  apply ZF_refl'; trivial. apply ZF_sym'; eauto.
  apply ZF_pair_el'; trivial. apply DI2. now apply ZF_refl'.
Qed.

Lemma opair_inj1 T x y x' y' :
  ZFeq' <<= T -> T ⊢ opair x y ≡ opair x' y' -> T ⊢ x ≡ x'.
Proof.
  intros HT He. assert (H : T ⊢ {x; x} ∈ opair x y).
  { apply ZF_pair_el'; trivial. apply DI1. now apply ZF_refl'. }
  eapply ZF_eq_elem in H; try apply He; try apply ZF_refl'; trivial.
  apply ZF_pair_el' in H; trivial.
  apply (DE H); eapply sing_pair1; try apply prv_T1; auto.
Qed.

Lemma opair_inj2 T x y x' y' :
  ZFeq' <<= T -> T ⊢ opair x y ≡ opair x' y' -> T ⊢ y ≡ y'.
Proof.
  intros HT H. assert (H' : T ⊢ y ≡ x' ∨ y ≡ y').
  - assert (H2 : T ⊢ {x; y} ∈ opair x' y').
    { eapply ZF_eq_elem; trivial. apply ZF_refl'; trivial. apply H.
      apply ZF_pair_el'; trivial. apply DI2. now apply ZF_refl'. }
    apply ZF_pair_el' in H2; trivial. apply (DE H2).
    + apply DI1. apply ZF_sym'; auto. eapply sing_pair2; auto. apply ZF_sym'; auto.
    + apply ZF_pair_el'; auto. eapply ZF_eq_elem; auto.
      * apply ZF_refl'; auto.
      * apply ZF_pair_el'; auto. apply DI2. apply ZF_refl'. auto.
  - apply (DE H'); try apply prv_T1.
    assert (H1 : T ⊢ x ≡ x') by apply (opair_inj1 HT H).
    assert (H2 : T ⊢ {x'; y'} ∈ opair x y).
    { eapply ZF_eq_elem; trivial. apply ZF_refl'; trivial. apply ZF_sym', H; trivial.
      apply ZF_pair_el'; trivial. apply DI2. now apply ZF_refl'. }
    apply ZF_pair_el' in H2; trivial.
    eapply DE; try eapply (Weak H2); auto.
    + eapply ZF_trans'; auto. eapply ZF_trans'; auto.
      * apply ZF_sym'. auto. apply (Weak H1). auto.
      * eapply sing_pair2; auto. apply ZF_sym'; auto.
    + eapply ZF_trans'; auto. eapply sing_pair2; auto. eapply ZF_trans'; auto.
      2: apply ZF_sym'; auto.
      eapply ZF_eq_pair; try apply ZF_sym'; auto.
      apply (Weak H1). auto.
    + auto.
Qed.

Lemma ZF_bunion_el1 T x y z :
  ZFeq' <<= T -> T ⊢ z ∈ x -> T ⊢ z ∈ x ∪ y.
Proof.
  intros HT H. now apply ZF_bunion_el', DI1.
Qed.

Lemma ZF_bunion_el2 T x y z :
  ZFeq' <<= T -> T ⊢ z ∈ y -> T ⊢ z ∈ x ∪ y.
Proof.
  intros HT H. now apply ZF_bunion_el', DI2.
Qed.

Lemma bunion_eset x :
   ZFeq' ⊢ ∅ ∪ x ≡ x.
Proof.
  apply ZF_ext'; auto; prv_all y; apply II.
  - eapply DE. eapply ZF_bunion_inv; auto.
    + apply Exp. eapply IE.
      eapply Weak; try apply ZF_eset. all: auto.
    + auto.
  - apply ZF_bunion_el2; auto.
Qed.

Lemma bunion_swap x y z :
  ZFeq' ⊢ (x ∪ y) ∪ z ≡ (x ∪ z) ∪ y.
Proof.
  apply ZF_ext'; auto; prv_all u; apply II.
  - eapply DE. eapply ZF_bunion_inv; auto.
    + eapply DE. eapply ZF_bunion_inv; auto.
      * apply ZF_bunion_el1, ZF_bunion_el1. all: auto.
      * apply ZF_bunion_el2; auto.
    + apply ZF_bunion_el1, ZF_bunion_el2. all: auto.
  - eapply DE. eapply ZF_bunion_inv; auto.
    + eapply DE. eapply ZF_bunion_inv; auto.
      * apply ZF_bunion_el1, ZF_bunion_el1. all: auto.
      * apply ZF_bunion_el2; auto.
    + apply ZF_bunion_el1, ZF_bunion_el2. all: auto.
Qed.

Lemma bunion_use T x y z phi :
  ZFeq' <<= T -> (x ∈ y :: T) ⊢ phi -> (x ≡ z :: T) ⊢ phi -> T ⊢ x ∈ y ∪ sing z → phi.
Proof.
  intros HT H1 H2. apply II. eapply DE.
  - eapply ZF_bunion_inv; auto.
  - apply (Weak H1). auto.
  - eapply IE.
    + eapply Weak. apply II, H2. auto.
    + apply ZF_sing_iff; auto.
Qed.

Lemma ZF_numeral_trans T n x y :
  ZFeq' <<= T -> T ⊢ x ∈ tnumeral n → y ∈ x → y ∈ tnumeral n.
Proof.
  intros HT. induction n; cbn.
  - apply II, Exp. eapply IE. apply ZF_eset'. all: auto.
  - apply bunion_use; trivial.
    + rewrite !imps. rewrite !imps in IHn. apply ZF_bunion_el1; auto.
    + apply II. apply ZF_bunion_el'. auto.
      apply DI1. eapply ZF_eq_elem; auto.
      apply ZF_refl'. auto.
Qed.

Lemma ZF_numeral_wf T n :
  ZFeq' <<= T -> T ⊢ ¬ (tnumeral n ∈ tnumeral n).
Proof.
  intros HT. induction n; cbn.
  - now apply ZF_eset'.
  - apply bunion_use; trivial.
    + eapply IE. apply (Weak IHn). auto.
      eapply IE. eapply IE. apply ZF_numeral_trans; auto.
      auto. apply ZF_sig_el. auto.
    + eapply IE. apply (Weak IHn). auto.
      eapply ZF_eq_elem. auto. apply ZF_refl'. auto.
      auto. apply ZF_sig_el. auto.
Qed.

(* ** Preservation proof *)

Fixpoint enc_derivations B n :=
  match n with
  | O => sing (opair ∅ (enc_stack B))
  | S n => enc_derivations B n ∪ sing (opair (tnumeral (S n)) (enc_stack (derivations B (S n))))
  end.

Lemma enc_derivations_base R n :
  ZFeq' ⊢ {{∅; ∅}; {∅; enc_stack R}} ∈ enc_derivations R n.
Proof.
  induction n; cbn.
  - apply ZF_sing_el.
  - apply ZF_bunion_el. now apply DI1.
Qed.

Lemma enc_derivations_step B n :
  ZFeq' ⊢ opair (tnumeral n) (enc_stack (derivations B n)) ∈ enc_derivations B n.
Proof.
  destruct n; cbn.
  - apply ZF_sing_el.
  - apply ZF_bunion_el. apply DI2. apply ZF_sing_el.
Qed.

Lemma enc_stack_spec R s t :
  s/t el R -> ZFeq' ⊢ opair (enc_string s) (enc_string t) ∈ enc_stack R.
Proof.
  induction R as [|[u v] R IH]; cbn; auto.
  intros [[=]| H]; subst.
  - apply ZF_bunion_el. apply DI2. apply ZF_sing_el.
  - apply ZF_bunion_el. apply DI1. now apply IH.
Qed.

Lemma ZF_derivations_bound T B k n x :
  ZFeq' <<= T -> T ⊢ opair k x ∈ enc_derivations B n -> T ⊢ k ∈ σ (tnumeral n).
Proof.
  induction n in T |- *; cbn; intros HT H.
  - apply ZF_sing_iff in H; trivial. eapply ZF_eq_elem; trivial.
    apply ZF_sym'; trivial. eapply opair_inj1; trivial. apply H.
    apply ZF_refl'; trivial. eapply ZF_bunion_el'; trivial.
    apply DI2. apply ZF_sing_iff; trivial. apply ZF_refl'; trivial.
  - apply ZF_bunion_inv in H; trivial. apply (DE H).
    + apply ZF_bunion_el1. auto. apply IHn; auto.
    + apply ZF_bunion_el2. auto. apply ZF_sing_iff. auto.
      eapply opair_inj1. auto. apply ZF_sing_iff; auto.
Qed.

Lemma enc_derivations_functional B n x y y' :
  ZFeq' ⊢ opair x y ∈ enc_derivations B n → opair x y' ∈ enc_derivations B n → y ≡ y'.
Proof.
  induction n; cbn -[derivations].
  - repeat apply II. eapply opair_inj2. auto. eapply ZF_trans'. auto.
    + apply ZF_sing_iff; auto.
    + apply ZF_sym'. auto. apply ZF_sing_iff; auto.
  - apply bunion_use; try apply bunion_use. 1,2,5: auto.
    + repeat rewrite <- imps. now apply (Weak IHn).
    + apply Exp. eapply IE. apply (@ZF_numeral_wf _ (S n)). auto.
      eapply ZF_derivations_bound. auto. eapply ZF_eq_elem. auto.
      2: apply ZF_refl'; auto. 2: auto. apply ZF_eq_opair; auto.
      eapply opair_inj1; auto. apply ZF_refl'. auto.
    + apply Exp. eapply IE. apply (@ZF_numeral_wf _ (S n)). auto.
      eapply ZF_derivations_bound. auto. eapply ZF_eq_elem. auto.
      2: apply ZF_refl'; auto. 2: auto. apply ZF_eq_opair; auto.
      eapply opair_inj1; auto. apply ZF_refl'. auto.
    + eapply opair_inj2. auto. eapply ZF_trans'; auto.
      apply ZF_sym'; auto.
Qed.

Lemma prep_string_subst sigma s x :
  (prep_string s x)`[sigma] = prep_string s x`[sigma].
Proof.
  induction s; cbn; trivial. rewrite IHs. destruct a; reflexivity.
Qed.

Lemma enc_stack_subst sigma B :
  (enc_stack B)`[sigma] = enc_stack B.
Proof.
  induction B as [|[s t] B IH]; cbn; trivial.
  rewrite IH. unfold enc_string. now rewrite !prep_string_subst.
Qed.

Lemma is_rep_subst s t x y sigma :
  (is_rep (comb_rel s t) x y)[sigma] = is_rep (comb_rel s t) x`[sigma] y`[sigma].
Proof.
  unfold is_rep. cbn -[comb_rel]. subsimpl. repeat f_equal.
  - unfold comb_rel. cbn. rewrite !prep_string_subst. reflexivity.
  - unfold comb_rel. cbn. rewrite !prep_string_subst. reflexivity.
Qed.

Lemma combinations_subst B x y sigma :
  (combinations B x y)[sigma] = combinations B x`[sigma] y`[sigma].
Proof.
  induction B as [|[s t] B IH] in sigma, x, y |- *.
  - cbn. reflexivity.
  - cbn -[is_rep]. rewrite IH, is_rep_subst. cbn -[is_rep]. now subsimpl.
Qed.

Lemma enc_derivations_eq T B n x :
  ZFeq' <<= T -> T ⊢ opair (tnumeral n) x ∈ enc_derivations B n -> T ⊢ x ≡ enc_stack (derivations B n).
Proof.
  intros HT H. destruct n; cbn in *.
  - eapply opair_inj2; trivial. eapply ZF_sing_iff; eauto.
  - apply ZF_bunion_inv in H; trivial. apply (DE H).
    + apply Exp. eapply IE. apply (ZF_numeral_wf (S n)). auto.
      eapply ZF_derivations_bound. auto. auto.
    + eapply opair_inj2. auto. apply ZF_sing_iff. auto. auto.
Qed.

Lemma enc_stack_app T B C :
  ZFeq' <<= T -> T ⊢ (enc_stack B) ∪ (enc_stack C) ≡ enc_stack (B ++ C).
Proof.
  intros HT. induction B as [|[s t] B IH]; cbn.
  - eapply Weak; try apply bunion_eset. assumption.
  - eapply ZF_trans'; trivial. eapply Weak; try apply bunion_swap; trivial.
    eapply ZF_eq_bunion; trivial. apply ZF_refl'; trivial.
Qed.

Lemma prep_string_app s t x :
  prep_string (s ++ t) x = prep_string s (prep_string t x).
Proof.
  induction s; cbn; congruence.
Qed.

Lemma ZF_eq_prep T s x y :
  ZFeq' <<= T -> T ⊢ x ≡ y -> T ⊢ prep_string s x ≡ prep_string s y.
Proof.
  intros HT H. induction s; cbn; try tauto.
  apply ZF_eq_opair; trivial. now apply ZF_refl'.
Qed.

Lemma append_all_el T B s t x y :
  ZFeq' <<= T -> T ⊢ opair x y ∈ enc_stack B
  -> T ⊢ opair (prep_string s x) (prep_string t y) ∈ enc_stack (append_all B (s/t)).
Proof.
  intros HT H. induction B as [|[u v] B IH] in T, HT, H |- *; cbn in *.
  - apply Exp. eapply IE. 2: apply H. now apply ZF_eset'.
  - eapply (ZF_bunion_el' HT). eapply DE. apply (ZF_bunion_inv HT H).
    + apply DI1. apply IH; auto.
    + assert1 H'. apply ZF_sing_iff in H'; try now auto.
      apply DI2. apply ZF_sing_iff. auto.
      rewrite !prep_string_app. apply ZF_eq_opair. auto.
      * apply ZF_eq_prep. auto. eapply opair_inj1; eauto.
      * apply ZF_eq_prep. auto. eapply opair_inj2; eauto.
Qed.

Local Arguments comb_rel : simpl never.

Lemma is_rep_eq T B s t x y :
  ZFeq' <<= T -> T ⊢ x ≡ enc_stack B -> T ⊢ is_rep (comb_rel s t) x y
  -> T ⊢ y ≡ enc_stack (append_all B (s / t)).
Proof.
  intros HT H1 H2. apply ZF_ext'; trivial.
  - prv_all a.
    apply (AllE a) in H2. cbn in H2. subsimpl_in H2.
    eapply CE1 in H2. rewrite imps in *.
    use_exists H2 z. assert1 H. apply CE in H as [H H'].
    unfold comb_rel at 2 in H'. cbn in H'. subsimpl_in H'.
    rewrite !prep_string_subst in H'. cbn in H'.
    use_exists H' c. clear H'.
    cbn. subsimpl. rewrite !prep_string_subst. cbn.
    assert1 H'. use_exists H' d. clear H'.
    cbn. subsimpl. rewrite !prep_string_subst. cbn. subsimpl.
    eapply ZF_eq_elem. auto. apply ZF_sym'. auto.
    eapply CE2. auto. apply ZF_refl'. auto.
    apply append_all_el. auto.
    eapply ZF_eq_elem. auto. eapply CE1. auto.
    eapply (Weak H1). auto. eapply (Weak H). auto.
  - prv_all a. apply (AllE a) in H2. cbn in H2. subsimpl_in H2.
    eapply CE2 in H2. apply II. eapply IE; try apply (Weak H2). auto.
    induction B as [|[u v] B IH] in T, x, HT, H1 |- *; cbn in *.
    + apply Exp. eapply IE. apply ZF_eset'. all: auto.
    + rewrite <- imps. apply bunion_use; trivial.
      * specialize (IH T (enc_stack B) HT).
        assert (H : T ⊢ enc_stack B ≡ enc_stack B) by now apply ZF_refl'.
        apply IH in H. use_exists H z. clear H. apply ExI with z.
        cbn. subsimpl. assert1 H. apply CE in H as [H H'].
        apply CI; trivial. eapply ZF_eq_elem. auto.
        apply ZF_refl'. auto. apply ZF_sym'. auto.
        apply (Weak H1). auto. apply ZF_bunion_el1; trivial. auto.
      * apply ExI with (opair (enc_string u) (enc_string v)).
        cbn. subsimpl. apply CI.
        -- eapply ZF_eq_elem. auto. apply ZF_refl'. auto.
           apply ZF_sym'. auto. apply (Weak H1). auto.
           apply ZF_bunion_el2. auto. eapply Weak. apply ZF_sing_el. auto.
        -- cbn. apply ExI with (enc_string v).
           cbn. apply ExI with (enc_string u).
           cbn. subsimpl. rewrite !prep_string_subst, !prep_string_app; cbn.
           subsimpl. apply CI; auto. apply ZF_refl'. auto.
Qed.

Local Arguments is_rep : simpl never.

Lemma combinations_eq T B C x y :
  ZFeq' <<= T -> T ⊢ x ≡ enc_stack C -> T ⊢ combinations B x y -> T ⊢ y ≡ enc_stack (derivation_step B C).
Proof.
  induction B as [|[s t] B IH] in y, T |-*; cbn; intros HT H1 H2; trivial.
  use_exists H2 u. assert1 H. use_exists H v. clear H.
  rewrite !combinations_subst, !is_rep_subst. cbn. subsimpl.
  eapply ZF_trans'. auto. eapply CE1. eapply CE1. auto.
  eapply ZF_trans'. auto. 2: apply enc_stack_app; auto.
  apply ZF_eq_bunion; auto.
  - eapply is_rep_eq; auto. apply (Weak H1); auto.
    eapply CE2. auto.
  - apply IH; auto.
    + apply (Weak H1); auto.
    + eapply CE2. eapply CE1. auto.
Qed.

Lemma combinations_step B n (i x y : term) :
  ZFeq' ⊢ i ∈ tnumeral n → opair i x ∈ enc_derivations B n
     → combinations B x y → opair (σ i) y ∈ enc_derivations B n.
Proof.
  induction n; cbn.
  - apply II. apply Exp.
    apply imps. apply ZF_eset.
  - apply bunion_use; try apply bunion_use; auto.
    + apply II. apply ZF_bunion_el'. auto.
      apply DI1. eapply IE. eapply IE. eapply IE.
      * eapply Weak. apply IHn. auto.
      * auto.
      * auto.
      * auto.
    + apply Exp. eapply IE. apply (ZF_numeral_wf (S n)). auto.
      eapply ZF_eq_elem. auto. eapply opair_inj1. auto. auto.
      apply ZF_refl'. auto. cbn. apply ZF_bunion_el'. auto.
      apply DI1. auto.
    + apply II. apply ZF_bunion_el'. auto.
      apply DI2. apply ZF_sing_iff. auto.
      apply ZF_eq_opair. auto.
      * apply ZF_eq_sig; auto.
      * eapply combinations_eq; auto.
        apply enc_derivations_eq. auto.
        eapply ZF_eq_elem; auto; try apply ZF_refl'; auto.
        eapply ZF_eq_opair; auto; try apply ZF_refl'. auto.
    + apply Exp. eapply IE. apply (ZF_numeral_wf n). auto.
      eapply ZF_eq_elem. auto. apply ZF_refl'. auto.
      eapply ZF_trans'. auto. apply ZF_sym'. auto.
      eapply opair_inj1. auto. auto. auto.
      apply ZF_sig_el. auto.
Qed.

Theorem dPCP_ZFD B :
  dPCPb B -> ZFeq' ⊢ solvable B.
Proof.
  intros [s H]. destruct (derivable_derivations H) as [n Hn].
  unfold solvable.
  apply ExI with (tnumeral n). cbn.
  apply ExI with (enc_derivations B n). cbn.
  apply ExI with (enc_string s). cbn. subsimpl.
  apply ExI with (enc_stack (derivations B n)). cbn.
  rewrite !enc_stack_subst, !combinations_subst. cbn. subsimpl.
  repeat apply CI.
  - apply ZF_numeral.
  - prv_all x. prv_all y. prv_all z.
    apply enc_derivations_functional.
  - apply enc_derivations_base.
  - prv_all x. prv_all y. prv_all z. rewrite !combinations_subst.
    cbn. subsimpl. apply combinations_step.
  - apply enc_derivations_step.
  - now apply enc_stack_spec.
Qed.

Theorem PCP_ZFD B :
  PCPb B -> ZFeq' ⊢ solvable B.
Proof.
  rewrite PCPb_iff_dPCPb. apply dPCP_ZFD.
Qed.

End ZF.


(*interface (g) to show the difference
between SME-NI and the extended SIR-NNI*)

Require Export refine.
Require Export parser.
Require Import subsetconst.

Definition expr2g: IA := parse
"IA [s1,s2,s3,s4,s5] (s1) [h1,m1_] [m1,m2] []
 [s1->(h1)s2, s1->(m1_)s3, s2->(m1)s4, s3->(m2)s5]".

(*at m1: false*)
Definition expr2g_m1_rep: IA :=
 IAutomaton.hiding
 ( IAutomaton.replacement expr2g (&"tau") (ASet.GenActs [&"h1"]) )
 (ASet.GenActs [&"m2"]).
(*Eval compute in IAutomaton.display expr2g_m1_rep.*)

Definition expr2g_m1_hid: IA :=
IAutomaton.hiding expr2g (ASet.GenActs [&"h1",&"m2"]).

(*Eval compute in IAutomaton.display expr2g_m1_rep.
Eval compute in IAutomaton.display expr2g_m1_hid.*)
Eval compute in SMENI_refinement expr2g_m1_rep expr2g_m1_hid.

(*at m2: false*)
Definition expr2g_m2_rep: IA :=
 subset_construction
 ( IAutomaton.hiding
 ( IAutomaton.replacement expr2g (&"tau") (ASet.GenActs [&"h1",&"m1_"]) )
 (ASet.GenActs [&"m1"]) ).
(*Eval compute in IAutomaton.display expr2g_m2_rep.*)

Definition expr2g_m2_hid: IA :=
IAutomaton.hiding expr2g (ASet.GenActs [&"h1",&"m1_",&"m1"]).

Eval compute in SMENI_refinement expr2g_m2_rep expr2g_m2_hid.

(*at l: true *)
Definition expr2g_l_rep: IA :=
 subset_construction
 ( IAutomaton.hiding
 ( IAutomaton.replacement expr2g (&"tau") (ASet.GenActs [&"h1",&"m1_"]) )
 (ASet.GenActs [&"m1",&"m2"]) ).

Definition expr2g_l_hid: IA :=
 IAutomaton.hiding expr2g (ASet.GenActs [&"h1",&"m1_",&"m1",&"m2"]).

Eval compute in SMENI_refinement expr2g_l_rep expr2g_l_hid.


From Undecidability Require Import TM.Util.Prelim.
From Undecidability Require Import TM.Util.TM_facts.
From Undecidability Require Import TM.Basic.Basic.
From Undecidability Require Import TM.Combinators.Combinators.
From Undecidability Require Import TM.Lifting.Lifting.

From Undecidability Require Import TM.Compound.TMTac.

Set Default Proof Using "Type".

(* * Simple compound multi-tape Machines *)

(* ** Nop *)

(* The n-tape Machine that does nothing *)
Section Nop.
  Variable sig : finType.
  Variable n : nat.

  Definition Nop : pTM sig unit n := LiftTapes Null (Vector.nil _).

  Definition Nop_Rel : pRel sig unit n :=
    ignoreParam (fun t t' => t' = t).

  Lemma Nop_Sem : Nop ⊨c(0) Nop_Rel.
  Proof.
    eapply RealiseIn_monotone.
    { unfold Nop. TM_Correct. }
    { reflexivity. }
    {
      intros tin ((), tout) (_&HInj). cbn in *.
      apply Vector.eq_nth_iff; intros i ? <-. apply HInj. vector_not_in.
    }
  Qed.
End Nop.

Arguments Nop_Rel {sig n} x y/.
Arguments Nop {sig n}.
Arguments Nop : simpl never.

(* ** Diverge *)

Section Diverge.
  Variable sig : finType.
  Variable n : nat.

  Definition Diverge : pTM sig unit n := While (Return Nop None).

  Definition Diverge_Rel : pRel sig unit n :=
    ignoreParam (fun t t' => False).

  Lemma Diverge_Realise : Diverge ⊨ Diverge_Rel.
  Proof.
    eapply Realise_monotone.
    { unfold Diverge. TM_Correct. eapply RealiseIn_Realise. apply Nop_Sem. }
    { eapply WhileInduction; intros; cbn in *; TMSimp; auto. }
  Qed.

End Diverge.

Arguments Diverge_Rel {sig n} x y/.
Arguments Diverge {sig n}.
Arguments Diverge : simpl never.

(* ** Move two tapes *)

Section MovePar.
  Variable sig : finType.
  Variable (D1 D2 : move).

  Definition MovePar_R : pRel sig unit 2 :=
    ignoreParam(fun (t t' : tapes sig 2) =>
                  t'[@Fin0] = tape_move t[@Fin0] D1 /\
                  t'[@Fin1] = tape_move t[@Fin1] D2).

  Definition MovePar : pTM sig unit 2 :=
    LiftTapes (Move D1) [|Fin0|];; LiftTapes (Move D2) [|Fin1|].

  Lemma MovePar_Sem : MovePar ⊨c(3) MovePar_R.
  Proof.
    eapply RealiseIn_monotone.
    { unfold MovePar. TM_Correct. }
    { reflexivity. }
    { hnf in *. intros tin (yout&tout) H. now TMSimp. }
  Qed.

End MovePar.

Arguments MovePar_R { sig } ( D1 D2 ) x y /.
Arguments MovePar {sig} (D1 D2).
Arguments MovePar : simpl never.

(* ** Copy Symbol *)

(* Copy the current symbol from tape 0 to tape 1 *)
Section Copy.
  Variable sig : finType.

  Variable f : sig -> sig.

  Definition CopyChar : pTM sig unit 2 :=
    Switch (LiftTapes ReadChar [|Fin0|])
          (fun s : option sig =>
             match s with
             | None =>  Nop
             | Some s => LiftTapes (Write (f s)) [|Fin1|]
             end).

  Definition CopyChar_Rel : pRel sig unit 2 :=
    ignoreParam (
        fun tin tout =>
          tout[@Fin0] = tin[@Fin0] /\
          tout[@Fin1] = tape_write tin[@Fin1] (map_opt f (current tin[@Fin0]))
      ).

  Lemma CopyChar_Sem : CopyChar ⊨c(3) CopyChar_Rel.
  Proof.
    eapply RealiseIn_monotone.
    {
      unfold CopyChar. eapply Switch_RealiseIn; cbn.
      - apply LiftTapes_RealiseIn. vector_dupfree. apply ReadChar_Sem.
      - instantiate (2 := fun o : option sig => match o with Some s => _ | None => _ end).
        intros [ s | ]; cbn.
        + eapply LiftTapes_RealiseIn. vector_dupfree. apply Write_Sem.
        + eapply RealiseIn_monotone'. apply Nop_Sem. lia.
    }
    { lia. }
    {
      intros tin ((), tout) H. cbn in *. TMSimp.
      destruct (current _) eqn:E; TMSimp; auto.
    }
  Qed.

End Copy.

Arguments CopyChar_Rel { sig } ( f ) x y /.
Arguments CopyChar { sig }.
Arguments CopyChar : simpl never.

(* ** Read Char *)

(* Read a char at an arbitrary tape *)
Section ReadChar.

  Variable sig : finType.
  Variable (n : nat) (k : Fin.t n).

  Definition ReadChar_at : pTM sig (option sig) n :=
    LiftTapes ReadChar [|k|].

  Definition ReadChar_at_Rel : pRel sig (option sig) n :=
    fun tin '(yout, tout) =>
      yout = current tin[@k] /\
      tout = tin.

  Lemma ReadChar_at_Sem :
    ReadChar_at ⊨c(1) ReadChar_at_Rel.
  Proof.
    eapply RealiseIn_monotone.
    { unfold ReadChar_at. TM_Correct. }
    { cbn. reflexivity. }
    {
      intros tin (yout, tout) H.
      hnf. TMSimp; clear_trivial_eqs. split; auto.
      eapply VectorSpec.eq_nth_iff; intros p ? <-.
      decide (p = k) as [->|HnEq]; TMSimp; auto.
      - apply H0. vector_not_in.
    }
  Qed.

End ReadChar.

Arguments ReadChar_at : simpl never.
Arguments ReadChar_at {sig n} k.
Arguments ReadChar_at_Rel { sig n } ( k ) x y /.

(* ** Tactic Support *)

Ltac smpl_TM_Multi :=
  once lazymatch goal with
  | [ |- Nop ⊨ _ ] => eapply RealiseIn_Realise; apply Nop_Sem
  | [ |- Nop ⊨c(_) _ ] => eapply Nop_Sem
  | [ |- projT1 (Nop) ↓ _ ] => eapply RealiseIn_TerminatesIn; apply Nop_Sem

  | [ |- Diverge ⊨ _ ] => apply Diverge_Realise

  | [ |- MovePar _ _ ⊨ _ ] => eapply RealiseIn_Realise; eapply MovePar_Sem
  | [ |- MovePar _ _ ⊨c(_) _ ] => eapply MovePar_Sem
  | [ |- projT1 (MovePar _ _) ↓ _ ] => eapply RealiseIn_TerminatesIn; eapply MovePar_Sem

  | [ |- CopyChar _ ⊨ _ ] => eapply RealiseIn_Realise; eapply CopyChar_Sem
  | [ |- CopyChar _ ⊨c(_) _ ] => eapply CopyChar_Sem
  | [ |- projT1 (CopyChar _) ↓ _ ] => eapply RealiseIn_TerminatesIn; eapply CopyChar_Sem

  | [ |- ReadChar_at _ ⊨ _ ] => eapply RealiseIn_Realise; eapply ReadChar_at_Sem
  | [ |- ReadChar_at _ ⊨c(_) _ ] => eapply ReadChar_at_Sem
  | [ |- projT1 (ReadChar_at _) ↓ _ ] => eapply RealiseIn_TerminatesIn; eapply ReadChar_at_Sem
  end.

Smpl Add smpl_TM_Multi : TM_Correct.


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

(***
Modulus : 2^321 - 9
Base: 24 + 9/13
***)

Definition curve : CurveParameters :=
  {|
    sz := 13%nat;
    base := 24 + 9/13;
    bitwidth := 32;
    s := 2^321;
    c := [(1, 9)];
    carry_chains := Some [seq 0 (pred 13); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    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.