(*  Title:       Jive Data and Store Model
    Author:      Norbert Schirmer <schirmer at informatik.tu-muenchen.de>  and
                 Nicole Rauch <rauch at informatik.uni-kl.de>, 2003
    Maintainer:  Nicole Rauch <rauch at informatik.uni-kl.de>
    License:     LGPL
*)

section \<open>Value\<close>

theory Value imports Subtype begin

text \<open>This theory contains our model of the values in the store. The store is untyped, therefore all
  types that exist in Java are wrapped into one type \<open>Value\<close>.

  In a first approach, the primitive Java types supported in this formalization are
  mapped to similar Isabelle
  types. Later, we will have
  proper formalizations of the Java types in Isabelle, which will then be used here.
\<close>

type_synonym JavaInt = int
type_synonym JavaShort = int
type_synonym JavaByte = int
type_synonym JavaBoolean = bool

text \<open>The objects of each class are identified by a unique ID.
We use elements of type @{typ nat} here, but in general it is sufficient to use
an infinite type with a successor function and a comparison predicate.
\<close>

type_synonym ObjectId = nat

text \<open>The definition of the datatype \<open>Value\<close>. Values can be of the Java types
boolean, int, short and byte. Additionally, they can be an object reference,
an array reference or the value null.\<close>

datatype Value = boolV  JavaBoolean
               | intgV  JavaInt
               | shortV JavaShort
               | byteV  JavaByte
               | objV   CTypeId ObjectId   \<comment> \<open>typed object reference\<close>
               | arrV   Arraytype ObjectId \<comment> \<open>typed array reference\<close>
               | nullV

text \<open>Arrays are modeled as references just like objects. So they
can be viewed as special kinds of objects, like in Java.\<close>

subsection \<open>Discriminator Functions\<close>

text \<open>To test values, we define the following discriminator functions.\<close>

definition isBoolV  :: "Value \<Rightarrow> bool" where
"isBoolV v = (case v of
               boolV b  \<Rightarrow> True
             | intgV i  \<Rightarrow> False
             | shortV s \<Rightarrow> False
             | byteV  by \<Rightarrow> False
             | objV C a \<Rightarrow> False
             | arrV T a \<Rightarrow> False
             | nullV    \<Rightarrow> False)"

lemma isBoolV_simps [simp]:
"isBoolV (boolV b)       = True"
"isBoolV (intgV i)       = False"
"isBoolV (shortV s)      = False"
"isBoolV (byteV by)       = False"
"isBoolV (objV C a)      = False"
"isBoolV (arrV T a)      = False"
"isBoolV (nullV)         = False"
  by (simp_all add: isBoolV_def)

definition isIntgV  :: "Value \<Rightarrow> bool" where
"isIntgV v = (case v of
               boolV b  \<Rightarrow> False
             | intgV i  \<Rightarrow> True
             | shortV s \<Rightarrow> False
             | byteV by  \<Rightarrow> False
             | objV C a \<Rightarrow> False
             | arrV T a \<Rightarrow> False
             | nullV    \<Rightarrow> False)"

lemma isIntgV_simps [simp]:
"isIntgV (boolV b)       = False"
"isIntgV (intgV i)       = True"
"isIntgV (shortV s)       = False"
"isIntgV (byteV by)       = False"
"isIntgV (objV C a)      = False"
"isIntgV (arrV T a)      = False"
"isIntgV (nullV)         = False"
  by (simp_all add: isIntgV_def)

definition isShortV :: "Value \<Rightarrow> bool" where
"isShortV v = (case v of
               boolV b  \<Rightarrow> False
             | intgV i  \<Rightarrow> False
             | shortV s \<Rightarrow> True
             | byteV by  \<Rightarrow> False
             | objV C a \<Rightarrow> False
             | arrV T a \<Rightarrow> False
             | nullV    \<Rightarrow> False)"

lemma isShortV_simps [simp]:
"isShortV (boolV b)     = False"
"isShortV (intgV i)     = False"
"isShortV (shortV s)    = True"
"isShortV (byteV by)     = False"
"isShortV (objV C a)    = False"
"isShortV (arrV T a)    = False"
"isShortV (nullV)       = False"
  by (simp_all add: isShortV_def)

definition isByteV :: "Value \<Rightarrow> bool" where
"isByteV v = (case v of
               boolV b  \<Rightarrow> False
             | intgV i  \<Rightarrow> False
             | shortV s \<Rightarrow> False
             | byteV by  \<Rightarrow> True
             | objV C a \<Rightarrow> False
             | arrV T a \<Rightarrow> False
             | nullV    \<Rightarrow> False)"

definition isRefV :: "Value \<Rightarrow> bool" where
"isRefV v = (case v of
               boolV b  \<Rightarrow> False
             | intgV i  \<Rightarrow> False
             | shortV s \<Rightarrow> False
             | byteV by \<Rightarrow> False
             | objV C a  \<Rightarrow> True
             | arrV T a  \<Rightarrow> True
             | nullV     \<Rightarrow> True)"

lemma isRefV_simps [simp]:
"isRefV (boolV b)       = False"
"isRefV (intgV i)       = False"
"isRefV (shortV s)      = False"
"isRefV (byteV by)      = False"
"isRefV (objV C a)      = True"
"isRefV (arrV T a)      = True"
"isRefV (nullV)         = True"
  by (simp_all add: isRefV_def)

definition isObjV :: "Value \<Rightarrow> bool" where
"isObjV v = (case v of
               boolV b  \<Rightarrow> False
             | intgV i  \<Rightarrow> False
             | shortV s  \<Rightarrow> False
             | byteV by  \<Rightarrow> False
             | objV C a \<Rightarrow> True
             | arrV T a \<Rightarrow> False
             | nullV    \<Rightarrow> False)"

lemma isObjV_simps [simp]:
"isObjV (boolV b)  = False"
"isObjV (intgV i)  = False"
"isObjV (shortV s)  = False"
"isObjV (byteV by)  = False"
"isObjV (objV c a) = True"
"isObjV (arrV T a) = False"
"isObjV nullV      = False"
  by (simp_all add: isObjV_def)

definition isArrV :: "Value \<Rightarrow> bool" where
"isArrV v = (case v of
               boolV b  \<Rightarrow> False
             | intgV i  \<Rightarrow> False
             | shortV s  \<Rightarrow> False
             | byteV by  \<Rightarrow> False
             | objV C a \<Rightarrow> False
             | arrV T a \<Rightarrow> True
             | nullV    \<Rightarrow> False)"

lemma isArrV_simps [simp]:
"isArrV (boolV b)  = False"
"isArrV (intgV i)  = False"
"isArrV (shortV s)  = False"
"isArrV (byteV by)  = False"
"isArrV (objV c a) = False"
"isArrV (arrV T a) = True"
"isArrV nullV      = False"
  by (simp_all add: isArrV_def)

definition isNullV  :: "Value \<Rightarrow> bool" where
"isNullV v = (case v of
               boolV b  \<Rightarrow> False
             | intgV i  \<Rightarrow> False
             | shortV s  \<Rightarrow> False
             | byteV by  \<Rightarrow> False
             | objV C a \<Rightarrow> False
             | arrV T a \<Rightarrow> False
             | nullV    \<Rightarrow> True)"

lemma isNullV_simps [simp]:
"isNullV (boolV b)   = False"
"isNullV (intgV i)   = False"
"isNullV (shortV s)   = False"
"isNullV (byteV by)   = False"
"isNullV (objV c a) = False"
"isNullV (arrV T a) = False"
"isNullV nullV      = True"
  by (simp_all add: isNullV_def)

subsection \<open>Selector Functions\<close>

definition aI :: "Value \<Rightarrow> JavaInt" where
"aI v = (case v of
            boolV  b   \<Rightarrow> undefined
          | intgV  i   \<Rightarrow> i
          | shortV sh  \<Rightarrow> undefined
          | byteV  by  \<Rightarrow> undefined
          | objV   C a \<Rightarrow> undefined
          | arrV  T a  \<Rightarrow> undefined
          | nullV      \<Rightarrow> undefined)"
lemma aI_simps [simp]:
"aI (intgV i) = i"
by (simp add: aI_def)

definition aB :: "Value \<Rightarrow> JavaBoolean" where
"aB v = (case v of
            boolV  b   \<Rightarrow> b
          | intgV  i   \<Rightarrow> undefined
          | shortV sh  \<Rightarrow> undefined
          | byteV  by  \<Rightarrow> undefined
          | objV   C a \<Rightarrow> undefined
          | arrV  T a  \<Rightarrow> undefined
          | nullV      \<Rightarrow> undefined)"
lemma aB_simps [simp]:
"aB (boolV b) = b"
by (simp add: aB_def)

definition aSh :: "Value \<Rightarrow> JavaShort" where
"aSh v = (case v of
            boolV  b   \<Rightarrow> undefined
          | intgV  i   \<Rightarrow> undefined
          | shortV sh  \<Rightarrow> sh
          | byteV  by  \<Rightarrow> undefined
          | objV   C a \<Rightarrow> undefined
          | arrV  T a  \<Rightarrow> undefined
          | nullV      \<Rightarrow> undefined)"
lemma aSh_simps [simp]:
"aSh (shortV sh) = sh"
by (simp add: aSh_def)

definition aBy :: "Value \<Rightarrow> JavaByte" where
"aBy v = (case v of
            boolV  b   \<Rightarrow> undefined
          | intgV  i   \<Rightarrow> undefined
          | shortV s   \<Rightarrow> undefined
          | byteV  by  \<Rightarrow> by
          | objV   C a \<Rightarrow> undefined
          | arrV  T a  \<Rightarrow> undefined
          | nullV      \<Rightarrow> undefined)"
lemma aBy_simps [simp]:
"aBy (byteV by) = by"
by (simp add: aBy_def)

definition tid :: "Value \<Rightarrow> CTypeId" where
"tid v = (case v of
            boolV  b   \<Rightarrow> undefined
          | intgV  i   \<Rightarrow> undefined
          | shortV s   \<Rightarrow> undefined
          | byteV  by  \<Rightarrow> undefined
          | objV   C a \<Rightarrow> C
          | arrV  T a  \<Rightarrow> undefined
          | nullV      \<Rightarrow> undefined)"

lemma tid_simps [simp]:
"tid (objV C a) = C"
by (simp add: tid_def)

definition oid :: "Value \<Rightarrow> ObjectId" where
"oid v = (case v of
            boolV  b   \<Rightarrow> undefined
          | intgV  i   \<Rightarrow> undefined
          | shortV s   \<Rightarrow> undefined
          | byteV  by  \<Rightarrow> undefined
          | objV   C a \<Rightarrow> a
          | arrV  T a  \<Rightarrow> undefined
          | nullV      \<Rightarrow> undefined)"

lemma oid_simps [simp]:
"oid (objV C a) = a"
by (simp add: oid_def)

definition jt :: "Value \<Rightarrow> Javatype" where
"jt v = (case v of
            boolV  b   \<Rightarrow> undefined
          | intgV  i   \<Rightarrow> undefined
          | shortV s   \<Rightarrow> undefined
          | byteV  by  \<Rightarrow> undefined
          | objV   C a \<Rightarrow> undefined
          | arrV  T a  \<Rightarrow> at2jt T
          | nullV      \<Rightarrow> undefined)"

lemma jt_simps [simp]:
"jt (arrV T a) = at2jt T"
by (simp add: jt_def)

definition aid :: "Value \<Rightarrow> ObjectId" where
"aid v = (case v of
            boolV  b   \<Rightarrow> undefined
          | intgV  i   \<Rightarrow> undefined
          | shortV s   \<Rightarrow> undefined
          | byteV  by  \<Rightarrow> undefined
          | objV   C a \<Rightarrow> undefined
          | arrV  T a  \<Rightarrow> a
          | nullV      \<Rightarrow> undefined)"

lemma aid_simps [simp]:
"aid (arrV T a) = a"
by (simp add: aid_def)

subsection\<open>Determining the Type of a Value\<close>

text \<open>To determine the type of a value, we define the function
\<open>typeof\<close>. This function is
often written as $\tau$ in theoretical texts, therefore we add
the appropriate syntax support.\<close>

definition typeof :: "Value \<Rightarrow> Javatype" where
"typeof v = (case v of
               boolV b  \<Rightarrow> BoolT
             | intgV i  \<Rightarrow> IntgT
             | shortV sh  \<Rightarrow> ShortT
             | byteV by  \<Rightarrow> ByteT
             | objV C a \<Rightarrow> CClassT C
             | arrV T a \<Rightarrow> ArrT T
             | nullV    \<Rightarrow> NullT)"

abbreviation tau_syntax :: "Value \<Rightarrow> Javatype" ("\<tau> _")
  where "\<tau> v == typeof v"

lemma typeof_simps [simp]:
"(\<tau> (boolV b)) = BoolT"
"(\<tau> (intgV i)) = IntgT"
"(\<tau> (shortV sh)) = ShortT"
"(\<tau> (byteV by)) = ByteT"
"(\<tau> (objV c a)) = CClassT c"
"(\<tau> (arrV t a)) = ArrT t"
"(\<tau> (nullV))   = NullT"
  by (simp_all add: typeof_def)

subsection \<open>Default Initialization Values for Types\<close>

text \<open>The function \<open>init\<close> yields the default initialization values for each
type. For boolean, the
default value is False, for the integral types, it is 0, and for the reference
types, it is nullV.
\<close>

definition init :: "Javatype \<Rightarrow> Value" where
"init T = (case T of
             BoolT        \<Rightarrow> boolV  False
           | IntgT        \<Rightarrow> intgV  0
           | ShortT        \<Rightarrow> shortV 0
           | ByteT        \<Rightarrow> byteV  0
           | NullT        \<Rightarrow> nullV
           | ArrT T       \<Rightarrow> nullV
           | CClassT C     \<Rightarrow> nullV
           | AClassT C     \<Rightarrow> nullV
           | InterfaceT I \<Rightarrow> nullV)"

lemma init_simps [simp]:
"init BoolT          = boolV False"
"init IntgT          = intgV 0"
"init ShortT         = shortV 0"
"init ByteT          = byteV 0"
"init NullT          = nullV"
"init (ArrT T)       = nullV"
"init (CClassT c)     = nullV"
"init (AClassT a)     = nullV"
"init (InterfaceT i) = nullV"
  by (simp_all add: init_def)

lemma typeof_init_widen [simp,intro]: "typeof (init T) \<le> T"
proof (cases T)
  assume c: "T = BoolT"
  show "(\<tau> (init T)) \<le> T"
    using c by simp
next
  assume c: "T = IntgT"
  show "(\<tau> (init T)) \<le> T"
    using c by simp
next
  assume c: "T = ShortT"
  show "(\<tau> (init T)) \<le> T"
    using c by simp
next
  assume c: "T = ByteT"
  show "(\<tau> (init T)) \<le> T"
    using c by simp
next
  assume c: "T = NullT"
  show "(\<tau> (init T)) \<le> T"
    using c by simp
next
  fix x
  assume c: "T = CClassT x"
  show "(\<tau> (init T)) \<le> T"
    using c by (cases x, simp_all)
next
  fix x
  assume c: "T = AClassT x"
  show "(\<tau> (init T)) \<le> T"
    using c by (cases x, simp_all)
next
  fix x
  assume c: "T = InterfaceT x"
  show "(\<tau> (init T)) \<le> T"
    using c by (cases x, simp_all)
next
  fix x
  assume c: "T = ArrT x"
  show "(\<tau> (init T)) \<le> T"
    using c
  proof (cases x)
    fix y
    assume c2: "x = CClassAT y"
    show "(\<tau> (init T)) \<le> T"
      using c c2 by (cases y, simp_all)
  next
    fix y
    assume c2: "x = AClassAT y"
    show "(\<tau> (init T)) \<le> T"
      using c c2 by (cases y, simp_all)
  next
    fix y
    assume c2: "x = InterfaceAT y"
    show "(\<tau> (init T)) \<le> T"
      using c c2 by (cases y, simp_all)
  next
    assume c2: "x = BoolAT"
    show "(\<tau> (init T)) \<le> T"
      using c c2 by simp
  next
    assume c2: "x = IntgAT"
    show "(\<tau> (init T)) \<le> T"
      using c c2 by simp
  next
    assume c2: "x = ShortAT"
    show "(\<tau> (init T)) \<le> T"
      using c c2 by simp
  next
    assume c2: "x = ByteAT"
    show "(\<tau> (init T)) \<le> T"
      using c c2 by simp
  qed
qed

end


chapter \<open>Calculus of Programming\<close>

theory Calculus_of_Programming
  imports Spec_Framework IDE_CP_Reasoning1
  abbrevs "<state>" = "\<s>\<t>\<a>\<t>\<e>"
      and "<results>" = "\<r>\<e>\<s>\<u>\<l>\<t>\<s>"
      and "<in>" = "\<i>\<n>"
      and "<is>" = "\<i>\<s>"
begin

section \<open>Implementing CoP Sequent\<close>

text \<open>CoP sequent \<open>P | S |- Q\<close> for \<open>S = (C\<^sub>1,v\<^sub>1); \<cdots> ; (C\<^sub>n,v\<^sub>n)\<close> is implemented as
\begin{align*}
& \<open>\<c>\<u>\<r>\<r>\<e>\<n>\<t> s\<^sub>0 [R] \<r>\<e>\<s>\<u>\<l>\<t>\<s> \<i>\<n> P\<close>, \\
& \<open>CodeBlock s\<^sub>0 s\<^sub>1 C\<^sub>1 v\<^sub>1,\<close>         \\
&     \qquad \<open>\<cdots>\<close>                 \\
& \<open>CodeBlock s\<^sub>i\<^sub>-\<^sub>1 s\<^sub>i C\<^sub>i v\<^sub>i,\<close>       \\
&     \qquad \<open>\<cdots>\<close>                 \\
& \<open>CodeBlock s\<^sub>n\<^sub>-\<^sub>1 s\<^sub>n C\<^sub>n v\<^sub>n\<close>        \\
\<open>\<turnstile>\<close> \;&\; \<open>\<c>\<u>\<r>\<r>\<e>\<n>\<t> s\<^sub>n [R] \<r>\<e>\<s>\<u>\<l>\<t>\<s> \<i>\<n> Q\<close>
\end{align*}
where \<open>s\<^sub>0\<close> denotes the initial state before execution and \<open>s\<^sub>i, v\<^sub>i\<close> denote
respectively the intermediate state after executing procedure \<open>C\<^sub>i\<close> and
the return value of \<open>C\<^sub>i\<close>.
Sequence \<open>{s\<^sub>i}\<^sub>n\<close> therefore links execution of each procedure.
\<open>R\<close> is the frame variable.

[C]-modality \<open>[C]{Q}{E}\<close> is implemented by \<open>\<p>\<e>\<n>\<d>\<i>\<n>\<g> C \<o>\<n> s\<^sub>n [R] \<r>\<e>\<s>\<u>\<l>\<t>\<s> \<i>\<n> Q \<t>\<h>\<r>\<o>\<w>\<s> E\<close>.

\<close>

text \<open>
In addition, besides programming of procedures,
the system is extended to deduce view shift and transformation of abstraction by programming.

The programming deduction of view shift is also realized using similar structures
(\<open>CurrentConstruction\<close>). Thus we reuse the infrastructures and
give two modes \<open>programming_mode\<close> and \<open>view_shift_mode\<close> to differentiate the two modes.
\<close>

consts programming_mode :: mode
       view_shift_mode  :: mode

definition CurrentConstruction :: " mode \<Rightarrow> resource \<Rightarrow> assn \<Rightarrow> assn \<Rightarrow> bool "
  where "CurrentConstruction mode s R S \<longleftrightarrow> s \<in> (INTERP_SPEC (R * S))"

abbreviation Programming_CurrentConstruction ("\<c>\<u>\<r>\<r>\<e>\<n>\<t> _ [_]/ \<r>\<e>\<s>\<u>\<l>\<t>\<s> \<i>\<n> _" [1000,1000,11] 10)
  where \<open>Programming_CurrentConstruction \<equiv> CurrentConstruction programming_mode\<close>

abbreviation View_Shift_CurrentConstruction ("\<v>\<i>\<e>\<w> _ [_]/ \<i>\<s> _" [1000,1000,11] 10)
  where \<open>View_Shift_CurrentConstruction \<equiv> CurrentConstruction view_shift_mode\<close>

consts Programming_CurrentConstruction_syntax :: \<open>assn \<Rightarrow> bool\<close> ("\<c>\<u>\<r>\<r>\<e>\<n>\<t> \<s>\<t>\<a>\<t>\<e>: _" [11] 10)
consts View_Shift_CurrentConstruction_syntax :: \<open>assn \<Rightarrow> bool\<close> ("\<c>\<u>\<r>\<r>\<e>\<n>\<t> \<v>\<i>\<e>\<w>: _" [11] 10)

definition PendingConstruction :: " 'ret::VALs proc
                                  \<Rightarrow> resource
                                  \<Rightarrow> assn
                                  \<Rightarrow> ('ret \<phi>arg \<Rightarrow> assn)
                                  \<Rightarrow> (ABNM \<Rightarrow> assn)
                                  \<Rightarrow> bool "
    ("\<p>\<e>\<n>\<d>\<i>\<n>\<g> _ \<o>\<n> _ [_]/ \<r>\<e>\<s>\<u>\<l>\<t>\<s> \<i>\<n> _/ \<t>\<h>\<r>\<o>\<w>\<s> _" [1000,1000,1000,11,11] 10)
    where "PendingConstruction f s R S E \<longleftrightarrow> f s \<subseteq> \<S> (\<lambda>ret. INTERP_SPEC (R * S ret)) (\<lambda>ex. INTERP_SPEC (R * E ex))"

consts PendingConstruction_syntax :: \<open>'ret::VALs proc \<Rightarrow> ('ret \<phi>arg \<Rightarrow> assn) \<Rightarrow> (ABNM \<Rightarrow> assn) \<Rightarrow> bool\<close>
  ("\<p>\<e>\<n>\<d>\<i>\<n>\<g> \<p>\<r>\<o>\<c> _/ \<r>\<e>\<s>\<u>\<l>\<t>\<s> \<i>\<n> _/ \<t>\<h>\<r>\<o>\<w>\<s> _" [1000,11,11] 10)

translations
  "\<c>\<u>\<r>\<r>\<e>\<n>\<t> \<s>\<t>\<a>\<t>\<e>: S" <= "CONST Programming_CurrentConstruction s R S"
  "\<c>\<u>\<r>\<r>\<e>\<n>\<t> \<v>\<i>\<e>\<w>: S" <= "CONST View_Shift_CurrentConstruction s R S"
  "\<p>\<e>\<n>\<d>\<i>\<n>\<g> \<p>\<r>\<o>\<c> f \<r>\<e>\<s>\<u>\<l>\<t>\<s> \<i>\<n> S \<t>\<h>\<r>\<o>\<w>\<s> E" <= "CONST PendingConstruction f s R S E"

definition \<open>CodeBlock s s' f ret \<longleftrightarrow> Success ret s' \<in> f s\<close>

lemma CurrentConstruction_D: "CurrentConstruction mode s H T \<Longrightarrow> Inhabited T"
  unfolding CurrentConstruction_def Inhabited_def by (clarsimp simp add: \<phi>expns; blast)

definition ToA_Construction :: \<open>'a \<Rightarrow> 'a set \<Rightarrow> bool\<close> ("\<a>\<b>\<s>\<t>\<r>\<a>\<c>\<t>\<i>\<o>\<n>'(_') \<i>\<s> _" [11,11] 10)
  where \<open>ToA_Construction = (\<in>)\<close>

section \<open>Rules for Constructing Programs\<close>

subsection \<open>Construct Procedure\<close>

lemma \<phi>apply_proc:
  "(\<c>\<u>\<r>\<r>\<e>\<n>\<t> blk [R] \<r>\<e>\<s>\<u>\<l>\<t>\<s> \<i>\<n> S)
\<Longrightarrow> \<p>\<r>\<o>\<c> f \<lbrace> S \<longmapsto> T \<rbrace> \<t>\<h>\<r>\<o>\<w>\<s> E
\<Longrightarrow>(\<p>\<e>\<n>\<d>\<i>\<n>\<g> f \<o>\<n> blk [R] \<r>\<e>\<s>\<u>\<l>\<t>\<s> \<i>\<n> T \<t>\<h>\<r>\<o>\<w>\<s> E)"
  unfolding \<phi>Procedure_def CurrentConstruction_def PendingConstruction_def bind_def by (auto 0 5)

lemma
  \<open> (\<exists>s' x. CodeBlock s  s'  f x \<and> CodeBlock s' s'' (g x) y)
\<longleftrightarrow> CodeBlock s  s'' (f \<bind> g) y\<close>
  unfolding CodeBlock_def bind_def
  apply (rule; clarsimp)
  apply blast
  by (case_tac x; clarsimp; blast)

(*Hint: because
\<p>\<e>\<n>\<d>\<i>\<n>\<g> f \<o>\<n> s [R] \<r>\<e>\<s>\<u>\<l>\<t>\<s> \<i>\<n> U \<t>\<h>\<r>\<o>\<w>\<s> E1 \<longrightarrow>
  Invalid \<notin> f s \<and> (\<forall>v s'. Abnormality v s' \<in> f s \<longrightarrow> s' \<in> INTERP_SPEC (R \<heavy_comma> E v))*)

lemma \<phi>assemble_proc:
  \<open> \<p>\<e>\<n>\<d>\<i>\<n>\<g> f \<o>\<n> s [R] \<r>\<e>\<s>\<u>\<l>\<t>\<s> \<i>\<n> T \<t>\<h>\<r>\<o>\<w>\<s> E1
\<Longrightarrow> (\<And>s' ret. CodeBlock s s' f ret \<Longrightarrow> \<p>\<e>\<n>\<d>\<i>\<n>\<g> (g ret) \<o>\<n> s' [R] \<r>\<e>\<s>\<u>\<l>\<t>\<s> \<i>\<n> U \<t>\<h>\<r>\<o>\<w>\<s> E2)
\<Longrightarrow> \<p>\<e>\<n>\<d>\<i>\<n>\<g> (f \<bind> g) \<o>\<n> s [R] \<r>\<e>\<s>\<u>\<l>\<t>\<s> \<i>\<n> U \<t>\<h>\<r>\<o>\<w>\<s> E1 + E2\<close>
  unfolding CurrentConstruction_def PendingConstruction_def bind_def subset_iff CodeBlock_def
  apply clarsimp subgoal for s s'
  by (cases s; simp; cases s'; simp add: split_comp_All ring_distribs plus_fun) .

lemma \<phi>accept_proc:
  \<open> \<p>\<e>\<n>\<d>\<i>\<n>\<g> f \<o>\<n> s [R] \<r>\<e>\<s>\<u>\<l>\<t>\<s> \<i>\<n> T \<t>\<h>\<r>\<o>\<w>\<s> E
\<Longrightarrow> CodeBlock s s' f ret
\<Longrightarrow> \<c>\<u>\<r>\<r>\<e>\<n>\<t> s' [R] \<r>\<e>\<s>\<u>\<l>\<t>\<s> \<i>\<n> T ret\<close>
  unfolding PendingConstruction_def bind_def subset_iff CurrentConstruction_def CodeBlock_def
  by blast

lemma \<phi>accept_proc_optimize_return_v:
  \<open> \<p>\<e>\<n>\<d>\<i>\<n>\<g> (Return v) \<o>\<n> s [R] \<r>\<e>\<s>\<u>\<l>\<t>\<s> \<i>\<n> T \<t>\<h>\<r>\<o>\<w>\<s> E
\<Longrightarrow> \<c>\<u>\<r>\<r>\<e>\<n>\<t> s [R] \<r>\<e>\<s>\<u>\<l>\<t>\<s> \<i>\<n> T v\<close>
  unfolding PendingConstruction_def bind_def subset_iff CurrentConstruction_def Return_def
            det_lift_def
  by simp

(* lemma \<phi>accept_proc: \<comment> \<open>Depreciated!\<close>
  " \<p>\<e>\<n>\<d>\<i>\<n>\<g> f \<o>\<n> s [R] \<r>\<e>\<s>\<u>\<l>\<t>\<s> \<i>\<n> T \<t>\<h>\<r>\<o>\<w>\<s> E1
\<Longrightarrow> (\<And>s' ret. \<c>\<u>\<r>\<r>\<e>\<n>\<t> s' [R] \<r>\<e>\<s>\<u>\<l>\<t>\<s> \<i>\<n> T ret \<Longrightarrow> \<p>\<e>\<n>\<d>\<i>\<n>\<g> (g ret) \<o>\<n> s' [R] \<r>\<e>\<s>\<u>\<l>\<t>\<s> \<i>\<n> U \<t>\<h>\<r>\<o>\<w>\<s> E2)
\<Longrightarrow> \<p>\<e>\<n>\<d>\<i>\<n>\<g> (f \<bind> g) \<o>\<n> s [R] \<r>\<e>\<s>\<u>\<l>\<t>\<s> \<i>\<n> U \<t>\<h>\<r>\<o>\<w>\<s> E1 + E2"
  unfolding CurrentConstruction_def PendingConstruction_def bind_def subset_iff plus_fun_def
  apply clarsimp subgoal for s' s'' by (cases s'; simp; cases s''; simp add: ring_distribs; blast) .*)

(*
lemma \<phi>return_when_unreachable:
  \<open> \<p>\<e>\<n>\<d>\<i>\<n>\<g> f \<o>\<n> s [R] \<r>\<e>\<s>\<u>\<l>\<t>\<s> \<i>\<n> (\<lambda>_. T) \<t>\<h>\<r>\<o>\<w>\<s> E
\<Longrightarrow> \<p>\<e>\<n>\<d>\<i>\<n>\<g> (f \<ggreater> Return (\<phi>arg undefined)) \<o>\<n> s [R] \<r>\<e>\<s>\<u>\<l>\<t>\<s> \<i>\<n> (\<lambda>_. T) \<t>\<h>\<r>\<o>\<w>\<s> E\<close>
  for f :: \<open>unreachable proc\<close>
  unfolding CurrentConstruction_def PendingConstruction_def bind_def Return_def det_lift_def subset_iff
  apply clarsimp subgoal for s' s'' by (cases s'; simp; cases s''; simp add: ring_distribs; blast) .
*)
lemma \<phi>return_additional_unit:
  \<open> \<p>\<e>\<n>\<d>\<i>\<n>\<g> f \<o>\<n> s [R] \<r>\<e>\<s>\<u>\<l>\<t>\<s> \<i>\<n> T \<t>\<h>\<r>\<o>\<w>\<s> E
\<Longrightarrow> \<p>\<e>\<n>\<d>\<i>\<n>\<g> (f \<bind> (\<lambda>v. Return (\<phi>V_pair v \<phi>V_none))) \<o>\<n> s [R]
        \<r>\<e>\<s>\<u>\<l>\<t>\<s> \<i>\<n> (\<lambda>ret. T (\<phi>V_fst ret)) \<t>\<h>\<r>\<o>\<w>\<s> E\<close>
  unfolding CurrentConstruction_def PendingConstruction_def bind_def Return_def \<phi>V_pair_def
    \<phi>V_fst_def \<phi>V_snd_def det_lift_def subset_iff
  apply clarsimp subgoal for s' s'' by (cases s'; simp; cases s''; simp add: ring_distribs; blast) .

lemma \<phi>return:
  " \<c>\<u>\<r>\<r>\<e>\<n>\<t> s [R] \<r>\<e>\<s>\<u>\<l>\<t>\<s> \<i>\<n> T'
\<Longrightarrow> T' = T ret
\<Longrightarrow> \<p>\<e>\<n>\<d>\<i>\<n>\<g> (Return ret) \<o>\<n> s [R] \<r>\<e>\<s>\<u>\<l>\<t>\<s> \<i>\<n> T \<t>\<h>\<r>\<o>\<w>\<s> 0"
  unfolding CurrentConstruction_def PendingConstruction_def bind_def Return_def det_lift_def subset_iff
  by simp+

lemma \<phi>reassemble_proc_final:
  "(\<And>s H. \<c>\<u>\<r>\<r>\<e>\<n>\<t> s [H] \<r>\<e>\<s>\<u>\<l>\<t>\<s> \<i>\<n> S \<Longrightarrow> \<p>\<e>\<n>\<d>\<i>\<n>\<g> g \<o>\<n> s [H] \<r>\<e>\<s>\<u>\<l>\<t>\<s> \<i>\<n> T \<t>\<h>\<r>\<o>\<w>\<s> E)
\<Longrightarrow> \<p>\<r>\<o>\<c> g \<lbrace> S \<longmapsto> T \<rbrace> \<t>\<h>\<r>\<o>\<w>\<s> E"
  unfolding CurrentConstruction_def PendingConstruction_def \<phi>Procedure_def bind_def split_paired_all
  by blast

lemma "\<phi>__Return_rule__":
  \<open> X \<s>\<h>\<i>\<f>\<t>\<s> Y \<a>\<n>\<d> Any
\<Longrightarrow> \<p>\<r>\<o>\<c> Return \<phi>V_none \<lbrace> X \<longmapsto> \<lambda>_::unit \<phi>arg. Y \<rbrace>\<close>
  unfolding \<phi>Procedure_def Return_def View_Shift_def subset_iff det_lift_def
  by clarsimp

subsection \<open>Construct View Shift\<close>

lemma \<phi>make_view_shift:
  \<open> (\<And>s R. \<v>\<i>\<e>\<w> s [R] \<i>\<s> S \<Longrightarrow> (\<v>\<i>\<e>\<w> s [R] \<i>\<s> S' \<s>\<u>\<b>\<j> P))
\<Longrightarrow> S \<s>\<h>\<i>\<f>\<t>\<s> S' \<a>\<n>\<d> P\<close>
  unfolding CurrentConstruction_def View_Shift_def
  by (simp add: INTERP_SPEC_subj Subjection_expn)

subsection \<open>Construct Implication\<close>

lemma "\<phi>make_implication":
  \<open>(\<And>x. \<a>\<b>\<s>\<t>\<r>\<a>\<c>\<t>\<i>\<o>\<n>(x) \<i>\<s> S \<Longrightarrow> \<a>\<b>\<s>\<t>\<r>\<a>\<c>\<t>\<i>\<o>\<n>(x) \<i>\<s> T \<s>\<u>\<b>\<j> P) \<Longrightarrow> S \<i>\<m>\<p>\<l>\<i>\<e>\<s> T \<a>\<n>\<d> P\<close>
  unfolding Imply_def ToA_Construction_def
  by (simp add: Subjection_expn)

subsection \<open>Cast\<close>

lemma \<phi>apply_view_shift:
  " CurrentConstruction mode blk R S
\<Longrightarrow> S \<s>\<h>\<i>\<f>\<t>\<s> S' \<a>\<n>\<d> P
\<Longrightarrow> (CurrentConstruction mode blk R S') \<and> P"
  unfolding CurrentConstruction_def View_Shift_def
  by (simp_all add: split_paired_all \<phi>expns)

lemmas \<phi>apply_implication = \<phi>apply_view_shift[OF _ view_shift_by_implication]

lemma \<phi>apply_view_shift_pending:
  " PendingConstruction f blk H T E
\<Longrightarrow> (\<And>x. T x \<s>\<h>\<i>\<f>\<t>\<s> T' x \<a>\<n>\<d> P)
\<Longrightarrow> PendingConstruction f blk H T' E"
  unfolding PendingConstruction_def View_Shift_def
  by (clarsimp simp add: \<phi>expns LooseStateSpec_expn' subset_iff split_comp_All)

lemma \<phi>apply_view_shift_pending_E:
  " PendingConstruction f blk H T E
\<Longrightarrow> (\<And>x. E x \<s>\<h>\<i>\<f>\<t>\<s> E' x \<a>\<n>\<d> P)
\<Longrightarrow> PendingConstruction f blk H T E'"
  unfolding PendingConstruction_def View_Shift_def
  by (clarsimp simp add: \<phi>expns LooseStateSpec_expn' subset_iff split_comp_All)

lemmas \<phi>apply_implication_pending =
  \<phi>apply_view_shift_pending[OF _ view_shift_by_implication]

lemmas \<phi>apply_implication_pending_E =
  \<phi>apply_view_shift_pending_E[OF _ view_shift_by_implication]

lemma \<phi>ex_quantify_E:
  \<open> \<p>\<e>\<n>\<d>\<i>\<n>\<g> f \<o>\<n> blk [H] \<r>\<e>\<s>\<u>\<l>\<t>\<s> \<i>\<n> T \<t>\<h>\<r>\<o>\<w>\<s> (E ret)
\<Longrightarrow> \<p>\<e>\<n>\<d>\<i>\<n>\<g> f \<o>\<n> blk [H] \<r>\<e>\<s>\<u>\<l>\<t>\<s> \<i>\<n> T \<t>\<h>\<r>\<o>\<w>\<s> (\<lambda>e. ExSet (\<lambda>x. E x e))\<close>
  using \<phi>apply_implication_pending_E[OF _ ExSet_imp_I[OF implies_refl]] .

lemma \<phi>apply_implication_impl:
  \<open> \<a>\<b>\<s>\<t>\<r>\<a>\<c>\<t>\<i>\<o>\<n>(s) \<i>\<s> S
\<Longrightarrow> S \<i>\<m>\<p>\<l>\<i>\<e>\<s> S' \<a>\<n>\<d> P
\<Longrightarrow>(\<a>\<b>\<s>\<t>\<r>\<a>\<c>\<t>\<i>\<o>\<n>(s) \<i>\<s> S') \<and> P\<close>
  unfolding ToA_Construction_def Imply_def by blast

lemma "_\<phi>cast_internal_rule_":
  " CurrentConstruction mode blk H T
\<Longrightarrow> T \<i>\<m>\<p>\<l>\<i>\<e>\<s> T' \<a>\<n>\<d> Any @action ToSA
\<Longrightarrow> \<r>Success
\<Longrightarrow> \<o>\<b>\<l>\<i>\<g>\<a>\<t>\<i>\<o>\<n> True
\<Longrightarrow> CurrentConstruction mode blk H T'"
  unfolding Action_Tag_def
  using \<phi>apply_implication by blast

lemma "_\<phi>cast_internal_rule_'":
  " \<p>\<e>\<n>\<d>\<i>\<n>\<g> f \<o>\<n> blk [H] \<r>\<e>\<s>\<u>\<l>\<t>\<s> \<i>\<n> T \<t>\<h>\<r>\<o>\<w>\<s> E
\<Longrightarrow> (\<And>v. T v \<i>\<m>\<p>\<l>\<i>\<e>\<s> T' v \<a>\<n>\<d> Any @action ToSA)
\<Longrightarrow> \<r>Success
\<Longrightarrow> \<o>\<b>\<l>\<i>\<g>\<a>\<t>\<i>\<o>\<n> True
\<Longrightarrow> \<p>\<e>\<n>\<d>\<i>\<n>\<g> f \<o>\<n> blk [H] \<r>\<e>\<s>\<u>\<l>\<t>\<s> \<i>\<n> T' \<t>\<h>\<r>\<o>\<w>\<s> E"
  unfolding Action_Tag_def
  using \<phi>apply_implication_pending by blast

lemma "_\<phi>cast_exception_":
  " \<p>\<e>\<n>\<d>\<i>\<n>\<g> f \<o>\<n> blk [H] \<r>\<e>\<s>\<u>\<l>\<t>\<s> \<i>\<n> T \<t>\<h>\<r>\<o>\<w>\<s> E
\<Longrightarrow> (\<And>v. E v \<i>\<m>\<p>\<l>\<i>\<e>\<s> E' v @action ToSA)
\<Longrightarrow> \<p>\<e>\<n>\<d>\<i>\<n>\<g> f \<o>\<n> blk [H] \<r>\<e>\<s>\<u>\<l>\<t>\<s> \<i>\<n> T \<t>\<h>\<r>\<o>\<w>\<s> E'"
  unfolding Action_Tag_def
  using \<phi>apply_implication_pending_E by blast

lemma "_\<phi>cast_exception_rule_":
  " \<p>\<e>\<n>\<d>\<i>\<n>\<g> f \<o>\<n> blk [H] \<r>\<e>\<s>\<u>\<l>\<t>\<s> \<i>\<n> T \<t>\<h>\<r>\<o>\<w>\<s> E
\<Longrightarrow> (\<And>v. E v \<i>\<m>\<p>\<l>\<i>\<e>\<s> E' v @action ToSA)
\<Longrightarrow> \<r>Success
\<Longrightarrow> \<o>\<b>\<l>\<i>\<g>\<a>\<t>\<i>\<o>\<n> True
\<Longrightarrow> \<p>\<e>\<n>\<d>\<i>\<n>\<g> f \<o>\<n> blk [H] \<r>\<e>\<s>\<u>\<l>\<t>\<s> \<i>\<n> T \<t>\<h>\<r>\<o>\<w>\<s> E'"
  using "_\<phi>cast_exception_" .

lemma "_\<phi>cast_implication_":
  \<open> \<a>\<b>\<s>\<t>\<r>\<a>\<c>\<t>\<i>\<o>\<n>(x) \<i>\<s> S
\<Longrightarrow> S \<i>\<m>\<p>\<l>\<i>\<e>\<s> T \<a>\<n>\<d> Any @action ToSA
\<Longrightarrow> \<r>Success
\<Longrightarrow> \<o>\<b>\<l>\<i>\<g>\<a>\<t>\<i>\<o>\<n> True
\<Longrightarrow> \<a>\<b>\<s>\<t>\<r>\<a>\<c>\<t>\<i>\<o>\<n>(x) \<i>\<s> T\<close>
  unfolding ToA_Construction_def Action_Tag_def Imply_def by blast

subsection \<open>Finalization Rewrites\<close>

text \<open>Rules showing the obtained procedure is identical to the desired goal
  in the end of the construction.\<close>

ML \<open>structure Proc_Monad_SS = Simpset(
  val initial_ss = Simpset_Configure.Minimal_SS
  val binding = \<^binding>\<open>procedure_simps\<close>
  val comment = "declare the rules for simplifying procedure monad."
)\<close>

consts procedure_simplification :: mode

lemmas [procedure_simps] =
            proc_bind_SKIP proc_bind_SKIP'
            proc_bind_assoc proc_bind_return_none \<phi>V_simps

\<phi>reasoner_ML procedure_equivalence 1200 (\<open>Premise procedure_simplification ?P\<close>)
  = \<open>PLPR_Simplifier.simplifier_by_ss' NONE Proc_Monad_SS.get'\<close>

\<phi>reasoner_ML procedure_simplification 1000 (\<open>Simplify procedure_simplification ?x ?y\<close>)
  = \<open>PLPR_Simplifier.simplifier_by_ss' NONE Proc_Monad_SS.get'\<close>

subsection \<open>Misc\<close>

paragraph \<open>Inhabitance\<close>

lemma ToA_Construction_Inhabited_rule:
  \<open>\<a>\<b>\<s>\<t>\<r>\<a>\<c>\<t>\<i>\<o>\<n>(x) \<i>\<s> S \<Longrightarrow> (Inhabited S \<Longrightarrow> C) \<Longrightarrow> C\<close>
  unfolding ToA_Construction_def Inhabited_def by blast

lemma CurrentConstruction_Inhabited_rule:
  "CurrentConstruction mode s H T \<Longrightarrow> (Inhabited T \<Longrightarrow> C) \<Longrightarrow> C"
  using CurrentConstruction_D by blast

paragraph \<open>Fact Store\<close>

lemma [\<phi>programming_simps]:
  "CurrentConstruction mode s H (T \<s>\<u>\<b>\<j> P) \<longleftrightarrow> (CurrentConstruction mode s H T) \<and> P"
  unfolding CurrentConstruction_def by (simp_all add: \<phi>expns split_paired_all)

lemma [\<phi>programming_simps]:
  "(CurrentConstruction mode s H T \<and> B) \<and> C \<longleftrightarrow> (CurrentConstruction mode s H T) \<and> (B \<and> C)"
  by simp

lemma [\<phi>programming_simps]:
  \<open>(\<a>\<b>\<s>\<t>\<r>\<a>\<c>\<t>\<i>\<o>\<n>(x) \<i>\<s> T \<s>\<u>\<b>\<j> P) \<longleftrightarrow> (\<a>\<b>\<s>\<t>\<r>\<a>\<c>\<t>\<i>\<o>\<n>(x) \<i>\<s> T) \<and> P\<close>
  unfolding ToA_Construction_def by (simp add: Subjection_expn)

lemma [\<phi>programming_simps]:
  \<open>((\<a>\<b>\<s>\<t>\<r>\<a>\<c>\<t>\<i>\<o>\<n>(x) \<i>\<s> T) \<and> B) \<and> C \<longleftrightarrow> (\<a>\<b>\<s>\<t>\<r>\<a>\<c>\<t>\<i>\<o>\<n>(x) \<i>\<s> T) \<and> (B \<and> C)\<close>
  by simp

paragraph \<open>Fixing Existentially Quantified Variable\<close>

lemma \<phi>ExTyp_strip:
  "(CurrentConstruction mode p H (ExSet T)) \<equiv> (\<exists>c. CurrentConstruction mode p H (T c))"
  unfolding CurrentConstruction_def atomize_eq by (simp_all add: \<phi>expns split_paired_all)

lemma \<phi>ExTyp_strip_imp:
  \<open>ToA_Construction s (ExSet T) \<equiv> (\<exists>c. ToA_Construction s (T c))\<close>
  unfolding ToA_Construction_def by (simp add: \<phi>expns)

paragraph \<open>Introducing Existential Quantification\<close>

lemma introduce_Ex:
  \<open>CurrentConstruction mode blk H (S x) \<Longrightarrow> CurrentConstruction mode blk H (ExSet S)\<close>
  using \<phi>apply_implication[OF _ ExSet_imp_I[OF implies_refl], THEN conjunct1] .

lemma introduce_Ex_subj:
  \<open>CurrentConstruction mode blk H (S x \<s>\<u>\<b>\<j> Q) \<Longrightarrow> CurrentConstruction mode blk H (ExSet S \<s>\<u>\<b>\<j> Q)\<close>
  by (metis Subjection_True Subjection_cong introduce_Ex)

lemma introduce_Ex_pending:
  \<open> \<p>\<e>\<n>\<d>\<i>\<n>\<g> f \<o>\<n> blk [H] \<r>\<e>\<s>\<u>\<l>\<t>\<s> \<i>\<n> (\<lambda>v. Q x v) \<t>\<h>\<r>\<o>\<w>\<s> E
\<Longrightarrow> \<p>\<e>\<n>\<d>\<i>\<n>\<g> f \<o>\<n> blk [H] \<r>\<e>\<s>\<u>\<l>\<t>\<s> \<i>\<n> (\<lambda>v. \<exists>*x. Q x v) \<t>\<h>\<r>\<o>\<w>\<s> E\<close>
  using \<phi>apply_implication_pending[OF _ ExSet_imp_I[OF implies_refl]] .

lemma introduce_Ex_pending_E:
  \<open> \<p>\<e>\<n>\<d>\<i>\<n>\<g> f \<o>\<n> blk [H] \<r>\<e>\<s>\<u>\<l>\<t>\<s> \<i>\<n> Q \<t>\<h>\<r>\<o>\<w>\<s> (\<lambda>v. E x v)
\<Longrightarrow> \<p>\<e>\<n>\<d>\<i>\<n>\<g> f \<o>\<n> blk [H] \<r>\<e>\<s>\<u>\<l>\<t>\<s> \<i>\<n> Q \<t>\<h>\<r>\<o>\<w>\<s> (\<lambda>v. \<exists>*x. E x v)\<close>
  using \<phi>apply_implication_pending_E[OF _ ExSet_imp_I[OF implies_refl]] .

lemma introduce_Ex_ToA:
  \<open> ToA_Construction s (S x)
\<Longrightarrow> ToA_Construction s (ExSet S) \<close>
  using \<phi>ExTyp_strip_imp by fastforce

lemma introduce_Ex_ToA_subj:
  \<open> ToA_Construction s (S x \<s>\<u>\<b>\<j> Q)
\<Longrightarrow> ToA_Construction s (ExSet S \<s>\<u>\<b>\<j> Q) \<close>
  by (metis Subjection_Flase Subjection_True introduce_Ex_ToA)

paragraph \<open>Return\<close>

lemma \<phi>M_Success[intro!]:
  \<open> v \<in> (y \<Ztypecolon> T)
\<Longrightarrow> \<p>\<r>\<o>\<c> Return (\<phi>arg v) \<lbrace> X \<longmapsto> \<lambda>u. X\<heavy_comma> y \<Ztypecolon> Val u T \<rbrace> \<t>\<h>\<r>\<o>\<w>\<s> Any \<close>
  unfolding \<phi>Procedure_def det_lift_def Return_def
  by (clarsimp simp add: \<phi>expns)

declare \<phi>M_Success[where X=1, simplified, intro!]

lemma \<phi>M_Success'[intro!]:
  \<open> \<p>\<r>\<o>\<c> Return vs \<lbrace> X vs \<longmapsto> X \<rbrace> \<t>\<h>\<r>\<o>\<w>\<s> Any \<close>
  unfolding Return_def \<phi>Procedure_def det_lift_def by (clarsimp simp add: \<phi>expns)

end


theory LiarsStreet  (*Christoph Benzmüller, 2020*)
  imports Main

abbrevs
 Nilda="\<^bold>N\<^bold>i\<^bold>l\<^bold>d\<^bold>a" and Nilda="\<^bold>C\<^bold>a\<^bold>r\<^bold>l\<^bold>a" and And="( \<^bold>a\<^bold>n\<^bold>d )" and Or="( \<^bold>o\<^bold>r )" and Not="(\<^bold>n\<^bold>o\<^bold>t )" and If_then="(\<^bold>I\<^bold>f \<^bold>t\<^bold>h\<^bold>e\<^bold>n )"
 and LiarsStreet="\<^bold>L\<^bold>i\<^bold>a\<^bold>r\<^bold>s\<^bold>S\<^bold>t\<^bold>r\<^bold>e\<^bold>e\<^bold>t" and TruthtellersRoad="\<^bold>T\<^bold>r\<^bold>u\<^bold>t\<^bold>h\<^bold>t\<^bold>e\<^bold>l\<^bold>l\<^bold>e\<^bold>r\<^bold>s\<^bold>R\<^bold>o\<^bold>a\<^bold>d" and Lies="\<^bold>(l\<^bold>i\<^bold>e\<^bold>s )"
 and Says_the_truth="(\<^bold>s\<^bold>a\<^bold>y\<^bold>s\<^bold>-\<^bold>t\<^bold>h\<^bold>e\<^bold>-\<^bold>t\<^bold>r\<^bold>u\<^bold>t\<^bold>h )" and Lives_not_in="( \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>s\<^bold>-\<^bold>n\<^bold>o\<^bold>t\<^bold>-\<^bold>i\<^bold>n )"
 and Neither_nor_live_in="\<^bold>(n\<^bold>e\<^bold>i\<^bold>t\<^bold>h\<^bold>e\<^bold>r  \<^bold>n\<^bold>o\<^bold>r  \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>-\<^bold>i\<^bold>n )" and Both_live_in="\<^bold>(b\<^bold>o\<^bold>t\<^bold>h  \<^bold>a\<^bold>n\<^bold>d  \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>-\<^bold>i\<^bold>n )"

begin
(*unimportant*) nitpick_params [user_axioms,format=2,show_all]
(*unimportant*) declare [[show_abbrevs=false]]

(***********************************************************************************
 ******************  Some Basic Types of our Ontology ******************************
 ***********************************************************************************)

(* There are some kids, could be many more *)
datatype Entity = Nilda ("\<^bold>N\<^bold>i\<^bold>l\<^bold>d\<^bold>a") | Carla  ("\<^bold>C\<^bold>a\<^bold>r\<^bold>l\<^bold>a")

lemma "\<not>(\<^bold>N\<^bold>i\<^bold>l\<^bold>d\<^bold>a = \<^bold>C\<^bold>a\<^bold>r\<^bold>l\<^bold>a)" sledgehammer by simp

(* There are some roads, could be many more *)
datatype Street = LiarsStreet ("\<^bold>L\<^bold>i\<^bold>a\<^bold>r\<^bold>s\<^bold>S\<^bold>t\<^bold>r\<^bold>e\<^bold>e\<^bold>t") | TruthtellersRoad ("\<^bold>T\<^bold>r\<^bold>u\<^bold>t\<^bold>h\<^bold>t\<^bold>e\<^bold>l\<^bold>l\<^bold>e\<^bold>r\<^bold>s\<^bold>R\<^bold>o\<^bold>a\<^bold>d")

(***********************************************************************************
 ******************  Controlled Natural Language Library ***************************
 ******************  Logic and Modalities ******************************************
 ***********************************************************************************)

definition And ("_ \<^bold>a\<^bold>n\<^bold>d _") where "X \<^bold>a\<^bold>n\<^bold>d Y \<equiv> X \<and> Y"
abbreviation Or ("_ \<^bold>o\<^bold>r _") where "X \<^bold>o\<^bold>r Y \<equiv> X \<or> Y"
definition Not ("\<^bold>n\<^bold>o\<^bold>t _") where "\<^bold>n\<^bold>o\<^bold>t X \<equiv> \<not>X"
definition If_then ("\<^bold>I\<^bold>f _ \<^bold>t\<^bold>h\<^bold>e\<^bold>n _") where "\<^bold>I\<^bold>f X \<^bold>t\<^bold>h\<^bold>e\<^bold>n Y \<equiv> X \<longrightarrow> Y"

(* "Says" "Knows" "Belief" "Obligation", etc. as uninterpreted truth-functions
   --- which, of course, will lead to known paradoxes *)
consts  Says::"Entity\<Rightarrow>bool\<Rightarrow>bool"  ("_ \<^bold>s\<^bold>a\<^bold>y\<^bold>s _")
consts  Knows::"Entity\<Rightarrow>bool\<Rightarrow>bool"  ("_ \<^bold>k\<^bold>n\<^bold>o\<^bold>w\<^bold>s _")
consts  Believes::"Entity\<Rightarrow>bool\<Rightarrow>bool"  ("_ \<^bold>b\<^bold>e\<^bold>l\<^bold>i\<^bold>e\<^bold>v\<^bold>e\<^bold>s _")
consts  Obligation::"Entity\<Rightarrow>bool\<Rightarrow>bool"  ("_ \<^bold>m\<^bold>u\<^bold>s\<^bold>t\<^bold>-\<^bold>d\<^bold>o _")

(* We can introduce some further derived modal NL phrases *)
definition Lies ("\<^bold>l\<^bold>i\<^bold>e\<^bold>s _") where "\<^bold>l\<^bold>i\<^bold>e\<^bold>s X \<equiv> \<forall>Y. \<^bold>I\<^bold>f (X \<^bold>s\<^bold>a\<^bold>y\<^bold>s Y) \<^bold>t\<^bold>h\<^bold>e\<^bold>n \<^bold>n\<^bold>o\<^bold>t Y"
definition Says_the_truth ("\<^bold>s\<^bold>a\<^bold>y\<^bold>s\<^bold>-\<^bold>t\<^bold>h\<^bold>e\<^bold>-\<^bold>t\<^bold>r\<^bold>u\<^bold>t\<^bold>h _")
  where "\<^bold>s\<^bold>a\<^bold>y\<^bold>s\<^bold>-\<^bold>t\<^bold>h\<^bold>e\<^bold>-\<^bold>t\<^bold>r\<^bold>u\<^bold>t\<^bold>h X \<equiv> \<forall>Y. \<^bold>I\<^bold>f (X \<^bold>s\<^bold>a\<^bold>y\<^bold>s Y) \<^bold>t\<^bold>h\<^bold>e\<^bold>n Y"

(* We add the above defintions to our "bag" called "Defs" — Unimportant *)
named_theorems Defs
declare Lies_def [Defs] Says_the_truth_def [Defs]

(***********************************************************************************
 ****************** Controlled Natural Language Library ****************************
 ****************** Domain specific concepts ***************************************
 ***********************************************************************************)

(* Uninterpreted predicate: Lives_in *)
consts Lives_in::"Entity\<Rightarrow>Street\<Rightarrow>bool" ("_ \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>s\<^bold>-\<^bold>i\<^bold>n _")

(* Further derived NL phrases that concern "Lives_in" *)
definition Lives_not_in ("_ \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>s\<^bold>-\<^bold>n\<^bold>o\<^bold>t\<^bold>-\<^bold>i\<^bold>n _")
  where "X \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>s\<^bold>-\<^bold>n\<^bold>o\<^bold>t\<^bold>-\<^bold>i\<^bold>n G \<equiv> \<^bold>n\<^bold>o\<^bold>t (X \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>s\<^bold>-\<^bold>i\<^bold>n G)"
definition Neither_nor_live_in ("\<^bold>n\<^bold>e\<^bold>i\<^bold>t\<^bold>h\<^bold>e\<^bold>r _ \<^bold>n\<^bold>o\<^bold>r _ \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>-\<^bold>i\<^bold>n _")
  where "\<^bold>n\<^bold>e\<^bold>i\<^bold>t\<^bold>h\<^bold>e\<^bold>r X \<^bold>n\<^bold>o\<^bold>r Y \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>-\<^bold>i\<^bold>n G \<equiv> (\<^bold>n\<^bold>o\<^bold>t (X \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>s\<^bold>-\<^bold>i\<^bold>n G)) \<^bold>a\<^bold>n\<^bold>d (\<^bold>n\<^bold>o\<^bold>t (Y \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>s\<^bold>-\<^bold>i\<^bold>n G))"
definition Both_live_in ("\<^bold>b\<^bold>o\<^bold>t\<^bold>h _ \<^bold>a\<^bold>n\<^bold>d _ \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>-\<^bold>i\<^bold>n _")
  where "\<^bold>b\<^bold>o\<^bold>t\<^bold>h X \<^bold>a\<^bold>n\<^bold>d Y \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>-\<^bold>i\<^bold>n G \<equiv> (X \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>s\<^bold>-\<^bold>i\<^bold>n G) \<^bold>a\<^bold>n\<^bold>d (Y \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>s\<^bold>-\<^bold>i\<^bold>n G)"

(* We add the above defintions to our "bag" called "Defs" — Unimportant *)
declare Lives_not_in_def [Defs] Neither_nor_live_in_def [Defs] Both_live_in_def [Defs]

(***********************************************************************************
 ****************** Example Queries ************************************************
 ***********************************************************************************)

axiomatization where
A1:  "\<forall>X. \<^bold>I\<^bold>f (X \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>s\<^bold>-\<^bold>i\<^bold>n \<^bold>L\<^bold>i\<^bold>a\<^bold>r\<^bold>s\<^bold>S\<^bold>t\<^bold>r\<^bold>e\<^bold>e\<^bold>t) \<^bold>t\<^bold>h\<^bold>e\<^bold>n (\<^bold>l\<^bold>i\<^bold>e\<^bold>s X)"  and
A2:  "\<forall>X. \<^bold>I\<^bold>f (X \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>s\<^bold>-\<^bold>i\<^bold>n \<^bold>T\<^bold>r\<^bold>u\<^bold>t\<^bold>h\<^bold>t\<^bold>e\<^bold>l\<^bold>l\<^bold>e\<^bold>r\<^bold>s\<^bold>R\<^bold>o\<^bold>a\<^bold>d) \<^bold>t\<^bold>h\<^bold>e\<^bold>n (\<^bold>s\<^bold>a\<^bold>y\<^bold>s\<^bold>-\<^bold>t\<^bold>h\<^bold>e\<^bold>-\<^bold>t\<^bold>r\<^bold>u\<^bold>t\<^bold>h X)"

lemma Question1:
  assumes
   "\<^bold>N\<^bold>i\<^bold>l\<^bold>d\<^bold>a \<^bold>s\<^bold>a\<^bold>y\<^bold>s (\<^bold>C\<^bold>a\<^bold>r\<^bold>l\<^bold>a \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>s\<^bold>-\<^bold>i\<^bold>n \<^bold>T\<^bold>r\<^bold>u\<^bold>t\<^bold>h\<^bold>t\<^bold>e\<^bold>l\<^bold>l\<^bold>e\<^bold>r\<^bold>s\<^bold>R\<^bold>o\<^bold>a\<^bold>d)"
   "\<^bold>C\<^bold>a\<^bold>r\<^bold>l\<^bold>a \<^bold>s\<^bold>a\<^bold>y\<^bold>s (\<^bold>N\<^bold>i\<^bold>l\<^bold>d\<^bold>a \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>s\<^bold>-\<^bold>i\<^bold>n \<^bold>T\<^bold>r\<^bold>u\<^bold>t\<^bold>h\<^bold>t\<^bold>e\<^bold>l\<^bold>l\<^bold>e\<^bold>r\<^bold>s\<^bold>R\<^bold>o\<^bold>a\<^bold>d)"
  shows
   "((\<^bold>N\<^bold>i\<^bold>l\<^bold>d\<^bold>a \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>s\<^bold>-\<^bold>i\<^bold>n S1) \<^bold>a\<^bold>n\<^bold>d (\<^bold>C\<^bold>a\<^bold>r\<^bold>l\<^bold>a \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>s\<^bold>-\<^bold>i\<^bold>n S2))"
  nitpick[satisfy] oops

lemma Question1b:
  assumes
   "\<^bold>N\<^bold>i\<^bold>l\<^bold>d\<^bold>a \<^bold>s\<^bold>a\<^bold>y\<^bold>s (\<^bold>C\<^bold>a\<^bold>r\<^bold>l\<^bold>a \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>s\<^bold>-\<^bold>i\<^bold>n \<^bold>T\<^bold>r\<^bold>u\<^bold>t\<^bold>h\<^bold>t\<^bold>e\<^bold>l\<^bold>l\<^bold>e\<^bold>r\<^bold>s\<^bold>R\<^bold>o\<^bold>a\<^bold>d)"
   "\<^bold>C\<^bold>a\<^bold>r\<^bold>l\<^bold>a \<^bold>s\<^bold>a\<^bold>y\<^bold>s (\<^bold>N\<^bold>i\<^bold>l\<^bold>d\<^bold>a \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>s\<^bold>-\<^bold>i\<^bold>n \<^bold>T\<^bold>r\<^bold>u\<^bold>t\<^bold>h\<^bold>t\<^bold>e\<^bold>l\<^bold>l\<^bold>e\<^bold>r\<^bold>s\<^bold>R\<^bold>o\<^bold>a\<^bold>d)"
  shows
   "((\<^bold>N\<^bold>i\<^bold>l\<^bold>d\<^bold>a \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>s\<^bold>-\<^bold>i\<^bold>n \<^bold>L\<^bold>i\<^bold>a\<^bold>r\<^bold>s\<^bold>S\<^bold>t\<^bold>r\<^bold>e\<^bold>e\<^bold>t) \<^bold>a\<^bold>n\<^bold>d (\<^bold>C\<^bold>a\<^bold>r\<^bold>l\<^bold>a \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>s\<^bold>-\<^bold>i\<^bold>n S2))"
  nitpick[satisfy] oops

lemma Question2:
  assumes
   "\<^bold>N\<^bold>i\<^bold>l\<^bold>d\<^bold>a \<^bold>s\<^bold>a\<^bold>y\<^bold>s (\<^bold>C\<^bold>a\<^bold>r\<^bold>l\<^bold>a \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>s\<^bold>-\<^bold>i\<^bold>n \<^bold>L\<^bold>i\<^bold>a\<^bold>r\<^bold>s\<^bold>S\<^bold>t\<^bold>r\<^bold>e\<^bold>e\<^bold>t)"
   "\<^bold>C\<^bold>a\<^bold>r\<^bold>l\<^bold>a \<^bold>s\<^bold>a\<^bold>y\<^bold>s (\<^bold>n\<^bold>e\<^bold>i\<^bold>t\<^bold>h\<^bold>e\<^bold>r \<^bold>N\<^bold>i\<^bold>l\<^bold>d\<^bold>a \<^bold>n\<^bold>o\<^bold>r \<^bold>C\<^bold>a\<^bold>r\<^bold>l\<^bold>a \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>-\<^bold>i\<^bold>n \<^bold>L\<^bold>i\<^bold>a\<^bold>r\<^bold>s\<^bold>S\<^bold>t\<^bold>r\<^bold>e\<^bold>e\<^bold>t)"
  shows
   "((\<^bold>N\<^bold>i\<^bold>l\<^bold>d\<^bold>a \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>s\<^bold>-\<^bold>i\<^bold>n S1) \<^bold>a\<^bold>n\<^bold>d (\<^bold>C\<^bold>a\<^bold>r\<^bold>l\<^bold>a \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>s\<^bold>-\<^bold>i\<^bold>n S2))"
  nitpick[satisfy] oops

lemma Question3:
  assumes
   "\<^bold>N\<^bold>i\<^bold>l\<^bold>d\<^bold>a \<^bold>s\<^bold>a\<^bold>y\<^bold>s (\<^bold>C\<^bold>a\<^bold>r\<^bold>l\<^bold>a \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>s\<^bold>-\<^bold>i\<^bold>n \<^bold>L\<^bold>i\<^bold>a\<^bold>r\<^bold>s\<^bold>S\<^bold>t\<^bold>r\<^bold>e\<^bold>e\<^bold>t)"
   "\<^bold>C\<^bold>a\<^bold>r\<^bold>l\<^bold>a \<^bold>s\<^bold>a\<^bold>y\<^bold>s (\<^bold>C\<^bold>a\<^bold>r\<^bold>l\<^bold>a \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>s\<^bold>-\<^bold>i\<^bold>n \<^bold>L\<^bold>i\<^bold>a\<^bold>r\<^bold>s\<^bold>S\<^bold>t\<^bold>r\<^bold>e\<^bold>e\<^bold>t)"
 shows
   "((\<^bold>N\<^bold>i\<^bold>l\<^bold>d\<^bold>a \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>s\<^bold>-\<^bold>i\<^bold>n S1) \<^bold>a\<^bold>n\<^bold>d (\<^bold>C\<^bold>a\<^bold>r\<^bold>l\<^bold>a \<^bold>l\<^bold>i\<^bold>v\<^bold>e\<^bold>s\<^bold>-\<^bold>i\<^bold>n S2))"
  nitpick[satisfy] oops

(*** Do we run into Paradoxes with the modelling of modalities? ***)

consts It_holds_that_One_plus_One_Equals_Two::bool
       It_holds_that_Fermats_last_Theorem_is_True::bool

lemma Question8:
  assumes
   "It_holds_that_One_plus_One_Equals_Two"
   "It_holds_that_Fermats_last_Theorem_is_True"
   "\<^bold>C\<^bold>a\<^bold>r\<^bold>l\<^bold>a \<^bold>s\<^bold>a\<^bold>y\<^bold>s It_holds_that_One_plus_One_Equals_Two"
  shows
   "\<^bold>C\<^bold>a\<^bold>r\<^bold>l\<^bold>a \<^bold>s\<^bold>a\<^bold>y\<^bold>s It_holds_that_Fermats_last_Theorem_is_True"
  using assms(1) assms(2) assms(3) by auto

lemma Question9:
  assumes
   "It_holds_that_One_plus_One_Equals_Two"
   "It_holds_that_Fermats_last_Theorem_is_True"
   "\<^bold>C\<^bold>a\<^bold>r\<^bold>l\<^bold>a \<^bold>k\<^bold>n\<^bold>o\<^bold>w\<^bold>s It_holds_that_One_plus_One_Equals_Two"
  shows
   "\<^bold>C\<^bold>a\<^bold>r\<^bold>l\<^bold>a \<^bold>k\<^bold>n\<^bold>o\<^bold>w\<^bold>s It_holds_that_Fermats_last_Theorem_is_True"
  sledgehammer [verbose](assms)
  nitpick oops

end


theory Semantics
imports Model
begin
typedecl binop
axiomatization apply_binop :: "binop \<Rightarrow> val \<Rightarrow> val \<Rightarrow> val"
  and plus minus :: binop
typedecl unop
axiomatization apply_unop :: "unop \<Rightarrow> val \<Rightarrow> val"
datatype condition = Eq | Neq | Leq | Le | Geq | Gr

fun eval_cond_aux :: "val \<Rightarrow> val \<Rightarrow> (byte \<Rightarrow> byte \<Rightarrow> bool) \<Rightarrow> bool \<Rightarrow> bool" where
  "eval_cond_aux [] [] _ b = b"
| "eval_cond_aux [] _ _ _ = undefined"
| "eval_cond_aux _ [] _ _ = undefined"
| "eval_cond_aux (v1#xs) (v2#ys) c b = (if v1=v2 then eval_cond_aux xs ys c b
    else c v1 v2)"

fun eval_cond :: "condition \<Rightarrow> val \<Rightarrow> val \<Rightarrow> bool" where
  "eval_cond Eq v1 v2 = (v1=v2)"
| "eval_cond Neq v1 v2 = (v1\<noteq>v2)"
| "eval_cond Leq v1 v2 = eval_cond_aux v1 v2 (\<le>) True"
| "eval_cond Le v1 v2 = eval_cond_aux v1 v2 (<) False"
| "eval_cond Geq v1 v2 = eval_cond_aux v1 v2 (\<ge>) True"
| "eval_cond Gr v1 v2 = eval_cond_aux v1 v2 (>) False"

type_synonym func = "string \<times> var list"

datatype command =
  AssignConst var val
| AssignVar var var
| Load var var
| Store var var
| Malloc var var
| Free var
| BinOp binop var var var
| UnOp unop var var
| PtrPlus var var var
| PtrSub var var var
| Memcpy (dest: var) (source: var) (number: var)
| Assume condition var var
| Assert condition var var
| Call "func" "var list"

subsection \<open>CFG\<close>

typedecl CFG_node
axiomatization entry :: CFG_node and exit :: CFG_node

type_synonym edge = "CFG_node \<times> command \<times> CFG_node"
type_synonym cfg = "func \<times> edge set"
type_synonym prog = "string \<rightharpoonup> cfg"

abbreviation can_allocate_from :: "blocks \<Rightarrow> loc \<Rightarrow> blockname \<Rightarrow> val \<Rightarrow> bool" where
  "can_allocate_from B l n z \<equiv>
    0<l \<and> \<comment> \<open>The location is not at null.\<close>
    l < l + (loc64_ops.from_val z) \<and> \<comment> \<open>The allocated block does not wrap around.\<close>
    \<comment> \<open>It doesn't overlap with any other block.\<close>
    (\<forall>b\<in>set (raw_blocks B). \<not>(overlaps_with (n,l,l + (loc64_ops.from_val z)) b)) \<and>
    (\<forall>b\<in>set (raw_blocks B). (case b of (n',_,_) \<Rightarrow> n'\<noteq>n)) \<comment> \<open>The name is new and unique\<close>"

text \<open>Given a control flow graph as a map from function names to their body graphs,
  relate the semantics of the program. The program implicitly starts at ''main''.\<close>
context fixes funs :: "string \<Rightarrow> cfg option" begin
inductive semantics :: "pre_config \<Rightarrow> command \<Rightarrow> pre_config option \<Rightarrow> bool"
  and fun_semantics :: "string \<Rightarrow> pre_config \<Rightarrow> pre_config \<Rightarrow> bool"
  and cfg_reachable :: "edge set \<Rightarrow> CFG_node \<Rightarrow> CFG_node \<Rightarrow> pre_config \<Rightarrow> pre_config \<Rightarrow> bool" where  SingleStep: "\<lbrakk>\<exists>cmd. (from,cmd,to) \<in> es; semantics pre cmd (Some post)\<rbrakk> \<Longrightarrow> cfg_reachable es from to pre post"
| MultiStep: "\<lbrakk>\<exists>cmd. (from,cmd,to') \<in> es; semantics pre cmd (Some interm);
  cfg_reachable es to' to interm post\<rbrakk> \<Longrightarrow> cfg_reachable es from to pre post"
| "\<lbrakk>(funs f) = Some cfg; cfg_reachable (snd cfg) entry exit pre post\<rbrakk> \<Longrightarrow> fun_semantics f pre post"
|  "fits k x \<Longrightarrow> semantics (S,B,M) (AssignConst x k) (Some (update_stack S x k,B,M))"
| "size x = size y \<Longrightarrow> semantics (S,B,M) (AssignVar x y) (Some (update_stack S x (lookup S y),B,M))"
| LoadFail:
  "\<comment> \<open>y does not point into any block, i.e. is an invalid location\<close>
  base B (loc64_ops.from_val (lookup S y)) = 0 \<or>
  \<comment> \<open>This load would read past the end of the block.\<close>
  ((loc64_ops.from_val (lookup S y)) + (sizev x) > ende B (loc64_ops.from_val (lookup S y)) \<or>
  \<comment> \<open>This would read past the maximum location and wrap around.\<close>
  (loc64_ops.from_val (lookup S y)) + (sizev x) \<le> (loc64_ops.from_val (lookup S y))) \<Longrightarrow>
     semantics (S,B,M) (Load x y) None"
| LoadSuccess: "\<lbrakk>\<not>(base B (loc64_ops.from_val (lookup S y)) = 0 \<or>
  ((loc64_ops.from_val (lookup S y)) + (sizev x) > ende B (loc64_ops.from_val (lookup S y)) \<or>
  (loc64_ops.from_val (lookup S y)) + (sizev x) \<le> (loc64_ops.from_val (lookup S y))));
  \<comment> \<open>The addressed memory cells are actually allocated.\<close>
  access M (loc64_ops.from_val (lookup S y)) (size x) = Some v\<rbrakk> \<Longrightarrow>
    semantics (S,B,M) (Load x y) (Some (update_stack S x v, B, M))"
| StoreFail:
  "\<comment> \<open>x does not point into any block, i.e. is an invalid location\<close>
  base B (loc64_ops.from_val (lookup S x)) = 0 \<or>
  \<comment> \<open>This store woudl write past the end of the block.\<close>
  ((loc64_ops.from_val (lookup S x)) + (sizev y) > ende B (loc64_ops.from_val (lookup S x)) \<or>
  \<comment> \<open>This would write past the maximum location and wrap around.\<close>
  (loc64_ops.from_val (lookup S x)) + (sizev y) \<le> (loc64_ops.from_val (lookup S x))) \<Longrightarrow>
    semantics (S,B,M) (Store x y) None"
| StoreSuccess: "\<not>(base B (loc64_ops.from_val (lookup S x)) = 0 \<or>
  ((loc64_ops.from_val (lookup S x)) + (sizev y) > ende B (loc64_ops.from_val (lookup S x)) \<or>
  (loc64_ops.from_val (lookup S x)) + (sizev y) \<le> (loc64_ops.from_val (lookup S x)))) \<Longrightarrow>
    semantics (S,B,M) (Store x y) (Some (S, B, update_memory M (loc64_ops.from_val (lookup S x)) (lookup S y)))"
| MallocError: "
  \<comment> \<open>If we would allocate 0 bytes or x can't hold a pointer.\<close>
  (\<forall>v\<in>set (lookup S z). v = 0) \<or> (size x \<noteq> loc_N_B) \<Longrightarrow>
  semantics (S,_,_) (Malloc x z) None"
| MallocSuccessNull: "\<lbrakk>\<exists>v\<in>set (lookup S z). v \<noteq> 0; size x = loc_N_B\<rbrakk> \<Longrightarrow>
  semantics (S,B,M) (Malloc x z) (Some (update_stack S x (null x),B,M))"
| MallocSuccess: "\<lbrakk>\<exists>v\<in>set (lookup S z). v \<noteq> 0; size x = loc_N_B;
  \<comment> \<open>l and n are new, k is arbitrary\<close>
  can_allocate_from B l n (lookup S z); length k = length (lookup S z)\<rbrakk> \<Longrightarrow>
  semantics (S,B,M) (Malloc x z)
    (Some (update_stack S  x (loc64_ops.to_val l),
    Blocks ((n,l,l+(loc64_ops.from_val (lookup S z)))#raw_blocks B),
    update_memory M l k))"
| FreeError: "loc64_ops.from_val (lookup S x) \<noteq> base B (loc64_ops.from_val (lookup S x))
  \<Longrightarrow> semantics (S,B,_) (Free x) None"
| FreeSuccess: "\<lbrakk>loc64_ops.from_val (lookup S x) = y; y = base B y\<rbrakk>
  \<Longrightarrow> semantics (S,B,M) (Free x) (Some (S,free_block B y, free_memory M y (ende B y)))"
| "semantics (S,B,M) (BinOp b x y z)
  (Some (update_stack S x (apply_binop b (lookup S y) (lookup S z)),B,M))"
| "semantics (S,B,M) (UnOp u x y)
  (Some (update_stack S x (apply_unop u (lookup S y)),B,M))"
| PtrPlusError: "\<lbrakk>y'=loc64_ops.from_val (lookup S y); z'=loc64_ops.from_val (lookup S z);
  (\<forall>v\<in>set (lookup S y). v = 0) \<or> (y' + z' < base B y') \<or> (y' + z' > ende B y')\<rbrakk>
  \<Longrightarrow> semantics (S,B,M) (PtrPlus _ y z) None"
| PtrPlusSuccess: "\<lbrakk>y'=loc64_ops.from_val (lookup S y); z'=loc64_ops.from_val (lookup S z);
  \<exists>v\<in>set (lookup S y). v \<noteq> 0; y' + z' \<ge> base B y'; y' + z' \<le> ende B y'\<rbrakk>
  \<Longrightarrow> semantics (S,B,M) (PtrPlus x y z) (Some (update_stack S x (loc64_ops.to_val (y'+z')),B,M))"
| PtrSubError: "\<lbrakk>y'=loc64_ops.from_val (lookup S y); z'=loc64_ops.from_val (lookup S z);
  (\<forall>v\<in>set (lookup S y). v = 0) \<or> (from_block y' B \<noteq> from_block z' B)\<rbrakk>
  \<Longrightarrow> semantics (S,B,M) (PtrSub _ y z) None"
| PtrSubSuccess: "\<lbrakk>y'=loc64_ops.from_val (lookup S y); z'=loc64_ops.from_val (lookup S z);
  \<exists>v\<in>set (lookup S y). v \<noteq> 0; from_block y' B = from_block z' B\<rbrakk>
  \<Longrightarrow> semantics (S,B,M) (PtrSub x y z) (Some (update_stack S x (loc64_ops.to_val (y'-z')),B,M))"
| MemcpyError: "\<lbrakk>y'=loc64_ops.from_val (lookup S y); z'=loc64_ops.from_val (lookup S z);
  x'=loc64_ops.from_val (lookup S x);
  \<comment> \<open>x or y do not point into any block, i.e. is an invalid location\<close>
  from_block x' B = None \<or> from_block y' B = None \<or>
  \<comment> \<open>The size is too big, i.e. we would read/write out of bounds\<close>
  x'+z' > ende B x' \<or> y'+z' > ende B y' \<or>
  \<comment> \<open>The two memory portions (pointer+size) overlap\<close>
  intv (x'+z') (bounds (raw_blocks B) y') \<or> intv (y'+z') (bounds (raw_blocks B) x')\<rbrakk>
  \<Longrightarrow> semantics (S,B,M) (Memcpy x y z) None"
| MemcpySuccess: "\<lbrakk>y'=loc64_ops.from_val (lookup S y); z'=loc64_ops.from_val (lookup S z);
  from_block x' B \<noteq> None; from_block y' B \<noteq> None; x'+z' \<le> ende B x'; y'+z' \<le> ende B y';
  \<not>(intv (x'+z') (bounds (raw_blocks B) y')); \<not>(intv (y'+z') (bounds (raw_blocks B) x'));
  access M y' (unat z') = Some v\<rbrakk>
  \<Longrightarrow> semantics (S,B,M) (Memcpy x y z) (Some (S,B,update_memory M x' v))"
| "eval_cond c (lookup S x) (lookup S y) \<Longrightarrow> semantics (S,B,M) (Assume c x y) (Some (S,B,M))"
| AssertError: "\<not> eval_cond c (lookup S x) (lookup S y) \<Longrightarrow> semantics (S,B,M) (Assert c x y) None"
| AssertSuccess: "eval_cond c (lookup S x) (lookup S y) \<Longrightarrow> semantics (S,B,M) (Assert c x y) (Some (S,B,M))"
| "\<lbrakk>distinct args; length args = length params; list_all2 (\<lambda>a p. size a = size p) args params;
  fun_semantics f (Stack (bind_args_to_params (lookup S) params args),B,M) (S',B',M')\<rbrakk>
  \<Longrightarrow> semantics (S,B,M) (Call (f,params) args)
    (Some (Stack (bind_args_to_params (lookup S') args params),B',M'))"
end

abbreviation program_semantics :: "prog \<Rightarrow> pre_config \<Rightarrow> bool" where
  "program_semantics program post \<equiv> fun_semantics program ''main'' initial post"

lift_definition program_semantics_config :: "prog \<Rightarrow> config \<Rightarrow> bool" is
  "program_semantics" .

abbreviation all_blocks_alloc :: "block list \<Rightarrow> memory \<Rightarrow> bool" where
  "all_blocks_alloc B M \<equiv> list_all (\<lambda>(n,l,u). \<forall>x. intv x (l,u) \<longrightarrow> M x \<noteq> None) B"

lift_definition blocks_alloc :: "blocks \<Rightarrow> memory \<Rightarrow> bool" is all_blocks_alloc .

abbreviation config_blocks_alloc :: "pre_config \<Rightarrow> bool" where
  "config_blocks_alloc \<equiv> \<lambda>(_,B,M). blocks_alloc B M"

lemma assumes "config_blocks_alloc pre"
  shows "(semantics pr pre cmd (Some post) \<longrightarrow> config_blocks_alloc post) \<and>
    (fun_semantics pr f pre post \<longrightarrow> config_blocks_alloc post) \<and>
    (cfg_reachable pr es from to pre post \<longrightarrow> config_blocks_alloc post)"
proof (induction rule: semantics_fun_semantics_cfg_reachable.induct)
  case (SingleStep "from" to es pre cmd post)
  then show ?case sorry
next
  case (MultiStep "from" to' es pre cmd interm to post)
  then show ?case sorry
next
  case (LoadFail B S y x M)
  then show ?case sorry
next
  case (LoadSuccess B S y x M v)
  then show ?case sorry
next
  case (StoreFail B S x y M)
  then show ?case sorry
next
  case (StoreSuccess B S x y M)
  then show ?case sorry
next
  case (MallocError S z x uu uv)
  then show ?case sorry
next
  case (MallocSuccessNull S z x B M)
  then show ?case sorry
next
  case (MallocSuccess S z x B l n k M)
  then show ?case sorry
next
  case (FreeError S x B uw)
  then show ?case sorry
next
  case (FreeSuccess S x y B M)
  then show ?case sorry
next
  case (PtrPlusError y' S y z' z B M ux)
  then show ?case sorry
next
  case (PtrPlusSuccess y' S y z' z B M x)
  then show ?case sorry
next
  case (PtrSubError y' S y z' z B M uy)
  then show ?case sorry
next
  case (PtrSubSuccess y' S y z' z B M x)
  then show ?case sorry
next
  case (MemcpyError y' S y z' z x' x B M)
  then show ?case sorry
next
  case (MemcpySuccess y' S y z' z x' B M v x)
  then show ?case sorry
next
  case (AssertError c S x y B M)
  then show ?case sorry
next
  case (AssertSuccess c S x y B M)
  then show ?case sorry
qed oops

lemma assumes "config_def pre"
  shows "(semantics pr pre cmd (Some post) \<longrightarrow> config_def post) \<and>
    (fun_semantics pr f pre post \<longrightarrow> config_def post) \<and>
    (cfg_reachable pr es from to pre post \<longrightarrow> config_def post)"
proof (induction rule: semantics_fun_semantics_cfg_reachable.induct)
  case (SingleStep "from" to es pre cmd post')
  then show ?case sorry
next
  case (MultiStep "from" to' es pre cmd interm to post)
  then show ?case sorry
next
  case (LoadFail B S y x M)
  then show ?case sorry
next
  case (LoadSuccess B S y x M v)
  then show ?case sorry
next
  case (StoreFail B S x y M)
  then show ?case sorry
next
  case (StoreSuccess B S x y M)
  then show ?case sorry
next
  case (MallocError S z x uu uv)
  then show ?case sorry
next
  case (MallocSuccessNull S z x B M)
  then show ?case sorry
next
  case (MallocSuccess S z x B l n k M)
  then show ?case sorry
next
  case (FreeError S x B uw)
  then show ?case sorry
next
  case (FreeSuccess S x y B M)
  then show ?case sorry
next
  case (PtrPlusError y' S y z' z B M ux)
  then show ?case sorry
next
  case (PtrPlusSuccess y' S y z' z B M x)
  then show ?case sorry
next
  case (PtrSubError y' S y z' z B M uy)
  then show ?case sorry
next
  case (PtrSubSuccess y' S y z' z B M x)
  then show ?case sorry
next
  case (MemcpyError y' S y z' z x' x B M)
  then show ?case sorry
next
  case (MemcpySuccess y' S y z' z x' B M v x)
  then show ?case sorry
next
  case (AssertError c S x y B M)
  then show ?case sorry
next
  case (AssertSuccess c S x y B M)
  then show ?case sorry
qed oops

end


theory Leadsto_Map
  imports Leadsto Unified_PW_Hashing Liveness_Subsumption_Map Heap_Hash_Map Next_Key
begin

definition map_to_set :: "('b \<rightharpoonup> 'a set) \<Rightarrow> 'a set" where
  "map_to_set m = (\<Union> (ran m))"

hide_const wait

definition
  "map_list_set_rel =
    {(ml, ms). dom ml = dom ms
     \<and> (\<forall> k \<in> dom ms. set (the (ml k)) = the (ms k) \<and> distinct (the (ml k)))
     \<and> finite (dom ml)
    }"

context Worklist_Map2_Defs
begin

definition
  "add_pw'_map3 passed wait a \<equiv>
   nfoldli (succs a) (\<lambda>(_, _, brk). \<not>brk)
    (\<lambda>a (passed, wait, _).
      do {
      RETURN (
        if empty a then
            (passed, wait, False)
        else if F' a then (passed, wait, True)
        else
          let k = key a; passed' = (case passed k of Some passed' \<Rightarrow> passed' | None \<Rightarrow> [])
          in
            if \<exists> x \<in> set passed'. a \<unlhd> x then
              (passed, wait, False)
            else
              (passed(k \<mapsto> (a # passed')), a # wait, False)
        )
      }
    )
    (passed,wait,False)"

definition
  "pw_map_inv3 \<equiv> \<lambda> (passed, wait, brk).
    \<exists> passed'. (passed, passed') \<in> map_list_set_rel \<and> pw_map_inv (passed', wait, brk)
  "

definition pw_algo_map3 where
  "pw_algo_map3 = do
    {
      if F a\<^sub>0 then RETURN (True, Map.empty)
      else if empty a\<^sub>0 then RETURN (False, Map.empty)
      else do {
        (passed, wait) \<leftarrow> RETURN ([key a\<^sub>0 \<mapsto> [a\<^sub>0]], [a\<^sub>0]);
        (passed, wait, brk) \<leftarrow> WHILEIT pw_map_inv3 (\<lambda> (passed, wait, brk). \<not> brk \<and> wait \<noteq> [])
          (\<lambda> (passed, wait, brk). do
            {
              (a, wait) \<leftarrow> take_from_list wait;
              ASSERT (reachable a);
              if empty a then RETURN (passed, wait, brk) else add_pw'_map3 passed wait a
            }
          )
          (passed, wait, False);
          RETURN (brk, passed)
      }
    }
  "

end \<comment> \<open>Worklist Map 2 Defs\<close>

lemma map_list_set_rel_empty[refine, simp, intro]:
  "(Map.empty, Map.empty) \<in> map_list_set_rel"
  unfolding map_list_set_rel_def by auto

lemma map_list_set_rel_single:
  "(ml(key a\<^sub>0 \<mapsto> [a\<^sub>0]), ms(key a\<^sub>0 \<mapsto> {a\<^sub>0})) \<in> map_list_set_rel" if "(ml, ms) \<in> map_list_set_rel"
  using that unfolding map_list_set_rel_def by auto

context Worklist_Map2
begin

lemma refine_start[refine]:
  "(([key a\<^sub>0 \<mapsto> [a\<^sub>0]], [a\<^sub>0]), [key a\<^sub>0 \<mapsto> {a\<^sub>0}], [a\<^sub>0]) \<in> map_list_set_rel \<times>\<^sub>r Id"
  by (simp add: map_list_set_rel_single)

lemma pw_map_inv_ref:
  "pw_map_inv (x1, x2, x3) \<Longrightarrow> (x1a, x1) \<in> map_list_set_rel \<Longrightarrow> pw_map_inv3 (x1a, x2, x3)"
  unfolding pw_map_inv3_def by auto

lemma refine_aux[refine]:
  "(x1, x) \<in> map_list_set_rel \<Longrightarrow> ((x1, x2, False), x, x2, False) \<in> map_list_set_rel \<times>\<^sub>r Id \<times>\<^sub>r Id"
  by simp

lemma map_list_set_relD:
  "ms k = Some (set xs)" if "(ml, ms) \<in> map_list_set_rel" "ml k = Some xs"
  using that unfolding map_list_set_rel_def
  by clarsimp (metis (mono_tags, lifting) domD domI option.sel)

lemma map_list_set_rel_distinct:
  "distinct xs" if "(ml, ms) \<in> map_list_set_rel" "ml k = Some xs"
  using that unfolding map_list_set_rel_def by clarsimp (metis domI option.sel)

lemma map_list_set_rel_NoneD1[dest, intro]:
  "ms k = None" if "(ml, ms) \<in> map_list_set_rel" "ml k = None"
  using that unfolding map_list_set_rel_def by auto

lemma map_list_set_rel_NoneD2[dest, intro]:
  "ml k = None" if "(ml, ms) \<in> map_list_set_rel" "ms k = None"
  using that unfolding map_list_set_rel_def by auto

lemma map_list_set_rel_insert:
  "(ml, ms) \<in> map_list_set_rel \<Longrightarrow>
   ml (key a) = Some xs \<Longrightarrow>
   ms (key a) = Some (set xs) \<Longrightarrow>
   a \<notin> set xs \<Longrightarrow>
   (ml(key a \<mapsto> a # xs), ms(key a \<mapsto> insert a (set xs))) \<in> map_list_set_rel"
  apply (frule map_list_set_rel_distinct) unfolding map_list_set_rel_def by auto

lemma add_pw'_map3_ref:
  "add_pw'_map3 ml xs a \<le> \<Down> (map_list_set_rel \<times>\<^sub>r Id) (add_pw'_map2 ms xs a)"
  if "(ml, ms) \<in> map_list_set_rel" "\<not> empty a"
  using that unfolding add_pw'_map3_def add_pw'_map2_def
  apply refine_rcg
     apply refine_dref_type
     apply (simp; fail)
    apply (simp; fail)
   apply (simp; fail)
  apply (clarsimp simp: Let_def)
  apply safe
  subgoal
    by (auto dest: map_list_set_relD[OF _ sym])
  subgoal
    apply (auto split: option.split_asm)
    by (metis (mono_tags, lifting)
          map_list_set_relD map_list_set_rel_NoneD1 option.collapse option.sel option.simps(3)
        )
  subgoal premises prems for a ms x2a ml x2c
  proof (cases "ml (key a)")
    case None
    with \<open>(ml, ms) \<in> map_list_set_rel\<close> have "ms (key a) = None"
      by auto
    with None \<open>(ml, ms) \<in> map_list_set_rel\<close> show ?thesis
      by (auto intro: map_list_set_rel_single)
  next
    case (Some xs)
    from map_list_set_relD[OF \<open>(ml, ms) \<in> map_list_set_rel\<close> \<open>ml _ = _\<close>] have
      "ms (key a) = Some (set xs)"
      by auto
    moreover from prems have "a \<notin> set xs"
      by (metis Some empty_subsumes' local.eq_refl)
    ultimately show ?thesis
      using Some \<open>(ml, ms) \<in> map_list_set_rel\<close> by (auto intro: map_list_set_rel_insert)
  qed
  done

lemma pw_algo_map3_ref[refine]:
  "pw_algo_map3 \<le> \<Down> (Id \<times>\<^sub>r map_list_set_rel) pw_algo_map2"
  unfolding pw_algo_map3_def pw_algo_map2_def
  apply refine_rcg
              apply refine_dref_type
              apply (simp; fail)+
          apply (clarsimp, rule refine_aux; assumption)
  by (auto intro: add_pw'_map3_ref pw_map_inv_ref)

lemma pw_algo_map2_ref':
  "pw_algo_map2 \<le> \<Down> (bool_rel \<times>\<^sub>r map_set_rel) pw_algo"
proof -
  note pw_algo_map2_ref
  also note pw_algo_map_ref
  also note pw_algo_unified_ref
  finally show ?thesis .
qed

lemma pw_algo_map3_ref'[refine]:
  "pw_algo_map3 \<le> \<Down> (bool_rel \<times>\<^sub>r (map_list_set_rel O map_set_rel)) pw_algo"
proof -
  have [simp]:
    "((bool_rel \<times>\<^sub>r map_list_set_rel) O (bool_rel \<times>\<^sub>r map_set_rel))
    = (bool_rel \<times>\<^sub>r (map_list_set_rel O map_set_rel))"
    unfolding relcomp_def prod_rel_def by auto
  note pw_algo_map3_ref
  also note pw_algo_map2_ref'
  finally show ?thesis
    by (simp add: conc_fun_chain)
qed

end \<comment> \<open>Worklist Map 2 Defs\<close>

lemma (in Worklist_Map2_finite) map_set_rel_finite_domI[intro]:
  "finite (dom m)" if "(m, S) \<in> map_set_rel"
  using that unfolding map_set_rel_def by auto

lemma (in Worklist_Map2_finite) map_set_rel_finiteI:
  "finite S" if "(m, S) \<in> map_set_rel"
  using that unfolding map_set_rel_def
  apply clarsimp
  apply (rule finite_Union)
   apply (auto intro: map_dom_ran_finite; fail)
  apply (auto simp: ran_def; fail)
  done

lemma (in Worklist_Map2_finite) map_set_rel_finite_ranI[intro]:
  "finite S'" if "(m, S) \<in> map_set_rel" "S' \<in> ran m"
  using that unfolding map_set_rel_def ran_def by auto

locale Leadsto_Search_Space_Key =
  A: Worklist_Map2 _ _ _ _ _ _ _ succs1 +
  Leadsto_Search_Space for succs1
begin

sublocale A': Worklist_Map2_finite a\<^sub>0 "\<lambda> _. False" "(\<preceq>)" empty "(\<unlhd>)" E key succs1 "\<lambda> _. False"
  by (standard; blast intro!: A.succs_correct)

interpretation B:
  Liveness_Search_Space_Key
  "\<lambda> x y. E x y \<and> Q y \<and> \<not> empty y" a\<^sub>0 "\<lambda> _. False" "(\<preceq>)" "\<lambda> x. A.reachable x \<and> \<not> empty x"
  succs_Q key
  by standard (auto intro!: A.empty_subsumes')

context
  fixes a\<^sub>1 :: 'a
begin

interpretation B':
  Liveness_Search_Space_Key_Defs
  a\<^sub>1 "\<lambda> _. False" "(\<preceq>)" "\<lambda> x. A.reachable x \<and> \<not> empty x"
  succs_Q "\<lambda> x y. E x y \<and> Q y \<and> \<not> empty y" key .

definition has_cycle_map where
  "has_cycle_map = B'.dfs_map"

context
  assumes "A.reachable a\<^sub>1"
begin

interpretation B':
  Liveness_Search_Space_Key
  "\<lambda> x y. E x y \<and> Q y \<and> \<not> empty y" a\<^sub>1 "\<lambda> _. False" "(\<preceq>)" "\<lambda> x. A.reachable x \<and> \<not> empty x"
  succs_Q key
  by standard

lemmas has_cycle_map_ref[refine] = B'.dfs_map_dfs_refine[folded has_cycle_map_def has_cycle_def]

end (* Reachability assumption *)

end (* Second start state *)

definition outer_inv where
  "outer_inv passed done todo \<equiv> \<lambda> (r, passed').
    (r \<longrightarrow> (\<exists> a. A.reachable a \<and> \<not> empty a \<and> P a \<and> Q a \<and> reaches_cycle a))
     \<and> (\<not> r \<longrightarrow>
          (\<forall> a \<in> \<Union> done. P a \<and> Q a \<longrightarrow> \<not> reaches_cycle a)
         \<and> B.liveness_compatible passed'
         \<and> passed' \<subseteq> {x. A.reachable x \<and> \<not> empty x}
       )
  "

definition inner_inv where
  "inner_inv passed done todo \<equiv> \<lambda> (r, passed').
    (r \<longrightarrow> (\<exists> a. A.reachable a \<and> \<not> empty a \<and> P a \<and> Q a \<and> reaches_cycle a))
     \<and> (\<not> r \<longrightarrow>
          (\<forall> a \<in> done. P a \<and> Q a \<longrightarrow> \<not> reaches_cycle a)
         \<and> B.liveness_compatible passed'
         \<and> passed' \<subseteq> {x. A.reachable x \<and> \<not> empty x}
       )
  "

definition leadsto' :: "bool nres" where
  "leadsto' = do {
    (r, passed) \<leftarrow> A'.pw_algo_map2;
    let passed = ran passed;
    (r, _) \<leftarrow> FOREACHcdi (outer_inv passed) passed (\<lambda>(b,_). \<not>b)
      (\<lambda> passed' (_,acc).
          FOREACHcdi (inner_inv acc) passed' (\<lambda>(b,_). \<not>b)
            (\<lambda>v' (_,passed).
              do {
                ASSERT(A.reachable v' \<and> \<not> empty v');
                if P v' \<and> Q v' then has_cycle v' passed else RETURN (False, passed)
              }
            )
            (False, acc)
      )
      (False, {});
    RETURN r
  }"

lemma leadsto'_correct:
  "leadsto' \<le> leadsto_spec"
proof -
  define inv where
    "inv \<equiv> \<lambda> passed it (r, passed').
       (r \<longrightarrow> (\<exists> a. A.reachable a \<and> \<not> empty a \<and> P a \<and> Q a \<and> reaches_cycle a))
     \<and> (\<not> r \<longrightarrow>
          (\<forall> a \<in> passed - it. \<not> reaches_cycle a)
         \<and> B.liveness_compatible passed'
         \<and> passed' \<subseteq> {x. A.reachable x \<and> \<not> empty x}
       )
    "

  have [simp, intro]:
    "\<not> A'.F_reachable"
    unfolding A'.F_reachable_def by simp

  have B_reaches_empty:
    "\<not> empty b" if "\<not> empty a" "B.reaches a b" for a b
    using that(2,1)by induction auto

  interpret Subgraph_Start E a\<^sub>0 "\<lambda> a x. E a x \<and> Q x \<and> \<not> empty x"
    by standard auto

  have B_A_reaches:
    "A.reaches a b" if "B.reaches a b" for a b
    using that by (rule reaches)

  have reaches_iff: "B.reaches a x \<longleftrightarrow> B.G.G'.reaches a x"
    if "A.reachable a" "\<not> empty a" for a x
    unfolding reaches_cycle_def
    apply standard
    using that
      apply (rotate_tac 3)
     apply (induction rule: rtranclp.induct)
      apply blast
     apply rule
      apply assumption
     apply (subst B.G.E'_def)
    subgoal for a b c
      by (auto dest: B_reaches_empty)
    subgoal
      by (rule B.G.reaches)
    done

  have reaches1_iff: "B.reaches1 a x \<longleftrightarrow> B.G.G'.reaches1 a x"
    if "A.reachable a" "\<not> empty a" for a x
    unfolding reaches_cycle_def
    apply standard
    subgoal
      using that
        apply (rotate_tac 3)
      apply (induction rule: tranclp.induct)
       apply (rule tranclp.intros(1), auto simp: B.G.E'_def; fail)
      apply (
          rule tranclp.intros(2);
          auto 4 3 simp: B.G.E'_def dest:B_reaches_empty tranclp_into_rtranclp
          )
      done
    subgoal
      by (rule B.G.reaches1)
    done

  have reaches_cycle_iff: "reaches_cycle a \<longleftrightarrow> (\<exists>x. B.G.G'.reaches a x \<and> B.G.G'.reaches1 x x)"
    if "A.reachable a" "\<not> empty a" for a
    unfolding reaches_cycle_def
    apply (subst reaches_iff[OF that])
    using reaches1_iff B.G.G'_reaches_V that by blast

  have aux1:
    "\<not> reaches_cycle x"
    if
      "\<forall>a. A.reachable a \<and> \<not> empty a \<longrightarrow> (\<exists>x\<in>passed. a \<preceq> x)"
      "passed \<subseteq> {a. A.reachable a \<and> \<not> empty a}"
      "\<forall> y \<in> ran passed'. \<forall> x \<in> y. P x \<and> Q x \<longrightarrow> \<not> reaches_cycle x"
      "A.reachable x" "\<not> empty x" "P x" "Q x"
      "(passed', passed) \<in> A'.map_set_rel"
    for x passed passed'
  proof (rule ccontr, simp)
    assume "reaches_cycle x"
    from that obtain x' where x':"x' \<in> passed" "x \<preceq> x'"
      by auto
    with \<open>(_, _) \<in> _\<close> obtain y where y: "y \<in> ran passed'" "x' \<in> y"
      unfolding A'.map_set_rel_def by auto
    from x' that have "P x'" "Q x'"
      by (auto intro: P_mono Q_mono)
    with \<open>x' \<in> passed\<close> that(3) y have "\<not> reaches_cycle x'"
      by auto
    have "A.reachable x'" "\<not> empty x'"
      using \<open>x' \<in> passed\<close> that(2) A.empty_mono \<open>x \<preceq> x'\<close> that(5) by auto
    note reaches_cycle_iff' = reaches_cycle_iff[OF this] reaches_iff[OF this] reaches1_iff[OF this]
    from \<open>reaches_cycle x\<close> guess y unfolding reaches_cycle_def
      by safe
    interpret
      Subsumption_Graph_Pre_Nodes
        "(\<preceq>)" A.subsumes_strictly "\<lambda> x y. E x y \<and> Q y \<and> \<not> empty y"
        "\<lambda> x. A.reachable x \<and> \<not> empty x"
      by standard (rule B.mono[simplified]; assumption)
    from \<open>B.reaches x y\<close> \<open>x \<preceq> x'\<close> \<open>B.reaches1 y y\<close> reaches_cycle_mono[OF B.finite_V] obtain y' where
      "y \<preceq> y'" "B.G.G'.reaches x' y'" "B.G.G'.reaches1 y' y'"
      apply atomize_elim
      apply (subst (asm) reaches_iff[rotated 2])
        defer
        defer
        apply (subst (asm) reaches1_iff)
          defer
          defer
      using \<open>A.reachable x\<close> \<open>\<not> empty x\<close> \<open>A.reachable x'\<close> \<open>\<not> empty x'\<close> \<open>B.reaches1 y y\<close>
      by (auto simp: B.reaches1_reaches_iff2 dest!: B.G.G'_reaches_V)
    with \<open>A.reachable x'\<close> \<open>\<not> empty x'\<close> have "reaches_cycle x'"
      unfolding reaches_cycle_iff'
      by auto
    with \<open>\<not> reaches_cycle x'\<close> show False ..
  qed

  note [refine_vcg] = A'.pw_algo_map2_correct[THEN order.trans]

  show ?thesis
    unfolding leadsto'_def leadsto_spec_def
    apply (refine_rcg refine_vcg)

      (* Input is finite 1 *)
    subgoal
      by (auto intro: map_dom_ran_finite)

      (* Outer invariant holds initially *)
      subgoal
        unfolding outer_inv_def B.liveness_compatible_def by simp

      (* Input is finite 2 *)
      subgoal
        by auto

      (* Inner invariant holds initially *)
      subgoal for x a b S1 S2 todo \<sigma> aa passed
        unfolding inner_inv_def outer_inv_def by simp

      (* Assertion *)
      subgoal
        unfolding inner_inv_def outer_inv_def A'.map_set_rel_def by auto

      (* Assertion *)
      subgoal
        unfolding inner_inv_def outer_inv_def A'.map_set_rel_def by auto

      (* Inner invariant is preserved *)
      subgoal for _ _ b S1 S2 xa \<sigma> aa passed S1' S2' a\<^sub>1 \<sigma>' ab passed'
        unfolding outer_inv_def
        apply clarsimp
        subgoal premises prems for p
        proof -
          from prems have "a\<^sub>1 \<in> p"
            unfolding A'.map_set_rel_def by auto
          with \<open>passed \<subseteq> _\<close> \<open>p \<subseteq> _\<close> have "A.reachable a\<^sub>1"
            by auto
          interpret B':
            Liveness_Search_Space
            "\<lambda> x y. E x y \<and> Q y \<and> \<not> empty y" a\<^sub>1 "\<lambda> _. False" "(\<preceq>)"
            "\<lambda> x. A.reachable x \<and> \<not> empty x" succs_Q
            by standard
          from \<open>inner_inv _ _ _ _\<close> have
            "B'.liveness_compatible passed'" "passed' \<subseteq> {x. A.reachable x \<and> \<not> empty x}"
            unfolding inner_inv_def by auto
          from B'.dfs_correct[OF _ this] \<open>passed \<subseteq> _\<close> \<open>a\<^sub>1 \<in> _\<close> \<open>p \<subseteq> _\<close> have
            "B'.dfs passed' \<le> B'.dfs_spec"
            by auto
          then show ?thesis
            unfolding has_cycle_def
            apply (rule order.trans)
            unfolding B'.dfs_spec_def
            apply clarsimp
            subgoal for r passed1
              apply (cases r)
               apply simp
              subgoal
                unfolding inner_inv_def
                using \<open>passed \<subseteq> _\<close> \<open>a\<^sub>1 \<in> _\<close> \<open>p \<subseteq> _\<close>
                apply simp
                apply (inst_existentials a\<^sub>1)
                by (auto 4 3 simp: reaches_cycle_iff intro: prems)
              subgoal
                using \<open>inner_inv _ _ _ _\<close> \<open>passed \<subseteq> _\<close> \<open>a\<^sub>1 \<in> _\<close> \<open>p \<subseteq> _\<close> reaches_cycle_iff
                unfolding inner_inv_def by auto
                done
              done
          qed
          done

          (* Current state filtered out *)
          subgoal for x a b S1 S2 xa \<sigma> aa ba S1a S2a xb \<sigma>' ab bb
            unfolding inner_inv_def by auto

          (* Break \<and> inner inv \<longrightarrow> outer inv *)
          subgoal for x a b S1 S2 xa \<sigma> aa ba S1a S2a \<sigma>'
            unfolding inner_inv_def outer_inv_def by auto

          (* \<not> Break \<and> inner inv \<longrightarrow> outer inv *)
          subgoal for x a b S1 S2 xa \<sigma> aa ba \<sigma>'
            unfolding inner_inv_def outer_inv_def by auto

          (* Break \<and> outer inv \<longrightarrow> cycle *)
          subgoal for x a b S1 S2 \<sigma> aa ba
            unfolding outer_inv_def by auto

          (* \<not> Break \<and> outer inv \<longrightarrow> cycle *)
          (* I \<and> \<not> b \<longrightarrow> post *)
          subgoal for x a b \<sigma> aa ba
            unfolding outer_inv_def by (auto dest!: aux1)

          done
      qed

lemma init_ref[refine]:
  "((False, Map.empty), False, {}) \<in> bool_rel \<times>\<^sub>r A'.map_set_rel"
  unfolding A'.map_set_rel_def by auto

lemma map_set_rel_id:
  "Liveness_Search_Space_Key.map_set_rel key = A'.map_set_rel"
  unfolding A'.map_set_rel_def B.map_set_rel_def ..

lemma has_cycle_map_ref'[refine]:
  assumes "(P1, P1') \<in> A'.map_set_rel" "(a, a') \<in> Id" "A.reachable a" "\<not> empty a"
  shows "has_cycle_map a P1 \<le> \<Down> (bool_rel \<times>\<^sub>r A'.map_set_rel) (has_cycle a' P1')"
  using has_cycle_map_ref assms by (auto simp: map_set_rel_id)

definition leadsto_map3' :: "bool nres" where
  "leadsto_map3' = do {
    (r, passed) \<leftarrow> A'.pw_algo_map2;
    let passed = ran passed;
    (r, _) \<leftarrow> FOREACHcd passed (\<lambda>(b,_). \<not>b)
      (\<lambda> passed' (_,acc).
        do {
          passed' \<leftarrow> SPEC (\<lambda>l. set l = passed');
          nfoldli passed' (\<lambda>(b,_). \<not>b)
            (\<lambda>v' (_,passed).
              if P v' \<and> Q v' then has_cycle_map v' passed else RETURN (False, passed)
            )
            (False, acc)
        }
      )
      (False, Map.empty);
    RETURN r
  }"

definition "pw_algo_map2_copy = A'.pw_algo_map2"

lemma [refine]:
  "A'.pw_algo_map2 \<le>
    \<Down> (br id (\<lambda> (_, m). finite (dom m) \<and> (\<forall> k S. m k = Some S \<longrightarrow> finite S))) pw_algo_map2_copy"
proof -
  have [refine]:
    "(x, x') \<in> Id \<Longrightarrow>
     x' = (x1, x2) \<Longrightarrow>
     x = (x1a, x2a) \<Longrightarrow>
     A'.pw_map_inv (x1, x2, False)
    \<Longrightarrow> ((x1a, x2a, False), x1, x2, False) \<in>
        (br id (\<lambda> m. finite (dom m) \<and> (\<forall> k S. m k = Some S \<longrightarrow> finite S))) \<times>\<^sub>r Id \<times>\<^sub>r Id"
    for x x' x1 x2 x1a x2a
    by (auto simp: br_def A'.pw_map_inv_def A'.map_set_rel_def)
  show ?thesis
    unfolding pw_algo_map2_copy_def
    unfolding A'.pw_algo_map2_def
    apply refine_rcg
                  apply refine_dref_type
                  prefer 5
                  apply assumption
                 apply (assumption | (simp add: br_def; fail) | (auto simp: br_def; fail))+
    subgoal
      apply (clarsimp simp: br_def)
      subgoal premises prems
        using \<open>finite _\<close> \<open>\<forall>k S. _ \<longrightarrow> finite _\<close>
        unfolding A'.add_pw'_map2_def
        apply refine_rcg
           apply refine_dref_type
           apply (auto simp: Let_def split!: option.split)
        done
      done
    by (simp add: br_def)
qed

lemma leadsto_map3'_ref[refine]:
  "leadsto_map3' \<le> \<Down> Id leadsto'"
  unfolding leadsto_map3'_def leadsto'_def
  apply (subst (2) pw_algo_map2_copy_def[symmetric])
  apply (subst (2) FOREACHcdi_def)
  apply (subst (2) FOREACHcd_def)
  apply refine_rcg
               apply refine_dref_type
  by (auto simp: br_def intro: map_dom_ran_finite)

definition leadsto_map3 :: "bool nres" where
  "leadsto_map3 = do {
    (r, passed) \<leftarrow> A'.pw_algo_map3;
    let passed = ran passed;
    (r, _) \<leftarrow> FOREACHcd passed (\<lambda>(b,_). \<not>b)
      (\<lambda> passed' (_,acc).
          nfoldli passed' (\<lambda>(b,_). \<not>b)
            (\<lambda>v' (_,passed).
              if P v' \<and> Q v' then has_cycle_map v' passed else RETURN (False, passed)
            )
            (False, acc)
      )
      (False, Map.empty);
    RETURN r
  }"

lemma start_ref:
  "((False, Map.empty), False, Map.empty) \<in> Id \<times>\<^sub>r map_list_set_rel"
  by simp

lemma map_list_set_rel_ran_set_rel:
  "(ran ml, ran ms) \<in> \<langle>br set (\<lambda>_. True)\<rangle>set_rel" if "(ml, ms) \<in> map_list_set_rel"
  using that unfolding map_list_set_rel_def set_rel_def
  apply safe
  subgoal for x
    by (auto simp: ran_def dom_def in_br_conv dest: A.map_list_set_relD[OF that])
  subgoal premises prems for x'
  proof -
    from prems(4) obtain a where "ms a = Some x'"
      unfolding ran_def by clarsimp
    with prems(1) obtain m' where
      "ml a = Some (m' a)"
      by (fastforce simp: dom_def ran_def)
    with prems(2) \<open>ms a = _\<close> show ?thesis
      by (fastforce simp: in_br_conv dom_def ran_def)
  qed
  done

lemma Id_list_rel_ref:
  "(x'a, x'a) \<in> \<langle>Id\<rangle>list_rel"
  by simp

lemma map_list_set_rel_finite_ran:
  "finite (ran ml)" if "(ml, ms) \<in> map_list_set_rel"
  using that unfolding map_list_set_rel_def by (auto intro: map_dom_ran_finite)

lemma leadsto_map3_ref[refine]:
  "leadsto_map3 \<le> \<Down> Id leadsto'"
  unfolding leadsto_map3_def leadsto'_def
  apply (subst (2) FOREACHcdi_def)
  apply (subst (2) FOREACHcd_def)
  apply (refine_rcg map_list_set_rel_ran_set_rel map_list_set_rel_finite_ran)
      prefer 4
    apply (rule rhs_step_bind_SPEC)
    apply (clarsimp simp: br_def; rule HOL.refl; fail)
   apply (refine_rcg Id_list_rel_ref; simp; fail)
   by auto

definition leadsto_map4 :: "bool nres" where
  "leadsto_map4 = do {
    (r, passed) \<leftarrow> A'.pw_algo_map3;
    ASSERT (finite (dom passed));
    passed \<leftarrow> ran_of_map passed;
    (r, _) \<leftarrow> nfoldli passed (\<lambda>(b,_). \<not>b)
      (\<lambda> passed' (_,acc).
          nfoldli passed' (\<lambda>(b,_). \<not>b)
            (\<lambda>v' (_,passed).
              if P v' \<and> Q v' then has_cycle_map v' passed else RETURN (False, passed)
            )
            (False, acc)
      )
      (False, Map.empty);
    RETURN r
  }"

lemma ran_of_map_ref:
  "ran_of_map m \<le> SPEC (\<lambda>c. (c, ran m') \<in> br set (\<lambda> _. True))" if "finite (dom m)" "(m, m') \<in> Id"
  using ran_of_map_correct[OF that(1)] that(2) unfolding br_def by (simp add: pw_le_iff)

lemma aux_ref:
  "(xa, x'a) \<in> Id \<Longrightarrow>
       x'a = (x1b, x2b) \<Longrightarrow> xa = (x1c, x2c) \<Longrightarrow> (x1c, x1b) \<in> bool_rel"
  by simp

definition "foo = A'.pw_algo_map3"

lemma [refine]:
  "A'.pw_algo_map3 \<le> \<Down> (br id (\<lambda> (_, m). finite (dom m))) foo"
proof -
  have [refine]:
    "(x, x') \<in> Id \<Longrightarrow>
     x' = (x1, x2) \<Longrightarrow>
     x = (x1a, x2a) \<Longrightarrow>
     A'.pw_map_inv3 (x1, x2, False)
    \<Longrightarrow> ((x1a, x2a, False), x1, x2, False) \<in> (br id (\<lambda> m. finite (dom m))) \<times>\<^sub>r Id \<times>\<^sub>r Id"
    for x x' x1 x2 x1a x2a
    by (auto simp: br_def A'.pw_map_inv3_def map_list_set_rel_def)
  show ?thesis
    unfolding foo_def
    unfolding A'.pw_algo_map3_def
    apply refine_rcg
                  apply refine_dref_type
                  prefer 5
                  apply assumption
                 apply (assumption | (simp add: br_def; fail) | (auto simp: br_def; fail))+
    subgoal
      apply (clarsimp simp: br_def)
      subgoal premises prems
        using \<open>finite _\<close>
        unfolding A'.add_pw'_map3_def
        apply refine_rcg
           apply refine_dref_type
           apply (auto simp: Let_def)
        done
      done
    by (simp add: br_def)
qed

lemma leadsto_map4_ref[refine]:
  "leadsto_map4 \<le> \<Down> Id leadsto_map3"
  unfolding leadsto_map4_def leadsto_map3_def FOREACHcd_def
  apply (subst (2) foo_def[symmetric])
  apply (refine_rcg ran_of_map_ref)
     apply refine_dref_type
     apply (simp add: br_def; fail)
    apply (simp add: br_def; fail)
   apply (rule rhs_step_bind_SPEC)
  by (auto simp: br_def)

definition leadsto_map4' :: "bool nres" where
  "leadsto_map4' = do {
    (r, passed) \<leftarrow> A'.pw_algo_map2;
    ASSERT (finite (dom passed));
    passed \<leftarrow> ran_of_map passed;
    (r, _) \<leftarrow> nfoldli passed (\<lambda>(b,_). \<not>b)
      (\<lambda> passed' (_,acc).
        do {
          passed' \<leftarrow> SPEC (\<lambda>l. set l = passed');
          nfoldli passed' (\<lambda>(b,_). \<not>b)
            (\<lambda>v' (_,passed).
              if P v' \<and> Q v' then has_cycle_map v' passed else RETURN (False, passed)
            )
            (False, acc)
        }
      )
      (False, Map.empty);
    RETURN r
  }"

lemma leadsto_map4'_ref:
  "leadsto_map4' \<le> \<Down> Id leadsto_map3'"
  unfolding leadsto_map4'_def leadsto_map3'_def FOREACHcd_def
  apply (subst (2) pw_algo_map2_copy_def[symmetric])
  apply (refine_rcg ran_of_map_ref)
     apply refine_dref_type
     apply (simp add: br_def; fail)
    apply (simp add: br_def; fail)
   apply (rule rhs_step_bind_SPEC)
  by (auto simp: br_def)

lemma leadsto_map4'_correct:
  "leadsto_map4' \<le> leadsto_spec_alt"
proof -
  note leadsto_map4'_ref
  also note leadsto_map3'_ref
  also note leadsto'_correct
  also note leadsto_spec_leadsto_spec_alt
  finally show ?thesis .
qed

end (* Leadsto Search Space Key *)

end (* Theory *)