chapter \<open>Second Example\<close>

theory %invisible Second_Example
imports Main
begin

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

text \<open>Pop-refinement is illustrated via a simple derivation,
in Isabelle/HOL,
of a non-deterministic program that satisfies a hyperproperty.\<close>

section \<open>Hyperproperties\<close>
text \<open>\label{sec:hyper}\<close>

text \<open>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.\<close>

text \<open>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.\<close>

text \<open>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}.\<close>

locale generalized_non_interference =
  fixes low_in :: "'\<tau> \<Rightarrow> 'i" \<comment> \<open>low inputs\<close>
  fixes low_out :: "'\<tau> \<Rightarrow> 'o" \<comment> \<open>low outputs\<close>
  fixes high_in :: "'\<tau> \<Rightarrow> 'i" \<comment> \<open>high inputs\<close>
  fixes high_out :: "'\<tau> \<Rightarrow> 'o" \<comment> \<open>high outputs\<close>

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 \<open>Target Programming Language\<close>
text \<open>\label{sec:targetII}\<close>

text \<open>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.\<close>

text \<open>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\}$.\<close>

subsection \<open>Syntax\<close>
text \<open>\label{sec:syntaxII}\<close>

text \<open>Variables are identified by names.\<close>

type_synonym name = string

text \<open>Expressions are built out of
constants, variables, and addition operations.\<close>

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

text \<open>Statements are built out of
deterministic assignments,
non-deterministic assignments,
conditionals,
and sequencing.\<close>

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

text \<open>A program consists of
a list of state variables
and a body statement.\<close>

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

subsection \<open>Static Semantics\<close>
text \<open>\label{sec:staticII}\<close>

text \<open>A context is a set of variables.\<close>

type_synonym ctxt = "name set"

text \<open>Given a context,
an expression is well-formed iff\
all its variables are in the context.\<close>

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 \<open>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.\<close>

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 \<open>The context of a program consists of the state variables.\<close>

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

text \<open>A program is well-formed iff\
the variables are distinct
and the body is well-formed in the context of the program.\<close>

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

subsection \<open>Dynamic Semantics\<close>
text \<open>\label{sec:dynamicII}\<close>

text \<open>A state associates values (non-negative integers) to variables.\<close>

type_synonym state = "name \<rightharpoonup> nat"

text \<open>A state matches a context iff\
state and context have the same variables.\<close>

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

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

definition add_opt :: "nat option \<Rightarrow> nat option \<Rightarrow> nat option" (infixl "\<oplus>" 65)
\<comment> \<open>Lifting of addition to @{typ "nat option"}.\<close>
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 \<open>Evaluating a well-formed expression never yields an error,
if the state matches the context.\<close>

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 \<open>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.\<close>

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 \<open>The execution of any statement in any state always yields a result.\<close>

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 \<open>Executing a well-formed statement in a state that matches the context
never yields an error and always yields states that match the context.\<close>

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 \<open>The states of a program
are the ones that match the context of the program.\<close>

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

text \<open>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.\<close>

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 \<open>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.\<close>

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 \<open>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}.\<close>

section \<open>Requirement Specification\<close>
text \<open>\label{sec:specificationII}\<close>

text \<open>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'.}\<close>

subsection \<open>Input/Output Variables\<close>
text \<open>\label{sec:specII:iovars}\<close>

text \<open>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).\<close>

text \<open>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.\<close>

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

subsection \<open>Low Processing\<close>
text \<open>\label{sec:specII:lowproc}\<close>

text \<open>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.\<close>

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 \<open>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.\<close>

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 \<open>High Processing\<close>
text \<open>\label{sec:specII:highproc}\<close>

text \<open>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.\<close>

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 \<open>All Requirements\<close>
text \<open>\label{sec:specII:all}\<close>

text \<open>Besides satisfying the above requirements on
input/output variables, low processing, and high processing,
the target program must be well-formed.\<close>

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 \<open>Generalized Non-Interference\<close>
text \<open>\label{sec:specII:GNI}\<close>

text \<open>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}\<close>

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 \<open>The requirements in @{const spec\<^sub>0} imply that
the set of traces of the target program satisfies GNI.\<close>

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"
  \<comment> \<open>Consider a trace @{text \<tau>\<^sub>1} and its high input:\<close>
  fix \<tau>\<^sub>1::trace
  define highIn where "highIn = high_in \<tau>\<^sub>1"
  \<comment> \<open>Consider a trace @{text \<tau>\<^sub>2},
        its low input and output,
        and its states:\<close>
  fix \<tau>\<^sub>2::trace
  define lowIn lowOut \<sigma>\<^sub>2 \<sigma>\<^sub>2'
    where "lowIn = low_in \<tau>\<^sub>2"
      and "lowOut = low_out \<tau>\<^sub>2"
      and "\<sigma>\<^sub>2 = initial \<tau>\<^sub>2"
      and "\<sigma>\<^sub>2' = 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)
  \<comment> \<open>Construct the initial state of the witness trace @{text \<tau>\<^sub>3}:\<close>
  define \<sigma>\<^sub>3 where "\<sigma>\<^sub>3 = \<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)
  \<comment> \<open>Construct the final state of @{text \<tau>\<^sub>3}, and @{text \<tau>\<^sub>3},
        by cases on @{term lowIn}:\<close>
  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
    \<comment> \<open>Use as final state the one required by @{term low_proc_0}:\<close>
    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)
    \<comment> \<open>Construct @{text \<tau>\<^sub>3} from its initial and final states:\<close>
    define \<tau>\<^sub>3 where "\<tau>\<^sub>3 = \<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
    \<comment> \<open>Derive @{term \<tau>\<^sub>2}'s low output from @{term low_proc_non0}:\<close>
    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)
    \<comment> \<open>Use any final state for @{text \<tau>\<^sub>3}:\<close>
    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)
    \<comment> \<open>Derive @{text \<tau>\<^sub>3}'s low output from @{term low_proc_non0}:\<close>
    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)
    \<comment> \<open>Construct @{text \<tau>\<^sub>3} from its initial and final states:\<close>
    define \<tau>\<^sub>3 where "\<tau>\<^sub>3 = \<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 \<open>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}.\<close>

section \<open>Stepwise Refinement\<close>
text \<open>\label{sec:refinementII}\<close>

text \<open>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.\<close>

subsection \<open>Step 1\<close>

text \<open>\label{sec:refII:stepI}\<close>

text \<open>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.\<close>

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

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

text \<open>The refinement of @{const io_vars}
reduces the well-formedness of the program
to the well-formedness of the body.\<close>

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 \<open>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.\<close>

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 \<open>The refinement of @{const spec\<^sub>0} consists of
the refinement of @{const io_vars} and of the simplified constraints.\<close>

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 \<open>Step 2\<close>

text \<open>\label{sec:refII:stepII}\<close>

text \<open>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.\<close>

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"
\<comment> \<open>The order of the two statements in the body is arbitrary.\<close>

text \<open>The splitting reduces the well-formedness of the body
to the well-formedness of the two statements.\<close>

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 \<open>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}\<close>

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, goal_cases)
  \<comment> \<open>Processing of non-0 low input:\<close>
  case 1
  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
  \<comment> \<open>Processing of 0 low input:\<close>
  case 2
  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 (auto simp add: body_split_def dest: ExecSeqOK)
  qed
next
  \<comment> \<open>Processing of high input:\<close>
  case 3
  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 \<open>The refined specification consists of
the splitting of the body into the two sequential statements
and the refined well-formedness and processing constraints.\<close>

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 \<open>Step 3\<close>

text \<open>\label{sec:refII:stepIII}\<close>

text \<open>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.\<close>

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 \<open>The refined specification is obtained
by simplification using the definition of @{term s\<^sub>L}.\<close>

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 \<open>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.\<close>

subsection \<open>Step 4\<close>

text \<open>\label{sec:refII:stepIV}\<close>

text \<open>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.\<close>

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 \<open>The refined specification is obtained
by substituting the refined processing constraint on @{term s\<^sub>H}.\<close>

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 \<open>Step 5\<close>

text \<open>\label{sec:refII:stepV}\<close>

text \<open>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''"}.\<close>

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 \<open>The refined specification is obtained
by simplification using the definition of @{term s\<^sub>H}.\<close>

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 \<open>Step 6\<close>

text \<open>\label{sec:refII:stepVI}\<close>

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

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 \<open>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.\<close>

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 \<open>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.\<close>

end %invisible


theory Proof_4_12
  imports Proofs_4
begin

thm VC12_def

abbreviation s where "s s0 user_value pressure_value \<equiv>
  (toEnv (reset (setVarAny s0 user_value pressure_value) ERROR))"

theorem proof_4_12: "VC12 inv4 env s0 user_value pressure_value"
  apply(simp only: VC12_def inv4_def R4_def extraInv_def)
  apply(rule impI)
  apply(rule conjI)
   apply(rule conjI)
    apply simp
  apply((rule allI)+)
    apply(rule impI)
 subgoal premises prems for s1 s2 s3
    apply(cases "s3 = s s0 user_value pressure_value")
     apply(cases "s2 = s s0 user_value pressure_value")
      using prems(2)  apply (simp split: if_splits)
      using prems(1)
        apply (smt (z3) getPstate.simps(9) substate_toEnvNum_id)
      using prems(2) apply(simp split: if_splits)
      apply(rule cut_rl[of " toEnvNum s2 s0 <DELAY'TIMEOUT"])
      using prems(1)
        apply (meson prems(2) substate_refl)
       apply simp
      apply(rule cut_rl[of "substate s3 s0"])
      using prems apply meson
      using prems(2)  by (simp split: if_splits)


(* Author: Dmitriy Traytel *)

header {* Monadic Second-Order Logic Formulas *}

(*<*)
theory Formula
imports Pi_Regular_Operators List_More
begin
(*>*)

subsection {* Interpretations and Encodings *}

type_synonym 'a interp = "'a list \<times> (nat + nat set) list"

abbreviation "enc_atom_bool I n \<equiv> map (\<lambda>x. case x of Inl p \<Rightarrow> n = p | Inr P \<Rightarrow> n \<in> P) I"

abbreviation "enc_atom I n a \<equiv> (a, enc_atom_bool I n)"

subsection {* Syntax and Semantics of MSO *}

datatype 'a formula =
  FQ 'a nat
| FLess nat nat
| FIn nat nat
| FNot "'a formula"
| FOr "'a formula" "'a formula"
| FAnd "'a formula" "'a formula"
| FExists "'a formula"
| FEXISTS "'a formula"

primrec FOV :: "'a formula \<Rightarrow> nat set" where
  "FOV (FQ a m) = {m}"
| "FOV (FLess m1 m2) = {m1, m2}"
| "FOV (FIn m M) = {m}"
| "FOV (FNot \<phi>) = FOV \<phi>"
| "FOV (FOr \<phi>\<^sub>1 \<phi>\<^sub>2) = FOV \<phi>\<^sub>1 \<union> FOV \<phi>\<^sub>2"
| "FOV (FAnd \<phi>\<^sub>1 \<phi>\<^sub>2) = FOV \<phi>\<^sub>1 \<union> FOV \<phi>\<^sub>2"
| "FOV (FExists \<phi>) = (\<lambda>x. x - 1) ` (FOV \<phi> - {0})"
| "FOV (FEXISTS \<phi>) = (\<lambda>x. x - 1) ` FOV \<phi>"

primrec SOV :: "'a formula \<Rightarrow> nat set" where
  "SOV (FQ a m) = {}"
| "SOV (FLess m1 m2) = {}"
| "SOV (FIn m M) = {M}"
| "SOV (FNot \<phi>) = SOV \<phi>"
| "SOV (FOr \<phi>\<^sub>1 \<phi>\<^sub>2) = SOV \<phi>\<^sub>1 \<union> SOV \<phi>\<^sub>2"
| "SOV (FAnd \<phi>\<^sub>1 \<phi>\<^sub>2) = SOV \<phi>\<^sub>1 \<union> SOV \<phi>\<^sub>2"
| "SOV (FExists \<phi>) = (\<lambda>x. x - 1) ` SOV \<phi>"
| "SOV (FEXISTS \<phi>) = (\<lambda>x. x - 1) ` (SOV \<phi> - {0})"

definition "\<sigma> = (\<lambda>\<Sigma> n. concat (map (\<lambda>bs. map (\<lambda>a. (a, bs)) \<Sigma>) (List.n_lists n [True, False])))"
definition "\<pi> = (\<lambda>(a, bs). (a, tl bs))"
definition "\<epsilon> = (\<lambda>\<Sigma> (a::'a, bs). if a \<in> set \<Sigma> then [(a, True # bs), (a, False # bs)] else [])"

datatype 'a atom =
    Singleton 'a "bool list"
  | AQ nat 'a
  | Arbitrary_Except nat bool
  | Arbitrary_Except2 nat nat
derive linorder atom

fun wf_atom where
  "wf_atom \<Sigma> n (Singleton a bs) = (a \<in> set \<Sigma> \<and> length bs = n)"
| "wf_atom \<Sigma> n (AQ m a) = (a \<in> set \<Sigma> \<and> m < n)"
| "wf_atom \<Sigma> n (Arbitrary_Except m _) = (m < n)"
| "wf_atom \<Sigma> n (Arbitrary_Except2 m1 m2) = (m1 < n \<and> m2 < n)"

fun lookup where
  "lookup (Singleton a' bs') (a, bs) = (a = a' \<and> bs = bs')"
| "lookup (AQ m a') (a, bs) = (a = a' \<and> bs ! m)"
| "lookup (Arbitrary_Except m b) (_, bs) = (bs ! m = b)"
| "lookup (Arbitrary_Except2 m1 m2) (_, bs) = (bs ! m1 \<and> bs ! m2)"

lemma \<pi>_\<sigma>: "\<pi> ` (set o \<sigma> \<Sigma>) (n + 1) = (set o \<sigma> \<Sigma>) n"
  unfolding \<pi>_def \<sigma>_def set_map[symmetric] o_apply map_concat by auto

locale formula = embed2 "set o (\<sigma> \<Sigma>)" "wf_atom \<Sigma>" \<pi> lookup "\<epsilon> \<Sigma>" "split Singleton"
for \<Sigma> :: "'a :: linorder list" +
assumes nonempty: "\<Sigma> \<noteq> []"
begin

abbreviation "\<Sigma>_product_lists n \<equiv>
   List.maps (\<lambda>bools. map (\<lambda>a. (a, bools)) \<Sigma>) (bool_product_lists n)"

(* Normal form: quantified variables are used in the body *)
primrec pre_wf_formula :: "nat \<Rightarrow> 'a formula \<Rightarrow> bool" where
  "pre_wf_formula n (FQ a m) = (a \<in> set \<Sigma> \<and> m < n)"
| "pre_wf_formula n (FLess m1 m2) = (m1 < n \<and> m2 < n)"
| "pre_wf_formula n (FIn m M) = (m < n \<and> M < n)"
| "pre_wf_formula n (FNot \<phi>) = pre_wf_formula n \<phi>"
| "pre_wf_formula n (FOr \<phi>\<^sub>1 \<phi>\<^sub>2) = (pre_wf_formula n \<phi>\<^sub>1 \<and> pre_wf_formula n \<phi>\<^sub>2)"
| "pre_wf_formula n (FAnd \<phi>\<^sub>1 \<phi>\<^sub>2) = (pre_wf_formula n \<phi>\<^sub>1 \<and> pre_wf_formula n \<phi>\<^sub>2)"
| "pre_wf_formula n (FExists \<phi>) = (pre_wf_formula (n + 1) \<phi> \<and> 0 \<in> FOV \<phi> \<and> 0 \<notin> SOV \<phi>)"
| "pre_wf_formula n (FEXISTS \<phi>) = (pre_wf_formula (n + 1) \<phi> \<and> 0 \<notin> FOV \<phi> \<and> 0 \<in> SOV \<phi>)"

abbreviation "closed \<equiv> pre_wf_formula 0"

definition [simp]: "wf_formula n \<phi> \<equiv> pre_wf_formula n \<phi> \<and> FOV \<phi> \<inter> SOV \<phi> = {}"

lemma max_idx_vars: "pre_wf_formula n \<phi> \<Longrightarrow> \<forall>p \<in> FOV \<phi> \<union> SOV \<phi>. p < n"
  by (induct \<phi> arbitrary: n)
   (auto split: split_if_asm, (metis Un_iff diff_Suc_less less_SucE less_imp_diff_less)+)

lemma finite_FOV: "finite (FOV \<phi>)"
  by (induct \<phi>) (auto split: split_if_asm)

subsection {* ENC *}

definition valid_ENC :: "nat \<Rightarrow> nat \<Rightarrow> ('a atom) rexp" where
  "valid_ENC n p = (if n = 0 then Full else
    TIMES [
      Star (Atom (Arbitrary_Except p False)),
      Atom (Arbitrary_Except p True),
      Star (Atom (Arbitrary_Except p False))])"

lemma wf_rexp_valid_ENC: "n = 0 \<or> p < n \<Longrightarrow> wf n (valid_ENC n p)"
  unfolding valid_ENC_def by auto

definition ENC :: "nat \<Rightarrow> nat set \<Rightarrow> ('a atom) rexp" where
  "ENC n V = flatten INTERSECT (valid_ENC n ` V)"

lemma wf_rexp_ENC: "\<lbrakk>finite V; n = 0 \<or> (\<forall>v \<in> V. v < n)\<rbrakk> \<Longrightarrow> wf n (ENC n V)"
  unfolding ENC_def
  by (intro iffD2[OF wf_flatten_INTERSECT]) (auto simp: wf_rexp_valid_ENC)

lemma enc_atom_\<sigma>_eq: "i < length w \<Longrightarrow>
 (length I = n \<and> p \<in> set \<Sigma>) \<longleftrightarrow> enc_atom I i p \<in> set (\<sigma> \<Sigma> n)"
  by (auto simp: \<sigma>_def set_n_lists intro!: exI[of _ "enc_atom_bool I i"] imageI)

lemmas enc_atom_\<sigma> = iffD1[OF enc_atom_\<sigma>_eq, OF _ conjI]

lemma enc_atom_bool_take_drop_True:
  "\<lbrakk>r < length I; case I ! r of Inl p' \<Rightarrow> p = p' | Inr P \<Rightarrow> p \<in> P\<rbrakk> \<Longrightarrow>
    enc_atom_bool I p = take r (enc_atom_bool I p) @ True # drop (Suc r) (enc_atom_bool I p)"
  by (auto intro: trans[OF id_take_nth_drop])

lemma enc_atom_bool_take_drop_True2:
  "\<lbrakk>r < length I; case I ! r of Inl p' \<Rightarrow> p = p' | Inr P \<Rightarrow> p \<in> P;
    s < length I; case I ! s of Inl p' \<Rightarrow> p = p' | Inr P \<Rightarrow> p \<in> P; r < s\<rbrakk> \<Longrightarrow>
    enc_atom_bool I p = take r (enc_atom_bool I p) @ True #
      take (s - Suc r) (drop (Suc r) (enc_atom_bool I p)) @ True #
      drop (Suc s) (enc_atom_bool I p)"
  using id_take_nth_drop[of r "enc_atom_bool I p"]
      id_take_nth_drop[of "s - r - 1" "drop (Suc r) (enc_atom_bool I p)"]
  by auto

lemma enc_atom_bool_take_drop_False:
  "\<lbrakk>r < length I; case I ! r of Inl p' \<Rightarrow> p \<noteq> p' | Inr P \<Rightarrow> p \<notin> P\<rbrakk> \<Longrightarrow>
    enc_atom_bool I p = take r (enc_atom_bool I p) @ False # drop (Suc r) (enc_atom_bool I p)"
  by (auto intro: trans[OF id_take_nth_drop] split: sum.splits)

lemma enc_atom_lang_AQ: "\<lbrakk>r < length I;
   case I ! r of Inl p' \<Rightarrow> p = p' | Inr P \<Rightarrow> p \<in> P; length I = n; a \<in> set \<Sigma>\<rbrakk> \<Longrightarrow>
  [enc_atom I p a] \<in> lang n (Atom (AQ r a))"
  unfolding lang.simps
  by (force intro!: enc_atom_bool_take_drop_True
    image_eqI[of _ _ "(\<lambda>J. take r J @ drop (r + 1) J) (enc_atom_bool I p)"]
    simp: \<sigma>_def set_n_lists)

lemma enc_atom_lang_Arbitrary_Except_True: "\<lbrakk>r < length I;
   case I ! r of Inl p' \<Rightarrow> p = p' | Inr P \<Rightarrow> p \<in> P; length I = n; a \<in> set \<Sigma>\<rbrakk> \<Longrightarrow>
  [enc_atom I p a] \<in> lang n (Atom (Arbitrary_Except r True))"
  unfolding lang.simps
  by (force intro!: enc_atom_bool_take_drop_True
    image_eqI[of _ _ "(\<lambda>J. take r J @ drop (r + 1) J) (enc_atom_bool I p)"]
    simp: \<sigma>_def set_n_lists)

lemma enc_atom_lang_Arbitrary_Except2:"\<lbrakk>r < length I; s < length I;
  case I ! r of Inl p' \<Rightarrow> p = p' | Inr P \<Rightarrow> p \<in> P;
  case I ! s of Inl p' \<Rightarrow> p = p' | Inr P \<Rightarrow> p \<in> P; length I = n; a \<in> set \<Sigma>\<rbrakk> \<Longrightarrow>
  [enc_atom I p a] \<in> lang n (Atom (Arbitrary_Except2 r s))"
  unfolding lang.simps
  by (force intro!: enc_atom_bool_take_drop_True2
    simp: set_n_lists \<sigma>_def take_Cons' drop_Cons' numeral_eq_Suc)

lemma enc_atom_lang_Arbitrary_Except_False: "\<lbrakk>r < length I;
  case I ! r of Inl p' \<Rightarrow> p \<noteq> p' | Inr P \<Rightarrow> p \<notin> P; length I = n; a \<in> set \<Sigma>\<rbrakk> \<Longrightarrow>
  [enc_atom I p a] \<in> lang n (Atom (Arbitrary_Except r False))"
  unfolding lang.simps
  by (force intro!: enc_atom_bool_take_drop_False
    image_eqI[of _ _ "(\<lambda>J. take r J @ drop (r + 1) J) (enc_atom_bool I p)"]
    simp: set_n_lists \<sigma>_def split: sum.splits)

lemma AQ_D:
  assumes "v \<in> lang n (Atom (AQ m a))" "m < n" "a \<in> set \<Sigma>"
  shows "\<exists>x. v = [x] \<and> fst x = a \<and> snd x ! m"
  using assms by auto

lemma Arbitrary_ExceptD:
  assumes "v \<in> lang n (Atom (Arbitrary_Except r b))" "r < n"
  shows "\<exists>x. v = [x] \<and> snd x ! r = b"
  using assms by auto

lemma Arbitrary_Except2D:
  assumes "v \<in> lang n (Atom (Arbitrary_Except2 r s))" "r < n" "s < n"
  shows "\<exists>x. v = [x] \<and> snd x ! r \<and> snd x ! s"
  using assms by auto

end

end


(*  Title:   CoProduct_QuasiBorel.thy
    Author:  Michikazu Hirata, Tokyo Institute of Technology
*)

subsubsection \<open> Countable Coproduct Spaces \<close>
theory CoProduct_QuasiBorel

imports
 "Product_QuasiBorel"
 "Binary_CoProduct_QuasiBorel"
begin

definition coprod_qbs_Mx :: "['a set, 'a \<Rightarrow> 'b quasi_borel] \<Rightarrow> (real \<Rightarrow> 'a \<times> 'b) set" where
"coprod_qbs_Mx I X \<equiv> { \<lambda>r. (f r, \<alpha> (f r) r) |f \<alpha>. f \<in> real_borel \<rightarrow>\<^sub>M count_space I \<and> (\<forall>i\<in>range f. \<alpha> i \<in> qbs_Mx (X i))}"

lemma coprod_qbs_MxI:
  assumes "f \<in> real_borel \<rightarrow>\<^sub>M count_space I"
      and "\<And>i. i \<in> range f \<Longrightarrow> \<alpha> i \<in> qbs_Mx (X i)"
    shows "(\<lambda>r. (f r, \<alpha> (f r) r)) \<in> coprod_qbs_Mx I X"
  using assms unfolding coprod_qbs_Mx_def by blast

definition coprod_qbs_Mx' :: "['a set, 'a \<Rightarrow> 'b quasi_borel] \<Rightarrow> (real \<Rightarrow> 'a \<times> 'b) set" where
"coprod_qbs_Mx' I X \<equiv> { \<lambda>r. (f r, \<alpha> (f r) r) |f \<alpha>. f \<in> real_borel \<rightarrow>\<^sub>M count_space I \<and> (\<forall>i. (i \<in> range f \<or> qbs_space (X i) \<noteq> {}) \<longrightarrow> \<alpha> i \<in> qbs_Mx (X i))}"

lemma coproduct_qbs_Mx_eq:
 "coprod_qbs_Mx I X = coprod_qbs_Mx' I X"
proof auto
  fix \<alpha>
  assume "\<alpha>  \<in> coprod_qbs_Mx I X"
  then obtain f \<beta> where hfb:
    "f \<in> real_borel \<rightarrow>\<^sub>M count_space I"
    "\<And>i. i \<in> range f \<Longrightarrow> \<beta> i \<in> qbs_Mx (X i)" "\<alpha> = (\<lambda>r. (f r, \<beta> (f r) r))"
    unfolding coprod_qbs_Mx_def by blast
  define \<beta>' where "\<beta>' \<equiv> (\<lambda>i. if i \<in> range f then \<beta> i
                              else if qbs_space (X i) \<noteq> {} then (SOME \<gamma>. \<gamma> \<in> qbs_Mx (X i))
                              else \<beta> i)"
  have 1:"\<alpha> = (\<lambda>r. (f r, \<beta>' (f r) r))"
    by(simp add: hfb(3) \<beta>'_def)
  have 2:"\<And>i. qbs_space (X i) \<noteq> {} \<Longrightarrow> \<beta>' i \<in> qbs_Mx (X i)"
  proof -
    fix i
    assume hne:"qbs_space (X i) \<noteq> {}"
    then obtain x where "x \<in> qbs_space (X i)" by auto
    hence "(\<lambda>r. x) \<in> qbs_Mx (X i)" by auto
    thus "\<beta>' i \<in> qbs_Mx (X i)"
      by(cases "i \<in> range f") (auto simp: \<beta>'_def hfb(2) hne intro!: someI2[where a="\<lambda>r. x"])
  qed
  show "\<alpha> \<in> coprod_qbs_Mx' I X"
    using hfb(1,2) 1 2 by(auto simp: coprod_qbs_Mx'_def intro!: exI[where x=f] exI[where x=\<beta>'])
next
  fix \<alpha>
  assume "\<alpha> \<in> coprod_qbs_Mx' I X"
  then obtain f \<beta> where hfb:
    "f \<in> real_borel \<rightarrow>\<^sub>M count_space I"  "\<And>i. qbs_space (X i) \<noteq> {} \<Longrightarrow> \<beta> i \<in> qbs_Mx (X i)"
    "\<And>i. i \<in> range f \<Longrightarrow> \<beta> i \<in> qbs_Mx (X i)"  "\<alpha> = (\<lambda>r. (f r, \<beta> (f r) r))"
    unfolding coprod_qbs_Mx'_def by blast
  show "\<alpha> \<in> coprod_qbs_Mx I X"
    by(auto simp: hfb(4) intro!: coprod_qbs_MxI[OF hfb(1) hfb(3)])
qed

definition coprod_qbs :: "['a set, 'a \<Rightarrow> 'b quasi_borel] \<Rightarrow> ('a \<times> 'b) quasi_borel" where
"coprod_qbs I X \<equiv> Abs_quasi_borel (SIGMA i:I. qbs_space (X i), coprod_qbs_Mx I X)"

syntax
 "_coprod_qbs" :: "pttrn \<Rightarrow> 'i set \<Rightarrow> 'a quasi_borel \<Rightarrow> ('i \<times> 'a) quasi_borel" ("(3\<amalg>\<^sub>Q _\<in>_./ _)"  10)
translations
 "\<amalg>\<^sub>Q x\<in>I. M" \<rightleftharpoons> "CONST coprod_qbs I (\<lambda>x. M)"

lemma coprod_qbs_f[simp]: "coprod_qbs_Mx I X \<subseteq> UNIV \<rightarrow> (SIGMA i:I. qbs_space (X i))"
  by(fastforce simp: coprod_qbs_Mx_def dest: measurable_space)

lemma coprod_qbs_closed1: "qbs_closed1 (coprod_qbs_Mx I X)"
proof(rule qbs_closed1I)
  fix \<alpha> f
  assume "\<alpha> \<in> coprod_qbs_Mx I X"
    and 1[measurable]: "f \<in> real_borel \<rightarrow>\<^sub>M real_borel"
  then obtain \<beta> g where ha:
   "\<And>i. i \<in> range g \<Longrightarrow> \<beta> i \<in> qbs_Mx (X i)" "\<alpha> = (\<lambda>r. (g r, \<beta> (g r) r))" and [measurable]:"g \<in> real_borel \<rightarrow>\<^sub>M count_space I"
    by(fastforce simp: coprod_qbs_Mx_def)
  then have "\<And>i. i \<in> range g \<Longrightarrow> \<beta> i \<circ> f \<in> qbs_Mx (X i)"
    by simp
  thus "\<alpha> \<circ> f \<in> coprod_qbs_Mx I X"
    by(auto intro!: coprod_qbs_MxI[where f="g \<circ> f" and \<alpha>="\<lambda>i. \<beta> i \<circ> f",simplified comp_def] simp: ha(2) comp_def)
qed

lemma coprod_qbs_closed2: "qbs_closed2 (SIGMA i:I. qbs_space (X i)) (coprod_qbs_Mx I X)"
proof(rule qbs_closed2I,auto)
  fix i x
  assume "i \<in> I" "x \<in> qbs_space (X i)"
  then show "(\<lambda>r. (i,x)) \<in> coprod_qbs_Mx I X"
    by(auto simp: coprod_qbs_Mx_def intro!: exI[where x="\<lambda>r. i"])
qed

lemma coprod_qbs_closed3:
 "qbs_closed3 (coprod_qbs_Mx I X)"
proof(rule qbs_closed3I)
  fix P Fi
  assume h:"\<And>i :: nat. P -` {i} \<in> sets real_borel"
           "\<And>i :: nat. Fi i \<in> coprod_qbs_Mx I X"
  then have "\<forall>i. \<exists>fi \<alpha>i. Fi i = (\<lambda>r. (fi r, \<alpha>i (fi r) r)) \<and> fi \<in> real_borel \<rightarrow>\<^sub>M count_space I \<and> (\<forall>j. (j \<in> range fi \<or> qbs_space (X j) \<noteq> {}) \<longrightarrow> \<alpha>i j \<in> qbs_Mx (X j))"
    by(auto simp: coproduct_qbs_Mx_eq coprod_qbs_Mx'_def)
  then obtain fi where
   "\<forall>i. \<exists>\<alpha>i. Fi i = (\<lambda>r. (fi i r, \<alpha>i (fi i r) r)) \<and> fi i \<in> real_borel \<rightarrow>\<^sub>M count_space I \<and> (\<forall>j. (j \<in> range (fi i) \<or> qbs_space (X j) \<noteq> {}) \<longrightarrow> \<alpha>i j \<in> qbs_Mx (X j))"
    by(fastforce intro!: choice)
  then obtain \<alpha>i where
  "\<forall>i. Fi i = (\<lambda>r. (fi i r, \<alpha>i i (fi i r) r)) \<and> fi i \<in> real_borel \<rightarrow>\<^sub>M count_space I \<and> (\<forall>j. (j \<in> range (fi i) \<or> qbs_space (X j) \<noteq> {}) \<longrightarrow> \<alpha>i i j \<in> qbs_Mx (X j))"
    by(fastforce intro!: choice)
  then have hf:
   "\<And>i. Fi i = (\<lambda>r. (fi i r, \<alpha>i i (fi i r) r))" "\<And>i. fi i \<in> real_borel \<rightarrow>\<^sub>M count_space I" "\<And>i j. j \<in> range (fi i) \<Longrightarrow> \<alpha>i i j \<in> qbs_Mx (X j)" "\<And>i j. qbs_space (X j) \<noteq> {} \<Longrightarrow> \<alpha>i i j \<in> qbs_Mx (X j)"
    by auto

  define f' where "f' \<equiv> (\<lambda>r. fi (P r) r)"
  define \<alpha>' where "\<alpha>' \<equiv> (\<lambda>i r. \<alpha>i (P r) i r)"
  have 1:"(\<lambda>r. Fi (P r) r) = (\<lambda>r. (f' r, \<alpha>' (f' r) r))"
    by(simp add: \<alpha>'_def f'_def hf)
  have "f' \<in> real_borel \<rightarrow>\<^sub>M count_space I"
  proof -
    note [measurable] = separate_measurable[OF h(1)]
    have "(\<lambda>(n,r). fi n r) \<in> count_space UNIV \<Otimes>\<^sub>M real_borel \<rightarrow>\<^sub>M count_space I"
      by(auto intro!: measurable_pair_measure_countable1 simp: hf)
    hence [measurable]:"(\<lambda>(n,r). fi n r) \<in> nat_borel \<Otimes>\<^sub>M real_borel \<rightarrow>\<^sub>M count_space I"
      using measurable_cong_sets[OF sets_pair_measure_cong[OF sets_borel_eq_count_space],of real_borel real_borel]
      by auto
    thus ?thesis
      using measurable_comp[of "\<lambda>r. (P r, r)" _ _ "(\<lambda>(n,r). fi n r)"]
      by(simp add: f'_def)
  qed
  moreover have "\<And>i. i \<in> range f' \<Longrightarrow> \<alpha>' i \<in> qbs_Mx (X i)"
  proof -
    fix i
    assume hi:"i \<in> range f'"
    then obtain r where hr:
     "i = fi (P r) r" by(auto simp: f'_def)
    hence "i \<in> range (fi (P r))" by simp
    hence "\<alpha>i (P r) i \<in> qbs_Mx (X i)" by(simp add: hf)
    hence "qbs_space (X i) \<noteq> {}"
      by(auto simp: qbs_empty_equiv)
    hence "\<And>j. \<alpha>i j i \<in> qbs_Mx (X i)"
      by(simp add: hf(4))
    then show "\<alpha>' i \<in> qbs_Mx (X i)"
      by(auto simp: \<alpha>'_def h(1) intro!: qbs_closed3_dest[of P "\<lambda>j. \<alpha>i j i"])
  qed
  ultimately show "(\<lambda>r. Fi (P r) r) \<in> coprod_qbs_Mx I X"
    by(auto intro!: coprod_qbs_MxI simp: 1)
qed

lemma coprod_qbs_correct: "Rep_quasi_borel (coprod_qbs I X) = (SIGMA i:I. qbs_space (X i), coprod_qbs_Mx I X)"
  unfolding coprod_qbs_def
  using is_quasi_borel_intro[OF coprod_qbs_f coprod_qbs_closed1 coprod_qbs_closed2 coprod_qbs_closed3]
  by(fastforce intro!: Abs_quasi_borel_inverse)

lemma coproduct_qbs_space[simp]: "qbs_space (coprod_qbs I X) = (SIGMA i:I. qbs_space (X i))"
  by(simp add: coprod_qbs_correct qbs_space_def)

lemma coproduct_qbs_Mx[simp]: "qbs_Mx (coprod_qbs I X) = coprod_qbs_Mx I X"
  by(simp add: coprod_qbs_correct qbs_Mx_def)

lemma ini_morphism:
  assumes "j \<in> I"
  shows "(\<lambda>x. (j,x)) \<in> X j \<rightarrow>\<^sub>Q (\<amalg>\<^sub>Q i\<in>I. X i)"
  by(fastforce intro!: qbs_morphismI exI[where x="\<lambda>r. j"] simp: coprod_qbs_Mx_def comp_def assms)

lemma coprod_qbs_canonical1:
  assumes "countable I"
      and "\<And>i. i \<in> I \<Longrightarrow> f i \<in> X i \<rightarrow>\<^sub>Q Y"
    shows  "(\<lambda>(i,x). f i x) \<in> (\<amalg>\<^sub>Q i \<in>I. X i) \<rightarrow>\<^sub>Q Y"
proof(rule qbs_morphismI)
  fix \<alpha>
  assume "\<alpha> \<in> qbs_Mx (coprod_qbs I X)"
  then obtain \<beta> g where ha:
   "\<And>i. i \<in> range g \<Longrightarrow> \<beta> i \<in> qbs_Mx (X i)" "\<alpha> = (\<lambda>r. (g r, \<beta> (g r) r))" and hg[measurable]:"g \<in> real_borel \<rightarrow>\<^sub>M count_space I"
    by(fastforce simp: coprod_qbs_Mx_def)
  define f' where "f' \<equiv> (\<lambda>i r. f i (\<beta> i r))"
  have "range g \<subseteq> I"
    using measurable_space[OF hg] by auto
  hence 1:"(\<And>i. i \<in> range g \<Longrightarrow> f' i \<in> qbs_Mx Y)"
    using qbs_morphismE(3)[OF assms(2) ha(1),simplified comp_def]
    by(auto simp: f'_def)
  have "(\<lambda>(i, x). f i x) \<circ> \<alpha> = (\<lambda>r. f' (g r) r)"
    by(auto simp: ha(2) f'_def)
  also have "... \<in> qbs_Mx Y"
    by(auto intro!: qbs_closed3_dest2'[OF assms(1) hg,of f',OF 1])
  finally show "(\<lambda>(i, x). f i x) \<circ> \<alpha> \<in> qbs_Mx Y " .
qed

lemma coprod_qbs_canonical1':
  assumes "countable I"
      and "\<And>i. i \<in> I \<Longrightarrow> (\<lambda>x. f (i,x)) \<in> X i \<rightarrow>\<^sub>Q Y"
    shows  "f \<in> (\<amalg>\<^sub>Q i \<in>I. X i) \<rightarrow>\<^sub>Q Y"
  using coprod_qbs_canonical1[where f="curry f"] assms by(auto simp: curry_def)

text \<open> $\coprod_{i=0,1} X_i \cong X_1 + X_2$. \<close>
lemma coproduct_binary_coproduct:
 "\<exists>f g. f \<in> (\<amalg>\<^sub>Q i\<in>UNIV. if i then X else Y) \<rightarrow>\<^sub>Q X <+>\<^sub>Q Y \<and> g \<in> X <+>\<^sub>Q Y \<rightarrow>\<^sub>Q (\<amalg>\<^sub>Q i\<in>UNIV. if i then X else Y) \<and>
        g \<circ> f = id \<and> f \<circ> g = id"
proof(auto intro!: exI[where x="\<lambda>(b,z). if b then Inl z else Inr z"] exI[where x="case_sum (\<lambda>z. (True,z)) (\<lambda>z. (False,z))"])
  show "(\<lambda>(b, z). if b then Inl z else Inr z) \<in> (\<amalg>\<^sub>Q i\<in>UNIV. if i then X else Y) \<rightarrow>\<^sub>Q X <+>\<^sub>Q Y"
  proof(rule qbs_morphismI)
    fix \<alpha>
    assume " \<alpha> \<in> qbs_Mx (\<amalg>\<^sub>Q i\<in>UNIV. if i then X else Y)"
    then obtain f \<beta> where hf:
      "\<alpha> = (\<lambda>r. (f r, \<beta> (f r) r))" "f \<in> real_borel \<rightarrow>\<^sub>M count_space UNIV" "\<And>i. i \<in> range f \<Longrightarrow> \<beta> i \<in> qbs_Mx (if i then X else Y)"
      by(auto simp: coprod_qbs_Mx_def)
    consider "range f = {True}" | "range f = {False}" | "range f = {True,False}"
      by auto
    thus "(\<lambda>(b, z). if b then Inl z else Inr z) \<circ> \<alpha> \<in> qbs_Mx (X <+>\<^sub>Q Y)"
    proof cases
      case 1
      then have "\<And>r. f r = True"
        by auto
      then show ?thesis
        using hf(3)
        by(auto intro!: bexI[where x="{}"] bexI[where x="\<beta> True"] simp: copair_qbs_Mx_def split_beta' comp_def hf(1))
    next
      case 2
      then have "\<And>r. f r = False"
        by auto
      then show ?thesis
        using hf(3)
        by(auto intro!: bexI[where x="UNIV"] bexI[where x="\<beta> False"] simp: copair_qbs_Mx_def split_beta' comp_def hf(1))
    next
      case 3
      then have 4:"f -` {True} \<in> sets real_borel"
        using measurable_sets[OF hf(2)] by simp
      have 5:"f -` {True} \<noteq> {} \<and> f -` {True} \<noteq> UNIV"
        using 3
        by (metis empty_iff imageE insertCI vimage_singleton_eq)
      have 6:"\<beta> True \<in> qbs_Mx X" "\<beta> False \<in> qbs_Mx Y"
        using hf(3)[of True] hf(3)[of False] by(auto simp: 3)
      show ?thesis
        apply(simp add: copair_qbs_Mx_def)
        apply(intro bexI[OF _ 4])
        apply(simp add: 5)
        apply(intro bexI[OF _ 6(1)] bexI[OF _ 6(2)])
        apply(auto simp add: hf(1) comp_def)
        done
    qed
  qed
next
  show "case_sum (Pair True) (Pair False) \<in> X <+>\<^sub>Q Y \<rightarrow>\<^sub>Q (\<amalg>\<^sub>Q i\<in>UNIV. if i then X else Y)"
  proof(rule qbs_morphismI)
    fix \<alpha>
    assume "\<alpha> \<in> qbs_Mx (X <+>\<^sub>Q Y)"
    then obtain S where hs:
    "S \<in> sets real_borel" "S = {}   \<longrightarrow> (\<exists> \<alpha>1\<in> qbs_Mx X. \<alpha> = (\<lambda>r. Inl (\<alpha>1 r)))" "S = UNIV \<longrightarrow> (\<exists> \<alpha>2\<in> qbs_Mx Y. \<alpha> = (\<lambda>r. Inr (\<alpha>2 r)))"
    "(S \<noteq> {} \<and> S \<noteq> UNIV) \<longrightarrow> (\<exists> \<alpha>1\<in> qbs_Mx X. \<exists> \<alpha>2\<in> qbs_Mx Y. \<alpha> = (\<lambda>r::real. (if (r \<in> S) then Inl (\<alpha>1 r) else Inr (\<alpha>2 r))))"
      by(auto simp: copair_qbs_Mx_def)
    consider "S = {}" | "S = UNIV" | "S \<noteq> {} \<and> S \<noteq> UNIV" by auto
    thus "case_sum (Pair True) (Pair False) \<circ> \<alpha>  \<in> qbs_Mx (\<amalg>\<^sub>Q i\<in>UNIV. if i then X else Y)"
    proof cases
      case 1
      then obtain \<alpha>1 where ha:
      "\<alpha>1\<in> qbs_Mx X" "\<alpha> = (\<lambda>r. Inl (\<alpha>1 r))"
        using hs(2) by auto
      hence "case_sum (Pair True) (Pair False) \<circ> \<alpha> = (\<lambda>r. (True, \<alpha>1 r))"
        by auto
      thus ?thesis
        by(auto intro!: coprod_qbs_MxI simp: ha)
    next
      case 2
      then obtain \<alpha>2 where ha:
      "\<alpha>2\<in> qbs_Mx Y" "\<alpha> = (\<lambda>r. Inr (\<alpha>2 r))"
        using hs(3) by auto
      hence "case_sum (Pair True) (Pair False) \<circ> \<alpha> = (\<lambda>r. (False, \<alpha>2 r))"
        by auto
      thus ?thesis
        by(auto intro!: coprod_qbs_MxI simp: ha)
    next
      case 3
      then obtain \<alpha>1 \<alpha>2 where ha:
       "\<alpha>1\<in> qbs_Mx X" "\<alpha>2\<in> qbs_Mx Y" "\<alpha> = (\<lambda>r. (if (r \<in> S) then Inl (\<alpha>1 r) else Inr (\<alpha>2 r)))"
        using hs(4) by auto
      define f :: "real \<Rightarrow> bool" where "f \<equiv> (\<lambda>r. r \<in> S)"
      define \<alpha>' where "\<alpha>' \<equiv> (\<lambda>i. if i then \<alpha>1 else \<alpha>2)"
      have "case_sum (Pair True) (Pair False) \<circ> \<alpha> = (\<lambda>r. (f r, \<alpha>' (f r) r))"
        by(auto simp: f_def \<alpha>'_def ha(3))
      thus ?thesis
        using hs(1)
        by(auto intro!: coprod_qbs_MxI simp: ha \<alpha>'_def f_def)
    qed
  qed
next
  show "(\<lambda>(b, z). if b then Inl z else Inr z) \<circ> case_sum (Pair True) (Pair False) = id"
    by (auto simp add: sum.case_eq_if )
qed

subsubsection \<open> Lists \<close>
abbreviation "list_of X \<equiv> \<amalg>\<^sub>Q n\<in>(UNIV :: nat set). (\<Pi>\<^sub>Q i\<in>{..<n}. X)"
abbreviation list_nil :: "nat \<times> (nat \<Rightarrow> 'a)" where
"list_nil \<equiv> (0, \<lambda>n. undefined)"
abbreviation list_cons :: "['a, nat \<times> (nat \<Rightarrow> 'a)] \<Rightarrow> nat \<times> (nat \<Rightarrow> 'a)" where
"list_cons x l \<equiv> (Suc (fst l), (\<lambda>n. if n = 0 then x else (snd l) (n - 1)))"

definition list_head :: "nat \<times> (nat \<Rightarrow> 'a) \<Rightarrow> 'a" where
"list_head l = snd l 0"
definition list_tail :: "nat \<times> (nat \<Rightarrow> 'a) \<Rightarrow> nat \<times> (nat \<Rightarrow> 'a)" where
"list_tail l = (fst l - 1, \<lambda>m. (snd l) (Suc m))"

lemma list_simp1:
 "list_nil \<noteq> list_cons x l"
  by simp

lemma list_simp2:
  assumes "list_cons a al = list_cons b bl"
  shows "a = b" "al = bl"
proof -
  have "a = snd (list_cons a al) 0"
       "b = snd (list_cons b bl) 0"
    by auto
  thus "a = b"
    by(simp add: assms)
next
  have "fst al = fst bl"
    using assms by simp
  moreover have "snd al = snd bl"
  proof
    fix n
    have "snd al n = snd (list_cons a al) (Suc n)"
      by simp
    also have "... = snd (list_cons b bl) (Suc n)"
      by (simp add: assms)
    also have "... = snd bl n"
      by simp
    finally show "snd al n = snd bl n" .
  qed
  ultimately show "al = bl"
    by (simp add: prod.expand)
qed

lemma list_simp3:
  shows "list_head (list_cons a l) = a"
  by(simp add: list_head_def)

lemma list_simp4:
  assumes "l \<in> qbs_space (list_of X)"
  shows "list_tail (list_cons a l) = l"
  using assms by(simp_all add: list_tail_def)

lemma list_decomp1:
  assumes "l \<in> qbs_space (list_of X)"
  shows "l = list_nil \<or>
         (\<exists>a l'. a \<in> qbs_space X \<and> l' \<in> qbs_space (list_of X) \<and> l = list_cons a l')"
proof(cases l)
  case hl:(Pair n f)
  show ?thesis
  proof(cases n)
    case 0
    then show ?thesis
      using assms hl by simp
  next
    case hn:(Suc n')
    define f' where "f' \<equiv> \<lambda>m. f (Suc m)"
    have "l = list_cons (f 0) (n',f')"
    proof(simp add: hl hn, standard)
      fix m
      show "f m = (if m = 0 then f 0 else snd (n', f') (m - 1))"
        using assms hl by(cases m; fastforce simp: f'_def)
    qed
    moreover have "(n', f') \<in> qbs_space (list_of X)"
    proof(simp,rule PiE_I)
      show "\<And>x. x \<in> {..<n'} \<Longrightarrow> f' x \<in> qbs_space X"
        using assms hl hn by(fastforce simp: f'_def)
    next
      fix x
      assume 1:"x \<notin> {..<n'}"
      thus " f' x = undefined"
        using hl assms hn by(auto simp: f'_def)
    qed
    ultimately show ?thesis
      using hl assms
      by(auto intro!: exI[where x="f 0"] exI[where x="(n',\<lambda>m. if m = 0 then undefined else f (Suc m))"])
  qed
qed

lemma list_simp5:
  assumes "l \<in> qbs_space (list_of X)"
      and "l \<noteq> list_nil"
    shows "l = list_cons (list_head l) (list_tail l)"
proof -
  obtain a l' where hl:
  "a \<in> qbs_space X" "l' \<in> qbs_space (list_of X)" "l = list_cons a l'"
    using list_decomp1[OF assms(1)] assms(2) by blast
  hence "list_head l = a" "list_tail l = l'"
    using list_simp3 list_simp4 by auto
  thus ?thesis
    using hl(3) list_simp2 by auto
qed

lemma list_simp6:
 "list_nil \<in> qbs_space (list_of X)"
  by simp

lemma list_simp7:
  assumes "a \<in> qbs_space X"
      and "l \<in> qbs_space (list_of X)"
    shows "list_cons a l \<in> qbs_space (list_of X)"
  using assms by(fastforce simp: PiE_def extensional_def)

lemma list_destruct_rule:
  assumes "l \<in> qbs_space (list_of X)"
          "P list_nil"
      and "\<And>a l'. a \<in> qbs_space X \<Longrightarrow> l' \<in> qbs_space (list_of X) \<Longrightarrow> P (list_cons a l')"
    shows "P l"
  by(rule disjE[OF list_decomp1[OF assms(1)]]) (use assms in auto)

lemma list_induct_rule:
  assumes "l \<in> qbs_space (list_of X)"
          "P list_nil"
      and "\<And>a l'. a \<in> qbs_space X \<Longrightarrow> l' \<in> qbs_space (list_of X) \<Longrightarrow> P l' \<Longrightarrow> P (list_cons a l')"
    shows "P l"
proof(cases l)
  case hl:(Pair n f)
  then show ?thesis
    using assms(1)
  proof(induction n arbitrary: f l)
    case 0
    then show ?case
      using assms(1,2) by simp
  next
    case ih:(Suc n)
    then obtain a l' where hl:
    "a \<in> qbs_space X" "l' \<in> qbs_space (list_of X)" "l = list_cons a l'"
      using list_decomp1 by blast
    have "P l'"
      using ih hl(3)
      by(auto intro!: ih(1)[OF _ hl(2),of "snd l'"])
    from assms(3)[OF hl(1,2) this]
    show ?case
      by(simp add: hl(3))
  qed
qed

fun from_list :: "'a list \<Rightarrow> nat \<times> (nat \<Rightarrow> 'a)" where
 "from_list [] = list_nil" |
 "from_list (a#l) = list_cons a (from_list l)"

fun to_list' ::  "nat \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> 'a list" where
 "to_list' 0 _ = []" |
 "to_list' (Suc n) f = f 0 # to_list' n (\<lambda>n. f (Suc n))"

definition to_list :: "nat \<times> (nat \<Rightarrow> 'a) \<Rightarrow> 'a list" where
"to_list \<equiv> case_prod to_list'"

lemma to_list_simp1:
  shows "to_list list_nil = []"
  by(simp add: to_list_def)

lemma to_list_simp2:
  assumes "l \<in> qbs_space (list_of X)"
  shows "to_list (list_cons a l) = a # to_list l"
  using assms by(auto simp:PiE_def to_list_def)

lemma from_list_length:
 "fst (from_list l) = length l"
  by(induction l, simp_all)

lemma from_list_in_list_of:
  assumes "set l \<subseteq> qbs_space X"
  shows "from_list l \<in> qbs_space (list_of X)"
  using assms by(induction l) (auto simp: PiE_def extensional_def Pi_def)

lemma from_list_in_list_of':
  shows "from_list l \<in> qbs_space (list_of (Abs_quasi_borel (UNIV,UNIV)))"
proof -
  have "set l \<subseteq> qbs_space (Abs_quasi_borel (UNIV,UNIV))"
    by(simp add: qbs_space_def Abs_quasi_borel_inverse[of "(UNIV,UNIV)",simplified is_quasi_borel_def qbs_closed1_def qbs_closed2_def qbs_closed3_def,simplified])
  thus ?thesis
    using from_list_in_list_of by blast
qed

lemma list_cons_in_list_of:
  assumes "set (a#l) \<subseteq> qbs_space X"
  shows "list_cons a (from_list l) \<in> qbs_space (list_of X)"
  using from_list_in_list_of[OF assms] by simp

lemma from_list_to_list_ident:
 "(to_list \<circ> from_list) l = l"
  by(induction l)
   (simp add: to_list_def,simp add: to_list_simp2[OF from_list_in_list_of'])

lemma to_list_from_list_ident:
  assumes "l \<in> qbs_space (list_of X)"
  shows "(from_list \<circ> to_list) l = l"
proof(rule list_induct_rule[OF assms])
  fix a l'
  assume h: "l' \<in> qbs_space (list_of X)"
     and ih:"(from_list \<circ> to_list) l' = l'"
  show "(from_list \<circ> to_list) (list_cons a l') = list_cons a l'"
    by(auto simp add: to_list_simp2[OF h] ih[simplified])
qed (simp add: to_list_simp1)

definition rec_list' :: "'b \<Rightarrow> ('a \<Rightarrow> (nat \<times> (nat \<Rightarrow> 'a)) \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> (nat \<times> (nat \<Rightarrow> 'a)) \<Rightarrow> 'b" where
"rec_list' t0 f l \<equiv> (rec_list t0 (\<lambda>x l'. f x (from_list l')) (to_list l))"

lemma rec_list'_simp1:
 "rec_list' t f list_nil = t"
  by(simp add: rec_list'_def to_list_simp1)

lemma rec_list'_simp2:
  assumes "l \<in> qbs_space (list_of X)"
  shows "rec_list' t f (list_cons x l) = f x l (rec_list' t f l)"
  by(simp add: rec_list'_def to_list_simp2[OF assms] to_list_from_list_ident[OF assms,simplified])

end


(*  Title:      HOL/HOLCF/Sfun.thy
    Author:     Brian Huffman
*)

section {* The Strict Function Type *}

theory Sfun
imports Cfun
begin

pcpodef ('a, 'b) sfun (infixr "->!" 0)
  = "{f :: 'a \<rightarrow> 'b. f\<cdot>\<bottom> = \<bottom>}"
by simp_all

type_notation (xsymbols)
  sfun  (infixr "\<rightarrow>!" 0)

text {* TODO: Define nice syntax for abstraction, application. *}

definition
  sfun_abs :: "('a \<rightarrow> 'b) \<rightarrow> ('a \<rightarrow>! 'b)"
where
  "sfun_abs = (\<Lambda> f. Abs_sfun (strictify\<cdot>f))"

definition
  sfun_rep :: "('a \<rightarrow>! 'b) \<rightarrow> 'a \<rightarrow> 'b"
where
  "sfun_rep = (\<Lambda> f. Rep_sfun f)"

lemma sfun_rep_beta: "sfun_rep\<cdot>f = Rep_sfun f"
  unfolding sfun_rep_def by (simp add: cont_Rep_sfun)

lemma sfun_rep_strict1 [simp]: "sfun_rep\<cdot>\<bottom> = \<bottom>"
  unfolding sfun_rep_beta by (rule Rep_sfun_strict)

lemma sfun_rep_strict2 [simp]: "sfun_rep\<cdot>f\<cdot>\<bottom> = \<bottom>"
  unfolding sfun_rep_beta by (rule Rep_sfun [simplified])

lemma strictify_cancel: "f\<cdot>\<bottom> = \<bottom> \<Longrightarrow> strictify\<cdot>f = f"
  by (simp add: cfun_eq_iff strictify_conv_if)

lemma sfun_abs_sfun_rep [simp]: "sfun_abs\<cdot>(sfun_rep\<cdot>f) = f"
  unfolding sfun_abs_def sfun_rep_def
  apply (simp add: cont_Abs_sfun cont_Rep_sfun)
  apply (simp add: Rep_sfun_inject [symmetric] Abs_sfun_inverse)
  apply (simp add: cfun_eq_iff strictify_conv_if)
  apply (simp add: Rep_sfun [simplified])
  done

lemma sfun_rep_sfun_abs [simp]: "sfun_rep\<cdot>(sfun_abs\<cdot>f) = strictify\<cdot>f"
  unfolding sfun_abs_def sfun_rep_def
  apply (simp add: cont_Abs_sfun cont_Rep_sfun)
  apply (simp add: Abs_sfun_inverse)
  done

lemma sfun_eq_iff: "f = g \<longleftrightarrow> sfun_rep\<cdot>f = sfun_rep\<cdot>g"
by (simp add: sfun_rep_def cont_Rep_sfun Rep_sfun_inject)

lemma sfun_below_iff: "f \<sqsubseteq> g \<longleftrightarrow> sfun_rep\<cdot>f \<sqsubseteq> sfun_rep\<cdot>g"
by (simp add: sfun_rep_def cont_Rep_sfun below_sfun_def)

end