(*  Title:      HOL/UNITY/Comp/Priority.thy
    Author:     Sidi O Ehmety, Cambridge University Computer Laboratory
    Copyright   2001  University of Cambridge
*)

section{*The priority system*}

theory Priority imports PriorityAux begin

text{*From Charpentier and Chandy,
Examples of Program Composition Illustrating the Use of Universal Properties
   In J. Rolim (editor), Parallel and Distributed Processing,
   Spriner LNCS 1586 (1999), pages 1215-1227.*}

type_synonym state = "(vertex*vertex)set"
type_synonym command = "vertex=>(state*state)set"

consts
  init :: "(vertex*vertex)set"
  --{* the initial state *}

text{*Following the definitions given in section 4.4 *}

definition highest :: "[vertex, (vertex*vertex)set]=>bool"
  where "highest i r <-> A i r = {}"
    --{* i has highest priority in r *}

definition lowest :: "[vertex, (vertex*vertex)set]=>bool"
  where "lowest i r <-> R i r = {}"
    --{* i has lowest priority in r *}

definition act :: command
  where "act i = {(s, s'). s'=reverse i s & highest i s}"

definition Component :: "vertex=>state program"
  where "Component i = mk_total_program({init}, {act i}, UNIV)"
    --{* All components start with the same initial state *}

text{*Some Abbreviations *}
definition Highest :: "vertex=>state set"
  where "Highest i = {s. highest i s}"

definition Lowest :: "vertex=>state set"
  where "Lowest i = {s. lowest i s}"

definition Acyclic :: "state set"
  where "Acyclic = {s. acyclic s}"

definition Maximal :: "state set"
    --{* Every ``above'' set has a maximal vertex*}
  where "Maximal = (\<Inter>i. {s. ~highest i s-->(\<exists>j \<in> above i  s. highest j s)})"

definition Maximal' :: "state set"
    --{* Maximal vertex: equivalent definition*}
  where "Maximal' = (\<Inter>i. Highest i Un (\<Union>j. {s. j \<in> above i s} Int Highest j))"

definition Safety :: "state set"
  where "Safety = (\<Inter>i. {s. highest i s --> (\<forall>j \<in> neighbors i s. ~highest j s)})"

  (* Composition of a finite set of component;
     the vertex 'UNIV' is finite by assumption *)

definition system :: "state program"
  where "system = (JN i. Component i)"

declare highest_def [simp] lowest_def [simp]
declare Highest_def [THEN def_set_simp, simp]
    and Lowest_def  [THEN def_set_simp, simp]

declare Component_def [THEN def_prg_Init, simp]
declare act_def [THEN def_act_simp, simp]

subsection{*Component correctness proofs*}

text{* neighbors is stable  *}
lemma Component_neighbors_stable: "Component i \<in> stable {s. neighbors k s = n}"
by (simp add: Component_def, safety, auto)

text{* property 4 *}
lemma Component_waits_priority: "Component i: {s. ((i,j):s) = b} Int (- Highest i) co {s. ((i,j):s)=b}"
by (simp add: Component_def, safety)

text{* property 5: charpentier and Chandy mistakenly express it as
 'transient Highest i'. Consider the case where i has neighbors *}
lemma Component_yields_priority:
 "Component i: {s. neighbors i s \<noteq> {}} Int Highest i
               ensures - Highest i"
apply (simp add: Component_def)
apply (ensures_tac "act i", blast+)
done

text{* or better *}
lemma Component_yields_priority': "Component i \<in> Highest i ensures Lowest i"
apply (simp add: Component_def)
apply (ensures_tac "act i", blast+)
done

text{* property 6: Component doesn't introduce cycle *}
lemma Component_well_behaves: "Component i \<in> Highest i co Highest i Un Lowest i"
by (simp add: Component_def, safety, fast)

text{* property 7: local axiom *}
lemma locality: "Component i \<in> stable {s. \<forall>j k. j\<noteq>i & k\<noteq>i--> ((j,k):s) = b j k}"
by (simp add: Component_def, safety)

subsection{*System  properties*}
text{* property 8: strictly universal *}

lemma Safety: "system \<in> stable Safety"
apply (unfold Safety_def)
apply (rule stable_INT)
apply (simp add: system_def, safety, fast)
done

text{* property 13: universal *}
lemma p13: "system \<in> {s. s = q} co {s. s=q} Un {s. \<exists>i. derive i q s}"
by (simp add: system_def Component_def mk_total_program_def totalize_JN, safety, blast)

text{* property 14: the 'above set' of a Component that hasn't got
      priority doesn't increase *}
lemma above_not_increase:
     "system \<in> -Highest i Int {s. j\<notin>above i s} co {s. j\<notin>above i s}"
apply (insert reach_lemma [of concl: j])
apply (simp add: system_def Component_def mk_total_program_def totalize_JN,
       safety)
apply (simp add: trancl_converse, blast)
done

lemma above_not_increase':
     "system \<in> -Highest i Int {s. above i s = x} co {s. above i s <= x}"
apply (insert above_not_increase [of i])
apply (simp add: trancl_converse constrains_def, blast)
done

text{* p15: universal property: all Components well behave  *}
lemma system_well_behaves: "system \<in> Highest i co Highest i Un Lowest i"
  by (simp add: system_def Component_def mk_total_program_def totalize_JN, safety, auto)

lemma Acyclic_eq: "Acyclic = (\<Inter>i. {s. i\<notin>above i s})"
  by (auto simp add: Acyclic_def acyclic_def trancl_converse)

lemmas system_co =
      constrains_Un [OF above_not_increase [rule_format] system_well_behaves]

lemma Acyclic_stable: "system \<in> stable Acyclic"
apply (simp add: stable_def Acyclic_eq)
apply (auto intro!: constrains_INT system_co [THEN constrains_weaken]
            simp add: image0_r_iff_image0_trancl trancl_converse)
done

lemma Acyclic_subset_Maximal: "Acyclic <= Maximal"
apply (unfold Acyclic_def Maximal_def, clarify)
apply (drule above_lemma_b, auto)
done

text{* property 17: original one is an invariant *}
lemma Acyclic_Maximal_stable: "system \<in> stable (Acyclic Int Maximal)"
by (simp add: Acyclic_subset_Maximal [THEN Int_absorb2] Acyclic_stable)

text{* property 5: existential property *}

lemma Highest_leadsTo_Lowest: "system \<in> Highest i leadsTo Lowest i"
apply (simp add: system_def Component_def mk_total_program_def totalize_JN)
apply (ensures_tac "act i", auto)
done

text{* a lowest i can never be in any abover set *}
lemma Lowest_above_subset: "Lowest i <= (\<Inter>k. {s. i\<notin>above k s})"
by (auto simp add: image0_r_iff_image0_trancl trancl_converse)

text{* property 18: a simpler proof than the original, one which uses psp *}
lemma Highest_escapes_above: "system \<in> Highest i leadsTo (\<Inter>k. {s. i\<notin>above k s})"
apply (rule leadsTo_weaken_R)
apply (rule_tac [2] Lowest_above_subset)
apply (rule Highest_leadsTo_Lowest)
done

lemma Highest_escapes_above':
     "system \<in> Highest j Int {s. j \<in> above i s} leadsTo {s. j\<notin>above i s}"
by (blast intro: leadsTo_weaken [OF Highest_escapes_above Int_lower1 INT_lower])

subsection{*The main result: above set decreases*}

text{* The original proof of the following formula was wrong *}

lemma Highest_iff_above0: "Highest i = {s. above i s ={}}"
by (auto simp add: image0_trancl_iff_image0_r)

lemmas above_decreases_lemma =
     psp [THEN leadsTo_weaken, OF Highest_escapes_above' above_not_increase']

lemma above_decreases:
     "system \<in> (\<Union>j. {s. above i s = x} Int {s. j \<in> above i s} Int Highest j)
               leadsTo {s. above i s < x}"
apply (rule leadsTo_UN)
apply (rule single_leadsTo_I, clarify)
apply (rule_tac x = "above i xa" in above_decreases_lemma)
apply (simp_all (no_asm_use) add: Highest_iff_above0)
apply blast+
done

(** Just a massage of conditions to have the desired form ***)
lemma Maximal_eq_Maximal': "Maximal = Maximal'"
by (unfold Maximal_def Maximal'_def Highest_def, blast)

lemma Acyclic_subset:
   "x\<noteq>{} ==>
    Acyclic Int {s. above i s = x} <=
    (\<Union>j. {s. above i s = x} Int {s. j \<in> above i s} Int Highest j)"
apply (rule_tac B = "Maximal' Int {s. above i s = x}" in subset_trans)
apply (simp (no_asm) add: Maximal_eq_Maximal' [symmetric])
apply (blast intro: Acyclic_subset_Maximal [THEN subsetD])
apply (simp (no_asm) del: above_def add: Maximal'_def Highest_iff_above0)
apply blast
done

lemmas above_decreases' = leadsTo_weaken_L [OF above_decreases Acyclic_subset]
lemmas above_decreases_psp = psp_stable [OF above_decreases' Acyclic_stable]

lemma above_decreases_psp':
"x\<noteq>{}==> system \<in> Acyclic Int {s. above i s = x} leadsTo
                   Acyclic Int {s. above i s < x}"
by (erule above_decreases_psp [THEN leadsTo_weaken], blast, auto)

lemmas finite_psubset_induct = wf_finite_psubset [THEN leadsTo_wf_induct]

lemma Progress: "system \<in> Acyclic leadsTo Highest i"
apply (rule_tac f = "%s. above i s" in finite_psubset_induct)
apply (simp del: above_def
            add: Highest_iff_above0 vimage_def finite_psubset_def, clarify)
apply (case_tac "m={}")
apply (rule Int_lower2 [THEN [2] leadsTo_weaken_L])
apply (force simp add: leadsTo_refl)
apply (rule_tac A' = "Acyclic Int {x. above i x < m}" in leadsTo_weaken_R)
apply (blast intro: above_decreases_psp')+
done

text{*We have proved all (relevant) theorems given in the paper.  We didn't
assume any thing about the relation @{term r}.  It is not necessary that
@{term r} be a priority relation as assumed in the original proof.  It
suffices that we start from a state which is finite and acyclic.*}

end


(* VDM to Isabelle Translation @2021-12-17T14:01:51.179804Z
   Copyright 2021, Leo Freitas, leo.freitas@newcastle.ac.uk

in 'TestV2IExprsComplexMaps' (./src/test/resources/TestV2IExprsComplexMaps.vdmsl) at line 6:5
files = [./src/test/resources/TestV2IExprsComplexMaps.vdmsl]
*)
theory TestV2IExprsComplexMaps_PO
imports TestV2IExprsComplexMaps
begin

\<comment>\<open>VDM source: R = ?\<close>
\<comment>\<open>in 'TestV2IExprsComplexMaps' (./src/test/resources/TestV2IExprsComplexMaps.vdmsl) at line 6:5\<close>
theorem R_INV_SATISFIABILITY:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<exists> (r :: R)  . (((
		(((inv_VDMNat (x\<^sub>R r))) \<and>
		 ((inv_VDMNat (y\<^sub>R r)))
		))) \<longrightarrow> ((x\<^sub>R (r)) < (y\<^sub>R (r))))))"

	oops

\<comment>\<open>VDM source: f = ?\<close>
\<comment>\<open>in 'TestV2IExprsComplexMaps' (./src/test/resources/TestV2IExprsComplexMaps.vdmsl) at line 14:39\<close>
theorem f_NON_ZERO:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (x :: VDMNat)  (y :: VDMNat)  . ((((inv_VDMNat x))) \<and>  (((inv_VDMNat y))) \<longrightarrow> ((\<not> (y = (0::VDMNat))) \<longrightarrow> (y \<noteq> (0::VDMNat))))))"

	oops

\<comment>\<open>VDM source: v5 = ?\<close>
\<comment>\<open>in 'TestV2IExprsComplexMaps' (./src/test/resources/TestV2IExprsComplexMaps.vdmsl) at line 24:12\<close>
theorem v5_SUB_TYPE:
	"((\<forall> x \<in> {(1::VDMNat1), (2::VDMNat1), (3::VDMNat1)}  . (\<forall> y \<in> {(4::VDMNat1), (5::VDMNat1), (6::VDMNat1)}  . ((x < y) \<longrightarrow> (inv_R \<lparr>x\<^sub>R = x, y\<^sub>R = y\<rparr>)))))"

	oops

\<comment>\<open>VDM source: v6 = ?\<close>
\<comment>\<open>in 'TestV2IExprsComplexMaps' (./src/test/resources/TestV2IExprsComplexMaps.vdmsl) at line 27:25\<close>
theorem v6_SUB_TYPE:
	"((\<forall> x \<in> {(1::VDMNat1), (2::VDMNat1), (3::VDMNat1)}  . (\<forall> y \<in> {(4::VDMNat1), (5::VDMNat1), (6::VDMNat1)}  . (inv_R \<lparr>x\<^sub>R = x, y\<^sub>R = y\<rparr>))))"

	oops

\<comment>\<open>Processing VDM exports as Isabelle hidden declarations\<close>
hide_const "f"
hide_const "v6"
hide_const "R"
hide_const "v5"

end


(******************************************************************************)
(* Project: Isabelle/UTP: Unifying Theories of Programming in Isabelle/HOL    *)
(* File: UNIV_TYPE.thy                                                        *)
(* Author: Frank Zeyda, University of York (UK)                               *)
(******************************************************************************)
(* LAST REVIEWED: 27 March 2014 *)

section \<open>Type Universe\<close>

theory UNIV_TYPE
imports Main
begin

definition UNIV_TYPE :: "'a itself \<Rightarrow> 'a set" where
"UNIV_TYPE (t :: 'a itself) = (UNIV :: 'a set)"

(* declare UNIV_TYPE_def [simp] *)

syntax
  "_UNIV_TYPE" :: "type => logic"  ("(1UNIV'_T/(1'(_')))")

translations
  "UNIV_T('t)" \<rightleftharpoons> "(CONST UNIV_TYPE) TYPE('t)"

theorem "0 \<in> UNIV_T(int)"
apply (simp add: UNIV_TYPE_def)
done

theorem "\<forall>x. x \<in> UNIV_T('a)"
apply (simp add: UNIV_TYPE_def)
done

theorem "UNIV_T('a) = UNIV"
apply (simp add: UNIV_TYPE_def)
done
end


theory prop_27
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  fun qrev :: "'a list => 'a list => 'a list" where
  "qrev (Nil2) y = y"
  | "qrev (Cons2 z xs) y = qrev xs (Cons2 z y)"
  fun append :: "'a list => 'a list => 'a list" where
  "append (Nil2) y = y"
  | "append (Cons2 z xs) y = Cons2 z (append xs y)"
  fun rev :: "'a list => 'a list" where
  "rev (Nil2) = Nil2"
  | "rev (Cons2 y xs) = append (rev xs) (Cons2 y (Nil2))"
  (*hipster qrev append rev *)

(*hipster qrev append rev*)
lemma lemma_a [thy_expl]: "append x2 Nil2 = x2"
by (hipster_induct_schemes qrev.simps append.simps rev.simps)

lemma lemma_aa [thy_expl]: "append (append x1 y1) z1 = append x1 (append y1 z1)"
by (hipster_induct_schemes qrev.simps append.simps rev.simps)

lemma lemma_ab [thy_expl]: "append (qrev x1 y1) z1 = qrev x1 (append y1 z1)"
by (hipster_induct_schemes qrev.simps append.simps rev.simps)

lemma lemma_ac [thy_expl]: "qrev (append x1 y1) z1 = qrev y1 (qrev x1 z1)"
by (hipster_induct_schemes qrev.simps append.simps rev.simps)

lemma lemma_ad [thy_expl]: "qrev (qrev x1 y1) z1 = qrev y1 (append x1 z1)"
by (hipster_induct_schemes qrev.simps append.simps rev.simps)

lemma lemma_ae [thy_expl]: "append (rev x3) y3 = qrev x3 y3"
by (hipster_induct_schemes qrev.simps append.simps rev.simps)

  theorem x0 :
    "(rev x) = (qrev x (Nil2))"
    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)
end


theory Fiber_bundles
  imports Chart
     "HOL-Analysis.Equivalence_Lebesgue_Henstock_Integration"
    "HOL-Library.Function_Algebras"
    "HOL-Types_To_Sets.Linear_Algebra_On"
begin

(* There seems to not be a definition of open map for the generic topology library... *)
definition "is_open_map_on U f \<equiv> \<forall> S. open S \<longrightarrow> open (f ` (S \<inter> U))"

lemma continuous_on_eq_continuous_at': "open s \<Longrightarrow> continuous_on s f \<longleftrightarrow> (\<forall>x\<in>s. continuous (at x) f)"
  by (simp add: continuous_on_def continuous_at at_within_open[of _ s])

(* 'a and 'b need to be t2 because the topology library is not general enough... *)

locale fiber_bundle =
  fixes \<pi> :: "('a :: t2_space) \<Rightarrow> ('b :: t2_space)" and
    local_triv :: "('a \<Rightarrow> 'b \<times> ('c :: t2_space)) set" and inverse base_set
  assumes open_base_set: "\<forall> f \<in> local_triv. open (base_set f)" (* can I prove this? *)
  and open_dom: "\<forall> f \<in> local_triv. open (\<pi> -` base_set f)"
  and locally_trivial: "\<forall> f \<in> local_triv.
    homeomorphism (\<pi> -` (base_set f)) (base_set f \<times> UNIV) f (inverse f)"
  and commuting_diagram': "\<forall> f \<in> local_triv. \<forall> x \<in>  \<pi> -` (base_set f). fst (f x) = \<pi> x"
begin

definition "carrier_base_space = (\<Union>(base_set ` local_triv))"

definition "carrier_total_space = \<pi> -` carrier_base_space"

definition "domn f = \<pi> -` base_set f"

definition "codomn f =  base_set f \<times> (UNIV :: 'c set)"

lemma commuting_diagram: "\<forall> f \<in> local_triv. \<forall> x \<in> domn f. fst (f x) = \<pi> x"
  by (simp add: commuting_diagram' domn_def)

lemma carrier_total_space_eq_un_domn: "carrier_total_space = (\<Union>f \<in> local_triv. domn f)"
  using carrier_base_space_def carrier_total_space_def domn_def by auto

lemma open_codomn: assumes "f \<in> local_triv"
  shows "open (codomn f)"
  by (metis assms codomn_def open_base_set open_vimage_fst vimage_fst)

lemma codomn_image_domn: assumes "f \<in> local_triv"
  shows "codomn f = f ` domn f"
  by (metis assms codomn_def domn_def homeomorphism_image1 locally_trivial)

lemma domain_local_triv: assumes "f \<in> local_triv"
  shows "homeomorphism (domn f) (codomn f) f (inverse f)"
  by (simp add: assms codomn_def domn_def locally_trivial)

lemma dom_preimage_codomn: assumes "f \<in> local_triv"
    shows "domn f = f -` codomn f"
proof
  show "domn f \<subseteq> f -` codomn f"
    using codomn_image_domn assms by auto
next
  show "f -` codomn f \<subseteq> domn f" (* Need to use that f is bijective on domn f*)
    using codomn_def assms locally_trivial domn_def
    sorry
qed

lemma open_carrier_base_space: "open carrier_base_space"
  by (simp add: carrier_base_space_def open_UN open_base_set)

lemma open_domn: assumes "f \<in> local_triv"
  shows "open (domn f)"
  by (simp add: assms domn_def open_dom)

lemma open_carrier_total_space: "open carrier_total_space"
  by (simp add: carrier_base_space_def carrier_total_space_def open_UN open_dom vimage_UN)

lemma continuous_on_proj: "continuous_on carrier_total_space \<pi>"
proof -
  have "\<forall> x \<in> carrier_total_space. \<exists> f \<in> local_triv. continuous (at x) f"
    by (smt (verit, del_insts) UnionE at_within_open carrier_base_space_def carrier_total_space_def
        continuous_on_eq_continuous_within homeomorphism_cont1 imageE locally_trivial open_dom
        vimageE vimageI)
  also have "\<forall> x \<in> carrier_total_space. continuous (at x) \<pi>"
  proof
    fix x assume "x \<in> carrier_total_space"
    have "\<exists> f \<in> local_triv. x \<in> domn f"
      using \<open>x \<in> carrier_total_space\<close> carrier_base_space_def carrier_total_space_def domn_def
      by auto
    then obtain f where mem_f: "f \<in> local_triv" and mem_x: "x \<in> domn f" by blast
    also have "continuous (at x) f"
      by (metis at_within_open continuous_on_eq_continuous_within domain_local_triv
          homeomorphism_cont1 mem_f mem_x open_domn)
    then have "continuous (at x) (\<lambda> x. fst (f x))"
      by (simp add: \<open>isCont f x\<close>)
    then have "eventually (\<lambda>x. fst (f x) = \<pi> x) (nhds x)" using commuting_diagram
      by (metis (mono_tags, lifting) eventually_nhds mem_f mem_x open_domn)
    then show "continuous (at x) \<pi>" using isCont_cong
    proof -
      show ?thesis
        using \<open>\<forall>\<^sub>F x in nhds x. fst (f x) = \<pi> x\<close> \<open>isCont (\<lambda>x. fst (f x)) x\<close> isCont_cong by force
    qed
  qed
  then show ?thesis
    by (simp add: continuous_at_imp_continuous_on)
qed

lemma is_open_proj: "is_open_map_on carrier_total_space \<pi>"
  sorry

end

lemma trivial_bunlde_is_fiber_bundle: "fiber_bundle fst {id} id (\<lambda> f. UNIV)"
proof
  show "\<forall>f\<in>{id}. open UNIV" by auto
next
  show "\<forall>f\<in>{id}. open (fst -` UNIV)" by auto
next
  show "\<forall>f\<in>{id}. homeomorphism (fst -` UNIV) (UNIV \<times> UNIV) f (id f)"
  by (metis UNIV_Times_UNIV eq_id_iff homeomorphism_ident singletonD vimage_UNIV)
next
  show "\<forall>f\<in>{id}. \<forall>x\<in>fst -` UNIV. fst (f x) = fst x"
   by auto
qed

locale fiber_bundle' =
  fixes \<pi> :: "('a :: topological_space) \<Rightarrow> ('b :: topological_space)" and
    local_triv :: "('a, 'b \<times> ('c :: topological_space)) chart set"
  assumes dom: "\<forall> f \<in> local_triv. domain f = \<pi> -` (fst ` codomain f)"
  and codom: "\<forall> f \<in> local_triv. codomain f = (fst ` codomain f) \<times> UNIV"
  and commuting_diagram: "\<forall> f \<in> local_triv. \<forall> x \<in> domain f. fst (f x) = \<pi> x"
begin

definition "carrier_total_space = \<Union>(domain ` local_triv)"

definition "carrier_base_space = fst ` (\<Union>(codomain ` local_triv))"

definition "base_set f = fst ` codomain f"

lemma domain_local_triv: assumes "f \<in> local_triv"
  shows "domain f = \<pi> -` base_set f"
  using dom assms
  by (simp add: base_set_def)

lemma "carrier_total_space = \<pi> -` (\<Union>(base_set ` local_triv))"
  using carrier_total_space_def domain_local_triv by auto

lemma "carrier_base_space = \<Union>(base_set ` local_triv)"
  using base_set_def carrier_base_space_def
  by (smt (verit, best) Inf.INF_cong image_UN)

lemma "carrier_total_space = \<pi> -` carrier_base_space"
  using carrier_base_space_def carrier_total_space_def dom
  by auto

end

lift_definition trivial_trivialization :: "(('a:: topological_space) \<times> ('b :: topological_space), 'a \<times> 'b) chart" is
"(UNIV:: ('a \<times> 'b) set, UNIV:: ('a \<times> 'b) set, id:: ('a \<times> 'b) \<Rightarrow> ('a \<times> 'b), id:: ('a \<times> 'b) \<Rightarrow> ('a \<times> 'b))"
  by (metis (no_types, lifting) case_prodI eq_id_iff homeomorphism_ident mem_Collect_eq open_UNIV)

lemma trivial_bunlde_is_fiber_bundle' : "fiber_bundle' fst {trivial_trivialization}"
proof
  show "\<forall>f\<in>{trivial_trivialization}. domain f = fst -` fst ` codomain f"
    using domain_def codomain_def trivial_trivialization_def
  sorry
next
  show " \<forall>f\<in>{trivial_trivialization}. codomain f = fst ` codomain f \<times> UNIV"
    using codomain_def
    sorry
next
  show "\<forall>f\<in>{trivial_trivialization}. \<forall>x\<in>domain f. fst (apply_chart f x) = fst x"
    sorry
qed

end


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

value "intersperse 0 [(Suc 0), (Suc 0), (Suc 0)]"

lemma "map f (intersperse a xs) = intersperse (f a) (map f xs)"
  apply(induction xs rule: intersperse.induct)
  apply(auto)
  done


theory Refinement
  imports StoreHeapModel
begin

text {* Morgan Refinement Laws *}

named_theorems ref_simps

definition spec :: "'a pred \<Rightarrow> 'a pred \<Rightarrow> 'a ptran"  where
  "spec p q \<equiv> Inf {F. p \<le> F q \<and> mono F}"

lemma spec_ht [ref_simps]: "ht p (spec p q) q"
  by (auto simp: ht_def spec_def)

lemma spec_char [ref_simps]: "p \<le> (spec p q) q"
  by (auto simp: ht_def spec_def)

lemma specI: "mono F \<Longrightarrow> ht p F q \<Longrightarrow> spec p q \<le> F"
  by (auto simp: ht_def spec_def intro: Inf_lower)

lemma ht_spec_eq: "mono F \<Longrightarrow> ht p F q \<longleftrightarrow> spec p q \<le> F"
proof (auto intro: specI, simp add: ht_def)
  assume assm: "spec p q \<le> F"
  have "p \<le> (spec p q) q"
    by (rule spec_char)
  also have "... \<le> F q" using assm
    by (auto simp: le_fun_def)
  finally show "p \<le> F q"
    by simp
qed

lemma spec_mono [mptran]: "mono (spec p q)"
  by (auto simp: spec_def intro: mptran)

(***********************************************************************************************)

text {* Morgan's refinement laws *}

named_theorems rlaw

lemma strengthen_post [rlaw]: "q' \<le> q \<Longrightarrow> spec p q \<le> spec p q'"
  by (meson hl_post ht_def specI spec_char spec_mono)

lemma weaken_pre [rlaw]: "p \<le> p' \<Longrightarrow> spec p q \<le> spec p' q"
  by (meson dual_order.trans ht_def specI spec_char spec_mono)

lemma weaken_and_strengthen [rlaw]: "p \<le> p' \<Longrightarrow> q' \<le> q \<Longrightarrow> spec p q \<le> spec p' q'"
  by (meson dual_order.trans strengthen_post weaken_pre)

lemma skip_ref: "spec true true \<le> skip"
  by (auto simp: skip_def spec_def mono_def intro!: Inf_lower)

lemma abort_ref [rlaw]: "spec false true \<le> F"
  by (metis (no_types, hide_lams) bot.extremum bot_apply dual_order.trans ht_def ht_spec_eq mono_def)

lemma magic_ref [rlaw]: "F \<le> spec true false"
  by (metis (no_types, hide_lams) antisym_conv bot.extremum ht_def ht_spec_eq le_fun_def spec_mono strengthen_post top_greatest)

lemma skip_ref_var1: "spec p true \<le> skip"
  by (simp add: hl_skip mono_skip specI)

lemma skip_ref_var2 [rlaw]: "p \<le> q \<Longrightarrow> spec p q \<le> skip"
  using hl_skip ht_spec_eq mono_skip by blast

lemma sequence_ref [rlaw]: "spec p q \<le> (spec p r); (spec r q)"
  using hl_seq mono_seq specI spec_ht spec_mono by blast

lemma following_ref: "mono y \<Longrightarrow> x \<le> y ; z \<Longrightarrow> z \<le> w \<Longrightarrow> x \<le> y ; w"
proof -
  assume m: "mono y" and zw: "z \<le> w" and "x \<le> y ; z"
  hence "x \<le> y ; z"
    by simp
  also have "... \<le> y ; w"
    apply (simp add: seq_def)
    apply (rule le_funI)
    apply simp
    apply (rule monoD, rule m)
    using zw by (auto simp: le_fun_def)
  finally show ?thesis
    by simp
qed

lemma leading_ref: "x \<le> y ; w \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z ; w"
proof -
  assume zw: "y \<le> z" and "x \<le> y ; w"
  hence "x \<le> y ; w"
    by simp
  also have "... \<le> z ; w"
    using zw by (auto simp: seq_def le_fun_def)
  finally show ?thesis
    by simp
qed

lemma leading_ref' [rlaw]: "spec p r \<le> F \<Longrightarrow> spec p q \<le> F; spec r q"
  apply (rule leading_ref[rotated])
  apply assumption
  apply (rule sequence_ref)
done

lemma mono_law [rlaw]: "mono x \<Longrightarrow> y \<le> z \<Longrightarrow> x ; y \<le> x ; z"
  apply (auto simp: seq_def)
  by (metis following_ref order_refl seq_def)

lemma choice_ref [rlaw]: "spec p q \<le> x \<Longrightarrow> spec p q \<le> y \<Longrightarrow> spec p q \<le> x \<sqinter> y"
  by simp

lemma test_expl_ref [rlaw]: "spec p q \<le>  \<lfloor>b\<rfloor>; (spec (p \<sqinter> b) q)"
  by (metis hl_asumption ht_def inf_commute mono_assumption mono_seq seq_def specI spec_char spec_mono)

lemma test_expr_ref [rlaw]: "spec p (q \<sqinter> b) \<le> (spec p q); \<lfloor>b\<rfloor>"
  by (metis Assertions.bbi.join_meet_galois Sup.order_refl assumption_def hl_seq ht_def inf_commute mono_assumption mono_seq specI spec_char spec_mono)

lemma conditional_ref [rlaw]: "spec p q \<le> cond b (spec (p \<sqinter> b) q) (spec (p \<sqinter> -b) q)"
  by (metis hl_cond ht_def inf_commute mono_cond specI spec_char spec_mono)

lemma while_ref [rlaw]: "spec p (p \<sqinter> -b) \<le> cwhile b (spec (p \<sqinter> b) p)"
  by (metis hl_while ht_def inf_commute mono_while specI spec_char spec_mono)

lemma iso_while_spec: "mono (\<lambda>p. cwhile b (spec p i))"
proof (auto simp: mono_def)
  fix x y :: "'a pred" assume "x \<le> y"
  moreover have "mono (spec x i)"
    by (simp add: spec_mono)
  moreover have "(spec x i) \<le> (spec y i)"
    by (meson calculation(1) hl_pre specI spec_ht spec_mono)
  ultimately show "cwhile b (spec x i) \<le> cwhile b (spec y i)"
    by (auto intro!: iso_while)
qed

lemma while_ref_tactic [rlaw]: "\<lbrakk>i \<sqinter> b \<le> p'; p \<le> i; i - b \<le> q\<rbrakk> \<Longrightarrow> spec p q \<le> cwhile b (spec p' i)"
proof -
  assume "p \<le> i" "i - b \<le> q" and assm: "i \<sqinter> b \<le> p'"
  hence "spec p q \<le> spec i (i \<sqinter> -b)"
    by (metis diff_eq weaken_and_strengthen)
  also have "... \<le> cwhile b (spec (i \<sqinter> b) i)"
    by (simp add: while_ref)
  also have "... \<le> cwhile b (spec p' i)"
    using assm by (auto intro!: monoD iso_while_spec)
  finally show ?thesis
    by simp
qed

lemma exs_ref [rlaw]: "mono R \<Longrightarrow> (\<And>x. spec (P x) (Q x) \<le> R) \<Longrightarrow> spec (EXS x. P x) (EXS y. Q y) \<le> R"
  by (auto simp: ht_spec_eq[symmetric] intro: hl_exs2)

(***********************************************************************************************)

text {* Framing laws *}

lemma frame_ref [rlaw]: "mono x \<Longrightarrow> local x r \<Longrightarrow> spec p q \<le> x \<Longrightarrow> spec (p * r) (q * r) \<le> x"
  using ht_spec_eq sl_frame by blast

lemma frame_ref2 [rlaw]: "mono x \<Longrightarrow> local x r \<Longrightarrow> spec p q \<le> x \<Longrightarrow> spec (r * p) (r * q) \<le> x"
  by (simp add: frame_ref sep_comm)

(***********************************************************************************************)

text {* Assignment and mutation laws *}

lemma assignment_ref [rlaw]: "p \<subseteq> subst_pred q v m \<Longrightarrow> spec p q \<le> assign v m"
  by (auto simp: subst_pred_def assign_def spec_def basic_def valid_mem_def intro!: Inf_lower mptran)

lemma following_assignment_ref [rlaw]: "q' \<subseteq> subst_pred q v m \<Longrightarrow> spec p q \<le> spec p q'; assign v m"
  by (auto intro: following_ref mptran rlaw)

lemma leading_assignment_ref [rlaw]: "p \<subseteq> subst_pred p' v m \<Longrightarrow> spec p q \<le> assign v m; spec p' q"
  by (auto intro: leading_ref rlaw)

lemma lookup_ref [rlaw]: "\<forall>s x. k (k_update (\<lambda>_. x) s) = x \<Longrightarrow>
            \<forall>s x. i (k_update (\<lambda>_. x) s) = i s \<Longrightarrow>
            \<forall>x. subst_pred (R k) k_update (\<lambda>_. x) = R (\<lambda>_. x) \<Longrightarrow>
            spec (EXS x. (i \<mapsto> (\<lambda>_. x)) * R (\<lambda>_. x)) ((i \<mapsto> k) * R k) \<le> lookup k_update i"
   apply (rule specI)
   apply (rule mptran)+
   apply (rule hl_pre[rotated])
   apply (rule sl_lookup_alt')
   apply (rule mono_exs)
   apply sep_simp
   apply simp
   apply (metis (no_types, lifting) bbi.Sup.qisol bbi.mult.left_commute top_greatest)
done

lemma lookup_suc_ref [rlaw]: "\<forall>s x. k (k_update (\<lambda>_. x) s) = x \<Longrightarrow>
            \<forall>s x. i (k_update (\<lambda>_. x) s) = i s \<Longrightarrow>
            \<forall>x. subst_pred (R k) k_update (\<lambda>_. x) = R (\<lambda>_. x) \<Longrightarrow>
            spec (EXS x. (i \<mapsto> (\<lambda>_. a), (\<lambda>_. x)) * R (\<lambda>_. x)) ((i \<mapsto> (\<lambda>_. a), k) * R k) \<le> lookup k_update (\<lambda>s. i s + 1)"
   apply (rule specI)
   apply (rule mptran)+
   apply (rule hl_pre[rotated])
   apply (rule sl_lookup_alt')
   apply (rule mono_exs)
   apply sep_simp
   apply simp
   apply (metis (no_types, lifting) bbi.Sup.qisol bbi.mult.left_commute top_greatest)
done

lemma alloc_ref [rlaw]: "free x_upd e \<Longrightarrow> vars1 x_upd x \<Longrightarrow> spec emp (x \<mapsto> e) \<le> alloc x_upd e"
  by (auto intro: specI mptran sl)

lemma disposal_ref [rlaw]: "spec ((e \<mapsto> n) * r) r \<le> disposal e"
  by (simp add: mono_disposal sl_disposal_alt specI)

lemma mutation_ref [rlaw]: "spec ((e \<mapsto> n) * r) ((e \<mapsto> e') * r) \<le> mutation e e'"
  by (auto intro: specI mptran sl)

lemma mutation_suc_ref [rlaw]: "spec ((i \<mapsto> a, b) * r) ((i \<mapsto> a, e) * r) \<le> mutation (\<lambda>s. i s + 1) e"
  by (auto simp: doublet_def sep_assoc intro: frame_ref2 mptran lptran specI sl)

(***********************************************************************************************)

text {* \emph{morgan} tactic *}

method morgan_step uses simp ref =
  (assumption | subst sep_assoc | subst seq_assoc | rule iso_while | rule ref rlaw mptran)

method morgan uses simp ref =
  (morgan_step simp: simp ref: ref; (morgan simp: simp ref: ref)?)+

end


theory ASC_Example
  imports ASC_Hoare
begin

section {* Example product machines and properties *}

text \<open>
This section provides example FSMs and shows that the assumptions on the inputs of the adaptive
state counting algorithm are not vacuous.
\<close>

subsection {* Constructing FSMs from transition relations *}

text \<open>
This subsection provides a function to more easily create FSMs, only requiring a set of
transition-tuples and an initial state instead of, in particular, the explicit successor function.
\<close>

fun from_rel :: "('state \<times> ('in \<times> 'out) \<times> 'state) set \<Rightarrow> 'state \<Rightarrow> ('in, 'out, 'state) FSM" where
"from_rel rel q0 = \<lparr> succ = \<lambda> io p . { q . (p,io,q) \<in> rel },
                    inputs = image (fst \<circ> fst \<circ> snd) rel,
                    outputs = image (snd \<circ> fst \<circ> snd) rel,
                    initial = q0 \<rparr>"

lemma nodes_from_rel : "nodes (from_rel rel q0) \<subseteq> insert q0 (image (snd \<circ> snd) rel)"
  (is "nodes ?M \<subseteq> insert q0 (image (snd \<circ> snd) rel)")
proof -
  have "\<And> q io p . q \<in> succ ?M io p \<Longrightarrow> q \<in> image (snd \<circ> snd) rel"
    by force
  have "\<And> q . q \<in> nodes ?M \<Longrightarrow> q = q0 \<or> q \<in> image (snd \<circ> snd) rel"
  proof -
    fix q assume "q \<in> nodes ?M"
    then show "q = q0 \<or> q \<in> image (snd \<circ> snd) rel"
    proof (cases rule: FSM.nodes.cases)
      case initial
      then show ?thesis by auto
    next
      case (execute p a)
      then show ?thesis
        using \<open>\<And> q io p . q \<in> succ ?M io p \<Longrightarrow> q \<in> image (snd \<circ> snd) rel\<close> by blast
    qed
  qed
  then show "nodes ?M \<subseteq> insert q0 (image (snd \<circ> snd) rel)"
    by blast
qed

fun well_formed_rel :: "('state \<times> ('in \<times> 'out) \<times> 'state) set \<Rightarrow> bool" where
  "well_formed_rel rel = (finite rel
                          \<and> (\<forall> s1 x y . (x \<notin> image (fst \<circ> fst \<circ> snd) rel
                                            \<or> y \<notin> image (snd \<circ> fst \<circ> snd) rel)
                                        \<longrightarrow> \<not>(\<exists> s2 . (s1,(x,y),s2) \<in> rel))
                          \<and> rel \<noteq> {})"

lemma well_formed_from_rel :
  assumes "well_formed_rel rel"
  shows "well_formed (from_rel rel q0)"  (is "well_formed ?M")
proof -
  have "nodes ?M \<subseteq> insert q0 (image (snd \<circ> snd) rel)"
    using nodes_from_rel[of rel q0] by auto
  moreover have "finite (insert q0 (image (snd \<circ> snd) rel))"
    using assms by auto
  ultimately have "finite (nodes ?M)"
    by (simp add: Finite_Set.finite_subset)
  moreover have "finite (inputs ?M)" "finite (outputs ?M)"
    using assms by auto
  ultimately have "finite_FSM ?M"
    by auto

  moreover have "inputs ?M \<noteq> {}"
    using assms by auto
  moreover have "outputs ?M \<noteq> {}"
    using assms by auto
  moreover have "\<And> s1 x y . (x \<notin> inputs ?M \<or> y \<notin> outputs ?M) \<longrightarrow> succ ?M (x,y) s1 = {}"
    using assms by auto

  ultimately show ?thesis
    by auto
qed

fun completely_specified_rel_over :: "('state \<times> ('in \<times> 'out) \<times> 'state) set \<Rightarrow> 'state set \<Rightarrow> bool"
  where
  "completely_specified_rel_over rel nods = (\<forall> s1 \<in> nods .
                                                \<forall> x \<in> image (fst \<circ> fst \<circ> snd) rel .
                                                  \<exists> y \<in> image (snd \<circ> fst \<circ> snd) rel .
                                                    \<exists> s2 . (s1,(x,y),s2) \<in> rel)"

lemma completely_specified_from_rel :
  assumes "completely_specified_rel_over rel (nodes ((from_rel rel q0)))"
  shows "completely_specified (from_rel rel q0)"  (is "completely_specified ?M")
  unfolding completely_specified.simps
proof
  fix s1 assume "s1 \<in> nodes (from_rel rel q0)"
  show  "\<forall>x\<in>inputs ?M. \<exists>y\<in>outputs ?M. \<exists>s2. s2 \<in> succ ?M (x, y) s1"
  proof
    fix x assume "x \<in> inputs (from_rel rel q0)"
    then have "x \<in>  image (fst \<circ> fst \<circ> snd) rel"
      using assms by auto

    obtain y s2 where "y \<in> image (snd \<circ> fst \<circ> snd) rel" "(s1,(x,y),s2) \<in> rel"
      using assms \<open>s1 \<in> nodes (from_rel rel q0)\<close> \<open>x \<in>  image (fst \<circ> fst \<circ> snd) rel\<close>
      by (meson completely_specified_rel_over.elims(2))

    then have "y \<in> outputs (from_rel rel q0)" "s2 \<in> succ (from_rel rel q0) (x, y) s1"
      by auto

    then show "\<exists>y\<in>outputs (from_rel rel q0). \<exists>s2. s2 \<in> succ (from_rel rel q0) (x, y) s1"
      by blast
  qed
qed

fun observable_rel :: "('state \<times> ('in \<times> 'out) \<times> 'state) set \<Rightarrow> bool" where
  "observable_rel rel = (\<forall> io s1 . { s2 . (s1,io,s2) \<in> rel } = {}
                                    \<or> (\<exists> s2 . { s2' . (s1,io,s2') \<in> rel } = {s2}))"

lemma observable_from_rel :
  assumes "observable_rel rel"
  shows "observable (from_rel rel q0)"  (is "observable ?M")
proof -
  have "\<And> io s1 . { s2 . (s1,io,s2) \<in> rel } = succ ?M io s1"
    by auto
  then show ?thesis using assms by auto
qed

abbreviation "OFSM_rel rel q0 \<equiv> well_formed_rel rel
                                \<and> completely_specified_rel_over rel (nodes (from_rel rel q0))
                                \<and> observable_rel rel"

lemma OFMS_from_rel :
  assumes "OFSM_rel rel q0"
  shows "OFSM (from_rel rel q0)"
  by (metis assms completely_specified_from_rel observable_from_rel well_formed_from_rel)

subsection {* Example FSMs and properties *}

abbreviation "M\<^sub>S_rel :: (nat\<times>(nat\<times>nat)\<times>nat) set \<equiv> {(0,(0,0),1), (0,(0,1),1), (1,(0,2),1)}"
abbreviation "M\<^sub>S :: (nat,nat,nat) FSM \<equiv> from_rel M\<^sub>S_rel 0"

abbreviation "M\<^sub>I_rel :: (nat\<times>(nat\<times>nat)\<times>nat) set \<equiv> {(0,(0,0),1), (0,(0,1),1), (1,(0,2),0)}"
abbreviation "M\<^sub>I :: (nat,nat,nat) FSM \<equiv> from_rel M\<^sub>I_rel 0"

lemma example_nodes :
  "nodes M\<^sub>S = {0,1}" "nodes M\<^sub>I = {0,1}"
proof -
  have "0 \<in> nodes M\<^sub>S" by auto
  have "1 \<in> succ M\<^sub>S (0,0) 0" by auto
  have "1 \<in> nodes M\<^sub>S"
    by (meson \<open>0 \<in> nodes M\<^sub>S\<close> \<open>1 \<in> succ M\<^sub>S (0, 0) 0\<close> succ_nodes)

  have "{0,1} \<subseteq> nodes M\<^sub>S"
    using \<open>0 \<in> nodes M\<^sub>S\<close> \<open>1 \<in> nodes M\<^sub>S\<close> by auto
  moreover have "nodes M\<^sub>S \<subseteq> {0,1}"
    using nodes_from_rel[of M\<^sub>S_rel 0] by auto
  ultimately show "nodes M\<^sub>S = {0,1}"
    by blast
next
  have "0 \<in> nodes M\<^sub>I" by auto
  have "1 \<in> succ M\<^sub>I (0,0) 0" by auto
  have "1 \<in> nodes M\<^sub>I"
    by (meson \<open>0 \<in> nodes M\<^sub>I\<close> \<open>1 \<in> succ M\<^sub>I (0, 0) 0\<close> succ_nodes)

  have "{0,1} \<subseteq> nodes M\<^sub>I"
    using \<open>0 \<in> nodes M\<^sub>I\<close> \<open>1 \<in> nodes M\<^sub>I\<close> by auto
  moreover have "nodes M\<^sub>I \<subseteq> {0,1}"
    using nodes_from_rel[of M\<^sub>I_rel 0] by auto
  ultimately show "nodes M\<^sub>I = {0,1}"
    by blast
qed

lemma example_OFSM :
  "OFSM M\<^sub>S" "OFSM M\<^sub>I"
proof -
  have "well_formed_rel M\<^sub>S_rel"
    unfolding well_formed_rel.simps by auto

  moreover have "completely_specified_rel_over M\<^sub>S_rel (nodes (from_rel M\<^sub>S_rel 0))"
    unfolding completely_specified_rel_over.simps
  proof
    fix s1 assume "(s1::nat) \<in> nodes (from_rel M\<^sub>S_rel 0)"
    then have "s1 \<in> (insert 0 (image (snd \<circ> snd) M\<^sub>S_rel))"
      using nodes_from_rel[of M\<^sub>S_rel 0] by blast
    moreover have "completely_specified_rel_over M\<^sub>S_rel (insert 0 (image (snd \<circ> snd) M\<^sub>S_rel))"
      unfolding completely_specified_rel_over.simps by auto
    ultimately show "\<forall>x\<in>(fst \<circ> fst \<circ> snd) ` M\<^sub>S_rel.
                      \<exists>y\<in>(snd \<circ> fst \<circ> snd) ` M\<^sub>S_rel. \<exists>s2. (s1, (x, y), s2) \<in> M\<^sub>S_rel"
      by simp
  qed

  moreover have "observable_rel M\<^sub>S_rel"
    by auto

  ultimately have "OFSM_rel M\<^sub>S_rel 0"
    by auto

  then show "OFSM M\<^sub>S"
    using OFMS_from_rel[of M\<^sub>S_rel 0] by linarith
next
  have "well_formed_rel M\<^sub>I_rel"
    unfolding well_formed_rel.simps by auto

  moreover have "completely_specified_rel_over M\<^sub>I_rel (nodes (from_rel M\<^sub>I_rel 0))"
    unfolding completely_specified_rel_over.simps
  proof
    fix s1 assume "(s1::nat) \<in> nodes (from_rel M\<^sub>I_rel 0)"
    then have "s1 \<in> (insert 0 (image (snd \<circ> snd) M\<^sub>I_rel))"
      using nodes_from_rel[of M\<^sub>I_rel 0] by blast
    have "completely_specified_rel_over M\<^sub>I_rel (insert 0 (image (snd \<circ> snd) M\<^sub>I_rel))"
      unfolding completely_specified_rel_over.simps by auto
    show "\<forall>x\<in>(fst \<circ> fst \<circ> snd) ` M\<^sub>I_rel.
            \<exists>y\<in>(snd \<circ> fst \<circ> snd) ` M\<^sub>I_rel. \<exists>s2. (s1, (x, y), s2) \<in> M\<^sub>I_rel"
      by (meson \<open>completely_specified_rel_over M\<^sub>I_rel (insert 0 ((snd \<circ> snd) ` M\<^sub>I_rel))\<close>
          \<open>s1 \<in> insert 0 ((snd \<circ> snd) ` M\<^sub>I_rel)\<close> completely_specified_rel_over.elims(2))
  qed

  moreover have "observable_rel M\<^sub>I_rel"
    by auto

  ultimately have "OFSM_rel M\<^sub>I_rel 0"
    by auto

  then show "OFSM M\<^sub>I"
    using OFMS_from_rel[of M\<^sub>I_rel 0] by linarith
qed

lemma example_fault_domain : "asc_fault_domain M\<^sub>S M\<^sub>I 2"
proof -
  have "inputs M\<^sub>S = inputs M\<^sub>I"
    by auto
  moreover have "card (nodes M\<^sub>I) \<le> 2"
    using example_nodes(2) by auto
  ultimately show "asc_fault_domain M\<^sub>S M\<^sub>I 2"
    by auto
qed

abbreviation "FAIL\<^sub>I :: (nat\<times>nat) \<equiv> (3,3)"
abbreviation "PM\<^sub>I :: (nat, nat, nat\<times>nat) FSM \<equiv> \<lparr>
            succ = (\<lambda> a (p1,p2) . (if (p1 \<in> nodes M\<^sub>S \<and> p2 \<in> nodes M\<^sub>I \<and> (fst a \<in> inputs M\<^sub>S)
                                        \<and> (snd a \<in> outputs M\<^sub>S \<union> outputs M\<^sub>I))
                                    then (if (succ M\<^sub>S a p1 = {} \<and> succ M\<^sub>I a p2 \<noteq> {})
                                      then {FAIL\<^sub>I}
                                      else (succ M\<^sub>S a p1 \<times> succ M\<^sub>I a p2))
                                    else {})),
            inputs = inputs M\<^sub>S,
            outputs = outputs M\<^sub>S \<union> outputs M\<^sub>I,
            initial = (initial M\<^sub>S, initial M\<^sub>I)
          \<rparr>"

lemma example_productF : "productF M\<^sub>S M\<^sub>I FAIL\<^sub>I PM\<^sub>I"
proof -
  have "inputs M\<^sub>S = inputs M\<^sub>I"
    by auto
  moreover have "fst FAIL\<^sub>I \<notin> nodes M\<^sub>S"
    using example_nodes(1) by auto
  moreover have "snd FAIL\<^sub>I \<notin> nodes M\<^sub>I"
    using example_nodes(2) by auto
  ultimately show ?thesis
    unfolding productF.simps by blast
qed

abbreviation "V\<^sub>I :: nat list set \<equiv> {[],[0]}"

lemma example_det_state_cover : "is_det_state_cover M\<^sub>S V\<^sub>I"
proof -
  have "d_reaches M\<^sub>S (initial M\<^sub>S) [] (initial M\<^sub>S)"
    by auto
  then have "initial M\<^sub>S \<in> d_reachable M\<^sub>S (initial M\<^sub>S)"
    unfolding d_reachable.simps by blast

  have "d_reached_by M\<^sub>S (initial M\<^sub>S) [0] 1 [1] [0]"
  proof
    show "length [0] = length [0] \<and>
    length [0] = length [1] \<and> path M\<^sub>S (([0] || [0]) || [1]) (initial M\<^sub>S)
                            \<and> target (([0] || [0]) || [1]) (initial M\<^sub>S) = 1"
      by auto

    have "\<And>ys2 tr2.
       length [0] = length ys2
          \<and> length [0] = length tr2
          \<and> path M\<^sub>S (([0] || ys2) || tr2) (initial M\<^sub>S)
            \<longrightarrow> target (([0] || ys2) || tr2) (initial M\<^sub>S) = 1"
    proof
      fix ys2 tr2 assume "length [0] = length ys2 \<and> length [0] = length tr2
                            \<and> path M\<^sub>S (([0] || ys2) || tr2) (initial M\<^sub>S)"
      then have "length ys2 = 1" "length tr2 = 1" "path M\<^sub>S (([0] || ys2) || tr2) (initial M\<^sub>S)"
        by auto
      moreover obtain y2 where "ys2 = [y2]"
        using \<open>length ys2 = 1\<close>
        by (metis One_nat_def \<open>length [0] = length ys2 \<and> length [0] = length tr2
            \<and> path M\<^sub>S (([0] || ys2) || tr2) (initial M\<^sub>S)\<close> append.simps(1) append_butlast_last_id
            butlast_snoc length_butlast length_greater_0_conv list.size(3) nat.simps(3))
      moreover obtain t2 where "tr2 = [t2]"
        using \<open>length tr2 = 1\<close>
        by (metis One_nat_def \<open>length [0] = length ys2 \<and> length [0] = length tr2
            \<and> path M\<^sub>S (([0] || ys2) || tr2) (initial M\<^sub>S)\<close> append.simps(1) append_butlast_last_id
            butlast_snoc length_butlast length_greater_0_conv list.size(3) nat.simps(3))
      ultimately have "path M\<^sub>S [((0,y2),t2)] (initial M\<^sub>S)"
        by auto
      then have "t2 \<in> succ M\<^sub>S (0,y2) (initial M\<^sub>S)"
        by auto
      moreover have "\<And> y . succ M\<^sub>S (0,y) (initial M\<^sub>S) \<subseteq> {1}"
        by auto
      ultimately have "t2 = 1"
        by blast

      show "target (([0] || ys2) || tr2) (initial M\<^sub>S) = 1"
        using \<open>ys2 = [y2]\<close> \<open>tr2 = [t2]\<close> \<open>t2 = 1\<close> by auto
    qed
    then show "\<forall>ys2 tr2.
       length [0] = length ys2 \<and> length [0] = length tr2
          \<and> path M\<^sub>S (([0] || ys2) || tr2) (initial M\<^sub>S)
            \<longrightarrow> target (([0] || ys2) || tr2) (initial M\<^sub>S) = 1"
      by auto
  qed

  then have "d_reaches M\<^sub>S (initial M\<^sub>S) [0] 1"
    unfolding d_reaches.simps by blast
  then have "1 \<in> d_reachable M\<^sub>S (initial M\<^sub>S)"
    unfolding d_reachable.simps by blast

  then have "{0,1} \<subseteq> d_reachable M\<^sub>S (initial M\<^sub>S)"
    using \<open>initial M\<^sub>S \<in> d_reachable M\<^sub>S (initial M\<^sub>S)\<close> by auto
  moreover have "d_reachable M\<^sub>S (initial M\<^sub>S) \<subseteq> nodes M\<^sub>S"
  proof
    fix s assume "s\<in>d_reachable M\<^sub>S (initial M\<^sub>S)"
    then have "s \<in> reachable M\<^sub>S (initial M\<^sub>S)"
      using d_reachable_reachable by auto
    then show "s \<in> nodes M\<^sub>S"
      by blast
  qed
  ultimately have "d_reachable M\<^sub>S (initial M\<^sub>S) = {0,1}"
    using example_nodes(1) by blast

  fix f' :: "nat \<Rightarrow> nat list"
  let ?f = "f'( 0 := [], 1 := [0])"

  have "is_det_state_cover_ass M\<^sub>S ?f"
    unfolding is_det_state_cover_ass.simps
  proof
    show "?f (initial M\<^sub>S) = []" by auto
    show "\<forall>s\<in>d_reachable M\<^sub>S (initial M\<^sub>S). d_reaches M\<^sub>S (initial M\<^sub>S) (?f s) s"
    proof
      fix s assume "s\<in>d_reachable M\<^sub>S (initial M\<^sub>S)"
      then have "s \<in> reachable M\<^sub>S (initial M\<^sub>S)"
        using d_reachable_reachable by auto
      then have "s \<in> nodes M\<^sub>S"
        by blast
      then have "s = 0 \<or> s = 1"
        using example_nodes(1) by blast
      then show "d_reaches M\<^sub>S (initial M\<^sub>S) (?f s) s"
      proof
        assume "s = 0"
        then show "d_reaches M\<^sub>S (initial M\<^sub>S) (?f s) s"
          using \<open>d_reaches M\<^sub>S (initial M\<^sub>S) [] (initial M\<^sub>S)\<close> by auto
      next
        assume "s = 1"
        then show "d_reaches M\<^sub>S (initial M\<^sub>S) (?f s) s"
          using \<open>d_reaches M\<^sub>S (initial M\<^sub>S) [0] 1\<close> by auto
      qed
    qed
  qed

  moreover have "V\<^sub>I = image ?f (d_reachable M\<^sub>S (initial M\<^sub>S))"
    using \<open>d_reachable M\<^sub>S (initial M\<^sub>S) = {0,1}\<close> by auto

  ultimately show ?thesis
    unfolding is_det_state_cover.simps by blast
qed

abbreviation "\<Omega>\<^sub>I::(nat,nat) ATC set \<equiv> { Node 0 (\<lambda> y . Leaf) }"

lemma "applicable_set M\<^sub>S \<Omega>\<^sub>I"
  by auto

lemma example_test_tools : "test_tools M\<^sub>S M\<^sub>I FAIL\<^sub>I PM\<^sub>I V\<^sub>I \<Omega>\<^sub>I"
  using example_productF example_det_state_cover by auto

lemma OFSM_not_vacuous :
  "\<exists> M :: (nat,nat,nat) FSM . OFSM M"
  using example_OFSM(1) by blast

lemma fault_domain_not_vacuous :
  "\<exists> (M2::(nat,nat,nat) FSM) (M1::(nat,nat,nat) FSM) m . asc_fault_domain M2 M1 m"
  using example_fault_domain by blast

lemma test_tools_not_vacuous :
  "\<exists> (M2::(nat,nat,nat) FSM)
     (M1::(nat,nat,nat) FSM)
     (FAIL::(nat\<times>nat))
     (PM::(nat,nat,nat\<times>nat) FSM)
     (V::(nat list set))
     (\<Omega>::(nat,nat) ATC set) . test_tools M2 M1 FAIL PM V \<Omega>"
proof -
  show ?thesis
  proof
    show "\<exists> (M1::(nat,nat,nat) FSM) FAIL PM V \<Omega> . test_tools M\<^sub>S M1 FAIL PM V \<Omega>"
    proof
      show "\<exists> FAIL PM V \<Omega>. test_tools M\<^sub>S M\<^sub>I FAIL PM V \<Omega>"
        using example_test_tools by blast
    qed
  qed
qed

lemma precondition_not_vacuous :
  shows "\<exists> (M2::(nat,nat,nat) FSM)
           (M1::(nat,nat,nat) FSM)
           (FAIL::(nat\<times>nat))
           (PM::(nat,nat,nat\<times>nat) FSM)
           (V::(nat list set))
           (\<Omega>::(nat,nat) ATC set)
           (m :: nat) .
              OFSM M1 \<and> OFSM M2 \<and> asc_fault_domain M2 M1 m \<and> test_tools M2 M1 FAIL PM V \<Omega>"
proof
  show "\<exists>(M1::(nat,nat,nat) FSM)
         (FAIL::(nat\<times>nat))
         (PM::(nat,nat,nat\<times>nat) FSM)
         (V::(nat list set))
         (\<Omega>::(nat,nat) ATC set)
         (m :: nat) .
            OFSM M1 \<and> OFSM M\<^sub>S \<and> asc_fault_domain M\<^sub>S M1 m \<and> test_tools M\<^sub>S M1 FAIL PM V \<Omega>"

  proof
    show "\<exists>(FAIL::(nat\<times>nat))
           (PM::(nat,nat,nat\<times>nat) FSM)
           (V::(nat list set))
           (\<Omega>::(nat,nat) ATC set)
           (m :: nat) .
              OFSM M\<^sub>I \<and> OFSM M\<^sub>S \<and> asc_fault_domain M\<^sub>S M\<^sub>I m \<and> test_tools M\<^sub>S M\<^sub>I FAIL PM V \<Omega>"
    proof
      show "\<exists>(PM::(nat,nat,nat\<times>nat) FSM)
             (V::(nat list set))
             (\<Omega>::(nat,nat) ATC set)
             (m :: nat) .
                OFSM M\<^sub>I \<and> OFSM M\<^sub>S \<and> asc_fault_domain M\<^sub>S M\<^sub>I m \<and> test_tools M\<^sub>S M\<^sub>I FAIL\<^sub>I PM V \<Omega>"
      proof
        show "\<exists>(V::(nat list set))
               (\<Omega>::(nat,nat) ATC set)
               (m :: nat) .
                  OFSM M\<^sub>I \<and> OFSM M\<^sub>S \<and> asc_fault_domain M\<^sub>S M\<^sub>I m \<and> test_tools M\<^sub>S M\<^sub>I FAIL\<^sub>I PM\<^sub>I V \<Omega>"
        proof
          show "\<exists>(\<Omega>::(nat,nat) ATC set)
                 (m :: nat) .
                    OFSM M\<^sub>I \<and> OFSM M\<^sub>S \<and> asc_fault_domain M\<^sub>S M\<^sub>I m \<and> test_tools M\<^sub>S M\<^sub>I FAIL\<^sub>I PM\<^sub>I V\<^sub>I \<Omega>"
          proof
            show "\<exists>(m :: nat) .
                    OFSM M\<^sub>I \<and> OFSM M\<^sub>S \<and> asc_fault_domain M\<^sub>S M\<^sub>I m \<and> test_tools M\<^sub>S M\<^sub>I FAIL\<^sub>I PM\<^sub>I V\<^sub>I \<Omega>\<^sub>I"
            proof
              show "OFSM M\<^sub>I \<and> OFSM M\<^sub>S \<and> asc_fault_domain M\<^sub>S M\<^sub>I 2 \<and> test_tools M\<^sub>S M\<^sub>I FAIL\<^sub>I PM\<^sub>I V\<^sub>I \<Omega>\<^sub>I"
                using example_OFSM(2,1) example_fault_domain example_test_tools by linarith
            qed
          qed
        qed
      qed
    qed
  qed
qed

end