header {* Second Example *}

theory %invisible Second_Example
imports Main
begin

text {* \label{chap:exampleII} *}

text {* Pop-refinement is illustrated via a simple derivation,
in Isabelle/HOL,
of a non-deterministic program that satisfies a hyperproperty. *}

section {* Hyperproperties *}
text {* \label{sec:hyper} *}

text {* Hyperproperties are predicates over sets of traces~%
\cite{ClarksonSchneiderHyperproperties}.
Hyperproperties capture security policies
like non-interference~\cite{GoguenMeseguerNonInterference},
which applies to deterministic systems,
and generalized non-interference (GNI)~\cite{McCulloughSpecificationsMLS},
which generalizes non-interference to non-deterministic systems.*}

text {* The formulation of GNI in~\cite{ClarksonSchneiderHyperproperties},
which is derived from~\cite{McLeanPossibilisticProperties},
is based on:
\begin{itemize}
\item
A notion of traces as infinite streams of abstract states.
\item
Functions that map each state to low and high inputs and outputs,
where `low' and `high' have the usual security meaning
(e.g.\ `low' means `unclassified' and `high' means `classified').
These functions are homomorphically extended to map each trace
to infinite streams of low and high inputs and outputs.
\end{itemize}
The following formulation is slightly more general,
because the functions that return low and high inputs and outputs
operate directly on abstract traces. *}

text {* GNI says that for any two traces @{term \<tau>\<^sub>1} and @{term \<tau>\<^sub>2},
there is always a trace @{term \<tau>\<^sub>3} with
the same high inputs as @{term \<tau>\<^sub>1}
and the same low inputs and low outputs as @{term \<tau>\<^sub>2}.
Intuitively, this means that a low observer
(i.e.\ one that only observes low inputs and low outputs of traces)
cannot gain any information about high inputs
(i.e.\ high inputs cannot interfere with low outputs)
because observing a trace @{term \<tau>\<^sub>2}
is indistinguishable from observing some other trace @{term \<tau>\<^sub>3}
that has the same high inputs as an arbitrary trace @{term \<tau>\<^sub>1}. *}

locale generalized_non_interference =
  fixes low_in :: "'\<tau> \<Rightarrow> 'i" -- {* low inputs *}
  fixes low_out :: "'\<tau> \<Rightarrow> 'o" -- {* low outputs *}
  fixes high_in :: "'\<tau> \<Rightarrow> 'i" -- {* high inputs *}
  fixes high_out :: "'\<tau> \<Rightarrow> 'o" -- {* high outputs *}

definition (in generalized_non_interference) GNI :: "'\<tau> set \<Rightarrow> bool"
where "GNI \<T> \<equiv>
  \<forall>\<tau>\<^sub>1 \<in> \<T>. \<forall>\<tau>\<^sub>2 \<in> \<T>. \<exists>\<tau>\<^sub>3 \<in> \<T>.
    high_in \<tau>\<^sub>3 = high_in \<tau>\<^sub>1 \<and> low_in \<tau>\<^sub>3 = low_in \<tau>\<^sub>2 \<and> low_out \<tau>\<^sub>3 = low_out \<tau>\<^sub>2"

section {* Target Programming Language *}
text {* \label{sec:targetII} *}

text {* In the target language used in this example,%
\footnote{Even though this language has many similarities
with the language in \secref{sec:targetI},
the two languages are defined separately
to keep \chapref{chap:exampleI} simpler.}
a program consists of
a list of distinct state variables
and a body of statements.
The statements modify the variables
by deterministically assigning results of expressions
and by non-deterministically assigning random values.
Expressions are built out of
non-negative integer constants,
state variables,
and addition operations.
Statements are combined
via conditionals, whose tests compare expressions for equality,
and via sequencing.
Each variable stores a non-negative integer.
Executing the body in a state yields a new state.
Because of non-determinism, different new states are possible,
i.e.\ executing the body in the same state
may yield different new states at different times. *}

text {* For instance, executing the body of the program
\begin{verbatim}
  prog {
    vars {
      x
      y
    }
    body {
      if (x == y + 1) {
        x = 0;
      } else {
        x = y + 3;
      }
      randomize y;
      y = y + 2;
    }
  }
\end{verbatim}
in the state where \verb|x| contains 4 and \verb|y| contains 7,
yields a new state where
\verb|x| always contains 10
and \verb|y| may contain any number in $\{2,3,\ldots\}$. *}

subsection {* Syntax *}
text {* \label{sec:syntaxII} *}

text {* Variables are identified by names. *}

type_synonym name = string

text {* Expressions are built out of
constants, variables, and addition operations. *}

datatype expr = Const nat | Var name | Add expr expr

text {* Statements are built out of
deterministic assignments,
non-deterministic assignments,
conditionals,
and sequencing. *}

datatype stmt =
  Assign name expr |
  Random name |
  IfEq expr expr stmt stmt |
  Seq stmt stmt

text {* A program consists of
a list of state variables
and a body statement. *}

record prog =
  vars :: "name list"
  body :: stmt

subsection {* Static Semantics *}
text {* \label{sec:staticII} *}

text {* A context is a set of variables. *}

type_synonym ctxt = "name set"

text {* Given a context,
an expression is well-formed iff\
all its variables are in the context. *}

fun wfe :: "ctxt \<Rightarrow> expr \<Rightarrow> bool"
where
  "wfe \<Gamma> (Const c) \<longleftrightarrow> True" |
  "wfe \<Gamma> (Var v) \<longleftrightarrow> v \<in> \<Gamma>" |
  "wfe \<Gamma> (Add e\<^sub>1 e\<^sub>2) \<longleftrightarrow> wfe \<Gamma> e\<^sub>1 \<and> wfe \<Gamma> e\<^sub>2"

text {* Given a context,
a statement is well-formed iff\
its deterministic assignments
assign well-formed expressions to variables in the context,
its non-deterministic assignments operate on variables in the context,
and its conditional tests compare well-formed expressions. *}

fun wfs :: "ctxt \<Rightarrow> stmt \<Rightarrow> bool"
where
  "wfs \<Gamma> (Assign v e) \<longleftrightarrow> v \<in> \<Gamma> \<and> wfe \<Gamma> e" |
  "wfs \<Gamma> (Random v) \<longleftrightarrow> v \<in> \<Gamma>" |
  "wfs \<Gamma> (IfEq e\<^sub>1 e\<^sub>2 s\<^sub>1 s\<^sub>2) \<longleftrightarrow> wfe \<Gamma> e\<^sub>1 \<and> wfe \<Gamma> e\<^sub>2 \<and> wfs \<Gamma> s\<^sub>1 \<and> wfs \<Gamma> s\<^sub>2" |
  "wfs \<Gamma> (Seq s\<^sub>1 s\<^sub>2) \<longleftrightarrow> wfs \<Gamma> s\<^sub>1 \<and> wfs \<Gamma> s\<^sub>2"

text {* The context of a program consists of the state variables. *}

definition ctxt :: "prog \<Rightarrow> ctxt"
where "ctxt p \<equiv> set (vars p)"

text {* A program is well-formed iff\
the variables are distinct
and the body is well-formed in the context of the program. *}

definition wfp :: "prog \<Rightarrow> bool"
where "wfp p \<equiv> distinct (vars p) \<and> wfs (ctxt p) (body p)"

subsection {* Dynamic Semantics *}
text {* \label{sec:dynamicII} *}

text {* A state associates values (non-negative integers) to variables. *}

type_synonym state = "name \<rightharpoonup> nat"

text {* A state matches a context iff\
state and context have the same variables. *}

definition match :: "state \<Rightarrow> ctxt \<Rightarrow> bool"
where "match \<sigma> \<Gamma> \<equiv> dom \<sigma> = \<Gamma>"

text {* Evaluating an expression in a state yields a value,
or an error (@{const None})
if the expression contains a variable not in the state. *}

definition add_opt :: "nat option \<Rightarrow> nat option \<Rightarrow> nat option" (infixl "\<oplus>" 65)
-- {* Lifting of addition to @{typ "nat option"}. *}
where "U\<^sub>1 \<oplus> U\<^sub>2 \<equiv>
  case (U\<^sub>1, U\<^sub>2) of (Some u\<^sub>1, Some u\<^sub>2) \<Rightarrow> Some (u\<^sub>1 + u\<^sub>2) | _ \<Rightarrow> None"

fun eval :: "state \<Rightarrow> expr \<Rightarrow> nat option"
where
 "eval \<sigma> (Const c) = Some c" |
 "eval \<sigma> (Var v) = \<sigma> v" |
 "eval \<sigma> (Add e\<^sub>1 e\<^sub>2) = eval \<sigma> e\<^sub>1 \<oplus> eval \<sigma> e\<^sub>2"

text {* Evaluating a well-formed expression never yields an error,
if the state matches the context. *}

lemma eval_wfe:
  "wfe \<Gamma> e \<Longrightarrow> match \<sigma> \<Gamma> \<Longrightarrow> eval \<sigma> e \<noteq> None"
by (induct e, auto simp: match_def add_opt_def)

text {* Executing a statement in a state yields a new state,
or an error (@{const None})
if the evaluation of an expression yields an error
or if an assignment operates on a variable not in the state.
Non-determinism is modeled via a relation
between old states and results,
where a result is either a new state or an error. *}

inductive exec :: "stmt \<Rightarrow> state \<Rightarrow> state option \<Rightarrow> bool"
  ("_ \<rhd> _ \<leadsto> _" [50, 50, 50] 50)
where
  ExecAssignNoVar:
    "v \<notin> dom \<sigma> \<Longrightarrow> Assign v e \<rhd> \<sigma> \<leadsto> None" |
  ExecAssignEvalError:
    "eval \<sigma> e = None \<Longrightarrow> Assign v e \<rhd> \<sigma> \<leadsto> None" |
  ExecAssignOK: "
    v \<in> dom \<sigma> \<Longrightarrow>
    eval \<sigma> e = Some u \<Longrightarrow>
    Assign v e \<rhd> \<sigma> \<leadsto> Some (\<sigma>(v \<mapsto> u))" |
  ExecRandomNoVar:
    "v \<notin> dom \<sigma> \<Longrightarrow> Random v \<rhd> \<sigma> \<leadsto> None" |
  ExecRandomOK:
    "v \<in> dom \<sigma> \<Longrightarrow> Random v \<rhd> \<sigma> \<leadsto> Some (\<sigma>(v \<mapsto> u))" |
  ExecCondEvalError1:
    "eval \<sigma> e\<^sub>1 = None \<Longrightarrow> IfEq e\<^sub>1 e\<^sub>2 s\<^sub>1 s\<^sub>2 \<rhd> \<sigma> \<leadsto> None" |
  ExecCondEvalError2:
    "eval \<sigma> e\<^sub>2 = None \<Longrightarrow> IfEq e\<^sub>1 e\<^sub>2 s\<^sub>1 s\<^sub>2 \<rhd> \<sigma> \<leadsto> None" |
  ExecCondTrue: "
    eval \<sigma> e\<^sub>1 = Some u\<^sub>1 \<Longrightarrow>
    eval \<sigma> e\<^sub>2 = Some u\<^sub>2 \<Longrightarrow>
    u\<^sub>1 = u\<^sub>2 \<Longrightarrow>
    s\<^sub>1 \<rhd> \<sigma> \<leadsto> \<rho> \<Longrightarrow>
    IfEq e\<^sub>1 e\<^sub>2 s\<^sub>1 s\<^sub>2 \<rhd> \<sigma> \<leadsto> \<rho>" |
  ExecCondFalse: "
    eval \<sigma> e\<^sub>1 = Some u\<^sub>1 \<Longrightarrow>
    eval \<sigma> e\<^sub>2 = Some u\<^sub>2 \<Longrightarrow>
    u\<^sub>1 \<noteq> u\<^sub>2 \<Longrightarrow>
    s\<^sub>2 \<rhd> \<sigma> \<leadsto> \<rho> \<Longrightarrow>
    IfEq e\<^sub>1 e\<^sub>2 s\<^sub>1 s\<^sub>2 \<rhd> \<sigma> \<leadsto> \<rho>" |
  ExecSeqError:
    "s\<^sub>1 \<rhd> \<sigma> \<leadsto> None \<Longrightarrow> Seq s\<^sub>1 s\<^sub>2 \<rhd> \<sigma> \<leadsto> None" |
  ExecSeqOK:
    "s\<^sub>1 \<rhd> \<sigma> \<leadsto> Some \<sigma>' \<Longrightarrow> s\<^sub>2 \<rhd> \<sigma>' \<leadsto> \<rho> \<Longrightarrow> Seq s\<^sub>1 s\<^sub>2 \<rhd> \<sigma> \<leadsto> \<rho>"

text {* The execution of any statement in any state always yields a result. *}

lemma exec_always:
  "\<exists>\<rho>. s \<rhd> \<sigma> \<leadsto> \<rho>"
proof (induct s arbitrary: \<sigma>)
  case Assign
  show ?case
  by (metis
    ExecAssignEvalError ExecAssignNoVar ExecAssignOK option.exhaust)
next
  case Random
  show ?case
  by (metis ExecRandomNoVar ExecRandomOK)
next
  case IfEq
  thus ?case
  by (metis
    ExecCondEvalError1 ExecCondEvalError2 ExecCondFalse ExecCondTrue
    option.exhaust)
next
  case Seq
  thus ?case
  by (metis ExecSeqError ExecSeqOK option.exhaust)
qed

text {* Executing a well-formed statement in a state that matches the context
never yields an error and always yields states that match the context. *}

lemma exec_wfs_match:
  "wfs \<Gamma> s \<Longrightarrow> match \<sigma> \<Gamma> \<Longrightarrow> s \<rhd> \<sigma> \<leadsto> Some \<sigma>' \<Longrightarrow> match \<sigma>' \<Gamma>"
proof (induct s arbitrary: \<sigma> \<sigma>')
  case (Assign v e)
  then obtain u
  where "eval \<sigma> e = Some u"
  and "\<sigma>' = \<sigma>(v \<mapsto> u)"
  by (auto elim: exec.cases)
  with Assign
  show ?case
  by (metis
    domIff dom_fun_upd fun_upd_triv match_def option.distinct(1) wfs.simps(1))
next
  case (Random v)
  then obtain u
  where "\<sigma>' = \<sigma>(v \<mapsto> u)"
  by (auto elim: exec.cases)
  with Random
  show ?case
  by (metis
    domIff dom_fun_upd fun_upd_triv match_def option.distinct(1) wfs.simps(2))
next
  case (IfEq e\<^sub>1 e\<^sub>2 s\<^sub>1 s\<^sub>2)
  hence "s\<^sub>1 \<rhd> \<sigma> \<leadsto> Some \<sigma>' \<or> s\<^sub>2 \<rhd> \<sigma> \<leadsto> Some \<sigma>'"
  by (blast elim: exec.cases)
  with IfEq
  show ?case
  by (metis wfs.simps(3))
next
  case (Seq s\<^sub>1 s\<^sub>2)
  then obtain \<sigma>\<^sub>i
  where "s\<^sub>1 \<rhd> \<sigma> \<leadsto> Some \<sigma>\<^sub>i"
  and "s\<^sub>2 \<rhd> \<sigma>\<^sub>i \<leadsto> Some \<sigma>'"
  by (blast elim: exec.cases)
  with Seq
  show ?case
  by (metis wfs.simps(4))
qed

lemma exec_wfs_no_error:
  "wfs \<Gamma> s \<Longrightarrow> match \<sigma> \<Gamma> \<Longrightarrow> \<not> (s \<rhd> \<sigma> \<leadsto> None)"
proof (induct s arbitrary: \<sigma>)
  case (Assign v e)
  hence Var: "v \<in> dom \<sigma>"
  by (auto simp: match_def)
  from Assign
  have "eval \<sigma> e \<noteq> None"
  by (metis eval_wfe wfs.simps(1))
  with Var
  show ?case
  by (auto elim: exec.cases)
next
  case (Random v)
  thus ?case
  by (auto simp: match_def elim: exec.cases)
next
  case (IfEq e\<^sub>1 e\<^sub>2 s\<^sub>1 s\<^sub>2)
  then obtain u\<^sub>1 u\<^sub>2
  where "eval \<sigma> e\<^sub>1 = Some u\<^sub>1"
  and "eval \<sigma> e\<^sub>2 = Some u\<^sub>2"
  by (metis eval_wfe not_Some_eq wfs.simps(3))
  with IfEq
  show ?case
  by (auto elim: exec.cases)
next
  case (Seq s\<^sub>1 s\<^sub>2)
  show ?case
  proof
    assume "Seq s\<^sub>1 s\<^sub>2 \<rhd> \<sigma> \<leadsto> None"
    hence "s\<^sub>1 \<rhd> \<sigma> \<leadsto> None \<or> (\<exists>\<sigma>'. s\<^sub>1 \<rhd> \<sigma> \<leadsto> Some \<sigma>' \<and> s\<^sub>2 \<rhd> \<sigma>' \<leadsto> None)"
    by (auto elim: exec.cases)
    with Seq exec_wfs_match
    show False
    by (metis wfs.simps(4))
  qed
qed

lemma exec_wfs_always_match:
  "wfs \<Gamma> s \<Longrightarrow> match \<sigma> \<Gamma> \<Longrightarrow> \<exists>\<sigma>'. s \<rhd> \<sigma> \<leadsto> Some \<sigma>' \<and> match \<sigma>' \<Gamma>"
by (metis exec_always exec_wfs_match exec_wfs_no_error option.exhaust)

text {* The states of a program
are the ones that match the context of the program. *}

definition states :: "prog \<Rightarrow> state set"
where "states p \<equiv> {\<sigma>. match \<sigma> (ctxt p)}"

text {* Executing the body of a well-formed program in a state of the program
always yields some state of the program, and never an error. *}

lemma exec_wfp_no_error:
  "wfp p \<Longrightarrow> \<sigma> \<in> states p \<Longrightarrow> \<not> (body p \<rhd> \<sigma> \<leadsto> None)"
by (metis exec_wfs_no_error mem_Collect_eq states_def wfp_def)

lemma exec_wfp_in_states:
  "wfp p \<Longrightarrow> \<sigma> \<in> states p \<Longrightarrow> body p \<rhd> \<sigma> \<leadsto> Some \<sigma>' \<Longrightarrow> \<sigma>' \<in> states p"
by (metis exec_wfs_match mem_Collect_eq states_def wfp_def)

lemma exec_wfp_always_in_states:
  "wfp p \<Longrightarrow> \<sigma> \<in> states p \<Longrightarrow> \<exists>\<sigma>'. body p \<rhd> \<sigma> \<leadsto> Some \<sigma>' \<and> \<sigma>' \<in> states p"
by (metis exec_always exec_wfp_in_states exec_wfp_no_error option.exhaust)

text {* Program execution can be described
in terms of the trace formalism in~\cite{ClarksonSchneiderHyperproperties}.
Every possible (non-erroneous) execution of a program
can be described by a trace of two states---initial and final.
In this definition,
erroneous executions do not contribute to the traces of a program;
only well-formed programs are of interest,
which, as proved above, never execute erroneously.
Due to non-determinism, there may be traces
with the same initial state and different final states. *}

record trace =
  initial :: state
  final :: state

inductive_set traces :: "prog \<Rightarrow> trace set"
for p::prog
where [intro!]: "
  \<sigma> \<in> states p \<Longrightarrow>
  body p \<rhd> \<sigma> \<leadsto> Some \<sigma>' \<Longrightarrow>
  \<lparr>initial = \<sigma>, final = \<sigma>'\<rparr> \<in> traces p"

text {* The finite traces of a program could be turned into infinite traces
by infinitely stuttering the final state,
obtaining the `executions' defined in~\cite{ClarksonSchneiderHyperproperties}.
However, such infinite traces carry no additional information
compared to the finite traces from which they are derived:
for programs in this language,
the infinite executions of~\cite{ClarksonSchneiderHyperproperties}
are modeled as finite traces of type @{typ trace}. *}

section {* Requirement Specification *}
text {* \label{sec:specificationII} *}

text {* The target program
must process low and high inputs to yield low and high outputs,
according to constraints that involve
both non-determinism and under-specification,
with no information flowing from high inputs to low outputs.%
\footnote{As in \secref{sec:hyper},
`low' and `high' have the usual security meaning,
e.g.\ `low' means `unclassified' and `high' means `classified'.} *}

subsection {* Input/Output Variables *}
text {* \label{sec:specII:iovars} *}

text {* Even though the language defined in \secref{sec:targetII}
has no explicit features for input and output,
an external agent could
write values into some variables,
execute the program body,
and read values from some variables.
Thus, variables may be regarded as holding
inputs (in the initial state) and outputs (in the final state). *}

text {* In the target program, four variables are required:
\begin{itemize}
\item
A variable @{term "''lowIn''"} to hold low inputs.
\item
A variable @{term "''lowOut''"} to hold low outputs.
\item
A variable @{term "''highIn''"} to hold high inputs.
\item
A variable @{term "''highOut''"} to hold high outputs.
\end{itemize}
Other variables are allowed but not required. *}

definition io_vars :: "prog \<Rightarrow> bool"
where "io_vars p \<equiv> ctxt p \<supseteq> {''lowIn'', ''lowOut'', ''highIn'', ''highOut''}"

subsection {* Low Processing *}
text {* \label{sec:specII:lowproc} *}

text {* If the low input is not 0,
the low output must be 1 plus the low input.
That is,
for every possible execution of the program
where the initial state's low input is not 0,
the final state's low output must be 1 plus the low input.
If there are multiple possible final states for the same initial state
due to non-determinism,
all of them must have the same required low output.
Thus, processing of non-0 low inputs must be deterministic. *}

definition low_proc_non0 :: "prog \<Rightarrow> bool"
where "low_proc_non0 p \<equiv>
  \<forall>\<sigma> \<in> states p. \<forall>\<sigma>'.
    the (\<sigma> ''lowIn'') \<noteq> 0 \<and>
    body p \<rhd> \<sigma> \<leadsto> Some \<sigma>' \<longrightarrow>
    the (\<sigma>' ''lowOut'') = the (\<sigma> ''lowIn'') + 1"

text {* If the low input is 0, the low output must be a random value.
That is,
for every possible initial state of the program whose low input is 0,
and for every possible value,
there must exist an execution of the program
whose final state has that value as low output.
Executions corresponding to all possible values must be possible.
Thus, processing of the 0 low input must be non-deterministic. *}

definition low_proc_0 :: "prog \<Rightarrow> bool"
where "low_proc_0 p \<equiv>
  \<forall>\<sigma> \<in> states p. \<forall>u.
    the (\<sigma> ''lowIn'') = 0 \<longrightarrow>
    (\<exists>\<sigma>'. body p \<rhd> \<sigma> \<leadsto> Some \<sigma>' \<and> the (\<sigma>' ''lowOut'') = u)"

subsection {* High Processing *}
text {* \label{sec:specII:highproc} *}

text {* The high output must be
at least as large as the sum of the low and high inputs.
That is,
for every possible execution of the program,
the final state's high output must satisfy the constraint.
If there are multiple possible final states for the same initial state
due to non-determinism,
all of them must contain a high output that satisfies the constraint.
Since different high outputs may satisfy the constraint given the same inputs,
not all the possible final states from a given initial state
must have the same high output.
Thus, processing of high inputs is under-specified;
it can be realized deterministically or non-deterministically. *}

definition high_proc :: "prog \<Rightarrow> bool"
where "high_proc p \<equiv>
  \<forall>\<sigma> \<in> states p. \<forall>\<sigma>'.
    body p \<rhd> \<sigma> \<leadsto> Some \<sigma>' \<longrightarrow>
    the (\<sigma>' ''highOut'') \<ge> the (\<sigma> ''lowIn'') + the (\<sigma> ''highIn'')"

subsection {* All Requirements *}
text {* \label{sec:specII:all} *}

text {* Besides satisfying the above requirements on
input/output variables, low processing, and high processing,
the target program must be well-formed. *}

definition spec\<^sub>0 :: "prog \<Rightarrow> bool"
where "spec\<^sub>0 p \<equiv>
  wfp p \<and> io_vars p \<and> low_proc_non0 p \<and> low_proc_0 p \<and> high_proc p"

subsection {* Generalized Non-Interference *}
text {* \label{sec:specII:GNI} *}

text {* The parameters of the GNI formulation in \secref{sec:hyper}
are instantiated according to the target program under consideration.
In an execution of the program:
\begin{itemize}
\item
The value of the variable @{term "''lowIn''"} in the initial state
is the low input.
\item
The value of the variable @{term "''lowOut''"} in the final state
is the low output.
\item
The value of the variable @{term "''highIn''"} in the initial state
is the high input.
\item
The value of the variable @{term "''highOut''"} in the final state
is the high output.
\end{itemize} *}

definition low_in :: "trace \<Rightarrow> nat"
where "low_in \<tau> \<equiv> the (initial \<tau> ''lowIn'')"

definition low_out :: "trace \<Rightarrow> nat"
where "low_out \<tau> \<equiv> the (final \<tau> ''lowOut'')"

definition high_in :: "trace \<Rightarrow> nat"
where "high_in \<tau> \<equiv> the (initial \<tau> ''highIn'')"

definition high_out :: "trace \<Rightarrow> nat"
where "high_out \<tau> \<equiv> the (final \<tau> ''highOut'')"

interpretation
  Target: generalized_non_interference low_in low_out high_in high_out .

abbreviation GNI :: "trace set \<Rightarrow> bool"
where "GNI \<equiv> Target.GNI"

text {* The requirements in @{const spec\<^sub>0} imply that
the set of traces of the target program satisfies GNI. *}

lemma spec\<^sub>0_GNI:
  "spec\<^sub>0 p \<Longrightarrow> GNI (traces p)"
proof (auto simp: Target.GNI_def)
  assume Spec: "spec\<^sub>0 p"
  -- {* Consider a trace @{text \<tau>\<^sub>1} and its high input: *}
  fix \<tau>\<^sub>1::trace
  def highIn \<equiv> "high_in \<tau>\<^sub>1"
  -- {* Consider a trace @{text \<tau>\<^sub>2},
        its low input and output,
        and its states: *}
  fix \<tau>\<^sub>2::trace
  def lowIn \<equiv> "low_in \<tau>\<^sub>2"
  and lowOut \<equiv> "low_out \<tau>\<^sub>2"
  and \<sigma>\<^sub>2 \<equiv> "initial \<tau>\<^sub>2"
  and \<sigma>\<^sub>2' \<equiv> "final \<tau>\<^sub>2"
  assume "\<tau>\<^sub>2 \<in> traces p"
  hence Exec2: "body p \<rhd> \<sigma>\<^sub>2 \<leadsto> Some \<sigma>\<^sub>2'"
  and State2: "\<sigma>\<^sub>2 \<in> states p"
  by (auto simp: \<sigma>\<^sub>2_def \<sigma>\<^sub>2'_def elim: traces.cases)
  -- {* Construct the initial state of the witness trace @{text \<tau>\<^sub>3}: *}
  def \<sigma>\<^sub>3 \<equiv> "\<sigma>\<^sub>2 (''highIn'' \<mapsto> highIn)"
  hence LowIn3: "the (\<sigma>\<^sub>3 ''lowIn'') = lowIn"
  and HighIn3: "the (\<sigma>\<^sub>3 ''highIn'') = highIn"
  by (auto simp: lowIn_def low_in_def \<sigma>\<^sub>2_def)
  from Spec State2
  have State3: "\<sigma>\<^sub>3 \<in> states p"
  by (auto simp: \<sigma>\<^sub>3_def states_def match_def spec\<^sub>0_def io_vars_def)
  -- {* Construct the final state of @{text \<tau>\<^sub>3}, and @{text \<tau>\<^sub>3},
        by cases on @{term lowIn}: *}
  show
    "\<exists>\<tau>\<^sub>3 \<in> traces p.
      high_in \<tau>\<^sub>3 = high_in \<tau>\<^sub>1 \<and>
      low_in \<tau>\<^sub>3 = low_in \<tau>\<^sub>2 \<and>
      low_out \<tau>\<^sub>3 = low_out \<tau>\<^sub>2"
  proof (cases lowIn)
    case 0
    -- {* Use as final state the one required by @{term low_proc_0}: *}
    with Spec State3 LowIn3
    obtain \<sigma>\<^sub>3'
    where Exec3: "body p \<rhd> \<sigma>\<^sub>3 \<leadsto> Some \<sigma>\<^sub>3'"
    and LowOut3: "the (\<sigma>\<^sub>3' ''lowOut'') = lowOut"
    by (auto simp: spec\<^sub>0_def low_proc_0_def)
    -- {* Construct @{text \<tau>\<^sub>3} from its initial and final states: *}
    def \<tau>\<^sub>3 \<equiv> "\<lparr>initial = \<sigma>\<^sub>3, final = \<sigma>\<^sub>3'\<rparr>"
    with Exec3 State3
    have Trace3: "\<tau>\<^sub>3 \<in> traces p"
    by auto
    have "high_in \<tau>\<^sub>3 = high_in \<tau>\<^sub>1"
    and "low_in \<tau>\<^sub>3 = low_in \<tau>\<^sub>2"
    and "low_out \<tau>\<^sub>3 = low_out \<tau>\<^sub>2"
    by (auto simp:
      high_in_def low_in_def low_out_def
      \<tau>\<^sub>3_def \<sigma>\<^sub>2_def \<sigma>\<^sub>2'_def
      highIn_def lowIn_def lowOut_def
      LowIn3 HighIn3 LowOut3)
    with Trace3
    show ?thesis
    by auto
  next
    case Suc
    hence Not0: "lowIn \<noteq> 0"
    by auto
    -- {* Derive @{term \<tau>\<^sub>2}'s low output from @{term low_proc_non0}: *}
    with Exec2 State2 Spec
    have LowOut2: "lowOut = lowIn + 1"
    by (auto simp:
      spec\<^sub>0_def low_proc_non0_def \<sigma>\<^sub>2_def \<sigma>\<^sub>2'_def
      low_in_def low_out_def lowIn_def lowOut_def)
    -- {* Use any final state for @{text \<tau>\<^sub>3}: *}
    from Spec
    have "wfp p"
    by (auto simp: spec\<^sub>0_def)
    with State3
    obtain \<sigma>\<^sub>3'
    where Exec3: "body p \<rhd> \<sigma>\<^sub>3 \<leadsto> Some \<sigma>\<^sub>3'"
    by (metis exec_always exec_wfp_no_error not_Some_eq)
    -- {* Derive @{text \<tau>\<^sub>3}'s low output from @{term low_proc_non0}: *}
    with State3 Spec Not0
    have LowOut3: "the (\<sigma>\<^sub>3' ''lowOut'') = lowIn + 1"
    by (auto simp: spec\<^sub>0_def low_proc_non0_def LowIn3)
    -- {* Construct @{text \<tau>\<^sub>3} from its initial and final states: *}
    def \<tau>\<^sub>3 \<equiv> "\<lparr>initial = \<sigma>\<^sub>3, final = \<sigma>\<^sub>3'\<rparr>"
    with Exec3 State3
    have Trace3: "\<tau>\<^sub>3 \<in> traces p"
    by auto
    have "high_in \<tau>\<^sub>3 = high_in \<tau>\<^sub>1"
    and "low_in \<tau>\<^sub>3 = low_in \<tau>\<^sub>2"
    and "low_out \<tau>\<^sub>3 = low_out \<tau>\<^sub>2"
    by (auto simp:
      high_in_def low_in_def low_out_def
      \<tau>\<^sub>3_def \<sigma>\<^sub>3_def \<sigma>\<^sub>2_def
      LowOut2 LowOut3
      highIn_def lowOut_def[unfolded low_out_def, symmetric])
    with Trace3
    show ?thesis
    by auto
  qed
qed

text {* Since GNI is implied by @{const spec\<^sub>0}
and since every pop-refinement of @{const spec\<^sub>0} implies @{const spec\<^sub>0},
GNI is preserved through every pop-refinement of @{const spec\<^sub>0}.
Pop-refinement differs from the popular notion of refinement
as inclusion of sets of traces (e.g.~\cite{AbadiLamportRefinement}),
which does not preserve GNI~\cite{ClarksonSchneiderHyperproperties}. *}

section {* Stepwise Refinement *}
text {* \label{sec:refinementII} *}

text {* The remark at the beginning of \secref{sec:refinementI}
applies here as well:
the following sequence of refinement steps
may be overkill for obtaining an implementation of @{const spec\<^sub>0},
but illustrates concepts that should apply to more complex cases. *}

subsection {* Step 1 *}

text {* \label{sec:refII:stepI} *}

text {* The program needs no other variables
besides those prescribed by @{const io_vars}.
Thus, @{const io_vars} is refined to a stronger condition
that constrains the program to contain exactly those variables,
in a certain order. *}

abbreviation vars\<^sub>0 :: "name list"
where "vars\<^sub>0 \<equiv> [''lowIn'', ''lowOut'', ''highIn'', ''highOut'']"
-- {* The order of the variables in the list is arbitrary. *}

lemma vars\<^sub>0_correct:
  "vars p = vars\<^sub>0 \<Longrightarrow> io_vars p"
by (auto simp: io_vars_def ctxt_def)

text {* The refinement of @{const io_vars}
reduces the well-formedness of the program
to the well-formedness of the body. *}

abbreviation \<Gamma>\<^sub>0 :: ctxt
where "\<Gamma>\<^sub>0 \<equiv> {''lowIn'', ''lowOut'', ''highIn'', ''highOut''}"

lemma reduce_wf_prog_to_body:
  "vars p = vars\<^sub>0 \<Longrightarrow> wfp p \<longleftrightarrow> wfs \<Gamma>\<^sub>0 (body p)"
by (auto simp: wfp_def ctxt_def)

text {* The refinement of @{const io_vars}
induces a simplification of the processing constraints:
since the context of the program is now defined to be @{const \<Gamma>\<^sub>0},
the @{term "\<sigma> \<in> states p"} conditions are replaced
with @{term "match \<sigma> \<Gamma>\<^sub>0"} conditions. *}

definition low_proc_non0\<^sub>1 :: "prog \<Rightarrow> bool"
where "low_proc_non0\<^sub>1 p \<equiv>
  \<forall>\<sigma> \<sigma>'.
    match \<sigma> \<Gamma>\<^sub>0 \<and>
    the (\<sigma> ''lowIn'') \<noteq> 0 \<and>
    body p \<rhd> \<sigma> \<leadsto> Some \<sigma>' \<longrightarrow>
    the (\<sigma>' ''lowOut'') = the (\<sigma> ''lowIn'') + 1"

lemma low_proc_non0\<^sub>1_correct:
  "vars p = vars\<^sub>0 \<Longrightarrow> low_proc_non0\<^sub>1 p \<longleftrightarrow> low_proc_non0 p"
by (auto simp: low_proc_non0\<^sub>1_def low_proc_non0_def states_def ctxt_def)

definition low_proc_0\<^sub>1 :: "prog \<Rightarrow> bool"
where "low_proc_0\<^sub>1 p \<equiv>
  \<forall>\<sigma> u.
    match \<sigma> \<Gamma>\<^sub>0 \<and>
    the (\<sigma> ''lowIn'') = 0 \<longrightarrow>
    (\<exists>\<sigma>'. body p \<rhd> \<sigma> \<leadsto> Some \<sigma>' \<and> the (\<sigma>' ''lowOut'') = u)"

lemma low_proc_0\<^sub>1_correct:
  "vars p = vars\<^sub>0 \<Longrightarrow> low_proc_0\<^sub>1 p \<longleftrightarrow> low_proc_0 p"
by (auto simp: low_proc_0\<^sub>1_def low_proc_0_def states_def ctxt_def)

definition high_proc\<^sub>1 :: "prog \<Rightarrow> bool"
where "high_proc\<^sub>1 p \<equiv>
  \<forall>\<sigma> \<sigma>'.
    match \<sigma> \<Gamma>\<^sub>0 \<and>
    body p \<rhd> \<sigma> \<leadsto> Some \<sigma>' \<longrightarrow>
    the (\<sigma>' ''highOut'') \<ge> the (\<sigma> ''lowIn'') + the (\<sigma> ''highIn'')"

lemma high_proc\<^sub>1_correct:
  "vars p = vars\<^sub>0 \<Longrightarrow> high_proc\<^sub>1 p \<longleftrightarrow> high_proc p"
by (auto simp: high_proc\<^sub>1_def high_proc_def states_def ctxt_def)

text {* The refinement of @{const spec\<^sub>0} consists of
the refinement of @{const io_vars} and of the simplified constraints. *}

definition spec\<^sub>1 :: "prog \<Rightarrow> bool"
where "spec\<^sub>1 p \<equiv>
  vars p = vars\<^sub>0 \<and>
  wfs \<Gamma>\<^sub>0 (body p) \<and>
  low_proc_non0\<^sub>1 p \<and>
  low_proc_0\<^sub>1 p \<and>
  high_proc\<^sub>1 p"

lemma step_1_correct:
  "spec\<^sub>1 p \<Longrightarrow> spec\<^sub>0 p"
by (auto simp:
  spec\<^sub>1_def spec\<^sub>0_def
  vars\<^sub>0_correct
  reduce_wf_prog_to_body
  low_proc_non0\<^sub>1_correct
  low_proc_0\<^sub>1_correct
  high_proc\<^sub>1_correct)

subsection {* Step 2 *}

text {* \label{sec:refII:stepII} *}

text {* The body of the target program is split
into two sequential statements---%
one to compute the low output and one to compute the high output. *}

definition body_split :: "prog \<Rightarrow> stmt \<Rightarrow> stmt \<Rightarrow> bool"
where "body_split p s\<^sub>L s\<^sub>H \<equiv> body p = Seq s\<^sub>L s\<^sub>H"
-- {* The order of the two statements in the body is arbitrary. *}

text {* The splitting reduces the well-formedness of the body
to the well-formedness of the two statements. *}

lemma reduce_wf_body_to_stmts:
  "body_split p s\<^sub>L s\<^sub>H \<Longrightarrow> wfs \<Gamma>\<^sub>0 (body p) \<longleftrightarrow> wfs \<Gamma>\<^sub>0 s\<^sub>L \<and> wfs \<Gamma>\<^sub>0 s\<^sub>H"
by (auto simp: body_split_def)

text {* The processing predicates over programs
are refined to predicates over the statements @{term s\<^sub>L} and @{term s\<^sub>H}.
Since @{term s\<^sub>H} follows @{term s\<^sub>L}:
\begin{itemize}
\item
@{term s\<^sub>H} must not change the low output, which is computed by @{term s\<^sub>L}.
\item
@{term s\<^sub>L} must not change the low and high inputs, which are used by @{term s\<^sub>H}.
\end{itemize} *}

definition low_proc_non0\<^sub>2 :: "stmt \<Rightarrow> bool"
where "low_proc_non0\<^sub>2 s\<^sub>L \<equiv>
  \<forall>\<sigma> \<sigma>'.
    match \<sigma> \<Gamma>\<^sub>0 \<and>
    the (\<sigma> ''lowIn'') \<noteq> 0 \<and>
    s\<^sub>L \<rhd> \<sigma> \<leadsto> Some \<sigma>' \<longrightarrow>
    the (\<sigma>' ''lowOut'') = the (\<sigma> ''lowIn'') + 1"

definition low_proc_0\<^sub>2 :: "stmt \<Rightarrow> bool"
where "low_proc_0\<^sub>2 s\<^sub>L \<equiv>
  \<forall>\<sigma> u.
    match \<sigma> \<Gamma>\<^sub>0 \<and>
    the (\<sigma> ''lowIn'') = 0 \<longrightarrow>
    (\<exists>\<sigma>'. s\<^sub>L \<rhd> \<sigma> \<leadsto> Some \<sigma>' \<and> the (\<sigma>' ''lowOut'') = u)"

definition low_proc_no_input_change :: "stmt \<Rightarrow> bool"
where "low_proc_no_input_change s\<^sub>L \<equiv>
  \<forall>\<sigma> \<sigma>'.
    match \<sigma> \<Gamma>\<^sub>0 \<and>
    s\<^sub>L \<rhd> \<sigma> \<leadsto> Some \<sigma>' \<longrightarrow>
    the (\<sigma>' ''lowIn'') = the (\<sigma> ''lowIn'') \<and>
    the (\<sigma>' ''highIn'') = the (\<sigma> ''highIn'')"

definition high_proc\<^sub>2 :: "stmt \<Rightarrow> bool"
where "high_proc\<^sub>2 s\<^sub>H \<equiv>
  \<forall>\<sigma> \<sigma>'.
    match \<sigma> \<Gamma>\<^sub>0 \<and>
    s\<^sub>H \<rhd> \<sigma> \<leadsto> Some \<sigma>' \<longrightarrow>
    the (\<sigma>' ''highOut'') \<ge> the (\<sigma> ''lowIn'') + the (\<sigma> ''highIn'')"

definition high_proc_no_low_output_change :: "stmt \<Rightarrow> bool"
where "high_proc_no_low_output_change s\<^sub>H \<equiv>
  \<forall>\<sigma> \<sigma>'.
    match \<sigma> \<Gamma>\<^sub>0 \<and>
    s\<^sub>H \<rhd> \<sigma> \<leadsto> Some \<sigma>' \<longrightarrow>
    the (\<sigma>' ''lowOut'') = the (\<sigma> ''lowOut'')"

lemma proc\<^sub>2_correct:
  assumes Body: "body_split p s\<^sub>L s\<^sub>H"
  assumes WfLow: "wfs \<Gamma>\<^sub>0 s\<^sub>L"
  assumes WfHigh: "wfs \<Gamma>\<^sub>0 s\<^sub>H"
  assumes LowNon0: "low_proc_non0\<^sub>2 s\<^sub>L"
  assumes Low0: "low_proc_0\<^sub>2 s\<^sub>L"
  assumes LowSame: "low_proc_no_input_change s\<^sub>L"
  assumes High: "high_proc\<^sub>2 s\<^sub>H"
  assumes HighSame: "high_proc_no_low_output_change s\<^sub>H"
  shows "low_proc_non0\<^sub>1 p \<and> low_proc_0\<^sub>1 p \<and> high_proc\<^sub>1 p"
proof auto
  -- {* Processing of non-0 low input: *}
  case goal1
  show ?case
  proof (auto simp: low_proc_non0\<^sub>1_def)
    fix \<sigma> \<sigma>'
    assume "body p \<rhd> \<sigma> \<leadsto> Some \<sigma>'"
    with Body
    obtain \<sigma>\<^sub>i
    where ExecLow: "s\<^sub>L \<rhd> \<sigma> \<leadsto> Some \<sigma>\<^sub>i"
    and ExecHigh: "s\<^sub>H \<rhd> \<sigma>\<^sub>i \<leadsto> Some \<sigma>'"
    by (auto simp: body_split_def elim: exec.cases)
    assume Non0: "the (\<sigma> ''lowIn'') > 0"
    assume InitMatch: "match \<sigma> \<Gamma>\<^sub>0"
    with ExecLow WfLow
    have "match \<sigma>\<^sub>i \<Gamma>\<^sub>0"
    by (auto simp: exec_wfs_match)
    with Non0 InitMatch ExecLow ExecHigh HighSame LowNon0
    show "the (\<sigma>' ''lowOut'') = Suc (the (\<sigma> ''lowIn''))"
    unfolding high_proc_no_low_output_change_def low_proc_non0\<^sub>2_def
    by (metis Suc_eq_plus1 gr_implies_not0)
  qed
next
  -- {* Processing of 0 low input: *}
  case goal2
  show ?case
  proof (auto simp: low_proc_0\<^sub>1_def)
    fix \<sigma> u
    assume InitMatch: "match \<sigma> \<Gamma>\<^sub>0"
    and "the (\<sigma> ''lowIn'') = 0"
    with Low0
    obtain \<sigma>\<^sub>i
    where ExecLow: "s\<^sub>L \<rhd> \<sigma> \<leadsto> Some \<sigma>\<^sub>i"
    and LowOut: "the (\<sigma>\<^sub>i ''lowOut'') = u"
    by (auto simp: low_proc_0\<^sub>2_def)
    from InitMatch ExecLow WfLow
    have MidMatch: "match \<sigma>\<^sub>i \<Gamma>\<^sub>0"
    by (auto simp: exec_wfs_match)
    with WfHigh
    obtain \<sigma>'
    where ExecHigh: "s\<^sub>H \<rhd> \<sigma>\<^sub>i \<leadsto> Some \<sigma>'"
    by (metis exec_wfs_always_match)
    with HighSame MidMatch
    have "the (\<sigma>' ''lowOut'') = the (\<sigma>\<^sub>i ''lowOut'')"
    by (auto simp: high_proc_no_low_output_change_def)
    with ExecLow ExecHigh Body LowOut
    show "\<exists>\<sigma>'. body p \<rhd> \<sigma> \<leadsto> Some \<sigma>' \<and> the (\<sigma>' ''lowOut'') = u"
    by (metis (hide_lams, no_types) ExecSeqOK body_split_def)
  qed
next
  -- {* Processing of high input: *}
  case goal3
  show ?case
  proof (auto simp: high_proc\<^sub>1_def)
    fix \<sigma> \<sigma>'
    assume "body p \<rhd> \<sigma> \<leadsto> Some \<sigma>'"
    with Body
    obtain \<sigma>\<^sub>i
    where ExecLow: "s\<^sub>L \<rhd> \<sigma> \<leadsto> Some \<sigma>\<^sub>i"
    and ExecHigh: "s\<^sub>H \<rhd> \<sigma>\<^sub>i \<leadsto> Some \<sigma>'"
    by (auto simp: body_split_def elim: exec.cases)
    assume InitMatch: "match \<sigma> \<Gamma>\<^sub>0"
    with ExecLow WfLow
    have "match \<sigma>\<^sub>i \<Gamma>\<^sub>0"
    by (auto simp: exec_wfs_match)
    with InitMatch ExecLow ExecHigh LowSame High
    show "the (\<sigma>' ''highOut'') \<ge> the (\<sigma> ''lowIn'') + the (\<sigma> ''highIn'')"
    unfolding low_proc_no_input_change_def high_proc\<^sub>2_def
    by metis
  qed
qed

text {* The refined specification consists of
the splitting of the body into the two sequential statements
and the refined well-formedness and processing constraints. *}

definition spec\<^sub>2 :: "prog \<Rightarrow> bool"
where "spec\<^sub>2 p \<equiv>
  vars p = vars\<^sub>0 \<and>
  (\<exists>s\<^sub>L s\<^sub>H.
    body_split p s\<^sub>L s\<^sub>H \<and>
    wfs \<Gamma>\<^sub>0 s\<^sub>L \<and>
    wfs \<Gamma>\<^sub>0 s\<^sub>H \<and>
    low_proc_non0\<^sub>2 s\<^sub>L \<and>
    low_proc_0\<^sub>2 s\<^sub>L \<and>
    low_proc_no_input_change s\<^sub>L \<and>
    high_proc\<^sub>2 s\<^sub>H \<and>
    high_proc_no_low_output_change s\<^sub>H)"

lemma step_2_correct:
  "spec\<^sub>2 p \<Longrightarrow> spec\<^sub>1 p"
by (auto simp: spec\<^sub>2_def spec\<^sub>1_def reduce_wf_body_to_stmts proc\<^sub>2_correct)

subsection {* Step 3 *}

text {* \label{sec:refII:stepIII} *}

text {* The processing constraints
@{const low_proc_non0\<^sub>2} and @{const low_proc_0\<^sub>2} on @{term s\<^sub>L}
suggest the use of a conditional that
randomizes @{term "''lowOut''"} if @{term "''lowIn''"} is 0,
and stores 1 plus @{term "''lowIn''"} into @{term "''lowOut''"} otherwise. *}

abbreviation s\<^sub>L\<^sub>0 :: stmt
where "s\<^sub>L\<^sub>0 \<equiv>
  IfEq
    (Var ''lowIn'')
    (Const 0)
    (Random ''lowOut'')
    (Assign ''lowOut'' (Add (Var ''lowIn'') (Const 1)))"

lemma wfs_s\<^sub>L\<^sub>0:
  "wfs \<Gamma>\<^sub>0 s\<^sub>L\<^sub>0"
by auto

lemma low_proc_non0_s\<^sub>L\<^sub>0:
  "low_proc_non0\<^sub>2 s\<^sub>L\<^sub>0"
proof (auto simp only: low_proc_non0\<^sub>2_def)
  fix \<sigma> \<sigma>'
  assume Match: "match \<sigma> \<Gamma>\<^sub>0"
  assume "s\<^sub>L\<^sub>0 \<rhd> \<sigma> \<leadsto> Some \<sigma>'"
  and "the (\<sigma> ''lowIn'') > 0"
  hence "(Assign ''lowOut'' (Add (Var ''lowIn'') (Const 1))) \<rhd> \<sigma> \<leadsto> Some \<sigma>'"
  by (auto elim: exec.cases)
  hence "\<sigma>' = \<sigma> (''lowOut'' \<mapsto> the (eval \<sigma> (Add (Var ''lowIn'') (Const 1))))"
  by (auto elim: exec.cases)
  with Match
  show "the (\<sigma>' ''lowOut'') = the (\<sigma> ''lowIn'') + 1"
  by (auto simp: match_def add_opt_def split: option.split)
qed

lemma low_proc_0_s\<^sub>L\<^sub>0:
  "low_proc_0\<^sub>2 s\<^sub>L\<^sub>0"
proof (auto simp only: low_proc_0\<^sub>2_def)
  fix \<sigma> u
  assume Match: "match \<sigma> \<Gamma>\<^sub>0"
  and "the (\<sigma> ''lowIn'') = 0"
  hence LowIn0: "\<sigma> ''lowIn'' = Some 0"
  by (cases "\<sigma> ''lowIn''", auto simp: match_def)
  from Match
  have "''lowOut'' \<in> dom \<sigma>"
  by (auto simp: match_def)
  then obtain \<sigma>'
  where ExecRand: "Random ''lowOut'' \<rhd> \<sigma> \<leadsto> Some \<sigma>'"
  and "\<sigma>' = \<sigma> (''lowOut'' \<mapsto> u)"
  by (auto intro: ExecRandomOK)
  hence "the (\<sigma>' ''lowOut'') = u"
  by auto
  with ExecRand LowIn0
  show "\<exists>\<sigma>'. s\<^sub>L\<^sub>0 \<rhd> \<sigma> \<leadsto> Some \<sigma>' \<and> the (\<sigma>' ''lowOut'') = u"
  by (metis ExecCondTrue eval.simps(1) eval.simps(2))
qed

lemma low_proc_no_input_change_s\<^sub>L\<^sub>0:
  "low_proc_no_input_change s\<^sub>L\<^sub>0"
proof (unfold low_proc_no_input_change_def, clarify)
  fix \<sigma> \<sigma>'
  assume "s\<^sub>L\<^sub>0 \<rhd> \<sigma> \<leadsto> Some \<sigma>'"
  hence "
    Random ''lowOut'' \<rhd> \<sigma> \<leadsto> Some \<sigma>' \<or>
    Assign ''lowOut'' (Add (Var ''lowIn'') (Const 1)) \<rhd> \<sigma> \<leadsto> Some \<sigma>'"
  by (auto elim: exec.cases)
  thus "
    the (\<sigma>' ''lowIn'') = the (\<sigma> ''lowIn'') \<and>
    the (\<sigma>' ''highIn'') = the (\<sigma> ''highIn'')"
  by (auto elim: exec.cases)
qed

text {* The refined specification is obtained
by simplification using the definition of @{term s\<^sub>L}. *}

definition spec\<^sub>3 :: "prog \<Rightarrow> bool"
where "spec\<^sub>3 p \<equiv>
  vars p = vars\<^sub>0 \<and>
  (\<exists>s\<^sub>H.
    body_split p s\<^sub>L\<^sub>0 s\<^sub>H \<and>
    wfs \<Gamma>\<^sub>0 s\<^sub>H \<and>
    high_proc\<^sub>2 s\<^sub>H \<and>
    high_proc_no_low_output_change s\<^sub>H)"

lemma step_3_correct:
  "spec\<^sub>3 p \<Longrightarrow> spec\<^sub>2 p"
unfolding spec\<^sub>3_def spec\<^sub>2_def
by (metis
  wfs_s\<^sub>L\<^sub>0 low_proc_non0_s\<^sub>L\<^sub>0 low_proc_0_s\<^sub>L\<^sub>0 low_proc_no_input_change_s\<^sub>L\<^sub>0)

text {* The non-determinism required by @{const low_proc_0}
cannot be pop-refined away.
In particular, @{term s\<^sub>L} cannot be defined
to copy the high input to the low output when the low input is 0,
which would lead to a program that does not satisfy GNI. *}

subsection {* Step 4 *}

text {* \label{sec:refII:stepIV} *}

text {* The processing constraint @{const high_proc\<^sub>2} on @{term s\<^sub>H}
can be satisfied in different ways.
A simple way is to pick the sum of the low and high inputs:
@{const high_proc\<^sub>2} is refined by replacing the inequality with an equality. *}

definition high_proc\<^sub>4 :: "stmt \<Rightarrow> bool"
where "high_proc\<^sub>4 s\<^sub>H \<equiv>
  \<forall>\<sigma> \<sigma>'.
    match \<sigma> \<Gamma>\<^sub>0 \<and>
    s\<^sub>H \<rhd> \<sigma> \<leadsto> Some \<sigma>' \<longrightarrow>
    the (\<sigma>' ''highOut'') = the (\<sigma> ''lowIn'') + the (\<sigma> ''highIn'')"

lemma high_proc\<^sub>4_correct:
  "high_proc\<^sub>4 s\<^sub>H \<Longrightarrow> high_proc\<^sub>2 s\<^sub>H"
by (auto simp: high_proc\<^sub>4_def high_proc\<^sub>2_def)

text {* The refined specification is obtained
by substituting the refined processing constraint on @{term s\<^sub>H}. *}

definition spec\<^sub>4 :: "prog \<Rightarrow> bool"
where "spec\<^sub>4 p \<equiv>
  vars p = vars\<^sub>0 \<and>
  (\<exists>s\<^sub>H.
    body_split p s\<^sub>L\<^sub>0 s\<^sub>H \<and>
    wfs \<Gamma>\<^sub>0 s\<^sub>H \<and>
    high_proc\<^sub>4 s\<^sub>H \<and>
    high_proc_no_low_output_change s\<^sub>H)"

lemma step_4_correct:
  "spec\<^sub>4 p \<Longrightarrow> spec\<^sub>3 p"
by (auto simp: spec\<^sub>4_def spec\<^sub>3_def high_proc\<^sub>4_correct)

subsection {* Step 5 *}

text {* \label{sec:refII:stepV} *}

text {* The refined processing constraint @{const high_proc\<^sub>4} on @{term s\<^sub>H}
suggest the use of an assignment that
stores the sum of @{term "''lowIn''"} and @{term "''highIn''"}
into @{term "''highOut''"}. *}

abbreviation s\<^sub>H\<^sub>0 :: stmt
where "s\<^sub>H\<^sub>0 \<equiv> Assign ''highOut'' (Add (Var ''lowIn'') (Var ''highIn''))"

lemma wfs_s\<^sub>H\<^sub>0:
  "wfs \<Gamma>\<^sub>0 s\<^sub>H\<^sub>0"
by auto

lemma high_proc\<^sub>4_s\<^sub>H\<^sub>0:
  "high_proc\<^sub>4 s\<^sub>H\<^sub>0"
proof (auto simp: high_proc\<^sub>4_def)
  fix \<sigma> \<sigma>'
  assume Match: "match \<sigma> \<Gamma>\<^sub>0"
  assume "s\<^sub>H\<^sub>0 \<rhd> \<sigma> \<leadsto> Some \<sigma>'"
  hence "
    \<sigma>' = \<sigma> (''highOut'' \<mapsto> the (eval \<sigma> (Add (Var ''lowIn'') (Var ''highIn''))))"
  by (auto elim: exec.cases)
  with Match
  show "the (\<sigma>' ''highOut'') = the (\<sigma> ''lowIn'') + the (\<sigma> ''highIn'')"
  by (auto simp: match_def add_opt_def split: option.split)
qed

lemma high_proc_no_low_output_change_s\<^sub>H\<^sub>0:
  "high_proc_no_low_output_change s\<^sub>H\<^sub>0"
by (auto simp: high_proc_no_low_output_change_def elim: exec.cases)

text {* The refined specification is obtained
by simplification using the definition of @{term s\<^sub>H}. *}

definition spec\<^sub>5 :: "prog \<Rightarrow> bool"
where "spec\<^sub>5 p \<equiv> vars p = vars\<^sub>0 \<and> body_split p s\<^sub>L\<^sub>0 s\<^sub>H\<^sub>0"

lemma step_5_correct:
  "spec\<^sub>5 p \<Longrightarrow> spec\<^sub>4 p"
unfolding spec\<^sub>5_def spec\<^sub>4_def
by (metis wfs_s\<^sub>H\<^sub>0 high_proc\<^sub>4_s\<^sub>H\<^sub>0 high_proc_no_low_output_change_s\<^sub>H\<^sub>0)

subsection {* Step 6 *}

text {* \label{sec:refII:stepVI} *}

text {* @{const spec\<^sub>5}, which defines the variables and the body,
is refined to characterize a unique program in explicit syntactic form. *}

abbreviation p\<^sub>0 :: prog
where "p\<^sub>0 \<equiv> \<lparr>vars = vars\<^sub>0, body = Seq s\<^sub>L\<^sub>0 s\<^sub>H\<^sub>0\<rparr>"

definition spec\<^sub>6 :: "prog \<Rightarrow> bool"
where "spec\<^sub>6 p \<equiv> p = p\<^sub>0"

lemma step_6_correct:
  "spec\<^sub>6 p \<Longrightarrow> spec\<^sub>5 p"
by (auto simp: spec\<^sub>6_def spec\<^sub>5_def body_split_def)

text {* The program satisfies @{const spec\<^sub>0} by construction.
The program witnesses the consistency of the requirements,
i.e.\ the fact that @{const spec\<^sub>0} is not always false. *}

lemma p\<^sub>0_sat_spec\<^sub>0:
  "spec\<^sub>0 p\<^sub>0"
by (metis
 step_1_correct
 step_2_correct
 step_3_correct
 step_4_correct
 step_5_correct
 step_6_correct
 spec\<^sub>6_def)

text {* From @{const p\<^sub>0}, the program text
\begin{verbatim}
  prog {
    vars {
      lowIn
      lowOut
      highIn
      highOut
    }
    body {
      if (lowIn == 0) {
        randomize lowOut;
      } else {
        lowOut = lowIn + 1;
      }
      highOut = lowIn + highIn;
    }
  }
\end{verbatim}
is easily obtained. *}

end %invisible


section\<open>Model of the negation of the Continuum Hypothesis\<close>

theory Not_CH
  imports
    Cardinal_Preservation
begin

text\<open>We are taking advantage that the poset of finite functions is absolute,
and thus we work with the unrelativized \<^term>\<open>Fn\<close>. But it would have been more
appropriate to do the following using the relative \<^term>\<open>Fn_rel\<close>. As it turns
out, the present theory was developed prior to having \<^term>\<open>Fn\<close> relativized!

We also note that \<^term>\<open>Fn(\<omega>,\<kappa>\<times>\<omega>,2)\<close> is separative, i.e. each \<^term>\<open>X \<in> Fn(\<omega>,\<kappa>\<times>\<omega>,2)\<close>
has two incompatible extensions; therefore we may recover part of our previous theorem
@{thm [source] extensions_of_ctms_ZF}. But that result also included the possibility
of not having $\AC$ in the ground model, which would not be sensible in a context
where the cardinality of the continuum is under discussion. It is also the case that
@{thm [source] extensions_of_ctms_ZF} was historically our first formalized result
(with a different proof) that showed the forcing machinery had all of its elements
in place.\<close>

abbreviation
  Add_subs :: "i \<Rightarrow> i" where
  "Add_subs(\<kappa>) \<equiv> Fn(\<omega>,\<kappa>\<times>\<omega>,2)"

abbreviation
  Add_le :: "i \<Rightarrow> i" where
  "Add_le(\<kappa>) \<equiv> Fnle(\<omega>,\<kappa> \<times> \<omega>,2)"

lemma (in M_aleph) Aleph_rel2_closed[intro,simp]: "M(\<aleph>\<^bsub>2\<^esub>\<^bsup>M\<^esup>)"
  using nat_into_Ord by simp

locale M_master = M_cohen + M_library +
  assumes
    UN_lepoll_assumptions:
    "M(A) \<Longrightarrow> M(b) \<Longrightarrow> M(f) \<Longrightarrow> M(A') \<Longrightarrow> separation(M, \<lambda>y. \<exists>x\<in>A'. y = \<langle>x, \<mu> i. x\<in>if_range_F_else_F((`)(A), b, f, i)\<rangle>)"

subsection\<open>Non-absolute concepts between extensions\<close>

sublocale M_master \<subseteq> M_Pi_replacement
  by unfold_locales

locale M_master_sub = M_master + N:M_aleph N for N +
  assumes
    M_imp_N: "M(x) \<Longrightarrow> N(x)" and
    Ord_iff: "Ord(x) \<Longrightarrow> M(x) \<longleftrightarrow> N(x)"

sublocale M_master_sub \<subseteq> M_N_Perm
  using M_imp_N by unfold_locales

context M_master_sub
begin

lemma cardinal_rel_le_cardinal_rel: "M(X) \<Longrightarrow> |X|\<^bsup>N\<^esup> \<le> |X|\<^bsup>M\<^esup>"
  using M_imp_N N.lepoll_rel_cardinal_rel_le[OF lepoll_rel_transfer Card_rel_is_Ord]
    cardinal_rel_eqpoll_rel[THEN eqpoll_rel_sym, THEN eqpoll_rel_imp_lepoll_rel]
  by simp

lemma Aleph_rel_sub_closed: "Ord(\<alpha>) \<Longrightarrow> M(\<alpha>) \<Longrightarrow> N(\<aleph>\<^bsub>\<alpha>\<^esub>\<^bsup>M\<^esup>)"
  using Ord_iff[THEN iffD1, OF Card_rel_Aleph_rel[THEN Card_rel_is_Ord]]
  by simp

lemma Card_rel_imp_Card_rel: "Card\<^bsup>N\<^esup>(\<kappa>) \<Longrightarrow> M(\<kappa>) \<Longrightarrow> Card\<^bsup>M\<^esup>(\<kappa>)"
  using N.Card_rel_is_Ord[of \<kappa>] M_imp_N Ord_cardinal_rel_le[of \<kappa>]
    cardinal_rel_le_cardinal_rel[of \<kappa>] le_anti_sym
  unfolding Card_rel_def by auto

lemma csucc_rel_le_csucc_rel:
  assumes "Ord(\<kappa>)" "M(\<kappa>)"
  shows "(\<kappa>\<^sup>+)\<^bsup>M\<^esup> \<le> (\<kappa>\<^sup>+)\<^bsup>N\<^esup>"
proof -
  note assms
  moreover from this
  have "N(L) \<and> Card\<^bsup>N\<^esup>(L) \<and> \<kappa> < L \<Longrightarrow> M(L) \<and> Card\<^bsup>M\<^esup>(L) \<and> \<kappa> < L"
    (is "?P(L) \<Longrightarrow> ?Q(L)") for L
    using M_imp_N Ord_iff[THEN iffD2, of L] N.Card_rel_is_Ord lt_Ord
      Card_rel_imp_Card_rel by auto
  moreover from assms
  have "N((\<kappa>\<^sup>+)\<^bsup>N\<^esup>)" "Card\<^bsup>N\<^esup>((\<kappa>\<^sup>+)\<^bsup>N\<^esup>)" "\<kappa> < (\<kappa>\<^sup>+)\<^bsup>N\<^esup>"
    using N.lt_csucc_rel[of \<kappa>] N.Card_rel_csucc_rel[of \<kappa>] M_imp_N by simp_all
  ultimately
  show ?thesis
    using M_imp_N Least_antitone[of _ ?P ?Q] unfolding csucc_rel_def by blast
qed

lemma Aleph_rel_le_Aleph_rel: "Ord(\<alpha>) \<Longrightarrow> M(\<alpha>) \<Longrightarrow> \<aleph>\<^bsub>\<alpha>\<^esub>\<^bsup>M\<^esup> \<le> \<aleph>\<^bsub>\<alpha>\<^esub>\<^bsup>N\<^esup>"
proof (induct rule:trans_induct3)
  case 0
  then
  show ?case
    using Aleph_rel_zero N.Aleph_rel_zero by simp
next
  case (succ x)
  then
  have "\<aleph>\<^bsub>x\<^esub>\<^bsup>M\<^esup> \<le> \<aleph>\<^bsub>x\<^esub>\<^bsup>N\<^esup>" "Ord(x)" "M(x)" by simp_all
  moreover from this
  have "(\<aleph>\<^bsub>x\<^esub>\<^bsup>M\<^esup>\<^sup>+)\<^bsup>M\<^esup> \<le> (\<aleph>\<^bsub>x\<^esub>\<^bsup>N\<^esup>\<^sup>+)\<^bsup>M\<^esup>"
    using M_imp_N Ord_iff[THEN iffD2, OF N.Card_rel_is_Ord]
    by (intro csucc_rel_le_mono) simp_all
  moreover from calculation
  have "(\<aleph>\<^bsub>x\<^esub>\<^bsup>N\<^esup>\<^sup>+)\<^bsup>M\<^esup> \<le> (\<aleph>\<^bsub>x\<^esub>\<^bsup>N\<^esup>\<^sup>+)\<^bsup>N\<^esup>"
    using M_imp_N N.Card_rel_is_Ord Ord_iff[THEN iffD2, OF N.Card_rel_is_Ord]
    by (intro csucc_rel_le_csucc_rel) auto
  ultimately
  show ?case
    using M_imp_N Aleph_rel_succ N.Aleph_rel_succ csucc_rel_le_csucc_rel
      le_trans by auto
next
  case (limit x)
  then
  show ?case
    using M_imp_N Aleph_rel_limit N.Aleph_rel_limit
    by simp (blast dest: transM intro!:le_implies_UN_le_UN)
qed

end \<comment> \<open>\<^locale>\<open>M_master_sub\<close>\<close>

lemmas (in M_ZF2_trans) sep_instances =
  separation_ifrangeF_body separation_ifrangeF_body2 separation_ifrangeF_body3
  separation_ifrangeF_body4 separation_ifrangeF_body5 separation_ifrangeF_body6
  separation_ifrangeF_body7 separation_cardinal_rel_lesspoll_rel
  separation_is_dcwit_body separation_cdltgamma separation_cdeqgamma

lemmas (in M_ZF2_trans) repl_instances = lam_replacement_inj_rel

sublocale M_ZFC2_ground_notCH_trans \<subseteq> M_master "##M"
  using replacement_trans_apply_image
  by unfold_locales (simp_all add:repl_instances sep_instances del:setclass_iff
      add: transrec_replacement_def wfrec_replacement_def)

sublocale M_ZFC2_trans \<subseteq> M_Pi_replacement "##M"
  by unfold_locales

subsection\<open>Cohen forcing is ccc\<close>

context M_ctm2_AC
begin

lemma ccc_Add_subs_Aleph_2: "ccc\<^bsup>M\<^esup>(Add_subs(\<aleph>\<^bsub>2\<^esub>\<^bsup>M\<^esup>),Add_le(\<aleph>\<^bsub>2\<^esub>\<^bsup>M\<^esup>))"
proof -
  interpret M_add_reals "##M" "\<aleph>\<^bsub>2\<^esub>\<^bsup>M\<^esup> \<times> \<omega>"
    by unfold_locales blast
  show ?thesis
    using ccc_rel_Fn_nat by fast
qed

end \<comment> \<open>\<^locale>\<open>M_ctm2_AC\<close>\<close>

sublocale G_generic3_AC \<subseteq> M_master_sub "##M" "##(M[G])"
  using M_subset_MG[OF one_in_G] generic Ord_MG_iff
  by unfold_locales auto

lemma (in M_trans) mem_F_bound4:
  fixes F A
  defines "F \<equiv> (`)"
  shows "x\<in>F(A,c) \<Longrightarrow> c \<in> (range(f) \<union> domain(A))"
  using apply_0 unfolding F_def
  by (cases "M(c)", auto simp:F_def)

lemma (in M_trans) mem_F_bound5:
  fixes F A
  defines "F \<equiv> \<lambda>_ x. A`x "
  shows "x\<in>F(A,c) \<Longrightarrow> c \<in> (range(f) \<union> domain(A))"
  using apply_0 unfolding F_def
  by (cases "M(c)", auto simp:F_def drSR_Y_def dC_F_def)

sublocale M_ctm2_AC \<subseteq> M_replacement_lepoll "##M" "(`)"
  using UN_lepoll_assumptions lam_replacement_apply lam_replacement_inj_rel
    mem_F_bound4 apply_0 lam_replacement_minimum
  unfolding lepoll_assumptions_defs
proof (unfold_locales,
    rule_tac [3] lam_Least_assumption_general[where U=domain, OF _ mem_F_bound4], simp_all)
  fix A i x
  assume "A \<in> M" "x \<in> M" "x \<in> A ` i"
  then
  show "i \<in> M"
    using apply_0[of i A] transM[of _ "domain(A)", simplified]
    by force
qed

context G_generic3_AC begin

context
  includes G_generic1_lemmas
begin

lemma G_in_MG: "G \<in> M[G]"
  using G_in_Gen_Ext
  by blast

lemma ccc_preserves_Aleph_succ:
  assumes "ccc\<^bsup>M\<^esup>(\<bbbP>,leq)" "Ord(z)" "z \<in> M"
  shows "Card\<^bsup>M[G]\<^esup>(\<aleph>\<^bsub>succ(z)\<^esub>\<^bsup>M\<^esup>)"
proof (rule ccontr)
  assume "\<not> Card\<^bsup>M[G]\<^esup>(\<aleph>\<^bsub>succ(z)\<^esub>\<^bsup>M\<^esup>)"
  moreover
  note \<open>z \<in> M\<close> \<open>Ord(z)\<close>
  moreover from this
  have "Ord(\<aleph>\<^bsub>succ(z)\<^esub>\<^bsup>M\<^esup>)"
    using Card_rel_is_Ord by fastforce
  ultimately
  obtain \<alpha> f where "\<alpha> < \<aleph>\<^bsub>succ(z)\<^esub>\<^bsup>M\<^esup>" "f \<in> surj\<^bsup>M[G]\<^esup>(\<alpha>, \<aleph>\<^bsub>succ(z)\<^esub>\<^bsup>M\<^esup>)"
    using ext.lt_surj_rel_empty_imp_Card_rel M_subset_MG[OF one_in_G]
    by force
  moreover from this and \<open>z\<in>M\<close> \<open>Ord(z)\<close>
  have "\<alpha> \<in> M" "f \<in> M[G]"
    using ext.trans_surj_rel_closed
    by (auto dest:transM ext.transM dest!:ltD)
  moreover
  note \<open>ccc\<^bsup>M\<^esup>(\<bbbP>,leq)\<close> \<open>z\<in>M\<close>
  ultimately
  obtain F where "F:\<alpha>\<rightarrow>Pow\<^bsup>M\<^esup>(\<aleph>\<^bsub>succ(z)\<^esub>\<^bsup>M\<^esup>)" "\<forall>\<beta>\<in>\<alpha>. f`\<beta> \<in> F`\<beta>" "\<forall>\<beta>\<in>\<alpha>. |F`\<beta>|\<^bsup>M\<^esup> \<le> \<omega>"
    "F \<in> M"
    using ccc_fun_approximation_lemma[of \<alpha> "\<aleph>\<^bsub>succ(z)\<^esub>\<^bsup>M\<^esup>" f]
      ext.mem_surj_abs[of f \<alpha> "\<aleph>\<^bsub>succ(z)\<^esub>\<^bsup>M\<^esup>"] \<open>Ord(z)\<close>
      surj_is_fun[of f \<alpha> "\<aleph>\<^bsub>succ(z)\<^esub>\<^bsup>M\<^esup>"] by auto
  then
  have "\<beta> \<in> \<alpha> \<Longrightarrow> |F`\<beta>|\<^bsup>M\<^esup> \<le> \<aleph>\<^bsub>0\<^esub>\<^bsup>M\<^esup>" for \<beta>
    using Aleph_rel_zero by simp
  have "w \<in> F ` x \<Longrightarrow> x \<in> M" for w x
  proof -
    fix w x
    assume "w \<in> F`x"
    then
    have "x \<in> domain(F)"
      using apply_0 by auto
    with \<open>F:\<alpha>\<rightarrow>Pow\<^bsup>M\<^esup>(\<aleph>\<^bsub>succ(z)\<^esub>\<^bsup>M\<^esup>)\<close> \<open>\<alpha> \<in> M\<close>
    show "x \<in> M" using domain_of_fun
      by (auto dest:transM)
  qed
  with \<open>\<alpha> \<in> M\<close> \<open>F:\<alpha>\<rightarrow>Pow\<^bsup>M\<^esup>(\<aleph>\<^bsub>succ(z)\<^esub>\<^bsup>M\<^esup>)\<close> \<open>F\<in>M\<close>
  interpret M_cardinal_UN_lepoll "##M" "\<lambda>\<beta>. F`\<beta>" \<alpha>
    using UN_lepoll_assumptions lepoll_assumptions
      lam_replacement_apply lam_replacement_inj_rel lam_replacement_minimum
  proof (unfold_locales, auto dest:transM simp del:if_range_F_else_F_def)
    fix f b
    assume "b\<in>M" "f\<in>M"
    with \<open>F\<in>M\<close>
    show "lam_replacement(##M, \<lambda>x. \<mu> i. x \<in> if_range_F_else_F((`)(F), b, f, i))"
      using UN_lepoll_assumptions mem_F_bound5
      by (rule_tac lam_Least_assumption_general[where U="domain", OF _ mem_F_bound5])
        simp_all
  qed
  from \<open>\<alpha> < \<aleph>\<^bsub>succ(z)\<^esub>\<^bsup>M\<^esup>\<close> \<open>\<alpha> \<in> M\<close> \<open>Ord(z)\<close> \<open>z\<in>M\<close>
  have "\<alpha> \<lesssim>\<^bsup>M\<^esup> \<aleph>\<^bsub>z\<^esub>\<^bsup>M\<^esup>"
    using
      cardinal_rel_lt_csucc_rel_iff[of "\<aleph>\<^bsub>z\<^esub>\<^bsup>M\<^esup>" \<alpha>]
      le_Card_rel_iff[of "\<aleph>\<^bsub>z\<^esub>\<^bsup>M\<^esup>" \<alpha>]
      Aleph_rel_succ[of z] Card_rel_lt_iff[of \<alpha> "\<aleph>\<^bsub>succ(z)\<^esub>\<^bsup>M\<^esup>"]
      lt_Ord[of \<alpha> "\<aleph>\<^bsub>succ(z)\<^esub>\<^bsup>M\<^esup>"]
      Card_rel_csucc_rel[of "\<aleph>\<^bsub>z\<^esub>\<^bsup>M\<^esup>"]
      Card_rel_Aleph_rel[THEN Card_rel_is_Ord]
    by simp
  with \<open>\<alpha> < \<aleph>\<^bsub>succ(z)\<^esub>\<^bsup>M\<^esup>\<close> \<open>\<forall>\<beta>\<in>\<alpha>. |F`\<beta>|\<^bsup>M\<^esup> \<le> \<omega>\<close> \<open>\<alpha> \<in> M\<close> assms
  have "|\<Union>\<beta>\<in>\<alpha>. F`\<beta>|\<^bsup>M\<^esup> \<le> \<aleph>\<^bsub>z\<^esub>\<^bsup>M\<^esup>"
    using InfCard_rel_Aleph_rel[of z] Aleph_rel_zero
      subset_imp_lepoll_rel[THEN lepoll_rel_imp_cardinal_rel_le,
        of "\<Union>\<beta>\<in>\<alpha>. F`\<beta>" "\<aleph>\<^bsub>z\<^esub>\<^bsup>M\<^esup>"] Aleph_rel_succ
      Aleph_rel_increasing[THEN leI, THEN [2] le_trans, of _ 0 z]
      Ord_0_lt_iff[THEN iffD1, of z]
    by (cases "0<z"; rule_tac lepoll_rel_imp_cardinal_rel_UN_le) (auto, force)
  moreover
  note \<open>z\<in>M\<close> \<open>Ord(z)\<close>
  moreover from \<open>\<forall>\<beta>\<in>\<alpha>. f`\<beta> \<in> F`\<beta>\<close> \<open>f \<in> surj\<^bsup>M[G]\<^esup>(\<alpha>, \<aleph>\<^bsub>succ(z)\<^esub>\<^bsup>M\<^esup>)\<close>
    \<open>\<alpha> \<in> M\<close> \<open>f \<in> M[G]\<close> and this
  have "\<aleph>\<^bsub>succ(z)\<^esub>\<^bsup>M\<^esup> \<subseteq> (\<Union>\<beta>\<in>\<alpha>. F`\<beta>)"
    using ext.mem_surj_abs by (force simp add:surj_def)
  moreover from \<open>F \<in> M\<close> \<open>\<alpha> \<in> M\<close>
  have "(\<Union>x\<in>\<alpha>. F ` x) \<in> M"
    using j.B_replacement
    by (intro Union_closed[simplified] RepFun_closed[simplified])
      (auto dest:transM)
  ultimately
  have "\<aleph>\<^bsub>succ(z)\<^esub>\<^bsup>M\<^esup> \<le> \<aleph>\<^bsub>z\<^esub>\<^bsup>M\<^esup>"
    using subset_imp_le_cardinal_rel[of "\<aleph>\<^bsub>succ(z)\<^esub>\<^bsup>M\<^esup>" "\<Union>\<beta>\<in>\<alpha>. F`\<beta>"]
      le_trans by auto
  with assms
  show "False"
    using Aleph_rel_increasing not_le_iff_lt[of "\<aleph>\<^bsub>succ(z)\<^esub>\<^bsup>M\<^esup>" "\<aleph>\<^bsub>z\<^esub>\<^bsup>M\<^esup>"]
      Card_rel_Aleph_rel[THEN Card_rel_is_Ord]
    by auto
qed

end \<comment> \<open>bundle G\_generic1\_lemmas\<close>

end \<comment> \<open>\<^locale>\<open>G_generic3_AC\<close>\<close>

context M_ctm1
begin

abbreviation
  Add :: "i" where
  "Add \<equiv> Fn(\<omega>, \<aleph>\<^bsub>2\<^esub>\<^bsup>M\<^esup> \<times> \<omega>, 2)"

end \<comment> \<open>\<^locale>\<open>M_ctm1\<close>\<close>

locale add_generic3 = G_generic3_AC "Fn(\<omega>, \<aleph>\<^bsub>2\<^esub>\<^bsup>##M\<^esup> \<times> \<omega>, 2)" "Fnle(\<omega>, \<aleph>\<^bsub>2\<^esub>\<^bsup>##M\<^esup> \<times> \<omega>, 2)" 0

sublocale add_generic3 \<subseteq> cohen_data \<omega> "\<aleph>\<^bsub>2\<^esub>\<^bsup>M\<^esup> \<times> \<omega>" 2 by unfold_locales auto

context add_generic3
begin

notation Leq (infixl "\<preceq>" 50)
notation Incompatible (infixl "\<bottom>" 50)

lemma Add_subs_preserves_Aleph_succ: "Ord(z) \<Longrightarrow> z\<in>M \<Longrightarrow> Card\<^bsup>M[G]\<^esup>(\<aleph>\<^bsub>succ(z)\<^esub>\<^bsup>M\<^esup>)"
  using ccc_preserves_Aleph_succ ccc_Add_subs_Aleph_2
  by auto

lemma Aleph_rel_nats_MG_eq_Aleph_rel_nats_M:
  includes G_generic1_lemmas
  assumes "z \<in> \<omega>"
  shows "\<aleph>\<^bsub>z\<^esub>\<^bsup>M[G]\<^esup> = \<aleph>\<^bsub>z\<^esub>\<^bsup>M\<^esup>"
  using assms
proof (induct)
  case 0
  show ?case
    by(rule trans[OF ext.Aleph_rel_zero Aleph_rel_zero[symmetric]])
next
  case (succ z)
  then
  have "\<aleph>\<^bsub>succ(z)\<^esub>\<^bsup>M\<^esup> \<le> \<aleph>\<^bsub>succ(z)\<^esub>\<^bsup>M[G]\<^esup>"
    using Aleph_rel_le_Aleph_rel nat_into_M by simp
  moreover from \<open>z \<in> \<omega>\<close>
  have "\<aleph>\<^bsub>z\<^esub>\<^bsup>M\<^esup> \<in> M[G]" "\<aleph>\<^bsub>succ(z)\<^esub>\<^bsup>M\<^esup> \<in> M[G]"
    using nat_into_M by simp_all
  moreover from this and \<open>\<aleph>\<^bsub>z\<^esub>\<^bsup>M[G]\<^esup> = \<aleph>\<^bsub>z\<^esub>\<^bsup>M\<^esup>\<close> \<open>z \<in> \<omega>\<close>
  have "\<aleph>\<^bsub>succ(z)\<^esub>\<^bsup>M[G]\<^esup> \<le> \<aleph>\<^bsub>succ(z)\<^esub>\<^bsup>M\<^esup>"
    using ext.Aleph_rel_succ nat_into_M
      Add_subs_preserves_Aleph_succ[THEN ext.csucc_rel_le, of z]
      Aleph_rel_increasing[of z "succ(z)"]
    by simp
  ultimately
  show ?case using le_anti_sym by blast
qed

abbreviation
  f_G :: "i" (\<open>f\<^bsub>G\<^esub>\<close>) where
  "f\<^bsub>G\<^esub> \<equiv> \<Union>G"

abbreviation
  dom_dense :: "i \<Rightarrow> i" where
  "dom_dense(x) \<equiv> {p \<in> Add . x \<in> domain(p) }"

declare (in M_ctm2_AC) Fn_nat_closed[simplified setclass_iff, simp, intro]
declare (in M_ctm2_AC) Fnle_nat_closed[simp del, rule del,
    simplified setclass_iff, simp, intro]
declare (in M_ctm2_AC) cexp_rel_closed[simplified setclass_iff, simp, intro]
declare (in G_generic3_AC) ext.cexp_rel_closed[simplified setclass_iff, simp, intro]

lemma dom_dense_closed[intro,simp]: "x \<in> \<aleph>\<^bsub>2\<^esub>\<^bsup>M\<^esup> \<times> \<omega> \<Longrightarrow> dom_dense(x) \<in> M"
  using separation_in_domain[of x] nat_into_M
  by (rule_tac separation_closed[simplified], blast dest:transM) simp

lemma domain_f_G: assumes "x \<in> \<aleph>\<^bsub>2\<^esub>\<^bsup>M\<^esup>" "y \<in> \<omega>"
  shows "\<langle>x, y\<rangle> \<in> domain(f\<^bsub>G\<^esub>)"
proof -
  from assms
  have "Add = Fn\<^bsup>M\<^esup>(\<omega>,\<aleph>\<^bsub>2\<^esub>\<^bsup>M\<^esup>\<times>\<omega>,2)"
    using Fn_nat_abs by auto
  moreover from this
  have "Fnle(\<omega>,\<aleph>\<^bsub>2\<^esub>\<^bsup>M\<^esup>\<times>\<omega>,2) = Fnle\<^bsup>M\<^esup>(\<omega>,\<aleph>\<^bsub>2\<^esub>\<^bsup>M\<^esup>\<times>\<omega>,2)"
    unfolding Fnle_rel_def Fnle_def by auto
  moreover from calculation assms
  have "dense(dom_dense(\<langle>x, y\<rangle>))"
    using dense_dom_dense[of "\<langle>x,y\<rangle>" "\<aleph>\<^bsub>2\<^esub>\<^bsup>M\<^esup>\<times>\<omega>" \<omega>  2] InfCard_rel_nat
    unfolding dense_def by auto
  with assms
  obtain p where "p\<in>dom_dense(\<langle>x, y\<rangle>)" "p\<in>G"
    using M_generic_denseD[of "dom_dense(\<langle>x, y\<rangle>)"]
    by auto
  then
  show "\<langle>x, y\<rangle> \<in> domain(f\<^bsub>G\<^esub>)" by blast
qed

lemma f_G_funtype:
  includes G_generic1_lemmas
  shows "f\<^bsub>G\<^esub> : \<aleph>\<^bsub>2\<^esub>\<^bsup>M\<^esup> \<times> \<omega> \<rightarrow> 2"
  using generic domain_f_G Pi_iff Un_filter_is_function generic
    subset_trans[OF filter_subset_notion Fn_nat_subset_Pow]
  by force

lemma inj_dense_closed[intro,simp]:
  "w \<in> \<aleph>\<^bsub>2\<^esub>\<^bsup>M\<^esup> \<Longrightarrow> x \<in> \<aleph>\<^bsub>2\<^esub>\<^bsup>M\<^esup> \<Longrightarrow> inj_dense(\<aleph>\<^bsub>2\<^esub>\<^bsup>M\<^esup>,2,w,x) \<in> M"
  using transM[OF _ Aleph_rel2_closed] separation_conj separation_bex
    lam_replacement_product
    separation_in lam_replacement_fst lam_replacement_snd lam_replacement_constant
    lam_replacement_hcomp[OF lam_replacement_snd lam_replacement_restrict']
    separation_bex separation_conj
  by simp

lemma Aleph_rel2_new_reals:
  assumes "w \<in> \<aleph>\<^bsub>2\<^esub>\<^bsup>M\<^esup>" "x \<in> \<aleph>\<^bsub>2\<^esub>\<^bsup>M\<^esup>" "w \<noteq> x"
  shows "(\<lambda>n\<in>\<omega>. f\<^bsub>G\<^esub> ` \<langle>w, n\<rangle>) \<noteq> (\<lambda>n\<in>\<omega>. f\<^bsub>G\<^esub> ` \<langle>x, n\<rangle>)"
proof -
  have "0\<in>2" by auto
  with assms
  have "dense(inj_dense(\<aleph>\<^bsub>2\<^esub>\<^bsup>M\<^esup>,2,w,x))"
    unfolding dense_def using dense_inj_dense by auto
  with assms
  obtain p where "p\<in>inj_dense(\<aleph>\<^bsub>2\<^esub>\<^bsup>M\<^esup>,2,w,x)" "p\<in>G"
    using M_generic_denseD[of "inj_dense(\<aleph>\<^bsub>2\<^esub>\<^bsup>M\<^esup>,2,w,x)"]
    by blast
  then
  obtain n where "n \<in> \<omega>" "\<langle>\<langle>w, n\<rangle>, 1\<rangle> \<in> p" "\<langle>\<langle>x, n\<rangle>, 0\<rangle> \<in> p"
    by blast
  moreover from this and \<open>p\<in>G\<close>
  have "\<langle>\<langle>w, n\<rangle>, 1\<rangle> \<in> f\<^bsub>G\<^esub>" "\<langle>\<langle>x, n\<rangle>, 0\<rangle> \<in> f\<^bsub>G\<^esub>" by auto
  moreover from calculation
  have "f\<^bsub>G\<^esub> ` \<langle>w, n\<rangle> = 1" "f\<^bsub>G\<^esub> ` \<langle>x, n\<rangle> = 0"
    using f_G_funtype apply_equality
    by auto
  ultimately
  have "(\<lambda>n\<in>\<omega>. f\<^bsub>G\<^esub> ` \<langle>w, n\<rangle>) ` n \<noteq> (\<lambda>n\<in>\<omega>. f\<^bsub>G\<^esub> ` \<langle>x, n\<rangle>) ` n"
    by simp
  then
  show ?thesis by fastforce
qed

definition
  h_G :: "i" (\<open>h\<^bsub>G\<^esub>\<close>) where
  "h\<^bsub>G\<^esub> \<equiv> \<lambda>\<alpha>\<in>\<aleph>\<^bsub>2\<^esub>\<^bsup>M\<^esup>. \<lambda>n\<in>\<omega>. f\<^bsub>G\<^esub>`\<langle>\<alpha>,n\<rangle>"

lemma h_G_in_MG[simp]:
  includes G_generic1_lemmas
  shows "h\<^bsub>G\<^esub> \<in> M[G]"
  using ext.curry_closed[unfolded curry_def] G_in_MG
  unfolding h_G_def
  by simp

lemma h_G_inj_Aleph_rel2_reals: "h\<^bsub>G\<^esub> \<in> inj\<^bsup>M[G]\<^esup>(\<aleph>\<^bsub>2\<^esub>\<^bsup>M\<^esup>, \<omega> \<rightarrow>\<^bsup>M[G]\<^esup> 2)"
  using Aleph_rel_sub_closed f_G_funtype G_in_MG Aleph_rel_sub_closed
    ext.curry_rel_exp[unfolded curry_def] ext.curry_closed[unfolded curry_def]
    ext.mem_function_space_rel_abs
  by (intro ext.mem_inj_abs[THEN iffD2],simp_all)
      (auto simp: inj_def h_G_def dest:Aleph_rel2_new_reals)

lemma Aleph2_extension_le_continuum_rel:
  includes G_generic1_lemmas
  shows "\<aleph>\<^bsub>2\<^esub>\<^bsup>M[G]\<^esup> \<le> 2\<^bsup>\<up>\<aleph>\<^bsub>0\<^esub>\<^bsup>M[G]\<^esup>,M[G]\<^esup>"
proof -
  have "\<aleph>\<^bsub>2\<^esub>\<^bsup>M[G]\<^esup> \<lesssim>\<^bsup>M[G]\<^esup> \<omega> \<rightarrow>\<^bsup>M[G]\<^esup> 2"
    using ext.def_lepoll_rel[of "\<aleph>\<^bsub>2\<^esub>\<^bsup>M\<^esup>" "\<omega> \<rightarrow>\<^bsup>M[G]\<^esup> 2"]
      h_G_inj_Aleph_rel2_reals Aleph_rel_nats_MG_eq_Aleph_rel_nats_M
    by auto
  moreover from calculation
  have "\<aleph>\<^bsub>2\<^esub>\<^bsup>M[G]\<^esup> \<lesssim>\<^bsup>M[G]\<^esup> |\<omega> \<rightarrow>\<^bsup>M[G]\<^esup> 2|\<^bsup>M[G]\<^esup>"
    using ext.lepoll_rel_imp_lepoll_rel_cardinal_rel by simp
  ultimately
  have "|\<aleph>\<^bsub>2\<^esub>\<^bsup>M[G]\<^esup>|\<^bsup>M[G]\<^esup> \<le> 2\<^bsup>\<up>\<aleph>\<^bsub>0\<^esub>\<^bsup>M[G]\<^esup>,M[G]\<^esup>"
    using ext.lepoll_rel_imp_cardinal_rel_le[of "\<aleph>\<^bsub>2\<^esub>\<^bsup>M[G]\<^esup>" "\<omega> \<rightarrow>\<^bsup>M[G]\<^esup> 2",
        OF _ _ ext.function_space_rel_closed]
      ext.Aleph_rel_zero
    unfolding cexp_rel_def by simp
  then
  show "\<aleph>\<^bsub>2\<^esub>\<^bsup>M[G]\<^esup> \<le> 2\<^bsup>\<up>\<aleph>\<^bsub>0\<^esub>\<^bsup>M[G]\<^esup>,M[G]\<^esup>"
    using ext.Card_rel_Aleph_rel[of 2, THEN ext.Card_rel_cardinal_rel_eq]
    by simp
qed

lemma Aleph_rel_lt_continuum_rel: "\<aleph>\<^bsub>1\<^esub>\<^bsup>M[G]\<^esup> < 2\<^bsup>\<up>\<aleph>\<^bsub>0\<^esub>\<^bsup>M[G]\<^esup>,M[G]\<^esup>"
  using Aleph2_extension_le_continuum_rel
    ext.Aleph_rel_increasing[of 1 2] le_trans by auto

corollary not_CH: "\<aleph>\<^bsub>1\<^esub>\<^bsup>M[G]\<^esup> \<noteq> 2\<^bsup>\<up>\<aleph>\<^bsub>0\<^esub>\<^bsup>M[G]\<^esup>,M[G]\<^esup>"
  using Aleph_rel_lt_continuum_rel by auto

end \<comment> \<open>\<^locale>\<open>add_generic3\<close>\<close>

subsection\<open>Models of fragments of $\ZFC + \neg \CH$\<close>

definition
  ContHyp :: "o" where
  "ContHyp \<equiv> \<aleph>\<^bsub>1\<^esub> = 2\<^bsup>\<up>\<aleph>\<^bsub>0\<^esub>\<^esup>"

relativize functional "ContHyp" "ContHyp_rel"
notation ContHyp_rel (\<open>CH\<^bsup>_\<^esup>\<close>)
relationalize "ContHyp_rel" "is_ContHyp"

context M_ZF_library
begin

is_iff_rel for "ContHyp"
  using is_cexp_iff is_Aleph_iff[of 0] is_Aleph_iff[of 1]
  unfolding is_ContHyp_def ContHyp_rel_def
  by (auto simp del:setclass_iff) (rule rexI[of _ _ M, OF _ nonempty], auto)

end \<comment> \<open>\<^locale>\<open>M_ZF_library\<close>\<close>

synthesize "is_ContHyp" from_definition assuming "nonempty"
arity_theorem for "is_ContHyp_fm"

notation is_ContHyp_fm (\<open>\<cdot>CH\<cdot>\<close>)

theorem ctm_of_not_CH:
  assumes
    "M \<approx> \<omega>" "Transset(M)" "M \<Turnstile> ZC \<union> {\<cdot>Replacement(p)\<cdot> . p \<in> overhead_notCH}"
    "\<Phi> \<subseteq> formula" "M \<Turnstile> { \<cdot>Replacement(ground_repl_fm(\<phi>))\<cdot> . \<phi> \<in> \<Phi>}"
  shows
    "\<exists>N.
      M \<subseteq> N \<and> N \<approx> \<omega> \<and> Transset(N) \<and> N \<Turnstile> ZC \<union> {\<cdot>\<not>\<cdot>CH\<cdot>\<cdot>} \<union> { \<cdot>Replacement(\<phi>)\<cdot> . \<phi> \<in> \<Phi>} \<and>
      (\<forall>\<alpha>. Ord(\<alpha>) \<longrightarrow> (\<alpha> \<in> M \<longleftrightarrow> \<alpha> \<in> N))"
proof -
  from \<open>M \<Turnstile> ZC \<union> {\<cdot>Replacement(p)\<cdot> . p \<in> overhead_notCH}\<close>
  interpret M_ZFC3 M
    using M_satT_overhead_imp_M_ZF3 unfolding overhead_notCH_def by force
  from \<open>M \<Turnstile> ZC \<union> {\<cdot>Replacement(p)\<cdot> . p \<in> overhead_notCH}\<close> \<open>Transset(M)\<close>
  interpret M_ZF_ground_notCH_trans M
    using M_satT_imp_M_ZF_ground_notCH_trans
    unfolding ZC_def by auto
  from \<open>M \<approx> \<omega>\<close>
  obtain enum where "enum \<in> bij(\<omega>,M)"
    using eqpoll_sym unfolding eqpoll_def by blast
  then
  interpret M_ctm3_AC M enum by unfold_locales
  interpret cohen_data \<omega> "\<aleph>\<^bsub>2\<^esub>\<^bsup>M\<^esup> \<times> \<omega>" 2 by unfold_locales auto
  have "Add \<in> M" "Add_le(\<aleph>\<^bsub>2\<^esub>\<^bsup>M\<^esup>) \<in> M"
    using nat_into_M Aleph_rel_closed M_nat cartprod_closed Fn_nat_closed Fnle_nat_closed
    by simp_all
  then
  interpret forcing_data1 "Add" "Add_le(\<aleph>\<^bsub>2\<^esub>\<^bsup>M\<^esup>)" 0 M enum
    by unfold_locales simp_all
  obtain G where "M_generic(G)"
    using generic_filter_existence[OF one_in_P]
    by auto
  moreover from this
  interpret add_generic3 M enum G by unfold_locales
  have "\<not> (\<aleph>\<^bsub>1\<^esub>\<^bsup>M[G]\<^esup> = 2\<^bsup>\<up>\<aleph>\<^bsub>0\<^esub>\<^bsup>M[G]\<^esup>,M[G]\<^esup>)"
    using not_CH .
  then
  have "M[G], [] \<Turnstile> \<cdot>\<not>\<cdot>CH\<cdot>\<cdot>"
    using ext.is_ContHyp_iff
    by (simp add:ContHyp_rel_def)
  then
  have "M[G] \<Turnstile> ZC \<union> {\<cdot>\<not>\<cdot>CH\<cdot>\<cdot>}"
    using ext.M_satT_ZC by auto
  moreover
  have "Transset(M[G])" using Transset_MG .
  moreover
  have "M \<subseteq> M[G]" using M_subset_MG[OF one_in_G] generic by simp
  moreover
  note \<open>M \<Turnstile> { \<cdot>Replacement(ground_repl_fm(\<phi>))\<cdot> . \<phi> \<in> \<Phi>}\<close> \<open>\<Phi> \<subseteq> formula\<close>
  ultimately
  show ?thesis
    using Ord_MG_iff MG_eqpoll_nat satT_ground_repl_fm_imp_satT_ZF_replacement_fm[of \<Phi>]
    by (rule_tac x="M[G]" in exI, blast)
qed

lemma ZF_replacement_overhead_sub_ZFC: "{\<cdot>Replacement(p)\<cdot> . p \<in> overhead} \<subseteq> ZFC"
  using overhead_type unfolding ZFC_def ZF_def ZF_schemes_def by auto

lemma ZF_replacement_overhead_notCH_sub_ZFC: "{\<cdot>Replacement(p)\<cdot> . p \<in> overhead_notCH} \<subseteq> ZFC"
  using overhead_notCH_type unfolding ZFC_def ZF_def ZF_schemes_def by auto

lemma ZF_replacement_overhead_CH_sub_ZFC: "{\<cdot>Replacement(p)\<cdot> . p \<in> overhead_CH} \<subseteq> ZFC"
  using overhead_CH_type unfolding ZFC_def ZF_def ZF_schemes_def by auto

corollary ctm_ZFC_imp_ctm_not_CH:
  assumes
    "M \<approx> \<omega>" "Transset(M)" "M \<Turnstile> ZFC"
  shows
    "\<exists>N.
      M \<subseteq> N \<and> N \<approx> \<omega> \<and> Transset(N) \<and> N \<Turnstile> ZFC \<union> {\<cdot>\<not>\<cdot>CH\<cdot>\<cdot>} \<and>
      (\<forall>\<alpha>. Ord(\<alpha>) \<longrightarrow> (\<alpha> \<in> M \<longleftrightarrow> \<alpha> \<in> N))"
proof-
  from assms
  have "\<exists>N.
      M \<subseteq> N \<and>
        N \<approx> \<omega> \<and>
        Transset(N) \<and>
        N \<Turnstile> ZC \<and> N \<Turnstile> {\<cdot>\<not>\<cdot>CH\<cdot>\<cdot>} \<and> N \<Turnstile> {\<cdot>Replacement(x)\<cdot> . x \<in> formula} \<and> (\<forall>\<alpha>. Ord(\<alpha>) \<longrightarrow> \<alpha> \<in> M \<longleftrightarrow> \<alpha> \<in> N)"
    using ctm_of_not_CH[of M formula] satT_ZFC_imp_satT_ZC[of M]
      satT_mono[OF _ ground_repl_fm_sub_ZFC, of M]
      satT_mono[OF _ ZF_replacement_overhead_notCH_sub_ZFC, of M]
      satT_mono[OF _ ZF_replacement_fms_sub_ZFC, of M]
    by (simp add: satT_Un_iff)
  then
  obtain N where "N \<Turnstile> ZC" "N \<Turnstile> {\<cdot>\<not>\<cdot>CH\<cdot>\<cdot>}" "N \<Turnstile> {\<cdot>Replacement(x)\<cdot> . x \<in> formula}"
    "M \<subseteq> N" "N \<approx> \<omega>" "Transset(N)" "(\<forall>\<alpha>. Ord(\<alpha>) \<longrightarrow> \<alpha> \<in> M \<longleftrightarrow> \<alpha> \<in> N)"
    by auto
  moreover from this
  have "N \<Turnstile> ZFC"
    using satT_ZC_ZF_replacement_imp_satT_ZFC
    by auto
  moreover from this and \<open>N \<Turnstile> {\<cdot>\<not>\<cdot>CH\<cdot>\<cdot>}\<close>
  have "N \<Turnstile> ZFC \<union> {\<cdot>\<not>\<cdot>CH\<cdot>\<cdot>}"
    by auto
  ultimately
  show ?thesis by auto
qed

end


section \<open>Refinement and Simulation\<close>

theory Refinement
imports Denotational_Semantics Circus_Syntax
begin

subsection \<open>Definitions\<close>

text \<open>In the following, data (state) simulation and functional backwards simulation
 are defined. The simulation is defined as a function $S$, that corresponds to a state
 abstraction function.\<close>

definition "Simul S b = extend (make (ok b) (wait b) (tr b) (ref b)) (S (more b))"

definition
Simulation::"('\<theta>::ev_eq,'\<sigma>) action \<Rightarrow> ('\<sigma>1 \<Rightarrow> '\<sigma>) \<Rightarrow> ('\<theta>, '\<sigma>1) action \<Rightarrow> bool" ("_ \<preceq>_ _")
where
"A \<preceq>S B \<equiv> \<forall> a b. (relation_of B) (a, b) \<longrightarrow> (relation_of A) (Simul S a, Simul S b)"

subsection \<open>Proofs\<close>

text \<open>In order to simplify refinement proofs, some general refinement laws are
defined to deal with the refinement of Circus actions at operators level and not at UTP level.
Using these laws, and exploiting the advantages of a shallow embedding, the automated proof of
refinement becomes surprisingly simple.\<close>

lemma Stop_Sim: "Stop \<preceq>S Stop"
by (auto simp: Simulation_def relation_of_Stop rp_defs design_defs Simul_def alpha_rp.defs
         split: cond_splits)

lemma Skip_Sim: "Skip \<preceq>S Skip"
by (auto simp: Simulation_def relation_of_Skip design_def rp_defs Simul_def alpha_rp.defs
         split: cond_splits)

lemma Chaos_Sim: "Chaos \<preceq>S Chaos"
by (auto simp: Simulation_def relation_of_Chaos rp_defs design_defs Simul_def alpha_rp.defs
         split: cond_splits)

lemma Ndet_Sim:
  assumes A: "P  \<preceq>S Q" and B: "P' \<preceq>S Q'"
  shows "(P \<sqinter> P') \<preceq>S (Q \<sqinter> Q')"
by (insert A B, auto simp: Simulation_def relation_of_Ndet)

lemma Det_Sim:
  assumes A: "P  \<preceq>S Q" and B: "P' \<preceq>S Q'"
  shows "(P \<box> P') \<preceq>S (Q \<box> Q')"
by (auto simp: Simulation_def relation_of_Det design_def rp_defs Simul_def alpha_rp.defs spec_def
         split: cond_splits
         dest: A[simplified Simulation_def Simul_def, rule_format]
               B[simplified Simulation_def Simul_def, rule_format])

lemma Schema_Sim:
  assumes A: "\<And> a. (Pre sc1) (S a) \<Longrightarrow> (Pre sc2) a"
  and B: "\<And> a b. \<lbrakk>Pre sc1 (S a) ; sc2 (a, b)\<rbrakk> \<Longrightarrow> sc1 (S a, S b)"
  shows "(Schema sc1) \<preceq>S (Schema sc2)"
by (auto simp: Simulation_def Simul_def relation_of_Schema rp_defs design_defs alpha_rp.defs A B
         split: cond_splits)

lemma SUb_Sim:
  assumes A: "\<And> a. (Pre sc1) (S a) \<Longrightarrow> (Pre sc2) a"
  and B: "\<And> a b. \<lbrakk>Pre sc1 (S a) ; sc2 (a, b)\<rbrakk> \<Longrightarrow> sc1 (S a, S b)"
  and C: "P \<preceq>S Q"
  shows "(state_update_before sc1 P) \<preceq>S (state_update_before sc2 Q)"
apply (auto simp: Simulation_def Simul_def relation_of_state_update_before rp_defs design_defs alpha_rp.defs A B
         split: cond_splits)
apply (drule C[simplified Simulation_def, rule_format])
apply (rule_tac b="Simul S ba" in comp_intro)
apply (auto simp: A B Simul_def alpha_rp.defs)
apply (clarsimp split: cond_splits)+
apply (drule C[simplified Simulation_def, rule_format])
apply (rule_tac b="Simul S ba" in comp_intro)
apply (auto simp: A B Simul_def alpha_rp.defs)
apply (clarsimp split: cond_splits)+
apply (case_tac "ok aa", simp_all)
apply (erule notE) back
apply (drule C[simplified Simulation_def, rule_format])
apply (rule_tac b="Simul S ba" in comp_intro)
apply (auto simp: A B Simul_def alpha_rp.defs)
apply (clarsimp split: cond_splits)+
apply (rule A)
apply (case_tac "Pre sc1 (S (alpha_rp.more aa))", simp_all)
apply (erule notE) back
apply (drule C[simplified Simulation_def, rule_format])
apply (rule_tac b="Simul S ba" in comp_intro)
apply (auto simp: A B Simul_def alpha_rp.defs)
apply (clarsimp split: cond_splits)+
apply (drule C[simplified Simulation_def, rule_format])
apply (rule_tac b="Simul S ba" in comp_intro)
apply (auto simp: A B Simul_def alpha_rp.defs)
apply (clarsimp split: cond_splits)+
apply (rule B, auto)
done

lemma Seq_Sim:
  assumes A: "P \<preceq>S Q" and B: "P' \<preceq>S Q'"
  shows "(P `;` P') \<preceq>S (Q `;` Q')"
by (auto simp: Simulation_def relation_of_Seq dest: A[simplified Simulation_def, rule_format]
                                                    B[simplified Simulation_def, rule_format])

lemma Par_Sim:
  assumes A: " P  \<preceq>S Q" and B: " P' \<preceq>S Q'"
  and C: "\<And> a b. S (ns'2 a b) = ns2 (S a) (S b)"
  and D: "\<And> a b. S (ns'1 a b) = ns1 (S a) (S b)"
  shows "(P \<lbrakk> ns1 | cs | ns2 \<rbrakk> P') \<preceq>S (Q \<lbrakk> ns'1 | cs | ns'2 \<rbrakk> Q')"
  apply (auto simp: Simulation_def relation_of_Par fun_eq_iff rp_defs Simul_def design_defs spec_def
                    alpha_rp.defs
              dest: A[simplified Simulation_def Simul_def, rule_format]
                    B[simplified Simulation_def Simul_def, rule_format])
  apply (split cond_splits)+
  apply (simp, erule disjE, rule disjI1, simp, rule disjI2, simp_all, rule impI)
  apply (auto)
  apply (erule_tac x="tr ba" in allE, auto)
  apply (erule notE) back
  apply (rule_tac b="Simul S ba\<lparr>ok := False\<rparr>" in comp_intro)
  apply (auto simp: Simul_def alpha_rp.defs dest: A[simplified Simulation_def Simul_def, rule_format])
  apply (erule_tac x="tr bb" in allE, auto)
  apply (erule notE) back
  apply (rule_tac b="Simul S bb\<lparr>ok := False\<rparr>" in comp_intro)
  apply (auto simp: Simul_def alpha_rp.defs dest: B[simplified Simulation_def Simul_def, rule_format])
  apply (erule_tac x="tr ba" in allE, auto)
  apply (erule notE) back
  apply (rule_tac b="Simul S ba\<lparr>ok := False\<rparr>" in comp_intro)
  apply (auto simp: Simul_def alpha_rp.defs dest: A[simplified Simulation_def Simul_def, rule_format])
  apply (erule_tac x="tr bb" in allE, auto)
  apply (erule notE) back
  apply (rule_tac b="Simul S bb\<lparr>ok := False\<rparr>" in comp_intro)
  apply (auto simp: Simul_def alpha_rp.defs dest: B[simplified Simulation_def Simul_def, rule_format])
  apply (rule_tac x="Simul S s1" in exI)
  apply (rule_tac x="Simul S s2" in exI)
  apply (auto simp: Simul_def alpha_rp.defs
              dest!: B[simplified Simulation_def Simul_def, rule_format]
                     A[simplified Simulation_def Simul_def, rule_format]
              split: cond_splits)
  apply (rule_tac b="Simul S ba" in comp_intro)
  apply (auto simp add: M_par_def alpha_rp.defs diff_tr_def fun_eq_iff ParMerge_def Simul_def
            split : cond_splits)
  apply (rule_tac b="\<lparr>ok = ok bb, wait = wait bb, tr = tr bb, ref = ref bb,
              \<dots> = S (alpha_rp.more bb)\<rparr>" in comp_intro, auto)
  apply (subst D[where a="(alpha_rp.more s1)" and b="(alpha_rp.more aa)", symmetric], simp)
  apply (subst C[where a="(alpha_rp.more s2)" and b="(alpha_rp.more bb)", symmetric], simp)
  apply (rule_tac b="\<lparr>ok = ok bb, wait = wait bb, tr = tr bb, ref = ref bb,
              \<dots> = S (alpha_rp.more bb)\<rparr>" in comp_intro, auto)
  apply (subst D[where a="(alpha_rp.more s1)" and b="(alpha_rp.more aa)", symmetric], simp)
  apply (subst C[where a="(alpha_rp.more s2)" and b="(alpha_rp.more bb)", symmetric], simp)
done

lemma Assign_Sim:
  assumes A: "\<And> A. vy A = vx (S A)"
  and B: "\<And> ff A. (S (y_update ff A)) = x_update ff (S A)"
  shows "(x `:=` vx) \<preceq>S (y `:=` vy)"
by (auto simp: Simulation_def relation_of_Assign update_def rp_defs design_defs Simul_def A B
                   alpha_rp.defs split: cond_splits)

lemma Var_Sim:
  assumes A: "P \<preceq>S Q" and B: "\<And> ff A. (S ((snd b) ff A)) = (snd a) ff (S A)"
  shows "(Var a P) \<preceq>S (Var b Q)"
  apply (auto simp: Simulation_def relation_of_Var rp_defs design_defs fun_eq_iff Simul_def B
                    alpha_rp.defs increase_def decrease_def)
  apply (rule_tac b="Simul S ab" in comp_intro)
  apply (split cond_splits)+
  apply (auto simp: B alpha_rp.defs Simul_def elim!: alpha_rp_eqE)
  apply (rule_tac b="Simul S bb" in comp_intro)
  apply (split cond_splits)+
  apply (auto simp: B alpha_rp.defs Simul_def
              elim!: alpha_rp_eqE dest!: A[simplified Simulation_def Simul_def, rule_format])
  apply (split cond_splits)+
  apply (simp add: alpha_rp.defs)
  apply (erule disjE, rule disjI1, simp, rule disjI2, simp)
  apply (simp_all add: alpha_rp.defs true_def)
  apply (rule impI, (erule conjE | simp)+)
  apply (simp add: B)
  apply (split cond_splits)+
  apply (simp add: alpha_rp.defs)
  apply (erule disjE, rule disjI1, simp, rule disjI2, simp_all)
  apply (rule impI, (erule conjE | simp)+)
  apply (simp add: B)
done

lemma Guard_Sim:
  assumes A: "P \<preceq>S Q" and B: "\<And> A. h A = g (S A)"
  shows "(g `&` P) \<preceq>S (h `&` Q)"
apply (auto simp: Simulation_def)
apply (case_tac "h (alpha_rp.more a)")
defer
apply (case_tac "g (S (alpha_rp.more a))")
apply (auto simp: true_Guard1 false_Guard1 Simul_def alpha_rp.defs Simulation_def B
            dest!: A[simplified, rule_format] Stop_Sim[simplified, rule_format])
done

lemma Write0_Sim:
  assumes A: "P \<preceq>S Q"
  shows "a \<rightarrow> P \<preceq>S a \<rightarrow> Q "
  using   A
  apply (auto simp: Simulation_def write0_def relation_of_Prefix0 design_defs rp_defs)
  apply (erule_tac x="ba" in allE)
  apply (erule_tac x="c" in allE, auto)
  apply (rule_tac b="Simul S ba" in comp_intro)
  apply (auto split: cond_splits simp: Simul_def alpha_rp.defs do_def)
done

lemma Read_Sim:
  assumes A: " P \<preceq>S Q" and B: "\<And> A. (d A) = c (S A)"
  shows "a`?`c \<rightarrow> P \<preceq>S a`?`d \<rightarrow> Q"
  using A
  apply (auto simp: Simulation_def read_def relation_of_iPrefix design_defs rp_defs)
  apply (erule_tac x="ba" in allE, erule_tac x="ca" in allE, simp)
  apply (rule_tac b="Simul S ba" in comp_intro)
  apply (auto split: cond_splits simp: Simul_def alpha_rp.defs do_I_def select_def B)
done

lemma Read1_Sim:
  assumes A: " P \<preceq>S Q" and B: "\<And> A. (d A) = c (S A)"
  shows "a`?`c`:`s \<rightarrow> P \<preceq>S a`?`d`:`s \<rightarrow> Q"
  using A
  apply (auto simp: Simulation_def read1_def relation_of_iPrefix design_defs rp_defs)
  apply (erule_tac x="ba" in allE, erule_tac x="ca" in allE, simp)
  apply (rule_tac b="Simul S ba" in comp_intro)
  apply (auto split: cond_splits simp: Simul_def alpha_rp.defs do_I_def select_def B)
done

lemma Read1S_Sim:
  assumes A: " P \<preceq>S Q" and B: "\<And> A. (d A) = c (S A)" and C: "\<And> A. (s' A) = s (S A)"
  shows "a`?`c`\<in>`s \<rightarrow> P \<preceq>S a`?`d`\<in>`s' \<rightarrow> Q"
  using A
  apply (auto simp: Simulation_def read1_def relation_of_iPrefix design_defs rp_defs)
  apply (erule_tac x="ba" in allE, erule_tac x="ca" in allE, simp)
  apply (rule_tac b="Simul S ba" in comp_intro)
  apply (auto split: cond_splits simp: Simul_def alpha_rp.defs do_I_def select_def B C)
done

lemma Write_Sim:
  assumes A: "P \<preceq>S Q" and B: "\<And> A. (d A) = c (S A)"
  shows "a`!`c \<rightarrow> P \<preceq>S a`!`d \<rightarrow> Q "
  using A
  apply (auto simp: Simulation_def write1_def relation_of_oPrefix design_defs rp_defs)
  apply (erule_tac x="ba" in allE, erule_tac x="ca" in allE, simp)
  apply (rule_tac b="Simul S ba" in comp_intro)
  apply (auto split: cond_splits simp: Simul_def alpha_rp.defs do_def select_def B)
done

lemma Hide_Sim:
  assumes A: " P \<preceq>S Q"
  shows "(P \\ cs) \<preceq>S (Q \\ cs)"
  apply (auto simp: Simulation_def relation_of_Hide design_defs rp_defs Simul_def alpha_rp.defs)
  apply (rule_tac b="Simul S ba" in comp_intro)
  apply (split cond_splits)+
  apply (auto simp: Simul_def alpha_rp.defs Simulation_def
              dest!: A[simplified, rule_format] Skip_Sim[simplified, rule_format])
  apply (rule_tac x=s in exI, auto simp: diff_tr_def)
done

lemma lfp_Siml:
  assumes A: "\<And> X. (X \<preceq>S Q) \<Longrightarrow> ((P X) \<preceq>S Q)" and B: "mono P"
  shows "(lfp P) \<preceq>S Q"
  apply (rule lfp_ordinal_induct, auto simp: B A)
  apply (auto simp add: Simulation_def Sup_action relation_of_bot relation_of_Sup[simplified])
  apply (subst (asm) CSP_is_rd[OF relation_of_CSP])
  apply (auto simp: rp_defs fun_eq_iff Simul_def alpha_rp.defs decrease_def split: cond_splits)
done

lemma Mu_Sim:
  assumes A: "\<And> X Y. X \<preceq>S Y \<Longrightarrow> (P X) \<preceq>S (Q Y)"
  and B: "mono P" and C: "mono Q"
  shows "(lfp P) \<preceq>S (lfp Q) "
  apply (rule lfp_Siml, drule A)
  apply (subst lfp_unfold, simp_all add: B C)
done

lemma bot_Sim: "bot \<preceq>S bot"
by (auto simp: Simulation_def rp_defs Simul_def relation_of_bot alpha_rp.defs split: cond_splits)

lemma sim_is_ref: "P \<sqsubseteq> Q = P \<preceq>(id) Q"
apply (auto simp: ref_def Simulation_def Simul_def alpha_rp.defs)
apply (erule_tac x=a in allE)
apply (erule_tac x=b in allE, auto)
apply (rule_tac t="\<lparr>ok = ok a, wait = wait a, tr = tr a, ref = ref a, \<dots> = alpha_rp.more a\<rparr>" and s=a in subst, simp)
apply (rule_tac t="\<lparr>ok = ok b, wait = wait b, tr = tr b, ref = ref b, \<dots> = alpha_rp.more b\<rparr>" and s=b in subst, simp_all)
apply (erule_tac x=a in allE)
apply (erule_tac x=b in allE, auto)
apply (rule_tac s="\<lparr>ok = ok a, wait = wait a, tr = tr a, ref = ref a, \<dots> = alpha_rp.more a\<rparr>" and t=a in subst, simp)
apply (rule_tac s="\<lparr>ok = ok b, wait = wait b, tr = tr b, ref = ref b, \<dots> = alpha_rp.more b\<rparr>" and t=b in subst, simp_all)
done

lemma ref_eq: "((P::('a::ev_eq,'b) action) = Q) = (P \<sqsubseteq> Q & Q \<sqsubseteq> P)"
apply (rule)
apply (simp add: ref_def)
apply (auto simp add: ref_def fun_eq_iff relation_of_inject[symmetric])
done

lemma rd_ref:
assumes A:"R (P \<turnstile> Q) \<in> {p. is_CSP_process p}"
and B:"R (P' \<turnstile> Q') \<in> {p. is_CSP_process p}"
and C:"\<And> a b. P (a, b) \<Longrightarrow> P' (a, b)"
and D:"\<And> a b. Q' (a, b) \<Longrightarrow> Q (a, b)"
shows "(action_of (R (P \<turnstile> Q))) \<sqsubseteq> (action_of (R (P' \<turnstile> Q')))"
apply (auto simp: ref_def)
apply (subst (asm) action_of_inverse, simp add: B[simplified])
apply (subst action_of_inverse, simp add: A[simplified])
apply (auto simp: rp_defs design_defs C D split: cond_splits)
done

lemma rd_impl:
assumes A:"R (P \<turnstile> Q) \<in> {p. is_CSP_process p}"
and B:"R (P' \<turnstile> Q') \<in> {p. is_CSP_process p}"
and C:"\<And> a b. P (a, b) \<Longrightarrow> P' (a, b)"
and D:"\<And> a b. Q' (a, b) \<Longrightarrow> Q (a, b)"
shows "R (P' \<turnstile> Q') (a, b) \<longrightarrow> R (P \<turnstile> Q) (a::('a::ev_eq, 'b) alpha_rp_scheme, b)"
apply (insert rd_ref[of P Q P' Q', OF A B C D])
apply (auto simp: ref_def)
apply (subst (asm) action_of_inverse, simp add: B[simplified])
apply (subst (asm) action_of_inverse, simp add: A[simplified])
apply (erule_tac x=a in allE)
apply (erule_tac x=b in allE)
apply (auto)
done

end