(*  Title:       A Fair Ordered Resolution Prover for First-Order Clauses with Weights
    Author:      Anders Schlichtkrull <andschl at dtu.dk>, 2017
    Author:      Jasmin Blanchette <j.c.blanchette at vu.nl>, 2017
    Maintainer:  Anders Schlichtkrull <andschl at dtu.dk>
*)

section \<open>A Fair Ordered Resolution Prover for First-Order Clauses with Weights\<close>

text \<open>
The \<open>weighted_RP\<close> prover introduced below operates on finite multisets of clauses and
organizes the multiset of processed clauses as a priority queue to ensure that inferences are
performed in a fair manner, to guarantee completeness.
\<close>

theory Weighted_FO_Ordered_Resolution_Prover
  imports Ordered_Resolution_Prover.FO_Ordered_Resolution_Prover
begin

type_synonym 'a wclause = "'a clause \<times> nat"
type_synonym 'a wstate = "'a wclause multiset \<times> 'a wclause multiset \<times> 'a wclause multiset \<times> nat"

fun state_of_wstate :: "'a wstate \<Rightarrow> 'a state" where
  "state_of_wstate (N, P, Q, n) =
   (set_mset (image_mset fst N), set_mset (image_mset fst P), set_mset (image_mset fst Q))"

locale weighted_FO_resolution_prover =
  FO_resolution_prover S subst_atm id_subst comp_subst renamings_apart atm_of_atms mgu less_atm
  for
    S :: "('a :: wellorder) clause \<Rightarrow> 'a clause" and
    subst_atm :: "'a \<Rightarrow> 's \<Rightarrow> 'a" and
    id_subst :: "'s" and
    comp_subst :: "'s \<Rightarrow> 's \<Rightarrow> 's" and
    renamings_apart :: "'a clause list \<Rightarrow> 's list" and
    atm_of_atms :: "'a list \<Rightarrow> 'a" and
    mgu :: "'a set set \<Rightarrow> 's option" and
    less_atm :: "'a \<Rightarrow> 'a \<Rightarrow> bool" +
  fixes
    weight :: "'a clause \<times> nat \<Rightarrow> nat"
  assumes
    weight_mono: "i < j \<Longrightarrow> weight (C, i) < weight (C, j)"
begin

abbreviation clss_of_wstate :: "'a wstate \<Rightarrow> 'a clause set" where
  "clss_of_wstate St \<equiv> clss_of_state (state_of_wstate St)"

abbreviation N_of_wstate :: "'a wstate \<Rightarrow> 'a clause set" where
  "N_of_wstate St \<equiv> N_of_state (state_of_wstate St)"

abbreviation P_of_wstate :: "'a wstate \<Rightarrow> 'a clause set" where
  "P_of_wstate St \<equiv> P_of_state (state_of_wstate St)"

abbreviation Q_of_wstate :: "'a wstate \<Rightarrow> 'a clause set" where
  "Q_of_wstate St \<equiv> Q_of_state (state_of_wstate St)"

fun wN_of_wstate :: "'a wstate \<Rightarrow> 'a wclause multiset" where
  "wN_of_wstate (N, P, Q, n) = N"

fun wP_of_wstate :: "'a wstate \<Rightarrow> 'a wclause multiset" where
  "wP_of_wstate (N, P, Q, n) = P"

fun wQ_of_wstate :: "'a wstate \<Rightarrow> 'a wclause multiset" where
  "wQ_of_wstate (N, P, Q, n) = Q"

fun n_of_wstate :: "'a wstate \<Rightarrow> nat" where
  "n_of_wstate (N, P, Q, n) = n"

lemma of_wstate_split[simp]:
  "(wN_of_wstate St, wP_of_wstate St, wQ_of_wstate St, n_of_wstate St) = St"
  by (cases St) auto

abbreviation grounding_of_wstate :: "'a wstate \<Rightarrow> 'a clause set" where
  "grounding_of_wstate St \<equiv> grounding_of_state (state_of_wstate St)"

abbreviation Liminf_wstate :: "'a wstate llist \<Rightarrow> 'a state" where
  "Liminf_wstate Sts \<equiv> Liminf_state (lmap state_of_wstate Sts)"

lemma timestamp_le_weight: "n \<le> weight (C, n)"
  by (induct n, simp, metis weight_mono[of k "Suc k" for k] Suc_le_eq le_less le_trans)

inductive weighted_RP :: "'a wstate \<Rightarrow> 'a wstate \<Rightarrow> bool" (infix "\<leadsto>\<^sub>w" 50) where
  tautology_deletion: "Neg A \<in># C \<Longrightarrow> Pos A \<in># C \<Longrightarrow> (N + {#(C, i)#}, P, Q, n) \<leadsto>\<^sub>w (N, P, Q, n)"
| forward_subsumption: "D \<in># image_mset fst (P + Q) \<Longrightarrow> subsumes D C \<Longrightarrow>
    (N + {#(C, i)#}, P, Q, n) \<leadsto>\<^sub>w (N, P, Q, n)"
| backward_subsumption_P: "D \<in># image_mset fst N \<Longrightarrow> C \<in># image_mset fst P \<Longrightarrow>
    strictly_subsumes D C \<Longrightarrow> (N, P, Q, n) \<leadsto>\<^sub>w (N, {#(E, k) \<in># P. E \<noteq> C#}, Q, n)"
| backward_subsumption_Q: "D \<in># image_mset fst N \<Longrightarrow> strictly_subsumes D C \<Longrightarrow>
    (N, P, Q + {#(C, i)#}, n) \<leadsto>\<^sub>w (N, P, Q, n)"
| forward_reduction: "D + {#L'#} \<in># image_mset fst (P + Q) \<Longrightarrow> - L = L' \<cdot>l \<sigma> \<Longrightarrow> D \<cdot> \<sigma> \<subseteq># C \<Longrightarrow>
    (N + {#(C + {#L#}, i)#}, P, Q, n) \<leadsto>\<^sub>w (N + {#(C, i)#}, P, Q, n)"
| backward_reduction_P: "D + {#L'#} \<in># image_mset fst N \<Longrightarrow> - L = L' \<cdot>l \<sigma> \<Longrightarrow> D \<cdot> \<sigma> \<subseteq># C \<Longrightarrow>
    (\<forall>j. (C + {#L#}, j) \<in># P \<longrightarrow> j \<le> i) \<Longrightarrow>
    (N, P + {#(C + {#L#}, i)#}, Q, n) \<leadsto>\<^sub>w (N, P + {#(C, i)#}, Q, n)"
| backward_reduction_Q: "D + {#L'#} \<in># image_mset fst N \<Longrightarrow> - L = L' \<cdot>l \<sigma> \<Longrightarrow> D \<cdot> \<sigma> \<subseteq># C \<Longrightarrow>
    (N, P, Q + {#(C + {#L#}, i)#}, n) \<leadsto>\<^sub>w (N, P + {#(C, i)#}, Q, n)"
| clause_processing: "(N + {#(C, i)#}, P, Q, n) \<leadsto>\<^sub>w (N, P + {#(C, i)#}, Q, n)"
| inference_computation: "(\<forall>(D, j) \<in># P. weight (C, i) \<le> weight (D, j)) \<Longrightarrow>
    N = mset_set ((\<lambda>D. (D, n)) ` concls_of
      (inference_system.inferences_between (ord_FO_\<Gamma> S) (set_mset (image_mset fst Q)) C)) \<Longrightarrow>
    ({#}, P + {#(C, i)#}, Q, n) \<leadsto>\<^sub>w (N, {#(D, j) \<in># P. D \<noteq> C#}, Q + {#(C, i)#}, Suc n)"

lemma weighted_RP_imp_RP: "St \<leadsto>\<^sub>w St' \<Longrightarrow> state_of_wstate St \<leadsto> state_of_wstate St'"
proof (induction rule: weighted_RP.induct)
  case (backward_subsumption_P D N C P Q n)
  show ?case
    by (rule arg_cong2[THEN iffD1, of _ _ _ _ "(\<leadsto>)", OF _ _
          RP.backward_subsumption_P[of D "fst ` set_mset N" C "fst ` set_mset P - {C}"
            "fst ` set_mset Q"]])
      (use backward_subsumption_P in auto)
next
  case (inference_computation P C i N n Q)
  show ?case
     by (rule arg_cong2[THEN iffD1, of _ _ _ _ "(\<leadsto>)", OF _ _
           RP.inference_computation[of "fst ` set_mset N" "fst ` set_mset Q" C
             "fst ` set_mset P - {C}"]],
         use inference_computation(2) finite_ord_FO_resolution_inferences_between in
           \<open>auto simp: comp_def image_comp inference_system.inferences_between_def\<close>)
qed (use RP.intros in simp_all)

lemma final_weighted_RP: "\<not> ({#}, {#}, Q, n) \<leadsto>\<^sub>w St"
  by (auto elim: weighted_RP.cases)

context
  fixes
    Sts :: "'a wstate llist"
  assumes
    full_deriv: "full_chain (\<leadsto>\<^sub>w) Sts" and
    empty_P0: "P_of_wstate (lhd Sts) = {}" and
    empty_Q0: "Q_of_wstate (lhd Sts) = {}"
begin

lemma finite_Sts0: "finite (clss_of_wstate (lhd Sts))"
  by (cases "lhd Sts") auto

lemmas deriv = full_chain_imp_chain[OF full_deriv]
lemmas lhd_lmap_Sts = llist.map_sel(1)[OF chain_not_lnull[OF deriv]]

lemma deriv_RP: "chain (\<leadsto>) (lmap state_of_wstate Sts)"
  using deriv weighted_RP_imp_RP by (metis chain_lmap)

lemma finite_Sts0_RP: "finite (clss_of_state (lhd (lmap state_of_wstate Sts)))"
  using finite_Sts0 chain_length_pos[OF deriv] by auto

lemma empty_P0_RP: "P_of_state (lhd (lmap state_of_wstate Sts)) = {}"
  using empty_P0 chain_length_pos[OF deriv] by auto

lemma empty_Q0_RP: "Q_of_state (lhd (lmap state_of_wstate Sts)) = {}"
  using empty_Q0 chain_length_pos[OF deriv] by auto

lemmas Sts_thms = deriv_RP finite_Sts0_RP empty_P0_RP empty_Q0_RP

theorem weighted_RP_model:
  "St \<leadsto>\<^sub>w St' \<Longrightarrow> I \<Turnstile>s grounding_of_wstate St' \<longleftrightarrow> I \<Turnstile>s grounding_of_wstate St"
  using RP_model Sts_thms weighted_RP_imp_RP by (simp only: comp_def)

abbreviation S_gQ :: "'a clause \<Rightarrow> 'a clause" where
  "S_gQ \<equiv> S_Q (lmap state_of_wstate Sts)"

interpretation sq: selection S_gQ
  unfolding S_Q_def using S_M_selects_subseteq S_M_selects_neg_lits selection_axioms
  by unfold_locales auto

interpretation gd: ground_resolution_with_selection S_gQ
  by unfold_locales

interpretation src: standard_redundancy_criterion_reductive gd.ord_\<Gamma>
  by unfold_locales

interpretation src: standard_redundancy_criterion_counterex_reducing gd.ord_\<Gamma>
  "ground_resolution_with_selection.INTERP S_gQ"
  by unfold_locales

lemmas ord_\<Gamma>_saturated_upto_def = src.saturated_upto_def
lemmas ord_\<Gamma>_saturated_upto_complete = src.saturated_upto_complete
lemmas ord_\<Gamma>_contradiction_Rf = src.contradiction_Rf

theorem weighted_RP_sound:
  assumes "{#} \<in> clss_of_state (Liminf_wstate Sts)"
  shows "\<not> satisfiable (grounding_of_wstate (lhd Sts))"
  by (rule RP_sound[OF deriv_RP assms, unfolded lhd_lmap_Sts])

abbreviation RP_filtered_measure :: "('a wclause \<Rightarrow> bool) \<Rightarrow> 'a wstate \<Rightarrow> nat \<times> nat \<times> nat" where
  "RP_filtered_measure \<equiv> \<lambda>p (N, P, Q, n).
     (sum_mset (image_mset (\<lambda>(C, i). Suc (size C)) {#Di \<in># N + P + Q. p Di#}),
      size {#Di \<in># N. p Di#}, size {#Di \<in># P. p Di#})"

abbreviation RP_combined_measure :: "nat \<Rightarrow> 'a wstate \<Rightarrow> nat \<times> (nat \<times> nat \<times> nat) \<times> (nat \<times> nat \<times> nat)" where
  "RP_combined_measure \<equiv> \<lambda>w St.
     (w + 1 - n_of_wstate St, RP_filtered_measure (\<lambda>(C, i). i \<le> w) St,
      RP_filtered_measure (\<lambda>Ci. True) St)"

abbreviation (input) RP_filtered_relation :: "((nat \<times> nat \<times> nat) \<times> (nat \<times> nat \<times> nat)) set" where
  "RP_filtered_relation \<equiv> natLess <*lex*> natLess <*lex*> natLess"

abbreviation (input) RP_combined_relation :: "((nat \<times> ((nat \<times> nat \<times> nat) \<times> (nat \<times> nat \<times> nat))) \<times>
    (nat \<times> ((nat \<times> nat \<times> nat) \<times> (nat \<times> nat \<times> nat)))) set" where
  "RP_combined_relation \<equiv> natLess <*lex*> RP_filtered_relation <*lex*> RP_filtered_relation"

abbreviation "(fst3 :: 'b * 'c * 'd \<Rightarrow> 'b) \<equiv> fst"
abbreviation "(snd3 :: 'b * 'c * 'd \<Rightarrow> 'c) \<equiv> \<lambda>x. fst (snd x)"
abbreviation "(trd3 :: 'b * 'c * 'd \<Rightarrow> 'd) \<equiv> \<lambda>x. snd (snd x)"

lemma
  wf_RP_filtered_relation: "wf RP_filtered_relation" and
  wf_RP_combined_relation: "wf RP_combined_relation"
  unfolding natLess_def using wf_less wf_mult by auto

lemma multiset_sum_of_Suc_f_monotone: "N \<subset># M \<Longrightarrow> (\<Sum>x \<in># N. Suc (f x)) < (\<Sum>x \<in># M. Suc (f x))"
proof (induction N arbitrary: M)
  case empty
  then obtain y where "y \<in># M"
    by force
  then have "(\<Sum>x \<in># M. 1) = (\<Sum>x \<in># M - {#y#} + {#y#}. 1)"
    by auto
  also have "... = (\<Sum>x \<in># M - {#y#}. 1) + (\<Sum>x \<in># {#y#}. 1)"
    by (metis image_mset_union sum_mset.union)
  also have "... > (0 :: nat)"
    by auto
  finally have "0 < (\<Sum>x \<in># M. Suc (f x))"
    by (fastforce intro: gr_zeroI)
  then show ?case
    using empty by auto
next
  case (add x N)
  from this(2) have "(\<Sum>y \<in># N. Suc (f y)) < (\<Sum>y \<in># M - {#x#}. Suc (f y))"
    using add(1)[of "M - {#x#}"] by (simp add: insert_union_subset_iff)
  moreover have "add_mset x (remove1_mset x M) = M"
    by (meson add.prems add_mset_remove_trivial_If mset_subset_insertD)
  ultimately show ?case
    by (metis (no_types) add.commute add_less_cancel_right sum_mset.insert)
qed

lemma multiset_sum_monotone_f':
  assumes "CC \<subset># DD"
  shows "(\<Sum>(C, i) \<in># CC. Suc (f C)) < (\<Sum>(C, i) \<in># DD. Suc (f C))"
  using multiset_sum_of_Suc_f_monotone[OF assms, of "f \<circ> fst"]
  by (metis (mono_tags) comp_apply image_mset_cong2 split_beta)

lemma filter_mset_strict_subset:
  assumes "x \<in># M" and "\<not> p x"
  shows "{#y \<in># M. p y#} \<subset># M"
proof -
  have subseteq: "{#E \<in># M. p E#} \<subseteq># M"
    by auto
  have "count {#E \<in># M. p E#} x = 0"
    using assms by auto
  moreover have "0 < count M x"
    using assms by auto
  ultimately have lt_count: "count {#y \<in># M. p y#} x < count M x"
    by auto
  then show ?thesis
    using subseteq by (metis less_not_refl2 subset_mset.le_neq_trans)
qed

lemma weighted_RP_measure_decreasing_N:
  assumes "St \<leadsto>\<^sub>w St'" and "(C, l) \<in># wN_of_wstate St"
  shows "(RP_filtered_measure (\<lambda>Ci. True) St', RP_filtered_measure (\<lambda>Ci. True) St)
    \<in> RP_filtered_relation"
using assms proof (induction rule: weighted_RP.induct)
  case (backward_subsumption_P D N C' P Q n)
  then obtain i' where  "(C', i') \<in># P"
    by auto
  then have "{#(E, k) \<in># P. E \<noteq> C'#} \<subset># P"
    using filter_mset_strict_subset[of "(C', i')" P "\<lambda>X. \<not>fst X =  C'"]
    by (metis (mono_tags, lifting) filter_mset_cong fst_conv prod.case_eq_if)
  then have "(\<Sum>(C, i) \<in># {#(E, k) \<in># P. E \<noteq> C'#}. Suc (size C)) < (\<Sum>(C, i) \<in># P. Suc (size C))"
    using multiset_sum_monotone_f'[of "{#(E, k) \<in># P. E \<noteq> C'#}" P size] by metis
  then show ?case
    unfolding natLess_def by auto
qed (auto simp: natLess_def)

lemma weighted_RP_measure_decreasing_P:
  assumes "St \<leadsto>\<^sub>w St'" and "(C, i) \<in># wP_of_wstate St"
  shows "(RP_combined_measure (weight (C, i)) St', RP_combined_measure (weight (C, i)) St)
    \<in> RP_combined_relation"
using assms proof (induction rule: weighted_RP.induct)
  case (backward_subsumption_P D N C' P Q n)

  define St where "St = (N, P, Q, n)"
  define P' where "P' = {#(E, k) \<in># P. E \<noteq> C'#}"
  define St' where "St' = (N, P', Q, n)"

  from backward_subsumption_P obtain i' where  "(C', i') \<in># P"
    by auto
  then have P'_sub_P: "P' \<subset># P"
    unfolding P'_def using filter_mset_strict_subset[of "(C', i')" P "\<lambda>Dj. fst Dj \<noteq> C'"]
    by (metis (no_types, lifting) filter_mset_cong fst_conv prod.case_eq_if)

  have P'_subeq_P_filter:
    "{#(Ca, ia) \<in># P'. ia \<le> weight (C, i)#} \<subseteq># {#(Ca, ia) \<in># P. ia \<le> weight (C, i)#}"
    using P'_sub_P by (auto intro: multiset_filter_mono)

  have "fst3 (RP_combined_measure (weight (C, i)) St')
    \<le> fst3 (RP_combined_measure (weight (C, i)) St)"
    unfolding St'_def St_def by auto
  moreover have "(\<Sum>(C, i) \<in># {#(Ca, ia) \<in># P'. ia \<le> weight (C, i)#}. Suc (size C))
    \<le> (\<Sum>x \<in># {#(Ca, ia) \<in># P. ia \<le> weight (C, i)#}. case x of (C, i) \<Rightarrow> Suc (size C))"
    using P'_subeq_P_filter by (rule sum_image_mset_mono)
  then have "fst3 (snd3 (RP_combined_measure (weight (C, i)) St'))
    \<le> fst3 (snd3 (RP_combined_measure (weight (C, i)) St))"
    unfolding St'_def St_def by auto
  moreover have "snd3 (snd3 (RP_combined_measure (weight (C, i)) St'))
    \<le> snd3 (snd3 (RP_combined_measure (weight (C, i)) St))"
    unfolding St'_def St_def by auto
  moreover from P'_subeq_P_filter have "size {#(Ca, ia) \<in># P'. ia \<le> weight (C, i)#}
    \<le> size {#(Ca, ia) \<in># P. ia \<le> weight (C, i)#}"
    by (simp add: size_mset_mono)
  then have "trd3 (snd3 (RP_combined_measure (weight (C, i)) St'))
    \<le> trd3 (snd3 (RP_combined_measure (weight (C, i)) St))"
    unfolding St'_def St_def unfolding fst_def snd_def by auto
  moreover from P'_sub_P have "(\<Sum>(C, i) \<in># P'. Suc (size C)) < (\<Sum>(C, i) \<in># P. Suc (size C))"
    using multiset_sum_monotone_f'[of "{#(E, k) \<in># P. E \<noteq> C'#}" P size] unfolding P'_def by metis
  then have "fst3 (trd3 (RP_combined_measure (weight (C, i)) St'))
    < fst3 (trd3 (RP_combined_measure (weight (C, i)) St))"
    unfolding P'_def St'_def St_def by auto
  ultimately show ?case
    unfolding natLess_def P'_def St'_def St_def by auto
next
  case (inference_computation P C' i' N n Q)
  then show ?case
  proof (cases "n \<le> weight (C, i)")
    case True
    then have "weight (C, i) + 1 - n > weight (C, i) + 1 - Suc n"
      by auto
    then show ?thesis
      unfolding natLess_def by auto
  next
    case n_nle_w: False

    define St :: "'a wstate" where "St = ({#}, P + {#(C', i')#}, Q, n)"
    define St' :: "'a wstate" where "St' =  (N, {#(D, j) \<in># P. D \<noteq> C'#}, Q + {#(C', i')#}, Suc n)"
    define concls :: "'a wclause set" where
      "concls = (\<lambda>D. (D, n)) ` concls_of (inference_system.inferences_between (ord_FO_\<Gamma> S)
         (fst ` set_mset Q) C')"

    have fin: "finite concls"
      unfolding concls_def using finite_ord_FO_resolution_inferences_between by auto

    have "{(D, ia) \<in> concls. ia \<le> weight (C, i)} = {}"
      unfolding concls_def using n_nle_w by auto
    then have "{#(D, ia) \<in># mset_set concls. ia \<le> weight (C, i)#} = {#}"
      using fin filter_mset_empty_if_finite_and_filter_set_empty[of concls] by auto
    then have n_low_weight_empty: "{#(D, ia) \<in># N. ia \<le> weight (C, i)#} = {#}"
      unfolding inference_computation unfolding concls_def by auto

    have "weight (C', i') \<le> weight (C, i)"
      using inference_computation by auto
    then have i'_le_w_Ci: "i' \<le> weight (C, i)"
      using timestamp_le_weight[of i' C'] by auto

    have subs: "{#(D, ia) \<in># N + {#(D, j) \<in># P. D \<noteq> C'#} + (Q + {#(C', i')#}). ia \<le> weight (C, i)#}
      \<subseteq># {#(D, ia) \<in># {#} + (P + {#(C', i')#}) + Q. ia \<le> weight (C, i)#}"
      using n_low_weight_empty by (auto simp: multiset_filter_mono)

    have "fst3 (RP_combined_measure (weight (C, i)) St')
      \<le> fst3 (RP_combined_measure (weight (C, i)) St)"
      unfolding St'_def St_def by auto
    moreover have "fst (RP_filtered_measure ((\<lambda>(D, ia). ia \<le> weight (C, i))) St') =
      (\<Sum>(C, i) \<in># {#(D, ia) \<in># N + {#(D, j) \<in># P. D \<noteq> C'#} + (Q + {#(C', i')#}).
         ia \<le> weight (C, i)#}. Suc (size C))"
      unfolding St'_def by auto
    also have "... \<le> (\<Sum>(C, i) \<in># {#(D, ia) \<in># {#} + (P + {#(C', i')#}) + Q. ia \<le> weight (C, i)#}.
      Suc (size C))"
      using subs sum_image_mset_mono by blast
    also have "... = fst (RP_filtered_measure (\<lambda>(D, ia). ia \<le> weight (C, i)) St)"
      unfolding St_def by auto
    finally have "fst3 (snd3 (RP_combined_measure (weight (C, i)) St'))
      \<le> fst3 (snd3 (RP_combined_measure (weight (C, i)) St))"
      by auto
    moreover have "snd3 (snd3 (RP_combined_measure (weight (C, i)) St')) =
      snd3 (snd3 (RP_combined_measure (weight (C, i)) St))"
      unfolding St_def St'_def using n_low_weight_empty by auto
    moreover have "trd3 (snd3 (RP_combined_measure (weight (C, i)) St')) <
      trd3 (snd3 (RP_combined_measure (weight (C, i)) St))"
      unfolding St_def St'_def using i'_le_w_Ci
      by (simp add: le_imp_less_Suc multiset_filter_mono size_mset_mono)
    ultimately show ?thesis
      unfolding natLess_def St'_def St_def lex_prod_def by force
  qed
qed (auto simp: natLess_def)

lemma preserve_min_or_delete_completely:
  assumes "St \<leadsto>\<^sub>w St'" "(C, i) \<in># wP_of_wstate St"
    "\<forall>k. (C, k) \<in># wP_of_wstate St \<longrightarrow> i \<le> k"
  shows "(C, i) \<in># wP_of_wstate St' \<or> (\<forall>j. (C, j) \<notin># wP_of_wstate St')"
using assms proof (induction rule: weighted_RP.induct)
  case (backward_reduction_P D L' N L \<sigma> C' P i' Q n)
  show ?case
  proof (cases "C = C' + {#L#}")
    case True_outer: True
    then have C_i_in: "(C, i) \<in># P + {#(C, i')#}"
      using backward_reduction_P by auto
    then have max: "\<And>k. (C, k) \<in># P + {#(C, i')#} \<Longrightarrow> k \<le> i'"
      using backward_reduction_P unfolding True_outer[symmetric] by auto
    then have "count (P + {#(C, i')#}) (C, i') \<ge> 1"
      by auto
    moreover
    {
      assume asm: "count (P + {#(C, i')#}) (C, i') = 1"
      then have nin_P: "(C, i') \<notin># P"
        using not_in_iff by force
      have ?thesis
      proof (cases "(C, i) = (C, i')")
        case True
        then have "i = i'"
          by auto
        then have "\<forall>j. (C, j) \<in># P + {#(C, i')#} \<longrightarrow> j = i'"
          using max backward_reduction_P(6) unfolding True_outer[symmetric] by force
        then show ?thesis
          using True_outer[symmetric] nin_P by auto
      next
        case False
        then show ?thesis
          using C_i_in by auto
      qed
    }
    moreover
    {
      assume "count (P + {#(C, i')#}) (C, i') > 1"
      then have ?thesis
        using C_i_in by auto
    }
    ultimately show ?thesis
      by (cases "count (P + {#(C, i')#}) (C, i') = 1") auto
  next
    case False
    then show ?thesis
      using backward_reduction_P by auto
  qed
qed auto

lemma preserve_min_P:
  assumes
    "St \<leadsto>\<^sub>w St'" "(C, j) \<in># wP_of_wstate St'" and
    "(C, i) \<in># wP_of_wstate St" and
    "\<forall>k. (C, k) \<in># wP_of_wstate St \<longrightarrow> i \<le> k"
  shows "(C, i) \<in># wP_of_wstate St'"
  using assms preserve_min_or_delete_completely by blast

lemma preserve_min_P_Sts:
  assumes
    "enat (Suc k) < llength Sts" and
    "(C, i) \<in># wP_of_wstate (lnth Sts k)" and
    "(C, j) \<in># wP_of_wstate (lnth Sts (Suc k))" and
    "\<forall>j. (C, j) \<in># wP_of_wstate (lnth Sts k) \<longrightarrow> i \<le> j"
  shows "(C, i) \<in># wP_of_wstate (lnth Sts (Suc k))"
  using deriv assms chain_lnth_rel preserve_min_P by metis

lemma in_lnth_in_Supremum_ldrop:
  assumes "i < llength xs" and "x \<in># (lnth xs i)"
  shows "x \<in> Sup_llist (lmap set_mset (ldrop (enat i) xs))"
  using assms by (metis (no_types) ldrop_eq_LConsD ldropn_0 llist.simps(13) contra_subsetD
      ldrop_enat ldropn_Suc_conv_ldropn lnth_0 lnth_lmap lnth_subset_Sup_llist)

lemma persistent_wclause_in_P_if_persistent_clause_in_P:
  assumes "C \<in> Liminf_llist (lmap P_of_state (lmap state_of_wstate Sts))"
  shows "\<exists>i. (C, i) \<in> Liminf_llist (lmap (set_mset \<circ> wP_of_wstate) Sts)"
proof -
  obtain t_C where t_C_p:
    "enat t_C < llength Sts"
    "\<And>t. t_C \<le> t \<Longrightarrow> t < llength Sts \<Longrightarrow> C \<in> P_of_state (state_of_wstate (lnth Sts t))"
    using assms unfolding Liminf_llist_def by auto
  then obtain i where i_p:
    "(C, i) \<in># wP_of_wstate (lnth Sts t_C)"
    using t_C_p by (cases "lnth Sts t_C") force

  have Ci_in_nth_wP: "\<exists>i. (C, i) \<in># wP_of_wstate (lnth Sts (t_C + t))" if "t_C + t < llength Sts"
    for t
    using that t_C_p(2)[of "t_C + _"] by (cases "lnth Sts (t_C + t)") force

  define in_Sup_wP :: "nat \<Rightarrow> bool" where
    "in_Sup_wP = (\<lambda>i. (C, i) \<in> Sup_llist (lmap (set_mset \<circ> wP_of_wstate) (ldrop t_C Sts)))"

  have "in_Sup_wP i"
    using i_p assms(1) in_lnth_in_Supremum_ldrop[of t_C "lmap wP_of_wstate Sts" "(C, i)"] t_C_p
    by (simp add: in_Sup_wP_def llist.map_comp)
  then obtain j where j_p: "is_least in_Sup_wP j"
    unfolding in_Sup_wP_def[symmetric] using least_exists by metis
  then have "\<forall>i. (C, i) \<in> Sup_llist (lmap (set_mset \<circ> wP_of_wstate) (ldrop t_C Sts)) \<longrightarrow> j \<le> i"
    unfolding is_least_def in_Sup_wP_def using not_less by blast
  then have j_smallest:
    "\<And>i t. enat (t_C + t) < llength Sts \<Longrightarrow> (C, i) \<in># wP_of_wstate (lnth Sts (t_C + t)) \<Longrightarrow> j \<le> i"
    unfolding comp_def
    by (smt add.commute ldrop_enat ldrop_eq_LConsD ldrop_ldrop ldropn_Suc_conv_ldropn
        plus_enat_simps(1)  lnth_ldropn Sup_llist_def UN_I ldrop_lmap llength_lmap lnth_lmap
        mem_Collect_eq)
  from j_p have "\<exists>t_Cj. t_Cj < llength (ldrop (enat t_C) Sts)
    \<and> (C, j) \<in># wP_of_wstate (lnth (ldrop t_C Sts) t_Cj)"
    unfolding in_Sup_wP_def Sup_llist_def is_least_def by simp
  then obtain t_Cj where j_p:
    "(C,j) \<in># wP_of_wstate (lnth Sts (t_C + t_Cj))"
    "enat (t_C + t_Cj) < llength Sts"
    by (smt add.commute ldrop_enat ldrop_eq_LConsD ldrop_ldrop ldropn_Suc_conv_ldropn
        plus_enat_simps(1) lhd_ldropn)
  have Ci_stays:
    "t_C + t_Cj + t < llength Sts \<Longrightarrow> (C,j) \<in># wP_of_wstate (lnth Sts (t_C + t_Cj + t))" for t
  proof (induction t)
    case 0
    then show ?case
      using j_p by (simp add: add.commute)
  next
    case (Suc t)
    have any_Ck_in_wP: "j \<le> k" if "(C, k) \<in># wP_of_wstate (lnth Sts (t_C + t_Cj + t))" for k
      using that j_p j_smallest Suc
      by (smt Suc_ile_eq add.commute add.left_commute add_Suc less_imp_le plus_enat_simps(1)
          the_enat.simps)
    from Suc have Cj_in_wP: "(C, j) \<in># wP_of_wstate (lnth Sts (t_C + t_Cj + t))"
      by (metis (no_types, opaque_lifting) Suc_ile_eq add.commute add_Suc_right less_imp_le)
    moreover have "C \<in> P_of_state (state_of_wstate (lnth Sts (Suc (t_C + t_Cj + t))))"
      using t_C_p(2) Suc.prems by auto
    then have "\<exists>k. (C, k) \<in># wP_of_wstate (lnth Sts (Suc (t_C + t_Cj + t)))"
      by (smt Suc.prems Ci_in_nth_wP add.commute add.left_commute add_Suc_right enat_ord_code(4))
    ultimately have "(C, j) \<in># wP_of_wstate (lnth Sts (Suc (t_C + t_Cj + t)))"
      using preserve_min_P_Sts Cj_in_wP any_Ck_in_wP Suc.prems by force
    then have "(C, j) \<in># lnth (lmap wP_of_wstate Sts) (Suc (t_C + t_Cj + t))"
      using Suc.prems by auto
    then show ?case
      by (smt Suc.prems add.commute add_Suc_right lnth_lmap)
  qed
  then have "(\<And>t. t_C + t_Cj \<le> t \<Longrightarrow> t < llength (lmap (set_mset \<circ> wP_of_wstate) Sts) \<Longrightarrow>
    (C, j) \<in># wP_of_wstate (lnth Sts t))"
    using Ci_stays[of "_ - (t_C + t_Cj)"] by (metis le_add_diff_inverse llength_lmap)
  then have "(C, j) \<in> Liminf_llist (lmap (set_mset \<circ> wP_of_wstate) Sts)"
    unfolding Liminf_llist_def using j_p by auto
  then show "\<exists>i. (C, i) \<in> Liminf_llist (lmap (set_mset \<circ> wP_of_wstate) Sts)"
    by auto
qed

lemma lfinite_not_LNil_nth_llast:
  assumes "lfinite Sts" and "Sts \<noteq> LNil"
  shows "\<exists>i < llength Sts. lnth Sts i = llast Sts \<and> (\<forall>j < llength Sts. j \<le> i)"
using assms proof (induction rule: lfinite.induct)
  case (lfinite_LConsI xs x)
  then show ?case
  proof (cases "xs = LNil")
    case True
    show ?thesis
      using True zero_enat_def by auto
  next
    case False
    then obtain i where
      i_p: "enat i < llength xs \<and> lnth xs i = llast xs \<and> (\<forall>j < llength xs. j \<le> enat i)"
      using lfinite_LConsI by auto
    then have "enat (Suc i) < llength (LCons x xs)"
      by (simp add: Suc_ile_eq)
    moreover from i_p have "lnth (LCons x xs) (Suc i) = llast (LCons x xs)"
      by (metis gr_implies_not_zero llast_LCons llength_lnull lnth_Suc_LCons)
    moreover from i_p have "\<forall>j < llength (LCons x xs). j \<le> enat (Suc i)"
      by (metis antisym_conv2 eSuc_enat eSuc_ile_mono ileI1 iless_Suc_eq llength_LCons)
    ultimately show ?thesis
      by auto
  qed
qed auto

lemma fair_if_finite:
  assumes fin: "lfinite Sts"
  shows "fair_state_seq (lmap state_of_wstate Sts)"
proof (rule ccontr)
  assume unfair: "\<not> fair_state_seq (lmap state_of_wstate Sts)"

  have no_inf_from_last: "\<forall>y. \<not> llast Sts \<leadsto>\<^sub>w y"
    using fin full_chain_iff_chain[of "(\<leadsto>\<^sub>w)" Sts] full_deriv by auto

  from unfair obtain C where
    "C \<in> Liminf_llist (lmap N_of_state (lmap state_of_wstate Sts))
       \<union> Liminf_llist (lmap P_of_state (lmap state_of_wstate Sts))"
    unfolding fair_state_seq_def Liminf_state_def by auto
  then obtain i where i_p:
    "enat i < llength Sts"
    "\<And>j. i \<le> j \<Longrightarrow> enat j < llength Sts \<Longrightarrow>
     C \<in> N_of_state (state_of_wstate (lnth Sts j)) \<union> P_of_state (state_of_wstate (lnth Sts j))"
    unfolding Liminf_llist_def by auto

  have C_in_llast:
    "C \<in> N_of_state (state_of_wstate (llast Sts)) \<union> P_of_state (state_of_wstate (llast Sts))"
  proof -
    obtain l where
      l_p: "enat l < llength Sts \<and> lnth Sts l = llast Sts \<and> (\<forall>j < llength Sts. j \<le> enat l)"
      using fin lfinite_not_LNil_nth_llast i_p(1) by fastforce
    then have
      "C \<in> N_of_state (state_of_wstate (lnth Sts l)) \<union> P_of_state (state_of_wstate (lnth Sts l))"
      using i_p(1) i_p(2)[of l] by auto
    then show ?thesis
      using l_p by auto
  qed

  define N :: "'a wclause multiset" where "N = wN_of_wstate (llast Sts)"
  define P :: "'a wclause multiset" where "P = wP_of_wstate (llast Sts)"
  define Q :: "'a wclause multiset" where "Q = wQ_of_wstate (llast Sts)"
  define n :: nat where "n = n_of_wstate (llast Sts)"

  {
    assume "N_of_state (state_of_wstate (llast Sts)) \<noteq> {}"
    then obtain D j where "(D, j) \<in># N"
      unfolding N_def by (cases "llast Sts") auto
    then have "llast Sts \<leadsto>\<^sub>w (N - {#(D, j)#}, P + {#(D, j)#}, Q, n)"
      using weighted_RP.clause_processing[of "N - {#(D, j)#}" D j P Q n]
      unfolding N_def P_def Q_def n_def by auto
    then have "\<exists>St'. llast Sts \<leadsto>\<^sub>w St'"
      by auto
  }
  moreover
  {
    assume a: "N_of_state (state_of_wstate (llast Sts)) = {}"
    then have b: "N = {#}"
      unfolding N_def by (cases "llast Sts") auto
    from a have "C \<in> P_of_state (state_of_wstate (llast Sts))"
      using C_in_llast by auto
    then obtain D j where "(D, j) \<in># P"
      unfolding P_def by (cases "llast Sts") auto
    then have "weight (D, j) \<in> weight ` set_mset P"
      by auto
    then have "\<exists>w. is_least (\<lambda>w. w \<in> (weight ` set_mset P)) w"
      using least_exists by auto
    then have "\<exists>D j. (\<forall>(D', j') \<in># P. weight (D, j) \<le> weight (D', j')) \<and> (D, j) \<in># P"
      using assms linorder_not_less unfolding is_least_def by (auto 6 0)
    then obtain D j where
      min: "(\<forall>(D', j') \<in># P. weight (D, j) \<le> weight (D', j'))" and
      Dj_in_p: "(D, j) \<in># P"
      by auto
    from min have min: "(\<forall>(D', j') \<in># P - {#(D, j)#}. weight (D, j) \<le> weight (D', j'))"
      using mset_subset_diff_self[OF Dj_in_p] by auto

    define N' where
      "N' = mset_set ((\<lambda>D'. (D', n)) ` concls_of (inference_system.inferences_between (ord_FO_\<Gamma> S)
         (set_mset (image_mset fst Q)) D))"

    have "llast Sts \<leadsto>\<^sub>w (N', {#(D', j') \<in># P - {#(D, j)#}. D' \<noteq> D#}, Q + {#(D,j)#}, Suc n)"
      using weighted_RP.inference_computation[of "P - {#(D, j)#}" D j N' n Q, OF min N'_def]
        of_wstate_split[symmetric, of "llast Sts"] Dj_in_p
      unfolding N_def[symmetric] P_def[symmetric] Q_def[symmetric] n_def[symmetric] b by auto
    then have "\<exists>St'. llast Sts \<leadsto>\<^sub>w St'"
      by auto
  }
  ultimately have "\<exists>St'. llast Sts \<leadsto>\<^sub>w St'"
    by auto
  then show False
    using no_inf_from_last by metis
qed

lemma N_of_state_state_of_wstate_wN_of_wstate:
  assumes "C \<in> N_of_state (state_of_wstate St)"
  shows "\<exists>i. (C, i) \<in># wN_of_wstate St"
  by (smt N_of_state.elims assms eq_fst_iff fstI fst_conv image_iff of_wstate_split set_image_mset
      state_of_wstate.simps)

lemma in_wN_of_wstate_in_N_of_wstate: "(C, i) \<in># wN_of_wstate St \<Longrightarrow> C \<in> N_of_wstate St"
  by (metis (mono_guards_query_query) N_of_state.simps fst_conv image_eqI of_wstate_split
      set_image_mset state_of_wstate.simps)

lemma in_wP_of_wstate_in_P_of_wstate: "(C, i) \<in># wP_of_wstate St \<Longrightarrow> C \<in> P_of_wstate St"
  by (metis (mono_guards_query_query) P_of_state.simps fst_conv image_eqI of_wstate_split
      set_image_mset state_of_wstate.simps)

lemma in_wQ_of_wstate_in_Q_of_wstate: "(C, i) \<in># wQ_of_wstate St \<Longrightarrow> C \<in> Q_of_wstate St"
  by (metis (mono_guards_query_query) Q_of_state.simps fst_conv image_eqI of_wstate_split
      set_image_mset state_of_wstate.simps)

lemma n_of_wstate_weighted_RP_increasing: "St \<leadsto>\<^sub>w St' \<Longrightarrow> n_of_wstate St \<le> n_of_wstate St'"
  by (induction rule: weighted_RP.induct) auto

lemma nth_of_wstate_monotonic:
  assumes "j < llength Sts" and "i \<le> j"
  shows "n_of_wstate (lnth Sts i) \<le> n_of_wstate (lnth Sts j)"
using assms proof (induction "j - i" arbitrary: i)
  case (Suc x)
  then have "x = j - (i + 1)"
    by auto
  then have "n_of_wstate (lnth Sts (i + 1)) \<le> n_of_wstate (lnth Sts j)"
    using Suc by auto
  moreover have "i < j"
    using Suc by auto
  then have "Suc i < llength Sts"
    using Suc by (metis enat_ord_simps(2) le_less_Suc_eq less_le_trans not_le)
  then have "lnth Sts i \<leadsto>\<^sub>w lnth Sts (Suc i)"
    using deriv chain_lnth_rel[of "(\<leadsto>\<^sub>w)" Sts i] by auto
  then have "n_of_wstate (lnth Sts i) \<le> n_of_wstate (lnth Sts (i + 1))"
    using n_of_wstate_weighted_RP_increasing[of "lnth Sts i" "lnth Sts (i + 1)"] by auto
  ultimately show ?case
    by auto
qed auto

lemma infinite_chain_relation_measure:
  assumes
    measure_decreasing: "\<And>St St'. P St \<Longrightarrow> R St St' \<Longrightarrow> (m St', m St) \<in> mR" and
    non_infer_chain: "chain R (ldrop (enat k) Sts)" and
    inf: "llength Sts = \<infinity>" and
    P: "\<And>i. P (lnth (ldrop (enat k) Sts) i)"
  shows "chain (\<lambda>x y. (x, y) \<in> mR)\<inverse>\<inverse> (lmap m (ldrop (enat k) Sts))"
proof (rule lnth_rel_chain)
  show "\<not> lnull (lmap m (ldrop (enat k) Sts))"
    using assms by auto
next
  from inf have ldrop_inf: "llength (ldrop (enat k) Sts) = \<infinity> \<and> \<not> lfinite (ldrop (enat k) Sts)"
    using inf by (auto simp: llength_eq_infty_conv_lfinite)
  {
    fix j :: "nat"
    define St where "St = lnth (ldrop (enat k) Sts) j"
    define St' where "St' = lnth (ldrop (enat k) Sts) (j + 1)"
    have P': "P St \<and> P St'"
      unfolding St_def St'_def using P by auto
    from ldrop_inf have "R St St'"
      unfolding St_def St'_def
      using non_infer_chain infinite_chain_lnth_rel[of "ldrop (enat k) Sts" R j] by auto
    then have "(m St', m St) \<in> mR"
      using measure_decreasing P' by auto
    then have "(lnth (lmap m (ldrop (enat k) Sts)) (j + 1), lnth (lmap m (ldrop (enat k) Sts)) j)
      \<in> mR"
      unfolding St_def St'_def using lnth_lmap
      by (smt enat.distinct(1) enat_add_left_cancel enat_ord_simps(4) inf ldrop_lmap llength_lmap
          lnth_ldrop plus_enat_simps(3))
  }
  then show "\<forall>j. enat (j + 1) < llength (lmap m (ldrop (enat k) Sts)) \<longrightarrow>
    (\<lambda>x y. (x, y) \<in> mR)\<inverse>\<inverse> (lnth (lmap m (ldrop (enat k) Sts)) j)
      (lnth (lmap m (ldrop (enat k) Sts)) (j + 1))"
    by blast
qed

theorem weighted_RP_fair: "fair_state_seq (lmap state_of_wstate Sts)"
proof (rule ccontr)
  assume asm: "\<not> fair_state_seq (lmap state_of_wstate Sts)"
  then have inff: "\<not> lfinite Sts" using fair_if_finite
    by auto
  then have inf: "llength Sts = \<infinity>"
    using llength_eq_infty_conv_lfinite by auto
  from asm obtain C where
    "C \<in> Liminf_llist (lmap N_of_state (lmap state_of_wstate Sts))
       \<union> Liminf_llist (lmap P_of_state (lmap state_of_wstate Sts))"
    unfolding fair_state_seq_def Liminf_state_def by auto
  then show False
  proof
    assume "C \<in> Liminf_llist (lmap N_of_state (lmap state_of_wstate Sts))"
    then obtain x where "enat x < llength Sts"
      "\<forall>xa. x \<le> xa \<and> enat xa < llength Sts \<longrightarrow> C \<in> N_of_state (state_of_wstate (lnth Sts xa))"
      unfolding Liminf_llist_def by auto
    then have "\<exists>k. \<forall>j. k \<le> j \<longrightarrow> (\<exists>i. (C, i) \<in># wN_of_wstate (lnth Sts j))"
      unfolding Liminf_llist_def by (force simp add: inf N_of_state_state_of_wstate_wN_of_wstate)
    then obtain k where k_p:
      "\<And>j. k \<le> j \<Longrightarrow> \<exists>i. (C, i) \<in># wN_of_wstate (lnth Sts j)"
      unfolding Liminf_llist_def
      by auto
    have chain_drop_Sts: "chain (\<leadsto>\<^sub>w) (ldrop k Sts)"
      using deriv inf inff by (simp add: inf_chain_ldropn_chain ldrop_enat)
    have in_N_j: "\<And>j. \<exists>i. (C, i) \<in># wN_of_wstate (lnth (ldrop k Sts) j)"
      using k_p by (simp add: add.commute inf)
    then have "chain (\<lambda>x y. (x, y) \<in> RP_filtered_relation)\<inverse>\<inverse> (lmap (RP_filtered_measure (\<lambda>Ci. True))
      (ldrop k Sts))"
      using inff inf weighted_RP_measure_decreasing_N chain_drop_Sts
        infinite_chain_relation_measure[of "\<lambda>St. \<exists>i. (C, i) \<in># wN_of_wstate St" "(\<leadsto>\<^sub>w)"] by blast
    then show False
      using wfP_iff_no_infinite_down_chain_llist[of "\<lambda>x y. (x, y) \<in> RP_filtered_relation"]
        wf_RP_filtered_relation inff
      by (metis (no_types, lifting) inf_llist_lnth ldrop_enat_inf_llist lfinite_inf_llist
        lfinite_lmap wfPUNIVI wf_induct_rule)
  next
    assume asm: "C \<in> Liminf_llist (lmap P_of_state (lmap state_of_wstate Sts))"
    from asm obtain i where i_p:
      "enat i < llength Sts"
      "\<And>j. i \<le> j \<and> enat j < llength Sts \<Longrightarrow> C \<in> P_of_state (state_of_wstate (lnth Sts j))"
      unfolding Liminf_llist_def by auto
    then obtain i where "(C, i) \<in> Liminf_llist (lmap (set_mset \<circ> wP_of_wstate) Sts)"
      using persistent_wclause_in_P_if_persistent_clause_in_P[of C] using asm inf by auto
    then have "\<exists>l. \<forall>k \<ge> l. (C, i) \<in> (set_mset \<circ> wP_of_wstate) (lnth Sts k)"
      unfolding Liminf_llist_def using inff inf by auto
    then obtain k where k_p:
      "(\<forall>k'\<ge>k. (C, i) \<in> (set_mset \<circ> wP_of_wstate) (lnth Sts k'))"
      by blast
    have Ci_in: "\<forall>k'. (C, i) \<in> (set_mset \<circ> wP_of_wstate) (lnth (ldrop k Sts) k')"
      using k_p lnth_ldrop[of k _ Sts] inf inff by force
    then have Ci_inn: "\<forall>k'. (C, i) \<in># (wP_of_wstate) (lnth (ldrop k Sts) k')"
      by auto
    have "chain (\<leadsto>\<^sub>w) (ldrop k Sts)"
      using deriv inf_chain_ldropn_chain inf inff by (simp add: inf_chain_ldropn_chain ldrop_enat)
    then have "chain (\<lambda>x y. (x, y) \<in> RP_combined_relation)\<inverse>\<inverse>
      (lmap (RP_combined_measure (weight (C, i))) (ldrop k Sts))"
      using inff inf Ci_in weighted_RP_measure_decreasing_P
        infinite_chain_relation_measure[of "\<lambda>St. (C, i) \<in># wP_of_wstate St" "(\<leadsto>\<^sub>w)"
          "RP_combined_measure (weight (C, i))" ]
      by auto
    then show False
      using wfP_iff_no_infinite_down_chain_llist[of "\<lambda>x y. (x, y) \<in> RP_combined_relation"]
        wf_RP_combined_relation inff
      by (smt inf_llist_lnth ldrop_enat_inf_llist lfinite_inf_llist lfinite_lmap wfPUNIVI
          wf_induct_rule)
  qed
qed

corollary weighted_RP_saturated: "src.saturated_upto (Liminf_llist (lmap grounding_of_wstate Sts))"
  using RP_saturated_if_fair[OF deriv_RP weighted_RP_fair empty_Q0_RP, unfolded llist.map_comp]
  by simp

corollary weighted_RP_complete:
  "\<not> satisfiable (grounding_of_wstate (lhd Sts)) \<Longrightarrow> {#} \<in> Q_of_state (Liminf_wstate Sts)"
  using RP_complete_if_fair[OF deriv_RP weighted_RP_fair empty_Q0_RP, simplified lhd_lmap_Sts] .

end

end

locale weighted_FO_resolution_prover_with_size_timestamp_factors =
  FO_resolution_prover S subst_atm id_subst comp_subst renamings_apart atm_of_atms mgu less_atm
  for
    S :: "('a :: wellorder) clause \<Rightarrow> 'a clause" and
    subst_atm :: "'a \<Rightarrow> 's \<Rightarrow> 'a" and
    id_subst :: "'s" and
    comp_subst :: "'s \<Rightarrow> 's \<Rightarrow> 's" and
    renamings_apart :: "'a literal multiset list \<Rightarrow> 's list" and
    atm_of_atms :: "'a list \<Rightarrow> 'a" and
    mgu :: "'a set set \<Rightarrow> 's option" and
    less_atm :: "'a \<Rightarrow> 'a \<Rightarrow> bool" +
  fixes
    size_atm :: "'a \<Rightarrow> nat" and
    size_factor :: nat and
    timestamp_factor :: nat
  assumes
    timestamp_factor_pos: "timestamp_factor > 0"
begin

fun weight :: "'a wclause \<Rightarrow> nat" where
  "weight (C, i) = size_factor * size_multiset (size_literal size_atm) C + timestamp_factor * i"

lemma weight_mono: "i < j \<Longrightarrow> weight (C, i) < weight (C, j)"
  using timestamp_factor_pos by simp

declare weight.simps [simp del]

sublocale wrp: weighted_FO_resolution_prover _ _ _ _ _ _ _ _ weight
  by unfold_locales (rule weight_mono)

notation wrp.weighted_RP (infix "\<leadsto>\<^sub>w" 50)

end

end


subsection\<open>HC, SC, and ND\<close>
theory HCSCND
imports HCSC SCND NDHC
begin

theorem HCSCND:
  defines "hc F \<equiv> AX10 \<turnstile>\<^sub>H F"
  defines "nd F \<equiv> {} \<turnstile> F"
  defines "sc F \<equiv> {#} \<Rightarrow> {# F #}"
  shows "hc F \<longleftrightarrow> nd F" and "nd F \<longleftrightarrow> sc F" and "sc F \<longleftrightarrow> hc F"
using HCSC[where F=F and \<Gamma>=\<open>{#}\<close>, simplified]
      SCND[where \<Gamma>=\<open>{#}\<close> and \<Delta>="{#F#}"] ND.ND.CC[where F=F and \<Gamma>="{}"]
      NDHC[where \<Gamma>="{}" and F=F]
by(simp_all add: assms) blast+

end


theory FunctionSpace
  imports Functions "../OPair/CartProd"
begin
class FunSpace = Function + CartProd
context FunSpace
begin

definition fun_from_opair_set :: "'a \<Rightarrow> 'a"
  where "fun_from_opair_set x \<equiv> mkfun {\<tau> p | p \<in> x} (\<lambda>a b. <a,b> \<in> x)"

definition partial_fun_space :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr \<open>\<Zpfun>''''\<close> 70)
  where "x \<Zpfun>'' y \<equiv> {g | \<exists>f \<in> \<P>(x \<times> y). g = fun_from_opair_set f \<and> g : x \<Zpfun> y}"

(* definition total_fun_space ::  "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr \<open>\<leadsto>''''\<close> 70)
  where "x \<leadsto>'' y \<equiv> {g | \<exists>f \<in> \<P>(x \<times> y). g = fun_from_opair_set f \<and> g : x \<leadsto> y}"
 *)
(* lemma total_fun_space_typ :
  "(\<leadsto>'') : (\<Pi> x : Set. \<Pi> y : Set. SetOf (x \<leadsto> y))"
proof (rule depfunI, rule depfunI, rule setofI)
  fix x y
  assume x : "x : Set"
     and y : "y : Set"
  show "x \<leadsto>'' y : Set"
    unfolding total_fun_space_def
    using repl_set[OF pow_set[OF cprod_set[OF x y]]]
    sorry
  fix b
  assume "b \<in> x \<leadsto>'' y"
  then
  show "b : x \<leadsto> y"
    unfolding total_fun_space_def
    using replaceE[OF pow_set[OF cprod_set[OF x y]]]
    sorry
qed
 *)
(* lemmas total_fun_space_setof = depfunE[OF depfunE[OF total_fun_space_typ]] *)

end
end


section \<open>Frame Inference\<close>
theory Frame_Infer
imports "Sep_Algebra_Add" Basic_VCG
begin

subsection \<open>Separation Algebra Specific Setup of VCG\<close>
lemmas [vcg_prep_ext_rules] = pure_part_split_conj

subsection \<open>Entails Connective\<close>
definition "entails" :: "('a::sep_algebra \<Rightarrow> bool) \<Rightarrow> _ \<Rightarrow> _" (infix "\<turnstile>" 25) where "P \<turnstile> Q \<equiv> \<forall>s. P s \<longrightarrow> Q s"
lemma entails_refl[intro!,simp]: "P \<turnstile> P" by (simp add: entails_def)

lemma entails_false[simp, intro!]: "sep_false \<turnstile> Q" by (simp add: entails_def)

lemma entails_trans[trans]: "P \<turnstile> Q \<Longrightarrow> Q \<turnstile> R \<Longrightarrow> P \<turnstile> R"
  by (simp add: entails_def)

lemma entails_mp: "\<lbrakk>Q \<turnstile> Q'; P \<turnstile> Q \<and>* F\<rbrakk> \<Longrightarrow> P \<turnstile> Q' \<and>* F"
  apply (clarsimp simp: entails_def)
  using sep_conj_impl1 by blast

lemma conj_entails_mono: "P\<turnstile>P' \<Longrightarrow> Q\<turnstile>Q' \<Longrightarrow> P**Q \<turnstile> P'**Q'"
  apply (clarsimp simp: entails_def)
  using sep_conj_impl by blast

lemma entails_exI: "P\<turnstile>Q x \<Longrightarrow> P\<turnstile>(EXS x. Q x)"
  by (metis (mono_tags, lifting) entails_def)

lemma entails_pureI: "\<lbrakk>pure_part P \<Longrightarrow> P\<turnstile>Q\<rbrakk> \<Longrightarrow> P\<turnstile>Q"
  by (auto simp: entails_def intro: pure_partI)

lemma entails_lift_extract_simps:
  "(\<up>\<Phi> \<turnstile> Q) \<longleftrightarrow> (\<Phi> \<longrightarrow> \<box> \<turnstile> Q)"
  "(\<up>\<Phi>**P \<turnstile> Q) \<longleftrightarrow> (\<Phi> \<longrightarrow> P \<turnstile> Q)"
  unfolding entails_def
  by (auto simp: sep_algebra_simps pred_lift_extract_simps)

lemma entails_eq_iff: "A=B \<longleftrightarrow> (A\<turnstile>B) \<and> (B\<turnstile>A)"
  unfolding entails_def by (auto)

lemma entails_eqI: "\<lbrakk> A\<turnstile>B; B\<turnstile>A \<rbrakk> \<Longrightarrow> A=B" by (simp add: entails_eq_iff)

definition "is_sep_red P' Q' P Q \<longleftrightarrow> (\<forall>Ps Qs. (P'**Ps\<turnstile>Q'**Qs) \<longrightarrow> (P**Ps\<turnstile>Q**Qs))"

lemma is_sep_redI: "\<lbrakk>\<And>Ps Qs. P'**Ps\<turnstile>Q'**Qs \<Longrightarrow> P**Ps\<turnstile>Q**Qs \<rbrakk> \<Longrightarrow> is_sep_red P' Q' P Q"
  unfolding is_sep_red_def by blast

lemma is_sep_redD: "\<lbrakk>is_sep_red P' Q' P Q; P'**Ps\<turnstile>Q'**Qs\<rbrakk> \<Longrightarrow> P**Ps\<turnstile>Q**Qs"
  unfolding is_sep_red_def by blast

subsection \<open>Tags for Frame Inference\<close>
definition "FRI_END \<equiv> \<box>"
definition "FRAME_INFER P Qs F \<equiv> P \<turnstile> Qs ** F"
lemmas fri_prems_cong = arg_cong[where f="\<lambda>P. FRAME_INFER P _ _"]
lemma fri_prems_cong_meta: "P\<equiv>P' \<Longrightarrow> FRAME_INFER P Q F \<equiv> FRAME_INFER P' Q F" by simp

lemmas fri_concls_cong = arg_cong[where f="\<lambda>P. FRAME_INFER _ P _"]

lemma fri_prepare: "FRAME_INFER Ps (Qs**FRI_END) F \<Longrightarrow> FRAME_INFER Ps Qs F"
  by (auto simp: FRI_END_def)

lemma fri_prepare_round: "FRAME_INFER (\<box>**Ps) Qs F \<Longrightarrow> FRAME_INFER Ps Qs F"
  by simp

lemma fri_end: (* Potential premises get solved by entails_refl. *)
  "Ps \<turnstile> F \<Longrightarrow> FRAME_INFER Ps FRI_END F"
  by (auto simp: FRAME_INFER_def FRI_END_def)

lemma fri_step_rl:
  assumes "P \<turnstile> Q"  (* Gets instantiated with frame_infer_rules *)
  assumes "FRAME_INFER Ps Qs F"
  shows "FRAME_INFER (P**Ps) (Q**Qs) F"
  using assms
  unfolding FRAME_INFER_def
  by (simp add: conj_entails_mono)

lemma fri_reduce_rl:
  assumes "is_sep_red P' Q' P Q"
  assumes "FRAME_INFER (P'**Ps) (Q'**Qs) F"
  shows "FRAME_INFER (P**Ps) (Q**Qs) F"
  using assms unfolding FRAME_INFER_def
  by (auto dest: is_sep_redD)

subsection \<open>Configurable Rule Sets\<close>
named_theorems fri_prepare_simps
named_theorems fri_rules
named_theorems fri_red_rules

lemma fri_empty_concl_simp: "(\<box> ** FRI_END) = FRI_END" by simp

lemmas [fri_prepare_simps] = sep_conj_assoc sep_conj_empty sep_conj_empty' sep_conj_exists
declare entails_refl[fri_rules]

lemma fri_exI: "FRAME_INFER Ps (Qs x) F \<Longrightarrow> FRAME_INFER Ps (EXS x. Qs x) F"
  by (auto simp: FRAME_INFER_def sep_algebra_simps intro: entails_exI)

subsection \<open>ML Code\<close>

ML \<open>

  structure Frame_Infer = struct
    open VCG_Lib

    (**** Utilities *)

    val simp_ai_tac = simp_only_tac @{thms sep_conj_assoc sep_conj_empty sep_conj_empty'}
    val simp_a_tac = simp_only_tac @{thms sep_conj_assoc}

    val rewrite_a_conv = rewrite_only_conv @{thms sep_conj_assoc}
    val rewrite_ai_conv = rewrite_only_conv @{thms sep_conj_assoc sep_conj_empty sep_conj_empty'}

    (**** Rotation Tactic *)

    local
      fun eq_rotate1_tac ctxt = CONVERSION (Refine_Util.HOL_concl_conv (
          fn ctxt => Conv.arg1_conv (
            Conv.rewr_conv @{thm sep_conj_commute[THEN eq_reflection]}
            then_conv Simplifier.rewrite (put_simpset HOL_basic_ss ctxt addsimps @{thms sep_conj_assoc})
          )) ctxt)

      fun eq_rotateN_tac ctxt n = WITH_concl (fn
        @{mpat "Trueprop (?lhs = _)"} => let
          val nc = length (SepConj.break_sep_conj lhs)
          val n = n mod nc

          fun tc 0 = K all_tac
            | tc n = eq_rotate1_tac ctxt THEN' tc (n-1)

        in tc n end
      | _ => K no_tac
      )

      (*
      fun eq_rotateN_tac _ 0 = K all_tac
        | eq_rotateN_tac ctxt n = eq_rotate1_tac ctxt THEN' eq_rotateN_tac ctxt (n-1)
      *)

    in
      (*
        Takes a congruence rule of the form a=b \<Longrightarrow> h a = h b,
        then expects a subgoal of the form h (a\<^sub>1**...**a\<^sub>n), and produces
        a sequence of new subgoals h (...) corresponding to all rotations of the a\<^sub>is.
      *)
      fun rotations_tac cong_rls ctxt = let
        val cong_rls = map_filter (try (fn thm => @{thm iffD2} OF [thm])) cong_rls
      in
        resolve_tac ctxt cong_rls
        THEN'
        WITH_concl (
          fn @{mpat \<open>Trueprop (?lhs = _)\<close>} => let
              val n = length (SepConj.break_sep_conj lhs)
              fun tac n = eq_rotateN_tac ctxt n
              val tacs = map tac (0 upto n-1)
            in
              APPEND_LIST' tacs
            end
          |  _ => K no_tac
        )
        THEN'
        resolve_tac ctxt @{thms refl}
      end

      fun rotate_tac cong_rls ctxt n = let
        val cong_rls = map_filter (try (fn thm => @{thm iffD2} OF [thm])) cong_rls
      in
        resolve_tac ctxt cong_rls
        THEN' eq_rotateN_tac ctxt n
        THEN' resolve_tac ctxt @{thms refl}
      end

    end

    (**** Frame Inference Tactic *)
    fun start_tac ctxt =
            asm_simp_named_thms_tac ctxt @{named_theorems fri_prepare_simps}
      THEN' REPEAT' (resolve_tac ctxt @{thms fri_exI})
      THEN' resolve_tac ctxt @{thms fri_prepare}
      THEN' simp_only_tac @{thms sep_conj_assoc fri_empty_concl_simp} ctxt

    fun end_tac ctxt =
      simp_ai_tac ctxt
      THEN' resolve_tac ctxt @{thms fri_end}
      THEN' resolve_tac ctxt @{thms entails_refl}

    fun start_round_tac ctxt =
      simp_ai_tac ctxt
      THEN' resolve_tac ctxt @{thms fri_prepare_round}
      THEN' simp_a_tac ctxt

    fun solve_round_thms ctxt = let
      val thms1 = Named_Theorems.get ctxt @{named_theorems fri_rules}
        |> map (fn thm => @{thm fri_step_rl} OF [thm])

      val thms2 = Named_Theorems.get ctxt @{named_theorems fri_red_rules}
        |> map (fn thm => @{thm fri_reduce_rl} OF [thm])
    in thms1@thms2 end

    fun solve_round_tac ctxt = let
      val thms = solve_round_thms ctxt
    in
      Basic_VCG.step_precond_tac ctxt (resolve_tac ctxt thms)
    end

    fun round_tac_aux ctxt =
      start_round_tac ctxt
      THEN' rotations_tac @{thms fri_prems_cong} ctxt
      THEN' solve_round_tac ctxt

    fun round_tac ctxt =
      round_tac_aux ctxt
      ORELSE' (CHANGED o asm_full_simp_tac ctxt ORELSE' round_tac_aux ctxt)

    fun infer_tac ctxt = start_tac ctxt THEN' REPEAT' (end_tac ctxt ORELSE' round_tac ctxt)

    (**** Debugging Tactics *)
    fun dbg_solve_round_tac ctxt = let
      val thms = solve_round_thms ctxt
    in
      Basic_VCG.step_precond_tac ctxt (resolve_tac ctxt thms)
      ORELSE' resolve_tac ctxt thms
    end

    fun dbg_round_tac_aux ctxt =
      start_round_tac ctxt
      THEN' rotations_tac @{thms fri_prems_cong} ctxt
      THEN' dbg_solve_round_tac ctxt

    fun dbg_round_tac ctxt =
      dbg_round_tac_aux ctxt
      ORELSE' (CHANGED o asm_full_simp_tac ctxt ORELSE' dbg_round_tac_aux ctxt)

  end
\<close>

subsubsection \<open>Methods\<close>
definition "FRAME P Q F \<equiv> P \<turnstile> Q ** F"
definition "ENTAILS P Q \<equiv> P \<turnstile> Q"
lemma ENTAILSD: "ENTAILS P Q \<Longrightarrow> P \<turnstile> Q" by (simp add: ENTAILS_def)

lemma fri_startI:
  "\<lbrakk>pure_part P \<Longrightarrow> FRAME_INFER P Q F\<rbrakk> \<Longrightarrow> FRAME P Q F"
  "\<lbrakk>pure_part P \<Longrightarrow> FRAME_INFER P Q \<box>\<rbrakk> \<Longrightarrow> ENTAILS P Q"
  unfolding FRAME_INFER_def FRAME_def ENTAILS_def
  by (auto intro: entails_pureI)

method_setup fri_rotations =
  \<open>(Attrib.thms >> (fn cong_rls => fn ctxt => SIMPLE_METHOD' (Frame_Infer.rotations_tac cong_rls ctxt )))\<close>
  \<open>Generate sequence of rotations wrt. specified congruence rule\<close>

method_setup fri_rotate =
  \<open>(Attrib.thms -- Scan.lift (Scan.optional (Parse.$$$ ":" |-- Parse.int) 1) >>
    (fn (cong_rls,n) => fn ctxt => SIMPLE_METHOD' (Frame_Infer.rotate_tac cong_rls ctxt n)))\<close>
  \<open>Rotate left n steps wrt. specified congruence rule\<close>

method_setup fri_keep_aux =
  \<open>(Scan.succeed (fn ctxt => SIMPLE_METHOD' (Frame_Infer.infer_tac ctxt)))\<close>
  \<open>Frame Inference, solve from left to right, as far as possible\<close>

method fri_keep = (rule fri_startI)?; fri_keep_aux

method fri = fri_keep;fail

method_setup fri_dbg_step =
  \<open>(Scan.succeed (fn ctxt => SIMPLE_METHOD' (Frame_Infer.dbg_round_tac ctxt)))\<close>
  \<open>Frame Inference, one round, keep unsolved goals\<close>

method_setup fri_dbg_end =
  \<open>(Scan.succeed (fn ctxt => SIMPLE_METHOD' (Frame_Infer.end_tac ctxt)))\<close>
  \<open>Frame Inference, end inference\<close>

subsubsection \<open>Solver Setup\<close>

declaration \<open>
  K (Basic_VCG.add_solver (@{thms fri_startI},@{binding infer_frame},Frame_Infer.infer_tac))
\<close>

method_setup fri_dbg_start =
  \<open>(Scan.succeed (fn ctxt => SIMPLE_METHOD' (TRY o resolve_tac ctxt @{thms fri_startI} THEN' Frame_Infer.start_tac ctxt)))\<close>
  \<open>Frame Inference, start\<close>

subsection \<open>Solving Pure Assertions\<close>

lemma fri_pure_rl[fri_rules]: "PRECOND (SOLVE_DEFAULT_AUTO \<Phi>) \<Longrightarrow> \<box>\<turnstile>\<up>\<Phi>"
  by (auto simp: sep_algebra_simps vcg_tag_defs)

abbreviation pred_lift_ASM ("\<up>\<^sub>a_" [100] 100) where "\<up>\<^sub>a\<Phi> \<equiv> \<up>SOLVE_ASM \<Phi>"
abbreviation pred_lift_AUTO_DEFER ("\<up>\<^sub>d_" [100] 100) where "\<up>\<^sub>d\<Phi> \<equiv> \<up>SOLVE_AUTO_DEFER \<Phi>"
abbreviation pred_lift_AUTO ("\<up>\<^sub>!_" [100] 100) where "\<up>\<^sub>!\<Phi> \<equiv> \<up>SOLVE_AUTO \<Phi>"

subsection \<open>Extraction\<close>

text \<open>A transformer that applies a configurable set of simplification rules
  only to certrain parts of the subgoal, as specified by a configurable set of
  congruence rules. Afterwards, VCG normalization is performed.

  The envisaged use of this transformer is to process the
  postcondition of a Hoare-triple when it is transformed to the current symbolic state,
  extracting all pure content.
\<close>

named_theorems fri_extract_congs \<open>Congruence rules for extraction\<close>
named_theorems fri_extract_simps \<open>Simplification rules for extraction\<close>

lemmas fri_basic_extract_simps = pred_lift_move_front_simps sep_conj_exists

definition EXTRACT :: "bool \<Rightarrow> bool" where [vcg_tag_defs]: "EXTRACT x \<equiv> x"
lemma
  EXTRACTI: "x \<Longrightarrow> EXTRACT x" and
  EXTRACTD: "EXTRACT x \<Longrightarrow> x"
  by (auto simp: vcg_tag_defs)

ML \<open>
  structure Fri_Extract = struct
    (* TODO: Move *)
    (* Conversion wrt. congruence rule. The rule must have the form a\<equiv>b \<Longrightarrow> c\<equiv>d. *)
    fun cong_rl_conv (conv:conv) rule ct = let
      val rule = Thm.incr_indexes (Thm.maxidx_of_cterm ct + 1) rule;
      val lhs = Thm.cprop_of rule |> Thm.dest_implies |> snd |> Thm.dest_equals_lhs;
      val rule = Thm.rename_boundvars (Thm.term_of lhs) (Thm.term_of ct) rule;
      val rule =
        Thm.instantiate (Thm.match (lhs, ct)) rule
          handle Pattern.MATCH => raise CTERM ("cong_rl_conv", [lhs, ct]);

      val lhs' = Thm.cprop_of rule |> Thm.dest_implies |> fst |> Thm.dest_equals_lhs;

    in rule OF [conv lhs'] end

    fun cong_rls_conv conv rules =
      Conv.first_conv (map (cong_rl_conv conv) rules)

    fun extract_basic_tac ctxt thms = let
      val ctxt = put_simpset HOL_Main_ss ctxt addsimps @{thms fri_basic_extract_simps} addsimps thms
      val cong_thms = Named_Theorems.get ctxt @{named_theorems fri_extract_congs}
    in
      CONVERSION (Conv.top_sweep_conv (fn ctxt => cong_rls_conv (Simplifier.rewrite ctxt) cong_thms) ctxt)
    end

    fun extract_tac ctxt thms =
      extract_basic_tac ctxt (
          Named_Theorems.get ctxt @{named_theorems fri_extract_simps}
        @ Named_Theorems.get ctxt @{named_theorems vcg_tag_defs}
        @ thms
        )

  end

\<close>

declaration \<open>
  let
  in K (I
  #> Basic_VCG.add_xformer (@{thms EXTRACTI},@{binding extract_xformer}, fn ctxt =>
        Fri_Extract.extract_tac ctxt []
        THEN' Basic_VCG.vcg_normalize_tac ctxt
      )
  ) end
\<close>

method_setup fri_extract_basic = \<open>Scan.lift (Args.mode "no_norm") -- Attrib.thms
  >> (fn (no_norm,thms) => fn ctxt => SIMPLE_METHOD' (
    Fri_Extract.extract_basic_tac ctxt thms
    THEN' (if no_norm then K all_tac else Basic_VCG.vcg_normalize_tac ctxt)
  ))\<close>
  \<open>Extraction of pure content, only basic rules\<close>

method_setup fri_extract = \<open>Scan.lift (Args.mode "no_norm") -- Attrib.thms
  >> (fn (no_norm,thms) => fn ctxt => SIMPLE_METHOD' (
    Fri_Extract.extract_tac ctxt thms
    THEN' (if no_norm then K all_tac else Basic_VCG.vcg_normalize_tac ctxt)
  ))\<close>
  \<open>Extraction of pure content\<close>

subsection \<open>Basic Methods\<close>

lemma entails_pre_cong: "A=B \<Longrightarrow> (A\<turnstile>C) = (B\<turnstile>C)" by simp
lemma entails_post_cong: "B=C \<Longrightarrow> (A\<turnstile>B) = (A\<turnstile>C)" by simp

thm conj_entails_mono

lemma sep_drule:
  "A \<turnstile> B \<Longrightarrow> B \<turnstile> Q \<Longrightarrow> A \<turnstile> Q"
  "A \<turnstile> B \<Longrightarrow> B**F \<turnstile> Q \<Longrightarrow> A**F \<turnstile> Q"
  apply (rule entails_trans; assumption)
  using entails_mp entails_trans by blast

lemma sep_rule:
  "A \<turnstile> B \<Longrightarrow> P \<turnstile> A \<Longrightarrow> P \<turnstile> B"
  "A \<turnstile> B \<Longrightarrow> P \<turnstile> A**F \<Longrightarrow> P \<turnstile> B**F"
  apply (rule entails_trans; assumption)
  using entails_mp entails_trans by blast

method_setup sep_drule = \<open>Attrib.thms >> (fn thms => fn ctxt => SIMPLE_METHOD' (let
  val thms = map_product (fn a => try (fn b => a OF [b])) @{thms sep_drule} thms
    |> map_filter I
 in
  Frame_Infer.rotations_tac @{thms entails_pre_cong} ctxt
  THEN' resolve_tac ctxt thms
  THEN' Frame_Infer.simp_a_tac ctxt
 end))\<close>

method_setup sep_rule = \<open>Attrib.thms >> (fn thms => fn ctxt => SIMPLE_METHOD' (let
  val thms = map_product (fn a => try (fn b => a OF [b])) @{thms sep_rule} thms
    |> map_filter I
 in
  Frame_Infer.rotations_tac @{thms entails_post_cong} ctxt
  THEN' resolve_tac ctxt thms
  THEN' Frame_Infer.simp_a_tac ctxt
 end))\<close>

subsection \<open>Utilities\<close>
  lemma fri_red_img_is: "PRECOND (SOLVE_AUTO (k\<in>I)) \<Longrightarrow> is_sep_red (\<Union>*i\<in>I-{k}. P i) \<box> (\<Union>*i\<in>I. P i) (P k)"
    unfolding vcg_tag_defs apply (rule is_sep_redI)
    by (auto simp: conj_entails_mono sep_set_img_remove)

  lemma fri_red_img_si: "PRECOND (SOLVE_AUTO (k\<in>I)) \<Longrightarrow> is_sep_red \<box> (\<Union>*i\<in>I-{k}. P i) (P k) (\<Union>*i\<in>I. P i)"
    unfolding vcg_tag_defs apply (rule is_sep_redI)
    by (smt conj_entails_mono entails_refl sep.add.left_neutral sep.mult.left_commute sep.mult_commute sep_set_img_remove)

  lemma fri_red_img_ss: "PRECOND (SOLVE_AUTO (I\<inter>I' \<noteq> {})) \<Longrightarrow> is_sep_red (\<Union>*i\<in>I-I'. P i) (\<Union>*i\<in>I'-I. P i) (\<Union>*i\<in>I. P i) (\<Union>*i\<in>I'. P i)"
    unfolding vcg_tag_defs apply (rule is_sep_redI)
  proof -
    fix Ps Qs
    assume "I \<inter> I' \<noteq> {}"
    and A: "(\<Union>*i\<in>I - I'. P i) \<and>* Ps \<turnstile> (\<Union>*i\<in>I' - I. P i) \<and>* Qs"

    have DJ: "(I-I') \<inter> (I\<inter>I') = {}" "(I'-I) \<inter> (I\<inter>I') = {}" by auto
    have II: "(I-I') \<union> (I\<inter>I') = I" "(I'-I) \<union> (I\<inter>I') = I'"  by auto

    show "(\<Union>*i\<in>I. P i) \<and>* Ps \<turnstile> (\<Union>*i\<in>I'. P i) \<and>* Qs"
      unfolding sep_set_img_union[OF DJ(1), simplified II]
      unfolding sep_set_img_union[OF DJ(2), simplified II]
      by (smt A conj_entails_mono entails_def semigroup.assoc sep.mult.semigroup_axioms sep.mult_commute)
  qed

  lemmas fri_red_img = fri_red_img_is fri_red_img_si fri_red_img_ss

end


theory TransClosure
  imports "HOL-Lattice.Orders"
begin

lemma transcl_fresh:
    assumes  "\<forall>b .(b,b)\<notin> f\<^sup>+"
        and "a \<notin> Domain f \<union> Range f"
        and "g = f \<union> {(a,a')}"
        and "a \<noteq> a'"
      shows "\<forall>b . (b,b) \<notin> g\<^sup>+"
  using assms
  apply(subgoal_tac "\<forall> c . (c,a)\<notin> f\<^sup>+") defer
   apply (metis Range.intros UnI2 trancl_range)
    apply auto
    using  acyclic_def acyclic_insert rtranclD
    by metis

lemma transcl_fresh_new:
    assumes  "\<forall>b .(b,b)\<notin> f\<^sup>+"
        and "a \<notin> Domain f \<union> Range f"
        and "g = f \<union> {(a,a')}"
        and "a \<noteq> a'"
      shows " (a,a) \<notin> g\<^sup>+"
  using assms
  apply(subgoal_tac "\<forall> c . (c,a)\<notin> f\<^sup>+") defer
   apply (metis Range.intros UnI2 trancl_range)
    apply auto
    using  acyclic_def acyclic_insert rtranclD
    by metis

lemma transcl_fresh1:
    assumes  "\<forall>b . b\<in>Range f \<longrightarrow> (c,b)\<in> f\<^sup>+"
        and "a \<notin> Domain f \<union> Range f"
        and "g = f \<union> {(a,c)}"
        and "a \<noteq> c"
      shows "\<forall>b .  b\<in>Range g \<longrightarrow>  (a,b) \<in> g\<^sup>+"
  using assms
  apply(subgoal_tac "\<forall> c . (c,a)\<notin> f\<^sup>+") defer
   apply (metis Range.intros UnI2 trancl_range)
  apply auto
  using insertI1 sup.cobounded1 trancl.simps trancl_id trancl_mono trans_trancl
  by (smt Range.intros assms(3) insertI1 sup.cobounded1 trancl.simps trancl_id trancl_mono trans_trancl)

lemma transcl_freshdd:
    assumes "\<forall>b .(b,b)\<notin> f\<^sup>+"
        and "a \<notin> Domain f \<union> Range f"
        and "(b,b')\<in>f\<^sup>+"
        and "g = f \<union> {(a,a')}"
        and "a \<noteq> a'"
      shows "(b,b') \<in> g\<^sup>+"
  using assms
  by (meson inf_sup_ord(3) trancl_mono)

lemma transcl_remove_top:
    assumes "\<forall> b. (b,b) \<notin> f\<^sup>+"
        and "\<forall> e. (a,e) \<in> f\<^sup>+"
        and "g = f - {(a,a')}"
        and "(c,d) \<in> f\<^sup>+"
        and "c \<noteq> a"
        and "d \<noteq> a"
      shows "(c,d) \<in> g\<^sup>+"
  using assms
  by blast

lemma transcl_remove_top11:
    assumes "\<forall> b. (b,b) \<notin> f\<^sup>+"
        and "\<forall> e. (a,e) \<in> f\<^sup>+"
        and "g = f - {(a,a')}"
        and "(c,d) \<notin> f\<^sup>+"
        and "c \<noteq> a"
        and "d \<noteq> a"
      shows "(c,d) \<notin> g\<^sup>+"
  using assms
  apply blast
  done

lemma transcl_remove_transitivity:
  assumes "f = {(a,b) | a b . a\<in>p \<and> b = nxt a}"
        and "\<forall> e1 e2 . e1\<in>p \<and> e2\<in>p \<and> e1\<noteq>e2 \<longrightarrow> nxt e1 \<noteq> nxt e2"
        and "p' = p \<union> {n}"
        and "n \<notin> p"
        and "\<forall> b . b\<in>p \<longrightarrow> (t, b)\<in>f\<^sup>+"
        and "(c,d) \<in> f"
        and "(x,y) \<in> f"
        and "(c,y) \<in> f\<^sup>+"
        and "c \<noteq> t"
        and "d \<noteq> t"
        and "c\<in>p"
        and "d\<in>p"
        and "x\<in>p - {c,d}"
        and "y\<in>p - {c,d}"
      shows "(c,x) \<in> f\<^sup>+"
  using assms
  oops

(*lemma transcl_fresh:
    assumes  "\<forall>b .(b,b)\<notin> f\<^sup>+"
        and "a \<notin> Domain f \<union> Range f"
        and "g = f \<union> {(a,a')}"
        and "a \<noteq> a'"
      shows "\<forall>b . (b,b) \<notin> g\<^sup>+"
    proof-
      have a1: "\<forall> c . (c,a)\<notin> f\<^sup>+"
        using assms
        by (metis FieldI2 Field_def  trancl_domain trancl_range)
      show ?thesis
        using assms
        apply auto
        using a1 acyclic_def acyclic_insert rtranclD
      by (metis )

*)

end


(*<*)
theory "Nominal-Utils"
imports Nominal2.Nominal2 "HOL-Library.AList"
begin
(*>*)

chapter \<open>Prelude\<close>
text \<open>Some useful Nominal lemmas. Many of these are from Launchbury.Nominal-Utils.\<close>

section \<open>Lemmas helping with equivariance proofs\<close>

lemma perm_rel_lemma:
  assumes "\<And> \<pi> x y. r (\<pi> \<bullet> x) (\<pi> \<bullet> y) \<Longrightarrow> r x y"
  shows "r (\<pi> \<bullet> x) (\<pi> \<bullet> y) \<longleftrightarrow> r x y" (is "?l \<longleftrightarrow> ?r")
by (metis (full_types) assms permute_minus_cancel(2))

lemma perm_rel_lemma2:
  assumes "\<And> \<pi> x y. r x y \<Longrightarrow> r (\<pi> \<bullet> x) (\<pi> \<bullet> y)"
  shows "r x y \<longleftrightarrow> r (\<pi> \<bullet> x) (\<pi> \<bullet> y)" (is "?l \<longleftrightarrow> ?r")
by (metis (full_types) assms permute_minus_cancel(2))

lemma fun_eqvtI:
  assumes f_eqvt[eqvt]: "(\<And> p x. p \<bullet> (f x) = f (p \<bullet> x))"
  shows "p \<bullet> f = f" by perm_simp rule

lemma eqvt_at_apply:
  assumes "eqvt_at f x"
  shows "(p \<bullet> f) x = f x"
by (metis (opaque_lifting, no_types) assms eqvt_at_def permute_fun_def permute_minus_cancel(1))

lemma eqvt_at_apply':
  assumes "eqvt_at f x"
  shows "p \<bullet> f x = f (p \<bullet> x)"
by (metis (opaque_lifting, no_types) assms eqvt_at_def)

lemma eqvt_at_apply'':
  assumes "eqvt_at f x"
  shows "(p \<bullet> f) (p \<bullet> x) = f (p \<bullet> x)"
by (metis (opaque_lifting, no_types) assms eqvt_at_def permute_fun_def permute_minus_cancel(1))

lemma size_list_eqvt[eqvt]: "p \<bullet> size_list f x = size_list (p \<bullet> f) (p \<bullet> x)"
proof (induction x)
  case (Cons x xs)
  have "f x = p \<bullet> (f x)" by (simp add: permute_pure)
  also have "... = (p \<bullet> f) (p \<bullet> x)" by simp
  with Cons
  show ?case by (auto simp add: permute_pure)
qed simp

section \<open> Freshness via equivariance \<close>

lemma eqvt_fresh_cong1: "(\<And>p x. p \<bullet> (f x) = f (p \<bullet> x)) \<Longrightarrow> a \<sharp> x \<Longrightarrow> a \<sharp> f x "
  apply (rule fresh_fun_eqvt_app[of f])
  apply (rule eqvtI)
  apply (rule eq_reflection)
  apply (rule ext)
  apply (metis permute_fun_def permute_minus_cancel(1))
  apply assumption
  done

lemma eqvt_fresh_cong2:
  assumes eqvt: "(\<And>p x y. p \<bullet> (f x y) = f (p \<bullet> x) (p \<bullet> y))"
  and fresh1: "a \<sharp> x" and fresh2: "a \<sharp> y"
  shows "a \<sharp> f x y"
proof-
  have "eqvt (\<lambda> (x,y). f x y)"
    using eqvt
    apply (- , auto simp add: eqvt_def)
    by (rule ext, auto, metis permute_minus_cancel(1))
  moreover
  have "a \<sharp> (x, y)" using fresh1 fresh2 by auto
  ultimately
  have "a \<sharp> (\<lambda> (x,y). f x y) (x, y)" by (rule fresh_fun_eqvt_app)
  thus ?thesis by simp
qed

lemma eqvt_fresh_star_cong1:
  assumes eqvt: "(\<And>p x. p \<bullet> (f x) = f (p \<bullet> x))"
  and fresh1: "a \<sharp>* x"
  shows "a \<sharp>* f x"
  by (metis fresh_star_def eqvt_fresh_cong1 assms)

lemma eqvt_fresh_star_cong2:
  assumes eqvt: "(\<And>p x y. p \<bullet> (f x y) = f (p \<bullet> x) (p \<bullet> y))"
  and fresh1: "a \<sharp>* x" and fresh2: "a \<sharp>* y"
  shows "a \<sharp>* f x y"
  by (metis fresh_star_def eqvt_fresh_cong2 assms)

lemma eqvt_fresh_cong3:
  assumes eqvt: "(\<And>p x y z. p \<bullet> (f x y z) = f (p \<bullet> x) (p \<bullet> y) (p \<bullet> z))"
  and fresh1: "a \<sharp> x" and fresh2: "a \<sharp> y" and fresh3: "a \<sharp> z"
  shows "a \<sharp> f x y z"
proof-
  have "eqvt (\<lambda> (x,y,z). f x y z)"
    using eqvt
    apply (- , auto simp add: eqvt_def)
    by(rule ext, auto, metis permute_minus_cancel(1))
  moreover
  have "a \<sharp> (x, y, z)" using fresh1 fresh2 fresh3 by auto
  ultimately
  have "a \<sharp> (\<lambda> (x,y,z). f x y z) (x, y, z)" by (rule fresh_fun_eqvt_app)
  thus ?thesis by simp
qed

lemma eqvt_fresh_star_cong3:
  assumes eqvt: "(\<And>p x y z. p \<bullet> (f x y z) = f (p \<bullet> x) (p \<bullet> y) (p \<bullet> z))"
  and fresh1: "a \<sharp>* x" and fresh2: "a \<sharp>* y" and fresh3: "a \<sharp>* z"
  shows "a \<sharp>* f x y z"
  by (metis fresh_star_def eqvt_fresh_cong3 assms)

section \<open> Additional simplification rules \<close>

lemma not_self_fresh[simp]: "atom x \<sharp> x \<longleftrightarrow> False"
  by (metis fresh_at_base(2))

lemma fresh_star_singleton: "{ x } \<sharp>* e \<longleftrightarrow> x \<sharp> e"
  by (simp add: fresh_star_def)

section \<open> Additional equivariance lemmas \<close>

lemma eqvt_cases:
  fixes f x \<pi>
  assumes eqvt: "\<And>x. \<pi> \<bullet> f x = f (\<pi> \<bullet> x)"
  obtains "f x" "f (\<pi> \<bullet> x)" | "\<not> f x " " \<not> f (\<pi> \<bullet> x)"
  using assms[symmetric]
   by (cases "f x") auto

lemma range_eqvt: "\<pi> \<bullet> range Y = range (\<pi> \<bullet> Y)"
  unfolding image_eqvt UNIV_eqvt ..

lemma case_option_eqvt[eqvt]:
  "\<pi> \<bullet> case_option d f x = case_option (\<pi> \<bullet> d) (\<pi> \<bullet> f) (\<pi> \<bullet> x)"
  by(cases x)(simp_all)

lemma supp_option_eqvt:
  "supp (case_option d f x) \<subseteq> supp d \<union> supp f \<union> supp x"
  apply (cases x)
  apply (auto simp add: supp_Some )
  apply (metis (mono_tags) Un_iff subsetCE supp_fun_app)
  done

lemma funpow_eqvt[simp,eqvt]:
  "\<pi> \<bullet> ((f :: 'a \<Rightarrow> 'a::pt) ^^ n) = (\<pi> \<bullet> f) ^^ (\<pi> \<bullet> n)"
 by (induct n,simp, rule ext, simp, perm_simp,simp)

lemma delete_eqvt[eqvt]:
  "\<pi> \<bullet> AList.delete x \<Gamma> = AList.delete (\<pi> \<bullet> x) (\<pi> \<bullet> \<Gamma>)"
by (induct \<Gamma>, auto)

lemma restrict_eqvt[eqvt]:
  "\<pi> \<bullet> AList.restrict S \<Gamma> = AList.restrict (\<pi> \<bullet> S) (\<pi> \<bullet> \<Gamma>)"
unfolding AList.restrict_eq by perm_simp rule

lemma supp_restrict:
  "supp (AList.restrict S \<Gamma>) \<subseteq> supp \<Gamma>"
 by (induction \<Gamma>) (auto simp add: supp_Pair supp_Cons)

lemma clearjunk_eqvt[eqvt]:
  "\<pi> \<bullet> AList.clearjunk \<Gamma> = AList.clearjunk (\<pi> \<bullet> \<Gamma>)"
  by (induction \<Gamma> rule: clearjunk.induct) auto

lemma map_ran_eqvt[eqvt]:
  "\<pi> \<bullet> map_ran f \<Gamma> = map_ran (\<pi> \<bullet> f) (\<pi> \<bullet> \<Gamma>)"
by (induct \<Gamma>, auto)

lemma dom_perm:
  "dom (\<pi> \<bullet> f) = \<pi> \<bullet> (dom f)"
  unfolding dom_def by (perm_simp) (simp)

lemmas dom_perm_rev[simp,eqvt] = dom_perm[symmetric]

lemma ran_perm[simp]:
  "\<pi> \<bullet> (ran f) = ran (\<pi> \<bullet> f)"
  unfolding ran_def by (perm_simp) (simp)

lemma map_add_eqvt[eqvt]:
  "\<pi> \<bullet> (m1 ++ m2) = (\<pi> \<bullet> m1) ++ (\<pi> \<bullet> m2)"
  unfolding map_add_def
  by (perm_simp, rule)

lemma map_of_eqvt[eqvt]:
  "\<pi> \<bullet> map_of l = map_of (\<pi> \<bullet> l)"
  by (induct l, simp add: permute_fun_def,simp,perm_simp,auto)

lemma concat_eqvt[eqvt]: "\<pi> \<bullet> concat l = concat (\<pi> \<bullet> l)"
  by (induction l)(auto simp add: append_eqvt)

lemma tranclp_eqvt[eqvt]: "\<pi> \<bullet> tranclp P v\<^sub>1 v\<^sub>2 = tranclp (\<pi> \<bullet> P) (\<pi> \<bullet> v\<^sub>1) (\<pi> \<bullet> v\<^sub>2)"
  unfolding tranclp_def by perm_simp rule

lemma rtranclp_eqvt[eqvt]: "\<pi> \<bullet> rtranclp P v\<^sub>1 v\<^sub>2 = rtranclp (\<pi> \<bullet> P) (\<pi> \<bullet> v\<^sub>1) (\<pi> \<bullet> v\<^sub>2)"
  unfolding rtranclp_def by perm_simp rule

lemma Set_filter_eqvt[eqvt]: "\<pi> \<bullet> Set.filter P S = Set.filter (\<pi> \<bullet> P) (\<pi> \<bullet> S)"
  unfolding Set.filter_def
  by perm_simp rule

lemma Sigma_eqvt'[eqvt]: "\<pi> \<bullet> Sigma = Sigma"
  apply (rule ext)
  apply (rule ext)
  apply (subst permute_fun_def)
  apply (subst permute_fun_def)
  unfolding Sigma_def
  apply perm_simp
  apply (simp add: permute_self)
  done

lemma override_on_eqvt[eqvt]:
  "\<pi> \<bullet> (override_on m1 m2 S) = override_on (\<pi> \<bullet> m1) (\<pi> \<bullet> m2) (\<pi> \<bullet> S)"
  by (auto simp add: override_on_def )

lemma card_eqvt[eqvt]:
  "\<pi> \<bullet> (card S) = card (\<pi> \<bullet> S)"
by (cases "finite S", induct rule: finite_induct) (auto simp add: card_insert_if mem_permute_iff permute_pure)

(* Helper lemmas provided by Christian Urban *)

lemma Projr_permute:
  assumes a: "\<exists>y. f = Inr y"
  shows "(p \<bullet> (Sum_Type.projr f)) = Sum_Type.projr (p \<bullet> f)"
using a by auto

section \<open> Freshness lemmas \<close>

lemma fresh_list_elem:
  assumes "a \<sharp> \<Gamma>"
  and "e \<in> set \<Gamma>"
  shows "a \<sharp> e"
using assms
by(induct \<Gamma>)(auto simp add: fresh_Cons)

lemma set_not_fresh:
  "x \<in> set L \<Longrightarrow> \<not>(atom x \<sharp> L)"
  by (metis fresh_list_elem not_self_fresh)

lemma pure_fresh_star[simp]: "a \<sharp>* (x :: 'a :: pure)"
  by (simp add: fresh_star_def pure_fresh)

lemma supp_set_mem: "x \<in> set L \<Longrightarrow> supp x \<subseteq> supp L"
  by (induct L) (auto simp add: supp_Cons)

lemma set_supp_mono: "set L \<subseteq> set L2 \<Longrightarrow> supp L \<subseteq> supp L2"
  by (induct L)(auto simp add: supp_Cons supp_Nil dest:supp_set_mem)

lemma fresh_star_at_base:
  fixes x :: "'a :: at_base"
  shows "S \<sharp>* x \<longleftrightarrow> atom x \<notin> S"
  by (metis fresh_at_base(2) fresh_star_def)

section \<open> Freshness and support for subsets of variables \<close>

lemma supp_mono: "finite (B::'a::fs set) \<Longrightarrow> A \<subseteq> B \<Longrightarrow> supp A \<subseteq> supp B"
  by (metis infinite_super subset_Un_eq supp_of_finite_union)

lemma fresh_subset:
  "finite B \<Longrightarrow> x \<sharp> (B :: 'a::at_base set) \<Longrightarrow> A \<subseteq> B \<Longrightarrow> x \<sharp> A"
  by (auto dest:supp_mono simp add: fresh_def)

lemma fresh_star_subset:
  "finite B \<Longrightarrow> x \<sharp>* (B :: 'a::at_base set) \<Longrightarrow> A \<subseteq> B \<Longrightarrow> x \<sharp>* A"
  by (metis fresh_star_def fresh_subset)

lemma fresh_star_set_subset:
  "x \<sharp>* (B :: 'a::at_base list) \<Longrightarrow> set A \<subseteq> set B \<Longrightarrow> x \<sharp>* A"
  by (metis fresh_star_set fresh_star_subset[OF finite_set])

section \<open> The set of free variables of an expression \<close>

definition fv :: "'a::pt \<Rightarrow> 'b::at_base set"
  where "fv e = {v. atom v \<in> supp e}"

lemma fv_eqvt[simp,eqvt]: "\<pi> \<bullet> (fv e) = fv (\<pi> \<bullet> e)"
  unfolding fv_def by simp

lemma fv_Nil[simp]: "fv [] = {}"
  by (auto simp add: fv_def supp_Nil)
lemma fv_Cons[simp]: "fv (x # xs) = fv x \<union> fv xs"
  by (auto simp add: fv_def supp_Cons)
lemma fv_Pair[simp]: "fv (x, y) = fv x \<union> fv y"
  by (auto simp add: fv_def supp_Pair)
lemma fv_append[simp]: "fv (x @ y) = fv x \<union> fv y"
  by (auto simp add: fv_def supp_append)
lemma fv_at_base[simp]: "fv a = {a::'a::at_base}"
  by (auto simp add: fv_def supp_at_base)
lemma fv_pure[simp]: "fv (a::'a::pure) = {}"
  by (auto simp add: fv_def pure_supp)

lemma fv_set_at_base[simp]: "fv (l :: ('a :: at_base) list) = set l"
  by (induction l) auto

lemma flip_not_fv: "a \<notin> fv x \<Longrightarrow> b \<notin> fv x \<Longrightarrow> (a \<leftrightarrow> b) \<bullet> x = x"
  by (metis flip_def fresh_def fv_def mem_Collect_eq swap_fresh_fresh)

lemma fv_not_fresh: "atom x \<sharp> e \<longleftrightarrow> x \<notin> fv e"
  unfolding fv_def fresh_def by blast

lemma fresh_fv: "finite (fv e :: 'a set) \<Longrightarrow>  atom (x :: ('a::at_base)) \<sharp> (fv e :: 'a set) \<longleftrightarrow> atom x \<sharp> e"
  unfolding fv_def fresh_def
  by (auto simp add: supp_finite_set_at_base)

lemma finite_fv[simp]: "finite (fv (e::'a::fs) :: ('b::at_base) set)"
proof-
  have "finite (supp e)" by (metis finite_supp)
  hence "finite (atom -` supp e :: 'b set)"
    apply (rule finite_vimageI)
    apply (rule inj_onI)
    apply (simp)
    done
  moreover
  have "(atom -` supp e  :: 'b set) = fv e"   unfolding fv_def by auto
  ultimately
  show ?thesis by simp
qed

definition fv_list :: "'a::fs \<Rightarrow> 'b::at_base list"
  where "fv_list e = (SOME l. set l = fv e)"

lemma fresh_fv_list[simp]:
  "a \<sharp> (fv_list e :: 'b::at_base list) \<longleftrightarrow> a \<sharp> (fv e :: 'b::at_base set)"
proof-
  have "a \<sharp> (fv_list e :: 'b::at_base list) \<longleftrightarrow> a \<sharp> set (fv_list e :: 'b::at_base list)"
    by (rule fresh_set[symmetric])
  also have "\<dots> \<longleftrightarrow> a \<sharp> (fv e :: 'b::at_base set)" by simp
  finally show ?thesis.
qed

section \<open> Other useful lemmas \<close>

lemma pure_permute_id: "permute p = (\<lambda> x. (x::'a::pure))"
  by rule (simp add: permute_pure)

lemma supp_set_elem_finite:
  assumes "finite S"
  and "(m::'a::fs) \<in> S"
  and "y \<in> supp m"
  shows "y \<in> supp S"
  using assms supp_of_finite_sets
  by auto

lemmas fresh_star_Cons = fresh_star_list(2)

lemma mem_permute_set:
  shows "x \<in> p \<bullet> S \<longleftrightarrow> (- p \<bullet> x) \<in> S"
  by (metis mem_permute_iff permute_minus_cancel(2))

lemma flip_set_both_not_in:
  assumes "x \<notin> S" and "x' \<notin> S"
  shows "((x' \<leftrightarrow> x) \<bullet> S) = S"
  unfolding permute_set_def
  by (auto) (metis assms flip_at_base_simps(3))+

lemma inj_atom: "inj atom" by (metis atom_eq_iff injI)

lemmas image_Int[OF inj_atom, simp]

lemma eqvt_uncurry: "eqvt f \<Longrightarrow> eqvt (case_prod f)"
  unfolding eqvt_def
  by perm_simp simp

lemma supp_fun_app_eqvt2:
  assumes a: "eqvt f"
  shows "supp (f x y) \<subseteq> supp x \<union> supp y"
proof-
  from supp_fun_app_eqvt[OF eqvt_uncurry [OF a]]
  have "supp (case_prod f (x,y)) \<subseteq> supp (x,y)".
  thus ?thesis by (simp add: supp_Pair)
qed

lemma supp_fun_app_eqvt3:
  assumes a: "eqvt f"
  shows "supp (f x y z) \<subseteq> supp x \<union> supp y \<union> supp z"
proof-
  from supp_fun_app_eqvt2[OF eqvt_uncurry [OF a]]
  have "supp (case_prod f (x,y) z) \<subseteq> supp (x,y) \<union> supp z".
  thus ?thesis by (simp add: supp_Pair)
qed

(* Fighting eta-contraction *)
lemma permute_0[simp]: "permute 0 = (\<lambda> x. x)"
  by auto
lemma permute_comp[simp]: "permute x \<circ> permute y = permute (x + y)" by auto

lemma map_permute: "map (permute p) = permute p"
  apply rule
  apply (induct_tac x)
  apply auto
  done

lemma fresh_star_restrictA[intro]: "a \<sharp>* \<Gamma> \<Longrightarrow> a \<sharp>* AList.restrict V \<Gamma>"
  by (induction \<Gamma>) (auto simp add: fresh_star_Cons)

lemma Abs_lst_Nil_eq[simp]: "[[]]lst. (x::'a::fs) = [xs]lst. x' \<longleftrightarrow> (([],x) = (xs, x'))"
  apply rule
  apply (frule Abs_lst_fcb2[where f = "\<lambda> x y _ . (x,y)" and as = "[]" and bs = "xs" and c = "()"])
  apply (auto simp add: fresh_star_def)
  done

lemma Abs_lst_Nil_eq2[simp]: "[xs]lst. (x::'a::fs) = [[]]lst. x' \<longleftrightarrow> ((xs,x) = ([], x'))"
  by (subst eq_commute) auto

lemma prod_cases8 [cases type]:
  obtains (fields) a b c d e f g h where "y = (a, b, c, d, e, f, g,h)"
  by (cases y, case_tac g) blast

lemma prod_induct8 [case_names fields, induct type]:
  "(\<And>a b c d e f g h. P (a, b, c, d, e, f, g, h)) \<Longrightarrow> P x"
  by (cases x) blast

lemma prod_cases9 [cases type]:
  obtains (fields) a b c d e f g h i where "y = (a, b, c, d, e, f, g,h,i)"
  by (cases y, case_tac h) blast

lemma prod_induct9 [case_names fields, induct type]:
  "(\<And>a b c d e f g h i. P (a, b, c, d, e, f, g, h, i)) \<Longrightarrow> P x"
  by (cases x) blast

named_theorems nominal_prod_simps

named_theorems ms_fresh "Facts for helping with freshness proofs"

lemma fresh_prod2[nominal_prod_simps,ms_fresh]: "x \<sharp> (a,b) = (x \<sharp> a \<and> x \<sharp> b )"
  using fresh_def supp_Pair by fastforce

lemma fresh_prod3[nominal_prod_simps,ms_fresh]: "x \<sharp> (a,b,c) = (x \<sharp> a \<and> x \<sharp> b  \<and> x \<sharp> c)"
  using fresh_def supp_Pair by fastforce

lemma fresh_prod4[nominal_prod_simps,ms_fresh]: "x \<sharp> (a,b,c,d) = (x \<sharp> a \<and> x \<sharp> b  \<and> x \<sharp> c  \<and> x \<sharp> d)"
  using fresh_def supp_Pair by fastforce

lemma fresh_prod5[nominal_prod_simps,ms_fresh]: "x \<sharp> (a,b,c,d,e) = (x \<sharp> a \<and> x \<sharp> b  \<and> x \<sharp> c  \<and> x \<sharp> d \<and> x \<sharp> e)"
  using fresh_def supp_Pair by fastforce

lemma fresh_prod6[nominal_prod_simps,ms_fresh]: "x \<sharp> (a,b,c,d,e,f) = (x \<sharp> a \<and> x \<sharp> b  \<and> x \<sharp> c  \<and> x \<sharp> d \<and> x \<sharp> e \<and> x \<sharp> f)"
  using fresh_def supp_Pair by fastforce

lemma fresh_prod7[nominal_prod_simps,ms_fresh]: "x \<sharp> (a,b,c,d,e,f,g) = (x \<sharp> a \<and> x \<sharp> b  \<and> x \<sharp> c  \<and> x \<sharp> d \<and> x \<sharp> e \<and> x \<sharp> f \<and> x \<sharp> g)"
  using fresh_def supp_Pair by fastforce

lemma fresh_prod8[nominal_prod_simps,ms_fresh]: "x \<sharp> (a,b,c,d,e,f,g,h) = (x \<sharp> a \<and> x \<sharp> b  \<and> x \<sharp> c  \<and> x \<sharp> d \<and> x \<sharp> e \<and> x \<sharp> f \<and> x \<sharp> g \<and> x \<sharp> h )"
  using fresh_def supp_Pair by fastforce

lemma fresh_prod9[nominal_prod_simps,ms_fresh]: "x \<sharp> (a,b,c,d,e,f,g,h,i) = (x \<sharp> a \<and> x \<sharp> b  \<and> x \<sharp> c  \<and> x \<sharp> d \<and> x \<sharp> e \<and> x \<sharp> f \<and> x \<sharp> g \<and> x \<sharp> h \<and> x \<sharp> i)"
  using fresh_def supp_Pair by fastforce

lemma fresh_prod10[nominal_prod_simps,ms_fresh]: "x \<sharp> (a,b,c,d,e,f,g,h,i,j) = (x \<sharp> a \<and> x \<sharp> b  \<and> x \<sharp> c  \<and> x \<sharp> d \<and> x \<sharp> e \<and> x \<sharp> f \<and> x \<sharp> g \<and> x \<sharp> h \<and> x \<sharp> i \<and> x \<sharp> j)"
  using fresh_def supp_Pair by fastforce

lemma fresh_prod12[nominal_prod_simps,ms_fresh]: "x \<sharp> (a,b,c,d,e,f,g,h,i,j,k,l) = (x \<sharp> a \<and> x \<sharp> b  \<and> x \<sharp> c  \<and> x \<sharp> d \<and> x \<sharp> e \<and> x \<sharp> f \<and> x \<sharp> g \<and> x \<sharp> h \<and> x \<sharp> i \<and> x \<sharp> j \<and> x \<sharp> k \<and> x \<sharp> l)"
  using fresh_def supp_Pair by fastforce

lemmas fresh_prodN = fresh_Pair fresh_prod3  fresh_prod4  fresh_prod5 fresh_prod6 fresh_prod7 fresh_prod8 fresh_prod9 fresh_prod10 fresh_prod12

lemma fresh_prod2I:
  fixes x and x1 and x2
  assumes "x \<sharp> x1" and "x \<sharp> x2"
  shows "x \<sharp> (x1,x2)" using fresh_prod2 assms by auto

lemma fresh_prod3I:
  fixes x and x1 and x2 and x3
  assumes "x \<sharp> x1" and "x \<sharp> x2" and "x \<sharp> x3"
  shows "x \<sharp> (x1,x2,x3)" using fresh_prod3 assms by auto

lemma fresh_prod4I:
  fixes x and x1 and x2 and x3 and x4
  assumes "x \<sharp> x1" and "x \<sharp> x2" and "x \<sharp> x3" and "x \<sharp> x4"
  shows "x \<sharp> (x1,x2,x3,x4)" using fresh_prod4 assms by auto

lemma fresh_prod5I:
  fixes x and x1 and x2 and x3 and x4 and x5
  assumes "x \<sharp> x1" and "x \<sharp> x2" and "x \<sharp> x3" and "x \<sharp> x4" and "x \<sharp> x5"
  shows "x \<sharp> (x1,x2,x3,x4,x5)" using fresh_prod5 assms by auto

lemma flip_collapse[simp]:
  fixes b1::"'a::pt" and bv1::"'b::at" and bv2::"'b::at"
  assumes "atom bv2 \<sharp> b1" and "atom c \<sharp> (bv1,bv2,b1)" and "bv1 \<noteq> bv2"
  shows "(bv2 \<leftrightarrow> c) \<bullet> (bv1 \<leftrightarrow> bv2) \<bullet> b1 = (bv1 \<leftrightarrow> c) \<bullet> b1"
proof -
  have "c  \<noteq> bv1" and "bv2 \<noteq> bv1" using assms by auto+
  hence "(bv2 \<leftrightarrow> c) + (bv1 \<leftrightarrow> bv2) + (bv2 \<leftrightarrow> c) =  (bv1 \<leftrightarrow> c)" using flip_triple[of c bv1 bv2] flip_commute by metis
  hence "(bv2 \<leftrightarrow> c)  \<bullet> (bv1 \<leftrightarrow> bv2)  \<bullet> (bv2 \<leftrightarrow> c) \<bullet> b1 =  (bv1 \<leftrightarrow> c) \<bullet> b1" using permute_plus by metis
  thus ?thesis using assms flip_fresh_fresh by force
qed

lemma triple_eqvt[simp]:
  "p \<bullet> (x, b,c) = (p \<bullet> x,  p \<bullet> b , p \<bullet> c)"
proof -
  have "(x,b,c) = (x,(b,c))" by simp
  thus ?thesis using Pair_eqvt by simp
qed

lemma lst_fst:
  fixes x::"'a::at" and t1::"'b::fs" and  x'::"'a::at" and t2::"'c::fs"
  assumes " ([[atom x]]lst. (t1,t2) = [[atom x']]lst. (t1',t2'))"
  shows " ([[atom x]]lst. t1 = [[atom x']]lst. t1')"
proof -
  have "(\<forall>c. atom c \<sharp> (t2,t2') \<longrightarrow> atom c \<sharp> (x, x', t1, t1') \<longrightarrow> (x \<leftrightarrow> c) \<bullet> t1 = (x' \<leftrightarrow> c) \<bullet> t1')"
  proof(rule,rule,rule)
    fix c::'a
    assume "atom c \<sharp>  (t2,t2')" and "atom c \<sharp> (x, x', t1, t1')"
    hence "atom c \<sharp> (x, x', (t1,t2), (t1',t2'))"  using fresh_prod2 by simp
    thus  " (x \<leftrightarrow> c) \<bullet> t1 = (x' \<leftrightarrow> c) \<bullet> t1'" using assms Abs1_eq_iff_all(3) Pair_eqvt by simp
  qed
  thus ?thesis using Abs1_eq_iff_all(3)[of x t1 x' t1' "(t2,t2')"] by simp
qed

lemma lst_snd:
  fixes x::"'a::at" and t1::"'b::fs" and  x'::"'a::at" and t2::"'c::fs"
  assumes " ([[atom x]]lst. (t1,t2) = [[atom x']]lst. (t1',t2'))"
  shows " ([[atom x]]lst. t2 = [[atom x']]lst. t2')"
proof -
  have "(\<forall>c. atom c \<sharp> (t1,t1') \<longrightarrow> atom c \<sharp> (x, x', t2, t2') \<longrightarrow> (x \<leftrightarrow> c) \<bullet> t2 = (x' \<leftrightarrow> c) \<bullet> t2')"
  proof(rule,rule,rule)
    fix c::'a
    assume "atom c \<sharp>  (t1,t1')" and "atom c \<sharp> (x, x', t2, t2')"
    hence "atom c \<sharp> (x, x', (t1,t2), (t1',t2'))"  using fresh_prod2 by simp
    thus  " (x \<leftrightarrow> c) \<bullet> t2 = (x' \<leftrightarrow> c) \<bullet> t2'" using assms Abs1_eq_iff_all(3) Pair_eqvt by simp
  qed
  thus ?thesis using Abs1_eq_iff_all(3)[of x t2 x' t2' "(t1,t1')"] by simp
qed

lemma lst_head_cons_pair:
  fixes y1::"'a ::at" and y2::"'a::at" and x1::"'b::fs" and x2::"'b::fs" and xs1::"('b::fs) list" and xs2::"('b::fs) list"
  assumes "[[atom y1]]lst. (x1 # xs1) = [[atom y2]]lst. (x2 # xs2)"
  shows "[[atom y1]]lst. (x1,xs1) = [[atom y2]]lst. (x2,xs2)"
proof(subst  Abs1_eq_iff_all(3)[of y1 "(x1,xs1)"  y2 "(x2,xs2)"],rule,rule,rule)
  fix c::'a
  assume "atom c \<sharp> (x1#xs1,x2#xs2)" and "atom c \<sharp> (y1, y2, (x1, xs1), x2, xs2)"
  thus  "(y1 \<leftrightarrow> c) \<bullet> (x1, xs1) = (y2 \<leftrightarrow> c) \<bullet> (x2, xs2)"  using assms Abs1_eq_iff_all(3) by auto
qed

lemma lst_head_cons_neq_nil:
  fixes y1::"'a ::at" and y2::"'a::at" and x1::"'b::fs" and x2::"'b::fs" and xs1::"('b::fs) list" and xs2::"('b::fs) list"
  assumes "[[atom y1]]lst. (x1 # xs1) = [[atom y2]]lst. (xs2)"
  shows "xs2 \<noteq> []"
proof
  assume as:"xs2 = []"
  thus  False using Abs1_eq_iff(3)[of y1 "x1#xs1" y2 Nil]  assms as by auto
qed

lemma lst_head_cons:
  fixes y1::"'a ::at" and y2::"'a::at" and x1::"'b::fs" and x2::"'b::fs" and xs1::"('b::fs) list" and xs2::"('b::fs) list"
  assumes "[[atom y1]]lst. (x1 # xs1) = [[atom y2]]lst. (x2 # xs2)"
  shows "[[atom y1]]lst. x1  = [[atom y2]]lst. x2" and "[[atom y1]]lst. xs1  = [[atom y2]]lst. xs2"
  using lst_head_cons_pair lst_fst lst_snd assms by metis+

lemma lst_pure:
  fixes x1::"'a ::at" and t1::"'b::pure" and  x2::"'a ::at" and t2::"'b::pure"
  assumes "[[atom x1]]lst. t1 = [[atom x2]]lst. t2"
  shows "t1=t2"
  using assms Abs1_eq_iff_all(3) pure_fresh flip_fresh_fresh
  by (metis Abs1_eq(3) permute_pure)

lemma lst_supp:
 assumes "[[atom x1]]lst. t1 = [[atom x2]]lst. t2"
 shows "supp t1 - {atom x1} = supp t2 - {atom x2}"
proof -
 have "supp ([[atom x1]]lst.t1) = supp ([[atom x2]]lst.t2)" using assms by auto
 thus ?thesis using Abs_finite_supp
   by (metis assms empty_set list.simps(15) supp_lst.simps)
qed

lemma lst_supp_subset:
   assumes "[[atom x1]]lst. t1 = [[atom x2]]lst. t2" and "supp t1 \<subseteq> {atom x1} \<union> B"
   shows "supp t2 \<subseteq> {atom x2} \<union> B"
  using assms lst_supp by fast

lemma projl_inl_eqvt:
  fixes \<pi> :: perm
  shows   "\<pi> \<bullet> (projl (Inl x)) = projl (Inl (\<pi> \<bullet> x))"
unfolding projl_def Inl_eqvt by simp

end