\<^marker>\<open>creator "Johannes Hölzl"\<close>
(* MH: This theory seems do be obsolete. There is HOL-Analysis.Measurable_Space *)
theory Measurable_Space
  imports "HOL-Probability.Probability"
begin

subsection \<open>Typeclass for measurable spaces\<close>

lemma borel_measurable_max[measurable (raw)]:
  fixes f g :: "'a \<Rightarrow> 'b::{second_countable_topology, linorder_topology}"
  shows "f \<in> borel_measurable M \<Longrightarrow> g \<in> borel_measurable M \<Longrightarrow> (\<lambda>x. max (g x) (f x)) \<in> borel_measurable M"
  by (intro borel_measurableI_less) auto

lemma borel_measurable_min[measurable (raw)]:
  fixes f g :: "'a \<Rightarrow> 'b::{second_countable_topology, linorder_topology}"
  shows "f \<in> borel_measurable M \<Longrightarrow> g \<in> borel_measurable M \<Longrightarrow> (\<lambda>x. min (g x) (f x)) \<in> borel_measurable M"
  by (intro borel_measurableI_less) (auto simp: min_less_iff_disj)

lemma borel_measurable_SUP[measurable (raw)]:
  fixes F :: "_ \<Rightarrow> _ \<Rightarrow> _::{countable_complete_lattice, linorder_topology, second_countable_topology}"
  assumes [simp]: "countable I"
  assumes [measurable]: "\<And>i. i \<in> I \<Longrightarrow> F i \<in> borel_measurable M"
  shows "(\<lambda>x. SUP i:I. F i x) \<in> borel_measurable M"
  by (rule borel_measurableI_greater) (simp add: less_ccSUP_iff)

lemma borel_measurable_INF[measurable (raw)]:
  fixes F :: "_ \<Rightarrow> _ \<Rightarrow> _::{countable_complete_lattice, linorder_topology, second_countable_topology}"
  assumes [simp]: "countable I"
  assumes [measurable]: "\<And>i. i \<in> I \<Longrightarrow> F i \<in> borel_measurable M"
  shows "(\<lambda>x. INF i:I. F i x) \<in> borel_measurable M"
  by (rule borel_measurableI_less) (simp add: ccINF_less_iff)

class measurable_space =
  fixes measurable_space :: "'a measure"
  assumes space_measurable_space[simp]: "space measurable_space = UNIV"

class borel_space = topological_space + measurable_space +
  assumes measurable_space_eq_borel: "measurable_space = borel"

instantiation real :: borel_space
begin

definition measurable_space_real :: "real measure"
  where "(measurable_space :: real measure) = borel"

instance by standard (simp_all add: measurable_space_real_def borel_def)

end

instantiation ereal :: borel_space
begin

definition measurable_space_ereal :: "ereal measure"
  where "(measurable_space :: ereal measure) = borel"

instance by standard (simp_all add: measurable_space_ereal_def borel_def)

end

instantiation ennreal :: borel_space
begin

definition measurable_space_ennreal :: "ennreal measure"
  where "(measurable_space :: ennreal measure) = borel"

instance by standard (simp_all add: measurable_space_ennreal_def borel_def)

end

instantiation stream :: (measurable_space) measurable_space
begin

definition measurable_space_stream :: "'a stream measure"
  where "(measurable_space :: 'a stream measure) = stream_space measurable_space"

instance by standard (simp add: measurable_space_stream_def space_stream_space)

end

instantiation bool :: borel_space
begin

definition measurable_space_bool :: "bool measure"
  where "(measurable_space :: bool measure) = borel"

instance by standard (simp_all add: measurable_space_bool_def borel_def)

end

instantiation enat :: borel_space
begin

definition measurable_space_enat :: "enat measure"
  where "(measurable_space :: enat measure) = borel"

instance by standard (simp_all add: measurable_space_enat_def borel_def)

end

instantiation nat :: borel_space
begin

definition measurable_space_nat :: "nat measure"
  where "(measurable_space :: nat measure) = borel"

instance by standard (simp_all add: measurable_space_nat_def borel_def)

end

subsection \<open>Type of measurable functions\<close>

typedef (overloaded) ('a, 'b) measurable_fun =
  "measurable measurable_space measurable_space :: ('a::measurable_space \<Rightarrow> 'b::measurable_space) set"
  by (intro exI[of _ "\<lambda>x. undefined"]) auto
setup_lifting type_definition_measurable_fun

instantiation measurable_fun :: (measurable_space, "{order, measurable_space}") order
begin

lift_definition less_eq_measurable_fun :: "('a, 'b) measurable_fun \<Rightarrow> ('a, 'b) measurable_fun \<Rightarrow> bool"
  is "op \<le>" .

lift_definition less_measurable_fun :: "('a, 'b) measurable_fun \<Rightarrow> ('a, 'b) measurable_fun \<Rightarrow> bool"
  is "op <" .

instance
  by standard (transfer ; auto)+
end

instantiation measurable_fun :: (measurable_space, "{order_bot, measurable_space}") order_bot
begin

lift_definition bot_measurable_fun :: "('a, 'b) measurable_fun" is "bot"
  by (simp add: bot_fun_def)

instance
  proof qed (transfer; auto)
end

instantiation measurable_fun :: (measurable_space, "{order_top, measurable_space}") order_top
begin

lift_definition top_measurable_fun :: "('a, 'b) measurable_fun" is "top"
  by (simp add: top_fun_def)

instance
  proof qed (transfer; auto)
end

instantiation measurable_fun :: (measurable_space, "{second_countable_topology, linorder_topology, borel_space}") lattice
begin

lift_definition sup_measurable_fun :: "('a, 'b) measurable_fun \<Rightarrow> ('a, 'b) measurable_fun \<Rightarrow> ('a, 'b) measurable_fun"
  is "\<lambda>f g x. max (f x) (g x)" by (auto simp: measurable_space_eq_borel)

lift_definition inf_measurable_fun :: "('a, 'b) measurable_fun \<Rightarrow> ('a, 'b) measurable_fun \<Rightarrow> ('a, 'b) measurable_fun"
  is "\<lambda>f g x. min (f x) (g x)" by (auto simp: measurable_space_eq_borel)

instance
  by standard (transfer; auto simp: le_fun_def)+
end

instantiation measurable_fun :: (measurable_space, "{second_countable_topology, countable_complete_lattice, linorder_topology, borel_space}") countable_complete_lattice
begin

lift_definition Sup_measurable_fun :: "('a, 'b) measurable_fun set \<Rightarrow> ('a, 'b) measurable_fun"
  is "\<lambda>A x. if countable A then SUP f:A. f x else top"
proof -
  fix A :: "('a \<Rightarrow> 'b) set" assume "\<And>f. f \<in> A \<Longrightarrow> f \<in> measurable_space \<rightarrow>\<^sub>M measurable_space"
  then show "(\<lambda>x. if countable A then SUP f:A. f x else top) \<in> measurable_space \<rightarrow>\<^sub>M measurable_space"
    by (cases "countable A") (auto simp: measurable_space_eq_borel)
qed

lift_definition Inf_measurable_fun :: "('a, 'b) measurable_fun set \<Rightarrow> ('a, 'b) measurable_fun"
  is "\<lambda>A x. if countable A then INF f:A. f x else bot"
proof -
  fix A :: "('a \<Rightarrow> 'b) set" assume "\<And>f. f \<in> A \<Longrightarrow> f \<in> measurable_space \<rightarrow>\<^sub>M measurable_space"
  then show "(\<lambda>x. if countable A then INF f : A. f x else bot) \<in> measurable_space \<rightarrow>\<^sub>M measurable_space"
    by (cases "countable A") (auto simp: measurable_space_eq_borel)
qed

instance
  by standard
     (transfer; auto simp add: le_fun_def intro: ccSUP_least ccSUP_upper ccINF_lower ccINF_greatest)+
end

lift_definition "integral_mf" :: "'a::measurable_space measure \<Rightarrow> ('a, ennreal) measurable_fun \<Rightarrow> ennreal" is
  nn_integral .

definition "rel_ne_countable = eq_onp (\<lambda>X. X \<noteq> {} \<and> countable X)"

lemma rel_ne_countable_UNIV_nat [transfer_rule]: "rel_ne_countable UNIV (UNIV::nat set)"
  by (auto simp: rel_ne_countable_def eq_onp_def)

lemma SUP_ennreal_transfer [transfer_rule]:
  "rel_fun rel_ne_countable (rel_fun (rel_fun op = pcr_ennreal) pcr_ennreal) SUPREMUM SUPREMUM"
  unfolding rel_fun_def rel_ne_countable_def eq_onp_def
  apply (auto simp: ennreal.pcr_cr_eq cr_ennreal_def Sup_ennreal.rep_eq)
  apply (subst (asm) max.absorb2)
  apply (auto intro: enn2ereal_nonneg SUP_upper2)
  done

lemma less_eq_measurable_ennreal_transfer[transfer_rule]:
  "rel_fun (pcr_measurable_fun op = pcr_ennreal) (rel_fun (pcr_measurable_fun op = pcr_ennreal) op =) op \<le> op \<le>"
  by (auto simp: rel_fun_def pcr_measurable_fun_def cr_measurable_fun_def le_fun_def cr_ennreal_def
                 ennreal.pcr_cr_eq less_eq_ennreal.rep_eq[symmetric] less_eq_measurable_fun.rep_eq)

lemma SUP_measurable_ennreal_transfer [transfer_rule]:
  fixes Q
  assumes *: "rel_fun (rel_ne_countable :: 'a set \<Rightarrow> 'a set \<Rightarrow> bool) (rel_fun (rel_fun op = R) R) SUPREMUM SUPREMUM"
  defines "M \<equiv> pcr_measurable_fun Q R"
  shows "rel_fun (rel_ne_countable :: 'a set \<Rightarrow> 'a set \<Rightarrow> bool) (rel_fun (rel_fun op = M) M) SUPREMUM SUPREMUM"
proof -
  have M: "M f g \<longleftrightarrow> (\<forall>x y. Q x y \<longrightarrow> R (f x) (Rep_measurable_fun g y))" for f g
    by (auto simp: M_def pcr_measurable_fun_def cr_measurable_fun_def
      ennreal.pcr_cr_eq cr_ennreal_def rel_fun_def relcompp.simps )
  show ?thesis
    unfolding rel_fun_def rel_ne_countable_def eq_onp_def Sup_measurable_fun.rep_eq M
    by (auto intro!: rel_funD[OF *, THEN rel_funD] simp: rel_ne_countable_def eq_onp_def)
qed

lemma rel_fun_pcr_ennreal_iff: "rel_fun op = pcr_ennreal f g \<longleftrightarrow> f = enn2ereal \<circ> g"
  by (auto simp: rel_fun_def ennreal.pcr_cr_eq cr_ennreal_def)

lemma sup_continuous_integral_mf:
  assumes [simp, measurable_cong]: "sets M = sets measurable_space"
  shows "sup_continuous (integral_mf M)"
  unfolding sup_continuous_def incseq_def
proof (transfer fixing: M, clarsimp simp: rel_fun_pcr_ennreal_iff)
  fix C :: "nat \<Rightarrow> 'a \<Rightarrow> ereal"
  assume "\<forall>i. \<exists>f. C i = enn2ereal \<circ> f \<and> f \<in> measurable_space \<rightarrow>\<^sub>M measurable_space"
  then obtain F where C: "\<And>i. C i = enn2ereal \<circ> F i" and F: "\<And>i. F i \<in> measurable_space \<rightarrow>\<^sub>M measurable_space"
    by metis
  assume "\<forall>m n. m \<le> n \<longrightarrow> C m \<le> C n"
  then show "integral\<^sup>N M (SUP x. C x) = (SUP i. integral\<^sup>N M (C i))"
    unfolding C using F
    by (subst nn_integral_monotone_convergence_SUP[symmetric])
       (auto simp: incseq_def o_def measurable_space_eq_borel
             cong: measurable_cong_sets intro!: nn_integral_cong)
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_propositional_AndCommutative
  imports "../../Test_Base"
begin

datatype ('a, 'b) pair = pair2 "'a" "'b"

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Form = x "Form" "Form" | Not "Form" | Var "int"

fun y :: "'a list => 'a list => 'a list" where
  "y (nil2) y2 = y2"
| "y (cons2 z2 xs) y2 = cons2 z2 (y xs y2)"

fun or2 :: "bool list => bool" where
  "or2 (nil2) = False"
| "or2 (cons2 y2 xs) = (y2 | (or2 xs))"

fun models7 :: "int => ((int, bool) pair) list =>
                ((int, bool) pair) list" where
  "models7 z (nil2) = nil2"
| "models7 z (cons2 z2 xs) =
     (if (z ~= (case z2 of pair2 x2 y22 => x2)) then
        cons2 z2 (models7 z xs)
        else
        models7 z xs)"

fun models6 :: "int => ((int, bool) pair) list => bool list" where
  "models6 z (nil2) = nil2"
| "models6 z (cons2 (pair2 y22 True) x2) = models6 z x2"
| "models6 z (cons2 (pair2 y22 False) x2) =
     cons2 (z = y22) (models6 z x2)"

fun models5 :: "int => ((int, bool) pair) list =>
                ((int, bool) pair) list" where
  "models5 z (nil2) = nil2"
| "models5 z (cons2 z2 xs) =
     (if (z ~= (case z2 of pair2 x2 y22 => x2)) then
        cons2 z2 (models5 z xs)
        else
        models5 z xs)"

fun models4 :: "int => ((int, bool) pair) list => bool list" where
  "models4 z (nil2) = nil2"
| "models4 z (cons2 (pair2 y22 True) x2) =
     cons2 (z = y22) (models4 z x2)"
| "models4 z (cons2 (pair2 y22 False) x2) = models4 z x2"

function models :: "(((int, bool) pair) list) list => Form =>
                    (((int, bool) pair) list) list => (((int, bool) pair) list) list"
  and
  models2 :: "Form => (((int, bool) pair) list) list =>
                     (((int, bool) pair) list) list"
  and
  models3 :: "Form => ((int, bool) pair) list =>
                     (((int, bool) pair) list) list" where
  "models z q (nil2) = models2 q z"
| "models z q (cons2 z2 x2) = cons2 z2 (models z q x2)"
| "models2 q (nil2) = nil2"
| "models2 q (cons2 y2 z2) = models z2 q (models3 q y2)"
| "models3 (x p q) y2 = models2 q (models3 p y2)"
| "models3 (Not (x r q2)) y2 =
     y (models3 (Not r) y2) (models3 (x r (Not q2)) y2)"
| "models3 (Not (Not p2)) y2 = models3 p2 y2"
| "models3 (Not (Var x2)) y2 =
     (if (~ (or2 (models4 x2 y2))) then
        cons2 (cons2 (pair2 x2 False) (models5 x2 y2)) (nil2)
        else
        nil2)"
| "models3 (Var x3) y2 =
     (if (~ (or2 (models6 x3 y2))) then
        cons2 (cons2 (pair2 x3 True) (models7 x3 y2)) (nil2)
        else
        nil2)"
  by pat_completeness auto

fun valid :: "Form => bool" where
  "valid z =
   (case models3 (Not z) (nil2) of
      nil2 => True
      | cons2 y2 z2 => False)"

theorem property0 :
  "((valid (x p q)) = (valid (x q p)))"
  oops

end


subsubsection \<open>Preliminary: Register machine sums are Diophantine\<close>

theory Register_Machine_Sums imports Diophantine_Relations
                                     "../Register_Machine/RegisterMachineSimulation"

begin

fun sum_polynomial :: "(nat \<Rightarrow> polynomial) \<Rightarrow> nat list \<Rightarrow> polynomial" where
  "sum_polynomial f [] = Const 0" |
  "sum_polynomial f (i#idxs) = f i [+] sum_polynomial f idxs"

lemma sum_polynomial_eval:
  "peval (sum_polynomial f idxs) a = (\<Sum>k=0..<length idxs. peval (f (idxs!k)) a)"
proof (induction "idxs" rule: List.rev_induct)
  case Nil
  then show ?case by auto
next
  case (snoc x xs)
  moreover have suc: "peval (sum_polynomial f (xs @ [x])) a = peval (sum_polynomial f (x # xs)) a"
    by (induction xs, auto)
  moreover have list_property: "xa < length xs \<Longrightarrow> (xs ! xa) = (xs @ [x]) ! xa" for xa
    by (simp add: nth_append)
  ultimately show ?case by auto
qed

definition sum_program :: "program \<Rightarrow> (nat \<Rightarrow> polynomial) \<Rightarrow> polynomial"
  ("[\<Sum>_] _" [100, 100] 100) where
  "[\<Sum>p] f \<equiv> sum_polynomial f [0..<length p]"

lemma sum_program_push: "m = length ns \<Longrightarrow> length l = length p \<Longrightarrow>
  peval ([\<Sum>p] (\<lambda>k. if g k then map (\<lambda>x. push_param x m) l ! k else h k)) (push_list a ns)
    = peval ([\<Sum>p] (\<lambda>k. if g k then l ! k else h k)) a"
  unfolding sum_program_def apply (induction p, auto)
  oops

definition sum_radd_polynomial :: "program \<Rightarrow> register \<Rightarrow> (nat \<Rightarrow> polynomial) \<Rightarrow> polynomial"
  ("[\<Sum>R+] _ _ _") where
  "[\<Sum>R+] p l f \<equiv> [\<Sum>p] (\<lambda>k. if isadd (p!k) \<and> l = modifies (p!k) then f k else Const 0)"

lemma sum_radd_polynomial_eval[defs]:
  assumes "length p > 0"
  shows "peval ([\<Sum>R+] p l f) a = (\<Sum>R+ p l (\<lambda>x. peval (f x) a))"
proof -
  have 1: "x \<le> length p - Suc 0 \<Longrightarrow> x < length p" for x using assms by linarith
  have 2: "x \<le> length p - Suc 0 \<Longrightarrow> peval (f ([0..<length p] ! x)) a = peval (f x) a" for x
    using assms
    by (metis diff_Suc_less less_imp_diff_less less_le_not_le nat_neq_iff nth_upt plus_nat.add_0)
  show ?thesis
  unfolding sum_radd_polynomial_def sum_program_def sum_radd.simps sum_polynomial_eval
  by (auto, rule sum.cong, auto simp: 1 2)
qed

definition sum_rsub_polynomial :: "program \<Rightarrow> register \<Rightarrow> (nat \<Rightarrow> polynomial) \<Rightarrow> polynomial"
  ("[\<Sum>R-] _ _ _") where
  "[\<Sum>R-] p l f \<equiv> [\<Sum>p] (\<lambda>k. if issub (p!k) \<and> l = modifies (p!k) then f k else Const 0)"

lemma sum_rsub_polynomial_eval[defs]:
  assumes "length p > 0"
  shows "peval ([\<Sum>R-] p l f) a = (\<Sum>R- p l (\<lambda>x. peval (f x) a))"
proof -
  have 1: "x \<le> length p - Suc 0 \<Longrightarrow> x < length p" for x using assms by linarith
  have 2: "x \<le> length p - Suc 0 \<Longrightarrow> peval (f ([0..<length p] ! x)) a = peval (f x) a" for x
    using assms
    by (metis diff_Suc_less less_imp_diff_less less_le_not_le nat_neq_iff nth_upt plus_nat.add_0)
  show ?thesis
  unfolding sum_rsub_polynomial_def sum_program_def sum_rsub.simps sum_polynomial_eval
  by (auto, rule sum.cong, auto simp: 1 2)
qed

definition sum_sadd_polynomial :: "program \<Rightarrow> state \<Rightarrow> (nat \<Rightarrow> polynomial) \<Rightarrow> polynomial"
  ("[\<Sum>S+] _ _ _") where
  "[\<Sum>S+] p d f \<equiv> [\<Sum>p] (\<lambda>k. if isadd (p!k) \<and> d = goes_to (p!k) then f k else Const 0)"

lemma sum_sadd_polynomial_eval[defs]:
  assumes "length p > 0"
  shows "peval ([\<Sum>S+] p d f) a = (\<Sum>S+ p d (\<lambda>x. peval (f x) a))"
proof -
  have 1: "x \<le> length p - Suc 0 \<Longrightarrow> x < length p" for x using assms by linarith
  have 2: "x \<le> length p - Suc 0 \<Longrightarrow> peval (f ([0..<length p] ! x)) a = peval (f x) a" for x
    using assms
    by (metis diff_Suc_less less_imp_diff_less less_le_not_le nat_neq_iff nth_upt plus_nat.add_0)
  show ?thesis
  unfolding sum_sadd_polynomial_def sum_program_def sum_sadd.simps sum_polynomial_eval
  by (auto, rule sum.cong, auto simp: 1 2)
qed

definition sum_ssub_nzero_polynomial :: "program \<Rightarrow> state \<Rightarrow> (nat \<Rightarrow> polynomial) \<Rightarrow> polynomial"
  ("[\<Sum>S-] _ _ _") where
  "[\<Sum>S-] p d f \<equiv> [\<Sum>p] (\<lambda>k. if issub (p!k) \<and> d = goes_to (p!k) then f k else Const 0)"

lemma sum_ssub_nzero_polynomial_eval[defs]:
  assumes "length p > 0"
  shows "peval ([\<Sum>S-] p d f) a = (\<Sum>S- p d (\<lambda>x. peval (f x) a))"
proof -
  have 1: "x \<le> length p - Suc 0 \<Longrightarrow> x < length p" for x using assms by linarith
  have 2: "x \<le> length p - Suc 0 \<Longrightarrow> peval (f ([0..<length p] ! x)) a = peval (f x) a" for x
    using assms
    by (metis diff_Suc_less less_imp_diff_less less_le_not_le nat_neq_iff nth_upt plus_nat.add_0)
  show ?thesis
  unfolding sum_ssub_nzero_polynomial_def sum_program_def sum_ssub_nzero.simps sum_polynomial_eval
  by (auto, rule sum.cong, auto simp: 1 2)
qed

definition sum_ssub_zero_polynomial :: "program \<Rightarrow> state \<Rightarrow> (nat \<Rightarrow> polynomial) \<Rightarrow> polynomial"
  ("[\<Sum>S0] _ _ _") where
  "[\<Sum>S0] p d f \<equiv> [\<Sum>p] (\<lambda>k. if issub (p!k) \<and> d = goes_to_alt (p!k) then f k else Const 0)"

lemma sum_ssub_zero_polynomial_eval[defs]:
  assumes "length p > 0"
  shows "peval ([\<Sum>S0] p d f) a = (\<Sum>S0 p d (\<lambda>x. peval (f x) a))"
proof -
  have 1: "x \<le> length p - Suc 0 \<Longrightarrow> x < length p" for x using assms by linarith
  have 2: "x \<le> length p - Suc 0 \<Longrightarrow> peval (f ([0..<length p] ! x)) a = peval (f x) a" for x
    using assms
    by (metis diff_Suc_less less_imp_diff_less less_le_not_le nat_neq_iff nth_upt plus_nat.add_0)
  show ?thesis
  unfolding sum_ssub_zero_polynomial_def sum_program_def sum_ssub_zero.simps sum_polynomial_eval
  by (auto, rule sum.cong, auto simp: 1 2)
qed

end


(*  Title:      HOL/HOLCF/IOA/LiveIOA.thy
    Author:     Olaf Müller
*)

section \<open>Live I/O automata -- specified by temproal formulas\<close>

theory LiveIOA
imports TLS
begin

default_sort type

type_synonym ('a, 's) live_ioa = "('a, 's)ioa \<times> ('a, 's) ioa_temp"

definition validLIOA :: "('a, 's) live_ioa \<Rightarrow> ('a, 's) ioa_temp \<Rightarrow> bool"
  where "validLIOA AL P \<longleftrightarrow> validIOA (fst AL) (snd AL \<^bold>\<longrightarrow> P)"

definition WF :: "('a, 's) ioa \<Rightarrow> 'a set \<Rightarrow> ('a, 's) ioa_temp"
  where "WF A acts = (\<diamond>\<box>\<langle>\<lambda>(s,a,t). Enabled A acts s\<rangle> \<^bold>\<longrightarrow> \<box>\<diamond>\<langle>xt2 (plift (\<lambda>a. a \<in> acts))\<rangle>)"

definition SF :: "('a, 's) ioa \<Rightarrow> 'a set \<Rightarrow> ('a, 's) ioa_temp"
  where "SF A acts = (\<box>\<diamond>\<langle>\<lambda>(s,a,t). Enabled A acts s\<rangle> \<^bold>\<longrightarrow> \<box>\<diamond>\<langle>xt2 (plift (\<lambda>a. a \<in> acts))\<rangle>)"

definition liveexecutions :: "('a, 's) live_ioa \<Rightarrow> ('a, 's) execution set"
  where "liveexecutions AP = {exec. exec \<in> executions (fst AP) \<and> (exec \<TTurnstile> snd AP)}"

definition livetraces :: "('a, 's) live_ioa \<Rightarrow> 'a trace set"
  where "livetraces AP = {mk_trace (fst AP) \<cdot> (snd ex) |ex. ex \<in> liveexecutions AP}"

definition live_implements :: "('a, 's1) live_ioa \<Rightarrow> ('a, 's2) live_ioa \<Rightarrow> bool"
  where "live_implements CL AM \<longleftrightarrow>
    inp (fst CL) = inp (fst AM) \<and> out (fst CL) = out (fst AM) \<and>
      livetraces CL \<subseteq> livetraces AM"

definition is_live_ref_map :: "('s1 \<Rightarrow> 's2) \<Rightarrow> ('a, 's1) live_ioa \<Rightarrow> ('a, 's2) live_ioa \<Rightarrow> bool"
  where "is_live_ref_map f CL AM \<longleftrightarrow>
    is_ref_map f (fst CL ) (fst AM) \<and>
    (\<forall>exec \<in> executions (fst CL). (exec \<TTurnstile> (snd CL)) \<longrightarrow>
      (corresp_ex (fst AM) f exec \<TTurnstile> snd AM))"

lemma live_implements_trans:
  "live_implements (A, LA) (B, LB) \<Longrightarrow> live_implements (B, LB) (C, LC) \<Longrightarrow>
    live_implements (A, LA) (C, LC)"
  by (auto simp: live_implements_def)

subsection \<open>Correctness of live refmap\<close>

lemma live_implements:
  "inp C = inp A \<Longrightarrow> out C = out A \<Longrightarrow> is_live_ref_map f (C, M) (A, L)
    \<Longrightarrow> live_implements (C, M) (A, L)"
  apply (simp add: is_live_ref_map_def live_implements_def livetraces_def liveexecutions_def)
  apply auto
  apply (rule_tac x = "corresp_ex A f ex" in exI)
  apply auto
  text \<open>Traces coincide, Lemma 1\<close>
  apply (pair ex)
  apply (erule lemma_1 [THEN spec, THEN mp])
  apply (simp (no_asm) add: externals_def)
  apply (auto)[1]
  apply (simp add: executions_def reachable.reachable_0)
  text \<open>\<open>corresp_ex\<close> is execution, Lemma 2\<close>
  apply (pair ex)
  apply (simp add: executions_def)
  text \<open>start state\<close>
  apply (rule conjI)
  apply (simp add: is_ref_map_def corresp_ex_def)
  text \<open>\<open>is_execution_fragment\<close>\<close>
  apply (erule lemma_2 [THEN spec, THEN mp])
  apply (simp add: reachable.reachable_0)
  done

end


(* Author: Dmitriy Traytel *)

header {* Derivatives of $\Pi$-Extended Regular Expressions *}
(*<*)
theory Pi_Derivatives
imports Pi_Regular_Exp
begin
(*>*)

locale embed = project \<Sigma> wf_atom project lookup
  for \<Sigma> :: "nat \<Rightarrow> 'a set"
  and wf_atom :: "nat \<Rightarrow> 'b :: linorder \<Rightarrow> bool"
  and project :: "'a \<Rightarrow> 'a"
  and lookup :: "'b \<Rightarrow> 'a \<Rightarrow> bool" +
fixes embed :: "'a \<Rightarrow> 'a list"
assumes embed: "\<And>a. a \<in> \<Sigma> n \<Longrightarrow> b \<in> set (embed a) = (b \<in> \<Sigma> (Suc n) \<and> project b = a)"
begin

subsection {* Syntactic Derivatives *}

primrec lderiv :: "'a \<Rightarrow> 'b rexp \<Rightarrow> 'b rexp" where
  "lderiv _ Zero = Zero"
| "lderiv _ Full = Full"
| "lderiv _ One = Zero"
| "lderiv a (Atom b) = (if lookup b a then One else Zero)"
| "lderiv a (Plus r s) = Plus (lderiv a r) (lderiv a s)"
| "lderiv a (Times r s) =
    (let r's = Times (lderiv a r) s
     in if final r then Plus r's (lderiv a s) else r's)"
| "lderiv a (Star r) = Times (lderiv a r) (Star r)"
| "lderiv a (Not r) = Not (lderiv a r)"
| "lderiv a (Inter r s) = Inter (lderiv a r) (lderiv a s)"
| "lderiv a (Pr r) = Pr (PLUS (map (\<lambda>a'. lderiv a' r) (embed a)))"

primrec lderivs where
  "lderivs [] r = r"
| "lderivs (w#ws) r = lderivs ws (lderiv w r)"

subsection {* Finiteness of ACI-Equivalent Derivatives *}

lemma toplevel_summands_lderiv:
  "toplevel_summands (lderiv as r) = (\<Union>s\<in>toplevel_summands r. toplevel_summands (lderiv as s))"
  by (induct r) (auto simp: Let_def)

lemma lderivs_Zero[simp]: "lderivs xs Zero = Zero"
  by (induct xs) auto

lemma lderivs_Full[simp]: "lderivs xs Full = Full"
  by (induct xs) auto

lemma lderivs_One: "lderivs xs One \<in> {Zero, One}"
  by (induct xs) auto

lemma lderivs_Atom: "lderivs xs (Atom as) \<in> {Zero, One, Atom as}"
proof (induct xs)
  case (Cons x xs) thus ?case by (auto intro: insertE[OF lderivs_One])
qed simp

lemma lderivs_Plus: "lderivs xs (Plus r s) = Plus (lderivs xs r) (lderivs xs s)"
  by (induct xs arbitrary: r s) auto

lemma lderivs_PLUS: "lderivs xs (PLUS ys) = PLUS (map (lderivs xs) ys)"
  by (induct ys rule: list_singleton_induct) (auto simp: lderivs_Plus)

lemma toplevel_summands_lderivs_Times: "toplevel_summands (lderivs xs (Times r s)) \<subseteq>
  {Times (lderivs xs r) s} \<union>
  {r'. \<exists>ys zs. r' \<in> toplevel_summands (lderivs ys s) \<and> ys \<noteq> [] \<and> zs @ ys = xs}"
proof (induct xs arbitrary: r s)
  case (Cons x xs)
  thus ?case by (auto simp: Let_def lderivs_Plus) (fastforce intro: exI[of _ "x#xs"])+
qed simp

lemma toplevel_summands_lderivs_Star_nonempty:
  "xs \<noteq> [] \<Longrightarrow> toplevel_summands (lderivs xs (Star r)) \<subseteq>
    {Times (lderivs ys r) (Star r) | ys. \<exists>zs. ys \<noteq> [] \<and> zs @ ys = xs}"
proof (induct xs rule: length_induct)
  case (1 xs)
  then obtain y ys where "xs = y # ys" by (cases xs) auto
  thus ?case using spec[OF 1(1)]
    by (auto dest!: subsetD[OF toplevel_summands_lderivs_Times] intro: exI[of _ "y#ys"])
       (auto elim!: impE dest!: meta_spec subsetD)
qed

lemma toplevel_summands_lderivs_Star:
  "toplevel_summands (lderivs xs (Star r)) \<subseteq>
    {Star r} \<union> {Times (lderivs ys r) (Star r) | ys. \<exists>zs. ys \<noteq> [] \<and> zs @ ys = xs}"
  by (cases "xs = []") (auto dest!: toplevel_summands_lderivs_Star_nonempty)

lemma ex_lderivs_Pr: "\<exists>s. lderivs ass (Pr r) = Pr s"
  by (induct ass arbitrary: r) auto

lemma toplevel_summands_PLUS:
 "xs \<noteq> [] \<Longrightarrow> toplevel_summands (PLUS (map f xs)) = (\<Union>r \<in> set xs. toplevel_summands (f r))"
  by (induct xs rule: list_singleton_induct) simp_all

lemma lderiv_toplevel_summands_Zero:
  "\<lbrakk>lderivs xs (Pr r) = Pr s; toplevel_summands r = {Zero}\<rbrakk> \<Longrightarrow> toplevel_summands s = {Zero}"
proof (induct xs arbitrary: r s)
  case (Cons y ys)
  from Cons.prems(1) have "toplevel_summands (PLUS (map (\<lambda>a. lderiv a r) (embed y))) = {Zero}"
  proof (cases "embed y = []")
    case False
    show ?thesis using Cons.prems(2) unfolding toplevel_summands_PLUS[OF False]
      by (subst toplevel_summands_lderiv) (simp add: False)
  qed simp
  with Cons show ?case by simp
qed simp

lemma toplevel_summands_lderivs_Pr:
  "\<lbrakk>xs \<noteq> []; lderivs xs (Pr r) = Pr s\<rbrakk> \<Longrightarrow>
    toplevel_summands s \<subseteq> {Zero} \<or> toplevel_summands s \<subseteq> (\<Union>xs. toplevel_summands (lderivs xs r))"
proof (induct xs arbitrary: r s)
  case (Cons y ys) note * = this
  show ?case
  proof (cases "embed y = []")
    case True with Cons show ?thesis by (cases "ys = []") (auto dest: lderiv_toplevel_summands_Zero)
  next
    case False
    show ?thesis
    proof (cases ys)
      case Nil with * show ?thesis
        by (auto simp: toplevel_summands_PLUS[OF False]) (metis lderivs.simps)
    next
      case (Cons z zs)
      have "toplevel_summands s \<subseteq> {Zero} \<or> toplevel_summands s \<subseteq>
       (\<Union>xs. toplevel_summands (lderivs xs (PLUS (map (\<lambda>a. lderiv a r) (embed y)))))" (is "_ \<or> ?B")
        by (rule *(1)) (auto simp: Cons *(3)[symmetric])
      thus ?thesis
      proof
        assume ?B
        also have "\<dots> \<subseteq> (\<Union>xs. toplevel_summands (lderivs xs r))"
          by (auto simp: lderivs_PLUS toplevel_summands_PLUS[OF False]) (metis lderivs.simps(2))
        finally show ?thesis ..
      qed blast
    qed
  qed
qed simp

lemma lderivs_Pr:
  "{lderivs xs (Pr r) | xs. True} \<subseteq>
    {Pr s | s. toplevel_summands s \<subseteq> {Zero} \<or>
               toplevel_summands s \<subseteq> (\<Union>xs. toplevel_summands (lderivs xs r))}"
  (is "?L \<subseteq>?R")
proof (rule subsetI)
  fix s assume "s \<in> ?L"
  then obtain xs where "s = lderivs xs (Pr r)" by blast
  moreover obtain t where "lderivs xs (Pr r) = Pr t" using ex_lderivs_Pr by blast
  ultimately show "s \<in> ?R"
    by (cases "xs = []") (auto dest!: toplevel_summands_lderivs_Pr elim!: allE[of _ "[]"])
qed

lemma ACI_norm_toplevel_summands_Zero: "toplevel_summands r \<subseteq> {Zero} \<Longrightarrow> \<guillemotleft>r\<guillemotright> = Zero"
  by (subst ACI_norm_flatten) (auto dest: subset_singletonD)

lemma ACI_norm_lderivs_Pr:
  "ACI_norm ` {lderivs xs (Pr r) | xs. True} \<subseteq>
    {Pr Zero} \<union> {Pr \<guillemotleft>s\<guillemotright> | s. toplevel_summands s \<subseteq> (\<Union>xs. toplevel_summands \<guillemotleft>lderivs xs r\<guillemotright>)}"
proof (intro subset_trans[OF image_mono[OF lderivs_Pr]] subsetI,
       elim imageE CollectE exE conjE disjE)
  fix x x' s :: "'b rexp"
  assume *: "x = \<guillemotleft>x'\<guillemotright>" "x' = Pr s" and "toplevel_summands s \<subseteq> {Zero}"
  hence "\<guillemotleft>Pr s\<guillemotright> = Pr Zero" using ACI_norm_toplevel_summands_Zero by simp
  thus "x \<in> {Pr Zero} \<union>
    {Pr \<guillemotleft>s\<guillemotright> |s. toplevel_summands s \<subseteq> (\<Union>xs. toplevel_summands \<guillemotleft>lderivs xs r\<guillemotright>)}"
    unfolding * by blast
next
  fix x x' s :: "'b rexp"
  assume *: "x = \<guillemotleft>x'\<guillemotright>" "x' = Pr s" and "toplevel_summands s \<subseteq> (\<Union>xs. toplevel_summands (lderivs xs r))"
  hence "toplevel_summands \<guillemotleft>s\<guillemotright> \<subseteq> (\<Union>xs. toplevel_summands \<guillemotleft>lderivs xs r\<guillemotright>)"
    by (fastforce simp: toplevel_summands_ACI_norm)
  moreover have "x = Pr \<guillemotleft>\<guillemotleft>s\<guillemotright>\<guillemotright>" unfolding * ACI_norm_idem ACI_norm.simps(10) ..
  ultimately show "x \<in> {Pr Zero} \<union>
    {Pr \<guillemotleft>s\<guillemotright> |s. toplevel_summands s \<subseteq> (\<Union>xs. toplevel_summands \<guillemotleft>lderivs xs r\<guillemotright>)}"
    by blast
qed

lemma finite_ACI_norm_toplevel_summands: "finite B \<Longrightarrow> finite {f \<guillemotleft>s\<guillemotright> |s. toplevel_summands s \<subseteq> B}"
  by (elim finite_surj[OF iffD2[OF finite_Pow_iff], of _ _ "f o flatten PLUS o image ACI_norm"])
   (auto simp: Pow_def image_Collect ACI_norm_flatten)

lemma lderivs_Not: "lderivs xs (Not r) = Not (lderivs xs r)"
  by (induct xs arbitrary: r) auto

lemma lderivs_Inter: "lderivs xs (Inter r s) = Inter (lderivs xs r) (lderivs xs s)"
  by (induct xs arbitrary: r s) auto

theorem finite_lderivs: "finite {\<guillemotleft>lderivs xs r\<guillemotright> | xs . True}"
proof (induct r)
  case Zero show ?case by simp
next
  case Full show ?case by simp
next
  case One show ?case
   by (rule finite_surj[of "{Zero, One}"]) (blast intro: insertE[OF lderivs_One])+
next
  case (Atom as) show ?case
    by (rule finite_surj[of "{Zero, One, Atom as}"]) (blast intro: insertE[OF lderivs_Atom])+
next
  case (Plus r s)
  show ?case by (auto simp: lderivs_Plus intro!: finite_surj[OF finite_cartesian_product[OF Plus]])
next
  case (Times r s)
  hence "finite (\<Union> (toplevel_summands ` {\<guillemotleft>lderivs xs s\<guillemotright> | xs . True}))" by auto
  moreover have "{\<guillemotleft>r'\<guillemotright> |r'. \<exists>ys. r' \<in> toplevel_summands (local.lderivs ys s)} =
    {r'. \<exists>ys. r' \<in> toplevel_summands \<guillemotleft>local.lderivs ys s\<guillemotright>}"
    unfolding toplevel_summands_ACI_norm by auto
  ultimately have fin: "finite {\<guillemotleft>r'\<guillemotright> |r'. \<exists>ys. r' \<in> toplevel_summands (local.lderivs ys s)}"
    by (fastforce intro: finite_subset[of _ "\<Union> (toplevel_summands ` {\<guillemotleft>lderivs xs s\<guillemotright> | xs . True})"])
  let ?X = "\<lambda>xs. {Times (lderivs ys r) s | ys. True} \<union> {r'. r' \<in> (\<Union>ys. toplevel_summands (lderivs ys s))}"
  show ?case unfolding ACI_norm_flatten
  proof (rule finite_surj[of "{X. \<exists>xs. X \<subseteq> ACI_norm ` ?X xs}" _ "flatten PLUS"])
    show "finite {X. \<exists>xs. X \<subseteq> ACI_norm ` ?X xs}"
      using fin by (fastforce simp: image_Un elim: finite_subset[rotated] intro: finite_surj[OF Times(1), of _ "\<lambda>r. Times r \<guillemotleft>s\<guillemotright>"])
  qed (fastforce dest!: subsetD[OF toplevel_summands_lderivs_Times] intro!: imageI)
next
  case (Star r)
  let ?f = "\<lambda>f r'. Times r' (Star (f r))"
  let ?X = "{Star r} \<union> ?f id ` {r'. r' \<in> {lderivs ys r|ys. True}}"
  show ?case unfolding ACI_norm_flatten
  proof (rule finite_surj[of "{X. X \<subseteq> ACI_norm ` ?X}" _ "flatten PLUS"])
    have *: "\<And>X. ACI_norm ` ?f (\<lambda>x. x) ` X = ?f ACI_norm ` ACI_norm ` X" by (auto simp: image_def)
    show "finite {X. X \<subseteq> ACI_norm ` ?X}"
      by (rule finite_Collect_subsets)
         (auto simp: * intro!: finite_imageI[of _ "?f ACI_norm"] intro: finite_subset[OF _ Star])
  qed (fastforce dest!: subsetD[OF toplevel_summands_lderivs_Star] intro!: imageI)
next
  case (Not r) thus ?case by (auto simp: lderivs_Not) (blast intro: finite_surj)
next
  case (Inter r s)
  show ?case by (auto simp: lderivs_Inter intro!: finite_surj[OF finite_cartesian_product[OF Inter]])
next
  case (Pr r)
  hence *: "finite (\<Union> (toplevel_summands ` {\<guillemotleft>lderivs xs r\<guillemotright> | xs . True}))" by auto
  have "finite (\<Union>xs. toplevel_summands \<guillemotleft>lderivs xs r\<guillemotright>)" by (rule finite_subset[OF _ *]) auto
  hence fin: "finite {Pr \<guillemotleft>s\<guillemotright> |s. toplevel_summands s \<subseteq> (\<Union>xs. toplevel_summands \<guillemotleft>lderivs xs r\<guillemotright>)}"
    by (intro finite_ACI_norm_toplevel_summands)
  have "{s. \<exists>xs. s = \<guillemotleft>lderivs xs (Pr r)\<guillemotright>} = {\<guillemotleft>s\<guillemotright>| s. \<exists>xs. s = lderivs xs (Pr r)}" by auto
  thus ?case using finite_subset[OF ACI_norm_lderivs_Pr, of r] fin unfolding image_Collect by auto
qed

subsection {* Wellformedness and language of derivatives *}

lemma wf_lderiv[simp]: "wf n r \<Longrightarrow> wf n (lderiv w r)"
  by (induct r arbitrary: n w) (auto simp add: Let_def)

lemma wf_lderivs[simp]: "wf n r \<Longrightarrow> wf n (lderivs ws r)"
  by (induct ws arbitrary: r) (auto intro: wf_lderiv)

lemma lQuot_map_project:
assumes "as \<in> \<Sigma> n" "A \<subseteq> lists (\<Sigma> (Suc n))"
shows "lQuot as (map project ` A) = map project ` (\<Union>a \<in> set (embed as). lQuot a A)" (is "?L = ?R")
proof (intro equalityI image_subsetI subsetI)
  fix xss assume "xss \<in> ?L"
  with assms obtain zss
    where zss: "zss \<in> A" "as # xss = map project zss"
    unfolding lQuot_def by fastforce
  hence "xss = map project (tl zss)" by auto
  with zss assms(2) show "xss \<in> ?R" using embed[OF project, of _ n] unfolding lQuot_def by fastforce
next
  fix xss assume "xss \<in> (\<Union>a \<in> set (embed as). lQuot a A)"
  with assms(1) show "map project xss \<in> lQuot as (map project ` A)" unfolding lQuot_def
    by (fastforce intro!: rev_image_eqI simp: embed)
qed

lemma lang_lderiv: "\<lbrakk>wf n r; w \<in> \<Sigma> n\<rbrakk> \<Longrightarrow> lang n (lderiv w r) = lQuot w (lang n r)"
proof (induct r arbitrary: n w)
  case (Pr r)
  hence *: "wf (Suc n) r" "\<And>w'. w' \<in> set (embed w) \<Longrightarrow>  w' \<in> \<Sigma> (Suc n)" by (auto simp: embed)
  from Pr(1)[OF *] lQuot_map_project[OF Pr(3) lang_subset_lists[OF *(1)]] show ?case
    by (auto simp: wf_lderiv[OF *(1)])
qed (auto simp: Let_def lang_final[symmetric])

lemma lang_lderivs: "\<lbrakk>wf n r; wf_word n ws\<rbrakk> \<Longrightarrow> lang n (lderivs ws r) = lQuots ws (lang n r)"
  by (induct ws arbitrary: r) (auto simp: lang_lderiv)

corollary lderivs_final:
assumes "wf n r" "wf_word n ws"
shows "final (lderivs ws r) \<longleftrightarrow> ws \<in> lang n r"
  using lang_lderivs[OF assms] lang_final[of "lderivs ws r" n] by auto

abbreviation "lderivs_set n r s \<equiv> {(\<guillemotleft>lderivs w r\<guillemotright>, \<guillemotleft>lderivs w s\<guillemotright>) | w. wf_word n w}"

subsection {* Deriving preserves ACI-equivalence *}

lemma ACI_norm_PLUS:
  "list_all2 (\<lambda>r s. \<guillemotleft>r\<guillemotright> = \<guillemotleft>s\<guillemotright>) xs ys \<Longrightarrow> \<guillemotleft>PLUS xs\<guillemotright> = \<guillemotleft>PLUS ys\<guillemotright>"
proof (induct rule: list_all2_induct)
  case (Cons x xs y ys)
  hence "length xs = length ys" by (elim list_all2_lengthD)
  thus ?case using Cons by (induct xs ys rule: list_induct2) auto
qed simp

lemma toplevel_summands_ACI_norm_lderiv:
  "(\<Union>a\<in>toplevel_summands r. toplevel_summands \<guillemotleft>lderiv as \<guillemotleft>a\<guillemotright>\<guillemotright>) = toplevel_summands \<guillemotleft>lderiv as \<guillemotleft>r\<guillemotright>\<guillemotright>"
proof (induct r)
  case (Plus r1 r2) thus ?case
   unfolding toplevel_summands.simps toplevel_summands_ACI_norm
     toplevel_summands_lderiv[of as "\<guillemotleft>Plus r1 r2\<guillemotright>"] SUP_def image_Un Union_Un_distrib
   by (simp add: image_UN)
qed (auto simp: Let_def)

theorem ACI_norm_lderiv:
  "\<guillemotleft>lderiv as \<guillemotleft>r\<guillemotright>\<guillemotright> = \<guillemotleft>lderiv as r\<guillemotright>"
proof (induct r arbitrary: as)
  case (Plus r1 r2) thus ?case
   unfolding lderiv.simps ACI_norm_flatten[of "lderiv as \<guillemotleft>Plus r1 r2\<guillemotright>"]
     toplevel_summands_lderiv[of as "\<guillemotleft>Plus r1 r2\<guillemotright>"] image_Un image_UN
   by (auto simp: toplevel_summands_ACI_norm toplevel_summands_flatten_ACI_norm_image_Union)
     (auto simp: toplevel_summands_ACI_norm[symmetric] toplevel_summands_ACI_norm_lderiv)
next
  case (Pr r)
  hence "list_all2 (\<lambda>r s. \<guillemotleft>r\<guillemotright> = \<guillemotleft>s\<guillemotright>)
    (map (\<lambda>a. local.lderiv a \<guillemotleft>r\<guillemotright>) (embed as)) (map (\<lambda>a. local.lderiv a r) (embed as))"
    unfolding list_all2_map1 list_all2_map2 by (intro list_all2_refl)
  thus ?case unfolding lderiv.simps ACI_norm.simps by (blast intro: ACI_norm_PLUS)
qed (simp_all add: Let_def)

corollary lderiv_preserves: "\<guillemotleft>r\<guillemotright> = \<guillemotleft>s\<guillemotright> \<Longrightarrow> \<guillemotleft>lderiv as r\<guillemotright> = \<guillemotleft>lderiv as s\<guillemotright>"
  by (rule box_equals[OF _ ACI_norm_lderiv ACI_norm_lderiv]) (erule arg_cong)

lemma lderivs_snoc[simp]: "lderivs (ws @ [w]) r = (lderiv w (lderivs ws r))"
  by (induct ws arbitrary: r) auto

theorem ACI_norm_lderivs:
  "\<guillemotleft>lderivs ws \<guillemotleft>r\<guillemotright>\<guillemotright> = \<guillemotleft>lderivs ws r\<guillemotright>"
proof (induct ws arbitrary: r rule: rev_induct)
  case (snoc w ws) thus ?case
    using ACI_norm_lderiv[of w "lderivs ws r"] ACI_norm_lderiv[of w "lderivs ws \<guillemotleft>r\<guillemotright>"] by auto
qed simp

lemma lderivs_alt: "\<guillemotleft>lderivs w r\<guillemotright> = fold (\<lambda>a r. \<guillemotleft>lderiv a r\<guillemotright>) w \<guillemotleft>r\<guillemotright>"
  by (induct w arbitrary: r) (auto simp: ACI_norm_lderiv)

lemma finite_fold_lderiv: "finite {fold (\<lambda>a r. \<guillemotleft>lderiv a r\<guillemotright>) w \<guillemotleft>s\<guillemotright> |w. True}"
  using finite_lderivs unfolding lderivs_alt .

end

(*<*)
end
(*>*)


section \<open>Constructing Paths and Runs in Transition Systems\<close>

theory Transition_System_Construction
imports
  "../Basic/Sequence_LTL"
  "Transition_System"
begin

  context transition_system
  begin

    lemma invariant_run:
      assumes "P p" "\<And> p. P p \<Longrightarrow> \<exists> a. enabled a p \<and> P (execute a p) \<and> Q p a"
      obtains r
      where "run r p" "pred_stream P (p ## trace r p)" "stream_all2 Q (p ## trace r p) r"
    proof -
      obtain f where 1: "enabled (f p) p" "P (execute (f p) p)" "Q p (f p)" if "P p" for p using assms(2) by metis
      let ?g = "\<lambda> p. execute (f p) p"
      let ?r = "\<lambda> p. smap f (siterate ?g p)"
      show ?thesis
      proof
        show "run (?r p) p" using assms(1) 1 by (coinduction arbitrary: p) (auto)
        show "pred_stream P (p ## trace (?r p) p)" using assms(1) 1 by (coinduction arbitrary: p) (auto)
        show "stream_all2 Q (p ## trace (?r p) p) (?r p)" using assms(1) 1 by (coinduction arbitrary: p) (auto)
      qed
    qed
    lemma recurring_condition:
      assumes "P p" "\<And> p. P p \<Longrightarrow> \<exists> r. r \<noteq> [] \<and> path r p \<and> P (target r p)"
      obtains r
      where "run r p" "infs P (p ## trace r p)"
    proof -
      obtain f where 1: "f p \<noteq> []" "path (f p) p" "P (target (f p) p)" if "P p" for p using assms(2) by metis
      let ?g = "\<lambda> p. target (f p) p"
      let ?r = "\<lambda> p. flat (smap f (siterate ?g p))"
      have 2: "?r p = f p @- ?r (?g p)" if "P p" for p using that 1(1) by (simp add: flat_unfold)
      show ?thesis
      proof
        show "run (?r p) p" using assms(1) 1 2 by (coinduction arbitrary: p rule: run_coinduct_shift) (blast)
        show "infs P (p ## trace (?r p) p)" using assms(1) 1 2 by (coinduction arbitrary: p rule: infs_sscan_coinduct) (blast)
      qed
    qed

    lemma invariant_run_index:
      assumes "P n p" "\<And> n p. P n p \<Longrightarrow> \<exists> a. enabled a p \<and> P (Suc n) (execute a p) \<and> Q n p a"
      obtains r
      where
        "run r p"
        "\<And> i. P (n + i) (target (stake i r) p)"
        "\<And> i. Q (n + i) (target (stake i r) p) (r !! i)"
    proof -
      define s where "s \<equiv> (n, p)"
      have 1: "case_prod P s" using assms(1) unfolding s_def by auto
      obtain f where 2:
        "\<And> n p. P n p \<Longrightarrow> enabled (f n p) p"
        "\<And> n p. P n p \<Longrightarrow> P (Suc n) (execute (f n p) p)"
        "\<And> n p. P n p \<Longrightarrow> Q n p (f n p)"
        using assms(2) by metis
      define g where "g \<equiv> \<lambda> (n, p). (Suc n, execute (f n p) p)"

      let ?r = "smap (case_prod f) (siterate g s)"

      have 3: "run ?r (snd s)" using 1 2(1, 2) unfolding g_def by (coinduction arbitrary: s) (auto)
      have 4: "case_prod P (compow k g s)" for k using 1 2(2) unfolding g_def by (induct k) (auto)
      have 5: "case_prod Q (compow k g s) (?r !! k)" for k using 2(3) 4 by (simp add: case_prod_beta)

      have 6: "compow k g (n, p) = (n + k, target (stake k ?r) p)" for k
        unfolding s_def g_def by (induct k) (auto simp add: stake_Suc simp del: stake.simps(2))

      show ?thesis using that 3 4 5 unfolding s_def 6 by simp
    qed

    lemma koenig:
      assumes "infinite (reachable p)"
      assumes "\<And> q. q \<in> reachable p \<Longrightarrow> finite (successors q)"
      obtains r
      where "run r p"
    proof (rule invariant_run[where ?P = "\<lambda> q. q \<in> reachable p \<and> infinite (reachable q)"])
      show "p \<in> reachable p \<and> infinite (reachable p)" using assms(1) by auto
    next
      fix q
      assume 1: "q \<in> reachable p \<and> infinite (reachable q)"
      have 2: "finite (successors q)" using assms(2) 1 by auto
      have 3: "infinite (insert q (\<Union>(reachable ` (successors q))))" using reachable_step 1 by metis
      obtain s where 4: "s \<in> successors q" "infinite (reachable s)" using 2 3 by auto
      show "\<exists> a. enabled a q \<and> (execute a q \<in> reachable p \<and> infinite (reachable (execute a q))) \<and> True"
        using 1 4 by auto
    qed

  end

end


theory HEAP1CBJNoLemmas
imports HEAP1
begin

lemma l1: "disjoint s1 s2 \<Longrightarrow> s3 \<subseteq> s2 \<Longrightarrow> disjoint s1 s3"
by (metis Int_absorb2 Int_assoc Int_empty_right disjoint_def le_infI1 order_refl)

lemma l2v0: "disjoint s1 s2 \<Longrightarrow> disjoint s2 s3 \<Longrightarrow> disjoint (s1 \<union> s2) s3"
nitpick
oops
lemma l2v1: "s2 \<noteq> {} \<Longrightarrow> disjoint s1 s2 \<Longrightarrow> disjoint s2 s3 \<Longrightarrow> disjoint (s1 \<union> s2) s3"
nitpick
oops

lemma l2v2: "s2 \<subseteq> s1 \<Longrightarrow> disjoint s1 s3 \<Longrightarrow> disjoint (s1 \<union> s2) s3"
oops

lemma l2: "disjoint s1 s2 \<Longrightarrow> disjoint s1 s3 \<Longrightarrow> disjoint s2 s3 \<Longrightarrow> disjoint (s1 \<union> s2) s3"
by (metis Un_empty_left disjoint_def inf_sup_distrib2)

lemma l2o: "disjoint s1 s3 \<Longrightarrow> disjoint s2 s3 \<Longrightarrow> disjoint (s1 \<union> s2) s3"
apply (metis Int_commute Un_empty_left disjoint_def inf_sup_distrib1)
done

lemma l3_1: "nat1_map f \<Longrightarrow> nat1_map(S -\<triangleleft> f)"
by (metis Diff_iff f_in_dom_ar_apply_subsume l_dom_dom_ar nat1_map_def)

lemma l3_2: "l \<in> dom (S -\<triangleleft> f) \<Longrightarrow>  l \<in> dom f"
unfolding dom_antirestr_def
by (cases "l\<in>S", auto)

lemma l3_3: "l \<in> dom (S -\<triangleleft> f) \<Longrightarrow> the ((S -\<triangleleft> f) l) = the (f l)"
unfolding dom_antirestr_def
by (cases "l\<in>S", auto)

lemma l3: "nat1_map f \<Longrightarrow> locs(S -\<triangleleft> f) \<subseteq> locs f"
apply (rule subsetI)
unfolding locs_def
apply (simp add: l3_1)
apply (erule bexE)
apply (frule l3_2)
apply (frule l3_3,simp)
apply (rule_tac x=s in bexI)
sledgehammer

lemma l4: "nat1 n \<Longrightarrow> nat1 m \<Longrightarrow> locs_of d (n+m) = (locs_of d n) \<union> (locs_of (d+n) m)"
unfolding locs_of_def
by auto

\<comment> \<open> New lemmas (relatively trivial)\<close>
lemma l5: "nat1_map f \<Longrightarrow> x \<in> dom f \<Longrightarrow> nat1 (the(f x))"
by (metis nat1_map_def)

lemma l6: "nat1 y \<Longrightarrow> y < s \<Longrightarrow> locs_of (d+s) y \<subseteq> locs_of d s"
unfolding locs_of_def
apply simp
apply (rule subsetI)
find_theorems "_ \<in> {_ . _}"
apply (elim conjE CollectE)
apply (intro conjI CollectI)
apply (simp)
oops

lemma l6_1: "x \<in> dom f \<Longrightarrow> nat1_map f \<Longrightarrow> x \<in> locs_of x (the(f x))"
unfolding locs_of_def
apply (frule l5)
by auto

lemma l6: "x \<in> dom f \<Longrightarrow> nat1_map f \<Longrightarrow> x \<in> locs f"
unfolding locs_def
by (metis UN_iff l6_1)
\<comment> \<open> UNUSED, but discovered through the failure to prove l6 above, which led to change in l2v2 \<close>

lemma l7v0: "d \<in> dom f \<Longrightarrow> x \<in> locs_of d s \<Longrightarrow> nat1_map f \<Longrightarrow> x \<in> locs f"
unfolding locs_def
apply simp
oops

lemma l7: "d \<in> dom f \<Longrightarrow> x \<in> locs_of d (the(f d)) \<Longrightarrow> nat1_map f \<Longrightarrow> x \<in> locs f"
unfolding locs_def
by (simp,rule bexI,simp_all)

\<comment> \<open> Going directly top bottom of proof - used wrong l2 lemma! \<close>
theorem try1: "F1_inv f \<Longrightarrow> nat1 s \<Longrightarrow> d+s \<in> dom f \<Longrightarrow> disjoint (locs_of d s) (locs f) \<Longrightarrow>
          disjoint (locs_of d (s+ (the(f(d+s))))) (locs ({d+s} -\<triangleleft> f))"
          unfolding F1_inv_def
          apply (elim conjE)
apply (frule l3[of f "{d+s}"])                                          \<comment> \<open> S4 : L3      \<close>
apply (frule l1[of "locs_of d s" "locs f" "(locs ({d+s} -\<triangleleft> f))"],simp)  \<comment> \<open> S5 : L1(S4,h)\<close>
\<comment> \<open> step 6 is strange: it is already what you want to conclude, yet it comes from h? \<close>
  \<comment> \<open> here S6 comes from Disjoint f \<close>
oops

\<comment> \<open> Going in the order of steps \<close>
theorem try2:
       \<comment> \<open> h1         h2          h3             h4  \<close>
      "F1_inv f \<Longrightarrow> nat1 s \<Longrightarrow> d+s \<in> dom f \<Longrightarrow> disjoint (locs_of d s) (locs f) \<Longrightarrow>
          disjoint (locs_of d (s+ (the(f(d+s))))) (locs ({d+s} -\<triangleleft> f))"
          unfolding F1_inv_def
          apply (elim conjE)
apply (frule l4[of s "the(f(d+s))" d])  \<comment> \<open> S1    : L4(S2)       \<close>
apply (rule l5,simp,simp)               \<comment> \<open> S2    : L5(h1[3],h3) \<close>
apply (erule ssubst)                    \<comment> \<open> infer : subs(S1)     ; Nothing about S6 \<close>
    thm  l2[of "locs_of d s"
                  "locs_of (d+s)
                    (s+(the(f(d+s))))"
                  "locs ({d+s} -\<triangleleft> f)"]
apply (rule l2)                         \<comment> \<open> S3    : L2(S5, S6)   \<close>
defer
    thm l1[of "locs_of d s"
              "locs f"
              "locs ({d+s} -\<triangleleft> f)"]
        l3[of f "{d+s}"]

apply (frule l3[of f "{d+s}"])          \<comment> \<open> S4    : L3           \<close>
apply (frule l1[of "locs_of d s"
                   "locs f"
               "(locs ({d+s} -\<triangleleft> f))"],
               simp)                    \<comment> \<open> S5 : L1(S4,h)        \<close>
\<comment> \<open> To me the backward steps towards the goal are harder to follow? How about S6? Will try backward \<close>
oops

\<comment> \<open>Just like try2 but going underneath disjoint definition\<close>
theorem try3:
       \<comment> \<open> h1         h2          h3             h4  \<close>
      "F1_inv f \<Longrightarrow> nat1 s \<Longrightarrow> d+s \<in> dom f \<Longrightarrow> disjoint (locs_of d s) (locs f) \<Longrightarrow>
          disjoint (locs_of d (s+ (the(f(d+s))))) (locs ({d+s} -\<triangleleft> f))"
          unfolding F1_inv_def
          apply (elim conjE)
apply (frule l4[of s "the(f(d+s))" d])  \<comment> \<open> S1    : L4(S2)       \<close>
apply (rule l5,simp,simp)               \<comment> \<open> S2    : L5(h1[3],h3) \<close>
apply (erule ssubst)                    \<comment> \<open> infer : subs(S1)     ; Nothing about S6 \<close>
apply (rule l2)                         \<comment> \<open> S3    : L2(S5, S6)   \<close>
defer
apply (rule l1[of _ "locs f" _],simp)   \<comment> \<open> S5   : L1(S4,h4)     \<close>
apply (rule l3,simp)                    \<comment> \<open> S4   : L3(h1[3])     \<close>
defer
  \<comment> \<open> If I had a lemma (should create? no general enough?); \<close>
unfolding disjoint_def
  apply (simp add: disjoint_iff_not_equal)
  apply (intro ballI)
  apply (erule_tac x=x in ballE,simp_all)
  apply (erule_tac x=y in ballE,simp)
  apply (erule notE)
  apply (rule l7[of "d+s" f _],simp_all)

  apply (fold disjoint_def)
  apply (unfold disjoint_def)
  apply (simp add: disjoint_iff_not_equal)
  apply (frule l6,simp)
  apply (intro ballI)
  apply (frule l3_1[of f "{d+s}"])
  unfolding locs_def
  apply simp
  apply (elim bexE)
 thm l3 l3_1 l3_2 l5
  apply (frule l3_2)
  apply (simp add: l3_3)
  apply (frule l5[of _ "d+s"],simp)
  apply (frule l5,simp) back
  apply (frule l5,simp) back back
  apply (erule ballE)+
  (*
  apply (erule_tac x=saa in ballE)
  apply (erule_tac x=y in ballE)
  *)
  apply simp
  prefer 3
  apply (erule notE)
  unfolding locs_of_def
  apply simp
  nitpick
oops

\<comment> \<open> Version shown to Cliff - in step order and using l2 new \<close>
theorem try4:
       \<comment> \<open> h1         h2          h3             h4  \<close>
      "F1_inv f \<Longrightarrow> nat1 s \<Longrightarrow> d+s \<in> dom f \<Longrightarrow> disjoint (locs_of d s) (locs f) \<Longrightarrow>
          disjoint (locs_of d (s+ (the(f(d+s))))) (locs ({d+s} -\<triangleleft> f))"
          unfolding F1_inv_def
          apply (elim conjE)
apply (frule l4[of s "the(f(d+s))" d])  \<comment> \<open> S1    : L4(S2)       \<close>
apply (rule l5,simp,simp)               \<comment> \<open> S2    : L5(h1[3],h3) \<close>
apply (erule ssubst)                    \<comment> \<open> infer : subs(S1)     ; Nothing about S6 \<close>
apply (rule l2)                         \<comment> \<open> S3    : L2(S5, S6)   \<close>
defer
apply (rule l1[of _ "locs f" _],simp)   \<comment> \<open> S5   : L1(S4,h4)     \<close>
apply (rule l3,simp)                    \<comment> \<open> S4   : L3(h1[3])     \<close>
defer
unfolding disjoint_def
  apply (simp add: disjoint_iff_not_equal)
  apply (intro ballI)
  apply (erule_tac x=x in ballE,simp_all)
  apply (erule_tac x=y in ballE,simp)
  apply (erule notE)
  apply (rule l7[of "d+s" f _],simp_all)
oops

lemma l3half_1: "nat1_map f \<Longrightarrow> (x \<in> locs f) = (\<exists>y \<in> dom f . x \<in> locs_of y (the(f y)))"
unfolding locs_def
by (metis (mono_tags) UN_iff)

\<comment> \<open> Version shown to Cliff - in step order and using l2original + new lemma\<close>
lemma l3half:
\<comment> \<open>see lemma l_locs_dom_ar_iff:\<close>
  "nat1_map f \<Longrightarrow> Disjoint f \<Longrightarrow> r \<in> dom f \<Longrightarrow> locs({r} -\<triangleleft> f) = locs f - locs_of r (the(f r))"
apply (rule equalityI)
apply (rule_tac [1-] subsetI)
apply (frule_tac [1-] l3_1[of _ "{r}"])
apply (simp_all add: l3half_1)
defer
apply (elim conjE)
defer
apply (intro conjI)
apply (metis f_in_dom_ar_subsume f_in_dom_ar_the_subsume)
apply (erule_tac [1-] bexE)
defer
apply (rule_tac x=y in bexI)
apply (metis f_in_dom_ar_apply_not_elem singleton_iff)
apply (metis l_dom_dom_ar member_remove remove_def)
apply (frule f_in_dom_ar_subsume)
apply (frule f_in_dom_ar_the_subsume)
unfolding Disjoint_def disjoint_def Locs_of_def
apply (simp)
by (metis disjoint_iff_not_equal f_in_dom_ar_notelem)

thm f_in_dom_ar_subsume
    f_in_dom_ar_the_subsume
    f_in_dom_ar_notelem
    f_in_dom_ar_apply_not_elem
    l_dom_dom_ar

lemma l8: "disjoint A (B - A)"
unfolding disjoint_def
by (metis Diff_disjoint)

\<comment> \<open> LATEST version from Cliff that avoids expanding locs def through lemmas (caveat: 3.5 is hard to prove \<close>
theorem try7:
       \<comment> \<open> h1         h2          h3             h4  \<close>
      "F1_inv f \<Longrightarrow> nat1 s \<Longrightarrow> d+s \<in> dom f \<Longrightarrow> disjoint (locs_of d s) (locs f) \<Longrightarrow>
          disjoint (locs_of d (s+ (the(f(d+s))))) (locs ({d+s} -\<triangleleft> f))"
          unfolding F1_inv_def
          apply (elim conjE)
apply (frule l4[of s "the(f(d+s))" d])  \<comment> \<open> S1    : L4(S2)       \<close>
apply (rule l5,simp,simp)               \<comment> \<open> S2    : L5(h1[3],h3) \<close>
apply (erule ssubst)                    \<comment> \<open> infer : subs(S1)     ; Nothing about S6 \<close>
apply (rule l2o)                        \<comment> \<open> S3    : L2(S4, S6)   \<close>
apply (metis (full_types) l1 l3)
by (metis l3half l8)

\<comment> \<open> trial lemma extracted from the last part of the next try proofs (try5/6 below)\<close>
lemma trial: "nat1_map f \<Longrightarrow> Disjoint f \<Longrightarrow> d+s \<in> dom f \<Longrightarrow> disjoint (locs_of (d + s) (the (f (d + s)))) (locs ({d+s} -\<triangleleft> f))"
unfolding Disjoint_def Locs_of_def
  apply (erule_tac x="d+s" in ballE)    \<comment> \<open> S6    : S8 \<close>
    apply (simp_all)
  unfolding disjoint_def
  apply (simp add: disjoint_iff_not_equal)
  apply (intro ballI)
  unfolding locs_def
  apply (frule l3_1[of _ "{d+s}"])
  apply simp
  apply (erule bexE)
  apply (frule l3_2)
  apply (frule f_in_dom_ar_notelem)
  apply (erule_tac x=sa in ballE,simp_all)
  apply (metis f_in_dom_ar_apply_subsume)
done

theorem try5:
       \<comment> \<open> h1         h2          h3             h4  \<close>
      "F1_inv f \<Longrightarrow> nat1 s \<Longrightarrow> d+s \<in> dom f \<Longrightarrow> disjoint (locs_of d s) (locs f) \<Longrightarrow>
          disjoint (locs_of d (s+ (the(f(d+s))))) (locs ({d+s} -\<triangleleft> f))"
          unfolding F1_inv_def
          apply (elim conjE)
apply (frule l4[of s "the(f(d+s))" d])  \<comment> \<open> S1    : L4(S2)       \<close>
apply (rule l5,simp,simp)               \<comment> \<open> S2    : L5(h1[3],h3) \<close>
apply (erule ssubst)                    \<comment> \<open> infer : subs(S1)     ; Nothing about S6 \<close>
apply (rule l2o)                        \<comment> \<open> S3    : L2(S4, S6)   \<close>
apply (rule l1[of _ "locs f" _],simp)   \<comment> \<open> S4    : L1(S5,h4)     \<close>
apply (rule l3,simp)                    \<comment> \<open> S5    : L3(h1[3])     \<close>

apply (frule l3half,simp,simp,simp)     \<comment> \<open> S8   : L3.5(h1[1])   \<close>
(*
apply (rule l1[of _ "locs f"])          \<comment> \<open> S8_1 : L1(h4)        \<close>
  defer thm Diff_subset l3 \<comment> \<open> either work \<close>
  apply (metis Diff_subset)             \<comment> \<open> S8_2 : L3 or set-thy \<close>
apply (rule trial,simp,simp,simp)       \<comment> \<open> S9   : ? S6 ? \<close>
      \<comment> \<open> cannot loose anti-restriction \<close>
*)
oops

theorem try6:
       \<comment> \<open> h1         h2          h3             h4  \<close>
      "F1_inv f \<Longrightarrow> nat1 s \<Longrightarrow> d+s \<in> dom f \<Longrightarrow> disjoint (locs_of d s) (locs f) \<Longrightarrow>
          disjoint (locs_of d (s+ (the(f(d+s))))) (locs ({d+s} -\<triangleleft> f))"
          unfolding F1_inv_def
          apply (elim conjE)
          thm l4[of s "the(f(d+s))" d]
          thm l5
          thm l1[of _ "locs f" _]
          thm trial
apply (frule l4[of s "the(f(d+s))" d])  \<comment> \<open> S1    : L4(S2)       \<close>
apply (rule l5,simp,simp)               \<comment> \<open> S2    : L5(h1[3],h3) \<close>
apply (erule ssubst)                    \<comment> \<open> infer : subs(S1)     ; Nothing about S6 \<close>
apply (rule l2o)                        \<comment> \<open> S3    : L2(S4, S6)   \<close>
apply (rule l1[of _ "locs f" _],simp)   \<comment> \<open> S4    : L1(S5,h4)     \<close>
apply (rule l3,simp)                    \<comment> \<open> S5    : L3(h1[3])     \<close>
apply (rule trial,simp,simp,simp)
done

end


(*  Title:       A Definitional Encoding of TLA in Isabelle/HOL
    Authors:     Gudmund Grov <ggrov at inf.ed.ac.uk>
                 Stephan Merz <Stephan.Merz at loria.fr>
    Year:        2011
    Maintainer:  Gudmund Grov <ggrov at inf.ed.ac.uk>
*)

header "Liveness"

theory Liveness
imports Rules
begin

text{* This theory derives proof rules for liveness properties.*}

definition enabled :: "'a formula \<Rightarrow> 'a formula"
where "enabled F \<equiv> \<lambda> s. \<exists> t. ((first s) ## t) \<Turnstile> F"

syntax "_Enabled" :: "lift \<Rightarrow> lift" ("(Enabled _)" [90] 90)

translations "_Enabled" \<rightleftharpoons> "CONST enabled"

definition WeakF :: "('a::world) formula \<Rightarrow> ('a,'b) stfun \<Rightarrow> 'a formula"
where "WeakF F v \<equiv> TEMP \<diamond>\<box>Enabled \<langle>F\<rangle>_v \<longrightarrow> \<box>\<diamond>\<langle>F\<rangle>_v"

definition StrongF :: "('a::world) formula \<Rightarrow> ('a,'b) stfun \<Rightarrow> 'a formula"
where "StrongF F v \<equiv> TEMP \<box>\<diamond>Enabled \<langle>F\<rangle>_v \<longrightarrow> \<box>\<diamond>\<langle>F\<rangle>_v"

text{*
  Lamport's TLA defines the above notions for actions.
  In \tlastar{}, (pre-)formulas generalise TLA's actions and the above
  definition is the natural generalisation of enabledness to pre-formulas.
  In particular, we have chosen to define @{text enabled} such that it
  yields itself a temporal formula, although its value really just depends
  on the first state of the sequence it is evaluated over.
  Then, the definitions of weak and strong fairness are exactly as in TLA.
*}

syntax
 "_WF" :: "[lift,lift] \<Rightarrow> lift" ("(WF'(_')'_(_))"  [20,1000] 90)
 "_SF" :: "[lift,lift] \<Rightarrow> lift" ("(SF'(_')'_(_))"  [20,1000] 90)
 "_WFsp" :: "[lift,lift] \<Rightarrow> lift" ("(WF '(_')'_(_))"  [20,1000] 90)
 "_SFsp" :: "[lift,lift] \<Rightarrow> lift" ("(SF '(_')'_(_))"  [20,1000] 90)

translations
 "_WF" \<rightleftharpoons> "CONST WeakF"
 "_SF" \<rightleftharpoons> "CONST StrongF"
 "_WFsp" \<rightharpoonup> "CONST WeakF"
 "_SFsp" \<rightharpoonup> "CONST StrongF"

subsection "Properties of @{term enabled}"

theorem enabledI: "\<turnstile> F \<longrightarrow> Enabled F"
proof (clarsimp)
  fix w
  assume "w \<Turnstile> F"
  with seq_app_first_tail[of w] have "((first w) ## tail w) \<Turnstile> F" by simp
  thus "w \<Turnstile> Enabled F" by (auto simp: enabled_def)
qed

theorem enabledE:
  assumes "s \<Turnstile> Enabled F" and "\<And>u. (first s ## u) \<Turnstile> F \<Longrightarrow> Q"
  shows "Q"
  using assms unfolding enabled_def by blast

lemma enabled_mono:
  assumes "w \<Turnstile> Enabled F" and "\<turnstile> F \<longrightarrow> G"
  shows "w \<Turnstile> Enabled G"
  using assms[unlifted] unfolding enabled_def by blast

lemma Enabled_disj1: "\<turnstile> Enabled F \<longrightarrow> Enabled (F \<or> G)"
  by (auto simp: enabled_def)

lemma  Enabled_disj2: "\<turnstile> Enabled F \<longrightarrow> Enabled (G \<or> F)"
  by (auto simp: enabled_def)

lemma  Enabled_conj1: "\<turnstile> Enabled (F \<and> G) \<longrightarrow> Enabled F"
  by (auto simp: enabled_def)

lemma  Enabled_conj2: "\<turnstile> Enabled (G \<and> F) \<longrightarrow> Enabled F"
  by (auto simp: enabled_def)

lemma Enabled_disjD: "\<turnstile> Enabled (F \<or> G) \<longrightarrow> Enabled F \<or> Enabled G"
  by (auto simp: enabled_def)

lemma Enabled_disj: "\<turnstile> Enabled (F \<or> G) = (Enabled F \<or> Enabled G)"
  by (auto simp: enabled_def)

lemmas enabled_disj_rew = Enabled_disj[int_rewrite]

lemma Enabled_ex: "\<turnstile> Enabled (\<exists> x. F x) = (\<exists> x. Enabled (F x))"
  by (force simp: enabled_def)

subsection "Fairness Properties"

lemma WF_alt: "\<turnstile> WF(A)_v = (\<box>\<diamond>\<not>Enabled \<langle>A\<rangle>_v \<or> \<box>\<diamond>\<langle>A\<rangle>_v)"
proof -
  have "\<turnstile> WF(A)_v = (\<not>\<diamond>\<box> Enabled \<langle>A\<rangle>_v \<or> \<box>\<diamond>\<langle>A\<rangle>_v)" by (auto simp: WeakF_def)
  thus ?thesis by (simp add: dualization_rew)
qed

lemma SF_alt: "\<turnstile> SF(A)_v = (\<diamond>\<box>\<not>Enabled \<langle>A\<rangle>_v \<or> \<box>\<diamond>\<langle>A\<rangle>_v)"
proof -
  have "\<turnstile> SF(A)_v = (\<not>\<box>\<diamond> Enabled \<langle>A\<rangle>_v \<or> \<box>\<diamond>\<langle>A\<rangle>_v)" by (auto simp: StrongF_def)
  thus ?thesis by (simp add: dualization_rew)
qed

lemma alwaysWFI: "\<turnstile> WF(A)_v \<longrightarrow> \<box>WF(A)_v"
  unfolding WF_alt[int_rewrite] by (rule MM6)

theorem WF_always[simp_unl]: "\<turnstile> \<box>WF(A)_v = WF(A)_v"
  by (rule int_iffI[OF ax1 alwaysWFI])

theorem WF_eventually[simp_unl]: "\<turnstile> \<diamond>WF(A)_v = WF(A)_v"
proof -
  have 1: "\<turnstile> \<not>WF(A)_v = (\<diamond>\<box>Enabled \<langle>A\<rangle>_v \<and> \<not> \<box>\<diamond>\<langle>A\<rangle>_v)"
    by (auto simp: WeakF_def)
  have "\<turnstile> \<box>\<not>WF(A)_v = \<not>WF(A)_v"
    by (simp add: 1[int_rewrite] STL5[int_rewrite] dualization_rew)
  thus ?thesis
    by (auto simp: eventually_def)
qed

lemma alwaysSFI: "\<turnstile> SF(A)_v \<longrightarrow> \<box>SF(A)_v"
proof -
  have "\<turnstile> \<box>\<diamond>\<box>\<not>Enabled \<langle>A\<rangle>_v \<or> \<box>\<diamond>\<langle>A\<rangle>_v \<longrightarrow> \<box>(\<box>\<diamond>\<box>\<not>Enabled \<langle>A\<rangle>_v \<or> \<box>\<diamond>\<langle>A\<rangle>_v)"
    by (rule MM6)
  thus ?thesis unfolding SF_alt[int_rewrite] by simp
qed

theorem SF_always[simp_unl]: "\<turnstile> \<box>SF(A)_v = SF(A)_v"
  by (rule int_iffI[OF ax1 alwaysSFI])

theorem SF_eventually[simp_unl]: "\<turnstile> \<diamond>SF(A)_v = SF(A)_v"
proof -
  have 1: "\<turnstile> \<not>SF(A)_v = (\<box>\<diamond>Enabled \<langle>A\<rangle>_v \<and> \<not> \<box>\<diamond>\<langle>A\<rangle>_v)"
    by (auto simp: StrongF_def)
  have "\<turnstile> \<box>\<not>SF(A)_v = \<not>SF(A)_v"
    by (simp add: 1[int_rewrite] STL5[int_rewrite] dualization_rew)
  thus ?thesis
    by (auto simp: eventually_def)
qed

theorem SF_imp_WF: "\<turnstile> SF (A)_v \<longrightarrow> WF (A)_v"
  unfolding WeakF_def StrongF_def by (auto dest: E20[unlift_rule])

theorem WF1_general:
  assumes h1: "|~ P \<and> N \<longrightarrow> \<circ>P \<or> \<circ>Q"
      and h2: "|~ P \<and> N \<and> \<langle>A\<rangle>_v \<longrightarrow> \<circ>Q"
      and h3: "\<turnstile> P \<and> N \<longrightarrow> Enabled \<langle>A\<rangle>_v"
      and h4: "|~ P \<and> Unchanged w \<longrightarrow> \<circ>P"
  shows "\<turnstile> \<box>N \<and> WF(A)_v \<longrightarrow> (P \<leadsto> Q)"
proof -
  have "\<turnstile> \<box>(\<box>N \<and> WF(A)_v) \<longrightarrow> \<box>(\<box>P \<longrightarrow> \<diamond>\<langle>A\<rangle>_v)"
  proof (rule STL4)
    have "\<turnstile> \<box>(P \<and> N) \<longrightarrow> \<diamond>\<box>Enabled \<langle>A\<rangle>_v" by (rule lift_imp_trans[OF h3[THEN STL4] E3])
    hence "\<turnstile> \<box>P \<and> \<box>N \<and> WF(A)_v \<longrightarrow> \<box>\<diamond>\<langle>A\<rangle>_v" by (auto simp: WeakF_def STL5[int_rewrite])
    with ax1[of "TEMP \<diamond>\<langle>A\<rangle>_v"] show "\<turnstile> \<box>N \<and> WF(A)_v \<longrightarrow> \<box>P \<longrightarrow> \<diamond>\<langle>A\<rangle>_v" by force
  qed
  hence "\<turnstile> \<box>N \<and> WF(A)_v \<longrightarrow> \<box>(\<box>P \<longrightarrow> \<diamond>\<langle>A\<rangle>_v)"
    by (simp add: STL5[int_rewrite])
  with AA22[OF h1 h2 h4] show ?thesis by force
qed

text {* Lamport's version of the rule is derived as a special case. *}

theorem WF1:
  assumes h1: "|~ P \<and> [N]_v \<longrightarrow> \<circ>P \<or> \<circ>Q"
      and h2: "|~ P \<and> \<langle>N \<and> A\<rangle>_v \<longrightarrow> \<circ>Q"
      and h3: "\<turnstile> P \<longrightarrow> Enabled \<langle>A\<rangle>_v"
      and h4: "|~ P \<and> Unchanged v \<longrightarrow> \<circ>P"
  shows "\<turnstile> \<box>[N]_v \<and> WF(A)_v \<longrightarrow> (P \<leadsto> Q)"
proof -
  have "\<turnstile> \<box>\<box>[N]_v \<and> WF(A)_v \<longrightarrow> (P \<leadsto> Q)"
  proof (rule WF1_general)
    from h1 T9[of N v] show "|~ P \<and> \<box>[N]_v \<longrightarrow> \<circ>P \<or> \<circ>Q" by force
  next
    from T9[of N v] have "|~ P \<and> \<box>[N]_v \<and> \<langle>A\<rangle>_v \<longrightarrow> P \<and> \<langle>N \<and> A\<rangle>_v"
      by (auto simp: actrans_def angle_actrans_def)
    from this h2 show "|~ P \<and> \<box>[N]_v \<and> \<langle>A\<rangle>_v \<longrightarrow> \<circ>Q" by (rule pref_imp_trans)
  next
    from h3 T9[of N v] show "\<turnstile> P \<and> \<box>[N]_v \<longrightarrow> Enabled \<langle>A\<rangle>_v" by force
  qed (rule h4)
  thus ?thesis by simp
qed

text {*
  The corresponding rule for strong fairness has an additional hypothesis
  @{text "\<box>F"}, which is typically a conjunction of other fairness properties
  used to prove that the helpful action eventually becomes enabled.
*}

theorem SF1_general:
  assumes h1: "|~ P \<and> N \<longrightarrow> \<circ>P \<or> \<circ>Q"
      and h2: "|~ P \<and> N \<and> \<langle>A\<rangle>_v \<longrightarrow> \<circ>Q"
      and h3: "\<turnstile> \<box>P \<and> \<box>N \<and> \<box>F \<longrightarrow> \<diamond>Enabled \<langle>A\<rangle>_v"
      and h4: "|~ P \<and> Unchanged w \<longrightarrow> \<circ>P"
  shows "\<turnstile> \<box>N \<and> SF(A)_v \<and> \<box>F \<longrightarrow> (P \<leadsto> Q)"
proof -
  have "\<turnstile> \<box>(\<box>N \<and> SF(A)_v \<and> \<box>F) \<longrightarrow> \<box>(\<box>P \<longrightarrow> \<diamond>\<langle>A\<rangle>_v)"
  proof (rule STL4)
    have "\<turnstile> \<box>(\<box>P \<and> \<box>N \<and> \<box>F) \<longrightarrow> \<box>\<diamond>Enabled \<langle>A\<rangle>_v" by (rule STL4[OF h3])
    hence "\<turnstile> \<box>P \<and> \<box>N \<and> \<box>F \<and> SF(A)_v \<longrightarrow> \<box>\<diamond>\<langle>A\<rangle>_v" by (auto simp: StrongF_def STL5[int_rewrite])
    with ax1[of "TEMP \<diamond>\<langle>A\<rangle>_v"] show "\<turnstile> \<box>N \<and> SF(A)_v \<and> \<box>F \<longrightarrow> \<box>P \<longrightarrow> \<diamond>\<langle>A\<rangle>_v" by force
  qed
  hence "\<turnstile> \<box>N \<and> SF(A)_v \<and> \<box>F \<longrightarrow> \<box>(\<box>P \<longrightarrow> \<diamond>\<langle>A\<rangle>_v)"
    by (simp add: STL5[int_rewrite])
  with AA22[OF h1 h2 h4] show ?thesis by force
qed

theorem SF1:
  assumes h1: "|~ P \<and> [N]_v \<longrightarrow> \<circ>P \<or> \<circ>Q"
      and h2: "|~ P \<and> \<langle>N \<and> A\<rangle>_v \<longrightarrow> \<circ>Q"
      and h3: "\<turnstile> \<box>P \<and> \<box>[N]_v \<and> \<box>F \<longrightarrow> \<diamond>Enabled \<langle>A\<rangle>_v"
      and h4: "|~ P \<and> Unchanged v \<longrightarrow> \<circ>P"
  shows "\<turnstile> \<box>[N]_v \<and> SF(A)_v \<and> \<box>F \<longrightarrow> (P \<leadsto> Q)"
proof -
  have "\<turnstile> \<box>\<box>[N]_v \<and> SF(A)_v \<and> \<box>F \<longrightarrow> (P \<leadsto> Q)"
  proof (rule SF1_general)
    from h1 T9[of N v] show "|~ P \<and> \<box>[N]_v \<longrightarrow> \<circ>P \<or> \<circ>Q" by force
  next
    from T9[of N v] have "|~ P \<and> \<box>[N]_v \<and> \<langle>A\<rangle>_v \<longrightarrow> P \<and> \<langle>N \<and> A\<rangle>_v"
      by (auto simp: actrans_def angle_actrans_def)
    from this h2 show "|~ P \<and> \<box>[N]_v \<and> \<langle>A\<rangle>_v \<longrightarrow> \<circ>Q" by (rule pref_imp_trans)
  next
    from h3 show "\<turnstile> \<box>P \<and> \<box>\<box>[N]_v \<and> \<box>F \<longrightarrow> \<diamond>Enabled \<langle>A\<rangle>_v" by simp
  qed (rule h4)
  thus ?thesis by simp
qed

text {*
  Lamport proposes the following rule as an introduction rule for @{text WF} formulas.
*}

theorem WF2:
  assumes h1: "|~ \<langle>N \<and> B\<rangle>_f \<longrightarrow> \<langle>M\<rangle>_g"
      and h2: "|~ P \<and> \<circ>P \<and> \<langle>N \<and> A\<rangle>_f \<longrightarrow> B"
      and h3: "\<turnstile> P \<and> Enabled \<langle>M\<rangle>_g \<longrightarrow> Enabled \<langle>A\<rangle>_f"
      and h4: "\<turnstile> \<box>[N \<and> \<not>B]_f \<and> WF(A)_f \<and> \<box>F \<and> \<diamond>\<box>Enabled \<langle>M\<rangle>_g \<longrightarrow> \<diamond>\<box>P"
  shows "\<turnstile> \<box>[N]_f \<and> WF(A)_f \<and> \<box>F \<longrightarrow> WF(M)_g"
proof -
  have "\<turnstile> \<box>[N]_f \<and> WF(A)_f \<and> \<box>F \<and> \<diamond>\<box>Enabled \<langle>M\<rangle>_g \<and> \<not>\<box>\<diamond>\<langle>M\<rangle>_g \<longrightarrow> \<box>\<diamond>\<langle>M\<rangle>_g"
  proof -
    have 1: "\<turnstile> \<box>[N]_f \<and> WF(A)_f \<and> \<box>F \<and> \<diamond>\<box>Enabled \<langle>M\<rangle>_g \<and> \<not>\<box>\<diamond>\<langle>M\<rangle>_g \<longrightarrow> \<diamond>\<box>P"
    proof -
      have A: "\<turnstile> \<box>[N]_f \<and> WF(A)_f \<and> \<box>F \<and> \<diamond>\<box>Enabled \<langle>M\<rangle>_g \<and> \<not>\<box>\<diamond>\<langle>M\<rangle>_g \<longrightarrow>
                 \<box>(\<box>[N]_f \<and> WF(A)_f \<and> \<box>F) \<and> \<diamond>\<box>(\<diamond>\<box>Enabled \<langle>M\<rangle>_g \<and> \<box>[\<not>M]_g)"
        unfolding STL6[int_rewrite] (* important to do this before STL5 is applied *)
        by (auto simp: STL5[int_rewrite] dualization_rew)
      have B: "\<turnstile> \<box>(\<box>[N]_f \<and> WF(A)_f \<and> \<box>F) \<and> \<diamond>\<box>(\<diamond>\<box>Enabled \<langle>M\<rangle>_g \<and> \<box>[\<not>M]_g) \<longrightarrow>
                 \<diamond>((\<box>[N]_f \<and> WF(A)_f \<and> \<box>F) \<and> \<box>(\<diamond>\<box>Enabled \<langle>M\<rangle>_g \<and> \<box>[\<not>M]_g))"
        by (rule SE2)
      from lift_imp_trans[OF A B]
      have "\<turnstile> \<box>[N]_f \<and> WF(A)_f \<and> \<box>F \<and> \<diamond>\<box>Enabled \<langle>M\<rangle>_g \<and> \<not>\<box>\<diamond>\<langle>M\<rangle>_g \<longrightarrow>
              \<diamond>((\<box>[N]_f \<and> WF(A)_f \<and> \<box>F) \<and> (\<diamond>\<box>Enabled \<langle>M\<rangle>_g \<and> \<box>[\<not>M]_g))"
        by (simp add: STL5[int_rewrite])
      moreover
      from h1 have "|~ [N]_f \<longrightarrow> [\<not>M]_g \<longrightarrow> [N \<and> \<not>B]_f" by (auto simp: actrans_def angle_actrans_def)
      hence "\<turnstile> \<box>[[N]_f]_f \<longrightarrow> \<box>[[\<not>M]_g \<longrightarrow> [N \<and> \<not>B]_f]_f" by (rule M2)
      from lift_imp_trans[OF this ax4] have "\<turnstile> \<box>[N]_f \<and> \<box>[\<not>M]_g \<longrightarrow> \<box>[N \<and> \<not>B]_f"
        by (force intro: T4[unlift_rule])
      with h4 have "\<turnstile> (\<box>[N]_f \<and> WF(A)_f \<and> \<box>F) \<and> (\<diamond>\<box>Enabled \<langle>M\<rangle>_g \<and> \<box>[\<not>M]_g) \<longrightarrow> \<diamond>\<box>P"
        by force
      from STL4_eve[OF this]
      have "\<turnstile> \<diamond>((\<box>[N]_f \<and> WF(A)_f \<and> \<box>F) \<and> (\<diamond>\<box>Enabled \<langle>M\<rangle>_g \<and> \<box>[\<not>M]_g)) \<longrightarrow> \<diamond>\<box>P" by simp
      ultimately
      show ?thesis by (rule lift_imp_trans)
    qed
    have 2: "\<turnstile> \<box>[N]_f \<and> WF(A)_f \<and> \<diamond>\<box>Enabled \<langle>M\<rangle>_g \<and> \<diamond>\<box>P \<longrightarrow> \<box>\<diamond>\<langle>M\<rangle>_g"
    proof -
      have A: "\<turnstile> \<diamond>\<box>P \<and> \<diamond>\<box>Enabled \<langle>M\<rangle>_g \<and> WF(A)_f \<longrightarrow> \<box>\<diamond>\<langle>A\<rangle>_f"
        using h3[THEN STL4, THEN STL4_eve] by (auto simp: STL6[int_rewrite] WeakF_def)
      have B: "\<turnstile> \<box>[N]_f \<and> \<diamond>\<box>P \<and>  \<box>\<diamond>\<langle>A\<rangle>_f \<longrightarrow> \<box>\<diamond>\<langle>M\<rangle>_g"
      proof -
        from M1[of P f] have "\<turnstile> \<box>P \<and> \<box>\<diamond>\<langle>N \<and> A\<rangle>_f \<longrightarrow> \<box>\<diamond>\<langle>(P \<and> \<circ>P) \<and> (N \<and> A)\<rangle>_f"
          by (force intro: AA29[unlift_rule])
        hence "\<turnstile> \<diamond>\<box>(\<box>P \<and> \<box>\<diamond>\<langle>N \<and> A\<rangle>_f) \<longrightarrow> \<diamond>\<box>\<box>\<diamond>\<langle>(P \<and> \<circ>P) \<and> (N \<and> A)\<rangle>_f"
          by (rule STL4_eve[OF STL4])
        hence "\<turnstile> \<diamond>\<box>P \<and> \<box>\<diamond>\<langle>N \<and> A\<rangle>_f \<longrightarrow> \<box>\<diamond>\<langle>(P \<and> \<circ>P) \<and> (N \<and> A)\<rangle>_f"
          by (simp add: STL6[int_rewrite])
        with AA29[of N f A]
        have B1: "\<turnstile> \<box>[N]_f \<and> \<diamond>\<box>P \<and>  \<box>\<diamond>\<langle>A\<rangle>_f \<longrightarrow> \<box>\<diamond>\<langle>(P \<and> \<circ>P) \<and> (N \<and> A)\<rangle>_f" by force
        from h2 have "|~ \<langle>(P \<and> \<circ>P) \<and> (N \<and> A)\<rangle>_f \<longrightarrow> \<langle>N \<and> B\<rangle>_f"
          by (auto simp: angle_actrans_sem[unlifted])
        from B1 this[THEN AA25, THEN STL4] have "\<turnstile> \<box>[N]_f \<and> \<diamond>\<box>P \<and>  \<box>\<diamond>\<langle>A\<rangle>_f \<longrightarrow> \<box>\<diamond>\<langle>N \<and> B\<rangle>_f"
          by (rule lift_imp_trans)
        moreover
        have "\<turnstile> \<box>\<diamond>\<langle>N \<and> B\<rangle>_f \<longrightarrow> \<box>\<diamond>\<langle>M\<rangle>_g" by (rule h1[THEN AA25, THEN STL4])
        ultimately show ?thesis by (rule lift_imp_trans)
      qed
      from A B show ?thesis by force
    qed
    from 1 2 show ?thesis by force
  qed
  thus ?thesis by (auto simp: WeakF_def)
qed

text {*
  Lamport proposes an analogous theorem for introducing strong fairness, and its
  proof is very similar, in fact, it was obtained by copy and paste, with minimal
  modifications.
*}

theorem SF2:
  assumes h1: "|~ \<langle>N \<and> B\<rangle>_f \<longrightarrow> \<langle>M\<rangle>_g"
      and h2: "|~ P \<and> \<circ>P \<and> \<langle>N \<and> A\<rangle>_f \<longrightarrow> B"
      and h3: "\<turnstile> P \<and> Enabled \<langle>M\<rangle>_g \<longrightarrow> Enabled \<langle>A\<rangle>_f"
      and h4: "\<turnstile> \<box>[N \<and> \<not>B]_f \<and> SF(A)_f \<and> \<box>F \<and> \<box>\<diamond>Enabled \<langle>M\<rangle>_g \<longrightarrow> \<diamond>\<box>P"
  shows "\<turnstile> \<box>[N]_f \<and> SF(A)_f \<and> \<box>F \<longrightarrow> SF(M)_g"
proof -
  have "\<turnstile> \<box>[N]_f \<and> SF(A)_f \<and> \<box>F \<and> \<box>\<diamond>Enabled \<langle>M\<rangle>_g \<and> \<not>\<box>\<diamond>\<langle>M\<rangle>_g \<longrightarrow> \<box>\<diamond>\<langle>M\<rangle>_g"
  proof -
    have 1: "\<turnstile> \<box>[N]_f \<and> SF(A)_f \<and> \<box>F \<and> \<box>\<diamond>Enabled \<langle>M\<rangle>_g \<and> \<not>\<box>\<diamond>\<langle>M\<rangle>_g \<longrightarrow> \<diamond>\<box>P"
    proof -
      have A: "\<turnstile> \<box>[N]_f \<and> SF(A)_f \<and> \<box>F \<and> \<box>\<diamond>Enabled \<langle>M\<rangle>_g \<and> \<not>\<box>\<diamond>\<langle>M\<rangle>_g \<longrightarrow>
                 \<box>(\<box>[N]_f \<and> SF(A)_f \<and> \<box>F) \<and> \<diamond>\<box>(\<box>\<diamond>Enabled \<langle>M\<rangle>_g \<and> \<box>[\<not>M]_g)"
        unfolding STL6[int_rewrite] (* important to do this before STL5 is applied *)
        by (auto simp: STL5[int_rewrite] dualization_rew)
      have B: "\<turnstile> \<box>(\<box>[N]_f \<and> SF(A)_f \<and> \<box>F) \<and> \<diamond>\<box>(\<box>\<diamond>Enabled \<langle>M\<rangle>_g \<and> \<box>[\<not>M]_g) \<longrightarrow>
                 \<diamond>((\<box>[N]_f \<and> SF(A)_f \<and> \<box>F) \<and> \<box>(\<box>\<diamond>Enabled \<langle>M\<rangle>_g \<and> \<box>[\<not>M]_g))"
        by (rule SE2)
      from lift_imp_trans[OF A B]
      have "\<turnstile> \<box>[N]_f \<and> SF(A)_f \<and> \<box>F \<and> \<box>\<diamond>Enabled \<langle>M\<rangle>_g \<and> \<not>\<box>\<diamond>\<langle>M\<rangle>_g \<longrightarrow>
              \<diamond>((\<box>[N]_f \<and> SF(A)_f \<and> \<box>F) \<and> (\<box>\<diamond>Enabled \<langle>M\<rangle>_g \<and> \<box>[\<not>M]_g))"
        by (simp add: STL5[int_rewrite])
      moreover
      from h1 have "|~ [N]_f \<longrightarrow> [\<not>M]_g \<longrightarrow> [N \<and> \<not>B]_f" by (auto simp: actrans_def angle_actrans_def)
      hence "\<turnstile> \<box>[[N]_f]_f \<longrightarrow> \<box>[[\<not>M]_g \<longrightarrow> [N \<and> \<not>B]_f]_f" by (rule M2)
      from lift_imp_trans[OF this ax4] have "\<turnstile> \<box>[N]_f \<and> \<box>[\<not>M]_g \<longrightarrow> \<box>[N \<and> \<not>B]_f"
        by (force intro: T4[unlift_rule])
      with h4 have "\<turnstile> (\<box>[N]_f \<and> SF(A)_f \<and> \<box>F) \<and> (\<box>\<diamond>Enabled \<langle>M\<rangle>_g \<and> \<box>[\<not>M]_g) \<longrightarrow> \<diamond>\<box>P"
        by force
      from STL4_eve[OF this]
      have "\<turnstile> \<diamond>((\<box>[N]_f \<and> SF(A)_f \<and> \<box>F) \<and> (\<box>\<diamond>Enabled \<langle>M\<rangle>_g \<and> \<box>[\<not>M]_g)) \<longrightarrow> \<diamond>\<box>P" by simp
      ultimately
      show ?thesis by (rule lift_imp_trans)
    qed
    have 2: "\<turnstile> \<box>[N]_f \<and> SF(A)_f \<and> \<box>\<diamond>Enabled \<langle>M\<rangle>_g \<and> \<diamond>\<box>P \<longrightarrow> \<box>\<diamond>\<langle>M\<rangle>_g"
    proof -
      have "\<turnstile> \<box>\<diamond>(P \<and> Enabled \<langle>M\<rangle>_g) \<and> SF(A)_f \<longrightarrow> \<box>\<diamond>\<langle>A\<rangle>_f"
        using h3[THEN STL4_eve, THEN STL4] by (auto simp: StrongF_def)
      with E28 have A: "\<turnstile> \<diamond>\<box>P \<and> \<box>\<diamond>Enabled \<langle>M\<rangle>_g \<and> SF(A)_f \<longrightarrow> \<box>\<diamond>\<langle>A\<rangle>_f"
        by force
      have B: "\<turnstile> \<box>[N]_f \<and> \<diamond>\<box>P \<and>  \<box>\<diamond>\<langle>A\<rangle>_f \<longrightarrow> \<box>\<diamond>\<langle>M\<rangle>_g"
      proof -
        from M1[of P f] have "\<turnstile> \<box>P \<and> \<box>\<diamond>\<langle>N \<and> A\<rangle>_f \<longrightarrow> \<box>\<diamond>\<langle>(P \<and> \<circ>P) \<and> (N \<and> A)\<rangle>_f"
          by (force intro: AA29[unlift_rule])
        hence "\<turnstile> \<diamond>\<box>(\<box>P \<and> \<box>\<diamond>\<langle>N \<and> A\<rangle>_f) \<longrightarrow> \<diamond>\<box>\<box>\<diamond>\<langle>(P \<and> \<circ>P) \<and> (N \<and> A)\<rangle>_f"
          by (rule STL4_eve[OF STL4])
        hence "\<turnstile> \<diamond>\<box>P \<and> \<box>\<diamond>\<langle>N \<and> A\<rangle>_f \<longrightarrow> \<box>\<diamond>\<langle>(P \<and> \<circ>P) \<and> (N \<and> A)\<rangle>_f"
          by (simp add: STL6[int_rewrite])
        with AA29[of N f A]
        have B1: "\<turnstile> \<box>[N]_f \<and> \<diamond>\<box>P \<and>  \<box>\<diamond>\<langle>A\<rangle>_f \<longrightarrow> \<box>\<diamond>\<langle>(P \<and> \<circ>P) \<and> (N \<and> A)\<rangle>_f" by force
        from h2 have "|~ \<langle>(P \<and> \<circ>P) \<and> (N \<and> A)\<rangle>_f \<longrightarrow> \<langle>N \<and> B\<rangle>_f"
          by (auto simp: angle_actrans_sem[unlifted])
        from B1 this[THEN AA25, THEN STL4] have "\<turnstile> \<box>[N]_f \<and> \<diamond>\<box>P \<and>  \<box>\<diamond>\<langle>A\<rangle>_f \<longrightarrow> \<box>\<diamond>\<langle>N \<and> B\<rangle>_f"
          by (rule lift_imp_trans)
        moreover
        have "\<turnstile> \<box>\<diamond>\<langle>N \<and> B\<rangle>_f \<longrightarrow> \<box>\<diamond>\<langle>M\<rangle>_g" by (rule h1[THEN AA25, THEN STL4])
        ultimately show ?thesis by (rule lift_imp_trans)
      qed
      from A B show ?thesis by force
    qed
    from 1 2 show ?thesis by force
  qed
  thus ?thesis by (auto simp: StrongF_def)
qed

text {* This is the lattice rule from TLA *}

theorem wf_leadsto:
  assumes h1: "wf r"
      and h2: "\<And>x. \<turnstile> F x \<leadsto> (G \<or> (\<exists>y. #((y,x) \<in> r) \<and> F y))"
  shows       "\<turnstile> F x \<leadsto> G"
using h1
proof (rule wf_induct)
  fix x
  assume ih: "\<forall>y. (y, x) \<in> r \<longrightarrow> (\<turnstile> F y \<leadsto> G)"
  show "\<turnstile> F x \<leadsto> G"
  proof -
    from ih have "\<turnstile> (\<exists>y. #((y,x) \<in> r) \<and> F y) \<leadsto> G"
      by (force simp: LT21[int_rewrite] LT33[int_rewrite])
    with h2 show ?thesis by (force intro: LT19[unlift_rule])
  qed
qed

subsection "Stuttering Invariance"

theorem stut_Enabled: "STUTINV Enabled \<langle>F\<rangle>_v"
  by (auto simp: enabled_def stutinv_def dest!: sim_first)

theorem stut_WF: "NSTUTINV F \<Longrightarrow> STUTINV WF(F)_v"
  by (auto simp: WeakF_def stut_Enabled bothstutinvs)

theorem stut_SF: "NSTUTINV F \<Longrightarrow> STUTINV SF(F)_v"
  by (auto simp: StrongF_def stut_Enabled bothstutinvs)

lemmas livestutinv = stut_WF stut_SF stut_Enabled

end


theory "AList-Utils-Nominal"
imports "AList-Utils" "Nominal-Utils"
begin

subsubsection {* Freshness lemmas related to associative lists *}

lemma domA_not_fresh:
  "x \<in> domA \<Gamma> \<Longrightarrow> \<not>(atom x \<sharp> \<Gamma>)"
  by (induct \<Gamma>, auto simp add: fresh_Cons fresh_Pair)

lemma fresh_delete:
  assumes "atom x \<sharp> \<Gamma>"
  shows "atom x \<sharp> (delete v \<Gamma>)"
using assms
by(induct \<Gamma>)(auto simp add: fresh_Cons)

lemma fv_delete_subset:
  "fv (delete v \<Gamma>) \<subseteq> fv \<Gamma>"
  using fresh_delete unfolding fresh_def fv_def by auto

lemma fresh_heap_expr:
  assumes "a \<sharp> \<Gamma>"
  and "(x,e) \<in> set \<Gamma>"
  shows "a \<sharp> e"
  using assms
  by (metis fresh_list_elem fresh_Pair)

lemma fresh_heap_expr':
  assumes "a \<sharp> \<Gamma>"
  and "e \<in> snd ` set \<Gamma>"
  shows "a \<sharp> e"
  using assms
  by (induct \<Gamma>, auto simp add: fresh_Cons fresh_Pair)

lemma fresh_star_heap_expr':
  assumes "S \<sharp>* \<Gamma>"
  and "e \<in> snd ` set \<Gamma>"
  shows "S \<sharp>* e"
  using assms
  by (metis fresh_star_def fresh_heap_expr')

lemma fresh_map_of:
  assumes "x \<in> domA \<Gamma>"
  assumes "a \<sharp> \<Gamma>"
  shows "a \<sharp> the (map_of \<Gamma> x)"
  using assms
  by (induct \<Gamma>)(auto simp add: fresh_Cons fresh_Pair)

lemma fresh_star_map_of:
  assumes "x \<in> domA \<Gamma>"
  assumes "a \<sharp>* \<Gamma>"
  shows "a \<sharp>* the (map_of \<Gamma> x)"
  using assms by (simp add: fresh_star_def fresh_map_of)

lemma domA_fv_subset: "domA \<Gamma> \<subseteq> fv \<Gamma>"
  by (induction \<Gamma>) auto

lemma map_of_fv_subset: "x \<in> domA \<Gamma> \<Longrightarrow> fv (the (map_of \<Gamma> x)) \<subseteq> fv \<Gamma>"
  by (induction \<Gamma>) auto

subsubsection {* Equivariance lemmas *}

lemma domA[eqvt]:
  "\<pi> \<bullet> domA \<Gamma> = domA (\<pi> \<bullet> \<Gamma>)"
  by (simp add: domA_def)

subsubsection {* Freshness and distinctness *}

subsubsection {* Pure codomains *}

lemma domA_fv_pure:
  fixes \<Gamma> :: "('a::at_base \<times> 'b::pure) list"
  shows  "fv \<Gamma> = domA \<Gamma>"
  apply (induct \<Gamma>)
  apply simp
  apply (case_tac a)
  apply (simp)
  done

lemma domA_fresh_pure:
  fixes \<Gamma> :: "('a::at_base \<times> 'b::pure) list"
  shows  "x \<in> domA \<Gamma> \<longleftrightarrow> \<not>(atom x \<sharp> \<Gamma>)"
  unfolding domA_fv_pure[symmetric]
  by (auto simp add: fv_def fresh_def)

end