theory Weak_HML_Contrasimulation
  imports
    Contrasim_Set_Game
    HM_Logic_Infinitary
begin

section \<open>Weak HML and the Contrasimulation Set Game\<close>

subsection \<open>Existence of Distinguishing Formula on Winning Attacker Position\<close>
locale c_game_with_attacker_strategy  =
  c_set_game trans \<tau>
for
  trans :: \<open>'s \<Rightarrow> 'a \<Rightarrow> 's \<Rightarrow> bool\<close> and
  \<tau> :: \<open>'a\<close> +
fixes
  strat :: \<open>('s, 'a) c_set_game_node posstrategy\<close> and
  attacker_winning_region :: \<open>('s, 'a) c_set_game_node set\<close> and
  attacker_order
defines
  \<open>attacker_order \<equiv> {(g', g). c_set_game_moves g g' \<and>
      g \<in> attacker_winning_region \<and> g' \<in> attacker_winning_region \<and>
      (player1_position g \<longrightarrow> g' = strat g)}\<^sup>+\<close>
assumes
  finite_win:
    \<open>wf attacker_order\<close> and
  strat_stays_winning:
    \<open>g \<in> attacker_winning_region \<Longrightarrow> player1_position g \<Longrightarrow>
      strat g \<in> attacker_winning_region \<and> c_set_game_moves g (strat g)\<close> and
  defender_keeps_losing:
    \<open>g \<in> attacker_winning_region \<Longrightarrow> c_set_game_defender_node g \<Longrightarrow> c_set_game_moves g g' \<Longrightarrow>
      g' \<in> attacker_winning_region\<close>
begin

text \<open>This construction of attacker formulas from a game only works if \<open>strat\<close> is a (non-cyclic)
  attacker strategy. (If it's winning and sound, the constructed formula should be distinguishing.)\<close>

function attack_formula :: \<open>('s, 'a) c_set_game_node \<Rightarrow> ('a,'s) HML_formula\<close> where
  \<open>attack_formula (AttackerNode p Q) =
    (if (AttackerNode p Q) \<in> attacker_winning_region then attack_formula (strat (AttackerNode p Q)) else HML_true)\<close>
| \<open>attack_formula (DefenderSimNode a p Q) =
    (if (DefenderSimNode a p Q) \<in> attacker_winning_region then \<langle>\<tau>\<rangle>\<langle>a\<rangle>(attack_formula (AttackerNode p (dsuccs a Q))) else HML_true)\<close>
| \<open>attack_formula (DefenderSwapNode p Q) =
    (if Q = {} \<or> DefenderSwapNode p Q \<notin> attacker_winning_region then HML_true else
    (HML_weaknor (weak_tau_succs Q) (\<lambda>q. if q \<in> (weak_tau_succs Q) then (attack_formula (AttackerNode q {p})) else HML_true )))\<close>
  using c_set_game_defender_node.cases
  by (auto, blast)

termination attack_formula
  using finite_win
proof (standard, safe)
  fix p Q
  assume \<open>AttackerNode p Q \<in> attacker_winning_region\<close>
  thus \<open>(strat (AttackerNode p Q), AttackerNode p Q) \<in> attacker_order\<close>
    unfolding attacker_order_def
    using strat_stays_winning
    by auto
next
  fix a p Q
  assume attacker_wins: \<open>DefenderSimNode a p Q \<in> attacker_winning_region\<close>
  hence \<open>AttackerNode p (dsuccs a Q) \<in> attacker_winning_region\<close>
    using defender_keeps_losing simulation_answer by force
  with attacker_wins show \<open>(AttackerNode p (dsuccs a Q), DefenderSimNode a p Q) \<in> attacker_order\<close>
    unfolding attacker_order_def
    by (simp add: r_into_trancl')
next
  fix p Q q' q
  assume case_assms:
    \<open>q' \<in> weak_tau_succs Q\<close>
    \<open>(AttackerNode q' {p}, DefenderSwapNode p Q) \<notin> attacker_order\<close>
    \<open>DefenderSwapNode p Q \<in> attacker_winning_region\<close>
    \<open>q \<in> Q\<close>
  hence \<open>AttackerNode q' {p} \<notin> attacker_winning_region\<close>
    unfolding attacker_order_def by auto
  moreover from case_assms have \<open>AttackerNode q' {p} \<in> attacker_winning_region\<close>
    using swap_answer defender_keeps_losing by force
  ultimately show \<open>q \<in> {}\<close> by blast
qed

lemma attacker_defender_switch:
  assumes
    \<open>(AttackerNode p Q) \<in> attacker_winning_region\<close>
  shows
    \<open>(\<exists>a p'. (strat (AttackerNode p Q)) = (DefenderSimNode a p' Q) \<and> p  =\<rhd>a p' \<and> \<not>tau a)
    \<or>(\<exists>p'. (strat (AttackerNode p Q)) = (DefenderSwapNode p' Q) \<and> p \<longmapsto>* tau p' )\<close>
  using strat_stays_winning[OF assms] by (cases \<open>strat (AttackerNode p Q)\<close>, auto)

lemma attack_options:
  assumes
    \<open>(AttackerNode p Q) \<in> attacker_winning_region\<close>
  shows
    \<open>(\<exists>a p'. p =\<rhd>a p' \<and> \<not>tau a \<and> strat (AttackerNode p Q) = (DefenderSimNode a p' Q) \<and>
      attack_formula (AttackerNode p Q) = \<langle>\<tau>\<rangle>\<langle>a\<rangle>(attack_formula (AttackerNode p' (dsuccs a Q))))
    \<or> (\<exists>p'. p \<longmapsto>* tau p' \<and> strat (AttackerNode p Q) = (DefenderSwapNode p' Q) \<and>
      attack_formula (AttackerNode p Q) =
      (HML_weaknor (weak_tau_succs Q) (\<lambda>q. if q \<in> (weak_tau_succs Q) then (attack_formula (AttackerNode q {p'})) else HML_true )))
    \<or> (Q = {} \<and> attack_formula (AttackerNode p Q) = HML_true)\<close>
proof -
  from assms have \<open>attack_formula (AttackerNode p Q) = attack_formula (strat (AttackerNode p Q))\<close> by simp
  moreover from attacker_defender_switch assms have
    \<open>(\<exists>a p'. (strat (AttackerNode p Q)) = (DefenderSimNode a p' Q) \<and> p  =\<rhd>a p' \<and> \<not>tau a)
    \<or>(\<exists>p'. (strat (AttackerNode p Q)) = (DefenderSwapNode p' Q) \<and> p \<longmapsto>* tau p')\<close> by blast
  ultimately have
    \<open>(\<exists>a p'. (strat (AttackerNode p Q)) = (DefenderSimNode a p' Q) \<and>
      (attack_formula (AttackerNode p Q)) = attack_formula (DefenderSimNode a p' Q) \<and> p  =\<rhd>a p' \<and> \<not>tau a)
    \<or>(\<exists>p'. (strat (AttackerNode p Q)) = (DefenderSwapNode p' Q) \<and>
      (attack_formula (AttackerNode p Q)) = attack_formula (DefenderSwapNode p' Q) \<and> p \<longmapsto>* tau p')\<close>
    by metis
  moreover from assms have \<open>strat (AttackerNode p Q) \<in> attacker_winning_region\<close>
    by (simp add: strat_stays_winning)
  ultimately show ?thesis using assms empty_iff
    by fastforce
qed

lemma distinction_soundness:
  fixes p Q p0 Q0
  defines
    \<open>pQ == AttackerNode p Q\<close>
  defines
    \<open>\<phi> == attack_formula pQ\<close>
  assumes
    \<open>pQ \<in> attacker_winning_region\<close>
  shows
    \<open>p \<Turnstile> \<phi> \<and> (\<forall>q\<in>Q. \<not> q \<Turnstile> \<phi>)\<close>
  using finite_win assms
proof (induct arbitrary: p Q \<phi>)
  case (less p Q)
  from attack_options[OF this(2)] show ?case
  proof
    assume \<open>\<exists>a p'. p =\<rhd> a  p' \<and> \<not> tau a \<and> strat (AttackerNode p Q) = DefenderSimNode a p' Q \<and>
      attack_formula (AttackerNode p Q) = \<langle>\<tau>\<rangle>\<langle>a\<rangle>attack_formula (AttackerNode p' (dsuccs a Q))\<close>
    then obtain a p' where case_assms:
      \<open>p =\<rhd> a  p' \<and> \<not> tau a\<close>
      \<open>strat (AttackerNode p Q) = DefenderSimNode a p' Q\<close>
      \<open>attack_formula (AttackerNode p Q) = \<langle>\<tau>\<rangle>\<langle>a\<rangle>attack_formula (AttackerNode p' (dsuccs a Q))\<close> by blast
    hence moves:
      \<open>c_set_game_moves (AttackerNode p Q) (DefenderSimNode a p' Q)\<close>
      \<open>c_set_game_moves (DefenderSimNode a p' Q) (AttackerNode p' (dsuccs a Q))\<close> by auto
    with case_assms less(2) defender_keeps_losing strat_stays_winning have all_winning:
      \<open>(AttackerNode p' (dsuccs a Q)) \<in> attacker_winning_region\<close>
      \<open>(DefenderSimNode a p' Q) \<in> attacker_winning_region\<close>
        by (metis c_set_game_defender_node.simps(2), force)
    with case_assms moves less(2) have
      \<open>(AttackerNode p' (dsuccs a Q), DefenderSimNode a p' Q) \<in> attacker_order\<close>
      \<open>(DefenderSimNode a p' Q, AttackerNode p Q) \<in> attacker_order\<close>
      unfolding attacker_order_def by (simp add: r_into_trancl')+
    hence \<open>(AttackerNode p' (dsuccs a Q), AttackerNode p Q) \<in> attacker_order\<close>
      unfolding attacker_order_def by auto
    with less.hyps all_winning(1) have
      \<open>p' \<Turnstile> attack_formula (AttackerNode p' (dsuccs a Q)) \<and> (\<forall>q\<in>(dsuccs a Q). \<not> q \<Turnstile> attack_formula (AttackerNode p' (dsuccs a Q)))\<close>
      by blast
    with case_assms have
      \<open>p \<Turnstile> \<langle>\<tau>\<rangle>\<langle>a\<rangle>attack_formula (AttackerNode p' (dsuccs a Q))\<close>
      \<open>\<forall>q\<in>Q. \<not>q \<Turnstile> \<langle>\<tau>\<rangle>\<langle>a\<rangle>attack_formula (AttackerNode p' (dsuccs a Q))\<close>
      unfolding dsuccs_def by (auto, blast+)
    thus ?case unfolding case_assms by blast
  next
    assume \<open>(\<exists>p'. p \<longmapsto>* tau  p' \<and> strat (AttackerNode p Q) = DefenderSwapNode p' Q \<and>
        attack_formula (AttackerNode p Q) = HML_weaknor (weak_tau_succs Q) (\<lambda>q. if q \<in> (weak_tau_succs Q) then attack_formula (AttackerNode q {p'}) else HML_true)) \<or>
      Q = {} \<and> attack_formula (AttackerNode p Q) = HML_true\<close>
    thus ?case
    proof
      assume \<open>\<exists>p'. p \<longmapsto>* tau  p' \<and> strat (AttackerNode p Q) = DefenderSwapNode p' Q \<and>
        attack_formula (AttackerNode p Q) = HML_weaknor (weak_tau_succs Q) (\<lambda>q. if q \<in> (weak_tau_succs Q) then attack_formula (AttackerNode q {p'}) else HML_true)\<close>
      then obtain p' where case_assms:
        \<open>p \<longmapsto>* tau  p'\<close>
        \<open>strat (AttackerNode p Q) = DefenderSwapNode p' Q\<close>
        \<open>attack_formula (AttackerNode p Q) = HML_weaknor (weak_tau_succs Q) (\<lambda>q. if q \<in> (weak_tau_succs Q) then attack_formula (AttackerNode q {p'}) else HML_true)\<close>
        by blast
      from case_assms have moves:
        \<open>c_set_game_moves (AttackerNode p Q) (DefenderSwapNode p' Q)\<close>
        \<open>\<forall>q'\<in>(weak_tau_succs Q). c_set_game_moves (DefenderSwapNode p' Q) (AttackerNode q' {p'})\<close> by auto
      with case_assms less(2) defender_keeps_losing strat_stays_winning have all_winning:
        \<open>(DefenderSwapNode p' Q) \<in> attacker_winning_region\<close>
        \<open>\<forall>q'\<in>(weak_tau_succs Q). (AttackerNode q' {p'}) \<in> attacker_winning_region\<close>
        by (metis, metis c_set_game_defender_node.simps(1,3))
      with case_assms moves less(2) have
        \<open>\<forall>q'\<in> weak_tau_succs Q. (AttackerNode q' {p'}, DefenderSwapNode p' Q) \<in> attacker_order\<close>
        \<open>(DefenderSwapNode p' Q, AttackerNode p Q) \<in> attacker_order\<close>
        unfolding attacker_order_def by (simp add: r_into_trancl')+
      hence \<open>\<forall>q'\<in> weak_tau_succs Q. (AttackerNode q' {p'}, AttackerNode p Q) \<in> attacker_order\<close>
        unfolding attacker_order_def by auto
      with less.hyps all_winning have
        \<open>\<forall>q'\<in> weak_tau_succs Q. q' \<Turnstile> attack_formula (AttackerNode q' {p'}) \<and> \<not> p' \<Turnstile> attack_formula (AttackerNode q' {p'})\<close>
        by blast
      with case_assms have
        \<open>p' \<Turnstile> HML_conj (weak_tau_succs Q) (\<lambda>q'. HML_neg (attack_formula (AttackerNode q' {p'})))\<close>
        \<open>\<forall>q'\<in> weak_tau_succs Q. \<not> q' \<Turnstile> HML_conj (weak_tau_succs Q) (\<lambda>qq'. HML_neg (attack_formula (AttackerNode qq' {p'})))\<close>
        by (simp, fastforce)
      with case_assms have
        \<open>p \<Turnstile>  HML_weaknor (weak_tau_succs Q) (\<lambda>q. if q \<in> (weak_tau_succs Q) then attack_formula (AttackerNode q {p'}) else HML_true)\<close>
        \<open>\<forall>q\<in>Q. \<not>q \<Turnstile>  HML_weaknor (weak_tau_succs Q) (\<lambda>q. if q \<in> (weak_tau_succs Q) then attack_formula (AttackerNode q {p'}) else HML_true)\<close>
        unfolding weak_tau_succs_def HML_weaknor_def
        using conj_only_depends_on_indexset by (auto, force, fastforce)
      thus ?case unfolding case_assms by blast
    next
      assume \<open>Q = {} \<and> attack_formula (AttackerNode p Q) = HML_true\<close>
      thus ?case by auto
    qed
  qed
qed

lemma distinction_in_language:
  fixes p Q
  defines
    \<open>pQ == AttackerNode p Q\<close>
  defines
    \<open>\<phi> == attack_formula pQ\<close>
  assumes
    \<open>pQ \<in> attacker_winning_region\<close>
  shows
    \<open>\<phi> \<in> HML_weak_formulas\<close>
  using assms(2,3) unfolding assms(1)
proof (induct arbitrary: \<phi> rule: attack_formula.induct)
  case (1 p Q)
  then show ?case using strat_stays_winning by auto
next
  case (2 a p Q)
  then show ?case
    by (simp add: HML_weak_formulas.Base HML_weak_formulas.Obs)
next
  case (3 p Q)
  hence \<open>\<forall>q' \<in> weak_tau_succs Q. attack_formula (AttackerNode q' {p}) \<in> HML_weak_formulas\<close>
    using weak_tau_succs_def HML_weak_formulas.Base by fastforce
  then show ?case
    using HML_weak_formulas.Base \<open>DefenderSwapNode p Q \<in> attacker_winning_region\<close>
    by (auto simp add: HML_weak_formulas.Conj)
qed

end

subsection \<open>Attacker Wins on Positions With Distinguishing Formula\<close>

locale c_game_with_attacker_formula  =
  c_set_game trans \<tau>
for
  trans :: \<open>'s \<Rightarrow> 'a \<Rightarrow> 's \<Rightarrow> bool\<close> and
  \<tau> :: \<open>'a\<close>
begin

inductive_set attacker_winning_region :: \<open>('s, 'a) c_set_game_node set\<close> where
  Base: \<open>DefenderSwapNode _ {} \<in> attacker_winning_region\<close> |
  Atk: \<open>(c_set_game_moves (AttackerNode p Q) g' \<and> g' \<in> attacker_winning_region) \<Longrightarrow> (AttackerNode p Q) \<in> attacker_winning_region\<close> |
  Def: \<open>c_set_game_defender_node g \<Longrightarrow> (\<And>g'. c_set_game_moves g g' \<Longrightarrow> g' \<in> attacker_winning_region) \<Longrightarrow> g \<in> attacker_winning_region\<close>

lemma Atk_node_wins_if_Q_is_empty:
  assumes \<open>Q = {}\<close>
  shows \<open>AttackerNode p Q \<in> attacker_winning_region\<close>
proof -
  have atk_move: \<open>c_set_game_moves (AttackerNode p Q) (DefenderSwapNode p Q)\<close>
    by (simp add: steps.refl)
  have \<open>DefenderSwapNode p Q \<in> attacker_winning_region\<close> using assms attacker_winning_region.Base by simp
  thus ?thesis using atk_move attacker_winning_region.Atk by blast
qed

lemma Atk_node_wins_in_2_moves:
  assumes
        \<open>AttackerNode p' (dsuccs a Q) \<in> attacker_winning_region\<close>
        \<open>p =\<rhd>a p'\<close>
        \<open>\<not>tau a\<close>
  shows \<open>AttackerNode p Q \<in> attacker_winning_region\<close>
proof -
  have AtkToSim: \<open>c_set_game_moves (AttackerNode p Q) (DefenderSimNode a p' Q)\<close>
    using assms(2, 3) by simp
  have \<open>\<forall>g. c_set_game_moves
(DefenderSimNode a p' Q) g \<longrightarrow> (g = AttackerNode p' (dsuccs a Q))\<close>
    by (simp add: move_DefSim_to_AtkNode)
  hence \<open>(DefenderSimNode a p' Q) \<in> attacker_winning_region\<close>
    using assms(1) attacker_winning_region.Def
    by (metis c_set_game_defender_node.simps(2))
  thus ?thesis using AtkToSim attacker_winning_region.Atk by blast
qed

lemma distinction_completeness:
  assumes
    \<open>\<phi> \<in> HML_weak_formulas\<close>
    \<open>distinguishes_from_set \<phi> p Q\<close>
  shows \<open>(AttackerNode p Q) \<in> attacker_winning_region\<close>
proof(cases \<open>Q = {}\<close>)
  case True
  then show ?thesis using Atk_node_wins_if_Q_is_empty by auto
next
  case False
  then show ?thesis using assms
  proof (induct arbitrary: p Q rule: HML_weak_formulas.induct[OF assms(1)])
    case Base: 1
    have \<open>\<forall>q. q \<Turnstile> HML_true\<close> by simp
    hence \<open>False\<close>
      using Base.prems(1, 3) by simp
    then show ?case by auto
  next
    case Obs: (2 \<phi> a)
    then obtain p' where p'_def: \<open>p =\<rhd>a p' \<and> p' \<Turnstile> \<phi> \<close>
      using tau_a_obs_implies_delay_step[of p a \<phi>] by auto
    have \<open>\<forall>q. q \<in> Q \<longrightarrow> \<not> q \<Turnstile> \<langle>\<tau>\<rangle>\<langle>a\<rangle>\<phi>\<close> using Obs by auto
    hence \<open>\<forall>q. q \<in> Q \<longrightarrow> (\<forall>q'.  \<not>q  =\<rhd>a  q' \<or> \<not>q' \<Turnstile> \<phi>)\<close>
      using delay_step_implies_tau_a_obs by blast
    hence \<open>\<forall>q'. q' \<in> dsuccs a Q \<longrightarrow> \<not> q' \<Turnstile> \<phi>\<close>
      unfolding dsuccs_def by blast
    hence phi_distinguishing: \<open>distinguishes_from_set \<phi> p' (dsuccs a Q)\<close>
      using p'_def by simp
    thus ?case
    proof (cases \<open>dsuccs a Q = {}\<close>)
      case dsuccs_empty: True
      then show ?thesis
      proof (cases \<open>tau a\<close>)
        case True
        hence \<open>{q1. \<exists>q\<in> Q. q \<longmapsto>* tau q1} = {}\<close> using dsuccs_def dsuccs_empty by auto
        hence \<open>Q = {}\<close> using steps.refl by blast
        then show ?thesis using Atk_node_wins_if_Q_is_empty by auto
      next
        case False
        hence \<open>AttackerNode p' (dsuccs a Q) \<in> attacker_winning_region\<close>
          using Atk_node_wins_if_Q_is_empty dsuccs_empty by auto
        thus ?thesis using Atk_node_wins_in_2_moves False p'_def by blast
      qed
    next
      case False
      hence wr_pred_atk_node: \<open>AttackerNode p' (dsuccs a Q) \<in> attacker_winning_region\<close>
        using Obs.hyps phi_distinguishing by auto
      thus ?thesis
      proof(cases \<open>tau a\<close>)
        case True
        hence \<open>\<forall>p. (p \<Turnstile> \<langle>\<tau>\<rangle>\<langle>a\<rangle>\<phi>) = (p  \<Turnstile> \<phi>)\<close>
          using delay_step_implies_tau_a_obs p'_def satisfies.simps(4) tau_tau
            Obs.hyps(1) weak_backwards_truth
          by (meson lts.refl)
        hence \<open>distinguishes_from_set \<phi> p Q\<close> using Obs.prems by auto
        thus ?thesis using Obs.hyps Obs.prems by blast
      next
        case False
        then show ?thesis
          using wr_pred_atk_node Atk_node_wins_in_2_moves p'_def by blast
      qed
    qed
  next
    case Conj: (3 I F)
    then obtain p' where \<open>p \<Rightarrow>^\<tau> p'\<close> and p_sat:  \<open>p' \<Turnstile> HML_conj I (\<lambda>f. HML_neg (F f))\<close>
      unfolding HML_weaknor_def by auto
    have \<open>\<And>q . q \<in> Q  \<Longrightarrow> \<not>q  \<Turnstile>  HML_poss \<tau> (HML_conj I (\<lambda>f. HML_neg (F f)))\<close>
      by (metis Conj.prems(3) HML_weaknor_def distinguishes_from_set.elims(2))
    hence \<open>\<And>q q'. q \<in> Q \<Longrightarrow> \<not>q \<Rightarrow>^\<tau> q' \<or> \<not>q'  \<Turnstile> HML_conj I (\<lambda>f. HML_neg (F f))\<close>
      using satisfies.simps(4) tau_tau by blast
    hence \<open>\<And>q'. \<not>q' \<in> (weak_tau_succs Q) \<or> \<not>q'  \<Turnstile> HML_conj I (\<lambda>f. HML_neg (F f))\<close>
      using weak_tau_succs_def by auto
    hence Ex: \<open>\<And>q'.  q' \<in> (weak_tau_succs Q) \<Longrightarrow> (\<exists>i. i \<in> I \<and> q'  \<Turnstile>  (F i))\<close>
      by auto
    have atk_move: \<open>c_set_game_moves (AttackerNode p Q) (DefenderSwapNode p' Q)\<close>
      using \<open>p \<Rightarrow>^\<tau> p'\<close> by auto
    have Ex_i: \<open>\<forall>q1 P1. c_set_game_moves (DefenderSwapNode p' Q) (AttackerNode q1 P1) \<longrightarrow>
          (\<exists>i. i \<in> I \<and> q1  \<Turnstile>  (F i)) \<and> P1 = {p'}\<close>
      using Ex by auto
    hence \<open>\<forall>q1 P1.
          c_set_game_moves (DefenderSwapNode p' Q) (AttackerNode q1 P1) \<longrightarrow>
          (\<exists>i. i \<in> I \<and> q1  \<Turnstile>  (F i) \<and> (\<forall>p'. p' \<in> P1 \<longrightarrow> \<not> p' \<Turnstile> (F i)))\<close>
      using p_sat by auto
    hence  \<open>\<forall>q1 P1.
          c_set_game_moves (DefenderSwapNode p' Q) (AttackerNode q1 P1) \<longrightarrow>
          (\<exists>i. i \<in> I \<and> distinguishes_from_set (F i) q1 P1)\<close>
      unfolding distinguishes_from_set.simps using p_sat by blast
    hence all_atk_succs_in_wr:
          \<open>\<forall>q1 P1. c_set_game_moves (DefenderSwapNode p' Q) (AttackerNode q1 P1) \<longrightarrow>
          (AttackerNode q1 P1 \<in> attacker_winning_region)\<close>
      using Conj.hyps Ex_i by blast
    hence \<open>\<forall>g. c_set_game_moves (DefenderSwapNode p' Q) g \<longrightarrow>
          (\<exists> q1 P1. g = (AttackerNode q1 P1))\<close>
      using move_DefSwap_to_AtkNode by blast
    hence \<open>\<forall>g. c_set_game_moves (DefenderSwapNode p' Q) g \<longrightarrow> g \<in> attacker_winning_region\<close>
      using all_atk_succs_in_wr by auto
    hence \<open>DefenderSwapNode p' Q \<in> attacker_winning_region\<close>
      using attacker_winning_region.Def
      by (meson c_set_game_defender_node.simps(3))
    then show ?case using atk_move attacker_winning_region.Atk by blast
  qed
qed

end

end


(*<*)
theory Restrict_Bounds
imports
  Relational_Calculus
  "Collections.Collections"
begin
(*>*)

section \<open>Restricting Bound Variables\<close>

fun flat_Disj where
  "flat_Disj (Disj Q1 Q2) = flat_Disj Q1 \<union> flat_Disj Q2"
| "flat_Disj Q = {Q}"

lemma finite_flat_Disj[simp]: "finite (flat_Disj Q)"
  by (induct Q rule: flat_Disj.induct) auto

lemma DISJ_flat_Disj: "DISJ (flat_Disj Q) \<triangleq> Q"
  by (induct Q rule: flat_Disj.induct) (auto simp: DISJ_union[THEN equiv_trans] simp del: cp.simps)

lemma fv_flat_Disj: "(\<Union>Q' \<in> flat_Disj Q. fv Q') = fv Q"
  by (induct Q rule: flat_Disj.induct) auto

lemma fv_flat_DisjD: "Q' \<in> flat_Disj Q \<Longrightarrow> x \<in> fv Q' \<Longrightarrow> x \<in> fv Q"
  by (auto simp: fv_flat_Disj[of Q, symmetric])

lemma cpropagated_flat_DisjD: "Q' \<in> flat_Disj Q \<Longrightarrow> cpropagated Q \<Longrightarrow> cpropagated Q'"
  by (induct Q rule: flat_Disj.induct) auto

lemma flat_Disj_sub: "flat_Disj Q \<subseteq> sub Q"
  by (induct Q) auto

lemma (in simplification) simplified_flat_DisjD: "Q' \<in> flat_Disj Q \<Longrightarrow> simplified Q \<Longrightarrow> simplified Q'"
  by (elim simplified_sub set_mp[OF flat_Disj_sub])

definition fixbound where
  "fixbound \<Q> x = {Q \<in> \<Q>. x \<in> nongens Q}"

definition (in simplification) rb_spec where
  "rb_spec Q = SPEC (\<lambda>Q'. rrb Q' \<and> simplified Q' \<and> Q \<triangleq> Q' \<and> fv Q' \<subseteq> fv Q)"

definition (in simplification) rb_INV where
  "rb_INV x Q \<Q> = (finite \<Q> \<and>
     Exists x Q \<triangleq> DISJ (exists x ` \<Q>) \<and>
     (\<forall>Q' \<in> \<Q>. rrb Q' \<and> fv Q' \<subseteq> fv Q \<and> simplified Q'))"

lemma (in simplification) rb_INV_I:
  "finite \<Q> \<Longrightarrow> Exists x Q \<triangleq> DISJ (exists x ` \<Q>) \<Longrightarrow> (\<And>Q'. Q' \<in> \<Q> \<Longrightarrow> rrb Q') \<Longrightarrow>
   (\<And>Q'. Q' \<in> \<Q> \<Longrightarrow> fv Q' \<subseteq> fv Q) \<Longrightarrow> (\<And>Q'. Q' \<in> \<Q> \<Longrightarrow> simplified Q') \<Longrightarrow> rb_INV x Q \<Q>"
  unfolding rb_INV_def by auto

fun (in simplification) rb :: "('a :: {infinite, linorder}, 'b :: linorder) fmla \<Rightarrow> ('a, 'b) fmla nres" where
  "rb (Neg Q) = do { Q' \<leftarrow> rb Q; RETURN (simp (Neg Q'))}"
| "rb (Disj Q1 Q2) = do { Q1' \<leftarrow> rb Q1; Q2' \<leftarrow> rb Q2; RETURN (simp (Disj Q1' Q2'))}"
| "rb (Conj Q1 Q2) = do { Q1' \<leftarrow> rb Q1; Q2' \<leftarrow> rb Q2; RETURN (simp (Conj Q1' Q2'))}"
| "rb (Exists x Q) = do {
    Q' \<leftarrow> rb Q;
    \<Q> \<leftarrow> WHILE\<^sub>T\<^bsup>rb_INV x Q'\<^esup>
      (\<lambda>\<Q>. fixbound \<Q> x \<noteq> {}) (\<lambda>\<Q>. do {
        Qfix \<leftarrow> RES (fixbound \<Q> x);
        G \<leftarrow> SPEC (cov x Qfix);
        RETURN (\<Q> - {Qfix} \<union>
          {simp (Conj Qfix (DISJ (qps G)))} \<union>
          (\<Union>y \<in> eqs x G. {cp (Qfix[x \<^bold>\<rightarrow> y])}) \<union>
          {cp (Qfix \<^bold>\<bottom> x)})})
      (flat_Disj Q');
    RETURN (simp (DISJ (exists x ` \<Q>)))}"
| "rb Q = do { RETURN (simp Q) }"

lemma (in simplification) cov_fixbound: "cov x Q G \<Longrightarrow> x \<in> fv Q \<Longrightarrow>
  fixbound (insert (cp (Q \<^bold>\<bottom> x)) (insert (simp (Conj Q (DISJ (qps G))))
  (\<Q> - {Q} \<union> ((\<lambda>y. cp (Q[x \<^bold>\<rightarrow> y])) ` eqs x G)))) x = fixbound \<Q> x - {Q}"
  using Gen_simp[OF cov_Gen_qps[of x Q G]]
  by (auto 4 4 simp: fixbound_def nongens_def fv_subst split: if_splits
      dest!: fv_cp[THEN set_mp] fv_simp[THEN set_mp] fv_erase[THEN set_mp] dest: arg_cong[of _ _ fv] simp del: cp.simps)

lemma finite_fixbound[simp]: "finite \<Q> \<Longrightarrow> finite (fixbound \<Q> x)"
  unfolding fixbound_def by auto

lemma fixboundE[elim_format]: "Q \<in> fixbound \<Q> x \<Longrightarrow> x \<in> fv Q \<and> Q \<in> \<Q> \<and> \<not> Gen x Q"
  unfolding fixbound_def nongens_def by auto

lemma fixbound_fv: "Q \<in> fixbound \<Q> x \<Longrightarrow> x \<in> fv Q"
  unfolding fixbound_def nongens_def by auto

lemma fixbound_in: "Q \<in> fixbound \<Q> x \<Longrightarrow> Q \<in> \<Q>"
  unfolding fixbound_def nongens_def by auto

lemma fixbound_empty_Gen: "fixbound \<Q> x = {} \<Longrightarrow> x \<in> fv Q \<Longrightarrow> Q \<in> \<Q> \<Longrightarrow> Gen x Q"
  unfolding fixbound_def nongens_def by auto

lemma fixbound_insert:
  "fixbound (insert Q \<Q>) x = (if Gen x Q \<or> x \<notin> fv Q then fixbound \<Q> x else insert Q (fixbound \<Q> x))"
  by (auto simp: fixbound_def nongens_def)

lemma fixbound_empty[simp]:
  "fixbound {} x = {}"
  by (auto simp: fixbound_def)

lemma flat_Disj_Exists_sub: "Q' \<in> flat_Disj Q \<Longrightarrow> Exists y Qy \<in> sub Q' \<Longrightarrow> Exists y Qy \<in> sub Q"
  by (induct Q arbitrary: Q' rule: flat_Disj.induct) auto

lemma rrb_flat_Disj[simp]: "Q \<in> flat_Disj Q' \<Longrightarrow> rrb Q' \<Longrightarrow> rrb Q"
  by (induct Q' rule: flat_Disj.induct) auto

lemma (in simplification) rb_INV_finite[simp]: "rb_INV x Q \<Q> \<Longrightarrow> finite \<Q>"
  by (auto simp: rb_INV_def)

lemma (in simplification) rb_INV_fv: "rb_INV x Q \<Q> \<Longrightarrow> Q' \<in> \<Q> \<Longrightarrow> z \<in> fv Q' \<Longrightarrow> z \<in> fv Q"
  by (auto simp: rb_INV_def)

lemma (in simplification) rb_INV_rrb: "rb_INV x Q \<Q> \<Longrightarrow> Q' \<in> \<Q> \<Longrightarrow> rrb Q'"
  by (auto simp: rb_INV_def)

lemma (in simplification) rb_INV_cpropagated: "rb_INV x Q \<Q> \<Longrightarrow> Q' \<in> \<Q> \<Longrightarrow> simplified Q'"
  by (auto simp: rb_INV_def)

lemma (in simplification) rb_INV_equiv: "rb_INV x Q \<Q> \<Longrightarrow> Exists x Q \<triangleq> DISJ (exists x ` \<Q>)"
  by (auto simp: rb_INV_def)

lemma (in simplification) rb_INV_init[simp]: "simplified Q \<Longrightarrow> rrb Q \<Longrightarrow> rb_INV x Q (flat_Disj Q)"
  by (auto simp: rb_INV_def fv_flat_DisjD simplified_flat_DisjD
      equiv_trans[OF equiv_Exists_cong[OF DISJ_flat_Disj[THEN equiv_sym]] Exists_DISJ, simplified])

lemma (in simplification) rb_INV_step[simp]:
  fixes Q :: "('a :: {infinite, linorder}, 'b :: linorder) fmla"
  assumes "rb_INV x Q \<Q>" "Q' \<in> fixbound \<Q> x" "cov x Q' G"
  shows "rb_INV x Q (insert (cp (Q' \<^bold>\<bottom> x)) (insert (simp (Conj Q' (DISJ (qps G)))) (\<Q> - {Q'} \<union> (\<lambda>y. cp (Q'[x \<^bold>\<rightarrow> y])) ` eqs x G)))"
proof (rule rb_INV_I, goal_cases finite equiv rrb fv simplified)
  case finite
  from assms(1,3) show ?case by simp
next
  case equiv
  from assms show ?case
    unfolding rb_INV_def
    by (auto 0 5 simp: fixbound_fv exists_cp_erase exists_cp_subst eqs_noteq exists_Exists
        image_image image_Un insert_commute ac_simps dest: fixbound_in elim!: equiv_trans
        intro:
        equiv_trans[OF DISJ_push_in]
        equiv_trans[OF DISJ_insert_reorder']
        equiv_trans[OF DISJ_insert_reorder]
        intro!:
        equiv_trans[OF DISJ_exists_pull_out]
        equiv_trans[OF equiv_Disj_cong[OF cov_Exists_equiv equiv_refl]]
        equiv_trans[OF equiv_Disj_cong[OF equiv_Disj_cong[OF equiv_Exists_exists_cong[OF equiv_refl] equiv_refl] equiv_refl]]
        simp del: cp.simps)
next
  case (rrb Q)
  with assms show ?case
    unfolding rb_INV_def
    by (auto intro!: rrb_cp_subst rrb_cp[OF rrb_erase] rrb_simp[of "Conj _ _"] dest: fixbound_in simp del: cp.simps)
next
  case (fv Q')
  with assms show ?case
    unfolding rb_INV_def
    by (auto 0 4 dest!: fv_cp[THEN set_mp] fv_simp[THEN set_mp] fv_DISJ[THEN set_mp, rotated 1] fv_erase[THEN set_mp]
        cov_fv[OF assms(3) _ qps_in, rotated]
        cov_fv[OF assms(3) _ eqs_in, rotated] dest: fixbound_in
        simp: fv_subst fixbound_fv split: if_splits simp del: cp.simps)
next
  case (simplified Q')
  with assms show ?case
    unfolding rb_INV_def by (auto simp: simplified_simp simplified_cp simp del: cp.simps)
qed

lemma (in simplification) rb_correct:
  fixes Q :: "('a :: {linorder, infinite}, 'b :: linorder) fmla"
  shows "rb Q \<le> rb_spec Q"
proof (induct Q rule: rb.induct[case_names Neg Disj Conj Exists Pred Bool Eq])
  case (Exists x Q)
  then show ?case
    unfolding rb.simps rb_spec_def bind_rule_complete
    by (rule order_trans, refine_vcg WHILEIT_rule[where R="measure (\<lambda>\<Q>. card (fixbound \<Q> x))"])
      (auto simp: rb_INV_rrb rrb_simp simplified_simp fixbound_fv equiv_trans[OF equiv_Exists_cong rb_INV_equiv]
        cov_fixbound fixbound_empty_Gen card_gt_0_iff UNION_singleton_eq_range subset_eq
        intro!: equiv_simp[THEN equiv_trans, THEN equiv_sym, OF equiv_sym]
        dest!: fv_DISJ[THEN set_mp, rotated 1] fv_simp[THEN set_mp] elim!: bspec elim: rb_INV_fv simp del: cp.simps)
qed (auto simp: rb_spec_def bind_rule_complete rrb_simp simplified_simp subset_eq dest!: fv_simp[THEN set_mp]
  elim!: order_trans intro!: equiv_simp[THEN equiv_trans, THEN equiv_sym, OF equiv_sym] simp del: cp.simps)

(*<*)
end
(*>*)


theory Prelude_Eq
imports "$HETS_LIB/Isabelle/MainHC"
uses "$HETS_LIB/Isabelle/prelude"
begin

ML "Header.initialize
    [\"DiffTDef\", \"DiffFDef\", \"TE1\", \"TE2\", \"TE3\", \"TE4\",
     \"IBE1\", \"IBE2\", \"IBE3\", \"IBE5\", \"IBE6\", \"IBE7\",
     \"IBE8\", \"IUE1\", \"IUE2\", \"NotFalse\", \"NotTrue\",
     \"AndDef1\", \"AndDef2\", \"AndDef3\", \"AndDef4\", \"OrDef\",
     \"OtherwiseDef\", \"NotTrue1\", \"NotFalse2\", \"TB1\",
     \"EqualTDef\", \"SymDef\", \"EqualSym\", \"EqualReflex\",
     \"EqualTransT\", \"DiffDef\", \"IBE4\"]"

typedecl Unit

datatype Bool = X_False ("False''") | X_True ("True''")

consts
Not__X :: "Bool => Bool" ("(Not''/ _)" [56] 56)
X__XAmpXAmp__X :: "Bool => Bool => Bool" ("(_/ &&/ _)" [54,54] 52)
X__XEqXEq__X :: "'a => 'a => Bool" ("(_/ ==''/ _)" [54,54] 52)
X__XSlashXEq__X :: "'a => 'a => Bool" ("(_/ '/=/ _)" [54,54] 52)
X__XVBarXVBar__X :: "Bool => Bool => Bool" ("(_/ ||/ _)" [54,54] 52)
otherwiseH :: "Bool"

instance Bool:: type ..
instance Unit:: type ..

axioms
NotFalse [rule_format] : "Not' False' = True'"

NotTrue [rule_format] : "Not' True' = False'"

AndDef1 [rule_format] : "False' && False' = False'"

AndDef2 [rule_format] : "False' && True' = False'"

AndDef3 [rule_format] : "True' && False' = False'"

AndDef4 [rule_format] : "True' && True' = True'"

OrDef [rule_format] :
"ALL x. ALL y. x || y = Not' (Not' x && Not' y)"

OtherwiseDef [rule_format] : "otherwiseH = True'"

NotTrue1 [rule_format] : "ALL x. Not' x = True' = (x = False')"

NotFalse2 [rule_format] : "ALL x. Not' x = False' = (x = True')"

TB1 [rule_format] : "~ True' = False'"

EqualTDef [rule_format] : "ALL x. ALL y. x = y --> x ==' y = True'"

SymDef [rule_format] : "ALL x. ALL y. x ==' y = y ==' x"

EqualSym [rule_format] : "ALL x. ALL y. x ==' y = y ==' x"

EqualReflex [rule_format] : "ALL x. x ==' x = True'"

EqualTransT [rule_format] :
"ALL x.
 ALL y.
 ALL z. x ==' y = True' & y ==' z = True' --> x ==' z = True'"

DiffDef [rule_format] : "ALL x. ALL y. x /= y = Not' (x ==' y)"

IBE4 [rule_format] : "False' ==' True' = False'"

declare NotFalse [simp]
declare NotTrue [simp]
declare AndDef1 [simp]
declare AndDef2 [simp]
declare AndDef3 [simp]
declare AndDef4 [simp]
declare EqualReflex [simp]
declare IBE4 [simp]

theorem DiffTDef :
"ALL x. ALL y. x /= y = True' = (Not' (x ==' y) = True')"
apply(simp add: DiffDef)
done

ML "Header.record \"DiffTDef\""

theorem DiffFDef :
"ALL x. ALL y. x /= y = False' = (x ==' y = True')"
apply(auto)
apply(simp add: DiffDef)
apply(case_tac "x ==' y")
apply(auto)
apply(simp add: DiffDef)
done

ML "Header.record \"DiffFDef\""

theorem TE1 : "ALL x. ALL y. x ==' y = False' --> ~ x = y"
by auto

ML "Header.record \"TE1\""

theorem TE2 :
"ALL x. ALL y. Not' (x ==' y) = True' = (x ==' y = False')"
apply(auto)
apply(case_tac "x =='y")
apply(auto)
done

ML "Header.record \"TE2\""

theorem TE3 :
"ALL x. ALL y. Not' (x ==' y) = False' = (x ==' y = True')"
apply(auto)
apply(case_tac "x =='y")
apply(auto)
done

ML "Header.record \"TE3\""

theorem TE4 :
"ALL x. ALL y. (~ x ==' y = True') = (x ==' y = False')"
apply(auto)
apply(case_tac "x =='y")
apply(auto)
done

ML "Header.record \"TE4\""

theorem IBE1 : "True' ==' True' = True'"
by auto

ML "Header.record \"IBE1\""

theorem IBE2 : "False' ==' False' = True'"
by auto

ML "Header.record \"IBE2\""

theorem IBE3 : "True' ==' False' = False'"
apply(simp add: EqualSym)
done

ML "Header.record \"IBE3\""

theorem IBE5 : "True' /= False' = True'"
apply(simp add: DiffTDef)
apply(simp add: IBE3)
done

ML "Header.record \"IBE5\""

theorem IBE6 : "False' /= True' = True'"
apply(simp add: DiffTDef)
done

ML "Header.record \"IBE6\""

theorem IBE7 : "Not' (True' ==' False') = True'"
apply(simp add: IBE3)
done

ML "Header.record \"IBE7\""

theorem IBE8 : "Not' Not' (True' ==' False') = False'"
apply(simp add: IBE3)
done

ML "Header.record \"IBE8\""

theorem IUE1 : "() ==' () = True'"
by auto

ML "Header.record \"IUE1\""

theorem IUE2 : "() /= () = False'"
apply(simp add: DiffFDef)
done

ML "Header.record \"IUE2\""

end


(*  Title:      HOL/Metis_Examples/Clausification.thy
    Author:     Jasmin Blanchette, TU Muenchen

Example that exercises Metis's Clausifier.
*)

section \<open>Example that Exercises Metis's Clausifier\<close>

theory Clausification
imports Complex_Main
begin

text \<open>Definitional CNF for facts\<close>

declare [[meson_max_clauses = 10]]

axiomatization q :: "nat \<Rightarrow> nat \<Rightarrow> bool" where
qax: "\<exists>b. \<forall>a. (q b a \<and> q 0 0 \<and> q 1 a \<and> q a 1) \<or> (q 0 1 \<and> q 1 0 \<and> q a b \<and> q 1 1)"

declare [[metis_new_skolem = false]]

lemma "\<exists>b. \<forall>a. (q b a \<or> q a b)"
by (metis qax)

lemma "\<exists>b. \<forall>a. (q b a \<or> q a b)"
by (metis (full_types) qax)

lemma "\<exists>b. \<forall>a. (q b a \<and> q 0 0 \<and> q 1 a \<and> q a 1) \<or> (q 0 1 \<and> q 1 0 \<and> q a b \<and> q 1 1)"
by (metis qax)

lemma "\<exists>b. \<forall>a. (q b a \<and> q 0 0 \<and> q 1 a \<and> q a 1) \<or> (q 0 1 \<and> q 1 0 \<and> q a b \<and> q 1 1)"
by (metis (full_types) qax)

declare [[metis_new_skolem]]

lemma "\<exists>b. \<forall>a. (q b a \<or> q a b)"
by (metis qax)

lemma "\<exists>b. \<forall>a. (q b a \<or> q a b)"
by (metis (full_types) qax)

lemma "\<exists>b. \<forall>a. (q b a \<and> q 0 0 \<and> q 1 a \<and> q a 1) \<or> (q 0 1 \<and> q 1 0 \<and> q a b \<and> q 1 1)"
by (metis qax)

lemma "\<exists>b. \<forall>a. (q b a \<and> q 0 0 \<and> q 1 a \<and> q a 1) \<or> (q 0 1 \<and> q 1 0 \<and> q a b \<and> q 1 1)"
by (metis (full_types) qax)

declare [[meson_max_clauses = 60]]

axiomatization r :: "nat \<Rightarrow> nat \<Rightarrow> bool" where
rax: "(r 0 0 \<and> r 0 1 \<and> r 0 2 \<and> r 0 3) \<or>
      (r 1 0 \<and> r 1 1 \<and> r 1 2 \<and> r 1 3) \<or>
      (r 2 0 \<and> r 2 1 \<and> r 2 2 \<and> r 2 3) \<or>
      (r 3 0 \<and> r 3 1 \<and> r 3 2 \<and> r 3 3)"

declare [[metis_new_skolem = false]]

lemma "r 0 0 \<or> r 1 1 \<or> r 2 2 \<or> r 3 3"
by (metis rax)

lemma "r 0 0 \<or> r 1 1 \<or> r 2 2 \<or> r 3 3"
by (metis (full_types) rax)

declare [[metis_new_skolem]]

lemma "r 0 0 \<or> r 1 1 \<or> r 2 2 \<or> r 3 3"
by (metis rax)

lemma "r 0 0 \<or> r 1 1 \<or> r 2 2 \<or> r 3 3"
by (metis (full_types) rax)

lemma "(r 0 0 \<and> r 0 1 \<and> r 0 2 \<and> r 0 3) \<or>
       (r 1 0 \<and> r 1 1 \<and> r 1 2 \<and> r 1 3) \<or>
       (r 2 0 \<and> r 2 1 \<and> r 2 2 \<and> r 2 3) \<or>
       (r 3 0 \<and> r 3 1 \<and> r 3 2 \<and> r 3 3)"
by (metis rax)

lemma "(r 0 0 \<and> r 0 1 \<and> r 0 2 \<and> r 0 3) \<or>
       (r 1 0 \<and> r 1 1 \<and> r 1 2 \<and> r 1 3) \<or>
       (r 2 0 \<and> r 2 1 \<and> r 2 2 \<and> r 2 3) \<or>
       (r 3 0 \<and> r 3 1 \<and> r 3 2 \<and> r 3 3)"
by (metis (full_types) rax)

text \<open>Definitional CNF for goal\<close>

axiomatization p :: "nat \<Rightarrow> nat \<Rightarrow> bool" where
pax: "\<exists>b. \<forall>a. (p b a \<and> p 0 0 \<and> p 1 a) \<or> (p 0 1 \<and> p 1 0 \<and> p a b)"

declare [[metis_new_skolem = false]]

lemma "\<exists>b. \<forall>a. \<exists>x. (p b a \<or> x) \<and> (p 0 0 \<or> x) \<and> (p 1 a \<or> x) \<and>
                   (p 0 1 \<or> \<not> x) \<and> (p 1 0 \<or> \<not> x) \<and> (p a b \<or> \<not> x)"
by (metis pax)

lemma "\<exists>b. \<forall>a. \<exists>x. (p b a \<or> x) \<and> (p 0 0 \<or> x) \<and> (p 1 a \<or> x) \<and>
                   (p 0 1 \<or> \<not> x) \<and> (p 1 0 \<or> \<not> x) \<and> (p a b \<or> \<not> x)"
by (metis (full_types) pax)

declare [[metis_new_skolem]]

lemma "\<exists>b. \<forall>a. \<exists>x. (p b a \<or> x) \<and> (p 0 0 \<or> x) \<and> (p 1 a \<or> x) \<and>
                   (p 0 1 \<or> \<not> x) \<and> (p 1 0 \<or> \<not> x) \<and> (p a b \<or> \<not> x)"
by (metis pax)

lemma "\<exists>b. \<forall>a. \<exists>x. (p b a \<or> x) \<and> (p 0 0 \<or> x) \<and> (p 1 a \<or> x) \<and>
                   (p 0 1 \<or> \<not> x) \<and> (p 1 0 \<or> \<not> x) \<and> (p a b \<or> \<not> x)"
by (metis (full_types) pax)

text \<open>New Skolemizer\<close>

declare [[metis_new_skolem]]

lemma
  fixes x :: real
  assumes fn_le: "!!n. f n \<le> x" and 1: "f \<longlonglongrightarrow> lim f"
  shows "lim f \<le> x"
by (metis 1 LIMSEQ_le_const2 fn_le)

definition
  bounded :: "'a::metric_space set \<Rightarrow> bool" where
  "bounded S \<longleftrightarrow> (\<exists>x eee. \<forall>y\<in>S. dist x y \<le> eee)"

lemma "bounded T \<Longrightarrow> S \<subseteq> T ==> bounded S"
by (metis bounded_def subset_eq)

lemma
  assumes a: "Quotient R Abs Rep T"
  shows "symp R"
using a unfolding Quotient_def using sympI
by (metis (full_types))

lemma
  "(\<exists>x \<in> set xs. P x) \<longleftrightarrow>
   (\<exists>ys x zs. xs = ys @ x # zs \<and> P x \<and> (\<forall>z \<in> set zs. \<not> P z))"
by (metis split_list_last_prop[where P = P] in_set_conv_decomp)

lemma ex_tl: "\<exists>ys. tl ys = xs"
using list.sel(3) by fast

lemma "(\<exists>ys::nat list. tl ys = xs) \<and> (\<exists>bs::int list. tl bs = as)"
by (metis ex_tl)

end


(*  Title:       Conflict analysis/Monitor Consistent Interleaving
    Author:      Peter Lammich <peter.lammich@uni-muenster.de>
    Maintainer:  Peter Lammich <peter.lammich@uni-muenster.de>
*)
section "Monitor Consistent Interleaving"
theory ConsInterleave
imports Interleave Misc
begin
text_raw \<open>\label{thy:ConsInterleave}\<close>

text \<open>The monitor consistent interleaving operator is defined on two lists of arbitrary elements, provided an abstraction function @{term \<alpha>} that maps list elements to pairs of sets of monitors is available.
  @{term "\<alpha> e = (M,M')"} intuitively means that step @{term e} enters the monitors in @{term M} and passes (enters and leaves) the monitors in @{term M'}.
  The consistent interleaving describes all interleavings of the two lists that are consistent w.r.t. the monitor usage.
\<close>

subsection "Monitors of lists of monitor pairs"
text \<open>The following defines the set of all monitors that occur in a list of pairs of monitors. This definition is used in the following context:
  \<open>mon_pl (map \<alpha> w)\<close> is the set of monitors used by a word \<open>w\<close> w.r.t. the abstraction \<open>\<alpha>\<close>\<close>
definition
  "mon_pl w == foldl (\<union>) {} (map (\<lambda>e. fst e \<union> snd e) w)"

lemma mon_pl_empty[simp]: "mon_pl [] = {}"
  by (unfold mon_pl_def, auto)
lemma mon_pl_cons[simp]: "mon_pl (e#w) = fst e \<union> snd e \<union> mon_pl w"
  by (unfold mon_pl_def) (simp, subst foldl_un_empty_eq, auto)

lemma mon_pl_unconc: "!!b. mon_pl (a@b) = mon_pl a \<union> mon_pl b"
  by (induct a) auto

lemma mon_pl_ileq: "w\<preceq>w' \<Longrightarrow> mon_pl w \<subseteq> mon_pl w'"
  by (induct rule: less_eq_list_induct) auto

lemma mon_pl_set: "mon_pl w = \<Union>{ fst e \<union> snd e | e. e\<in>set w }"
  by (auto simp add: mon_pl_def foldl_set) blast+

fun
  cil :: "'a list \<Rightarrow> ('a \<Rightarrow> ('m set \<times> 'm set)) \<Rightarrow> 'a list \<Rightarrow> 'a list set"
    ("_ \<otimes>\<^bsub>_\<^esub> _" [64,64,64] 64) where
  \<comment> \<open>Interleaving with the empty word results in the empty word\<close>
  "[] \<otimes>\<^bsub>\<alpha> \<^esub> w = {w}"
  | "w \<otimes>\<^bsub>\<alpha>\<^esub> [] = {w}"
  \<comment> \<open>If both words are not empty, we can take the first step of one word,
  interleave the rest with the other word and then append
  the first step to all result set elements, provided it does not allocate
  a monitor that is used by the other word\<close>
  | "e1#w1 \<otimes>\<^bsub>\<alpha>\<^esub> e2#w2 = (
    if fst (\<alpha> e1) \<inter> mon_pl (map \<alpha> (e2#w2)) = {} then
      e1\<cdot>(w1 \<otimes>\<^bsub>\<alpha>\<^esub> e2#w2)
    else {}
  ) \<union> (
    if fst (\<alpha> e2) \<inter> mon_pl (map \<alpha> (e1#w1)) = {} then
      e2\<cdot>(e1#w1 \<otimes>\<^bsub>\<alpha>\<^esub> w2)
    else {}
  )"

text \<open>Note that this definition allows reentrant monitors, because it only checks that a monitor that is going to be entered by one word is not used in the {\em other} word. Thus the same word may enter the same monitor
  multiple times.\<close>

text \<open>The next lemmas are some auxiliary lemmas to simplify the handling of the consistent interleaving operator.\<close>
lemma cil_last_case_split[cases set, case_names left right]: "
  \<lbrakk> w\<in>e1#w1 \<otimes>\<^bsub>\<alpha>\<^esub> e2#w2;
    !!w'. \<lbrakk>w=e1#w'; w'\<in>(w1 \<otimes>\<^bsub>\<alpha>\<^esub> e2#w2);
           fst (\<alpha> e1) \<inter> mon_pl (map \<alpha> (e2#w2)) = {} \<rbrakk> \<Longrightarrow> P;
    !!w'. \<lbrakk>w=e2#w'; w'\<in>(e1#w1 \<otimes>\<^bsub>\<alpha>\<^esub> w2);
           fst (\<alpha> e2) \<inter> mon_pl (map \<alpha> (e1#w1)) = {} \<rbrakk> \<Longrightarrow> P
  \<rbrakk> \<Longrightarrow> P"
  by (auto elim: list_set_cons_cases split: if_split_asm)

lemma cil_cases[cases set, case_names both_empty left_empty right_empty app_left app_right]: "
  \<lbrakk> w\<in>wa\<otimes>\<^bsub>\<alpha>\<^esub>wb;
    \<lbrakk> w=[]; wa=[]; wb=[] \<rbrakk> \<Longrightarrow> P;
    \<lbrakk>wa=[]; w=wb\<rbrakk> \<Longrightarrow> P;
    \<lbrakk> w=wa; wb=[] \<rbrakk> \<Longrightarrow> P;
    !!ea wa' w'. \<lbrakk>w=ea#w'; wa=ea#wa'; w'\<in>wa'\<otimes>\<^bsub>\<alpha>\<^esub>wb;
                  fst (\<alpha> ea) \<inter> mon_pl (map \<alpha> wb) = {}  \<rbrakk> \<Longrightarrow> P;
    !!eb wb' w'. \<lbrakk>w=eb#w'; wb=eb#wb'; w'\<in>wa\<otimes>\<^bsub>\<alpha>\<^esub>wb';
                  fst (\<alpha> eb) \<inter> mon_pl (map \<alpha> wa) = {}  \<rbrakk> \<Longrightarrow> P
  \<rbrakk> \<Longrightarrow> P"
proof (induct wa \<alpha> wb rule: cil.induct)
  case 1 thus ?case by simp next
  case 2 thus ?case by simp next
  case (3 ea wa' \<alpha> eb wb')
  from "3.prems"(1) show ?thesis proof (cases rule: cil_last_case_split)
    case (left w') from "3.prems"(5)[OF left(1) _ left(2,3)] show ?thesis by simp next
    case (right w') from "3.prems"(6)[OF right(1) _ right(2,3)] show ?thesis by simp
  qed
qed

lemma cil_induct'[case_names both_empty left_empty right_empty append]: "\<lbrakk>
  \<And>\<alpha>. P \<alpha> [] [];
  \<And>\<alpha> ad ae. P \<alpha> [] (ad # ae);
  \<And>\<alpha> z aa. P \<alpha> (z # aa) [];
  \<And>\<alpha> e1 w1 e2 w2. \<lbrakk>
    \<lbrakk>fst (\<alpha> e1) \<inter> mon_pl (map \<alpha> (e2 # w2)) = {}\<rbrakk> \<Longrightarrow> P \<alpha> w1 (e2 # w2);
    \<lbrakk>fst (\<alpha> e2) \<inter> mon_pl (map \<alpha> (e1 # w1)) = {}\<rbrakk> \<Longrightarrow> P \<alpha> (e1 # w1) w2\<rbrakk>
  \<Longrightarrow> P \<alpha> (e1 # w1) (e2 # w2)
  \<rbrakk> \<Longrightarrow> P \<alpha> wa wb"
  apply (induct wa \<alpha> wb rule: cil.induct)
  apply (case_tac w)
  apply auto
  done

lemma cil_induct_fix\<alpha>: "\<lbrakk>
  P \<alpha> [] [];
  \<And>ad ae. P \<alpha> [] (ad # ae);
  \<And>z aa. P \<alpha> (z # aa) [];
  \<And>e1 w1 e2 w2.
    \<lbrakk>fst (\<alpha> e2) \<inter> mon_pl (map \<alpha> (e1 # w1)) = {} \<longrightarrow> P \<alpha> (e1 # w1) w2;
     fst (\<alpha> e1) \<inter> mon_pl (map \<alpha> (e2 # w2)) = {} \<longrightarrow> P \<alpha> w1 (e2 # w2)\<rbrakk>
     \<Longrightarrow> P \<alpha> (e1 # w1) (e2 # w2)\<rbrakk>
  \<Longrightarrow> P \<alpha> v w"
  apply (induct v \<alpha> w rule: cil.induct)
  apply (case_tac w)
  apply auto
  done

lemma cil_induct_fix\<alpha>'[case_names both_empty left_empty right_empty append]: "\<lbrakk>
  P \<alpha> [] [];
  \<And>ad ae. P \<alpha> [] (ad # ae);
  \<And>z aa. P \<alpha> (z # aa) [];
  \<And>e1 w1 e2 w2. \<lbrakk>
    fst (\<alpha> e1) \<inter> mon_pl (map \<alpha> (e2 # w2)) = {} \<Longrightarrow> P \<alpha> w1 (e2 # w2);
    fst (\<alpha> e2) \<inter> mon_pl (map \<alpha> (e1 # w1)) = {} \<Longrightarrow> P \<alpha> (e1 # w1) w2\<rbrakk>
    \<Longrightarrow> P \<alpha> (e1 # w1) (e2 # w2)
  \<rbrakk> \<Longrightarrow> P \<alpha> wa wb"
  apply (induct wa \<alpha> wb rule: cil.induct)
  apply (case_tac w)
  apply auto
  done

lemma cil_contains_empty[rule_format, simp]: "([] \<in> wa\<otimes>\<^bsub>\<alpha>\<^esub>wb) = (wa=[] \<and> wb=[])"
  by (induct wa \<alpha> wb rule: cil.induct) auto

lemma cil_cons_cases[cases set, case_names left right]: "\<lbrakk> e#w \<in> w1\<otimes>\<^bsub>\<alpha>\<^esub>w2;
  !!w1'. \<lbrakk>w1=e#w1'; w\<in>w1'\<otimes>\<^bsub>\<alpha>\<^esub>w2; fst (\<alpha> e) \<inter> mon_pl (map \<alpha> w2) = {} \<rbrakk> \<Longrightarrow> P;
  !!w2'. \<lbrakk>w2=e#w2'; w\<in>w1\<otimes>\<^bsub>\<alpha>\<^esub>w2'; fst (\<alpha> e) \<inter> mon_pl (map \<alpha> w1) = {} \<rbrakk> \<Longrightarrow> P
\<rbrakk> \<Longrightarrow> P"
  by (cases rule: cil_cases) auto

lemma cil_set_induct[induct set, case_names empty left right]: "!!\<alpha> w1 w2. \<lbrakk>
    w\<in>w1\<otimes>\<^bsub>\<alpha>\<^esub>w2;
    !!\<alpha>. P [] \<alpha> [] [];
    !!\<alpha> e w' w1' w2. \<lbrakk>w'\<in>w1'\<otimes>\<^bsub>\<alpha>\<^esub>w2; fst (\<alpha> e) \<inter> mon_pl (map \<alpha> w2) = {};
                      P w' \<alpha> w1' w2 \<rbrakk> \<Longrightarrow> P (e#w') \<alpha> (e#w1') w2;
    !!\<alpha> e w' w2' w1. \<lbrakk>w'\<in>w1\<otimes>\<^bsub>\<alpha>\<^esub>w2'; fst (\<alpha> e) \<inter> mon_pl (map \<alpha> w1) = {};
                      P w' \<alpha> w1 w2' \<rbrakk> \<Longrightarrow> P (e#w') \<alpha> w1 (e#w2')
  \<rbrakk> \<Longrightarrow> P w \<alpha> w1 w2"
  by (induct w) (auto intro!: cil_contains_empty elim: cil_cons_cases)

lemma cil_set_induct_fix\<alpha>[induct set, case_names empty left right]: "!!w1 w2. \<lbrakk>
    w\<in>w1\<otimes>\<^bsub>\<alpha>\<^esub>w2;
    P [] \<alpha> [] [];
    !!e w' w1' w2. \<lbrakk>w'\<in>w1'\<otimes>\<^bsub>\<alpha>\<^esub>w2; fst (\<alpha> e) \<inter> mon_pl (map \<alpha> w2) = {};
                    P w' \<alpha> w1' w2 \<rbrakk> \<Longrightarrow> P (e#w') \<alpha> (e#w1') w2;
    !!e w' w2' w1. \<lbrakk>w'\<in>w1\<otimes>\<^bsub>\<alpha>\<^esub>w2'; fst (\<alpha> e) \<inter> mon_pl (map \<alpha> w1) = {};
                    P w' \<alpha> w1 w2' \<rbrakk> \<Longrightarrow> P (e#w') \<alpha> w1 (e#w2')
  \<rbrakk> \<Longrightarrow> P w \<alpha> w1 w2"
  by (induct w) (auto intro!: cil_contains_empty elim: cil_cons_cases)

lemma cil_cons1: "\<lbrakk>w\<in>wa\<otimes>\<^bsub>\<alpha>\<^esub>wb; fst (\<alpha> e) \<inter> mon_pl (map \<alpha> wb) = {}\<rbrakk>
                  \<Longrightarrow> e#w \<in> e#wa \<otimes>\<^bsub>\<alpha>\<^esub> wb"
  by (cases wb) auto
lemma cil_cons2: "\<lbrakk>w\<in>wa\<otimes>\<^bsub>\<alpha>\<^esub>wb; fst (\<alpha> e) \<inter> mon_pl (map \<alpha> wa) = {}\<rbrakk>
                  \<Longrightarrow> e#w \<in> wa \<otimes>\<^bsub>\<alpha>\<^esub> e#wb"
  by (cases wa) auto

subsection "Properties of consistent interleaving"

\<comment> \<open>Consistent interleaving is a restriction of interleaving\<close>

lemma cil_subset_il': "w\<in>w1\<otimes>\<^bsub>\<alpha>\<^esub>w2 \<Longrightarrow> w\<in>w1\<otimes>w2"
  using cil_subset_il by (auto)

\<comment> \<open>Consistent interleaving preserves the set of letters of both operands\<close>
lemma cil_set: "w\<in>w1\<otimes>\<^bsub>\<alpha>\<^esub>w2 \<Longrightarrow> set w = set w1 \<union> set w2"
  by (induct rule: cil_set_induct_fix\<alpha>) auto
corollary cil_mon_pl: "w\<in>w1\<otimes>\<^bsub>\<alpha>\<^esub>w2
  \<Longrightarrow> mon_pl (map \<alpha> w) = mon_pl (map \<alpha> w1) \<union> mon_pl (map \<alpha> w2)"
  by (subst mon_pl_unconc[symmetric]) (simp add: mon_pl_set cil_set, blast 20)

\<comment> \<open>Consistent interleaving preserves the length of both operands\<close>
lemma cil_length[rule_format]: "\<forall>w\<in>wa\<otimes>\<^bsub>\<alpha>\<^esub>wb. length w = length wa + length wb"
  by (induct rule: cil.induct) auto

\<comment> \<open>Consistent interleaving contains all letters of each operand in the original order\<close>
lemma cil_ileq: "w\<in>w1\<otimes>\<^bsub>\<alpha>\<^esub>w2 \<Longrightarrow> w1\<preceq>w \<and> w2\<preceq>w"
  by (intro conjI cil_subset_il' ileq_interleave)

\<comment> \<open>Consistent interleaving is commutative and associative\<close>
lemma cil_commute: "w\<otimes>\<^bsub>\<alpha>\<^esub>w' = w'\<otimes>\<^bsub>\<alpha>\<^esub>w"
  by (induct rule: cil.induct) auto

lemma cil_assoc1: "!!wl w1 w2 w3. \<lbrakk> w\<in>wl\<otimes>\<^bsub>\<alpha>\<^esub>w3; wl\<in>w1\<otimes>\<^bsub>\<alpha>\<^esub>w2 \<rbrakk>
  \<Longrightarrow> \<exists>wr. w\<in>w1\<otimes>\<^bsub>\<alpha>\<^esub>wr \<and> wr\<in>w2\<otimes>\<^bsub>\<alpha>\<^esub>w3"
proof (induct w rule: length_compl_induct)
  case Nil thus ?case by auto
next
  case (Cons e w) from Cons.prems(1) show ?case proof (cases rule: cil_cons_cases)
    case (left wl') with Cons.prems(2) have "e#wl' \<in> w1\<otimes>\<^bsub>\<alpha>\<^esub>w2" by simp
    thus ?thesis proof (cases rule: cil_cons_cases[case_names left' right'])
      case (left' w1')
      from Cons.hyps[OF _ left(2) left'(2)] obtain wr where IHAPP: "w \<in> w1' \<otimes>\<^bsub>\<alpha>\<^esub> wr" "wr \<in> w2 \<otimes>\<^bsub>\<alpha>\<^esub> w3" by blast
      have "e#w\<in>e#w1'\<otimes>\<^bsub>\<alpha>\<^esub>wr" proof (rule cil_cons1[OF IHAPP(1)])
        from left left' cil_mon_pl[OF IHAPP(2)] show "fst (\<alpha> e) \<inter> mon_pl (map \<alpha> wr) = {}" by auto
      qed
      thus ?thesis using IHAPP(2) left' by blast
    next
      case (right' w2') from Cons.hyps[OF _ left(2) right'(2)] obtain wr where IHAPP: "w \<in> w1 \<otimes>\<^bsub>\<alpha>\<^esub> wr" "wr \<in> w2' \<otimes>\<^bsub>\<alpha>\<^esub> w3" by blast
      from IHAPP(2) left have "e#wr \<in> e#w2' \<otimes>\<^bsub>\<alpha>\<^esub> w3" by (auto intro: cil_cons1)
      moreover from right' IHAPP(1) have "e#w \<in> w1 \<otimes>\<^bsub>\<alpha>\<^esub> e#wr" by (auto intro: cil_cons2)
      ultimately show ?thesis using right' by blast
    qed
  next
    case (right w3') from Cons.hyps[OF _ right(2) Cons.prems(2)] obtain wr where IHAPP: "w \<in> w1 \<otimes>\<^bsub>\<alpha>\<^esub> wr" "wr \<in> w2 \<otimes>\<^bsub>\<alpha>\<^esub> w3'" by blast
    from IHAPP(2) right cil_mon_pl[OF Cons.prems(2)] have "e#wr \<in> w2 \<otimes>\<^bsub>\<alpha>\<^esub> e#w3'" by (auto intro: cil_cons2)
    moreover from IHAPP(1) right cil_mon_pl[OF Cons.prems(2)] have "e#w \<in> w1 \<otimes>\<^bsub>\<alpha>\<^esub> e#wr" by (auto intro: cil_cons2)
    ultimately show ?thesis using right by blast
  qed
qed

lemma cil_assoc2:
  assumes A: "w\<in>w1\<otimes>\<^bsub>\<alpha>\<^esub>wr" and B: "wr\<in>w2\<otimes>\<^bsub>\<alpha>\<^esub>w3"
  shows "\<exists>wl. w\<in>wl\<otimes>\<^bsub>\<alpha>\<^esub>w3 \<and> wl\<in>w1\<otimes>\<^bsub>\<alpha>\<^esub>w2"
proof -
  from A have A': "w\<in>wr\<otimes>\<^bsub>\<alpha>\<^esub>w1" by (simp add: cil_commute)
  from B have B': "wr\<in>w3\<otimes>\<^bsub>\<alpha>\<^esub>w2" by (simp add: cil_commute)
  from cil_assoc1[OF A' B'] obtain wl where "w \<in> w3 \<otimes>\<^bsub>\<alpha>\<^esub> wl \<and> wl \<in> w2 \<otimes>\<^bsub>\<alpha>\<^esub> w1" by blast
  thus ?thesis by (auto simp add: cil_commute)
qed

\<comment> \<open>Parts of the abstraction can be moved to the operands\<close>
(* FIXME: ?? Something strange is going on with the simplification of \<alpha>\<circ>f and implicit \<eta>-contraction/expansion, hence this lengthy isar proof. Usually, this proof should be a just few lines apply-script !*)
lemma cil_map: "w\<in>w1 \<otimes>\<^bsub>(\<alpha>\<circ>f)\<^esub> w2 \<Longrightarrow> map f w \<in> map f w1 \<otimes>\<^bsub>\<alpha>\<^esub> map f w2"
proof (induct rule: cil_set_induct_fix\<alpha>)
  case empty thus ?case by auto
next
  case (left e w' w1' w2)
  have "f e # map f w' \<in> f e # map f w1' \<otimes>\<^bsub>\<alpha>\<^esub> map f w2" proof (rule cil_cons1)
    from left(2) have "fst ((\<alpha>\<circ>f) e) \<inter> mon_pl (map \<alpha> (map f w2)) = {}" by (simp only: map_map[symmetric])
    thus "fst (\<alpha> (f e)) \<inter> mon_pl (map \<alpha> (map f w2)) = {}" by (simp only: o_apply)
  qed (rule left(3))
  thus ?case by simp
next
  case (right e w' w2' w1)
  have "f e # map f w' \<in> map f w1 \<otimes>\<^bsub>\<alpha>\<^esub> f e # map f w2'" proof (rule cil_cons2)
    from right(2) have "fst ((\<alpha>\<circ>f) e) \<inter> mon_pl (map \<alpha> (map f w1)) = {}" by (simp only: map_map[symmetric])
    thus "fst (\<alpha> (f e)) \<inter> mon_pl (map \<alpha> (map f w1)) = {}" by (simp only: o_apply)
  qed (rule right(3))
  thus ?case by simp
qed

end


(* Author: Joshua Schneider, ETH Zurich *)

subsection \<open>Set with Cartesian product\<close>

theory Applicative_Set imports
  Applicative
  "~~/src/Tools/Adhoc_Overloading"
begin

definition ap_set :: "('a \<Rightarrow> 'b) set \<Rightarrow> 'a set \<Rightarrow> 'b set"
  where "ap_set F X = {f x | f x. f \<in> F \<and> x \<in> X}"

adhoc_overloading Applicative.ap ap_set

lemma ap_set_transfer[transfer_rule]:
  "rel_fun (rel_set (rel_fun A B)) (rel_fun (rel_set A) (rel_set B)) ap_set ap_set"
unfolding ap_set_def[abs_def] rel_set_def
by (fastforce elim: rel_funE)

applicative set (C)
for
  pure: "\<lambda>x. {x}"
  ap: ap_set
  rel: rel_set
  set: "\<lambda>x. x"
proof -
  fix R :: "'a \<Rightarrow> 'b \<Rightarrow> bool"
  show "rel_fun R (rel_set R) (\<lambda>x. {x}) (\<lambda>x. {x})" by (auto intro: rel_setI)
next
  fix R and f :: "('a \<Rightarrow> 'b) set" and g :: "('a \<Rightarrow> 'c) set" and x
  assume [transfer_rule]: "rel_set (rel_fun (eq_on x) R) f g"
  have [transfer_rule]: "rel_set (eq_on x) x x" by (auto intro: rel_setI)
  show "rel_set R (ap_set f x) (ap_set g x)" by transfer_prover
qed (unfold ap_set_def, fast+)

end


section {* Entry Point for the Automatic Refinement Tool *}
theory Automatic_Refinement
imports
  "Tool/Autoref_Tool"
  "Autoref_Bindings_HOL"
begin
  text {* The automatic refinement tool should be used by
    importing this theory *}

subsection {* Convenience *}

text {* The following lemmas can be used to add tags to theorems *}
lemma PREFER_I: "P x \<Longrightarrow> PREFER P x" by simp
lemma PREFER_D: "PREFER P x \<Longrightarrow> P x" by simp

lemmas PREFER_sv_D = PREFER_D[of single_valued]
lemma PREFER_id_D: "PREFER_id R \<Longrightarrow> R=Id" by simp

abbreviation "PREFER_RUNIV \<equiv> PREFER (\<lambda>R. Range R = UNIV)"
lemmas PREFER_RUNIV_D = PREFER_D[of "(\<lambda>R. Range R = UNIV)"]

lemma SIDE_GEN_ALGO_D: "SIDE_GEN_ALGO P \<Longrightarrow> P" by simp

lemma GEN_OP_D: "GEN_OP c a R \<Longrightarrow> (c,a)\<in>R"
  by simp

lemma MINOR_PRIO_TAG_I: "P \<Longrightarrow> (MINOR_PRIO_TAG p \<Longrightarrow> P)" by auto
lemma MAJOR_PRIO_TAG_I: "P \<Longrightarrow> (MAJOR_PRIO_TAG p \<Longrightarrow> P)" by auto
lemma PRIO_TAG_I: "P \<Longrightarrow> (PRIO_TAG ma mi \<Longrightarrow> P)" by auto

end


section \<open>Hoare-Triples\<close>
theory Hoare_Triple
imports Assertions
begin

text \<open>In this theory, we define Hoare-Triples, which are our basic tool
  for specifying properties of Imperative HOL programs.\<close>

subsection \<open>Definition\<close>

text \<open>Analyze the heap before and after executing a command, to add
  the allocated addresses to the covered address range.\<close>
definition new_addrs :: "heap \<Rightarrow> addr set \<Rightarrow> heap \<Rightarrow> addr set" where
  "new_addrs h as h' = as \<union> {a. lim h \<le> a \<and> a < lim h'}"

lemma new_addr_refl[simp]: "new_addrs h as h = as"
  unfolding new_addrs_def by auto

text \<open>
  Apart from correctness of the program wrt. the pre- and post condition,
  a Hoare-triple also encodes some well-formedness conditions of the command:
  The command must not change addresses outside the address range of the
  precondition, and it must not decrease the heap limit.

  Note that we do not require that the command only reads from heap locations
  inside the precondition's address range, as this condition would be quite
  complicated to express with the heap model of Imperative/HOL, and is not
  necessary in our formalization of partial heaps, that always contain the
  information for all addresses.
\<close>

definition hoare_triple
  :: "assn \<Rightarrow> 'a Heap \<Rightarrow> ('a \<Rightarrow> assn) \<Rightarrow> bool" ("<_>/ _/ <_>")
  where
  "<P> c <Q> \<equiv> \<forall>h as. (h,as)\<Turnstile>P \<longrightarrow> (\<exists>r h' t. execute c h = Some (r,h',t)
  \<and> (let as'=new_addrs h as h' in
      (h',as')\<Turnstile>Q r \<and> relH ({a . a<lim h \<and> a\<notin>as}) h h'
    \<and> lim h \<le> lim h'))"

text \<open>Sanity checking theorems for Hoare-Triples\<close>
lemma
  assumes "<P> c <Q>"
  assumes "(h,as)\<Turnstile>P"
  shows hoare_triple_success: "success c h"
    and hoare_triple_effect: "\<exists>h' r t. effect c h h' r t \<and> (h',new_addrs h as h')\<Turnstile>Q r"
  using assms
  unfolding hoare_triple_def success_def effect_def
  apply -
  apply (auto simp: Let_def) apply fastforce+ done

lemma hoare_tripleE:
  assumes "<P> c <Q>"
  assumes "(h,as)\<Turnstile>P"
  obtains r h' t where
    "execute c h = Some (r,h',t)"
    "(h',new_addrs h as h')\<Turnstile>Q r"
    "relH ({a . a<lim h \<and> a\<notin>as}) h h'"
    "lim h \<le> lim h'"
  using assms
  unfolding hoare_triple_def Let_def
  by blast

lemma hoare_tripleI[intro?]:
  assumes "\<And>h as. (h,as)\<Turnstile>P \<Longrightarrow> (\<exists>r h' t.
    execute c h = Some (r,h',t)
  \<and> (h',new_addrs h as h') \<Turnstile> Q r
  \<and> relH ({a . a<lim h \<and> a\<notin>as}) h h'
  \<and> lim h \<le> lim h'
  )"
  shows "<P> c <Q>"
  using assms unfolding hoare_triple_def Let_def
  by blast

(*lemma hoare_tripleD:
  fixes h h' as as' r
  assumes "<P> c <Q>"
  assumes "(h,as)\<Turnstile>P"
  assumes "execute c h = Some (r,h')"
  defines "as'\<equiv>new_addrs h as h'"
  shows "(h',as')\<Turnstile>Q r"
  and "relH ({a . a<lim h \<and> a\<notin>as}) h h'"
  and "lim h \<le> lim h'"
  using assms
  unfolding hoare_triple_def as'_def
  apply (auto simp: Let_def)
*)

text \<open>For garbage-collected languages, specifications usually allow for some
  arbitrary heap parts in the postcondition. The following abbreviation defines
  a handy shortcut notation for such specifications.\<close>
abbreviation hoare_triple'
  :: "assn \<Rightarrow> 'r Heap \<Rightarrow> ('r \<Rightarrow> assn) \<Rightarrow> bool" ("<_> _ <_>\<^sub>t")
  where "<P> c <Q>\<^sub>t \<equiv> <P> c <\<lambda>r. Q r * true>"

subsection \<open>Rules\<close>
text \<open>
  In this section, we provide a set of rules to prove Hoare-Triples correct.
\<close>
subsubsection \<open>Basic Rules\<close>

lemma hoare_triple_preI:
  assumes "\<And>h. h\<Turnstile>P \<Longrightarrow> <P> c <Q>"
  shows "<P> c <Q>"
  using assms
  unfolding hoare_triple_def
  by auto

lemma frame_rule:
  assumes A: "<P> c <Q>"
  shows "<P*R> c <\<lambda>x. Q x * R>"
  unfolding hoare_triple_def Let_def
  apply (intro allI impI)
proof -
  fix h as
  assume "(h,as) \<Turnstile> P * R"
  then obtain as1 as2 where [simp]: "as=as1\<union>as2" and DJ: "as1\<inter>as2={}"
    and M1: "(h,as1)\<Turnstile>P" and M2: "(h,as2)\<Turnstile>R"
    by (auto simp: mod_star_conv)

  from hoare_tripleE[OF A M1] obtain r h' t where
    EX: "execute c h = Some (r, h',t)"
    and MDL: "(h', new_addrs h as1 h') \<Turnstile> Q r"
    and RH1: "relH {a. a < lim h \<and> a \<notin> as1} h h'"
    and "lim h \<le> lim h'"
    .

  have "{a. a < lim h \<and> a \<notin> as} \<subseteq> {a. a < lim h \<and> a \<notin> as1}"
    by auto
  then have "relH {a. a < lim h \<and> a \<notin> as} h h'" using RH1
    by (blast intro: relH_subset)

  have DJN: "new_addrs h as1 h' \<inter> as2 = {}"
    using DJ models_in_range[OF M2]
    by (auto simp: in_range.simps new_addrs_def)
  moreover have "as2 \<subseteq> {a. a < lim h \<and> a \<notin> as1}"
    using DJ models_in_range[OF M2]
    by (auto simp: in_range.simps)
  hence "relH as2 h h'" using RH1
    by (blast intro: relH_subset)
  with M2 have "(h', as2)\<Turnstile>R"
    by (metis mem_Collect_eq Rep_assn
      proper_iff relH_in_rangeI(2))
  moreover have "new_addrs h as h'
    = new_addrs h as1 h' \<union> as2"
    by (auto simp: new_addrs_def)
  ultimately have
    M: "(h', new_addrs h as h') \<Turnstile> Q r * R"
    using MDL
    unfolding times_assn_def
    apply (simp add: Abs_assn_inverse)
    apply blast
    done

  show "\<exists>r h' t.
          execute c h = Some (r, h',t) \<and>
          (h', new_addrs h as h') \<Turnstile> Q r * R \<and> relH {a. a < lim h \<and> a \<notin> as} h h' \<and> lim h \<le> lim h'"
    apply (rule exI[where x=r])
    apply (rule exI[where x=h'])
    apply (rule exI[where x=t])
    apply safe
    apply fact
    apply fact
    apply fact
    apply fact
    done
qed

lemma false_rule[simp, intro!]: "<false> c <Q>"
  unfolding hoare_triple_def by simp

lemma cons_rule:
  assumes CPRE: "P \<Longrightarrow>\<^sub>A P'"
  assumes CPOST: "\<And>x. Q x \<Longrightarrow>\<^sub>A Q' x"
  assumes R: "<P'> c <Q>"
  shows "<P> c <Q'>"
  using assms
  unfolding hoare_triple_def Let_def
  using entailsD by blast

lemmas cons_pre_rule = cons_rule[OF _ ent_refl]
lemmas cons_post_rule = cons_rule[OF ent_refl, rotated]

lemma cons_rulet: "\<lbrakk>P\<Longrightarrow>\<^sub>tP'; \<And>x. Q x \<Longrightarrow>\<^sub>t Q' x; <P'> c <Q>\<^sub>t \<rbrakk> \<Longrightarrow> <P> c <Q'>\<^sub>t"
  unfolding entailst_def
  apply (rule cons_pre_rule)
  apply assumption
  apply (rule cons_post_rule)
  apply (erule frame_rule)
  by (simp add: enttD enttI)

lemmas cons_pre_rulet = cons_rulet[OF _ entt_refl]
lemmas cons_post_rulet = cons_rulet[OF entt_refl, rotated]

lemma norm_pre_ex_rule:
  assumes A: "\<And>x. <P x> f <Q>"
  shows "<\<exists>\<^sub>Ax. P x> f <Q>"
  unfolding hoare_triple_def Let_def
  apply (intro allI impI, elim conjE mod_exE)
  using assms hoare_tripleE by fastforce

lemma norm_pre_pure_iff[simp]:
  "<P*\<up>b> f <Q> \<longleftrightarrow> (b \<longrightarrow> <P> f <Q>)"
  unfolding hoare_triple_def Let_def
  by auto

lemma norm_pre_pure_iff_sng[simp]:
  "<\<up>b> f <Q> \<longleftrightarrow> (b \<longrightarrow> <emp> f <Q>)"
  using norm_pre_pure_iff[where P=emp]
  by simp

lemma norm_pre_pure_rule1:
  "\<lbrakk>b \<Longrightarrow> <P> f <Q>\<rbrakk> \<Longrightarrow> <P*\<up>b> f <Q>" by simp

lemma norm_pre_pure_rule2:
  "\<lbrakk> b \<Longrightarrow> <emp> f <Q> \<rbrakk> \<Longrightarrow> <\<up>b> f <Q>" by simp

lemmas norm_pre_pure_rule = norm_pre_pure_rule1 norm_pre_pure_rule2

subsubsection \<open>Rules for Time Commands\<close>
lemma wait_rule: "<emp> wait n <\<lambda>_. emp>"
  apply rule
  apply (simp add: execute_simps)
  by (simp add: in_range.simps relH_refl)

lemma wait_bind_decon: "<P> m <Q> \<Longrightarrow> <P> do {wait n; m} <Q>"
  apply rule
  apply (auto elim!: hoare_tripleE simp: execute_simps)
  done

subsubsection \<open>Rules for Atomic Commands\<close>
lemma ref_rule:
  "<emp> ref x <\<lambda>r. r \<mapsto>\<^sub>r x>"
  unfolding one_assn_def sngr_assn_def hoare_triple_def
  apply (simp add: Let_def Abs_assn_inverse)
  apply (simp add: execute_simps)
  apply (auto
    simp: new_addrs_def Ref_Time.alloc_def Let_def
    Ref_Time.set_def Ref_Time.get_def relH_def in_range.simps)
  done

lemma lookup_rule:
  "<p \<mapsto>\<^sub>r x> !p <\<lambda>r. p \<mapsto>\<^sub>r x * \<up>(r = x)>"
  unfolding hoare_triple_def sngr_assn_def
  apply (simp add: Let_def Abs_assn_inverse)
  apply (simp add: execute_simps)
  apply (auto elim: simp add: relH_refl in_range.simps new_addrs_def)
  done

lemma update_rule:
  "<p \<mapsto>\<^sub>r y> p := x <\<lambda>r. p \<mapsto>\<^sub>r x>"
  unfolding hoare_triple_def sngr_assn_def
  apply (simp add: execute_simps)
  apply (auto elim!:
    simp: Let_def Abs_assn_inverse new_addrs_def in_range.simps
    intro!: relH_set_ref)
  done

lemma update_wp_rule:
  "<r \<mapsto>\<^sub>r y * ((r \<mapsto>\<^sub>r x) -* (Q ()))> r := x <Q>"
  apply (rule cons_post_rule)
  apply (rule frame_rule[OF update_rule[where p=r and x=x],
    where R="((r \<mapsto>\<^sub>r x) -* (Q ()))"])
  apply (rule ent_trans)
  apply (rule ent_mp)
  by simp

lemma new_rule:
  "<emp> Array_Time.new n x <\<lambda>r. r \<mapsto>\<^sub>a replicate n x>"
  unfolding hoare_triple_def snga_assn_def one_assn_def
  apply (simp add: Let_def Abs_assn_inverse)
  apply (simp add: execute_simps)
  apply (auto
    simp: Let_def new_addrs_def Array_Time.get_def Array_Time.set_def Array_Time.alloc_def
      relH_def in_range.simps
  )
  done

lemma make_rule: "<emp> Array_Time.make n f <\<lambda>r. r \<mapsto>\<^sub>a (map f [0 ..< n])>"
  unfolding hoare_triple_def snga_assn_def one_assn_def
  apply (simp add: Let_def Abs_assn_inverse)
  apply (simp add: execute_simps)
  apply (auto
    simp: Let_def new_addrs_def Array_Time.get_def Array_Time.set_def Array_Time.alloc_def
      relH_def in_range.simps
  )
  done

lemma of_list_rule: "<emp> Array_Time.of_list xs <\<lambda>r. r \<mapsto>\<^sub>a xs>"
  unfolding hoare_triple_def snga_assn_def one_assn_def
  apply (simp add: Let_def Abs_assn_inverse)
  apply (simp add: execute_simps)
  apply (auto
    simp: Let_def new_addrs_def Array_Time.get_def Array_Time.set_def Array_Time.alloc_def
      relH_def in_range.simps
  )
  by (simp add: map_idI)

lemma length_rule:
  "<a \<mapsto>\<^sub>a xs> Array_Time.len a <\<lambda>r. a \<mapsto>\<^sub>a xs * \<up>(r = length xs)>"
  unfolding hoare_triple_def snga_assn_def
  apply (simp add: Let_def Abs_assn_inverse)
  apply (simp add: execute_simps)
  apply (auto
    simp: Let_def new_addrs_def Array_Time.get_def Array_Time.set_def Array_Time.alloc_def
      relH_def in_range.simps Array_Time.length_def
  )
  done

text \<open>Note that the Boolean expression is placed at meta level and not
  inside the precondition. This makes frame inference simpler.\<close>
lemma nth_rule:
  "\<lbrakk>i < length xs\<rbrakk> \<Longrightarrow> <a \<mapsto>\<^sub>a xs> Array_Time.nth a i <\<lambda>r. a \<mapsto>\<^sub>a xs * \<up>(r = xs ! i)>"
  unfolding hoare_triple_def snga_assn_def
  apply (simp add: Let_def Abs_assn_inverse)
  apply (auto
    simp: Let_def new_addrs_def Array_Time.get_def Array_Time.set_def Array_Time.alloc_def
      relH_def in_range.simps Array_Time.length_def
      execute_simps
  )
  done

lemma upd_rule:
  "\<lbrakk>i < length xs\<rbrakk> \<Longrightarrow>
  <a \<mapsto>\<^sub>a xs>
  Array_Time.upd i x a
  <\<lambda>r. (a \<mapsto>\<^sub>a (list_update xs i x)) * \<up>(r = a)>"
  unfolding hoare_triple_def snga_assn_def
  apply (simp add: Let_def Abs_assn_inverse)
  apply (auto
    simp: Let_def new_addrs_def Array_Time.get_def Array_Time.set_def Array_Time.alloc_def
      relH_def in_range.simps Array_Time.length_def Array_Time.update_def comp_def
      execute_simps
  )
  done

lemma freeze_rule:
  "<a \<mapsto>\<^sub>a xs> Array_Time.freeze a <\<lambda>r. a \<mapsto>\<^sub>a xs * \<up>(r = xs)>"
  unfolding hoare_triple_def snga_assn_def
  apply (simp add: Let_def Abs_assn_inverse)
  apply (auto
    simp: Let_def new_addrs_def Array_Time.get_def Array_Time.set_def Array_Time.alloc_def
      relH_def in_range.simps Array_Time.length_def Array_Time.update_def
      execute_simps
  )
  done

lemma return_wp_rule:
  "<Q x> return x <Q>"
  unfolding hoare_triple_def Let_def
  apply (auto simp: execute_simps)
  apply (rule relH_refl)
  apply (simp add: in_range.simps)
  done

lemma return_sp_rule:
  "<P> return x <\<lambda>r. P * \<up>(r = x)>"
  unfolding hoare_triple_def Let_def
  apply (simp add: Abs_assn_inverse)
  apply (auto intro!: relH_refl intro: models_in_range simp: execute_simps)
  apply (simp add: in_range.simps)
  done

lemma raise_iff:
  "<P> raise s <Q> \<longleftrightarrow> P = false"
  unfolding hoare_triple_def Let_def
  apply (rule iffI)
  apply (unfold bot_assn_def) []
  apply rule
  apply (auto simp add: execute_simps) []

  apply (auto simp add: execute_simps) []
  done

lemma raise_rule: "<false> raise s <Q>"
  by (simp add: raise_iff)

subsubsection \<open>Rules for Composed Commands\<close>
lemma bind_rule:
  assumes T1: "<P> f <R>"
  assumes T2: "\<And>x. <R x> g x <Q>"
  shows "<P> bind f g <Q>"
proof
  fix h as
  assume "(h, as) \<Turnstile> P"

  from hoare_tripleE[OF T1 this] obtain rf h' t' where
    EX_F: "execute f h = Some (rf, h',t')"
    and POST_F: "(h', new_addrs h as h') \<Turnstile> R rf"
    and RH_F: "relH {a. a < lim h \<and> a \<notin> as} h h'"
    and LIM_F: "lim h \<le> lim h'"
    .

  from hoare_tripleE[OF T2 POST_F] obtain rg h'' t'' where
    EX_G: "execute (g rf) h' = Some (rg, h'',t'')"
    and POST_G: "(h'', new_addrs h' (new_addrs h as h') h'') \<Turnstile> Q rg"
    and RH_G: "relH {a. a < lim h' \<and> a \<notin> new_addrs h as h'} h' h''"
    and LIM_G: "lim h' \<le> lim h''"
    .

  have
    "new_addrs
      h'
      (new_addrs h as h')
      h''
    = new_addrs h as h''"
    using LIM_F LIM_G
    by (auto simp add: new_addrs_def)
  with POST_G have
    "(h'', new_addrs h as h'') \<Turnstile> Q rg"
    by simp

  note RH_F
  also have "relH {a. a < lim h \<and> a \<notin> as} h' h''"
    apply (rule relH_subset[OF RH_G])
    using LIM_F LIM_G
    by (auto simp: new_addrs_def)
  finally have "relH {a. a < lim h \<and> a \<notin> as} h h''" .

  note LIM_F
  also note LIM_G
  finally have "lim h \<le> lim h''" .

  show "\<exists>r h' t'.
          execute (f \<bind> g) h = Some (r, h',t') \<and>
          (h', new_addrs h as h') \<Turnstile> Q r \<and> relH {a. a < lim h \<and> a \<notin> as} h h' \<and> lim h \<le> lim h'"
    apply (intro exI conjI)
    apply (simp add: EX_F EX_G execute_simps; fail)
    apply fact+
    done
qed

lemma bind_rule' :
  assumes T1: "\<And> r. <P> f <\<lambda> r. (P * R r) >"
  assumes T2: "\<And>x. <R x * P> g x <Q>"
  shows "<P> bind f g <Q>"
  by (metis (no_types, lifting) T1 T2 ab_semigroup_mult_class.mult.commute bind_rule)

lemma if_rule:
  assumes  "b \<Longrightarrow> <P> f <Q>"
  assumes  "\<not>b \<Longrightarrow> <P> g <Q>"
  shows "<P> if b then f else g <Q>"
  using assms by auto

lemma if_rule_split:
  assumes  B: "b \<Longrightarrow> <P> f <Q1>"
  assumes  NB: "\<not>b \<Longrightarrow> <P> g <Q2>"
  assumes M: "\<And>x. (Q1 x * \<up>b) \<or>\<^sub>A (Q2 x * \<up>(\<not>b)) \<Longrightarrow>\<^sub>A Q x"
  shows "<P> if b then f else g <Q>"
  apply (cases b)
  apply simp_all
  apply (rule cons_post_rule)
  apply (erule B)
  apply (rule ent_trans[OF _ ent_disjI1[OF M]])
  apply simp

  apply (rule cons_post_rule)
  apply (erule NB)
  apply (rule ent_trans[OF _ ent_disjI2[OF M]])
  apply simp
  done

lemma split_rule:
  assumes P: "<P> c <R>"
  assumes Q: "<Q> c <R>"
  shows "<P \<or>\<^sub>A Q> c <R>"
  apply rule
  using assms
  apply (auto elim!: hoare_tripleE)
  done

lemmas decon_if_split = if_rule_split split_rule
  \<comment> \<open>Use with care: Complete splitting of if statements\<close>

lemma case_prod_rule:
  "(\<And>a b. x = (a, b) \<Longrightarrow> <P> f a b <Q>) \<Longrightarrow> <P> case x of (a, b) \<Rightarrow> f a b <Q>"
  by (auto split: prod.split)

lemma case_list_rule:
  "\<lbrakk> l=[] \<Longrightarrow> <P> fn <Q>; \<And>x xs. l=x#xs \<Longrightarrow> <P> fc x xs <Q> \<rbrakk> \<Longrightarrow>
  <P> case_list fn fc l <Q>"
  by (auto split: list.split)

lemma case_option_rule:
  "\<lbrakk> v=None \<Longrightarrow> <P> fn <Q>; \<And>x. v=Some x \<Longrightarrow> <P> fs x <Q> \<rbrakk>
  \<Longrightarrow> <P> case_option fn fs v <Q>"
  by (auto split: option.split)

lemma case_sum_rule:
  "\<lbrakk> \<And>x. v=Inl x \<Longrightarrow> <P> fl x <Q>;
     \<And>x. v=Inr x \<Longrightarrow> <P> fr x <Q> \<rbrakk>
  \<Longrightarrow> <P> case_sum fl fr v <Q>"
  by (auto split: sum.split)

lemma let_rule: "(\<And>x. x = t \<Longrightarrow> <P> f x <Q>) \<Longrightarrow> <P> Let t f <Q>"
  by (auto)

end


(*  Title:       Phase Partitioning
    Author:      Max Haslbeck
*)

section "Phase Partitioning"

theory Phase_Partitioning
imports OPT2
begin

subsection "Definition of Phases"

definition "other a x y = (if a=x then y else x)"

definition Lxx where
  "Lxx (x::nat) y = lang (L_lasthasxx x y)"

lemma Lxx_not_nullable: "[] \<notin> Lxx x y"
unfolding Lxx_def L_lasthasxx_def by simp

(* lemma set_Lxx: "xs \<in> Lxx x y \<Longrightarrow> set xs \<subseteq> {x,y}"
unfolding Lxx_def L_lasthasxx_def apply(simp add: star_def) sle dgehammer *)

lemma Lxx_ends_in_two_equal: "xs \<in> Lxx x y \<Longrightarrow> \<exists>pref e. xs = pref @ [e,e]"
by(auto simp: conc_def Lxx_def L_lasthasxx_def)

lemma "Lxx x y = Lxx y x" unfolding Lxx_def by(rule lastxx_com)

definition "hideit x y = (Plus rexp.One (nodouble x y))"

lemma Lxx_othercase: "set qs \<subseteq> {x,y} \<Longrightarrow> \<not> (\<exists>xs ys. qs = xs @ ys \<and> xs \<in> Lxx x y) \<Longrightarrow> qs \<in> lang (hideit x y)"
proof -
  assume "set qs \<subseteq> {x,y}"
  then have "qs \<in> lang (myUNIV x y)" using myUNIV_alle[of x y] by blast
  then have "qs \<in> star (lang (L_lasthasxx x y)) @@  lang (hideit x y)" unfolding hideit_def
    by(auto simp add: myUNIV_char)
  then have qs: "qs \<in> star (Lxx x y) @@  lang (hideit x y)" by(simp add: Lxx_def)
  assume notpos: "\<not> (\<exists>xs ys. qs = xs @ ys \<and> xs \<in> Lxx x y)"
  show "qs \<in> lang (hideit x y)"
  proof -
    from qs obtain A B where qsAB: "qs=A@B" and A: "A\<in>star (Lxx x y)" and B: "B\<in>lang (hideit x y)" by auto
    with notpos have notin: "A \<notin> (Lxx x y)" by blast

    from A have 1: "A = [] \<or> A \<in> (Lxx x y) @@ star (Lxx x y)" using Regular_Set.star_unfold_left by auto
    have 2: "A \<notin> (Lxx x y) @@ star (Lxx x y)"
    proof (rule ccontr)
      assume "\<not> A \<notin> Lxx x y @@ star (Lxx x y)"
      then have " A \<in> Lxx x y @@ star (Lxx x y)" by auto
      then obtain A1 A2 where "A=A1@A2" and A1: "A1\<in>(Lxx x y)" and "A2\<in> star (Lxx x y)" by auto
      with qsAB have "qs=A1@(A2@B)" "A1\<in>(Lxx x y)" by auto
      with notpos have "A1 \<notin> (Lxx x y)" by blast
      with A1 show "False" by auto
    qed
    from 1 2 have "A=[]" by auto
    with qsAB have "qs=B" by auto
    with B show ?thesis by simp
  qed
qed

fun pad where "pad xs x y = (if xs=[] then [x,x] else
                                    (if last xs = x then xs @ [x] else xs @ [y]))"

lemma pad_adds2: "qs \<noteq> [] \<Longrightarrow> set qs \<subseteq> {x,y} \<Longrightarrow> pad qs x y = qs @ [last qs]"
apply(auto) by (metis insertE insert_absorb insert_not_empty last_in_set subset_iff)

lemma nodouble_padded: "qs \<noteq> [] \<Longrightarrow> qs \<in> lang (nodouble x y) \<Longrightarrow> pad qs x y \<in> Lxx x y"
proof -
  assume nn: "qs \<noteq> []"
  assume "qs \<in> lang (nodouble x y)"
  then have a: "qs \<in> lang         (seq
          [Plus (Atom x) rexp.One,
           Star (Times (Atom y) (Atom x)),
           Atom y]) \<or> qs \<in> lang
        (seq
          [Plus (Atom y) rexp.One,
           Star (Times (Atom x) (Atom y)),
           Atom x])"  unfolding nodouble_def by auto

  show ?thesis
  proof (cases "qs \<in> lang (seq [Plus (Atom x) One, Star (Times (Atom y) (Atom x)), Atom y])")
    case True
    then have "qs \<in> lang (seq [Plus (Atom x) One, Star (Times (Atom y) (Atom x))]) @@ {[y]}"
      by(simp add: conc_assoc)
    then have "last qs = y" by auto
    with nn have p: "pad qs x y = qs @ [y]" by auto
    have A: "pad qs x y \<in> lang  (seq [Plus (Atom x) One, Star (Times (Atom y) (Atom x)),
             Atom y]) @@ {[y]}" unfolding p
             apply(simp)
             apply(rule concI)
              using True by auto
    have B: "lang  (seq [Plus (Atom x) One, Star (Times (Atom y) (Atom x)),
             Atom y]) @@ {[y]} = lang  (seq [Plus (Atom x) One, Star (Times (Atom y) (Atom x)),
             Atom y, Atom y])" by (simp add: conc_assoc)
    show "pad qs x y \<in> Lxx x y" unfolding Lxx_def L_lasthasxx_def
      using B A by auto
  next
    case False
    with a have T: "qs \<in> lang (seq [Plus (Atom y) One, Star (Times (Atom x) (Atom y)), Atom x])" by auto

    then have "qs \<in> lang (seq [Plus (Atom y) One, Star (Times (Atom x) (Atom y))]) @@ {[x]}"
      by(simp add: conc_assoc)
    then have "last qs = x" by auto
    with nn have p: "pad qs x y = qs @ [x]" by auto
    have A: "pad qs x y \<in> lang  (seq [Plus (Atom y) One, Star (Times (Atom x) (Atom y)),
             Atom x]) @@ {[x]}" unfolding p
             apply(simp)
             apply(rule concI)
              using T by auto
    have B: "lang  (seq [Plus (Atom y) One, Star (Times (Atom x) (Atom y)),
             Atom x]) @@ {[x]} = lang  (seq [Plus (Atom y) One, Star (Times (Atom x) (Atom y)),
             Atom x, Atom x])" by (simp add: conc_assoc)
    show "pad qs x y \<in> Lxx x y" unfolding Lxx_def L_lasthasxx_def
      using B A by auto
 qed
qed

thm UnE
lemma "c \<in> A \<union> B \<Longrightarrow> P"
  apply(erule UnE) oops

lemma LxxE: "qs \<in> Lxx x y
    \<Longrightarrow> (qs \<in> lang (seq [Atom x, Atom x]) \<Longrightarrow> P x y qs)
    \<Longrightarrow> (qs \<in> lang (seq [Plus (Atom x) rexp.One, Atom y, Atom x, Star (Times (Atom y) (Atom x)), Atom y, Atom y]) \<Longrightarrow> P x y qs)
    \<Longrightarrow> (qs \<in> lang (seq [Plus (Atom x) rexp.One, Atom y, Atom x, Star (Times (Atom y) (Atom x)), Atom x]) \<Longrightarrow> P x y qs)
    \<Longrightarrow> (qs \<in> lang (seq [Plus (Atom x) rexp.One, Atom y, Atom y]) \<Longrightarrow> P x y qs)
    \<Longrightarrow> P x y qs"
unfolding Lxx_def lastxx_is_4cases[symmetric] L_4cases_def apply(simp only: verund.simps lang.simps)
using UnE by blast

thm UnE LxxE

lemma "qs \<in> Lxx x y \<Longrightarrow> P"
apply(erule LxxE) oops

lemma LxxI: "(qs \<in> lang (seq [Atom x, Atom x]) \<Longrightarrow> P x y qs)
    \<Longrightarrow> (qs \<in> lang (seq [Plus (Atom x) rexp.One, Atom y, Atom x, Star (Times (Atom y) (Atom x)), Atom y, Atom y]) \<Longrightarrow> P x y qs)
    \<Longrightarrow> (qs \<in> lang (seq [Plus (Atom x) rexp.One, Atom y, Atom x, Star (Times (Atom y) (Atom x)), Atom x]) \<Longrightarrow> P x y qs)
    \<Longrightarrow> (qs \<in> lang (seq [Plus (Atom x) rexp.One, Atom y, Atom y]) \<Longrightarrow> P x y qs)
    \<Longrightarrow> (qs \<in> Lxx x y \<Longrightarrow> P x y qs)"
unfolding Lxx_def lastxx_is_4cases[symmetric] L_4cases_def apply(simp only: verund.simps lang.simps)
  by blast

lemma Lxx1: "xs \<in> Lxx x y \<Longrightarrow> length xs \<ge> 2"
  apply(rule LxxI[where P="(\<lambda>x y qs. length qs \<ge> 2)"])
  apply(auto) by(auto simp: conc_def)

subsection "OPT2 Splitting"

lemma ayay: "length qs = length as \<Longrightarrow> T\<^sub>p s (qs@[q]) (as@[a]) = T\<^sub>p s qs as + t\<^sub>p (steps s qs as) q a"
apply(induct qs as arbitrary: s rule: list_induct2) by simp_all

lemma tlofOPT2: "Q \<in> {x,y} \<Longrightarrow> set QS \<subseteq> {x,y} \<Longrightarrow> R \<in> {[x, y], [y, x]} \<Longrightarrow> tl (OPT2 ((Q # QS) @ [x, x]) R) =
    OPT2 (QS @ [x, x]) (step R Q (hd (OPT2 ((Q # QS) @ [x, x]) R)))"
      apply(cases "Q=x")
        apply(cases "R=[x,y]")
          apply(simp add: OPT2x step_def)
          apply(simp)
            apply(cases QS)
                apply(simp add: step_def mtf2_def swap_def)
                apply(simp add: step_def mtf2_def swap_def)
        apply(cases "R=[x,y]")
          apply(simp)
            apply(cases QS)
                apply(simp add: step_def mtf2_def swap_def)
                apply(simp add: step_def mtf2_def swap_def)
          by(simp add: OPT2x step_def)

lemma T\<^sub>p_split: "length qs1=length as1 \<Longrightarrow> T\<^sub>p s (qs1@qs2) (as1@as2) = T\<^sub>p s qs1 as1 + T\<^sub>p (steps s qs1 as1) qs2 as2"
apply(induct qs1 as1 arbitrary: s rule: list_induct2) by(simp_all)

lemma T\<^sub>p_spliting: "x\<noteq>y \<Longrightarrow> set xs \<subseteq> {x,y} \<Longrightarrow> set ys \<subseteq> {x,y} \<Longrightarrow>
      R \<in> {[x,y],[y,x]} \<Longrightarrow>
      T\<^sub>p R (xs@[x,x]) (OPT2 (xs@[x,x]) R) + T\<^sub>p [x,y] ys (OPT2 ys [x,y])
      = T\<^sub>p R (xs@[x,x]@ys) (OPT2 (xs@[x,x]@ys) R)"
proof -
  assume nxy: "x\<noteq>y"
  assume XSxy: "set xs \<subseteq> {x,y}"
  assume YSxy: "set ys \<subseteq> {x,y}"
  assume R: "R \<in> {[x,y],[y,x]}"
  {
    fix R
    assume XSxy: "set xs \<subseteq> {x,y}"
    have "R\<in>{[x,y],[y,x]} \<Longrightarrow> set xs \<subseteq> {x,y}  \<Longrightarrow> steps R (xs@[x,x]) (OPT2 (xs@[x,x]) R) = [x,y]"
    proof(induct xs arbitrary: R)
      case Nil
      then show ?case
        apply(cases "R=[x,y]")
(* FIXME why is simp_all needed? *)
          apply simp_all apply(simp add: step_def)
          by(simp add: step_def mtf2_def swap_def)
    next
      case (Cons Q QS)
      let ?R'="(step R Q (hd (OPT2 ((Q # QS) @ [x, x]) R)))"

      have a: "Q \<in> {x,y}"  and b: "set QS \<subseteq> {x,y}" using Cons by auto
      have t: "?R' \<in> {[x,y],[y,x]}"
        apply(rule stepxy) using nxy Cons by auto
      then have "length (OPT2 (QS @ [x, x]) ?R') > 0"
        apply(cases "?R' = [x,y]") by(simp_all add: OPT2_length)
      then have "OPT2 (QS @ [x, x]) ?R' \<noteq> []" by auto
      then have hdtl: "OPT2 (QS @ [x, x]) ?R' = hd (OPT2 (QS @ [x, x]) ?R') # tl (OPT2 (QS @ [x, x]) ?R')"
         by auto

      have maa: "(tl (OPT2 ((Q # QS) @ [x, x]) R)) = OPT2 (QS @ [x, x]) ?R' "
        using tlofOPT2[OF a b Cons(2)] by auto

      from Cons(2) have "length (OPT2 ((Q # QS) @ [x, x]) R) > 0"
        apply(cases "R = [x,y]") by(simp_all add: OPT2_length)
      then have nempty: "OPT2 ((Q # QS) @ [x, x]) R \<noteq> []" by auto
      then have "steps R ((Q # QS) @ [x, x]) (OPT2 ((Q # QS) @ [x, x]) R)
        = steps R ((Q # QS) @ [x, x]) (hd(OPT2 ((Q # QS) @ [x, x]) R) #  tl(OPT2 ((Q # QS) @ [x, x]) R))"
          by(simp)
      also have "\<dots>
        = steps ?R' (QS @ [x,x]) (tl (OPT2 ((Q # QS) @ [x, x]) R))"
          unfolding maa by auto
      also have "\<dots> = steps ?R' (QS @ [x,x]) (OPT2 (QS @ [x, x]) ?R')" using maa by auto
      also with Cons(1)[OF t b] have "\<dots> = [x,y]" by auto

      finally show ?case .
    qed
  } note aa=this

    from aa XSxy R have ll: "steps R (xs@[x,x]) (OPT2 (xs@[x,x]) R)
      = [x,y]" by auto

  have uer: " length (xs @ [x, x]) = length (OPT2 (xs @ [x, x]) R)"
    using R  by (auto simp: OPT2_length)

  have "OPT2 (xs @ [x, x] @ ys) R = OPT2 (xs @ [x, x]) R @ OPT2 ys [x, y]"
    apply(rule OPT2_split11)
      using nxy XSxy YSxy R by auto

  then have "T\<^sub>p R (xs@[x,x]@ys) (OPT2 (xs@[x,x]@ys) R)
        = T\<^sub>p R ((xs@[x,x])@ys) (OPT2 (xs @ [x, x]) R @ OPT2 ys [x, y])"  by auto
  also have "\<dots> = T\<^sub>p R (xs@[x,x]) (OPT2 (xs @ [x, x]) R)
                + T\<^sub>p [x,y] ys (OPT2 ys [x, y])"
                  using T\<^sub>p_split[of "xs@[x,x]" "OPT2 (xs @ [x, x]) R" R ys "OPT2 ys [x, y]", OF uer, unfolded ll]
                by auto
  finally show ?thesis by simp
qed

lemma OPTauseinander: "x\<noteq>y \<Longrightarrow> set xs \<subseteq> {x,y} \<Longrightarrow> set ys \<subseteq> {x,y} \<Longrightarrow>
      LTS \<in> {[x,y],[y,x]} \<Longrightarrow> hd LTS = last xs \<Longrightarrow>
     xs = (pref @ [hd LTS, hd LTS]) \<Longrightarrow>
      T\<^sub>p [x,y] xs (OPT2 xs [x,y]) + T\<^sub>p LTS ys (OPT2 ys LTS)
      = T\<^sub>p [x,y] (xs@ys) (OPT2 (xs@ys) [x,y])"
proof -
  assume nxy: "x\<noteq>y"
  assume xsxy: "set xs \<subseteq> {x,y}"
  assume ysxy: "set ys \<subseteq> {x,y}"
  assume L: "LTS \<in> {[x,y],[y,x]}"
  assume "hd LTS = last xs"
  assume prefix: "xs = (pref @ [hd LTS, hd LTS])"
  show ?thesis
    proof (cases "LTS = [x,y]")
      case True
      show ?thesis unfolding True prefix
        apply(simp)
        apply(rule T\<^sub>p_spliting[simplified])
          using nxy xsxy ysxy prefix by auto
    next
      case False
      with L have TT: "LTS = [y,x]" by auto
      show ?thesis unfolding TT prefix
        apply(simp)
        apply(rule T\<^sub>p_spliting[simplified])
          using nxy xsxy ysxy prefix by auto
   qed
qed

subsection "Phase Partitioning lemma"

  show ?case
  proof (cases "\<exists>xs ys. \<sigma>=xs@ys \<and> xs \<in> Lxx x y")
    case True

    then obtain xs ys where qs: "\<sigma>=xs@ys" and xsLxx: "xs \<in> Lxx x y" by auto

    with Lxx1 have len: "length ys < length \<sigma>" by fastforce
    from qs(1) less(4) have ysxy: "set ys \<subseteq> {x,y}" by auto

    have xsset: "set xs \<subseteq> {x, y}" using less(4) qs by auto
    from xsLxx Lxx1 have lxsgt1: "length xs \<ge> 2" by auto
    then have xs_not_Nil: "xs \<noteq> []" by auto

    from D[OF xsLxx less(2) less(5) less(3) xsset]
      have D1: "T_on_rand' A s xs \<le> c * T\<^sub>p [x, y] xs (OPT2 xs [x, y])"
         and inv: "P (config'_rand A s xs) (last xs) [x0, y0]" by auto

    from xsLxx Lxx_ends_in_two_equal obtain pref e where "xs = pref @ [e,e]" by metis
    then have endswithsame: "xs = pref @ [last xs, last xs]" by auto

    let ?c' = "[last xs, other (last xs) x y]"

    have setys: "set ys \<subseteq> {x,y}" using qs less by auto
    have setxs: "set xs \<subseteq> {x,y}" using qs less by auto
    have lxs: "last xs \<in> set xs" using xs_not_Nil by auto
    from lxs setxs have lxsxy: "last xs \<in> {x,y}" by auto
     from lxs setxs have otherxy: "other (last xs) x y \<in> {x,y}" by (simp add: other_def)
    from less(2) have other_diff: "last xs \<noteq> other (last xs) x y" by(simp add: other_def)

    have lo: "{last xs, other (last xs) x y} = {x0, y0}"
      using lxsxy otherxy other_diff less(5) by force

    have nextstate: "{[last xs, other (last xs) x y], [other (last xs) x y, last xs]}
            = { [x,y],[y,x]}" using lxsxy otherxy other_diff by fastforce
    have setys': "set ys \<subseteq> {last xs, other (last xs) x y}"
            using setys lxsxy otherxy other_diff by fastforce

    have c: "T_on_rand' A (config'_rand A s xs) ys
        \<le> c * T\<^sub>p ?c' ys (OPT2 ys ?c') + c"
            apply(rule less(1))
              apply(fact len)
              apply(fact other_diff)
              apply(fact inv)
              apply(fact setys')
              by(fact lo)

    have well: "T\<^sub>p [x, y] xs (OPT2 xs [x, y]) + T\<^sub>p ?c' ys (OPT2 ys ?c')
        = T\<^sub>p [x, y] (xs @ ys) (OPT2 (xs @ ys) [x, y])"
          apply(rule OPTauseinander[where pref=pref])
            apply(fact)+
            using lxsxy other_diff otherxy apply(fastforce)
            apply(simp)
            using endswithsame by simp

    have E0: "T_on_rand' A s \<sigma>
          =  T_on_rand' A s (xs@ys)" using qs by auto
     also have E1: "\<dots> = T_on_rand' A s xs + T_on_rand' A (config'_rand A s xs) ys"
              by (rule T_on_rand'_append)
    also have E2: "\<dots> \<le> T_on_rand' A s xs + c * T\<^sub>p ?c' ys (OPT2 ys ?c') + c"
        using c by simp
    also have E3: "\<dots> \<le> c * T\<^sub>p [x, y] xs (OPT2 xs [x, y]) + c * T\<^sub>p ?c' ys (OPT2 ys ?c') + c"
        using D1 by simp
    also have "\<dots> = c * (T\<^sub>p [x,y] xs (OPT2 xs [x,y]) + T\<^sub>p ?c' ys (OPT2 ys ?c')) + c"
        using cpos apply(auto) by algebra
    also have  "\<dots> = c * (T\<^sub>p [x,y] (xs@ys) (OPT2 (xs@ys) [x,y])) + c"
      using well by auto
    also have E4: "\<dots> = c * (T\<^sub>p [x,y] \<sigma> (OPT2 \<sigma> [x,y])) + c"
        using qs by auto
    finally show ?thesis .
  next
    case False
    note f1=this
    from Lxx_othercase[OF less(4) this, unfolded hideit_def] have
        nodouble: "\<sigma> = [] \<or> \<sigma> \<in> lang (nodouble x y)" by  auto
    show ?thesis
    proof (cases "\<sigma> = []")
      case True
      then show ?thesis using cpos  by simp
    next
      case False
      (* with padding *)
      from False nodouble have qsnodouble: "\<sigma> \<in> lang (nodouble x y)" by auto
      let ?padded = "pad \<sigma> x y"

      have padset: "set ?padded \<subseteq> {x, y}" using less(4) by(simp)

      from False pad_adds2[of \<sigma> x y] less(4) obtain addum where ui: "pad \<sigma> x y = \<sigma> @ [last \<sigma>]" by auto
      from nodouble_padded[OF False qsnodouble] have pLxx: "?padded \<in> Lxx x y" .

      have E0: "T_on_rand' A s \<sigma> \<le> T_on_rand' A s ?padded"
      proof -
        have "T_on_rand' A s \<sigma> = sum (T_on_rand'_n A s \<sigma>) {..<length \<sigma>}"
          by(rule T_on_rand'_as_sum)
        also have "\<dots>
             = sum (T_on_rand'_n A s (\<sigma> @ [last \<sigma>])) {..<length \<sigma>}"
          proof(rule sum.cong, goal_cases)
            case (2 t)
            then have "t < length \<sigma>" by auto
            then show ?case by(simp add: nth_append)
          qed simp
        also have "\<dots> \<le> T_on_rand' A s ?padded"
          unfolding ui
            apply(subst (2) T_on_rand'_as_sum) by(simp add: T_on_rand'_nn del: T_on_rand'.simps)
        finally show ?thesis by auto
      qed

      also have E1: "\<dots> \<le> c * T\<^sub>p [x,y] ?padded (OPT2 ?padded [x,y])"
        using D[OF pLxx less(2) less(5) less(3) padset] by simp
      also have E2: "\<dots> \<le> c * (T\<^sub>p [x,y] \<sigma> (OPT2 \<sigma> [x,y]) + 1)"
      proof -
        from False less(2) obtain \<sigma>' x' y' where qs': "\<sigma> = \<sigma>' @ [x']" and x': "x' = last \<sigma>" "y'\<noteq>x'" "y' \<in>{x,y}"
            by (metis append_butlast_last_id insert_iff)
        have tla: "last \<sigma> \<in> {x,y}" using less(4) False last_in_set by blast
        with x' have grgr: "{x,y} = {x',y'}" by auto
        then have "(x = x' \<and> y = y') \<or> (x = y' \<and> y = x')" using less(2) by auto
        then have tts: "[x, y] \<in> {[x', y'], [y', x']}" by blast

        from qs' ui have pd: "?padded = \<sigma>' @ [x', x']" by auto

        have "T\<^sub>p [x,y] (?padded) (OPT2 (?padded) [x,y])
              = T\<^sub>p [x,y] (\<sigma>' @ [x', x']) (OPT2 (\<sigma>' @ [x', x']) [x,y])"
                unfolding pd by simp
        also have gr: "\<dots>
            \<le> T\<^sub>p [x,y] (\<sigma>' @ [x']) (OPT2 (\<sigma>' @ [x']) [x,y]) + 1"
              apply(rule OPT2_padded[where x="x'" and y="y'"])
                apply(fact)
                using grgr qs' less(4) by auto
        also have "\<dots> \<le> T\<^sub>p [x,y] (\<sigma>) (OPT2 (\<sigma>) [x,y]) + 1"
              unfolding qs' by simp
        finally show ?thesis using cpos by (meson mult_left_mono of_nat_le_iff)
      qed
      also have "\<dots> =  c * T\<^sub>p [x,y] \<sigma> (OPT2 \<sigma> [x,y]) + c" by (metis (no_types, lifting) mult.commute of_nat_1 of_nat_add semiring_normalization_rules(2))
      finally show ?thesis .
    qed
  qed
qed
} note allg=this

 have "T_on_rand A [x0,y0] \<sigma> \<le> c * real (T\<^sub>p [x0, y0] \<sigma> (OPT2 \<sigma> [x0, y0])) + c"
  apply(rule allg)
    apply(fact)
    using initial apply(simp add: map_pmf_def)
    apply(fact assms(3))
    by simp
  also have "\<dots> = c * T\<^sub>p_opt [x0, y0] \<sigma> + c"
    using OPT2_is_opt[OF assms(3,1)] by(simp)
  finally show ?thesis .
qed

term "A::(nat,'is) alg_on"

theorem Phase_partitioning_general_det:
  fixes P :: "(nat state * 'is) \<Rightarrow> nat \<Rightarrow> nat list \<Rightarrow> bool"
      and A :: "(nat,'is) alg_on"
  assumes xny: "(x0::nat) \<noteq> y0"
    and cpos: "(c::real)\<ge>0"
    and static: "set \<sigma> \<subseteq> {x0,y0}"
    and initial: "P ([x0,y0],(fst A [x0,y0])) x0 [x0,y0]"
    and D: "\<And>a b \<sigma> s.  \<sigma> \<in> Lxx a b \<Longrightarrow> a\<noteq>b \<Longrightarrow> {a,b}={x0,y0} \<Longrightarrow> P s a [x0,y0]  \<Longrightarrow> set \<sigma> \<subseteq> {a,b}
          \<Longrightarrow> T_on' A s \<sigma> \<le> c * T\<^sub>p [a,b] \<sigma> (OPT2 \<sigma> [a,b])  \<and> P (config' A s \<sigma>) (last \<sigma>) [x0,y0]"
  shows "T\<^sub>p_on A [x0,y0] \<sigma>  \<le> c * T\<^sub>p_opt [x0,y0] \<sigma> + c"
proof -
  thm Phase_partitioning_general

  thm T_deter_rand
  term T_on'
  term "embed"
  show ?thesis oops

end