(*<*)
(*
 * The worker/wrapper transformation, following Gill and Hutton.
 * (C)opyright 2009-2011, Peter Gammie, peteg42 at gmail.com.
 * License: BSD
 *)

theory UnboxedNats
imports
  HOLCF
  Nats
  WorkerWrapperNew
begin
(*>*)

section\<open>Unboxing types.\<close>

text\<open>The original application of the worker/wrapper transformation
was the unboxing of flat types by \citet{SPJ-JL:1991}. We can model
the boxed and unboxed types as (respectively) pointed and unpointed
domains in HOLCF. Concretely @{typ "UNat"} denotes the discrete domain
of naturals, @{typ "UNat\<^sub>\<bottom>"} the lifted (flat and pointed) variant, and
@{typ "Nat"} the standard boxed domain, isomorphic to @{typ
"UNat\<^sub>\<bottom>"}. This latter distinction helps us keep the boxed naturals and
lifted function codomains separated; applications of @{term "unbox"}
should be thought of in the same way as Haskell's @{term "newtype"}
constructors, i.e. operationally equivalent to @{term "ID"}.

The divergence monad is used to handle the unboxing, see below.\<close>

subsection\<open>Factorial example.\<close>

text\<open>Standard definition of factorial.\<close>

fixrec fac :: "Nat \<rightarrow> Nat"
where
  "fac\<cdot>n = If n =\<^sub>B 0 then 1 else n * fac\<cdot>(n - 1)"

declare fac.simps[simp del]

lemma fac_strict[simp]: "fac\<cdot>\<bottom> = \<bottom>"
by fixrec_simp

definition
  fac_body :: "(Nat \<rightarrow> Nat) \<rightarrow> Nat \<rightarrow> Nat" where
  "fac_body \<equiv> \<Lambda> r n. If n =\<^sub>B 0 then 1 else n * r\<cdot>(n - 1)"

lemma fac_body_strict[simp]: "fac_body\<cdot>r\<cdot>\<bottom> = \<bottom>"
  unfolding fac_body_def by simp

lemma fac_fac_body_eq: "fac = fix\<cdot>fac_body"
  unfolding fac_body_def by (rule cfun_eqI, subst fac_def, simp)

text\<open>Wrap / unwrap functions. Note the explicit lifting of the
co-domain. For some reason the published version of
\citet{GillHutton:2009} does not discuss this point: if we're going to
handle recursive functions, we need a bottom.

@{term "unbox"} simply removes the tag, yielding a possibly-divergent
unboxed value, the result of the function.\<close>

definition
  unwrapB :: "(Nat \<rightarrow> Nat) \<rightarrow> UNat \<rightarrow> UNat\<^sub>\<bottom>" where
  "unwrapB \<equiv> \<Lambda> f. unbox oo f oo box"

text\<open>Note that the monadic bind operator @{term "(>>=)"} here stands
in for the \textsf{case} construct in the paper.\<close>

definition
  wrapB :: "(UNat \<rightarrow> UNat\<^sub>\<bottom>) \<rightarrow> Nat \<rightarrow> Nat" where
  "wrapB \<equiv> \<Lambda> f x . unbox\<cdot>x >>= f >>= box"

lemma wrapB_unwrapB_body:
  assumes strictF: "f\<cdot>\<bottom> = \<bottom>"
  shows "(wrapB oo unwrapB)\<cdot>f = f" (is "?lhs = ?rhs")
proof(rule cfun_eqI)
  fix x :: Nat
  have "?lhs\<cdot>x = unbox\<cdot>x >>= (\<Lambda> x'. unwrapB\<cdot>f\<cdot>x' >>= box)"
    unfolding wrapB_def by simp
  also have "\<dots> = unbox\<cdot>x >>= (\<Lambda> x'. unbox\<cdot>(f\<cdot>(box\<cdot>x')) >>= box)"
    unfolding unwrapB_def by simp
  also from strictF have "\<dots> = f\<cdot>x" by (cases x, simp_all)
  finally show "?lhs\<cdot>x = ?rhs\<cdot>x" .
qed

text\<open>Apply worker/wrapper.\<close>

definition
  fac_work :: "UNat \<rightarrow> UNat\<^sub>\<bottom>" where
  "fac_work \<equiv> fix\<cdot>(unwrapB oo fac_body oo wrapB)"

definition
  fac_wrap :: "Nat \<rightarrow> Nat" where
  "fac_wrap \<equiv> wrapB\<cdot>fac_work"

lemma fac_fac_ww_eq: "fac = fac_wrap" (is "?lhs = ?rhs")
proof -
  have "wrapB oo unwrapB oo fac_body = fac_body"
    using wrapB_unwrapB_body[OF fac_body_strict]
    by - (rule cfun_eqI, simp)
  thus ?thesis
    using worker_wrapper_body[where computation=fac and body=fac_body and wrap=wrapB and unwrap=unwrapB]
    unfolding fac_work_def fac_wrap_def by (simp add: fac_fac_body_eq)
qed

text\<open>This is not entirely faithful to the paper, as they don't
explicitly handle the lifting of the codomain.\<close>

definition
  fac_body' :: "(UNat \<rightarrow> UNat\<^sub>\<bottom>) \<rightarrow> UNat \<rightarrow> UNat\<^sub>\<bottom>" where
  "fac_body' \<equiv> \<Lambda> r n.
     unbox\<cdot>(If box\<cdot>n =\<^sub>B 0
              then 1
              else unbox\<cdot>(box\<cdot>n - 1) >>= r >>= (\<Lambda> b. box\<cdot>n * box\<cdot>b))"

text\<open>The @{term "up"} constructors here again mediate the
isomorphism, operationally doing nothing. Note the switch to the
machine-oriented \emph{if} construct: the test @{term "n = 0"} cannot
diverge.\<close>

definition
  fac_body_final :: "(UNat \<rightarrow> UNat\<^sub>\<bottom>) \<rightarrow> UNat \<rightarrow> UNat\<^sub>\<bottom>" where
  "fac_body_final \<equiv> \<Lambda> r n.
     if n = 0 then up\<cdot>1 else r\<cdot>(n -\<^sub># 1) >>= (\<Lambda> b. up\<cdot>(n *\<^sub># b))"

lemma fac_body_final_fac_body': "fac_body_final = fac_body'" (is "?lhs = ?rhs")
proof(rule cfun_eqI)+
  fix r x
  show "?lhs\<cdot>r\<cdot>x = ?rhs\<cdot>r\<cdot>x"
    using bbind_case_distr_strict[where f="unbox" and g="r\<cdot>(x -\<^sub># 1)" and h="(\<Lambda> b. box\<cdot>(x *\<^sub># b))"]
    unfolding fac_body_final_def fac_body'_def uMinus_def uMult_def zero_Nat_def one_Nat_def
    by simp
qed

definition
  fac_work_final :: "UNat \<rightarrow> UNat\<^sub>\<bottom>" where
  "fac_work_final \<equiv> fix\<cdot>fac_body_final"

definition
  fac_final :: "Nat \<rightarrow> Nat" where
  "fac_final \<equiv> \<Lambda> n. unbox\<cdot>n >>= fac_work_final >>= box"

lemma fac_fac_final: "fac = fac_final" (is "?lhs=?rhs")
proof -
  have "?lhs = fac_wrap" by (rule fac_fac_ww_eq)
  also have "\<dots> = wrapB\<cdot>fac_work" by (simp only: fac_wrap_def)
  also have "\<dots> = wrapB\<cdot>(fix\<cdot>(unwrapB oo fac_body oo wrapB))" by (simp only: fac_work_def)
  also have "\<dots> = wrapB\<cdot>(fix\<cdot>fac_body')" by (simp only: fac_body'_fac_body)
  also have "\<dots> = wrapB\<cdot>fac_work_final" by (simp only: fac_body_final_fac_body' fac_work_final_def)
  also have "\<dots> = fac_final" by (simp add: fac_final_def wrapB_def)
  finally show ?thesis .
qed

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

subsection\<open>Introducing an accumulator.\<close>

text\<open>

The final version of factorial uses unboxed naturals but is not
tail-recursive. We can apply worker/wrapper once more to introduce an
accumulator, similar to \S\ref{sec:accum}.

The monadic machinery complicates things slightly here. We use
\emph{Kleisli composition}, denoted @{term "(>=>)"}, in the
homomorphism.

Firstly we introduce an ``accumulator'' monoid and show the
homomorphism.

\<close>

type_synonym UNatAcc = "UNat \<rightarrow> UNat\<^sub>\<bottom>"

definition
  n2a :: "UNat \<rightarrow> UNatAcc" where
  "n2a \<equiv> \<Lambda> m n. up\<cdot>(m *\<^sub># n)"

definition
  a2n :: "UNatAcc \<rightarrow> UNat\<^sub>\<bottom>" where
  "a2n \<equiv> \<Lambda> a. a\<cdot>1"

lemma a2n_strict[simp]: "a2n\<cdot>\<bottom> = \<bottom>"
  unfolding a2n_def by simp

lemma a2n_n2a: "a2n\<cdot>(n2a\<cdot>u) = up\<cdot>u"
  unfolding a2n_def n2a_def by (simp add: uMult_arithmetic)

lemma A_hom_mult: "n2a\<cdot>(x *\<^sub># y) = (n2a\<cdot>x >=> n2a\<cdot>y)"
  unfolding n2a_def bKleisli_def by (simp add: uMult_arithmetic)

definition
  unwrapA :: "(UNat \<rightarrow> UNat\<^sub>\<bottom>) \<rightarrow> UNat \<rightarrow> UNatAcc" where
  "unwrapA \<equiv> \<Lambda> f n. f\<cdot>n >>= n2a"

lemma unwrapA_strict[simp]: "unwrapA\<cdot>\<bottom> = \<bottom>"
  unfolding unwrapA_def by (rule cfun_eqI) simp

definition
  wrapA :: "(UNat \<rightarrow> UNatAcc) \<rightarrow> UNat \<rightarrow> UNat\<^sub>\<bottom>" where
  "wrapA \<equiv> \<Lambda> f. a2n oo f"

lemma wrapA_unwrapA_id: "wrapA oo unwrapA = ID"
  unfolding wrapA_def unwrapA_def
  apply (rule cfun_eqI)+
  apply (case_tac "x\<cdot>xa")
  apply (simp_all add: a2n_n2a)
  done

text\<open>Some steps along the way.\<close>

definition
  fac_acc_body1 :: "(UNat \<rightarrow> UNatAcc) \<rightarrow> UNat \<rightarrow> UNatAcc" where
  "fac_acc_body1 \<equiv> \<Lambda> r n.
     if n = 0 then n2a\<cdot>1 else wrapA\<cdot>r\<cdot>(n -\<^sub># 1) >>= (\<Lambda> res. n2a\<cdot>(n *\<^sub># res))"

lemma fac_acc_body1_fac_body_final_eq: "fac_acc_body1 = unwrapA oo fac_body_final oo wrapA"
  unfolding fac_acc_body1_def fac_body_final_def wrapA_def unwrapA_def
  by (rule cfun_eqI)+ simp

text\<open>Use the homomorphism.\<close>

definition
  fac_acc_body2 :: "(UNat \<rightarrow> UNatAcc) \<rightarrow> UNat \<rightarrow> UNatAcc" where
  "fac_acc_body2 \<equiv> \<Lambda> r n.
     if n = 0 then n2a\<cdot>1 else wrapA\<cdot>r\<cdot>(n -\<^sub># 1) >>= (\<Lambda> res. n2a\<cdot>n >=> n2a\<cdot>res)"

lemma fac_acc_body2_body1_eq: "fac_acc_body2 = fac_acc_body1"
  unfolding fac_acc_body1_def fac_acc_body2_def
  by (rule cfun_eqI)+ (simp add: A_hom_mult)

text\<open>Apply worker/wrapper.\<close>

definition
  fac_acc_body3 :: "(UNat \<rightarrow> UNatAcc) \<rightarrow> UNat \<rightarrow> UNatAcc" where
  "fac_acc_body3 \<equiv> \<Lambda> r n.
     if n = 0 then n2a\<cdot>1 else n2a\<cdot>n >=> r\<cdot>(n -\<^sub># 1)"

lemma fac_acc_body3_body2: "fac_acc_body3 oo (unwrapA oo wrapA) = fac_acc_body2" (is "?lhs=?rhs")
proof(rule cfun_eqI)+
  fix r n acc
  show "((fac_acc_body3 oo (unwrapA oo wrapA))\<cdot>r\<cdot>n\<cdot>acc) = fac_acc_body2\<cdot>r\<cdot>n\<cdot>acc"
    unfolding fac_acc_body2_def fac_acc_body3_def unwrapA_def
    using bbind_case_distr_strict[where f="\<Lambda> y. n2a\<cdot>n >=> y" and h="n2a", symmetric]
    by simp
qed

lemma fac_work_final_body3_eq: "fac_work_final = wrapA\<cdot>(fix\<cdot>fac_acc_body3)"
  unfolding fac_work_final_def
  by (rule worker_wrapper_fusion_new[OF wrapA_unwrapA_id unwrapA_strict])
     (simp add: fac_acc_body3_body2 fac_acc_body2_body1_eq fac_acc_body1_fac_body_final_eq)

definition
  fac_acc_body_final :: "(UNat \<rightarrow> UNatAcc) \<rightarrow> UNat \<rightarrow> UNatAcc" where
  "fac_acc_body_final \<equiv> \<Lambda> r n acc.
     if n = 0 then up\<cdot>acc else r\<cdot>(n -\<^sub># 1)\<cdot>(n *\<^sub># acc)"

definition
  fac_acc_work_final :: "UNat \<rightarrow> UNat\<^sub>\<bottom>" where
  "fac_acc_work_final \<equiv> \<Lambda> x. fix\<cdot>fac_acc_body_final\<cdot>x\<cdot>1"

lemma fac_acc_work_final_fac_acc_work3_eq: "fac_acc_body_final = fac_acc_body3" (is "?lhs=?rhs")
  unfolding fac_acc_body3_def fac_acc_body_final_def n2a_def bKleisli_def
  by (rule cfun_eqI)+
     (simp add: uMult_arithmetic)

lemma fac_acc_work_final_fac_work: "fac_acc_work_final = fac_work_final" (is "?lhs=?rhs")
proof -
  have "?rhs = wrapA\<cdot>(fix\<cdot>fac_acc_body3)" by (rule fac_work_final_body3_eq)
  also have "\<dots> = wrapA\<cdot>(fix\<cdot>fac_acc_body_final)"
    using fac_acc_work_final_fac_acc_work3_eq by simp
  also have "\<dots> = ?lhs"
    unfolding fac_acc_work_final_def wrapA_def a2n_def
    by (simp add: cfcomp1)
  finally show ?thesis by simp
qed

(*<*)
end
(*>*)


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

(* Author: Rafal Kolanski, 2008
   Maintainers: Gerwin Klein <kleing at cse.unsw.edu.au>
                Rafal Kolanski <rafal.kolanski at nicta.com.au>
*)

chapter {* More properties of maps plus map disjuction. *}

theory Map_Extra
imports "~~/src/HOL/Main"
begin

text {*
  A note on naming:
  Anything not involving heap disjuction can potentially be incorporated
  directly into Map.thy, thus uses @{text "m"} for map variable names.
  Anything involving heap disjunction is not really mergeable with Map, is
  destined for use in separation logic, and hence uses @{text "h"}
*}

section {* Things that could go into Option Type *}

text {* Misc option lemmas *}

lemma None_not_eq: "(None \<noteq> x) = (\<exists>y. x = Some y)" by (cases x) auto

lemma None_com: "(None = x) = (x = None)" by fast

lemma Some_com: "(Some y = x) = (x = Some y)" by fast

section {* Things that go into Map.thy *}

text {* Map intersection: set of all keys for which the maps agree. *}

definition
  map_inter :: "('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> 'a set" (infixl "\<inter>\<^sub>m" 70) where
  "m\<^sub>1 \<inter>\<^sub>m m\<^sub>2 \<equiv> {x \<in> dom m\<^sub>1. m\<^sub>1 x = m\<^sub>2 x}"

text {* Map restriction via domain subtraction *}

definition
  sub_restrict_map :: "('a \<rightharpoonup> 'b) => 'a set => ('a \<rightharpoonup> 'b)" (infixl "`-"  110)
  where
  "m `- S \<equiv> (\<lambda>x. if x \<in> S then None else m x)"

subsection {* Properties of maps not related to restriction *}

lemma empty_forall_equiv: "(m = empty) = (\<forall>x. m x = None)"
  by fastforce

lemma map_le_empty2 [simp]:
  "(m \<subseteq>\<^sub>m empty) = (m = empty)"
  by (auto simp: map_le_def)

lemma dom_iff:
  "(\<exists>y. m x = Some y) = (x \<in> dom m)"
  by auto

lemma non_dom_eval:
  "x \<notin> dom m \<Longrightarrow> m x = None"
  by auto

lemma non_dom_eval_eq:
  "x \<notin> dom m = (m x = None)"
  by auto

lemma map_add_same_left_eq:
  "m\<^sub>1 = m\<^sub>1' \<Longrightarrow> (m\<^sub>0 ++ m\<^sub>1 = m\<^sub>0 ++ m\<^sub>1')"
  by simp

lemma map_add_left_cancelI [intro!]:
  "m\<^sub>1 = m\<^sub>1' \<Longrightarrow> m\<^sub>0 ++ m\<^sub>1 = m\<^sub>0 ++ m\<^sub>1'"
  by simp

lemma dom_empty_is_empty:
  "(dom m = {}) = (m = empty)"
proof (rule iffI)
  assume a: "dom m = {}"
  { assume "m \<noteq> empty"
    hence "dom m \<noteq> {}"
      by - (subst (asm) empty_forall_equiv, simp add: dom_def)
    hence False using a by blast
  }
  thus "m = empty" by blast
next
  assume a: "m = empty"
  thus "dom m = {}" by simp
qed

lemma map_add_dom_eq:
  "dom m = dom m' \<Longrightarrow> m ++ m' = m'"
  by (rule ext) (auto simp: map_add_def split: option.splits)

lemma map_add_right_dom_eq:
  "\<lbrakk> m\<^sub>0 ++ m\<^sub>1 = m\<^sub>0' ++ m\<^sub>1'; dom m\<^sub>1 = dom m\<^sub>1' \<rbrakk> \<Longrightarrow> m\<^sub>1 = m\<^sub>1'"
  unfolding map_add_def
  by (rule ext, rule ccontr,
      drule_tac x=x in fun_cong, clarsimp split: option.splits,
      drule sym, drule sym, force+)

lemma map_le_same_dom_eq:
  "\<lbrakk> m\<^sub>0 \<subseteq>\<^sub>m m\<^sub>1 ; dom m\<^sub>0 = dom m\<^sub>1 \<rbrakk> \<Longrightarrow> m\<^sub>0 = m\<^sub>1"
  by (simp add: map_le_antisym map_le_def)

subsection {* Properties of map restriction *}

lemma restrict_map_cancel:
  "(m |` S = m |` T) = (dom m \<inter> S = dom m \<inter> T)"
  by (fastforce dest: fun_cong simp: restrict_map_def None_not_eq split: if_split_asm)

lemma map_add_restricted_self [simp]:
  "m ++ m |` S = m"
  by (auto simp: restrict_map_def map_add_def split: option.splits)

lemma map_add_restrict_dom_right [simp]:
  "(m ++ m') |` dom m' = m'"
  by (rule ext, auto simp: restrict_map_def map_add_def split: option.splits)

lemma restrict_map_UNIV [simp]:
  "m |` UNIV = m"
  by (simp add: restrict_map_def)

lemma restrict_map_dom:
  "S = dom m \<Longrightarrow> m |` S = m"
  by (rule ext, auto simp: restrict_map_def None_not_eq)

lemma restrict_map_subdom:
  "dom m \<subseteq> S \<Longrightarrow> m |` S = m"
  by (fastforce simp: restrict_map_def None_com)

lemma map_add_restrict:
  "(m\<^sub>0 ++ m\<^sub>1) |` S = ((m\<^sub>0 |` S) ++ (m\<^sub>1 |` S))"
  by (force simp: map_add_def restrict_map_def)

lemma map_le_restrict:
  "m \<subseteq>\<^sub>m m' \<Longrightarrow> m = m' |` dom m"
  by (force simp: map_le_def restrict_map_def None_com)

lemma restrict_map_le:
  "m |` S \<subseteq>\<^sub>m m"
  by (auto simp: map_le_def)

lemma restrict_map_remerge:
  "\<lbrakk> S \<inter> T = {} \<rbrakk> \<Longrightarrow> m |` S ++ m |` T = m |` (S \<union> T)"
  by (rule ext, clarsimp simp: restrict_map_def map_add_def
                         split: option.splits)

lemma restrict_map_empty:
  "dom m \<inter> S = {} \<Longrightarrow> m |` S = empty"
  by (fastforce simp: restrict_map_def)

lemma map_add_restrict_comp_right [simp]:
  "(m |` S ++ m |` (UNIV - S)) = m"
  by (force simp: map_add_def restrict_map_def split: option.splits)

lemma map_add_restrict_comp_right_dom [simp]:
  "(m |` S ++ m |` (dom m - S)) = m"
  by (rule ext, auto simp: map_add_def restrict_map_def split: option.splits)

lemma map_add_restrict_comp_left [simp]:
  "(m |` (UNIV - S) ++ m |` S) = m"
  by (subst map_add_comm, auto)

lemma restrict_self_UNIV:
  "m |` (dom m - S) = m |` (UNIV - S)"
  by (rule ext, auto simp: restrict_map_def)

lemma map_add_restrict_nonmember_right:
  "x \<notin> dom m' \<Longrightarrow> (m ++ m') |` {x} = m |` {x}"
  by (rule ext, auto simp: restrict_map_def map_add_def split: option.splits)

lemma map_add_restrict_nonmember_left:
  "x \<notin> dom m \<Longrightarrow> (m ++ m') |` {x} = m' |` {x}"
  by (rule ext, auto simp: restrict_map_def map_add_def split: option.splits)

lemma map_add_restrict_right:
  "x \<subseteq> dom m' \<Longrightarrow> (m ++ m') |` x = m' |` x"
  by (rule ext, auto simp: restrict_map_def map_add_def split: option.splits)

lemma restrict_map_compose:
  "\<lbrakk> S \<union> T = dom m ; S \<inter> T = {} \<rbrakk> \<Longrightarrow> m |` S ++ m |` T = m"
  by (fastforce simp: map_add_def restrict_map_def)

lemma map_le_dom_subset_restrict:
  "\<lbrakk> m' \<subseteq>\<^sub>m m; dom m' \<subseteq> S \<rbrakk> \<Longrightarrow> m' \<subseteq>\<^sub>m (m |` S)"
  by (force simp: restrict_map_def map_le_def)

lemma map_le_dom_restrict_sub_add:
  "m' \<subseteq>\<^sub>m m \<Longrightarrow> m |` (dom m - dom m') ++ m' = m"
  by (rule ext, auto simp: None_com map_add_def restrict_map_def map_le_def
                     split: option.splits; force simp: Some_com)

lemma subset_map_restrict_sub_add:
  "T \<subseteq> S \<Longrightarrow> m |` (S - T) ++ m |` T = m |` S"
  by (rule ext) (auto simp: restrict_map_def map_add_def split: option.splits)

lemma restrict_map_sub_union:
  "m |` (dom m - (S \<union> T)) = (m |` (dom m - T)) |` (dom m - S)"
  by (auto simp: restrict_map_def)

lemma prod_restrict_map_add:
  "\<lbrakk> S \<union> T = U; S \<inter> T = {} \<rbrakk> \<Longrightarrow> m |` (X \<times> S) ++ m |` (X \<times> T) = m |` (X \<times> U)"
  by (auto simp: map_add_def restrict_map_def split: option.splits)

section {* Things that should not go into Map.thy (separation logic) *}

subsection {* Definitions *}

text {* Map disjuction *}

definition
  map_disj :: "('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> bool" (infix "\<bottom>" 51) where
  "h\<^sub>0 \<bottom> h\<^sub>1 \<equiv> dom h\<^sub>0 \<inter> dom h\<^sub>1 = {}"

declare None_not_eq [simp]

subsection {* Properties of @{term "sub_restrict_map"} *}

lemma restrict_map_sub_add: "h |` S ++ h `- S = h"
  by (fastforce simp: sub_restrict_map_def restrict_map_def map_add_def
               split: option.splits if_split)

subsection {* Properties of map disjunction *}

lemma map_disj_empty_right [simp]:
  "h \<bottom> empty"
  by (simp add: map_disj_def)

lemma map_disj_empty_left [simp]:
  "empty \<bottom> h"
  by (simp add: map_disj_def)

lemma map_disj_com:
  "h\<^sub>0 \<bottom> h\<^sub>1 = h\<^sub>1 \<bottom> h\<^sub>0"
  by (simp add: map_disj_def, fast)

lemma map_disjD:
  "h\<^sub>0 \<bottom> h\<^sub>1 \<Longrightarrow> dom h\<^sub>0 \<inter> dom h\<^sub>1 = {}"
  by (simp add: map_disj_def)

lemma map_disjI:
  "dom h\<^sub>0 \<inter> dom h\<^sub>1 = {} \<Longrightarrow> h\<^sub>0 \<bottom> h\<^sub>1"
  by (simp add: map_disj_def)

subsection {* Map associativity-commutativity based on map disjuction *}

lemma map_add_com:
  "h\<^sub>0 \<bottom> h\<^sub>1 \<Longrightarrow> h\<^sub>0 ++ h\<^sub>1 = h\<^sub>1 ++ h\<^sub>0"
  by (drule map_disjD, rule map_add_comm, force)

lemma map_add_left_commute:
  "h\<^sub>0 \<bottom> h\<^sub>1 \<Longrightarrow> h\<^sub>0 ++ (h\<^sub>1 ++ h\<^sub>2) = h\<^sub>1 ++ (h\<^sub>0 ++ h\<^sub>2)"
  by (simp add: map_add_com map_disj_com)

lemma map_add_disj:
  "h\<^sub>0 \<bottom> (h\<^sub>1 ++ h\<^sub>2) = (h\<^sub>0 \<bottom> h\<^sub>1 \<and> h\<^sub>0 \<bottom> h\<^sub>2)"
  by (simp add: map_disj_def, fast)

lemma map_add_disj':
  "(h\<^sub>1 ++ h\<^sub>2) \<bottom> h\<^sub>0 = (h\<^sub>1 \<bottom> h\<^sub>0 \<and> h\<^sub>2 \<bottom> h\<^sub>0)"
  by (simp add: map_disj_def, fast)

text {*
  We redefine @{term "map_add"} associativity to bind to the right, which
  seems to be the more common case.
  Note that when a theory includes Map again, @{text "map_add_assoc"} will
  return to the simpset and will cause infinite loops if its symmetric
  counterpart is added (e.g. via @{text "map_add_ac"})
  *}

declare map_add_assoc [simp del]

text {*
  Since the associativity-commutativity of @{term "map_add"} relies on
  map disjunction, we include some basic rules into the ac set.
  *}

lemmas map_add_ac =
  map_add_assoc[symmetric] map_add_com map_disj_com
  map_add_left_commute map_add_disj map_add_disj'

subsection {* Basic properties *}

lemma map_disj_None_right:
  "\<lbrakk> h\<^sub>0 \<bottom> h\<^sub>1 ; x \<in> dom h\<^sub>0 \<rbrakk> \<Longrightarrow> h\<^sub>1 x = None"
  by (auto simp: map_disj_def dom_def)

lemma map_disj_None_left:
  "\<lbrakk> h\<^sub>0 \<bottom> h\<^sub>1 ; x \<in> dom h\<^sub>1 \<rbrakk> \<Longrightarrow> h\<^sub>0 x = None"
  by (auto simp: map_disj_def dom_def)

lemma map_disj_None_left':
  "\<lbrakk> h\<^sub>0 x = Some y ; h\<^sub>1 \<bottom> h\<^sub>0 \<rbrakk> \<Longrightarrow> h\<^sub>1 x = None "
  by (auto simp: map_disj_def)

lemma map_disj_None_right':
  "\<lbrakk> h\<^sub>1 x = Some y ; h\<^sub>1 \<bottom> h\<^sub>0 \<rbrakk> \<Longrightarrow> h\<^sub>0 x = None "
  by (auto simp: map_disj_def)

lemma map_disj_common:
  "\<lbrakk> h\<^sub>0 \<bottom> h\<^sub>1 ; h\<^sub>0 p = Some v ; h\<^sub>1 p = Some v' \<rbrakk> \<Longrightarrow> False"
  by (frule (1) map_disj_None_left', simp)

lemma map_disj_eq_dom_left:
  "\<lbrakk> h\<^sub>0 \<bottom> h\<^sub>1 ; dom h\<^sub>0' = dom h\<^sub>0 \<rbrakk> \<Longrightarrow> h\<^sub>0' \<bottom> h\<^sub>1"
  by (auto simp: map_disj_def)

subsection {* Map disjunction and addition *}

lemma map_add_eval_left:
  "\<lbrakk> x \<in> dom h ; h \<bottom> h' \<rbrakk> \<Longrightarrow> (h ++ h') x = h x"
  by (auto dest!: map_disj_None_right simp: map_add_def cong: option.case_cong)

lemma map_add_eval_right:
  "\<lbrakk> x \<in> dom h' \<rbrakk> \<Longrightarrow> (h ++ h') x = h' x"
  by (rule map_add_dom_app_simps)

lemma map_add_eval_right':
  "\<lbrakk> x \<notin> dom h \<rbrakk> \<Longrightarrow> (h ++ h') x = h' x"
  by (rule map_add_dom_app_simps)

lemma map_add_left_dom_eq:
  assumes eq: "h\<^sub>0 ++ h\<^sub>1 = h\<^sub>0' ++ h\<^sub>1'"
  assumes etc: "h\<^sub>0 \<bottom> h\<^sub>1" "h\<^sub>0' \<bottom> h\<^sub>1'" "dom h\<^sub>0 = dom h\<^sub>0'"
  shows "h\<^sub>0 = h\<^sub>0'"
proof -
  from eq have "h\<^sub>1 ++ h\<^sub>0 = h\<^sub>1' ++ h\<^sub>0'" using etc by (simp add: map_add_ac)
  thus ?thesis using etc
    by (fastforce elim!: map_add_right_dom_eq simp: map_add_ac)
qed

lemma map_add_left_eq:
  assumes eq: "h\<^sub>0 ++ h = h\<^sub>1 ++ h"
  assumes disj: "h\<^sub>0 \<bottom> h" "h\<^sub>1 \<bottom> h"
  shows "h\<^sub>0 = h\<^sub>1"
proof (rule ext)
  fix x
  from eq have eq': "(h\<^sub>0 ++ h) x = (h\<^sub>1 ++ h) x" by auto
  { assume "x \<in> dom h"
    hence "h\<^sub>0 x = h\<^sub>1 x" using disj by (simp add: map_disj_None_left)
  } moreover {
    assume "x \<notin> dom h"
    hence "h\<^sub>0 x = h\<^sub>1 x" using disj eq' by (simp add: map_add_eval_left')
  }
  ultimately show "h\<^sub>0 x = h\<^sub>1 x" by cases
qed

lemma map_add_right_eq:
  "\<lbrakk>h ++ h\<^sub>0 = h ++ h\<^sub>1; h\<^sub>0 \<bottom> h; h\<^sub>1 \<bottom> h\<rbrakk> \<Longrightarrow> h\<^sub>0 = h\<^sub>1"
  by (rule_tac h=h in map_add_left_eq, auto simp: map_add_ac)

lemma map_disj_add_eq_dom_right_eq:
  assumes merge: "h\<^sub>0 ++ h\<^sub>1 = h\<^sub>0' ++ h\<^sub>1'" and d: "dom h\<^sub>0 = dom h\<^sub>0'" and
      ab_disj: "h\<^sub>0 \<bottom> h\<^sub>1" and cd_disj: "h\<^sub>0' \<bottom> h\<^sub>1'"
  shows "h\<^sub>1 = h\<^sub>1'"
proof (rule ext)
  fix x
  from merge have merge_x: "(h\<^sub>0 ++ h\<^sub>1) x = (h\<^sub>0' ++ h\<^sub>1') x" by simp
  with d ab_disj cd_disj show  "h\<^sub>1 x = h\<^sub>1' x"
    by - (case_tac "h\<^sub>1 x", case_tac "h\<^sub>1' x", simp, fastforce simp: map_disj_def,
          case_tac "h\<^sub>1' x", clarsimp, simp add: Some_com,
          force simp: map_disj_def, simp)
qed

lemma map_disj_add_eq_dom_left_eq:
  assumes add: "h\<^sub>0 ++ h\<^sub>1 = h\<^sub>0' ++ h\<^sub>1'" and
          dom: "dom h\<^sub>1 = dom h\<^sub>1'" and
          disj: "h\<^sub>0 \<bottom> h\<^sub>1" "h\<^sub>0' \<bottom> h\<^sub>1'"
  shows "h\<^sub>0 = h\<^sub>0'"
proof -
  have "h\<^sub>1 ++ h\<^sub>0 = h\<^sub>1' ++ h\<^sub>0'" using add disj by (simp add: map_add_ac)
  thus ?thesis using dom disj
    by - (rule map_disj_add_eq_dom_right_eq, auto simp: map_disj_com)
qed

lemma map_add_left_cancel:
  assumes disj: "h\<^sub>0 \<bottom> h\<^sub>1" "h\<^sub>0 \<bottom> h\<^sub>1'"
  shows "(h\<^sub>0 ++ h\<^sub>1 = h\<^sub>0 ++ h\<^sub>1') = (h\<^sub>1 = h\<^sub>1')"
proof (rule iffI, rule ext)
  fix x
  assume "(h\<^sub>0 ++ h\<^sub>1) = (h\<^sub>0 ++ h\<^sub>1')"
  hence "(h\<^sub>0 ++ h\<^sub>1) x = (h\<^sub>0 ++ h\<^sub>1') x" by auto
  hence "h\<^sub>1 x = h\<^sub>1' x" using disj
    by (cases "x \<in> dom h\<^sub>0"; simp add: map_disj_None_right map_add_eval_right')
  thus "h\<^sub>1 x = h\<^sub>1' x" by auto
qed auto

lemma map_add_lr_disj:
  "\<lbrakk> h\<^sub>0 ++ h\<^sub>1 = h\<^sub>0' ++ h\<^sub>1'; h\<^sub>1 \<bottom> h\<^sub>1'  \<rbrakk> \<Longrightarrow> dom h\<^sub>1 \<subseteq> dom h\<^sub>0'"
  by (clarsimp simp: map_disj_def map_add_def, drule_tac x=x in fun_cong)
     (auto split: option.splits)

subsection {* Map disjunction and map updates *}

lemma map_disj_update_left [simp]:
  "p \<in> dom h\<^sub>1 \<Longrightarrow> h\<^sub>0 \<bottom> h\<^sub>1(p \<mapsto> v) = h\<^sub>0 \<bottom> h\<^sub>1"
  by (clarsimp simp: map_disj_def, blast)

lemma map_disj_update_right [simp]:
  "p \<in> dom h\<^sub>1 \<Longrightarrow> h\<^sub>1(p \<mapsto> v) \<bottom> h\<^sub>0 = h\<^sub>1 \<bottom> h\<^sub>0"
  by (simp add: map_disj_com)

lemma map_add_update_left:
  "\<lbrakk> h\<^sub>0 \<bottom> h\<^sub>1 ; p \<in> dom h\<^sub>0 \<rbrakk> \<Longrightarrow> (h\<^sub>0 ++ h\<^sub>1)(p \<mapsto> v) = (h\<^sub>0(p \<mapsto> v) ++ h\<^sub>1)"
  by (drule (1) map_disj_None_right)
     (auto simp: map_add_def cong: option.case_cong)

lemma map_add_update_right:
  "\<lbrakk> h\<^sub>0 \<bottom> h\<^sub>1 ; p \<in> dom h\<^sub>1  \<rbrakk> \<Longrightarrow> (h\<^sub>0 ++ h\<^sub>1)(p \<mapsto> v) = (h\<^sub>0 ++ h\<^sub>1 (p \<mapsto> v))"
  by (drule (1) map_disj_None_left)
     (auto simp: map_add_def cong: option.case_cong)

subsection {* Map disjunction and @{term "map_le"} *}

lemma map_le_override [simp]:
  "\<lbrakk> h \<bottom> h' \<rbrakk> \<Longrightarrow> h \<subseteq>\<^sub>m h ++ h'"
  by (auto simp: map_le_def map_add_def map_disj_def split: option.splits)

lemma map_leI_left:
  "\<lbrakk> h = h\<^sub>0 ++ h\<^sub>1 ; h\<^sub>0 \<bottom> h\<^sub>1 \<rbrakk> \<Longrightarrow> h\<^sub>0 \<subseteq>\<^sub>m h" by auto

lemma map_leI_right:
  "\<lbrakk> h = h\<^sub>0 ++ h\<^sub>1 ; h\<^sub>0 \<bottom> h\<^sub>1 \<rbrakk> \<Longrightarrow> h\<^sub>1 \<subseteq>\<^sub>m h" by auto

lemma map_disj_map_le:
  "\<lbrakk> h\<^sub>0' \<subseteq>\<^sub>m h\<^sub>0; h\<^sub>0 \<bottom> h\<^sub>1 \<rbrakk> \<Longrightarrow> h\<^sub>0' \<bottom> h\<^sub>1"
  by (force simp: map_disj_def map_le_def)

lemma map_le_on_disj_left:
  "\<lbrakk> h' \<subseteq>\<^sub>m h ; h\<^sub>0 \<bottom> h\<^sub>1 ; h' = h\<^sub>0 ++ h\<^sub>1 \<rbrakk> \<Longrightarrow> h\<^sub>0 \<subseteq>\<^sub>m h"
  unfolding map_le_def
  by (rule ballI, erule_tac x=a in ballE, auto simp: map_add_eval_left)+

lemma map_le_on_disj_right:
  "\<lbrakk> h' \<subseteq>\<^sub>m h ; h\<^sub>0 \<bottom> h\<^sub>1 ; h' = h\<^sub>1 ++ h\<^sub>0 \<rbrakk> \<Longrightarrow> h\<^sub>0 \<subseteq>\<^sub>m h"
  by (auto simp: map_le_on_disj_left map_add_ac)

lemma map_le_add_cancel:
  "\<lbrakk> h\<^sub>0 \<bottom> h\<^sub>1 ; h\<^sub>0' \<subseteq>\<^sub>m h\<^sub>0 \<rbrakk> \<Longrightarrow> h\<^sub>0' ++ h\<^sub>1 \<subseteq>\<^sub>m h\<^sub>0 ++ h\<^sub>1"
  by (auto simp: map_le_def map_add_def map_disj_def split: option.splits)

lemma map_le_override_bothD:
  assumes subm: "h\<^sub>0' ++ h\<^sub>1 \<subseteq>\<^sub>m h\<^sub>0 ++ h\<^sub>1"
  assumes disj': "h\<^sub>0' \<bottom> h\<^sub>1"
  assumes disj: "h\<^sub>0 \<bottom> h\<^sub>1"
  shows "h\<^sub>0' \<subseteq>\<^sub>m h\<^sub>0"
unfolding map_le_def
proof (rule ballI)
  fix a
  assume a: "a \<in> dom h\<^sub>0'"
  hence sumeq: "(h\<^sub>0' ++ h\<^sub>1) a = (h\<^sub>0 ++ h\<^sub>1) a"
    using subm unfolding map_le_def by auto
  from a have "a \<notin> dom h\<^sub>1" using disj' by (auto dest!: map_disj_None_right)
  thus "h\<^sub>0' a = h\<^sub>0 a" using a sumeq disj disj'
    by (simp add: map_add_eval_left map_add_eval_left')
qed

lemma map_le_conv:
  "(h\<^sub>0' \<subseteq>\<^sub>m h\<^sub>0 \<and> h\<^sub>0' \<noteq> h\<^sub>0) = (\<exists>h\<^sub>1. h\<^sub>0 = h\<^sub>0' ++ h\<^sub>1 \<and> h\<^sub>0' \<bottom> h\<^sub>1 \<and> h\<^sub>0' \<noteq> h\<^sub>0)"
  unfolding map_le_def map_disj_def map_add_def
  by (rule iffI,
      clarsimp intro!: exI[where x="\<lambda>x. if x \<notin> dom h\<^sub>0' then h\<^sub>0 x else None"])
     (fastforce intro: split: option.splits if_split_asm)+

lemma map_le_conv2:
  "h\<^sub>0' \<subseteq>\<^sub>m h\<^sub>0 = (\<exists>h\<^sub>1. h\<^sub>0 = h\<^sub>0' ++ h\<^sub>1 \<and> h\<^sub>0' \<bottom> h\<^sub>1)"
  by (case_tac "h\<^sub>0'=h\<^sub>0", insert map_le_conv, auto intro: exI[where x=empty])

subsection {* Map disjunction and restriction *}

lemma map_disj_comp [simp]:
  "h\<^sub>0 \<bottom> h\<^sub>1 |` (UNIV - dom h\<^sub>0)"
  by (force simp: map_disj_def)

lemma restrict_map_disj:
  "S \<inter> T = {} \<Longrightarrow> h |` S \<bottom> h |` T"
  by (auto simp: map_disj_def restrict_map_def dom_def)

lemma map_disj_restrict_dom [simp]:
  "h\<^sub>0 \<bottom> h\<^sub>1 |` (dom h\<^sub>1 - dom h\<^sub>0)"
  by (force simp: map_disj_def)

lemma restrict_map_disj_dom_empty:
  "h \<bottom> h' \<Longrightarrow> h |` dom h' = empty"
  by (fastforce simp: map_disj_def restrict_map_def)

lemma restrict_map_univ_disj_eq:
  "h \<bottom> h' \<Longrightarrow> h |` (UNIV - dom h') = h"
  by (rule ext, auto simp: map_disj_def restrict_map_def)

lemma restrict_map_disj_dom:
  "h\<^sub>0 \<bottom> h\<^sub>1 \<Longrightarrow> h |` dom h\<^sub>0 \<bottom> h |` dom h\<^sub>1"
  by (auto simp: map_disj_def restrict_map_def dom_def)

lemma map_add_restrict_dom_left:
  "h \<bottom> h' \<Longrightarrow> (h ++ h') |` dom h = h"
  by (rule ext, auto simp: restrict_map_def map_add_def dom_def map_disj_def
                     split: option.splits)

lemma map_add_restrict_dom_left':
  "h \<bottom> h' \<Longrightarrow> S = dom h \<Longrightarrow> (h ++ h') |` S = h"
  by (rule ext, auto simp: restrict_map_def map_add_def dom_def map_disj_def
                     split: option.splits)

lemma restrict_map_disj_right:
  "h\<^sub>0 \<bottom> h\<^sub>1 \<Longrightarrow> h\<^sub>0 \<bottom> h\<^sub>1 |` S"
  by (auto simp: map_disj_def)

lemmas restrict_map_disj_both = restrict_map_disj_right restrict_map_disj_left

lemma map_dom_disj_restrict_right:
  "h\<^sub>0 \<bottom> h\<^sub>1 \<Longrightarrow> (h\<^sub>0 ++ h\<^sub>0') |` dom h\<^sub>1 = h\<^sub>0' |` dom h\<^sub>1"
  by (simp add: map_add_restrict restrict_map_empty map_disj_def)

lemma restrict_map_on_disj:
  "h\<^sub>0' \<bottom> h\<^sub>1 \<Longrightarrow> h\<^sub>0 |` dom h\<^sub>0' \<bottom> h\<^sub>1"
  unfolding map_disj_def by auto

lemma restrict_map_on_disj':
  "h\<^sub>0 \<bottom> h\<^sub>1 \<Longrightarrow> h\<^sub>0 \<bottom> h\<^sub>1 |` S"
  by (rule restrict_map_disj_right)

lemma map_le_sub_dom:
  "\<lbrakk> h\<^sub>0 ++ h\<^sub>1 \<subseteq>\<^sub>m h ; h\<^sub>0 \<bottom> h\<^sub>1 \<rbrakk> \<Longrightarrow> h\<^sub>0 \<subseteq>\<^sub>m h |` (dom h - dom h\<^sub>1)"
  by (rule map_le_override_bothD, subst map_le_dom_restrict_sub_add)
     (auto elim: map_add_le_mapE simp: map_add_ac)

lemma map_submap_break:
  "\<lbrakk> h \<subseteq>\<^sub>m h' \<rbrakk> \<Longrightarrow> h' = (h' |` (UNIV - dom h)) ++ h"
  by (fastforce split: option.splits
                simp: map_le_restrict restrict_map_def map_le_def map_add_def
                      dom_def)

lemma map_add_disj_restrict_both:
  "\<lbrakk> h\<^sub>0 \<bottom> h\<^sub>1; S \<inter> S' = {}; T \<inter> T' = {} \<rbrakk>
   \<Longrightarrow> (h\<^sub>0 |` S) ++ (h\<^sub>1 |` T) \<bottom> (h\<^sub>0 |` S') ++ (h\<^sub>1 |` T')"
  by (auto simp: map_add_ac intro!: restrict_map_disj_both restrict_map_disj)

end


section \<open>Circus actions\<close>

theory Circus_Actions
imports HOLCF CSP_Processes
begin

text \<open>In this section, we introduce definitions for Circus actions with
some useful theorems and lemmas.\<close>

default_sort type

subsection \<open>Definitions\<close>

text \<open>The Circus actions type is defined as the set of all the CSP healthy reactive processes.\<close>

typedef ('\<theta>::"ev_eq",'\<sigma>)  "action" = "{p::('\<theta>,'\<sigma>) relation_rp. is_CSP_process p}"
    morphisms relation_of action_of
proof -
   have "R (false \<turnstile> true) \<in> {p :: ('\<theta>,'\<sigma>) relation_rp. is_CSP_process p}"
        by (auto intro: rd_is_CSP)
   thus ?thesis by auto
qed

print_theorems

text \<open>The type-definition introduces a new type by stating a set. In our case,
 it is the set of reactive processes that satisfy the healthiness-conditions
 for CSP-processes, isomorphic to the new type.
 Technically, this construct introduces two constants (morphisms) definitions $relation\_of$
 and $action\_of$ as well as the usual axioms expressing the bijection @{thm relation_of_inverse}
 and @{thm action_of_inverse}.\<close>

lemma relation_of_CSP: "is_CSP_process (relation_of x)"
proof -
have "(relation_of x) :{p. is_CSP_process p}" by (rule relation_of)
then show "is_CSP_process (relation_of x)" ..
qed

lemma relation_of_CSP1: "(relation_of x) is CSP1 healthy"
by (rule CSP_is_CSP1[OF relation_of_CSP])

lemma relation_of_CSP2: "(relation_of x) is CSP2 healthy"
by (rule CSP_is_CSP2[OF relation_of_CSP])

lemma relation_of_R: "(relation_of x) is R healthy"
by (rule CSP_is_R[OF relation_of_CSP])

subsection \<open>Proofs\<close>

text \<open>In the following, Circus actions are proved to be an instance of the $Complete\_Lattice$ class.\<close>

lemma relation_of_spec_f_f:
"\<forall>a b. (relation_of y \<longrightarrow> relation_of x) (a, b) \<Longrightarrow>
           (relation_of y)\<^sup>f\<^sub>f (a\<lparr>tr := []\<rparr>, b) \<Longrightarrow>
                      (relation_of x)\<^sup>f\<^sub>f (a\<lparr>tr := []\<rparr>, b)"
by (auto simp: spec_def)

lemma relation_of_spec_t_f:
"\<forall>a b. (relation_of y \<longrightarrow> relation_of x) (a, b) \<Longrightarrow>
           (relation_of y)\<^sup>t\<^sub>f (a\<lparr>tr := []\<rparr>, b) \<Longrightarrow>
                     (relation_of x)\<^sup>t\<^sub>f (a\<lparr>tr := []\<rparr>, b)"
by (auto simp: spec_def)

instantiation "action"::(ev_eq, type) below
begin
definition ref_def : "P \<sqsubseteq> Q \<equiv> [(relation_of Q) \<longrightarrow> (relation_of P)]"
instance ..
end

instance "action" :: (ev_eq, type) po
proof
  fix x y z::"('a, 'b) action"
  {
    show "x \<sqsubseteq> x" by (simp add: ref_def utp_defs)
  next
    assume "x \<sqsubseteq> y" and "y \<sqsubseteq> z" then show " x \<sqsubseteq> z"
      by (simp add: ref_def utp_defs)
  next
    assume A:"x \<sqsubseteq> y" and B:"y \<sqsubseteq> x" then show " x = y"
      by (auto simp add: ref_def relation_of_inject[symmetric] fun_eq_iff)
  }
qed

instantiation "action"  ::  (ev_eq, type) lattice
begin

definition inf_action : "(inf P Q \<equiv> action_of ((relation_of P) \<sqinter> (relation_of Q)))"
definition sup_action : "(sup P Q \<equiv> action_of ((relation_of P) \<squnion> (relation_of Q)))"
definition less_eq_action : "(less_eq (P::('a, 'b) action) Q \<equiv> P \<sqsubseteq> Q)"
definition less_action : "(less (P::('a, 'b) action) Q \<equiv> P \<sqsubseteq> Q \<and> \<not> Q \<sqsubseteq> P)"

instance
proof
  fix x y z::"('a, 'b) action"
  {
    show "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"
      by (simp add: less_action less_eq_action)
  next
    show "(x \<le> x)" by (simp add: less_eq_action)
  next
    assume "x \<le> y" and "y \<le> z"
    then show " x \<le> z"
      by (simp add: less_eq_action ref_def utp_defs)
  next
    assume "x \<le> y" and "y \<le> x"
    then show " x = y"
      by (auto simp add: less_eq_action ref_def relation_of_inject[symmetric] utp_defs)
  next
    show "inf x y \<le> x"
      apply (auto simp add: less_eq_action inf_action ref_def
        csp_defs design_defs rp_defs)
      apply (subst action_of_inverse, simp add: Healthy_def)
      apply (insert relation_of_CSP[where x="x"])
      apply (insert relation_of_CSP[where x="y"])
      apply (simp_all add: CSP_join)
      apply (simp add: utp_defs)
      done
  next
    show "inf x y \<le> y"
      apply (auto simp add: less_eq_action inf_action ref_def csp_defs)
      apply (subst action_of_inverse, simp add: Healthy_def)
      apply (insert relation_of_CSP[where x="x"])
      apply (insert relation_of_CSP[where x="y"])
      apply (simp_all add: CSP_join)
      apply (simp add: utp_defs)
      done
  next
    assume "x \<le> y" and "x \<le> z"
    then show "x \<le> inf y z"
      apply (auto simp add: less_eq_action inf_action ref_def impl_def csp_defs)
      apply (erule_tac x="a" in allE, erule_tac x="a" in allE)
      apply (erule_tac x="b" in allE)+
      apply (subst (asm) action_of_inverse)
      apply (simp add: Healthy_def)
      apply (insert relation_of_CSP[where x="z"])
      apply (insert relation_of_CSP[where x="y"])
      apply (auto simp add: CSP_join)
      done
  next
    show "x \<le> sup x y"
      apply (auto simp add: less_eq_action sup_action ref_def
         impl_def csp_defs)
      apply (subst (asm) action_of_inverse)
      apply (simp add: Healthy_def)
      apply (insert relation_of_CSP[where x="x"])
      apply (insert relation_of_CSP[where x="y"])
      apply (auto simp add: CSP_meet)
      done
  next
    show "y \<le> sup x y"
      apply (auto simp add: less_eq_action sup_action ref_def
         impl_def csp_defs)
      apply (subst (asm) action_of_inverse)
      apply (simp add: Healthy_def)
      apply (insert relation_of_CSP[where x="x"])
      apply (insert relation_of_CSP[where x="y"])
      apply (auto simp add: CSP_meet)
      done
  next
    assume "y \<le> x" and "z \<le> x"
    then show "sup y z \<le> x"
      apply (auto simp add: less_eq_action sup_action ref_def  impl_def csp_defs)
      apply (erule_tac x="a" in allE)
      apply (erule_tac x="a" in allE)
      apply (erule_tac x="b" in allE)+
      apply (subst action_of_inverse)
      apply (simp add: Healthy_def)
      apply (insert relation_of_CSP[where x="z"])
      apply (insert relation_of_CSP[where x="y"])
      apply (auto simp add: CSP_meet)
      done
  }
qed

end

lemma bot_is_action: "R (false \<turnstile> true) \<in> {p. is_CSP_process p}"
  by (auto intro: rd_is_CSP)

lemma bot_eq_true: "R (false \<turnstile> true) = R true"
  by (auto simp: fun_eq_iff design_defs rp_defs split: cond_splits)

instantiation "action"  ::  (ev_eq, type) bounded_lattice
begin

definition bot_action : "(bot::('a, 'b) action) \<equiv> action_of (R(false \<turnstile> true))"
definition top_action : "(top::('a, 'b) action) \<equiv> action_of (R(true \<turnstile> false))"

instance
proof
  fix x::"('a, 'b) action"
  {
    show "bot \<le> x"
      unfolding bot_action
      apply (auto simp add: less_action less_eq_action ref_def bot_action)
      apply (subst action_of_inverse) apply (rule bot_is_action)
      apply (subst bot_eq_true)
      apply (subst (asm) CSP_is_rd)
      apply (rule relation_of_CSP)
      apply (auto simp add: csp_defs rp_defs fun_eq_iff split: cond_splits)
      done
  next
    show "x \<le> top"
      apply (auto simp add: less_action less_eq_action ref_def top_action)
      apply (subst (asm) action_of_inverse)
      apply (simp)
      apply (rule rd_is_CSP)
      apply auto
      apply (subst action_of_cases[where x=x], simp_all)
      apply (subst action_of_inverse, simp_all)
      apply (subst CSP_is_rd[where P=y], simp_all)
      apply (auto simp: rp_defs design_defs fun_eq_iff split: cond_splits)
      done
  }
qed

end

lemma relation_of_top: "relation_of top = R(true \<turnstile> false)"
  apply (simp add: top_action)
  apply (subst action_of_inverse)
  apply (simp)
  apply (rule rd_is_CSP)
  apply (auto simp add: utp_defs design_defs rp_defs)
  done

lemma relation_of_bot: "relation_of bot = R true"
  apply (simp add: bot_action)
  apply (subst action_of_inverse)
  apply (simp add: bot_is_action[simplified], rule bot_eq_true)
  done

lemma non_emptyE: assumes "A \<noteq> {}" obtains x where "x : A"
  using assms by (auto simp add: ex_in_conv [symmetric])

lemma CSP1_Inf:
assumes *:"A \<noteq> {}"
shows "(\<Sqinter> relation_of ` A) is CSP1 healthy"
proof -
  have "(\<Sqinter> relation_of ` A) = CSP1 (\<Sqinter> relation_of ` A)"
  proof
    fix P
    note * then
    show "(P \<in> \<Union>{{p. P p} |P. P \<in> relation_of ` A}) = CSP1 (\<lambda>Aa. Aa \<in> \<Union>{{p. P p} |P. P \<in> relation_of ` A}) P"
    apply (intro iffI)
    apply (simp_all add: csp_defs)
    apply (rule disj_introC, simp)
    apply (erule disj_elim, simp_all)
    apply (cases P, simp_all)
    apply (erule non_emptyE)
    apply (rule_tac x="Collect (relation_of x)" in exI, simp)
    apply (rule conjI)
    apply (rule_tac x="(relation_of x)" in exI, simp)
    apply (subst CSP_is_rd, simp add: relation_of_CSP)
    apply (auto simp add: csp_defs design_defs rp_defs fun_eq_iff split: cond_splits)
    done
  qed
  then show "(\<Sqinter> relation_of ` A) is CSP1 healthy" by (simp add: design_defs)
qed

lemma CSP2_Inf:
assumes *:"A \<noteq> {}"
shows "(\<Sqinter> relation_of ` A) is CSP2 healthy"
proof -
  have "(\<Sqinter> relation_of ` A) = CSP2 (\<Sqinter> relation_of ` A)"
  proof
    fix P
    note * then
    show "(P \<in> \<Union>{{p. P p} |P. P \<in> relation_of ` A}) = CSP2 (\<lambda>Aa. Aa \<in> \<Union>{{p. P p} |P. P \<in> relation_of ` A}) P"
    apply (intro iffI)
    apply (simp_all add: csp_defs)
    apply (cases P, simp_all)
    apply (erule exE)
    apply (rule_tac b=b in comp_intro, simp_all)
    apply (rule_tac x=x in exI, simp)
    apply (erule comp_elim, simp_all)
    apply (erule exE | erule conjE)+
    apply (simp_all)
    apply (rule_tac x="Collect Pa" in exI, simp)
    apply (rule conjI)
    apply (rule_tac x="Pa" in exI, simp)
    apply (erule Set.imageE, simp add: relation_of)
    apply (subst CSP_is_rd, simp add: relation_of_CSP)
    apply (subst (asm) CSP_is_rd, simp add: relation_of_CSP)
    apply (auto simp add: csp_defs rp_defs prefix_def design_defs fun_eq_iff split: cond_splits)
    apply (subgoal_tac "b\<lparr>tr := zs, ok := False\<rparr> = c\<lparr>tr := zs, ok := False\<rparr>", auto)
    apply (subgoal_tac "b\<lparr>tr := zs, ok := False\<rparr> = c\<lparr>tr := zs, ok := False\<rparr>", auto)
    apply (subgoal_tac "b\<lparr>tr := zs, ok := False\<rparr> = c\<lparr>tr := zs, ok := False\<rparr>", auto)
    apply (subgoal_tac "b\<lparr>tr := zs, ok := False\<rparr> = c\<lparr>tr := zs, ok := False\<rparr>", auto)
    apply (subgoal_tac "b\<lparr>tr := zs, ok := False\<rparr> = c\<lparr>tr := zs, ok := False\<rparr>", auto)
    apply (subgoal_tac "b\<lparr>tr := zs, ok := False\<rparr> = c\<lparr>tr := zs, ok := False\<rparr>", auto)
    apply (subgoal_tac "b\<lparr>tr := zs, ok := True\<rparr> = c\<lparr>tr := zs, ok := True\<rparr>", auto)
    apply (subgoal_tac "b\<lparr>tr := zs, ok := True\<rparr> = c\<lparr>tr := zs, ok := True\<rparr>", auto)
    done
  qed
  then show "(\<Sqinter> relation_of ` A) is CSP2 healthy" by (simp add: design_defs)
qed

lemma R_Inf:
assumes *:"A \<noteq> {}"
shows "(\<Sqinter> relation_of ` A) is R healthy"
proof -
  have "(\<Sqinter> relation_of ` A) = R (\<Sqinter> relation_of ` A)"
  proof
    fix P
    show "(P \<in> \<Union>{{p. P p} |P. P \<in> relation_of ` A}) = R (\<lambda>Aa. Aa \<in> \<Union>{{p. P p} |P. P \<in> relation_of ` A}) P"
    apply (cases P, simp_all)
    apply (rule)
    apply (simp_all add: csp_defs rp_defs split: cond_splits)
    apply (erule exE)
    apply (erule exE | erule conjE)+
    apply (simp_all)
    apply (erule Set.imageE, simp add: relation_of)
    apply (subst (asm) CSP_is_rd, simp add: relation_of_CSP)
    apply (simp add: csp_defs prefix_def design_defs rp_defs fun_eq_iff split: cond_splits)
    apply (rule_tac x="x" in exI, simp)
    apply (rule conjI)
    apply (rule_tac x="relation_of xa" in exI, simp)
    apply (subst CSP_is_rd, simp add: relation_of_CSP)
    apply (simp add: csp_defs prefix_def design_defs rp_defs fun_eq_iff split: cond_splits)
    apply (insert *)
    apply (erule non_emptyE)
    apply (rule_tac x="Collect (relation_of x)" in exI, simp)
    apply (rule conjI)
    apply (rule_tac x="(relation_of x)" in exI, simp)
    apply (subst CSP_is_rd, simp add: relation_of_CSP)
    apply (simp add: csp_defs prefix_def design_defs rp_defs fun_eq_iff split: cond_splits)
    apply (erule exE | erule conjE)+
    apply (simp_all)
    apply (erule Set.imageE, simp add: relation_of)
    apply (rule_tac x="x" in exI, simp)
    apply (rule conjI)
    apply (rule_tac x="(relation_of xa)" in exI, simp)
    apply (subst CSP_is_rd, simp add: relation_of_CSP)
    apply (simp add: csp_defs prefix_def design_defs rp_defs fun_eq_iff split: cond_splits)
    apply (subst (asm) CSP_is_rd, simp add: relation_of_CSP)
    apply (simp add: csp_defs prefix_def design_defs rp_defs fun_eq_iff split: cond_splits)
    done
  qed
  then show "(\<Sqinter> relation_of ` A) is R healthy" by (simp add: design_defs)
qed

lemma CSP_Inf:
  assumes "A \<noteq> {}"
  shows "is_CSP_process (\<Sqinter> relation_of ` A)"
  unfolding is_CSP_process_def
  using assms CSP1_Inf CSP2_Inf R_Inf
  by auto

lemma Inf_is_action: "A \<noteq> {} \<Longrightarrow> \<Sqinter> relation_of ` A \<in> {p. is_CSP_process p}"
  by (auto dest!: CSP_Inf)

lemma CSP1_Sup: "A \<noteq> {} \<Longrightarrow> (\<Squnion> relation_of ` A) is CSP1 healthy"
  apply (auto simp add: design_defs csp_defs fun_eq_iff)
  apply (subst CSP_is_rd, simp add: relation_of_CSP)
  apply (simp add: csp_defs prefix_def design_defs rp_defs split: cond_splits)
done

lemma CSP2_Sup: "A \<noteq> {} \<Longrightarrow> (\<Squnion> relation_of ` A) is CSP2 healthy"
  apply (simp add: design_defs csp_defs fun_eq_iff)
  apply (rule allI)+
  apply (rule)
  apply (rule_tac b=b in comp_intro, simp_all)
  apply (erule comp_elim, simp_all)
  apply (rule allI)
  apply (erule_tac x=x in allE)
  apply (rule impI)
  apply (case_tac "(\<exists>P. x = Collect P & P \<in> relation_of ` A)", simp_all)
  apply (erule exE | erule conjE)+
  apply (simp_all)
  apply (erule Set.imageE, simp add: relation_of)
  apply (subst (asm) CSP_is_rd, simp add: relation_of_CSP, subst CSP_is_rd, simp add: relation_of_CSP)
  apply (auto simp add: csp_defs design_defs rp_defs split: cond_splits)
  apply (subgoal_tac "ba\<lparr>tr := tr c - tr aa, ok := False\<rparr> = c\<lparr>tr := tr c - tr aa, ok := False\<rparr>", simp_all)
  apply (subgoal_tac "ba\<lparr>tr := tr c - tr aa, ok := False\<rparr> = c\<lparr>tr := tr c - tr aa, ok := False\<rparr>", simp_all)
  apply (subgoal_tac "ba\<lparr>tr := tr c - tr aa, ok := False\<rparr> = c\<lparr>tr := tr c - tr aa, ok := False\<rparr>", simp_all)
  apply (subgoal_tac "ba\<lparr>tr := tr c - tr aa, ok := False\<rparr> = c\<lparr>tr := tr c - tr aa, ok := False\<rparr>", simp_all)
  apply (subgoal_tac "ba\<lparr>tr := tr c - tr aa, ok := False\<rparr> = c\<lparr>tr := tr c - tr aa, ok := False\<rparr>", simp_all)
  apply (subgoal_tac "ba\<lparr>tr := tr c - tr aa, ok := False\<rparr> = c\<lparr>tr := tr c - tr aa, ok := False\<rparr>", simp_all)
  apply (subgoal_tac "ba\<lparr>tr := tr c - tr aa, ok := True\<rparr> = c\<lparr>tr := tr c - tr aa, ok := True\<rparr>", simp_all)
  apply (subgoal_tac "ba\<lparr>tr := tr c - tr aa, ok := True\<rparr> = c\<lparr>tr := tr c - tr aa, ok := True\<rparr>", simp_all)
done

lemma R_Sup: "A \<noteq> {} \<Longrightarrow> (\<Squnion> relation_of ` A) is R healthy"
  apply (simp add: rp_defs design_defs csp_defs fun_eq_iff)
  apply (rule allI)+
  apply (rule)
  apply (simp split: cond_splits)
  apply (case_tac "wait a", simp_all)
  apply (erule non_emptyE)
  apply (erule_tac x="Collect (relation_of x)" in allE, simp_all)
  apply (case_tac "relation_of x (a, b)", simp_all)
  apply (subst (asm) CSP_is_rd, simp add: relation_of_CSP)
  apply (simp add: csp_defs design_defs rp_defs split: cond_splits)
  apply (erule_tac x="(relation_of x)" in allE, simp_all)
  apply (rule conjI)
  apply (rule allI)
  apply (erule_tac x=x in allE)
  apply (rule impI)
  apply (case_tac "(\<exists>P. x = Collect P & P \<in> relation_of ` A)", simp_all)
  apply (erule exE | erule conjE)+
  apply (simp_all)
  apply (erule Set.imageE, simp add: relation_of)
  apply (subst (asm) CSP_is_rd, simp add: relation_of_CSP, subst CSP_is_rd, simp add: relation_of_CSP)
  apply (simp add: csp_defs design_defs rp_defs split: cond_splits)
  apply (erule non_emptyE)
  apply (erule_tac x="Collect (relation_of x)" in allE, simp_all)
  apply (case_tac "relation_of x (a, b)", simp_all)
  apply (subst (asm) CSP_is_rd, simp add: relation_of_CSP)
  apply (simp add: csp_defs design_defs rp_defs split: cond_splits)
  apply (erule_tac x="(relation_of x)" in allE, simp_all)
  apply (simp split: cond_splits)
  apply (rule allI)
  apply (rule impI)
  apply (erule exE | erule conjE)+
  apply (simp_all)
  apply (erule Set.imageE, simp add: relation_of)
  apply (subst (asm) CSP_is_rd, simp add: relation_of_CSP, subst CSP_is_rd, simp add: relation_of_CSP)
  apply (simp add: csp_defs design_defs rp_defs split: cond_splits)
  apply (rule allI)
  apply (rule impI)
  apply (erule exE | erule conjE)+
  apply (simp_all)
  apply (erule Set.imageE, simp add: relation_of)
  apply (erule_tac x="x" in allE, simp_all)
  apply (case_tac "relation_of xa (a\<lparr>tr := []\<rparr>, b\<lparr>tr := tr b - tr a\<rparr>)", simp_all)
  apply (subst (asm) CSP_is_rd) back back back
  apply (simp add: relation_of_CSP, subst CSP_is_rd, simp add: relation_of_CSP)
  apply (simp add: csp_defs design_defs rp_defs split: cond_splits)
  apply (erule_tac x="P" in allE, simp_all)
done

lemma CSP_Sup: "A \<noteq> {} \<Longrightarrow> is_CSP_process (\<Squnion> relation_of ` A)"
  unfolding is_CSP_process_def using CSP1_Sup CSP2_Sup R_Sup by auto

lemma Sup_is_action: "A \<noteq> {} \<Longrightarrow> \<Squnion> relation_of ` A \<in> {p. is_CSP_process p}"
  by (auto dest!: CSP_Sup)

lemma relation_of_Sup:
  "A \<noteq> {} \<Longrightarrow> relation_of (action_of \<Squnion> relation_of ` A) = \<Squnion> relation_of ` A"
  by (auto simp: action_of_inverse dest!: Sup_is_action)

instantiation "action"  ::  (ev_eq, type) complete_lattice
begin

definition Sup_action :
"(Sup (S:: ('a, 'b) action set) \<equiv> if S={} then bot else action_of \<Squnion> (relation_of ` S))"
definition Inf_action :
"(Inf (S:: ('a, 'b) action set) \<equiv> if S={} then top else action_of \<Sqinter> (relation_of ` S))"

instance
proof
  fix A::"('a, 'b) action set" and z::"('a, 'b) action"
  {
    fix x::"('a, 'b) action"
    assume "x \<in> A"
    then show "Inf A \<le> x"
      apply (auto simp add: less_action less_eq_action Inf_action ref_def)
      apply (subst (asm) action_of_inverse)
      apply (auto intro: Inf_is_action[simplified])
      done
  } note rule1 = this
  {
    assume *: "\<And>x. x \<in> A \<Longrightarrow> z \<le> x"
    show "z \<le> Inf A"
    proof (cases "A = {}")
      case True
      then show ?thesis by (simp add: Inf_action)
    next
      case False
      show ?thesis
        using *
        apply (auto simp add: Inf_action)
        using \<open>A \<noteq> {}\<close>
        apply (simp add: less_eq_action Inf_action ref_def)
        apply (subst (asm) action_of_inverse)
        apply (subst (asm) ex_in_conv[symmetric])
        apply (erule exE)
        apply (auto intro: Inf_is_action[simplified])
        done
    qed
  }{
    fix x::"('a, 'b) action"
    assume "x \<in> A"
    then show "x \<le> (Sup A)"
      apply (auto simp add: less_action less_eq_action Sup_action ref_def)
      apply (subst (asm) action_of_inverse)
      apply (auto intro: Sup_is_action[simplified])
      done
  } note rule2 = this
  {
    assume "\<And>x. x \<in> A \<Longrightarrow> x \<le> z"
    then show "Sup A \<le> z"
      apply (auto simp add: Sup_action)
      apply atomize
      apply (case_tac "A = {}", simp_all)
      apply (insert rule2)
      apply (auto simp add: less_action less_eq_action Sup_action ref_def)
      apply (subst (asm) action_of_inverse)
      apply (auto intro: Sup_is_action[simplified])
      apply (subst (asm) action_of_inverse)
      apply (auto intro: Sup_is_action[simplified])
      done
  }
  { show "Inf ({}::('a, 'b) action set) = top" by(simp add:Inf_action) }
  { show "Sup ({}::('a, 'b) action set) = bot" by(simp add:Sup_action) }
qed

end

end


section \<open>Augmented Type Syntax for Concrete Checker\<close>

theory Wasm_Checker_Types imports Wasm "HOL-Library.Sublist" begin

datatype ct =
    TAny
  | TSome t

datatype checker_type =
    TopType "ct list"
  | Type "t list"
  | Bot

definition to_ct_list :: "t list \<Rightarrow> ct list" where
  "to_ct_list ts = map TSome ts"

fun ct_eq :: "ct \<Rightarrow> ct \<Rightarrow> bool" where
  "ct_eq (TSome t) (TSome t') = (t = t')"
| "ct_eq TAny _ = True"
| "ct_eq _ TAny = True"

definition ct_list_eq :: "ct list \<Rightarrow> ct list \<Rightarrow> bool" where
  "ct_list_eq ct1s ct2s = list_all2 ct_eq ct1s ct2s"

definition ct_prefix :: "ct list \<Rightarrow> ct list \<Rightarrow> bool" where
  "ct_prefix xs ys = (\<exists>as bs. ys = as@bs \<and> ct_list_eq as xs)"

definition ct_suffix :: "ct list \<Rightarrow> ct list \<Rightarrow> bool" where
  "ct_suffix xs ys = (\<exists>as bs. ys = as@bs \<and> ct_list_eq bs xs)"

lemma ct_eq_commute:
  assumes "ct_eq x y"
  shows "ct_eq y x"
  using assms
  by (metis ct_eq.elims(3) ct_eq.simps(1))

lemma ct_eq_flip: "ct_eq\<inverse>\<inverse> = ct_eq"
  using ct_eq_commute
  by fastforce

lemma ct_eq_common_tsome: "ct_eq x y = (\<exists>t. ct_eq x (TSome t) \<and> ct_eq (TSome t) y)"
  by (metis ct_eq.elims(3) ct_eq.simps(1))

lemma ct_list_eq_commute:
  assumes "ct_list_eq xs ys"
  shows "ct_list_eq ys xs"
  using assms ct_eq_commute List.List.list.rel_flip ct_eq_flip
  unfolding ct_list_eq_def
  by fastforce

lemma ct_list_eq_refl: "ct_list_eq xs xs"
  unfolding ct_list_eq_def
  by (metis ct_eq.elims(3) ct_eq.simps(1) list_all2_refl)

lemma ct_list_eq_length:
  assumes "ct_list_eq xs ys"
  shows "length xs = length ys"
  using assms list_all2_lengthD
  unfolding ct_list_eq_def
  by blast

lemma ct_list_eq_concat:
  assumes "ct_list_eq xs ys"
          "ct_list_eq xs' ys'"
  shows "ct_list_eq (xs@xs') (ys@ys')"
  using assms
  unfolding ct_list_eq_def
  by (simp add: list_all2_appendI)

lemma ct_list_eq_ts_conv_eq:
  "ct_list_eq (to_ct_list ts) (to_ct_list ts') = (ts = ts')"
  unfolding ct_list_eq_def to_ct_list_def
            list_all2_map1 list_all2_map2
            ct_eq.simps(1)
  by (simp add: list_all2_eq)

lemma ct_list_eq_exists: "\<exists>ys. ct_list_eq xs (to_ct_list ys)"
proof (induction xs)
  case Nil
  thus ?case
    unfolding ct_list_eq_def to_ct_list_def
    by (simp)
next
  case (Cons a xs)
  thus ?case
    unfolding ct_list_eq_def to_ct_list_def
    apply (cases a)
     apply (metis ct_eq.simps(3) ct_eq_commute list.rel_intros(2) list.simps(9))
    apply (metis ct_eq.simps(1) list.rel_intros(2) list.simps(9))
    done
qed

lemma ct_list_eq_common_tsome_list:
  "ct_list_eq xs ys = (\<exists>zs. ct_list_eq xs (to_ct_list zs) \<and> ct_list_eq (to_ct_list zs) ys)"
proof (induction ys arbitrary: xs)
  case Nil
  thus ?case
    unfolding ct_list_eq_def to_ct_list_def
    by simp
next
  case (Cons a ys)
  show ?case
  proof (safe)
    assume assms:"ct_list_eq xs (a # ys)"
    then obtain x' xs' where xs_def:"xs = x'#xs'"
      by (meson ct_list_eq_def list_all2_Cons2)
    then obtain zs where zs_def:"ct_eq x' a"
                                "ct_list_eq xs' (to_ct_list zs) \<and> ct_list_eq (to_ct_list zs) ys"
      using Cons[of xs'] assms list_all2_Cons
      unfolding ct_list_eq_def
      by fastforce
    obtain z where "ct_eq x' (TSome z)" "ct_eq (TSome z) a"
      using ct_eq_common_tsome[of x' a] zs_def(1)
      by fastforce
    hence "ct_list_eq (x'#xs') (to_ct_list (z#zs)) \<and> ct_list_eq (to_ct_list (z#zs)) (a # ys)"
      using zs_def(2) list_all2_Cons
      unfolding ct_list_eq_def to_ct_list_def
      by simp
    thus "\<exists>zs. ct_list_eq xs (to_ct_list zs) \<and> ct_list_eq (to_ct_list zs) (a # ys)"
      using xs_def
      by fastforce
  next
    fix zs
    assume assms:"ct_list_eq xs (to_ct_list zs)" "ct_list_eq (to_ct_list zs) (a # ys)"
    then obtain x' xs' z' zs' where "xs = x'#xs'"
                                    "zs = z'#zs'"
                                    "ct_list_eq xs' (to_ct_list zs')"
                                    "ct_list_eq (to_ct_list zs') (ys)"
      using list_all2_Cons2
      unfolding ct_list_eq_def to_ct_list_def list_all2_map1 list_all2_map2
      by (metis (no_types, lifting))
    thus "ct_list_eq xs (a # ys)"
      using assms Cons ct_list_eq_def to_ct_list_def ct_eq_common_tsome
      by (metis list.simps(9) list_all2_Cons)
  qed
qed

lemma ct_list_eq_cons_ct_list:
  assumes "ct_list_eq (to_ct_list as) (xs @ ys)"
  shows "\<exists>bs bs'. as = bs @ bs' \<and> ct_list_eq (to_ct_list bs) xs \<and> ct_list_eq (to_ct_list bs') ys"
  using assms
proof (induction xs arbitrary: as)
  case Nil
  thus ?case
    by (metis append_Nil ct_list_eq_ts_conv_eq list.simps(8) to_ct_list_def)
next
  case (Cons a xs)
  thus ?case
    unfolding ct_list_eq_def to_ct_list_def list_all2_map1
    by (meson list_all2_append2)
qed

lemma ct_list_eq_cons_ct_list1:
  assumes "ct_list_eq (to_ct_list as) (xs @ (to_ct_list ys))"
  shows "\<exists>bs. as = bs @ ys \<and> ct_list_eq (to_ct_list bs) xs"
  using ct_list_eq_cons_ct_list[OF assms] ct_list_eq_ts_conv_eq
  by fastforce

lemma ct_list_eq_shared:
  assumes "ct_list_eq xs (to_ct_list as)"
          "ct_list_eq ys (to_ct_list as)"
  shows "ct_list_eq xs ys"
  using assms ct_list_eq_def
  by (meson ct_list_eq_common_tsome_list ct_list_eq_commute)

lemma ct_list_eq_take:
  assumes "ct_list_eq xs ys"
  shows "ct_list_eq (take n xs) (take n ys)"
  using assms list_all2_takeI
  unfolding ct_list_eq_def
  by blast

lemma ct_prefixI [intro?]:
  assumes "ys = as @ zs"
          "ct_list_eq as xs"
  shows "ct_prefix xs ys"
  using assms
  unfolding ct_prefix_def
  by blast

lemma ct_prefixE [elim?]:
  assumes "ct_prefix xs ys"
  obtains as zs where "ys = as @ zs" "ct_list_eq as xs"
  using assms
  unfolding ct_prefix_def
  by blast

lemma ct_prefix_snoc [simp]: "ct_prefix xs (ys @ [y]) = (ct_list_eq xs (ys@[y]) \<or> ct_prefix xs ys)"
proof (safe)
  assume "ct_prefix xs (ys @ [y])" "\<not> ct_prefix xs ys"
  thus "ct_list_eq xs (ys @ [y])"
    unfolding ct_prefix_def ct_list_eq_def
    by (metis butlast_append butlast_snoc ct_eq_flip list.rel_flip)
next
  assume "ct_list_eq xs (ys @ [y])"
  thus "ct_prefix xs (ys @ [y])"
    using ct_list_eq_commute ct_prefixI
    by fastforce
next
  assume "ct_prefix xs ys"
  thus "ct_prefix xs (ys @ [y])"
    using append_assoc
    unfolding ct_prefix_def
    by blast
qed

lemma ct_prefix_nil:"ct_prefix [] xs"
                    "\<not>ct_prefix (x # xs) []"
  by (simp_all add: ct_prefix_def ct_list_eq_def)

lemma Cons_ct_prefix_Cons[simp]: "ct_prefix (x # xs) (y # ys) = ((ct_eq x y) \<and> ct_prefix xs ys)"
proof (safe)
  assume "ct_prefix (x # xs) (y # ys)"
  thus "ct_eq x y"
    unfolding ct_prefix_def ct_list_eq_def
    by (metis ct_eq_commute hd_append2 list.sel(1) list.simps(3) list_all2_Cons2)
next
  assume "ct_prefix (x # xs) (y # ys)"
  thus "ct_prefix xs ys"
    unfolding ct_prefix_def ct_list_eq_def
    by (metis list.rel_distinct(1) list.sel(3) list_all2_Cons2 tl_append2)
next
  assume "ct_eq x y" "ct_prefix xs ys"
  thus "ct_prefix (x # xs) (y # ys)"
    unfolding ct_prefix_def ct_list_eq_def
    by (metis (full_types) append_Cons ct_list_eq_commute ct_list_eq_def list.rel_inject(2))
qed

lemma ct_prefix_code [code]:
  "ct_prefix [] xs = True"
  "ct_prefix (x # xs) [] = False"
  "ct_prefix (x # xs) (y # ys) = ((ct_eq x y) \<and> ct_prefix xs ys)"
  by (simp_all add: ct_prefix_nil)

lemma ct_suffix_to_ct_prefix [code]: "ct_suffix xs ys = ct_prefix (rev xs) (rev ys)"
  unfolding ct_suffix_def ct_prefix_def ct_list_eq_def
  by (metis list_all2_rev1 rev_append rev_rev_ident)

lemma inj_TSome: "inj TSome"
  by (meson ct.inject injI)

lemma to_ct_list_append:
  assumes "to_ct_list ts = as@bs"
  shows "\<exists>as'. to_ct_list as' = as"
        "\<exists>bs'. to_ct_list bs' = bs"
  using assms
proof (induct as arbitrary: ts)
  fix ts
  assume "to_ct_list ts = [] @ bs"
  thus "\<exists>as'. to_ct_list as' = []"
       "\<exists>bs'. to_ct_list bs' = bs"
    unfolding to_ct_list_def
    by auto
next
  case (Cons a as)
  fix ts
  assume local_assms:"to_ct_list ts = (a # as) @ bs"
  then obtain t' ts' where "ts = t'#ts'"
    unfolding to_ct_list_def
    by auto
  thus "\<exists>as'. to_ct_list as' = a # as"
       "\<exists>as'. to_ct_list as' = bs"
    using Cons local_assms
    unfolding to_ct_list_def
    apply simp_all
     apply (metis list.simps(9))
    apply blast
    done
qed

lemma ct_suffixI [intro?]:
  assumes "ys = as @ zs"
          "ct_list_eq zs xs"
  shows "ct_suffix xs ys"
  using assms
  unfolding ct_suffix_def
  by blast

lemma ct_suffixE [elim?]:
  assumes "ct_suffix xs ys"
  obtains as zs where "ys = as @ zs" "ct_list_eq zs xs"
  using assms
  unfolding ct_suffix_def
  by blast

lemma ct_suffix_nil: "ct_suffix [] ts"
  unfolding ct_suffix_def
  using ct_list_eq_refl
  by auto

lemma ct_suffix_refl: "ct_suffix ts ts"
  unfolding ct_suffix_def
  using ct_list_eq_refl
  by auto

lemma ct_suffix_length:
  assumes "ct_suffix ts ts'"
  shows "length ts \<le> length ts'"
  using assms list_all2_lengthD
  unfolding ct_suffix_def ct_list_eq_def
  by fastforce

lemma ct_suffix_take:
  assumes "ct_suffix ts ts'"
  shows "ct_suffix ((take (length ts - n) ts)) ((take (length ts' - n) ts'))"
  using assms ct_list_eq_take append_eq_conv_conj
  unfolding ct_suffix_def
proof -
  assume "\<exists>as bs. ts' = as @ bs \<and> ct_list_eq bs ts"
  then obtain ccs :: "ct list" and ccsa :: "ct list" where
    f1: "ts' = ccs @ ccsa \<and> ct_list_eq ccsa ts"
    by moura
  then have f2: "length ccsa = length ts"
    by (meson ct_list_eq_length)
  have "\<And>n. ct_list_eq (take n ccsa) (take n ts)"
    using f1 by (meson ct_list_eq_take)
  then show "\<exists>cs csa. take (length ts' - n) ts' = cs @ csa \<and> ct_list_eq csa (take (length ts - n) ts)"
    using f2 f1 by auto
qed

lemma ct_suffix_ts_conv_suffix:
  "ct_suffix (to_ct_list ts) (to_ct_list ts') = suffix ts ts'"
proof safe
  assume "ct_suffix (to_ct_list ts) (to_ct_list ts')"
  then obtain as bs where "to_ct_list ts' = (to_ct_list as) @ (to_ct_list bs)"
                          "ct_list_eq (to_ct_list bs) (to_ct_list ts)"
    using to_ct_list_append
    unfolding ct_suffix_def
    by metis
  thus "suffix ts ts'"
    using ct_list_eq_ts_conv_eq
    unfolding ct_suffix_def to_ct_list_def suffix_def
    by (metis map_append)
next
  assume "suffix ts ts'"
  thus "ct_suffix (to_ct_list ts) (to_ct_list ts')"
    using ct_list_eq_ts_conv_eq
    unfolding ct_suffix_def to_ct_list_def suffix_def
    by (metis map_append)
qed

lemma ct_suffix_exists: "\<exists>ts_c. ct_suffix x1 (to_ct_list ts_c)"
  using ct_list_eq_commute ct_list_eq_exists ct_suffix_def
  by fastforce

lemma ct_suffix_ct_list_eq_exists:
  assumes "ct_suffix x1 x2"
  shows "\<exists>ts_c. ct_suffix x1 (to_ct_list ts_c) \<and> ct_list_eq (to_ct_list ts_c) x2"
proof -
  obtain as bs where x2_def:"x2 = as @ bs" "ct_list_eq x1 bs"
    using assms ct_list_eq_commute
    unfolding ct_suffix_def
    by blast
  then obtain ts_as ts_bs where "ct_list_eq as (to_ct_list ts_as)"
                                "ct_list_eq x1 (to_ct_list ts_bs)"
                                "ct_list_eq (to_ct_list ts_bs) bs"
    using ct_list_eq_common_tsome_list[of x1 bs] ct_list_eq_exists
    by fastforce
  thus ?thesis
    using x2_def ct_list_eq_commute
    unfolding ct_suffix_def to_ct_list_def
    by (metis ct_list_eq_def list_all2_appendI map_append)
qed

lemma ct_suffix_cons_ct_list:
  assumes "ct_suffix (xs@ys) (to_ct_list zs)"
  shows "\<exists>as bs. zs = as@bs \<and> ct_list_eq ys (to_ct_list bs) \<and> ct_suffix xs (to_ct_list as)"
proof -
  obtain as bs where "to_ct_list zs = (to_ct_list as) @ (to_ct_list bs)"
                     "ct_list_eq (to_ct_list bs) (xs @ ys)"
    using assms to_ct_list_append[of zs]
    unfolding ct_suffix_def
    by blast
  thus ?thesis
    using assms ct_list_eq_cons_ct_list[of bs xs ys]
    unfolding ct_suffix_def
  by (metis append.assoc ct_list_eq_commute ct_list_eq_ts_conv_eq map_append to_ct_list_def)
qed

lemma ct_suffix_cons_ct_list1:
  assumes "ct_suffix (xs@(to_ct_list ys)) (to_ct_list zs)"
  shows "\<exists>as. zs = as@ys \<and> ct_suffix xs (to_ct_list as)"
  using ct_suffix_cons_ct_list[OF assms] ct_list_eq_ts_conv_eq
  by fastforce

lemma ct_suffix_cons2:
  assumes "ct_suffix (xs) (ys@zs)"
          "length xs = length zs"
  shows "ct_list_eq xs zs"
  using assms
  by (metis append_eq_append_conv ct_list_eq_commute ct_list_eq_def ct_suffix_def list_all2_lengthD)

lemma ct_suffix_imp_ct_list_eq:
  assumes "ct_suffix xs ys"
  shows "ct_list_eq (drop (length ys - length xs) ys) xs"
  using assms ct_list_eq_def list_all2_lengthD
  unfolding ct_suffix_def
  by fastforce

lemma ct_suffix_extend_ct_list_eq:
  assumes "ct_suffix xs ys"
          "ct_list_eq xs' ys'"
  shows "ct_suffix (xs@xs') (ys@ys')"
  using assms
  unfolding ct_suffix_def ct_list_eq_def
  by (meson append.assoc ct_list_eq_commute ct_list_eq_def list_all2_appendI)

lemma ct_suffix_extend_any1:
  assumes "ct_suffix xs ys"
          "length xs < length ys"
  shows "ct_suffix (TAny#xs) ys"
proof -
  obtain as bs where ys_def:"ys = as@bs"
                            "ct_list_eq bs xs"
    using assms(1) ct_suffix_def
    by fastforce
  hence "length as > 0"
    using list_all2_lengthD assms(2)
    unfolding ct_list_eq_def
    by fastforce
  then obtain as' a where as_def:"as = as'@[a]"
    by (metis append_butlast_last_id length_greater_0_conv)
  hence "ct_list_eq (a#bs) (TAny#xs)"
    using ys_def
    by (meson ct_eq.simps(2) ct_list_eq_commute ct_list_eq_def list.rel_intros(2))
  thus ?thesis
    using as_def ys_def ct_suffix_def
    by fastforce
qed

lemma ct_suffix_singleton_any: "ct_suffix [TAny] [t]"
  using ct_suffix_extend_ct_list_eq[of "[]" "[]" "[TAny]" "[t]"] ct_suffix_nil
  by (simp add: ct_list_eq_def)

lemma ct_suffix_cons_it: "ct_suffix xs (xs'@xs)"
  using ct_list_eq_refl ct_suffix_def
  by blast

lemma ct_suffix_singleton:
  assumes "length cts > 0"
  shows "ct_suffix [TAny] cts"
proof -
  have "\<And>c. ct_prefix [TAny] [c]"
    using ct_suffix_singleton_any ct_suffix_to_ct_prefix by force
  then show ?thesis
    by (metis (no_types) Suc_leI append_butlast_last_id assms butlast.simps(2) ct_list_eq_commute
                         ct_prefix_nil(2) ct_prefix_snoc ct_suffix_def impossible_Cons length_Cons
                         list.size(3))
qed

lemma ct_suffix_less:
  assumes "ct_suffix (xs@xs') ys"
  shows "ct_suffix xs' ys"
  using assms
  unfolding ct_suffix_def
  by (metis append_eq_appendI ct_list_eq_def list_all2_append2)

lemma ct_suffix_unfold_one: "ct_suffix (xs@[x]) (ys@[y]) = ((ct_eq x y) \<and> ct_suffix xs ys)"
  using ct_prefix_code(3)
  by (simp add: ct_suffix_to_ct_prefix)

lemma ct_suffix_shared:
  assumes "ct_suffix cts (to_ct_list ts)"
          "ct_suffix cts' (to_ct_list ts)"
  shows "ct_suffix cts cts' \<or> ct_suffix cts' cts"
proof (cases "length cts > length cts'")
  case True
  obtain as bs where cts_def:"ts = as@bs"
                             "ct_list_eq cts (to_ct_list bs)"
    using assms(1) ct_suffix_def to_ct_list_def
    by (metis append_Nil ct_suffix_cons_ct_list)
  obtain as' bs' where cts'_def:"ts = as'@bs'"
                                "ct_list_eq cts' (to_ct_list bs')"
    using assms(2) ct_suffix_def to_ct_list_def
    by (metis append_Nil ct_suffix_cons_ct_list)
  obtain ct1s ct2s where "cts = ct1s@ct2s"
                         "length ct2s = length cts'"
    using True (* List.append_eq_conv_conj[of _ _ cts] *)
    by (metis add_diff_cancel_right' append_take_drop_id length_drop less_imp_le_nat nat_le_iff_add)
  show ?thesis
  proof -
    obtain tts :: "t list \<Rightarrow> ct list \<Rightarrow> ct list \<Rightarrow> t list" and ttsa :: "t list \<Rightarrow> ct list \<Rightarrow> ct list \<Rightarrow> t list" where
      "\<forall>x0 x1 x2. (\<exists>v3 v4. x0 = v3 @ v4 \<and> ct_list_eq x1 (to_ct_list v4) \<and> ct_suffix x2 (to_ct_list v3)) = (x0 = tts x0 x1 x2 @ ttsa x0 x1 x2 \<and> ct_list_eq x1 (to_ct_list (ttsa x0 x1 x2)) \<and> ct_suffix x2 (to_ct_list (tts x0 x1 x2)))"
      by moura
    then have f1: "as' @ bs' = tts (as' @ bs') ct2s ct1s @ ttsa (as' @ bs') ct2s ct1s \<and> ct_list_eq ct2s (to_ct_list (ttsa (as' @ bs') ct2s ct1s)) \<and> ct_suffix ct1s (to_ct_list (tts (as' @ bs') ct2s ct1s))"
      using assms(1) \<open>cts = ct1s @ ct2s\<close> cts'_def(1) ct_suffix_cons_ct_list by force
    then have "ct_list_eq cts' (to_ct_list (ttsa (as' @ bs') ct2s ct1s))"
      by (metis \<open>ct_suffix cts' (to_ct_list ts)\<close> \<open>length ct2s = length cts'\<close> cts'_def(1) ct_list_eq_length ct_suffix_cons2 map_append to_ct_list_def)
    then show ?thesis
      using f1 by (metis \<open>cts = ct1s @ ct2s\<close> ct_list_eq_shared ct_suffix_def)
  qed
next
  case False
  hence len:"length cts' \<ge> length cts"
    by linarith
  obtain as bs where cts_def:"ts = as@bs"
                             "ct_list_eq cts (to_ct_list bs)"
    using assms(1) ct_suffix_def to_ct_list_def
    by (metis append_Nil ct_suffix_cons_ct_list)
  obtain as' bs' where cts'_def:"ts = as'@bs'"
                                "ct_list_eq cts' (to_ct_list bs')"
    using assms(2) ct_suffix_def to_ct_list_def
    by (metis append_Nil ct_suffix_cons_ct_list)
  obtain ct1s ct2s where "cts' = ct1s@ct2s"
                         "length ct2s = length cts"
    using len (* List.append_eq_conv_conj[of _ _ cts] *)
    by (metis add_diff_cancel_right' append_take_drop_id length_drop nat_le_iff_add)
  show ?thesis
  proof -
    obtain tts :: "t list \<Rightarrow> ct list \<Rightarrow> ct list \<Rightarrow> t list" and ttsa :: "t list \<Rightarrow> ct list \<Rightarrow> ct list \<Rightarrow> t list" where
      "\<forall>x0 x1 x2. (\<exists>v3 v4. x0 = v3 @ v4 \<and> ct_list_eq x1 (to_ct_list v4) \<and> ct_suffix x2 (to_ct_list v3)) = (x0 = tts x0 x1 x2 @ ttsa x0 x1 x2 \<and> ct_list_eq x1 (to_ct_list (ttsa x0 x1 x2)) \<and> ct_suffix x2 (to_ct_list (tts x0 x1 x2)))"
      by moura
    then have f1: "as @ bs = tts (as @ bs) ct2s ct1s @ ttsa (as @ bs) ct2s ct1s \<and> ct_list_eq ct2s (to_ct_list (ttsa (as @ bs) ct2s ct1s)) \<and> ct_suffix ct1s (to_ct_list (tts (as @ bs) ct2s ct1s))"
      using assms(2) \<open>cts' = ct1s @ ct2s\<close> cts_def(1) ct_suffix_cons_ct_list by force
    then have "ct_list_eq cts (to_ct_list (ttsa (as @ bs) ct2s ct1s))"
      by (metis \<open>ct_suffix cts (to_ct_list ts)\<close> \<open>length ct2s = length cts\<close> cts_def(1) ct_list_eq_length ct_suffix_cons2 map_append to_ct_list_def)
    then show ?thesis
      using f1 by (metis \<open>cts' = ct1s @ ct2s\<close> ct_list_eq_shared ct_suffix_def)
  qed
qed

fun checker_type_suffix::"checker_type \<Rightarrow> checker_type \<Rightarrow> bool" where
  "checker_type_suffix (Type ts) (Type ts') = suffix ts ts'"
| "checker_type_suffix (Type ts) (TopType cts) = ct_suffix (to_ct_list ts) cts"
| "checker_type_suffix (TopType cts) (Type ts) = ct_suffix cts (to_ct_list ts)"
| "checker_type_suffix _ _ = False"

fun consume :: "checker_type \<Rightarrow> ct list \<Rightarrow> checker_type" where
  "consume (Type ts) cons = (if ct_suffix cons (to_ct_list ts)
                               then Type (take (length ts - length cons) ts)
                               else Bot)"
| "consume (TopType cts) cons = (if ct_suffix cons cts
                                  then TopType (take (length cts - length cons) cts)
                                  else (if ct_suffix cts cons
                                          then TopType []
                                          else Bot))"
| "consume _ _ = Bot"

fun produce :: "checker_type \<Rightarrow> checker_type \<Rightarrow> checker_type" where
  "produce (TopType ts) (Type ts') = TopType (ts@(to_ct_list ts'))"
| "produce (Type ts) (Type ts') = Type (ts@ts')"
| "produce (Type ts') (TopType ts) = TopType ts"
| "produce (TopType ts') (TopType ts) = TopType ts"
| "produce _ _ = Bot"

fun type_update :: "checker_type \<Rightarrow> ct list \<Rightarrow> checker_type \<Rightarrow> checker_type" where
  "type_update curr_type cons prods = produce (consume curr_type cons) prods"

fun select_return_top :: "[ct list] \<Rightarrow> ct \<Rightarrow> ct \<Rightarrow> checker_type" where
  "select_return_top ts ct1 TAny = TopType ((take (length ts - 3) ts) @ [ct1])"
| "select_return_top ts TAny ct2 = TopType ((take (length ts - 3) ts) @ [ct2])"
| "select_return_top ts (TSome t1) (TSome t2) = (if (t1 = t2)
                                                   then (TopType ((take (length ts - 3) ts) @ [TSome t1]))
                                                   else Bot)"

fun type_update_select :: "checker_type \<Rightarrow> checker_type" where
  "type_update_select (Type ts) = (if (length ts \<ge> 3 \<and> (ts!(length ts-2)) = (ts!(length ts-3)))
                                    then consume (Type ts) [TAny, TSome T_i32]
                                    else Bot)"
| "type_update_select (TopType ts) = (case length ts of
                                        0 \<Rightarrow> TopType [TAny]
                                      | Suc 0 \<Rightarrow> type_update (TopType ts) [TSome T_i32] (TopType [TAny])
                                      | Suc (Suc 0) \<Rightarrow> consume (TopType ts) [TSome T_i32]
                                      | _  \<Rightarrow> type_update (TopType ts) [TAny, TAny, TSome T_i32]
                                                          (select_return_top ts (ts!(length ts-2)) (ts!(length ts-3))))"
| "type_update_select _ = Bot"

fun c_types_agree :: "checker_type \<Rightarrow> t list \<Rightarrow> bool" where
  "c_types_agree (Type ts) ts' = (ts = ts')"
| "c_types_agree (TopType ts) ts' = ct_suffix ts (to_ct_list ts')"
| "c_types_agree Bot _ = False"

lemma consume_type:
  assumes "consume (Type ts) ts' = c_t"
          "c_t \<noteq> Bot"
  shows "\<exists>ts''. ct_list_eq (to_ct_list ts) ((to_ct_list ts'')@ts') \<and> c_t = Type ts''"
proof -
  {
    assume a1: "(if ct_suffix ts' (map TSome ts) then Type (take (length ts - length ts') ts) else Bot) = c_t"
    assume a2: "c_t \<noteq> Bot"
    obtain ccs :: "ct list \<Rightarrow> ct list \<Rightarrow> ct list" and ccsa :: "ct list \<Rightarrow> ct list \<Rightarrow> ct list" where
      f3: "\<forall>cs csa. \<not> ct_suffix cs csa \<or> csa = ccs cs csa @ ccsa cs csa \<and> ct_list_eq (ccsa cs csa) cs"
      using ct_suffixE by moura
    have f4: "ct_suffix ts' (map TSome ts)"
      using a2 a1 by metis
    then have f5: "ct_list_eq (ccsa ts' (map TSome ts)) ts'"
      using f3 by blast
    have f6: "take (length (map TSome ts) - length (ccsa ts' (map TSome ts))) (map TSome ts) @ ccsa ts' (map TSome ts) = map TSome ts"
      using f4 f3 by (metis (full_types) suffixI suffix_take)
    have "\<And>cs. ct_list_eq (cs @ ccsa ts' (map TSome ts)) (cs @ ts')"
      using f5 ct_list_eq_concat ct_list_eq_refl by blast
    then have "\<exists>tsa. ct_list_eq (map TSome ts) (map TSome tsa @ ts') \<and> c_t = Type tsa"
      using f6 f5 f4 a1 by (metis (no_types) ct_list_eq_length length_map take_map)
  }
  thus ?thesis
    using assms to_ct_list_def
    by simp
qed

lemma consume_top_geq:
  assumes "consume (TopType ts) ts' = c_t"
          "length ts \<ge> length ts'"
          "c_t \<noteq> Bot"
  shows "(\<exists>as bs. ts = as@bs \<and> ct_list_eq bs ts' \<and> c_t = TopType as)"
proof -
  consider (1) "ct_suffix ts' ts"
         | (2) "\<not>ct_suffix ts' ts" "ct_suffix ts ts'"
         | (3) "\<not>ct_suffix ts' ts" "\<not>ct_suffix ts ts'"
    by blast
  thus ?thesis
  proof (cases)
    case 1
    hence "TopType (take (length ts - length ts') ts) = c_t"
      using assms
      by simp
    thus ?thesis
      using assms(2) 1 ct_list_eq_def
      unfolding ct_suffix_def
      by (metis (no_types, lifting) append_eq_append_conv append_take_drop_id diff_diff_cancel length_drop list_all2_lengthD)
  next
    case 2
    thus ?thesis
      using assms append_eq_append_conv ct_list_eq_commute
      unfolding ct_suffix_def
      by (metis append.left_neutral ct_suffix_def ct_suffix_length le_antisym)
  next
    case 3
    thus ?thesis
      using assms
      by auto
  qed
qed

lemma consume_top_leq:
  assumes "consume (TopType ts) ts' = c_t"
          "length ts \<le> length ts'"
          "c_t \<noteq> Bot"
  shows "c_t = TopType []"
  using assms append_eq_conv_conj
  by fastforce

lemma consume_type_type:
  assumes "consume xs cons = (Type t_int)"
  shows "\<exists>tn. xs = Type tn"
  using assms
  apply (cases xs)
    apply simp_all
  apply (metis checker_type.distinct(1) checker_type.distinct(5))
  done

lemma produce_type_type:
  assumes "produce xs cons = (Type tm)"
  shows "\<exists>tn. xs = Type tn"
  apply (cases xs; cases cons)
  using assms
          apply simp_all
  done

lemma consume_weaken_type:
  assumes "consume (Type tn) cons = (Type t_int)"
  shows "consume (Type (ts@tn)) cons = (Type (ts@t_int))"
proof -
  obtain ts' where "ct_list_eq (to_ct_list tn) (to_ct_list ts' @ cons) \<and> Type t_int = Type ts'"
    using consume_type[OF assms]
    by blast
  have cond:"ct_suffix cons (to_ct_list tn)"
    using assms
    by (simp, metis checker_type.distinct(5))
  hence res:"t_int = take (length tn - length cons) tn"
    using assms
    by simp
  have "ct_suffix cons (to_ct_list (ts@tn))"
    using cond
    unfolding to_ct_list_def
    by (metis append_assoc ct_suffix_def map_append)
  moreover
  have "ts@t_int = take (length (ts@tn) - length cons) (ts@tn)"
    using res take_append cond ct_suffix_length to_ct_list_def
    by fastforce
  ultimately
  show ?thesis
    by simp
qed

lemma produce_weaken_type:
  assumes "produce (Type tn) cons = (Type tm)"
  shows "produce (Type (ts@tn)) cons = (Type (ts@tm))"
  using assms
  by (cases cons, simp_all)

lemma produce_nil: "produce ts (Type []) = ts"
  using to_ct_list_def
  by (cases ts, simp_all)

lemma c_types_agree_id: "c_types_agree (Type ts) ts"
  by simp

lemma c_types_agree_top1: "c_types_agree (TopType []) ts"
  using ct_suffix_ts_conv_suffix to_ct_list_def
  by (simp add: ct_suffix_nil)

lemma c_types_agree_top2:
  assumes "ct_list_eq ts (to_ct_list ts'')"
  shows "c_types_agree (TopType ts) (ts'@ts'')"
  using assms ct_list_eq_commute ct_suffix_def to_ct_list_def
  by auto

lemma c_types_agree_imp_ct_list_eq:
  assumes "c_types_agree (TopType cts) ts"
  shows "\<exists>ts' ts''. (ts = ts'@ts'') \<and> ct_list_eq cts (to_ct_list ts'')"
  using assms ct_suffix_def to_ct_list_def
  by (simp, metis ct_list_eq_commute ct_list_eq_ts_conv_eq ct_suffix_ts_conv_suffix suffixE
                  to_ct_list_append(2))

lemma c_types_agree_not_bot_exists:
  assumes "ts \<noteq> Bot"
  shows "\<exists>ts_c. c_types_agree ts ts_c"
  using assms ct_suffix_exists
  by (cases ts, simp_all)

lemma consume_c_types_agree:
  assumes "consume (Type ts) cts = (Type ts')"
          "c_types_agree ctn ts"
  shows "\<exists>c_t'. consume ctn cts = c_t' \<and> c_types_agree c_t' ts'"
  using assms
proof (cases ctn)
  case (TopType x1)
  have 1:"ct_suffix cts (to_ct_list ts)"
    using assms
    by (simp, metis checker_type.distinct(5))
  hence "ct_suffix cts x1 \<or> ct_suffix x1 cts"
    using TopType 1 assms(2) ct_suffix_shared
    by simp
  thus ?thesis
  proof (rule disjE)
    assume local_assms:"ct_suffix cts x1"
    hence 2:"consume (TopType x1) cts = TopType (take (length x1 - length cts) x1)"
      by simp
    have "(take (length ts - length cts) ts) = ts'"
      using assms 1
      by simp
    hence "c_types_agree (TopType (take (length x1 - length cts) x1)) ts'"
      using 2 assms local_assms TopType ct_suffix_take
      by (simp, metis length_map take_map to_ct_list_def)
    thus ?thesis
      using 2 TopType
      by simp
  next
    assume local_assms:"ct_suffix x1 cts"
    hence 3:"consume (TopType x1) cts = TopType []"
      by (simp add: ct_suffix_length)
    thus ?thesis
      using TopType c_types_agree_top1
      by blast
  qed
qed simp_all

lemma type_update_type:
  assumes "type_update (Type ts) (to_ct_list cons) prods = ts'"
          "ts' \<noteq> Bot"
        shows "(ts' = prods \<and> (\<exists>ts_c. prods = (TopType ts_c)))
               \<or> (\<exists>ts_a ts_b. prods = Type ts_a \<and> ts = ts_b@cons \<and> ts' = Type (ts_b@ts_a))"
  using assms
  apply (cases prods)
    apply simp_all
   apply (metis (full_types) produce.simps(3) produce.simps(7))
  using ct_suffix_ts_conv_suffix suffix_take to_ct_list_def
  apply fastforce
  done

lemma type_update_empty: "type_update ts cons (Type []) = consume ts cons"
  using produce_nil
  by simp

lemma type_update_top_top:
  assumes "type_update (TopType ts) (to_ct_list cons) (Type prods) = (TopType ts')"
          "c_types_agree (TopType ts') t_ag"
  shows "ct_suffix (to_ct_list prods) ts'"
        "\<exists>t_ag'. t_ag = t_ag'@prods \<and> c_types_agree (TopType ts) (t_ag'@cons)"
proof -
  consider (1) "ct_suffix (to_ct_list cons) ts"
         | (2) "\<not>ct_suffix (to_ct_list cons) ts" "ct_suffix ts (to_ct_list cons)"
         | (3) "\<not>ct_suffix (to_ct_list cons) ts" "\<not>ct_suffix ts (to_ct_list cons)"
    by blast
  hence "ct_suffix (to_ct_list prods) ts' \<and> (\<exists>t_ag'. t_ag = t_ag'@prods \<and> c_types_agree (TopType ts) (t_ag'@cons))"
  proof (cases)
    case 1
    hence "ts' = (take (length ts - length cons) ts) @ to_ct_list prods"
      using assms(1) to_ct_list_def
      by simp
    moreover
    then obtain t_ag' where "t_ag = t_ag' @ prods"
                            "ct_suffix (take (length ts - length cons) ts) (to_ct_list t_ag')"
      using assms(2) ct_suffix_cons_ct_list1
      unfolding c_types_agree.simps
      by blast
    moreover
    hence "ct_suffix ts (to_ct_list (t_ag'@cons))"
      using 1 ct_suffix_imp_ct_list_eq ct_suffix_extend_ct_list_eq to_ct_list_def
      by fastforce
    ultimately
    show ?thesis
      using c_types_agree.simps(2) ct_list_eq_ts_conv_eq ct_suffix_def
      by auto
  next
    case 2
    thus ?thesis
      using assms
      by (metis append.assoc c_types_agree.simps(2) checker_type.inject(1) consume.simps(2)
                ct_list_eq_ts_conv_eq ct_suffix_cons_ct_list ct_suffix_def map_append
                produce.simps(1) to_ct_list_def type_update.simps)
  next
    case 3
    thus ?thesis
      using assms
      by simp
  qed
  thus "ct_suffix (to_ct_list prods) ts'"
        "\<exists>t_ag'. t_ag = t_ag'@prods \<and> c_types_agree (TopType ts) (t_ag'@cons)"
  by simp_all
qed

lemma type_update_select_length0:
  assumes "type_update_select (TopType cts) = tm"
          "length cts = 0"
          "tm \<noteq> Bot"
  shows "tm = TopType [TAny]"
  using assms
  by simp

lemma type_update_select_length1:
  assumes "type_update_select (TopType cts) = tm"
          "length cts = 1"
          "tm \<noteq> Bot"
  shows "ct_list_eq cts [TSome T_i32]"
        "tm = TopType [TAny]"
proof -
  have 1:"type_update (TopType cts) [TSome T_i32] (TopType [TAny]) = tm"
    using assms(1,2)
    by simp
  hence "ct_suffix cts [TSome T_i32] \<or> ct_suffix [TSome T_i32] cts"
    using assms(3)
    by (metis consume.simps(2) produce.simps(7) type_update.simps)
  thus "ct_list_eq cts [TSome T_i32]"
    using assms(2,3) ct_suffix_imp_ct_list_eq
    by (metis One_nat_def Suc_length_conv ct_list_eq_commute diff_Suc_1 drop_0 list.size(3))
  show "tm = TopType [TAny]"
    using 1 assms(3) consume_top_leq
    by (metis One_nat_def assms(2) diff_Suc_1 diff_is_0_eq length_Cons list.size(3)
              produce.simps(4,7) type_update.simps)
qed

lemma type_update_select_length2:
  assumes "type_update_select (TopType cts) = tm"
          "length cts = 2"
          "tm \<noteq> Bot"
  shows "\<exists>t1 t2. cts = [t1, t2] \<and> ct_eq t2 (TSome T_i32) \<and> tm = TopType [t1]"
proof -
  obtain x y where cts_def:"cts = [x,y]"
    using assms(2) List.length_Suc_conv[of cts "Suc 0"]
    by (metis length_0_conv length_Suc_conv numeral_2_eq_2)
  moreover
  hence "consume (TopType [x,y]) [TSome T_i32] = tm"
    using assms(1,2)
    by simp
  moreover
  hence "ct_suffix [x,y] [TSome T_i32] \<or> ct_suffix [TSome T_i32] [x,y]"
    using assms(3)
    by (metis consume.simps(2))
  hence "ct_suffix [TSome T_i32] ([x]@[y])"
    using assms(2) ct_suffix_length
    by fastforce
  moreover
  hence "ct_eq y (TSome T_i32)"
    by (metis ct_eq_commute ct_list_eq_def ct_suffix_cons2 list.rel_sel list.sel(1) list.simps(3)
              list.size(4))
  ultimately
  show ?thesis
    by auto
qed

lemma type_update_select_length3:
  assumes "type_update_select (TopType cts) = (TopType ctm)"
          "length cts \<ge> 3"
  shows "\<exists>cts' ct1 ct2 ct3. cts = cts'@[ct1, ct2, ct3] \<and> ct_eq ct3 (TSome T_i32)"
proof -
  obtain cts' cts'' where cts_def:"cts = cts'@ cts''" "length cts'' = 3"
    using assms(2)
    by (metis append_take_drop_id diff_diff_cancel length_drop)
  then obtain ct1 cts''2 where "cts'' = ct1#cts''2" "length cts''2 = Suc (Suc 0)"
    using List.length_Suc_conv[of cts' "Suc (Suc 0)"]
    by (metis length_Suc_conv numeral_3_eq_3)
  then obtain ct2 ct3 where "cts'' = [ct1,ct2,ct3]"
    using List.length_Suc_conv[of cts''2 "Suc 0"]
    by (metis length_0_conv length_Suc_conv)
  hence cts_def2:"cts = cts'@ [ct1,ct2,ct3]"
    using cts_def
    by simp
  obtain nat where "length cts = Suc (Suc (Suc nat))"
    using assms(2)
    by (simp add: cts_def)
  hence "(type_update (TopType cts) [TAny, TAny, TSome T_i32] (select_return_top cts (cts ! (length cts - 2)) (cts ! (length cts - 3)))) = TopType ctm"
    using assms
    by simp
  then obtain c_mid where "consume (TopType cts) [TAny, TAny, TSome T_i32] = TopType c_mid"
    by (metis consume.simps(2) produce.simps(6) type_update.simps)
  hence "ct_suffix [TAny, TAny, TSome T_i32] (cts'@ [ct1,ct2,ct3])"
    using assms(2) consume_top_geq cts_def2
    by (metis checker_type.distinct(3) ct_suffix_def length_Cons list.size(3) numeral_3_eq_3)
  hence "ct_eq ct3 (TSome T_i32)"
    using ct_suffix_def ct_list_eq_def
    by (simp, metis append_eq_append_conv length_Cons list_all2_Cons list_all2_lengthD)
  thus ?thesis
    using cts_def2
    by simp
qed

lemma type_update_select_type_length3:
  assumes "type_update_select (Type tn) = (Type tm)"
  shows "\<exists>t ts'. tn = ts'@[t, t, T_i32]"
proof -
  have tn_cond:"(length tn \<ge> 3 \<and> (tn!(length tn-2)) = (tn!(length tn-3)))"
    using assms
    by (simp, metis checker_type.distinct(5))
  hence tm_def:"consume (Type tn) [TAny, TSome T_i32] = Type tm"
    using assms
    by simp
  obtain tn' tn'' where tn_split:"tn = tn'@tn''"
                                 "length tn'' = 3"
    using assms tn_cond
    by (metis append_take_drop_id diff_diff_cancel length_drop)
  then obtain t1 tn''2 where "tn'' = t1#tn''2" "length tn''2 = Suc (Suc 0)"
    by (metis length_Suc_conv numeral_3_eq_3)
  then obtain t2 t3 where tn''_def:"tn'' = [t1,t2,t3]"
    using List.length_Suc_conv[of tn''2 "Suc 0"]
    by (metis length_0_conv length_Suc_conv)
  hence tn_def:"tn = tn'@ [t1,t2,t3]"
    using tn_split
    by simp
  hence t1_t2_eq:"t1 = t2"
    using tn_cond
    by (metis (no_types, lifting) Suc_diff_Suc Suc_eq_plus1_left Suc_lessD tn''_def
                                  add_diff_cancel_right' diff_is_0_eq length_append neq0_conv
                                  not_less_eq_eq nth_Cons_0 nth_Cons_numeral
                                  nth_append numeral_2_eq_2 numeral_3_eq_3 numeral_One tn_split(2)
                                  zero_less_diff)
  have "ct_suffix [TAny, TSome T_i32] (to_ct_list (tn' @ [t1, t2, t3]))"
    using tn_def tm_def
    by (simp, metis checker_type.distinct(5))
  hence "t3 = T_i32"
    using ct_suffix_unfold_one[of "[TAny]" "TSome T_i32" "to_ct_list (tn' @ [t1, t2])" "TSome t3"]
          ct_eq.simps(1)
    unfolding to_ct_list_def
    by simp
  thus ?thesis
    using t1_t2_eq tn_def
    by simp
qed

lemma select_return_top_exists:
  assumes "select_return_top cts c1 c2 = ctm"
          "ctm \<noteq> Bot"
  shows "\<exists>xs. ctm = TopType xs"
  using assms
  by (meson select_return_top.elims)

lemma type_update_select_top_exists:
  assumes "type_update_select xs = (TopType tm)"
  shows "\<exists>tn. xs = TopType tn"
  using assms
proof (cases xs)
  case (Type x2)
  thus ?thesis
    using assms
    by (simp, metis checker_type.distinct(1) checker_type.distinct(3) consume.simps(1))
qed simp_all

lemma type_update_select_conv_select_return_top:
  assumes "ct_suffix [TSome T_i32] cts"
          "length cts \<ge> 3"
  shows "type_update_select (TopType cts) = (select_return_top cts (cts!(length cts-2)) (cts!(length cts-3)))"
proof -
  obtain nat where nat_def:"length cts = Suc (Suc (Suc nat))"
    using assms(2)
    by (metis add_eq_if diff_Suc_1 le_Suc_ex numeral_3_eq_3 nat.distinct(2))
  have "ct_suffix [TAny, TAny, TSome T_i32] cts"
    using assms ct_suffix_extend_any1
    by simp
  then obtain cts' where "consume (TopType cts) [TAny, TAny, TSome T_i32] = TopType cts'"
    by simp
  thus ?thesis
    using nat_def select_return_top_exists
    apply (cases "select_return_top cts (cts ! Suc nat) (cts ! nat)")
      apply simp_all
    apply blast
    done
qed

lemma select_return_top_ct_eq:
  assumes "select_return_top cts c1 c2 = TopType ctm"
          "length cts \<ge> 3"
          "c_types_agree (TopType ctm) cm"
  shows "\<exists>c' cm'. cm = cm'@[c']
                  \<and> ct_suffix (take (length cts - 3) cts) (to_ct_list cm')
                  \<and> ct_eq c1 (TSome c')
                  \<and> ct_eq c2 (TSome c')"
proof (cases c1)
  case TAny
  note outer_TAny = TAny
  show ?thesis
  proof (cases c2)
    case TAny
    hence "take (length cts - 3) cts @ [TAny] = ctm"
      using outer_TAny  assms ct_suffix_cons_ct_list
      by simp
    then obtain cm' c where "cm = cm' @ [c]"
                            "ct_suffix (take (length cts - 3) cts) (to_ct_list cm')"
      using ct_suffix_cons_ct_list[of "take (length cts - 3) cts" "[TAny]"]
            assms(3) c_types_agree.simps(2)[of ctm cm]
      unfolding ct_list_eq_def to_ct_list_def
      by (metis Suc_leI impossible_Cons length_Cons length_map list.exhaust list.size(3)
                list_all2_conv_all_nth zero_less_Suc)
    thus ?thesis
      using TAny outer_TAny ct_eq.simps(2)
      by blast
  next
    case (TSome x2)
    hence "take (length cts - 3) cts @ [TSome x2] = ctm"
      using outer_TAny assms ct_suffix_cons_ct_list
      by simp
    then obtain cm' where "cm = cm' @ [x2]"
                          "ct_suffix (take (length cts - 3) cts) (to_ct_list cm')"
      using ct_suffix_cons_ct_list[of "take (length cts - 3) cts" "[TSome x2]"]
            assms(3) c_types_agree.simps(2)[of ctm cm] ct_list_eq_ts_conv_eq
      unfolding ct_list_eq_def to_ct_list_def
      by (metis (no_types, hide_lams) list.simps(8,9))
    thus ?thesis
      using TSome outer_TAny
      by simp
  qed
next
  case (TSome x2)
  note outer_TSome = TSome
  show ?thesis
  proof (cases c2)
    case TAny
    hence "take (length cts - 3) cts @ [TSome x2] = ctm"
      using TSome assms ct_suffix_cons_ct_list
      by simp
    then obtain cm' where "cm = cm' @ [x2]"
                          "ct_suffix (take (length cts - 3) cts) (to_ct_list cm')"
      using ct_suffix_cons_ct_list[of "take (length cts - 3) cts" "[TSome x2]"]
            assms(3) c_types_agree.simps(2)[of ctm cm] ct_list_eq_ts_conv_eq
      unfolding ct_list_eq_def to_ct_list_def
      by (metis (no_types, hide_lams) list.simps(8,9))
    thus ?thesis
      using TSome TAny
      by simp
  next
    case (TSome x3)
    hence x_eq:"x2 = x3"
      using outer_TSome assms ct_suffix_cons_ct_list
      by (metis checker_type.distinct(3) select_return_top.simps(3))
    hence "take (length cts - 3) cts @ [TSome x2] = ctm"
      using TSome outer_TSome assms ct_suffix_cons_ct_list
      by (metis checker_type.inject(1) select_return_top.simps(3))
    then obtain cm' where "cm = cm' @ [x2]"
                          "ct_suffix (take (length cts - 3) cts) (to_ct_list cm')"
      using ct_suffix_cons_ct_list[of "take (length cts - 3) cts" "[TSome x2]"]
            assms(3) c_types_agree.simps(2)[of ctm cm] ct_list_eq_ts_conv_eq
      unfolding ct_list_eq_def to_ct_list_def
      by (metis (no_types, hide_lams) list.simps(8,9))
    thus ?thesis
      using TSome outer_TSome x_eq
      by simp
  qed
qed

end


(*  Title:      HOL/HOLCF/Discrete.thy
    Author:     Tobias Nipkow
*)

section \<open>Discrete cpo types\<close>

theory Discrete
  imports Cont
begin

datatype 'a discr = Discr "'a :: type"

subsection \<open>Discrete cpo class instance\<close>

instantiation discr :: (type) discrete_cpo
begin

definition "((\<sqsubseteq>) :: 'a discr \<Rightarrow> 'a discr \<Rightarrow> bool) = (=)"

instance
  by standard (simp add: below_discr_def)

end

subsection \<open>\emph{undiscr}\<close>

definition undiscr :: "('a::type)discr \<Rightarrow> 'a"
  where "undiscr x = (case x of Discr y \<Rightarrow> y)"

lemma undiscr_Discr [simp]: "undiscr (Discr x) = x"
  by (simp add: undiscr_def)

lemma Discr_undiscr [simp]: "Discr (undiscr y) = y"
  by (induct y) simp

end