theory ScottVariant imports HOML MFilter BaseDefs
begin
(*Axioms of Scott's variant*)
axiomatization where
 A1: "\<lfloor>\<^bold>\<forall>X.((\<^bold>\<not>(\<P> X)) \<^bold>\<leftrightarrow> (\<P>(\<^bold>\<rightharpoondown>X)))\<rfloor>" and
 A2: "\<lfloor>\<^bold>\<forall>X Y.(((\<P> X) \<^bold>\<and> (X\<Rrightarrow>Y)) \<^bold>\<rightarrow> (\<P> Y))\<rfloor>" and
 A3: "\<lfloor>\<^bold>\<forall>\<Z>.((\<P>\<o>\<s> \<Z>) \<^bold>\<rightarrow> (\<^bold>\<forall>X.((X\<Sqinter>\<Z>) \<^bold>\<rightarrow> (\<P> X))))\<rfloor>" and
 A4: "\<lfloor>\<^bold>\<forall>X.((\<P> X) \<^bold>\<rightarrow> \<^bold>\<box>(\<P> X))\<rfloor>" and
 A5: "\<lfloor>\<P> \<N>\<E>\<rfloor>" and
 B:  "\<lfloor>\<^bold>\<forall>\<phi>.(\<phi> \<^bold>\<rightarrow> \<^bold>\<box>\<^bold>\<diamond>\<phi>)\<rfloor>" (*Logic KB*)

lemma B': "\<forall>x y. \<not>(x\<^bold>ry) \<or> (y\<^bold>rx)" using B by fastforce

(*Necessary existence of a Godlike entity*)
theorem T6: "\<lfloor>\<^bold>\<box>(\<^bold>\<exists>\<^sup>E \<G>)\<rfloor>"
proof -
 have T1: "\<lfloor>\<^bold>\<forall>X.((\<P> X) \<^bold>\<rightarrow> \<^bold>\<diamond>(\<^bold>\<exists>\<^sup>E X))\<rfloor>"
          using A1 A2 by blast
 have T2: "\<lfloor>\<P> \<G>\<rfloor>" by (metis A3 G_def)
 have T3: "\<lfloor>\<^bold>\<diamond>(\<^bold>\<exists>\<^sup>E \<G>)\<rfloor>" using T1 T2 by simp
 have T4: "\<lfloor>\<^bold>\<forall>\<^sup>Ex.((\<G> x)\<^bold>\<rightarrow>(\<E> \<G> x))\<rfloor>"
          by (metis A1 A4 G_def E_def)
 have T5: "\<lfloor>(\<^bold>\<diamond>(\<^bold>\<exists>\<^sup>E\<G>))\<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<exists>\<^sup>E\<G>)\<rfloor>"
          by (smt A5 G_def B' NE_def T4)
 thus ?thesis using T3 by blast qed

(*Existence of a Godlike entity*)
lemma "\<lfloor>\<^bold>\<exists>\<^sup>E \<G>\<rfloor>" using A1 A2 B' T6 by blast

(*Consistency*)
lemma True nitpick[satisfy] oops (*Model found*)

(*Modal collapse: holds*)
lemma MC: "\<lfloor>\<^bold>\<forall>\<Phi>.(\<Phi> \<^bold>\<rightarrow> \<^bold>\<box>\<Phi>)\<rfloor>"
proof - {fix w fix Q
 have 1: "\<forall>x.((\<G> x w) \<longrightarrow>
           (\<^bold>\<forall>Z.((Z x) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>\<^sup>Ez.((\<G> z) \<^bold>\<rightarrow> (Z z))))) w)"
         by (metis A1 A4 G_def)
 have 2: "(\<exists>x. \<G> x w)\<longrightarrow>((Q \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>\<^sup>Ez.((\<G> z) \<^bold>\<rightarrow> Q))) w)"
         using 1 by force
 have 3: "(Q \<^bold>\<rightarrow> \<^bold>\<box>Q) w" using B' T6 2 by blast}
 thus ?thesis by auto qed

(*Analysis of positive properties using ultrafilters*)
theorem U1: "\<lfloor>UFilter \<P>\<rfloor>" sledgehammer (*Proof found*)
proof -
 have 1: "\<lfloor>(\<^bold>U\<^bold>\<in>\<P>) \<^bold>\<and> \<^bold>\<not>(\<^bold>\<emptyset>\<^bold>\<in>\<P>)\<rfloor>"
          using A1 A2 by blast
 have 2: "\<lfloor>\<^bold>\<forall>\<phi> \<psi>.(((\<phi>\<^bold>\<in>\<P>)\<^bold>\<and>(\<phi>\<^bold>\<subseteq>\<psi>))\<^bold>\<rightarrow>(\<psi>\<^bold>\<in>\<P>))\<rfloor>"
         by (smt A2 B' MC)
 have 3: "\<lfloor>\<^bold>\<forall>\<phi> \<psi>.(((\<phi>\<^bold>\<in>\<P>)\<^bold>\<and>(\<psi>\<^bold>\<in>\<P>))\<^bold>\<rightarrow>((\<phi>\<^bold>\<sqinter>\<psi>)\<^bold>\<in>\<P>))\<rfloor>"
         by (metis A1 A2 G_def B' T6)
 have 4: "\<lfloor>\<^bold>\<forall>\<phi>.((\<phi>\<^bold>\<in>\<P>) \<^bold>\<or> ((\<inverse>\<phi>)\<^bold>\<in>\<P>))\<rfloor>"
         using A1 by blast
 thus ?thesis using 1 2 3 4 by simp qed

lemma L1: "\<lfloor>\<^bold>\<forall>X Y.((X\<Rrightarrow>Y) \<^bold>\<rightarrow> (X\<^bold>\<sqsubseteq>Y))\<rfloor>"
          by (metis A1 A2 MC)
lemma L2: "\<lfloor>\<^bold>\<forall>X Y.(((\<P> X) \<^bold>\<and> (X\<^bold>\<sqsubseteq>Y)) \<^bold>\<rightarrow> (\<P> Y))\<rfloor>"
          by (smt A2 B' MC)

(*Set of supersets of X, we call this HF X*)
abbreviation HF where "HF X \<equiv> \<lambda>Y.(X\<^bold>\<sqsubseteq>Y)"

(*HF \<G> is a filter; hence, HF \<G> is Hauptfilter of \<G>*)
lemma F1: "\<lfloor>Filter (HF \<G>)\<rfloor>" by (metis A2 B' T6 U1)
lemma F2: "\<lfloor>UFilter (HF \<G>)\<rfloor>" by (smt A1 F1 G_def)

(*T6 follows directly from F1*)
theorem T6again: "\<lfloor>\<^bold>\<box>(\<^bold>\<exists>\<^sup>E \<G>)\<rfloor>" using F1 by simp
end

(*
(*The simplified version in appendix C is implied*)
lemma  A1':  "\<lfloor>\<P>(\<lambda>x. x\<^bold>=x) \<^bold>\<and> \<^bold>\<not>\<P>(\<lambda>x. x\<^bold>\<noteq>x)\<rfloor>" using A1 A2 by blast
lemma A2'': "\<lfloor>\<^bold>\<forall>X Y. (\<P> X \<^bold>\<and> (X\<^bold>\<sqsubseteq>Y)) \<^bold>\<rightarrow> \<P> Y\<rfloor>" by (metis A1 A2 B G_def T6)
lemma T2:   "\<lfloor>\<P> \<G>\<rfloor>" by (metis A3 G_def)
*)

(*
theorem T6again: "\<lfloor>\<^bold>\<box>(\<^bold>\<exists>\<^sup>E \<G>)\<rfloor>"
proof -
 have L1: "\<lfloor>(\<^bold>\<exists>X. \<P> X \<^bold>\<and> \<^bold>\<not>(\<^bold>\<exists>\<^sup>E X)) \<^bold>\<rightarrow> \<P>(\<lambda>x. x\<^bold>\<noteq>x)\<rfloor>"
   by (metis A2 B G_def T6)
 have L2: "\<lfloor>\<^bold>\<not>(\<^bold>\<exists>X. \<P> X \<^bold>\<and> \<^bold>\<not>(\<^bold>\<exists>\<^sup>E X))\<rfloor>"
   using A1 A2 L1 by blast
 have T1': "\<lfloor>\<^bold>\<forall>X. \<P> X \<^bold>\<rightarrow> (\<^bold>\<exists>\<^sup>E X)\<rfloor>" by (metis L2)
 have T3': "\<lfloor>\<^bold>\<exists>\<^sup>E \<G>\<rfloor>"
   by (metis A2 A5 B L2 T6)
 have T3: "\<lfloor>\<^bold>\<diamond>(\<^bold>\<exists>\<^sup>E \<G>)\<rfloor>"
   using A1 A2 T3' by blast (*not needed*)
 have T6: "\<lfloor>\<^bold>\<box>(\<^bold>\<exists>\<^sup>E \<G>)\<rfloor>" by (metis T3')
 thus ?thesis by simp qed
*)


theory Isar_Induction_Demo
imports Main
begin

section "Case distinction and induction"

subsection "Case distinction"

text \<open>Explicit:\<close>

lemma "length(tl xs) = length xs - 1"
proof (cases xs)
  assume "xs = []" thus ?thesis by simp
next
  fix y ys assume "xs = y#ys"
  thus ?thesis by simp
qed

text \<open>Implicit:\<close>

lemma "length(tl xs) = length xs - 1"
proof (cases xs)
print_cases
  case Nil
thm Nil
  thus ?thesis by simp
next
  case (Cons y ys)
thm Cons
  thus ?thesis by simp
qed

subsection \<open>Structural induction for type @{typ nat}\<close>

text \<open>Explicit:\<close>

lemma "\<Sum>{0..n::nat} = n*(n+1) div 2" (is "?P n")
proof (induction n)
  show "?P 0" by simp
next
  fix n assume "?P n"
  thus "?P(Suc n)" by simp
qed

text \<open>In more detail:\<close>

lemma "\<Sum>{0..n::nat} = n*(n+1) div 2" (is "?P n")
proof (induction n)
  show "?P 0" by simp
next
  fix n assume IH: "?P n"
  have "\<Sum>{0..Suc n} = \<Sum>{0..n} + Suc n" by simp
  also have "\<dots> = n*(n+1) div 2 + Suc n" using IH by simp
  also have "\<dots> = (Suc n)*((Suc n)+1) div 2" by simp
  finally show "?P(Suc n)" .
qed

text \<open>Implicit:\<close>

lemma "\<Sum>{0..n::nat} = n*(n+1) div 2"
proof (induction n)
print_cases
  case 0
  show ?case by simp
next
  case (Suc n)
thm Suc
  thus ?case by simp
qed

text \<open>Induction with \<open>\<Longrightarrow>\<close>:\<close>

lemma split_list: "x : set xs \<Longrightarrow> \<exists>ys zs. xs = ys @ x # zs"
proof (induction xs)
  case Nil thus ?case by simp
next
  case (Cons a xs)
thm Cons.IH (* Induction hypothesis *)
thm Cons.prems (* Premises of the step case *)
thm Cons
  from Cons.prems have "x = a \<or> x : set xs" by simp
  thus ?case
  proof
    assume "x = a"
    hence "a#xs = [] @ x # xs" by simp
    thus ?thesis by blast
  next
    assume "x : set xs"
    then obtain ys zs where "xs = ys @ x # zs" using Cons.IH by auto
    hence "a#xs = (a#ys) @ x # zs" by simp
    thus ?thesis by blast
  qed
qed

subsection "Computation induction"

fun div2 :: "nat \<Rightarrow> nat" where
"div2 0 = 0" |
"div2 (Suc 0) = 0" |
"div2 (Suc(Suc n)) = div2 n + 1"

lemma "2 * div2 n \<le> n"
proof(induction n rule: div2.induct)
  case 1
  show ?case by simp
next
  case 2
  show ?case by simp
next
  case (3 n)
  have "2 * div2 (Suc(Suc n)) = 2 * div2 n + 2" by simp
  also have "\<dots> \<le> n + 2" using "3.IH" by simp
  also have "\<dots> = Suc(Suc n)" by simp
  finally show ?case .
qed

text \<open>Note that \<open>3.IH\<close> is not a valid name, it needs double quotes: \<open>"3.IH"\<close>.\<close>

fun sep :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"sep a (x # y # zs) = x # a # sep a (y # zs)" |
"sep a xs = xs"

thm sep.simps

lemma "map f (sep a xs) = sep (f a) (map f xs)"
proof (induction a xs rule: sep.induct)
print_cases
  case (1 a x y zs)
  thus ?case by simp
next
  case ("2_1" a)
  show ?case by simp
next
  case ("2_2" a v)
  show ?case by simp
qed

subsection "Rule induction"

inductive ev :: "nat => bool" where
ev0:  "ev 0" |
evSS:  "ev n \<Longrightarrow> ev(Suc(Suc n))"

declare ev.intros [simp]

lemma "ev n \<Longrightarrow> \<exists>k. n = 2*k"
proof (induction rule: ev.induct)
  case ev0 show ?case by simp
next
  case evSS thus ?case by arith
qed

lemma "ev n \<Longrightarrow> \<exists>k. n = 2*k"
proof (induction rule: ev.induct)
  case ev0 show ?case by simp
next
  case (evSS m)
thm evSS
thm evSS.IH
thm evSS.hyps
  from evSS.IH obtain k where "m = 2*k" by blast
  hence "Suc(Suc m) = 2*(k+1)" by simp
  thus "\<exists>k. Suc(Suc m) = 2*k" by blast
qed

subsection "Inductive definition of the reflexive transitive closure"

consts step :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<rightarrow>" 55)

inductive steps :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<rightarrow>*" 55) where
refl: "x \<rightarrow>* x" |
step: "\<lbrakk> x \<rightarrow> y; y \<rightarrow>* z \<rbrakk> \<Longrightarrow> x \<rightarrow>* z"

declare refl[simp, intro]

text "Explicit and by hand:"

lemma "x \<rightarrow>* y  \<Longrightarrow>  y \<rightarrow>* z \<Longrightarrow> x \<rightarrow>* z"
proof(induction rule: steps.induct)
  fix x assume "x \<rightarrow>* z"
  thus "x \<rightarrow>* z" . (* by assumption *)
next
  fix x' x y :: 'a
  assume "x' \<rightarrow> x" and "x \<rightarrow>* y"
  assume IH: "y \<rightarrow>* z \<Longrightarrow> x \<rightarrow>* z"
  assume "y \<rightarrow>* z"
  show "x' \<rightarrow>* z" by(rule step[OF `x' \<rightarrow> x` IH[OF `y\<rightarrow>*z`]])
qed

text \<open>Implicit and automatic:\<close>

lemma "x \<rightarrow>* y  \<Longrightarrow>  y \<rightarrow>* z \<Longrightarrow> x \<rightarrow>* z"
proof(induction rule: steps.induct)
  case refl thus ?case .
next
  case (step x' x y)
  (* x' x y not used in proof text, just for demo *)
thm step
thm step.IH
thm step.hyps
thm step.prems
  show ?case
    by (metis step.hyps(1) step.IH step.prems steps.step)
qed

subsection "Rule inversion"

lemma assumes "ev n" shows "ev(n - 2)"
proof-
  from `ev n` show "ev(n - 2)"
  proof cases
    case ev0
thm ev0
    then show ?thesis by simp
  next
    case (evSS k)
thm evSS
    then show ?thesis by simp
  qed
qed

text \<open>Impossible cases are proved automatically:\<close>

lemma "\<not> ev(Suc 0)"
proof
  assume "ev(Suc 0)"
  then show False
  proof cases
  qed
qed

end


(* Author: Tobias Nipkow *)

section "Abstract Interpretation"

subsection "Complete Lattice"

theory Complete_Lattice
imports MainRLT
begin

locale Complete_Lattice =
fixes L :: "'a::order set" and Glb :: "'a set \<Rightarrow> 'a"
assumes Glb_lower: "A \<subseteq> L \<Longrightarrow> a \<in> A \<Longrightarrow> Glb A \<le> a"
and Glb_greatest: "b \<in> L \<Longrightarrow> \<forall>a\<in>A. b \<le> a \<Longrightarrow> b \<le> Glb A"
and Glb_in_L: "A \<subseteq> L \<Longrightarrow> Glb A \<in> L"
begin

definition lfp :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a" where
"lfp f = Glb {a : L. f a \<le> a}"

lemma index_lfp: "lfp f \<in> L"
by(auto simp: lfp_def intro: Glb_in_L)

lemma lfp_lowerbound:
  "\<lbrakk> a \<in> L;  f a \<le> a \<rbrakk> \<Longrightarrow> lfp f \<le> a"
by (auto simp add: lfp_def intro: Glb_lower)

lemma lfp_greatest:
  "\<lbrakk> a \<in> L;  \<And>u. \<lbrakk> u \<in> L; f u \<le> u\<rbrakk> \<Longrightarrow> a \<le> u \<rbrakk> \<Longrightarrow> a \<le> lfp f"
by (auto simp add: lfp_def intro: Glb_greatest)

end

end


header {* Conjunctive and Disjunctive Functions *}

(*
    Author: Viorel Preoteasa
*)

theory Conj_Disj
imports Main
begin

text{*
This theory introduces the definitions and some properties for
conjunctive, disjunctive, universally conjunctive, and universally
disjunctive functions.
*}

locale conjunctive =
  fixes inf_b :: "'b \<Rightarrow> 'b \<Rightarrow> 'b"
  and inf_c :: "'c \<Rightarrow> 'c \<Rightarrow> 'c"
  and times_abc :: "'a \<Rightarrow> 'b \<Rightarrow> 'c"
begin

definition
  "conjunctive = {x . (\<forall> y z . times_abc x (inf_b y z) = inf_c (times_abc x y) (times_abc x z))}"

lemma conjunctiveD: "x \<in> conjunctive \<Longrightarrow> times_abc x (inf_b y z) = inf_c (times_abc x y) (times_abc x z)"
  by (simp add: conjunctive_def)

end

interpretation Apply: conjunctive "inf::'a::semilattice_inf \<Rightarrow> 'a \<Rightarrow> 'a"
  "inf::'b::semilattice_inf \<Rightarrow> 'b \<Rightarrow> 'b" "\<lambda> f . f"
  done

interpretation Comp: conjunctive "inf::('a::lattice \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a)"
  "inf::('a::lattice \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a)" "(op o)"
  done

lemma "Apply.conjunctive = Comp.conjunctive"
  apply (simp add: Apply.conjunctive_def Comp.conjunctive_def)
  apply safe
  apply (simp_all add: fun_eq_iff inf_fun_def)
  apply (drule_tac x = "\<lambda> u . y" in spec)
  apply (drule_tac x = "\<lambda> u . z" in spec)
  by simp

locale disjunctive =
  fixes sup_b :: "'b \<Rightarrow> 'b \<Rightarrow> 'b"
  and sup_c :: "'c \<Rightarrow> 'c \<Rightarrow> 'c"
  and times_abc :: "'a \<Rightarrow> 'b \<Rightarrow> 'c"
begin

definition
  "disjunctive = {x . (\<forall> y z . times_abc x (sup_b y z) = sup_c (times_abc x y) (times_abc x z))}"

lemma disjunctiveD: "x \<in> disjunctive \<Longrightarrow> times_abc x (sup_b y z) = sup_c (times_abc x y) (times_abc x z)"
  by (simp add: disjunctive_def)

end

interpretation Apply: disjunctive "sup::'a::semilattice_sup \<Rightarrow> 'a \<Rightarrow> 'a"
  "sup::'b::semilattice_sup \<Rightarrow> 'b \<Rightarrow> 'b" "\<lambda> f . f"
  done

interpretation Comp: disjunctive "sup::('a::lattice \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a)"
  "sup::('a::lattice \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a)" "(op o)"
  done

lemma apply_comp_disjunctive: "Apply.disjunctive = Comp.disjunctive"
  apply (simp add: Apply.disjunctive_def Comp.disjunctive_def)
  apply safe
  apply (simp_all add: fun_eq_iff sup_fun_def)
  apply (drule_tac x = "\<lambda> u . y" in spec)
  apply (drule_tac x = "\<lambda> u . z" in spec)
  by simp

locale Conjunctive =
  fixes Inf_b :: "'b set \<Rightarrow> 'b"
  and Inf_c :: "'c set \<Rightarrow> 'c"
  and times_abc :: "'a \<Rightarrow> 'b \<Rightarrow> 'c"
begin

definition
  "Conjunctive = {x . (\<forall> X . times_abc x (Inf_b X) = Inf_c ((times_abc x) ` X) )}"
end

interpretation Apply: Conjunctive Inf Inf "\<lambda> f . f"
  done

interpretation Comp: Conjunctive "Inf::(('a::complete_lattice \<Rightarrow> 'a) set) \<Rightarrow> ('a \<Rightarrow> 'a)"
  "Inf::(('a::complete_lattice \<Rightarrow> 'a) set) \<Rightarrow> ('a \<Rightarrow> 'a)" "(op o)"
  done

lemma fun_eq: "x = y \<Longrightarrow> f x = f y"
  by simp

lemma "Apply.Conjunctive = Comp.Conjunctive"
  apply (simp add: Apply.Conjunctive_def Comp.Conjunctive_def)
  apply safe
  apply (simp add: fun_eq_iff  Inf_fun_def comp_def image_def)
  apply (simp only: INF_def)
  apply safe
  apply (rule_tac f = Inf in fun_eq)
  apply auto
  apply (drule_tac x = "{x . \<exists> y \<in> X . x = (\<lambda> u . y)}" in spec)
  apply (simp add: fun_eq_iff  Inf_fun_def comp_def image_def)
  apply (drule_tac x = "bot" in spec)
  apply (subgoal_tac "{y\<Colon>'a. \<exists>f . (\<exists>y \<in> X. \<forall>x::'a . f x = y) \<and> y = f bot} = X \<and>
      {y\<Colon>'a. \<exists>f. (\<exists>xa. (\<exists>y \<in> X. \<forall>x\<Colon>'a. xa x = y) \<and>
      (\<forall>xb\<Colon>'a. f xb = x (xa xb))) \<and> y = f bot} = {y\<Colon>'a. \<exists>xa\<Colon>'a\<in>X. y = x xa}")
  apply (simp add: INF_def image_def, safe)
  apply simp_all
  apply auto
  apply (metis (full_types) Collect_const UNIV_I mem_Collect_eq)
  apply (rule_tac x = "\<lambda> u . x xaa" in exI)
  by auto

locale Disjunctive =
  fixes Sup_b :: "'b set \<Rightarrow> 'b"
  and Sup_c :: "'c set \<Rightarrow> 'c"
  and times_abc :: "'a \<Rightarrow> 'b \<Rightarrow> 'c"
begin

definition
  "Disjunctive = {x . (\<forall> X . times_abc x (Sup_b X) = Sup_c ((times_abc x) ` X) )}"

lemma DisjunctiveD: "x \<in> Disjunctive \<Longrightarrow> times_abc x (Sup_b X) = Sup_c ((times_abc x) ` X)"
  by (simp add: Disjunctive_def)

end

interpretation Apply: Disjunctive Sup Sup "\<lambda> f . f"
  done

interpretation Comp: Disjunctive "Sup::(('a::complete_lattice \<Rightarrow> 'a) set) \<Rightarrow> ('a \<Rightarrow> 'a)"
  "Sup::(('a::complete_lattice \<Rightarrow> 'a) set) \<Rightarrow> ('a \<Rightarrow> 'a)" "(op o)"
  done

lemma apply_comp_Disjunctive: "Apply.Disjunctive = Comp.Disjunctive"
  apply (simp add: Apply.Disjunctive_def Comp.Disjunctive_def)
  apply safe
  apply (simp add: fun_eq_iff  Sup_fun_def comp_def image_def)
  apply (simp only: SUP_def)
  apply safe
  apply (rule_tac f = Sup in fun_eq)
  apply auto
  apply (drule_tac x = "{x . \<exists> y \<in> X . x = (\<lambda> u . y)}" in spec)
  apply (simp add: fun_eq_iff  Sup_fun_def comp_def image_def)
  apply (drule_tac x = "bot" in spec)
  apply (subgoal_tac "{y. \<exists>f::'a \<Rightarrow> 'a. (\<exists>y\<in>X. \<forall>x. f x = y) \<and> y = f bot} = X
    \<and> {y. \<exists>f::'a \<Rightarrow> 'a. (\<exists>xa. (\<exists>y\<in>X. \<forall>x. xa x = y) \<and> (\<forall>xb. f xb = x (xa xb))) \<and> y = f bot} = {y. \<exists>xa\<in>X. y = x xa}")
  apply (simp add: SUP_def image_def, safe)
  apply auto
  apply (metis (full_types) Collect_const UNIV_I mem_Collect_eq)
  apply (rule_tac x = "\<lambda> u . x xaa" in exI)
  by auto

lemma [simp]: "F \<in> Apply.conjunctive \<Longrightarrow> mono F"
  apply (simp add: Apply.conjunctive_def mono_def)
  apply safe
  apply (drule_tac x = "x" in spec)
  apply (drule_tac x = "y" in spec)
  apply (subgoal_tac "inf x y = x")
  apply simp
  apply (subgoal_tac "inf (F x) (F y) \<le> F y")
  apply simp
  apply (rule inf_le2)
  apply (rule antisym)
  by simp_all

lemma [simp]: "(F::'a::complete_lattice \<Rightarrow> 'b::complete_lattice) \<in> Apply.Conjunctive \<Longrightarrow> F top = top"
  apply (simp add: Apply.Conjunctive_def)
  apply (drule_tac x="{}" in spec)
  by simp

lemma [simp]: "(F::'a::complete_lattice \<Rightarrow> 'b::complete_lattice) \<in> Apply.Disjunctive \<Longrightarrow> F \<in> Apply.disjunctive"
  apply (simp add: Apply.Disjunctive_def Apply.disjunctive_def)
  apply safe
  apply (drule_tac x = "{y, z}" in spec)
  by simp

lemma [simp]: "F \<in> Apply.disjunctive \<Longrightarrow> mono F"
  apply (simp add: Apply.disjunctive_def mono_def)
  apply safe
  apply (drule_tac x = "x" in spec)
  apply (drule_tac x = "y" in spec)
  apply (subgoal_tac "sup x y = y")
  apply simp
  apply (subgoal_tac "F x \<le> sup (F x) (F y)")
  apply simp
  apply (rule sup_ge1)
  apply (rule antisym)
  apply simp
  by (rule sup_ge2)

lemma [simp]: "(F::'a::complete_lattice \<Rightarrow> 'b::complete_lattice) \<in> Apply.Disjunctive \<Longrightarrow> F bot = bot"
  apply (simp add: Apply.Disjunctive_def)
  apply (drule_tac x="{}" in spec)
  by simp

lemma weak_fusion: "h \<in> Apply.Disjunctive \<Longrightarrow> mono f \<Longrightarrow> mono g \<Longrightarrow>
    h o f \<le> g o h \<Longrightarrow> h (lfp f) \<le> lfp g"
  apply (rule_tac P = "\<lambda> x . h x \<le> lfp g" in lfp_ordinal_induct, simp_all)
  apply (rule_tac y = "g (h S)" in order_trans)
  apply (simp add: le_fun_def)
  apply (rule_tac y = "g (lfp g)" in order_trans)
  apply (rule_tac f = g in monoD, simp_all)
  apply (rule lfp_lemma2, simp)
  apply (simp add: Apply.DisjunctiveD)
  by (rule SUP_least, blast)

end


theory Permutation
  imports Main
begin

(* Some theorems about permutation were copied from HOL/HOL-NSA-Examples/Permutation *)
inductive perm :: "'a list => 'a list => bool"  ("_ <~~> _"  [50, 50] 50)
where
  Nil [intro!]: "[] <~~> []"
| swap [intro!]: "y # x # l <~~> x # y # l"
| Cons [intro!]: "xs <~~> ys ==> z # xs <~~> z # ys"
| trans [intro]: "xs <~~> ys ==> ys <~~> zs ==> xs <~~> zs"

lemma perm_refl [iff]: "l <~~> l"
  by (induct l) auto

lemma xperm_empty_imp: "[] <~~> ys ==> ys = []"
  by (induct xs == "[]::'a list" ys pred: perm) simp_all

lemma perm_length: "xs <~~> ys ==> length xs = length ys"
  by (induct pred: perm) simp_all

lemma perm_sym: "xs <~~> ys ==> ys <~~> xs"
  by (induct pred: perm) auto

lemma perm_append_Cons: "a # xs @ ys <~~> xs @ a # ys"
  by (induct xs) auto

lemma perm_append_swap: "xs @ ys <~~> ys @ xs"
  apply (induct xs)
    apply simp_all
  apply (blast intro: perm_append_Cons)
  done

lemma perm_append_single: "a # xs <~~> xs @ [a]"
  by (rule perm.trans [OF _ perm_append_swap]) simp

lemma perm_rev: "rev xs <~~> xs"
  apply (induct xs)
   apply simp_all
  apply (blast intro!: perm_append_single intro: perm_sym)
  done

lemma perm_append1: "xs <~~> ys ==> l @ xs <~~> l @ ys"
  by (induct l) auto

lemma perm_append2: "xs <~~> ys ==> xs @ l <~~> ys @ l"
  by (blast intro!: perm_append_swap perm_append1)

lemma perm_swap: "xs @ y # x # ys <~~> xs @ x # y # ys"
  apply (induct xs)
  by auto

end


\<^marker>\<open>creator "Alexander Krauss"\<close>
\<^marker>\<open>creator "Kevin Kappelmann"\<close>
\<^marker>\<open>creator "Larry Paulson"\<close>
section \<open>Union and Intersection\<close>
theory Union_Intersection
  imports Comprehension
begin

definition "inter A \<equiv> {x \<in> \<Union>A | \<forall>y \<in> A. x \<in> y}"

bundle hotg_inter_syntax begin notation inter ("\<Inter>_" [90] 90) end
bundle no_hotg_inter_syntax begin no_notation inter ("\<Inter>_" [90] 90) end
unbundle hotg_inter_syntax

text \<open>Intersection is well-behaved only if the family is non-empty!\<close>

lemma mem_inter_iff [iff]: "A \<in> \<Inter>C \<longleftrightarrow> C \<noteq> {} \<and> (\<forall>x \<in> C. A \<in> x)"
  unfolding inter_def by auto

(*LP: A "destruct" rule: every B in C contains A as an element, but A \<in> B can
  hold when B \<in> C does not! This rule is analogous to "spec".*)
lemma interD [dest]: "\<lbrakk>A \<in> \<Inter>C; B \<in> C\<rbrakk> \<Longrightarrow> A \<in> B" by auto

lemma union_empty_eq [iff]: "\<Union>{} = {}" by auto

lemma inter_empty_eq [iff]: "\<Inter>{} = {}" by auto

lemma union_eq_empty_iff: "\<Union>A = {} \<longleftrightarrow> A = {} \<or> A = {{}}"
proof
  assume "\<Union>A = {}"
  show "A = {} \<or> A = {{}}"
  proof (rule or_if_not_imp)
    assume "A \<noteq> {}"
    then obtain x where "x \<in> A" by auto
    from \<open>\<Union>A = {}\<close> have [simp]: "\<And>x. x \<in> A \<Longrightarrow> x = {}" by auto
    with \<open>x \<in> A\<close> have "x = {}" by simp
    with \<open>x \<in> A\<close> have [simp]: "{} \<in> A" by simp
    show "A = {{}}" by auto
  qed
qed auto

lemma union_eq_empty_iff': "\<Union>A = {} \<longleftrightarrow> (\<forall>B \<in> A. B = {})" by auto

lemma union_singleton_eq [simp]: "\<Union>{b} = b" by auto

lemma inter_singleton_eq [simp]: "\<Inter>{b} = b" by auto

lemma subset_union_if_mem: "B \<in> A \<Longrightarrow> B \<subseteq> \<Union>A" by blast

lemma inter_subset_if_mem: "B \<in> A \<Longrightarrow> \<Inter>A \<subseteq> B" by blast

lemma union_subset_iff: "\<Union>A \<subseteq> C \<longleftrightarrow> (\<forall>x \<in> A. x \<subseteq> C)" by blast

lemma subset_inter_iff_all_mem_subset_if_ne_empty:
  "A \<noteq> {} \<Longrightarrow> C \<subseteq> \<Inter>A \<longleftrightarrow> (\<forall>x \<in> A. C \<subseteq> x)"
  by blast

lemma union_subset_if_all_mem_subset: "(\<And>x. x \<in> A \<Longrightarrow> x \<subseteq> C) \<Longrightarrow> \<Union>A \<subseteq> C" by blast

lemma subset_inter_if_all_mem_subset_if_ne_empty:
  "\<lbrakk>A \<noteq> {}; \<And>x. x \<in> A \<Longrightarrow> C \<subseteq> x\<rbrakk> \<Longrightarrow> C \<subseteq> \<Inter>A"
  using subset_inter_iff_all_mem_subset_if_ne_empty by auto

lemma mono_union: "mono union"
  by (intro monoI) auto

lemma antimono_inter: "A \<noteq> {} \<Longrightarrow> A \<subseteq> A' \<Longrightarrow> \<Inter>A' \<subseteq> \<Inter>A"
  by auto

subsection \<open>Indexed Union and Intersection:\<close>

bundle hotg_idx_union_inter_syntax
begin
syntax
  "_idx_union" :: \<open>[pttrn, set, set \<Rightarrow> set] => set\<close> ("(3\<Union>_ \<in> _./ _)" [0, 0, 10] 10)
  "_idx_inter" :: \<open>[pttrn, set, set \<Rightarrow> set] => set\<close> ("(3\<Inter>_ \<in> _./ _)" [0, 0, 10] 10)
end
bundle no_hotg_idx_union_inter_syntax
begin
no_syntax
  "_idx_union" :: \<open>[pttrn, set, set \<Rightarrow> set] => set\<close> ("(3\<Union>_ \<in> _./ _)" [0, 0, 10] 10)
  "_idx_inter" :: \<open>[pttrn, set, set \<Rightarrow> set] => set\<close> ("(3\<Inter>_ \<in> _./ _)" [0, 0, 10] 10)
end
unbundle hotg_idx_union_inter_syntax

translations
  "\<Union>x \<in> A. B" \<rightleftharpoons> "\<Union>{B | x \<in> A}"
  "\<Inter>x \<in> A. B" \<rightleftharpoons> "\<Inter>{B | x \<in> A}"

lemma mem_idx_unionE [elim!]:
  assumes "b \<in> (\<Union>x \<in> A. B x)"
  obtains x where "x \<in> A" and "b \<in> B x"
  using assms by blast

lemma mem_idx_interD:
  assumes "b \<in> (\<Inter>x \<in> A. B x)" and "x \<in> A"
  shows "b \<in> B x"
  using assms by blast

lemma idx_union_cong [cong]:
  "\<lbrakk>A = B; \<And>x. x \<in> B \<Longrightarrow> C x = D x\<rbrakk> \<Longrightarrow> (\<Union>x \<in> A. C x) = (\<Union>x \<in> B. D x)"
  by simp

lemma idx_inter_cong [cong]:
  "\<lbrakk>A = B; \<And>x. x \<in> B \<Longrightarrow> C x = D x\<rbrakk> \<Longrightarrow> (\<Inter>x \<in> A. C x) = (\<Inter>x \<in> B. D x)"
  by simp

lemma idx_union_const_eq_if_ne_empty: "A \<noteq> {} \<Longrightarrow> (\<Union>x \<in> A. B) = B"
  by (rule eq_if_subset_if_subset) auto

lemma idx_inter_const_eq_if_ne_empty: "A \<noteq> {} \<Longrightarrow> (\<Inter>x \<in> A. B) = B"
  by (rule eq_if_subset_if_subset) auto

lemma idx_union_empty_dom_eq [simp]: "(\<Union>x \<in> {}. B x) = {}" by auto

lemma idx_inter_empty_dom_eq [simp]: "(\<Inter>x \<in> {}. B x) = {}" by auto

lemma idx_union_empty_eq [simp]: "(\<Union>x \<in> A. {}) = {}" by auto

lemma idx_inter_empty_eq [simp]: "(\<Inter>x \<in> A. {}) = {}" by blast

lemma idx_union_eq_union [simp]: "(\<Union>x \<in> A. x) = \<Union>A" by auto

lemma idx_inter_eq_inter [simp]: "(\<Inter>x \<in> A. x) = \<Inter>A" by auto

lemma idx_union_subset_iff: "(\<Union>x \<in> A. B x) \<subseteq> C \<longleftrightarrow> (\<forall>x \<in> A. B x \<subseteq> C)" by blast

lemma subset_idx_inter_iff_if_ne_empty:
  "C \<noteq> {} \<Longrightarrow> C \<subseteq> (\<Inter>x \<in> A. B x) \<longleftrightarrow> (A \<noteq> {} \<and> (\<forall>x \<in> A. C \<subseteq> B x))"
  by auto

lemma subset_idx_union_if_mem: "x \<in> A \<Longrightarrow> B x \<subseteq> (\<Union>x \<in> A. B x)" by blast

lemma idx_inter_subset_if_mem: "x \<in> A \<Longrightarrow> (\<Inter>x \<in> A. B x) \<subseteq> B x" by blast

lemma idx_union_subset_if_all_mem_app_subset:
  "(\<And>x. x \<in> A \<Longrightarrow> B x \<subseteq> C) \<Longrightarrow> (\<Union>x \<in> A. B x) \<subseteq> C"
  by blast

lemma subset_idx_inter_if_all_mem_subset_app_if_ne_empty:
  "\<lbrakk>A \<noteq> {}; \<And>x. x \<in> A \<Longrightarrow> C \<subseteq> B x\<rbrakk> \<Longrightarrow> C \<subseteq> (\<Inter>x \<in> A. B x)"
  by blast

lemma idx_union_singleton_eq [simp]: "(\<Union>x \<in> A. {x}) = A"
  by (rule eq_if_subset_if_subset) auto

lemma idx_union_flatten [simp]:
  "(\<Union>x \<in> (\<Union>y \<in> A. B y). C x) = (\<Union>y \<in> A. \<Union>x \<in> B y. C x)"
  by (rule eq_if_subset_if_subset) auto

lemma idx_union_const [simp]: "(\<Union>y \<in> A. c) = (if A = {} then {} else c)"
  by (rule eq_if_subset_if_subset) auto

lemma idx_inter_const [simp]: "(\<Inter>y \<in> A. c) = (if A = {} then {} else c)"
  by (rule eq_if_subset_if_subset) auto

lemma idx_union_repl [simp]: "(\<Union>y \<in> {f x | x \<in> A}. B y) = (\<Union>x \<in> A. B (f x))"
  by (rule eq_if_subset_if_subset) auto

lemma idx_inter_repl [simp]: "(\<Inter>x \<in> {f x | x \<in> A}. B x) = (\<Inter>a \<in> A. B(f a))"
  by auto

lemma idx_inter_union_eq_idx_inter_idx_inter:
  "{} \<notin> A \<Longrightarrow> (\<Inter>x \<in> \<Union>A. B x) = (\<Inter>y \<in> A. \<Inter>x \<in> y. B x)"
  by (auto iff: union_eq_empty_iff)

lemma idx_inter_idx_union_eq_idx_inter_idx_inter:
  assumes "\<And>x. (x \<in> A \<Longrightarrow> B x \<noteq> {})"
  shows "(\<Inter>z \<in> (\<Union>x \<in> A. B x). C z) = (\<Inter>x \<in> A. \<Inter>z \<in> B x. C z)"
proof (rule eqI)
  fix x assume "x \<in> (\<Inter>z \<in> (\<Union>x \<in> A. B x). C z)"
  with assms show "x \<in> (\<Inter>x \<in> A. \<Inter>z \<in> B x. C z)" by (auto 5 0)
next
  fix x assume x_mem: "x \<in> (\<Inter>x \<in> A. \<Inter>z \<in> B x. C z)"
  then have "A \<noteq> {}" by auto
  then obtain y where "y \<in> A" by auto
  with assms have "B y \<noteq> {}" by auto
  with \<open>y \<in> A\<close> have "{B x | x \<in> A} \<noteq> {{}}" by auto
  with x_mem show "x \<in> (\<Inter>z \<in> (\<Union>x \<in> A. B x). C z)"
    by (auto simp: union_eq_empty_iff)
qed

lemma mono_idx_union:
  assumes "A \<subseteq> A'"
  and "\<And>x. x \<in> A \<Longrightarrow> B x \<subseteq> B' x"
  shows "(\<Union>x \<in> A. B x) \<subseteq> (\<Union>x \<in> A'. B' x)"
  using assms by auto

lemma mono_antimono_idx_inter:
  assumes "A \<noteq> {}"
  and "A \<subseteq> A'"
  and "\<And>x. x \<in> A \<Longrightarrow> B' x \<subseteq> B x"
  shows "(\<Inter>x \<in> A'. B' x) \<subseteq> (\<Inter>x \<in> A. B x)"
  using assms by (intro subsetI) auto

subsection \<open>Binary Union and Intersection\<close>

definition "bin_union A B \<equiv> \<Union>{A, B}"

bundle hotg_bin_union_syntax begin notation bin_union (infixl "\<union>" 70) end
bundle no_hotg_bin_union_syntax begin no_notation bin_union (infixl "\<union>" 70) end
unbundle hotg_bin_union_syntax

definition "bin_inter A B \<equiv> \<Inter>{A, B}"

bundle hotg_bin_inter_syntax begin notation bin_inter (infixl "\<inter>" 70) end
bundle no_hotg_bin_inter_syntax begin no_notation bin_inter (infixl "\<inter>" 70) end
unbundle hotg_bin_inter_syntax

lemma mem_bin_union_iff [iff]: "x \<in> A \<union> B \<longleftrightarrow> x \<in> A \<or> x \<in> B"
  unfolding bin_union_def by auto

lemma mem_bin_inter_iff [iff]: "x \<in> A \<inter> B \<longleftrightarrow> x \<in> A \<and> x \<in> B"
  unfolding bin_inter_def by auto

paragraph\<open>Binary Union\<close>

lemma mem_bin_union_if_mem_left [elim?]: "c \<in> A \<Longrightarrow> c \<in> A \<union> B"
  by simp

lemma mem_bin_union_if_mem_right [elim?]: "c \<in> B \<Longrightarrow> c \<in> A \<union> B"
  by simp

lemma bin_unionE [elim!]:
  assumes "c \<in> A \<union> B"
  obtains (mem_left) "c \<in> A" | (mem_right) "c \<in> B"
  using assms by auto

(*stronger version of above rule*)
lemma bin_unionE' [elim!]:
  assumes "c \<in> A \<union> B"
  obtains (mem_left) "c \<in> A" | (mem_right) "c \<in> B" and "c \<notin> A"
  using assms by auto

(*LP: Classical introduction rule: no commitment to A vs B*)
lemma mem_bin_union_if_mem_if_not_mem: "(c \<notin> B \<Longrightarrow> c \<in> A) \<Longrightarrow> c \<in> A \<union> B"
  by auto

lemma bin_union_comm: "A \<union> B = B \<union> A"
  by (rule eq_if_subset_if_subset) auto

lemma bin_union_assoc: "(A \<union> B) \<union> C = A \<union> (B \<union> C)"
  by (rule eq_if_subset_if_subset) auto

lemma bin_union_comm_left: "A \<union> (B \<union> C) = B \<union> (A \<union> C)" by auto

lemmas bin_union_AC_rules = bin_union_comm bin_union_assoc bin_union_comm_left

lemma empty_bin_union_eq [iff]: "{} \<union> A = A"
  by (rule eq_if_subset_if_subset) auto

lemma bin_union_empty_eq [iff]: "A \<union> {} = A"
  by (rule eq_if_subset_if_subset) auto

lemma singleton_bin_union_absorb [simp]: "a \<in> A \<Longrightarrow> {a} \<union> A = A"
  by auto

lemma singleton_bin_union_eq_insert: "{x} \<union> A = insert x A"
  by (rule eq_if_subset_if_subset) auto

lemma bin_union_singleton_eq_insert: "A \<union> {x} = insert x A"
  using singleton_bin_union_eq_insert by (subst bin_union_comm)

lemma mem_singleton_bin_union [iff]: "a \<in> {a} \<union> B" by auto

lemma mem_bin_union_singleton [iff]: "b \<in> A \<union> {b}" by auto

lemma bin_union_subset_iff [iff]: "A \<union> B \<subseteq> C \<longleftrightarrow> A \<subseteq> C \<and> B \<subseteq> C"
  by blast

lemma bin_union_eq_left_iff [iff]: "A \<union> B = A \<longleftrightarrow> B \<subseteq> A"
  using mem_bin_union_if_mem_right[of _ B A] by (auto simp only: sym[of "A \<union> B"])

lemma bin_union_eq_right_iff [iff]: "A \<union> B = B \<longleftrightarrow> A \<subseteq> B"
  by (subst bin_union_comm) (fact bin_union_eq_left_iff)

lemma subset_bin_union_left: "A \<subseteq> A \<union> B" by blast

lemma subset_bin_union_right: "B \<subseteq> A \<union> B"
  by (subst bin_union_comm) (fact subset_bin_union_left)

lemma bin_union_subset_if_subset_if_subset: "\<lbrakk>A \<subseteq> C; B \<subseteq> C\<rbrakk> \<Longrightarrow> A \<union> B \<subseteq> C"
  by blast

lemma bin_union_self_eq_self [simp]: "A \<union> A = A"
  by (rule eq_if_subset_if_subset) auto

lemma bin_union_absorb: "A \<union> (A \<union> B) = A \<union> B"
  by (rule eq_if_subset_if_subset) auto

lemma bin_union_eq_right_if_subset: "A \<subseteq> B \<Longrightarrow> A \<union> B = B"
  by (rule eq_if_subset_if_subset) auto

lemma bin_union_eq_left_if_subset: "B \<subseteq> A \<Longrightarrow> A \<union> B = A"
  by (rule eq_if_subset_if_subset) auto

lemma bin_union_subset_bin_union_if_subset: "B \<subseteq> C \<Longrightarrow> A \<union> B \<subseteq> A \<union> C"
  by auto

lemma bin_union_subset_bin_union_if_subset': "A \<subseteq> B \<Longrightarrow> A \<union> C \<subseteq> B \<union> C"
  by auto

lemma bin_union_eq_empty_iff [iff]: "(A \<union> B = {}) \<longleftrightarrow> (A = {} \<and> B = {})"
  by auto

lemma mono_bin_union_left: "mono (\<lambda>A. A \<union> B)"
  by (intro monoI) auto

lemma mono_bin_union_right: "mono (\<lambda>B. A \<union> B)"
  by (intro monoI) auto

paragraph \<open>Binary Intersection\<close>

lemma mem_bin_inter_if_mem_if_mem [intro!]: "\<lbrakk>c \<in> A; c \<in> B\<rbrakk> \<Longrightarrow> c \<in> A \<inter> B"
  by simp

lemma mem_bin_inter_if_mem_left: "c \<in> A \<inter> B \<Longrightarrow> c \<in> A"
  by simp

lemma mem_bin_inter_if_mem_right: "c \<in> A \<inter> B \<Longrightarrow> c \<in> B"
  by simp

lemma mem_bin_interE [elim!]:
  assumes "c \<in> A \<inter> B"
  obtains "c \<in> A" and "c \<in> B"
  using assms by simp

lemma bin_inter_empty_iff [iff]: "A \<inter> B = {} \<longleftrightarrow> (\<forall>a \<in> A. a \<notin> B)"
  by auto

lemma bin_inter_comm: "A \<inter> B = B \<inter> A"
  by auto

lemma bin_inter_assoc: "(A \<inter> B) \<inter> C = A \<inter> (B \<inter> C)"
  by auto

lemma bin_inter_comm_left: "A \<inter> (B \<inter> C) = B \<inter> (A \<inter> C)"
  by auto

lemmas bin_inter_AC_rules = bin_inter_comm bin_inter_assoc bin_inter_comm_left

lemma empty_bin_inter_eq_empty [iff]: "{} \<inter> B = {}"
  by auto

lemma bin_inter_empty_eq_empty [iff]: "A \<inter> {} = {}"
  by auto

lemma bin_inter_subset_iff [iff]: "C \<subseteq> A \<inter> B \<longleftrightarrow> C \<subseteq> A \<and> C \<subseteq> B"
  by blast

lemma bin_inter_subset_left [iff]: "A \<inter> B \<subseteq> A"
  by blast

lemma bin_inter_subset_right [iff]: "A \<inter> B \<subseteq> B"
  by blast

lemma subset_bin_inter_if_subset_if_subset: "\<lbrakk>C \<subseteq> A; C \<subseteq> B\<rbrakk> \<Longrightarrow> C \<subseteq> A \<inter> B"
  by blast

lemma bin_inter_self_eq_self [iff]: "A \<inter> A = A"
  by (rule eq_if_subset_if_subset) auto

lemma bin_inter_absorb [iff]: "A \<inter> (A \<inter> B) = A \<inter> B"
  by (rule eq_if_subset_if_subset) auto

lemma bin_inter_eq_right_if_subset: "B \<subseteq> A \<Longrightarrow> A \<inter> B = B"
  by (rule eq_if_subset_if_subset) auto

lemma bin_inter_eq_left_if_subset: "A \<subseteq> B \<Longrightarrow> A \<inter> B = A"
  by (subst bin_inter_comm) (fact bin_inter_eq_right_if_subset)

lemma bin_inter_bin_union_distrib: "(A \<inter> B) \<union> C = (A \<union> C) \<inter> (B \<union> C)"
  by (rule eq_if_subset_if_subset) auto

lemma bin_inter_bin_union_distrib': "A \<inter> (B \<union> C) = (A \<inter> B) \<union> (A \<inter> C)"
  by (rule eq_if_subset_if_subset) auto

lemma bin_union_bin_inter_distrib: "(A \<union> B) \<inter> C = (A \<inter> C) \<union> (B \<inter> C)"
  by (rule eq_if_subset_if_subset) auto

lemma bin_union_bin_inter_distrib': "A \<union> (B \<inter> C) = (A \<union> B) \<inter> (A \<union> C)"
  by (rule eq_if_subset_if_subset) auto

lemma bin_inter_eq_left_iff_subset: "A \<subseteq> B \<longleftrightarrow> A \<inter> B = A"
  by auto

lemma bin_inter_eq_right_iff_subset: "A \<subseteq> B \<longleftrightarrow> B \<inter> A = A"
  by auto

lemma bin_inter_bin_union_assoc_iff:
  "(A \<inter> B) \<union> C = A \<inter> (B \<union> C) \<longleftrightarrow> C \<subseteq> A"
  by auto

lemma bin_inter_bin_union_swap3:
 "(A \<inter> B) \<union> (B \<inter> C) \<union> (C \<inter> A) = (A \<union> B) \<inter> (B \<union> C) \<inter> (C \<union> A)"
  by auto

lemma mono_bin_inter_left: "mono (\<lambda>A. A \<inter> B)"
  by (intro monoI) auto

lemma mono_bin_inter_right: "mono (\<lambda>B. A \<inter> B)"
  by (intro monoI) auto

paragraph\<open>Comprehension\<close>

lemma collect_eq_bin_inter [simp]: "{a \<in> A | a \<in> A'} = A \<inter> A'" by auto

lemma collect_bin_union_eq:
  "{x \<in> A \<union> B | P x} = {x \<in> A | P x} \<union> {x \<in> B | P x}"
  by (rule eq_if_subset_if_subset) auto

lemma collect_bin_inter_eq:
  "{x \<in> A \<inter> B | P x} = {x \<in> A | P x} \<inter> {x \<in> B | P x}"
  by (rule eq_if_subset_if_subset) auto

lemma bin_inter_collect_absorb [iff]:
  "A \<inter> {x \<in> A | P x} = {x \<in> A | P x}"
  by (rule eq_if_subset_if_subset) auto

lemma collect_idx_union_eq_union_collect [simp]:
  "{y \<in> (\<Union>x \<in> A. B x) | P y} = (\<Union>x \<in> A. {y \<in> B x | P y})"
  by (rule eq_if_subset_if_subset) auto

lemma bin_inter_collect_left_eq_collect:
  "{x \<in> A | P x} \<inter> B = {x \<in> A \<inter> B | P x}"
  by (rule eq_if_subset_if_subset) auto

lemma bin_inter_collect_right_eq_collect:
  "A \<inter> {x \<in> B | P x} = {x \<in> A \<inter> B | P x}"
  by (rule eq_if_subset_if_subset) auto

lemma collect_and_eq_inter_collect:
  "{x \<in> A | P x \<and> Q x} = {x \<in> A | P x} \<inter> {x \<in> A | Q x}"
  by (rule eq_if_subset_if_subset) auto

lemma collect_or_eq_union_collect:
  "{x \<in> A | P x \<or> Q x} = {x \<in> A | P x} \<union> {x \<in> A | Q x}"
  by (rule eq_if_subset_if_subset) auto

lemma union_bin_union_eq_bin_union_union: "\<Union>(A \<union> B) = \<Union>A \<union> \<Union>B"
  by (rule eq_if_subset_if_subset) auto

lemma union_bin_inter_subset_bin_inter_union: "\<Union>(A \<inter> B) \<subseteq> \<Union>A \<inter> \<Union>B"
  by blast

lemma union__disjoint_iff: "\<Union>C \<inter> A = {} \<longleftrightarrow> (\<forall>B \<in> C. B \<inter> A = {})"
  by blast

lemma subset_idx_union_iff_eq:
  "A \<subseteq> (\<Union>i \<in> I. B i) \<longleftrightarrow> A = (\<Union>i \<in> I. A \<inter> B i)" (is "A \<subseteq> ?lhs_union \<longleftrightarrow> A = ?rhs_union")
proof
  assume A_eq: "A = ?rhs_union"
  show "A \<subseteq> ?lhs_union"
  proof (rule subsetI)
    fix a assume "a \<in> A"
    with A_eq have "a \<in> ?rhs_union" by simp
    then obtain x where "x \<in> I" and "a \<in> A \<inter> B x" by auto
    then show "a \<in> ?lhs_union" by auto
  qed
qed (auto 5 0 intro!: eqI)

lemma bin_inter_union_eq_idx_union_inter: "\<Union>B \<inter> A = (\<Union>C \<in> B. C \<inter> A)"
  by (rule eq_if_subset_if_subset) auto

lemma bin_union_inter_subset_inter_bin_inter:
  "\<lbrakk>z \<in> A; z \<in> B\<rbrakk> \<Longrightarrow> \<Inter>A \<union> \<Inter>B \<subseteq> \<Inter>(A \<inter> B)"
  by blast

lemma inter_bin_union_eq_bin_inter_inter:
  "\<lbrakk>A \<noteq> {}; B \<noteq> {}\<rbrakk> \<Longrightarrow> \<Inter>(A \<union> B) = \<Inter>A \<inter> \<Inter>B"
  by (rule eq_if_subset_if_subset) auto

lemma idx_union_bin_union_dom_eq_bin_union_idx_union:
  "(\<Union>i \<in> A \<union> B. C i) = (\<Union>i \<in> A. C i) \<union> (\<Union>i \<in> B. C i)"
  by (rule eq_if_subset_if_subset) auto

lemma idx_inter_bin_inter_dom_eq_bin_inter_idx_inter:
  "(\<Inter>i \<in> I \<union> J. A i) = (
    if I = {} then \<Inter>j \<in> J. A j
    else if J = {} then \<Inter>i \<in> I. A i
    else (\<Inter>i \<in> I. A i) \<inter> (\<Inter>j \<in> J. A j)
  )"
  by (rule eq_if_subset_if_subset) auto

(*Halmos, Naive Set Theory, page 35*)
lemma bin_inter_idx_union_eq_union_bin_inter:
  "B \<inter> (\<Union>i \<in> I. A i) = (\<Union>i \<in> I. B \<inter> A i)"
  by (rule eq_if_subset_if_subset) auto

lemma bin_union_idx_inter_eq_inter_bin_union:
  "I \<noteq> {} \<Longrightarrow> B \<union> (\<Inter>i \<in> I. A i) = (\<Inter>i \<in> I. B \<union> A i)"
  by (rule eq_if_subset_if_subset) auto

lemma bin_inter_idx_union_eq_idx_union_bin_inter:
  "(\<Union>i \<in> I. A i) \<inter> (\<Union>j \<in> J. B j) = (\<Union>i \<in> I. \<Union>j \<in> J. A i \<inter> B j)"
  by (rule eq_if_subset_if_subset) auto

lemma bin_union_idx_inter_eq_idx_inter_bin_union:
  "\<lbrakk>I \<noteq> {}; J \<noteq> {}\<rbrakk> \<Longrightarrow>
    (\<Inter>i \<in> I. A i) \<union> (\<Inter>j \<in> J. B j) = (\<Inter>i \<in> I. \<Inter>j \<in> J. A i \<union> B j)"
  by (rule eq_if_subset_if_subset) auto

lemma idx_union_bin_union_eq_bin_union_idx_union:
  "(\<Union>i \<in> I. A i \<union> B i) = (\<Union>i \<in> I. A i) \<union> (\<Union>i \<in> I. B i)"
  by (rule eq_if_subset_if_subset) auto

lemma idx_inter_bin_inter_eq_bin_inter_idx_inter:
  "I \<noteq> {} \<Longrightarrow> (\<Inter>i \<in> I. A i \<inter> B i) = (\<Inter>i \<in> I. A i) \<inter> (\<Inter>i \<in> I. B i)"
  by (rule eq_if_subset_if_subset) auto

lemma idx_union_bin_inter_subset_bin_inter_idx_union:
  "(\<Union>z \<in> I \<inter> J. A z) \<subseteq> (\<Union>z \<in> I. A z) \<inter> (\<Union>z \<in> J. A z)"
  by blast

end


theory ATC
imports "../FSM/FSM"
begin

section \<open> Adaptive test cases \<close>

text \<open>
Adaptive test cases (ATCs) are tree-like structures that label nodes with inputs and edges with
outputs such that applying an ATC to some FSM is performed by applying the label of its root node
and then applying the ATC connected to the root node by an edge labeled with the observed output of
the FSM. The result of such an application is here called an ATC-reaction.

ATCs are here modelled to have edges for every possible output from each non-leaf node. This is not
a restriction on the definition of ATCs by Hierons \<^cite>\<open>"hierons"\<close> as a missing edge can be
expressed by an edge to a leaf.
\<close>

datatype ('in, 'out) ATC = Leaf | Node 'in "'out \<Rightarrow> ('in, 'out) ATC"

inductive atc_reaction :: "('in, 'out, 'state) FSM \<Rightarrow> 'state \<Rightarrow> ('in, 'out) ATC
                            \<Rightarrow> ('in \<times> 'out) list \<Rightarrow> bool"
  where
  leaf[intro!]: "atc_reaction M q1 Leaf []" |
  node[intro!]: "q2 \<in> succ M (x,y) q1
                  \<Longrightarrow> atc_reaction M q2 (f y) io
                  \<Longrightarrow> atc_reaction M q1 (Node x f) ((x,y)#io)"

inductive_cases leaf_elim[elim!] : "atc_reaction M q1 Leaf []"
inductive_cases node_elim[elim!] : "atc_reaction M q1 (Node x f) ((x,y)#io)"

subsection \<open> Properties of ATC-reactions \<close>

lemma atc_reaction_empty[simp] :
  assumes "atc_reaction M q t []"
  shows "t = Leaf"
using assms atc_reaction.simps by force

lemma atc_reaction_nonempty_no_leaf :
  assumes "atc_reaction M q t (Cons a io)"
  shows "t \<noteq> Leaf"
using assms
proof -
  have "\<And>f c a ps. \<not> atc_reaction f (c::'c) (a::('a, 'b) ATC) ps \<or> a \<noteq> Leaf \<or> a \<noteq> Leaf \<or> ps = []"
    using atc_reaction.simps by fastforce
  then show ?thesis
    using assms by blast
qed

lemma atc_reaction_nonempty[elim] :
  assumes "atc_reaction M q1 t (Cons (x,y) io)"
  obtains q2 f
  where "t = Node x f" "q2 \<in> succ M (x,y) q1"  "atc_reaction M q2 (f y) io"
proof -
  obtain x2 f where "t = Node x2 f"
    using assms by (metis ATC.exhaust atc_reaction_nonempty_no_leaf)
  moreover have "x = x2"
    using assms calculation atc_reaction.cases by fastforce
  ultimately show ?thesis
    using assms using that by blast
qed

lemma atc_reaction_path_ex :
  assumes "atc_reaction M q1 t io"
  shows "\<exists> tr . path M (io || tr) q1 \<and> length io = length tr"
using assms proof (induction io arbitrary: q1 t rule: list.induct)
  case Nil
  then show ?case by (simp add: FSM.nil)
next
  case (Cons io_hd io_tl)
  then obtain x y where io_hd_def : "io_hd = (x,y)"
    by (meson surj_pair)
  then obtain f where f_def : "t = (Node x f)"
    using Cons atc_reaction_nonempty by metis
  then obtain q2 where q2_def : "q2 \<in> succ M (x,y) q1" "atc_reaction M q2 (f y) io_tl"
    using Cons io_hd_def atc_reaction_nonempty by auto
  then obtain tr_tl where tr_tl_def :  "path M (io_tl || tr_tl) q2" "length io_tl = length tr_tl"
    using Cons.IH[of q2 "f y"] by blast
  then have "path M (io_hd # io_tl || q2 # tr_tl) q1"
    using Cons q2_def by (simp add: FSM.path.intros(2) io_hd_def)
  then show ?case using tr_tl_def by fastforce
qed

lemma atc_reaction_path[elim] :
  assumes "atc_reaction M q1 t io"
obtains tr
  where "path M (io || tr) q1" "length io = length tr"
by (meson assms atc_reaction_path_ex)

subsection \<open> Applicability \<close>

text \<open>
An ATC can be applied to an FSM if each node-label is contained in the input alphabet of the FSM.
\<close>

inductive subtest :: "('in, 'out) ATC \<Rightarrow> ('in, 'out) ATC \<Rightarrow> bool" where
  "t \<in> range f \<Longrightarrow> subtest t (Node x f)"

lemma accp_subtest : "Wellfounded.accp subtest t"
proof (induction t)
  case Leaf
  then show ?case by (meson ATC.distinct(1) accp.simps subtest.cases)
next
  case (Node x f)
  have IH: "Wellfounded.accp subtest t" if "t \<in> range f" for "t"
    using Node[of t] and that by (auto simp: eq_commute)
  show ?case by (rule accpI) (auto intro: IH elim!: subtest.cases)
qed

definition subtest_rel where "subtest_rel = {(t, Node x f) |f x t. t \<in> range f}"

lemma subtest_rel_altdef: "subtest_rel = {(s, t) |s t. subtest s t}"
  by (auto simp: subtest_rel_def subtest.simps)

lemma subtest_relI [intro]: "t \<in> range f \<Longrightarrow> (t, Node x f) \<in> subtest_rel"
  by (simp add: subtest_rel_def)

lemma subtest_relI' [intro]: "t = f y \<Longrightarrow> (t, Node x f) \<in> subtest_rel"
  by (auto simp: subtest_rel_def ran_def)

lemma wf_subtest_rel [simp, intro]: "wf subtest_rel"
  using accp_subtest unfolding subtest_rel_altdef accp_eq_acc wf_acc_iff
  by auto

function inputs_atc :: "('a,'b) ATC \<Rightarrow> 'a set" where
  "inputs_atc Leaf = {}" |
  "inputs_atc (Node x f) = insert x (\<Union> (image inputs_atc (range f)))"
by pat_completeness auto
termination by (relation subtest_rel) auto

fun applicable :: "('in, 'out, 'state) FSM \<Rightarrow> ('in, 'out) ATC \<Rightarrow> bool" where
  "applicable M t = (inputs_atc t \<subseteq> inputs M)"

fun applicable_set :: "('in, 'out, 'state) FSM \<Rightarrow> ('in, 'out) ATC set \<Rightarrow> bool" where
  "applicable_set M \<Omega> = (\<forall> t \<in> \<Omega> . applicable M t)"

lemma applicable_subtest :
  assumes "applicable M (Node x f)"
shows "applicable M (f y)"
using assms inputs_atc.simps
  by (simp add: Sup_le_iff)

subsection \<open> Application function IO \<close>

text \<open>
Function @{verbatim IO} collects all ATC-reactions of some FSM to some ATC.
\<close>

fun IO :: "('in, 'out, 'state) FSM \<Rightarrow> 'state \<Rightarrow> ('in, 'out) ATC \<Rightarrow> ('in \<times> 'out) list set" where
  "IO M q t = { tr . atc_reaction M q t tr }"

fun IO_set :: "('in, 'out, 'state) FSM \<Rightarrow> 'state \<Rightarrow> ('in, 'out) ATC set \<Rightarrow> ('in \<times> 'out) list set"
  where
  "IO_set M q \<Omega> = \<Union> {IO M q t | t . t \<in> \<Omega>}"

lemma IO_language : "IO M q t \<subseteq> language_state M q"
  by (metis atc_reaction_path IO.elims language_state mem_Collect_eq subsetI)

lemma IO_leaf[simp] : "IO M q Leaf = {[]}"
proof
  show "IO M q Leaf \<subseteq> {[]}"
  proof (rule ccontr)
    assume assm : "\<not> IO M q Leaf \<subseteq> {[]}"
    then obtain io_hd io_tl where elem_ex : "Cons io_hd io_tl \<in> IO M q Leaf"
      by (metis (no_types, opaque_lifting) insertI1 neq_Nil_conv subset_eq)
    then show "False"
      using atc_reaction_nonempty_no_leaf assm by (metis IO.simps mem_Collect_eq)
  qed
next
  show "{[]} \<subseteq> IO M q Leaf" by auto
qed

lemma IO_applicable_nonempty :
  assumes "applicable M t"
  and     "completely_specified M"
  and     "q1 \<in> nodes M"
  shows "IO M q1 t \<noteq> {}"
using assms proof (induction t arbitrary: q1)
  case Leaf
  then show ?case by auto
next
  case (Node x f)
  then have "x \<in> inputs M" by auto
  then obtain y q2  where x_appl : "q2 \<in> succ M (x, y) q1"
    using Node unfolding completely_specified.simps by blast
  then have "applicable M (f y)"
    using applicable_subtest Node by metis
  moreover have "q2 \<in> nodes M"
    using Node(4) \<open>q2 \<in> succ M (x, y) q1\<close> FSM.nodes.intros(2)[of q1 M "((x,y),q2)"] by auto
  ultimately have "IO M q2 (f y) \<noteq> {}"
    using Node by auto
  then show ?case unfolding IO.simps
    using x_appl by blast
qed

lemma IO_in_language :
  "IO M q t \<subseteq> LS M q"
  unfolding IO.simps by blast

lemma IO_set_in_language :
  "IO_set M q \<Omega> \<subseteq> LS M q"
  using IO_in_language[of M q] unfolding IO_set.simps by blast

subsection \<open> R-distinguishability \<close>

text \<open>
A non-empty ATC r-distinguishes two states of some FSM if there exists no shared ATC-reaction.
\<close>

fun r_dist :: "('in, 'out, 'state) FSM \<Rightarrow> ('in, 'out) ATC \<Rightarrow> 'state \<Rightarrow> 'state \<Rightarrow> bool" where
"r_dist M t s1 s2 = (t \<noteq> Leaf \<and> IO M s1 t \<inter> IO M s2 t = {})"

fun r_dist_set :: "('in, 'out, 'state) FSM \<Rightarrow> ('in, 'out) ATC set \<Rightarrow> 'state \<Rightarrow> 'state \<Rightarrow> bool" where
"r_dist_set M T s1 s2 = (\<exists> t \<in> T . r_dist M t s1 s2)"

lemma r_dist_dist :
  assumes "applicable M t"
  and     "completely_specified M"
  and     "r_dist M t q1 q2"
  and     "q1 \<in> nodes M"
shows   "q1 \<noteq> q2"
proof (rule ccontr)
  assume "\<not>(q1 \<noteq> q2)"
  then have "q1 = q2"
    by simp
  then have "IO M q1 t = {}"
    using assms by simp
  moreover have "IO M q1 t \<noteq> {}"
    using assms IO_applicable_nonempty by auto
  ultimately show "False"
    by simp
qed

lemma r_dist_set_dist :
  assumes "applicable_set M \<Omega>"
  and     "completely_specified M"
  and     "r_dist_set M \<Omega> q1 q2"
  and     "q1 \<in> nodes M"
shows   "q1 \<noteq> q2"
using assms r_dist_dist by (metis applicable_set.elims(2) r_dist_set.elims(2))

lemma r_dist_set_dist_disjoint :
  assumes "applicable_set M \<Omega>"
  and     "completely_specified M"
  and     "\<forall> t1 \<in> T1 . \<forall> t2 \<in> T2 . r_dist_set M \<Omega> t1 t2"
  and     "T1 \<subseteq> nodes M"
shows "T1 \<inter> T2 = {}"
  by (metis assms disjoint_iff_not_equal r_dist_set_dist subsetCE)

subsection \<open> Response sets \<close>

text \<open>
The following functions calculate the sets of all ATC-reactions observed by applying some set of
ATCs on every state reached in some FSM using a given set of IO-sequences.
\<close>

fun B :: "('in, 'out, 'state) FSM \<Rightarrow> ('in * 'out) list \<Rightarrow> ('in, 'out) ATC set
          \<Rightarrow> ('in * 'out) list set" where
  "B M io \<Omega> = \<Union> (image (\<lambda> s . IO_set M s \<Omega>) (io_targets M (initial M) io))"

fun D :: "('in, 'out, 'state) FSM \<Rightarrow> 'in list set \<Rightarrow> ('in, 'out) ATC set
          \<Rightarrow> ('in * 'out) list set set" where
  "D M ISeqs \<Omega> = image (\<lambda> io . B M io \<Omega>) (LS\<^sub>i\<^sub>n M (initial M) ISeqs)"

fun append_io_B :: "('in, 'out, 'state) FSM \<Rightarrow> ('in * 'out) list \<Rightarrow> ('in, 'out) ATC set
                    \<Rightarrow> ('in * 'out) list set" where
  "append_io_B M io \<Omega> = { io@res | res . res \<in> B M io \<Omega> }"

lemma B_dist' :
  assumes df: "B M io1 \<Omega> \<noteq> B M io2 \<Omega>"
  shows   "(io_targets M (initial M) io1) \<noteq> (io_targets M (initial M) io2)"
  using assms by force

lemma B_dist :
  assumes "io_targets M (initial M) io1 = {q1}"
  and     "io_targets M (initial M) io2 = {q2}"
  and     "B M io1 \<Omega> \<noteq> B M io2 \<Omega>"
shows   "q1 \<noteq> q2"
  using assms by force

lemma D_bound :
  assumes wf: "well_formed M"
  and     ob: "observable M"
  and     fi: "finite ISeqs"
  shows "finite (D M ISeqs \<Omega>)" "card (D M ISeqs \<Omega>) \<le> card (nodes M)"
proof -
  have "D M ISeqs \<Omega> \<subseteq> image (\<lambda> s . IO_set M s \<Omega>) (nodes M)"
  proof
    fix RS assume RS_def : "RS \<in> D M ISeqs \<Omega>"
    then obtain xs ys where RS_tr : "RS = B M (xs || ys) \<Omega>"
                                    "(xs \<in> ISeqs \<and> length xs = length ys
                                        \<and> (xs || ys) \<in> language_state M (initial M))"
      by auto
    then obtain qx where qx_def : "io_targets M (initial M) (xs || ys) = { qx }"
      by (meson io_targets_observable_singleton_ex ob)
    then have "RS = IO_set M qx \<Omega>"
      using RS_tr by auto
    moreover have "qx \<in> nodes M"
      by (metis FSM.nodes.initial io_targets_nodes qx_def singletonI)
    ultimately show "RS \<in> image (\<lambda> s . IO_set M s \<Omega>) (nodes M)"
      by auto
  qed
  moreover have "finite (nodes M)"
    using assms by auto
  ultimately show "finite (D M ISeqs \<Omega>)" "card (D M ISeqs \<Omega>) \<le> card (nodes M)"
    by (meson  finite_imageI infinite_super surj_card_le)+
qed

lemma append_io_B_in_language :
  "append_io_B M io \<Omega> \<subseteq> L M"
proof
  fix x assume "x \<in> append_io_B M io \<Omega>"
  then obtain res where "x = io@res" "res \<in> B M io \<Omega>"
    unfolding append_io_B.simps by blast
  then obtain q where "q \<in> io_targets M (initial M) io"  "res \<in> IO_set M q \<Omega>"
    unfolding B.simps by blast
  then have "res \<in> LS M q"
    using IO_set_in_language[of M q \<Omega>] by blast

  obtain pIO where "path M (io || pIO) (initial M)"
                   "length pIO = length io" "target (io || pIO) (initial M) = q"
    using \<open>q \<in> io_targets M (initial M) io\<close> by auto
  moreover obtain pRes where "path M (res || pRes) q" "length pRes = length res"
    using \<open>res \<in> LS M q\<close> by auto
  ultimately have "io@res \<in> L M"
    using FSM.path_append[of M "io||pIO" "initial M" "res||pRes"]
    by (metis language_state length_append zip_append)
  then show "x \<in> L M"
    using \<open>x = io@res\<close> by blast
qed

lemma append_io_B_nonempty :
  assumes "applicable_set M \<Omega>"
  and     "completely_specified M"
  and     "io \<in> language_state M (initial M)"
  and     "\<Omega> \<noteq> {}"
shows "append_io_B M io \<Omega> \<noteq> {}"
proof -
  obtain t where "t \<in> \<Omega>"
    using assms(4) by blast
  then have "applicable M t"
    using assms(1) by simp
  moreover obtain tr where "path M (io || tr) (initial M) \<and> length tr = length io"
    using assms(3) by auto
  moreover have "target (io || tr) (initial M) \<in> nodes M"
    using calculation(2) by blast
  ultimately have "IO M (target (io || tr) (initial M)) t \<noteq> {}"
    using assms(2) IO_applicable_nonempty by simp
  then obtain io' where "io' \<in> IO M (target (io || tr) (initial M)) t"
    by blast
  then have "io' \<in> IO_set M (target (io || tr) (initial M)) \<Omega>"
    using \<open>t \<in> \<Omega>\<close> unfolding IO_set.simps by blast
  moreover have "(target (io || tr) (initial M)) \<in> io_targets M (initial M) io"
    using \<open>path M (io || tr) (initial M) \<and> length tr = length io\<close> by auto
  ultimately have "io' \<in> B M io \<Omega>"
    unfolding B.simps by blast
  then have "io@io' \<in> append_io_B M io \<Omega>"
    unfolding append_io_B.simps by blast
  then show ?thesis by blast
qed

lemma append_io_B_prefix_in_language :
  assumes "append_io_B M io \<Omega> \<noteq> {}"
  shows "io \<in> L M"
proof -
  obtain res where "io @ res \<in> append_io_B M io \<Omega> \<and> res \<in> B M io \<Omega>"
    using assms by auto
  then have "io_targets M (initial M) io \<noteq> {}"
    by auto
  then obtain q where "q \<in> io_targets M (initial M) io"
    by blast
  then obtain tr where "target (io || tr) (initial M) = q \<and> path M (io || tr) (initial M)
                          \<and> length tr = length io" by auto
  then show ?thesis by auto
qed

subsection \<open> Characterizing sets \<close>

text \<open>
A set of ATCs is a characterizing set for some FSM if for every pair of r-distinguishable states it
contains an ATC that r-distinguishes them.
\<close>

fun characterizing_atc_set :: "('in, 'out, 'state) FSM \<Rightarrow> ('in, 'out) ATC set \<Rightarrow> bool" where
"characterizing_atc_set M \<Omega> = (applicable_set M \<Omega> \<and> (\<forall> s1 \<in> (nodes M) . \<forall> s2 \<in> (nodes M) .
    (\<exists> td . r_dist M td s1 s2) \<longrightarrow> (\<exists> tt \<in> \<Omega> . r_dist M tt s1 s2)))"

subsection \<open> Reduction over ATCs \<close>

text \<open>
Some state is a an ATC-reduction of another over some set of ATCs if for every contained ATC every
ATC-reaction to it of the former state is also an ATC-reaction of the latter state.
\<close>

fun atc_reduction :: "('in, 'out, 'state) FSM \<Rightarrow> 'state \<Rightarrow> ('in, 'out, 'state) FSM \<Rightarrow> 'state
                      \<Rightarrow> ('in, 'out) ATC set \<Rightarrow> bool" where
  "atc_reduction M2 s2 M1 s1 \<Omega> = (\<forall> t \<in> \<Omega> . IO M2 s2 t \<subseteq> IO M1 s1 t)"

\<comment> \<open>r-distinguishability holds for atc-reductions\<close>
lemma atc_rdist_dist[intro] :
  assumes wf2   : "well_formed M2"
  and     cs2   : "completely_specified M2"
  and     ap2   : "applicable_set M2 \<Omega>"
  and     el_t1 : "t1 \<in> nodes M2"
  and     red1  : "atc_reduction M2 t1 M1 s1 \<Omega>"
  and     red2  : "atc_reduction M2 t2 M1 s2 \<Omega>"
  and     rdist : "r_dist_set M1 \<Omega> s1 s2"
  and             "t1 \<in> nodes M2"
shows "r_dist_set M2 \<Omega> t1 t2"
proof -
  obtain td where td_def : "td \<in> \<Omega> \<and> r_dist M1 td s1 s2"
    using rdist by auto
  then have "IO M1 s1 td \<inter> IO M1 s2 td = {}"
    using td_def by simp
  moreover have "IO M2 t1 td \<subseteq> IO M1 s1 td"
    using red1 td_def by auto
  moreover have "IO M2 t2 td \<subseteq> IO M1 s2 td"
    using red2 td_def by auto
  ultimately have no_inter : "IO M2 t1 td \<inter> IO M2 t2 td = {}"
    by blast

  then have "td \<noteq> Leaf"
    by auto
  then have "IO M2 t1 td \<noteq> {}"
    by (meson ap2 IO_applicable_nonempty applicable_set.elims(2) cs2 td_def assms(8))
  then have "IO M2 t1 td \<noteq> IO M2 t2 td"
    using no_inter by auto
  then show ?thesis
    using no_inter td_def by auto
qed

subsection \<open> Reduction over ATCs applied after input sequences \<close>

text \<open>
The following functions check whether some FSM is a reduction of another over a given set of input
sequences while furthermore the response sets obtained by applying a set of ATCs after every input
sequence to the first FSM are subsets of the analogously constructed response sets of the second
FSM.
\<close>

fun atc_io_reduction_on :: "('in, 'out, 'state1) FSM \<Rightarrow> ('in, 'out, 'state2) FSM \<Rightarrow> 'in list
                            \<Rightarrow> ('in, 'out) ATC set \<Rightarrow> bool" where
  "atc_io_reduction_on M1 M2 iseq \<Omega> = (L\<^sub>i\<^sub>n M1 {iseq} \<subseteq> L\<^sub>i\<^sub>n M2 {iseq}
    \<and> (\<forall> io \<in> L\<^sub>i\<^sub>n M1 {iseq} . B M1 io \<Omega> \<subseteq> B M2 io \<Omega>))"

fun atc_io_reduction_on_sets :: "('in, 'out, 'state1) FSM \<Rightarrow> 'in list set \<Rightarrow> ('in, 'out) ATC set
                                  \<Rightarrow> ('in, 'out, 'state2) FSM \<Rightarrow> bool" where
  "atc_io_reduction_on_sets M1 TS \<Omega> M2 = (\<forall> iseq \<in> TS . atc_io_reduction_on M1 M2 iseq \<Omega>)"

notation
  atc_io_reduction_on_sets ("(_ \<preceq>\<lbrakk>_._\<rbrakk> _)" [1000,1000,1000,1000])

lemma io_reduction_from_atc_io_reduction :
  assumes "atc_io_reduction_on_sets M1 T \<Omega> M2"
  and     "finite T"
  shows "io_reduction_on M1 T M2"
using assms(2,1) proof (induction T)
  case empty
  then show ?case by auto
next
  case (insert t T)
  then have "atc_io_reduction_on M1 M2 t \<Omega>"
    by auto
  then have "L\<^sub>i\<^sub>n M1 {t} \<subseteq> L\<^sub>i\<^sub>n M2 {t}"
    using atc_io_reduction_on.simps by blast

  have "L\<^sub>i\<^sub>n M1 T \<subseteq> L\<^sub>i\<^sub>n M2 T"
    using insert.IH
  proof -
    have "atc_io_reduction_on_sets M1 T \<Omega> M2"
      by (meson contra_subsetD insert.prems atc_io_reduction_on_sets.simps subset_insertI)
    then show ?thesis
      using insert.IH by blast
  qed
  then have "L\<^sub>i\<^sub>n M1 T \<subseteq> L\<^sub>i\<^sub>n M2 (insert t T)"
    by (meson insert_iff language_state_for_inputs_in_language_state
        language_state_for_inputs_map_fst language_state_for_inputs_map_fst_contained
        subsetCE subsetI)
  moreover have "L\<^sub>i\<^sub>n M1 {t} \<subseteq> L\<^sub>i\<^sub>n M2 (insert t T)"
  proof -
    obtain pps :: "('a \<times> 'b) list set \<Rightarrow> ('a \<times> 'b) list set \<Rightarrow> ('a \<times> 'b) list" where
      "\<forall>x0 x1. (\<exists>v2. v2 \<in> x1 \<and> v2 \<notin> x0) = (pps x0 x1 \<in> x1 \<and> pps x0 x1 \<notin> x0)"
      by moura
    then have "\<forall>P Pa. pps Pa P \<in> P \<and> pps Pa P \<notin> Pa \<or> P \<subseteq> Pa"
      by blast
    moreover
    { assume "map fst (pps (L\<^sub>i\<^sub>n M2 (insert t T)) (L\<^sub>i\<^sub>n M1 {t})) \<notin> insert t T"
      then have "pps (L\<^sub>i\<^sub>n M2 (insert t T)) (L\<^sub>i\<^sub>n M1 {t}) \<notin> L\<^sub>i\<^sub>n M1 {t}
                      \<or> pps (L\<^sub>i\<^sub>n M2 (insert t T)) (L\<^sub>i\<^sub>n M1 {t}) \<in> L\<^sub>i\<^sub>n M2 (insert t T)"
        by (metis (no_types) insertI1 language_state_for_inputs_map_fst_contained singletonD) }
    ultimately show ?thesis
      by (meson \<open>L\<^sub>i\<^sub>n M1 {t} \<subseteq> L\<^sub>i\<^sub>n M2 {t}\<close> language_state_for_inputs_in_language_state
          language_state_for_inputs_map_fst set_rev_mp)
  qed

  ultimately show ?case
  proof -
    have f1: "\<forall>ps P Pa. (ps::('a \<times> 'b) list) \<notin> P \<or> \<not> P \<subseteq> Pa \<or> ps \<in> Pa"
      by blast
    obtain pps :: "('a \<times> 'b) list set \<Rightarrow> ('a \<times> 'b) list set \<Rightarrow> ('a \<times> 'b) list" where
      "\<forall>x0 x1. (\<exists>v2. v2 \<in> x1 \<and> v2 \<notin> x0) = (pps x0 x1 \<in> x1 \<and> pps x0 x1 \<notin> x0)"
      by moura
    moreover
    { assume "pps (L\<^sub>i\<^sub>n M2 (insert t T)) (L\<^sub>i\<^sub>n M1 (insert t T))
              \<notin> L\<^sub>i\<^sub>n M1 {t}"
      moreover
      { assume "map fst (pps (L\<^sub>i\<^sub>n M2 (insert t T)) (L\<^sub>i\<^sub>n M1 (insert t T)))
                \<notin> {t}"
        then have "map fst (pps (L\<^sub>i\<^sub>n M2 (insert t T))
                      (L\<^sub>i\<^sub>n M1 (insert t T))) \<noteq> t"
          by blast
        then have "pps (L\<^sub>i\<^sub>n M2 (insert t T)) (L\<^sub>i\<^sub>n M1 (insert t T))
                        \<notin> L\<^sub>i\<^sub>n M1 (insert t T)
                    \<or> pps (L\<^sub>i\<^sub>n M2 (insert t T)) (L\<^sub>i\<^sub>n M1 (insert t T))
                          \<in> L\<^sub>i\<^sub>n M2 (insert t T)"
          using f1 by (meson \<open>L\<^sub>i\<^sub>n M1 T \<subseteq> L\<^sub>i\<^sub>n M2 (insert t T)\<close>
                       insertE language_state_for_inputs_in_language_state
                       language_state_for_inputs_map_fst
                       language_state_for_inputs_map_fst_contained) }
      ultimately have "io_reduction_on M1 (insert t T) M2
                        \<or> pps (L\<^sub>i\<^sub>n M2 (insert t T)) (L\<^sub>i\<^sub>n M1 (insert t T))
                            \<notin> L\<^sub>i\<^sub>n M1 (insert t T)
                        \<or> pps (L\<^sub>i\<^sub>n M2 (insert t T)) (L\<^sub>i\<^sub>n M1 (insert t T))
                            \<in> L\<^sub>i\<^sub>n M2 (insert t T)"
        using f1 by (meson language_state_for_inputs_in_language_state
                     language_state_for_inputs_map_fst) }
      ultimately show ?thesis
        using f1 by (meson \<open>L\<^sub>i\<^sub>n M1 {t} \<subseteq> L\<^sub>i\<^sub>n M2 (insert t T)\<close> subsetI)
  qed
qed

lemma atc_io_reduction_on_subset :
  assumes "atc_io_reduction_on_sets M1 T \<Omega> M2"
  and     "T' \<subseteq> T"
shows "atc_io_reduction_on_sets M1 T' \<Omega> M2"
  using assms unfolding atc_io_reduction_on_sets.simps by blast

lemma atc_reaction_reduction[intro] :
  assumes ls : "language_state M1 q1 \<subseteq> language_state M2 q2"
  and     el1 : "q1 \<in> nodes M1"
  and     el2 : "q2 \<in> nodes M2"
  and     rct : "atc_reaction M1 q1 t io"
  and     ob2 : "observable M2"
  and     ob1 : "observable M1"
shows "atc_reaction M2 q2 t io"
using assms proof (induction t arbitrary: io q1 q2)
  case Leaf
  then have "io = []"
    by (metis atc_reaction_nonempty_no_leaf list.exhaust)
  then show ?case
    by (simp add: leaf)
next
  case (Node x f)
  then obtain io_hd io_tl where io_split : "io = io_hd # io_tl"
    by (metis ATC.distinct(1) atc_reaction_empty list.exhaust)
  moreover obtain y where y_def : "io_hd = (x,y)"
    using Node calculation by (metis ATC.inject atc_reaction_nonempty surj_pair)
  ultimately  obtain q1x where q1x_def : "q1x \<in> succ M1 (x,y) q1" "atc_reaction M1 q1x (f y) io_tl"
    using Node.prems(4) by blast

  then have pt1 : "path M1 ([(x,y)] || [q1x]) q1"
    by auto
  then have ls1 : "[(x,y)] \<in> language_state M1 q1"
    unfolding language_state_def path_def using list.simps(9) by force
  moreover have "q1x \<in> io_targets M1 q1 [(x,y)]"
    unfolding io_targets.simps
  proof -
    have f1: "length [(x, y)] = length [q1x]"
      by simp
    have "q1x = target ([(x, y)] || [q1x]) q1"
      by simp
    then show "q1x \<in> {target ([(x, y)] || cs) q1 |cs. path M1 ([(x, y)] || cs) q1
                                                      \<and> length [(x, y)] = length cs}"
      using f1 pt1 by blast
  qed
  ultimately have tgt1 : "io_targets M1 q1 [(x,y)] = {q1x}"
    using Node.prems io_targets_observable_singleton_ex q1x_def
    by (metis (no_types, lifting) singletonD)

  then have ls2 : "[(x,y)] \<in> language_state M2 q2"
    using Node.prems(1) ls1 by auto
  then obtain q2x where q2x_def : "q2x \<in> succ M2 (x,y) q2"
    unfolding language_state_def path_def
    using transition_system.path.cases by fastforce
  then have pt2 : "path M2 ([(x,y)] || [q2x]) q2"
    by auto
  then have "q2x \<in> io_targets M2 q2 [(x,y)]"
    using ls2 unfolding io_targets.simps
  proof -
    have f1: "length [(x, y)] = length [q2x]"
      by simp
    have "q2x = target ([(x, y)] || [q2x]) q2"
      by simp
    then show "q2x \<in> {target ([(x, y)] || cs) q2 |cs. path M2 ([(x, y)] || cs) q2
                                                        \<and> length [(x, y)] = length cs}"
      using f1 pt2 by blast
  qed

  then have tgt2 : "io_targets M2 q2 [(x,y)] = {q2x}"
    using Node.prems io_targets_observable_singleton_ex ls2 q2x_def
    by (metis (no_types, lifting) singletonD)

  then have "language_state M1 q1x \<subseteq> language_state M2 q2x"
    using language_state_inclusion_of_state_reached_by_same_sequence
          [of M1 q1 M2 q2 "[(x,y)]" q1x q2x]
          tgt1 tgt2 Node.prems by auto
  moreover have "q1x \<in> nodes M1"
    using q1x_def(1) Node.prems(2) by (metis insertI1 io_targets_nodes tgt1)
  moreover have "q2x \<in> nodes M2"
    using q2x_def(1) Node.prems(3) by (metis insertI1 io_targets_nodes tgt2)
  ultimately have "q2x \<in> succ M2 (x,y) q2 \<and> atc_reaction M2 q2x (f y) io_tl"
    using Node.IH[of "f y" q1x q2x io_tl] ob1 ob2 q1x_def(2) q2x_def by blast

  then show "atc_reaction M2 q2 (Node x f) io" using io_split y_def by blast
qed

lemma IO_reduction :
  assumes ls : "language_state M1 q1 \<subseteq> language_state M2 q2"
  and     el1 : "q1 \<in> nodes M1"
  and     el2 : "q2 \<in> nodes M2"
  and     ob1 : "observable M1"
  and     ob2 : "observable M2"
shows "IO M1 q1 t \<subseteq> IO M2 q2 t"
  using assms atc_reaction_reduction unfolding IO.simps by auto

lemma IO_set_reduction :
  assumes ls : "language_state M1 q1 \<subseteq> language_state M2 q2"
  and     el1 : "q1 \<in> nodes M1"
  and     el2 : "q2 \<in> nodes M2"
  and     ob1 : "observable M1"
  and     ob2 : "observable M2"
shows "IO_set M1 q1 \<Omega> \<subseteq> IO_set M2 q2 \<Omega>"
proof -
  have "\<forall> t \<in> \<Omega> . IO M1 q1 t \<subseteq> IO M2 q2 t"
    using assms IO_reduction by metis
  then show ?thesis
    unfolding IO_set.simps by blast
qed

lemma B_reduction :
  assumes red : "M1 \<preceq> M2"
  and     ob1 : "observable M1"
  and     ob2 : "observable M2"
shows "B M1 io \<Omega> \<subseteq> B M2 io \<Omega>"
proof
  fix xy assume xy_assm : "xy \<in> B M1 io \<Omega>"
  then obtain q1x where q1x_def : "q1x \<in> (io_targets M1 (initial M1) io) \<and> xy \<in> IO_set M1 q1x \<Omega>"
    unfolding B.simps by auto
  then obtain tr1 where tr1_def : "path M1 (io || tr1) (initial M1) \<and> length io = length tr1"
    by auto

  then have q1x_ob : "io_targets M1 (initial M1) io = {q1x}"
    using assms
    by (metis io_targets_observable_singleton_ex language_state q1x_def singleton_iff)

  then have ls1 : "io \<in> language_state M1 (initial M1)"
    by auto
  then have ls2 : "io \<in> language_state M2 (initial M2)"
    using red by auto

  then obtain tr2 where tr2_def : "path M2 (io || tr2) (initial M2) \<and> length io = length tr2"
    by auto
  then obtain q2x where q2x_def : "q2x \<in> (io_targets M2 (initial M2) io)"
    by auto

  then have q2x_ob : "io_targets M2 (initial M2) io = {q2x}"
    using tr2_def assms
    by (metis io_targets_observable_singleton_ex language_state singleton_iff)

  then have "language_state M1 q1x \<subseteq> language_state M2 q2x"
    using q1x_ob assms unfolding io_reduction.simps
    by (simp add: language_state_inclusion_of_state_reached_by_same_sequence)
  then have "IO_set M1 q1x \<Omega> \<subseteq> IO_set M2 q2x \<Omega>"
    using assms IO_set_reduction by (metis FSM.nodes.initial io_targets_nodes q1x_def q2x_def)
  moreover have "B M1 io \<Omega> = IO_set M1 q1x \<Omega>"
    using q1x_ob by auto
  moreover have "B M2 io \<Omega> = IO_set M2 q2x \<Omega>"
    using q2x_ob by auto
  ultimately have "B M1 io \<Omega> \<subseteq> B M2 io \<Omega>"
    by simp
  then show "xy \<in> B M2 io \<Omega>" using xy_assm
    by blast
qed

lemma append_io_B_reduction :
  assumes red : "M1 \<preceq> M2"
  and     ob1 : "observable M1"
  and     ob2 : "observable M2"
shows "append_io_B M1 io \<Omega> \<subseteq> append_io_B M2 io \<Omega>"
proof
  fix ioR assume ioR_assm : "ioR \<in> append_io_B M1 io \<Omega>"
  then obtain res where res_def : "ioR = io @ res" "res \<in> B M1 io \<Omega>"
    by auto
  then have "res \<in> B M2 io \<Omega>"
    using assms B_reduction by (metis (no_types, opaque_lifting) subset_iff)
  then show "ioR \<in> append_io_B M2 io \<Omega>"
    using ioR_assm res_def by auto
qed

lemma atc_io_reduction_on_reduction[intro] :
  assumes red : "M1 \<preceq> M2"
  and     ob1 : "observable M1"
  and     ob2 : "observable M2"
shows "atc_io_reduction_on M1 M2 iseq \<Omega>"
unfolding atc_io_reduction_on.simps proof
  show "L\<^sub>i\<^sub>n M1 {iseq} \<subseteq> L\<^sub>i\<^sub>n M2 {iseq}"
    using red by auto
next
  show "\<forall>io\<in>L\<^sub>i\<^sub>n M1 {iseq}. B M1 io \<Omega> \<subseteq> B M2 io \<Omega>"
    using  B_reduction assms by blast
qed

lemma atc_io_reduction_on_sets_reduction[intro] :
  assumes red : "M1 \<preceq> M2"
  and     ob1 : "observable M1"
  and     ob2 : "observable M2"
shows "atc_io_reduction_on_sets M1 TS \<Omega> M2"
  using assms atc_io_reduction_on_reduction by (metis atc_io_reduction_on_sets.elims(3))

lemma atc_io_reduction_on_sets_via_LS\<^sub>i\<^sub>n :
  assumes "atc_io_reduction_on_sets M1 TS \<Omega> M2"
  shows "(L\<^sub>i\<^sub>n M1 TS \<union> (\<Union>io\<in>L\<^sub>i\<^sub>n M1 TS. B M1 io \<Omega>))
          \<subseteq> (L\<^sub>i\<^sub>n M2 TS \<union> (\<Union>io\<in>L\<^sub>i\<^sub>n M2 TS. B M2 io \<Omega>))"
proof -
  have "\<forall> iseq \<in> TS . (L\<^sub>i\<^sub>n M1 {iseq} \<subseteq> L\<^sub>i\<^sub>n M2 {iseq}
                        \<and> (\<forall> io \<in> L\<^sub>i\<^sub>n M1 {iseq} . B M1 io \<Omega> \<subseteq> B M2 io \<Omega>))"
    using assms by auto
  then have "\<forall> iseq \<in> TS . (\<Union>io\<in>L\<^sub>i\<^sub>n M1 {iseq}. B M1 io \<Omega>)
                            \<subseteq> (\<Union>io\<in>L\<^sub>i\<^sub>n M2 {iseq}. B M2 io \<Omega>)"
    by blast
  moreover have "\<forall> iseq \<in> TS . (\<Union>io\<in>L\<^sub>i\<^sub>n M2 {iseq}. B M2 io \<Omega>)
                                \<subseteq> (\<Union>io\<in>L\<^sub>i\<^sub>n M2 TS. B M2 io \<Omega>)"
    unfolding language_state_for_inputs.simps by blast
  ultimately have elem_subset : "\<forall> iseq \<in> TS .
                                  (\<Union>io\<in>L\<^sub>i\<^sub>n M1 {iseq}. B M1 io \<Omega>)
                                    \<subseteq> (\<Union>io\<in>L\<^sub>i\<^sub>n M2 TS. B M2 io \<Omega>)"
    by blast

  show ?thesis
  proof
    fix x assume "x \<in> L\<^sub>i\<^sub>n M1 TS \<union> (\<Union>io\<in>L\<^sub>i\<^sub>n M1 TS. B M1 io \<Omega>)"
    then show "x \<in> L\<^sub>i\<^sub>n M2 TS \<union> (\<Union>io\<in>L\<^sub>i\<^sub>n M2 TS. B M2 io \<Omega>)"
    proof (cases "x \<in> L\<^sub>i\<^sub>n M1 TS")
      case True
      then obtain iseq where "iseq \<in> TS" "x\<in> L\<^sub>i\<^sub>n M1 {iseq}"
        unfolding language_state_for_inputs.simps by blast
      then have "atc_io_reduction_on M1 M2 iseq \<Omega>"
        using assms by auto
      then have "L\<^sub>i\<^sub>n M1 {iseq} \<subseteq> L\<^sub>i\<^sub>n M2 {iseq}"
        by auto
      then have "x \<in> L\<^sub>i\<^sub>n M2 TS"
        by (metis (no_types, lifting) UN_I
            \<open>\<And>thesis. (\<And>iseq. \<lbrakk>iseq \<in> TS; x \<in> L\<^sub>i\<^sub>n M1 {iseq}\<rbrakk> \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close>
            \<open>\<forall>iseq\<in>TS. L\<^sub>i\<^sub>n M1 {iseq} \<subseteq> L\<^sub>i\<^sub>n M2 {iseq} \<and> (\<forall>io\<in>L\<^sub>i\<^sub>n M1 {iseq}. B M1 io \<Omega> \<subseteq> B M2 io \<Omega>)\<close>
            language_state_for_input_alt_def language_state_for_inputs_alt_def set_rev_mp)
      then show ?thesis
        by blast
    next
      case False
      then have "x \<in> (\<Union>io\<in>L\<^sub>i\<^sub>n M1 TS. B M1 io \<Omega>)"
        using \<open>x \<in> L\<^sub>i\<^sub>n M1 TS \<union> (\<Union>io\<in>L\<^sub>i\<^sub>n M1 TS. B M1 io \<Omega>)\<close> by blast
      then obtain io where "io \<in> L\<^sub>i\<^sub>n M1 TS" "x \<in> B M1 io \<Omega>"
        by blast
      then obtain iseq where "iseq \<in> TS" "io\<in>L\<^sub>i\<^sub>n M1 {iseq}"
        unfolding language_state_for_inputs.simps by blast
      have "x \<in> (\<Union>io\<in>L\<^sub>i\<^sub>n M1 {iseq}. B M1 io \<Omega>)"
        using \<open>io \<in> L\<^sub>i\<^sub>n M1 {iseq}\<close> \<open>x \<in> B M1 io \<Omega>\<close> by blast
      then have "x \<in> (\<Union>io\<in>L\<^sub>i\<^sub>n M2 TS. B M2 io \<Omega>)"
        using \<open>iseq \<in> TS\<close> elem_subset by blast
      then show ?thesis
        by blast
    qed
  qed
qed

end


theory Exercises2_07
  imports Main
begin

(*---------------- Exercise 2.7----------------*)
datatype 'a tree2 = Leaf 'a | Node "'a tree2" 'a "'a tree2"

(* mirror function *)
fun mirror :: "'a tree2 \<Rightarrow> 'a tree2" where
"mirror (Leaf a) = Leaf a" |
"mirror (Node l a r) = Node (mirror r) a (mirror l)"

(* pre-order function *)
fun pre_order :: "'a tree2 \<Rightarrow> 'a list" where
"pre_order (Leaf a) = [a]" |
"pre_order (Node l a r) = [a]@(pre_order l)@(pre_order r)"

(* post-order function *)
fun post_order :: "'a tree2 \<Rightarrow> 'a list" where
"post_order (Leaf a) = [a]" |
"post_order (Node l a r) = (post_order l)@(post_order r)@[a]"

theorem pre_post : "pre_order (mirror t) = rev (post_order t)"
  apply(induction t)
  apply(auto)
  done

end


section "Stack Proofs"

theory Stack_Proof
imports Stack Util
begin

lemma push_list [simp]: "list (push x stack) = x # list stack"
  by(cases stack) auto

lemma pop_list [simp]: "\<not> is_empty stack \<Longrightarrow> list (pop stack) = tl (list stack)"
  by(induction stack rule: pop.induct) auto

lemma first_list [simp]: "\<not> is_empty stack \<Longrightarrow> first stack = hd (list stack)"
  by(induction stack rule: first.induct) auto

lemma list_empty: "list stack = [] \<longleftrightarrow> is_empty stack"
  by(induction stack rule: is_empty_stack.induct) auto

lemma list_not_empty: "list stack  \<noteq> [] \<longleftrightarrow> \<not> is_empty stack"
  by(induction stack rule: is_empty_stack.induct) auto

lemma list_empty_2 [simp]: "\<lbrakk>list stack \<noteq> []; is_empty stack\<rbrakk> \<Longrightarrow> False"
  by (simp add: list_empty)

lemma list_not_empty_2 [simp]:"\<lbrakk>list stack = []; \<not> is_empty stack\<rbrakk> \<Longrightarrow> False"
  by (simp add: list_empty)

lemma list_empty_size: "list stack = [] \<longleftrightarrow> size stack = 0"
  by(induction stack) auto

lemma list_not_empty_size:"list stack \<noteq> [] \<longleftrightarrow> 0 < size stack"
  by(induction stack) auto

lemma list_empty_size_2 [simp]: "\<lbrakk>list stack \<noteq> []; size stack = 0\<rbrakk> \<Longrightarrow> False"
  by (simp add: list_empty_size)

lemma list_not_empty_size_2 [simp]:"\<lbrakk>list stack = []; 0 < size stack\<rbrakk> \<Longrightarrow> False"
  by (simp add: list_empty_size)

lemma size_push [simp]: "size (push x stack) = Suc (size stack)"
  by(cases stack) auto

lemma size_pop [simp]: "size (pop stack) = size stack - Suc 0"
  by(induction stack rule: pop.induct) auto

lemma size_empty: "size (stack :: 'a stack) = 0 \<longleftrightarrow> is_empty stack"
  by(induction stack rule: is_empty_stack.induct) auto

lemma size_not_empty: "size (stack :: 'a stack) > 0 \<longleftrightarrow> \<not> is_empty stack"
  by(induction stack rule: is_empty_stack.induct) auto

lemma size_empty_2[simp]: "\<lbrakk>size (stack :: 'a stack) = 0; \<not>is_empty stack\<rbrakk> \<Longrightarrow> False"
  by (simp add: size_empty)

lemma size_not_empty_2[simp]: "\<lbrakk>0 < size (stack :: 'a stack); is_empty stack\<rbrakk> \<Longrightarrow> False"
  by (simp add: size_not_empty)

lemma size_list_length [simp]: "length (list stack) = size stack"
  by(cases stack) auto

lemma first_pop [simp]: "\<not> is_empty stack \<Longrightarrow> first stack # list (pop stack) = list stack"
  by(induction stack rule: pop.induct) auto

lemma push_not_empty [simp]: "\<lbrakk>\<not> is_empty stack; is_empty (push x stack)\<rbrakk> \<Longrightarrow> False"
  by(induction x stack rule: push.induct) auto

lemma pop_list_length [simp]: "\<not> is_empty stack
   \<Longrightarrow> Suc (length (list (pop stack))) = length (list stack)"
  by(induction stack rule: pop.induct) auto

lemma first_take: "\<not>is_empty stack \<Longrightarrow> [first stack] = take 1 (Stack.list stack)"
  by (simp add: list_empty)

lemma first_take_tl [simp]: "0 < size big
   \<Longrightarrow> (first big # take count (tl (list big))) = take (Suc count) (list big)"
  by(induction big rule: Stack.first.induct) auto

lemma first_take_pop [simp]: "\<lbrakk>\<not>is_empty stack; 0 < x\<rbrakk>
   \<Longrightarrow> first stack # take (x - Suc 0) (list (pop stack)) = take x (list stack)"
  by(induction stack rule: pop.induct) (auto simp: take_Cons')

lemma first_hd: "Stack.first stack = hd (Stack.list stack)"
  by(induction stack rule: first.induct)(auto simp: hd_def)

lemma pop_tl [simp]: "list (pop stack) = tl (list stack)"
  by(induction stack rule: pop.induct) auto

lemma pop_drop: "list (pop stack) = drop 1 (list stack)"
  by (simp add: drop_Suc)

lemma popN_drop [simp]: "list ((pop ^^ n) stack) = drop n (list stack)"
  by(induction n)(auto simp: drop_Suc tl_drop)

lemma popN_size [simp]: "size ((pop ^^ n) stack) = (size stack) - n"
 by(induction n) auto

lemma take_first: "\<lbrakk>0 < size s1; 0 < size s2; take (size s1) (list s2) = take (size s2) (list s1)\<rbrakk>
    \<Longrightarrow> first s1 = first s2"
  by(induction s1 rule: first.induct; induction s2 rule: first.induct) auto

end