(*  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

subsection \<open>Library\<close>

(* TODO: Move to "Coinductive"? *)
lemma ldrop_Suc_conv_ltl: "ldrop (enat (Suc k)) xs = ltl (ldrop (enat k) xs)"
  by (metis eSuc_enat ldrop_eSuc_conv_ltl)

(* TODO: Move to "Coinductive"? *)
lemma lhd_ldrop':
  assumes "enat k < llength xs"
  shows "lhd (ldrop (enat k) xs) = lnth xs k"
  using assms by (simp add: lhd_ldrop)

(* TODO: Move to "Multiset_More.thy". *)
lemma filter_mset_empty_if_finite_and_filter_set_empty:
  assumes
    "{x \<in> X. P x} = {}" and
    "finite X"
  shows "{#x \<in># mset_set X. P x#} = {#}"
proof -
  have empty_empty: "\<And>Y. set_mset Y = {} \<Longrightarrow> Y = {#}"
    by auto
  from assms have "set_mset {#x \<in># mset_set X. P x#} = {}"
    by auto
  then show ?thesis
    by (rule empty_empty)
qed

(* TODO: Move to "Lazy_List_Chain.thy". *)
lemma inf_chain_ltl_chain: "chain R xs \<Longrightarrow> llength xs = \<infinity> \<Longrightarrow> chain R (ltl xs)"
  unfolding chain.simps[of R xs] llength_eq_infty_conv_lfinite
  by (metis lfinite_code(1) lfinite_ltl llist.sel(3))

(* TODO: Move to "Lazy_List_Chain.thy". *)
lemma inf_chain_ldrop_chain:
  assumes
    chain: "chain R xs" and
    inf: "\<not> lfinite xs"
  shows "chain R (ldrop (enat k) xs)"
proof (induction k)
  case 0
  then show ?case
    using zero_enat_def chain by auto
next
  case (Suc k)
  have "llength (ldrop (enat k) xs) = \<infinity>"
    using inf by (simp add: not_lfinite_llength)
  with Suc have "chain R (ltl (ldrop (enat k) xs))"
    using inf_chain_ltl_chain[of R "(ldrop (enat k) xs)"] by auto
  then show ?case
    using ldrop_Suc_conv_ltl[of k xs] by auto
qed

subsection \<open>Prover\<close>

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))"
  unfolding clss_of_state_def 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[OF deriv_RP empty_Q0_RP]
  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 empty_Q0_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, hide_lams) 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 inf_chain_ldrop_chain by auto
    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_ldrop_chain inf inff by auto
    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 empty_Q0_RP weighted_RP_fair, 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 empty_Q0_RP weighted_RP_fair, simplified lhd_lmap_Sts]
  by simp

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


(*
   Title: The pi-calculus
   Author/Maintainer: Jesper Bengtson (jebe.dk), 2012
*)
theory Weak_Late_Bisim_Pres
  imports Weak_Late_Bisim_SC Weak_Late_Sim_Pres Strong_Late_Bisim_SC
begin

lemma tauPres:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<approx> Q"

  shows "\<tau>.(P) \<approx> \<tau>.(Q)"
proof -
  let ?X = "{(\<tau>.(P), \<tau>.(Q)) | P Q. P \<approx> Q}"
  from assms have "(\<tau>.(P), \<tau>.(Q)) \<in> ?X" by auto
  thus ?thesis
    by(coinduct rule: weakBisimCoinduct)
      (auto simp add: pi.inject intro:  Weak_Late_Sim_Pres.tauPres symmetric)
qed

lemma inputPres:
  fixes P :: pi
  and   Q :: pi
  and   a :: name
  and   x :: name

  assumes PSimQ: "\<forall>y. P[x::=y] \<approx> Q[x::=y]"

  shows "a<x>.P \<approx> a<x>.Q"
proof -
  let ?X = "{(a<x>.P, a<x>.Q) | a x P Q. \<forall>y. P[x::=y] \<approx> Q[x::=y]}"
  {
    fix axP axQ p
    assume "(axP, axQ) \<in> ?X"
    then obtain a x P Q where A: "\<forall>y. P[x::=y] \<approx> Q[x::=y]" and B: "axP = a<x>.P" and C: "axQ = a<x>.Q"
      by auto
    have "\<And>y. ((p::name prm) \<bullet> P)[(p \<bullet> x)::=y] \<approx> (p \<bullet> Q)[(p \<bullet> x)::=y]"
    proof -
      fix y
      from A have "P[x::=(rev p \<bullet> y)] \<approx> Q[x::=(rev p \<bullet> y)]"
        by blast
      hence "(p \<bullet> (P[x::=(rev p \<bullet> y)])) \<approx> p \<bullet> (Q[x::=(rev p \<bullet> y)])"
        by(rule eqvtI)
      thus "(p \<bullet> P)[(p \<bullet> x)::=y] \<approx> (p \<bullet> Q)[(p \<bullet> x)::=y]"
        by(simp add: eqvts pt_pi_rev[OF pt_name_inst, OF at_name_inst])
    qed
    hence "((p::name prm) \<bullet> axP, p \<bullet> axQ) \<in> ?X" using B C
      by auto
  }
  hence "eqvt ?X" by(simp add: eqvt_def)

  from PSimQ have "(a<x>.P, a<x>.Q) \<in> ?X" by auto
  thus ?thesis
  proof(coinduct rule: weakBisimCoinduct)
    case(cSim P Q)
    thus ?case using `eqvt ?X`
      by(force intro: inputPres)
  next
    case(cSym P Q)
    thus ?case
      by(blast dest: symmetric)
  qed
qed

lemma outputPres:
  fixes P :: pi
  and   Q :: pi
  and   a :: name
  and   b :: name

  assumes "P \<approx> Q"

  shows "a{b}.(P) \<approx> a{b}.(Q)"
proof -
  let ?X = "{(a{b}.(P), a{b}.(Q)) | a b P Q. P \<approx> Q}"
  from assms have "(a{b}.(P), a{b}.(Q)) \<in> ?X" by auto
  thus ?thesis
    by(coinduct rule: weakBisimCoinduct)
      (auto simp add: pi.inject intro:  Weak_Late_Sim_Pres.outputPres symmetric)
qed

  shows "<\<nu>x>P \<approx> <\<nu>x>Q"
proof -
  let ?X = "{x. \<exists>P Q. P \<approx> Q \<and> (\<exists>a. x = (<\<nu>a>P, <\<nu>a>Q))}"
  from PBiSimQ have "(<\<nu>x>P, <\<nu>x>Q) \<in> ?X" by blast
  moreover have "\<And>P Q a. P \<leadsto>\<^sup>^<weakBisim> Q \<Longrightarrow> <\<nu>a>P \<leadsto>\<^sup>^<(?X \<union> weakBisim)> <\<nu>a>Q"
  proof -
    fix P Q a
    assume PSimQ: "P \<leadsto>\<^sup>^<weakBisim> Q"
    moreover have "\<And>P Q a. P \<approx> Q \<Longrightarrow> (<\<nu>a>P, <\<nu>a>Q) \<in> ?X \<union> weakBisim" by blast
    moreover have "weakBisim \<subseteq> ?X \<union> weakBisim" by blast
    moreover have "eqvt weakBisim" by(rule eqvt)
    moreover have "eqvt (?X \<union> weakBisim)"
      by(auto simp add: eqvt_def dest: eqvtI)+
    ultimately show "<\<nu>a>P \<leadsto>\<^sup>^<(?X \<union> weakBisim)> <\<nu>a>Q"
      by(rule Weak_Late_Sim_Pres.resPres)
  qed

  ultimately show ?thesis using PBiSimQ
    by(coinduct rule: weakBisimCoinductAux, blast dest: unfoldE)
qed

  assumes "P \<approx> Q"

  shows "[a\<frown>b]P \<approx> [a\<frown>b]Q"
proof -
  let ?X = "{([a\<frown>b]P, [a\<frown>b]Q) | a b P Q. P \<approx> Q}"
  from assms have "([a\<frown>b]P, [a\<frown>b]Q) \<in> ?X" by auto
  thus ?thesis
  proof(coinduct rule: weakBisimCoinduct)
    case(cSim P Q)
    {
      fix P Q a b
      assume "P \<approx> Q"
      hence "P \<leadsto>\<^sup>^<weakBisim> Q" by(rule unfoldE)
      moreover {
        fix P Q a
        assume "P \<approx> Q"
        moreover have "[a\<frown>a]P \<approx> P" by(rule matchId)
        ultimately have "[a\<frown>a]P \<approx> Q" by(blast intro: transitive)
      }
      moreover have "weakBisim \<subseteq> ?X \<union> weakBisim" by blast
      ultimately have "[a\<frown>b]P \<leadsto>\<^sup>^<(?X \<union> weakBisim)> [a\<frown>b]Q"
        by(rule matchPres)
    }
    with `(P, Q) \<in> ?X` show ?case by auto
  next
    case(cSym P Q)
    thus ?case by(auto simp add: pi.inject dest: symmetric)
  qed
qed

lemma mismatchPres:
  fixes P :: pi
  and   Q :: pi
  and   a :: name
  and   b :: name

  assumes "P \<approx> Q"

  shows "[a\<noteq>b]P \<approx> [a\<noteq>b]Q"
proof -
  let ?X = "{([a\<noteq>b]P, [a\<noteq>b]Q) | a b P Q. P \<approx> Q}"
  from assms have "([a\<noteq>b]P, [a\<noteq>b]Q) \<in> ?X" by auto
  thus ?thesis
  proof(coinduct rule: weakBisimCoinduct)
    case(cSim P Q)
    {
      fix P Q a b
      assume "P \<approx> Q"
      hence "P \<leadsto>\<^sup>^<weakBisim> Q" by(rule unfoldE)
      moreover {
        fix P Q a b
        assume "P \<approx> Q" and "(a::name) \<noteq> b"
        note `P \<approx> Q`
        moreover from `a \<noteq> b` have "[a\<noteq>b]P \<approx> P" by(rule mismatchId)
        ultimately have "[a\<noteq>b]P \<approx> Q" by(blast intro: transitive)
      }
      moreover have "weakBisim \<subseteq> ?X \<union> weakBisim" by blast
      ultimately have "[a\<noteq>b]P \<leadsto>\<^sup>^<(?X \<union> weakBisim)> [a\<noteq>b]Q"
        by(rule mismatchPres)
    }
    with `(P, Q) \<in> ?X` show ?case by auto
  next
    case(cSym P Q)
    thus ?case by(auto simp add: pi.inject dest: symmetric)
  qed
qed

lemma parPres:
  fixes P :: pi
  and   Q :: pi
  and   R :: pi

  assumes "P \<approx> Q"

  shows "P \<parallel> R \<approx> Q \<parallel> R"
proof -
  let ?ParSet = "{(resChain lst (P \<parallel> R), resChain lst (Q \<parallel> R)) | lst P Q R. P \<approx> Q}"
  have BC: "\<And>P Q. P \<parallel> Q = resChain [] (P \<parallel> Q)" by auto
  from assms have "(P \<parallel> R, Q \<parallel> R) \<in> ?ParSet" by(blast intro: BC)
  thus ?thesis
  proof(coinduct rule: weakBisimCoinduct)
    case(cSim PR QR)
    {
      fix P Q R lst
      assume "P \<approx> Q"

      from eqvtI have "eqvt (?ParSet \<union> weakBisim)"
        by(auto simp add: eqvt_def, blast)
      moreover have "\<And>P Q a. (P, Q) \<in> ?ParSet \<union> weakBisim \<Longrightarrow> (<\<nu>a>P, <\<nu>a>Q) \<in> ?ParSet \<union> weakBisim"
        by(blast intro: resChain.step[THEN sym] resPres)
      moreover {
        from `P \<approx> Q` have "P \<leadsto>\<^sup>^<weakBisim> Q" by(rule unfoldE)
        moreover note `P \<approx> Q`
        moreover {
          fix P Q R
          assume "P \<approx> Q"
          moreover have "P \<parallel> R = resChain [] (P \<parallel> R)" by simp
          moreover have "Q \<parallel> R = resChain [] (Q \<parallel> R)" by simp
          ultimately have "(P \<parallel> R, Q \<parallel> R) \<in> ?ParSet \<union> weakBisim" by blast
        }
        moreover {
          fix P Q a
          assume A: "(P, Q) \<in> ?ParSet \<union> weakBisim"
          hence "(<\<nu>a>P, <\<nu>a>Q) \<in> ?ParSet \<union> weakBisim" (is "?goal")
            apply(auto intro: resPres)
            by(rule_tac x="a#lst" in exI) auto
        }
        ultimately have "(P \<parallel> R) \<leadsto>\<^sup>^<(?ParSet \<union> weakBisim)> (Q \<parallel> R)" using eqvt `eqvt(?ParSet \<union> weakBisim)`
          by(rule Weak_Late_Sim_Pres.parPres)
      }

      ultimately have "resChain lst (P \<parallel> R) \<leadsto>\<^sup>^<(?ParSet \<union> weakBisim)> resChain lst (Q \<parallel> R)"
        by(rule resChainI)
    }
    with `(PR, QR) \<in> ?ParSet` show ?case by blast
  next
    case(cSym PR QR)
    thus ?case by(auto dest: symmetric)
  qed
qed

  assumes PBisimQ: "P \<approx> Q"

  shows "!P \<approx> !Q"
proof -
  let ?X = "(bangRel weakBisim)"
  let ?Y = "Strong_Late_Bisim.bisim O (bangRel weakBisim) O Strong_Late_Bisim.bisim"

  from eqvt Strong_Late_Bisim.bisimEqvt have eqvtY: "eqvt ?Y" by(blast intro: eqvtBangRel)
  have XsubY: "?X \<subseteq> ?Y" by(auto intro: Strong_Late_Bisim.reflexive)

  have RelStay: "\<And>P Q. (P \<parallel> !P, Q) \<in> ?Y \<Longrightarrow> (!P, Q) \<in> ?Y"
  proof(auto)
    fix P Q R T
    assume PBisimQ: "P \<parallel> !P \<sim> Q"
       and QBRR: "(Q, R) \<in> bangRel weakBisim"
       and RBisimT: "R \<sim> T"
    have "!P \<sim> Q"
    proof -
      have "!P \<sim> P \<parallel> !P" by(rule Strong_Late_Bisim_SC.bangSC)
      thus ?thesis using PBisimQ by(rule Strong_Late_Bisim.transitive)
    qed
    with QBRR RBisimT show "(!P, T) \<in> ?Y" by blast
  qed

  have ParCompose: "\<And>P Q R T. \<lbrakk>P \<approx> Q; (R, T) \<in> ?Y\<rbrakk> \<Longrightarrow> (P \<parallel> R, Q \<parallel> T) \<in> ?Y"
  proof -
    fix P Q R T
    assume PBisimQ: "P \<approx> Q"
       and RYT:     "(R, T) \<in> ?Y"
    thus "(P \<parallel> R, Q \<parallel> T) \<in> ?Y"
    proof(auto)
      fix T' R'
      assume T'BisimT: "T' \<sim> T" and RBisimR': "R \<sim> R'"
         and R'BRT': "(R', T') \<in> bangRel weakBisim"
      have "P \<parallel> R \<sim> P \<parallel> R'"
      proof -
        from RBisimR' have "R \<parallel> P \<sim> R' \<parallel> P" by(rule Strong_Late_Bisim_Pres.parPres)
        moreover have "P \<parallel> R \<sim> R \<parallel> P" and "R' \<parallel> P \<sim> P \<parallel> R'" by(rule Strong_Late_Bisim_SC.parSym)+
        ultimately show ?thesis by(blast intro: Strong_Late_Bisim.transitive)
      qed
      moreover from PBisimQ R'BRT' have "(P \<parallel> R', Q \<parallel> T') \<in> bangRel weakBisim" by(rule BRPar)
      moreover have "Q \<parallel> T' \<sim> Q \<parallel> T"
      proof -
        from T'BisimT have "T' \<parallel> Q \<sim> T \<parallel> Q" by(rule Strong_Late_Bisim_Pres.parPres)
        moreover have "Q \<parallel> T' \<sim> T' \<parallel> Q" and "T \<parallel> Q \<sim> Q \<parallel> T" by(rule Strong_Late_Bisim_SC.parSym)+
        ultimately show ?thesis by(blast intro: Strong_Late_Bisim.transitive)
      qed
      ultimately show ?thesis by blast
    qed
  qed

  have ResCong: "\<And>P Q x. (P, Q) \<in> ?Y \<Longrightarrow> (<\<nu>x>P, <\<nu>x>Q) \<in> ?Y"
    by(auto intro: BRRes Strong_Late_Bisim_Pres.resPres transitive)

  from PBisimQ have "(!P, !Q) \<in> ?X" by(rule BRBang)
  moreover from eqvt have "eqvt (bangRel weakBisim)" by(rule eqvtBangRel)
  ultimately show ?thesis
  proof(coinduct rule: weakBisimTransitiveCoinduct)
    case(cSim P Q)
    from `(P, Q) \<in> ?X`
    show "P \<leadsto>\<^sup>^<?Y> Q"
    proof(induct)
      case(BRBang P Q)
      have "P \<approx> Q" by fact
      moreover hence "P \<leadsto>\<^sup>^<weakBisim> Q" by(blast dest: unfoldE)
      moreover have "\<And>P Q. P \<approx> Q \<Longrightarrow> P \<leadsto>\<^sup>^<weakBisim> Q" by(blast dest: unfoldE)
      moreover from Strong_Late_Bisim.bisimEqvt eqvt have "eqvt ?Y" by(blast intro: eqvtBangRel)

      ultimately show "!P \<leadsto>\<^sup>^<?Y> !Q" using ParCompose ResCong RelStay XsubY
        by(rule_tac Weak_Late_Sim_Pres.bangPres, simp_all)
    next
      case(BRPar P Q R T)
      have PBiSimQ: "P \<approx> Q" by fact
      have RBangRelT: "(R, T) \<in> ?X" by fact
      have RSimT: "R \<leadsto>\<^sup>^<?Y> T" by fact
      moreover from PBiSimQ  have "P \<leadsto>\<^sup>^<weakBisim> Q" by(blast dest: unfoldE)
      moreover from RBangRelT have "(R, T) \<in> ?Y" by(blast intro: Strong_Late_Bisim.reflexive)
      ultimately show "P \<parallel> R \<leadsto>\<^sup>^<?Y> Q \<parallel> T" using ParCompose ResCong eqvt eqvtY `P \<approx> Q`
        by(rule_tac Weak_Late_Sim_Pres.parCompose)
    next
      case(BRRes P Q x)
      have "P \<leadsto>\<^sup>^<?Y> Q" by fact
      thus "<\<nu>x>P \<leadsto>\<^sup>^<?Y> <\<nu>x>Q" using ResCong eqvtY XsubY
        by(rule_tac Weak_Late_Sim_Pres.resPres, simp_all)
    qed
  next
    case(cSym P Q)
    thus ?case by(metis symmetric bangRelSymetric)
  qed
qed

end


(*
    Author:   Benedikt Seidl
    License:  BSD
*)

section \<open>Asymmetric Variant of the Master Theorem\<close>

theory Asymmetric_Master_Theorem
imports
  Advice After
begin

text \<open>This variant of the Master Theorem fixes only a subset @{term Y}
      of @{term \<nu>LTL} subformulas and all conditions depend on the
      index @{term i}. While this does not lead to a simple DRA construction,
      but can be used to build NBAs and LDBAs.\<close>

lemma FG_advice_b1_helper:
  "\<psi> \<in> subfrmlsn \<phi> \<Longrightarrow> suffix i w \<Turnstile>\<^sub>n \<psi> \<Longrightarrow> suffix i w \<Turnstile>\<^sub>n \<psi>[\<F>\<G> \<phi> w]\<^sub>\<mu>"
proof -
  assume "\<psi> \<in> subfrmlsn \<phi>"

  then have "\<F>\<G> \<psi> (suffix i w) \<subseteq> \<F>\<G> \<phi> w"
    using \<F>\<G>_suffix subformulas\<^sub>\<nu>_subset unfolding \<F>\<G>_semantics' by fast

  moreover

  assume "suffix i w \<Turnstile>\<^sub>n \<psi>"

  ultimately show "suffix i w \<Turnstile>\<^sub>n \<psi>[\<F>\<G> \<phi> w]\<^sub>\<mu>"
    using FG_advice_b1 by blast
qed

lemma FG_advice_b2_helper:
  "S \<subseteq> \<G> \<phi> (suffix i w) \<Longrightarrow> i \<le> j \<Longrightarrow> suffix j w \<Turnstile>\<^sub>n \<psi>[S]\<^sub>\<mu> \<Longrightarrow> suffix j w \<Turnstile>\<^sub>n \<psi>"
proof -
  fix i j
  assume "S \<subseteq> \<G> \<phi> (suffix i w)" and "i \<le> j" and "suffix j w \<Turnstile>\<^sub>n \<psi>[S]\<^sub>\<mu>"

  then have "suffix j w \<Turnstile>\<^sub>n \<psi>[S \<inter> subformulas\<^sub>\<nu> \<psi>]\<^sub>\<mu>"
    using FG_advice_inter_subformulas by metis

  moreover

  have "S \<inter> subformulas\<^sub>\<nu> \<psi> \<subseteq> \<G> \<psi> (suffix i w)"
    using `S \<subseteq> \<G> \<phi> (suffix i w)` unfolding \<G>_semantics' by blast
  then have "S \<inter> subformulas\<^sub>\<nu> \<psi> \<subseteq> \<G> \<psi> (suffix j w)"
    using \<G>_suffix \<open>i \<le> j\<close> inf.absorb_iff2 le_Suc_ex by fastforce

  ultimately show "suffix j w \<Turnstile>\<^sub>n \<psi>"
    using FG_advice_b2 by blast
qed

lemma Y_\<G>:
  assumes
    Y_\<nu>: "Y \<subseteq> subformulas\<^sub>\<nu> \<phi>"
  and
    Y_G_1: "\<forall>\<psi>\<^sub>1 \<psi>\<^sub>2. \<psi>\<^sub>1 R\<^sub>n \<psi>\<^sub>2 \<in> Y \<longrightarrow> suffix i w \<Turnstile>\<^sub>n G\<^sub>n (\<psi>\<^sub>2[Y]\<^sub>\<mu>)"
  and
    Y_G_2: "\<forall>\<psi>\<^sub>1 \<psi>\<^sub>2. \<psi>\<^sub>1 W\<^sub>n \<psi>\<^sub>2 \<in> Y \<longrightarrow> suffix i w \<Turnstile>\<^sub>n G\<^sub>n (\<psi>\<^sub>1[Y]\<^sub>\<mu> or\<^sub>n \<psi>\<^sub>2[Y]\<^sub>\<mu>)"
  shows
    "Y \<subseteq> \<G> \<phi> (suffix i w)"
proof -
  \<comment> \<open>Custom induction rule with @{term size} as a partial order\<close>
  note induct = finite_ranking_induct[where f = size]

  have "finite Y"
    using Y_\<nu> finite_subset subformulas\<^sub>\<nu>_finite by auto

  then show ?thesis
    using assms
  proof (induction Y rule: induct)
    case (insert \<psi> S)

    show ?case
    proof (cases "\<psi> \<notin> S")
      assume "\<psi> \<notin> S"

      note FG_advice_insert = FG_advice_insert[OF `\<psi> \<notin> S`]

      {
        \<comment> \<open>Show @{term "S \<subseteq> \<G> \<phi> (suffix i w)"}\<close>

        {
          fix \<psi>\<^sub>1 \<psi>\<^sub>2
          assume "\<psi>\<^sub>1 R\<^sub>n \<psi>\<^sub>2 \<in> S"

          then have "suffix i w \<Turnstile>\<^sub>n G\<^sub>n \<psi>\<^sub>2[insert \<psi> S]\<^sub>\<mu>"
            using insert(5) by blast

          then have "suffix i w \<Turnstile>\<^sub>n G\<^sub>n \<psi>\<^sub>2[S]\<^sub>\<mu>"
            using `\<psi>\<^sub>1 R\<^sub>n \<psi>\<^sub>2 \<in> S` FG_advice_insert insert.hyps(2)
            by fastforce
        }

        moreover

        {
          fix \<psi>\<^sub>1 \<psi>\<^sub>2
          assume "\<psi>\<^sub>1 W\<^sub>n \<psi>\<^sub>2 \<in> S"

          then have "suffix i w \<Turnstile>\<^sub>n G\<^sub>n (\<psi>\<^sub>1[insert \<psi> S]\<^sub>\<mu> or\<^sub>n \<psi>\<^sub>2[insert \<psi> S]\<^sub>\<mu>)"
            using insert(6) by blast

          then have "suffix i w \<Turnstile>\<^sub>n G\<^sub>n (\<psi>\<^sub>1[S]\<^sub>\<mu> or\<^sub>n \<psi>\<^sub>2[S]\<^sub>\<mu>)"
            using `\<psi>\<^sub>1 W\<^sub>n \<psi>\<^sub>2 \<in> S` FG_advice_insert insert.hyps(2)
            by fastforce
        }

        ultimately

        have "S \<subseteq> \<G> \<phi> (suffix i w)"
          using insert.IH insert.prems(1) by blast
      }

      moreover

      {
        \<comment> \<open>Show @{term "\<psi> \<in> \<G> \<phi> (suffix i w)"}\<close>

        have "\<psi> \<in> subformulas\<^sub>\<nu> \<phi>"
          using insert.prems(1) by fast
        then have "suffix i w \<Turnstile>\<^sub>n G\<^sub>n \<psi>"
          using subformulas\<^sub>\<nu>_semantics
        proof (cases \<psi>)
          case (Release_ltln \<psi>\<^sub>1 \<psi>\<^sub>2)

          then have "suffix i w \<Turnstile>\<^sub>n G\<^sub>n \<psi>\<^sub>2[insert \<psi> S]\<^sub>\<mu>"
            using insert.prems(2) by blast
          then have "suffix i w \<Turnstile>\<^sub>n G\<^sub>n \<psi>\<^sub>2[S]\<^sub>\<mu>"
            using Release_ltln FG_advice_insert by simp
          then have "suffix i w \<Turnstile>\<^sub>n G\<^sub>n \<psi>\<^sub>2"
            using FG_advice_b2_helper[OF `S \<subseteq> \<G> \<phi> (suffix i w)`] by auto
          then show ?thesis
            using Release_ltln globally_release
            by blast
        next
          case (WeakUntil_ltln \<psi>\<^sub>1 \<psi>\<^sub>2)

          then have "suffix i w \<Turnstile>\<^sub>n G\<^sub>n (\<psi>\<^sub>1[insert \<psi> S]\<^sub>\<mu> or\<^sub>n \<psi>\<^sub>2[insert \<psi> S]\<^sub>\<mu>)"
            using insert.prems(3) by blast
          then have "suffix i w \<Turnstile>\<^sub>n G\<^sub>n (\<psi>\<^sub>1 or\<^sub>n \<psi>\<^sub>2)[S]\<^sub>\<mu>"
            using WeakUntil_ltln FG_advice_insert by simp
          then have "suffix i w \<Turnstile>\<^sub>n G\<^sub>n (\<psi>\<^sub>1 or\<^sub>n \<psi>\<^sub>2)"
            using FG_advice_b2_helper[OF `S \<subseteq> \<G> \<phi> (suffix i w)`, of _ "\<psi>\<^sub>1 or\<^sub>n \<psi>\<^sub>2"]
            by force
          then show ?thesis
            unfolding WeakUntil_ltln semantics_ltln.simps
            by (metis order_refl suffix_suffix)
        qed fast+

        then have "\<psi> \<in> \<G> \<phi> (suffix i w)"
          unfolding \<G>_semantics using `\<psi> \<in> subformulas\<^sub>\<nu> \<phi>`
          by simp
      }

      ultimately show ?thesis
        by blast
    next
      assume "\<not> \<psi> \<notin> S"
      then have "insert \<psi> S = S"
        by auto
      then show ?thesis
        using insert by simp
    qed
  qed simp
qed

theorem asymmetric_master_theorem_ltr:
  assumes
    "w \<Turnstile>\<^sub>n \<phi>"
  obtains Y and i where
    "Y \<subseteq> subformulas\<^sub>\<nu> \<phi>"
  and
    "suffix i w \<Turnstile>\<^sub>n af \<phi> (prefix i w)[Y]\<^sub>\<mu>"
  and
    "\<forall>\<psi>\<^sub>1 \<psi>\<^sub>2. \<psi>\<^sub>1 R\<^sub>n \<psi>\<^sub>2 \<in> Y \<longrightarrow> suffix i w \<Turnstile>\<^sub>n G\<^sub>n (\<psi>\<^sub>2[Y]\<^sub>\<mu>)"
  and
    "\<forall>\<psi>\<^sub>1 \<psi>\<^sub>2. \<psi>\<^sub>1 W\<^sub>n \<psi>\<^sub>2 \<in> Y \<longrightarrow> suffix i w \<Turnstile>\<^sub>n G\<^sub>n (\<psi>\<^sub>1[Y]\<^sub>\<mu> or\<^sub>n \<psi>\<^sub>2[Y]\<^sub>\<mu>)"
proof
  let ?Y = "\<F>\<G> \<phi> w"

  show "?Y \<subseteq> subformulas\<^sub>\<nu> \<phi>"
    by (rule \<F>\<G>_subformulas\<^sub>\<nu>)
next
  let ?Y = "\<F>\<G> \<phi> w"
  let ?i = "SOME i. ?Y = \<G> \<phi> (suffix i w)"

  have "suffix ?i w \<Turnstile>\<^sub>n af \<phi> (prefix ?i w)"
    using af_ltl_continuation \<open>w \<Turnstile>\<^sub>n \<phi>\<close> by fastforce
  then show "suffix ?i w \<Turnstile>\<^sub>n af \<phi> (prefix ?i w)[?Y]\<^sub>\<mu>"
    by (metis \<F>\<G>_suffix FG_advice_b1 \<F>\<G>_af order_refl)
next
  let ?Y = "\<F>\<G> \<phi> w"
  let ?i = "SOME i. ?Y = \<G> \<phi> (suffix i w)"

  have "\<exists>i. ?Y = \<G> \<phi> (suffix i w)"
    using suffix_\<nu>_stable \<F>\<G>_suffix unfolding \<nu>_stable_def MOST_nat
    by fast
  then have Y_G: "?Y = \<G> \<phi> (suffix ?i w)"
    by (metis (mono_tags, lifting) someI_ex)

  show "\<forall>\<psi>\<^sub>1 \<psi>\<^sub>2. \<psi>\<^sub>1 R\<^sub>n \<psi>\<^sub>2 \<in> ?Y \<longrightarrow> suffix ?i w \<Turnstile>\<^sub>n G\<^sub>n (\<psi>\<^sub>2[?Y]\<^sub>\<mu>)"
  proof safe
    fix \<psi>\<^sub>1 \<psi>\<^sub>2
    assume "\<psi>\<^sub>1 R\<^sub>n \<psi>\<^sub>2 \<in> ?Y"

    then have "suffix ?i w \<Turnstile>\<^sub>n G\<^sub>n (\<psi>\<^sub>1 R\<^sub>n \<psi>\<^sub>2)"
      using Y_G \<G>_semantics' by blast
    then have "suffix ?i w \<Turnstile>\<^sub>n G\<^sub>n \<psi>\<^sub>2"
      by force

    moreover

    have "\<psi>\<^sub>2 \<in> subfrmlsn \<phi>"
      using \<F>\<G>_subfrmlsn `\<psi>\<^sub>1 R\<^sub>n \<psi>\<^sub>2 \<in> ?Y` subfrmlsn_subset by force

    ultimately show "suffix ?i w \<Turnstile>\<^sub>n G\<^sub>n (\<psi>\<^sub>2 [?Y]\<^sub>\<mu>)"
      using FG_advice_b1_helper by fastforce
  qed
next
  let ?Y = "\<F>\<G> \<phi> w"
  let ?i = "SOME i. ?Y = \<G> \<phi> (suffix i w)"

  have "\<exists>i. ?Y = \<G> \<phi> (suffix i w)"
    using suffix_\<nu>_stable \<F>\<G>_suffix unfolding \<nu>_stable_def MOST_nat
    by fast
  then have Y_G: "?Y = \<G> \<phi> (suffix ?i w)"
    by (rule someI_ex)

  show "\<forall>\<psi>\<^sub>1 \<psi>\<^sub>2. \<psi>\<^sub>1 W\<^sub>n \<psi>\<^sub>2 \<in> ?Y \<longrightarrow> suffix ?i w \<Turnstile>\<^sub>n G\<^sub>n (\<psi>\<^sub>1[?Y]\<^sub>\<mu> or\<^sub>n \<psi>\<^sub>2[?Y]\<^sub>\<mu>)"
  proof safe
    fix \<psi>\<^sub>1 \<psi>\<^sub>2
    assume "\<psi>\<^sub>1 W\<^sub>n \<psi>\<^sub>2 \<in> ?Y"

    then have "suffix ?i w \<Turnstile>\<^sub>n G\<^sub>n (\<psi>\<^sub>1 W\<^sub>n \<psi>\<^sub>2)"
      using Y_G \<G>_semantics' by blast
    then have "suffix ?i w \<Turnstile>\<^sub>n G\<^sub>n (\<psi>\<^sub>1 or\<^sub>n \<psi>\<^sub>2)"
      by force

    moreover

    have "\<psi>\<^sub>1 \<in> subfrmlsn \<phi>" and "\<psi>\<^sub>2 \<in> subfrmlsn \<phi>"
      using \<F>\<G>_subfrmlsn `\<psi>\<^sub>1 W\<^sub>n \<psi>\<^sub>2 \<in> ?Y` subfrmlsn_subset by force+

    ultimately show "suffix ?i w \<Turnstile>\<^sub>n G\<^sub>n (\<psi>\<^sub>1[?Y]\<^sub>\<mu> or\<^sub>n \<psi>\<^sub>2[?Y]\<^sub>\<mu>)"
      using FG_advice_b1_helper by fastforce
  qed
qed

theorem asymmetric_master_theorem_rtl:
  assumes
    1: "Y \<subseteq> subformulas\<^sub>\<nu> \<phi>"
  and
    2: "suffix i w \<Turnstile>\<^sub>n af \<phi> (prefix i w)[Y]\<^sub>\<mu>"
  and
    3: "\<forall>\<psi>\<^sub>1 \<psi>\<^sub>2. \<psi>\<^sub>1 R\<^sub>n \<psi>\<^sub>2 \<in> Y \<longrightarrow> suffix i w \<Turnstile>\<^sub>n G\<^sub>n (\<psi>\<^sub>2[Y]\<^sub>\<mu>)"
  and
    4: "\<forall>\<psi>\<^sub>1 \<psi>\<^sub>2. \<psi>\<^sub>1 W\<^sub>n \<psi>\<^sub>2 \<in> Y \<longrightarrow> suffix i w \<Turnstile>\<^sub>n G\<^sub>n (\<psi>\<^sub>1[Y]\<^sub>\<mu> or\<^sub>n \<psi>\<^sub>2[Y]\<^sub>\<mu>)"
  shows
    "w \<Turnstile>\<^sub>n \<phi>"
proof -
  have "suffix i w \<Turnstile>\<^sub>n af \<phi> (prefix i w)"
    by (metis assms Y_\<G> FG_advice_b2 \<G>_af)

  then show "w \<Turnstile>\<^sub>n \<phi>"
    using af_ltl_continuation by force
qed

theorem asymmetric_master_theorem:
  "w \<Turnstile>\<^sub>n \<phi> \<longleftrightarrow>
    (\<exists>i. \<exists>Y \<subseteq> subformulas\<^sub>\<nu> \<phi>.
      suffix i w \<Turnstile>\<^sub>n af \<phi> (prefix i w)[Y]\<^sub>\<mu>
      \<and> (\<forall>\<psi>\<^sub>1 \<psi>\<^sub>2. \<psi>\<^sub>1 R\<^sub>n \<psi>\<^sub>2 \<in> Y \<longrightarrow> suffix i w \<Turnstile>\<^sub>n G\<^sub>n (\<psi>\<^sub>2[Y]\<^sub>\<mu>))
      \<and> (\<forall>\<psi>\<^sub>1 \<psi>\<^sub>2. \<psi>\<^sub>1 W\<^sub>n \<psi>\<^sub>2 \<in> Y \<longrightarrow> suffix i w \<Turnstile>\<^sub>n G\<^sub>n (\<psi>\<^sub>1[Y]\<^sub>\<mu> or\<^sub>n \<psi>\<^sub>2[Y]\<^sub>\<mu>)))"
  by (metis asymmetric_master_theorem_ltr asymmetric_master_theorem_rtl)

end


theory LundfallErfurtEx09
imports QMLS5U Main Temp
begin
section\<open>Exercise 2\<close>

(*S5 is axiom M together with axiom V*)

theorem M:
  shows "\<lfloor>\<^bold>\<box>p\<^bold>\<rightarrow>p\<rfloor>"
  by simp

theorem V:
  shows "\<lfloor>\<^bold>\<forall>\<phi>. \<^bold>\<diamond>\<phi> \<^bold>\<rightarrow> \<^bold>\<box>\<^bold>\<diamond>\<phi>\<rfloor>"
  by simp

  (*Positive property*)
  consts Pp :: "(\<mu> \<Rightarrow> \<sigma>) \<Rightarrow> \<sigma>"

  (* A God-like being possesses all positive properties. *)
  definition God :: "\<mu> \<Rightarrow> \<sigma>" where "God = (\<lambda>x. \<^bold>\<forall>(\<lambda>\<Phi>. Pp \<Phi> \<^bold>\<rightarrow> \<Phi> x))"

  (* An essence of an individual is a property possessed by it
     and necessarily implying any of its properties *)
  definition ess :: "(\<mu> \<Rightarrow> \<sigma>) \<Rightarrow> \<mu> \<Rightarrow> \<sigma>" (infixr "ess" 85) where
    "\<Phi> ess x = \<Phi> x \<^bold>\<and> (\<^bold>\<forall>\<Psi>. \<Psi> x \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>y. \<Phi> y \<^bold>\<rightarrow> \<Psi> y))"

  (* Necessary existence of an individual is the necessary
     exemplification of all its essences. *)
  definition NE :: "\<mu> \<Rightarrow> \<sigma>" where "NE = (\<lambda>x. \<^bold>\<forall>\<Phi>. \<Phi> ess x \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<exists> \<Phi>))"

  axiomatization where
    (* Either a property or its negation is positive, but not both. *)
    A1a: "\<lfloor>\<^bold>\<forall>\<Phi>. Pp(\<^sup>\<not>\<Phi>) \<^bold>\<rightarrow> \<^bold>\<not>(Pp \<Phi>)\<rfloor>" and
    A1b: "\<lfloor>\<^bold>\<forall>\<Phi>. \<^bold>\<not>(Pp \<Phi>) \<^bold>\<rightarrow> Pp (\<^sup>\<not>\<Phi>)\<rfloor>" and

    (* A property necessarily implied by a positive property is positive. *)
    A2:  "\<lfloor>\<^bold>\<forall>\<Phi>. \<^bold>\<forall>\<Psi>. (Pp \<Phi> \<^bold>\<and> \<^bold>\<box> (\<^bold>\<forall>x. \<Phi> x \<^bold>\<rightarrow> \<Psi> x)) \<^bold>\<rightarrow> Pp \<Psi>\<rfloor>"
  axiomatization where A3:  "\<lfloor>Pp God\<rfloor>"
  axiomatization where A4:  "\<lfloor>\<^bold>\<forall>\<Phi>. Pp \<Phi> \<^bold>\<rightarrow> \<^bold>\<box>(Pp \<Phi>)\<rfloor>"
  axiomatization where A5:  "\<lfloor>Pp NE\<rfloor>"

theorem god:
  shows "\<lfloor>\<^bold>\<box>(\<^bold>\<exists> God)\<rfloor>"
  by (metis A1a A1b A2 A3 A4 A5 God_def NE_def ess_def)

subsection\<open>d\<close>
text \<open>With this formalization, there is no difference between a proposition being globally valid
and it being necessarily true. In fact, for any world w, we have "\<lfloor>P\<rfloor> = \emph{\box}P(w)"\<close>

section\<open>Exercise 3\<close>
subsection\<open>(a)\<close>
theorem "KforG":
assumes "*\<lfloor> G (\<Psi> *\<rightarrow> \<Phi>) \<rfloor>*"
shows "*\<lfloor> G \<Psi> *\<rightarrow> G \<Phi> \<rfloor>*"
  by (simp add: assms)

theorem "KforH":
assumes "*\<lfloor> H(\<Psi> *\<rightarrow> \<Phi>) \<rfloor>*"
shows "*\<lfloor> H \<Psi> *\<rightarrow> H \<Phi> \<rfloor>*"
  by (simp add: assms)

theorem "SymI":
shows "*\<lfloor> \<Psi> *\<rightarrow>  G (P \<Psi>) \<rfloor>*"
  by auto

theorem "SymII":
shows "*\<lfloor> \<Psi> *\<rightarrow>  H (F \<Psi>) \<rfloor>*"
 by auto

theorem TRAN:
  assumes Kt_sem
  shows "*\<lfloor>G \<Psi> *\<rightarrow> G(G \<Psi>)\<rfloor>*"
  using assms by blast

theorem NOEND:
  assumes Kt_sem
  shows "*\<lfloor> G \<Psi> *\<rightarrow> F \<Psi>\<rfloor>*"
  using assms by blast

theorem NOBEG:
  assumes Kt_sem
  shows "*\<lfloor> H \<Psi> *\<rightarrow> P \<Psi>\<rfloor>*"
  using assms by blast

theorem LIN:
  assumes "Kt_sem"
  shows "*\<lfloor> (P (F \<Psi>) *\<or> F (P \<Psi>)) *\<rightarrow> (P \<Psi>) *\<or> \<Psi> *\<or> (F \<Psi>) \<rfloor>*"
  using assms by blast

subsection\<open>(c)\<close>
consts dead :: "\<mu>\<mu> \<Rightarrow> \<sigma>\<sigma>"
theorem deadness:
  assumes "Kt_sem \<and> *\<lfloor> *\<forall> entity.  (dead(entity) *\<rightarrow> G dead(entity)) *\<and> F dead(entity) *\<and> (F *\<not> dead(entity) *\<or> P *\<not> dead(entity) *\<or> *\<not> dead(entity)) \<rfloor>*"
  shows "*\<lfloor> *\<forall> entity. P (H *\<not> dead(entity)) \<rfloor>*"
  by (metis assms)

end


theory RGToolkit
imports VDMToolkit
begin

(*================================================================*)

(* TODO:
1. generalise op with a ('a \<Rightarrow> 'a) list?
2. generalise it to have I/O?
3. how to 'inherit' the type 'a so that we can
   have the fixes across different locales under same type?
*)

class VDM =
  fixes st_inv :: "'a \<Rightarrow> \<bool>"
  assumes st_valid: "st_inv s"

class Op = VDM +
  fixes pre :: "('a::VDM) \<Rightarrow> \<bool>"
  and   post:: "('a::VDM) \<Rightarrow> 'a \<Rightarrow> \<bool>"

class Op_VCG = Op +
 assumes t_op_fsb: "\<forall> s . pre s \<longrightarrow> (\<exists> s' . post s s')"

class RG = Op +
fixes  rely:: "('a::VDM) \<Rightarrow> 'a \<Rightarrow> \<bool>"
  and  guar:: "('a::VDM) \<Rightarrow> 'a \<Rightarrow> \<bool>"
begin

subclass VDM ..
end

class RG_closure = RG +
assumes
    t_refl_rely : "\<forall> s . rely s s"
and t_refl_guar : "\<forall> s . guar s s"
and t_trans_rely: "\<forall> s t u. rely s t \<and> rely t u \<longrightarrow> rely s u"
and t_trans_guar: "\<forall> s t u. guar s t \<and> guar t u \<longrightarrow> guar s u"

class RG_coherence = RG +
assumes
     t_coherence: "\<forall> s s' . guar s s' \<longrightarrow> rely s s'"

inductive spec_comp  :: "(('a::VDM) \<Rightarrow> 'a \<Rightarrow> \<bool>) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> \<bool>) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> \<bool>)"  (infixr ";;" 75)
  for P :: "('a \<Rightarrow> 'a \<Rightarrow> \<bool>)"
  and Q :: "('a \<Rightarrow> 'a \<Rightarrow> \<bool>)"
where relcompI [intro]: "P s s0 \<Longrightarrow> Q s0 s' \<Longrightarrow> (P ;; Q) s s'"

inductive_cases spec_compE: "(P ;; Q) s s'"

definition
  spec_comp2:: "('a \<Rightarrow> 'a \<Rightarrow> \<bool>) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> \<bool>) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> \<bool>)" (infixl ";:" 55)
where
  "(P ;: Q) \<equiv> \<lambda> s s' . (\<exists> s0 . (P s s0) \<and> (Q s0 s'))"

lemma l_spec_comp_eq: "(P ;; Q) = (P ;: Q)"
apply rule+
unfolding spec_comp2_def
 apply safe
  apply (erule spec_compE, blast)
  by (simp add: relcompI)

class RG_stability = RG +
assumes
     t_pre_rely : "\<forall> s s' . pre s \<and> (rely s s') \<longrightarrow> pre s'"
and  t_rely_post: "\<forall> s s' . pre s \<and> (rely ;; post) s s' \<longrightarrow> post s s'"
and  t_post_rely: "\<forall> s s' . (post ;; rely) s s' \<longrightarrow> post s s'"

class RG_feasibility = RG +
assumes
        t_rg_fsb: "\<forall> s . pre s \<longrightarrow> (\<exists>s' . post s s' \<and> guar s s')"

class RG_VCG = Op_VCG + RG_closure + RG_stability + RG_feasibility (* RG_coherence *)
begin
subclass VDM ..

lemma False nitpick [show_all] oops
end

locale Silly =
   assumes "(x::nat) \<noteq> x"
begin
lemma "False" nitpick [show_all] oops
end

end


theory Proto_Sepref_Borrow
imports Sepref
begin

  (* Simple-Minded borrowing for sepref.

    Idea: When we can prove that we have not changed an object abstractly,
      and its concrete value is still the same, we can reinstantiate it
      after it has been invalidated.

  *)

  text \<open>Operation to reinstantiate dst, by moving source.
    Implementations will also require a proof that the concrete objects are equal!
  \<close>
  definition "unborrow src dst \<equiv> doN {ASSERT (src=dst); RETURN ()}"
  sepref_register unborrow

  lemma unborrow_correct[refine_vcg]: "s=d \<Longrightarrow> unborrow s d \<le> SPEC (\<lambda>r. r=())"
    unfolding unborrow_def by auto

  lemma unborrow_rule[sepref_comb_rules]:
    assumes FRAME: "\<Gamma> \<turnstile> hn_ctxt R src srci ** hn_invalid R dst dsti ** F"
    assumes [simp]: "vassn_tag \<Gamma> \<Longrightarrow> srci = dsti"
    shows "hn_refine \<Gamma> (return ()) (hn_invalid R src srci ** hn_ctxt R dst dsti ** F) unit_assn (unborrow$src$dst)"
    apply (rule hn_refine_vassn_tagI)
    apply (rule hn_refine_cons_pre[OF FRAME])
    apply (rule hn_refineI)
    unfolding unborrow_def
    apply (simp add: refine_pw_simps)
    unfolding hn_ctxt_def invalid_assn_def pure_def
    by vcg'

  lemma unborrow_nofail[refine_pw_simps]: "nofail (unborrow a b) \<longleftrightarrow> a=b" by (auto simp: unborrow_def refine_pw_simps)

  text \<open>Assertion that adds constraint on concrete value. Used to carry through concrete equalities.\<close>
  definition "cnc_assn \<phi> A a c \<equiv> \<up>(\<phi> c) ** A a c"

  lemma norm_ceq_assn[named_ss sepref_frame_normrel]: "hn_ctxt (cnc_assn \<phi> A) a c = (\<up>(\<phi> c) ** hn_ctxt A a c)"
    unfolding hn_ctxt_def cnc_assn_def by simp

  lemma cnc_assn_prod_conv[named_ss sepref_frame_normrel]:
    shows "\<And>A B \<phi>. A \<times>\<^sub>a cnc_assn \<phi> B = cnc_assn (\<phi> o snd) (A\<times>\<^sub>aB)"
      and "\<And>A B \<phi>. cnc_assn \<phi> A \<times>\<^sub>a B = cnc_assn (\<phi> o fst) (A\<times>\<^sub>aB)"
    unfolding cnc_assn_def
    by (auto simp: sep_algebra_simps fun_eq_iff)

  text \<open>Rule to prove a-posteriori constraint (Only useful for simple programs.
    TODO: More partial Hoare-triples would make this more useful, e.g.,
      we could assume assertions, preconditions, and even termination!
  )\<close>
  lemma hnr_ceq_assnI:
    assumes HNR: "hn_refine \<Gamma> c \<Gamma>' R a"
    assumes HT: "llvm_htriple \<Gamma> c (\<lambda>x'. \<up>(\<phi> x') ** sep_true)"
    shows "hn_refine \<Gamma> c \<Gamma>' (cnc_assn \<phi> R) a"
  proof (rule hn_refine_nofailI)
    assume NF: "nofail a"

    show ?thesis
      apply (rule hn_refineI)
      apply (rule cons_post_rule)
      apply (rule htriple_conj_pure[OF HNR[THEN hn_refineD[OF _ NF]] HT])
      apply (auto simp: sep_algebra_simps pred_lift_extract_simps cnc_assn_def)
      done

  qed

end


theory my_theory
imports Main
begin

thm impI

lemma trivial: "A \<longrightarrow> A"
apply (rule_tac impI)
apply assumption
done (* of lemma proof *)

thm trivial

lemma trivial2: "A \<longrightarrow> A"
proof (rule_tac impI)
  assume H1: "A"
  from H1
  show "A"
    by (rule_tac H1)
qed

end (* of theory file *)


theory Debranching
imports
  BranchingAssemblyLanguage
  "../Assembly/AssemblyLanguage"
  "../Utilities/Iterate"
  "../Utilities/FiniteMap"
begin

fun branch_instr_convert :: "code_label\<^sub>2 set \<Rightarrow> b_assembly list \<Rightarrow> code_label\<^sub>2 \<Rightarrow>
    assembly list \<times> code_label\<^sub>2 \<times> (code_label\<^sub>2 \<rightharpoonup> assembly list \<times> code_label\<^sub>2)" where
  "branch_instr_convert ss [] s = ([], s, empty)"
| "branch_instr_convert ss (ABAssm x # \<pi>) s = (
    let (\<pi>', s', \<Pi>) = branch_instr_convert ss \<pi> s
    in (AAssm x # \<pi>', s', \<Pi>))"
| "branch_instr_convert ss (CBAssm dst cmp # \<pi>) s = (
    let (\<pi>', s', \<Pi>) = branch_instr_convert ss \<pi> s
    in (CAssm dst cmp # \<pi>', s', \<Pi>))"
| "branch_instr_convert ss (IBAssm jmp \<pi>\<^sub>t \<pi>\<^sub>f # \<pi>) s = (
    let s\<^sub>e = new_label\<^sub>2 ss
    in let (\<pi>', s', \<Pi>\<^sub>1) = branch_instr_convert (ss \<union> {s\<^sub>e}) \<pi> s
    in let (\<pi>\<^sub>t', s\<^sub>t, \<Pi>\<^sub>2) = branch_instr_convert (ss \<union> dom \<Pi>\<^sub>1 \<union> {s\<^sub>e}) \<pi>\<^sub>t s\<^sub>e
    in let (\<pi>\<^sub>f', s\<^sub>f, \<Pi>\<^sub>3) = branch_instr_convert (ss \<union> dom \<Pi>\<^sub>1 \<union> dom \<Pi>\<^sub>2 \<union> {s\<^sub>e}) \<pi>\<^sub>f s\<^sub>e
    in (JAssm jmp s\<^sub>t # \<pi>\<^sub>f', s\<^sub>f, \<Pi>\<^sub>1 ++ \<Pi>\<^sub>2 ++ \<Pi>\<^sub>3 ++ [s\<^sub>t \<mapsto> (\<pi>\<^sub>t', s\<^sub>t), s\<^sub>e \<mapsto> (\<pi>', s')]))"
| "branch_instr_convert ss (JBAssm s' # \<pi>) s = ([], s', empty)"
| "branch_instr_convert ss (PBAssm # \<pi>) s = (
    let (\<pi>', s', \<Pi>) = branch_instr_convert ss \<pi> s
    in (PAssm # \<pi>', s', \<Pi>))"

fun block_convert :: "code_label\<^sub>2 set \<Rightarrow> code_label\<^sub>2 \<times> b_assembly list \<times> code_label\<^sub>2 \<Rightarrow>
    assembly_program \<Rightarrow> assembly_program" where
  "block_convert ss (s, \<pi>, s') \<Pi> = (
    let (\<pi>', s'', \<Pi>') = branch_instr_convert (ss \<union> dom \<Pi>) \<pi> s'
    in \<Pi>'(s \<mapsto> (\<pi>', s'')))"

definition debranch :: "b_assembly_program \<Rightarrow> assembly_program" where
  "debranch \<Pi> = finite_map_fold (block_convert (dom \<Pi>)) empty \<Pi>"

function remove_continuations :: "assembly list \<Rightarrow> code_label\<^sub>2 \<Rightarrow> assembly_program \<Rightarrow>
    (assembly list \<times> code_label\<^sub>2)" where
  "\<not> finite (dom \<Pi>) \<Longrightarrow> remove_continuations \<pi> s \<Pi> = (\<pi>, s)"
| "finite (dom \<Pi>) \<Longrightarrow> remove_continuations \<pi> s \<Pi> = (case \<Pi> s of
        Some (\<pi>', s') \<Rightarrow> remove_continuations (\<pi> @ \<pi>') s' (\<Pi>(s := None))
      | None \<Rightarrow> (\<pi>, s))"
  by atomize_elim auto
termination
  by (relation "measure (card o dom o snd o snd)") (auto, meson card_Diff1_less domI)

fun state_convert :: "code_label\<^sub>2 set \<Rightarrow> b_assembly_state \<Rightarrow> assembly_state" where
  "state_convert ss (\<mu>, a, d, \<pi>, s, \<omega>) = (
    let (\<pi>', s', \<Pi>') = branch_instr_convert ss \<pi> s
    in let (\<pi>'', s'') = remove_continuations \<pi>' s' \<Pi>'
    in (\<mu>, a, d, \<pi>'', s'', \<omega>))"

(* conversion correctness *)

lemma finite_block_convert: "finite (dom \<Pi>) \<Longrightarrow> finite ss \<Longrightarrow>
    finite (dom (block_convert ss \<pi> \<Pi>))"
  by (cases \<pi>) (auto split: prod.splits)

lemma [simp]: "finite ss \<Longrightarrow> ss \<supseteq> dom \<Pi> \<Longrightarrow>
    finite (dom (finite_map_fold (block_convert ss) empty \<Pi>))"
  proof (induction "block_convert ss" "empty :: code_label\<^sub>2 \<Rightarrow> (assembly list \<times> code_label\<^sub>2) option" \<Pi>
         rule: finite_map_fold.induct)
  case 1
    thus ?case by (metis finite_subset)
  next case 2
    thus ?case by simp
  next case (3 \<Pi>)
    let ?x = "SOME x. x \<in> dom \<Pi>"
    let ?ih = "finite_map_fold (block_convert ss) empty (\<Pi>(?x := None))"
    from 3 have "finite (dom ?ih)" by auto
    with finite_block_convert 3 have "finite (dom (block_convert ss (?x, the (\<Pi> ?x)) ?ih))" by simp
    with 3 show ?case by (simp add: Let_def)
  qed

lemma [simp]: "finite (dom \<Pi>) \<Longrightarrow> finite (dom (debranch \<Pi>))"
  by (simp add: debranch_def)

lemma [simp]: "remove_continuations \<pi> s \<Pi> = (\<pi>', s') \<Longrightarrow>
    remove_continuations (\<iota> # \<pi>) s \<Pi> = (\<iota> # \<pi>', s')"
  proof (induction \<pi> s \<Pi> rule: remove_continuations.induct)
  case 1
    thus ?case by simp
  next case (2 \<Pi> \<pi> s)
    thus ?case
      proof (cases "\<Pi> s")
      case (Some ps)
        with 2 show ?thesis by (cases ps) fastforce
      next case None
        with 2 show ?thesis by simp
      qed
  qed

lemma [simp]: "remove_continuations \<pi> s \<Pi> = (\<pi>', s') \<Longrightarrow>
    remove_continuations (\<pi>\<^sub>2 @ \<pi>) s \<Pi> = (\<pi>\<^sub>2 @ \<pi>', s')"
  proof (induction \<pi> s \<Pi> rule: remove_continuations.induct)
  case 1
    thus ?case by simp
  next case (2 \<Pi> \<pi> s)
    thus ?case
      proof (cases "\<Pi> s")
      case (Some ps)
        with 2 show ?thesis by (cases ps) fastforce
      next case None
        with 2 show ?thesis by simp
      qed
  qed

lemma [simp]: "finite ss \<Longrightarrow> ss \<supseteq> dom \<Pi> \<Longrightarrow> \<Pi> s = Some (\<pi>\<^sub>B, s') \<Longrightarrow>
  branch_instr_convert ss \<pi>\<^sub>B s' = (\<pi>\<^sub>A, s'', \<Pi>') \<Longrightarrow>
    remove_continuations \<pi>\<^sub>A s'' \<Pi>' = (\<pi>\<^sub>A', s''') \<Longrightarrow>
      finite_map_fold (block_convert ss) empty \<Pi> s = Some (\<pi>\<^sub>A', s''')"
  proof (induction "block_convert ss" "empty :: code_label\<^sub>2 \<Rightarrow> (assembly list \<times> code_label\<^sub>2) option" \<Pi>
         rule: finite_map_fold.induct)
  case 1
    thus ?case by (metis finite_subset)
  next case 2
    hence False by simp
    thus ?case by simp
  next case (3 \<Pi>)
    let ?x = "SOME x. x \<in> dom \<Pi>"
    let ?ih = "finite_map_fold (block_convert ss) Map.empty (\<Pi>(?x := None))"
    show ?case
      proof (cases "s = ?x")
      case True
        from 3 have "finite (dom \<Pi>)" by simp
        from 3 have "card (dom \<Pi>) \<noteq> 0" by simp
        from 3 have "
          finite ss \<Longrightarrow>
          dom (\<Pi>(?x := None)) \<subseteq> ss \<Longrightarrow>
          (\<Pi>(?x := None)) s = Some (\<pi>\<^sub>B, s') \<Longrightarrow>
          branch_instr_convert (dom (\<Pi>(?x := None))) \<pi>\<^sub>B s' = (\<pi>\<^sub>A, s'', \<Pi>') \<Longrightarrow>
          remove_continuations \<pi>\<^sub>A s'' \<Pi>' = (\<pi>\<^sub>A', s''') \<Longrightarrow> ?ih s = Some (\<pi>\<^sub>A', s''')" by simp
        from 3 have "finite ss" by simp
        from 3 have "dom \<Pi> \<subseteq> ss" by simp
        from 3 have "\<Pi> s = Some (\<pi>\<^sub>B, s')" by simp
        from 3 have "branch_instr_convert ss \<pi>\<^sub>B s' = (\<pi>\<^sub>A, s'', \<Pi>')" by simp
        from 3 have "remove_continuations \<pi>\<^sub>A s'' \<Pi>' = (\<pi>\<^sub>A', s''')" by simp

        have "(let (\<pi>', s'', \<Pi>') = branch_instr_convert (ss \<union> dom ?ih) \<pi>\<^sub>B s' in \<Pi>'(s \<mapsto> (\<pi>', s''))) s = Some (\<pi>\<^sub>A', s''')" by simp
        with 3 have "block_convert ss (s, the (\<Pi> s)) ?ih s = Some (\<pi>\<^sub>A', s''')" by simp
        with True have "block_convert ss (?x, the (\<Pi> ?x)) ?ih s = Some (\<pi>\<^sub>A', s''')" by simp
        with 3 show ?thesis by (simp add: Let_def)
      next case False
        from 3 have "finite (dom \<Pi>)" by simp
        from 3 have "card (dom \<Pi>) \<noteq> 0" by simp
        from 3 have "
          finite ss \<Longrightarrow>
          dom (\<Pi>(?x := None)) \<subseteq> ss \<Longrightarrow>
          (\<Pi>(?x := None)) s = Some (\<pi>\<^sub>B, s') \<Longrightarrow>
          branch_instr_convert (dom (\<Pi>(?x := None))) \<pi>\<^sub>B s' = (\<pi>\<^sub>A, s'', \<Pi>') \<Longrightarrow>
          remove_continuations \<pi>\<^sub>A s'' \<Pi>' = (\<pi>\<^sub>A', s''') \<Longrightarrow> ?ih s = Some (\<pi>\<^sub>A', s''')" by simp
        from 3 have "finite ss" by simp
        from 3 have "dom \<Pi> \<subseteq> ss" by simp
        from 3 have "\<Pi> s = Some (\<pi>\<^sub>B, s')" by simp
        from 3 have "branch_instr_convert ss \<pi>\<^sub>B s' = (\<pi>\<^sub>A, s'', \<Pi>')" by simp
        from 3 have "remove_continuations \<pi>\<^sub>A s'' \<Pi>' = (\<pi>\<^sub>A', s''')" by simp

    have "block_convert ss (s, \<pi>, s') ?ih = (
        let (\<pi>', s'', \<Pi>') = branch_instr_convert (ss \<union> dom ?ih) \<pi> s'
        in \<Pi>'(s \<mapsto> (\<pi>', s'')))" by simp

        have "block_convert ss (?x, the (\<Pi> ?x)) ?ih s = Some (\<pi>\<^sub>A', s''')" by simp
        with 3 show ?thesis by (simp add: Let_def)
      qed
  qed

lemma [simp]: "finite (dom \<Pi>) \<Longrightarrow>  \<Pi> s = Some (\<pi>\<^sub>B, s') \<Longrightarrow>
  branch_instr_convert (dom \<Pi>) \<pi>\<^sub>B s' = (\<pi>\<^sub>A, s'', \<Pi>') \<Longrightarrow>
    remove_continuations \<pi>\<^sub>A s'' \<Pi>' = (\<pi>\<^sub>A', s''') \<Longrightarrow> debranch \<Pi> s = Some (\<pi>\<^sub>A', s''')"
  by (simp add: debranch_def)

lemma [simp]: "assembly_output (state_convert ss \<Sigma>\<^sub>B) = b_assembly_output \<Sigma>\<^sub>B"
  by (induction \<Sigma>\<^sub>B rule: b_assembly_output.induct) (simp split: prod.splits)

lemma debranch_step: "finite (dom \<Pi>) \<Longrightarrow> eval_b_assembly \<Pi> \<Sigma>\<^sub>B = Some \<Sigma>\<^sub>B' \<Longrightarrow>
    eval_assembly (debranch \<Pi>) (state_convert (dom \<Pi>) \<Sigma>\<^sub>B) = Some (state_convert (dom \<Pi>) \<Sigma>\<^sub>B')"
  proof (induction \<Pi> \<Sigma>\<^sub>B rule: eval_b_assembly.induct)
  case (1 \<Pi> \<mu> a d s \<omega>)
    then obtain ps where "\<Pi> s = Some ps" by (cases "\<Pi> s") simp_all
    then obtain \<pi>\<^sub>B s' where PS: "\<Pi> s = Some (\<pi>\<^sub>B, s')" by (cases ps) simp
    obtain \<pi>\<^sub>A s'' \<Pi>' where B: "branch_instr_convert (dom \<Pi>) \<pi>\<^sub>B s' = (\<pi>\<^sub>A, s'', \<Pi>')"
      by (cases "branch_instr_convert (dom \<Pi>) \<pi>\<^sub>B s'") simp
    obtain \<pi>\<^sub>A' s''' where C: "remove_continuations \<pi>\<^sub>A s'' \<Pi>' = (\<pi>\<^sub>A', s''')"
      by (cases "remove_continuations \<pi>\<^sub>A s'' \<Pi>'") simp
    from B C have "state_convert (dom \<Pi>) (\<mu>, None, d, \<pi>\<^sub>B, s', \<omega>) = (\<mu>, None, d, \<pi>\<^sub>A', s''', \<omega>)"
      by simp
    with 1 PS B C show ?case by simp
  next case (2 \<Pi> \<mu> a d x \<pi>\<^sub>B s \<omega>)
    obtain \<pi>\<^sub>A s' \<Pi>' where B: "branch_instr_convert (dom \<Pi>) \<pi>\<^sub>B s = (\<pi>\<^sub>A, s', \<Pi>')"
      by (cases "branch_instr_convert (dom \<Pi>) \<pi>\<^sub>B s") simp
    obtain \<pi>\<^sub>A' s'' where C: "remove_continuations \<pi>\<^sub>A s' \<Pi>' = (\<pi>\<^sub>A', s'')"
      by (cases "remove_continuations \<pi>\<^sub>A s' \<Pi>'") simp
    from B C have A: "state_convert (dom \<Pi>) (\<mu>, a, d, ABAssm x # \<pi>\<^sub>B, s, \<omega>) =
      (\<mu>, a, d, AAssm x # \<pi>\<^sub>A', s'', \<omega>)" by simp
    from B C have "state_convert (dom \<Pi>) (\<mu>, Some x, d, \<pi>\<^sub>B, s, \<omega>) = (\<mu>, Some x, d, \<pi>\<^sub>A', s'', \<omega>)"
      by simp
    with 2 A show ?case by simp
  next case (3 \<Pi> \<mu> a d dst cmp \<pi>\<^sub>B s \<omega>)
    let ?n = "compute cmp (\<mu> (nat a)) a d"
    let ?m = "if M \<in> dst then \<mu>(nat a := ?n) else \<mu>"
    let ?a = "Some (if A \<in> dst then ?n else a)"
    let ?d = "if D \<in> dst then ?n else d"
    obtain \<pi>\<^sub>A s' \<Pi>' where B: "branch_instr_convert (dom \<Pi>) \<pi>\<^sub>B s = (\<pi>\<^sub>A, s', \<Pi>')"
      by (cases "branch_instr_convert (dom \<Pi>) \<pi>\<^sub>B s") simp
    obtain \<pi>\<^sub>A' s'' where C: "remove_continuations \<pi>\<^sub>A s' \<Pi>' = (\<pi>\<^sub>A', s'')"
      by (cases "remove_continuations \<pi>\<^sub>A s' \<Pi>'") simp
    from B C have S: "state_convert (dom \<Pi>) (?m, ?a, ?d, \<pi>\<^sub>B, s, \<omega>) = (?m, ?a, ?d, \<pi>\<^sub>A', s'', \<omega>)"
      by simp
    from B C have "state_convert (dom \<Pi>) (\<mu>, Some a, d, CBAssm dst cmp # \<pi>\<^sub>B, s, \<omega>) =
      (\<mu>, Some a, d, CAssm dst cmp # \<pi>\<^sub>A', s'', \<omega>)" by simp
    with 3 S show ?case by (simp add: Let_def)
  next case 4
    thus ?case by simp
  next case (5 \<Pi> \<mu> a d jmp \<pi>\<^sub>B\<^sub>t \<pi>\<^sub>B\<^sub>f \<pi>\<^sub>B s \<omega>)
    let ?s\<^sub>e = "new_label\<^sub>2 (dom \<Pi>)"
    obtain \<pi>\<^sub>A s' \<Pi>\<^sub>1 where B: "branch_instr_convert (dom \<Pi> \<union> {?s\<^sub>e}) \<pi>\<^sub>B s = (\<pi>\<^sub>A, s', \<Pi>\<^sub>1)"
      by (cases "branch_instr_convert (dom \<Pi> \<union> {?s\<^sub>e}) \<pi>\<^sub>B s") simp
    obtain \<pi>\<^sub>A\<^sub>t s\<^sub>t \<Pi>\<^sub>2 where BT: "branch_instr_convert (dom \<Pi> \<union> dom \<Pi>\<^sub>1 \<union> {?s\<^sub>e}) \<pi>\<^sub>B\<^sub>t ?s\<^sub>e = (\<pi>\<^sub>A\<^sub>t, s\<^sub>t, \<Pi>\<^sub>2)"
      by (cases "branch_instr_convert (dom \<Pi> \<union> dom \<Pi>\<^sub>1 \<union> {?s\<^sub>e}) \<pi>\<^sub>B\<^sub>t ?s\<^sub>e") simp
    obtain \<pi>\<^sub>A\<^sub>f s\<^sub>f \<Pi>\<^sub>3 where BF: "branch_instr_convert (dom \<Pi> \<union> dom \<Pi>\<^sub>1 \<union> dom \<Pi>\<^sub>2 \<union> {?s\<^sub>e}) \<pi>\<^sub>B\<^sub>f ?s\<^sub>e =
        (\<pi>\<^sub>A\<^sub>f, s\<^sub>f, \<Pi>\<^sub>3)"
      by (cases "branch_instr_convert (dom \<Pi> \<union> dom \<Pi>\<^sub>1 \<union> dom \<Pi>\<^sub>2 \<union> {?s\<^sub>e}) \<pi>\<^sub>B\<^sub>f ?s\<^sub>e") simp
    let ?\<Pi>' = "\<Pi>\<^sub>1 ++ \<Pi>\<^sub>2 ++ \<Pi>\<^sub>3 ++ [s\<^sub>t \<mapsto> (\<pi>\<^sub>A\<^sub>t, s\<^sub>t), ?s\<^sub>e \<mapsto> (\<pi>\<^sub>A, s')]"
    obtain \<pi>\<^sub>A\<^sub>f' s\<^sub>f' where CF: "remove_continuations \<pi>\<^sub>A\<^sub>f s\<^sub>f ?\<Pi>' = (\<pi>\<^sub>A\<^sub>f', s\<^sub>f')"
      by (cases "remove_continuations \<pi>\<^sub>A\<^sub>f s\<^sub>f ?\<Pi>'") simp
    from BT BF B have BI: "branch_instr_convert (dom \<Pi>) (IBAssm jmp \<pi>\<^sub>B\<^sub>t \<pi>\<^sub>B\<^sub>f # \<pi>\<^sub>B) s =
        (JAssm jmp s\<^sub>t # \<pi>\<^sub>A\<^sub>f, s\<^sub>f, ?\<Pi>')" by simp
    with CF have SI: "state_convert (dom \<Pi>) (\<mu>, a, d, IBAssm jmp \<pi>\<^sub>B\<^sub>t \<pi>\<^sub>B\<^sub>f # \<pi>\<^sub>B, s, \<omega>) =
        (\<mu>, a, d, JAssm jmp s\<^sub>t # \<pi>\<^sub>A\<^sub>f', s\<^sub>f', \<omega>)" by simp
    thus ?case
      proof (cases "compare d jmp")
      case True

        have "(case debranch \<Pi> s\<^sub>t of Some (\<pi>', s'') \<Rightarrow> Some (\<mu>, None, d, \<pi>', s'', \<omega>) | None \<Rightarrow> None) = Some (state_convert (dom \<Pi>) (\<mu>, None, d, \<pi>\<^sub>B\<^sub>t @ \<pi>\<^sub>B, s, \<omega>))" by simp
        with 5 SI True show ?thesis by auto
      next case False

have "state_convert (dom \<Pi>) (\<mu>, None, d, \<pi>\<^sub>B\<^sub>f @ \<pi>\<^sub>B, s, \<omega>) = (
    let (\<pi>', s', \<Pi>') = branch_instr_convert (dom \<Pi>) (\<pi>\<^sub>B\<^sub>f @ \<pi>\<^sub>B) s
    in let (\<pi>\<^sub>A\<^sub>f', s\<^sub>f') = remove_continuations \<pi>' s' \<Pi>'
    in (\<mu>, None, d, \<pi>\<^sub>A\<^sub>f', s\<^sub>f', \<omega>))" by simp

        have "(\<mu>, None, d, \<pi>\<^sub>A\<^sub>f', s\<^sub>f', \<omega>) = state_convert (dom \<Pi>) (\<mu>, None, d, \<pi>\<^sub>B\<^sub>f @ \<pi>\<^sub>B, s, \<omega>)" by simp
        with 5 SI False show ?thesis by auto
      qed
  next case (6 \<Pi> \<mu> a d s \<pi> s' \<omega>)
    then obtain ps where "\<Pi> s = Some ps" by (cases "\<Pi> s") simp_all
    then obtain \<pi>\<^sub>B s' where PS: "\<Pi> s = Some (\<pi>\<^sub>B, s')" by (cases ps) simp

have "state_convert (dom \<Pi>) (\<mu>, None, d, \<pi>\<^sub>B, s', \<omega>) = (
    let (\<pi>', s', \<Pi>') = branch_instr_convert (dom \<Pi>) \<pi>\<^sub>B s'
    in let (\<pi>'', s'') = remove_continuations \<pi>' s' \<Pi>'
    in (\<mu>, None, d, \<pi>'', s'', \<omega>))" by simp

    have "eval_assembly (debranch \<Pi>) (\<mu>, a, d, [], s, \<omega>) = Some (state_convert (dom \<Pi>) (\<mu>, None, d, \<pi>\<^sub>B, s', \<omega>))" by simp
    with 6 PS show ?case by simp
  next case (7 \<Pi> \<mu> a d \<pi>\<^sub>B s \<omega>)
    obtain \<pi>\<^sub>A s' \<Pi>' where B: "branch_instr_convert (dom \<Pi>) \<pi>\<^sub>B s = (\<pi>\<^sub>A, s', \<Pi>')"
      by (cases "branch_instr_convert (dom \<Pi>) \<pi>\<^sub>B s") simp
    obtain \<pi>\<^sub>A' s'' where C: "remove_continuations \<pi>\<^sub>A s' \<Pi>' = (\<pi>\<^sub>A', s'')"
      by (cases "remove_continuations \<pi>\<^sub>A s' \<Pi>'") simp
    from B C have A: "state_convert (dom \<Pi>) (\<mu>, a, d, PBAssm # \<pi>\<^sub>B, s, \<omega>) =
      (\<mu>, a, d, PAssm # \<pi>\<^sub>A', s'', \<omega>)" by simp
    from B C have "state_convert (dom \<Pi>) (\<mu>, a, d, \<pi>\<^sub>B, s, d # \<omega>) = (\<mu>, a, d, \<pi>\<^sub>A', s'', d # \<omega>)"
      by simp
    with 7 A show ?case by simp
  qed

theorem debranching_correct [simp]: "iterate (eval_b_assembly \<Pi>) \<Sigma>\<^sub>B \<Sigma>\<^sub>B' \<Longrightarrow> finite (dom \<Pi>) \<Longrightarrow>
    iterate (eval_assembly (debranch \<Pi>)) (state_convert (dom \<Pi>) \<Sigma>\<^sub>B) (state_convert (dom \<Pi>) \<Sigma>\<^sub>B')"
  proof (induction "eval_b_assembly \<Pi>" \<Sigma>\<^sub>B \<Sigma>\<^sub>B' rule: iterate.induct)
  case iter_refl
    thus ?case by auto
  next case iter_step
    with debranch_step show ?case by auto
  qed

end


(*  Title:       CoreC++

    Author:      Daniel Wasserrab
    Maintainer:  Daniel Wasserrab <wasserra at fmi.uni-passau.de>

    Based on the Jinja theory Common/TypeRel.thy by Tobias Nipkow
*)

header {* \isaheader{The subclass relation} *}

theory ClassRel imports Decl begin

-- "direct repeated subclass"
inductive_set
  subclsR :: "prog \<Rightarrow> (cname \<times> cname) set"
  and subclsR' :: "prog \<Rightarrow> [cname, cname] \<Rightarrow> bool" ("_ \<turnstile> _ \<prec>\<^sub>R _" [71,71,71] 70)
  for P :: prog
where
  "P \<turnstile> C \<prec>\<^sub>R D \<equiv> (C,D) \<in> subclsR P"
| subclsRI: "\<lbrakk>class P C = Some (Bs,rest); Repeats(D) \<in> set Bs\<rbrakk> \<Longrightarrow> P \<turnstile> C \<prec>\<^sub>R D"

-- "direct shared subclass"
inductive_set
  subclsS :: "prog \<Rightarrow> (cname \<times> cname) set"
  and subclsS' :: "prog \<Rightarrow> [cname, cname] \<Rightarrow> bool" ("_ \<turnstile> _ \<prec>\<^sub>S _" [71,71,71] 70)
  for P :: prog
where
  "P \<turnstile> C \<prec>\<^sub>S D \<equiv> (C,D) \<in> subclsS P"
| subclsSI: "\<lbrakk>class P C = Some (Bs,rest); Shares(D) \<in> set Bs\<rbrakk> \<Longrightarrow> P \<turnstile> C \<prec>\<^sub>S D"

 -- "direct subclass"
inductive_set
  subcls1 :: "prog \<Rightarrow> (cname \<times> cname) set"
  and subcls1' :: "prog \<Rightarrow> [cname, cname] \<Rightarrow> bool" ("_ \<turnstile> _ \<prec>\<^sup>1 _" [71,71,71] 70)
  for P :: prog
where
  "P \<turnstile> C \<prec>\<^sup>1 D \<equiv> (C,D) \<in> subcls1 P"
| subcls1I: "\<lbrakk>class P C = Some (Bs,rest); D \<in>  baseClasses Bs\<rbrakk> \<Longrightarrow> P \<turnstile> C \<prec>\<^sup>1 D"

abbreviation
  subcls    :: "prog \<Rightarrow> [cname, cname] \<Rightarrow> bool" ("_ \<turnstile> _ \<preceq>\<^sup>* _"  [71,71,71] 70) where
  "P \<turnstile> C \<preceq>\<^sup>* D \<equiv> (C,D) \<in> (subcls1 P)\<^sup>*"

lemma subclsRD:
  "P \<turnstile> C \<prec>\<^sub>R D \<Longrightarrow> \<exists>fs ms Bs. (class P C = Some (Bs,fs,ms)) \<and> (Repeats(D) \<in> set Bs)"
by(auto elim: subclsR.cases)

lemma subclsSD:
  "P \<turnstile> C \<prec>\<^sub>S D \<Longrightarrow> \<exists>fs ms Bs. (class P C = Some (Bs,fs,ms)) \<and> (Shares(D) \<in> set Bs)"
by(auto elim: subclsS.cases)

lemma subcls1D:
  "P \<turnstile> C \<prec>\<^sup>1 D \<Longrightarrow> \<exists>fs ms Bs. (class P C = Some (Bs,fs,ms)) \<and> (D \<in> baseClasses Bs)"
by(auto elim: subcls1.cases)

lemma subclsR_subcls1:
  "P \<turnstile> C \<prec>\<^sub>R D \<Longrightarrow> P \<turnstile> C \<prec>\<^sup>1 D"
by (auto elim!:subclsR.cases intro:subcls1I simp:RepBaseclass_isBaseclass)

lemma subclsS_subcls1:
  "P \<turnstile> C \<prec>\<^sub>S D \<Longrightarrow> P \<turnstile> C \<prec>\<^sup>1 D"
by (auto elim!:subclsS.cases intro:subcls1I simp:ShBaseclass_isBaseclass)

lemma subcls1_subclsR_or_subclsS:
  "P \<turnstile> C \<prec>\<^sup>1 D \<Longrightarrow> P \<turnstile> C \<prec>\<^sub>R D \<or> P \<turnstile> C \<prec>\<^sub>S D"
by (auto dest!:subcls1D intro:subclsRI
  dest:baseClasses_repeats_or_shares subclsSI)

lemma finite_subcls1: "finite (subcls1 P)"

apply(subgoal_tac "subcls1 P = (SIGMA C: {C. is_class P C} .
                     {D. D \<in> baseClasses (fst(the(class P C)))})")
 prefer 2
 apply(fastforce simp:is_class_def dest: subcls1D elim: subcls1I)
apply simp
apply(rule finite_SigmaI [OF finite_is_class])
apply(rule_tac B = "baseClasses (fst (the (class P C)))" in finite_subset)
apply (auto intro:finite_baseClasses simp:is_class_def)
done

lemma finite_subclsR: "finite (subclsR P)"
by(rule_tac B = "subcls1 P" in finite_subset,
  auto simp:subclsR_subcls1 finite_subcls1)

lemma finite_subclsS: "finite (subclsS P)"
by(rule_tac B = "subcls1 P" in finite_subset,
  auto simp:subclsS_subcls1 finite_subcls1)

lemma subcls1_class:
  "P \<turnstile> C \<prec>\<^sup>1 D \<Longrightarrow> is_class P C"
by (auto dest:subcls1D simp:is_class_def)

lemma subcls_is_class:
"\<lbrakk>P \<turnstile> D \<preceq>\<^sup>* C; is_class P C\<rbrakk> \<Longrightarrow> is_class P D"
by (induct rule:rtrancl_induct,auto dest:subcls1_class)

end