(*
(C) Copyright Andreas Viktor Hess, DTU, 2015-2020

All Rights Reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

- Redistributions of source code must retain the above copyright
  notice, this list of conditions and the following disclaimer.

- Redistributions in binary form must reproduce the above copyright
  notice, this list of conditions and the following disclaimer in the
  documentation and/or other materials provided with the distribution.

- Neither the name of the copyright holder nor the names of its
  contributors may be used to endorse or promote products
  derived from this software without specific prior written
  permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)

(*  Title:      Messages.thy
    Author:     Andreas Viktor Hess, DTU
*)

section \<open>Protocol Messages as (First-Order) Terms\<close>

theory Messages
  imports Miscellaneous "First_Order_Terms.Term"
begin

subsection \<open>Term-related definitions: subterms and free variables\<close>
abbreviation "the_Fun \<equiv> un_Fun1"
lemmas the_Fun_def = un_Fun1_def

fun subterms::"('a,'b) term \<Rightarrow> ('a,'b) terms" where
  "subterms (Var x) = {Var x}"
| "subterms (Fun f T) = {Fun f T} \<union> (\<Union>t \<in> set T. subterms t)"

abbreviation subtermeq (infix "\<sqsubseteq>" 50) where "t' \<sqsubseteq> t \<equiv> (t' \<in> subterms t)"
abbreviation subterm (infix "\<sqsubset>" 50) where "t' \<sqsubset> t \<equiv> (t' \<sqsubseteq> t \<and> t' \<noteq> t)"

abbreviation "subterms\<^sub>s\<^sub>e\<^sub>t M \<equiv> \<Union>(subterms ` M)"
abbreviation subtermeqset (infix "\<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t" 50) where "t \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t M \<equiv> (t \<in> subterms\<^sub>s\<^sub>e\<^sub>t M)"

abbreviation fv where "fv \<equiv> vars_term"
lemmas fv_simps = term.simps(17,18)

fun fv\<^sub>s\<^sub>e\<^sub>t where "fv\<^sub>s\<^sub>e\<^sub>t M = \<Union>(fv ` M)"

abbreviation fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r where "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r p \<equiv> case p of (t,t') \<Rightarrow> fv t \<union> fv t'"

fun fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s where "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F = \<Union>(fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r ` set F)"

abbreviation ground where "ground M \<equiv> fv\<^sub>s\<^sub>e\<^sub>t M = {}"

subsection \<open>Variants that return lists insteads of sets\<close>
fun fv_list where
  "fv_list (Var x) = [x]"
| "fv_list (Fun f T) = concat (map fv_list T)"

definition fv_list\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s where
  "fv_list\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \<equiv> concat (map (\<lambda>(t,t'). fv_list t@fv_list t') F)"

fun subterms_list::"('a,'b) term \<Rightarrow> ('a,'b) term list" where
  "subterms_list (Var x) = [Var x]"
| "subterms_list (Fun f T) = remdups (Fun f T#concat (map subterms_list T))"

lemma fv_list_is_fv: "fv t = set (fv_list t)"
by (induct t) auto

lemma fv_list\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_is_fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s: "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F = set (fv_list\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F)"
by (induct F) (auto simp add: fv_list_is_fv fv_list\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_def)

lemma subterms_list_is_subterms: "subterms t = set (subterms_list t)"
by (induct t) auto

subsection \<open>The subterm relation defined as a function\<close>
fun subterm_of where
  "subterm_of t (Var y) = (t = Var y)"
| "subterm_of t (Fun f T) = (t = Fun f T \<or> list_ex (subterm_of t) T)"

lemma subterm_of_iff_subtermeq[code_unfold]: "t \<sqsubseteq> t' = subterm_of t t'"
proof (induction t')
  case (Fun f T) thus ?case
  proof (cases "t = Fun f T")
    case False thus ?thesis
      using Fun.IH subterm_of.simps(2)[of t f T]
      unfolding list_ex_iff by fastforce
  qed simp
qed simp

lemma subterm_of_ex_set_iff_subtermeqset[code_unfold]: "t \<sqsubseteq>\<^sub>s\<^sub>e\<^sub>t M = (\<exists>t' \<in> M. subterm_of t t')"
using subterm_of_iff_subtermeq by blast

subsection \<open>The subterm relation is a partial order on terms\<close>

interpretation "term": ordering "(\<sqsubseteq>)" "(\<sqsubset>)"
proof
  show "s \<sqsubseteq> s" for s :: "('a,'b) term"
    by (induct s rule: subterms.induct) auto

  show trans: "s \<sqsubseteq> t \<Longrightarrow> t \<sqsubseteq> u \<Longrightarrow> s \<sqsubseteq> u" for s t u :: "('a,'b) term"
    by (induct u rule: subterms.induct) auto

  show "s \<sqsubseteq> t \<Longrightarrow> t \<sqsubseteq> s \<Longrightarrow> s = t" for s t :: "('a,'b) term"
  proof (induction s arbitrary: t rule: subterms.induct[case_names Var Fun])
    case (Fun f T)
    { assume 0: "t \<noteq> Fun f T"
      then obtain u::"('a,'b) term" where u: "u \<in> set T" "t \<sqsubseteq> u" using Fun.prems(2) by auto
      hence 1: "Fun f T \<sqsubseteq> u" using trans[OF Fun.prems(1)] by simp

      have 2: "u \<sqsubseteq> Fun f T"
        by (cases u) (use u(1) in force, use u(1) subterms.simps(2)[of f T] in fastforce)
      hence 3: "u = Fun f T" using Fun.IH[OF u(1) _ 1] by simp

      have "u \<sqsubseteq> t" using trans[OF 2 Fun.prems(1)] by simp
      hence 4: "u = t" using Fun.IH[OF u(1) _ u(2)] by simp

      have "t = Fun f T" using 3 4 by simp
      hence False using 0 by simp
    }
    thus ?case by auto
  qed simp
  show \<open>s \<sqsubset> t \<longleftrightarrow> s \<sqsubset> t\<close> for s t :: "('a,'b) term" ..
qed

interpretation "term": order "(\<sqsubseteq>)" "(\<sqsubset>)"
  by (rule ordering_orderI) (fact term.ordering_axioms)

subsection \<open>Lemmata concerning subterms and free variables\<close>
lemma fv_list\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_append: "fv_list\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F@G) = fv_list\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F@fv_list\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s G"
by (simp add: fv_list\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_def)

lemma distinct_fv_list_idx_fv_disjoint:
  assumes t: "distinct (fv_list t)" "Fun f T \<sqsubseteq> t"
    and ij: "i < length T" "j < length T" "i < j"
  shows "fv (T ! i) \<inter> fv (T ! j) = {}"
using t
proof (induction t rule: fv_list.induct)
  case (2 g S)
  have "distinct (fv_list s)" when s: "s \<in> set S" for s
    by (metis (no_types, lifting) s "2.prems"(1) concat_append distinct_append
          map_append split_list fv_list.simps(2) concat.simps(2) list.simps(9))
  hence IH: "fv (T ! i) \<inter> fv (T ! j) = {}"
    when s: "s \<in> set S" "Fun f T \<sqsubseteq> s" for s
    using "2.IH" s by blast

  show ?case
  proof (cases "Fun f T = Fun g S")
    case True
    define U where "U \<equiv> map fv_list T"

    have a: "distinct (concat U)"
      using "2.prems"(1) True unfolding U_def by auto

    have b: "i < length U" "j < length U"
      using ij(1,2) unfolding U_def by simp_all

    show ?thesis
      using b distinct_concat_idx_disjoint[OF a b ij(3)]
            fv_list_is_fv[of "T ! i"] fv_list_is_fv[of "T ! j"]
      unfolding U_def by force
  qed (use IH "2.prems"(2) in auto)
qed force

lemmas subtermeqI'[intro] = term.eq_refl

lemma finite_fv_set[intro]: "finite M \<Longrightarrow> finite (fv\<^sub>s\<^sub>e\<^sub>t M)"
by auto

lemma finite_fun_symbols[simp]: "finite (funs_term t)"
by (induct t) simp_all

lemma fv_set_mono: "M \<subseteq> N \<Longrightarrow> fv\<^sub>s\<^sub>e\<^sub>t M \<subseteq> fv\<^sub>s\<^sub>e\<^sub>t N"
by auto

lemma subterms\<^sub>s\<^sub>e\<^sub>t_mono: "M \<subseteq> N \<Longrightarrow> subterms\<^sub>s\<^sub>e\<^sub>t M \<subseteq> subterms\<^sub>s\<^sub>e\<^sub>t N"
by auto

lemma ground_empty[simp]: "ground {}"
by simp

lemma ground_subset: "M \<subseteq> N \<Longrightarrow> ground N \<Longrightarrow> ground M"
by auto

lemma fv_map_fv_set: "\<Union>(set (map fv L)) = fv\<^sub>s\<^sub>e\<^sub>t (set L)"
by (induct L) auto

lemma fv\<^sub>s\<^sub>e\<^sub>t_union: "fv\<^sub>s\<^sub>e\<^sub>t (M \<union> N) = fv\<^sub>s\<^sub>e\<^sub>t M \<union> fv\<^sub>s\<^sub>e\<^sub>t N"
by auto

lemma finite_subset_Union:
  fixes A::"'a set" and f::"'a \<Rightarrow> 'b set"
  assumes "finite (\<Union>a \<in> A. f a)"
  shows "\<exists>B. finite B \<and> B \<subseteq> A \<and> (\<Union>b \<in> B. f b) = (\<Union>a \<in> A. f a)"
by (metis assms eq_iff finite_subset_image finite_UnionD)

lemma inv_set_fv: "finite M \<Longrightarrow> \<Union>(set (map fv (inv set M))) = fv\<^sub>s\<^sub>e\<^sub>t M"
using fv_map_fv_set[of "inv set M"] inv_set_fset by auto

lemma ground_subterm: "fv t = {} \<Longrightarrow> t' \<sqsubseteq> t \<Longrightarrow> fv t' = {}" by (induct t) auto

lemma empty_fv_not_var: "fv t = {} \<Longrightarrow> t \<noteq> Var x" by auto

lemma empty_fv_exists_fun: "fv t = {} \<Longrightarrow> \<exists>f X. t = Fun f X" by (cases t) auto

lemma vars_iff_subtermeq: "x \<in> fv t \<longleftrightarrow> Var x \<sqsubseteq> t" by (induct t) auto

lemma vars_iff_subtermeq_set: "x \<in> fv\<^sub>s\<^sub>e\<^sub>t M \<longleftrightarrow> Var x \<in> subterms\<^sub>s\<^sub>e\<^sub>t M"
using vars_iff_subtermeq[of x] by auto

lemma vars_if_subtermeq_set: "Var x \<in> subterms\<^sub>s\<^sub>e\<^sub>t M \<Longrightarrow> x \<in> fv\<^sub>s\<^sub>e\<^sub>t M"
by (metis vars_iff_subtermeq_set)

lemma subtermeq_set_if_vars: "x \<in> fv\<^sub>s\<^sub>e\<^sub>t M \<Longrightarrow> Var x \<in> subterms\<^sub>s\<^sub>e\<^sub>t M"
by (metis vars_iff_subtermeq_set)

lemma vars_iff_subterm_or_eq: "x \<in> fv t \<longleftrightarrow> Var x \<sqsubset> t \<or> Var x = t"
by (induct t) (auto simp add: vars_iff_subtermeq)

lemma var_is_subterm: "x \<in> fv t \<Longrightarrow> Var x \<in> subterms t"
by (simp add: vars_iff_subtermeq)

lemma subterm_is_var: "Var x \<in> subterms t \<Longrightarrow> x \<in> fv t"
by (simp add: vars_iff_subtermeq)

lemma no_var_subterm: "\<not>t \<sqsubset> Var v" by auto

lemma fun_if_subterm: "t \<sqsubset> u \<Longrightarrow> \<exists>f X. u = Fun f X" by (induct u) simp_all

lemma subtermeq_vars_subset: "M \<sqsubseteq> N \<Longrightarrow> fv M \<subseteq> fv N" by (induct N) auto

lemma fv_subterms[simp]: "fv\<^sub>s\<^sub>e\<^sub>t (subterms t) = fv t"
by (induct t) auto

lemma fv_subterms_set[simp]: "fv\<^sub>s\<^sub>e\<^sub>t (subterms\<^sub>s\<^sub>e\<^sub>t M) = fv\<^sub>s\<^sub>e\<^sub>t M"
using subtermeq_vars_subset by auto

lemma fv_subset: "t \<in> M \<Longrightarrow> fv t \<subseteq> fv\<^sub>s\<^sub>e\<^sub>t M"
by auto

lemma fv_subset_subterms: "t \<in> subterms\<^sub>s\<^sub>e\<^sub>t M \<Longrightarrow> fv t \<subseteq> fv\<^sub>s\<^sub>e\<^sub>t M"
using fv_subset fv_subterms_set by metis

lemma subterms_finite[simp]: "finite (subterms t)" by (induction rule: subterms.induct) auto

lemma subterms_union_finite: "finite M \<Longrightarrow> finite (\<Union>t \<in> M. subterms t)"
by (induction rule: subterms.induct) auto

lemma subterms_subset: "t' \<sqsubseteq> t \<Longrightarrow> subterms t' \<subseteq> subterms t"
by (induction rule: subterms.induct) auto

lemma subterms_subset_set: "M \<subseteq> subterms t \<Longrightarrow> subterms\<^sub>s\<^sub>e\<^sub>t M \<subseteq> subterms t"
by (metis SUP_least contra_subsetD subterms_subset)

lemma subset_subterms_Union[simp]: "M \<subseteq> subterms\<^sub>s\<^sub>e\<^sub>t M" by auto

lemma in_subterms_Union: "t \<in> M \<Longrightarrow> t \<in> subterms\<^sub>s\<^sub>e\<^sub>t M" using subset_subterms_Union by blast

lemma in_subterms_subset_Union: "t \<in> subterms\<^sub>s\<^sub>e\<^sub>t M \<Longrightarrow> subterms t \<subseteq> subterms\<^sub>s\<^sub>e\<^sub>t M"
using subterms_subset by auto

lemma subterm_param_split:
  assumes "t \<sqsubset> Fun f X"
  shows "\<exists>pre x suf. t \<sqsubseteq> x \<and> X = pre@x#suf"
proof -
  obtain x where "t \<sqsubseteq> x" "x \<in> set X" using assms by auto
  then obtain pre suf where "X = pre@x#suf" "x \<notin> set pre \<or> x \<notin> set suf"
    by (meson split_list_first split_list_last)
  thus ?thesis using \<open>t \<sqsubseteq> x\<close> by auto
qed

lemma ground_iff_no_vars: "ground (M::('a,'b) terms) \<longleftrightarrow> (\<forall>v. Var v \<notin> (\<Union>m \<in> M. subterms m))"
proof
  assume "ground M"
  hence "\<forall>v. \<forall>m \<in> M. v \<notin> fv m" by auto
  hence "\<forall>v. \<forall>m \<in> M. Var v \<notin> subterms m" by (simp add: vars_iff_subtermeq)
  thus "(\<forall>v. Var v \<notin> (\<Union>m \<in> M. subterms m))" by simp
next
  assume no_vars: "\<forall>v. Var v \<notin> (\<Union>m \<in> M. subterms m)"
  moreover
  { assume "\<not>ground M"
    then obtain v and m::"('a,'b) term" where "m \<in> M" "fv m \<noteq> {}" "v \<in> fv m" by auto
    hence "Var v \<in> (subterms m)" by (simp add: vars_iff_subtermeq)
    hence "\<exists>v. Var v \<in> (\<Union>t \<in> M. subterms t)" using \<open>m \<in> M\<close> by auto
    hence False using no_vars by simp
  }
  ultimately show "ground M" by blast
qed

lemma index_Fun_subterms_subset[simp]: "i < length T \<Longrightarrow> subterms (T ! i) \<subseteq> subterms (Fun f T)"
by auto

lemma index_Fun_fv_subset[simp]: "i < length T \<Longrightarrow> fv (T ! i) \<subseteq> fv (Fun f T)"
using subtermeq_vars_subset by fastforce

lemma subterms_union_ground:
  assumes "ground M"
  shows "ground (subterms\<^sub>s\<^sub>e\<^sub>t M)"
proof -
  { fix t assume "t \<in> M"
    hence "fv t = {}"
      using ground_iff_no_vars[of M] assms
      by auto
    hence "\<forall>t' \<in> subterms t. fv t' = {}" using subtermeq_vars_subset[of _ t] by simp
    hence "ground (subterms t)" by auto
  }
  thus ?thesis by auto
qed

lemma Var_subtermeq: "t \<sqsubseteq> Var v \<Longrightarrow> t = Var v" by simp

lemma subterms_const: "subterms (Fun f []) = {Fun f []}" by simp

lemma subterm_subtermeq_neq: "\<lbrakk>t \<sqsubset> u; u \<sqsubseteq> v\<rbrakk> \<Longrightarrow> t \<noteq> v"
by (metis term.eq_iff)

lemma subtermeq_subterm_neq: "\<lbrakk>t \<sqsubseteq> u; u \<sqsubset> v\<rbrakk> \<Longrightarrow> t \<noteq> v"
by (metis term.eq_iff)

lemma subterm_size_lt: "x \<sqsubset> y \<Longrightarrow> size x < size y"
using not_less_eq size_list_estimation by (induct y, simp, fastforce)

lemma in_subterms_eq: "\<lbrakk>x \<in> subterms y; y \<in> subterms x\<rbrakk> \<Longrightarrow> subterms x = subterms y"
using term.antisym by auto

lemma Fun_gt_params: "Fun f X \<notin> (\<Union>x \<in> set X. subterms x)"
proof -
  have "size_list size X < size (Fun f X)" by simp
  hence "Fun f X \<notin> set X" by (meson less_not_refl size_list_estimation)
  hence "\<forall>x \<in> set X. Fun f X \<notin> subterms x \<or> x \<notin> subterms (Fun f X)"
    by (metis term.antisym[of "Fun f X" _])
  moreover have "\<forall>x \<in> set X. x \<in> subterms (Fun f X)" by fastforce
  ultimately show ?thesis by auto
qed

lemma params_subterms[simp]: "set X \<subseteq> subterms (Fun f X)" by auto

lemma params_subterms_Union[simp]: "subterms\<^sub>s\<^sub>e\<^sub>t (set X) \<subseteq> subterms (Fun f X)" by auto

lemma Fun_subterm_inside_params: "t \<sqsubset> Fun f X \<longleftrightarrow> t \<in> (\<Union>x \<in> (set X). subterms x)"
using Fun_gt_params by fastforce

lemma Fun_param_is_subterm: "x \<in> set X \<Longrightarrow> x \<sqsubset> Fun f X"
using Fun_subterm_inside_params by fastforce

lemma Fun_param_in_subterms: "x \<in> set X \<Longrightarrow> x \<in> subterms (Fun f X)"
using Fun_subterm_inside_params by fastforce

lemma Fun_not_in_param: "x \<in> set X \<Longrightarrow> \<not>Fun f X \<sqsubset> x"
using term.antisym by fast

lemma Fun_ex_if_subterm: "t \<sqsubset> s \<Longrightarrow> \<exists>f T. Fun f T \<sqsubseteq> s \<and> t \<in> set T"
proof (induction s)
  case (Fun f T)
  then obtain s' where s': "s' \<in> set T" "t \<sqsubseteq> s'" by auto
  show ?case
  proof (cases "t = s'")
    case True thus ?thesis using s' by blast
  next
    case False
    thus ?thesis
      using Fun.IH[OF s'(1)] s'(2) term.order_trans[OF _ Fun_param_in_subterms[OF s'(1), of f]]
      by metis
  qed
qed simp

lemma const_subterm_obtain:
  assumes "fv t = {}"
  obtains c where "Fun c [] \<sqsubseteq> t"
using assms
proof (induction t)
  case (Fun f T) thus ?case by (cases "T = []") force+
qed simp

lemma const_subterm_obtain': "fv t = {} \<Longrightarrow> \<exists>c. Fun c [] \<sqsubseteq> t"
by (metis const_subterm_obtain)

lemma subterms_singleton:
  assumes "(\<exists>v. t = Var v) \<or> (\<exists>f. t = Fun f [])"
  shows "subterms t = {t}"
using assms by (cases t) auto

lemma subtermeq_Var_const:
  assumes "s \<sqsubseteq> t"
  shows "t = Var v \<Longrightarrow> s = Var v" "t = Fun f [] \<Longrightarrow> s = Fun f []"
using assms by fastforce+

lemma subterms_singleton':
  assumes "subterms t = {t}"
  shows "(\<exists>v. t = Var v) \<or> (\<exists>f. t = Fun f [])"
proof (cases t)
  case (Fun f T)
  { fix s S assume "T = s#S"
    hence "s \<in> subterms t" using Fun by auto
    hence "s = t" using assms by auto
    hence False
      using Fun_param_is_subterm[of s "s#S" f] \<open>T = s#S\<close> Fun
      by auto
  }
  hence "T = []" by (cases T) auto
  thus ?thesis using Fun by simp
qed (simp add: assms)

lemma funs_term_subterms_eq[simp]:
  "(\<Union>s \<in> subterms t. funs_term s) = funs_term t"
  "(\<Union>s \<in> subterms\<^sub>s\<^sub>e\<^sub>t M. funs_term s) = \<Union>(funs_term ` M)"
proof -
  show "\<And>t. \<Union>(funs_term ` subterms t) = funs_term t"
    using term.order_refl subtermeq_imp_funs_term_subset by blast
  thus "\<Union>(funs_term ` (subterms\<^sub>s\<^sub>e\<^sub>t M)) = \<Union>(funs_term ` M)" by force
qed

lemmas subtermI'[intro] = Fun_param_is_subterm

lemma funs_term_Fun_subterm: "f \<in> funs_term t \<Longrightarrow> \<exists>T. Fun f T \<in> subterms t"
proof (induction t)
  case (Fun g T)
  hence "f = g \<or> (\<exists>s \<in> set T. f \<in> funs_term s)" by simp
  thus ?case
  proof
    assume "\<exists>s \<in> set T. f \<in> funs_term s"
    then obtain s where "s \<in> set T" "\<exists>T. Fun f T \<in> subterms s" using Fun.IH by auto
    thus ?thesis by auto
  qed (auto simp add: Fun)
qed simp

lemma funs_term_Fun_subterm': "Fun f T \<in> subterms t \<Longrightarrow> f \<in> funs_term t"
by (induct t) auto

lemma fv_disj_Fun_subterm_param_cases:
  assumes "fv t \<inter> X = {}" "Fun f T \<in> subterms t"
  shows "T = [] \<or> (\<exists>s\<in>set T. s \<notin> Var ` X)"
proof (cases T)
  case (Cons s S)
  hence "s \<in> subterms t"
    using assms(2) term.order_trans[of _ "Fun f T" t]
    by auto
  hence "fv s \<inter> X = {}" using assms(1) fv_subterms by force
  thus ?thesis using Cons by auto
qed simp

lemma fv_eq_FunI:
  assumes "length T = length S" "\<And>i. i < length T \<Longrightarrow> fv (T ! i) = fv (S ! i)"
  shows "fv (Fun f T) = fv (Fun g S)"
using assms
proof (induction T arbitrary: S)
  case (Cons t T S')
  then obtain s S where S': "S' = s#S" by (cases S') simp_all
  thus ?case using Cons by fastforce
qed simp

lemma fv_eq_FunI':
  assumes "length T = length S" "\<And>i. i < length T \<Longrightarrow> x \<in> fv (T ! i) \<longleftrightarrow> x \<in> fv (S ! i)"
  shows "x \<in> fv (Fun f T) \<longleftrightarrow> x \<in> fv (Fun g S)"
using assms
proof (induction T arbitrary: S)
  case (Cons t T S')
  then obtain s S where S': "S' = s#S" by (cases S') simp_all
  thus ?case using Cons by fastforce
qed simp

lemma finite_fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s[simp]: "finite (fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s x)" by auto

lemma fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_Nil[simp]: "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s [] = {}" by simp

lemma fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_singleton[simp]: "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s [(t,s)] = fv t \<union> fv s" by simp

lemma fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_Cons: "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s ((s,t)#F) = fv s \<union> fv t \<union> fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F" by simp

lemma fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_append: "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (F@G) = fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \<union> fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s G" by simp

lemma fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_mono: "set M \<subseteq> set N \<Longrightarrow> fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s M \<subseteq> fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s N" by auto

lemma fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_inI[intro]:
  "f \<in> set F \<Longrightarrow> x \<in> fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r f \<Longrightarrow> x \<in> fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F"
  "f \<in> set F \<Longrightarrow> x \<in> fv (fst f) \<Longrightarrow> x \<in> fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F"
  "f \<in> set F \<Longrightarrow> x \<in> fv (snd f) \<Longrightarrow> x \<in> fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F"
  "(t,s) \<in> set F \<Longrightarrow> x \<in> fv t \<Longrightarrow> x \<in> fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F"
  "(t,s) \<in> set F \<Longrightarrow> x \<in> fv s \<Longrightarrow> x \<in> fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F"
using UN_I by fastforce+

lemma fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s_cons_subset: "fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s F \<subseteq> fv\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s (f#F)"
by auto

subsection \<open>Other lemmata\<close>
lemma nonvar_term_has_composed_shallow_term:
  fixes t::"('f,'v) term"
  assumes "\<not>(\<exists>x. t = Var x)"
  shows "\<exists>f T. Fun f T \<sqsubseteq> t \<and> (\<forall>s \<in> set T. (\<exists>c. s = Fun c []) \<or> (\<exists>x. s = Var x))"
proof -
  let ?Q = "\<lambda>S. \<forall>s \<in> set S. (\<exists>c. s = Fun c []) \<or> (\<exists>x. s = Var x)"
  let ?P = "\<lambda>t. \<exists>g S. Fun g S \<sqsubseteq> t \<and> ?Q S"
  { fix t::"('f,'v) term"
    have "(\<exists>x. t = Var x) \<or> ?P t"
    proof (induction t)
      case (Fun h R) show ?case
      proof (cases "R = [] \<or> (\<forall>r \<in> set R. \<exists>x. r = Var x)")
        case False
        then obtain r g S where "r \<in> set R" "?P r" "Fun g S \<sqsubseteq> r" "?Q S" using Fun.IH by fast
        thus ?thesis by auto
      qed force
    qed simp
  } thus ?thesis using assms by blast
qed

end


(*File: Reachability.thy
  Author: L Beringer & M Hofmann, LMU Munich
  Date: 05/12/2008
  Purpose: Operational judgement that extends MultiStep by
           entering subframes. Necessary for the interpretation
           of invariants.
*)
(*<*)
theory Reachability imports Language begin
(*>*)

subsection\<open>Reachability relation\<close>

text\<open>The second auxiliary operational judgement is required for the
interpretation of invariants and method invariants. Invariants are
expected to be satisfied in all heap components of (future) states
that occur either in the same frame as the current state or a subframe
thereof. Likewise, method invariants are expected to be satisfied by
all heap components of states observed during the execution of a
method, including subframes. None of the previous three operational
judgements allows us to express these interpretations, as \<open>Step\<close>
injects the execution of an invoked method as a single step. Thus,
states occurring in subframes cannot be related to states occurring in
the parent frame using these judgements. This motivates the
introduction of predicates relating states $s$ and $t$ whenever the
latter can be reach from the former, i.e.~whenever $t$ occurs as a
successor of $s$ in the same frame as $s$ or one of its
subframes. Again, we first define a relation that includes an explicit
derivation height index.\<close>

inductive_set
  Reachable::"(Mbody \<times> Label \<times> State \<times> nat \<times> State) set"
where
Reachable_zero: "\<lbrakk>k=0; t=s\<rbrakk> \<Longrightarrow> (M,l,s,k,t):Reachable"
|
Reachable_step:
  "\<lbrakk> (M,l,s,n,ll,r):Step; (M,ll,r,m,t):Reachable; k=Suc m+n\<rbrakk>
  \<Longrightarrow> (M,l,s,k,t) : Reachable"
|
Reachable_invS:
  "\<lbrakk> mbody_is C m (par,code,l0); get_ins M l = Some (invokeS C m);
      s = (ops,S,h); (ops,par,R,ops1):Frame;
     ((par,code,l0), l0, ([],R,h), n, t):Reachable; k=Suc n\<rbrakk>
  \<Longrightarrow> (M,l,s,k,t) : Reachable"

text\<open>The following properties of are useful to notice.\<close>
(*<*)
lemma ZeroHeightReachableElimAux[rule_format]:
  "(M, l, s, k, r) \<in> Reachable \<Longrightarrow> 0=k \<longrightarrow> r=s"
by (erule Reachable.induct, simp_all)
(*>*)
lemma ZeroHeightReachableElim: "(M,l,s,0,r) \<in> Reachable \<Longrightarrow> r=s"
(*<*)
by (erule ZeroHeightReachableElimAux, simp)
(*>*)

lemma ReachableSplit[rule_format]:
  "(M, l,s, k, t) \<in> Reachable \<Longrightarrow>
    1 \<le> k \<longrightarrow>
   ((\<exists> n m r ll. (M,l,s,n,ll,r):Step \<and>
                 (M,ll,r,m,t):Reachable \<and> Suc m +n =k) \<or>
    (\<exists> n ops S h c m par R ops1 code l0.
          s=(ops,S,h) \<and> get_ins M l = Some (invokeS c m) \<and>
          mbody_is c m (par,code,l0) \<and> (ops,par,R,ops1):Frame \<and>
          ((par,code,l0), l0, ([],R,h), n, t):Reachable \<and> Suc n = k))"
(*<*)
apply (erule Reachable.induct, simp_all)
apply clarsimp
  apply (case_tac m, clarsimp)
    apply (drule ZeroHeightReachableElim[simplified], clarsimp)
      apply (rule, rule,rule, rule,rule, rule, rule, assumption)
      apply (rule,rule Reachable_zero) apply simp apply simp apply simp
  apply clarsimp
    apply (rule, rule,rule, rule,rule, rule,rule,assumption) apply (rule,assumption)
    apply simp
apply (rule disjI2)
apply fast
done
(*>*)

lemma Reachable_returnElim[rule_format]:
"(M,l,s,k,t) \<in> Reachable \<Longrightarrow> get_ins M l = Some vreturn \<longrightarrow> t=s"
(*<*)
apply (erule Reachable.induct)
apply clarsimp
apply clarsimp apply (drule RetElim1) apply simp apply clarsimp
apply clarsimp
done
(*>*)

text\<open>Similar to the operational semantics, we define a variation of
the reachability relation that hides the index.\<close>

definition Reach::"Mbody \<Rightarrow> Label \<Rightarrow> State \<Rightarrow> State \<Rightarrow> bool"
where "Reach M l s t = (\<exists> k . (M,l,s,k,t):Reachable)"

(*<*)
end
(*>*)


(*  Title:      HOL/Statespace/StateSpaceEx.thy
    Author:     Norbert Schirmer, TU Muenchen
*)

section \<open>Examples \label{sec:Examples}\<close>
theory StateSpaceEx
imports StateSpaceLocale StateSpaceSyntax
begin

(*<*)
syntax
 "_statespace_updates" :: "('a \<Rightarrow> 'b) \<Rightarrow> updbinds \<Rightarrow> ('a \<Rightarrow> 'b)" ("_\<langle>_\<rangle>" [900,0] 900)
(*>*)

text \<open>Did you ever dream about records with multiple inheritance?
Then you should definitely have a look at statespaces. They may be
what you are dreaming of. Or at least almost \dots\<close>

text \<open>Isabelle allows to add new top-level commands to the
system. Building on the locale infrastructure, we provide a command
\<^theory_text>\<open>statespace\<close> like this:\<close>

statespace vars =
  n::nat
  b::bool

print_locale vars_namespace
print_locale vars_valuetypes
print_locale vars

text \<open>\noindent This resembles a \<^theory_text>\<open>record\<close> definition,
but introduces sophisticated locale
infrastructure instead of HOL type schemes.  The resulting context
postulates two distinct names \<^term>\<open>n\<close> and \<^term>\<open>b\<close> and
projection~/ injection functions that convert from abstract values to
\<^typ>\<open>nat\<close> and \<open>bool\<close>. The logical content of the locale is:\<close>

locale vars' =
  fixes n::'name and b::'name
  assumes "distinct [n, b]"

  fixes project_nat::"'value \<Rightarrow> nat" and inject_nat::"nat \<Rightarrow> 'value"
  assumes "\<And>n. project_nat (inject_nat n) = n"

  fixes project_bool::"'value \<Rightarrow> bool" and inject_bool::"bool \<Rightarrow> 'value"
  assumes "\<And>b. project_bool (inject_bool b) = b"

text \<open>\noindent The HOL predicate \<^const>\<open>distinct\<close> describes
distinctness of all names in the context.  Locale \<open>vars'\<close>
defines the raw logical content that is defined in the state space
locale. We also maintain non-logical context information to support
the user:

\begin{itemize}

\item Syntax for state lookup and updates that automatically inserts
the corresponding projection and injection functions.

\item Setup for the proof tools that exploit the distinctness
information and the cancellation of projections and injections in
deductions and simplifications.

\end{itemize}

This extra-logical information is added to the locale in form of
declarations, which associate the name of a variable to the
corresponding projection and injection functions to handle the syntax
transformations, and a link from the variable name to the
corresponding distinctness theorem. As state spaces are merged or
extended there are multiple distinctness theorems in the context. Our
declarations take care that the link always points to the strongest
distinctness assumption.  With these declarations in place, a lookup
can be written as \<open>s\<cdot>n\<close>, which is translated to \<open>project_nat (s n)\<close>, and an update as \<open>s\<langle>n := 2\<rangle>\<close>, which is
translated to \<open>s(n := inject_nat 2)\<close>. We can now establish the
following lemma:\<close>

lemma (in vars) foo: "s<n := 2>\<cdot>b = s\<cdot>b" by simp

text \<open>\noindent Here the simplifier was able to refer to
distinctness of \<^term>\<open>b\<close> and \<^term>\<open>n\<close> to solve the equation.
The resulting lemma is also recorded in locale \<open>vars\<close> for
later use and is automatically propagated to all its interpretations.
Here is another example:\<close>

statespace 'a varsX = NB: vars [n=N, b=B] + vars + x::'a

text \<open>\noindent The state space \<open>varsX\<close> imports two copies
of the state space \<open>vars\<close>, where one has the variables renamed
to upper-case letters, and adds another variable \<^term>\<open>x\<close> of type
\<^typ>\<open>'a\<close>. This type is fixed inside the state space but may get
instantiated later on, analogous to type parameters of an ML-functor.
The distinctness assumption is now \<open>distinct [N, B, n, b, x]\<close>,
from this we can derive both \<^term>\<open>distinct [N,B]\<close> and \<^term>\<open>distinct [n,b]\<close>, the distinction assumptions for the two versions of
locale \<open>vars\<close> above.  Moreover we have all necessary
projection and injection assumptions available. These assumptions
together allow us to establish state space \<^term>\<open>varsX\<close> as an
interpretation of both instances of locale \<^term>\<open>vars\<close>. Hence we
inherit both variants of theorem \<open>foo\<close>: \<open>s\<langle>N := 2\<rangle>\<cdot>B =
s\<cdot>B\<close> as well as \<open>s\<langle>n := 2\<rangle>\<cdot>b = s\<cdot>b\<close>. These are immediate
consequences of the locale interpretation action.

The declarations for syntax and the distinctness theorems also observe
the morphisms generated by the locale package due to the renaming
\<^term>\<open>n = N\<close>:\<close>

lemma (in varsX) foo: "s\<langle>N := 2\<rangle>\<cdot>x = s\<cdot>x" by simp

text \<open>To assure scalability towards many distinct names, the
distinctness predicate is refined to operate on balanced trees. Thus
we get logarithmic certificates for the distinctness of two names by
the distinctness of the paths in the tree. Asked for the distinctness
of two names, our tool produces the paths of the variables in the tree
(this is implemented in SML, outside the logic) and returns a
certificate corresponding to the different paths.  Merging state
spaces requires to prove that the combined distinctness assumption
implies the distinctness assumptions of the components.  Such a proof
is of the order $m \cdot \log n$, where $n$ and $m$ are the number of
nodes in the larger and smaller tree, respectively.\<close>

text \<open>We continue with more examples.\<close>

statespace 'a foo =
  f::"nat\<Rightarrow>nat"
  a::int
  b::nat
  c::'a

lemma (in foo) foo1:
  shows "s\<langle>a := i\<rangle>\<cdot>a = i"
  by simp

lemma (in foo) foo2:
  shows "(s\<langle>a:=i\<rangle>)\<cdot>a = i"
  by simp

lemma (in foo) foo3:
  shows "(s\<langle>a:=i\<rangle>)\<cdot>b = s\<cdot>b"
  by simp

lemma (in foo) foo4:
  shows "(s\<langle>a:=i,b:=j,c:=k,a:=x\<rangle>) = (s\<langle>b:=j,c:=k,a:=x\<rangle>)"
  by simp

statespace bar =
  b::bool
  c::string

lemma (in bar) bar1:
  shows "(s\<langle>b:=True\<rangle>)\<cdot>c = s\<cdot>c"
  by simp

text \<open>You can define a derived state space by inheriting existing state spaces, renaming
of components if you like, and by declaring new components.
\<close>

statespace ('a,'b) loo = 'a foo + bar [b=B,c=C] +
  X::'b

lemma (in loo) loo1:
  shows "s\<langle>a:=i\<rangle>\<cdot>B = s\<cdot>B"
proof -
  thm foo1
  txt \<open>The Lemma @{thm [source] foo1} from the parent state space
         is also available here: \begin{center}@{thm foo1}\end{center}\<close>
  have "s<a:=i>\<cdot>a = i"
    by (rule foo1)
  thm bar1
  txt \<open>Note the renaming of the parameters in Lemma @{thm [source] bar1}:
         \begin{center}@{thm bar1}\end{center}\<close>
  have "s<B:=True>\<cdot>C = s\<cdot>C"
    by (rule bar1)
  show ?thesis
    by simp
qed

statespace 'a dup = FA: 'a foo [f=F, a=A] + 'a foo +
  x::int

lemma (in dup)
 shows "s<a := i>\<cdot>x = s\<cdot>x"
  by simp

lemma (in dup)
 shows "s<A := i>\<cdot>a = s\<cdot>a"
  by simp

lemma (in dup)
 shows "s<A := i>\<cdot>x = s\<cdot>x"
  by simp

(*
text "Hmm, I hoped this would work now..."

locale fooX = foo +
 assumes "s<a:=i>\<cdot>b = k"
*)

(* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
text \<open>There are known problems with syntax-declarations. They currently
only work, when the context is already built. Hopefully this will be
implemented correctly in future Isabelle versions.\<close>

(*
lemma
  assumes "foo f a b c p1 i1 p2 i2 p3 i3 p4 i4"
  shows True
proof
  interpret foo [f a b c p1 i1 p2 i2 p3 i3 p4 i4] by fact
  term "s<a := i>\<cdot>a = i"
qed
*)
(*
lemma
  includes foo
  shows "s<a := i>\<cdot>a = i"
*)

text \<open>It would be nice to have nested state spaces. This is
logically no problem. From the locale-implementation side this may be
something like an 'includes' into a locale. When there is a more
elaborate locale infrastructure in place this may be an easy exercise.
\<close>

subsection \<open>Benchmarks\<close>

text \<open>Here are some bigger examples for benchmarking.\<close>

ML \<open>
  fun make_benchmark n =
    writeln (Active.sendback_markup_command
      ("statespace benchmark" ^ string_of_int n ^ " =\n" ^
        (cat_lines (map (fn i => "A" ^ string_of_int i ^ "::nat") (1 upto n)))));
\<close>

text "0.2s"
statespace benchmark100 = A1::nat A2::nat A3::nat A4::nat A5::nat
A6::nat A7::nat A8::nat A9::nat A10::nat A11::nat A12::nat A13::nat
A14::nat A15::nat A16::nat A17::nat A18::nat A19::nat A20::nat
A21::nat A22::nat A23::nat A24::nat A25::nat A26::nat A27::nat
A28::nat A29::nat A30::nat A31::nat A32::nat A33::nat A34::nat
A35::nat A36::nat A37::nat A38::nat A39::nat A40::nat A41::nat
A42::nat A43::nat A44::nat A45::nat A46::nat A47::nat A48::nat
A49::nat A50::nat A51::nat A52::nat A53::nat A54::nat A55::nat
A56::nat A57::nat A58::nat A59::nat A60::nat A61::nat A62::nat
A63::nat A64::nat A65::nat A66::nat A67::nat A68::nat A69::nat
A70::nat A71::nat A72::nat A73::nat A74::nat A75::nat A76::nat
A77::nat A78::nat A79::nat A80::nat A81::nat A82::nat A83::nat
A84::nat A85::nat A86::nat A87::nat A88::nat A89::nat A90::nat
A91::nat A92::nat A93::nat A94::nat A95::nat A96::nat A97::nat
A98::nat A99::nat A100::nat

text "2.4s"
statespace benchmark500 = A1::nat A2::nat A3::nat A4::nat A5::nat
A6::nat A7::nat A8::nat A9::nat A10::nat A11::nat A12::nat A13::nat
A14::nat A15::nat A16::nat A17::nat A18::nat A19::nat A20::nat
A21::nat A22::nat A23::nat A24::nat A25::nat A26::nat A27::nat
A28::nat A29::nat A30::nat A31::nat A32::nat A33::nat A34::nat
A35::nat A36::nat A37::nat A38::nat A39::nat A40::nat A41::nat
A42::nat A43::nat A44::nat A45::nat A46::nat A47::nat A48::nat
A49::nat A50::nat A51::nat A52::nat A53::nat A54::nat A55::nat
A56::nat A57::nat A58::nat A59::nat A60::nat A61::nat A62::nat
A63::nat A64::nat A65::nat A66::nat A67::nat A68::nat A69::nat
A70::nat A71::nat A72::nat A73::nat A74::nat A75::nat A76::nat
A77::nat A78::nat A79::nat A80::nat A81::nat A82::nat A83::nat
A84::nat A85::nat A86::nat A87::nat A88::nat A89::nat A90::nat
A91::nat A92::nat A93::nat A94::nat A95::nat A96::nat A97::nat
A98::nat A99::nat A100::nat A101::nat A102::nat A103::nat A104::nat
A105::nat A106::nat A107::nat A108::nat A109::nat A110::nat A111::nat
A112::nat A113::nat A114::nat A115::nat A116::nat A117::nat A118::nat
A119::nat A120::nat A121::nat A122::nat A123::nat A124::nat A125::nat
A126::nat A127::nat A128::nat A129::nat A130::nat A131::nat A132::nat
A133::nat A134::nat A135::nat A136::nat A137::nat A138::nat A139::nat
A140::nat A141::nat A142::nat A143::nat A144::nat A145::nat A146::nat
A147::nat A148::nat A149::nat A150::nat A151::nat A152::nat A153::nat
A154::nat A155::nat A156::nat A157::nat A158::nat A159::nat A160::nat
A161::nat A162::nat A163::nat A164::nat A165::nat A166::nat A167::nat
A168::nat A169::nat A170::nat A171::nat A172::nat A173::nat A174::nat
A175::nat A176::nat A177::nat A178::nat A179::nat A180::nat A181::nat
A182::nat A183::nat A184::nat A185::nat A186::nat A187::nat A188::nat
A189::nat A190::nat A191::nat A192::nat A193::nat A194::nat A195::nat
A196::nat A197::nat A198::nat A199::nat A200::nat A201::nat A202::nat
A203::nat A204::nat A205::nat A206::nat A207::nat A208::nat A209::nat
A210::nat A211::nat A212::nat A213::nat A214::nat A215::nat A216::nat
A217::nat A218::nat A219::nat A220::nat A221::nat A222::nat A223::nat
A224::nat A225::nat A226::nat A227::nat A228::nat A229::nat A230::nat
A231::nat A232::nat A233::nat A234::nat A235::nat A236::nat A237::nat
A238::nat A239::nat A240::nat A241::nat A242::nat A243::nat A244::nat
A245::nat A246::nat A247::nat A248::nat A249::nat A250::nat A251::nat
A252::nat A253::nat A254::nat A255::nat A256::nat A257::nat A258::nat
A259::nat A260::nat A261::nat A262::nat A263::nat A264::nat A265::nat
A266::nat A267::nat A268::nat A269::nat A270::nat A271::nat A272::nat
A273::nat A274::nat A275::nat A276::nat A277::nat A278::nat A279::nat
A280::nat A281::nat A282::nat A283::nat A284::nat A285::nat A286::nat
A287::nat A288::nat A289::nat A290::nat A291::nat A292::nat A293::nat
A294::nat A295::nat A296::nat A297::nat A298::nat A299::nat A300::nat
A301::nat A302::nat A303::nat A304::nat A305::nat A306::nat A307::nat
A308::nat A309::nat A310::nat A311::nat A312::nat A313::nat A314::nat
A315::nat A316::nat A317::nat A318::nat A319::nat A320::nat A321::nat
A322::nat A323::nat A324::nat A325::nat A326::nat A327::nat A328::nat
A329::nat A330::nat A331::nat A332::nat A333::nat A334::nat A335::nat
A336::nat A337::nat A338::nat A339::nat A340::nat A341::nat A342::nat
A343::nat A344::nat A345::nat A346::nat A347::nat A348::nat A349::nat
A350::nat A351::nat A352::nat A353::nat A354::nat A355::nat A356::nat
A357::nat A358::nat A359::nat A360::nat A361::nat A362::nat A363::nat
A364::nat A365::nat A366::nat A367::nat A368::nat A369::nat A370::nat
A371::nat A372::nat A373::nat A374::nat A375::nat A376::nat A377::nat
A378::nat A379::nat A380::nat A381::nat A382::nat A383::nat A384::nat
A385::nat A386::nat A387::nat A388::nat A389::nat A390::nat A391::nat
A392::nat A393::nat A394::nat A395::nat A396::nat A397::nat A398::nat
A399::nat A400::nat A401::nat A402::nat A403::nat A404::nat A405::nat
A406::nat A407::nat A408::nat A409::nat A410::nat A411::nat A412::nat
A413::nat A414::nat A415::nat A416::nat A417::nat A418::nat A419::nat
A420::nat A421::nat A422::nat A423::nat A424::nat A425::nat A426::nat
A427::nat A428::nat A429::nat A430::nat A431::nat A432::nat A433::nat
A434::nat A435::nat A436::nat A437::nat A438::nat A439::nat A440::nat
A441::nat A442::nat A443::nat A444::nat A445::nat A446::nat A447::nat
A448::nat A449::nat A450::nat A451::nat A452::nat A453::nat A454::nat
A455::nat A456::nat A457::nat A458::nat A459::nat A460::nat A461::nat
A462::nat A463::nat A464::nat A465::nat A466::nat A467::nat A468::nat
A469::nat A470::nat A471::nat A472::nat A473::nat A474::nat A475::nat
A476::nat A477::nat A478::nat A479::nat A480::nat A481::nat A482::nat
A483::nat A484::nat A485::nat A486::nat A487::nat A488::nat A489::nat
A490::nat A491::nat A492::nat A493::nat A494::nat A495::nat A496::nat
A497::nat A498::nat A499::nat A500::nat

text "9.0s"
statespace benchmark1000 = A1::nat A2::nat A3::nat A4::nat A5::nat
A6::nat A7::nat A8::nat A9::nat A10::nat A11::nat A12::nat A13::nat
A14::nat A15::nat A16::nat A17::nat A18::nat A19::nat A20::nat
A21::nat A22::nat A23::nat A24::nat A25::nat A26::nat A27::nat
A28::nat A29::nat A30::nat A31::nat A32::nat A33::nat A34::nat
A35::nat A36::nat A37::nat A38::nat A39::nat A40::nat A41::nat
A42::nat A43::nat A44::nat A45::nat A46::nat A47::nat A48::nat
A49::nat A50::nat A51::nat A52::nat A53::nat A54::nat A55::nat
A56::nat A57::nat A58::nat A59::nat A60::nat A61::nat A62::nat
A63::nat A64::nat A65::nat A66::nat A67::nat A68::nat A69::nat
A70::nat A71::nat A72::nat A73::nat A74::nat A75::nat A76::nat
A77::nat A78::nat A79::nat A80::nat A81::nat A82::nat A83::nat
A84::nat A85::nat A86::nat A87::nat A88::nat A89::nat A90::nat
A91::nat A92::nat A93::nat A94::nat A95::nat A96::nat A97::nat
A98::nat A99::nat A100::nat A101::nat A102::nat A103::nat A104::nat
A105::nat A106::nat A107::nat A108::nat A109::nat A110::nat A111::nat
A112::nat A113::nat A114::nat A115::nat A116::nat A117::nat A118::nat
A119::nat A120::nat A121::nat A122::nat A123::nat A124::nat A125::nat
A126::nat A127::nat A128::nat A129::nat A130::nat A131::nat A132::nat
A133::nat A134::nat A135::nat A136::nat A137::nat A138::nat A139::nat
A140::nat A141::nat A142::nat A143::nat A144::nat A145::nat A146::nat
A147::nat A148::nat A149::nat A150::nat A151::nat A152::nat A153::nat
A154::nat A155::nat A156::nat A157::nat A158::nat A159::nat A160::nat
A161::nat A162::nat A163::nat A164::nat A165::nat A166::nat A167::nat
A168::nat A169::nat A170::nat A171::nat A172::nat A173::nat A174::nat
A175::nat A176::nat A177::nat A178::nat A179::nat A180::nat A181::nat
A182::nat A183::nat A184::nat A185::nat A186::nat A187::nat A188::nat
A189::nat A190::nat A191::nat A192::nat A193::nat A194::nat A195::nat
A196::nat A197::nat A198::nat A199::nat A200::nat A201::nat A202::nat
A203::nat A204::nat A205::nat A206::nat A207::nat A208::nat A209::nat
A210::nat A211::nat A212::nat A213::nat A214::nat A215::nat A216::nat
A217::nat A218::nat A219::nat A220::nat A221::nat A222::nat A223::nat
A224::nat A225::nat A226::nat A227::nat A228::nat A229::nat A230::nat
A231::nat A232::nat A233::nat A234::nat A235::nat A236::nat A237::nat
A238::nat A239::nat A240::nat A241::nat A242::nat A243::nat A244::nat
A245::nat A246::nat A247::nat A248::nat A249::nat A250::nat A251::nat
A252::nat A253::nat A254::nat A255::nat A256::nat A257::nat A258::nat
A259::nat A260::nat A261::nat A262::nat A263::nat A264::nat A265::nat
A266::nat A267::nat A268::nat A269::nat A270::nat A271::nat A272::nat
A273::nat A274::nat A275::nat A276::nat A277::nat A278::nat A279::nat
A280::nat A281::nat A282::nat A283::nat A284::nat A285::nat A286::nat
A287::nat A288::nat A289::nat A290::nat A291::nat A292::nat A293::nat
A294::nat A295::nat A296::nat A297::nat A298::nat A299::nat A300::nat
A301::nat A302::nat A303::nat A304::nat A305::nat A306::nat A307::nat
A308::nat A309::nat A310::nat A311::nat A312::nat A313::nat A314::nat
A315::nat A316::nat A317::nat A318::nat A319::nat A320::nat A321::nat
A322::nat A323::nat A324::nat A325::nat A326::nat A327::nat A328::nat
A329::nat A330::nat A331::nat A332::nat A333::nat A334::nat A335::nat
A336::nat A337::nat A338::nat A339::nat A340::nat A341::nat A342::nat
A343::nat A344::nat A345::nat A346::nat A347::nat A348::nat A349::nat
A350::nat A351::nat A352::nat A353::nat A354::nat A355::nat A356::nat
A357::nat A358::nat A359::nat A360::nat A361::nat A362::nat A363::nat
A364::nat A365::nat A366::nat A367::nat A368::nat A369::nat A370::nat
A371::nat A372::nat A373::nat A374::nat A375::nat A376::nat A377::nat
A378::nat A379::nat A380::nat A381::nat A382::nat A383::nat A384::nat
A385::nat A386::nat A387::nat A388::nat A389::nat A390::nat A391::nat
A392::nat A393::nat A394::nat A395::nat A396::nat A397::nat A398::nat
A399::nat A400::nat A401::nat A402::nat A403::nat A404::nat A405::nat
A406::nat A407::nat A408::nat A409::nat A410::nat A411::nat A412::nat
A413::nat A414::nat A415::nat A416::nat A417::nat A418::nat A419::nat
A420::nat A421::nat A422::nat A423::nat A424::nat A425::nat A426::nat
A427::nat A428::nat A429::nat A430::nat A431::nat A432::nat A433::nat
A434::nat A435::nat A436::nat A437::nat A438::nat A439::nat A440::nat
A441::nat A442::nat A443::nat A444::nat A445::nat A446::nat A447::nat
A448::nat A449::nat A450::nat A451::nat A452::nat A453::nat A454::nat
A455::nat A456::nat A457::nat A458::nat A459::nat A460::nat A461::nat
A462::nat A463::nat A464::nat A465::nat A466::nat A467::nat A468::nat
A469::nat A470::nat A471::nat A472::nat A473::nat A474::nat A475::nat
A476::nat A477::nat A478::nat A479::nat A480::nat A481::nat A482::nat
A483::nat A484::nat A485::nat A486::nat A487::nat A488::nat A489::nat
A490::nat A491::nat A492::nat A493::nat A494::nat A495::nat A496::nat
A497::nat A498::nat A499::nat A500::nat A501::nat A502::nat A503::nat
A504::nat A505::nat A506::nat A507::nat A508::nat A509::nat A510::nat
A511::nat A512::nat A513::nat A514::nat A515::nat A516::nat A517::nat
A518::nat A519::nat A520::nat A521::nat A522::nat A523::nat A524::nat
A525::nat A526::nat A527::nat A528::nat A529::nat A530::nat A531::nat
A532::nat A533::nat A534::nat A535::nat A536::nat A537::nat A538::nat
A539::nat A540::nat A541::nat A542::nat A543::nat A544::nat A545::nat
A546::nat A547::nat A548::nat A549::nat A550::nat A551::nat A552::nat
A553::nat A554::nat A555::nat A556::nat A557::nat A558::nat A559::nat
A560::nat A561::nat A562::nat A563::nat A564::nat A565::nat A566::nat
A567::nat A568::nat A569::nat A570::nat A571::nat A572::nat A573::nat
A574::nat A575::nat A576::nat A577::nat A578::nat A579::nat A580::nat
A581::nat A582::nat A583::nat A584::nat A585::nat A586::nat A587::nat
A588::nat A589::nat A590::nat A591::nat A592::nat A593::nat A594::nat
A595::nat A596::nat A597::nat A598::nat A599::nat A600::nat A601::nat
A602::nat A603::nat A604::nat A605::nat A606::nat A607::nat A608::nat
A609::nat A610::nat A611::nat A612::nat A613::nat A614::nat A615::nat
A616::nat A617::nat A618::nat A619::nat A620::nat A621::nat A622::nat
A623::nat A624::nat A625::nat A626::nat A627::nat A628::nat A629::nat
A630::nat A631::nat A632::nat A633::nat A634::nat A635::nat A636::nat
A637::nat A638::nat A639::nat A640::nat A641::nat A642::nat A643::nat
A644::nat A645::nat A646::nat A647::nat A648::nat A649::nat A650::nat
A651::nat A652::nat A653::nat A654::nat A655::nat A656::nat A657::nat
A658::nat A659::nat A660::nat A661::nat A662::nat A663::nat A664::nat
A665::nat A666::nat A667::nat A668::nat A669::nat A670::nat A671::nat
A672::nat A673::nat A674::nat A675::nat A676::nat A677::nat A678::nat
A679::nat A680::nat A681::nat A682::nat A683::nat A684::nat A685::nat
A686::nat A687::nat A688::nat A689::nat A690::nat A691::nat A692::nat
A693::nat A694::nat A695::nat A696::nat A697::nat A698::nat A699::nat
A700::nat A701::nat A702::nat A703::nat A704::nat A705::nat A706::nat
A707::nat A708::nat A709::nat A710::nat A711::nat A712::nat A713::nat
A714::nat A715::nat A716::nat A717::nat A718::nat A719::nat A720::nat
A721::nat A722::nat A723::nat A724::nat A725::nat A726::nat A727::nat
A728::nat A729::nat A730::nat A731::nat A732::nat A733::nat A734::nat
A735::nat A736::nat A737::nat A738::nat A739::nat A740::nat A741::nat
A742::nat A743::nat A744::nat A745::nat A746::nat A747::nat A748::nat
A749::nat A750::nat A751::nat A752::nat A753::nat A754::nat A755::nat
A756::nat A757::nat A758::nat A759::nat A760::nat A761::nat A762::nat
A763::nat A764::nat A765::nat A766::nat A767::nat A768::nat A769::nat
A770::nat A771::nat A772::nat A773::nat A774::nat A775::nat A776::nat
A777::nat A778::nat A779::nat A780::nat A781::nat A782::nat A783::nat
A784::nat A785::nat A786::nat A787::nat A788::nat A789::nat A790::nat
A791::nat A792::nat A793::nat A794::nat A795::nat A796::nat A797::nat
A798::nat A799::nat A800::nat A801::nat A802::nat A803::nat A804::nat
A805::nat A806::nat A807::nat A808::nat A809::nat A810::nat A811::nat
A812::nat A813::nat A814::nat A815::nat A816::nat A817::nat A818::nat
A819::nat A820::nat A821::nat A822::nat A823::nat A824::nat A825::nat
A826::nat A827::nat A828::nat A829::nat A830::nat A831::nat A832::nat
A833::nat A834::nat A835::nat A836::nat A837::nat A838::nat A839::nat
A840::nat A841::nat A842::nat A843::nat A844::nat A845::nat A846::nat
A847::nat A848::nat A849::nat A850::nat A851::nat A852::nat A853::nat
A854::nat A855::nat A856::nat A857::nat A858::nat A859::nat A860::nat
A861::nat A862::nat A863::nat A864::nat A865::nat A866::nat A867::nat
A868::nat A869::nat A870::nat A871::nat A872::nat A873::nat A874::nat
A875::nat A876::nat A877::nat A878::nat A879::nat A880::nat A881::nat
A882::nat A883::nat A884::nat A885::nat A886::nat A887::nat A888::nat
A889::nat A890::nat A891::nat A892::nat A893::nat A894::nat A895::nat
A896::nat A897::nat A898::nat A899::nat A900::nat A901::nat A902::nat
A903::nat A904::nat A905::nat A906::nat A907::nat A908::nat A909::nat
A910::nat A911::nat A912::nat A913::nat A914::nat A915::nat A916::nat
A917::nat A918::nat A919::nat A920::nat A921::nat A922::nat A923::nat
A924::nat A925::nat A926::nat A927::nat A928::nat A929::nat A930::nat
A931::nat A932::nat A933::nat A934::nat A935::nat A936::nat A937::nat
A938::nat A939::nat A940::nat A941::nat A942::nat A943::nat A944::nat
A945::nat A946::nat A947::nat A948::nat A949::nat A950::nat A951::nat
A952::nat A953::nat A954::nat A955::nat A956::nat A957::nat A958::nat
A959::nat A960::nat A961::nat A962::nat A963::nat A964::nat A965::nat
A966::nat A967::nat A968::nat A969::nat A970::nat A971::nat A972::nat
A973::nat A974::nat A975::nat A976::nat A977::nat A978::nat A979::nat
A980::nat A981::nat A982::nat A983::nat A984::nat A985::nat A986::nat
A987::nat A988::nat A989::nat A990::nat A991::nat A992::nat A993::nat
A994::nat A995::nat A996::nat A997::nat A998::nat A999::nat A1000::nat

lemma (in benchmark100) test: "s<A1 := a>\<cdot>A100 = s\<cdot>A100" by simp
lemma (in benchmark500) test: "s<A1 := a>\<cdot>A100 = s\<cdot>A100" by simp
lemma (in benchmark1000) test: "s<A1 := a>\<cdot>A100 = s\<cdot>A100" by simp

end


(*  Title:      HOL/HOLCF/IOA/Automata.thy
    Author:     Olaf Müller, Konrad Slind, Tobias Nipkow
*)

section \<open>The I/O automata of Lynch and Tuttle in HOLCF\<close>

theory Automata
imports Asig
begin

default_sort type

type_synonym ('a, 's) transition = "'s \<times> 'a \<times> 's"
type_synonym ('a, 's) ioa =
  "'a signature \<times> 's set \<times> ('a, 's)transition set \<times> 'a set set \<times> 'a set set"

subsection \<open>IO automata\<close>

definition asig_of :: "('a, 's) ioa \<Rightarrow> 'a signature"
  where "asig_of = fst"

definition starts_of :: "('a, 's) ioa \<Rightarrow> 's set"
  where "starts_of = fst \<circ> snd"

definition trans_of :: "('a, 's) ioa \<Rightarrow> ('a, 's) transition set"
  where "trans_of = fst \<circ> snd \<circ> snd"

abbreviation trans_of_syn  ("_ \<midarrow>_\<midarrow>_\<rightarrow> _" [81, 81, 81, 81] 100)
  where "s \<midarrow>a\<midarrow>A\<rightarrow> t \<equiv> (s, a, t) \<in> trans_of A"

definition wfair_of :: "('a, 's) ioa \<Rightarrow> 'a set set"
  where "wfair_of = fst \<circ> snd \<circ> snd \<circ> snd"

definition sfair_of :: "('a, 's) ioa \<Rightarrow> 'a set set"
  where "sfair_of = snd \<circ> snd \<circ> snd \<circ> snd"

definition is_asig_of :: "('a, 's) ioa \<Rightarrow> bool"
  where "is_asig_of A = is_asig (asig_of A)"

definition is_starts_of :: "('a, 's) ioa \<Rightarrow> bool"
  where "is_starts_of A \<longleftrightarrow> starts_of A \<noteq> {}"

definition is_trans_of :: "('a, 's) ioa \<Rightarrow> bool"
  where "is_trans_of A \<longleftrightarrow>
    (\<forall>triple. triple \<in> trans_of A \<longrightarrow> fst (snd triple) \<in> actions (asig_of A))"

definition input_enabled :: "('a, 's) ioa \<Rightarrow> bool"
  where "input_enabled A \<longleftrightarrow>
    (\<forall>a. a \<in> inputs (asig_of A) \<longrightarrow> (\<forall>s1. \<exists>s2. (s1, a, s2) \<in> trans_of A))"

definition IOA :: "('a, 's) ioa \<Rightarrow> bool"
  where "IOA A \<longleftrightarrow>
    is_asig_of A \<and>
    is_starts_of A \<and>
    is_trans_of A \<and>
    input_enabled A"

abbreviation "act A \<equiv> actions (asig_of A)"
abbreviation "ext A \<equiv> externals (asig_of A)"
abbreviation int where "int A \<equiv> internals (asig_of A)"
abbreviation "inp A \<equiv> inputs (asig_of A)"
abbreviation "out A \<equiv> outputs (asig_of A)"
abbreviation "local A \<equiv> locals (asig_of A)"

text \<open>invariants\<close>

inductive reachable :: "('a, 's) ioa \<Rightarrow> 's \<Rightarrow> bool" for C :: "('a, 's) ioa"
where
  reachable_0:  "s \<in> starts_of C \<Longrightarrow> reachable C s"
| reachable_n:  "reachable C s \<Longrightarrow> (s, a, t) \<in> trans_of C \<Longrightarrow> reachable C t"

definition invariant :: "[('a, 's) ioa, 's \<Rightarrow> bool] \<Rightarrow> bool"
  where "invariant A P \<longleftrightarrow> (\<forall>s. reachable A s \<longrightarrow> P s)"

subsection \<open>Parallel composition\<close>

subsubsection \<open>Binary composition of action signatures and automata\<close>

definition compatible :: "('a, 's) ioa \<Rightarrow> ('a, 't) ioa \<Rightarrow> bool"
  where "compatible A B \<longleftrightarrow>
    out A \<inter> out B = {} \<and>
    int A \<inter> act B = {} \<and>
    int B \<inter> act A = {}"

definition asig_comp :: "'a signature \<Rightarrow> 'a signature \<Rightarrow> 'a signature"
  where "asig_comp a1 a2 =
     (((inputs a1 \<union> inputs a2) - (outputs a1 \<union> outputs a2),
       (outputs a1 \<union> outputs a2),
       (internals a1 \<union> internals a2)))"

definition par :: "('a, 's) ioa \<Rightarrow> ('a, 't) ioa \<Rightarrow> ('a, 's * 't) ioa"  (infixr "\<parallel>" 10)
  where "(A \<parallel> B) =
    (asig_comp (asig_of A) (asig_of B),
     {pr. fst pr \<in> starts_of A \<and> snd pr \<in> starts_of B},
     {tr.
        let
          s = fst tr;
          a = fst (snd tr);
          t = snd (snd tr)
        in
          (a \<in> act A \<or> a \<in> act B) \<and>
          (if a \<in> act A then (fst s, a, fst t) \<in> trans_of A
           else fst t = fst s) \<and>
          (if a \<in> act B then (snd s, a, snd t) \<in> trans_of B
           else snd t = snd s)},
      wfair_of A \<union> wfair_of B,
      sfair_of A \<union> sfair_of B)"

subsection \<open>Hiding\<close>

subsubsection \<open>Hiding and restricting\<close>

definition restrict_asig :: "'a signature \<Rightarrow> 'a set \<Rightarrow> 'a signature"
  where "restrict_asig asig actns =
    (inputs asig \<inter> actns,
     outputs asig \<inter> actns,
     internals asig \<union> (externals asig - actns))"

text \<open>
  Notice that for \<open>wfair_of\<close> and \<open>sfair_of\<close> nothing has to be changed, as
  changes from the outputs to the internals does not touch the locals as a
  whole, which is of importance for fairness only.
\<close>
definition restrict :: "('a, 's) ioa \<Rightarrow> 'a set \<Rightarrow> ('a, 's) ioa"
  where "restrict A actns =
    (restrict_asig (asig_of A) actns,
     starts_of A,
     trans_of A,
     wfair_of A,
     sfair_of A)"

definition hide_asig :: "'a signature \<Rightarrow> 'a set \<Rightarrow> 'a signature"
  where "hide_asig asig actns =
    (inputs asig - actns,
     outputs asig - actns,
     internals asig \<union> actns)"

definition hide :: "('a, 's) ioa \<Rightarrow> 'a set \<Rightarrow> ('a, 's) ioa"
  where "hide A actns =
    (hide_asig (asig_of A) actns,
     starts_of A,
     trans_of A,
     wfair_of A,
     sfair_of A)"

subsection \<open>Renaming\<close>

definition rename_set :: "'a set \<Rightarrow> ('c \<Rightarrow> 'a option) \<Rightarrow> 'c set"
  where "rename_set A ren = {b. \<exists>x. Some x = ren b \<and> x \<in> A}"

definition rename :: "('a, 'b) ioa \<Rightarrow> ('c \<Rightarrow> 'a option) \<Rightarrow> ('c, 'b) ioa"
  where "rename ioa ren =
    ((rename_set (inp ioa) ren,
      rename_set (out ioa) ren,
      rename_set (int ioa) ren),
     starts_of ioa,
     {tr.
        let
          s = fst tr;
          a = fst (snd tr);
          t = snd (snd tr)
        in \<exists>x. Some x = ren a \<and> s \<midarrow>x\<midarrow>ioa\<rightarrow> t},
     {rename_set s ren | s. s \<in> wfair_of ioa},
     {rename_set s ren | s. s \<in> sfair_of ioa})"

subsection \<open>Fairness\<close>

subsubsection \<open>Enabledness of actions and action sets\<close>

definition enabled :: "('a, 's) ioa \<Rightarrow> 'a \<Rightarrow> 's \<Rightarrow> bool"
  where "enabled A a s \<longleftrightarrow> (\<exists>t. s \<midarrow>a\<midarrow>A\<rightarrow> t)"

definition Enabled :: "('a, 's) ioa \<Rightarrow> 'a set \<Rightarrow> 's \<Rightarrow> bool"
  where "Enabled A W s \<longleftrightarrow> (\<exists>w \<in> W. enabled A w s)"

text \<open>Action set keeps enabled until probably disabled by itself.\<close>

definition en_persistent :: "('a, 's) ioa \<Rightarrow> 'a set \<Rightarrow> bool"
  where "en_persistent A W \<longleftrightarrow>
    (\<forall>s a t. Enabled A W s \<and> a \<notin> W \<and> s \<midarrow>a\<midarrow>A\<rightarrow> t \<longrightarrow> Enabled A W t)"

text \<open>Post conditions for actions and action sets.\<close>

definition was_enabled :: "('a, 's) ioa \<Rightarrow> 'a \<Rightarrow> 's \<Rightarrow> bool"
  where "was_enabled A a t \<longleftrightarrow> (\<exists>s. s \<midarrow>a\<midarrow>A\<rightarrow> t)"

definition set_was_enabled :: "('a, 's) ioa \<Rightarrow> 'a set \<Rightarrow> 's \<Rightarrow> bool"
  where "set_was_enabled A W t \<longleftrightarrow> (\<exists>w \<in> W. was_enabled A w t)"

text \<open>Constraints for fair IOA.\<close>

definition fairIOA :: "('a, 's) ioa \<Rightarrow> bool"
  where "fairIOA A \<longleftrightarrow> (\<forall>S \<in> wfair_of A. S \<subseteq> local A) \<and> (\<forall>S \<in> sfair_of A. S \<subseteq> local A)"

definition input_resistant :: "('a, 's) ioa \<Rightarrow> bool"
  where "input_resistant A \<longleftrightarrow>
    (\<forall>W \<in> sfair_of A. \<forall>s a t.
      reachable A s \<and> reachable A t \<and> a \<in> inp A \<and>
      Enabled A W s \<and> s \<midarrow>a\<midarrow>A\<rightarrow> t \<longrightarrow> Enabled A W t)"

declare split_paired_Ex [simp del]

lemmas ioa_projections = asig_of_def starts_of_def trans_of_def wfair_of_def sfair_of_def

subsection "\<open>asig_of\<close>, \<open>starts_of\<close>, \<open>trans_of\<close>"

lemma ioa_triple_proj:
  "asig_of (x, y, z, w, s) = x \<and>
   starts_of (x, y, z, w, s) = y \<and>
   trans_of (x, y, z, w, s) = z \<and>
   wfair_of (x, y, z, w, s) = w \<and>
   sfair_of (x, y, z, w, s) = s"
  by (simp add: ioa_projections)

lemma trans_in_actions: "is_trans_of A \<Longrightarrow> s1 \<midarrow>a\<midarrow>A\<rightarrow> s2 \<Longrightarrow> a \<in> act A"
  by (auto simp add: is_trans_of_def actions_def is_asig_def)

lemma starts_of_par: "starts_of (A \<parallel> B) = {p. fst p \<in> starts_of A \<and> snd p \<in> starts_of B}"
  by (simp add: par_def ioa_projections)

lemma trans_of_par:
  "trans_of(A \<parallel> B) =
    {tr.
      let
        s = fst tr;
        a = fst (snd tr);
        t = snd (snd tr)
      in
        (a \<in> act A \<or> a \<in> act B) \<and>
        (if a \<in> act A then (fst s, a, fst t) \<in> trans_of A
         else fst t = fst s) \<and>
        (if a \<in> act B then (snd s, a, snd t) \<in> trans_of B
         else snd t = snd s)}"
  by (simp add: par_def ioa_projections)

subsection \<open>\<open>actions\<close> and \<open>par\<close>\<close>

lemma actions_asig_comp: "actions (asig_comp a b) = actions a \<union> actions b"
  by (auto simp add: actions_def asig_comp_def asig_projections)

lemma asig_of_par: "asig_of(A \<parallel> B) = asig_comp (asig_of A) (asig_of B)"
  by (simp add: par_def ioa_projections)

lemma externals_of_par: "ext (A1 \<parallel> A2) = ext A1 \<union> ext A2"
  by (auto simp add: externals_def asig_of_par asig_comp_def
    asig_inputs_def asig_outputs_def Un_def set_diff_eq)

lemma actions_of_par: "act (A1 \<parallel> A2) = act A1 \<union> act A2"
  by (auto simp add: actions_def asig_of_par asig_comp_def
    asig_inputs_def asig_outputs_def asig_internals_def Un_def set_diff_eq)

lemma inputs_of_par: "inp (A1 \<parallel> A2) = (inp A1 \<union> inp A2) - (out A1 \<union> out A2)"
  by (simp add: actions_def asig_of_par asig_comp_def
    asig_inputs_def asig_outputs_def Un_def set_diff_eq)

lemma outputs_of_par: "out (A1 \<parallel> A2) = out A1 \<union> out A2"
  by (simp add: actions_def asig_of_par asig_comp_def
    asig_outputs_def Un_def set_diff_eq)

lemma internals_of_par: "int (A1 \<parallel> A2) = int A1 \<union> int A2"
  by (simp add: actions_def asig_of_par asig_comp_def
    asig_inputs_def asig_outputs_def asig_internals_def Un_def set_diff_eq)

subsection \<open>Actions and compatibility\<close>

lemma compat_commute: "compatible A B = compatible B A"
  by (auto simp add: compatible_def Int_commute)

lemma ext1_is_not_int2: "compatible A1 A2 \<Longrightarrow> a \<in> ext A1 \<Longrightarrow> a \<notin> int A2"
  by (auto simp add: externals_def actions_def compatible_def)

(*just commuting the previous one: better commute compatible*)
lemma ext2_is_not_int1: "compatible A2 A1 \<Longrightarrow> a \<in> ext A1 \<Longrightarrow> a \<notin> int A2"
  by (auto simp add: externals_def actions_def compatible_def)

lemmas ext1_ext2_is_not_act2 = ext1_is_not_int2 [THEN int_and_ext_is_act]
lemmas ext1_ext2_is_not_act1 = ext2_is_not_int1 [THEN int_and_ext_is_act]

lemma intA_is_not_extB: "compatible A B \<Longrightarrow> x \<in> int A \<Longrightarrow> x \<notin> ext B"
  by (auto simp add: externals_def actions_def compatible_def)

lemma intA_is_not_actB: "compatible A B \<Longrightarrow> a \<in> int A \<Longrightarrow> a \<notin> act B"
  by (auto simp add: externals_def actions_def compatible_def is_asig_def asig_of_def)

(*the only one that needs disjointness of outputs and of internals and _all_ acts*)
lemma outAactB_is_inpB: "compatible A B \<Longrightarrow> a \<in> out A \<Longrightarrow> a \<in> act B \<Longrightarrow> a \<in> inp B"
  by (auto simp add: asig_outputs_def asig_internals_def actions_def asig_inputs_def
      compatible_def is_asig_def asig_of_def)

(*needed for propagation of input_enabledness from A, B to A \<parallel> B*)
lemma inpAAactB_is_inpBoroutB:
  "compatible A B \<Longrightarrow> a \<in> inp A \<Longrightarrow> a \<in> act B \<Longrightarrow> a \<in> inp B \<or> a \<in> out B"
  by (auto simp add: asig_outputs_def asig_internals_def actions_def asig_inputs_def
      compatible_def is_asig_def asig_of_def)

subsection \<open>Input enabledness and par\<close>

(*ugly case distinctions. Heart of proof:
    1. inpAAactB_is_inpBoroutB ie. internals are really hidden.
    2. inputs_of_par: outputs are no longer inputs of par. This is important here.*)
lemma input_enabled_par:
  "compatible A B \<Longrightarrow> input_enabled A \<Longrightarrow> input_enabled B \<Longrightarrow> input_enabled (A \<parallel> B)"
  apply (unfold input_enabled_def)
  apply (simp add: Let_def inputs_of_par trans_of_par)
  apply (tactic "safe_tac (Context.raw_transfer \<^theory> \<^theory_context>\<open>Fun\<close>)")
  apply (simp add: inp_is_act)
  prefer 2
  apply (simp add: inp_is_act)
  text \<open>\<open>a \<in> inp A\<close>\<close>
  apply (case_tac "a \<in> act B")
  text \<open>\<open>a \<in> inp B\<close>\<close>
  apply (erule_tac x = "a" in allE)
  apply simp
  apply (drule inpAAactB_is_inpBoroutB)
  apply assumption
  apply assumption
  apply (erule_tac x = "a" in allE)
  apply simp
  apply (erule_tac x = "aa" in allE)
  apply (erule_tac x = "b" in allE)
  apply (erule exE)
  apply (erule exE)
  apply (rule_tac x = "(s2, s2a)" in exI)
  apply (simp add: inp_is_act)
  text \<open>\<open>a \<notin> act B\<close>\<close>
  apply (simp add: inp_is_act)
  apply (erule_tac x = "a" in allE)
  apply simp
  apply (erule_tac x = "aa" in allE)
  apply (erule exE)
  apply (rule_tac x = " (s2,b) " in exI)
  apply simp

  text \<open>\<open>a \<in> inp B\<close>\<close>
  apply (case_tac "a \<in> act A")
  text \<open>\<open>a \<in> act A\<close>\<close>
  apply (erule_tac x = "a" in allE)
  apply (erule_tac x = "a" in allE)
  apply (simp add: inp_is_act)
  apply (frule_tac A1 = "A" in compat_commute [THEN iffD1])
  apply (drule inpAAactB_is_inpBoroutB)
  back
  apply assumption
  apply assumption
  apply simp
  apply (erule_tac x = "aa" in allE)
  apply (erule_tac x = "b" in allE)
  apply (erule exE)
  apply (erule exE)
  apply (rule_tac x = "(s2, s2a)" in exI)
  apply (simp add: inp_is_act)
  text \<open>\<open>a \<notin> act B\<close>\<close>
  apply (simp add: inp_is_act)
  apply (erule_tac x = "a" in allE)
  apply (erule_tac x = "a" in allE)
  apply simp
  apply (erule_tac x = "b" in allE)
  apply (erule exE)
  apply (rule_tac x = "(aa, s2)" in exI)
  apply simp
  done

subsection \<open>Invariants\<close>

lemma invariantI:
  assumes "\<And>s. s \<in> starts_of A \<Longrightarrow> P s"
    and "\<And>s t a. reachable A s \<Longrightarrow> P s \<Longrightarrow> (s, a, t) \<in> trans_of A \<longrightarrow> P t"
  shows "invariant A P"
  using assms
  apply (unfold invariant_def)
  apply (rule allI)
  apply (rule impI)
  apply (rule_tac x = "s" in reachable.induct)
  apply assumption
  apply blast
  apply blast
  done

lemma invariantI1:
  assumes "\<And>s. s \<in> starts_of A \<Longrightarrow> P s"
    and "\<And>s t a. reachable A s \<Longrightarrow> P s \<longrightarrow> (s, a, t) \<in> trans_of A \<longrightarrow> P t"
  shows "invariant A P"
  using assms by (blast intro: invariantI)

lemma invariantE: "invariant A P \<Longrightarrow> reachable A s \<Longrightarrow> P s"
  unfolding invariant_def by blast

subsection \<open>\<open>restrict\<close>\<close>

lemmas reachable_0 = reachable.reachable_0
  and reachable_n = reachable.reachable_n

lemma cancel_restrict_a:
  "starts_of (restrict ioa acts) = starts_of ioa \<and>
   trans_of (restrict ioa acts) = trans_of ioa"
  by (simp add: restrict_def ioa_projections)

lemma cancel_restrict_b: "reachable (restrict ioa acts) s = reachable ioa s"
  apply (rule iffI)
  apply (erule reachable.induct)
  apply (simp add: cancel_restrict_a reachable_0)
  apply (erule reachable_n)
  apply (simp add: cancel_restrict_a)
  text \<open>\<open>\<longleftarrow>\<close>\<close>
  apply (erule reachable.induct)
  apply (rule reachable_0)
  apply (simp add: cancel_restrict_a)
  apply (erule reachable_n)
  apply (simp add: cancel_restrict_a)
  done

lemma acts_restrict: "act (restrict A acts) = act A"
  by (auto simp add: actions_def asig_internals_def
    asig_outputs_def asig_inputs_def externals_def asig_of_def restrict_def restrict_asig_def)

lemma cancel_restrict:
  "starts_of (restrict ioa acts) = starts_of ioa \<and>
   trans_of (restrict ioa acts) = trans_of ioa \<and>
   reachable (restrict ioa acts) s = reachable ioa s \<and>
   act (restrict A acts) = act A"
  by (simp add: cancel_restrict_a cancel_restrict_b acts_restrict)

subsection \<open>\<open>rename\<close>\<close>

lemma trans_rename: "s \<midarrow>a\<midarrow>(rename C f)\<rightarrow> t \<Longrightarrow> (\<exists>x. Some x = f a \<and> s \<midarrow>x\<midarrow>C\<rightarrow> t)"
  by (simp add: Let_def rename_def trans_of_def)

lemma reachable_rename: "reachable (rename C g) s \<Longrightarrow> reachable C s"
  apply (erule reachable.induct)
  apply (rule reachable_0)
  apply (simp add: rename_def ioa_projections)
  apply (drule trans_rename)
  apply (erule exE)
  apply (erule conjE)
  apply (erule reachable_n)
  apply assumption
  done

subsection \<open>\<open>trans_of (A \<parallel> B)\<close>\<close>

lemma trans_A_proj:
  "(s, a, t) \<in> trans_of (A \<parallel> B) \<Longrightarrow> a \<in> act A \<Longrightarrow> (fst s, a, fst t) \<in> trans_of A"
  by (simp add: Let_def par_def trans_of_def)

lemma trans_B_proj:
  "(s, a, t) \<in> trans_of (A \<parallel> B) \<Longrightarrow> a \<in> act B \<Longrightarrow> (snd s, a, snd t) \<in> trans_of B"
  by (simp add: Let_def par_def trans_of_def)

lemma trans_A_proj2: "(s, a, t) \<in> trans_of (A \<parallel> B) \<Longrightarrow> a \<notin> act A \<Longrightarrow> fst s = fst t"
  by (simp add: Let_def par_def trans_of_def)

lemma trans_B_proj2: "(s, a, t) \<in> trans_of (A \<parallel> B) \<Longrightarrow> a \<notin> act B \<Longrightarrow> snd s = snd t"
  by (simp add: Let_def par_def trans_of_def)

lemma trans_AB_proj: "(s, a, t) \<in> trans_of (A \<parallel> B) \<Longrightarrow> a \<in> act A \<or> a \<in> act B"
  by (simp add: Let_def par_def trans_of_def)

lemma trans_AB:
  "a \<in> act A \<Longrightarrow> a \<in> act B \<Longrightarrow>
  (fst s, a, fst t) \<in> trans_of A \<Longrightarrow>
  (snd s, a, snd t) \<in> trans_of B \<Longrightarrow>
  (s, a, t) \<in> trans_of (A \<parallel> B)"
  by (simp add: Let_def par_def trans_of_def)

lemma trans_A_notB:
  "a \<in> act A \<Longrightarrow> a \<notin> act B \<Longrightarrow>
  (fst s, a, fst t) \<in> trans_of A \<Longrightarrow>
  snd s = snd t \<Longrightarrow>
  (s, a, t) \<in> trans_of (A \<parallel> B)"
  by (simp add: Let_def par_def trans_of_def)

lemma trans_notA_B:
  "a \<notin> act A \<Longrightarrow> a \<in> act B \<Longrightarrow>
  (snd s, a, snd t) \<in> trans_of B \<Longrightarrow>
  fst s = fst t \<Longrightarrow>
  (s, a, t) \<in> trans_of (A \<parallel> B)"
  by (simp add: Let_def par_def trans_of_def)

lemmas trans_of_defs1 = trans_AB trans_A_notB trans_notA_B
  and trans_of_defs2 = trans_A_proj trans_B_proj trans_A_proj2 trans_B_proj2 trans_AB_proj

lemma trans_of_par4:
  "(s, a, t) \<in> trans_of (A \<parallel> B \<parallel> C \<parallel> D) \<longleftrightarrow>
    ((a \<in> actions (asig_of A) \<or> a \<in> actions (asig_of B) \<or> a \<in> actions (asig_of C) \<or>
      a \<in> actions (asig_of D)) \<and>
     (if a \<in> actions (asig_of A)
      then (fst s, a, fst t) \<in> trans_of A
      else fst t = fst s) \<and>
     (if a \<in> actions (asig_of B)
      then (fst (snd s), a, fst (snd t)) \<in> trans_of B
      else fst (snd t) = fst (snd s)) \<and>
     (if a \<in> actions (asig_of C)
      then (fst (snd (snd s)), a, fst (snd (snd t))) \<in> trans_of C
      else fst (snd (snd t)) = fst (snd (snd s))) \<and>
     (if a \<in> actions (asig_of D)
      then (snd (snd (snd s)), a, snd (snd (snd t))) \<in> trans_of D
      else snd (snd (snd t)) = snd (snd (snd s))))"
  by (simp add: par_def actions_asig_comp prod_eq_iff Let_def ioa_projections)

subsection \<open>Proof obligation generator for IOA requirements\<close>

(*without assumptions on A and B because is_trans_of is also incorporated in par_def*)
lemma is_trans_of_par: "is_trans_of (A \<parallel> B)"
  by (simp add: is_trans_of_def Let_def actions_of_par trans_of_par)

lemma is_trans_of_restrict: "is_trans_of A \<Longrightarrow> is_trans_of (restrict A acts)"
  by (simp add: is_trans_of_def cancel_restrict acts_restrict)

lemma is_trans_of_rename: "is_trans_of A \<Longrightarrow> is_trans_of (rename A f)"
  apply (unfold is_trans_of_def restrict_def restrict_asig_def)
  apply (simp add: Let_def actions_def trans_of_def asig_internals_def
    asig_outputs_def asig_inputs_def externals_def asig_of_def rename_def rename_set_def)
  apply blast
  done

lemma is_asig_of_par: "is_asig_of A \<Longrightarrow> is_asig_of B \<Longrightarrow> compatible A B \<Longrightarrow> is_asig_of (A \<parallel> B)"
  apply (simp add: is_asig_of_def asig_of_par asig_comp_def compatible_def
    asig_internals_def asig_outputs_def asig_inputs_def actions_def is_asig_def)
  apply (simp add: asig_of_def)
  apply auto
  done

lemma is_asig_of_restrict: "is_asig_of A \<Longrightarrow> is_asig_of (restrict A f)"
  apply (unfold is_asig_of_def is_asig_def asig_of_def restrict_def restrict_asig_def
    asig_internals_def asig_outputs_def asig_inputs_def externals_def o_def)
  apply simp
  apply auto
  done

lemma is_asig_of_rename: "is_asig_of A \<Longrightarrow> is_asig_of (rename A f)"
  apply (simp add: is_asig_of_def rename_def rename_set_def asig_internals_def
    asig_outputs_def asig_inputs_def actions_def is_asig_def asig_of_def)
  apply auto
  apply (drule_tac [!] s = "Some _" in sym)
  apply auto
  done

lemmas [simp] = is_asig_of_par is_asig_of_restrict
  is_asig_of_rename is_trans_of_par is_trans_of_restrict is_trans_of_rename

lemma compatible_par: "compatible A B \<Longrightarrow> compatible A C \<Longrightarrow> compatible A (B \<parallel> C)"
  by (auto simp add: compatible_def internals_of_par outputs_of_par actions_of_par)

(*better derive by previous one and compat_commute*)
lemma compatible_par2: "compatible A C \<Longrightarrow> compatible B C \<Longrightarrow> compatible (A \<parallel> B) C"
  by (auto simp add: compatible_def internals_of_par outputs_of_par actions_of_par)

lemma compatible_restrict:
  "compatible A B \<Longrightarrow> (ext B - S) \<inter> ext A = {} \<Longrightarrow> compatible A (restrict B S)"
  by (auto simp add: compatible_def ioa_triple_proj asig_triple_proj externals_def
    restrict_def restrict_asig_def actions_def)

declare split_paired_Ex [simp]

end


(*  Title:      HOL/BNF_Least_Fixpoint.thy
    Author:     Dmitriy Traytel, TU Muenchen
    Author:     Lorenz Panny, TU Muenchen
    Author:     Jasmin Blanchette, TU Muenchen
    Copyright   2012, 2013, 2014

Least fixpoint (datatype) operation on bounded natural functors.
*)

section \<open>Least Fixpoint (Datatype) Operation on Bounded Natural Functors\<close>

theory BNF_Least_Fixpoint
imports BNF_Fixpoint_Base
keywords
  "datatype" :: thy_decl and
  "datatype_compat" :: thy_decl
begin

lemma subset_emptyI: "(\<And>x. x \<in> A \<Longrightarrow> False) \<Longrightarrow> A \<subseteq> {}"
  by blast

lemma image_Collect_subsetI: "(\<And>x. P x \<Longrightarrow> f x \<in> B) \<Longrightarrow> f ` {x. P x} \<subseteq> B"
  by blast

lemma Collect_restrict: "{x. x \<in> X \<and> P x} \<subseteq> X"
  by auto

lemma prop_restrict: "\<lbrakk>x \<in> Z; Z \<subseteq> {x. x \<in> X \<and> P x}\<rbrakk> \<Longrightarrow> P x"
  by auto

lemma underS_I: "\<lbrakk>i \<noteq> j; (i, j) \<in> R\<rbrakk> \<Longrightarrow> i \<in> underS R j"
  unfolding underS_def by simp

lemma underS_E: "i \<in> underS R j \<Longrightarrow> i \<noteq> j \<and> (i, j) \<in> R"
  unfolding underS_def by simp

lemma underS_Field: "i \<in> underS R j \<Longrightarrow> i \<in> Field R"
  unfolding underS_def Field_def by auto

lemma bij_betwE: "bij_betw f A B \<Longrightarrow> \<forall>a\<in>A. f a \<in> B"
  unfolding bij_betw_def by auto

lemma f_the_inv_into_f_bij_betw:
  "bij_betw f A B \<Longrightarrow> (bij_betw f A B \<Longrightarrow> x \<in> B) \<Longrightarrow> f (the_inv_into A f x) = x"
  unfolding bij_betw_def by (blast intro: f_the_inv_into_f)

lemma ex_bij_betw: "|A| \<le>o (r :: 'b rel) \<Longrightarrow> \<exists>f B :: 'b set. bij_betw f B A"
  by (subst (asm) internalize_card_of_ordLeq) (auto dest!: iffD2[OF card_of_ordIso ordIso_symmetric])

lemma bij_betwI':
  "\<lbrakk>\<And>x y. \<lbrakk>x \<in> X; y \<in> X\<rbrakk> \<Longrightarrow> (f x = f y) = (x = y);
    \<And>x. x \<in> X \<Longrightarrow> f x \<in> Y;
    \<And>y. y \<in> Y \<Longrightarrow> \<exists>x \<in> X. y = f x\<rbrakk> \<Longrightarrow> bij_betw f X Y"
  unfolding bij_betw_def inj_on_def by blast

lemma surj_fun_eq:
  assumes surj_on: "f ` X = UNIV" and eq_on: "\<forall>x \<in> X. (g1 o f) x = (g2 o f) x"
  shows "g1 = g2"
proof (rule ext)
  fix y
  from surj_on obtain x where "x \<in> X" and "y = f x" by blast
  thus "g1 y = g2 y" using eq_on by simp
qed

lemma Card_order_wo_rel: "Card_order r \<Longrightarrow> wo_rel r"
  unfolding wo_rel_def card_order_on_def by blast

lemma Cinfinite_limit: "\<lbrakk>x \<in> Field r; Cinfinite r\<rbrakk> \<Longrightarrow> \<exists>y \<in> Field r. x \<noteq> y \<and> (x, y) \<in> r"
  unfolding cinfinite_def by (auto simp add: infinite_Card_order_limit)

lemma Card_order_trans:
  "\<lbrakk>Card_order r; x \<noteq> y; (x, y) \<in> r; y \<noteq> z; (y, z) \<in> r\<rbrakk> \<Longrightarrow> x \<noteq> z \<and> (x, z) \<in> r"
  unfolding card_order_on_def well_order_on_def linear_order_on_def
    partial_order_on_def preorder_on_def trans_def antisym_def by blast

lemma Cinfinite_limit2:
  assumes x1: "x1 \<in> Field r" and x2: "x2 \<in> Field r" and r: "Cinfinite r"
  shows "\<exists>y \<in> Field r. (x1 \<noteq> y \<and> (x1, y) \<in> r) \<and> (x2 \<noteq> y \<and> (x2, y) \<in> r)"
proof -
  from r have trans: "trans r" and total: "Total r" and antisym: "antisym r"
    unfolding card_order_on_def well_order_on_def linear_order_on_def
      partial_order_on_def preorder_on_def by auto
  obtain y1 where y1: "y1 \<in> Field r" "x1 \<noteq> y1" "(x1, y1) \<in> r"
    using Cinfinite_limit[OF x1 r] by blast
  obtain y2 where y2: "y2 \<in> Field r" "x2 \<noteq> y2" "(x2, y2) \<in> r"
    using Cinfinite_limit[OF x2 r] by blast
  show ?thesis
  proof (cases "y1 = y2")
    case True with y1 y2 show ?thesis by blast
  next
    case False
    with y1(1) y2(1) total have "(y1, y2) \<in> r \<or> (y2, y1) \<in> r"
      unfolding total_on_def by auto
    thus ?thesis
    proof
      assume *: "(y1, y2) \<in> r"
      with trans y1(3) have "(x1, y2) \<in> r" unfolding trans_def by blast
      with False y1 y2 * antisym show ?thesis by (cases "x1 = y2") (auto simp: antisym_def)
    next
      assume *: "(y2, y1) \<in> r"
      with trans y2(3) have "(x2, y1) \<in> r" unfolding trans_def by blast
      with False y1 y2 * antisym show ?thesis by (cases "x2 = y1") (auto simp: antisym_def)
    qed
  qed
qed

lemma Cinfinite_limit_finite:
  "\<lbrakk>finite X; X \<subseteq> Field r; Cinfinite r\<rbrakk> \<Longrightarrow> \<exists>y \<in> Field r. \<forall>x \<in> X. (x \<noteq> y \<and> (x, y) \<in> r)"
proof (induct X rule: finite_induct)
  case empty thus ?case unfolding cinfinite_def using ex_in_conv[of "Field r"] finite.emptyI by auto
next
  case (insert x X)
  then obtain y where y: "y \<in> Field r" "\<forall>x \<in> X. (x \<noteq> y \<and> (x, y) \<in> r)" by blast
  then obtain z where z: "z \<in> Field r" "x \<noteq> z \<and> (x, z) \<in> r" "y \<noteq> z \<and> (y, z) \<in> r"
    using Cinfinite_limit2[OF _ y(1) insert(5), of x] insert(4) by blast
  show ?case
    apply (intro bexI ballI)
    apply (erule insertE)
    apply hypsubst
    apply (rule z(2))
    using Card_order_trans[OF insert(5)[THEN conjunct2]] y(2) z(3)
    apply blast
    apply (rule z(1))
    done
qed

lemma insert_subsetI: "\<lbrakk>x \<in> A; X \<subseteq> A\<rbrakk> \<Longrightarrow> insert x X \<subseteq> A"
  by auto

lemmas well_order_induct_imp = wo_rel.well_order_induct[of r "\<lambda>x. x \<in> Field r \<longrightarrow> P x" for r P]

lemma meta_spec2:
  assumes "(\<And>x y. PROP P x y)"
  shows "PROP P x y"
  by (rule assms)

lemma nchotomy_relcomppE:
  assumes "\<And>y. \<exists>x. y = f x" "(r OO s) a c" "\<And>b. r a (f b) \<Longrightarrow> s (f b) c \<Longrightarrow> P"
  shows P
proof (rule relcompp.cases[OF assms(2)], hypsubst)
  fix b assume "r a b" "s b c"
  moreover from assms(1) obtain b' where "b = f b'" by blast
  ultimately show P by (blast intro: assms(3))
qed

lemma predicate2D_vimage2p: "\<lbrakk>R \<le> vimage2p f g S; R x y\<rbrakk> \<Longrightarrow> S (f x) (g y)"
  unfolding vimage2p_def by auto

lemma ssubst_Pair_rhs: "\<lbrakk>(r, s) \<in> R; s' = s\<rbrakk> \<Longrightarrow> (r, s') \<in> R"
  by (rule ssubst)

lemma all_mem_range1:
  "(\<And>y. y \<in> range f \<Longrightarrow> P y) \<equiv> (\<And>x. P (f x)) "
  by (rule equal_intr_rule) fast+

lemma all_mem_range2:
  "(\<And>fa y. fa \<in> range f \<Longrightarrow> y \<in> range fa \<Longrightarrow> P y) \<equiv> (\<And>x xa. P (f x xa))"
  by (rule equal_intr_rule) fast+

lemma all_mem_range3:
  "(\<And>fa fb y. fa \<in> range f \<Longrightarrow> fb \<in> range fa \<Longrightarrow> y \<in> range fb \<Longrightarrow> P y) \<equiv> (\<And>x xa xb. P (f x xa xb))"
  by (rule equal_intr_rule) fast+

lemma all_mem_range4:
  "(\<And>fa fb fc y. fa \<in> range f \<Longrightarrow> fb \<in> range fa \<Longrightarrow> fc \<in> range fb \<Longrightarrow> y \<in> range fc \<Longrightarrow> P y) \<equiv>
   (\<And>x xa xb xc. P (f x xa xb xc))"
  by (rule equal_intr_rule) fast+

lemma all_mem_range5:
  "(\<And>fa fb fc fd y. fa \<in> range f \<Longrightarrow> fb \<in> range fa \<Longrightarrow> fc \<in> range fb \<Longrightarrow> fd \<in> range fc \<Longrightarrow>
     y \<in> range fd \<Longrightarrow> P y) \<equiv>
   (\<And>x xa xb xc xd. P (f x xa xb xc xd))"
  by (rule equal_intr_rule) fast+

lemma all_mem_range6:
  "(\<And>fa fb fc fd fe ff y. fa \<in> range f \<Longrightarrow> fb \<in> range fa \<Longrightarrow> fc \<in> range fb \<Longrightarrow> fd \<in> range fc \<Longrightarrow>
     fe \<in> range fd \<Longrightarrow> ff \<in> range fe \<Longrightarrow> y \<in> range ff \<Longrightarrow> P y) \<equiv>
   (\<And>x xa xb xc xd xe xf. P (f x xa xb xc xd xe xf))"
  by (rule equal_intr_rule) (fastforce, fast)

lemma all_mem_range7:
  "(\<And>fa fb fc fd fe ff fg y. fa \<in> range f \<Longrightarrow> fb \<in> range fa \<Longrightarrow> fc \<in> range fb \<Longrightarrow> fd \<in> range fc \<Longrightarrow>
     fe \<in> range fd \<Longrightarrow> ff \<in> range fe \<Longrightarrow> fg \<in> range ff \<Longrightarrow> y \<in> range fg \<Longrightarrow> P y) \<equiv>
   (\<And>x xa xb xc xd xe xf xg. P (f x xa xb xc xd xe xf xg))"
  by (rule equal_intr_rule) (fastforce, fast)

lemma all_mem_range8:
  "(\<And>fa fb fc fd fe ff fg fh y. fa \<in> range f \<Longrightarrow> fb \<in> range fa \<Longrightarrow> fc \<in> range fb \<Longrightarrow> fd \<in> range fc \<Longrightarrow>
     fe \<in> range fd \<Longrightarrow> ff \<in> range fe \<Longrightarrow> fg \<in> range ff \<Longrightarrow> fh \<in> range fg \<Longrightarrow> y \<in> range fh \<Longrightarrow> P y) \<equiv>
   (\<And>x xa xb xc xd xe xf xg xh. P (f x xa xb xc xd xe xf xg xh))"
  by (rule equal_intr_rule) (fastforce, fast)

lemmas all_mem_range = all_mem_range1 all_mem_range2 all_mem_range3 all_mem_range4 all_mem_range5
  all_mem_range6 all_mem_range7 all_mem_range8

ML_file "Tools/BNF/bnf_lfp_util.ML"
ML_file "Tools/BNF/bnf_lfp_tactics.ML"
ML_file "Tools/BNF/bnf_lfp.ML"
ML_file "Tools/BNF/bnf_lfp_compat.ML"
ML_file "Tools/BNF/bnf_lfp_rec_sugar_more.ML"
ML_file "Tools/BNF/bnf_lfp_size.ML"

end


theory snoc
  imports Complex_Main

begin
primrec snoc :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a list"
  where
    "snoc [] a = [a]"
  | "snoc (x # xs) a = x # (snoc xs a)"

lemma snoc_append: "snoc xs a = xs @ [a]"
  apply (induct "xs")
  apply auto
done

theorem rev_cons: "rev (x # xs) = snoc (rev xs) x"
  apply (induct "xs")
  apply (auto simp add:snoc_append)
done

end


theory ConcreteSemantics10_1_Def_Init
  imports Main "~~/src/HOL/IMP/Vars"
begin
subsection "Definite Initialization Analysis"

inductive D :: "vname set \<Rightarrow> com \<Rightarrow> vname set \<Rightarrow> bool" where
Skip: "D A SKIP A" |
Assign: "vars a \<subseteq> A \<Longrightarrow> D A (x ::= a) (insert x A)" |
Seq: "\<lbrakk> D A\<^sub>1 c\<^sub>1 A\<^sub>2;  D A\<^sub>2 c\<^sub>2 A\<^sub>3 \<rbrakk> \<Longrightarrow> D A\<^sub>1 (c\<^sub>1;; c\<^sub>2) A\<^sub>3" |
If: "\<lbrakk> vars b \<subseteq> A;  D A c\<^sub>1 A\<^sub>1;  D A c\<^sub>2 A\<^sub>2 \<rbrakk> \<Longrightarrow>
  D A (IF b THEN c\<^sub>1 ELSE c\<^sub>2) (A\<^sub>1 Int A\<^sub>2)" |
While: "\<lbrakk> vars b \<subseteq> A;  D A c A' \<rbrakk> \<Longrightarrow> D A (WHILE b DO c) A"

inductive_cases [elim!]:
"D A SKIP A'"
"D A (x ::= a) A'"
"D A (c1;;c2) A'"
"D A (IF b THEN c1 ELSE c2) A'"
"D A (WHILE b DO c) A'"

lemma D_incr:
  "D A c A' \<Longrightarrow> A \<subseteq> A'"
  apply(induct rule: D.induct)
      apply(auto)
  done

end