theory Common
imports Main
begin

(* FIXME when to use options and when to use rresult *)

section "preliminaries"

definition rev_apply :: "'a => ('a => 'b) => 'b" (infixl "|>" 100) where
  "rev_apply x f = f x"

(* Quickcheck_Examples/Completeness.thy - should be in Main? simpler defn here*)
definition is_Some :: "'a option => bool" where
  "is_Some x == x ~= None"

primrec dest_Some (* :: "'a option => 'a" *) where
  "dest_Some (Some x) = x"
  | "dest_Some None = undefined"

definition arb :: "'a" where
  "arb == undefined"

definition impossible :: "'a" where
  "impossible == undefined"

datatype 'a rresult = Ok 'a | Error

definition rresult_to_option :: "'a rresult => 'a option" where
  "rresult_to_option x = (case x of Ok x => Some x | Error => None)"

section "page, page_ref, store"

(* type vars: 'bs 'k 'r 'v *)

datatype 'bs page = Page 'bs (* bytes *)

datatype 'r page_ref = Page_ref 'r

definition dest_page_ref :: "'r page_ref => 'r" where
  "dest_page_ref r0 == (case r0 of Page_ref r => r)"

datatype ('bs,'r) store = Store "('r page_ref ~=> 'bs page)"  (* different to paper: we store actual bytes *)

definition dest_store :: "('bs,'r) store => ('r page_ref ~=> 'bs page)" where
  "dest_store s0 == (case s0 of Store f => f)"

definition ref_to_page :: "('bs,'r) store => 'r page_ref => 'bs page option" where
  "ref_to_page s0 r0 == (s0|>dest_store) r0"

section "key and frame, (leaf_frame) key_to_v"

datatype 'k key = Key 'k

definition dest_key :: "'k key => 'k" where
  "dest_key k = (case k of Key k => k)"

datatype 'v value_t = Value 'v

definition dest_value :: "'v value_t => 'v" where
  "dest_value v == (case v of Value v => v)"

record ('r,'k) node_frame =
  nf_n :: "nat"
  nf_ks :: "nat => 'k key"
  nf_rs :: "nat => 'r page_ref"

record ('k,'v) leaf_frame =
  lf_kvs :: "('k key * 'v value_t) list" (* slightly different to paper - we store ks in tree *)

datatype ('r,'k,'v) frame = Frm_I "('r,'k) node_frame" | Frm_L "('k,'v) leaf_frame"

definition key_to_v :: "('k,'v) leaf_frame => 'k key => 'v value_t option" where
  "key_to_v lf k == (lf |> lf_kvs |> map_of) k"

section "page and frame, page_to_frame, ctxt_p2f"

(* interpretation of pages *)
datatype ('bs,'k,'r,'v) page_to_frame = P2f "'bs page => ('r,'k,'v) frame"  (* note that this forces that the page internally stores its type; this is not necessary, but is used by step_find *)

definition dest_p2f :: "('bs,'k,'r,'v) page_to_frame => 'bs page => ('r,'k,'v) frame" where
  "dest_p2f x = (case x of P2f f => f)"

(**********)
(* to convert a page_ref to a frame, lookup the page option and use the above *)
record  ('bs,'k,'r,'v) ctxt_p2f_t =
  ctxt_p2f :: "('bs,'k,'r,'v) page_to_frame"

(* from this point, we don't duplicate 0/Suc defns, to minimize # of defns *)
definition page_ref_to_frame :: "('bs,'k,'r,'v) ctxt_p2f_t => ('bs,'r) store =>  'r page_ref => ('r,'k,'v) frame option" where
  "page_ref_to_frame c0 s0 r0 == (
    case ref_to_page s0 r0 of
    None => (Error |> rresult_to_option)  (* invalid page access *)
    | Some p => (Some( (c0|>ctxt_p2f|>dest_p2f) p))
)"

section "tree"

datatype ('k,'v) tree = Tr_nd "(nat * (nat => 'k key) * (nat => ('k,'v) tree))" | Tr_lf "('k key * 'v value_t) list"

type_synonym tree_height = nat

lemma FIXME: "P" sorry

function tree_to_leaves :: "('k,'v) tree => ('k key *'v value_t) list list" where
  "tree_to_leaves (Tr_lf(kvs)) = [kvs]"
  | "tree_to_leaves (Tr_nd(n,ks,ts)) = (
    [0..<n+1] |> (List.map ts) |> (List.map tree_to_leaves) |> List.concat)"
by pat_completeness auto
termination  (* tree_to_leavess_dom is not right here - the function package seems confused FIXME *)
  apply(force intro:FIXME)
  done

definition tree_to_kvs :: "('k,'v) tree => ('k key *'v value_t) list" where
  "tree_to_kvs t0 == tree_to_leaves t0 |> List.concat"

lemma tree_to_kvs_simp: "
  (tree_to_kvs (Tr_lf(kvs)) = kvs)
  & (tree_to_kvs (Tr_nd(n,ks,ts)) = ([0..<n+1] |> (List.map ts) |> (List.map tree_to_kvs) |> List.concat))
"
  sorry

section "page_ref_to_tree, page_ref_to_map, page_ref_key_to_v"

type_synonym ('k,'r,'v) pr2f_t = " ('r page_ref => ('k,'v) tree option)"

definition nf_to_subtrees' :: "('bs,'k,'r,'v) ctxt_p2f_t =>  ('bs,'r) store =>
  ('r,'k) node_frame => (* given a node frame *)
  ('k,'r,'v) pr2f_t => (* and a function taking page_refs and giving subtrees (the recursive call) *)
  (nat => ('k,'v) tree) rresult" (* produce the equivalent of the nf, but with trees not refs *)
where
  "nf_to_subtrees' c0 s0 nf pr2t == (
          let n = (nf|>nf_n) in
          let rs = (nf|>nf_rs) :: (nat => 'r page_ref) in
          let f0 = pr2t :: ('r page_ref => ('k,'v) tree option) in
          let prop = (! (m::nat). m <= n --> m |> rs |> f0 |> is_Some) in (* we use \<le> because the number of subtrees to create is n (number of keys) + 1 --since we start from index 0, it is just n*)
          case prop of
          True => (Ok(% (m::nat). m |> rs |> f0 |> dest_Some))
          | False => (Error)  (* Frm_I was not wellformed - prop was false *)
  )"

(* NB this has an explicit n argument, whereas wfness gives us that we can just use page_ref_to_frame *)
fun page_ref_to_tree :: "
  ('bs,'k,'r,'v) ctxt_p2f_t =>  ('bs,'r) store => 'r page_ref => tree_height =>
  ('k,'v) tree option"
where
  "page_ref_to_tree c0 s0 r0 0 = (
      case page_ref_to_frame c0 s0 r0 of
      None => (Error |> rresult_to_option)
      | Some frm => (
        case frm of
        Frm_L(lf) => (Some(Tr_lf (lf|>lf_kvs)))
        | _ => (Error |> rresult_to_option )))"  (* attempt to access missing page *)
  | "page_ref_to_tree c0 s0 r0 (Suc n') = (
      case page_ref_to_frame c0 s0 r0 of
      None => (Error |> rresult_to_option)  (* attempt to access missing page *)
      | Some frm => (
        case frm of
        Frm_I(nf) => (
          let ks = (nf|>nf_ks) in
          let rs :: (nat => 'r page_ref) = nf|>nf_rs in
          let pr2t ::  ('k,'r,'v) pr2f_t = (% r. page_ref_to_tree c0 s0 r n') in
          let subtrees :: (nat => ('k,'v) tree) rresult = nf_to_subtrees' c0 s0 nf pr2t in
          case subtrees of
          Error => (Error |> rresult_to_option)
          | Ok subtrees => (arb))
        | Frm_L(_) => (Error |> rresult_to_option)))"  (* found Frm_L but tree_height was not 0 *)

(* notice that this ideally belongs in section "page and frame" *)
definition page_ref_to_kvs ::  "('bs,'k,'r,'v) ctxt_p2f_t =>  ('bs,'r) store => 'r page_ref => tree_height => ('k key*'v value_t) list option" where
  "page_ref_to_kvs c0 s0 r0 n0 == (
  (page_ref_to_tree c0 s0 r0 n0)
  |> (% x. case x of
    None => None
    | Some t => Some(tree_to_kvs t)))"

definition kvs_to_map :: "('k key*'v value_t) list => ('k key ~=> 'v value_t)" where
  "kvs_to_map kvs == (map_of kvs)"

definition page_ref_to_map :: "('bs,'k,'r,'v) ctxt_p2f_t =>  ('bs,'r) store => 'r page_ref => tree_height => ('k key ~=> 'v value_t) option" where
  "page_ref_to_map c0 s0 r0 n0 == (page_ref_to_kvs c0 s0 r0 n0) |> (map_option kvs_to_map)"

definition page_ref_key_to_v :: "('bs,'k,'r,'v) ctxt_p2f_t => ('bs,'r) store => 'r page_ref => tree_height =>'k key => 'v value_t option" where
  "page_ref_key_to_v ctxt s0 r0 n0 k0 == (
    let m0 = page_ref_to_map ctxt s0 r0 n0 in
    Option.bind m0 (% m. m k0))"

section "(given node_frame) key_to_ref, ctxt_k2r_t"

(* NB we need some properties of these functions for correctness

This abstracts from the particular find implementation. Essentially, at a non-leaf node, we need to map
a key to a page ref, from which we can continue the find. The property this function should have is
that, given a key, if there is a value corresponding to the key (which is unique), then the
returned page ref identifies the relevant subtree.

*)
(* FIXME following should be key to index *)
datatype ('bs,'k,'r,'v) key_to_ref = Key_to_ref "('r,'k) node_frame => 'k key => nat (* 'r page_ref *)"
(* datatype ('bs,'k,'r,'v) key_to_v = Key_to_v "('k,'v) leaf_frame => 'k key => 'v option"  (* may be no such v *) - there is only one impl! *)

definition dest_key_to_ref :: "('bs,'k,'r,'v) key_to_ref => ('r,'k) node_frame => 'k key => nat (* 'r page_ref *)" where
  "dest_key_to_ref k2r == (case k2r of Key_to_ref f => f)"

(*
definition dest_key_to_v :: "('bs,'k,'r,'v) key_to_v => ('k,'v) leaf_frame => 'k key => 'v value_t option" where
  "dest_key_to_v k2v == (case k2v of Key_to_v f => f)"
*)

(**********)
record  ('bs,'k,'r,'v) ctxt_k2r_t =  "('bs,'k,'r,'v) ctxt_p2f_t" +
  key_to_ref2 :: "('bs,'k,'r,'v) key_to_ref"
(*  key_to_v :: "('bs,'k,'r,'v) key_to_v" *)

definition apply_key_to_ref :: "('bs,'k,'r,'v) key_to_ref => ('r,'k) node_frame  => 'k key => 'r page_ref" where
  "apply_key_to_ref k2r nf k0 == (
    let n = (dest_key_to_ref k2r) nf k0 in
    (nf|>nf_rs) n)"

end


(*<*)(*:maxLineLen=68:*)
theory dAutomaton_causal
  imports dAutomaton spf.SPF
begin

default_sort "chan"
(*>*)

subsection \<open>Deterministic Causal Automaton\<close> text\<open>\label{cauaut}\<close>

text\<open>Since the causality properties are an important factor for the
realizability of a component we introduce two automaton types that
work similar to our general deterministic automaton, but always have
a causal semantic. From the general causality theorems we can see
directly how to comply with their assumptions. First, we define the
output of a transition function as a @{type sbElem}. This leads
directly the weakness of an automaton.\<close>

record ('state::type, 'in, 'out) dAutomaton_weak  =
  dawTransition :: "('state \<Rightarrow> 'in\<^sup>\<surd> \<Rightarrow> ('state \<times> 'out\<^sup>\<surd>))"
  dawInitState :: "'state"

text\<open>The semantic of a weak automaton will never be strong, because
it has no initial output. But expanding it with an initial output in
from of a @{type sbElem} will directly fulfill necessary assumptions
for its strong semantic. Hence, we define the extension of the weak
automaton type as the strong automaton type.\<close>

record ('state::type,'in,'out)dAutomaton_strong =
      "('state::type,'in,'out)dAutomaton_weak" + dasInitOut::"'out\<^sup>\<surd>"

text\<open>Records directly provide functions for arbitrary type
extensions, we use them for the defined type extension from weak to
strong automatons.\<close>

definition daw2das::
"('state::type, 'in, 'out) dAutomaton_weak
\<Rightarrow> 'out\<^sup>\<surd> \<Rightarrow> ('state::type, 'in, 'out) dAutomaton_strong"where
"daw2das daw initout\<equiv> dAutomaton_weak.extend daw
                      (dAutomaton_strong.fields initout)"

text\<open>Furthermore, the next two functions convert our causal
automatons to equivalent general automatons\ref{sub:detaut}.\<close>

definition daw2da::"('state::type, 'in, 'out) dAutomaton_weak
\<Rightarrow> ('state::type, 'in, 'out) dAutomaton" where
"daw2da \<equiv> \<lambda>aut.
(| daTransition =(\<lambda>s sbe. (fst(dawTransition aut s sbe),
                           sbe2sb (snd(dawTransition aut s sbe)))),
   daInitState  = dawInitState(aut),
   daInitOut    = \<bottom> |)"

text\<open>The only difference in those converters is the initial output.
It is the empty bundle for weak automatons.\<close>

definition das2da::"('state::type, 'in, 'out) dAutomaton_strong
\<Rightarrow> ('state::type, 'in, 'out) dAutomaton" where
"das2da \<equiv> \<lambda>aut.
(| daTransition =(\<lambda>s sbe. (fst(dawTransition aut s sbe),
                           sbe2sb (snd(dawTransition aut s sbe)))),
   daInitState  = dawInitState(aut),
    daInitOut   = sbe2sb(dasInitOut aut) |)"

text\<open>The semantic mapping of our causal automatons use the
converters to apply our general state semantic mapping
@{const daStateSem} to our converted automatons.\<close>

definition dawStateSem::
"('s::type,'I::{chan,finite},'O) dAutomaton_weak
\<Rightarrow> ('s \<Rightarrow> ('I\<^sup>\<Omega> \<rightarrow> 'O\<^sup>\<Omega>))" where
"dawStateSem da \<equiv> daStateSem (daw2da da)"

text\<open>Since our weak Automatons have no initial output, the complete
semantic mapping only maps the state semantic to the corresponding
\gls{spf} of the initial state. Alternatively we could also use
@{const daSem}\ref{subsub:sem} and our converter to accomplish the
same.\<close>

definition dawSem::
"('s::type, 'I::{chan,finite},'O) dAutomaton_weak
\<Rightarrow> ('I\<^sup>\<Omega> \<rightarrow> 'O\<^sup>\<Omega>)" where
"dawSem da \<equiv> dawStateSem da (dawInitState da)"

text\<open>Our strong semantic does exactly this.\<close>

definition dasSem::
"('s::type, 'I::{chan,finite},'O) dAutomaton_strong
\<Rightarrow> ('I\<^sup>\<Omega> \<rightarrow> 'O\<^sup>\<Omega>)" where
"dasSem da \<equiv> daSem(das2da da)"
(*<*)
subsubsection  \<open>Rum96 Automaton Semantic\<close>

function Rum_tap::"('s::type, 'in,'out) dAutomaton_weak
\<Rightarrow> ('s \<Rightarrow> ('in,'out) spfw) set" where
"Rum_tap aut =
{h | h. \<forall>m s. \<exists>t out . snd(dawTransition aut s m) = out \<and>
                       (\<exists>h2\<in> (Rum_tap aut). \<forall>i .
          Rep_spfw(h s)\<cdot>(m \<bullet>\<^sup>\<surd> i) = out \<bullet>\<^sup>\<surd> (Rep_spfw(h2 t))\<cdot>i)}"
  by(simp)+

fun Rum_ta::"('s::type, 'in,'out) dAutomaton_weak
\<Rightarrow> (('in,'out) spfw) set"where
"Rum_ta aut = {g | g. \<exists>h\<in>(Rum_tap aut). \<exists> s (out::'out\<^sup>\<surd>). \<forall>i.
              (Rep_spfw g)\<cdot>i = out\<bullet>\<^sup>\<surd>((Rep_spfw(h s))\<cdot>i)}"

fun Rum_ta_strong::
"('s::type, 'in::{chan,finite},'out) dAutomaton_strong
\<Rightarrow> (('in,'out) spfs) set"where
"Rum_ta_strong aut = Abs_spfs`Rum_ta (dAutomaton_weak.truncate aut)"

(*>*)
paragraph \<open>Causal Sem lemmas \\\<close>

text\<open>The causal automaton types work very similar to our general
automatons. Firstly, the semantic iteration terminates, if the input
\gls{sb} has not bundle element.\<close>

lemma dawstatesem_unfolding:
"dawStateSem automat s = sb_split\<cdot>(\<lambda>sbe. \<Lambda> sb .
           let (nextState, output) = dawTransition automat s sbe in
           output \<bullet>\<^sup>\<surd> ((dawStateSem automat) nextState\<cdot>sb))"
  apply(simp add: dawStateSem_def daw2da_def)
  apply(subst dastatesem_unfolding)
  by(simp add: sbECons_def prod.case_eq_if)

lemma dawNextOut:
  shows "sbe2sb (snd ((dawTransition automat) s sbe)) =
         daNextOut (daw2da automat) s sbe"
  by (simp add: daNextOut_def daw2da_def)

lemma dawNextState:
  shows "fst (dawTransition automat s sbe) =
         daNextState (daw2da automat) s sbe"
  by  (simp add: daNextState_def daw2da_def)

theorem dawstatesem_bottom:
  assumes "\<not>sbHdElemWell (sb::'b::{finite,chan}\<^sup>\<Omega>)"
  and "\<not> chDomEmpty TYPE('b)"
  shows "(dawStateSem automat s)\<cdot>sb = \<bottom>"
  by  (simp_all add: assms dawStateSem_def dastatesem_bottom)

lemma dawstatesem_strict:
  assumes "\<not> chDomEmpty TYPE('b::{finite, chan})"
  shows "(dawStateSem automat s)\<cdot>(\<bottom>::'b\<^sup>\<Omega>) = \<bottom>"
  by (simp add: assms dawStateSem_def dastatesem_strict)

lemma dawstatesem_step:
  assumes "sbHdElemWell sb"
  shows "(dawStateSem da s)\<cdot>sb =
  snd (dawTransition da s (sbHdElem sb)) \<bullet>\<^sup>\<surd>
  dawStateSem da (fst (dawTransition da s (sbHdElem sb)))\<cdot>(sbRt\<cdot>sb)"
  by (simp_all add: dawStateSem_def sbECons_def assms
      daNextState_def[symmetric] dawNextState[symmetric]
      daNextOut_def[symmetric] dawNextOut dastatesem_step)

lemma dawstatesem_final:
  assumes "sbHdElemWell sb"
  shows "dawStateSem automat s\<cdot>sb =
(let (nextState, output) = dawTransition automat s (sbHdElem sb) in
                  output \<bullet>\<^sup>\<surd> dawStateSem automat nextState\<cdot>(sbRt\<cdot>sb))"
  by (simp add: case_prod_unfold Let_def dawStateSem_def sbECons_def
      dawNextOut dawNextState dastatesem_final assms)

text\<open>Furthermore, process every input bundle element similar to the
general automatons, but produce exactly one bundle element as
output for every input element.\<close>

theorem dawstatesem_final_h2:
  shows "(dawStateSem automat s)\<cdot>(sbe \<bullet>\<^sup>\<surd> sb) =
          (let (nextState, output) = dawTransition automat s sbe in
                         output \<bullet>\<^sup>\<surd> dawStateSem automat nextState\<cdot>sb)"
  apply (simp add: case_prod_unfold Let_def dawStateSem_def)
  apply (subst (2) sbECons_def)
  by (simp add: dawNextOut dawNextState dastatesem_final_h2)

text\<open>Thus, the length of the output is equal to the length of the
input. This leads directly to the weakness of any weak automaton
semantic.\<close>

lemma dawsem_len:
  fixes automat::"('s::type,'I::{chan,finite},'O)dAutomaton_weak"
  assumes "\<not>chDomEmpty TYPE('O)"
  shows "sbLen (dawStateSem automat s\<cdot>sb) = sbLen sb"
proof (cases "chDomEmpty TYPE('I)")
  case True
  have "\<And>s sbe. sbLen (sbe2sb (snd ((dawTransition automat) s sbe))) = 1"
    by (simp add: assms)
  thus ?thesis
    by (metis (mono_tags, lifting) True dastatesem_inempty_len
        dawNextOut dawStateSem_def min.orderI min_def sblen_empty
        sbtypeepmpty_sbbot)
next
  case False
  have "\<And>s sbe. sbLen (sbe2sb (snd ((dawTransition automat) s sbe))) = 1"
    by (simp add: assms)
  hence nextout_len: "\<And>s sbe. sbLen (daNextOut (daw2da automat) s sbe) = 1"
    by (simp add: dawNextOut)
  have "sbLen sb < \<infinity> \<Longrightarrow> sbLen sb = sbLen (dawStateSem automat s\<cdot>sb)"
  proof-
    assume sb_len: "sbLen sb < \<infinity>"
    thus ?thesis
    proof (induction sb arbitrary: s rule: sb_finind)
      case 1
      then show ?case
        using sb_len by blast
    next
      case (2 sb)
      then show ?case
        by (metis False assms botsbleast dawstatesem_bottom lnzero_def sbleast2sblenempty)
    next
      case (3 sbe sb)
      then show ?case
        by (metis dawstatesem_step fold_inf inf_less_eq le_less_linear
            lnat.con_rews lnzero_def sbecons_len sbleast2sblenempty sbrt_sbecons)
    qed
  qed
  thus ?thesis
    by (metis dastatesem_weak dawStateSem_def inf_less_eq
        le_less_linear less_irrefl nextout_len weak_well_def)
qed

lemma dawstatesem_weak:
  shows  "weak_well (dawStateSem automat s)"
  apply (simp add: dawStateSem_def)
  apply (rule dastatesem_weak)
  apply (simp add: daw2da_def daNextOut_def)
  by (cases "chDomEmpty TYPE('b)",auto)

theorem dawsem_weak[simp]:
  fixes automat::"('s::type,'I::{chan,finite},'O)dAutomaton_weak"
  shows  "weak_well (dawSem automat)"
  apply (simp add: dawSem_def)
  by (simp add: dawstatesem_weak eta_cfun)

lemma dassem_insert:
"dasSem automat\<cdot>sb = dasInitOut automat \<bullet>\<^sup>\<surd>
                     dawStateSem (dAutomaton_weak.truncate automat)
                     (dawInitState automat)\<cdot>sb"
  by (simp add:  dasSem_def dawSem_def dAutomaton_weak.defs
      dAutomaton_strong.defs sbECons_def  dasem_insert das2da_def
      dawStateSem_def daw2da_def daStateSem_def)

lemma dasinitout_well:"(dasInitOut
         (dAutomaton_weak.extend daw
           (dAutomaton_strong.fields
             sbe))) = sbe"
  by(simp add: dAutomaton_weak.defs dAutomaton_strong.defs)

lemma das2daw_trunc_well:"dAutomaton_weak.truncate
                (dAutomaton_weak.extend da
                  (dAutomaton_strong.fields sbe)) = da"
  by(simp add: dAutomaton_weak.defs dAutomaton_strong.defs)

lemma dassem_bottom:
  assumes "\<not> chDomEmpty TYPE('b::{finite,chan})"
  shows "dasSem automat\<cdot>(\<bottom>::'b\<^sup>\<Omega>) = sbe2sb (dasInitOut automat)"
  by (simp add: dasSem_def dasem_bottom assms das2da_def)

text\<open>Of course the strong automatons are then immediately strong,
since they have an additional initial output element.\<close>

lemma dassem_len:
  fixes automat::"('s::type,'I::{chan,finite},'O)dAutomaton_strong"
  assumes "\<not>chDomEmpty TYPE('O)"
  shows  "sbLen (dasSem automat\<cdot>sb) = lnsuc\<cdot>(sbLen sb)"
  by (simp add: assms dassem_insert dawsem_len sbecons_len)

theorem dassem_strong:
shows "strong_well (dasSem automat)"
  apply (simp add: strong_well_def dassem_insert SB.sbecons_len)
  by (meson dawstatesem_weak weak_well_def)

paragraph \<open>Lifted semantic \\\<close>

text\<open>We can then provide lifted semantics for strong and weak
automatons. The lifted versions of @{const dawSem} and
@{const dasSem} map to well formed causal \glspl{spf}.\<close>

lift_definition semantic_weak::
"('state::type,'in::{chan,finite},'out) dAutomaton_weak
\<Rightarrow> ('in,'out)spfw" is "dawSem"
  by %visible simp

lift_definition semantic_strong::
"('s::type, 'in::{chan,finite}, 'out) dAutomaton_strong
\<Rightarrow> ('in,'out)spfs"is "\<lambda>auts. Abs_spfw(dasSem auts)"
  by %visible (simp add: Abs_spfw_inverse dassem_strong strong2weak)

subsubsection \<open>Causal Automaton Locales\<close>

text\<open>The semantic mapping allows us to verify the behaviour of
components with \glspl{spf}. Since these components are modeled as
automatons, we introduce two locals for constructing and
transforming automatons. These locals are used in the generation
process, where a MontiArc model provides the information about the
automatons components. Hence, they provide us with a state type,
message types, the transition function directly obtained from the
model and an initial state. Since the MontiArc model has no
\glspl{sb}, @{type sbElem}s or the @{type M}, the transition
function also does not use any of these things. Instead it uses
exactly the types from its model. But the message types do not have
to be in type @{type M} to construct an automaton in Isabelle,
because our locals @{locale sbeGen} and @{locale sbGen} are also
interpreted with constructors provided by the generator and we can
utilize them to define the automaton internally and independently.\<close>

locale sscanlGen =
  fixes daTransition::"'state::countable \<Rightarrow> 'a::countable
                        \<Rightarrow> ('state\<times>'b::countable)"
  and   daInitialState::"'state"
  and fin::"'a::countable \<Rightarrow> 'in::{chan,finite} \<Rightarrow> M"
  and fout::"'b::countable \<Rightarrow> 'out::{chan,finite} \<Rightarrow> M"
  assumes sbegenfin:"sbeGen fin"
      and sbegenfout:"sbeGen fout"
begin

text\<open>Using the setter, getter and MontiArc transition function we
define the corresponding transition function for our automaton by
applying the provided getter to its input @{type sbElem}, running
the MontiArc transition function and then using the setter to
convert its output back to a @{type sbElem}. The state type is not
converted.\<close>

definition daTransitionH::"'state \<Rightarrow> 'in\<^sup>\<surd> \<Rightarrow> ('state \<times> 'out\<^sup>\<surd>)" where
"daTransitionH state sbe =
     (let (s,output) = daTransition state (sbeGen.getter fin sbe) in
                       (s, sbeGen.setter fout output))"

text\<open>Then the deterministic automaton is defined with the initial
state and @{const daTransitionH}.\<close>

definition "da = \<lparr> dawTransition = daTransitionH,
                 dawInitState =daInitialState \<rparr>"

text\<open>Often components output behaviour depends on the input. These
components have a non-empty input and output domain and so does
their semantic. We can then represent their components behaviour by
reducing its semantic with the setter and getter to a
@{const sscanlAsnd} mapping that uses the MontiArc transition
function and works completely over streams. This is an important
part of the verification process because it is often easier to proof
properties directly for the streams of a bundle and not for the
bundle itself. If the input domain is empty, the components output
is independent from the input.\<close>

theorem daut2sscanl:
  assumes "\<not>chDomEmpty TYPE('out)"
  and "\<not>chDomEmpty TYPE('in)"
  shows"sbeGen.getterSB fout \<cdot>
  (dawStateSem da state\<cdot>(sbeGen.setterSB fin\<cdot>input)) =
   sscanlAsnd daTransition state\<cdot>input"
using assms
proof(induction input arbitrary: state rule: ind)
  case 1
  then show ?case
    by simp
next
  case 2
  then show ?case
    by (simp add: assms sbeGen.gettersb_realboteps
        sbeGen.settersb_strict sbegenfin sbegenfout
        dawstatesem_strict)
next
  case (3 a s)
  then show ?case
    by (simp add: sbeGen.get_set dawstatesem_final_h2 sbegenfin
        sbegenfout sbeGen.settersb_unfold prod.case_eq_if
        sbeGen.gettersb_unfold da_def daTransitionH_def)
qed

lemma daut2sscanl2:
  shows"(dawStateSem da state\<cdot>input) =
   sbeGen.setterSB fout\<cdot>(sscanlAsnd daTransition state\<cdot>(sbeGen.getterSB fin\<cdot>input))"
  apply(induction input arbitrary: state)
    apply simp_all
  apply(cases "chDomEmpty TYPE('in)")
    apply (simp add: sbegenfin sbegenfout sbeGen.gettersb_empty_inf)
  defer
    apply (simp add: sbegenfin sbegenfout sbeGen.gettersb_boteps)
    apply (simp add: dawstatesem_bottom sbeGen.settersb_strict sbegenfout)
    apply (simp add: sbegenfin sbegenfout sbeGen.gettersb_unfold dawstatesem_final_h2)(* TODO: anstatt "case" ein lemma mit "fst"/"snd" anlegen *)
  apply (simp add: case_prod_beta daTransitionH_def da_def sbeGen.settersb_unfold sbegenfout)
  oops

lemma emptychan_eq[simp]:
  "chDomEmpty TYPE('out) \<Longrightarrow> (sb1::'out\<^sup>\<Omega>) = sb2"
  by (metis (full_types)sbtypeepmpty_sbbot)

lemma daut2sscanl:
"(dawStateSem da state\<cdot>input) = sbeGen.setterSB fout\<cdot>
(sscanlAsnd daTransition state\<cdot>(sbeGen.getterSB fin\<cdot>input))"
  apply(cases "chDomEmpty(TYPE('out))",simp_all)
  apply(insert daut2sscanl[of state "sbeGen.getterSB fin\<cdot>input"])
  oops

fun %invisible stateSemList::"'state \<Rightarrow> 'a list \<Rightarrow> 'b list" where
"stateSemList _ [] = []" |
"stateSemList state (l#ls) = snd(daTransition state l) #
                      stateSemList (fst (daTransition state l)) ls"

lemma "dawStateSem da state\<cdot>(sbeGen.setterList fin input) =
        sbeGen.setterList fout (stateSemList state input)"
  oops
(* TODO: initiale ausgabe ... "sscanlA" kann nichts partielles
ausgben. dh alles oder nichts. Das kann man durch den typ abfangen!
    * weak = "chIstEmpty" als assumption (oder besser, dafür eine
klasse anlegen)
    * strong = gleicher typ wie ausgabe
*)

end

text\<open>Some automatons contains a self looping state that will never
be left again. If such an automaton reaches a self looping state on
its run, its behaviour can be reduced to an easier transition
function. For such cases we provide a sub local of
@{locale sscanlGen} which provides an additional behaviour
translation.\<close>

locale smapGen =
  fixes daTransition::"'state::countable \<Rightarrow> 'a::countable \<Rightarrow>
                      ('state\<times>'b::countable)"
  and   daInitialState::"'state"
  and fin::"'a::countable \<Rightarrow> 'in::{chan,finite} \<Rightarrow> M"
  and fout::"'b::countable \<Rightarrow> 'out::{chan,finite} \<Rightarrow> M"
  and loopState::"'state"
  assumes scscanlgenf:"sscanlGen fin fout"
  and singlestate:"\<And>sbe. fst(daTransition loopState sbe)=loopState"
begin

text\<open>The looping state is used for defining a mapping \<open> 'a \<Rightarrow> 'b\<close>
from the MontiArc transition function.\<close>

abbreviation "smapTransition \<equiv> (\<lambda>e. snd(daTransition loopState e))"

text\<open>Using this, we can reduce the semantic with setter and getter
to a @{const smap} mapping over streams from the moment its looping
state is reached.\<close>

theorem daut2smap:
  assumes "\<not>chDomEmpty TYPE('out)"
  and "\<not>chDomEmpty TYPE('in)"
  shows"sbeGen.getterSB fout\<cdot>(dawStateSem
        (sscanlGen.da daTransition daInitialState fin fout)
        loopState\<cdot>(sbeGen.setterSB fin \<cdot>input)) =
        smap smapTransition\<cdot>input"
  apply(subst sscanlGen.daut2sscanl)
  using scscanlgenf sscanlGen.sbegenfin assms  apply auto[2]
  by (simp_all add: assms singlestate sscanl2smap)

text\<open>In case of a previous reduction to the @{const sscanlAsnd}
mapping an additional theorem is provided, that allows the further
reduction to @{const smap} if a looping state is reached at any
point.\<close>

theorem step2smap:
  assumes "\<not>chDomEmpty TYPE('out)"
  and     "\<not>chDomEmpty TYPE('in)"
  shows   "sscanlAsnd daTransition loopState\<cdot>input =
           smap smapTransition\<cdot>input"
  using scscanlgenf sscanlGen.sbegenfin assms apply auto
  by (simp_all add: assms singlestate sscanl2smap)

end

text\<open>A @{locale smapGen} interpretation should also automatically
provide all properties and definitions from the @{locale sscanlGen}
locale. This is done be instantiating @{locale smapGen} as a
sub locale of @{locale sscanlGen}.\<close>

sublocale smapGen \<subseteq> sscanlGen
  by %visible (simp add: scscanlgenf)

(*<*)
end
(*>*)


(*  Title:    HOL/Prolog/Test.thy
    Author:   David von Oheimb (based on a lecture on Lambda Prolog by Nadathur)
*)

section \<open>Basic examples\<close>

theory Test
imports HOHH
begin

typedecl nat

typedecl 'a list

consts
  Nil   :: "'a list"                                  ("[]")
  Cons  :: "'a => 'a list => 'a list"                 (infixr "#"  65)

syntax
  (* list Enumeration *)
  "_list"     :: "args => 'a list"                          ("[(_)]")

translations
  "[x, xs]"     == "x#[xs]"
  "[x]"         == "x#[]"

typedecl person

axiomatization
  append  :: "['a list, 'a list, 'a list]            => bool" and
  reverse :: "['a list, 'a list]                     => bool" and

  mappred :: "[('a => 'b => bool), 'a list, 'b list] => bool" and
  mapfun  :: "[('a => 'b), 'a list, 'b list]         => bool" and

  bob     :: person and
  sue     :: person and
  ned     :: person and

  nat23   :: nat          ("23") and
  nat24   :: nat          ("24") and
  nat25   :: nat          ("25") and

  age     :: "[person, nat]                          => bool" and

  eq      :: "['a, 'a]                               => bool" and

  empty   :: "['b]                                   => bool" and
  add     :: "['a, 'b, 'b]                           => bool" and
  remove  :: "['a, 'b, 'b]                           => bool" and
  bag_appl:: "['a, 'a, 'a, 'a]                       => bool"
where
        append:  "\<And>x xs ys zs. append  []    xs  xs    ..
                  append (x#xs) ys (x#zs) :- append xs ys zs" and
        reverse: "\<And>L1 L2. reverse L1 L2 :- (\<forall>rev_aux.
                  (\<forall>L.          rev_aux  []    L  L )..
                  (\<forall>X L1 L2 L3. rev_aux (X#L1) L2 L3 :- rev_aux L1 L2 (X#L3))
                  => rev_aux L1 L2 [])" and

        mappred: "\<And>x xs y ys P. mappred P  []     []    ..
                  mappred P (x#xs) (y#ys) :- P x y  &  mappred P xs ys" and
        mapfun:  "\<And>x xs ys f. mapfun f  []     []      ..
                  mapfun f (x#xs) (f x#ys) :- mapfun f xs ys" and

        age:     "age bob 24 ..
                  age sue 23 ..
                  age ned 23" and

        eq:      "\<And>x. eq x x" and

(* actual definitions of empty and add is hidden -> yields abstract data type *)

        bag_appl: "\<And>A B X Y. bag_appl A B X Y:- (\<exists>S1 S2 S3 S4 S5.
                                empty    S1    &
                                add A    S1 S2 &
                                add B    S2 S3 &
                                remove X S3 S4 &
                                remove Y S4 S5 &
                                empty    S5)"

lemmas prog_Test = append reverse mappred mapfun age eq bag_appl

schematic_goal "append ?x ?y [a,b,c,d]"
  apply (prolog prog_Test)
  back
  back
  back
  back
  done

schematic_goal "append [a,b] y ?L"
  apply (prolog prog_Test)
  done

schematic_goal "\<forall>y. append [a,b] y (?L y)"
  apply (prolog prog_Test)
  done

schematic_goal "reverse [] ?L"
  apply (prolog prog_Test)
  done

schematic_goal "reverse [23] ?L"
  apply (prolog prog_Test)
  done

schematic_goal "reverse [23,24,?x] ?L"
  apply (prolog prog_Test)
  done

schematic_goal "reverse ?L [23,24,?x]"
  apply (prolog prog_Test)
  done

schematic_goal "mappred age ?x [23,24]"
  apply (prolog prog_Test)
  back
  done

schematic_goal "mappred (\<lambda>x y. \<exists>z. age z y) ?x [23,24]"
  apply (prolog prog_Test)
  done

schematic_goal "mappred ?P [bob,sue] [24,23]"
  apply (prolog prog_Test)
  done

schematic_goal "mapfun f [bob,bob,sue] [?x,?y,?z]"
  apply (prolog prog_Test)
  done

schematic_goal "mapfun (%x. h x 25) [bob,sue] ?L"
  apply (prolog prog_Test)
  done

schematic_goal "mapfun ?F [24,25] [h bob 24,h bob 25]"
  apply (prolog prog_Test)
  done

schematic_goal "mapfun ?F [24] [h 24 24]"
  apply (prolog prog_Test)
  back
  back
  back
  done

lemma "True"
  apply (prolog prog_Test)
  done

schematic_goal "age ?x 24 & age ?y 23"
  apply (prolog prog_Test)
  back
  done

schematic_goal "age ?x 24 | age ?x 23"
  apply (prolog prog_Test)
  back
  back
  done

lemma "\<exists>x y. age x y"
  apply (prolog prog_Test)
  done

lemma "\<forall>x y. append [] x x"
  apply (prolog prog_Test)
  done

schematic_goal "age sue 24 .. age bob 23 => age ?x ?y"
  apply (prolog prog_Test)
  back
  back
  back
  back
  done

(*set trace_DEPTH_FIRST;*)
lemma "age bob 25 :- age bob 24 => age bob 25"
  apply (prolog prog_Test)
  done
(*reset trace_DEPTH_FIRST;*)

schematic_goal "(\<forall>x. age x 25 :- age x 23) => age ?x 25 & age ?y 25"
  apply (prolog prog_Test)
  back
  back
  back
  done

lemma "\<forall>x. \<exists>y. eq x y"
  apply (prolog prog_Test)
  done

schematic_goal "\<exists>P. P \<and> eq P ?x"
  apply (prolog prog_Test)
(*
  back
  back
  back
  back
  back
  back
  back
  back
*)
  done

lemma "\<exists>P. eq P (True & True) \<and> P"
  apply (prolog prog_Test)
  done

lemma "\<exists>P. eq P (\<or>) \<and> P k True"
  apply (prolog prog_Test)
  done

lemma "\<exists>P. eq P (Q => True) \<and> P"
  apply (prolog prog_Test)
  done

(* P flexible: *)
lemma "(\<forall>P k l. P k l :- eq P Q) => Q a b"
  apply (prolog prog_Test)
  done
(*
loops:
lemma "(!P k l. P k l :- eq P (%x y. x | y)) => a | b"
*)

(* implication and disjunction in atom: *)
lemma "\<exists>Q. (\<forall>p q. R(q :- p) => R(Q p q)) \<and> Q (t | s) (s | t)"
  by fast

(* disjunction in atom: *)
lemma "(\<forall>P. g P :- (P => b \<or> a)) => g(a \<or> b)"
  apply (tactic "step_tac (put_claset HOL_cs \<^context>) 1")
  apply (tactic "step_tac (put_claset HOL_cs \<^context>) 1")
  apply (tactic "step_tac (put_claset HOL_cs \<^context>) 1")
   prefer 2
   apply fast
  apply fast
  done

(*
hangs:
lemma "(!P. g P :- (P => b | a)) => g(a | b)"
  by fast
*)

schematic_goal "\<forall>Emp Stk.(
                       empty    (Emp::'b) ..
         (\<forall>(X::nat) S. add    X (S::'b)         (Stk X S)) ..
         (\<forall>(X::nat) S. remove X ((Stk X S)::'b) S))
 => bag_appl 23 24 ?X ?Y"
  oops

schematic_goal "\<forall>Qu. (
          (\<forall>L.            empty    (Qu L L)) ..
          (\<forall>(X::nat) L K. add    X (Qu L (X#K)) (Qu L K)) ..
          (\<forall>(X::nat) L K. remove X (Qu (X#L) K) (Qu L K)))
 => bag_appl 23 24 ?X ?Y"
  oops

lemma "D \<and> (\<forall>y. E) :- (\<forall>x. True \<and> True) :- True => D"
  apply (prolog prog_Test)
  done

schematic_goal "P x .. P y => P ?X"
  apply (prolog prog_Test)
  back
  done

end


theory utp_lens_demo
  imports "../theories/utp_designs"
begin

alphabet person =
  surname :: string
  forename :: string
  dateOfBirth :: "nat * nat * nat"

alphabet myst =
  x :: nat
  y :: person
  z :: "int list"

lemma "(\<exists> x \<bullet> &x >\<^sub>u 1) = true"
  by (rel_auto)

lemma "(\<forall> x \<bullet> &x >\<^sub>u 1) = true"
  apply (rel_simp)
  nitpick
oops

lemma "x := 1 ;; x := (&x + 1) = x := 2"
  by (rel_auto)

lemma "x := 1 ;; x := (&x + 2) = x := 2"
  apply (rel_auto)
  oops

lemma "x := (&x - 5) wp (&x >\<^sub>u 10) = (&x >\<^sub>u 15)"
  apply (simp add: wp)
  apply (subst_tac)
  apply (pred_auto)
done

lemma "(true \<turnstile>\<^sub>n x := 1) ;; ((&x >\<^sub>u 1) \<turnstile>\<^sub>n y := &y) = \<bottom>\<^sub>D"
  apply (simp add: ndesign_composition_wp)
  apply (simp add: wp)
  apply (subst_tac)
  apply (pred_auto)
done

term "x +\<^sub>L y"

lemma "x \<bowtie> y"
  by (simp)

lemma "x +\<^sub>L y \<bowtie> z"
  by (simp)

term "surname ;\<^sub>L y"

term "y:surname := \<guillemotleft>''Foster''\<guillemotright> ;; y:dateOfBirth := (02, 02, &x)\<^sub>u"

lemma "(surname ;\<^sub>L y) \<subseteq>\<^sub>L y"
  by (simp)

lemma "x +\<^sub>L y +\<^sub>L z \<approx>\<^sub>L 1\<^sub>L"
  oops
end


theory RedsImprovesArityAnalysis
imports ArityAnalysisFixProps Launchbury
begin

fixrec inc_bot :: "Arity\<^sub>\<bottom> \<rightarrow> Arity\<^sub>\<bottom>" ("inc\<^sub>\<bottom>")
  where "inc\<^sub>\<bottom>\<cdot>(up\<cdot>n)=up\<cdot>(inc\<cdot>n)"

locale ArityAnalysisSafeAfix = ArityAnalysisSafe +
  assumes Aexp_Let: "Afix as\<cdot>(Aexp e\<cdot>n) f|` (- domA as) \<sqsubseteq> Aexp (Let as e)\<cdot>n"

begin
lemma fup_Aexp_Let: "Afix as\<cdot>(fup\<cdot>(Aexp e)\<cdot>n) f|` (- domA as) \<sqsubseteq> fup\<cdot>(Aexp (Let as e))\<cdot>n"
  by (cases n) (simp_all add: Aexp_Let)

lemma  reds_improves_arity':
       "\<Gamma> : e \<Down>\<^bsub>L\<^esub> \<Delta> : v \<Longrightarrow>
        edom ae \<subseteq> set L \<Longrightarrow>
        Afix \<Delta> \<cdot> (fup\<cdot>(Aexp v)\<cdot>n \<squnion> ae) f|` (- (domA \<Delta> - domA \<Gamma>)) \<sqsubseteq> Afix \<Gamma> \<cdot> (fup\<cdot>(Aexp e)\<cdot>n \<squnion> ae) f|` (- (domA \<Delta> - domA \<Gamma>))"
proof(induct arbitrary: ae n rule: reds.induct)
case Lambda
  show ?case by simp
next
case (Variable \<Gamma> x e L \<Delta> z ae n)
  have reorder: "map_of ((x, e) # delete x \<Gamma>) = map_of \<Gamma>" by (rule map_of_delete_insert[OF Variable.hyps(1)])

  from `edom ae \<subseteq> set L`
  have prem: "edom ae \<subseteq> set (x#L)" by auto

  from `map_of \<Gamma> x = Some e` have [simp]: "x \<in> domA \<Gamma>" by (metis domA_from_set map_of_is_SomeD)

  have "x \<notin> domA \<Delta>" by (rule reds_avoids_live[OF Variable(2), where x = x]) simp_all
  hence [simp]:"delete x \<Delta> = \<Delta>" by simp

  note IH =  Variable(3)
  let "?S" = "(- (domA ((x, z) # \<Delta>) - domA \<Gamma>))"

  have "Afix ((x, z) # \<Delta>) \<cdot> (fup\<cdot>(Aexp z)\<cdot>n \<squnion> ae)  f|` ?S = (\<mu> ae'. fup\<cdot>(Aexp z)\<cdot>(ae' x) \<squnion> ABinds \<Delta> \<cdot> ae' \<squnion> fup\<cdot>(Aexp z)\<cdot>n \<squnion> ae) f|` ?S"
    unfolding Afix_eq by simp
  also have "\<dots> \<sqsubseteq> (\<mu> ae'. ABinds \<Delta> \<cdot> ae' \<squnion> (fup\<cdot>(Aexp z)\<cdot>(n \<squnion> ae' x) \<squnion> ae)) f|` ?S"
    by (auto intro!: env_restr_mono monofun_cfun_arg cfun_belowI join_mono[OF below_refl] join_mono[OF _ below_refl] cfun_join_below simp del: join_assoc)
  also have "\<dots> = (\<mu> ae'. Afix \<Delta> \<cdot> ae' \<squnion> (fup\<cdot>(Aexp z)\<cdot>(n \<squnion> ae' x) \<squnion> ae))  f|` ?S"
    apply (rule arg_cong[where f = "\<lambda> x. x f|` ?S"] )
    apply (rule fix_eq_fix, simp_all)

    apply (subst fix_eq) back back apply simp_all
    apply (intro join_below)
    apply (simp add: below_trans[OF _ join_above2]  below_trans[OF _ join_above1])
    apply (simp add: below_trans[OF _ join_above2]  below_trans[OF _ join_above1] monofun_cfun_fun[OF Abinds_below_Afix])
    apply (simp add: below_trans[OF _ join_above2]  below_trans[OF _ join_above1])

    apply (intro join_below)
    apply (subst fix_eq, simp)
    apply (subst Afix_eq)
    apply (rule fix_least_below, simp)

    apply (subst fix_eq) back apply simp
    apply (simp add: below_trans[OF _ join_above2]  below_trans[OF _ join_above1])
    apply (subst fix_eq) back apply simp
    apply (simp add: below_trans[OF _ join_above2]  below_trans[OF _ join_above1])
    done
  also have "\<dots> = (\<mu> ae'. Afix \<Delta> \<cdot> (fup\<cdot>(Aexp z)\<cdot>(n \<squnion> ae' x) \<squnion> ae)) f|` ?S"
    apply (rule arg_cong[where f = "\<lambda> x. x f|` ?S"] )
    apply (rule fix_eq_fix, simp_all)

    apply (subst fix_eq) back back apply simp_all
    apply (intro join_below)
    apply (simp add: below_trans[OF _ join_above2]  below_trans[OF _ join_above1]  below_trans[OF _ Afix_above_arg])

    apply (subst Afix_eq)
    apply (rule fix_least_below, simp)
    apply (rule join_below)
    apply (subst fix_eq, simp)

    apply (simp add: below_trans[OF _ join_above2]  below_trans[OF _ join_above1] monofun_cfun_fun[OF Abinds_below_Afix])

    apply (subst Afix_eq) back apply simp
    apply (subst fix_eq, simp) back
    apply (simp add: below_trans[OF _ join_above2]  below_trans[OF _ join_above1])

    apply (subst fix_eq, simp) back
    apply (rule below_trans[OF _ join_above2])
    apply (rule below_trans[OF _ join_above1])
    apply (rule monofun_cfun_arg)
    apply (intro join_below)
    apply (subst fix_eq, simp)
    apply (subst fix_eq, simp) back
    apply (rule below_trans[OF _ join_above2])
    apply (rule below_trans[OF _ join_above2])
    apply rule
    done

  also have "\<dots> \<sqsubseteq> (\<mu> ae'. Afix (delete x \<Gamma>) \<cdot> (fup\<cdot>(Aexp e)\<cdot>(n \<squnion> ae' x) \<squnion> ae)) f|` ?S"
  proof (induction rule: parallel_fix_ind[where P ="\<lambda> x y. x f|` ?S \<sqsubseteq> y f|` ?S"])
  case (goal3 aeL aeR)
    have "- (domA ((x, z) # \<Delta>) - domA \<Gamma>) \<subseteq> - (domA \<Delta> - domA (delete x \<Gamma>))"
      using `x \<notin> domA \<Delta>` by auto
    moreover
    note IH[OF prem]
    ultimately have "(Afix \<Delta>\<cdot>(fup\<cdot>(Aexp z)\<cdot>(n \<squnion> aeL x) \<squnion> ae)) f|` ?S \<sqsubseteq> (Afix (delete x \<Gamma>)\<cdot>(fup\<cdot>(Aexp e)\<cdot>(n \<squnion> aeL x) \<squnion> ae)) f|` ?S"
      by (rule env_restr_below_subset)
    also from goal3 have "aeL x \<sqsubseteq>  aeR x" by (rule env_restr_belowD) simp
    finally have "Afix \<Delta>\<cdot>(fup\<cdot>(Aexp z)\<cdot>(n \<squnion> aeL x) \<squnion> ae) f|` ?S \<sqsubseteq> Afix (delete x \<Gamma>)\<cdot>(fup\<cdot>(Aexp e)\<cdot>(n \<squnion> aeR x) \<squnion> ae) f|` ?S" by this simp_all
    thus ?case by simp
  qed simp_all
  also have "\<dots> \<sqsubseteq> (\<mu> ae'. Afix ((x,e)#delete x \<Gamma>) \<cdot> (esing x \<cdot> (n \<squnion> ae' x) \<squnion> ae))  f|` ?S"
    apply (rule env_restr_mono)
    apply (rule monofun_cfun_arg)
    apply (rule cfun_belowI, simp)
    apply (rule Afix_e_to_heap[simplified])
    done
  also have "\<dots> = Afix ((x,e)#delete x \<Gamma>) \<cdot> (esing x\<cdot>n \<squnion> ae)  f|` ?S" by (rule arg_cong[OF Afix_repeat_singleton])
  also have "\<dots> \<sqsubseteq> Afix ((x,e)#delete x \<Gamma>) \<cdot> (fup\<cdot>(Aexp (Var x))\<cdot>n \<squnion> ae)  f|` ?S" by (intro fup_Aexp_Var monofun_cfun env_restr_mono join_mono below_refl)
  also have "\<dots> = Afix \<Gamma> \<cdot> (fup\<cdot>(Aexp (Var x))\<cdot>n \<squnion> ae) f|` ?S" by (rule arg_cong[OF Afix_reorder[OF reorder]])
  finally show "Afix ((x, z) # \<Delta>)\<cdot>(fup\<cdot>(Aexp z)\<cdot>n \<squnion> ae) f|` ?S \<sqsubseteq> Afix \<Gamma>\<cdot>(fup\<cdot>(Aexp (Var x))\<cdot>n \<squnion> ae) f|` ?S"
    by this simp_all
next
case (Application y \<Gamma> e x L \<Delta> \<Theta> z e' ae n)
  note prem1 =  `edom ae \<subseteq> set L`
  hence prem2: "edom ae \<subseteq> set (x#L)" by auto
  hence prem3: "edom (esing x\<cdot>(up\<cdot>0) \<squnion> ae) \<subseteq> set (x#L)" by auto

  have subset1: " (- (domA \<Theta> - domA \<Gamma>)) \<subseteq> (- (domA \<Theta> - domA \<Delta>))"
    and subset2: "(- (domA \<Theta> - domA \<Gamma>)) \<subseteq> (- (domA \<Delta> - domA \<Gamma>))"
    using reds_doesnt_forget[OF Application(2)]  reds_doesnt_forget[OF Application(4)] by auto
  let "?S" = " (- (domA \<Theta> - domA \<Gamma>))"

  show "Afix \<Theta>\<cdot>(fup\<cdot>(Aexp z)\<cdot>n \<squnion> ae) f|` ?S \<sqsubseteq> Afix \<Gamma>\<cdot>(fup\<cdot>(Aexp (App e x))\<cdot>n \<squnion> ae)  f|` ?S"
  proof(cases n)
    case bottom
    from env_restr_below_trans[OF env_restr_below_subset[OF subset1 Application(5)[OF prem1, where n = "\<bottom>"], simplified]
                                  env_restr_below_subset[OF subset2 Application(3)[OF prem2, where n = "\<bottom>"], simplified]]
    show ?thesis using bottom by simp
  next
    case (up n')
    note IH1 = env_restr_below_subset[OF subset2 Application(3)[OF prem3, where n = "inc\<^sub>\<bottom>\<cdot>n"], unfolded up inc_bot.simps fup2]
    note IH2 = env_restr_below_subset[OF subset1 Application(5)[OF prem1, where n = n], unfolded up fup2]
    have "Afix \<Theta>\<cdot>(Aexp z\<cdot>n' \<squnion> ae)  f|` ?S  \<sqsubseteq> Afix \<Delta>\<cdot>(Aexp e'[y::=x]\<cdot>n' \<squnion> ae)  f|` ?S" by (rule IH2)
    also have "\<dots> \<sqsubseteq> Afix \<Delta>\<cdot>(env_delete y (Aexp e'\<cdot>n') \<squnion>  esing x \<cdot> (up\<cdot>0) \<squnion> ae)  f|` ?S"
      by (intro monofun_cfun_arg monofun_cfun_fun env_restr_mono Aexp_subst join_mono below_refl)
    also have "\<dots> = Afix \<Delta>\<cdot>(env_delete y (Aexp e'\<cdot>(pred\<cdot>(inc\<cdot>n'))) \<squnion> (esing x \<cdot> (up\<cdot>0) \<squnion> ae))  f|` ?S" by simp
    also have "\<dots> \<sqsubseteq> Afix \<Delta>\<cdot>(Aexp (Lam [y]. e')\<cdot>(inc\<cdot>n') \<squnion> (esing x \<cdot> (up\<cdot>0) \<squnion> ae))  f|` ?S"
      by (intro monofun_cfun_arg monofun_cfun_fun env_restr_mono Aexp_Lam join_mono below_refl)
    also have "\<dots> \<sqsubseteq> Afix \<Gamma>\<cdot>(Aexp e\<cdot>(inc\<cdot>n') \<squnion> (esing x\<cdot>(up\<cdot>0) \<squnion> ae)) f|` ?S" by (rule IH1)
    also have "\<dots> = Afix \<Gamma>\<cdot>(Aexp e\<cdot>(inc\<cdot>n') \<squnion> esing x\<cdot>(up\<cdot>0) \<squnion> ae)  f|` ?S" by simp
    also have "\<dots> \<sqsubseteq> Afix \<Gamma>\<cdot>(Aexp (App e x)\<cdot>n' \<squnion> ae)  f|` ?S"
      by (intro monofun_cfun_arg monofun_cfun_fun env_restr_mono Aexp_App join_mono below_refl)
    finally
    show ?thesis unfolding up by simp
  qed
next
case (Let as \<Gamma> L e \<Delta> z ae n)
  have *: "atom ` domA as \<sharp>* \<Gamma>" using Let(1) by (metis fresh_star_Pair)

  let ?S = "(- (domA \<Delta> - domA \<Gamma>))"
  have subset: "?S \<subseteq>  (- (domA \<Delta> - domA (as @ \<Gamma>)))" by auto

  note prem = `edom ae \<subseteq> set L`
  note IH = env_restr_below_subset[OF subset Let(3)[OF prem]]

  from `atom \` domA as \<sharp>* (\<Gamma>, L)`
  have "atom ` domA as \<sharp>* set L" by (auto simp add: fresh_star_Pair set_bn_to_atom_domA fresh_star_set)
  hence "domA as \<inter> set L = {}" by (metis Int_commute disjoint_iff_not_equal fresh_list_elem fresh_set fresh_star_def image_eqI not_self_fresh)
  with prem
  have **: "ae ` domA as \<subseteq> {\<bottom>}" by (auto simp add: edom_def)

  have [simp]: "ae f|` (-domA as) = ae" apply (rule env_restr_useless) using prem `domA as \<inter> set L = {}` by auto

  from `atom \` domA as \<sharp>* \<Gamma>` have "domA as \<inter> domA \<Gamma> = {}" by (metis fresh_distinct)
  moreover from reds_doesnt_forget[OF Let(2)] have "domA as \<subseteq> domA \<Delta>" by auto
  ultimately have ***: "((- domA \<Delta> \<union> domA \<Gamma>) \<inter> - domA as) = (- domA \<Delta> \<union> domA \<Gamma>)" by auto

  have "Afix \<Delta>\<cdot>(fup\<cdot>(Aexp z)\<cdot>n \<squnion> ae)  f|` ?S \<sqsubseteq> Afix (as @ \<Gamma>)\<cdot>(fup\<cdot>(Aexp e)\<cdot>n \<squnion> ae)  f|` ?S" by (rule IH)
  also have "\<dots> = Afix \<Gamma>\<cdot>(Afix as\<cdot>(fup\<cdot>(Aexp e)\<cdot>n \<squnion> ae))  f|` ?S" by (rule arg_cong[OF Afix_append_fresh[OF *]])
  also have "\<dots> = Afix \<Gamma>\<cdot>(Afix as\<cdot>(fup\<cdot>(Aexp e)\<cdot>n) \<squnion> ae)  f|` ?S" by (rule arg_cong[OF Afix_join_fresh[OF **]])
  also have "\<dots> = Afix \<Gamma>\<cdot>(Afix as\<cdot>(fup\<cdot>(Aexp e)\<cdot>n) \<squnion> ae) f|` (- (domA as)) f|` ?S" by (simp add: ***)
  also have "\<dots> = Afix \<Gamma>\<cdot>((Afix as\<cdot>(fup\<cdot>(Aexp e)\<cdot>n) \<squnion> ae) f|` (- (domA as))) f|` (- (domA as)) f|` ?S" by (rule arg_cong[OF Afix_restr_fresh[OF *]])
  also have "\<dots> = Afix \<Gamma>\<cdot>((Afix as\<cdot>(fup\<cdot>(Aexp e)\<cdot>n) \<squnion> ae) f|` (- (domA as))) f|` ?S" by (simp add: ***)
  also have "\<dots> = Afix \<Gamma>\<cdot>((Afix as\<cdot>(fup\<cdot>(Aexp e)\<cdot>n)  f|` (- (domA as))) \<squnion> ae) f|` ?S" by (simp add: env_restr_join)
  also have "\<dots> \<sqsubseteq> Afix \<Gamma>\<cdot>(fup\<cdot>(Aexp (Let as e))\<cdot>n \<squnion> ae) f|` ?S" by (intro monofun_cfun_arg join_mono env_restr_mono below_refl fup_Aexp_Let)
  finally
  show "Afix \<Delta>\<cdot>(fup\<cdot>(Aexp z)\<cdot>n \<squnion> ae) f|` ?S \<sqsubseteq> Afix \<Gamma>\<cdot>(fup\<cdot>(Aexp (Let as e))\<cdot>n \<squnion> ae) f|` ?S" by this simp_all
qed

corollary  reds_improves_arity'':
       "\<Gamma> : e \<Down>\<^bsub>L\<^esub> \<Delta> : v \<Longrightarrow>
        edom ae \<subseteq> set L \<Longrightarrow>
        Afix \<Delta> \<cdot> (Aexp v \<cdot> n \<squnion> ae) f|` (- (domA \<Delta> - domA \<Gamma>)) \<sqsubseteq> Afix \<Gamma> \<cdot> (Aexp e \<cdot> n \<squnion> ae) f|` (- (domA \<Delta> - domA \<Gamma>))"
using reds_improves_arity'[OF assms, where n = "up\<cdot>n", simplified] by simp

corollary  reds_improves_arity:
  assumes "\<Gamma> : e \<Down>\<^bsub>L\<^esub> \<Delta> : v"
  shows "Afix \<Delta> \<cdot> (fup\<cdot>(Aexp v) \<cdot> n) f|` (- (domA \<Delta> - domA \<Gamma>)) \<sqsubseteq> Afix \<Gamma> \<cdot> (fup\<cdot>(Aexp e) \<cdot> n) f|` (- (domA \<Delta> - domA \<Gamma>))"
  using reds_improves_arity'[where ae = \<bottom>, OF assms] by simp
end

end


chapter \<open>Definition\<close>

theory %invisible Definition
imports Main
begin

text \<open>\label{chap:definition}\<close>

text \<open>In stepwise refinement~\<^cite>\<open>"DijkstraConstructive" and "WirthRefinement"\<close>,
a program is derived from a specification
via a sequence of intermediate specifications.\<close>

text \<open>Pop-refinement (where `pop' stands for `predicates over programs')
is an approach to stepwise refinement,
carried out inside an interactive theorem prover
(e.g.\ Isabelle/HOL, HOL4, Coq, PVS, ACL2)
as follows:
\begin{enumerate}
\item
Formalize the syntax and semantics
of (the needed subset of) the target programming language (and libraries),
as a deep embedding.
\item
Specify the requirements
by defining a predicate over programs
that characterizes the possible implementations.
\item
Refine the specification stepwise
by defining monotonically decreasing predicates over programs
(decreasing with respect to inclusion, i.e.\ logical implication),
according to decisions that narrow down the possible implementations.
\item
Conclude the derivation
with a predicate that characterizes a unique program in explicit syntactic form,
from which the program text is readily obtained.
\end{enumerate}\<close>

end %invisible


(*  Title:      ZF/AC/WO6_WO1.thy
    Author:     Krzysztof Grabczewski

Proofs needed to state that formulations WO1,...,WO6 are all equivalent.
The only hard one is WO6 ==> WO1.

Every proof (except WO6 ==> WO1 and WO1 ==> WO2) are described as "clear"
by Rubin & Rubin (page 2).
They refer reader to a book by Gödel to see the proof WO1 ==> WO2.
Fortunately order types made this proof also very easy.
*)

theory WO6_WO1
imports Cardinal_aux
begin

(* Auxiliary definitions used in proof *)
definition
  NN  :: "i => i"  where
    "NN(y) == {m \<in> nat. \<exists>a. \<exists>f. Ord(a) & domain(f)=a  &
                        (\<Union>b<a. f`b) = y & (\<forall>b<a. f`b \<lesssim> m)}"

definition
  uu  :: "[i, i, i, i] => i"  where
    "uu(f, beta, gamma, delta) == (f`beta * f`gamma) \<inter> f`delta"

(** Definitions for case 1 **)
definition
  vv1 :: "[i, i, i] => i"  where
     "vv1(f,m,b) ==
           let g = \<mu> g. (\<exists>d. Ord(d) & (domain(uu(f,b,g,d)) \<noteq> 0 &
                                 domain(uu(f,b,g,d)) \<lesssim> m));
               d = \<mu> d. domain(uu(f,b,g,d)) \<noteq> 0 &
                            domain(uu(f,b,g,d)) \<lesssim> m
           in  if f`b \<noteq> 0 then domain(uu(f,b,g,d)) else 0"

definition
  ww1 :: "[i, i, i] => i"  where
     "ww1(f,m,b) == f`b - vv1(f,m,b)"

definition
  gg1 :: "[i, i, i] => i"  where
     "gg1(f,a,m) == \<lambda>b \<in> a++a. if b<a then vv1(f,m,b) else ww1(f,m,b--a)"

(** Definitions for case 2 **)
definition
  vv2 :: "[i, i, i, i] => i"  where
     "vv2(f,b,g,s) ==
           if f`g \<noteq> 0 then {uu(f, b, g, \<mu> d. uu(f,b,g,d) \<noteq> 0)`s} else 0"

definition
  ww2 :: "[i, i, i, i] => i"  where
     "ww2(f,b,g,s) == f`g - vv2(f,b,g,s)"

definition
  gg2 :: "[i, i, i, i] => i"  where
     "gg2(f,a,b,s) ==
              \<lambda>g \<in> a++a. if g<a then vv2(f,b,g,s) else ww2(f,b,g--a,s)"

lemma WO2_WO3: "WO2 ==> WO3"
by (unfold WO2_def WO3_def, fast)

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

lemma WO3_WO1: "WO3 ==> WO1"
apply (unfold eqpoll_def WO1_def WO3_def)
apply (intro allI)
apply (drule_tac x=A in spec)
apply (blast intro: bij_is_inj well_ord_rvimage
                    well_ord_Memrel [THEN well_ord_subset])
done

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

lemma WO1_WO2: "WO1 ==> WO2"
apply (unfold eqpoll_def WO1_def WO2_def)
apply (blast intro!: Ord_ordertype ordermap_bij)
done

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

lemma lam_sets: "f \<in> A->B ==> (\<lambda>x \<in> A. {f`x}): A -> {{b}. b \<in> B}"
by (fast intro!: lam_type apply_type)

lemma surj_imp_eq': "f \<in> surj(A,B) ==> (\<Union>a \<in> A. {f`a}) = B"
apply (unfold surj_def)
apply (fast elim!: apply_type)
done

lemma surj_imp_eq: "[| f \<in> surj(A,B); Ord(A) |] ==> (\<Union>a<A. {f`a}) = B"
by (fast dest!: surj_imp_eq' intro!: ltI elim!: ltE)

lemma WO1_WO4: "WO1 ==> WO4(1)"
apply (unfold WO1_def WO4_def)
apply (rule allI)
apply (erule_tac x = A in allE)
apply (erule exE)
apply (intro exI conjI)
apply (erule Ord_ordertype)
apply (erule ordermap_bij [THEN bij_converse_bij, THEN bij_is_fun, THEN lam_sets, THEN domain_of_fun])
apply (simp_all add: singleton_eqpoll_1 eqpoll_imp_lepoll Ord_ordertype
       ordermap_bij [THEN bij_converse_bij, THEN bij_is_surj, THEN surj_imp_eq]
       ltD)
done

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

lemma WO4_mono: "[| m\<le>n; WO4(m) |] ==> WO4(n)"
apply (unfold WO4_def)
apply (blast dest!: spec intro: lepoll_trans [OF _ le_imp_lepoll])
done

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

lemma WO4_WO5: "[| m \<in> nat; 1\<le>m; WO4(m) |] ==> WO5"
by (unfold WO4_def WO5_def, blast)

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

lemma WO5_WO6: "WO5 ==> WO6"
by (unfold WO4_def WO5_def WO6_def, blast)

(* **********************************************************************
    The proof of "WO6 ==> WO1".  Simplified by L C Paulson.

    From the book "Equivalents of the Axiom of Choice" by Rubin & Rubin,
    pages 2-5
************************************************************************* *)

lemma lt_oadd_odiff_disj:
      "[| k < i++j;  Ord(i);  Ord(j) |]
       ==> k < i  |  (~ k<i & k = i ++ (k--i) & (k--i)<j)"
apply (rule_tac i = k and j = i in Ord_linear2)
prefer 4
   apply (drule odiff_lt_mono2, assumption)
   apply (simp add: oadd_odiff_inverse odiff_oadd_inverse)
apply (auto elim!: lt_Ord)
done

(* ********************************************************************** *)
(* The most complicated part of the proof - lemma ii - p. 2-4             *)
(* ********************************************************************** *)

(* ********************************************************************** *)
(* some properties of relation uu(beta, gamma, delta) - p. 2              *)
(* ********************************************************************** *)

lemma domain_uu_subset: "domain(uu(f,b,g,d)) \<subseteq> f`b"
by (unfold uu_def, blast)

lemma quant_domain_uu_lepoll_m:
     "\<forall>b<a. f`b \<lesssim> m ==> \<forall>b<a. \<forall>g<a. \<forall>d<a. domain(uu(f,b,g,d)) \<lesssim> m"
by (blast intro: domain_uu_subset [THEN subset_imp_lepoll] lepoll_trans)

lemma uu_subset1: "uu(f,b,g,d) \<subseteq> f`b * f`g"
by (unfold uu_def, blast)

lemma uu_subset2: "uu(f,b,g,d) \<subseteq> f`d"
by (unfold uu_def, blast)

lemma uu_lepoll_m: "[| \<forall>b<a. f`b \<lesssim> m;  d<a |] ==> uu(f,b,g,d) \<lesssim> m"
by (blast intro: uu_subset2 [THEN subset_imp_lepoll] lepoll_trans)

(* ********************************************************************** *)
(* Two cases for lemma ii                                                 *)
(* ********************************************************************** *)
lemma cases:
     "\<forall>b<a. \<forall>g<a. \<forall>d<a. u(f,b,g,d) \<lesssim> m
      ==> (\<forall>b<a. f`b \<noteq> 0 \<longrightarrow>
                  (\<exists>g<a. \<exists>d<a. u(f,b,g,d) \<noteq> 0 & u(f,b,g,d) \<prec> m))
        | (\<exists>b<a. f`b \<noteq> 0 & (\<forall>g<a. \<forall>d<a. u(f,b,g,d) \<noteq> 0 \<longrightarrow>
                                        u(f,b,g,d) \<approx> m))"
apply (unfold lesspoll_def)
apply (blast del: equalityI)
done

(* ********************************************************************** *)
(* Lemmas used in both cases                                              *)
(* ********************************************************************** *)
lemma UN_oadd: "Ord(a) ==> (\<Union>b<a++a. C(b)) = (\<Union>b<a. C(b) \<union> C(a++b))"
by (blast intro: ltI lt_oadd1 oadd_lt_mono2 dest!: lt_oadd_disj)

(* ********************************************************************** *)
(* Case 1: lemmas                                                        *)
(* ********************************************************************** *)

lemma vv1_subset: "vv1(f,m,b) \<subseteq> f`b"
by (simp add: vv1_def Let_def domain_uu_subset)

(* ********************************************************************** *)
(* Case 1: Union of images is the whole "y"                              *)
(* ********************************************************************** *)
lemma UN_gg1_eq:
  "[| Ord(a);  m \<in> nat |] ==> (\<Union>b<a++a. gg1(f,a,m)`b) = (\<Union>b<a. f`b)"
by (simp add: gg1_def UN_oadd lt_oadd1 oadd_le_self [THEN le_imp_not_lt]
              lt_Ord odiff_oadd_inverse ltD vv1_subset [THEN Diff_partition]
              ww1_def)

lemma domain_gg1: "domain(gg1(f,a,m)) = a++a"
by (simp add: lam_funtype [THEN domain_of_fun] gg1_def)

(* ********************************************************************** *)
(* every value of defined function is less than or equipollent to m       *)
(* ********************************************************************** *)
lemma nested_LeastI:
     "[| P(a, b);  Ord(a);  Ord(b);
         Least_a = (\<mu> a. \<exists>x. Ord(x) & P(a, x)) |]
      ==> P(Least_a, \<mu> b. P(Least_a, b))"
apply (erule ssubst)
apply (rule_tac Q = "%z. P (z, \<mu> b. P (z, b))" in LeastI2)
apply (fast elim!: LeastI)+
done

lemmas nested_Least_instance =
       nested_LeastI [of "%g d. domain(uu(f,b,g,d)) \<noteq> 0 &
                                domain(uu(f,b,g,d)) \<lesssim> m"] for f b m

lemma gg1_lepoll_m:
     "[| Ord(a);  m \<in> nat;
         \<forall>b<a. f`b \<noteq>0 \<longrightarrow>
             (\<exists>g<a. \<exists>d<a. domain(uu(f,b,g,d)) \<noteq> 0  &
                          domain(uu(f,b,g,d)) \<lesssim> m);
         \<forall>b<a. f`b \<lesssim> succ(m);  b<a++a |]
      ==> gg1(f,a,m)`b \<lesssim> m"
apply (simp add: gg1_def empty_lepollI)
apply (safe dest!: lt_oadd_odiff_disj)
(*Case b<a   \<in> show vv1(f,m,b) \<lesssim> m *)
 apply (simp add: vv1_def Let_def empty_lepollI)
 apply (fast intro: nested_Least_instance [THEN conjunct2]
             elim!: lt_Ord)
(*Case a\<le>b \<in> show ww1(f,m,b--a) \<lesssim> m *)
apply (simp add: ww1_def empty_lepollI)
apply (case_tac "f` (b--a) = 0", simp add: empty_lepollI)
apply (rule Diff_lepoll, blast)
apply (rule vv1_subset)
apply (drule ospec [THEN mp], assumption+)
apply (elim oexE conjE)
apply (simp add: vv1_def Let_def lt_Ord nested_Least_instance [THEN conjunct1])
done

(* ********************************************************************** *)
(* Case 2: lemmas                                                        *)
(* ********************************************************************** *)

(* ********************************************************************** *)
(* Case 2: vv2_subset                                                    *)
(* ********************************************************************** *)

lemma ex_d_uu_not_empty:
     "[| b<a;  g<a;  f`b\<noteq>0;  f`g\<noteq>0;
         y*y \<subseteq> y;  (\<Union>b<a. f`b)=y |]
      ==> \<exists>d<a. uu(f,b,g,d) \<noteq> 0"
by (unfold uu_def, blast)

lemma uu_not_empty:
     "[| b<a; g<a; f`b\<noteq>0; f`g\<noteq>0;  y*y \<subseteq> y; (\<Union>b<a. f`b)=y |]
      ==> uu(f,b,g,\<mu> d. (uu(f,b,g,d) \<noteq> 0)) \<noteq> 0"
apply (drule ex_d_uu_not_empty, assumption+)
apply (fast elim!: LeastI lt_Ord)
done

lemma not_empty_rel_imp_domain: "[| r \<subseteq> A*B; r\<noteq>0 |] ==> domain(r)\<noteq>0"
by blast

lemma Least_uu_not_empty_lt_a:
     "[| b<a; g<a; f`b\<noteq>0; f`g\<noteq>0; y*y \<subseteq> y; (\<Union>b<a. f`b)=y |]
      ==> (\<mu> d. uu(f,b,g,d) \<noteq> 0) < a"
apply (erule ex_d_uu_not_empty [THEN oexE], assumption+)
apply (blast intro: Least_le [THEN lt_trans1] lt_Ord)
done

lemma subset_Diff_sing: "[| B \<subseteq> A; a\<notin>B |] ==> B \<subseteq> A-{a}"
by blast

(*Could this be proved more directly?*)
lemma supset_lepoll_imp_eq:
     "[| A \<lesssim> m; m \<lesssim> B; B \<subseteq> A; m \<in> nat |] ==> A=B"
apply (erule natE)
apply (fast dest!: lepoll_0_is_0 intro!: equalityI)
apply (safe intro!: equalityI)
apply (rule ccontr)
apply (rule succ_lepoll_natE)
 apply (erule lepoll_trans)
 apply (rule lepoll_trans)
  apply (erule subset_Diff_sing [THEN subset_imp_lepoll], assumption)
 apply (rule Diff_sing_lepoll, assumption+)
done

lemma uu_Least_is_fun:
     "[| \<forall>g<a. \<forall>d<a. domain(uu(f, b, g, d))\<noteq>0 \<longrightarrow>
          domain(uu(f, b, g, d)) \<approx> succ(m);
          \<forall>b<a. f`b \<lesssim> succ(m);  y*y \<subseteq> y;
          (\<Union>b<a. f`b)=y;  b<a;  g<a;  d<a;
          f`b\<noteq>0;  f`g\<noteq>0;  m \<in> nat;  s \<in> f`b |]
      ==> uu(f, b, g, \<mu> d. uu(f,b,g,d)\<noteq>0) \<in> f`b -> f`g"
apply (drule_tac x2=g in ospec [THEN ospec, THEN mp])
   apply (rule_tac [3] not_empty_rel_imp_domain [OF uu_subset1 uu_not_empty])
        apply (rule_tac [2] Least_uu_not_empty_lt_a, assumption+)
apply (rule rel_is_fun)
    apply (erule eqpoll_sym [THEN eqpoll_imp_lepoll])
   apply (erule uu_lepoll_m)
   apply (rule Least_uu_not_empty_lt_a, assumption+)
apply (rule uu_subset1)
apply (rule supset_lepoll_imp_eq [OF _ eqpoll_sym [THEN eqpoll_imp_lepoll]])
apply (fast intro!: domain_uu_subset)+
done

lemma vv2_subset:
     "[| \<forall>g<a. \<forall>d<a. domain(uu(f, b, g, d))\<noteq>0 \<longrightarrow>
                       domain(uu(f, b, g, d)) \<approx> succ(m);
         \<forall>b<a. f`b \<lesssim> succ(m); y*y \<subseteq> y;
         (\<Union>b<a. f`b)=y;  b<a;  g<a;  m \<in> nat;  s \<in> f`b |]
      ==> vv2(f,b,g,s) \<subseteq> f`g"
apply (simp add: vv2_def)
apply (blast intro: uu_Least_is_fun [THEN apply_type])
done

(* ********************************************************************** *)
(* Case 2: Union of images is the whole "y"                              *)
(* ********************************************************************** *)
lemma UN_gg2_eq:
     "[| \<forall>g<a. \<forall>d<a. domain(uu(f,b,g,d)) \<noteq> 0 \<longrightarrow>
               domain(uu(f,b,g,d)) \<approx> succ(m);
         \<forall>b<a. f`b \<lesssim> succ(m); y*y \<subseteq> y;
         (\<Union>b<a. f`b)=y;  Ord(a);  m \<in> nat;  s \<in> f`b;  b<a |]
      ==> (\<Union>g<a++a. gg2(f,a,b,s) ` g) = y"
apply (unfold gg2_def)
apply (drule sym)
apply (simp add: ltD UN_oadd  oadd_le_self [THEN le_imp_not_lt]
                 lt_Ord odiff_oadd_inverse ww2_def
                 vv2_subset [THEN Diff_partition])
done

lemma domain_gg2: "domain(gg2(f,a,b,s)) = a++a"
by (simp add: lam_funtype [THEN domain_of_fun] gg2_def)

(* ********************************************************************** *)
(* every value of defined function is less than or equipollent to m       *)
(* ********************************************************************** *)

lemma vv2_lepoll: "[| m \<in> nat; m\<noteq>0 |] ==> vv2(f,b,g,s) \<lesssim> m"
apply (unfold vv2_def)
apply (simp add: empty_lepollI)
apply (fast dest!: le_imp_subset [THEN subset_imp_lepoll, THEN lepoll_0_is_0]
       intro!: singleton_eqpoll_1 [THEN eqpoll_imp_lepoll, THEN lepoll_trans]
               not_lt_imp_le [THEN le_imp_subset, THEN subset_imp_lepoll]
               nat_into_Ord nat_1I)
done

lemma ww2_lepoll:
    "[| \<forall>b<a. f`b \<lesssim> succ(m);  g<a;  m \<in> nat;  vv2(f,b,g,d) \<subseteq> f`g |]
     ==> ww2(f,b,g,d) \<lesssim> m"
apply (unfold ww2_def)
apply (case_tac "f`g = 0")
apply (simp add: empty_lepollI)
apply (drule ospec, assumption)
apply (rule Diff_lepoll, assumption+)
apply (simp add: vv2_def not_emptyI)
done

lemma gg2_lepoll_m:
     "[| \<forall>g<a. \<forall>d<a. domain(uu(f,b,g,d)) \<noteq> 0 \<longrightarrow>
                      domain(uu(f,b,g,d)) \<approx> succ(m);
         \<forall>b<a. f`b \<lesssim> succ(m);  y*y \<subseteq> y;
         (\<Union>b<a. f`b)=y;  b<a;  s \<in> f`b;  m \<in> nat;  m\<noteq> 0;  g<a++a |]
      ==> gg2(f,a,b,s) ` g \<lesssim> m"
apply (simp add: gg2_def empty_lepollI)
apply (safe elim!: lt_Ord2 dest!: lt_oadd_odiff_disj)
 apply (simp add: vv2_lepoll)
apply (simp add: ww2_lepoll vv2_subset)
done

(* ********************************************************************** *)
(* lemma ii                                                               *)
(* ********************************************************************** *)
lemma lemma_ii: "[| succ(m) \<in> NN(y); y*y \<subseteq> y; m \<in> nat; m\<noteq>0 |] ==> m \<in> NN(y)"
apply (unfold NN_def)
apply (elim CollectE exE conjE)
apply (rule quant_domain_uu_lepoll_m [THEN cases, THEN disjE], assumption)
(* case 1 *)
apply (simp add: lesspoll_succ_iff)
apply (rule_tac x = "a++a" in exI)
apply (fast intro!: Ord_oadd domain_gg1 UN_gg1_eq gg1_lepoll_m)
(* case 2 *)
apply (elim oexE conjE)
apply (rule_tac A = "f`B" for B in not_emptyE, assumption)
apply (rule CollectI)
apply (erule succ_natD)
apply (rule_tac x = "a++a" in exI)
apply (rule_tac x = "gg2 (f,a,b,x) " in exI)
apply (simp add: Ord_oadd domain_gg2 UN_gg2_eq gg2_lepoll_m)
done

(* ********************************************************************** *)
(* lemma iv - p. 4:                                                       *)
(* For every set x there is a set y such that   x \<union> (y * y) \<subseteq> y         *)
(* ********************************************************************** *)

(* The leading \<forall>-quantifier looks odd but makes the proofs shorter
   (used only in the following two lemmas)                          *)

lemma z_n_subset_z_succ_n:
     "\<forall>n \<in> nat. rec(n, x, %k r. r \<union> r*r) \<subseteq> rec(succ(n), x, %k r. r \<union> r*r)"
by (fast intro: rec_succ [THEN ssubst])

lemma le_subsets:
     "[| \<forall>n \<in> nat. f(n)<=f(succ(n)); n\<le>m; n \<in> nat; m \<in> nat |]
      ==> f(n)<=f(m)"
apply (erule_tac P = "n\<le>m" in rev_mp)
apply (rule_tac P = "%z. n\<le>z \<longrightarrow> f (n) \<subseteq> f (z) " in nat_induct)
apply (auto simp add: le_iff)
done

lemma le_imp_rec_subset:
     "[| n\<le>m; m \<in> nat |]
      ==> rec(n, x, %k r. r \<union> r*r) \<subseteq> rec(m, x, %k r. r \<union> r*r)"
apply (rule z_n_subset_z_succ_n [THEN le_subsets])
apply (blast intro: lt_nat_in_nat)+
done

lemma lemma_iv: "\<exists>y. x \<union> y*y \<subseteq> y"
apply (rule_tac x = "\<Union>n \<in> nat. rec (n, x, %k r. r \<union> r*r) " in exI)
apply safe
apply (rule nat_0I [THEN UN_I], simp)
apply (rule_tac a = "succ (n \<union> na) " in UN_I)
apply (erule Un_nat_type [THEN nat_succI], assumption)
apply (auto intro: le_imp_rec_subset [THEN subsetD]
            intro!: Un_upper1_le Un_upper2_le Un_nat_type
            elim!: nat_into_Ord)
done

(* ********************************************************************** *)
(* Rubin & Rubin wrote,                                                   *)
(* "It follows from (ii) and mathematical induction that if y*y \<subseteq> y then *)
(* y can be well-ordered"                                                 *)

(* In fact we have to prove                                               *)
(*      * WO6 ==> NN(y) \<noteq> 0                                              *)
(*      * reverse induction which lets us infer that 1 \<in> NN(y)            *)
(*      * 1 \<in> NN(y) ==> y can be well-ordered                             *)
(* ********************************************************************** *)

(* ********************************************************************** *)
(*      WO6 ==> NN(y) \<noteq> 0                                                *)
(* ********************************************************************** *)

lemma WO6_imp_NN_not_empty: "WO6 ==> NN(y) \<noteq> 0"
by (unfold WO6_def NN_def, clarify, blast)

(* ********************************************************************** *)
(*      1 \<in> NN(y) ==> y can be well-ordered                               *)
(* ********************************************************************** *)

lemma lemma1:
     "[| (\<Union>b<a. f`b)=y; x \<in> y; \<forall>b<a. f`b \<lesssim> 1; Ord(a) |] ==> \<exists>c<a. f`c = {x}"
by (fast elim!: lepoll_1_is_sing)

lemma lemma2:
     "[| (\<Union>b<a. f`b)=y; x \<in> y; \<forall>b<a. f`b \<lesssim> 1; Ord(a) |]
      ==> f` (\<mu> i. f`i = {x}) = {x}"
apply (drule lemma1, assumption+)
apply (fast elim!: lt_Ord intro: LeastI)
done

lemma NN_imp_ex_inj: "1 \<in> NN(y) ==> \<exists>a f. Ord(a) & f \<in> inj(y, a)"
apply (unfold NN_def)
apply (elim CollectE exE conjE)
apply (rule_tac x = a in exI)
apply (rule_tac x = "\<lambda>x \<in> y. \<mu> i. f`i = {x}" in exI)
apply (rule conjI, assumption)
apply (rule_tac d = "%i. THE x. x \<in> f`i" in lam_injective)
apply (drule lemma1, assumption+)
apply (fast elim!: Least_le [THEN lt_trans1, THEN ltD] lt_Ord)
apply (rule lemma2 [THEN ssubst], assumption+, blast)
done

lemma y_well_ord: "[| y*y \<subseteq> y; 1 \<in> NN(y) |] ==> \<exists>r. well_ord(y, r)"
apply (drule NN_imp_ex_inj)
apply (fast elim!: well_ord_rvimage [OF _ well_ord_Memrel])
done

(* ********************************************************************** *)
(*      reverse induction which lets us infer that 1 \<in> NN(y)              *)
(* ********************************************************************** *)

lemma rev_induct_lemma [rule_format]:
     "[| n \<in> nat; !!m. [| m \<in> nat; m\<noteq>0; P(succ(m)) |] ==> P(m) |]
      ==> n\<noteq>0 \<longrightarrow> P(n) \<longrightarrow> P(1)"
by (erule nat_induct, blast+)

lemma rev_induct:
     "[| n \<in> nat;  P(n);  n\<noteq>0;
         !!m. [| m \<in> nat; m\<noteq>0; P(succ(m)) |] ==> P(m) |]
      ==> P(1)"
by (rule rev_induct_lemma, blast+)

lemma NN_into_nat: "n \<in> NN(y) ==> n \<in> nat"
by (simp add: NN_def)

lemma lemma3: "[| n \<in> NN(y); y*y \<subseteq> y; n\<noteq>0 |] ==> 1 \<in> NN(y)"
apply (rule rev_induct [OF NN_into_nat], assumption+)
apply (rule lemma_ii, assumption+)
done

(* ********************************************************************** *)
(* Main theorem "WO6 ==> WO1"                                             *)
(* ********************************************************************** *)

(* another helpful lemma *)
lemma NN_y_0: "0 \<in> NN(y) ==> y=0"
apply (unfold NN_def)
apply (fast intro!: equalityI dest!: lepoll_0_is_0 elim: subst)
done

lemma WO6_imp_WO1: "WO6 ==> WO1"
apply (unfold WO1_def)
apply (rule allI)
apply (case_tac "A=0")
apply (fast intro!: well_ord_Memrel nat_0I [THEN nat_into_Ord])
apply (rule_tac x = A in lemma_iv [elim_format])
apply (erule exE)
apply (drule WO6_imp_NN_not_empty)
apply (erule Un_subset_iff [THEN iffD1, THEN conjE])
apply (erule_tac A = "NN (y) " in not_emptyE)
apply (frule y_well_ord)
 apply (fast intro!: lemma3 dest!: NN_y_0 elim!: not_emptyE)
apply (fast elim: well_ord_subset)
done

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
subsubsection \<open>Transport for Partial Quotient Types\<close>
theory Transport_Partial_Quotient_Types
  imports
    HOL.Lifting
    Transport.Transport
begin

paragraph \<open>Summary\<close>
text \<open>Every partial quotient type @{term Quotient}, as used by the Lifting
package, is transportable.\<close>

context transport
begin

interpretation t : transport L "(=)" l r .

lemma Quotient_T_eq_Galois:
  assumes "Quotient (\<le>\<^bsub>L\<^esub>) l r T"
  shows "T = t.Galois"
proof (intro ext iffI)
  fix x y assume "T x y"
  with assms have "x \<le>\<^bsub>L\<^esub> x" "l x = y" using Quotient_cr_rel by auto
  with assms have "r (l x) \<le>\<^bsub>L\<^esub> x" "r (l x) \<le>\<^bsub>L\<^esub> r y"
    using Quotient_rep_abs Quotient_rep_reflp by auto
  with assms have "x \<le>\<^bsub>L\<^esub> r y" using Quotient_part_equivp
    by (blast elim: part_equivpE dest: transpD sympD)
  then show "t.Galois x y" by blast
next
  fix x y assume "t.Galois x y"
  with assms show "T x y" using Quotient_cr_rel Quotient_refl1 Quotient_symp
    by (fastforce intro: Quotient_rel_abs2[symmetric] dest: sympD)
qed

lemma Quotient_if_preorder_equivalence:
  assumes "((\<le>\<^bsub>L\<^esub>) \<equiv>\<^bsub>pre\<^esub> (=)) l r"
  shows "Quotient (\<le>\<^bsub>L\<^esub>) l r t.Galois"
proof (rule QuotientI)
  from assms show "l (r y) = y" for y by fast
  from assms show "r y \<le>\<^bsub>L\<^esub> r y" for y by blast
  show "x \<le>\<^bsub>L\<^esub> x' \<longleftrightarrow> x \<le>\<^bsub>L\<^esub> x \<and> x' \<le>\<^bsub>L\<^esub> x' \<and> l x = l x'"
    (is "?lhs \<longleftrightarrow> ?rhs") for x x'
  proof (rule iffI)
    assume ?rhs
    with assms have "\<eta> x \<le>\<^bsub>L\<^esub> \<eta> x'" by fastforce
    moreover from \<open>?rhs\<close> assms have "x \<le>\<^bsub>L\<^esub> \<eta> x" "\<eta> x' \<le>\<^bsub>L\<^esub> x'"
      by (blast elim: t.preorder_equivalence_order_equivalenceE)+
    moreover from assms have "transitive (\<le>\<^bsub>L\<^esub>)" by blast
    ultimately show "x \<le>\<^bsub>L\<^esub> x'" by blast
  next
    assume ?lhs
    with assms show ?rhs by blast
  qed
  from assms show "t.Galois = (\<lambda>x y. x \<le>\<^bsub>L\<^esub> x \<and> l x = y)"
    by (intro ext iffI)
    (blast elim!: t.GaloisE,
    auto intro!: t.Galois_left_if_left_rel_if_inflationary_on_in_fieldI
      elim!: t.preorder_equivalence_order_equivalenceE)
qed

lemma partial_equivalence_rel_equivalence_if_Quotient:
  assumes "Quotient (\<le>\<^bsub>L\<^esub>) l r T"
  shows "((\<le>\<^bsub>L\<^esub>) \<equiv>\<^bsub>PER\<^esub> (=)) l r"
proof (rule t.partial_equivalence_rel_equivalence_if_order_equivalenceI)
  from Quotient_part_equivp[OF assms] show "partial_equivalence_rel (\<le>\<^bsub>L\<^esub>)"
    by (blast elim: part_equivpE dest: transpD sympD)
  have "x \<equiv>\<^bsub>L\<^esub> r (l x)" if "in_field (\<le>\<^bsub>L\<^esub>) x" for x
  proof -
    from assms \<open>in_field (\<le>\<^bsub>L\<^esub>) x\<close> have "x \<le>\<^bsub>L\<^esub> x"
      using Quotient_refl1 Quotient_refl2 by fastforce
    with assms Quotient_rep_abs Quotient_symp show ?thesis
      by (fastforce dest: sympD)
  qed
  with assms show "((\<le>\<^bsub>L\<^esub>) \<equiv>\<^sub>o (=)) l r"
    using Quotient_abs_rep Quotient_rel_abs Quotient_rep_reflp
      Quotient_abs_rep[symmetric]
    by (intro t.order_equivalenceI dep_mono_wrt_relI rel_equivalence_onI
      inflationary_onI deflationary_onI)
    auto
qed auto

corollary Quotient_iff_partial_equivalence_rel_equivalence:
  "Quotient (\<le>\<^bsub>L\<^esub>) l r t.Galois \<longleftrightarrow> ((\<le>\<^bsub>L\<^esub>) \<equiv>\<^bsub>PER\<^esub> (=)) l r"
  using Quotient_if_preorder_equivalence partial_equivalence_rel_equivalence_if_Quotient
  by blast

corollary Quotient_T_eq_flip_Galois:
  assumes "Quotient (\<le>\<^bsub>L\<^esub>) l r T"
  shows "T = t.flip_Galois\<inverse>"
  using assms
  by (subst t.inv_flip_Galois_eq_Galois_if_symmetric_if_in_codom_eq_in_dom_if_galois_prop)
  (blast dest: partial_equivalence_rel_equivalence_if_Quotient
  intro: in_codom_eq_in_dom_if_reflexive_on_in_field Quotient_T_eq_Galois)+

end

end


theory Normalized_Zone_Semantics_Certification
  imports TA_Impl.Normalized_Zone_Semantics_Impl_Semantic_Refinement
begin

no_notation TA_Start_Defs.step_impl' ("\<langle>_, _\<rangle> \<leadsto>\<^bsub>_\<^esub> \<langle>_, _\<rangle>" [61,61,61] 61)

context TA_Start_Defs
begin

definition
  "E_precise_op l r g l' M \<equiv>
    let
      M' = FW' (abstr_upd (inv_of A l) (up_canonical_upd M n)) n;
      M'' = FW' (abstr_upd (inv_of A l') (reset'_upd (FW' (abstr_upd g M') n) n r 0)) n
    in M''"

definition
  "E_precise_op' l r g l' M \<equiv>
    let
      M1 = abstr_repair (inv_of A l) (up_canonical_upd M n);
      M2 = filter_diag (\<lambda> M. abstr_repair g M) M1;
      M3 = filter_diag (\<lambda> M. abstr_repair (inv_of A l') (reset'_upd M n r 0)) M2
    in M3"

lemma E_precise_op'_alt_def:
  "E_precise_op' l r g l' M \<equiv>
    let
      M' = abstr_repair (inv_of A l) (up_canonical_upd M n);
      f1 = \<lambda> M. abstr_repair g M;
      f2 = \<lambda> M. abstr_repair (inv_of A l') (reset'_upd M n r 0)
    in filter_diag (filter_diag f2 o f1) M'"
  unfolding E_precise_op'_def filter_diag_def
  by (rule HOL.eq_reflection) (auto simp: Let_def check_diag_marker)

no_notation step_impl' ("\<langle>_, _\<rangle> \<leadsto>\<^bsub>_\<^esub> \<langle>_, _\<rangle>" [61,61,61] 61)

abbreviation step_impl_precise ("\<langle>_, _\<rangle> \<leadsto>\<^bsub>_\<^esub> \<langle>_, _\<rangle>" [61,61,61] 61)
where
  "\<langle>l, Z\<rangle> \<leadsto>\<^bsub>a\<^esub> \<langle>l'', Z''\<rangle> \<equiv> \<exists> l' Z'.
    A \<turnstile>\<^sub>I \<langle>l, Z\<rangle> \<leadsto>\<^bsub>n,\<tau>\<^esub> \<langle>l', Z'\<rangle> \<and> A \<turnstile>\<^sub>I \<langle>l', Z'\<rangle> \<leadsto>\<^bsub>n,\<upharpoonleft>a\<^esub> \<langle>l'', Z''\<rangle>"

(* sublocale Graph_Defs "\<lambda> (l, u) (l', u'). conv_A A \<turnstile>' \<langle>l, u\<rangle> \<rightarrow> \<langle>l', u'\<rangle>" . *)

definition "E_precise \<equiv> (\<lambda>(l, Z) (l'', Z''). \<exists>a. \<langle>l, Z\<rangle> \<leadsto>\<^bsub>a\<^esub> \<langle>l'', Z''\<rangle>)"

end

locale E_Precise_Bisim = E_From_Op +
  assumes op_bisim:
    "A \<turnstile> l \<longrightarrow>\<^bsup>g,a,r\<^esup> l' \<Longrightarrow> wf_dbm M \<Longrightarrow> f l r g l' M \<simeq> E_precise_op l r g l' M"
    and op_wf:
    "A \<turnstile> l \<longrightarrow>\<^bsup>g,a,r\<^esup> l' \<Longrightarrow> wf_dbm M \<Longrightarrow> wf_dbm (f l r g l' M)"
begin

lemma E_precise_E_op:
  "E_precise = (\<lambda>(l, M) (l', M'''). \<exists>g a r. A \<turnstile> l \<longrightarrow>\<^bsup>g,a,r\<^esup> l' \<and> M''' = E_precise_op l r g l' M)"
  unfolding E_precise_op_def E_precise_def by (intro ext) (auto elim!: step_impl.cases)

lemma E_E_from_op_step:
  "\<exists>c. E_from_op a c \<and> b \<sim> c" if "E_precise a b" "wf_state a"
  using that unfolding E_precise_E_op E_from_op_def wf_state_def state_equiv_def
  by (blast intro: op_bisim dbm_equiv_sym)

lemma E_from_op_E_step:
  "\<exists>c. E_precise a c \<and> b \<sim> c" if "E_from_op a b" "wf_state a"
  using that unfolding E_precise_E_op E_from_op_def wf_state_def state_equiv_def
  by (blast intro: op_bisim)

lemma E_from_op_wf_state:
  "wf_state b" if "wf_state a" "E_from_op a b"
  using that unfolding E_E_op E_from_op_def wf_state_def state_equiv_def by (blast intro: op_wf)

lemma E_precise_wf_dbm[intro]:
  "wf_dbm D'" if "E_precise (l, D) (l', D')" "wf_dbm D"
  using that unfolding wf_state_def E_def E_precise_def by (auto intro: step_impl_wf_dbm)

lemma E_precise_wf_state:
  "wf_state a \<Longrightarrow> E_precise a b \<Longrightarrow> wf_state b"
  unfolding wf_state_def by auto

(* lemma E_E_from_op_steps_empty:
  "(\<exists>l' M'. E_precise\<^sup>*\<^sup>* a\<^sub>0 (l', M') \<and> [curry (conv_M M')]\<^bsub>v,n\<^esub> = {}) \<longleftrightarrow>
   (\<exists>l' M'. E_from_op\<^sup>*\<^sup>* a\<^sub>0 (l', M') \<and> [curry (conv_M M')]\<^bsub>v,n\<^esub> = {})"
  by (rule E_E\<^sub>1_steps_empty[OF E_E_from_op_step E_from_op_E_step E_from_op_wf_state]) *)

theorem E_from_op_reachability_check:
  "(\<exists> l' D'. E_precise\<^sup>*\<^sup>* a\<^sub>0 (l', D') \<and> F_rel (l', D'))
  \<longleftrightarrow> (\<exists> l' D'. E_from_op\<^sup>*\<^sup>* a\<^sub>0 (l', D') \<and> F_rel (l', D'))"
  oops
(*   apply (rule E_E\<^sub>1_steps_equiv[OF E_E_from_op_step E_from_op_E_step E_from_op_wf_state])
  by
    (auto
      simp: F_rel_def state_equiv_def wf_state_def dbm_equiv_def
      dest!:
        check_diag_empty_spec[OF check_diag_conv_M]
        canonical_check_diag_empty_iff[OF wf_dbm_altD(1)]
    ) *)

lemma E_from_op_mono:
  assumes "E_from_op (l,D) (l',D')"
    and   "wf_dbm D" "wf_dbm M"
    and "[curry (conv_M D)]\<^bsub>v,n\<^esub> \<subseteq> [curry (conv_M M)]\<^bsub>v,n\<^esub>"
  shows "\<exists> M'. E_from_op (l,M) (l',M') \<and> [curry (conv_M D')]\<^bsub>v,n\<^esub> \<subseteq> [curry (conv_M M')]\<^bsub>v,n\<^esub>"
  (* using assms by - (rule E\<^sub>1_mono[OF E_E_from_op_step E_from_op_E_step E_from_op_wf_state]; blast) *)
  oops

lemma E_from_op_mono':
  assumes "E_from_op (l,D) (l',D')"
    and   "wf_dbm D" "wf_dbm M"
    and "dbm_subset n D M"
  shows "\<exists> M'. E_from_op (l,M) (l',M') \<and> dbm_subset n D' M'"
  (* using assms by - (rule E\<^sub>1_mono'[OF E_E_from_op_step E_from_op_E_step E_from_op_wf_state]; blast) *)
  oops

  thm E_E_from_op_step E_from_op_E_step E_from_op_wf_state

lemma E_equiv:
  "\<exists> b'. E_precise b b' \<and> a' \<sim> b'" if "E_precise a a'" "a \<sim> b" "wf_state a" "wf_state b"
  using that
  unfolding wf_state_def E_precise_def
  apply safe
  apply (frule step_impl_equiv, assumption, assumption, rule state_equiv_D, assumption)
  by (safe, drule step_impl_equiv, auto intro: step_impl_wf_dbm simp: state_equiv_def)

lemma E_from_op_bisim:
  "Bisimulation_Invariant E_precise E_from_op (\<sim>) wf_state wf_state"
  apply standard
  subgoal
    by (drule E_equiv, assumption+) (auto dest!: E_E_from_op_step)
  subgoal
    by (drule (1) E_from_op_E_step, safe, drule E_equiv) (auto 4 4 intro: state_equiv_sym)
   apply (rule E_precise_wf_state; assumption)
  apply (rule E_from_op_wf_state; assumption)
  done

lemma E_from_op_bisim_empty:
  "Bisimulation_Invariant
    (\<lambda>(l, M) (l', M'). E_precise (l, M) (l', M') \<and> \<not> check_diag n M')
    (\<lambda>(l, M) (l', M'). E_from_op (l, M) (l', M') \<and> \<not> check_diag n M')
    (\<sim>) wf_state wf_state"
  using E_from_op_bisim
  apply (rule Bisimulation_Invariant_filter[
        where FA = "\<lambda>(l, M). \<not> check_diag n M" and FB = "\<lambda>(l, M). \<not> check_diag n M"
        ])
  subgoal
    unfolding wf_state_def state_equiv_def
    apply clarsimp
    apply (subst canonical_check_diag_empty_iff[symmetric], erule wf_dbm_altD(1))
    apply (subst canonical_check_diag_empty_iff[symmetric], erule wf_dbm_altD(1))
    apply (simp add: dbm_equiv_def)
    done
   apply (auto; fail)+
  done

end (* End of context for bisimilarity *)

definition step_z_dbm' ::
  "('a, 'c, 't, 's) ta \<Rightarrow> 's \<Rightarrow> 't :: {linordered_cancel_ab_monoid_add,uminus} DBM
    \<Rightarrow> ('c \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 's \<Rightarrow> 't DBM \<Rightarrow> bool"
("_ \<turnstile>'' \<langle>_, _\<rangle> \<leadsto>\<^bsub>_,_,_\<^esub> \<langle>_, _\<rangle>" [61,61,61,61] 61) where
  "A \<turnstile>' \<langle>l,D\<rangle> \<leadsto>\<^bsub>v,n,a\<^esub> \<langle>l'',D''\<rangle> \<equiv>
  \<exists>l' D'. A \<turnstile> \<langle>l, D\<rangle> \<leadsto>\<^bsub>v,n,\<tau>\<^esub> \<langle>l', D'\<rangle> \<and> A \<turnstile> \<langle>l', D'\<rangle> \<leadsto>\<^bsub>v,n,\<upharpoonleft>a\<^esub> \<langle>l'', D''\<rangle>"

context TA_Start
begin

lemma E_precise_op'_bisim:
  "E_precise_op' l r g l' M \<simeq> E_precise_op l r g l' M" if "A \<turnstile> l \<longrightarrow>\<^bsup>g,a,r\<^esup> l'" "wf_dbm M"
proof -
  note intros =
    dbm_equiv_refl dbm_equiv_trans[OF filter_diag_equiv, rotated]
    wf_dbm_abstr_repair_equiv_FW[rotated] reset'_upd_equiv
  have "\<forall>c\<in>constraint_clk ` set (inv_of A l). 0 < c \<and> c \<le> n"
    using clock_range collect_clks_inv_clk_set[of A l] unfolding collect_clks_def by blast
  moreover have
    "\<forall>c\<in>constraint_clk ` set (inv_of A l'). 0 < c \<and> c \<le> n"
    "\<forall>c\<in>constraint_clk ` set (inv_of A l'). 0 < c"
    using clock_range collect_clks_inv_clk_set[of A l'] unfolding collect_clks_def by blast+
  moreover have "\<forall>c\<in>constraint_clk ` set g. 0 < c \<and> c \<le> n" "\<forall>c\<in>constraint_clk ` set g. 0 < c"
    using clock_range collect_clocks_clk_set[OF that(1)] unfolding collect_clks_def by blast+
  moreover have "\<forall>i\<in>set r. 0 < i \<and> i \<le> n" "\<forall>i\<in>set r. 0 < i"
    using clock_range reset_clk_set[OF that(1)] unfolding collect_clks_def by blast+
  moreover note side_conds = calculation that(2)
  note wf_intros =
    wf_dbm_abstr_repair wf_dbm_reset'_upd wf_dbm_up_canonical_upd filter_diag_wf_dbm
    wf_dbm_FW'_abstr_upd
  note check_diag_intros =
    reset'_upd_check_diag_preservation abstr_repair_check_diag_preservation
  show ?thesis unfolding E_precise_op'_def E_precise_op_def
    by simp (intro intros check_diag_intros side_conds wf_intros order.refl)
qed

lemma step_z_'_step_z_dbm'_equiv:
  "Bisimulation_Invariant
     (\<lambda> (l, D) (l', D'). \<exists> a. step_z' (conv_A A) l D l' D')
     (\<lambda> (l, D) (l', D'). \<exists> a. step_z_dbm' (conv_A A) l D v n a l' D')
     (\<lambda>(l, Z) (l', M). l = l' \<and> [M]\<^bsub>v,n\<^esub> = Z)
     (\<lambda>(l, Z). True)
     (\<lambda>(l, y). True)"
proof (standard, goal_cases)
  case prems: (1 a b a')
  obtain l Z l' Z' l1 M where unfolds[simp]: "a = (l, Z)" "b = (l', Z')" "a' = (l1, M)"
    by force+
  from prems have [simp]: "l1 = l"
    by auto
  from prems have "conv_A A \<turnstile> \<langle>l, Z\<rangle> \<leadsto> \<langle>l', Z'\<rangle>" "[M]\<^bsub>v,n\<^esub> = Z"
    by auto
  from this(1) guess Z1 a
    unfolding step_z'_def by safe
  note Z1 = this
  from step_z_dbm_DBM[OF Z1(1)[folded \<open>_ = Z\<close>]] guess M1 .
  note M1 = this
  from step_z_dbm_DBM[OF Z1(2)[unfolded \<open>Z1 = _\<close>]] guess Z2 .
  with M1 Z1 show ?case
    unfolding step_z_dbm'_def by auto
next
  case prems: (2 a a' b')
  obtain l M l' M' l1 Z where unfolds[simp]: "a' = (l, M)" "b' = (l', M')" "a = (l1, Z)"
    by force+
  from prems have [simp]: "l1 = l"
    by auto
  from prems obtain a1 where "conv_A A \<turnstile>' \<langle>l, M\<rangle> \<leadsto>\<^bsub>v,n,a1\<^esub> \<langle>l', M'\<rangle>" "[M]\<^bsub>v,n\<^esub> = Z"
    by auto
  from this(1) guess l1' Z1
    unfolding step_z_dbm'_def by safe
  note Z1 = this
  then have [simp]: "l1' = l"
    by (intro step_z_dbm_delay_loc)
  from Z1 \<open>_ = Z\<close> show ?case
    unfolding step_z'_def by (auto dest: step_z_dbm_sound)
next
  case (3 a b)
  then show ?case
    by auto
next
  case (4 a b)
  then show ?case
    by auto
qed

lemma step_z_dbm'_step_impl_precise_equiv:
  "Bisimulation_Invariant
     (\<lambda> (l, D) (l', D'). \<exists> a. step_z_dbm' (conv_A A) l D v n a l' D')
     (\<lambda>(l, D) (l', D'). \<exists>a. \<langle>l, D\<rangle> \<leadsto>\<^bsub>a\<^esub> \<langle>l', D'\<rangle>)
     (\<lambda>(l, M) (l', D). l = l' \<and> [curry (conv_M D)]\<^bsub>v,n\<^esub> = [M]\<^bsub>v,n\<^esub>)
     (\<lambda>(l, y). valid_dbm y)
     wf_state"
proof (standard, goal_cases)
  case prems: (1 a b a')
  obtain l M l' M' l1 D where unfolds[simp]: "a = (l, M)" "b = (l', M')" "a' = (l1, D)"
    by force+
  from prems have [simp]: "l1 = l"
    by auto
  from prems obtain a1 where
    "step_z_dbm' (conv_A A) l M v n a1 l' M'"
    by auto
  then obtain l2 M1 where steps:
    "conv_A A \<turnstile> \<langle>l,  M\<rangle>  \<leadsto>\<^bsub>v,n,\<tau>\<^esub>   \<langle>l2, M1\<rangle>"
    "conv_A A \<turnstile> \<langle>l2, M1\<rangle> \<leadsto>\<^bsub>v,n,\<upharpoonleft>a1\<^esub> \<langle>l', M'\<rangle>"
    unfolding step_z_dbm'_def by auto
  from step_z_dbm_equiv'[OF steps(1), of "curry (conv_M D)"] prems(2-) obtain M2 where
    "conv_A A \<turnstile> \<langle>l, curry (conv_M D)\<rangle> \<leadsto>\<^bsub>v,n,\<tau>\<^esub> \<langle>l2, M2\<rangle>" "wf_dbm D" "[M1]\<^bsub>v,n\<^esub> = [M2]\<^bsub>v,n\<^esub>"
    by (auto simp: wf_state_def)
  with step_impl_complete''_improved[OF this(1)] obtain D2 where D2:
    "A \<turnstile>\<^sub>I \<langle>l, D\<rangle> \<leadsto>\<^bsub>n,\<tau>\<^esub> \<langle>l2, D2\<rangle>" "[curry (conv_M D2)]\<^bsub>v,n\<^esub> = [M1]\<^bsub>v,n\<^esub>"
    by auto
  from step_impl_wf_dbm[OF D2(1) \<open>wf_dbm D\<close>] have "wf_dbm D2" .
  from step_z_dbm_equiv'[OF steps(2) sym[OF D2(2)]] obtain D3 where D3:
    "conv_A A \<turnstile> \<langle>l2, curry (conv_M D2)\<rangle> \<leadsto>\<^bsub>v,n,\<upharpoonleft>a1\<^esub> \<langle>l', D3\<rangle>" "[M']\<^bsub>v,n\<^esub> = [D3]\<^bsub>v,n\<^esub>"
    by (elim conjE exE)
  from step_impl_complete''_improved[OF D3(1) \<open>wf_dbm D2\<close>] obtain D4 where D4:
    "A \<turnstile>\<^sub>I \<langle>l2, D2\<rangle> \<leadsto>\<^bsub>n,\<upharpoonleft>a1\<^esub> \<langle>l', D4\<rangle>" "[curry (conv_M D4)]\<^bsub>v,n\<^esub> = [D3]\<^bsub>v,n\<^esub>"
    by auto
  with D2(1) have "\<langle>l, D\<rangle> \<leadsto>\<^bsub>a1\<^esub> \<langle>l', D4\<rangle>"
    by auto
  with D4(2) D3 show ?case
    by force
next
  case prems: (2 a a' b')
  obtain l M l' D' l1 D where unfolds[simp]: "a = (l, M)" "b' = (l', D')" "a' = (l1, D)"
    by force+
  from prems have [simp]: "l1 = l"
    by auto
  from prems obtain a1 where "\<langle>l, D\<rangle> \<leadsto>\<^bsub>a1\<^esub> \<langle>l', D'\<rangle>"
    by auto
  then obtain D1 where steps:
    "A \<turnstile>\<^sub>I \<langle>l, D\<rangle> \<leadsto>\<^bsub>n,\<tau>\<^esub> \<langle>l, D1\<rangle>" "A \<turnstile>\<^sub>I \<langle>l, D1\<rangle> \<leadsto>\<^bsub>n,\<upharpoonleft>a1\<^esub> \<langle>l', D'\<rangle>"
    by (auto dest: step_impl_delay_loc_eq)
  from prems have "wf_dbm D"
    by (auto simp: wf_state_def)
  with steps have "wf_dbm D1"
    by (blast intro: step_impl_wf_dbm)
  from step_impl_sound'[OF steps(1)] \<open>wf_dbm D\<close> obtain M2 where M2:
    "conv_A A \<turnstile> \<langle>l, curry (conv_M D)\<rangle> \<leadsto>\<^bsub>v,n,\<tau>\<^esub> \<langle>l, M2\<rangle>"
    "[curry (conv_M D1)]\<^bsub>v,n\<^esub> = [M2]\<^bsub>v,n\<^esub>"
    using wf_dbm_D by auto
  from step_impl_sound'[OF steps(2)] \<open>wf_dbm D1\<close> obtain M3 where M3:
    "step_z_dbm (conv_A A) l (curry (conv_M D1)) v n (\<upharpoonleft>a1) l' M3"
    "[curry (conv_M D')]\<^bsub>v,n\<^esub> = [M3]\<^bsub>v,n\<^esub>"
    using wf_dbm_D by auto
  from step_z_dbm_equiv'[OF M2(1), of M] prems(2) obtain M2' where M2':
    "conv_A A \<turnstile> \<langle>l, M\<rangle> \<leadsto>\<^bsub>v,n,\<tau>\<^esub> \<langle>l, M2'\<rangle>" "[M2]\<^bsub>v,n\<^esub> = [M2']\<^bsub>v,n\<^esub>"
    by auto
  from step_z_dbm_equiv'[OF M3(1), of M2'] M2(2) M2'(2) obtain M3' where
    "conv_A A \<turnstile> \<langle>l, M2'\<rangle> \<leadsto>\<^bsub>v,n,\<upharpoonleft>a1\<^esub> \<langle>l', M3'\<rangle>" "[M3]\<^bsub>v,n\<^esub> = [M3']\<^bsub>v,n\<^esub>"
    by auto
  with M2'(1) M3(2) show ?case
    unfolding step_z_dbm'_def by auto
next
  case (3 a b)
  then show ?case
    unfolding step_z_dbm'_def using step_z_norm_valid_dbm'_spec step_z_valid_dbm' by auto
next
  case (4 a b)
  then show ?case
    by (clarsimp simp: norm_step_wf_dbm step_impl_wf_dbm wf_state_def)
qed

lemma E_precise_op'_wf:
  assumes "A \<turnstile> l \<longrightarrow>\<^bsup>g,a,r\<^esup> l'" "wf_dbm M"
    shows "wf_dbm (E_precise_op' l r g l' M)"
proof -
  have "\<forall>c\<in>constraint_clk ` set (inv_of A l). 0 < c \<and> c \<le> n"
    using clock_range collect_clks_inv_clk_set[of A l] unfolding collect_clks_def by blast
  moreover have "\<forall>c\<in>constraint_clk ` set (inv_of A l'). 0 < c \<and> c \<le> n"
    using clock_range collect_clks_inv_clk_set[of A l'] unfolding collect_clks_def by blast
  moreover have "\<forall>c\<in>constraint_clk ` set g. 0 < c \<and> c \<le> n"
    using clock_range collect_clocks_clk_set[OF assms(1)] unfolding collect_clks_def by blast
  moreover have "\<forall>i\<in>set r. 0 < i \<and> i \<le> n"
    using clock_range reset_clk_set[OF assms(1)] unfolding collect_clks_def by blast
  moreover note side_conds = calculation assms(2)
  note wf_intros =
    wf_dbm_abstr_repair wf_dbm_reset'_upd wf_dbm_up_canonical_upd filter_diag_wf_dbm
  show ?thesis
    unfolding E_precise_op'_def by simp (intro wf_intros side_conds order.refl)
qed

sublocale E_precise_op': E_Precise_Bisim _ _ _ _ E_precise_op'
  by standard (rule E_precise_op'_bisim E_precise_op'_wf; assumption)+

lemma step_z_dbm'_final_bisim:
  "Bisimulation_Invariant
     (\<lambda> (l, D) (l', D'). \<exists> a. step_z_dbm' (conv_A A) l D v n a l' D')
     E_precise_op'.E_from_op
     (\<lambda> (l, M) (l', D'). l' = l \<and> [curry (conv_M D')]\<^bsub>v,n\<^esub> = [M]\<^bsub>v,n\<^esub>)
     (\<lambda>(l, y). valid_dbm y) wf_state"
  by (rule Bisimulation_Invariant_sim_replace,
      rule Bisimulation_Invariant_composition[
        OF step_z_dbm'_step_impl_precise_equiv[folded E_precise_def] E_precise_op'.E_from_op_bisim
      ]) (auto simp add: state_equiv_def dbm_equiv_def)

end (* TA Start *)

context E_Precise_Bisim
begin

theorem step_z_dbm'_mono:
  assumes "conv_A A \<turnstile>' \<langle>l, M\<rangle> \<leadsto>\<^bsub>v,n,a\<^esub> \<langle>l', M'\<rangle>" and "[M]\<^bsub>v,n\<^esub> \<subseteq> [D]\<^bsub>v,n\<^esub>"
  shows "\<exists>D'. conv_A A \<turnstile>' \<langle>l, D\<rangle> \<leadsto>\<^bsub>v,n,a\<^esub> \<langle>l', D'\<rangle> \<and> [M']\<^bsub>v,n\<^esub> \<subseteq> [D']\<^bsub>v,n\<^esub>"
  using assms unfolding step_z_dbm'_def
  apply clarsimp
  apply (drule step_z_dbm_mono, assumption)
  apply safe
  apply (drule step_z_dbm_mono, assumption)
  apply auto
  done

interpretation
  Bisimulation_Invariant
  "(\<lambda> (l, D) (l', D'). \<exists> a. step_z_dbm' (conv_A A) l D v n a l' D')"
  E_from_op
  "\<lambda> (l, M) (l', D'). l' = l \<and> [curry (conv_M D')]\<^bsub>v,n\<^esub> = [M]\<^bsub>v,n\<^esub>"
  "\<lambda>(l, y). valid_dbm y"
  wf_state
  by (rule Bisimulation_Invariant_sim_replace,
      rule Bisimulation_Invariant_composition[
        OF step_z_dbm'_step_impl_precise_equiv[folded E_precise_def] E_from_op_bisim
      ]) (auto simp add: state_equiv_def dbm_equiv_def)

lemmas step_z_dbm'_E_from_op_bisim = Bisimulation_Invariant_axioms

definition
  "E_from_op_empty \<equiv> \<lambda>(l, D) (l', D'). E_from_op (l, D) (l', D') \<and> \<not> check_diag n D'"

interpretation bisim_empty:
  Bisimulation_Invariant
  "\<lambda>(l, M) (l', M'). \<exists> a. step_z_dbm' (conv_A A) l M v n a l' M' \<and> [M']\<^bsub>v,n\<^esub> \<noteq> {}"
  "\<lambda>(l, D) (l', D'). E_from_op (l, D) (l', D') \<and> \<not> check_diag n D'"
  "\<lambda>(l, M) (l', D'). l' = l \<and> [curry (conv_M D')]\<^bsub>v,n\<^esub> = [M]\<^bsub>v,n\<^esub>"
  "\<lambda>(l, y). valid_dbm y"
  wf_state
  using step_z_dbm'_E_from_op_bisim apply (rule Bisimulation_Invariant_filter[
        where FA = "\<lambda>(l', M'). [M']\<^bsub>v,n\<^esub> \<noteq> {}" and FB = "\<lambda>(l', D'). \<not> check_diag n D'"
        ])
  using canonical_check_diag_empty_iff canonical_empty_check_diag' by (auto simp: wf_state_def)

lemmas step_z_dbm'_E_from_op_bisim_empty =
  bisim_empty.Bisimulation_Invariant_axioms[folded E_from_op_empty_def]

lemma E_from_op_mono:
  assumes "E_from_op (l,D) (l',D')"
    and   "wf_dbm D" "wf_dbm M"
    and "[curry (conv_M D)]\<^bsub>v,n\<^esub> \<subseteq> [curry (conv_M M)]\<^bsub>v,n\<^esub>"
  shows "\<exists> M'. E_from_op (l,M) (l',M') \<and> [curry (conv_M D')]\<^bsub>v,n\<^esub> \<subseteq> [curry (conv_M M')]\<^bsub>v,n\<^esub>"
proof -
  from B_A_step[OF assms(1), of "(l, curry (conv_M D))"] assms(2) obtain a D1 where D1:
    "conv_A A \<turnstile>' \<langle>l, curry (conv_M D)\<rangle> \<leadsto>\<^bsub>v,n,a\<^esub> \<langle>l', D1\<rangle>" "[D1]\<^bsub>v,n\<^esub> = [curry (conv_M D')]\<^bsub>v,n\<^esub>"
    unfolding wf_state_def by (force dest: wf_dbm_D)
  from step_z_dbm'_mono[OF this(1) assms(4)] guess M1
    by safe
  note M1 = this
  with A_B_step[of "(l, curry (conv_M M))" "(l', M1)" "(l, M)"] assms(3) obtain M2 where
    "E_from_op (l, M) (l', M2)" "[curry (conv_M M2)]\<^bsub>v,n\<^esub> = [M1]\<^bsub>v,n\<^esub>"
    unfolding wf_state_def by (force dest: wf_dbm_D)
  with assms(3) M1(2) D1(2) show ?thesis
    by auto
qed

(* XXX Duplication (E_mono') *)
lemma E_from_op_mono':
  assumes "E_from_op (l,D) (l',D')"
    and   "wf_dbm D" "wf_dbm M"
    and "dbm_subset n D M"
  shows "\<exists> M'. E_from_op (l,M) (l',M') \<and> dbm_subset n D' M'"
  using assms
  apply -
  apply (frule E_from_op_mono[where M = M], assumption+)
   apply (subst dbm_subset_correct'', assumption+)
   apply (rule dbm_subset_conv, assumption)
  apply safe
  apply (subst (asm) dbm_subset_correct'')
  subgoal
    using B_invariant[unfolded wf_state_def] by auto
  subgoal
    using B_invariant[unfolded wf_state_def] by auto
  apply (blast intro: dbm_subset_conv_rev)
  done

lemma E_from_op_empty_mono':
  assumes "E_from_op_empty (l,D) (l',D')"
    and   "wf_dbm D" "wf_dbm M"
    and "dbm_subset n D M"
  shows "\<exists> M'. E_from_op_empty (l,M) (l',M') \<and> dbm_subset n D' M'"
  using assms unfolding E_from_op_empty_def using check_diag_subset E_from_op_mono' by blast

end (* E Precise Bisim *)

end