(*
 * 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)
 *)

(*
   Nondeterministic state and error monads with failure in Isabelle.
*)

chapter "Nondeterministic State Monad with Failure"

theory NonDetMonad
imports "../Lib"
begin

text \<open>
  \label{c:monads}

  State monads are used extensively in the seL4 specification. They are
  defined below.
\<close>

section "The Monad"

text \<open>
  The basic type of the nondeterministic state monad with failure is
  very similar to the normal state monad. Instead of a pair consisting
  of result and new state, we return a set of these pairs coupled with
  a failure flag. Each element in the set is a potential result of the
  computation. The flag is @{const True} if there is an execution path
  in the computation that may have failed. Conversely, if the flag is
  @{const False}, none of the computations resulting in the returned
  set can have failed.\<close>
type_synonym ('s,'a) nondet_monad = "'s \<Rightarrow> ('a \<times> 's) set \<times> bool"

text \<open>
  The definition of fundamental monad functions \<open>return\<close> and
  \<open>bind\<close>. The monad function \<open>return x\<close> does not change
  the  state, does not fail, and returns \<open>x\<close>.
\<close>
definition
  return :: "'a \<Rightarrow> ('s,'a) nondet_monad" where
  "return a \<equiv> \<lambda>s. ({(a,s)},False)"

text \<open>
  The monad function \<open>bind f g\<close>, also written \<open>f >>= g\<close>,
  is the execution of @{term f} followed by the execution of \<open>g\<close>.
  The function \<open>g\<close> takes the result value \emph{and} the result
  state of \<open>f\<close> as parameter. The definition says that the result of
  the combined operation is the union of the set of sets that is created
  by \<open>g\<close> applied to the result sets of \<open>f\<close>. The combined
  operation may have failed, if \<open>f\<close> may have failed or \<open>g\<close> may
  have failed on any of the results of \<open>f\<close>.
\<close>
definition
  bind :: "('s, 'a) nondet_monad \<Rightarrow> ('a \<Rightarrow> ('s, 'b) nondet_monad) \<Rightarrow>
           ('s, 'b) nondet_monad" (infixl ">>=" 60)
  where
  "bind f g \<equiv> \<lambda>s. (\<Union>(fst ` case_prod g ` fst (f s)),
                   True \<in> snd ` case_prod g ` fst (f s) \<or> snd (f s))"

text \<open>
  Sometimes it is convenient to write \<open>bind\<close> in reverse order.
\<close>
abbreviation(input)
  bind_rev :: "('c \<Rightarrow> ('a, 'b) nondet_monad) \<Rightarrow> ('a, 'c) nondet_monad \<Rightarrow>
               ('a, 'b) nondet_monad" (infixl "=<<" 60) where
  "g =<< f \<equiv> f >>= g"

text \<open>
  The basic accessor functions of the state monad. \<open>get\<close> returns
  the current state as result, does not fail, and does not change the state.
  \<open>put s\<close> returns nothing (@{typ unit}), changes the current state
  to \<open>s\<close> and does not fail.
\<close>
definition
  get :: "('s,'s) nondet_monad" where
  "get \<equiv> \<lambda>s. ({(s,s)}, False)"

definition
  put :: "'s \<Rightarrow> ('s, unit) nondet_monad" where
  "put s \<equiv> \<lambda>_. ({((),s)}, False)"

subsection "Nondeterminism"

text \<open>
  Basic nondeterministic functions. \<open>select A\<close> chooses an element
  of the set \<open>A\<close>, does not change the state, and does not fail
  (even if the set is empty). \<open>f \<sqinter> g\<close> executes \<open>f\<close> or
  executes \<open>g\<close>. It retuns the union of results of \<open>f\<close> and
  \<open>g\<close>, and may have failed if either may have failed.
\<close>
definition
  select :: "'a set \<Rightarrow> ('s,'a) nondet_monad" where
  "select A \<equiv> \<lambda>s. (A \<times> {s}, False)"

definition
  alternative :: "('s,'a) nondet_monad \<Rightarrow> ('s,'a) nondet_monad \<Rightarrow>
                  ('s,'a) nondet_monad"
  (infixl "\<sqinter>" 20)
where
  "f \<sqinter> g \<equiv> \<lambda>s. (fst (f s) \<union> fst (g s), snd (f s) \<or> snd (g s))"

text \<open>A variant of \<open>select\<close> that takes a pair. The first component
  is a set as in normal \<open>select\<close>, the second component indicates
  whether the execution failed. This is useful to lift monads between
  different state spaces.
\<close>
definition
  select_f :: "'a set \<times> bool  \<Rightarrow> ('s,'a) nondet_monad" where
  "select_f S \<equiv> \<lambda>s. (fst S \<times> {s}, snd S)"

text \<open>\<open>select_state\<close> takes a relationship between
  states, and outputs nondeterministically a state
  related to the input state.\<close>

definition
  state_select :: "('s \<times> 's) set \<Rightarrow> ('s, unit) nondet_monad"
where
  "state_select r \<equiv> \<lambda>s. ((\<lambda>x. ((), x)) ` {s'. (s, s') \<in> r}, \<not> (\<exists>s'. (s, s') \<in> r))"

subsection "Failure"

text \<open>The monad function that always fails. Returns an empty set of
results and sets the failure flag.\<close>
definition
  fail :: "('s, 'a) nondet_monad" where
 "fail \<equiv> \<lambda>s. ({}, True)"

text \<open>Assertions: fail if the property \<open>P\<close> is not true\<close>
definition
  assert :: "bool \<Rightarrow> ('a, unit) nondet_monad" where
 "assert P \<equiv> if P then return () else fail"

text \<open>Fail if the value is @{const None},
  return result \<open>v\<close> for @{term "Some v"}\<close>
definition
  assert_opt :: "'a option \<Rightarrow> ('b, 'a) nondet_monad" where
 "assert_opt v \<equiv> case v of None \<Rightarrow> fail | Some v \<Rightarrow> return v"

text \<open>An assertion that also can introspect the current state.\<close>

definition
  state_assert :: "('s \<Rightarrow> bool) \<Rightarrow> ('s, unit) nondet_monad"
where
  "state_assert P \<equiv> get >>= (\<lambda>s. assert (P s))"

subsection "Generic functions on top of the state monad"

text \<open>Apply a function to the current state and return the result
without changing the state.\<close>
definition
  gets :: "('s \<Rightarrow> 'a) \<Rightarrow> ('s, 'a) nondet_monad" where
 "gets f \<equiv> get >>= (\<lambda>s. return (f s))"

text \<open>Modify the current state using the function passed in.\<close>
definition
  modify :: "('s \<Rightarrow> 's) \<Rightarrow> ('s, unit) nondet_monad" where
 "modify f \<equiv> get >>= (\<lambda>s. put (f s))"

lemma simpler_gets_def: "gets f = (\<lambda>s. ({(f s, s)}, False))"
  apply (simp add: gets_def return_def bind_def get_def)
  done

lemma simpler_modify_def:
  "modify f = (\<lambda>s. ({((), f s)}, False))"
  by (simp add: modify_def bind_def get_def put_def)

text \<open>Execute the given monad when the condition is true,
  return \<open>()\<close> otherwise.\<close>
definition
  "when" :: "bool \<Rightarrow> ('s, unit) nondet_monad \<Rightarrow>
           ('s, unit) nondet_monad" where
  "when P m \<equiv> if P then m else return ()"

text \<open>Execute the given monad unless the condition is true,
  return \<open>()\<close> otherwise.\<close>
definition
  unless :: "bool \<Rightarrow> ('s, unit) nondet_monad \<Rightarrow>
            ('s, unit) nondet_monad" where
  "unless P m \<equiv> when (\<not>P) m"

text \<open>
  Perform a test on the current state, performing the left monad if
  the result is true or the right monad if the result is false.
\<close>
definition
  condition :: "('s \<Rightarrow> bool) \<Rightarrow> ('s, 'r) nondet_monad \<Rightarrow> ('s, 'r) nondet_monad \<Rightarrow> ('s, 'r) nondet_monad"
where
  "condition P L R \<equiv> \<lambda>s. if (P s) then (L s) else (R s)"

notation (output)
  condition  ("(condition (_)//  (_)//  (_))" [1000,1000,1000] 1000)

text \<open>
Apply an option valued function to the current state, fail
if it returns @{const None}, return \<open>v\<close> if it returns
@{term "Some v"}.
\<close>
definition
  gets_the :: "('s \<Rightarrow> 'a option) \<Rightarrow> ('s, 'a) nondet_monad" where
 "gets_the f \<equiv> gets f >>= assert_opt"

subsection \<open>The Monad Laws\<close>

text \<open>A more expanded definition of \<open>bind\<close>\<close>
lemma bind_def':
  "(f >>= g) \<equiv>
       \<lambda>s. ({(r'', s''). \<exists>(r', s') \<in> fst (f s). (r'', s'') \<in> fst (g r' s') },
                     snd (f s) \<or> (\<exists>(r', s') \<in> fst (f s). snd (g r' s')))"
  apply (rule eq_reflection)
  apply (auto simp add: bind_def split_def Let_def)
  done

text \<open>Each monad satisfies at least the following three laws.\<close>

text \<open>@{term return} is absorbed at the left of a @{term bind},
  applying the return value directly:\<close>
lemma return_bind [simp]: "(return x >>= f) = f x"
  by (simp add: return_def bind_def)

text \<open>@{term return} is absorbed on the right of a @{term bind}\<close>
lemma bind_return [simp]: "(m >>= return) = m"
  apply (rule ext)
  apply (simp add: bind_def return_def split_def)
  done

text \<open>@{term bind} is associative\<close>
lemma bind_assoc:
  fixes m :: "('a,'b) nondet_monad"
  fixes f :: "'b \<Rightarrow> ('a,'c) nondet_monad"
  fixes g :: "'c \<Rightarrow> ('a,'d) nondet_monad"
  shows "(m >>= f) >>= g  =  m >>= (\<lambda>x. f x >>= g)"
  apply (unfold bind_def Let_def split_def)
  apply (rule ext)
  apply clarsimp
  apply (auto intro: rev_image_eqI)
  done

section \<open>Adding Exceptions\<close>

text \<open>
  The type @{typ "('s,'a) nondet_monad"} gives us nondeterminism and
  failure. We now extend this monad with exceptional return values
  that abort normal execution, but can be handled explicitly.
  We use the sum type to indicate exceptions.

  In @{typ "('s, 'e + 'a) nondet_monad"}, @{typ "'s"} is the state,
  @{typ 'e} is an exception, and @{typ 'a} is a normal return value.

  This new type itself forms a monad again. Since type classes in
  Isabelle are not powerful enough to express the class of monads,
  we provide new names for the @{term return} and @{term bind} functions
  in this monad. We call them \<open>returnOk\<close> (for normal return values)
  and \<open>bindE\<close> (for composition). We also define \<open>throwError\<close>
  to return an exceptional value.
\<close>
definition
  returnOk :: "'a \<Rightarrow> ('s, 'e + 'a) nondet_monad" where
  "returnOk \<equiv> return o Inr"

definition
  throwError :: "'e \<Rightarrow> ('s, 'e + 'a) nondet_monad" where
  "throwError \<equiv> return o Inl"

text \<open>
  Lifting a function over the exception type: if the input is an
  exception, return that exception; otherwise continue execution.
\<close>
definition
  lift :: "('a \<Rightarrow> ('s, 'e + 'b) nondet_monad) \<Rightarrow>
           'e +'a \<Rightarrow> ('s, 'e + 'b) nondet_monad"
where
  "lift f v \<equiv> case v of Inl e \<Rightarrow> throwError e
                      | Inr v' \<Rightarrow> f v'"

text \<open>
  The definition of @{term bind} in the exception monad (new
  name \<open>bindE\<close>): the same as normal @{term bind}, but
  the right-hand side is skipped if the left-hand side
  produced an exception.
\<close>
definition
  bindE :: "('s, 'e + 'a) nondet_monad \<Rightarrow>
            ('a \<Rightarrow> ('s, 'e + 'b) nondet_monad) \<Rightarrow>
            ('s, 'e + 'b) nondet_monad"  (infixl ">>=E" 60)
where
  "bindE f g \<equiv> bind f (lift g)"

text \<open>
  Lifting a normal nondeterministic monad into the
  exception monad is achieved by always returning its
  result as normal result and never throwing an exception.
\<close>
definition
  liftE :: "('s,'a) nondet_monad \<Rightarrow> ('s, 'e+'a) nondet_monad"
where
  "liftE f \<equiv> f >>= (\<lambda>r. return (Inr r))"

text \<open>
  Since the underlying type and \<open>return\<close> function changed,
  we need new definitions for when and unless:
\<close>
definition
  whenE :: "bool \<Rightarrow> ('s, 'e + unit) nondet_monad \<Rightarrow>
            ('s, 'e + unit) nondet_monad"
  where
  "whenE P f \<equiv> if P then f else returnOk ()"

definition
  unlessE :: "bool \<Rightarrow> ('s, 'e + unit) nondet_monad \<Rightarrow>
            ('s, 'e + unit) nondet_monad"
  where
  "unlessE P f \<equiv> if P then returnOk () else f"

text \<open>
  Throwing an exception when the parameter is @{term None}, otherwise
  returning @{term "v"} for @{term "Some v"}.
\<close>
definition
  throw_opt :: "'e \<Rightarrow> 'a option \<Rightarrow> ('s, 'e + 'a) nondet_monad" where
  "throw_opt ex x \<equiv>
  case x of None \<Rightarrow> throwError ex | Some v \<Rightarrow> returnOk v"

text \<open>
  Failure in the exception monad is redefined in the same way
  as @{const whenE} and @{const unlessE}, with @{term returnOk}
  instead of @{term return}.
\<close>
definition
  assertE :: "bool \<Rightarrow> ('a, 'e + unit) nondet_monad" where
 "assertE P \<equiv> if P then returnOk () else fail"

subsection "Monad Laws for the Exception Monad"

text \<open>More direct definition of @{const liftE}:\<close>
lemma liftE_def2:
  "liftE f = (\<lambda>s. ((\<lambda>(v,s'). (Inr v, s')) ` fst (f s), snd (f s)))"
  by (auto simp: liftE_def return_def split_def bind_def)

text \<open>Left @{const returnOk} absorbtion over @{term bindE}:\<close>
lemma returnOk_bindE [simp]: "(returnOk x >>=E f) = f x"
  apply (simp only: bindE_def return_def returnOk_def)
  apply (clarsimp simp: lift_def)
  done

lemma lift_return [simp]:
  "lift (return \<circ> Inr) = return"
  by (rule ext)
     (simp add: lift_def throwError_def split: sum.splits)

text \<open>Right @{const returnOk} absorbtion over @{term bindE}:\<close>
lemma bindE_returnOk [simp]: "(m >>=E returnOk) = m"
  by (simp add: bindE_def returnOk_def)

text \<open>Associativity of @{const bindE}:\<close>
lemma bindE_assoc:
  "(m >>=E f) >>=E g = m >>=E (\<lambda>x. f x >>=E g)"
  apply (simp add: bindE_def bind_assoc)
  apply (rule arg_cong [where f="\<lambda>x. m >>= x"])
  apply (rule ext)
  apply (case_tac x, simp_all add: lift_def throwError_def)
  done

text \<open>@{const returnOk} could also be defined via @{const liftE}:\<close>
lemma returnOk_liftE:
  "returnOk x = liftE (return x)"
  by (simp add: liftE_def returnOk_def)

text \<open>Execution after throwing an exception is skipped:\<close>
lemma throwError_bindE [simp]:
  "(throwError E >>=E f) = throwError E"
  by (simp add: bindE_def bind_def throwError_def lift_def return_def)

section "Syntax"

text \<open>This section defines traditional Haskell-like do-syntax
  for the state monad in Isabelle.\<close>

subsection "Syntax for the Nondeterministic State Monad"

text \<open>We use \<open>K_bind\<close> to syntactically indicate the
  case where the return argument of the left side of a @{term bind}
  is ignored\<close>
definition
  K_bind_def [iff]: "K_bind \<equiv> \<lambda>x y. x"

nonterminal
  dobinds and dobind and nobind

syntax (ASCII)
  "_dobind"    :: "[pttrn, 'a] => dobind"             ("(_ <-/ _)" 10)
syntax
  "_dobind"    :: "[pttrn, 'a] => dobind"             ("(_ \<leftarrow>/ _)" 10)
  ""           :: "dobind => dobinds"                 ("_")
  "_nobind"    :: "'a => dobind"                      ("_")
  "_dobinds"   :: "[dobind, dobinds] => dobinds"      ("(_);//(_)")

  "_do"        :: "[dobinds, 'a] => 'a"               ("(do ((_);//(_))//od)" 100)
translations
  "_do (_dobinds b bs) e"  == "_do b (_do bs e)"
  "_do (_nobind b) e"      == "b >>= (CONST K_bind e)"
  "do x <- a; e od"        == "a >>= (\<lambda>x. e)"

text \<open>Syntax examples:\<close>
lemma "do x \<leftarrow> return 1;
          return (2::nat);
          return x
       od =
       return 1 >>=
       (\<lambda>x. return (2::nat) >>=
            K_bind (return x))"
  by (rule refl)

lemma "do x \<leftarrow> return 1;
          return 2;
          return x
       od = return 1"
  by simp

subsection "Syntax for the Exception Monad"

text \<open>
  Since the exception monad is a different type, we
  need to syntactically distinguish it in the syntax.
  We use \<open>doE\<close>/\<open>odE\<close> for this, but can re-use
  most of the productions from \<open>do\<close>/\<open>od\<close>
  above.
\<close>

syntax
  "_doE" :: "[dobinds, 'a] => 'a"  ("(doE ((_);//(_))//odE)" 100)

translations
  "_doE (_dobinds b bs) e"  == "_doE b (_doE bs e)"
  "_doE (_nobind b) e"      == "b >>=E (CONST K_bind e)"
  "doE x <- a; e odE"       == "a >>=E (\<lambda>x. e)"

text \<open>Syntax examples:\<close>
lemma "doE x \<leftarrow> returnOk 1;
           returnOk (2::nat);
           returnOk x
       odE =
       returnOk 1 >>=E
       (\<lambda>x. returnOk (2::nat) >>=E
            K_bind (returnOk x))"
  by (rule refl)

lemma "doE x \<leftarrow> returnOk 1;
           returnOk 2;
           returnOk x
       odE = returnOk 1"
  by simp

section "Library of Monadic Functions and Combinators"

text \<open>Lifting a normal function into the monad type:\<close>
definition
  liftM :: "('a \<Rightarrow> 'b) \<Rightarrow> ('s,'a) nondet_monad \<Rightarrow> ('s, 'b) nondet_monad"
where
  "liftM f m \<equiv> do x \<leftarrow> m; return (f x) od"

text \<open>The same for the exception monad:\<close>
definition
  liftME :: "('a \<Rightarrow> 'b) \<Rightarrow> ('s,'e+'a) nondet_monad \<Rightarrow> ('s,'e+'b) nondet_monad"
where
  "liftME f m \<equiv> doE x \<leftarrow> m; returnOk (f x) odE"

text \<open>
  Run a sequence of monads from left to right, ignoring return values.\<close>
definition
  sequence_x :: "('s, 'a) nondet_monad list \<Rightarrow> ('s, unit) nondet_monad"
where
  "sequence_x xs \<equiv> foldr (\<lambda>x y. x >>= (\<lambda>_. y)) xs (return ())"

text \<open>
  Map a monadic function over a list by applying it to each element
  of the list from left to right, ignoring return values.
\<close>
definition
  mapM_x :: "('a \<Rightarrow> ('s,'b) nondet_monad) \<Rightarrow> 'a list \<Rightarrow> ('s, unit) nondet_monad"
where
  "mapM_x f xs \<equiv> sequence_x (map f xs)"

text \<open>
  Map a monadic function with two parameters over two lists,
  going through both lists simultaneously, left to right, ignoring
  return values.
\<close>
definition
  zipWithM_x :: "('a \<Rightarrow> 'b \<Rightarrow> ('s,'c) nondet_monad) \<Rightarrow>
                 'a list \<Rightarrow> 'b list \<Rightarrow> ('s, unit) nondet_monad"
where
  "zipWithM_x f xs ys \<equiv> sequence_x (zipWith f xs ys)"

text \<open>The same three functions as above, but returning a list of
return values instead of \<open>unit\<close>\<close>
definition
  sequence :: "('s, 'a) nondet_monad list \<Rightarrow> ('s, 'a list) nondet_monad"
where
  "sequence xs \<equiv> let mcons = (\<lambda>p q. p >>= (\<lambda>x. q >>= (\<lambda>y. return (x#y))))
                 in foldr mcons xs (return [])"

definition
  mapM :: "('a \<Rightarrow> ('s,'b) nondet_monad) \<Rightarrow> 'a list \<Rightarrow> ('s, 'b list) nondet_monad"
where
  "mapM f xs \<equiv> sequence (map f xs)"

definition
  zipWithM :: "('a \<Rightarrow> 'b \<Rightarrow> ('s,'c) nondet_monad) \<Rightarrow>
                 'a list \<Rightarrow> 'b list \<Rightarrow> ('s, 'c list) nondet_monad"
where
  "zipWithM f xs ys \<equiv> sequence (zipWith f xs ys)"

definition
  foldM :: "('b \<Rightarrow> 'a \<Rightarrow> ('s, 'a) nondet_monad) \<Rightarrow> 'b list \<Rightarrow> 'a \<Rightarrow> ('s, 'a) nondet_monad"
where
  "foldM m xs a \<equiv> foldr (\<lambda>p q. q >>= m p) xs (return a) "

text \<open>The sequence and map functions above for the exception monad,
with and without lists of return value\<close>
definition
  sequenceE_x :: "('s, 'e+'a) nondet_monad list \<Rightarrow> ('s, 'e+unit) nondet_monad"
where
  "sequenceE_x xs \<equiv> foldr (\<lambda>x y. doE _ <- x; y odE) xs (returnOk ())"

definition
  mapME_x :: "('a \<Rightarrow> ('s,'e+'b) nondet_monad) \<Rightarrow> 'a list \<Rightarrow>
              ('s,'e+unit) nondet_monad"
where
  "mapME_x f xs \<equiv> sequenceE_x (map f xs)"

definition
  sequenceE :: "('s, 'e+'a) nondet_monad list \<Rightarrow> ('s, 'e+'a list) nondet_monad"
where
  "sequenceE xs \<equiv> let mcons = (\<lambda>p q. p >>=E (\<lambda>x. q >>=E (\<lambda>y. returnOk (x#y))))
                 in foldr mcons xs (returnOk [])"

definition
  mapME :: "('a \<Rightarrow> ('s,'e+'b) nondet_monad) \<Rightarrow> 'a list \<Rightarrow>
              ('s,'e+'b list) nondet_monad"
where
  "mapME f xs \<equiv> sequenceE (map f xs)"

text \<open>Filtering a list using a monadic function as predicate:\<close>
primrec
  filterM :: "('a \<Rightarrow> ('s, bool) nondet_monad) \<Rightarrow> 'a list \<Rightarrow> ('s, 'a list) nondet_monad"
where
  "filterM P []       = return []"
| "filterM P (x # xs) = do
     b  <- P x;
     ys <- filterM P xs;
     return (if b then (x # ys) else ys)
   od"

section "Catching and Handling Exceptions"

text \<open>
  Turning an exception monad into a normal state monad
  by catching and handling any potential exceptions:
\<close>
definition
  catch :: "('s, 'e + 'a) nondet_monad \<Rightarrow>
            ('e \<Rightarrow> ('s, 'a) nondet_monad) \<Rightarrow>
            ('s, 'a) nondet_monad" (infix "<catch>" 10)
where
  "f <catch> handler \<equiv>
     do x \<leftarrow> f;
        case x of
          Inr b \<Rightarrow> return b
        | Inl e \<Rightarrow> handler e
     od"

text \<open>
  Handling exceptions, but staying in the exception monad.
  The handler may throw a type of exceptions different from
  the left side.
\<close>
definition
  handleE' :: "('s, 'e1 + 'a) nondet_monad \<Rightarrow>
               ('e1 \<Rightarrow> ('s, 'e2 + 'a) nondet_monad) \<Rightarrow>
               ('s, 'e2 + 'a) nondet_monad" (infix "<handle2>" 10)
where
  "f <handle2> handler \<equiv>
   do
      v \<leftarrow> f;
      case v of
        Inl e \<Rightarrow> handler e
      | Inr v' \<Rightarrow> return (Inr v')
   od"

text \<open>
  A type restriction of the above that is used more commonly in
  practice: the exception handle (potentially) throws exception
  of the same type as the left-hand side.
\<close>
definition
  handleE :: "('s, 'x + 'a) nondet_monad \<Rightarrow>
              ('x \<Rightarrow> ('s, 'x + 'a) nondet_monad) \<Rightarrow>
              ('s, 'x + 'a) nondet_monad" (infix "<handle>" 10)
where
  "handleE \<equiv> handleE'"

text \<open>
  Handling exceptions, and additionally providing a continuation
  if the left-hand side throws no exception:
\<close>
definition
  handle_elseE :: "('s, 'e + 'a) nondet_monad \<Rightarrow>
                   ('e \<Rightarrow> ('s, 'ee + 'b) nondet_monad) \<Rightarrow>
                   ('a \<Rightarrow> ('s, 'ee + 'b) nondet_monad) \<Rightarrow>
                   ('s, 'ee + 'b) nondet_monad"
  ("_ <handle> _ <else> _" 10)
where
  "f <handle> handler <else> continue \<equiv>
   do v \<leftarrow> f;
   case v of Inl e  \<Rightarrow> handler e
           | Inr v' \<Rightarrow> continue v'
   od"

subsection "Loops"

text \<open>
  Loops are handled using the following inductive predicate;
  non-termination is represented using the failure flag of the
  monad.
\<close>

inductive_set
  whileLoop_results :: "('r \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('r \<Rightarrow> ('s, 'r) nondet_monad) \<Rightarrow> ((('r \<times> 's) option) \<times> (('r \<times> 's) option)) set"
  for C B
where
    "\<lbrakk> \<not> C r s \<rbrakk> \<Longrightarrow> (Some (r, s), Some (r, s)) \<in> whileLoop_results C B"
  | "\<lbrakk> C r s; snd (B r s) \<rbrakk> \<Longrightarrow> (Some (r, s), None) \<in> whileLoop_results C B"
  | "\<lbrakk> C r s; (r', s') \<in> fst (B r s); (Some (r', s'), z) \<in> whileLoop_results C B  \<rbrakk>
       \<Longrightarrow> (Some (r, s), z) \<in> whileLoop_results C B"

inductive_cases whileLoop_results_cases_valid: "(Some x, Some y) \<in> whileLoop_results C B"
inductive_cases whileLoop_results_cases_fail: "(Some x, None) \<in> whileLoop_results C B"
inductive_simps whileLoop_results_simps: "(Some x, y) \<in> whileLoop_results C B"
inductive_simps whileLoop_results_simps_valid: "(Some x, Some y) \<in> whileLoop_results C B"
inductive_simps whileLoop_results_simps_start_fail [simp]: "(None, x) \<in> whileLoop_results C B"

inductive
  whileLoop_terminates :: "('r \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('r \<Rightarrow> ('s, 'r) nondet_monad) \<Rightarrow> 'r \<Rightarrow> 's \<Rightarrow> bool"
  for C B
where
    "\<not> C r s \<Longrightarrow> whileLoop_terminates C B r s"
  | "\<lbrakk> C r s; \<forall>(r', s') \<in> fst (B r s). whileLoop_terminates C B r' s' \<rbrakk>
        \<Longrightarrow> whileLoop_terminates C B r s"

inductive_cases whileLoop_terminates_cases: "whileLoop_terminates C B r s"
inductive_simps whileLoop_terminates_simps: "whileLoop_terminates C B r s"

definition
  "whileLoop C B \<equiv> (\<lambda>r s.
     ({(r',s'). (Some (r, s), Some (r', s')) \<in> whileLoop_results C B},
        (Some (r, s), None) \<in> whileLoop_results C B \<or> (\<not> whileLoop_terminates C B r s)))"

notation (output)
  whileLoop  ("(whileLoop (_)//  (_))" [1000, 1000] 1000)

definition
  whileLoopE :: "('r \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('r \<Rightarrow> ('s, 'e + 'r) nondet_monad)
      \<Rightarrow> 'r \<Rightarrow> 's \<Rightarrow> (('e + 'r) \<times> 's) set \<times> bool"
where
  "whileLoopE C body \<equiv>
      \<lambda>r. whileLoop (\<lambda>r s. (case r of Inr v \<Rightarrow> C v s | _ \<Rightarrow> False)) (lift body) (Inr r)"

notation (output)
  whileLoopE  ("(whileLoopE (_)//  (_))" [1000, 1000] 1000)

section "Hoare Logic"

subsection "Validity"

text \<open>This section defines a Hoare logic for partial correctness for
  the nondeterministic state monad as well as the exception monad.
  The logic talks only about the behaviour part of the monad and ignores
  the failure flag.

  The logic is defined semantically. Rules work directly on the
  validity predicate.

  In the nondeterministic state monad, validity is a triple of precondition,
  monad, and postcondition. The precondition is a function from state to
  bool (a state predicate), the postcondition is a function from return value
  to state to bool. A triple is valid if for all states that satisfy the
  precondition, all result values and result states that are returned by
  the monad satisfy the postcondition. Note that if the computation returns
  the empty set, the triple is trivially valid. This means @{term "assert P"}
  does not require us to prove that @{term P} holds, but rather allows us
  to assume @{term P}! Proving non-failure is done via separate predicate and
  calculus (see below).
\<close>
definition
  valid :: "('s \<Rightarrow> bool) \<Rightarrow> ('s,'a) nondet_monad \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool"
  ("\<lbrace>_\<rbrace>/ _ /\<lbrace>_\<rbrace>")
where
  "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace> \<equiv> \<forall>s. P s \<longrightarrow> (\<forall>(r,s') \<in> fst (f s). Q r s')"

text \<open>
  Validity for the exception monad is similar and build on the standard
  validity above. Instead of one postcondition, we have two: one for
  normal and one for exceptional results.
\<close>
definition
  validE :: "('s \<Rightarrow> bool) \<Rightarrow> ('s, 'a + 'b) nondet_monad \<Rightarrow>
             ('b \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow>
             ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool"
("\<lbrace>_\<rbrace>/ _ /(\<lbrace>_\<rbrace>,/ \<lbrace>_\<rbrace>)")
where
  "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>,\<lbrace>E\<rbrace> \<equiv> \<lbrace>P\<rbrace> f \<lbrace> \<lambda>v s. case v of Inr r \<Rightarrow> Q r s | Inl e \<Rightarrow> E e s \<rbrace>"

text \<open>
  The following two instantiations are convenient to separate reasoning
  for exceptional and normal case.
\<close>
definition
  validE_R :: "('s \<Rightarrow> bool) \<Rightarrow> ('s, 'e + 'a) nondet_monad \<Rightarrow>
               ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool"
   ("\<lbrace>_\<rbrace>/ _ /\<lbrace>_\<rbrace>, -")
where
 "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>,- \<equiv> validE P f Q (\<lambda>x y. True)"

definition
  validE_E :: "('s \<Rightarrow> bool) \<Rightarrow>  ('s, 'e + 'a) nondet_monad \<Rightarrow>
               ('e \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool"
   ("\<lbrace>_\<rbrace>/ _ /-, \<lbrace>_\<rbrace>")
where
 "\<lbrace>P\<rbrace> f -,\<lbrace>Q\<rbrace> \<equiv> validE P f (\<lambda>x y. True) Q"

text \<open>Abbreviations for trivial preconditions:\<close>
abbreviation(input)
  top :: "'a \<Rightarrow> bool" ("\<top>")
where
  "\<top> \<equiv> \<lambda>_. True"

abbreviation(input)
  bottom :: "'a \<Rightarrow> bool" ("\<bottom>")
where
  "\<bottom> \<equiv> \<lambda>_. False"

text \<open>Abbreviations for trivial postconditions (taking two arguments):\<close>
abbreviation(input)
  toptop :: "'a \<Rightarrow> 'b \<Rightarrow> bool" ("\<top>\<top>")
where
 "\<top>\<top> \<equiv> \<lambda>_ _. True"

abbreviation(input)
  botbot :: "'a \<Rightarrow> 'b \<Rightarrow> bool" ("\<bottom>\<bottom>")
where
 "\<bottom>\<bottom> \<equiv> \<lambda>_ _. False"

text \<open>
  Lifting \<open>\<and>\<close> and \<open>\<or>\<close> over two arguments.
  Lifting \<open>\<and>\<close> and \<open>\<or>\<close> over one argument is already
  defined (written \<open>and\<close> and \<open>or\<close>).
\<close>
definition
  bipred_conj :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool)"
  (infixl "And" 96)
where
  "bipred_conj P Q \<equiv> \<lambda>x y. P x y \<and> Q x y"

definition
  bipred_disj :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool)"
  (infixl "Or" 91)
where
  "bipred_disj P Q \<equiv> \<lambda>x y. P x y \<or> Q x y"

subsection "Determinism"

text \<open>A monad of type \<open>nondet_monad\<close> is deterministic iff it
returns exactly one state and result and does not fail\<close>
definition
  det :: "('a,'s) nondet_monad \<Rightarrow> bool"
where
  "det f \<equiv> \<forall>s. \<exists>r. f s = ({r},False)"

text \<open>A deterministic \<open>nondet_monad\<close> can be turned
  into a normal state monad:\<close>
definition
  the_run_state :: "('s,'a) nondet_monad \<Rightarrow> 's \<Rightarrow> 'a \<times> 's"
where
  "the_run_state M \<equiv> \<lambda>s. THE s'. fst (M s) = {s'}"

subsection "Non-Failure"

text \<open>
  With the failure flag, we can formulate non-failure separately
  from validity. A monad \<open>m\<close> does not fail under precondition
  \<open>P\<close>, if for no start state in that precondition it sets
  the failure flag.
\<close>
definition
  no_fail :: "('s \<Rightarrow> bool) \<Rightarrow> ('s,'a) nondet_monad \<Rightarrow> bool"
where
  "no_fail P m \<equiv> \<forall>s. P s \<longrightarrow> \<not> (snd (m s))"

text \<open>
  It is often desired to prove non-failure and a Hoare triple
  simultaneously, as the reasoning is often similar. The following
  definitions allow such reasoning to take place.
\<close>

definition
  validNF ::"('s \<Rightarrow> bool) \<Rightarrow> ('s,'a) nondet_monad \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool"
      ("\<lbrace>_\<rbrace>/ _ /\<lbrace>_\<rbrace>!")
where
  "validNF P f Q \<equiv> valid P f Q \<and> no_fail P f"

definition
  validE_NF :: "('s \<Rightarrow> bool) \<Rightarrow> ('s, 'a + 'b) nondet_monad \<Rightarrow>
             ('b \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow>
             ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool"
  ("\<lbrace>_\<rbrace>/ _ /(\<lbrace>_\<rbrace>,/ \<lbrace>_\<rbrace>!)")
where
  "validE_NF P f Q E \<equiv> validE P f Q E \<and> no_fail P f"

lemma validE_NF_alt_def:
  "\<lbrace> P \<rbrace> B \<lbrace> Q \<rbrace>,\<lbrace> E \<rbrace>! = \<lbrace> P \<rbrace> B \<lbrace> \<lambda>v s. case v of Inl e \<Rightarrow> E e s | Inr r \<Rightarrow> Q r s \<rbrace>!"
  by (clarsimp simp: validE_NF_def validE_def validNF_def)

text \<open>
  Usually, well-formed monads constructed from the primitives
  above will have the following property: if they return an
  empty set of results, they will have the failure flag set.
\<close>
definition
  empty_fail :: "('s,'a) nondet_monad \<Rightarrow> bool"
where
  "empty_fail m \<equiv> \<forall>s. fst (m s) = {} \<longrightarrow> snd (m s)"

text \<open>
  Useful in forcing otherwise unknown executions to have
  the @{const empty_fail} property.
\<close>
definition
  mk_ef :: "'a set \<times> bool \<Rightarrow> 'a set \<times> bool"
where
  "mk_ef S \<equiv> (fst S, fst S = {} \<or> snd S)"

section "Basic exception reasoning"

text \<open>
  The following predicates \<open>no_throw\<close> and \<open>no_return\<close> allow
  reasoning that functions in the exception monad either do
  no throw an exception or never return normally.
\<close>

definition "no_throw P A \<equiv> \<lbrace> P \<rbrace> A \<lbrace> \<lambda>_ _. True \<rbrace>,\<lbrace> \<lambda>_ _. False \<rbrace>"

definition "no_return P A \<equiv> \<lbrace> P \<rbrace> A \<lbrace>\<lambda>_ _. False\<rbrace>,\<lbrace>\<lambda>_ _. True \<rbrace>"

end


(*
   Title: The pi-calculus
   Author/Maintainer: Jesper Bengtson (jebe.dk), 2012
*)
theory Strong_Early_Bisim_Subst
  imports Strong_Early_Bisim
begin

abbreviation StrongCongEarlyJudge (infixr "\<sim>\<^sup>s" 65) where   "P \<sim>\<^sup>s Q \<equiv> (P, Q) \<in> (substClosed bisim)"

lemma congBisim:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<sim>\<^sup>s Q"

  shows "P \<sim> Q"
using assms substClosedSubset by blast

lemma eqvt:
  shows "eqvt (substClosed bisim)"
by(rule eqvtSubstClosed[OF Strong_Early_Bisim.eqvt])

lemma eqvtI:
  fixes P :: pi
  and   Q :: pi
  and   perm :: "name prm"

  assumes "P \<sim>\<^sup>s Q"

  shows "(perm \<bullet> P) \<sim>\<^sup>s (perm \<bullet> Q)"
using assms
by(rule eqvtRelI[OF eqvt])

lemma reflexive:
  fixes P :: pi

  shows "P \<sim>\<^sup>s P"
by(force simp add: substClosed_def intro: Strong_Early_Bisim.reflexive)

lemma symetric:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<sim>\<^sup>s Q"

  shows "Q \<sim>\<^sup>s P"
using assms
by(force simp add: substClosed_def intro: Strong_Early_Bisim.bisimE)

lemma partUnfold:
  fixes P :: pi
  and   Q :: pi
  and   s :: "(name \<times> name) list"

  assumes "P \<sim>\<^sup>s Q"

  shows "P[<s>] \<sim>\<^sup>s Q[<s>]"
using assms
proof(auto simp add: substClosed_def)
  fix s'
  assume "\<forall>s. P[<s>] \<sim> Q[<s>]"
  hence "P[<(s@s')>] \<sim> Q[<(s@s')>]" by blast
  moreover have "P[<(s@s')>] = (P[<s>])[<s'>]"
    by(induct s', auto)
  moreover have "Q[<(s@s')>] = (Q[<s>])[<s'>]"
    by(induct s', auto)

  ultimately show "(P[<s>])[<s'>] \<sim> (Q[<s>])[<s'>]"
    by simp
qed

end


section \<open>A Formalization of Jeroslow's Original Argument\<close>

(*<*)
theory Jeroslow_Original imports
"Syntax_Independent_Logic.Pseudo_Term"
Abstract_Jeroslow_Encoding
begin
(*>*)

subsection \<open>Preliminaries\<close>

text \<open>The First Derivability Condition was stated using a formula
with free variable @{term xx}, whereas the pseudo-term theory employs a different variable,
inp. The distinction is of course immaterial, because we can perform
a change of variable in the instantiation:\<close>

context HBL1
begin

text \<open>Changing the variable (from @{term xx} to @{term inp}) in the provability predicate:\<close>
definition "Pinp \<equiv> subst P (Var inp) xx"
lemma PP_Pinp: "t \<in> trm \<Longrightarrow> PP t = instInp Pinp t"
unfolding PP_def Pinp_def instInp_def by auto

text \<open>A version of HBL1 that uses the @{term inp} variable:\<close>
lemma HBL1_inp:
"\<phi> \<in> fmla \<Longrightarrow> Fvars \<phi> = {} \<Longrightarrow> prv \<phi> \<Longrightarrow> prv (instInp Pinp \<langle>\<phi>\<rangle>)"
unfolding Pinp_def instInp_def by (auto intro: HBL1)

end \<comment> \<open>context @{locale HBL1 }\<close>

subsection \<open>Jeroslow-style diagonalization\<close>

locale Jeroslow_Diagonalization =
Deduct_with_False_Disj_Rename
  var trm fmla Var FvarsT substT Fvars subst
  eql cnj imp all exi
  fls
  dsj
  num
  prv
+
Encode
  var trm fmla Var FvarsT substT Fvars subst
  num
  enc
for
var :: "'var set" and trm :: "'trm set" and fmla :: "'fmla set"
and Var FvarsT substT Fvars subst
and eql cnj imp all exi
and fls
and dsj
and num
and prv
and enc ("\<langle>_\<rangle>")
+
fixes F :: "('trm \<Rightarrow> 'trm) set"
  and encF :: "('trm \<Rightarrow> 'trm) \<Rightarrow> 'fmla"
  and N :: "'trm \<Rightarrow> 'trm"
  and ssap :: "'fmla \<Rightarrow> 'trm \<Rightarrow> 'trm"
assumes
\<comment> \<open>For the members @{term f} of @{term F}, we will only care about their action on numerals,
and we assume that they send numerals to numerals.\<close>
F[simp,intro!]: "\<And> f n. f \<in> F \<Longrightarrow> n \<in> num \<Longrightarrow> f n \<in> num"
and
encF[simp,intro!]: "\<And> f. f \<in> F \<Longrightarrow> encF f \<in> ptrm (Suc 0)"
and
N[simp,intro!]: "N \<in> F"
and
ssap[simp]: "\<And>\<phi>. \<phi> \<in> fmla \<Longrightarrow> Fvars \<phi> = {inp} \<Longrightarrow> ssap \<phi> \<in> F"
and
ReprF: "\<And>f n. f \<in> F \<Longrightarrow> n \<in> num \<Longrightarrow> prveqlPT (instInp (encF f) n) (f n)"
and
CapN: "\<And>\<phi>. \<phi> \<in> fmla \<Longrightarrow> Fvars \<phi> = {} \<Longrightarrow> N \<langle>\<phi>\<rangle> = \<langle>neg \<phi>\<rangle>"
and
CapSS: \<comment> \<open>We consider formulas @{term \<psi>} of one variable, called @{term inp}:\<close>
"\<And> \<psi> f. \<psi> \<in> fmla \<Longrightarrow> Fvars \<psi> = {inp} \<Longrightarrow> f \<in> F \<Longrightarrow>
    ssap \<psi> \<langle>encF f\<rangle> = \<langle>instInpP \<psi> 0 (instInp (encF f) \<langle>encF f\<rangle>)\<rangle>"
begin

lemma encF_fmla[simp,intro!]: "\<And> f. f \<in> F \<Longrightarrow> encF f \<in> fmla"
by auto

lemma enc_trm: "\<phi> \<in> fmla \<Longrightarrow> \<langle>\<phi>\<rangle> \<in> trm"
by auto

definition \<tau>J :: "'fmla \<Rightarrow> 'fmla" where
"\<tau>J \<psi> \<equiv> instInp (encF (ssap \<psi>)) (\<langle>encF (ssap \<psi>)\<rangle>)"

definition \<phi>J :: "'fmla \<Rightarrow> 'fmla" where
"\<phi>J \<psi> \<equiv> instInpP \<psi> 0 (\<tau>J \<psi>)"

lemma \<tau>J[simp]:
assumes "\<psi> \<in> fmla" and "Fvars \<psi> = {inp}"
shows "\<tau>J \<psi> \<in> ptrm 0"
unfolding \<tau>J_def apply(rule instInp)
using assms by auto

lemma \<tau>J_fmla[simp]:
assumes "\<psi> \<in> fmla" and "Fvars \<psi> = {inp}"
shows "\<tau>J \<psi> \<in> fmla"
using \<tau>J[OF assms] unfolding ptrm_def by auto

lemma FvarsT_\<tau>J[simp]:
assumes "\<psi> \<in> fmla" and "Fvars \<psi> = {inp}"
shows "Fvars (\<tau>J \<psi>) = {out}"
using \<tau>J[OF assms] unfolding ptrm_def by auto

lemma \<phi>J[simp]:
assumes "\<psi> \<in> fmla" and "Fvars \<psi> = {inp}"
shows "\<phi>J \<psi> \<in> fmla"
unfolding \<phi>J_def using assms by (intro instInpP_fmla) auto

lemma Fvars_\<phi>J[simp]:
assumes "\<psi> \<in> fmla" and "Fvars \<psi> = {inp}"
shows "Fvars (\<phi>J \<psi>) = {}"
using assms unfolding \<phi>J_def by auto

lemma diagonalization:
assumes \<psi>[simp]: "\<psi> \<in> fmla" and [simp]: "Fvars \<psi> = {inp}"
shows "prveqlPT (\<tau>J \<psi>) \<langle>instInpP \<psi> 0 (\<tau>J \<psi>)\<rangle> \<and>
       prv (eqv (\<phi>J \<psi>) (instInp \<psi> \<langle>\<phi>J \<psi>\<rangle>))"
proof
  define f where "f \<equiv> ssap \<psi>"
  have f[simp]: "f \<in> F" unfolding f_def using assms by auto
  have ff: "f \<langle>encF f\<rangle> = \<langle>instInpP \<psi> 0 (\<tau>J \<psi>)\<rangle>"
  using assms unfolding f_def \<tau>J_def by (intro CapSS) auto

  show "prveqlPT (\<tau>J \<psi>) \<langle>instInpP \<psi> 0 (\<tau>J \<psi>)\<rangle>"
  using ReprF[OF f, of "\<langle>encF f\<rangle>"]
  unfolding \<tau>J_def[of \<psi>, unfolded f_def[symmetric],symmetric] ff[symmetric]
  by auto
  from prveqlPT_prv_instInp_eqv_instInpP[OF \<psi>, of "\<tau>J \<psi>", OF _ _ _ _ this,
           unfolded \<phi>J_def[symmetric]]
  show "prv (eqv (\<phi>J \<psi>) (instInp \<psi> \<langle>\<phi>J \<psi>\<rangle>))"
  by auto
qed

end \<comment> \<open>context @{locale Jeroslow_Diagonalization}\<close>

subsection \<open>Jeroslow's Second Incompleteness Theorem\<close>

text \<open>We follow Jeroslow's pseudo-term-based development of the
Second Incompleteness Theorem and point out the location in the proof that
implicitly uses an unstated assumption: the fact that, for certain two provably
equivalent formulas @{term \<phi>} and @{term \<phi>'}, it is provable that
the provability of the encoding of @{term \<phi>'} implies
the provability of the encoding of @{term \<phi>}. \<close>

locale Jeroslow_Godel_Second =
Jeroslow_Diagonalization
  var trm fmla Var FvarsT substT Fvars subst
  eql cnj imp all exi
  fls
  dsj
  num
  prv
  enc
  F encF N ssap
+
HBL1
  var trm fmla Var FvarsT substT Fvars subst
  num
  eql cnj imp all exi
  prv prv
  enc
  P
for
var :: "'var set" and trm :: "'trm set" and fmla :: "'fmla set"
and Var FvarsT substT Fvars subst
and eql cnj imp all exi
and fls
and dsj
and num
and prv
and enc ("\<langle>_\<rangle>")
and P
and F encF N ssap
+
assumes
SHBL3: "\<And>\<tau>. \<tau> \<in> ptrm 0 \<Longrightarrow> prv (imp (instInpP Pinp 0 \<tau>) (instInp Pinp \<langle>instInpP Pinp 0 \<tau>\<rangle>))"
begin

text \<open>Consistency formula a la Jeroslow:\<close>
definition jcons :: "'fmla" where
"jcons \<equiv> all xx (neg (cnj (instInp Pinp (Var xx))
                           (instInpP Pinp 0 (instInp (encF N) (Var (xx))))))"

lemma prv_eql_subst_trm3:
"x \<in> var \<Longrightarrow> \<phi> \<in> fmla \<Longrightarrow> t1 \<in> trm \<Longrightarrow> t2 \<in> trm \<Longrightarrow>
prv (eql t1 t2) \<Longrightarrow> prv (subst \<phi> t1 x) \<Longrightarrow> prv (subst \<phi> t2 x)"
using prv_eql_subst_trm2
  by (meson subst prv_imp_mp)

lemma Pinp[simp,intro!]: "Pinp \<in> fmla"
and Fvars_Pinp[simp]: "Fvars Pinp = {inp}"
unfolding Pinp_def by auto

lemma ReprF_combineWith_CapN:
assumes "\<phi> \<in> fmla" and "Fvars \<phi> = {}"
shows "prveqlPT (instInp (encF N) \<langle>\<phi>\<rangle>) \<langle>neg \<phi>\<rangle>"
using assms unfolding CapN[symmetric, OF assms] by (intro ReprF) auto

theorem jeroslow_godel_second:
assumes consistent
\<comment> \<open>Assumption that is not stated by Jeroslow, but seems to be needed:\<close>
assumes unstated:
        "let \<psi> = instInpP Pinp (Suc 0) (encF N);
             \<tau> = \<tau>J \<psi>;
             \<phi> = instInpP (instInpP Pinp (Suc 0) (encF N)) 0 \<tau>;
             \<phi>' = instInpP Pinp 0 (instInpP (encF N) 0 \<tau>)
         in prv (imp (instInp Pinp \<langle>\<phi>'\<rangle>) (instInp Pinp \<langle>\<phi>\<rangle>))"
shows "\<not> prv jcons"
proof
  assume *: "prv jcons"

  define \<psi> where "\<psi> \<equiv> instInpP Pinp (Suc 0) (encF N)"
  define \<tau> where "\<tau> \<equiv> \<tau>J \<psi>"
  define \<phi> where "\<phi> \<equiv> \<phi>J \<psi>"
  have \<psi>[simp,intro]: "\<psi> \<in> fmla" "Fvars \<psi> = {inp}"
  unfolding \<psi>_def by auto
  have \<tau>[simp,intro]: "\<tau> \<in> ptrm 0" "\<tau> \<in> fmla" "Fvars \<tau> = {out}"
    unfolding \<tau>_def by auto
  have [simp]: "\<phi> \<in> fmla" "Fvars \<phi> = {}" unfolding \<phi>_def by auto

  define eN\<tau> where "eN\<tau> \<equiv> instInpP (encF N) 0 \<tau>"
  have eN\<tau>[simp]: "eN\<tau> \<in> ptrm 0" "eN\<tau> \<in> fmla" "Fvars eN\<tau> = {out}"
   unfolding eN\<tau>_def by auto
  define \<phi>' where "\<phi>' \<equiv> instInpP Pinp 0 eN\<tau>"
  have [simp]: "\<phi>' \<in> fmla" "Fvars \<phi>' = {}" unfolding \<phi>'_def by auto

  have \<phi>\<phi>': "prv (imp \<phi> \<phi>')" and \<phi>'\<phi>: "prv (imp \<phi>' \<phi>)" and \<phi>e\<phi>': "prv (eqv \<phi> \<phi>')"
   unfolding \<phi>_def \<phi>J_def \<phi>'_def eN\<tau>_def \<tau>_def[symmetric] unfolding \<psi>_def
   using prv_instInpP_compose[of Pinp "encF N" \<tau>] by auto

  from diagonalization[OF \<psi>]
  have "prveqlPT \<tau> \<langle>instInpP \<psi> 0 \<tau>\<rangle>" and **: "prv (eqv \<phi> (instInp \<psi> \<langle>\<phi>\<rangle>))"
  unfolding \<tau>_def[symmetric] \<phi>_def[symmetric] by auto
  have "**1": "prv (imp \<phi> (instInp \<psi> \<langle>\<phi>\<rangle>))" "prv (imp (instInp \<psi> \<langle>\<phi>\<rangle>) \<phi>)"
   using prv_imp_eqvEL[OF _ _ **] prv_imp_eqvER[OF _ _ **] by auto

  from SHBL3[OF eN\<tau>(1)]
  have "prv (imp (instInpP Pinp 0 eN\<tau>) (instInp Pinp \<langle>instInpP Pinp 0 eN\<tau>\<rangle>))" .
  hence "prv (imp \<phi>' (instInp Pinp \<langle>\<phi>'\<rangle>))" unfolding \<phi>'_def .
  from prv_prv_imp_trans[OF _ _ _ \<phi>\<phi>' this]
  have 0: "prv (imp \<phi> (instInp Pinp \<langle>\<phi>'\<rangle>))" by auto

  note unr = unstated[unfolded Let_def
    \<phi>_def[unfolded \<phi>J_def \<tau>_def[symmetric], symmetric] \<psi>_def[symmetric]
      \<tau>_def[symmetric] eN\<tau>_def[symmetric] \<phi>'_def[symmetric] \<phi>J_def]

  have 1: "prv (imp \<phi> (instInp Pinp \<langle>\<phi>\<rangle>))"
  apply(nrule r: nprv_prvI)
  apply(nrule r: nprv_impI)
  apply(nrule r: nprv_addLemmaE[OF unr])
  apply(nrule r: nprv_addImpLemmaE[OF 0])
  apply(nrule r: nprv_clear3_3)
  by (simp add: nprv_clear2_2 prv_nprv1I unr)

  have 2: "prv (imp \<phi> (cnj (instInp Pinp \<langle>\<phi>\<rangle>)
                           (instInp \<psi> \<langle>\<phi>\<rangle>)))"
  apply(nrule r: nprv_prvI)
  apply(nrule r: nprv_impI)
  apply(nrule r: nprv_cnjI)
  subgoal apply(nrule r: nprv_addImpLemmaE[OF 1]) .
  subgoal apply(nrule r: nprv_addImpLemmaE[OF "**1"(1)]) . .

  define z where "z \<equiv> Variable (Suc (Suc 0))"
  have z_facts[simp]: "z \<in> var" "z \<noteq> xx" "z \<notin> Fvars Pinp"
    "out \<noteq> z \<and> z \<noteq> out" "inp \<noteq> z \<and> z \<noteq> inp"
   unfolding z_def by auto

  have 30: "subst (instInpP Pinp 0 (instInp (encF N) (Var xx))) \<langle>\<phi>\<rangle> xx =
            instInpP Pinp 0 (instInp (encF N) \<langle>\<phi>\<rangle>)"
  unfolding z_def[symmetric] instInp_def instInpP_def Let_def
  by (variousSubsts4 auto
        s1: subst_compose_diff s2: subst_subst
        s3: subst_notIn[of _ _ xx] s4: subst_compose_diff)
  have 31: "subst (instInp Pinp (Var xx)) \<langle>\<phi>\<rangle> xx =
            instInp Pinp \<langle>\<phi>\<rangle>" unfolding instInp_def by auto
  have [simp]: "instInp (instInpP Pinp (Suc 0) (encF N)) \<langle>\<phi>\<rangle> =
           instInpP Pinp 0 (instInp (encF N) \<langle>\<phi>\<rangle>)"
  by (auto simp: instInp_instInpP \<psi>_def)

  have 3: "prv (neg (cnj (instInp Pinp \<langle>\<phi>\<rangle>)
                         (instInp \<psi> \<langle>\<phi>\<rangle>)))"
  apply(nrule r: nprv_prvI)
  apply(nrule r: nprv_addLemmaE[OF *, unfolded jcons_def])
  apply(rule nprv_allE0[of _ _ _ "\<langle>\<phi>\<rangle>"], auto)
  unfolding 30 31
  apply(nrule r: nprv_clear2_2)
  apply(nrule r: nprv_negI)
  apply(nrule r: nprv_negE0)
  apply(nrule r: nprv_clear2_2)
  apply(nrule r: nprv_cnjE0)
  apply(nrule r: nprv_clear3_3)
  apply(nrule r: nprv_cnjI)
  apply(nrule r: nprv_clear2_1)
  unfolding \<psi>_def
  apply(nrule r: nprv_hyp) .

  have ***: "prv (neg \<phi>)"
  apply(nrule r: nprv_prvI)
  apply(nrule r: nprv_negI)
  apply(nrule r: nprv_addImpLemmaE[OF 2])
  apply(nrule r: nprv_addLemmaE[OF 3])
  apply(nrule r: nprv_negE0) .

  have 4: "prv (instInp Pinp \<langle>neg \<phi>\<rangle>)" using HBL1_inp[OF _ _ ***] by auto

  have 5: "prveqlPT (instInp (encF N) \<langle>\<phi>\<rangle>) \<langle>neg \<phi>\<rangle>"
    using ReprF_combineWith_CapN[of \<phi>] by auto

  have [simp]: "instInp (encF N) \<langle>\<phi>\<rangle> \<in> ptrm 0" using instInp by auto

  have 6: "prv (instInpP Pinp 0 (instInp (encF N) \<langle>\<phi>\<rangle>))"
  apply(nrule r: nprv_prvI)
  apply(nrule r: nprv_addLemmaE[OF 4])
  apply(nrule r: prveqlPT_nprv_instInpP_instInp[OF _ _ _ _ _ 5]) .

  note lem = "**1"(2)[unfolded \<psi>_def]
  have "prv \<phi>"
  apply(nrule r: nprv_prvI)
  apply(nrule r: nprv_addLemmaE[OF 6])
  apply(nrule r: nprv_addImpLemmaE[OF lem]) .

  from this *** \<open>consistent\<close> show False unfolding consistent_def3 by auto
qed

end \<comment> \<open>context @{locale Jeroslow_Godel_Second}\<close>

(*<*)
end
(*>*)


theory Calc_Mem_Imp imports (*Calc_Mem*)
 "../../Language_Components/Cond/Cond"
 "../../Language_Components/Calc/Calc"
  "../../Language_Components/Mem/Mem_Simple"
              "../../Language_Components/Imp_Ctl/Imp_Ctl"
             "../../Language_Components/Seq/Seq"
"../../Hoare/Hoare_Step"
"../../Composition/Dominant_Instances"
"../../Lifter/Auto_Lifter_Proofs"
"../../Lifter/Auto_Lifter"
begin

datatype syn =
  Sc "calc"
  | Sm "Mem_Simple.syn"
  | Sb "cond"
  | Si "Imp_Ctl.syn'"
  | Ss "Seq.syn"
  | Ssk

fun calc_trans :: "syn \<Rightarrow> calc" where
"calc_trans (Sc x ) = x"
| "calc_trans _ = Cskip"

fun calc_prio :: "(Calc.calc \<Rightarrow> nat)" where
"calc_prio (Cskip) = 1"
| "calc_prio _ = 2"

fun calc_toggle :: "syn \<Rightarrow> bool" where
"calc_toggle (Sc _) = True"
| "calc_toggle _ = False"

fun mem_trans :: "syn \<Rightarrow> Mem_Simple.syn" where
"mem_trans (Sm m) = m"
| "mem_trans _ = Mem_Simple.Sskip"

fun mem_toggle :: "syn \<Rightarrow> bool" where
"mem_toggle (Sm _) = True"
| "mem_toggle _ = False"

(* mem_prio not needed, handled by custom implementation (?still true?) *)

fun cond_trans :: "syn \<Rightarrow> Cond.cond" where
"cond_trans (Sb x) = x"
| "cond_trans _ = Sskip_cond"

fun cond_prio :: "Cond.cond \<Rightarrow> nat" where
"cond_prio (Sskip_cond) = 1"
| "cond_prio _ = 2"

fun cond_toggle :: "syn \<Rightarrow> bool" where
"cond_toggle (Sb _) = True"
| "cond_toggle _ = False"

fun seq_trans :: "syn \<Rightarrow> Seq.syn" where
"seq_trans (Ss x) = x"
| "seq_trans _ = Seq.Sskip"

(* NB seq is always active; this is handled by special rules *)

fun imp_trans :: "syn \<Rightarrow> Imp_Ctl.syn'" where
"imp_trans (Si x) = x"
| "imp_trans _ = Imp_Ctl.Sskip"

fun imp_toggle :: "syn \<Rightarrow> bool" where
"imp_toggle (Si x) = (x \<noteq> Imp_Ctl.Sskip)"
| "imp_toggle _ = False"

(* layout of state:
 * boolean flag
 * result int (for some reason)
 * input int 1
 * input int 2
 * control stuff (at end and probably don't need to care)
 *)

type_synonym ('s, 'x) state =
  "('s, 'x) Mem_Simple.state"

definition calc_schemi where
"calc_schemi = (SP NA (SP NB NC))"
declare calc_schemi_def [simp]

definition calc_lift_aux1 where
"calc_lift_aux1 =
  schem_lift NA (SPRI (SO NA))"
declare calc_lift_aux1_def [simp]

definition calc_lift_aux2 where
"calc_lift_aux2 =
  schem_lift NA (SP (SPRI (SO NA)) NX)"

definition calc_schemo where
"calc_schemo = (SP NX (SP (SPRC calc_prio (SO NC)) (SP (SPRI (SO NA)) (SP (SPRI (SO NB)) NX))))"
declare calc_schemo_def [simp]

(* need no_control_lifting_S *)
definition calc_lift :: "(Calc.calc, Calc.calc_state, ('s, 'x :: {Bogus, Pord, Mergeableb, Okay, Pordps}) Mem_Simple.state) lifting" where
"calc_lift =
  no_control_lifting (schem_lift calc_schemi calc_schemo)"

definition calc_sem_l :: "syn \<Rightarrow> ('s, _) state \<Rightarrow> ('s, _) state" where
"calc_sem_l =
 lift_map_t_s calc_trans calc_lift calc_toggle
calc_sem"

lemma calc_prio_pos : "\<And> s . 0 < calc_prio s"
proof-
  fix s
  show "0 < calc_prio s"
    by(cases s; auto)
qed

lemma calc_valid :
  "lifting_valid_ok ((schem_lift calc_schemi calc_schemo)
::
    (Calc.calc, Calc.calc_state, ('x :: {Okay, Bogus, Mergeableb, Pordps}) state1) lifting)
    (schem_lift_S calc_schemi calc_schemo) "
  unfolding calc_lift_def schem_lift_defs schem_lift_S_defs
no_control_lifting_def calc_schemi_def calc_schemo_def
  by(fastforce simp add: calc_prio_pos intro: lifting_valid_fast lifting_ortho_fast)

lemma calc_valid_full' :
  "lifting_valid_ok (no_control_lifting (schem_lift calc_schemi calc_schemo)  ::
(Calc.calc, Calc.calc_state, ('s, 'x :: {Bogus, Pord, Mergeableb, Okay, Pordps}) Mem_Simple.state) lifting)
                    (no_control_lifting_S (schem_lift calc_schemi calc_schemo) (schem_lift_S calc_schemi calc_schemo))"
  using no_control_l_valid[OF calc_valid]
  by auto

lemma calc_valid_full :
  "lifting_valid_ok calc_lift
(no_control_lifting_S (schem_lift calc_schemi calc_schemo) (schem_lift_S calc_schemi calc_schemo))"
  unfolding calc_lift_def
  using calc_valid_full'
  by auto

(* the following sketch gives more detail into the proof structure.
 * it may be useful for debugging errors in the proof search, especially
 * tricky ones related to polymorphism *)
(*

  apply(rule merge_l_ortho.ax_g_comm)
          apply(auto intro: lifting_valid_slower lifting_ortho_slow)
        apply(rule merge_l_ortho.intro)
          apply(rule snd_l_ortho.ax_g)
          apply(auto intro: lifting_valid_slower lifting_ortho_slow)
              apply(rule snd_l_ortho.intro)
              apply(rule fst_l_snd_l_ortho.ax_g_comm)
          apply(auto intro: lifting_valid_slower lifting_ortho_slow)
              apply(rule fst_l_snd_l_ortho.intro)
               apply(rule lifting_valid_base_ext.intro)
               apply(simp add: prio_l_def option_l_def triv_l_def bot_defs)
  apply(rule lifting_valid_base_ext.intro)
        apply(simp add: lifter_instances bot_defs)
  apply(rule snd_l_ortho.ax_g)
         apply(auto intro: lifting_valid_slower lifting_ortho_slow)
       apply(rule snd_l_ortho.intro)
  apply(rule snd_l_ortho.ax_g)
         apply(auto intro: lifting_valid_slower lifting_ortho_slow)
       apply(rule snd_l_ortho.intro)
  apply(rule fst_l_snd_l_ortho.ax_g_comm)
         apply(fastforce intro: lifting_valid_slower lifting_ortho_slow)
        apply(fastforce intro: lifting_valid_slower lifting_ortho_slow)
       apply(fastforce intro: lifting_valid_slower lifting_ortho_slow)
      apply(fastforce intro: lifting_valid_slower lifting_ortho_slow)
         apply(fastforce intro: lifting_valid_slower lifting_ortho_slow)
    apply(fastforce intro: lifting_valid_slower lifting_ortho_slow)
  apply(rule merge_l_valid_ext.ax)
  apply(rule merge_l_valid_ext.intro)
    apply(fastforce intro: lifting_valid_slower lifting_ortho_slow)
   apply(rule merge_l_valid_ext.ax)
  apply(rule merge_l_valid_ext.intro)
    apply(fastforce intro: lifting_valid_slower lifting_ortho_slow)
   apply(rule snd_l_valid_ext.ax)
   apply(rule snd_l_valid_ext.intro)
   apply(rule fst_l_valid_ext.ax)
   apply(rule fst_l_valid_ext.intro)
   apply(rule prio_l_valid_ext_strong.ax)
   apply(rule prio_l_valid_ext_strong.intro)
   apply(rule prio_l_valid_ext_strong'.intro)
   apply(simp add: calc_prio_pos)

  apply(rule merge_l_valid_ok_ext.ax_g)
  apply(rule merge_l_valid_ok_ext.intro)
         apply(fastforce simp add: calc_prio_pos intro: lifting_valid_fast lifting_ortho_fast)
  apply(rule snd_l_valid_ok_ext.ax_g)
     apply(rule snd_l_valid_ok_ext.intro)
  apply(rule snd_l_valid_ok_ext.ax_g)
  apply(rule snd_l_valid_ok_ext.intro)
  apply(rule fst_l_valid_ok_ext.ax_g)
       apply(rule fst_l_valid_ok_ext.intro)
       apply(rule prio_l_valid_ok_ext.ax)
       apply(rule prio_l_valid_ok_ext.intro)
       apply(rule option_l_valid_ok_ext.ax)
       apply(rule option_l_valid_ok_ext.intro)
(* Something weird about polymorphism is happening here. *)
  apply(rule triv_l_valid_ok_ext.ax)
         apply(fastforce simp add: calc_prio_pos intro: lifting_valid_fast lifting_ortho_fast)
         apply(fastforce simp add: calc_prio_pos intro: lifting_valid_fast lifting_ortho_fast)
         apply(fastforce simp add: calc_prio_pos intro: lifting_valid_fast lifting_ortho_fast)
         apply(fastforce simp add: calc_prio_pos intro: lifting_valid_fast lifting_ortho_fast)
         apply(fastforce simp add: calc_prio_pos intro: lifting_valid_fast lifting_ortho_fast)

(*
  using merge_l_ortho.ax_g_comm
  using merge_l_ortho.ax_g_comm
[of "(snd_l (snd_l (snd_l (fst_l (prio_l (\<lambda>_. 0) (\<lambda>_. (+) (Suc 0)) (option_l triv_l))))))"
     _
     "(snd_l (fst_l (prio_l calc_prio (\<lambda>s. (+) (calc_prio s)) (option_l triv_l))))"
     _
     "(snd_l (snd_l (fst_l (prio_l (\<lambda>_. 0) (\<lambda>_. (+) (Suc 0)) (option_l triv_l)))))"]
*)
        apply(rule merge_l_ortho.ax_g_comm)
              apply(fastforce intro: lifting_valid_noaxiom lifting_ortho_noaxiom)
              apply(fastforce intro: lifting_valid_noaxiom lifting_ortho_noaxiom; simp add: fst_l_S_def snd_l_S_def prio_l_S_def)

          apply(auto intro: lifting_valid_noaxiom lifting_ortho_noaxiom)
        apply(rule merge_l_ortho.intro)
(* bad things start happening here - introducing existential-variable constraints that are not solvable! *)
  apply(rule snd_l_ortho.ax)
            apply(auto intro: lifting_valid_noaxiom lifting_ortho_noaxiom)
              apply(rule snd_l_ortho.intro)
  apply(rule fst_l_snd_l_ortho.ax_g_comm)
          apply(auto intro: lifting_valid_noaxiom lifting_ortho_noaxiom lifting_valid_base_ext.intro base_bot)
              apply(rule fst_l_snd_l_ortho.intro)
  apply(rule prio_l_valid_base_ext.ax)
  apply(rule prio_l_valid_base_ext.intro)
                apply(auto intro: lifting_valid_noaxiom lifting_ortho_noaxiom)
              apply(fastforce intro: lifting_valid_noaxiom lifting_ortho_noaxiom)
  apply(simp add: snd_l_S_def fst_l_S_def prio_l_S_def option_l_S_def split: md_prio.splits)
apply(fastforce intro: lifting_valid_noaxiom lifting_ortho_noaxiom)
              apply(rule snd_l_valid_base_ext.ax)
              apply(rule snd_l_valid_base_ext.intro)
           apply(rule fst_l_valid_base_ext.ax)
  apply(simp add: snd_l_S_def fst_l_S_def prio_l_S_def option_l_S_def split: md_prio.splits)
apply(fastforce intro: lifting_valid_noaxiom lifting_ortho_noaxiom)
  apply(simp add: snd_l_S_def fst_l_S_def prio_l_S_def option_l_S_def split: md_prio.splits)
apply(fastforce intro: lifting_valid_noaxiom lifting_ortho_noaxiom)

                apply(auto intro: lifting_valid_noaxiom lifting_ortho_noaxiom)
*)

definition cond_lift :: "(Cond.cond, Cond.cond_state, ('s, 'x :: {Bogus, Pord, Mergeableb, Okay, Pordps}) Mem_Simple.state) lifting" where
"cond_lift =
  no_control_lifting (schem_lift (SP NA NB) (SP (SPRC cond_prio (SO NA))
                     (SP (SPRI (SO NB)) NX)) :: (Cond.cond, Cond.cond_state, ('x :: {Okay, Bogus, Mergeableb, Pordps}) state1) lifting)
"

definition cond_sem_l :: "syn \<Rightarrow> ('s, _) state \<Rightarrow> ('s, _) state" where
"cond_sem_l =
  lift_map_t_s cond_trans
    cond_lift cond_toggle
  cond_sem"

lemma cond_prio_pos :
  "\<And> s . 0 < cond_prio s"
proof-
  fix s
  show "0 < cond_prio s"
    by(cases s; auto)
qed

lemma cond_valid :
  "lifting_valid_ok ((schem_lift (SP NA NB) (SP (SPRC cond_prio (SO NA))
                     (SP (SPRI (SO NB)) NX))) ::
    (Cond.cond, Cond.cond_state, ('x :: {Okay, Bogus, Mergeableb, Pordps}) state1) lifting)
    (schem_lift_S (SP NA NB) (SP (SPRC cond_prio (SO NA))
                     (SP (SPRI (SO NB)) NX))) "
  unfolding calc_lift_def schem_lift_defs schem_lift_S_defs
no_control_lifting_def calc_schemi_def calc_schemo_def
  by(fastforce simp add: cond_prio_pos intro: lifting_valid_fast lifting_ortho_fast)

lemma cond_valid_full' :
  "lifting_valid_ok
  (no_control_lifting (schem_lift (SP NA NB) (SP (SPRC cond_prio (SO NA))
                     (SP (SPRI (SO NB)) NX)) :: (Cond.cond, Cond.cond_state, ('x :: {Okay, Bogus, Mergeableb, Pordps}) state1) lifting))
  (no_control_lifting_S (schem_lift (SP NA NB) (SP (SPRC cond_prio (SO NA))
                     (SP (SPRI (SO NB)) NX)))
  (schem_lift_S (SP NA NB) (SP (SPRC cond_prio (SO NA))
                     (SP (SPRI (SO NB)) NX))))"
    using no_control_l_valid[OF cond_valid]
    by auto

lemma cond_valid_full :
  "lifting_valid_ok
  cond_lift
  (no_control_lifting_S (schem_lift (SP NA NB) (SP (SPRC cond_prio (SO NA))
                     (SP (SPRI (SO NB)) NX)))
  (schem_lift_S (SP NA NB) (SP (SPRC cond_prio (SO NA))
                     (SP (SPRI (SO NB)) NX))))"
  unfolding cond_lift_def
  using cond_valid_full'
  by blast

(*
definition imp_sem_l :: "syn \<Rightarrow> ('s, (_ :: Pordc_all)) state \<Rightarrow> ('s, (_ :: Pordc_all)) state" where
"imp_sem_l = imp_sem_l_gen imp_trans"
*)

definition seq_sem_l :: "syn \<Rightarrow> ('s, _ ::{Okay, Bogus, Mergeableb, Pordps}) state \<Rightarrow> ('s, _) state" where
"seq_sem_l = seq_sem_l_gen seq_trans"

definition mem_lift :: "(Mem_Simple.syn, Mem_Simple.state0, ('s, _ ::{Okay, Bogus, Mergeableb, Pordps}) state) lifting" where
"mem_lift = no_control_lifting mem_lift1"

lemma mem_prio_reg_pos : "\<And> r s . 0 < mem_prio_reg r s"
proof-
  fix r s
  show "0 < mem_prio_reg r s"
    by(cases s; auto)
qed

lemma mem_prio_mem_pos : "\<And> s . 0 < mem_prio_mem s"
proof-
  fix s
  show "0 < mem_prio_mem s"
    by(cases s; auto)
qed

lemma mem_valid :
  "lifting_valid_ok mem_lift1 mem_lift1_S"
  unfolding mem_lift1_def mem_lift1_S_def
no_control_lifting_def calc_schemi_def calc_schemo_def schem_lift_defs schem_lift_S_defs
  by(fastforce simp add: mem_prio_reg_pos mem_prio_mem_pos intro: lifting_valid_fast lifting_ortho_fast)

lemma mem_valid_full :
  "lifting_valid_ok mem_lift (no_control_lifting_S mem_lift1 mem_lift1_S)"
  using no_control_l_valid[OF mem_valid]
  unfolding mem_lift_def
  by auto

definition mem_sem_l :: "syn \<Rightarrow> ('s, _) state \<Rightarrow> ('s, _) state" where
"mem_sem_l = lift_map_t_s mem_trans mem_lift mem_toggle mem0_sem"

definition imp_sem_lifting_spec where
"imp_sem_lifting_spec =
  (imp_sem_lifting_gen :: (_, _, (_, (_ :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state) lifting)"

definition imp_sem_l :: "syn \<Rightarrow> ('s, (_ :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> ('s, (_ :: {Okay, Bogus, Mergeableb, Pordps})) state" where
"imp_sem_l = lift_map_t_s imp_trans imp_sem_lifting_spec imp_toggle imp_ctl_sem"

definition sem_final :: "syn \<Rightarrow> ('s, (_ :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> ('s, (_ :: {Okay, Bogus, Mergeableb, Pordps})) state" where
"sem_final =
  pcomps [calc_sem_l, mem_sem_l, cond_sem_l, imp_sem_l, seq_sem_l]"

definition sems ::
  "(syn \<Rightarrow> ('s, (_ :: {Okay, Bogus, Mergeableb, Pordps})) state \<Rightarrow> ('s, (_ :: {Okay, Bogus, Mergeableb, Pordps})) state) set" where
"sems = {calc_sem_l, mem_sem_l, cond_sem_l, imp_sem_l, seq_sem_l}"

(* sems without seq - this is used for certain Hoare facts. *)

definition sems' ::
  "(syn \<Rightarrow> ('s, (_ :: {Okay, Bogus, Mergeableb, Pordps})) state \<Rightarrow> ('s, (_ :: {Okay, Bogus, Mergeableb, Pordps})) state) set" where
"sems' = {calc_sem_l, mem_sem_l, cond_sem_l, imp_sem_l}"

(* For a rather annoying technical reason we have to show that the other semantics
 * functions aren't equal to the Seq function (this is because we use sets in places
 * to reason about the semantics functions)
 * Fortunately this is usually not hard to prove, but it feels like there should be
 * a way around it.*)
lemma calc_sem_l_noteq_seq :
  "(calc_sem_l :: (syn \<Rightarrow> ('s, ('c :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> ('s, ('c )) state)) \<noteq>
   (seq_sem_l :: (syn \<Rightarrow> ('s, ('c)) state \<Rightarrow> ('s, ('c)) state))"
proof
  assume H : "(calc_sem_l :: (syn \<Rightarrow> ('s, ('c)) state \<Rightarrow> ('s, ('c)) state)) =
   (seq_sem_l :: (syn \<Rightarrow> ('s, ('c)) state \<Rightarrow> ('s, ('c)) state))"

  have
    "(calc_sem_l :: (syn \<Rightarrow> ('s, ('c)) state \<Rightarrow> ('s, ('c)) state)) (Sc Cadd) \<bottom> =
   (seq_sem_l :: (syn \<Rightarrow> ('s, ('c)) state \<Rightarrow> ('s, ('c)) state))
    (Sc Cadd) \<bottom>"
    using fun_cong[OF fun_cong[OF H, of "Sc Cadd"], of \<bottom>]
    by(auto)
  then show False
    by(auto simp add: seq_sem_l_def calc_sem_l_def bot_defs
lift_map_t_s_def seq_sem_l_gen_def seq_sem_lifting_gen_def lift_map_s_def calc_lift_def no_control_lifting_def
schem_lift_defs lifter_instances)
qed

lemma mem_sem_l_noteq_seq :
  "(mem_sem_l :: (syn \<Rightarrow> ('s, ('c :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> ('s, ('c)) state)) \<noteq>
   (seq_sem_l :: (syn \<Rightarrow> ('s, ('c)) state \<Rightarrow> ('s, ('c)) state))"
proof
  assume H :
    "(mem_sem_l :: (syn \<Rightarrow> ('s, ('c :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> ('s, ('c)) state)) =
      (seq_sem_l ::  (syn \<Rightarrow> ('s, ('c :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> ('s, ('c)) state))"

  have "(mem_sem_l :: (syn \<Rightarrow> ('s, ('c :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> ('s, ('c)) state)) Ssk \<bottom> = seq_sem_l Ssk \<bottom>"
    using fun_cong[OF fun_cong[OF H, of "Ssk"], of \<bottom>]
    by(auto)
  then show False
    by(auto simp add: seq_sem_l_def calc_sem_l_def mem_sem_l_def bot_defs
lift_map_t_s_def seq_sem_l_gen_def seq_sem_lifting_gen_def lift_map_s_def calc_lift_def no_control_lifting_def
schem_lift_defs lifter_instances)
qed

lemma cond_sem_l_noteq_seq :
  "(cond_sem_l :: (syn \<Rightarrow> ('s, ('c :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> ('s, ('c)) state)) \<noteq>
   (seq_sem_l :: (syn \<Rightarrow> ('s, ('c)) state \<Rightarrow> ('s, ('c)) state))"
proof
  assume H :
    "(cond_sem_l :: (syn \<Rightarrow> ('s, ('c :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> ('s, ('c)) state)) =
      (seq_sem_l ::  (syn \<Rightarrow> ('s, ('c :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> ('s, ('c)) state))"

  have "(cond_sem_l :: (syn \<Rightarrow> ('s, ('c :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> ('s, ('c)) state)) Ssk \<bottom> = seq_sem_l Ssk \<bottom>"
    using fun_cong[OF fun_cong[OF H, of "Ssk"], of \<bottom>]
    by(auto)
  then show False
    by(auto simp add: seq_sem_l_def cond_sem_l_def mem_sem_l_def bot_defs
lift_map_t_s_def seq_sem_l_gen_def seq_sem_lifting_gen_def lift_map_s_def calc_lift_def no_control_lifting_def
schem_lift_defs lifter_instances)
qed

lemma imp_sem_l_noteq_seq :
  "(imp_sem_l :: (syn \<Rightarrow> ('s, ('c :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> ('s, ('c)) state)) \<noteq>
   (seq_sem_l :: (syn \<Rightarrow> ('s, ('c)) state \<Rightarrow> ('s, ('c)) state))"
proof
  assume H :
    "(imp_sem_l :: (syn \<Rightarrow> ('s, ('c :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> ('s, ('c)) state)) =
      (seq_sem_l ::  (syn \<Rightarrow> ('s, ('c :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> ('s, ('c)) state))"

  have "(imp_sem_l :: (syn \<Rightarrow> ('s, ('c :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> ('s, ('c)) state)) Ssk \<bottom> = seq_sem_l Ssk \<bottom>"
    using fun_cong[OF fun_cong[OF H, of "Ssk"], of \<bottom>]
    by(auto)
  then show False
    by(auto simp add: seq_sem_l_def imp_sem_l_def calc_sem_l_def mem_sem_l_def bot_defs
lift_map_t_s_def seq_sem_l_gen_def seq_sem_lifting_gen_def lift_map_s_def calc_lift_def no_control_lifting_def
schem_lift_defs lifter_instances)
qed

lemma sems'_eq :
  shows "sems' = sems - {seq_sem_l}"
proof
  show "sems - {seq_sem_l} \<subseteq> sems'"
    unfolding sems_def sems'_def
    by auto
next
  show "sems' \<subseteq> sems - {seq_sem_l}"
    unfolding sems'_def sems_def
    by(auto simp add: imp_sem_l_noteq_seq calc_sem_l_noteq_seq mem_sem_l_noteq_seq cond_sem_l_noteq_seq)
qed

(* Domination facts needed for proof. *)
lemma calc_dom :
  "(calc_sem_l :: (syn \<Rightarrow> ('s, ('c :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) state \<Rightarrow> ('s, ('c)) state)) \<downharpoonleft> sems' { x . (calc_toggle x = True)}"
  unfolding calc_sem_l_def
proof(rule dominant_toggles)
  show "lifting_valid calc_lift
     (no_control_lifting_S (schem_lift calc_schemi calc_schemo)
       (schem_lift_S calc_schemi calc_schemo))"
    using lifting_valid_ok.axioms[OF calc_valid_full] unfolding calc_lift_def
    by(auto)
next
  show "finite sems'"
    unfolding sems'_def
    by auto
next
  show "lift_map_t_s calc_trans calc_lift calc_toggle calc_sem \<in> sems'"
    unfolding sems'_def
    calc_sem_l_def
    by auto
next
  show "\<And>s. s \<in> {x. calc_toggle x = True} \<Longrightarrow> calc_toggle s"
    by auto
next
  fix f s z
  assume F1 :"f \<in> sems'"
  assume F2 :"f \<noteq> lift_map_t_s calc_trans calc_lift calc_toggle calc_sem"

  have Calc_Mem : "(\<forall>s. calc_toggle s \<longrightarrow> \<not> mem_toggle s)"
  proof
    fix s
    show "calc_toggle s \<longrightarrow> \<not> mem_toggle s"
      by(cases s; auto)
  qed

  have Calc_Imp : "(\<forall>s. calc_toggle s \<longrightarrow> \<not> imp_toggle s)"
  proof
    fix s
    show "calc_toggle s \<longrightarrow> \<not> imp_toggle s"
      by(cases s; auto)
  qed

  have Calc_Cond : "(\<forall>s. calc_toggle s \<longrightarrow> \<not> cond_toggle s)"
  proof
    fix s
    show "calc_toggle s \<longrightarrow> \<not> cond_toggle s"
      by(cases s; auto)
  qed

  show "\<exists>tg g. f = toggle tg g \<and> (\<forall>s. s \<in> {x. calc_toggle x = True} \<longrightarrow> \<not> tg s)"
    using F1 F2 Calc_Mem Calc_Imp Calc_Cond
    unfolding sems'_def calc_sem_l_def mem_sem_l_def cond_sem_l_def imp_sem_l_def
      lift_map_t_s_toggle
    by(auto)
qed

lemma mem_dom :
  "mem_sem_l \<downharpoonleft> sems' { x . (mem_toggle x = True)}"
  unfolding mem_sem_l_def
proof(rule dominant_toggles)
  show "lifting_valid mem_lift (no_control_lifting_S mem_lift1 mem_lift1_S)"
    using lifting_valid_ok.axioms[OF mem_valid_full]
    by(auto)
next
  show "finite sems'"
    unfolding sems'_def
    by auto
next
  show "lift_map_t_s mem_trans mem_lift mem_toggle mem0_sem \<in> sems'"
    unfolding sems'_def
    mem_sem_l_def
    by auto
next
  show "\<And>s. s \<in> {x. mem_toggle x = True} \<Longrightarrow> mem_toggle s"
    by auto
next
  fix f s z
  assume F1 :"f \<in> sems'"
  assume F2 :"f \<noteq> lift_map_t_s mem_trans mem_lift mem_toggle mem0_sem"

  have Mem_Calc : "(\<forall>s. mem_toggle s \<longrightarrow> \<not> calc_toggle s)"
  proof
    fix s
    show "mem_toggle s \<longrightarrow> \<not> calc_toggle s"
      by(cases s; auto)
  qed

  have Mem_Imp : "(\<forall>s. mem_toggle s \<longrightarrow> \<not> imp_toggle s)"
  proof
    fix s
    show "mem_toggle s \<longrightarrow> \<not> imp_toggle s"
      by(cases s; auto)
  qed

  have Mem_Cond : "(\<forall>s. mem_toggle s \<longrightarrow> \<not> cond_toggle s)"
  proof
    fix s
    show "mem_toggle s \<longrightarrow> \<not> cond_toggle s"
      by(cases s; auto)
  qed

  show "\<exists>tg g. f = toggle tg g \<and> (\<forall>s. s \<in> {x. mem_toggle x = True} \<longrightarrow> \<not> tg s)"
    using F1 F2 Mem_Calc Mem_Imp Mem_Cond
    unfolding sems'_def calc_sem_l_def mem_sem_l_def cond_sem_l_def imp_sem_l_def
      lift_map_t_s_toggle
    by(auto)
qed

lemma cond_dom :
  "cond_sem_l \<downharpoonleft> sems' { x . (cond_toggle x = True)}"
  unfolding cond_sem_l_def
proof(rule dominant_toggles)
  show "lifting_valid cond_lift (no_control_lifting_S (schem_lift (SP NA NB) (SP (SPRC cond_prio (SO NA))
                     (SP (SPRI (SO NB)) NX)))
  (schem_lift_S (SP NA NB) (SP (SPRC cond_prio (SO NA))
                     (SP (SPRI (SO NB)) NX))))"
    using lifting_valid_ok.axioms[OF cond_valid_full]
    by(auto)
next
  show "finite sems'"
    unfolding sems'_def
    by auto
next
  show "lift_map_t_s cond_trans cond_lift cond_toggle cond_sem \<in> sems'"
    unfolding sems'_def
    cond_sem_l_def
    by auto
next
  show "\<And>s. s \<in> {x. cond_toggle x = True} \<Longrightarrow> cond_toggle s"
    by auto
next
  fix f s z
  assume F1 :"f \<in> sems'"
  assume F2 :"f \<noteq> lift_map_t_s cond_trans cond_lift cond_toggle cond_sem"

  have Cond_Calc : "(\<forall>s. cond_toggle s \<longrightarrow> \<not> calc_toggle s)"
  proof
    fix s
    show "cond_toggle s \<longrightarrow> \<not> calc_toggle s"
      by(cases s; auto)
  qed

  have Cond_Imp : "(\<forall>s. cond_toggle s \<longrightarrow> \<not> imp_toggle s)"
  proof
    fix s
    show "cond_toggle s \<longrightarrow> \<not> imp_toggle s"
      by(cases s; auto)
  qed

  have Cond_Mem : "(\<forall>s. cond_toggle s \<longrightarrow> \<not> mem_toggle s)"
  proof
    fix s
    show "cond_toggle s \<longrightarrow> \<not> mem_toggle s"
      by(cases s; auto)
  qed

  show "\<exists>tg g. f = toggle tg g \<and> (\<forall>s. s \<in> {x. cond_toggle x = True} \<longrightarrow> \<not> tg s)"
    using F1 F2 Cond_Calc Cond_Imp Cond_Mem
    unfolding sems'_def calc_sem_l_def mem_sem_l_def cond_sem_l_def imp_sem_l_def
      lift_map_t_s_toggle
    by(auto)
qed

lemma imp_dom :
  "imp_sem_l \<downharpoonleft> sems' { x . (imp_toggle x = True )}"
  unfolding imp_sem_l_def
proof(rule dominant_toggles)
  show "lifting_valid imp_sem_lifting_spec
         (schem_lift_S (SP NA NB)
             (SP (SPRC imp_prio (SO NA)) (SP NX (SP (SPRI (SO NB)) NX))))"
    using lifting_valid_ok.axioms[OF imp_sem_lifting_gen_valid2]
    unfolding imp_sem_lifting_gen_def imp_sem_lifting_spec_def
    by(auto)
next
  show "finite sems'"
    unfolding sems'_def
    by auto
next
  show "lift_map_t_s imp_trans imp_sem_lifting_spec imp_toggle imp_ctl_sem \<in> sems'"
    unfolding sems'_def
    imp_sem_l_def
    by auto
next
  show "\<And>s. s \<in> {x. imp_toggle x = True} \<Longrightarrow> imp_toggle s"
    by auto
next
  fix f s z
  assume F1 :"f \<in> sems'"
  assume F2 :"f \<noteq> lift_map_t_s imp_trans imp_sem_lifting_spec imp_toggle imp_ctl_sem"

  have Imp_Calc : "(\<forall>s. imp_toggle s \<longrightarrow> \<not> calc_toggle s)"
  proof
    fix s
    show "imp_toggle s \<longrightarrow> \<not> calc_toggle s"
      by(cases s; auto)
  qed

  have Imp_Cond : "(\<forall>s. imp_toggle s \<longrightarrow> \<not> cond_toggle s)"
  proof
    fix s
    show "imp_toggle s \<longrightarrow> \<not> cond_toggle s"
      by(cases s; auto)
  qed

  have Imp_Mem : "(\<forall>s. imp_toggle s \<longrightarrow> \<not> mem_toggle s)"
  proof
    fix s
    show "imp_toggle s \<longrightarrow> \<not> mem_toggle s"
      by(cases s; auto)
  qed

  show "\<exists>tg g. f = toggle tg g \<and> (\<forall>s. s \<in> {x. imp_toggle x = True} \<longrightarrow> \<not> tg s)"
    using F1 F2 Imp_Calc Imp_Cond Imp_Mem
    unfolding sems'_def calc_sem_l_def mem_sem_l_def cond_sem_l_def imp_sem_l_def
      lift_map_t_s_toggle
    by(auto)
qed

lemma seq_sem_lifting_gen_valid'' :
  "lifting_valid_ok (seq_sem_lifting_gen :: (Seq.syn, 'x state', ('x, _ :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all}) control) lifting)
                  (schem_lift_S seq_sem_lifting_schem1 seq_sem_lifting_schem2)" unfolding seq_sem_lifting_gen_def seq_sem_lifting_schem1_def seq_sem_lifting_schem2_def
  unfolding seq_sem_lifting'_def schem_lift_defs schem_lift_S_defs
  by(fastforce intro: lifting_valid_fast)

lemma seq_dom :
  "((seq_sem_l :: (syn \<Rightarrow> ('s, _ ::{Okay, Bogus, Mergeableb, Pordps, Pordc_all}) state \<Rightarrow> ('s, _) state)) \<downharpoonleft> sems { Ss Sseq})"
  unfolding seq_sem_l_def seq_sem_l_gen_def
proof(rule dominant_toggle_others)
  show "lifting_valid
    (seq_sem_lifting_gen ::
    (Seq.syn, 'x state', ('x, (_  :: {Okay, Bogus, Mergeableb, Pordps, Pordc_all})) control) lifting)
    (schem_lift_S seq_sem_lifting_schem1 seq_sem_lifting_schem2)"
    using lifting_valid_ok.axioms(1)[OF seq_sem_lifting_gen_valid'']
    unfolding seq_sem_lifting_gen_def
    by(auto)
next
  show "finite sems"
    unfolding sems_def
    by auto
next
  show "lift_map_s seq_trans seq_sem_lifting_gen seq_sem \<in> sems"
    unfolding sems_def
    seq_sem_l_gen_def seq_sem_l_def
    by auto
next
  show "\<And>s. s \<in> {Ss Sseq} \<Longrightarrow> (\<lambda> x . x = (Ss Sseq)) s"
    by auto
next
  fix f s z
  assume F1 :"f \<in> sems"
  assume F2 :"f \<noteq> lift_map_s seq_trans seq_sem_lifting_gen seq_sem"

  have Seq_Calc : "(\<forall>s. s = Ss Sseq \<longrightarrow> \<not> calc_toggle s)"
  proof
    fix s
    show "s = Ss Sseq \<longrightarrow> \<not> calc_toggle s"
      by(cases s; auto)
  qed

  have Seq_Cond : "(\<forall>s. s = Ss Sseq \<longrightarrow> \<not> cond_toggle s)"
  proof
    fix s
    show "s = Ss Sseq  \<longrightarrow> \<not> cond_toggle s"
      by(cases s; auto)
  qed

  have Seq_Mem : "(\<forall>s. s = Ss Sseq \<longrightarrow> \<not> mem_toggle s)"
  proof
    fix s
    show "s = Ss Sseq \<longrightarrow> \<not> mem_toggle s"
      by(cases s; auto)
  qed

  have Seq_Imp : "(\<forall>s. s = Ss Sseq \<longrightarrow> \<not> imp_toggle s)"
  proof
    fix s
    show "s = Ss Sseq \<longrightarrow> \<not> imp_toggle s"
      by(cases s; auto)
  qed

  show "\<exists>tg g. f = toggle tg g \<and> (\<forall>s. s \<in> {Ss Sseq} \<longrightarrow> \<not> tg s)"
    using F1 F2 Seq_Calc Seq_Cond Seq_Mem
    unfolding sems_def sems'_def calc_sem_l_def mem_sem_l_def cond_sem_l_def imp_sem_l_def
      lift_map_t_s_toggle seq_sem_l_def seq_sem_l_gen_def
    by(auto)
qed
lemma imp_dom_seq :
  "(imp_sem_l :: syn \<Rightarrow> ('s, 'a ::{Okay, Bogus, Mergeableb, Pordps, Pordc_all}) state \<Rightarrow> ('s, 'a) state) \<downharpoonleft> {imp_sem_l, seq_sem_l} { x . (imp_toggle x = True)}"
proof(rule dominantI)
  fix x :: Calc_Mem_Imp.syn
  fix b :: "('s, 'a ::{Okay, Bogus, Mergeableb, Pordps, Pordc_all}) state"

  assume X: "x \<in> {x. imp_toggle x = True}"

  then obtain x' where X' : "x = Si x'" "x' \<noteq> Imp_Ctl.Sskip"
    by (cases x; auto)

  then have "seq_sem_l x b <[ imp_sem_l x b"
    by(cases x'; auto simp add: seq_sem_l_def imp_sem_l_def
seq_sem_l_gen_def lift_map_s_def lift_map_t_s_def seq_sem_lifting_gen_def schem_lift_defs
imp_sem_lifting_spec_def imp_sem_lifting_gen_def lifter_instances
seq_sem_def imp_prio_def imp_ctl_sem_def
prod_pleq prio_pleq leq_refl list_bogus
split: prod.splits option.splits md_triv.splits md_prio.splits Seq.syn.splits)

  then have Conc' : "is_sup
            (
             {seq_sem_l x b, imp_sem_l x b})
            (imp_sem_l x b)"
    using is_sup_pair
    by auto

  have Comm : "{imp_sem_l x b, seq_sem_l x b} = {seq_sem_l x b, imp_sem_l x b}"
    by auto

  have Eq : "{seq_sem_l x b, imp_sem_l x b} =
((\<lambda>g. g x b) `
             {(imp_sem_l)
              , seq_sem_l})"
    by auto

  show
    "is_sup
            ((\<lambda>g. g x b) `
             {(imp_sem_l)
              , seq_sem_l})
            (imp_sem_l x b)"
    using Conc'
    unfolding Comm Eq
    by auto
qed

lemma imp_dom_all :
  "imp_sem_l \<downharpoonleft> sems { x . (imp_toggle x = True )}"
proof(rule dominant_pairwise)
  show "finite sems"
    by(auto simp add: sems_def)
next
  show "imp_sem_l \<in> sems"
    by(auto simp add: sems_def)
next
  fix f'
  assume "f' \<in> sems"

  then consider (F'_s')  "f' \<in> sems'" |
           (F'_seq) "f' = seq_sem_l"
    unfolding sems'_def sems_def
    by auto
  then
  show "imp_sem_l \<downharpoonleft> {f', imp_sem_l} {x. imp_toggle x = True}"
  proof cases
    case F'_s'
    then show ?thesis
      using dominant_subset[OF imp_dom, of "{f', imp_sem_l}"]
      unfolding sems'_def
      by(auto)
  next
    case F'_seq

    have Comm : "{imp_sem_l, seq_sem_l} = {seq_sem_l, imp_sem_l}"
      by auto

    then show ?thesis
      using imp_dom_seq unfolding Comm F'_seq
      by auto
  qed
qed

(*
term "(schem_lift (SP NA (SP NB (SP NC (SP ND (NE)))))
                    (SP (SPRI (SO NA)) (SP (SPRI (SO NB)) (SP (SPRI (SO NC))
                    (SP (SPRI (SO ND)) (SID NE))))))"

term "(schem_lift (SP NA (SP NB (SP NC (SP ND (SP NE NF)))))
                    (SP (SPRI (SO NA)) (SP (SPRI (SO NB)) (SP (SPRI (SO NC))
                    (SP (SPRI (SO ND)) (SP (SPRI (SO NE)) (SID NF)))))))"

definition st_lift :: "(syn, int * int * int * int  * (String.literal, int swr) oalist, state) lifting" where
"st_lift =
  (schem_lift (SP NA (SP NB (SP NC (SP ND (NE)))))
                    (SP (SPRI (SO NA)) (SP (SPRI (SO NB)) (SP (SPRI (SO NC))
                    (SP (SPRI (SO ND)) (SID NE))))))"
term "LNew st_lift"

value "sem_final (Sm (Swrite (STR ''a'') Reg_a)) (LNew st_lift Ssk (4, 0, 0, 0, empty))"
*)
end