theory ex_2_8
  imports Main
begin
fun intersperse::"'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"intersperse a [] = []" |
"intersperse a [x] = [x]" |
"intersperse a (x # xs) = x # a # (intersperse a xs)"

theorem map_equiv:"map f (intersperse a xs) = intersperse (f a) (map f xs)"
  apply (induction a xs rule: intersperse.induct)
  by (auto)
end


section \<open>Soundness theorem for the STRIPS semantics\<close>
text \<open>We prove the soundness theorem according to ~\cite{lifschitz1987semantics}.\<close>

theory Lifschitz_Consistency
imports PDDL_STRIPS_Semantics
begin

text \<open>States are modeled as valuations of our underlying predicate logic.\<close>
type_synonym state = "(predicate\<times>object list) valuation"

context ast_domain begin
  text \<open>An action is a partial function from states to states. \<close>
  type_synonym action = "state \<rightharpoonup> state"

  text \<open>The Isabelle/HOL formula @{prop \<open>f s = Some s'\<close>} means
    that \<open>f\<close> is applicable in state \<open>s\<close>, and the result is \<open>s'\<close>. \<close>

  text \<open>Definition B (i)--(iv) in Lifschitz's paper~\cite{lifschitz1987semantics}\<close>

  fun is_NegPredAtom where
    "is_NegPredAtom (Not x) = is_predAtom x" | "is_NegPredAtom _ = False"

  definition "close_eq s = (\<lambda>predAtm p xs \<Rightarrow> s (p,xs) | Eq a b \<Rightarrow> a=b)"

  lemma close_eq_predAtm[simp]: "close_eq s (predAtm p xs) \<longleftrightarrow> s (p,xs)"
    by (auto simp: close_eq_def)

  lemma close_eq_Eq[simp]: "close_eq s (Eq a b) \<longleftrightarrow> a=b"
    by (auto simp: close_eq_def)

  abbreviation entail_eq :: "state \<Rightarrow> object atom formula \<Rightarrow> bool" (infix "\<Turnstile>\<^sub>=" 55)
    where "entail_eq s f \<equiv> close_eq s \<Turnstile> f"

  fun sound_opr :: "ground_action \<Rightarrow> action \<Rightarrow> bool" where
    "sound_opr (Ground_Action pre (Effect add del)) f \<longleftrightarrow>
      (\<forall>s. s \<Turnstile>\<^sub>= pre \<longrightarrow>
        (\<exists>s'. f s = Some s' \<and> (\<forall>atm. is_predAtom atm \<and> atm \<notin> set del \<and> s \<Turnstile>\<^sub>= atm \<longrightarrow> s' \<Turnstile>\<^sub>= atm)
              \<and>  (\<forall>atm. is_predAtom atm \<and> atm \<notin> set add \<and> s \<Turnstile>\<^sub>= Not atm \<longrightarrow> s' \<Turnstile>\<^sub>= Not atm)
              \<and> (\<forall>fmla. fmla \<in> set add \<longrightarrow> s' \<Turnstile>\<^sub>= fmla)
              \<and> (\<forall>fmla. fmla \<in> set del \<and> fmla \<notin> set add \<longrightarrow> s' \<Turnstile>\<^sub>= (Not fmla))
              ))
        \<and> (\<forall>fmla\<in>set add. is_predAtom fmla)"

  lemma sound_opr_alt:
    "sound_opr opr f =
      ((\<forall>s. s \<Turnstile>\<^sub>= (precondition opr) \<longrightarrow>
          (\<exists>s'. f s = (Some s')
                \<and> (\<forall>atm. is_predAtom atm \<and> atm \<notin> set(dels (effect opr)) \<and> s \<Turnstile>\<^sub>= atm \<longrightarrow> s' \<Turnstile>\<^sub>= atm)
                \<and> (\<forall>atm. is_predAtom atm \<and> atm \<notin> set (adds (effect opr)) \<and> s \<Turnstile>\<^sub>= Not atm \<longrightarrow> s' \<Turnstile>\<^sub>= Not atm)
                \<and> (\<forall>atm. atm \<in> set(adds (effect opr)) \<longrightarrow> s' \<Turnstile>\<^sub>= atm)
                \<and> (\<forall>fmla. fmla \<in> set (dels (effect opr)) \<and> fmla \<notin> set(adds (effect opr)) \<longrightarrow> s' \<Turnstile>\<^sub>= (Not fmla))
                \<and> (\<forall>a b. s \<Turnstile>\<^sub>= Atom (Eq a b) \<longrightarrow> s' \<Turnstile>\<^sub>= Atom (Eq a b))
                \<and> (\<forall>a b. s \<Turnstile>\<^sub>= Not (Atom (Eq a b)) \<longrightarrow> s' \<Turnstile>\<^sub>= Not (Atom (Eq a b)))
                ))
        \<and> (\<forall>fmla\<in>set(adds (effect opr)). is_predAtom fmla))"
    by (cases "(opr,f)" rule: sound_opr.cases) auto

  text \<open>Definition B (v)--(vii) in  Lifschitz's paper~\cite{lifschitz1987semantics}\<close>
definition sound_system
    :: "ground_action set
      \<Rightarrow> world_model
      \<Rightarrow> state
      \<Rightarrow> (ground_action \<Rightarrow> action)
      \<Rightarrow> bool"
    where
    "sound_system \<Sigma> M\<^sub>0 s\<^sub>0 f \<longleftrightarrow>
      ((\<forall>fmla\<in>close_world M\<^sub>0. s\<^sub>0  \<Turnstile>\<^sub>= fmla)
      \<and> wm_basic M\<^sub>0
      \<and> (\<forall>\<alpha>\<in>\<Sigma>. sound_opr \<alpha> (f \<alpha>)))"

  text \<open>Composing two actions\<close>
  definition compose_action :: "action \<Rightarrow> action \<Rightarrow> action" where
    "compose_action f1 f2 x = (case f2 x of Some y \<Rightarrow> f1 y | None \<Rightarrow> None)"

  text \<open>Composing a list of actions\<close>
  definition compose_actions :: "action list \<Rightarrow> action" where
    "compose_actions fs \<equiv> fold compose_action fs Some"

  text \<open>Composing a list of actions satisfies some natural lemmas: \<close>
  lemma compose_actions_Nil[simp]:
    "compose_actions [] = Some" unfolding compose_actions_def by auto

  lemma compose_actions_Cons[simp]:
    "f s = Some s' \<Longrightarrow> compose_actions (f#fs) s = compose_actions fs s'"
  proof -
    interpret monoid_add compose_action Some
      apply unfold_locales
      unfolding compose_action_def
      by (auto split: option.split)
    assume "f s = Some s'"
    then show ?thesis
      unfolding compose_actions_def
      by (simp add: compose_action_def fold_plus_sum_list_rev)
  qed

  text \<open>Soundness Theorem in Lifschitz's paper~\cite{lifschitz1987semantics}.\<close>
theorem STRIPS_sema_sound:
  assumes "sound_system \<Sigma> M\<^sub>0 s\<^sub>0 f"
    \<comment> \<open>For a sound system \<open>\<Sigma>\<close>\<close>
  assumes "set \<alpha>s \<subseteq> \<Sigma>"
    \<comment> \<open>And a plan \<open>\<alpha>s\<close>\<close>
  assumes "ground_action_path M\<^sub>0 \<alpha>s M'"
    \<comment> \<open>Which is accepted by the system, yielding result \<open>M'\<close>
          (called \<open>R(\<alpha>s)\<close> in Lifschitz's paper~\cite{lifschitz1987semantics}.)\<close>
  obtains s'
    \<comment> \<open>We have that \<open>f(\<alpha>s)\<close> is applicable
          in initial state, yielding state \<open>s'\<close> (called \<open>f\<^sub>\<alpha>\<^sub>s(s\<^sub>0)\<close> in Lifschitz's paper~\cite{lifschitz1987semantics}.)\<close>
  where "compose_actions (map f \<alpha>s) s\<^sub>0 = Some s'"
    \<comment> \<open>The result world model \<open>M'\<close> is satisfied in state \<open>s'\<close>\<close>
    and "\<forall>fmla\<in>close_world M'. s' \<Turnstile>\<^sub>= fmla"
proof -
  have "(valuation M' \<Turnstile> fmla)" if "wm_basic M'" "fmla\<in>M'" for fmla
    using that apply (induction fmla)
    by (auto simp: valuation_def wm_basic_def split: atom.split)
  have "\<exists>s'. compose_actions (map f \<alpha>s) s\<^sub>0 = Some s' \<and> (\<forall>fmla\<in>close_world M'. s' \<Turnstile>\<^sub>= fmla)"
    using assms
  proof(induction \<alpha>s arbitrary: s\<^sub>0 M\<^sub>0 )
    case Nil
    then show ?case by (auto simp add: close_world_def compose_action_def sound_system_def)
  next
    case ass: (Cons \<alpha> \<alpha>s)
    then obtain pre add del where a: "\<alpha> = Ground_Action pre (Effect add del)"
      using ground_action.exhaust ast_effect.exhaust by metis
    let ?M\<^sub>1 = "execute_ground_action \<alpha> M\<^sub>0"
    have "close_world M\<^sub>0 \<TTurnstile> precondition \<alpha>"
      using ass(4)
      by auto
    moreover have s0_ent_cwM0: "\<forall>fmla\<in>(close_world M\<^sub>0). close_eq s\<^sub>0 \<Turnstile> fmla"
      using ass(2)
      unfolding sound_system_def
      by auto
    ultimately have s0_ent_alpha_precond: "close_eq s\<^sub>0 \<Turnstile> precondition \<alpha>"
      unfolding entailment_def
      by auto
    then obtain s\<^sub>1 where s1: "(f \<alpha>) s\<^sub>0 = Some s\<^sub>1"
      "(\<forall>atm. is_predAtom atm \<longrightarrow> atm \<notin> set(dels (effect \<alpha>))
                                            \<longrightarrow> close_eq s\<^sub>0 \<Turnstile> atm
                                            \<longrightarrow> close_eq s\<^sub>1 \<Turnstile> atm)"
      "(\<forall>fmla. fmla \<in> set(adds (effect \<alpha>))
                                            \<longrightarrow> close_eq s\<^sub>1 \<Turnstile> fmla)"
      "(\<forall>atm. is_predAtom atm \<and> atm \<notin> set (adds (effect \<alpha>)) \<and> close_eq s\<^sub>0 \<Turnstile> Not atm \<longrightarrow> close_eq s\<^sub>1 \<Turnstile> Not atm)"
      "(\<forall>fmla. fmla \<in> set (dels (effect \<alpha>)) \<and> fmla \<notin> set(adds (effect \<alpha>)) \<longrightarrow> close_eq s\<^sub>1 \<Turnstile> (Not fmla))"
      "(\<forall>a b. close_eq s\<^sub>0 \<Turnstile> Atom (Eq a b) \<longrightarrow> close_eq s\<^sub>1 \<Turnstile> Atom (Eq a b))"
      "(\<forall>a b. close_eq s\<^sub>0 \<Turnstile> Not (Atom (Eq a b)) \<longrightarrow> close_eq s\<^sub>1 \<Turnstile> Not (Atom (Eq a b)))"
      using ass(2-4)
      unfolding sound_system_def sound_opr_alt by force
    have "close_eq s\<^sub>1 \<Turnstile> fmla" if "fmla\<in>close_world ?M\<^sub>1" for fmla
      using ass(2)
      using that s1 s0_ent_cwM0
      unfolding sound_system_def execute_ground_action_def wm_basic_def
      apply (auto simp: in_close_world_conv)
      subgoal
        by (metis (no_types, lifting) DiffE UnE a apply_effect.simps ground_action.sel(2) ast_effect.sel(1) ast_effect.sel(2) close_world_extensive subsetCE)
      subgoal
        by (metis Diff_iff Un_iff a ground_action.sel(2) ast_domain.apply_effect.simps ast_domain.close_eq_predAtm ast_effect.sel(1) ast_effect.sel(2) formula_semantics.simps(1) formula_semantics.simps(3) in_close_world_conv is_predAtom.simps(1))
      done
    moreover have "(\<forall>atm. fmla \<noteq> formula.Atom atm) \<longrightarrow> s \<Turnstile> fmla" if "fmla\<in>?M\<^sub>1" for fmla s
    proof-
      have alpha: "(\<forall>s.\<forall>fmla\<in>set(adds (effect \<alpha>)). \<not> is_predAtom fmla \<longrightarrow> s \<Turnstile> fmla)"
        using ass(2,3)
        unfolding sound_system_def ast_domain.sound_opr_alt
        by auto
      then show ?thesis
        using that
        unfolding a execute_ground_action_def
        using ass.prems(1)[unfolded sound_system_def]
        by(cases fmla; fastforce simp: wm_basic_def)

    qed
    moreover have "(\<forall>opr\<in>\<Sigma>. sound_opr opr (f opr))"
      using ass(2) unfolding sound_system_def
      by (auto simp add:)
    moreover have "wm_basic ?M\<^sub>1"
      using ass(2,3)
      unfolding sound_system_def execute_ground_action_def
      thm sound_opr.cases
      apply (cases "(\<alpha>,f \<alpha>)" rule: sound_opr.cases)
      apply (auto simp: wm_basic_def)
      done
    ultimately have "sound_system \<Sigma> ?M\<^sub>1 s\<^sub>1 f"
      unfolding sound_system_def
      by (auto simp: wm_basic_def)
    from ass.IH[OF this] ass.prems obtain s' where
      "compose_actions (map f \<alpha>s) s\<^sub>1 = Some s' \<and> (\<forall>a\<in>close_world M'. s' \<Turnstile>\<^sub>= a)"
      by auto
    thus ?case by (auto simp: s1(1))
  qed
  with that show ?thesis by blast
qed

  text \<open>More compact notation of the soundness theorem.\<close>
  theorem STRIPS_sema_sound_compact_version:
    "sound_system \<Sigma> M\<^sub>0 s\<^sub>0 f \<Longrightarrow> set \<alpha>s \<subseteq> \<Sigma>
    \<Longrightarrow> ground_action_path M\<^sub>0 \<alpha>s M'
    \<Longrightarrow> \<exists>s'. compose_actions (map f \<alpha>s) s\<^sub>0 = Some s'
          \<and> (\<forall>fmla\<in>close_world M'. s' \<Turnstile>\<^sub>= fmla)"
    using STRIPS_sema_sound by metis

end \<comment> \<open>Context of \<open>ast_domain\<close>\<close>

subsection \<open>Soundness Theorem for PDDL\<close>

context wf_ast_problem begin

  text \<open>Mapping world models to states\<close>
  definition state_to_wm :: "state \<Rightarrow> world_model"
    where "state_to_wm s = ({formula.Atom (predAtm p xs) | p xs. s (p,xs)})"
  definition wm_to_state :: "world_model \<Rightarrow> state"
    where "wm_to_state M = (\<lambda>(p,xs). (formula.Atom (predAtm p xs)) \<in> M)"

  lemma wm_to_state_inv[simp]: "wm_to_state (state_to_wm s) = s"
    by (auto simp: wm_to_state_def
      state_to_wm_def image_def)

  text \<open>Mapping AST action instances to actions\<close>
  definition "pddl_opr_to_act g_opr s = (
    let M = state_to_wm s in
    if (wm_to_state (close_world M)) \<Turnstile>\<^sub>= (precondition g_opr) then
      Some (wm_to_state (apply_effect (effect g_opr) M))
    else
      None)"

definition "close_eq_M M = (M \<inter> {Atom (predAtm p xs) | p xs. True }) \<union> {Atom (Eq a a) | a. True} \<union> {\<^bold>\<not>(Atom (Eq a b)) | a b. a\<noteq>b}"

  lemma atom_in_wm_eq:
    "s \<Turnstile>\<^sub>= (formula.Atom atm)
      \<longleftrightarrow> ((formula.Atom atm) \<in> close_eq_M (state_to_wm s))"
    by (auto simp: wm_to_state_def
      state_to_wm_def image_def close_eq_M_def close_eq_def split: atom.splits)

lemma atom_in_wm_2_eq:
    "close_eq (wm_to_state M) \<Turnstile> (formula.Atom atm)
      \<longleftrightarrow> ((formula.Atom atm) \<in> close_eq_M M)"
    by (auto simp: wm_to_state_def
      state_to_wm_def image_def close_eq_def close_eq_M_def split:atom.splits)

  lemma not_dels_preserved:
    assumes "f \<notin> (set d)" " f \<in> M"
    shows "f \<in> apply_effect (Effect a d) M"
    using assms
    by auto

  lemma adds_satisfied:
    assumes "f \<in> (set a)"
    shows "f \<in> apply_effect (Effect a d) M"
    using assms
    by auto

  lemma dels_unsatisfied:
    assumes "f \<in> (set d)" "f \<notin> set a"
    shows "f \<notin> apply_effect (Effect a d) M"
    using assms
    by auto

  lemma dels_unsatisfied_2:
    assumes "f \<in> set (dels eff)" "f \<notin> set (adds eff)"
    shows "f \<notin> apply_effect eff M"
    using assms
    by (cases eff; auto)

  lemma wf_fmla_atm_is_atom: "wf_fmla_atom objT f \<Longrightarrow> is_predAtom f"
    by (cases f rule: wf_fmla_atom.cases) auto

  lemma wf_act_adds_are_atoms:
    assumes "wf_effect_inst effs" "ae \<in> set (adds effs)"
    shows "is_predAtom ae"
    using assms
    by (cases effs) (auto simp: wf_fmla_atom_alt)

  lemma wf_act_adds_dels_atoms:
    assumes "wf_effect_inst effs" "ae \<in> set (dels effs)"
    shows "is_predAtom ae"
    using assms
    by (cases effs) (auto simp: wf_fmla_atom_alt)

  lemma to_state_close_from_state_eq[simp]: "wm_to_state (close_world (state_to_wm s)) = s"
    by (auto simp: wm_to_state_def close_world_def
      state_to_wm_def image_def)

lemma wf_eff_pddl_ground_act_is_sound_opr:
  assumes "wf_effect_inst (effect g_opr)"
  shows "sound_opr g_opr ((pddl_opr_to_act g_opr))"
  unfolding sound_opr_alt
  apply(cases g_opr; safe)
  subgoal for pre eff s
    apply (rule exI[where x="wm_to_state(apply_effect eff (state_to_wm s))"])
    apply (auto simp: pddl_opr_to_act_def Let_def split:if_splits)
    subgoal for atm
      by (cases eff; cases atm; auto simp: close_eq_def wm_to_state_def state_to_wm_def split: atom.splits)
    subgoal for atm
      by (cases eff; cases atm; auto simp: close_eq_def wm_to_state_def state_to_wm_def split: atom.splits)
    subgoal for atm
      using assms
      by (cases eff; cases atm; force simp: close_eq_def wm_to_state_def state_to_wm_def split: atom.splits)
    subgoal for fmla
      using assms
      by (cases eff; cases fmla rule: wf_fmla_atom.cases; force simp: close_eq_def wm_to_state_def state_to_wm_def split: atom.splits)
    done
  subgoal for pre eff fmla
    using assms
    by (cases eff; cases fmla rule: wf_fmla_atom.cases; force)
  done

  lemma wf_eff_impt_wf_eff_inst: "wf_effect objT eff \<Longrightarrow> wf_effect_inst eff"
    by (cases eff; auto simp add: wf_fmla_atom_alt)

  lemma wf_action_schema_sound_inst:
    assumes "action_params_match act args" "wf_action_schema act"
    shows "sound_opr
      (instantiate_action_schema act args)
      ((pddl_opr_to_act (instantiate_action_schema act args)))"
    using
      wf_pddl_ground_act_is_sound_opr[
        OF wf_instantiate_action_schema[OF assms]]
      by blast

  lemma wf_plan_act_is_sound:
    assumes "wf_plan_action (PAction n args)"
    shows "sound_opr
      (instantiate_action_schema (the (resolve_action_schema n)) args)
      ((pddl_opr_to_act
        (instantiate_action_schema (the (resolve_action_schema n)) args)))"
    using assms
    using wf_action_schema_sound_inst wf_eff_pddl_ground_act_is_sound_opr
    by (auto split: option.splits)

  lemma wf_plan_act_is_sound':
    assumes "wf_plan_action \<pi>"
    shows "sound_opr
      (resolve_instantiate \<pi>)
      ((pddl_opr_to_act (resolve_instantiate \<pi>)))"
    using assms wf_plan_act_is_sound
    by (cases \<pi>; auto )

  lemma wf_world_model_has_atoms: "f\<in>M \<Longrightarrow> wf_world_model M \<Longrightarrow> is_predAtom f"
    using wf_fmla_atm_is_atom
    unfolding wf_world_model_def
    by auto

  lemma wm_to_state_works_for_wf_wm_closed:
    "wf_world_model M \<Longrightarrow> fmla\<in>close_world M \<Longrightarrow> close_eq (wm_to_state M) \<Turnstile> fmla"
    apply (cases fmla rule: wf_fmla_atom.cases)
    by (auto simp: wf_world_model_def close_eq_def wm_to_state_def close_world_def)

  lemma wm_to_state_works_for_wf_wm: "wf_world_model M \<Longrightarrow> fmla\<in>M \<Longrightarrow> close_eq (wm_to_state M) \<Turnstile> fmla"
    apply (cases fmla rule: wf_fmla_atom.cases)
    by (auto simp: wf_world_model_def close_eq_def wm_to_state_def)

  lemma wm_to_state_works_for_I_closed:
    assumes "x \<in> close_world I"
    shows "close_eq (wm_to_state I) \<Turnstile> x"
    apply (rule wm_to_state_works_for_wf_wm_closed)
    using assms wf_I by auto

  lemma wf_wm_imp_basic: "wf_world_model M \<Longrightarrow> wm_basic M"
    by (auto simp: wf_world_model_def wm_basic_def wf_fmla_atm_is_atom)

theorem wf_plan_sound_system:
  assumes "\<forall>\<pi>\<in> set \<pi>s. wf_plan_action \<pi>"
  shows "sound_system
      (set (map resolve_instantiate \<pi>s))
      I
      (wm_to_state I)
      ((\<lambda>\<alpha>. pddl_opr_to_act \<alpha>))"
  unfolding sound_system_def
proof(intro conjI ballI)
  show "close_eq(wm_to_state I) \<Turnstile> x" if "x \<in> close_world I" for x
    using that[unfolded in_close_world_conv]
      wm_to_state_works_for_I_closed wm_to_state_works_for_wf_wm
    by (auto simp: wf_I)

  show "wm_basic I" using wf_wm_imp_basic[OF wf_I] .

  show "sound_opr \<alpha> (pddl_opr_to_act \<alpha>)" if "\<alpha> \<in> set (map resolve_instantiate \<pi>s)" for \<alpha>
    using that
    using wf_plan_act_is_sound' assms
    by auto
qed

theorem wf_plan_soundness_theorem:
    assumes "plan_action_path I \<pi>s M"
    defines "\<alpha>s \<equiv> map (pddl_opr_to_act \<circ> resolve_instantiate) \<pi>s"
    defines "s\<^sub>0 \<equiv> wm_to_state I"
    shows "\<exists>s'. compose_actions \<alpha>s s\<^sub>0 = Some s' \<and> (\<forall>\<phi>\<in>close_world M. s' \<Turnstile>\<^sub>= \<phi>)"
    apply (rule STRIPS_sema_sound)
    apply (rule wf_plan_sound_system)
    using assms
    unfolding plan_action_path_def
    by (auto simp add: image_def)

end \<comment> \<open>Context of \<open>wf_ast_problem\<close>\<close>

end


theory Tree_Automata_Abstract_Impl
  imports Tree_Automata_Det Horn_Fset
begin

section \<open>Computing state derivation\<close>

lemma ta_der_Var_code [code]:
  "ta_der \<A> (Var q) = finsert q ((eps \<A>)|\<^sup>+| |``| {|q|})"
  by (auto)

lemma ta_der_Fun_code [code]:
  "ta_der \<A> (Fun f ts) =
     (let args = map (ta_der \<A>) ts in
      let P = (\<lambda> r. case r of TA_rule g ps p \<Rightarrow> f = g \<and> list_all2 fmember ps args) in
      let S = r_rhs |`| ffilter P (rules \<A>) in
         S |\<union>| (eps \<A>)|\<^sup>+| |``| S)" (is "?Ls = ?Rs")
proof
  {fix q assume "q |\<in>| ?Ls" then have "q |\<in>| ?Rs"
      by (auto simp: Let_def ffmember_filter fimage_iff fBex_def list_all2_conv_all_nth fImage_iff
               split!: ta_rule.splits) force}
  then show "?Ls |\<subseteq>| ?Rs" by blast
next
  {fix q assume "q |\<in>| ?Rs" then have "q |\<in>| ?Ls"
      apply (auto simp: Let_def ffmember_filter fimage_iff fBex_def list_all2_conv_all_nth fImage_iff
                  split!: ta_rule.splits)
      apply (metis ta_rule.collapse)
      apply blast
      done}
  then show "?Rs |\<subseteq>| ?Ls" by blast
qed

definition eps_free_automata where
  "eps_free_automata epscl \<A> =
  (let ruleps = (\<lambda> r. finsert (r_rhs r) (epscl |``| {|r_rhs r|})) in
   let rules = (\<lambda> r. (\<lambda> q. TA_rule (r_root r) (r_lhs_states r) q) |`| (ruleps r)) |`| (rules \<A>) in
   TA ( |\<Union>| rules) {||})"

lemma eps_free [code]:
  "eps_free \<A> = eps_free_automata ((eps \<A>)|\<^sup>+|) \<A>"
  apply (intro TA_equalityI)
   apply (auto simp: eps_free_def eps_free_rulep_def eps_free_automata_def)
  using fBex_def apply fastforce
  apply (metis ta_rule.exhaust_sel)+
  done

lemma eps_of_eps_free_automata [simp]:
  "eps (eps_free_automata S \<A>) = {||}"
  by (auto simp add: eps_free_automata_def)

lemma eps_free_automata_empty [simp]:
  "eps \<A> = {||} \<Longrightarrow> eps_free_automata {||} \<A> = \<A>"
  by (auto simp add: eps_free_automata_def intro!: TA_equalityI)

section \<open>Computing the restriction of tree automata to state set\<close>

lemma ta_restrict [code]:
  "ta_restrict \<A> Q =
     (let rules =  ffilter (\<lambda> r. case r of TA_rule f ps p \<Rightarrow> fset_of_list ps |\<subseteq>| Q \<and> p |\<in>| Q) (rules \<A>) in
      let eps = ffilter (\<lambda> r. case r of (p, q) \<Rightarrow> p |\<in>| Q \<and> q |\<in>| Q) (eps \<A>) in
      TA rules eps)"
  by (auto simp: Let_def ta_restrict_def split!: ta_rule.splits intro: finite_subset[OF _ finite_Collect_ta_rule])

section \<open>Computing the epsilon transition for the product automaton\<close>

lemma prod_eps[code_unfold]:
  "fCollect (prod_epsLp \<A> \<B>) = (\<lambda> ((p, q), r). ((p, r), (q, r))) |`| (eps \<A> |\<times>| \<Q> \<B>)"
  "fCollect (prod_epsRp \<A> \<B>) = (\<lambda> ((p, q), r). ((r, p), (r, q))) |`| (eps \<B> |\<times>| \<Q> \<A>)"
  by (auto simp: finite_prod_epsLp prod_epsLp_def finite_prod_epsRp prod_epsRp_def fimage_iff fBex_def)

section \<open>Computing reachability\<close>

inductive_set ta_reach for \<A> where
   rule [intro]: "f qs \<rightarrow> q |\<in>| rules \<A> \<Longrightarrow> \<forall> i < length qs. qs ! i \<in> ta_reach \<A> \<Longrightarrow> q \<in> ta_reach \<A>"
 |  eps [intro]: "q \<in> ta_reach \<A> \<Longrightarrow> (q, r) |\<in>| eps \<A> \<Longrightarrow> r \<in> ta_reach \<A>"

lemma ta_reach_eps_transI:
  assumes "(p, q) |\<in>| (eps \<A>)|\<^sup>+|" "p \<in> ta_reach \<A>"
  shows "q \<in> ta_reach \<A>" using assms
  by (induct rule: ftrancl_induct) auto

lemma ta_reach_ground_term_der:
  assumes "q \<in> ta_reach \<A>"
  shows "\<exists> t. ground t \<and> q |\<in>| ta_der \<A> t" using assms
proof (induct)
  case (rule f qs q)
  then obtain ts where "length ts = length qs"
    "\<forall> i < length qs. ground (ts ! i)"
    "\<forall> i < length qs. qs ! i |\<in>| ta_der \<A> (ts ! i)"
    using Ex_list_of_length_P[of "length qs" "\<lambda> t i. ground t \<and> qs ! i |\<in>| ta_der \<A> t"]
    by auto
  then show ?case using rule(1)
    by (auto dest!: in_set_idx intro!: exI[of _ "Fun f ts"]) blast
qed (auto, meson ta_der_eps)

lemma ground_term_der_ta_reach:
  assumes "ground t" "q |\<in>| ta_der \<A> t"
  shows "q \<in> ta_reach \<A>" using assms(2, 1)
  by (induct rule: ta_der_induct) (auto simp add: rule ta_reach_eps_transI)

lemma ta_reach_reachable:
  "ta_reach \<A> = fset (ta_reachable \<A>)"
  using ta_reach_ground_term_der[of _ \<A>]
  using ground_term_der_ta_reach[of _ _ \<A>]
  unfolding ta_reachable_def
  by (auto simp flip: fmember_iff_member_fset)

subsection \<open>Horn setup for reachable states\<close>
definition "reach_rules \<A> =
  {qs \<rightarrow>\<^sub>h q | f qs q. TA_rule f qs q |\<in>| rules \<A>} \<union>
  {[q] \<rightarrow>\<^sub>h r | q r. (q, r) |\<in>| eps \<A>}"

locale reach_horn =
  fixes \<A> :: "('q, 'f) ta"
begin

sublocale horn "reach_rules \<A>" .

lemma reach_infer0: "infer0 = {q | f q. TA_rule f [] q |\<in>| rules \<A>}"
  by (auto simp: horn.infer0_def reach_rules_def)

lemma reach_infer1:
  "infer1 p X = {r | f qs r. TA_rule f qs r |\<in>| rules \<A> \<and> p \<in> set qs \<and> set qs \<subseteq> insert p X} \<union>
   {r | r. (p, r) |\<in>| eps \<A>}"
  unfolding reach_rules_def
  by (auto simp: horn.infer1_def simp flip: ex_simps(1))

lemma reach_sound:
  "ta_reach \<A> = saturate"
proof (intro set_eqI iffI, goal_cases lr rl)
  case (lr x) obtain p where x: "p = ta_reach \<A>" by auto
  show ?case using lr unfolding x
  proof (induct)
    case (rule f qs q)
    then show ?case
      by (intro infer[of qs q]) (auto simp: reach_rules_def dest: in_set_idx)
  next
    case (eps q r)
    then show ?case
      by (intro infer[of "[q]" r]) (auto simp: reach_rules_def)
  qed
next
  case (rl x)
  then show ?case
    by (induct) (auto simp: reach_rules_def)
qed
end

subsection \<open>Computing productivity\<close>

text \<open>First, use an alternative definition of productivity\<close>

inductive_set ta_productive_ind :: "'q fset \<Rightarrow> ('q,'f) ta \<Rightarrow> 'q set" for P and \<A> :: "('q,'f) ta" where
  basic [intro]: "q |\<in>| P \<Longrightarrow> q \<in> ta_productive_ind P \<A>"
| eps [intro]: "(p, q) |\<in>| (eps \<A>)|\<^sup>+| \<Longrightarrow> q \<in> ta_productive_ind P \<A> \<Longrightarrow> p \<in> ta_productive_ind P \<A>"
| rule: "TA_rule f qs q |\<in>| rules \<A> \<Longrightarrow> q \<in> ta_productive_ind P \<A> \<Longrightarrow> q' \<in> set qs \<Longrightarrow> q' \<in> ta_productive_ind P \<A>"

lemma ta_productive_ind:
  "ta_productive_ind P \<A> = fset (ta_productive P \<A>)" (is "?LS = ?RS")
proof -
  {fix q assume "q \<in> ?LS" then have "q \<in> ?RS"
      by (induct) (auto dest: ta_prod_epsD simp flip: fmember_iff_member_fset intro: ta_productive_setI,
         metis (full_types) in_set_conv_nth rule_reachable_ctxt_exist ta_productiveI')}
  moreover
  {fix q assume "q \<in> ?RS" note * = this[unfolded fmember_iff_member_fset[symmetric]]
    from ta_productiveE[OF *] obtain r C where
      reach : "r |\<in>| ta_der \<A> C\<langle>Var q\<rangle>" and f: "r |\<in>| P" by auto
    from f have "r \<in> ta_productive_ind P \<A>" "r |\<in>| ta_productive P \<A>"
      by (auto intro: ta_productive_setI)
    then have "q \<in> ?LS" using reach
    proof (induct C arbitrary: q r)
      case (More f ss C ts)
      from iffD1 ta_der_Fun[THEN iffD1, OF More(4)[unfolded ctxt_apply_term.simps]] obtain ps p where
        inv: "f ps \<rightarrow> p |\<in>| rules \<A>" "p = r \<or> (p, r) |\<in>| (eps \<A>)|\<^sup>+|" "length ps = length (ss @ C\<langle>Var q\<rangle> # ts)"
             "ps ! length ss |\<in>| ta_der \<A> C\<langle>Var q\<rangle>"
        by (auto simp: nth_append_Cons split: if_splits)
      then have "p \<in> ta_productive_ind P \<A> \<Longrightarrow> p |\<in>| ta_der \<A> C\<langle>Var q\<rangle> \<Longrightarrow> q \<in> ta_productive_ind P \<A>" for p
        using More(1) calculation by (auto simp flip: fmember_iff_member_fset)
      note [intro!] = this[of "ps ! length ss"]
      show ?case using More(2) inv
        by (auto simp flip: fmember_iff_member_fset simp: nth_append_Cons ta_productive_ind.rule)
           (metis less_add_Suc1 nth_mem ta_productive_ind.simps)
    qed (auto intro: ta_productive_setI)
  }
  ultimately show ?thesis by auto
qed

subsubsection \<open>Horn setup for productive states\<close>

definition "productive_rules P \<A> = {[] \<rightarrow>\<^sub>h q | q. q |\<in>| P} \<union>
  {[r] \<rightarrow>\<^sub>h q | q r. (q, r) |\<in>| eps \<A>} \<union>
  {[q] \<rightarrow>\<^sub>h r | f qs q r. TA_rule f qs q |\<in>| rules \<A> \<and> r \<in> set qs}"

locale productive_horn =
  fixes \<A> :: "('q, 'f) ta" and P :: "'q fset"
begin

sublocale horn "productive_rules P \<A>" .

lemma productive_infer0: "infer0 = fset P"
  by (auto simp: productive_rules_def horn.infer0_def simp flip: fmember_iff_member_fset)

lemma productive_infer1:
  "infer1 p X = {r | r. (r, p) |\<in>| eps \<A>} \<union>
    {r | f qs r. TA_rule f qs p |\<in>| rules \<A> \<and> r \<in> set qs}"
  unfolding productive_rules_def horn_infer1_union
  by (auto simp add: horn.infer1_def)
     (metis insertCI list.set(1) list.simps(15) singletonD subsetI)

lemma productive_sound:
  "ta_productive_ind P \<A> = saturate"
proof (intro set_eqI iffI, goal_cases lr rl)
  case (lr p) then show ?case using lr
  proof (induct)
    case (basic q)
    then show ?case
      by (intro infer[of "[]" q]) (auto simp: productive_rules_def)
  next
    case (eps p q) then show ?case
    proof (induct rule: ftrancl_induct)
      case (Base p q)
      then show ?case using infer[of "[q]" p]
        by (auto simp: productive_rules_def)
    next
      case (Step p q r)
      then show ?case using infer[of "[r]" q]
        by (auto simp: productive_rules_def)
    qed
  next
    case (rule f qs q p)
    then show ?case
      by (intro infer[of "[q]" p]) (auto simp: productive_rules_def)
  qed
next
  case (rl p)
  then show ?case
    by (induct) (auto simp: productive_rules_def ta_productive_ind.rule)
qed
end

subsection \<open>Horn setup for power set construction states\<close>

lemma prod_list_exists:
  assumes "fst p \<in> set qs" "set qs \<subseteq> insert (fst p) (fst ` X)"
  obtains as where "p \<in> set as" "map fst as = qs" "set as \<subseteq> insert p X"
proof -
  from assms have "qs \<in> lists (fst ` (insert p X))" by blast
  then obtain ts where ts: "map fst ts = qs" "ts \<in> lists (insert p X)"
    by (metis image_iff lists_image)
  then obtain i where mem: "i < length qs" "qs ! i = fst p" using assms(1)
    by (metis in_set_idx)
  from ts have p: "ts[i := p] \<in> lists (insert p X)"
    using set_update_subset_insert by fastforce
  then have "p \<in> set (ts[i := p])" "map fst (ts[i := p]) = qs" "set (ts[i := p]) \<subseteq> insert p X"
    using mem ts(1)
    by (auto simp add: nth_list_update set_update_memI intro!: nth_equalityI)
  then show ?thesis using that
    by blast
qed

definition "ps_states_rules \<A> = {rs \<rightarrow>\<^sub>h (Wrapp q) | rs f q.
    q = ps_reachable_states \<A> f (map ex rs) \<and> q \<noteq> {||}}"

locale ps_states_horn =
  fixes \<A> :: "('q, 'f) ta"
begin

sublocale horn "ps_states_rules \<A>" .

lemma ps_construction_infer0: "infer0 =
  {Wrapp q | f q. q = ps_reachable_states \<A> f [] \<and> q \<noteq> {||}}"
    by (auto simp: ps_states_rules_def horn.infer0_def simp flip: fmember_iff_member_fset)

lemma ps_construction_infer1:
  "infer1 p X = {Wrapp q | f qs q. q = ps_reachable_states \<A> f (map ex qs) \<and> q \<noteq> {||} \<and>
   p \<in> set qs \<and> set qs \<subseteq> insert p X}"
  unfolding ps_states_rules_def horn_infer1_union
  by (auto simp add: horn.infer1_def ps_reachable_states_def comp_def elim!: prod_list_exists)

lemma ps_states_sound:
  "ps_states_set \<A> = saturate"
proof (intro set_eqI iffI, goal_cases lr rl)
  case (lr p) then show ?case using lr
  proof (induct)
    case (1 ps f)
    then have "ps \<rightarrow>\<^sub>h (Wrapp (ps_reachable_states \<A> f (map ex ps))) \<in> ps_states_rules \<A>"
      by (auto simp: ps_states_rules_def)
    then show ?case using horn.saturate.simps 1
      by fastforce
  qed
next
  case (rl p)
  then obtain q where "q \<in> saturate" "q = p" by blast
  then show ?case
    by (induct arbitrary: p)
       (auto simp: ps_states_rules_def intro!: ps_states_set.intros)
qed

end

definition ps_reachable_states_cont where
  "ps_reachable_states_cont \<Delta> \<Delta>\<^sub>\<epsilon> f ps =
   (let R = ffilter (\<lambda> r. case r of TA_rule g qs q \<Rightarrow> f = g \<and> list_all2 (|\<in>|) qs ps) \<Delta> in
    let S = r_rhs |`| R in
    S |\<union>| \<Delta>\<^sub>\<epsilon>|\<^sup>+| |``| S)"

lemma ps_reachable_states [code]:
  "ps_reachable_states (TA \<Delta> \<Delta>\<^sub>\<epsilon>) f ps = ps_reachable_states_cont \<Delta> \<Delta>\<^sub>\<epsilon> f ps"
  by (auto simp: ps_reachable_states_fmember ps_reachable_states_cont_def Let_def fimage_iff fBex_def
           split!: ta_rule.splits) force+

definition ps_rules_cont where
 "ps_rules_cont \<A> Q =
   (let sig = ta_sig \<A> in
    let qss = (\<lambda> (f, n). (f, n, fset_of_list (List.n_lists n (sorted_list_of_fset Q)))) |`| sig in
    let res = (\<lambda> (f, n, Qs). (\<lambda> qs. TA_rule f qs (Wrapp (ps_reachable_states \<A> f (map ex qs)))) |`| Qs) |`| qss in
      ffilter (\<lambda> r. ex (r_rhs r) \<noteq> {||}) ( |\<Union>| res))"

lemma ps_rules [code]:
  "ps_rules \<A> Q = ps_rules_cont \<A> Q"
  using ps_reachable_states_sig finite_ps_rulesp_unfolded[of Q \<A>]
  unfolding ps_rules_cont_def
  apply (auto simp: fset_of_list_elem ps_rules_def fin_mono ps_rulesp_def
    fimage_iff set_n_lists simp flip: fmember_iff_member_fset split!: prod.splits dest!: in_set_idx)
  apply fastforce
  apply (meson fmember_iff_member_fset nth_mem subsetD)
  done

end


(*  Title:      HOL/UNITY/ELT.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1999  University of Cambridge

leadsTo strengthened with a specification of the allowable sets transient parts

TRY INSTEAD (to get rid of the {} and to gain strong induction)

  elt :: "['a set set, 'a program, 'a set] => ('a set) set"

inductive "elt CC F B"
  intros

    Weaken:  "A <= B ==> A : elt CC F B"

    ETrans:  "[| F : A ensures A';  A-A' : CC;  A' : elt CC F B |]
              ==> A : elt CC F B"

    Union:  "{A. A: S} : Pow (elt CC F B) ==> (Union S) : elt CC F B"

  monos Pow_mono
*)

section\<open>Progress Under Allowable Sets\<close>

theory ELT imports Project begin

inductive_set
  (*LEADS-TO constant for the inductive definition*)
  elt :: "['a set set, 'a program] => ('a set * 'a set) set"
  for CC :: "'a set set" and F :: "'a program"
 where

   Basis:  "[| F \<in> A ensures B;  A-B \<in> (insert {} CC) |] ==> (A,B) \<in> elt CC F"

 | Trans:  "[| (A,B) \<in> elt CC F;  (B,C) \<in> elt CC F |] ==> (A,C) \<in> elt CC F"

 | Union:  "\<forall>A\<in>S. (A,B) \<in> elt CC F ==> (Union S, B) \<in> elt CC F"

definition
  (*the set of all sets determined by f alone*)
  givenBy :: "['a => 'b] => 'a set set"
  where "givenBy f = range (%B. f-` B)"

definition
  (*visible version of the LEADS-TO relation*)
  leadsETo :: "['a set, 'a set set, 'a set] => 'a program set"
                                        ("(3_/ leadsTo[_]/ _)" [80,0,80] 80)
  where "leadsETo A CC B = {F. (A,B) \<in> elt CC F}"

definition
  LeadsETo :: "['a set, 'a set set, 'a set] => 'a program set"
                                        ("(3_/ LeadsTo[_]/ _)" [80,0,80] 80)
  where "LeadsETo A CC B =
      {F. F \<in> (reachable F Int A) leadsTo[(%C. reachable F Int C) ` CC] B}"

(*** givenBy ***)

lemma givenBy_id [simp]: "givenBy id = UNIV"
by (unfold givenBy_def, auto)

lemma givenBy_eq_all: "(givenBy v) = {A. \<forall>x\<in>A. \<forall>y. v x = v y \<longrightarrow> y \<in> A}"
apply (unfold givenBy_def, safe)
apply (rule_tac [2] x = "v ` _" in image_eqI, auto)
done

lemma givenByI: "(\<And>x y. [| x \<in> A;  v x = v y |] ==> y \<in> A) ==> A \<in> givenBy v"
by (subst givenBy_eq_all, blast)

lemma givenByD: "[| A \<in> givenBy v;  x \<in> A;  v x = v y |] ==> y \<in> A"
by (unfold givenBy_def, auto)

lemma empty_mem_givenBy [iff]: "{} \<in> givenBy v"
by (blast intro!: givenByI)

lemma givenBy_imp_eq_Collect: "A \<in> givenBy v ==> \<exists>P. A = {s. P(v s)}"
apply (rule_tac x = "\<lambda>n. \<exists>s. v s = n \<and> s \<in> A" in exI)
apply (simp (no_asm_use) add: givenBy_eq_all)
apply blast
done

lemma Collect_mem_givenBy: "{s. P(v s)} \<in> givenBy v"
by (unfold givenBy_def, best)

lemma givenBy_eq_Collect: "givenBy v = {A. \<exists>P. A = {s. P(v s)}}"
by (blast intro: Collect_mem_givenBy givenBy_imp_eq_Collect)

(*preserving v preserves properties given by v*)
lemma preserves_givenBy_imp_stable:
     "[| F \<in> preserves v;  D \<in> givenBy v |] ==> F \<in> stable D"
by (force simp add: preserves_subset_stable [THEN subsetD] givenBy_eq_Collect)

lemma givenBy_o_subset: "givenBy (w o v) <= givenBy v"
apply (simp (no_asm) add: givenBy_eq_Collect)
apply best
done

lemma givenBy_DiffI:
     "[| A \<in> givenBy v;  B \<in> givenBy v |] ==> A-B \<in> givenBy v"
apply (simp (no_asm_use) add: givenBy_eq_Collect)
apply safe
apply (rule_tac x = "%z. R z & ~ Q z" for R Q in exI)
unfolding set_diff_eq
apply auto
done

(** Standard leadsTo rules **)

lemma leadsETo_Basis [intro]:
     "[| F \<in> A ensures B;  A-B \<in> insert {} CC |] ==> F \<in> A leadsTo[CC] B"
apply (unfold leadsETo_def)
apply (blast intro: elt.Basis)
done

lemma leadsETo_Trans:
     "[| F \<in> A leadsTo[CC] B;  F \<in> B leadsTo[CC] C |] ==> F \<in> A leadsTo[CC] C"
apply (unfold leadsETo_def)
apply (blast intro: elt.Trans)
done

(*Useful with cancellation, disjunction*)
lemma leadsETo_Un_duplicate:
     "F \<in> A leadsTo[CC] (A' \<union> A') \<Longrightarrow> F \<in> A leadsTo[CC] A'"
by (simp add: Un_ac)

lemma leadsETo_Un_duplicate2:
     "F \<in> A leadsTo[CC] (A' \<union> C \<union> C) ==> F \<in> A leadsTo[CC] (A' Un C)"
by (simp add: Un_ac)

(*The Union introduction rule as we should have liked to state it*)
lemma leadsETo_Union:
    "(\<And>A. A \<in> S \<Longrightarrow> F \<in> A leadsTo[CC] B) \<Longrightarrow> F \<in> (\<Union>S) leadsTo[CC] B"
apply (unfold leadsETo_def)
apply (blast intro: elt.Union)
done

lemma leadsETo_UN:
    "(\<And>i. i \<in> I \<Longrightarrow> F \<in> (A i) leadsTo[CC] B)
     ==> F \<in> (UN i:I. A i) leadsTo[CC] B"
apply (blast intro: leadsETo_Union)
done

(*The INDUCTION rule as we should have liked to state it*)
lemma leadsETo_induct:
  "[| F \<in> za leadsTo[CC] zb;
      !!A B. [| F \<in> A ensures B;  A-B \<in> insert {} CC |] ==> P A B;
      !!A B C. [| F \<in> A leadsTo[CC] B; P A B; F \<in> B leadsTo[CC] C; P B C |]
               ==> P A C;
      !!B S. \<forall>A\<in>S. F \<in> A leadsTo[CC] B & P A B ==> P (\<Union>S) B
   |] ==> P za zb"
apply (unfold leadsETo_def)
apply (drule CollectD)
apply (erule elt.induct, blast+)
done

(** New facts involving leadsETo **)

lemma leadsETo_mono: "CC' <= CC ==> (A leadsTo[CC'] B) <= (A leadsTo[CC] B)"
apply safe
apply (erule leadsETo_induct)
prefer 3 apply (blast intro: leadsETo_Union)
prefer 2 apply (blast intro: leadsETo_Trans)
apply blast
done

lemma leadsETo_Trans_Un:
     "[| F \<in> A leadsTo[CC] B;  F \<in> B leadsTo[DD] C |]
      ==> F \<in> A leadsTo[CC Un DD] C"
by (blast intro: leadsETo_mono [THEN subsetD] leadsETo_Trans)

lemma leadsETo_Union_Int:
 "(!!A. A \<in> S ==> F \<in> (A Int C) leadsTo[CC] B)
  ==> F \<in> (\<Union>S Int C) leadsTo[CC] B"
apply (unfold leadsETo_def)
apply (simp only: Int_Union_Union)
apply (blast intro: elt.Union)
done

(*Binary union introduction rule*)
lemma leadsETo_Un:
     "[| F \<in> A leadsTo[CC] C; F \<in> B leadsTo[CC] C |]
      ==> F \<in> (A Un B) leadsTo[CC] C"
  using leadsETo_Union [of "{A, B}" F CC C] by auto

lemma single_leadsETo_I:
     "(\<And>x. x \<in> A ==> F \<in> {x} leadsTo[CC] B) \<Longrightarrow> F \<in> A leadsTo[CC] B"
by (subst UN_singleton [symmetric], rule leadsETo_UN, blast)

lemma subset_imp_leadsETo: "A<=B \<Longrightarrow> F \<in> A leadsTo[CC] B"
by (simp add: subset_imp_ensures [THEN leadsETo_Basis]
              Diff_eq_empty_iff [THEN iffD2])

lemmas empty_leadsETo = empty_subsetI [THEN subset_imp_leadsETo, simp]

(** Weakening laws **)

lemma leadsETo_weaken_R:
     "[| F \<in> A leadsTo[CC] A';  A'<=B' |] ==> F \<in> A leadsTo[CC] B'"
by (blast intro: subset_imp_leadsETo leadsETo_Trans)

lemma leadsETo_weaken_L:
     "[| F \<in> A leadsTo[CC] A'; B<=A |] ==> F \<in> B leadsTo[CC] A'"
by (blast intro: leadsETo_Trans subset_imp_leadsETo)

(*Distributes over binary unions*)
lemma leadsETo_Un_distrib:
     "F \<in> (A Un B) leadsTo[CC] C  =
      (F \<in> A leadsTo[CC] C \<and> F \<in> B leadsTo[CC] C)"
by (blast intro: leadsETo_Un leadsETo_weaken_L)

lemma leadsETo_UN_distrib:
     "F \<in> (UN i:I. A i) leadsTo[CC] B  =
      (\<forall>i\<in>I. F \<in> (A i) leadsTo[CC] B)"
by (blast intro: leadsETo_UN leadsETo_weaken_L)

lemma leadsETo_Union_distrib:
     "F \<in> (\<Union>S) leadsTo[CC] B  =  (\<forall>A\<in>S. F \<in> A leadsTo[CC] B)"
by (blast intro: leadsETo_Union leadsETo_weaken_L)

lemma leadsETo_weaken:
     "[| F \<in> A leadsTo[CC'] A'; B<=A; A'<=B';  CC' <= CC |]
      ==> F \<in> B leadsTo[CC] B'"
apply (drule leadsETo_mono [THEN subsetD], assumption)
apply (blast del: subsetCE
             intro: leadsETo_weaken_R leadsETo_weaken_L leadsETo_Trans)
done

lemma leadsETo_givenBy:
     "[| F \<in> A leadsTo[CC] A';  CC <= givenBy v |]
      ==> F \<in> A leadsTo[givenBy v] A'"
by (blast intro: leadsETo_weaken)

(*Set difference*)
lemma leadsETo_Diff:
     "[| F \<in> (A-B) leadsTo[CC] C; F \<in> B leadsTo[CC] C |]
      ==> F \<in> A leadsTo[CC] C"
by (blast intro: leadsETo_Un leadsETo_weaken)

(*Binary union version*)
lemma leadsETo_Un_Un:
     "[| F \<in> A leadsTo[CC] A';  F \<in> B leadsTo[CC] B' |]
      ==> F \<in> (A Un B) leadsTo[CC] (A' Un B')"
by (blast intro: leadsETo_Un leadsETo_weaken_R)

(** The cancellation law **)

lemma leadsETo_cancel2:
     "[| F \<in> A leadsTo[CC] (A' Un B); F \<in> B leadsTo[CC] B' |]
      ==> F \<in> A leadsTo[CC] (A' Un B')"
by (blast intro: leadsETo_Un_Un subset_imp_leadsETo leadsETo_Trans)

lemma leadsETo_cancel1:
     "[| F \<in> A leadsTo[CC] (B Un A'); F \<in> B leadsTo[CC] B' |]
    ==> F \<in> A leadsTo[CC] (B' Un A')"
apply (simp add: Un_commute)
apply (blast intro!: leadsETo_cancel2)
done

lemma leadsETo_cancel_Diff1:
     "[| F \<in> A leadsTo[CC] (B Un A'); F \<in> (B-A') leadsTo[CC] B' |]
    ==> F \<in> A leadsTo[CC] (B' Un A')"
apply (rule leadsETo_cancel1)
 prefer 2 apply assumption
apply simp_all
done

(** PSP: Progress-Safety-Progress **)

(*Special case of PSP: Misra's "stable conjunction"*)
lemma e_psp_stable:
   "[| F \<in> A leadsTo[CC] A';  F \<in> stable B;  \<forall>C\<in>CC. C Int B \<in> CC |]
    ==> F \<in> (A Int B) leadsTo[CC] (A' Int B)"
apply (unfold stable_def)
apply (erule leadsETo_induct)
prefer 3 apply (blast intro: leadsETo_Union_Int)
prefer 2 apply (blast intro: leadsETo_Trans)
apply (rule leadsETo_Basis)
prefer 2 apply (force simp add: Diff_Int_distrib2 [symmetric])
apply (simp add: ensures_def Diff_Int_distrib2 [symmetric]
                 Int_Un_distrib2 [symmetric])
apply (blast intro: transient_strengthen constrains_Int)
done

lemma e_psp_stable2:
     "[| F \<in> A leadsTo[CC] A'; F \<in> stable B;  \<forall>C\<in>CC. C Int B \<in> CC |]
      ==> F \<in> (B Int A) leadsTo[CC] (B Int A')"
by (simp (no_asm_simp) add: e_psp_stable Int_ac)

lemma e_psp:
     "[| F \<in> A leadsTo[CC] A'; F \<in> B co B';
         \<forall>C\<in>CC. C Int B Int B' \<in> CC |]
      ==> F \<in> (A Int B') leadsTo[CC] ((A' Int B) Un (B' - B))"
apply (erule leadsETo_induct)
prefer 3 apply (blast intro: leadsETo_Union_Int)
(*Transitivity case has a delicate argument involving "cancellation"*)
apply (rule_tac [2] leadsETo_Un_duplicate2)
apply (erule_tac [2] leadsETo_cancel_Diff1)
prefer 2
 apply (simp add: Int_Diff Diff_triv)
 apply (blast intro: leadsETo_weaken_L dest: constrains_imp_subset)
(*Basis case*)
apply (rule leadsETo_Basis)
apply (blast intro: psp_ensures)
apply (subgoal_tac "A Int B' - (Ba Int B Un (B' - B)) = (A - Ba) Int B Int B'")
apply auto
done

lemma e_psp2:
     "[| F \<in> A leadsTo[CC] A'; F \<in> B co B';
         \<forall>C\<in>CC. C Int B Int B' \<in> CC |]
      ==> F \<in> (B' Int A) leadsTo[CC] ((B Int A') Un (B' - B))"
by (simp add: e_psp Int_ac)

(*** Special properties involving the parameter [CC] ***)

(*??IS THIS NEEDED?? or is it just an example of what's provable??*)
lemma gen_leadsETo_imp_Join_leadsETo:
     "[| F \<in> (A leadsTo[givenBy v] B);  G \<in> preserves v;
         F\<squnion>G \<in> stable C |]
      ==> F\<squnion>G \<in> ((C Int A) leadsTo[(%D. C Int D) ` givenBy v] B)"
apply (erule leadsETo_induct)
  prefer 3
  apply (subst Int_Union)
  apply (blast intro: leadsETo_UN)
prefer 2
 apply (blast intro: e_psp_stable2 [THEN leadsETo_weaken_L] leadsETo_Trans)
apply (rule leadsETo_Basis)
apply (auto simp add: Diff_eq_empty_iff [THEN iffD2]
                      Int_Diff ensures_def givenBy_eq_Collect)
prefer 3 apply (blast intro: transient_strengthen)
apply (drule_tac [2] P1 = P in preserves_subset_stable [THEN subsetD])
apply (drule_tac P1 = P in preserves_subset_stable [THEN subsetD])
apply (unfold stable_def)
apply (blast intro: constrains_Int [THEN constrains_weaken])+
done

(**** Relationship with traditional "leadsTo", strong & weak ****)

(** strong **)

lemma leadsETo_subset_leadsTo: "(A leadsTo[CC] B) <= (A leadsTo B)"
apply safe
apply (erule leadsETo_induct)
  prefer 3 apply (blast intro: leadsTo_Union)
 prefer 2 apply (blast intro: leadsTo_Trans, blast)
done

lemma leadsETo_UNIV_eq_leadsTo: "(A leadsTo[UNIV] B) = (A leadsTo B)"
apply safe
apply (erule leadsETo_subset_leadsTo [THEN subsetD])
(*right-to-left case*)
apply (erule leadsTo_induct)
  prefer 3 apply (blast intro: leadsETo_Union)
 prefer 2 apply (blast intro: leadsETo_Trans, blast)
done

(**** weak ****)

lemma LeadsETo_eq_leadsETo:
     "A LeadsTo[CC] B =
        {F. F \<in> (reachable F Int A) leadsTo[(%C. reachable F Int C) ` CC]
        (reachable F Int B)}"
apply (unfold LeadsETo_def)
apply (blast dest: e_psp_stable2 intro: leadsETo_weaken)
done

(*** Introduction rules: Basis, Trans, Union ***)

lemma LeadsETo_Trans:
     "[| F \<in> A LeadsTo[CC] B;  F \<in> B LeadsTo[CC] C |]
      ==> F \<in> A LeadsTo[CC] C"
apply (simp add: LeadsETo_eq_leadsETo)
apply (blast intro: leadsETo_Trans)
done

lemma LeadsETo_Union:
     "(\<And>A. A \<in> S \<Longrightarrow> F \<in> A LeadsTo[CC] B) \<Longrightarrow> F \<in> (\<Union>S) LeadsTo[CC] B"
apply (simp add: LeadsETo_def)
apply (subst Int_Union)
apply (blast intro: leadsETo_UN)
done

lemma LeadsETo_UN:
     "(\<And>i. i \<in> I \<Longrightarrow> F \<in> (A i) LeadsTo[CC] B)
      \<Longrightarrow> F \<in> (UN i:I. A i) LeadsTo[CC] B"
apply (blast intro: LeadsETo_Union)
done

(*Binary union introduction rule*)
lemma LeadsETo_Un:
     "[| F \<in> A LeadsTo[CC] C; F \<in> B LeadsTo[CC] C |]
      ==> F \<in> (A Un B) LeadsTo[CC] C"
  using LeadsETo_Union [of "{A, B}" F CC C] by auto

(*Lets us look at the starting state*)
lemma single_LeadsETo_I:
     "(\<And>s. s \<in> A ==> F \<in> {s} LeadsTo[CC] B) \<Longrightarrow> F \<in> A LeadsTo[CC] B"
by (subst UN_singleton [symmetric], rule LeadsETo_UN, blast)

lemma subset_imp_LeadsETo:
     "A <= B \<Longrightarrow> F \<in> A LeadsTo[CC] B"
apply (simp (no_asm) add: LeadsETo_def)
apply (blast intro: subset_imp_leadsETo)
done

lemmas empty_LeadsETo = empty_subsetI [THEN subset_imp_LeadsETo]

lemma LeadsETo_weaken_R:
     "[| F \<in> A LeadsTo[CC] A';  A' <= B' |] ==> F \<in> A LeadsTo[CC] B'"
apply (simp add: LeadsETo_def)
apply (blast intro: leadsETo_weaken_R)
done

lemma LeadsETo_weaken_L:
     "[| F \<in> A LeadsTo[CC] A';  B <= A |] ==> F \<in> B LeadsTo[CC] A'"
apply (simp add: LeadsETo_def)
apply (blast intro: leadsETo_weaken_L)
done

lemma LeadsETo_weaken:
     "[| F \<in> A LeadsTo[CC'] A';
         B <= A;  A' <= B';  CC' <= CC |]
      ==> F \<in> B LeadsTo[CC] B'"
apply (simp (no_asm_use) add: LeadsETo_def)
apply (blast intro: leadsETo_weaken)
done

lemma LeadsETo_subset_LeadsTo: "(A LeadsTo[CC] B) <= (A LeadsTo B)"
apply (unfold LeadsETo_def LeadsTo_def)
apply (blast intro: leadsETo_subset_leadsTo [THEN subsetD])
done

(*Postcondition can be strengthened to (reachable F Int B) *)
lemma reachable_ensures:
     "F \<in> A ensures B \<Longrightarrow> F \<in> (reachable F Int A) ensures B"
apply (rule stable_ensures_Int [THEN ensures_weaken_R], auto)
done

lemma lel_lemma:
     "F \<in> A leadsTo B \<Longrightarrow> F \<in> (reachable F Int A) leadsTo[Pow(reachable F)] B"
apply (erule leadsTo_induct)
  apply (blast intro: reachable_ensures)
 apply (blast dest: e_psp_stable2 intro: leadsETo_Trans leadsETo_weaken_L)
apply (subst Int_Union)
apply (blast intro: leadsETo_UN)
done

lemma LeadsETo_UNIV_eq_LeadsTo: "(A LeadsTo[UNIV] B) = (A LeadsTo B)"
apply safe
apply (erule LeadsETo_subset_LeadsTo [THEN subsetD])
(*right-to-left case*)
apply (unfold LeadsETo_def LeadsTo_def)
apply (blast intro: lel_lemma [THEN leadsETo_weaken])
done

(**** EXTEND/PROJECT PROPERTIES ****)

context Extend
begin

lemma givenBy_o_eq_extend_set:
     "givenBy (v o f) = extend_set h ` (givenBy v)"
apply (simp add: givenBy_eq_Collect)
apply (rule equalityI, best)
apply blast
done

lemma givenBy_eq_extend_set: "givenBy f = range (extend_set h)"
by (simp add: givenBy_eq_Collect, best)

lemma extend_set_givenBy_I:
     "D \<in> givenBy v ==> extend_set h D \<in> givenBy (v o f)"
apply (simp (no_asm_use) add: givenBy_eq_all, blast)
done

lemma leadsETo_imp_extend_leadsETo:
     "F \<in> A leadsTo[CC] B
      ==> extend h F \<in> (extend_set h A) leadsTo[extend_set h ` CC]
                       (extend_set h B)"
apply (erule leadsETo_induct)
  apply (force intro: subset_imp_ensures
               simp add: extend_ensures extend_set_Diff_distrib [symmetric])
 apply (blast intro: leadsETo_Trans)
apply (simp add: leadsETo_UN extend_set_Union)
done

(*This version's stronger in the "ensures" precondition
  BUT there's no ensures_weaken_L*)
lemma Join_project_ensures_strong:
     "[| project h C G \<notin> transient (project_set h C Int (A-B)) |
           project_set h C Int (A - B) = {};
         extend h F\<squnion>G \<in> stable C;
         F\<squnion>project h C G \<in> (project_set h C Int A) ensures B |]
      ==> extend h F\<squnion>G \<in> (C Int extend_set h A) ensures (extend_set h B)"
apply (subst Int_extend_set_lemma [symmetric])
apply (rule Join_project_ensures)
apply (auto simp add: Int_Diff)
done

(*NOT WORKING.  MODIFY AS IN Project.thy
lemma pld_lemma:
     "[| extend h F\<squnion>G : stable C;
         F\<squnion>project h C G : (project_set h C Int A) leadsTo[(%D. project_set h C Int D)`givenBy v] B;
         G : preserves (v o f) |]
      ==> extend h F\<squnion>G :
            (C Int extend_set h (project_set h C Int A))
            leadsTo[(%D. C Int extend_set h D)`givenBy v]  (extend_set h B)"
apply (erule leadsETo_induct)
  prefer 3
  apply (simp del: UN_simps add: Int_UN_distrib leadsETo_UN extend_set_Union)
 prefer 2
 apply (blast intro: e_psp_stable2 [THEN leadsETo_weaken_L] leadsETo_Trans)
txt{*Base case is hard*}
apply auto
apply (force intro: leadsETo_Basis subset_imp_ensures)
apply (rule leadsETo_Basis)
 prefer 2
 apply (simp add: Int_Diff Int_extend_set_lemma extend_set_Diff_distrib [symmetric])
apply (rule Join_project_ensures_strong)
apply (auto intro: project_stable_project_set simp add: Int_left_absorb)
apply (simp (no_asm_simp) add: stable_ensures_Int [THEN ensures_weaken_R] Int_lower2 project_stable_project_set extend_stable_project_set)
done

lemma project_leadsETo_D_lemma:
     "[| extend h F\<squnion>G : stable C;
         F\<squnion>project h C G :
             (project_set h C Int A)
             leadsTo[(%D. project_set h C Int D)`givenBy v] B;
         G : preserves (v o f) |]
      ==> extend h F\<squnion>G : (C Int extend_set h A)
            leadsTo[(%D. C Int extend_set h D)`givenBy v] (extend_set h B)"
apply (rule pld_lemma [THEN leadsETo_weaken])
apply (auto simp add: split_extended_all)
done

lemma project_leadsETo_D:
     "[| F\<squnion>project h UNIV G : A leadsTo[givenBy v] B;
         G : preserves (v o f) |]
      ==> extend h F\<squnion>G : (extend_set h A)
            leadsTo[givenBy (v o f)] (extend_set h B)"
apply (cut_tac project_leadsETo_D_lemma [of _ _ UNIV], auto)
apply (erule leadsETo_givenBy)
apply (rule givenBy_o_eq_extend_set [THEN equalityD2])
done

lemma project_LeadsETo_D:
     "[| F\<squnion>project h (reachable (extend h F\<squnion>G)) G
             : A LeadsTo[givenBy v] B;
         G : preserves (v o f) |]
      ==> extend h F\<squnion>G :
            (extend_set h A) LeadsTo[givenBy (v o f)] (extend_set h B)"
apply (cut_tac subset_refl [THEN stable_reachable, THEN project_leadsETo_D_lemma])
apply (auto simp add: LeadsETo_def)
 apply (erule leadsETo_mono [THEN [2] rev_subsetD])
 apply (blast intro: extend_set_givenBy_I)
apply (simp add: project_set_reachable_extend_eq [symmetric])
done

lemma extending_leadsETo:
     "(ALL G. extend h F ok G --> G : preserves (v o f))
      ==> extending (%G. UNIV) h F
                (extend_set h A leadsTo[givenBy (v o f)] extend_set h B)
                (A leadsTo[givenBy v] B)"
apply (unfold extending_def)
apply (auto simp add: project_leadsETo_D)
done

lemma extending_LeadsETo:
     "(ALL G. extend h F ok G --> G : preserves (v o f))
      ==> extending (%G. reachable (extend h F\<squnion>G)) h F
                (extend_set h A LeadsTo[givenBy (v o f)] extend_set h B)
                (A LeadsTo[givenBy v]  B)"
apply (unfold extending_def)
apply (blast intro: project_LeadsETo_D)
done
*)

(*** leadsETo in the precondition ***)

(*Lemma for the Trans case*)
lemma pli_lemma:
     "[| extend h F\<squnion>G \<in> stable C;
         F\<squnion>project h C G
           \<in> project_set h C Int project_set h A leadsTo project_set h B |]
      ==> F\<squnion>project h C G
            \<in> project_set h C Int project_set h A leadsTo
              project_set h C Int project_set h B"
apply (rule psp_stable2 [THEN leadsTo_weaken_L])
apply (auto simp add: project_stable_project_set extend_stable_project_set)
done

lemma project_leadsETo_I_lemma:
     "[| extend h F\<squnion>G \<in> stable C;
         extend h F\<squnion>G \<in>
           (C Int A) leadsTo[(%D. C Int D)`givenBy f]  B |]
  ==> F\<squnion>project h C G
    \<in> (project_set h C Int project_set h (C Int A)) leadsTo (project_set h B)"
apply (erule leadsETo_induct)
  prefer 3
  apply (simp only: Int_UN_distrib project_set_Union)
  apply (blast intro: leadsTo_UN)
 prefer 2 apply (blast intro: leadsTo_Trans pli_lemma)
apply (simp add: givenBy_eq_extend_set)
apply (rule leadsTo_Basis)
apply (blast intro: ensures_extend_set_imp_project_ensures)
done

lemma project_leadsETo_I:
     "extend h F\<squnion>G \<in> (extend_set h A) leadsTo[givenBy f] (extend_set h B)
      \<Longrightarrow> F\<squnion>project h UNIV G \<in> A leadsTo B"
apply (rule project_leadsETo_I_lemma [THEN leadsTo_weaken], auto)
done

lemma project_LeadsETo_I:
     "extend h F\<squnion>G \<in> (extend_set h A) LeadsTo[givenBy f] (extend_set h B)
      \<Longrightarrow> F\<squnion>project h (reachable (extend h F\<squnion>G)) G
           \<in> A LeadsTo B"
apply (simp (no_asm_use) add: LeadsTo_def LeadsETo_def)
apply (rule project_leadsETo_I_lemma [THEN leadsTo_weaken])
apply (auto simp add: project_set_reachable_extend_eq [symmetric])
done

lemma projecting_leadsTo:
     "projecting (\<lambda>G. UNIV) h F
                 (extend_set h A leadsTo[givenBy f] extend_set h B)
                 (A leadsTo B)"
apply (unfold projecting_def)
apply (force dest: project_leadsETo_I)
done

lemma projecting_LeadsTo:
     "projecting (\<lambda>G. reachable (extend h F\<squnion>G)) h F
                 (extend_set h A LeadsTo[givenBy f] extend_set h B)
                 (A LeadsTo B)"
apply (unfold projecting_def)
apply (force dest: project_LeadsETo_I)
done

end

end


(*  Title:      FOLP/FOLP.thy
    Author:     Martin D Coen, Cambridge University Computer Laboratory
    Copyright   1992  University of Cambridge
*)

section {* Classical First-Order Logic with Proofs *}

theory FOLP
imports IFOLP
begin

axiomatization cla :: "[p=>p]=>p"
  where classical: "(!!x. x:~P ==> f(x):P) ==> cla(f):P"

(*** Classical introduction rules for | and EX ***)

schematic_lemma disjCI:
  assumes "!!x. x:~Q ==> f(x):P"
  shows "?p : P|Q"
  apply (rule classical)
  apply (assumption | rule assms disjI1 notI)+
  apply (assumption | rule disjI2 notE)+
  done

(*introduction rule involving only EX*)
schematic_lemma ex_classical:
  assumes "!!u. u:~(EX x. P(x)) ==> f(u):P(a)"
  shows "?p : EX x. P(x)"
  apply (rule classical)
  apply (rule exI, rule assms, assumption)
  done

(*version of above, simplifying ~EX to ALL~ *)
schematic_lemma exCI:
  assumes "!!u. u:ALL x. ~P(x) ==> f(u):P(a)"
  shows "?p : EX x. P(x)"
  apply (rule ex_classical)
  apply (rule notI [THEN allI, THEN assms])
  apply (erule notE)
  apply (erule exI)
  done

schematic_lemma excluded_middle: "?p : ~P | P"
  apply (rule disjCI)
  apply assumption
  done

(*** Special elimination rules *)

(*Classical implies (-->) elimination. *)
schematic_lemma impCE:
  assumes major: "p:P-->Q"
    and r1: "!!x. x:~P ==> f(x):R"
    and r2: "!!y. y:Q ==> g(y):R"
  shows "?p : R"
  apply (rule excluded_middle [THEN disjE])
   apply (tactic {* DEPTH_SOLVE (atac 1 ORELSE
       resolve_tac [@{thm r1}, @{thm r2}, @{thm major} RS @{thm mp}] 1) *})
  done

(*Double negation law*)
schematic_lemma notnotD: "p:~~P ==> ?p : P"
  apply (rule classical)
  apply (erule notE)
  apply assumption
  done

(*** Tactics for implication and contradiction ***)

(*Classical <-> elimination.  Proof substitutes P=Q in
    ~P ==> ~Q    and    P ==> Q  *)
schematic_lemma iffCE:
  assumes major: "p:P<->Q"
    and r1: "!!x y.[| x:P; y:Q |] ==> f(x,y):R"
    and r2: "!!x y.[| x:~P; y:~Q |] ==> g(x,y):R"
  shows "?p : R"
  apply (insert major)
  apply (unfold iff_def)
  apply (rule conjE)
  apply (tactic {* DEPTH_SOLVE_1 (etac @{thm impCE} 1 ORELSE
      eresolve_tac [@{thm notE}, @{thm impE}] 1 THEN atac 1 ORELSE atac 1 ORELSE
      resolve_tac [@{thm r1}, @{thm r2}] 1) *})+
  done

(*Should be used as swap since ~P becomes redundant*)
schematic_lemma swap:
  assumes major: "p:~P"
    and r: "!!x. x:~Q ==> f(x):P"
  shows "?p : Q"
  apply (rule classical)
  apply (rule major [THEN notE])
  apply (rule r)
  apply assumption
  done

ML_file "classical.ML"      (* Patched because matching won't instantiate proof *)
ML_file "simp.ML"           (* Patched because matching won't instantiate proof *)

ML {*
structure Cla = Classical
(
  val sizef = size_of_thm
  val mp = @{thm mp}
  val not_elim = @{thm notE}
  val swap = @{thm swap}
  val hyp_subst_tacs = [hyp_subst_tac]
);
open Cla;

(*Propositional rules
  -- iffCE might seem better, but in the examples in ex/cla
     run about 7% slower than with iffE*)
val prop_cs =
  empty_cs addSIs [@{thm refl}, @{thm TrueI}, @{thm conjI}, @{thm disjCI},
      @{thm impI}, @{thm notI}, @{thm iffI}]
    addSEs [@{thm conjE}, @{thm disjE}, @{thm impCE}, @{thm FalseE}, @{thm iffE}];

(*Quantifier rules*)
val FOLP_cs =
  prop_cs addSIs [@{thm allI}] addIs [@{thm exI}, @{thm ex1I}]
    addSEs [@{thm exE}, @{thm ex1E}] addEs [@{thm allE}];

val FOLP_dup_cs =
  prop_cs addSIs [@{thm allI}] addIs [@{thm exCI}, @{thm ex1I}]
    addSEs [@{thm exE}, @{thm ex1E}] addEs [@{thm all_dupE}];
*}

schematic_lemma cla_rews:
  "?p1 : P | ~P"
  "?p2 : ~P | P"
  "?p3 : ~ ~ P <-> P"
  "?p4 : (~P --> P) <-> P"
  apply (tactic {* ALLGOALS (Cla.fast_tac @{context} FOLP_cs) *})
  done

ML_file "simpdata.ML"

end


section \<open> Weakest Liberal Precondition Calculus \<close>

theory utp_wlp
imports utp_hoare
begin

text \<open> The calculus we here define is termed ``weakest precondition'' in the UTP book, however
  it is in reality the liberal version that does not account for termination. \<close>

named_theorems wp

method wp_tac = (simp add: wp usubst unrest)

consts
  uwlp :: "'a \<Rightarrow> 'b \<Rightarrow> 'c" (infix "wlp" 60)

definition wlp_upred :: "('\<alpha>, '\<beta>) urel \<Rightarrow> '\<beta> cond \<Rightarrow> '\<alpha> cond" where
"wlp_upred Q r = \<lfloor>\<not> (Q ;; (\<not> \<lceil>r\<rceil>\<^sub><)) :: ('\<alpha>, '\<beta>) urel\<rfloor>\<^sub><"

utp_const uwlp (0)

adhoc_overloading
  uwlp wlp_upred

declare wlp_upred_def [urel_defs]

lemma wlp_true [wp]: "p wlp true = true"
  by (rel_simp)

lemma wlp_conj [wp]: "(P wlp (b \<and> c)) = ((P wlp b) \<and> (P wlp c))"
  by (rel_auto)

theorem wlp_assigns_r [wp]:
  "\<langle>\<sigma>\<rangle>\<^sub>a wlp r = \<sigma> \<dagger> r"
  by rel_auto

lemma wlp_nd_assign [wp]: "(x := *) wlp b = (\<^bold>\<forall> v \<bullet> b\<lbrakk>\<guillemotleft>v\<guillemotright>/&x\<rbrakk>)"
  by (simp add: nd_assign_def wp, rel_auto)

lemma wlp_rel_aext_unrest [wp]: "\<lbrakk> vwb_lens a; a \<sharp> b \<rbrakk> \<Longrightarrow> a:[P]\<^sup>+ wlp b = ((P wlp false) \<oplus>\<^sub>p a \<or> b)"
  by (rel_simp, metis mwb_lens_def vwb_lens_def weak_lens.put_get)

lemma wlp_rel_aext_usedby [wp]: "\<lbrakk> vwb_lens a; a \<natural> b \<rbrakk> \<Longrightarrow> a:[P]\<^sup>+ wlp b = (P wlp (b \<restriction>\<^sub>e a)) \<oplus>\<^sub>p a"
  by (rel_auto, metis mwb_lens_def vwb_lens_mwb weak_lens.put_get)

theorem wlp_skip_r [wp]:
  "II wlp r = r"
  by rel_auto

theorem wlp_abort [wp]:
  "r \<noteq> true \<Longrightarrow> true wlp r = false"
  by rel_auto

theorem wlp_seq_r [wp]: "(P ;; Q) wlp r = P wlp (Q wlp r)"
  by rel_auto

theorem wlp_choice [wp]: "(P \<sqinter> Q) wlp R = (P wlp R \<and> Q wlp R)"
  by (rel_auto)

theorem wlp_choice' [wp]: "(P \<or> Q) wlp R = (P wlp R \<and> Q wlp R)"
  by (rel_auto)

theorem wlp_cond [wp]: "(P \<triangleleft> b \<triangleright>\<^sub>r Q) wlp r = ((b \<Rightarrow> P wlp r) \<and> ((\<not> b) \<Rightarrow> Q wlp r))"
  by rel_auto

lemma wlp_UINF_ind [wp]: "(\<Sqinter> i \<bullet> P(i)) wlp b = (\<^bold>\<forall> i \<bullet> P(i) wlp b)"
  by (rel_auto)

lemma wlp_test [wp]: "?[b] wlp c = (b \<Rightarrow> c)"
  by (rel_auto)

lemma wlp_gcmd [wp]: "(b \<longrightarrow>\<^sub>r P) wlp c = (b \<Rightarrow> P wlp c)"
  by (simp add: rgcmd_def wp)

lemma wlp_USUP_pre [wp]:
  fixes Q :: "_ \<Rightarrow> 's upred"
  shows "P wlp (\<And> i\<in>A \<bullet> Q(i)) = U(\<forall> i\<in>\<guillemotleft>A\<guillemotright>. P wlp Q i)"
  by (rel_auto; blast)

theorem wlp_hoare_link:
  "\<lbrace>p\<rbrace>Q\<lbrace>r\<rbrace>\<^sub>u \<longleftrightarrow> `p \<Rightarrow> Q wlp r`"
  by rel_auto

text \<open> We can use the above theorem as a means to discharge Hoare triples with the following tactic \<close>

method hoare_wlp_auto uses defs = (simp add: wlp_hoare_link wp unrest usubst defs; rel_auto)

text \<open> If two programs have the same weakest precondition for any postcondition then the programs
  are the same. \<close>

theorem wlp_eq_intro: "\<lbrakk> \<And> r. P wlp r = Q wlp r \<rbrakk> \<Longrightarrow> P = Q"
  by (rel_auto robust, fastforce+)

end


(*  Title:      ZF/UNITY/Comp.thy
    Author:     Sidi O Ehmety, Computer Laboratory
    Copyright   1998  University of Cambridge

From Chandy and Sanders, "Reasoning About Program Composition",
Technical Report 2000-003, University of Florida, 2000.

Revised by Sidi Ehmety on January  2001

Added: a strong form of the order relation over component and localize

Theory ported from HOL.

*)

section{*Composition*}

theory Comp imports Union Increasing begin

definition
  component :: "[i,i]=>o"  (infixl "component" 65)  where
  "F component H == (\<exists>G. F Join G = H)"

definition
  strict_component :: "[i,i]=>o" (infixl "strict'_component" 65)  where
  "F strict_component H == F component H & F\<noteq>H"

definition
  (* A stronger form of the component relation *)
  component_of :: "[i,i]=>o"   (infixl "component'_of" 65)  where
  "F component_of H  == (\<exists>G. F ok G & F Join G = H)"

definition
  strict_component_of :: "[i,i]=>o" (infixl "strict'_component'_of" 65)  where
  "F strict_component_of H  == F component_of H  & F\<noteq>H"

definition
  (* Preserves a state function f, in particular a variable *)
  preserves :: "(i=>i)=>i"  where
  "preserves(f) == {F:program. \<forall>z. F: stable({s:state. f(s) = z})}"

definition
  fun_pair :: "[i=>i, i =>i] =>(i=>i)"  where
  "fun_pair(f, g) == %x. <f(x), g(x)>"

definition
  localize  :: "[i=>i, i] => i"  where
  "localize(f,F) == mk_program(Init(F), Acts(F),
                       AllowedActs(F) \<inter> (\<Union>G\<in>preserves(f). Acts(G)))"

(*** component and strict_component relations ***)

lemma componentI:
     "H component F | H component G ==> H component (F Join G)"
apply (unfold component_def, auto)
apply (rule_tac x = "Ga Join G" in exI)
apply (rule_tac [2] x = "G Join F" in exI)
apply (auto simp add: Join_ac)
done

lemma component_eq_subset:
     "G \<in> program ==> (F component G) \<longleftrightarrow>
   (Init(G) \<subseteq> Init(F) & Acts(F) \<subseteq> Acts(G) & AllowedActs(G) \<subseteq> AllowedActs(F))"
apply (unfold component_def, auto)
apply (rule exI)
apply (rule program_equalityI, auto)
done

lemma component_SKIP [simp]: "F \<in> program ==> SKIP component F"
apply (unfold component_def)
apply (rule_tac x = F in exI)
apply (force intro: Join_SKIP_left)
done

lemma component_refl [simp]: "F \<in> program ==> F component F"
apply (unfold component_def)
apply (rule_tac x = F in exI)
apply (force intro: Join_SKIP_right)
done

lemma SKIP_minimal: "F component SKIP ==> programify(F) = SKIP"
apply (rule program_equalityI)
apply (simp_all add: component_eq_subset, blast)
done

lemma component_Join1: "F component (F Join G)"
by (unfold component_def, blast)

lemma component_Join2: "G component (F Join G)"
apply (unfold component_def)
apply (simp (no_asm) add: Join_commute)
apply blast
done

lemma Join_absorb1: "F component G ==> F Join G = G"
by (auto simp add: component_def Join_left_absorb)

lemma Join_absorb2: "G component F ==> F Join G = F"
by (auto simp add: Join_ac component_def)

lemma JN_component_iff:
     "H \<in> program==>(JOIN(I,F) component H) \<longleftrightarrow> (\<forall>i \<in> I. F(i) component H)"
apply (case_tac "I=0", force)
apply (simp (no_asm_simp) add: component_eq_subset)
apply auto
apply blast
apply (rename_tac "y")
apply (drule_tac c = y and A = "AllowedActs (H)" in subsetD)
apply (blast elim!: not_emptyE)+
done

lemma component_JN: "i \<in> I ==> F(i) component (\<Squnion>i \<in> I. (F(i)))"
apply (unfold component_def)
apply (blast intro: JN_absorb)
done

lemma component_trans: "[| F component G; G component H |] ==> F component H"
apply (unfold component_def)
apply (blast intro: Join_assoc [symmetric])
done

lemma component_antisym:
     "[| F \<in> program; G \<in> program |] ==>(F component G & G  component F) \<longrightarrow> F = G"
apply (simp (no_asm_simp) add: component_eq_subset)
apply clarify
apply (rule program_equalityI, auto)
done

lemma Join_component_iff:
     "H \<in> program ==>
      ((F Join G) component H) \<longleftrightarrow> (F component H & G component H)"
apply (simp (no_asm_simp) add: component_eq_subset)
apply blast
done

lemma component_constrains:
     "[| F component G; G \<in> A co B; F \<in> program |] ==> F \<in> A co B"
apply (frule constrainsD2)
apply (auto simp add: constrains_def component_eq_subset)
done

(*** preserves ***)

lemma preserves_is_safety_prop [simp]: "safety_prop(preserves(f))"
apply (unfold preserves_def safety_prop_def)
apply (auto dest: ActsD simp add: stable_def constrains_def)
apply (drule_tac c = act in subsetD, auto)
done

lemma preservesI [rule_format]:
     "\<forall>z. F \<in> stable({s \<in> state. f(s) = z})  ==> F \<in> preserves(f)"
apply (auto simp add: preserves_def)
apply (blast dest: stableD2)
done

lemma preserves_imp_eq:
     "[| F \<in> preserves(f);  act \<in> Acts(F);  <s,t> \<in> act |] ==> f(s) = f(t)"
apply (unfold preserves_def stable_def constrains_def)
apply (subgoal_tac "s \<in> state & t \<in> state")
 prefer 2 apply (blast dest!: Acts_type [THEN subsetD], force)
done

lemma Join_preserves [iff]:
"(F Join G \<in> preserves(v)) \<longleftrightarrow>
      (programify(F) \<in> preserves(v) & programify(G) \<in> preserves(v))"
by (auto simp add: preserves_def INT_iff)

lemma JN_preserves [iff]:
     "(JOIN(I,F): preserves(v)) \<longleftrightarrow> (\<forall>i \<in> I. programify(F(i)):preserves(v))"
by (auto simp add: JN_stable preserves_def INT_iff)

lemma SKIP_preserves [iff]: "SKIP \<in> preserves(v)"
by (auto simp add: preserves_def INT_iff)

lemma fun_pair_apply [simp]: "fun_pair(f,g,x) = <f(x), g(x)>"
apply (unfold fun_pair_def)
apply (simp (no_asm))
done

lemma preserves_fun_pair:
     "preserves(fun_pair(v,w)) = preserves(v) \<inter> preserves(w)"
apply (rule equalityI)
apply (auto simp add: preserves_def stable_def constrains_def, blast+)
done

lemma preserves_fun_pair_iff [iff]:
     "F \<in> preserves(fun_pair(v, w))  \<longleftrightarrow> F \<in> preserves(v) \<inter> preserves(w)"
by (simp add: preserves_fun_pair)

lemma fun_pair_comp_distrib:
     "(fun_pair(f, g) comp h)(x) = fun_pair(f comp h, g comp h, x)"
by (simp add: fun_pair_def metacomp_def)

lemma comp_apply [simp]: "(f comp g)(x) = f(g(x))"
by (simp add: metacomp_def)

lemma preserves_type: "preserves(v)<=program"
by (unfold preserves_def, auto)

lemma preserves_into_program [TC]: "F \<in> preserves(f) ==> F \<in> program"
by (blast intro: preserves_type [THEN subsetD])

lemma subset_preserves_comp: "preserves(f) \<subseteq> preserves(g comp f)"
apply (auto simp add: preserves_def stable_def constrains_def)
apply (drule_tac x = "f (xb)" in spec)
apply (drule_tac x = act in bspec, auto)
done

lemma imp_preserves_comp: "F \<in> preserves(f) ==> F \<in> preserves(g comp f)"
by (blast intro: subset_preserves_comp [THEN subsetD])

lemma preserves_subset_stable: "preserves(f) \<subseteq> stable({s \<in> state. P(f(s))})"
apply (auto simp add: preserves_def stable_def constrains_def)
apply (rename_tac s' s)
apply (subgoal_tac "f (s) = f (s') ")
apply (force+)
done

lemma preserves_imp_stable:
     "F \<in> preserves(f) ==> F \<in> stable({s \<in> state. P(f(s))})"
by (blast intro: preserves_subset_stable [THEN subsetD])

lemma preserves_imp_increasing:
 "[| F \<in> preserves(f); \<forall>x \<in> state. f(x):A |] ==> F \<in> Increasing.increasing(A, r, f)"
apply (unfold Increasing.increasing_def)
apply (auto intro: preserves_into_program)
apply (rule_tac P = "%x. <k, x>:r" in preserves_imp_stable, auto)
done

lemma preserves_id_subset_stable:
 "st_set(A) ==> preserves(%x. x) \<subseteq> stable(A)"
apply (unfold preserves_def stable_def constrains_def, auto)
apply (drule_tac x = xb in spec)
apply (drule_tac x = act in bspec)
apply (auto dest: ActsD)
done

lemma preserves_id_imp_stable:
     "[| F \<in> preserves(%x. x); st_set(A) |] ==> F \<in> stable(A)"
by (blast intro: preserves_id_subset_stable [THEN subsetD])

(** Added by Sidi **)
(** component_of **)

(*  component_of is stronger than component *)
lemma component_of_imp_component:
"F component_of H ==> F component H"
apply (unfold component_def component_of_def, blast)
done

(* component_of satisfies many of component's properties *)
lemma component_of_refl [simp]: "F \<in> program ==> F component_of F"
apply (unfold component_of_def)
apply (rule_tac x = SKIP in exI, auto)
done

lemma component_of_SKIP [simp]: "F \<in> program ==>SKIP component_of F"
apply (unfold component_of_def, auto)
apply (rule_tac x = F in exI, auto)
done

lemma component_of_trans:
     "[| F component_of G; G component_of H |] ==> F component_of H"
apply (unfold component_of_def)
apply (blast intro: Join_assoc [symmetric])
done

(** localize **)
lemma localize_Init_eq [simp]: "Init(localize(v,F)) = Init(F)"
by (unfold localize_def, simp)

lemma localize_Acts_eq [simp]: "Acts(localize(v,F)) = Acts(F)"
by (unfold localize_def, simp)

lemma localize_AllowedActs_eq [simp]:
 "AllowedActs(localize(v,F)) = AllowedActs(F) \<inter> (\<Union>G \<in> preserves(v). Acts(G))"
apply (unfold localize_def)
apply (rule equalityI)
apply (auto dest: Acts_type [THEN subsetD])
done

(** Theorems used in ClientImpl **)

lemma stable_localTo_stable2:
 "[| F \<in> stable({s \<in> state. P(f(s), g(s))});  G \<in> preserves(f);  G \<in> preserves(g) |]
      ==> F Join G \<in> stable({s \<in> state. P(f(s), g(s))})"
apply (auto dest: ActsD preserves_into_program simp add: stable_def constrains_def)
apply (case_tac "act \<in> Acts (F) ")
apply auto
apply (drule preserves_imp_eq)
apply (drule_tac [3] preserves_imp_eq, auto)
done

lemma Increasing_preserves_Stable:
     "[| F \<in> stable({s \<in> state. <f(s), g(s)>:r});  G \<in> preserves(f);
         F Join G \<in> Increasing(A, r, g);
         \<forall>x \<in> state. f(x):A & g(x):A |]
      ==> F Join G \<in> Stable({s \<in> state. <f(s), g(s)>:r})"
apply (auto simp add: stable_def Stable_def Increasing_def Constrains_def all_conj_distrib)
apply (simp_all add: constrains_type [THEN subsetD] preserves_type [THEN subsetD])
apply (blast intro: constrains_weaken)
(*The G case remains*)
apply (auto dest: ActsD simp add: preserves_def stable_def constrains_def ball_conj_distrib all_conj_distrib)
(*We have a G-action, so delete assumptions about F-actions*)
apply (erule_tac V = "\<forall>act \<in> Acts (F) . ?P (act)" in thin_rl)
apply (erule_tac V = "\<forall>k\<in>A. \<forall>act \<in> Acts (F) . ?P (k,act)" in thin_rl)
apply (subgoal_tac "f (x) = f (xa) ")
apply (auto dest!: bspec)
done

(** Lemma used in AllocImpl **)

lemma Constrains_UN_left:
     "[| \<forall>x \<in> I. F \<in> A(x) Co B; F \<in> program |] ==> F:(\<Union>x \<in> I. A(x)) Co B"
by (unfold Constrains_def constrains_def, auto)

lemma stable_Join_Stable:
 "[| F \<in> stable({s \<in> state. P(f(s), g(s))});
     \<forall>k \<in> A. F Join G \<in> Stable({s \<in> state. P(k, g(s))});
     G \<in> preserves(f); \<forall>s \<in> state. f(s):A|]
  ==> F Join G \<in> Stable({s \<in> state. P(f(s), g(s))})"
apply (unfold stable_def Stable_def preserves_def)
apply (rule_tac A = "(\<Union>k \<in> A. {s \<in> state. f(s)=k} \<inter> {s \<in> state. P (f (s), g (s))})" in Constrains_weaken_L)
prefer 2 apply blast
apply (rule Constrains_UN_left, auto)
apply (rule_tac A = "{s \<in> state. f(s)=k} \<inter> {s \<in> state. P (f (s), g (s))} \<inter> {s \<in> state. P (k, g (s))}" and A' = "({s \<in> state. f(s)=k} \<union> {s \<in> state. P (f (s), g (s))}) \<inter> {s \<in> state. P (k, g (s))}" in Constrains_weaken)
 prefer 2 apply blast
 prefer 2 apply blast
apply (rule Constrains_Int)
apply (rule constrains_imp_Constrains)
apply (auto simp add: constrains_type [THEN subsetD])
apply (blast intro: constrains_weaken)
apply (drule_tac x = k in spec)
apply (blast intro: constrains_weaken)
done

end