\<^marker>\<open>creator Florian Keßler\<close>

section "SAS++ to SAS+"

theory SAS_Plus_Plus_To_SAS_Plus
  imports SAS_Plus_Plus
begin

text \<open> We give a reduction from SAS++ to SAS+. The challenge here is to replace the semantics of
       SAS++ that permit initial states with some variables unspecified to be guessed by the solver,
       by SAS+, where initial states need to specify all variables. We do this by constructing
       SAS+ problems where every solution plan is divided into two phases, first one where
       unspecified variables in the initial state are guessed, and the one where the SAS++ problem
       is simulated. \<close>

datatype 'v variable =  Var 'v | Stage
datatype 'd domain_element = DE 'd | Init | NonInit

type_synonym ('v, 'd) state = "('v, 'd) State_Variable_Representation.state"
type_synonym ('v, 'd) operator = "('v variable, 'd domain_element) sas_plus_operator"
type_synonym ('v, 'd) problem = "('v variable, 'd domain_element) sas_plus_problem"

definition SAS_Plus_Plus_State_To_SAS_Plus::
  "('d domain_element \<times> ('v, 'd) state) \<Rightarrow> ('v variable, 'd domain_element) state" where
"SAS_Plus_Plus_State_To_SAS_Plus is = ((\<lambda>x. Some (DE x)) \<circ>\<^sub>m (snd is)
  \<circ>\<^sub>m (\<lambda>x. (case x of Var x \<Rightarrow> Some x | Stage \<Rightarrow> None)))(Stage \<mapsto> (fst is))"

lemma SAS_Plus_Plus_State_To_SAS_Plus_eq_iff_snd_eq[simp]:
  "SAS_Plus_Plus_State_To_SAS_Plus (i, s) = SAS_Plus_Plus_State_To_SAS_Plus (i, s')
  \<longleftrightarrow> s = s'"
  apply (auto simp: SAS_Plus_Plus_State_To_SAS_Plus_def map_comp_def fun_eq_iff
      split: option.splits variable.splits)
  by (metis option.exhaust_sel)

lemma SAS_Plus_Plus_State_To_SAS_Plus_Stage[simp]:
  "SAS_Plus_Plus_State_To_SAS_Plus (i, s) Stage = Some i"
  by (auto simp: SAS_Plus_Plus_State_To_SAS_Plus_def)

lemma SAS_Plus_Plus_State_To_SAS_Plus_update_stage[simp]:
  "SAS_Plus_Plus_State_To_SAS_Plus (a, s)(Stage \<mapsto> b) = SAS_Plus_Plus_State_To_SAS_Plus (b, s)"
  by (auto simp: SAS_Plus_Plus_State_To_SAS_Plus_def map_comp_def fun_eq_iff)

lemma SAS_Plus_Plus_State_To_SAS_Plus_update_Var[simp]:
  "SAS_Plus_Plus_State_To_SAS_Plus (i, s)(Var x \<mapsto> DE y)
    = SAS_Plus_Plus_State_To_SAS_Plus(i, s(x \<mapsto> y))"
  by (auto simp: SAS_Plus_Plus_State_To_SAS_Plus_def map_comp_def fun_eq_iff
      split: option.splits variable.splits)

lemma SAS_Plus_Plus_State_To_SAS_Plus_map_le[simp]:
  "SAS_Plus_Plus_State_To_SAS_Plus (a, s) \<subseteq>\<^sub>m m
    \<Longrightarrow> SAS_Plus_Plus_State_To_SAS_Plus (b, s) \<subseteq>\<^sub>m m(Stage \<mapsto> b)"
  by(auto simp: SAS_Plus_Plus_State_To_SAS_Plus_def map_le_def map_comp_def
      split: option.splits variable.splits)

lemma Stage_map_le_SAS_Plus_Plus_State_To_SAS_Plus[simp]:
  "[Stage \<mapsto> i] \<subseteq>\<^sub>m SAS_Plus_Plus_State_To_SAS_Plus (i, s)"
  by(auto simp: SAS_Plus_Plus_State_To_SAS_Plus_def map_le_def)

lemma Var_not_in_map_Var_iff[simp]: "Var x \<notin> Var ` S \<longleftrightarrow> x \<notin> S" by auto

lemma dom_of_SAS_Plus_Plus_State_To_SAS_Plus:
  "dom (SAS_Plus_Plus_State_To_SAS_Plus (i, s)) = { Stage } \<union> (Var ` dom s)"
  by(auto simp: SAS_Plus_Plus_State_To_SAS_Plus_def map_comp_def
      split: option.splits variable.splits)

lemma SAS_Plus_Plus_State_To_SAS_Plus_map_le_SAS_Plus_Plus_State_To_SAS_Plus[simp]:
  "SAS_Plus_Plus_State_To_SAS_Plus (a, s1) \<subseteq>\<^sub>m SAS_Plus_Plus_State_To_SAS_Plus (b, s2)
    \<longleftrightarrow> (a = b \<and> s1 \<subseteq>\<^sub>m s2)"
  apply(auto simp: map_le_def dom_of_SAS_Plus_Plus_State_To_SAS_Plus)
   apply(auto simp: SAS_Plus_Plus_State_To_SAS_Plus_def map_comp_def split: option.splits)
  by force+

definition SAS_Plus_Plus_Operator_To_SAS_Plus_Operator::
  "('v, 'd) sas_plus_operator \<Rightarrow> ('v, 'd) operator" where
"SAS_Plus_Plus_Operator_To_SAS_Plus_Operator op =
  \<lparr> precondition_of = (Stage, NonInit) # (map (\<lambda> x. (Var (fst x), DE (snd x))) (precondition_of op)),
    effect_of = (map (\<lambda> x. (Var (fst x), DE (snd x))) (effect_of op))\<rparr>"

lemma dom_of_map_of_map[simp]:
  "dom (map_of (map (\<lambda>x. (Var (fst x), DE (snd x))) l)) = (\<lambda>x. Var (fst x)) ` set l"
  apply(induction l)
  apply(auto)
  by (metis (mono_tags, lifting) domD fst_conv imageI)

lemma map_of_map_eq_None_iff[simp]: "(map_of (map (\<lambda>x. (Var (fst x), DE (snd x))) l) (Var y) = None)
  \<longleftrightarrow> (y \<notin> fst ` set l)"
  apply(induction l)
  by(auto)

lemma map_of_map_eq_Some_iff[simp]: "(map_of (map (\<lambda>x. (Var (fst x), DE (snd x))) l) (Var x) = Some (DE y))
  \<longleftrightarrow> (map_of l x = Some y)"
  apply(induction l)
  by(auto)

lemma SAS_Plus_Plus_Operator_To_SAS_Plus_Operator_applicable[simp]:
  "is_operator_applicable_in (SAS_Plus_Plus_State_To_SAS_Plus (i, s))
    (SAS_Plus_Plus_Operator_To_SAS_Plus_Operator op)
  \<longleftrightarrow> (i = NonInit \<and> is_operator_applicable_in s op)"
  apply(auto simp: SAS_Plus_Plus_State_To_SAS_Plus_def map_comp_def
      SAS_Plus_Plus_Operator_To_SAS_Plus_Operator_def)
    apply(simp_all add: map_le_def)
   apply(auto split: option.splits variable.splits)
    apply(frule map_of_SomeD)
    apply auto
  by (metis domI weak_map_of_SomeI)+

lemma SAS_Plus_Plus_Operator_To_SAS_Plus_Operator_execute[simp]:
  "SAS_Plus_Plus_State_To_SAS_Plus (i, s) ++ map_of (effect_of (SAS_Plus_Plus_Operator_To_SAS_Plus_Operator op))
  = SAS_Plus_Plus_State_To_SAS_Plus(i, s \<then>\<^sub>+ op)"
  using map_of_SomeD
  apply(auto simp: SAS_Plus_Plus_State_To_SAS_Plus_def map_comp_def fun_eq_iff map_add_def
      SAS_Plus_Plus_Operator_To_SAS_Plus_Operator_def split: option.splits variable.splits)
            apply force+
          prefer 9 using map_of_SomeD apply fastforce
  using map_of_map_eq_None_iff map_of_map_eq_Some_iff
  by (metis (mono_tags, lifting) map_of_eq_None_iff map_of_map_eq_Some_iff option.simps
      option.distinct domI  domIff option.simps)+

lemma execute_SAS_Plus_Plus_ops_in_SAS_Plus[simp]:
  "execute_serial_plan_sas_plus (SAS_Plus_Plus_State_To_SAS_Plus (NonInit, s))
    (map SAS_Plus_Plus_Operator_To_SAS_Plus_Operator ops)
    = SAS_Plus_Plus_State_To_SAS_Plus (NonInit, execute_serial_plan_sas_plus s ops)"
  apply(induction ops arbitrary: s)
   apply(simp add: SAS_Plus_Plus_State_To_SAS_Plus_def
      SAS_Plus_Plus_Operator_To_SAS_Plus_Operator_def)
  by(auto simp: SAS_Plus_Plus_Operator_To_SAS_Plus_Operator_applicable[simplified])

fun thef:: "'a list option \<Rightarrow> 'a list" where
"thef None = []"|
"thef (Some x) = x"

definition initialization_operators:: "('v, 'd) sas_plus_problem \<Rightarrow> ('v, 'd) operator list" where
"initialization_operators P =
  concat (map (\<lambda> v. (if v \<in> dom ((P)\<^sub>I\<^sub>+) then []
    else map (\<lambda> y. \<lparr> precondition_of = [(Stage, Init)],  effect_of = [(Var v, DE y)]\<rparr>)
      (thef (range_of P v)))) ((P)\<^sub>\<V>\<^sub>+))"

lemma in_initialization_operators_iff:
  "\<lparr>precondition_of = [(Stage, Init)], effect_of = [(Var x, DE y)]\<rparr>
    \<in> set (initialization_operators P)
  \<longleftrightarrow> (x \<in> set ((P)\<^sub>\<V>\<^sub>+) \<and> ((P)\<^sub>I\<^sub>+) x = None \<and> y \<in> set (thef (range_of P x)))"
  by(auto simp: initialization_operators_def)

lemma Stage_after_initialization_operator[simp]:
  "op \<in> set (initialization_operators P) \<Longrightarrow> (s ++ map_of (effect_of op)) Stage = s Stage"
  by(auto simp: initialization_operators_def)

definition initial_state::
  "('v, 'd) sas_plus_problem \<Rightarrow> ('v variable, 'd domain_element) state" where
"initial_state P = SAS_Plus_Plus_State_To_SAS_Plus (Init, (\<lambda> v.
  (if v \<in> set ((P)\<^sub>\<V>\<^sub>+) then Some (case ((P)\<^sub>I\<^sub>+) v of
        Some val \<Rightarrow> val |
        None \<Rightarrow> (the (range_of P v)) ! 0)
   else None)))"

definition SAS_Plus_Plus_To_SAS_Plus:: "('v, 'd) sas_plus_problem \<Rightarrow> ('v, 'd) problem" where
"SAS_Plus_Plus_To_SAS_Plus P = \<lparr> variables_of = Stage # (map Var ((P)\<^sub>\<V>\<^sub>+)),
      operators_of = \<lparr> precondition_of = [(Stage, Init)], effect_of = [(Stage, NonInit)]\<rparr>
        # (initialization_operators P)
        @ (map SAS_Plus_Plus_Operator_To_SAS_Plus_Operator ((P)\<^sub>\<O>\<^sub>+)),
      initial_of = initial_state P ,
      goal_of = SAS_Plus_Plus_State_To_SAS_Plus (NonInit, ((P)\<^sub>G\<^sub>+)),
      range_of = ((\<lambda>x. Some (map DE x)) \<circ>\<^sub>m (range_of P)
        \<circ>\<^sub>m (\<lambda>x. (case x of Var x \<Rightarrow> Some x | Stage \<Rightarrow> None)))(Stage \<mapsto> [Init, NonInit])\<rparr>"

lemma SAS_Plus_Plus_To_SAS_Plus_valid:
  assumes "is_valid_problem_sas_plus_plus P"
  shows "is_valid_problem_sas_plus (SAS_Plus_Plus_To_SAS_Plus P)"
  using assms apply(auto simp: is_valid_problem_sas_plus_plus_def is_valid_problem_sas_plus_def
      SAS_Plus_Plus_To_SAS_Plus_def list_all_def is_valid_operator_sas_plus_def Let_def
      initialization_operators_def SAS_Plus_Plus_Operator_To_SAS_Plus_Operator_def ListMem_iff)
               apply auto
              apply fastforce
             apply fastforce
            apply fastforce
           apply fastforce
          apply blast
         apply blast
         apply(auto simp: initial_state_def map_comp_def SAS_Plus_Plus_State_To_SAS_Plus_def
        split: variable.splits if_splits option.splits)
  by (meson assms is_valid_problem_sas_plus_plus_then(1) range_of_not_empty)+

lemma stage_of_initial_state[simp]: "((SAS_Plus_Plus_To_SAS_Plus P)\<^sub>I\<^sub>+) Stage = Some Init"
  by(auto simp: SAS_Plus_Plus_To_SAS_Plus_def initial_state_def)

definition initialization_sequence:: "('v \<times> 'd) list \<Rightarrow> ('v, 'd) operator list" where
  "initialization_sequence vs = map (\<lambda>v. \<lparr> precondition_of = [(Stage, Init)],
      effect_of = [(Var (fst v), DE (snd v))]\<rparr>) vs"

lemma result_of_initialization_sequence[simp]:
  assumes "I Stage = Some Init"
    "distinct (map fst vs)"
  shows "execute_serial_plan_sas_plus I (initialization_sequence vs) =
  I ++ SAS_Plus_Plus_State_To_SAS_Plus (Init, map_of vs)"
using assms proof (induction vs arbitrary: I)
  case Nil
  then show ?case using Nil
    by (auto simp: initialization_sequence_def SAS_Plus_Plus_State_To_SAS_Plus_def map_add_def)
next
  case (Cons v vs)
  hence "execute_serial_plan_sas_plus I (initialization_sequence (v # vs))
    = execute_serial_plan_sas_plus (I(Var (fst v) \<mapsto> DE (snd v))) (initialization_sequence vs)"
    by (auto simp: initialization_sequence_def map_le_def)
  also have "... = I ++ SAS_Plus_Plus_State_To_SAS_Plus (Init, map_of (v # vs))" using Cons
    by(auto simp: SAS_Plus_Plus_State_To_SAS_Plus_def map_add_def fun_eq_iff map_comp_def
        rev_image_eqI split: option.splits variable.splits)
  ultimately show ?case by metis
qed

lemma initialization_sequence_chain_applicable_condition[simp]:
  assumes "s Stage = Some Init"
  shows "chain_applicable s (initialization_sequence vs)"
  using assms apply(induction vs arbitrary: s)
  by(auto simp:  initialization_sequence_def map_le_def)

lemma map_of_conact_map_cases_eq_Some[simp]:
  "map_of (concat (map (\<lambda>v. case m v of None \<Rightarrow> [(v, f v)] | Some x \<Rightarrow> []) l)) x = Some y
  \<longleftrightarrow> (x \<in> set l \<and> f x = y \<and> m x = None)"
proof
  assume "map_of (concat (map (\<lambda>v. case m v of None \<Rightarrow> [(v, f v)] | Some x \<Rightarrow> []) l)) x = Some y"
  then show "x \<in> set l \<and> f x = y \<and> m x = None"
    apply -
    apply(drule map_of_SomeD)
    by(auto)
next
  assume "x \<in> set l \<and> f x = y \<and> m x = None"
  hence "(x, y) \<in> set (concat (map (\<lambda>v. case m v of None \<Rightarrow> [(v, f v)] | Some x \<Rightarrow> []) l))"
    by auto
  moreover have "\<forall>y'. (x, y') \<in> set (concat (map (\<lambda>v. case m v of None \<Rightarrow> [(v, f v)] | Some x \<Rightarrow> []) l))
    \<longrightarrow> y' = f x" by auto
  ultimately show "map_of (concat (map (\<lambda>v. case m v of None \<Rightarrow> [(v, f v)] | Some x \<Rightarrow> []) l)) x = Some y"
    by (metis (no_types, lifting) map_of_SomeD weak_map_of_SomeI)
qed

lemma map_of_conact_map_cases_eq_None[simp]:
  "map_of (concat (map (\<lambda>v. case m v of None \<Rightarrow> [(v, f v)] | Some x \<Rightarrow> []) l)) x = None
  \<longleftrightarrow> (x \<notin> set l \<or> m x \<noteq> None)"
proof -
  have "(map_of (concat (map (\<lambda>v. case m v of None \<Rightarrow> [(v, f v)] | Some x \<Rightarrow> []) l)) x = None)
    = (\<not>(\<exists>y. map_of (concat (map (\<lambda>v. case m v of None \<Rightarrow> [(v, f v)] | Some x \<Rightarrow> []) l)) x = Some y))"
    by fastforce
  also have "... = (\<not>(\<exists>y. x \<in> set l \<and> f x = y \<and> m x = None))" by auto
  ultimately show ?thesis by simp
qed

lemma distinct_map_fst_concat[simp]:
  "distinct (map fst (concat (map (\<lambda>v. case m v of None \<Rightarrow> [(v, f v)] | Some x \<Rightarrow> []) (remdups l))))"
  apply(induction l)
  by(auto split: option.splits)

lemma length_concat_map[simp]:
  "length (concat (map (\<lambda>v. case m v of None \<Rightarrow> [f v] | Some _ \<Rightarrow> []) (remdups l))) \<le> length l"
  apply(induction l)
  by(auto split: option.splits)

subsection \<open>Correctness\<close>

lemma SAS_Plus_Plus_To_SAS_Plus:
  assumes "is_valid_problem_sas_plus_plus P"
    "is_serial_solution_for_problem_sas_plus_plus P plan"
  shows "\<exists>prefix. length prefix \<le> length ((P)\<^sub>\<V>\<^sub>+) + 1
    \<and> is_serial_solution_for_problem (SAS_Plus_Plus_To_SAS_Plus P)
        (prefix @ (map SAS_Plus_Plus_Operator_To_SAS_Plus_Operator plan))"
proof -
  obtain I where I_def: "((P)\<^sub>I\<^sub>+) \<subseteq>\<^sub>m I \<and> dom I = set ((P)\<^sub>\<V>\<^sub>+)
        \<and> (\<forall> v \<in> set ((P)\<^sub>\<V>\<^sub>+). the (I v) \<in> range_of' P v)
        \<and> ((P)\<^sub>G\<^sub>+) \<subseteq>\<^sub>m execute_serial_plan_sas_plus I plan
        \<and> list_all (\<lambda>op. ListMem op ((P)\<^sub>\<O>\<^sub>+)) plan" using assms
    by (auto simp: is_serial_solution_for_problem_sas_plus_plus_def Let_def)
  let ?P' = "SAS_Plus_Plus_To_SAS_Plus P"
  let ?missing_vs = "(concat (map (\<lambda>v. case ((P)\<^sub>I\<^sub>+) v of Some _ \<Rightarrow> [] |
    None \<Rightarrow> [(v, the (I v))]) (remdups ((P)\<^sub>\<V>\<^sub>+))))"
  let ?prefix' = "initialization_sequence ?missing_vs"
  let ?prefix = "?prefix' @ [\<lparr> precondition_of = [(Stage, Init)], effect_of = [(Stage, NonInit)]\<rparr>]"
  have "execute_serial_plan_sas_plus ((?P')\<^sub>I\<^sub>+) ?prefix'
    = SAS_Plus_Plus_State_To_SAS_Plus (Init, I)" using I_def
    apply(auto simp: SAS_Plus_Plus_To_SAS_Plus_def SAS_Plus_Plus_State_To_SAS_Plus_def map_le_def
        initial_state_def map_add_def map_comp_def fun_eq_iff split: option.splits variable.splits)
    by (metis domI option.inject)
  hence "execute_serial_plan_sas_plus ((?P')\<^sub>I\<^sub>+)
    (?prefix @ (map SAS_Plus_Plus_Operator_To_SAS_Plus_Operator plan))
    = SAS_Plus_Plus_State_To_SAS_Plus (NonInit, execute_serial_plan_sas_plus I plan)" by auto
  hence "((?P')\<^sub>G\<^sub>+) \<subseteq>\<^sub>m execute_serial_plan_sas_plus ((?P')\<^sub>I\<^sub>+)
    (?prefix @ (map SAS_Plus_Plus_Operator_To_SAS_Plus_Operator plan))" using I_def
    apply(auto simp:  SAS_Plus_Plus_To_SAS_Plus_def SAS_Plus_Plus_State_To_SAS_Plus_def
        map_add_def map_comp_def split: option.splits variable.splits)
    apply(simp add: map_le_def fun_eq_iff)
    by (metis (no_types, lifting) domIff option.case_eq_if)
  hence "length ?prefix \<le> length ((P)\<^sub>\<V>\<^sub>+) + 1
    \<and> is_serial_solution_for_problem (SAS_Plus_Plus_To_SAS_Plus P)
        (?prefix @ (map SAS_Plus_Plus_Operator_To_SAS_Plus_Operator plan))"
    using I_def
    by(auto simp: is_serial_solution_for_problem_def Let_def in_initialization_operators_iff
        initialization_sequence_def ListMem_iff SAS_Plus_Plus_To_SAS_Plus_def range_of'_def
        list_all_def split: option.splits)
  thus ?thesis by blast
qed

lemma map_of_map_Stage[simp]:
  "map_of (map (\<lambda>x. (Var (fst x), DE (snd x))) l) Stage = None"
  apply(induction l)
  by(auto)

lemma chain_applicable_in_Stage_NonInit:
  "s Stage = Some NonInit \<Longrightarrow> chain_applicable s plan
  \<Longrightarrow> \<forall>op \<in> set plan. op \<in> set ((SAS_Plus_Plus_To_SAS_Plus P)\<^sub>\<O>\<^sub>+)
  \<Longrightarrow> \<forall>op \<in> set plan. op \<in> set (map SAS_Plus_Plus_Operator_To_SAS_Plus_Operator ((P)\<^sub>\<O>\<^sub>+))"
proof(induction plan arbitrary: s)
  case Nil
  then show ?case by auto
next
  case (Cons a plan)
  hence "a \<in> set (map SAS_Plus_Plus_Operator_To_SAS_Plus_Operator ((P)\<^sub>\<O>\<^sub>+))"
    "(s \<then>\<^sub>+ a) Stage = Some NonInit"
    using Cons
    by (auto simp: SAS_Plus_Plus_To_SAS_Plus_def map_le_def map_add_def option.case_eq_if
        SAS_Plus_Plus_Operator_To_SAS_Plus_Operator_def initialization_operators_def)
  thus ?case using Cons by auto
qed

lemma in_set_take_then: "op \<in> set (take k (a # as)) \<Longrightarrow> (op = a \<or> op \<in> set (take (k - 1) as))"
  by (metis empty_iff empty_set set_ConsD take_Cons')

lemma SAS_plus_plan_structure:
  assumes "s Stage = Some Init"
    "chain_applicable s plan"
    "execute_serial_plan_sas_plus s plan Stage = Some NonInit"
    "list_all (\<lambda>op. ListMem op ((SAS_Plus_Plus_To_SAS_Plus P)\<^sub>\<O>\<^sub>+) ) plan"
  shows "\<exists>k. k < length plan
    \<and> list_all (\<lambda>op. op \<in> set (initialization_operators P)) (take k plan)
    \<and> plan ! k = \<lparr> precondition_of = [(Stage, Init)], effect_of = [(Stage, NonInit)]\<rparr>
    \<and> list_all (\<lambda>op. op \<in> set (map SAS_Plus_Plus_Operator_To_SAS_Plus_Operator ((P)\<^sub>\<O>\<^sub>+)))
      (drop (k + 1) plan)"
using assms proof(induction plan arbitrary: s)
  case (Cons a plan)
  hence "a \<in> set (initialization_operators P)
    \<or> a = \<lparr> precondition_of = [(Stage, Init)], effect_of = [(Stage, NonInit)]\<rparr>
    \<or> a \<in> set (map SAS_Plus_Plus_Operator_To_SAS_Plus_Operator ((P)\<^sub>\<O>\<^sub>+))"
    by (auto simp: SAS_Plus_Plus_To_SAS_Plus_def ListMem_iff)
  thus ?case
  using Cons proof(elim disjE)
    assume *: "a \<in> set (initialization_operators P)"
    hence "(s ++ map_of (effect_of a)) Stage = Some Init" using Cons by simp
    then obtain k where "k < length plan
      \<and> list_all (\<lambda>op. op \<in> set (initialization_operators P)) (take k plan)
      \<and> plan ! k = \<lparr> precondition_of = [(Stage, Init)], effect_of = [(Stage, NonInit)]\<rparr>
      \<and> list_all (\<lambda>op. op \<in> set (map SAS_Plus_Plus_Operator_To_SAS_Plus_Operator ((P)\<^sub>\<O>\<^sub>+)))
      (drop (k + 1) plan)" using Cons apply(simp) by presburger
    thus ?thesis using Cons * by auto
  next
    assume *: "a = \<lparr> precondition_of = [(Stage, Init)], effect_of = [(Stage, NonInit)]\<rparr>"
    hence "\<forall>op \<in> set plan. op \<in> set (map SAS_Plus_Plus_Operator_To_SAS_Plus_Operator ((P)\<^sub>\<O>\<^sub>+))"
      apply -
      apply(rule chain_applicable_in_Stage_NonInit[where ?s = "s ++ map_of(effect_of a)"])
      using Cons by (auto simp: list_all_def ListMem_iff)
    thus ?thesis using * by (auto simp: list_all_def)
  qed (auto simp: SAS_Plus_Plus_Operator_To_SAS_Plus_Operator_def list_all_def map_le_def)
qed auto

lemma result_of_initialization_operator:
  "is_valid_problem_sas_plus_plus P
    \<Longrightarrow> op \<in> set (initialization_operators P)
    \<Longrightarrow> ((P)\<^sub>I\<^sub>+) \<subseteq>\<^sub>m I
    \<Longrightarrow> (\<forall>v \<in> dom I. the (I v) \<in> \<R>\<^sub>+ P v)
    \<Longrightarrow> (\<exists>I'. (SAS_Plus_Plus_State_To_SAS_Plus (Init, I)) ++ map_of(effect_of op)
        = SAS_Plus_Plus_State_To_SAS_Plus (Init, I')
      \<and> ((P)\<^sub>I\<^sub>+) \<subseteq>\<^sub>m I' \<and> (\<forall>v \<in> dom I'. the (I' v) \<in> \<R>\<^sub>+ P v))"
  apply(auto simp: initialization_operators_def map_le_def range_of'_def dom_def ListMem_iff
       is_valid_problem_sas_plus_plus_def Let_def list_all_def split: if_splits option.splits)
   apply (meson domI domIff)
  by (metis option.sel option.simps)

lemma result_of_initialization_operators:
  "is_valid_problem_sas_plus_plus P
    \<Longrightarrow> list_all (\<lambda>op. op \<in> set (initialization_operators P)) ops
    \<Longrightarrow> ((P)\<^sub>I\<^sub>+) \<subseteq>\<^sub>m I
    \<Longrightarrow> (\<forall>v \<in> dom I. the (I v) \<in> \<R>\<^sub>+ P v)
    \<Longrightarrow> (\<exists>I'. execute_serial_plan_sas_plus (SAS_Plus_Plus_State_To_SAS_Plus (Init, I)) ops
        = SAS_Plus_Plus_State_To_SAS_Plus (Init, I')
      \<and> ((P)\<^sub>I\<^sub>+) \<subseteq>\<^sub>m I' \<and> (\<forall>v \<in> dom I'. the (I' v) \<in> \<R>\<^sub>+ P v))"
proof(induction ops arbitrary: I)
  case (Cons op ops)
  thus ?case using result_of_initialization_operator[OF Cons(2)] by force
qed auto

lemma list_all_in_map_set_then:
  "\<forall>a\<in>set as. a \<in> f ` S  \<Longrightarrow> (\<exists>bs. as = map f bs \<and> (\<forall>b \<in> set bs. b \<in> S))"
  apply(induction as)
   apply(auto)
  by (metis list.simps set_ConsD)

lemma result_of_initialization_operators_on_initial_state:
  "is_valid_problem_sas_plus_plus P
    \<Longrightarrow> list_all (\<lambda>op. op \<in> set (initialization_operators P)) ops
    \<Longrightarrow> (\<exists>I'. execute_serial_plan_sas_plus ((SAS_Plus_Plus_To_SAS_Plus P)\<^sub>I\<^sub>+) ops
        = SAS_Plus_Plus_State_To_SAS_Plus (Init, I')
      \<and> ((P)\<^sub>I\<^sub>+) \<subseteq>\<^sub>m I' \<and> (\<forall>v \<in> dom I'. the (I' v) \<in> \<R>\<^sub>+ P v))"
  apply(simp add: SAS_Plus_Plus_To_SAS_Plus_def initial_state_def)
  apply(rule result_of_initialization_operators)
  apply(auto simp: list_all_def map_le_def is_valid_problem_sas_plus_plus_def Let_def ListMem_iff
      range_of'_def split: option.splits)
  by auto

lemma length_of_mapped: "l' = map f l \<Longrightarrow> length l' \<le> x \<Longrightarrow> length l \<le> x" by simp

lemma SAS_Plus_To_SAS_Plus_Plus:
  assumes "is_valid_problem_sas_plus_plus P"
    "is_serial_solution_for_problem (SAS_Plus_Plus_To_SAS_Plus P) plan"
  shows "\<exists>plan'. length plan' \<le> length plan
    \<and> is_serial_solution_for_problem_sas_plus_plus P plan'"
proof-
  let ?plan = "chain_applicable_prefix ((SAS_Plus_Plus_To_SAS_Plus P)\<^sub>I\<^sub>+) plan"
  obtain k where k_def: "k < length ?plan
    \<and> list_all (\<lambda>op. op \<in> set (initialization_operators P)) (take k ?plan)
    \<and> ?plan ! k = \<lparr> precondition_of = [(Stage, Init)], effect_of = [(Stage, NonInit)]\<rparr>
    \<and> list_all (\<lambda>op. op \<in> set (map SAS_Plus_Plus_Operator_To_SAS_Plus_Operator ((P)\<^sub>\<O>\<^sub>+)))
      (drop (k + 1) ?plan)"
    using exE[OF SAS_plus_plan_structure[where ?s ="((SAS_Plus_Plus_To_SAS_Plus P)\<^sub>I\<^sub>+)"
            and ?P = P and ?plan = ?plan]] assms set_of_chain_applicable_prefix
    by(force simp: is_serial_solution_for_problem_def list_all_def map_le_def Let_def
        execute_chain_applicable_prefix SAS_Plus_Plus_To_SAS_Plus_def initial_state_def ListMem_iff
        SAS_Plus_Plus_State_To_SAS_Plus_def)+

  let ?prefix = "take k ?plan"
  obtain I' where I'_def: "execute_serial_plan_sas_plus ((SAS_Plus_Plus_To_SAS_Plus P)\<^sub>I\<^sub>+) ?prefix
        = SAS_Plus_Plus_State_To_SAS_Plus (Init, I')
      \<and> ((P)\<^sub>I\<^sub>+) \<subseteq>\<^sub>m I' \<and> (\<forall>v \<in> dom I'. the (I' v) \<in> \<R>\<^sub>+ P v)"
    using result_of_initialization_operators_on_initial_state assms k_def by blast
  moreover have  "dom (execute_serial_plan_sas_plus ((SAS_Plus_Plus_To_SAS_Plus P)\<^sub>I\<^sub>+) ?prefix)
    = set ((SAS_Plus_Plus_To_SAS_Plus P)\<^sub>\<V>\<^sub>+)"
    apply(rule dom_of_execute_serial_plan_sas_plus)
    using SAS_Plus_Plus_To_SAS_Plus_valid assms k_def
    by(auto simp: list_all_def SAS_Plus_Plus_To_SAS_Plus_def initial_state_def
        SAS_Plus_Plus_State_To_SAS_Plus_def map_comp_def split: option.splits variable.splits)
  ultimately have dom_of_I': "dom I' = set ((P)\<^sub>\<V>\<^sub>+)"
    by (auto simp: dom_of_SAS_Plus_Plus_State_To_SAS_Plus SAS_Plus_Plus_To_SAS_Plus_def)

  have "\<exists>plan'. drop (k + 1) ?plan = map SAS_Plus_Plus_Operator_To_SAS_Plus_Operator plan'
    \<and> (\<forall>op \<in> set plan'. op \<in> set ((P)\<^sub>\<O>\<^sub>+))"
    using k_def list_all_in_map_set_then by(auto simp: list_all_def)
  then obtain plan' where plan'_def: "map SAS_Plus_Plus_Operator_To_SAS_Plus_Operator plan'
    = drop (k + 1) ?plan  \<and> (\<forall>op \<in> set plan'. op \<in> set ((P)\<^sub>\<O>\<^sub>+))" by fastforce

  have "?plan = ((take k ?plan)
    @ [\<lparr> precondition_of = [(Stage, Init)], effect_of = [(Stage, NonInit)]\<rparr>]
    @ (drop (k + 1) ?plan))" using k_def
    by (metis One_nat_def add.right_neutral add_Suc_right append.assoc append_take_drop_id
        hd_drop_conv_nth take_hd_drop)
  hence "execute_serial_plan_sas_plus ((SAS_Plus_Plus_To_SAS_Plus P)\<^sub>I\<^sub>+) ?plan
    = execute_serial_plan_sas_plus (SAS_Plus_Plus_State_To_SAS_Plus (Init, I'))
        ([\<lparr> precondition_of = [(Stage, Init)], effect_of = [(Stage, NonInit)]\<rparr>]
        @ (drop (k + 1) ?plan))" using I'_def
    by (metis chain_applicable_append chain_applicable_prefix_chain_applicable
        execute_serial_plan_sas_plus_append)
  also have "... = SAS_Plus_Plus_State_To_SAS_Plus (NonInit, execute_serial_plan_sas_plus I' plan')"
    using plan'_def by auto (metis execute_SAS_Plus_Plus_ops_in_SAS_Plus)
  ultimately have "(P)\<^sub>G\<^sub>+ \<subseteq>\<^sub>m execute_serial_plan_sas_plus I' plan'"
    using assms(2) plan'_def
    by(auto simp: execute_chain_applicable_prefix is_serial_solution_for_problem_def
        SAS_Plus_Plus_To_SAS_Plus_def)
  hence "(P)\<^sub>I\<^sub>+ \<subseteq>\<^sub>m I' \<and> dom I' = set ((P)\<^sub>\<V>\<^sub>+)
        \<and> (\<forall> v \<in> set ((P)\<^sub>\<V>\<^sub>+). the (I' v) \<in> range_of' P v)
        \<and> (P)\<^sub>G\<^sub>+ \<subseteq>\<^sub>m execute_serial_plan_sas_plus I' plan'
        \<and> list_all (\<lambda>op. ListMem op ((P)\<^sub>\<O>\<^sub>+)) plan'"
    using plan'_def I'_def dom_of_I' by (auto simp: list_all_def ListMem_iff)
  hence "length plan' \<le> length plan
    \<and> is_serial_solution_for_problem_sas_plus_plus P plan'" using plan'_def
    apply (auto simp: is_serial_solution_for_problem_sas_plus_plus_def)
    using length_of_mapped length_of_chain_applicable_prefix le_add1 le_diff_conv le_trans
    by (metis (mono_tags, lifting) length_drop)
  thus ?thesis by blast
qed

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_nat_max_comm
imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun le :: "Nat => Nat => bool" where
"le (Z) y = True"
| "le (S z) (Z) = False"
| "le (S z) (S x2) = le z x2"

theorem property0 :
  "((if le x y then y else x) = (if le y x then x else y))"
  oops

end


(*
   Title: The pi-calculus
   Author/Maintainer: Jesper Bengtson (jebe.dk), 2012
*)
theory Strong_Late_Bisim_Subst
  imports Strong_Late_Bisim
begin

abbreviation
  StrongEqJudge (infixr "\<sim>\<^sup>s" 65) where "P \<sim>\<^sup>s Q \<equiv> (P, Q) \<in> (substClosed bisim)"

lemma congBisim:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<sim>\<^sup>s Q"

  shows "P \<sim> Q"
using assms substClosedSubset by blast

lemma eqvt:
  shows "eqvt (substClosed bisim)"
by(rule eqvtSubstClosed[OF Strong_Late_Bisim.bisimEqvt])

lemma eqClosed:
  fixes P :: pi
  and   Q :: pi
  and   perm :: "name prm"

  assumes "P \<sim>\<^sup>s Q"

  shows "(perm \<bullet> P) \<sim>\<^sup>s (perm \<bullet> Q)"
using assms
by(rule eqvtRelI[OF eqvt])

lemma reflexive:
  fixes P :: pi

  shows "P \<sim>\<^sup>s P"
by(force simp add: substClosed_def intro: Strong_Late_Bisim.reflexive)

end


(*<*)
theory TAO_10_PossibleWorlds
imports TAO_9_PLM
begin
(*>*)

section\<open>Possible Worlds\<close>
text\<open>\label{TAO_PossibleWorlds}\<close>

locale PossibleWorlds = PLM
begin

subsection\<open>Definitions\<close>
text\<open>\label{TAO_PossibleWorlds_Definitions}\<close>

  definition Situation where
    "Situation x \<equiv> \<lparr>A!,x\<rparr> \<^bold>& (\<^bold>\<forall> F. \<lbrace>x,F\<rbrace> \<^bold>\<rightarrow> Propositional F)"

  definition EncodeProposition (infixl "\<^bold>\<Sigma>" 70) where
    "x\<^bold>\<Sigma>p \<equiv> \<lparr>A!,x\<rparr> \<^bold>& \<lbrace>x, \<^bold>\<lambda> x . p\<rbrace>"
  definition TrueInSituation (infixl "\<^bold>\<Turnstile>" 10) where
    "x \<^bold>\<Turnstile> p \<equiv> Situation x \<^bold>& x\<^bold>\<Sigma>p"
  definition PossibleWorld where
    "PossibleWorld x \<equiv> Situation x \<^bold>& \<^bold>\<diamond>(\<^bold>\<forall> p . x\<^bold>\<Sigma>p \<^bold>\<equiv> p)"

subsection\<open>Auxiliary Lemmas\<close>
text\<open>\label{TAO_PossibleWorlds_Aux}\<close>

  lemma possit_sit_1:
    "[Situation (x\<^sup>P) \<^bold>\<equiv> \<^bold>\<box>(Situation (x\<^sup>P)) in v]"
    proof (rule "\<^bold>\<equiv>I"; rule CP)
      assume "[Situation (x\<^sup>P) in v]"
      hence 1: "[\<lparr>A!,x\<^sup>P\<rparr> \<^bold>& (\<^bold>\<forall> F. \<lbrace>x\<^sup>P,F\<rbrace> \<^bold>\<rightarrow> Propositional F) in v]"
        unfolding Situation_def by auto
      have "[\<^bold>\<box>\<lparr>A!,x\<^sup>P\<rparr> in v]"
        using 1[conj1, THEN oa_facts_2[deduction]] .
      moreover have "[\<^bold>\<box>(\<^bold>\<forall> F. \<lbrace>x\<^sup>P,F\<rbrace> \<^bold>\<rightarrow> Propositional F) in v]"
         using 1[conj2] unfolding Propositional_def
         by (rule enc_prop_nec_2[deduction])
      ultimately show "[\<^bold>\<box>Situation (x\<^sup>P) in v]"
        unfolding Situation_def
        apply cut_tac apply (rule KBasic_3[equiv_rl])
        by (rule intro_elim_1)
    next
      assume "[\<^bold>\<box>Situation (x\<^sup>P) in v]"
      thus "[Situation (x\<^sup>P) in v]"
        using qml_2[axiom_instance, deduction] by auto
    qed

  lemma possworld_nec:
    "[PossibleWorld (x\<^sup>P) \<^bold>\<equiv> \<^bold>\<box>(PossibleWorld (x\<^sup>P)) in v]"
    apply (rule "\<^bold>\<equiv>I"; rule CP)
     subgoal unfolding PossibleWorld_def
     apply (rule KBasic_3[equiv_rl])
     apply (rule intro_elim_1)
      using possit_sit_1[equiv_lr] "\<^bold>&E"(1) apply blast
     using qml_3[axiom_instance, deduction] "\<^bold>&E"(2) by blast
    using qml_2[axiom_instance,deduction] by auto

  lemma TrueInWorldNecc:
    "[((x\<^sup>P) \<^bold>\<Turnstile> p) \<^bold>\<equiv> \<^bold>\<box>((x\<^sup>P) \<^bold>\<Turnstile> p) in v]"
    proof (rule "\<^bold>\<equiv>I"; rule CP)
      assume "[x\<^sup>P \<^bold>\<Turnstile> p in v]"
      hence "[Situation (x\<^sup>P) \<^bold>& (\<lparr>A!,x\<^sup>P\<rparr> \<^bold>& \<lbrace>x\<^sup>P,\<^bold>\<lambda>x. p\<rbrace>) in v]"
        unfolding TrueInSituation_def EncodeProposition_def .
      hence "[(\<^bold>\<box>Situation (x\<^sup>P) \<^bold>& \<^bold>\<box>\<lparr>A!,x\<^sup>P\<rparr>) \<^bold>& \<^bold>\<box>\<lbrace>x\<^sup>P, \<^bold>\<lambda>x. p\<rbrace> in v]"
        using "\<^bold>&I" "\<^bold>&E" possit_sit_1[equiv_lr] oa_facts_2[deduction]
              encoding[axiom_instance,deduction] by metis
      thus "[\<^bold>\<box>((x\<^sup>P) \<^bold>\<Turnstile> p) in v]"
        unfolding TrueInSituation_def EncodeProposition_def
        using KBasic_3[equiv_rl] "\<^bold>&I" "\<^bold>&E" by metis
    next
      assume "[\<^bold>\<box>(x\<^sup>P \<^bold>\<Turnstile> p) in v]"
      thus "[x\<^sup>P \<^bold>\<Turnstile> p in v]"
        using qml_2[axiom_instance,deduction] by auto
    qed

  lemma PossWorldAux:
    "[(\<lparr>A!,x\<^sup>P\<rparr> \<^bold>& (\<^bold>\<forall> F . (\<lbrace>x\<^sup>P,F\<rbrace> \<^bold>\<equiv> (\<^bold>\<exists> p . p \<^bold>& (F \<^bold>= (\<^bold>\<lambda> x . p))))))
       \<^bold>\<rightarrow> (PossibleWorld (x\<^sup>P)) in v]"
    proof (rule CP)
      assume DefX: "[\<lparr>A!,x\<^sup>P\<rparr> \<^bold>& (\<^bold>\<forall> F . (\<lbrace>x\<^sup>P,F\<rbrace> \<^bold>\<equiv>
            (\<^bold>\<exists> p . p \<^bold>& (F \<^bold>= (\<^bold>\<lambda> x . p))))) in v]"

      have "[Situation (x\<^sup>P) in v]"
      proof -
        have "[\<lparr>A!,x\<^sup>P\<rparr> in v]"
          using DefX[conj1] .
        moreover have "[(\<^bold>\<forall>F. \<lbrace>x\<^sup>P,F\<rbrace> \<^bold>\<rightarrow> Propositional F) in v]"
          proof (rule "\<^bold>\<forall>I"; rule CP)
            fix F
            assume "[\<lbrace>x\<^sup>P,F\<rbrace> in v]"
            moreover have "[\<lbrace>x\<^sup>P,F\<rbrace> \<^bold>\<equiv> (\<^bold>\<exists> p . p \<^bold>& (F \<^bold>= (\<^bold>\<lambda> x . p))) in v]"
              using DefX[conj2] cqt_1[axiom_instance, deduction] by auto
            ultimately have "[(\<^bold>\<exists> p . p \<^bold>& (F \<^bold>= (\<^bold>\<lambda> x . p))) in v]"
              using "\<^bold>\<equiv>E"(1) by blast
            then obtain p where "[p \<^bold>& (F \<^bold>= (\<^bold>\<lambda> x . p)) in v]"
              by (rule "\<^bold>\<exists>E")
            hence "[(F \<^bold>= (\<^bold>\<lambda> x . p)) in v]"
              by (rule "\<^bold>&E"(2))
            hence "[(\<^bold>\<exists> p . (F \<^bold>= (\<^bold>\<lambda> x . p))) in v]"
              by PLM_solver
            thus "[Propositional F in v]"
              unfolding Propositional_def .
          qed
        ultimately show "[Situation (x\<^sup>P) in v]"
          unfolding Situation_def by (rule "\<^bold>&I")
      qed
      moreover have "[\<^bold>\<diamond>(\<^bold>\<forall>p. x\<^sup>P \<^bold>\<Sigma> p \<^bold>\<equiv> p) in v]"
        unfolding EncodeProposition_def
        proof (rule TBasic[deduction]; rule "\<^bold>\<forall>I")
          fix q
          have EncodeLambda:
            "[\<lbrace>x\<^sup>P, \<^bold>\<lambda>x. q\<rbrace> \<^bold>\<equiv> (\<^bold>\<exists> p . p \<^bold>& ((\<^bold>\<lambda>x. q) \<^bold>= (\<^bold>\<lambda> x . p))) in v]"
            using DefX[conj2] by (rule cqt_1[axiom_instance, deduction])
          moreover {
             assume "[q in v]"
             moreover have "[(\<^bold>\<lambda>x. q) \<^bold>= (\<^bold>\<lambda> x . q) in v]"
              using id_eq_prop_prop_1 by auto
             ultimately have "[q \<^bold>& ((\<^bold>\<lambda>x. q) \<^bold>= (\<^bold>\<lambda> x . q)) in v]"
               by (rule "\<^bold>&I")
             hence "[\<^bold>\<exists> p . p \<^bold>& ((\<^bold>\<lambda>x. q) \<^bold>= (\<^bold>\<lambda> x . p)) in v]"
               by PLM_solver
             moreover have "[\<lparr>A!,x\<^sup>P\<rparr> in v]"
               using DefX[conj1] .
             ultimately have "[\<lparr>A!,x\<^sup>P\<rparr> \<^bold>& \<lbrace>x\<^sup>P, \<^bold>\<lambda>x. q\<rbrace> in v]"
               using EncodeLambda[equiv_rl] "\<^bold>&I" by auto
          }
          moreover {
            assume "[\<lparr>A!,x\<^sup>P\<rparr> \<^bold>& \<lbrace>x\<^sup>P, \<^bold>\<lambda>x. q\<rbrace> in v]"
            hence "[\<lbrace>x\<^sup>P, \<^bold>\<lambda>x. q\<rbrace> in v]"
              using "\<^bold>&E"(2) by auto
            hence "[\<^bold>\<exists> p . p \<^bold>& ((\<^bold>\<lambda>x. q) \<^bold>= (\<^bold>\<lambda> x . p)) in v]"
              using EncodeLambda[equiv_lr] by auto
            then obtain p where p_and_lambda_q_is_lambda_p:
              "[p \<^bold>& ((\<^bold>\<lambda>x. q) \<^bold>= (\<^bold>\<lambda> x . p)) in v]"
              by (rule "\<^bold>\<exists>E")
            have "[\<lparr>(\<^bold>\<lambda> x . p), x\<^sup>P\<rparr> \<^bold>\<equiv> p in v]"
              apply (rule beta_C_meta_1)
              by show_proper
            hence "[\<lparr>(\<^bold>\<lambda> x . p), x\<^sup>P\<rparr> in v]"
              using p_and_lambda_q_is_lambda_p[conj1] "\<^bold>\<equiv>E"(2) by auto
            hence "[\<lparr>(\<^bold>\<lambda> x . q), x\<^sup>P\<rparr> in v]"
              using p_and_lambda_q_is_lambda_p[conj2, THEN id_eq_prop_prop_2[deduction]]
                l_identity[axiom_instance, deduction, deduction] by fast
            moreover have "[\<lparr>(\<^bold>\<lambda> x . q), x\<^sup>P\<rparr> \<^bold>\<equiv> q in v]"
              apply (rule beta_C_meta_1) by show_proper
            ultimately have "[q in v]"
              using "\<^bold>\<equiv>E"(1) by blast
          }
          ultimately show "[\<lparr>A!,x\<^sup>P\<rparr> \<^bold>& \<lbrace>x\<^sup>P,\<^bold>\<lambda>x. q\<rbrace> \<^bold>\<equiv> q in v]"
            using "\<^bold>&I" "\<^bold>\<equiv>I" CP by auto
        qed

      ultimately show "[PossibleWorld (x\<^sup>P) in v]"
        unfolding PossibleWorld_def by (rule "\<^bold>&I")
    qed

subsection\<open>For every syntactic Possible World there is a semantic Possible World\<close>
text\<open>\label{TAO_PossibleWorlds_SyntacticSemantic}\<close>

  theorem SemanticPossibleWorldForSyntacticPossibleWorlds:
    "\<forall> x . [PossibleWorld (x\<^sup>P) in w] \<longrightarrow>
     (\<exists> v . \<forall> p . [(x\<^sup>P \<^bold>\<Turnstile> p) in w] \<longleftrightarrow> [p in v])"
    proof
      fix x
      {
        assume PossWorldX: "[PossibleWorld (x\<^sup>P) in w]"
        hence SituationX: "[Situation (x\<^sup>P) in w]"
          unfolding PossibleWorld_def apply cut_tac by PLM_solver
        have PossWorldExpanded:
          "[\<lparr>A!,x\<^sup>P\<rparr> \<^bold>& (\<^bold>\<forall>F. \<lbrace>x\<^sup>P,F\<rbrace> \<^bold>\<rightarrow> (\<^bold>\<exists>p. F \<^bold>= (\<^bold>\<lambda>x. p)))
            \<^bold>& \<^bold>\<diamond>(\<^bold>\<forall>p. \<lparr>A!,x\<^sup>P\<rparr> \<^bold>& \<lbrace>x\<^sup>P,\<^bold>\<lambda>x. p\<rbrace> \<^bold>\<equiv> p) in w]"
           using PossWorldX
           unfolding PossibleWorld_def Situation_def
                     Propositional_def EncodeProposition_def .
        have AbstractX: "[\<lparr>A!,x\<^sup>P\<rparr> in w]"
          using PossWorldExpanded[conj1,conj1] .

        have "[\<^bold>\<diamond>(\<^bold>\<forall>p. \<lbrace>x\<^sup>P,\<^bold>\<lambda>x. p\<rbrace> \<^bold>\<equiv> p) in w]"
          apply (PLM_subst_method
                 "\<lambda>p. \<lparr>A!,x\<^sup>P\<rparr> \<^bold>& \<lbrace>x\<^sup>P,\<^bold>\<lambda>x. p\<rbrace>"
                 "\<lambda> p . \<lbrace>x\<^sup>P,\<^bold>\<lambda>x. p\<rbrace>")
           subgoal using PossWorldExpanded[conj1,conj1,THEN oa_facts_2[deduction]]
                   using Semantics.T6 apply cut_tac by PLM_solver
          using PossWorldExpanded[conj2] .

        hence "\<exists>v. \<forall>p. ([\<lbrace>x\<^sup>P,\<^bold>\<lambda>x. p\<rbrace> in v])
                        = [p in v]"
         unfolding diamond_def equiv_def conj_def
         apply (simp add: Semantics.T4 Semantics.T6 Semantics.T5
                          Semantics.T8)
         by auto

        then obtain v where PropsTrueInSemWorld:
          "\<forall>p. ([\<lbrace>x\<^sup>P,\<^bold>\<lambda>x. p\<rbrace> in v]) = [p in v]"
          by auto
        {
          fix p
          {
            assume "[((x\<^sup>P) \<^bold>\<Turnstile> p) in w]"
            hence "[((x\<^sup>P) \<^bold>\<Turnstile> p) in v]"
              using TrueInWorldNecc[equiv_lr] Semantics.T6 by simp
            hence "[Situation (x\<^sup>P) \<^bold>& (\<lparr>A!,x\<^sup>P\<rparr> \<^bold>& \<lbrace>x\<^sup>P,\<^bold>\<lambda>x. p\<rbrace>) in v]"
              unfolding TrueInSituation_def EncodeProposition_def .
            hence "[\<lbrace>x\<^sup>P,\<^bold>\<lambda>x. p\<rbrace> in v]"
              using "\<^bold>&E"(2) by blast
            hence "[p in v]"
              using PropsTrueInSemWorld by blast
          }
          moreover {
            assume "[p in v]"
            hence "[\<lbrace>x\<^sup>P,\<^bold>\<lambda>x. p\<rbrace> in v]"
              using PropsTrueInSemWorld by blast
            hence "[(x\<^sup>P) \<^bold>\<Turnstile> p in v]"
              apply cut_tac unfolding TrueInSituation_def EncodeProposition_def
              apply (rule "\<^bold>&I") using SituationX[THEN possit_sit_1[equiv_lr]]
              subgoal using Semantics.T6 by auto
              apply (rule "\<^bold>&I")
              subgoal using AbstractX[THEN oa_facts_2[deduction]]
                using Semantics.T6 by auto
              by assumption
            hence "[\<^bold>\<box>((x\<^sup>P) \<^bold>\<Turnstile> p) in v]"
              using TrueInWorldNecc[equiv_lr] by simp
            hence "[(x\<^sup>P) \<^bold>\<Turnstile> p in w]"
              using Semantics.T6 by simp
          }
          ultimately have "[p in v] \<longleftrightarrow> [(x\<^sup>P) \<^bold>\<Turnstile> p in w]"
            by auto
        }
        hence "(\<exists> v . \<forall> p . [p in v] \<longleftrightarrow> [(x\<^sup>P) \<^bold>\<Turnstile> p in w])"
          by blast
      }
      thus "[PossibleWorld (x\<^sup>P) in w] \<longrightarrow>
            (\<exists>v. \<forall> p . [(x\<^sup>P) \<^bold>\<Turnstile> p in w] \<longleftrightarrow> [p in v])"
        by blast
    qed

subsection\<open>For every semantic Possible World there is a syntactic Possible World\<close>
text\<open>\label{TAO_PossibleWorlds_SemanticSyntactic}\<close>

  theorem SyntacticPossibleWorldForSemanticPossibleWorlds:
    "\<forall> v . \<exists> x . [PossibleWorld (x\<^sup>P) in w] \<and>
     (\<forall> p . [p in v] \<longleftrightarrow> [((x\<^sup>P) \<^bold>\<Turnstile> p) in w])"
    proof
      fix v
      have "[\<^bold>\<exists>x. \<lparr>A!,x\<^sup>P\<rparr> \<^bold>& (\<^bold>\<forall> F . (\<lbrace>x\<^sup>P,F\<rbrace> \<^bold>\<equiv>
            (\<^bold>\<exists> p . p \<^bold>& (F \<^bold>= (\<^bold>\<lambda> x . p))))) in v]"
        using A_objects[axiom_instance] by fast
      then obtain x where DefX:
        "[\<lparr>A!,x\<^sup>P\<rparr> \<^bold>& (\<^bold>\<forall> F . (\<lbrace>x\<^sup>P,F\<rbrace> \<^bold>\<equiv> (\<^bold>\<exists> p . p \<^bold>& (F \<^bold>= (\<^bold>\<lambda> x . p))))) in v]"
        by (rule "\<^bold>\<exists>E")
      hence PossWorldX: "[PossibleWorld (x\<^sup>P) in v]"
        using PossWorldAux[deduction] by blast
      hence "[PossibleWorld (x\<^sup>P) in w]"
        using possworld_nec[equiv_lr] Semantics.T6 by auto
      moreover have "(\<forall> p . [p in v] \<longleftrightarrow> [(x\<^sup>P) \<^bold>\<Turnstile> p in w])"
      proof
        fix q
        {
           assume "[q in v]"
           moreover have "[(\<^bold>\<lambda> x . q) \<^bold>= (\<^bold>\<lambda> x . q) in v]"
             using id_eq_prop_prop_1 by auto
           ultimately have "[q \<^bold>& (\<^bold>\<lambda> x . q) \<^bold>= (\<^bold>\<lambda> x . q) in v]"
             using "\<^bold>&I" by auto
           hence "[(\<^bold>\<exists> p . p \<^bold>& ((\<^bold>\<lambda> x . q) \<^bold>= (\<^bold>\<lambda> x . p))) in v]"
             by PLM_solver
           hence 4: "[\<lbrace>x\<^sup>P, (\<^bold>\<lambda> x . q)\<rbrace> in v]"
             using cqt_1[axiom_instance,deduction, OF DefX[conj2], equiv_rl]
             by blast
           have "[(x\<^sup>P \<^bold>\<Turnstile> q) in v]"
             unfolding TrueInSituation_def apply (rule "\<^bold>&I")
              using PossWorldX unfolding PossibleWorld_def
              using "\<^bold>&E"(1) apply blast
             unfolding EncodeProposition_def apply (rule "\<^bold>&I")
              using DefX[conj1] apply simp
             using 4 .
          hence "[(x\<^sup>P \<^bold>\<Turnstile> q) in w]"
            using TrueInWorldNecc[equiv_lr] Semantics.T6 by auto
        }
        moreover {
          assume "[(x\<^sup>P \<^bold>\<Turnstile> q) in w]"
          hence "[(x\<^sup>P \<^bold>\<Turnstile> q) in v]"
             using TrueInWorldNecc[equiv_lr] Semantics.T6
             by auto
          hence "[\<lbrace>x\<^sup>P, (\<^bold>\<lambda> x . q)\<rbrace> in v]"
            unfolding TrueInSituation_def EncodeProposition_def
            using "\<^bold>&E"(2) by blast
          hence "[(\<^bold>\<exists> p . p \<^bold>& ((\<^bold>\<lambda> x . q) \<^bold>= (\<^bold>\<lambda> x . p))) in v]"
            using cqt_1[axiom_instance,deduction, OF DefX[conj2], equiv_lr]
            by blast
          then obtain p where 4:
            "[(p \<^bold>& ((\<^bold>\<lambda> x . q) \<^bold>= (\<^bold>\<lambda> x . p))) in v]"
            by (rule "\<^bold>\<exists>E")
          have "[\<lparr>(\<^bold>\<lambda> x . p),x\<^sup>P\<rparr> \<^bold>\<equiv> p in v]"
            apply (rule beta_C_meta_1)
            by show_proper
          hence "[\<lparr>(\<^bold>\<lambda> x . q),x\<^sup>P\<rparr> \<^bold>\<equiv> p in v]"
              using l_identity[where \<beta>="(\<^bold>\<lambda> x . q)" and \<alpha>="(\<^bold>\<lambda> x . p)",
                               axiom_instance, deduction, deduction]
              using 4[conj2,THEN id_eq_prop_prop_2[deduction]] by meson
          hence "[\<lparr>(\<^bold>\<lambda> x . q),x\<^sup>P\<rparr> in v]" using 4[conj1] "\<^bold>\<equiv>E"(2) by blast
          moreover have "[\<lparr>(\<^bold>\<lambda> x . q),x\<^sup>P\<rparr> \<^bold>\<equiv> q in v]"
            apply (rule beta_C_meta_1)
            by show_proper
          ultimately have "[q in v]"
            using "\<^bold>\<equiv>E"(1) by blast
        }
        ultimately show "[q in v] \<longleftrightarrow> [(x\<^sup>P) \<^bold>\<Turnstile> q in w]"
          by blast
      qed
      ultimately show "\<exists> x . [PossibleWorld (x\<^sup>P) in w]
                           \<and> (\<forall> p . [p in v] \<longleftrightarrow> [(x\<^sup>P) \<^bold>\<Turnstile> p in w])"
        by auto
    qed
end

(*<*)
end
(*>*)


subsection \<open>Labeled Transition Systems\<close>

theory Transition_Systems
  imports Finite_Partial_Order
begin

locale lts =
fixes
  trans :: \<open>'s \<Rightarrow> 'a \<Rightarrow> 's \<Rightarrow> bool\<close>

begin

abbreviation step_pred :: \<open>'s \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 's \<Rightarrow> bool\<close>
  where
  \<open>step_pred p af q \<equiv> \<exists> a. af a \<and> trans p a q\<close>

abbreviation step ::
  \<open>'s \<Rightarrow> 'a \<Rightarrow> 's \<Rightarrow> bool\<close>
   ("_ \<longmapsto>_  _" [70, 70, 70] 80)
where
  \<open>p \<longmapsto>a  q \<equiv> trans p a q\<close>

inductive steps :: \<open>'s \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 's \<Rightarrow> bool\<close>
     ("_ \<longmapsto>* _  _" [70, 70, 70] 80)
where
  refl: \<open>p \<longmapsto>* A p\<close> | step: \<open>p \<longmapsto>* A q1 \<Longrightarrow> q1 \<longmapsto>a q \<Longrightarrow> A a \<Longrightarrow> (p \<longmapsto>* A q)\<close>

lemma steps_one_step:
  assumes
    \<open>p \<longmapsto>a p'\<close>
     \<open>A a\<close>
   shows
    \<open>p \<longmapsto>* A p'\<close> using steps.step[of p A p a p'] steps.refl[of p A] assms .

lemma steps_concat:
  assumes
    \<open>p' \<longmapsto>* A p''\<close>
     \<open>p \<longmapsto>* A p'\<close>
   shows
    \<open>p \<longmapsto>* A p''\<close> using assms
proof (induct arbitrary: p)
  case (refl p'' A p')
  then show ?case by auto
next
  case (step p' A p'' a pp p)
  hence \<open>p \<longmapsto>* A  p''\<close> by simp
  show ?case using steps.step[OF `p \<longmapsto>* A  p''` step(3,4)] .
qed

lemma steps_left:
  assumes
    \<open>p \<noteq> p'\<close>
     \<open>p \<longmapsto>* A p'\<close>
   shows
    \<open>\<exists>p'' a . p \<longmapsto>a p'' \<and> A a \<and> p'' \<longmapsto>* A p'\<close>
   using assms(1)
  by (induct rule:steps.induct[OF assms(2)], blast, metis refl steps_concat steps_one_step)

lemma steps_no_step:
  assumes
    \<open>\<And> a p' . p \<longmapsto>a p' \<Longrightarrow> \<not>A a\<close>
     \<open>p \<noteq> p''\<close>
     \<open>p \<longmapsto>* A p''\<close>
   shows
    \<open>False\<close>
   using steps_left[OF assms(2,3)] assms(1) by blast

lemma steps_no_step_pos:
  assumes
    \<open>\<And> a p' . p \<longmapsto>a p' \<Longrightarrow> \<not>A a\<close>
     \<open>p \<longmapsto>* A p'\<close>
   shows
    \<open>p = p'\<close>
   using assms steps_no_step by blast

lemma steps_loop:
  assumes
    \<open>\<And> a p' . p \<longmapsto>a p' \<Longrightarrow> p = p'\<close>
     \<open>p \<noteq> p''\<close>
     \<open>p \<longmapsto>* A p''\<close>
   shows
    \<open>False\<close>
   using assms(3,1,2) by (induct, auto)

corollary steps_transp:
  \<open>transp (\<lambda> p p'. p \<longmapsto>* A p')\<close>
   using steps_concat unfolding transp_def by blast

lemma steps_spec:
  assumes
    \<open>p \<longmapsto>* A' p'\<close>
     \<open>\<And> a . A' a \<Longrightarrow> A a\<close>
   shows
    \<open>p \<longmapsto>* A p'\<close> using assms(1,2)
proof induct
  case (refl p)
  show ?case using steps.refl .
next
  case (step p A' pp a pp')
  hence \<open>p \<longmapsto>* A  pp\<close> by simp
  then show ?case using step(3,4,5) steps.step by auto
qed

interpretation preorder \<open>(\<lambda> p p'. p \<longmapsto>* A p')\<close> \<open>\<lambda> p p'. p \<longmapsto>* A p' \<and> \<not>(p' \<longmapsto>* A p)\<close>
  by (standard, simp, simp add: steps.refl, metis steps_concat)

text\<open>If one can reach only a finite portion of the graph following @{text \<open>\<longmapsto>* A\<close>},
  and all cycles are loops, then there must be nodes which are maximal wrt. \<open>\<longmapsto>* A\<close>.\<close>
lemma step_max_deadlock:
  fixes A q
  assumes
    antiysmm: \<open>\<And> r1 r2. r1 \<longmapsto>* A r2 \<and> r2 \<longmapsto>* A r1 \<Longrightarrow> r1 = r2\<close> and
    finite: \<open>finite {q'. q \<longmapsto>* A q'}\<close> and
    no_max: \<open>\<forall> q'. q \<longmapsto>* A q' \<longrightarrow> (\<exists>q''. q' \<longmapsto>* A q'' \<and> q' \<noteq> q'')\<close>
   shows
    False
proof -
  interpret order \<open>(\<lambda> p p'. p \<longmapsto>* A p')\<close> \<open>\<lambda> p p'. p \<longmapsto>* A p' \<and> \<not>(p' \<longmapsto>* A p)\<close>
    by (standard, simp add: assms(1))
  show ?thesis using local.finite_max assms local.order_trans mem_Collect_eq by metis
qed

end \<comment>\<open>end of lts\<close>

lemma lts_impl_steps2:
  assumes
    \<open>lts.steps step1 p1 ap p2\<close>
     \<open>\<And> p1 a p2 . step1 p1 a p2 \<and> P p1 a p2 \<Longrightarrow> step2 p1 a p2\<close>
     \<open>\<And> p1 a p2 . P p1 a p2\<close>
   shows
    \<open>lts.steps step2 p1 ap p2\<close>
proof (induct rule: lts.steps.induct[OF assms(1)])
  case (1 p af)
  show ?case using lts.steps.refl[of step2 p af] by blast
next
  case (2 p af q1 a q)
  hence \<open>step2 q1 a q\<close> using assms(2,3) by blast
  thus ?case using lts.step[OF 2(2) _ 2(4)] by blast
qed

lemma lts_impl_steps:
  assumes
    \<open>lts.steps step1 p1 ap p2\<close>
     \<open>\<And> p1 a p2 . step1 p1 a p2 \<Longrightarrow> step2 p1 a p2\<close>
   shows
    \<open>lts.steps step2 p1 ap p2\<close>
   using assms lts_impl_steps2[OF assms] by auto

end


(*<*)
theory TAO_6_Identifiable
imports TAO_5_MetaSolver
begin
(*>*)

section\<open>General Identity\<close>
text\<open>\label{TAO_Identifiable}\<close>

text\<open>
\begin{remark}
  In order to define a general identity symbol that can act
  on all types of terms a type class is introduced
  which assumes the substitution property which
  is needed to derive the corresponding axiom.
  This type class is instantiated for all relation types, individual terms
  and individuals.
\end{remark}
\<close>

subsection\<open>Type Classes\<close>
text\<open>\label{TAO_Identifiable_Class}\<close>

class identifiable =
fixes identity :: "'a\<Rightarrow>'a\<Rightarrow>\<o>" (infixl "\<^bold>=" 63)
assumes l_identity:
  "w \<Turnstile> x \<^bold>= y \<Longrightarrow> w \<Turnstile> \<phi> x \<Longrightarrow> w \<Turnstile> \<phi> y"
begin
  abbreviation notequal (infixl "\<^bold>\<noteq>" 63) where
    "notequal \<equiv> \<lambda> x y . \<^bold>\<not>(x \<^bold>= y)"
end

class quantifiable_and_identifiable = quantifiable + identifiable
begin
  definition exists_unique::"('a\<Rightarrow>\<o>)\<Rightarrow>\<o>" (binder "\<^bold>\<exists>!" [8] 9) where
    "exists_unique \<equiv> \<lambda> \<phi> . \<^bold>\<exists> \<alpha> . \<phi> \<alpha> \<^bold>& (\<^bold>\<forall>\<beta>. \<phi> \<beta> \<^bold>\<rightarrow> \<beta> \<^bold>= \<alpha>)"

  declare exists_unique_def[conn_defs]
end

subsection\<open>Instantiations\<close>
text\<open>\label{TAO_Identifiable_Instantiation}\<close>

instantiation \<kappa> :: identifiable
begin
  definition identity_\<kappa> where "identity_\<kappa> \<equiv> basic_identity\<^sub>\<kappa>"
  instance proof
    fix x y :: \<kappa> and w \<phi>
    show "[x \<^bold>= y in w] \<Longrightarrow> [\<phi> x in w] \<Longrightarrow> [\<phi> y in w]"
      unfolding identity_\<kappa>_def
      using MetaSolver.Eq\<kappa>_prop ..
  qed
end

instantiation \<nu> :: identifiable
begin
  definition identity_\<nu> where "identity_\<nu> \<equiv> \<lambda> x y . x\<^sup>P \<^bold>= y\<^sup>P"
  instance proof
    fix \<alpha> :: \<nu> and \<beta> :: \<nu> and v \<phi>
    assume "v \<Turnstile> \<alpha> \<^bold>= \<beta>"
    hence "v \<Turnstile> \<alpha>\<^sup>P \<^bold>= \<beta>\<^sup>P"
      unfolding identity_\<nu>_def by auto
    hence "\<And>\<phi>.(v \<Turnstile> \<phi> (\<alpha>\<^sup>P)) \<Longrightarrow> (v \<Turnstile> \<phi> (\<beta>\<^sup>P))"
      using l_identity by auto
    hence "(v \<Turnstile> \<phi> (rep (\<alpha>\<^sup>P))) \<Longrightarrow> (v \<Turnstile> \<phi> (rep (\<beta>\<^sup>P)))"
      by meson
    thus "(v \<Turnstile> \<phi> \<alpha>) \<Longrightarrow> (v \<Turnstile> \<phi> \<beta>)"
      by (simp only: rep_proper_id)
  qed
end

instantiation \<Pi>\<^sub>1 :: identifiable
begin
  definition identity_\<Pi>\<^sub>1 where "identity_\<Pi>\<^sub>1 \<equiv> basic_identity\<^sub>1"
  instance proof
    fix F G :: \<Pi>\<^sub>1 and w \<phi>
    show "(w \<Turnstile> F \<^bold>= G) \<Longrightarrow> (w \<Turnstile> \<phi> F) \<Longrightarrow> (w \<Turnstile> \<phi> G)"
      unfolding identity_\<Pi>\<^sub>1_def using MetaSolver.Eq\<^sub>1_prop ..
  qed
end

instantiation \<Pi>\<^sub>2 :: identifiable
begin
  definition identity_\<Pi>\<^sub>2 where "identity_\<Pi>\<^sub>2 \<equiv> basic_identity\<^sub>2"
  instance proof
    fix F G :: \<Pi>\<^sub>2 and w \<phi>
    show "(w \<Turnstile> F \<^bold>= G) \<Longrightarrow> (w \<Turnstile> \<phi> F) \<Longrightarrow> (w \<Turnstile> \<phi> G)"
      unfolding identity_\<Pi>\<^sub>2_def using MetaSolver.Eq\<^sub>2_prop ..
  qed
end

instantiation \<Pi>\<^sub>3 :: identifiable
begin
  definition identity_\<Pi>\<^sub>3 where "identity_\<Pi>\<^sub>3 \<equiv> basic_identity\<^sub>3"
  instance proof
    fix F G :: \<Pi>\<^sub>3 and w \<phi>
    show "(w \<Turnstile> F \<^bold>= G) \<Longrightarrow> (w \<Turnstile> \<phi> F) \<Longrightarrow> (w \<Turnstile> \<phi> G)"
      unfolding identity_\<Pi>\<^sub>3_def using MetaSolver.Eq\<^sub>3_prop ..
  qed
end

instantiation \<o> :: identifiable
begin
  definition identity_\<o> where "identity_\<o> \<equiv> basic_identity\<^sub>0"
  instance proof
    fix F G :: \<o> and w \<phi>
    show "(w \<Turnstile> F \<^bold>= G) \<Longrightarrow> (w \<Turnstile> \<phi> F) \<Longrightarrow> (w \<Turnstile> \<phi> G)"
      unfolding identity_\<o>_def using MetaSolver.Eq\<^sub>0_prop ..
  qed
end

instance \<nu> :: quantifiable_and_identifiable ..
instance \<Pi>\<^sub>1 :: quantifiable_and_identifiable ..
instance \<Pi>\<^sub>2 :: quantifiable_and_identifiable ..
instance \<Pi>\<^sub>3 :: quantifiable_and_identifiable ..
instance \<o> :: quantifiable_and_identifiable ..

subsection\<open>New Identity Definitions\<close>
text\<open>\label{TAO_Identifiable_Definitions}\<close>

text\<open>
\begin{remark}
  The basic definitions of identity use type specific quantifiers
  and identity symbols. Equivalent definitions that
  use the general identity symbol and general quantifiers are provided.
\end{remark}
\<close>

named_theorems identity_defs
lemma identity\<^sub>E_def[identity_defs]:
  "basic_identity\<^sub>E \<equiv> \<^bold>\<lambda>\<^sup>2 (\<lambda>x y. \<lparr>O!,x\<^sup>P\<rparr> \<^bold>& \<lparr>O!,y\<^sup>P\<rparr> \<^bold>& \<^bold>\<box>(\<^bold>\<forall>F. \<lparr>F,x\<^sup>P\<rparr> \<^bold>\<equiv> \<lparr>F,y\<^sup>P\<rparr>))"
  unfolding basic_identity\<^sub>E_def forall_\<Pi>\<^sub>1_def by simp
lemma identity\<^sub>E_infix_def[identity_defs]:
  "x \<^bold>=\<^sub>E y \<equiv> \<lparr>basic_identity\<^sub>E,x,y\<rparr>" using basic_identity\<^sub>E_infix_def .
lemma identity\<^sub>\<kappa>_def[identity_defs]:
  "(\<^bold>=) \<equiv> \<lambda>x y. x \<^bold>=\<^sub>E y \<^bold>\<or> \<lparr>A!,x\<rparr> \<^bold>& \<lparr>A!,y\<rparr> \<^bold>& \<^bold>\<box>(\<^bold>\<forall> F. \<lbrace>x,F\<rbrace> \<^bold>\<equiv> \<lbrace>y,F\<rbrace>)"
  unfolding identity_\<kappa>_def basic_identity\<^sub>\<kappa>_def forall_\<Pi>\<^sub>1_def by simp
lemma identity\<^sub>\<nu>_def[identity_defs]:
  "(\<^bold>=) \<equiv> \<lambda>x y. (x\<^sup>P) \<^bold>=\<^sub>E (y\<^sup>P) \<^bold>\<or> \<lparr>A!,x\<^sup>P\<rparr> \<^bold>& \<lparr>A!,y\<^sup>P\<rparr> \<^bold>& \<^bold>\<box>(\<^bold>\<forall> F. \<lbrace>x\<^sup>P,F\<rbrace> \<^bold>\<equiv> \<lbrace>y\<^sup>P,F\<rbrace>)"
  unfolding identity_\<nu>_def identity\<^sub>\<kappa>_def by simp
lemma identity\<^sub>1_def[identity_defs]:
  "(\<^bold>=) \<equiv> \<lambda>F G. \<^bold>\<box>(\<^bold>\<forall> x . \<lbrace>x\<^sup>P,F\<rbrace> \<^bold>\<equiv> \<lbrace>x\<^sup>P,G\<rbrace>)"
  unfolding identity_\<Pi>\<^sub>1_def basic_identity\<^sub>1_def forall_\<nu>_def by simp
lemma identity\<^sub>2_def[identity_defs]:
  "(\<^bold>=) \<equiv> \<lambda>F G. \<^bold>\<forall> x. (\<^bold>\<lambda>y. \<lparr>F,x\<^sup>P,y\<^sup>P\<rparr>) \<^bold>= (\<^bold>\<lambda>y. \<lparr>G,x\<^sup>P,y\<^sup>P\<rparr>)
                    \<^bold>& (\<^bold>\<lambda>y. \<lparr>F,y\<^sup>P,x\<^sup>P\<rparr>) \<^bold>= (\<^bold>\<lambda>y. \<lparr>G,y\<^sup>P,x\<^sup>P\<rparr>)"
  unfolding identity_\<Pi>\<^sub>2_def identity_\<Pi>\<^sub>1_def basic_identity\<^sub>2_def forall_\<nu>_def by simp
lemma identity\<^sub>3_def[identity_defs]:
  "(\<^bold>=) \<equiv> \<lambda>F G. \<^bold>\<forall> x y. (\<^bold>\<lambda>z. \<lparr>F,z\<^sup>P,x\<^sup>P,y\<^sup>P\<rparr>) \<^bold>= (\<^bold>\<lambda>z. \<lparr>G,z\<^sup>P,x\<^sup>P,y\<^sup>P\<rparr>)
                      \<^bold>& (\<^bold>\<lambda>z. \<lparr>F,x\<^sup>P,z\<^sup>P,y\<^sup>P\<rparr>) \<^bold>= (\<^bold>\<lambda>z. \<lparr>G,x\<^sup>P,z\<^sup>P,y\<^sup>P\<rparr>)
                      \<^bold>& (\<^bold>\<lambda>z. \<lparr>F,x\<^sup>P,y\<^sup>P,z\<^sup>P\<rparr>) \<^bold>= (\<^bold>\<lambda>z. \<lparr>G,x\<^sup>P,y\<^sup>P,z\<^sup>P\<rparr>)"
  unfolding identity_\<Pi>\<^sub>3_def identity_\<Pi>\<^sub>1_def basic_identity\<^sub>3_def forall_\<nu>_def by simp
lemma identity\<^sub>\<o>_def[identity_defs]: "(\<^bold>=) \<equiv> \<lambda>F G. (\<^bold>\<lambda>y. F) \<^bold>= (\<^bold>\<lambda>y. G)"
  unfolding identity_\<o>_def identity_\<Pi>\<^sub>1_def basic_identity\<^sub>0_def by simp

(*<*)
end
(*>*)


(*  Title:      HOL/HOLCF/FOCUS/Fstream.thy
    Author:     David von Oheimb, TU Muenchen

FOCUS streams (with lifted elements).

TODO: integrate Fstreams.thy
*)

section \<open>FOCUS flat streams\<close>

theory Fstream
imports "HOLCF-Library.Stream"
begin

default_sort type

type_synonym 'a fstream = "'a lift stream"

definition
  fscons        :: "'a     \<Rightarrow> 'a fstream \<rightarrow> 'a fstream" where
  "fscons a = (\<Lambda> s. Def a && s)"

definition
  fsfilter      :: "'a set \<Rightarrow> 'a fstream \<rightarrow> 'a fstream" where
  "fsfilter A = (sfilter\<cdot>(flift2 (\<lambda>x. x\<in>A)))"

abbreviation
  emptystream   :: "'a fstream"                          ("<>") where
  "<> == \<bottom>"

abbreviation
  fscons'       :: "'a \<Rightarrow> 'a fstream \<Rightarrow> 'a fstream"       ("(_\<leadsto>_)" [66,65] 65) where
  "a\<leadsto>s == fscons a\<cdot>s"

abbreviation
  fsfilter'     :: "'a set \<Rightarrow> 'a fstream \<Rightarrow> 'a fstream"   ("(_\<copyright>_)" [64,63] 63) where
  "A\<copyright>s == fsfilter A\<cdot>s"

notation (ASCII)
  fscons'  ("(_~>_)" [66,65] 65) and
  fsfilter'  ("(_'(C')_)" [64,63] 63)

lemma Def_maximal: "a = Def d \<Longrightarrow> a\<sqsubseteq>b \<Longrightarrow> b = Def d"
by simp

section "fscons"

lemma fscons_def2: "a~>s = Def a && s"
apply (unfold fscons_def)
apply (simp)
done

lemma fstream_exhaust: "x = UU \<or> (\<exists>a y. x = a~> y)"
apply (simp add: fscons_def2)
apply (cut_tac stream.nchotomy)
apply (fast dest: not_Undef_is_Def [THEN iffD1])
done

lemma fstream_cases: "[| x = UU ==> P; !!a y. x = a~> y ==> P |] ==> P"
apply (cut_tac fstream_exhaust)
apply (erule disjE)
apply fast
apply fast
done

lemma fstream_exhaust_eq: "(x \<noteq> UU) = (\<exists>a y. x = a~> y)"
apply (simp add: fscons_def2 stream_exhaust_eq)
apply (fast dest: not_Undef_is_Def [THEN iffD1] elim: DefE)
done

lemma fscons_not_empty [simp]: "a~> s \<noteq> <>"
by (simp add: fscons_def2)

lemma fscons_inject [simp]: "(a~> s = b~> t) = (a = b \<and> s = t)"
by (simp add: fscons_def2)

lemma fstream_prefix: "a~> s << t ==> \<exists>tt. t = a~> tt \<and> s << tt"
apply (cases t)
apply (cut_tac fscons_not_empty)
apply (fast dest: bottomI)
apply (simp add: fscons_def2)
done

lemma fstream_prefix' [simp]:
        "x << a~> z = (x = <> \<or> (\<exists>y. x = a~> y \<and> y << z))"
apply (simp add: fscons_def2 lift.distinct(2) [THEN stream_prefix'])
apply (safe)
apply (erule_tac [!] contrapos_np)
prefer 2 apply (fast elim: DefE)
apply (rule lift.exhaust)
apply (erule (1) notE)
apply (safe)
apply (drule Def_below_Def [THEN iffD1])
apply fast
done

(* ------------------------------------------------------------------------- *)

section "ft & rt"

lemmas ft_empty = stream.sel_rews (1)
lemma ft_fscons [simp]: "ft\<cdot>(m~> s) = Def m"
by (simp add: fscons_def)

lemmas rt_empty = stream.sel_rews (2)
lemma rt_fscons [simp]: "rt\<cdot>(m~> s) = s"
by (simp add: fscons_def)

lemma ft_eq [simp]: "(ft\<cdot>s = Def a) = (\<exists>t. s = a~> t)"
apply (unfold fscons_def)
apply (simp)
apply (safe)
apply (erule subst)
apply (rule exI)
apply (rule surjectiv_scons [symmetric])
apply (simp)
done

lemma surjective_fscons_lemma: "(d\<leadsto>y = x) = (ft\<cdot>x = Def d & rt\<cdot>x = y)"
by auto

lemma surjective_fscons: "ft\<cdot>x = Def d \<Longrightarrow> d\<leadsto>rt\<cdot>x = x"
by (simp add: surjective_fscons_lemma)

(* ------------------------------------------------------------------------- *)

section "take"

lemma fstream_take_Suc [simp]:
        "stream_take (Suc n)\<cdot>(a~> s) = a~> stream_take n\<cdot>s"
by (simp add: fscons_def)

(* ------------------------------------------------------------------------- *)

section "slen"

lemma slen_fscons: "#(m~> s) = eSuc (#s)"
by (simp add: fscons_def)

lemma slen_fscons_eq:
        "(enat (Suc n) < #x) = (\<exists>a y. x = a~> y \<and> enat n < #y)"
apply (simp add: fscons_def2 slen_scons_eq)
apply (fast dest: not_Undef_is_Def [THEN iffD1] elim: DefE)
done

lemma slen_fscons_eq_rev:
        "(#x < enat (Suc (Suc n))) = (\<forall>a y. x \<noteq> a~> y \<or> #y < enat (Suc n))"
apply (simp add: fscons_def2 slen_scons_eq_rev)
apply (tactic \<open>step_tac (put_claset HOL_cs \<^context> addSEs @{thms DefE}) 1\<close>)
apply (tactic \<open>step_tac (put_claset HOL_cs \<^context> addSEs @{thms DefE}) 1\<close>)
apply (tactic \<open>step_tac (put_claset HOL_cs \<^context> addSEs @{thms DefE}) 1\<close>)
apply (tactic \<open>step_tac (put_claset HOL_cs \<^context> addSEs @{thms DefE}) 1\<close>)
apply (tactic \<open>step_tac (put_claset HOL_cs \<^context> addSEs @{thms DefE}) 1\<close>)
apply (tactic \<open>step_tac (put_claset HOL_cs \<^context> addSEs @{thms DefE}) 1\<close>)
apply (erule contrapos_np)
apply (fast dest: not_Undef_is_Def [THEN iffD1] elim: DefE)
done

lemma slen_fscons_less_eq:
        "(#(a~> y) < enat (Suc (Suc n))) = (#y < enat (Suc n))"
apply (subst slen_fscons_eq_rev)
apply (fast dest!: fscons_inject [THEN iffD1])
done

(* ------------------------------------------------------------------------- *)

section "induction"

lemma fstream_ind:
        "[| adm P; P <>; !!a s. P s ==> P (a~> s) |] ==> P x"
apply (erule stream.induct)
apply (assumption)
apply (unfold fscons_def2)
apply (fast dest: not_Undef_is_Def [THEN iffD1])
done

lemma fstream_ind2:
  "[| adm P; P UU; !!a. P (a~> UU); !!a b s. P s ==> P (a~> b~> s) |] ==> P x"
apply (erule stream_ind2)
apply (assumption)
apply (unfold fscons_def2)
apply (fast dest: not_Undef_is_Def [THEN iffD1])
apply (fast dest: not_Undef_is_Def [THEN iffD1])
done

(* ------------------------------------------------------------------------- *)

section "fsfilter"

lemma fsfilter_empty: "A(C)UU = UU"
apply (unfold fsfilter_def)
apply (rule sfilter_empty)
done

lemma fsfilter_fscons:
        "A(C)x~> xs = (if x\<in>A then x~> (A(C)xs) else A(C)xs)"
apply (unfold fsfilter_def)
apply (simp add: fscons_def2 If_and_if)
done

lemma fsfilter_emptys: "{}(C)x = UU"
apply (rule_tac x="x" in fstream_ind)
apply (simp)
apply (rule fsfilter_empty)
apply (simp add: fsfilter_fscons)
done

lemma fsfilter_insert: "(insert a A)(C)a~> x = a~> ((insert a A)(C)x)"
by (simp add: fsfilter_fscons)

lemma fsfilter_single_in: "{a}(C)a~> x = a~> ({a}(C)x)"
by (rule fsfilter_insert)

lemma fsfilter_single_out: "b ~= a ==> {a}(C)b~> x = ({a}(C)x)"
by (simp add: fsfilter_fscons)

lemma fstream_lub_lemma1:
    "\<lbrakk>chain Y; (\<Squnion>i. Y i) = a\<leadsto>s\<rbrakk> \<Longrightarrow> \<exists>j t. Y j = a\<leadsto>t"
apply (case_tac "max_in_chain i Y")
apply  (drule (1) lub_finch1 [THEN lub_eqI, THEN sym])
apply  (force)
apply (unfold max_in_chain_def)
apply auto
apply (frule (1) chain_mono)
apply (rule_tac x="Y j" in fstream_cases)
apply  (force)
apply (drule_tac x="j" in is_ub_thelub)
apply (force)
done

lemma fstream_lub_lemma:
      "\<lbrakk>chain Y; (\<Squnion>i. Y i) = a\<leadsto>s\<rbrakk> \<Longrightarrow> (\<exists>j t. Y j = a\<leadsto>t) \<and> (\<exists>X. chain X \<and> (\<forall>i. \<exists>j. Y j = a\<leadsto>X i) \<and> (\<Squnion>i. X i) = s)"
apply (frule (1) fstream_lub_lemma1)
apply (clarsimp)
apply (rule_tac x="\<lambda>i. rt\<cdot>(Y(i+j))" in exI)
apply (rule conjI)
apply  (erule chain_shift [THEN chain_monofun])
apply safe
apply  (drule_tac i="j" and j="i+j" in chain_mono)
apply   (simp)
apply  (simp)
apply  (rule_tac x="i+j" in exI)
apply  (drule fstream_prefix)
apply  (clarsimp)
apply  (subst lub_APP)
apply   (rule chainI)
apply   (fast)
apply  (erule chain_shift)
apply (subst lub_const)
apply (subst lub_range_shift)
apply  (assumption)
apply (simp)
done

end