(*  Title:       The Inductive Unwinding Theorem for CSP Noninterference Security
    Author:      Pasquale Noce
                 Security Certification Specialist at Arjo Systems - Gep S.p.A.
                 pasquale dot noce dot lavoro at gmail dot com
                 pasquale dot noce at arjowiggins-it dot com
*)

section "The Inductive Unwinding Theorem"

theory InductiveUnwinding
imports Noninterference_Ipurge_Unwinding.DeterministicProcesses
begin

text \<open>
\null

The necessary and sufficient condition for CSP noninterference security \<^cite>\<open>"R2"\<close> stated by the
Ipurge Unwinding Theorem \<^cite>\<open>"R3"\<close> is expressed in terms of a pair of event lists varying over the
set of process traces. This does not render it suitable for the subsequent application of rule
induction in the case of a process defined inductively, since rule induction may rather be applied
to a single variable ranging over an inductively defined set (cf. \<^cite>\<open>"R6"\<close>).

However, the formulation of an inductive definition is the standard way of defining a process that
admits traces of unbounded length, indeed because it provides rule induction as a powerful method to
prove process properties, particularly noninterference security, by considering any indefinitely
long trace of the process. Therefore, it is essential to infer some condition equivalent to CSP
noninterference security and suitable for being handled by means of rule induction.

Starting from the Ipurge Unwinding Theorem, this paper derives a necessary and sufficient condition
for CSP noninterference security that involves a single event list varying over the set of process
traces, and is thus suitable for rule induction; hence its name, \emph{Inductive Unwinding Theorem}.
Similarly to the Ipurge Unwinding Theorem, the new theorem only requires to consider individual
accepted and refused events for each process trace, and applies to the general case of a possibly
intransitive noninterference policy. Specific variants of this theorem are additionally proven for
deterministic processes and trace set processes \<^cite>\<open>"R3"\<close>.

For details about the theory of Communicating Sequential Processes, to which the notion of process
security defined in \<^cite>\<open>"R2"\<close> and applied in this paper refers, cf. \<^cite>\<open>"R4"\<close>.

As regards the formal contents of this paper, the salient points of definitions and proofs are
commented; for additional information, cf. Isabelle documentation, particularly \<^cite>\<open>"R6"\<close>,
\<^cite>\<open>"R7"\<close>, \<^cite>\<open>"R8"\<close>, and \<^cite>\<open>"R9"\<close>.
\<close>

subsection "Propaedeutic lemmas"

text \<open>
Here below are the proofs of some lemmas on the constants defined in \<^cite>\<open>"R2"\<close> and \<^cite>\<open>"R3"\<close> which
are propaedeutic to the demonstration of the Inductive Unwinding Theorem.

Among other things, the lemmas being proven formalize the following statements:

\begin{itemize}

\item
A set of domains @{term U} may affect a set of domains @{term V} via an event list @{term xs}, as
expressed through function @{term sinks_aux}, just in case @{term V} may be affected by @{term U}
via @{term xs}, as expressed through function @{term sources_aux}.

\item
The event lists output by function @{term ipurge_tr} are not longer than the corresponding input
ones.

\item
Function @{term ipurge_tr_rev} is idempotent.

\end{itemize}

\null
\<close>

lemma sources_aux_single_dom:
 "sources_aux I D {u} xs = insert u (sources I D u xs)"
by (simp add: sources_sinks sources_sinks_aux sinks_aux_single_dom)

lemma sources_interference_eq:
 "((D x, u) \<in> I \<or> (\<exists>v \<in> sources I D u xs. (D x, v) \<in> I)) =
  (D x \<in> sources I D u (x # xs))"
proof (simp only: sources_sinks rev.simps, subst (1 2) converse_iff [symmetric])
qed (rule sinks_interference_eq)

lemma ex_sinks_sources_aux_1 [rule_format]:
 "(\<exists>u \<in> sinks_aux I D U xs. \<exists>v \<in> V. (u, v) \<in> I) \<longrightarrow>
  (\<exists>u \<in> U. \<exists>v \<in> sources_aux I D V xs. (u, v) \<in> I)"
proof (induction xs arbitrary: V rule: rev_induct, simp, subst sources_aux_append,
 rule impI)
  fix x xs V
  let
    ?V = "sources_aux I D V [x]" and
    ?V' = "insert (D x) V"
  assume
    A: "\<And>V. (\<exists>u \<in> sinks_aux I D U xs. \<exists>v \<in> V. (u, v) \<in> I) \<longrightarrow>
      (\<exists>u \<in> U. \<exists>v \<in> sources_aux I D V xs. (u, v) \<in> I)" and
    B: "\<exists>u \<in> sinks_aux I D U (xs @ [x]). \<exists>v \<in> V. (u, v) \<in> I"
  show "\<exists>u \<in> U. \<exists>v \<in> sources_aux I D ?V xs. (u, v) \<in> I"
  proof (cases "\<exists>u \<in> sinks_aux I D U xs. (u, D x) \<in> I")
    case True
    hence "(\<exists>v \<in> V. (D x, v) \<in> I) \<or>
      (\<exists>u \<in> sinks_aux I D U xs. \<exists>v \<in> V. (u, v) \<in> I)"
     (is "?A \<or> ?B") using B by simp
    moreover {
      assume ?A
      have "(\<exists>u \<in> sinks_aux I D U xs. \<exists>v \<in> ?V'. (u, v) \<in> I) \<longrightarrow>
        (\<exists>u \<in> U. \<exists>v \<in> sources_aux I D ?V' xs. (u, v) \<in> I)"
       using A .
      moreover obtain u where
        C: "u \<in> sinks_aux I D U xs" and D: "(u, D x) \<in> I"
       using True ..
      have "D x \<in> ?V'" by simp
      with D have "\<exists>v \<in> ?V'. (u, v) \<in> I" ..
      hence "\<exists>u \<in> sinks_aux I D U xs. \<exists>v \<in> ?V'. (u, v) \<in> I" using C ..
      ultimately have "\<exists>u \<in> U. \<exists>v \<in> sources_aux I D ?V' xs. (u, v) \<in> I" ..
      hence ?thesis using \<open>?A\<close> by simp
    }
    moreover {
      assume ?B
      have "(\<exists>u \<in> sinks_aux I D U xs. \<exists>v \<in> ?V. (u, v) \<in> I) \<longrightarrow>
        (\<exists>u \<in> U. \<exists>v \<in> sources_aux I D ?V xs. (u, v) \<in> I)"
       using A .
      moreover obtain u where
        C: "u \<in> sinks_aux I D U xs" and D: "\<exists>v \<in> V. (u, v) \<in> I"
       using \<open>?B\<close> ..
      have "V \<subseteq> ?V" by (rule sources_aux_subset)
      hence "\<exists>v \<in> ?V. (u, v) \<in> I" using D by simp
      hence "\<exists>u \<in> sinks_aux I D U xs. \<exists>v \<in> ?V. (u, v) \<in> I" using C ..
      ultimately have ?thesis ..
    }
    ultimately show ?thesis ..
  next
    case False
    have "(\<exists>u \<in> sinks_aux I D U xs. \<exists>v \<in> ?V. (u, v) \<in> I) \<longrightarrow>
      (\<exists>u \<in> U. \<exists>v \<in> sources_aux I D ?V xs. (u, v) \<in> I)"
     using A .
    moreover have "\<exists>u \<in> sinks_aux I D U xs. \<exists>v \<in> V. (u, v) \<in> I"
     using B and False by simp
    then obtain u where
      C: "u \<in> sinks_aux I D U xs" and D: "\<exists>v \<in> V. (u, v) \<in> I" ..
    have "V \<subseteq> ?V" by (rule sources_aux_subset)
    hence "\<exists>v \<in> ?V. (u, v) \<in> I" using D by simp
    hence "\<exists>u \<in> sinks_aux I D U xs. \<exists>v \<in> ?V. (u, v) \<in> I" using C ..
    ultimately show ?thesis ..
  qed
qed

lemma ex_sinks_sources_aux_2 [rule_format]:
 "(\<exists>u \<in> U. \<exists>v \<in> sources_aux I D V xs. (u, v) \<in> I) \<longrightarrow>
  (\<exists>u \<in> sinks_aux I D U xs. \<exists>v \<in> V. (u, v) \<in> I)"
proof (induction xs arbitrary: V rule: rev_induct, simp, subst sources_aux_append,
 rule impI)
  fix x xs V
  let
    ?V = "sources_aux I D V [x]" and
    ?V' = "insert (D x) V"
  assume
    A: "\<And>V. (\<exists>u \<in> U. \<exists>v \<in> sources_aux I D V xs. (u, v) \<in> I) \<longrightarrow>
      (\<exists>u \<in> sinks_aux I D U xs. \<exists>v \<in> V. (u, v) \<in> I)" and
    B: "\<exists>u \<in> U. \<exists>v \<in> sources_aux I D ?V xs. (u, v) \<in> I"
  show "\<exists>u \<in> sinks_aux I D U (xs @ [x]). \<exists>v \<in> V. (u, v) \<in> I"
  proof (cases "\<exists>u \<in> sinks_aux I D U xs. (u, D x) \<in> I",
   cases "\<exists>v \<in> V. (D x, v) \<in> I", simp_all (no_asm_simp))
    have "(\<exists>u \<in> U. \<exists>v \<in> sources_aux I D V xs. (u, v) \<in> I) \<longrightarrow>
      (\<exists>u \<in> sinks_aux I D U xs. \<exists>v \<in> V. (u, v) \<in> I)"
     using A .
    moreover assume "\<not> (\<exists>v \<in> V. (D x, v) \<in> I)"
    hence "\<exists>u \<in> U. \<exists>v \<in> sources_aux I D V xs. (u, v) \<in> I" using B by simp
    ultimately show "\<exists>u \<in> sinks_aux I D U xs. \<exists>v \<in> V. (u, v) \<in> I" ..
  next
    assume C: "\<not> (\<exists>u \<in> sinks_aux I D U xs. (u, D x) \<in> I)"
    have "(\<exists>u \<in> U. \<exists>v \<in> sources_aux I D ?V xs. (u, v) \<in> I) \<longrightarrow>
      (\<exists>u \<in> sinks_aux I D U xs. \<exists>v \<in> ?V. (u, v) \<in> I)"
     using A .
    hence "\<exists>u \<in> sinks_aux I D U xs. \<exists>v \<in> ?V. (u, v) \<in> I" using B ..
    then obtain u where
      D: "u \<in> sinks_aux I D U xs" and E: "\<exists>v \<in> ?V. (u, v) \<in> I" ..
    obtain v where F: "v \<in> ?V" and G: "(u, v) \<in> I" using E ..
    have "v = D x \<or> v \<in> V" using F by (cases "\<exists>v \<in> V. (D x, v) \<in> I", simp_all)
    moreover {
      assume "v = D x"
      hence "(u, D x) \<in> I" using G by simp
      hence "\<exists>u \<in> sinks_aux I D U xs. (u, D x) \<in> I" using D ..
      hence "\<exists>u \<in> sinks_aux I D U xs. \<exists>v \<in> V. (u, v) \<in> I"
       using C by contradiction
    }
    moreover {
      assume "v \<in> V"
      with G have "\<exists>v \<in> V. (u, v) \<in> I" ..
      hence "\<exists>u \<in> sinks_aux I D U xs. \<exists>v \<in> V. (u, v) \<in> I" using D ..
    }
    ultimately show "\<exists>u \<in> sinks_aux I D U xs. \<exists>v \<in> V. (u, v) \<in> I" ..
  qed
qed

lemma ex_sinks_sources_aux:
 "(\<exists>u \<in> sinks_aux I D U xs. \<exists>v \<in> V. (u, v) \<in> I) =
  (\<exists>u \<in> U. \<exists>v \<in> sources_aux I D V xs. (u, v) \<in> I)"
by (rule iffI, erule ex_sinks_sources_aux_1, rule ex_sinks_sources_aux_2)

lemma ipurge_tr_rev_ipurge_tr_sources_aux_1 [rule_format]:
 "\<not> (\<exists>v \<in> D ` set ys. \<exists>u \<in> sources_aux I D U zs. (v, u) \<in> I) \<longrightarrow>
  ipurge_tr_rev_aux I D U (xs @ ys @ zs) =
  ipurge_tr_rev_aux I D U (xs @ ipurge_tr_aux I D (D ` set ys) zs)"
proof (induction zs arbitrary: U rule: rev_induct, rule_tac [!] impI,
 simp del: bex_simps)
  fix U
  assume "\<not> (\<exists>v \<in> D ` set ys. \<exists>u \<in> U. (v, u) \<in> I)"
  hence "ipurge_tr_rev_aux I D U ys = []" by (simp add: ipurge_tr_rev_aux_nil)
  thus "ipurge_tr_rev_aux I D U (xs @ ys) = ipurge_tr_rev_aux I D U xs"
   by (simp add: ipurge_tr_rev_aux_append_nil)
next
  fix z zs U
  let
    ?U = "sources_aux I D U [z]" and
    ?U' = "insert (D z) U"
  assume "\<And>U. \<not> (\<exists>v \<in> D ` set ys. \<exists>u \<in> sources_aux I D U zs. (v, u) \<in> I) \<longrightarrow>
    ipurge_tr_rev_aux I D U (xs @ ys @ zs) =
    ipurge_tr_rev_aux I D U (xs @ ipurge_tr_aux I D (D ` set ys) zs)"
  hence "\<not> (\<exists>v \<in> D ` set ys. \<exists>u \<in> sources_aux I D ?U zs. (v, u) \<in> I) \<longrightarrow>
    ipurge_tr_rev_aux I D ?U (xs @ ys @ zs) =
    ipurge_tr_rev_aux I D ?U (xs @ ipurge_tr_aux I D (D ` set ys) zs)" .
  moreover assume
   "\<not> (\<exists>v \<in> D ` set ys. \<exists>u \<in> sources_aux I D U (zs @ [z]). (v, u) \<in> I)"
  hence A:
   "\<not> (\<exists>v \<in> D ` set ys. \<exists>u \<in> sources_aux I D ?U zs. (v, u) \<in> I)"
   by (subst (asm) sources_aux_append)
  ultimately have B:
   "ipurge_tr_rev_aux I D ?U (xs @ ys @ zs) =
    ipurge_tr_rev_aux I D ?U (xs @ ipurge_tr_aux I D (D ` set ys) zs)" ..
  have
   "ipurge_tr_rev_aux I D U (xs @ ys @ zs @ [z]) =
    ipurge_tr_rev_aux I D U ((xs @ ys @ zs) @ [z])"
   by simp
  hence C:
   "ipurge_tr_rev_aux I D U (xs @ ys @ zs @ [z]) =
    ipurge_tr_rev_aux I D ?U (xs @ ys @ zs) @ ipurge_tr_rev_aux I D U [z]"
   (is "_ = _ @ ?ws") by (simp only: ipurge_tr_rev_aux_append)
  show
   "ipurge_tr_rev_aux I D U (xs @ ys @ zs @ [z]) =
    ipurge_tr_rev_aux I D U (xs @ ipurge_tr_aux I D (D ` set ys) (zs @ [z]))"
  proof (subst C, cases "\<exists>u \<in> U. (D z, u) \<in> I",
   simp_all (no_asm_simp) del: ipurge_tr_aux.simps)
    case True
    have "\<not> (\<exists>v \<in> sinks_aux I D (D ` set ys) zs. \<exists>u \<in> ?U. (v, u) \<in> I)"
     using A by (simp add: ex_sinks_sources_aux)
    hence "\<not> (\<exists>v \<in> sinks_aux I D (D ` set ys) zs. (v, D z) \<in> I)"
     using True by simp
    hence
     "ipurge_tr_rev_aux I D U (xs @ ipurge_tr_aux I D (D ` set ys) (zs @ [z])) =
      ipurge_tr_rev_aux I D U ((xs @ ipurge_tr_aux I D (D ` set ys) zs) @ [z])"
     by simp
    also have "\<dots> =
      ipurge_tr_rev_aux I D ?U (xs @ ipurge_tr_aux I D (D ` set ys) zs) @ ?ws"
     by (simp only: ipurge_tr_rev_aux_append)
    also have "\<dots> =
      ipurge_tr_rev_aux I D ?U' (xs @ ipurge_tr_aux I D (D ` set ys) zs) @ [z]"
     using True by simp
    finally have
     "ipurge_tr_rev_aux I D U (xs @ ipurge_tr_aux I D (D ` set ys) (zs @ [z])) =
      ipurge_tr_rev_aux I D ?U' (xs @ ipurge_tr_aux I D (D ` set ys) zs) @ [z]" .
    thus
     "ipurge_tr_rev_aux I D ?U' (xs @ ys @ zs) @ [z] =
      ipurge_tr_rev_aux I D U (xs @ ipurge_tr_aux I D (D ` set ys) (zs @ [z]))"
     using B and True by simp
  next
    case False
    have
     "ipurge_tr_rev_aux I D U (xs @ ipurge_tr_aux I D (D ` set ys) (zs @ [z])) =
      ipurge_tr_rev_aux I D U (xs @ ipurge_tr_aux I D (D ` set ys) zs)"
    proof (cases "\<exists>v \<in> sinks_aux I D (D ` set ys) zs. (v, D z) \<in> I", simp_all)
      have
       "ipurge_tr_rev_aux I D U (xs @ ipurge_tr_aux I D (D ` set ys) zs @ [z]) =
        ipurge_tr_rev_aux I D U ((xs @ ipurge_tr_aux I D (D ` set ys) zs) @ [z])"
       by simp
      also have "\<dots> =
        ipurge_tr_rev_aux I D ?U (xs @ ipurge_tr_aux I D (D ` set ys) zs) @ ?ws"
       by (simp only: ipurge_tr_rev_aux_append)
      also have "\<dots> =
        ipurge_tr_rev_aux I D U (xs @ ipurge_tr_aux I D (D ` set ys) zs)"
       using False by simp
      finally show
       "ipurge_tr_rev_aux I D U (xs @ ipurge_tr_aux I D (D ` set ys) zs @ [z]) =
        ipurge_tr_rev_aux I D U (xs @ ipurge_tr_aux I D (D ` set ys) zs)" .
    qed
    thus
     "ipurge_tr_rev_aux I D U (xs @ ys @ zs) =
      ipurge_tr_rev_aux I D U (xs @ ipurge_tr_aux I D (D ` set ys) (zs @ [z]))"
     using B and False by simp
  qed
qed

lemma ipurge_tr_rev_ipurge_tr_sources_1:
  assumes A: "D y \<notin> sources I D u (y # zs)"
  shows
   "ipurge_tr_rev I D u (xs @ y # zs) =
    ipurge_tr_rev I D u (xs @ ipurge_tr I D (D y) zs)"
proof -
  have "\<not> ((D y, u) \<in> I \<or> (\<exists>v \<in> sources I D u zs. (D y, v) \<in> I))"
   using A by (simp only: sources_interference_eq, simp)
  hence "\<not> (\<exists>v \<in> D ` set [y]. \<exists>u \<in> sources_aux I D {u} zs. (v, u) \<in> I)"
   by (simp add: sources_aux_single_dom)
  hence
   "ipurge_tr_rev_aux I D {u} (xs @ [y] @ zs) =
    ipurge_tr_rev_aux I D {u} (xs @ ipurge_tr_aux I D (D ` set [y]) zs)"
   by (rule ipurge_tr_rev_ipurge_tr_sources_aux_1)
  thus ?thesis by (simp add: ipurge_tr_aux_single_dom ipurge_tr_rev_aux_single_dom)
qed

lemma ipurge_tr_length:
 "length (ipurge_tr I D u xs) \<le> length xs"
by (induction xs rule: rev_induct, simp_all)

lemma sources_idem:
 "sources I D u (ipurge_tr_rev I D u xs) = sources I D u xs"
by (induction xs, simp_all)

lemma ipurge_tr_rev_idem:
 "ipurge_tr_rev I D u (ipurge_tr_rev I D u xs) = ipurge_tr_rev I D u xs"
by (induction xs, simp_all add: sources_idem)

subsection "Closure of the traces of a secure process under reverse intransitive purge"

text \<open>
The derivation of the Inductive Unwinding Theorem from the Ipurge Unwinding Theorem requires to
prove that the set of the traces of a secure process is closed under reverse intransitive purge,
i.e. function @{term ipurge_tr_rev} \<^cite>\<open>"R3"\<close>. This can be expressed formally by means of the
following statement:

\null

@{term "secure P I D \<Longrightarrow> xs \<in> traces P \<Longrightarrow> ipurge_tr_rev I D u xs \<in> traces P"}

\null

The reason why such closure property holds is that the reverse intransitive purge of a list
@{term xs} with regard to a policy @{term I}, an event-domain map @{term D}, and a domain @{term u}
can equivalently be computed as follows: for each item @{term x} of @{term xs}, if @{term x} may
affect @{term u}, retain @{term x} and go on recursively using as input the sublist of @{term xs}
following @{term x}, say @{term xs'}; otherwise, discard @{term x} and go on recursively using
@{term "ipurge_tr I D (D x) xs'"} \<^cite>\<open>"R2"\<close> as input.

The result actually matches @{term "ipurge_tr_rev I D u xs"}. In fact, for each @{term x} not
affecting @{term u}, @{term "ipurge_tr I D (D x) xs'"} retains any item of @{term xs'} not affected
by @{term x}, which is the case for any item of @{term xs'} affecting @{term u}, since otherwise
@{term x} would affect @{term u}.

Furthermore, if @{term xs} is a trace of a secure process, the result is still a trace. In fact, for
each @{term x} not affecting @{term u}, if @{term ys} is the partial output for the sublist of
@{term xs} preceding @{term x}, then @{term "ys @ ipurge_tr I D (D x) xs'"} is a trace provided such
is @{term "ys @ x # xs'"}, by virtue of the definition of CSP noninterference security \<^cite>\<open>"R2"\<close>.
Hence, the property of being a trace is conserved upon each recursive call by the concatenation of
the partial output and the residual input, until the latter is nil and the former matches the total
output.

This argument shows that in order to prove by induction, under the aforesaid assumptions, that the
output of such a reverse intransitive purge function is a trace, the partial output has to be passed
to the function as an argument, in addition to the residual input, in the recursive calls contained
within the definition of the function. Therefore, the output of the function has to be accumulated
into one of its parameters, viz. the function needs to be tail-recursive. This suggests to prove the
properties of interest of the function by applying the ten-step proof method for theorems on
tail-recursive functions described in \<^cite>\<open>"R1"\<close>.

The starting point is to formulate a naive definition of the function, which will then be refined as
specified by the proof method. The name of the refined function, from which the name of the naive
function here below is derived, will be \<open>ipurge_tr_rev_t\<close>, where suffix \emph{t} stands for
\emph{tail-recursive}.

\null
\<close>

function (sequential) ipurge_tr_rev_t_naive ::
  "('d \<times> 'd) set \<Rightarrow> ('a \<Rightarrow> 'd) \<Rightarrow> 'd \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"ipurge_tr_rev_t_naive I D u (x # xs) ys =
 (if D x \<in> sources I D u (x # xs)
  then ipurge_tr_rev_t_naive I D u xs (ys @ [x])
  else ipurge_tr_rev_t_naive I D u (ipurge_tr I D (D x) xs) ys)" |
"ipurge_tr_rev_t_naive _ _ _ _ ys = ys"
oops

text \<open>
\null

The parameter into which the output is accumulated is the last one.

As shown by the previous argument, the properties of function @{term ipurge_tr_rev_t_naive} that
would have to be proven are the following ones:

\null

@{term "ipurge_tr_rev_t_naive I D u xs [] = ipurge_tr_rev I D u xs"}

\null

@{term "secure P I D \<Longrightarrow> xs \<in> traces P \<Longrightarrow> ipurge_tr_rev_t_naive I D u xs [] \<in> traces P"}

\null

as they clearly entail the above formal statement of the target closure lemma.
\<close>

subsubsection "Step 1"

text \<open>
In the definition of the auxiliary tail-recursive function @{term ipurge_tr_rev_t_aux}, the
Cartesian product of the input types of function @{term ipurge_tr_rev_t_naive} will be implemented
as a record type.

\null
\<close>

record ('a, 'd) ipurge_rec =
  Pol :: "('d \<times> 'd) set"
  Map :: "'a \<Rightarrow> 'd"
  Dom :: 'd
  In :: "'a list"
  Out :: "'a list"

function (sequential) ipurge_tr_rev_t_aux ::
  "('a, 'd) ipurge_rec \<Rightarrow> ('a, 'd) ipurge_rec" where
"ipurge_tr_rev_t_aux \<lparr>Pol = I, Map = D, Dom = u, In = x # xs, Out = ys\<rparr> =
 (if D x \<in> sources I D u (x # xs)
  then ipurge_tr_rev_t_aux
    \<lparr>Pol = I, Map = D, Dom = u, In = xs, Out = ys @ [x]\<rparr>
  else ipurge_tr_rev_t_aux
    \<lparr>Pol = I, Map = D, Dom = u, In = ipurge_tr I D (D x) xs, Out = ys\<rparr>)" |
"ipurge_tr_rev_t_aux X = X"
proof (simp_all, atomize_elim)
  fix X :: "('a, 'd) ipurge_rec"
  show
   "(\<exists>I D u x xs ys.
      X = \<lparr>Pol = I, Map = D, Dom = u, In = x # xs, Out = ys\<rparr>) \<or>
    (\<exists>I D u ys.
      X = \<lparr>Pol = I, Map = D, Dom = u, In = [], Out = ys\<rparr>)"
  proof (cases X, simp_all)
  qed (subst disj_commute, rule spec [OF list.nchotomy])
qed

termination ipurge_tr_rev_t_aux
proof (relation "measure (\<lambda>X. length (In X))", simp_all)
  fix D :: "'a \<Rightarrow> 'd" and I x xs
  have "length (ipurge_tr I D (D x) xs) \<le> length xs" by (rule ipurge_tr_length)
  thus "length (ipurge_tr I D (D x) xs) < Suc (length xs)" by simp
qed

text \<open>
\null

As shown by this proof, the termination of function @{term ipurge_tr_rev_t_aux} is guaranteed by the
fact, proven previously, that the event lists output by function @{term ipurge_tr} are not longer
than the corresponding input ones.
\<close>

subsubsection "Step 2"

definition ipurge_tr_rev_t_in ::
  "('d \<times> 'd) set \<Rightarrow> ('a \<Rightarrow> 'd) \<Rightarrow> 'd \<Rightarrow> 'a list \<Rightarrow> ('a, 'd) ipurge_rec" where
"ipurge_tr_rev_t_in I D u xs \<equiv>
  \<lparr>Pol = I, Map = D, Dom = u, In = xs, Out = []\<rparr>"

definition ipurge_tr_rev_t_out ::
  "('a, 'd) ipurge_rec \<Rightarrow> 'a list" where
"ipurge_tr_rev_t_out \<equiv> Out"

definition ipurge_tr_rev_t ::
  "('d \<times> 'd) set \<Rightarrow> ('a \<Rightarrow> 'd) \<Rightarrow> 'd \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"ipurge_tr_rev_t I D u xs \<equiv>
  ipurge_tr_rev_t_out (ipurge_tr_rev_t_aux (ipurge_tr_rev_t_in I D u xs))"

text \<open>
\null

Since the significant inputs of function @{term ipurge_tr_rev_t_naive} match pattern \<open>_\<close>,
\<open>_\<close>, \<open>_\<close>, \<open>_\<close>, @{term "[]"}, those of function @{term ipurge_tr_rev_t_aux}, as
returned by function @{term ipurge_tr_rev_t_in}, match pattern
\<open>\<lparr>Pol = _, Map = _, Dom = _, In = _, Out = []\<rparr>\<close>.

In terms of function @{term ipurge_tr_rev_t}, the statements to be proven, henceforth respectively
named \<open>ipurge_tr_rev_t_equiv\<close> and \<open>ipurge_tr_rev_t_trace\<close>, take the following form:

\null

@{term "ipurge_tr_rev_t I D u xs = ipurge_tr_rev I D u xs"}

\null

@{term "secure P I D \<Longrightarrow> xs \<in> traces P \<Longrightarrow> ipurge_tr_rev_t I D u xs \<in> traces P"}
\<close>

subsubsection "Step 3"

inductive_set ipurge_tr_rev_t_set :: "('a, 'd) ipurge_rec \<Rightarrow> ('a, 'd) ipurge_rec set"
  for X :: "('a, 'd) ipurge_rec" where
R0: "X \<in> ipurge_tr_rev_t_set X" |
R1: "\<lbrakk>\<lparr>Pol = I, Map = D, Dom = u, In = x # xs, Out = ys\<rparr>
        \<in> ipurge_tr_rev_t_set X;
      D x \<in> sources I D u (x # xs)\<rbrakk> \<Longrightarrow>
     \<lparr>Pol = I, Map = D, Dom = u, In = xs, Out = ys @ [x]\<rparr>
       \<in> ipurge_tr_rev_t_set X" |
R2: "\<lbrakk>\<lparr>Pol = I, Map = D, Dom = u, In = x # xs, Out = ys\<rparr>
        \<in> ipurge_tr_rev_t_set X;
      D x \<notin> sources I D u (x # xs)\<rbrakk> \<Longrightarrow>
     \<lparr>Pol = I, Map = D, Dom = u, In = ipurge_tr I D (D x) xs, Out = ys\<rparr>
       \<in> ipurge_tr_rev_t_set X"

subsubsection "Step 4"

lemma ipurge_tr_rev_t_subset:
  assumes A: "Y \<in> ipurge_tr_rev_t_set X"
  shows "ipurge_tr_rev_t_set Y \<subseteq> ipurge_tr_rev_t_set X"
proof (rule subsetI, erule ipurge_tr_rev_t_set.induct)
  show "Y \<in> ipurge_tr_rev_t_set X" using A .
next
  fix I D u x xs ys
  assume
    "\<lparr>Pol = I, Map = D, Dom = u, In = x # xs, Out = ys\<rparr>
       \<in> ipurge_tr_rev_t_set X" and
    "D x \<in> sources I D u (x # xs)"
  thus "\<lparr>Pol = I, Map = D, Dom = u, In = xs, Out = ys @ [x]\<rparr>
    \<in> ipurge_tr_rev_t_set X"
   by (rule R1)
next
  fix I D u x xs ys
  assume
    "\<lparr>Pol = I, Map = D, Dom = u, In = x # xs, Out = ys\<rparr>
       \<in> ipurge_tr_rev_t_set X" and
    "D x \<notin> sources I D u (x # xs)"
  thus "\<lparr>Pol = I, Map = D, Dom = u, In = ipurge_tr I D (D x) xs, Out = ys\<rparr>
    \<in> ipurge_tr_rev_t_set X"
   by (rule R2)
qed

lemma ipurge_tr_rev_t_aux_set:
 "ipurge_tr_rev_t_aux X \<in> ipurge_tr_rev_t_set X"
proof (induction rule: ipurge_tr_rev_t_aux.induct,
 simp_all only: ipurge_tr_rev_t_aux.simps(2) R0)
  fix I u x xs ys and D :: "'a \<Rightarrow> 'd"
  assume
    A: "D x \<in> sources I D u (x # xs) \<Longrightarrow>
        ipurge_tr_rev_t_aux
          \<lparr>Pol = I, Map = D, Dom = u, In = xs, Out = ys @ [x]\<rparr>
        \<in> ipurge_tr_rev_t_set
          \<lparr>Pol = I, Map = D, Dom = u, In = xs, Out = ys @ [x]\<rparr>"
      (is "_ \<Longrightarrow> ipurge_tr_rev_t_aux ?Y \<in> _") and
    B: "D x \<notin> sources I D u (x # xs) \<Longrightarrow>
        ipurge_tr_rev_t_aux
          \<lparr>Pol = I, Map = D, Dom = u, In = ipurge_tr I D (D x) xs, Out = ys\<rparr>
        \<in> ipurge_tr_rev_t_set
          \<lparr>Pol = I, Map = D, Dom = u, In = ipurge_tr I D (D x) xs, Out = ys\<rparr>"
      (is "_ \<Longrightarrow> ipurge_tr_rev_t_aux ?Z \<in> _")
  show
   "ipurge_tr_rev_t_aux
      \<lparr>Pol = I, Map = D, Dom = u, In = x # xs, Out = ys\<rparr>
    \<in> ipurge_tr_rev_t_set
      \<lparr>Pol = I, Map = D, Dom = u, In = x # xs, Out = ys\<rparr>"
    (is "ipurge_tr_rev_t_aux ?X \<in> _")
  proof (cases "D x \<in> sources I D u (x # xs)", simp_all del: sources.simps)
    case True
    have "?X \<in> ipurge_tr_rev_t_set ?X" by (rule R0)
    moreover have "?X \<in> ipurge_tr_rev_t_set ?X \<Longrightarrow> ?Y \<in> ipurge_tr_rev_t_set ?X"
     by (rule R1 [OF _ True])
    ultimately have "?Y \<in> ipurge_tr_rev_t_set ?X" by simp
    hence "ipurge_tr_rev_t_set ?Y \<subseteq> ipurge_tr_rev_t_set ?X"
     by (rule ipurge_tr_rev_t_subset)
    moreover have "ipurge_tr_rev_t_aux ?Y \<in> ipurge_tr_rev_t_set ?Y"
     using True by (rule A)
    ultimately show "ipurge_tr_rev_t_aux ?Y \<in> ipurge_tr_rev_t_set ?X" ..
  next
    case False
    have "?X \<in> ipurge_tr_rev_t_set ?X" by (rule R0)
    moreover have "?X \<in> ipurge_tr_rev_t_set ?X \<Longrightarrow> ?Z \<in> ipurge_tr_rev_t_set ?X"
     by (rule R2 [OF _ False])
    ultimately have "?Z \<in> ipurge_tr_rev_t_set ?X" by simp
    hence "ipurge_tr_rev_t_set ?Z \<subseteq> ipurge_tr_rev_t_set ?X"
     by (rule ipurge_tr_rev_t_subset)
    moreover have "ipurge_tr_rev_t_aux ?Z \<in> ipurge_tr_rev_t_set ?Z"
     using False by (rule B)
    ultimately show "ipurge_tr_rev_t_aux ?Z \<in> ipurge_tr_rev_t_set ?X" ..
  qed
qed

subsubsection "Step 5"

definition ipurge_tr_rev_t_inv_1 ::
  "('d \<times> 'd) set \<Rightarrow> ('a \<Rightarrow> 'd) \<Rightarrow> 'd \<Rightarrow> 'a list \<Rightarrow> ('a, 'd) ipurge_rec \<Rightarrow> bool"
where
"ipurge_tr_rev_t_inv_1 I D u xs X \<equiv>
  Out X @ ipurge_tr_rev I D u (In X) = ipurge_tr_rev I D u xs"

definition ipurge_tr_rev_t_inv_2 ::
  "'a process \<Rightarrow> ('d \<times> 'd) set \<Rightarrow> ('a \<Rightarrow> 'd) \<Rightarrow> 'a list \<Rightarrow> ('a, 'd) ipurge_rec \<Rightarrow> bool"
where
"ipurge_tr_rev_t_inv_2 P I D xs X \<equiv>
  secure P I D \<longrightarrow> xs \<in> traces P \<longrightarrow> Out X @ In X \<in> traces P"

text \<open>
\null

Two invariants have been defined, one for each of lemmas \<open>ipurge_tr_rev_t_equiv\<close>,
\<open>ipurge_tr_rev_t_trace\<close>.

More precisely, the invariants are @{term "ipurge_tr_rev_t_inv_1 I D u xs"} and
@{term "ipurge_tr_rev_t_inv_2 P I D xs"}, where the free variables are intended to match those
appearing in the aforesaid lemmas.
\<close>

subsubsection "Step 6"

lemma ipurge_tr_rev_t_input_1:
 "ipurge_tr_rev_t_inv_1 I D u xs \<lparr>Pol = I, Map = D, Dom = u, In = xs, Out = []\<rparr>"
by (simp add: ipurge_tr_rev_t_inv_1_def)

lemma ipurge_tr_rev_t_input_2:
 "ipurge_tr_rev_t_inv_2 P I D xs \<lparr>Pol = I, Map = D, Dom = u, In = xs, Out = []\<rparr>"
by (simp add: ipurge_tr_rev_t_inv_2_def)

subsubsection "Step 7"

definition ipurge_tr_rev_t_form :: "('a, 'd) ipurge_rec \<Rightarrow> bool" where
"ipurge_tr_rev_t_form X \<equiv> In X = []"

lemma ipurge_tr_rev_t_intro_1:
 "\<lbrakk>ipurge_tr_rev_t_inv_1 I D u xs X; ipurge_tr_rev_t_form X\<rbrakk> \<Longrightarrow>
  ipurge_tr_rev_t_out X = ipurge_tr_rev I D u xs"
by (simp add: ipurge_tr_rev_t_inv_1_def ipurge_tr_rev_t_form_def
 ipurge_tr_rev_t_out_def)

lemma ipurge_tr_rev_t_intro_2:
 "\<lbrakk>ipurge_tr_rev_t_inv_2 P I D xs X; ipurge_tr_rev_t_form X\<rbrakk> \<Longrightarrow>
  secure P I D \<longrightarrow> xs \<in> traces P \<longrightarrow> ipurge_tr_rev_t_out X \<in> traces P"
by (simp add: ipurge_tr_rev_t_inv_2_def ipurge_tr_rev_t_form_def
 ipurge_tr_rev_t_out_def)

subsubsection "Step 8"

lemma ipurge_tr_rev_t_form_aux:
 "ipurge_tr_rev_t_form (ipurge_tr_rev_t_aux X)"
by (induction X rule: ipurge_tr_rev_t_aux.induct,
 simp_all add: ipurge_tr_rev_t_form_def)

subsubsection "Step 9"

lemma ipurge_tr_rev_t_invariance_aux:
 "Y \<in> ipurge_tr_rev_t_set X \<Longrightarrow>
  Pol Y = Pol X \<and> Map Y = Map X \<and> Dom Y = Dom X"
by (erule ipurge_tr_rev_t_set.induct, simp_all)

text \<open>
\null

The lemma just proven, stating the invariance of the first three record fields over inductive set
@{term "ipurge_tr_rev_t_set X"}, is used in the following proofs of the invariance of predicates
@{term "ipurge_tr_rev_t_inv_1 I D u xs"} and @{term "ipurge_tr_rev_t_inv_2 P I D xs"}.

The equality between the free variables appearing in the predicates and the corresponding fields of
the record generating the set, which is required for such invariance properties to hold, is asserted
in the enunciation of the properties by means of record updates. In the subsequent proofs of lemmas
\<open>ipurge_tr_rev_t_equiv\<close>, \<open>ipurge_tr_rev_t_trace\<close>, the enforcement of this equality will
be ensured by the identification of both predicate variables and record fields with the related free
variables appearing in the lemmas.

\null
\<close>

lemma ipurge_tr_rev_t_invariance_1:
 "\<lbrakk>Y \<in> ipurge_tr_rev_t_set (X\<lparr>Pol := I, Map := D, Dom := u\<rparr>);
    ipurge_tr_rev_t_inv_1 I D u ws (X\<lparr>Pol := I, Map := D, Dom := u\<rparr>)\<rbrakk> \<Longrightarrow>
  ipurge_tr_rev_t_inv_1 I D u ws Y"
proof (erule ipurge_tr_rev_t_set.induct, assumption,
 drule_tac [!] ipurge_tr_rev_t_invariance_aux,
 simp_all add: ipurge_tr_rev_t_inv_1_def del: sources.simps)
  fix x xs ys
  assume A: "D x \<notin> sources I D u (x # xs)"
  hence "ipurge_tr_rev I D u xs = ipurge_tr_rev I D u ([] @ x # xs)" by simp
  also have "\<dots> = ipurge_tr_rev I D u ([] @ ipurge_tr I D (D x) xs)"
   using A by (rule ipurge_tr_rev_ipurge_tr_sources_1)
  finally have
   "ipurge_tr_rev I D u xs = ipurge_tr_rev I D u (ipurge_tr I D (D x) xs)"
   by simp
  moreover assume "ys @ ipurge_tr_rev I D u xs = ipurge_tr_rev I D u ws"
  ultimately show
   "ys @ ipurge_tr_rev I D u (ipurge_tr I D (D x) xs) = ipurge_tr_rev I D u ws"
   by simp
qed

lemma ipurge_tr_rev_t_invariance_2:
 "\<lbrakk>Y \<in> ipurge_tr_rev_t_set (X\<lparr>Pol := I, Map := D\<rparr>);
    ipurge_tr_rev_t_inv_2 P I D ws (X\<lparr>Pol := I, Map := D\<rparr>)\<rbrakk> \<Longrightarrow>
  ipurge_tr_rev_t_inv_2 P I D ws Y"
proof (erule ipurge_tr_rev_t_set.induct, assumption,
 drule_tac [!] ipurge_tr_rev_t_invariance_aux,
 simp_all add: ipurge_tr_rev_t_inv_2_def, (rule impI)+)
  fix x xs ys
  assume
    S: "secure P I D" and
    "ws \<in> traces P" and
    "secure P I D \<longrightarrow> ws \<in> traces P \<longrightarrow> ys @ x # xs \<in> traces P"
  hence "ys @ x # xs \<in> traces P" by simp
  hence "(ys @ x # xs, {}) \<in> failures P" by (rule traces_failures)
  hence "(x # xs, {}) \<in> futures P ys" by (simp add: futures_def)
  hence "(ipurge_tr I D (D x) xs, ipurge_ref I D (D x) xs {}) \<in> futures P ys"
   using S by (simp add: secure_def)
  hence "(ys @ ipurge_tr I D (D x) xs, ipurge_ref I D (D x) xs {}) \<in> failures P"
   by (simp add: futures_def)
  thus "ys @ ipurge_tr I D (D x) xs \<in> traces P" by (rule failures_traces)
qed

subsubsection "Step 10"

text \<open>
Here below are the proofs of lemmas \<open>ipurge_tr_rev_t_equiv\<close>, \<open>ipurge_tr_rev_t_trace\<close>,
which are then applied to demonstrate the target closure lemma.

\null
\<close>

lemma ipurge_tr_rev_t_equiv:
 "ipurge_tr_rev_t I D u xs = ipurge_tr_rev I D u xs"
proof -
  let ?X = "\<lparr>Pol = I, Map = D, Dom = u, In = xs, Out = []\<rparr>"
  have "ipurge_tr_rev_t_aux ?X
    \<in> ipurge_tr_rev_t_set (?X\<lparr>Pol := I, Map := D, Dom := u\<rparr>)"
   by (simp add: ipurge_tr_rev_t_aux_set)
  moreover have
   "ipurge_tr_rev_t_inv_1 I D u xs (?X\<lparr>Pol := I, Map := D, Dom := u\<rparr>)"
   by (simp add: ipurge_tr_rev_t_input_1)
  ultimately have "ipurge_tr_rev_t_inv_1 I D u xs (ipurge_tr_rev_t_aux ?X)"
   by (rule ipurge_tr_rev_t_invariance_1)
  moreover have "ipurge_tr_rev_t_form (ipurge_tr_rev_t_aux ?X)"
   by (rule ipurge_tr_rev_t_form_aux)
  ultimately have
   "ipurge_tr_rev_t_out (ipurge_tr_rev_t_aux ?X) = ipurge_tr_rev I D u xs"
   by (rule ipurge_tr_rev_t_intro_1)
  moreover have "?X = ipurge_tr_rev_t_in I D u xs"
   by (simp add: ipurge_tr_rev_t_in_def)
  ultimately show ?thesis by (simp add: ipurge_tr_rev_t_def)
qed

lemma ipurge_tr_rev_t_trace [rule_format]:
 "secure P I D \<longrightarrow> xs \<in> traces P \<longrightarrow> ipurge_tr_rev_t I D u xs \<in> traces P"
proof -
  let ?X = "\<lparr>Pol = I, Map = D, Dom = u, In = xs, Out = []\<rparr>"
  have "ipurge_tr_rev_t_aux ?X
    \<in> ipurge_tr_rev_t_set (?X\<lparr>Pol := I, Map := D\<rparr>)"
   by (simp add: ipurge_tr_rev_t_aux_set)
  moreover have "ipurge_tr_rev_t_inv_2 P I D xs (?X\<lparr>Pol := I, Map := D\<rparr>)"
   by (simp add: ipurge_tr_rev_t_input_2)
  ultimately have "ipurge_tr_rev_t_inv_2 P I D xs (ipurge_tr_rev_t_aux ?X)"
   by (rule ipurge_tr_rev_t_invariance_2)
  moreover have "ipurge_tr_rev_t_form (ipurge_tr_rev_t_aux ?X)"
   by (rule ipurge_tr_rev_t_form_aux)
  ultimately have "secure P I D \<longrightarrow> xs \<in> traces P \<longrightarrow>
    ipurge_tr_rev_t_out (ipurge_tr_rev_t_aux ?X) \<in> traces P"
   by (rule ipurge_tr_rev_t_intro_2)
  moreover have "?X = ipurge_tr_rev_t_in I D u xs"
   by (simp add: ipurge_tr_rev_t_in_def)
  ultimately show ?thesis by (simp add: ipurge_tr_rev_t_def)
qed

lemma ipurge_tr_rev_trace:
 "secure P I D \<Longrightarrow> xs \<in> traces P \<Longrightarrow> ipurge_tr_rev I D u xs \<in> traces P"
by (subst ipurge_tr_rev_t_equiv [symmetric], rule ipurge_tr_rev_t_trace)

subsection "The Inductive Unwinding Theorem in its general form"

text \<open>
In what follows, the Inductive Unwinding Theorem is proven, in the form applying to a generic
process. The equivalence of the condition expressed by the theorem to CSP noninterference security,
as defined in \<^cite>\<open>"R2"\<close>, is demonstrated by showing that it is necessary and sufficient for the
verification of the condition expressed by the Ipurge Unwinding Theorem, under the same assumption
that the sets of refusals of the process be closed under union (cf. \<^cite>\<open>"R3"\<close>).

Particularly, the closure of the traces of a secure process under function @{term ipurge_tr_rev} and
the idempotence of this function are used in the proof of condition necessity.

\null
\<close>

lemma inductive_unwinding_1:
  assumes
    R: "ref_union_closed P" and
    S: "secure P I D"
  shows "\<forall>xs \<in> traces P. \<forall>u \<in> range D \<inter> (-I) `` range D.
    next_dom_events P D u (ipurge_tr_rev I D u xs) = next_dom_events P D u xs \<and>
    ref_dom_events P D u (ipurge_tr_rev I D u xs) = ref_dom_events P D u xs"
proof (rule ballI)+
  fix xs u
  from R and S have "\<forall>u \<in> range D \<inter> (- I) `` range D. \<forall>xs ys.
    xs \<in> traces P \<and> ys \<in> traces P \<and>
      ipurge_tr_rev I D u xs = ipurge_tr_rev I D u ys \<longrightarrow>
    next_dom_events P D u xs = next_dom_events P D u ys \<and>
    ref_dom_events P D u xs = ref_dom_events P D u ys"
   by (simp add: ipurge_unwinding weakly_future_consistent_def rel_ipurge_def)
  moreover assume "u \<in> range D \<inter> (- I) `` range D"
  ultimately have "\<forall>xs ys.
    xs \<in> traces P \<and> ys \<in> traces P \<and>
      ipurge_tr_rev I D u xs = ipurge_tr_rev I D u ys \<longrightarrow>
    next_dom_events P D u xs = next_dom_events P D u ys \<and>
    ref_dom_events P D u xs = ref_dom_events P D u ys" ..
  hence
   "ipurge_tr_rev I D u xs \<in> traces P \<and> xs \<in> traces P \<and>
      ipurge_tr_rev I D u (ipurge_tr_rev I D u xs) = ipurge_tr_rev I D u xs \<longrightarrow>
    next_dom_events P D u (ipurge_tr_rev I D u xs) = next_dom_events P D u xs \<and>
    ref_dom_events P D u (ipurge_tr_rev I D u xs) = ref_dom_events P D u xs"
   by blast
  moreover assume xs: "xs \<in> traces P"
  moreover from S and xs have "ipurge_tr_rev I D u xs \<in> traces P"
   by (rule ipurge_tr_rev_trace)
  moreover have
   "ipurge_tr_rev I D u (ipurge_tr_rev I D u xs) = ipurge_tr_rev I D u xs"
   by (rule ipurge_tr_rev_idem)
  ultimately show
   "next_dom_events P D u (ipurge_tr_rev I D u xs) = next_dom_events P D u xs \<and>
    ref_dom_events P D u (ipurge_tr_rev I D u xs) = ref_dom_events P D u xs"
   by simp
qed

lemma inductive_unwinding_2:
  assumes
    R: "ref_union_closed P" and
    S: "\<forall>xs \<in> traces P. \<forall>u \<in> range D \<inter> (-I) `` range D.
      next_dom_events P D u (ipurge_tr_rev I D u xs) =
        next_dom_events P D u xs \<and>
      ref_dom_events P D u (ipurge_tr_rev I D u xs) =
        ref_dom_events P D u xs"
  shows "secure P I D"
proof (simp add: ipurge_unwinding [OF R] weakly_future_consistent_def rel_ipurge_def,
 rule ballI, (rule allI)+, rule impI, (erule conjE)+)
  fix u xs ys
  assume "xs \<in> traces P"
  with S have "\<forall>u \<in> range D \<inter> (-I) `` range D.
    next_dom_events P D u (ipurge_tr_rev I D u xs) = next_dom_events P D u xs \<and>
    ref_dom_events P D u (ipurge_tr_rev I D u xs) = ref_dom_events P D u xs" ..
  moreover assume A: "u \<in> range D \<inter> (- I) `` range D"
  ultimately have B:
   "next_dom_events P D u (ipurge_tr_rev I D u xs) = next_dom_events P D u xs \<and>
    ref_dom_events P D u (ipurge_tr_rev I D u xs) = ref_dom_events P D u xs" ..
  assume "ys \<in> traces P"
  with S have "\<forall>u \<in> range D \<inter> (-I) `` range D.
    next_dom_events P D u (ipurge_tr_rev I D u ys) = next_dom_events P D u ys \<and>
    ref_dom_events P D u (ipurge_tr_rev I D u ys) = ref_dom_events P D u ys" ..
  hence
   "next_dom_events P D u (ipurge_tr_rev I D u ys) = next_dom_events P D u ys \<and>
    ref_dom_events P D u (ipurge_tr_rev I D u ys) = ref_dom_events P D u ys"
   using A ..
  moreover assume "ipurge_tr_rev I D u xs = ipurge_tr_rev I D u ys"
  ultimately show
   "next_dom_events P D u xs = next_dom_events P D u ys \<and>
    ref_dom_events P D u xs = ref_dom_events P D u ys"
   using B by simp
qed

theorem inductive_unwinding:
 "ref_union_closed P \<Longrightarrow>
  secure P I D =
  (\<forall>xs \<in> traces P. \<forall>u \<in> range D \<inter> (-I) `` range D.
    next_dom_events P D u (ipurge_tr_rev I D u xs) = next_dom_events P D u xs \<and>
    ref_dom_events P D u (ipurge_tr_rev I D u xs) = ref_dom_events P D u xs)"
by (rule iffI, rule inductive_unwinding_1, assumption+, rule inductive_unwinding_2)

text \<open>
\null

Interestingly, this necessary and sufficient condition for the noninterference security of a process
resembles the classical definition of noninterference security for a deterministic state machine
with outputs formulated in \<^cite>\<open>"R5"\<close>, which is formalized in \<^cite>\<open>"R2"\<close> as predicate
\<open>c_secure\<close>.

Denoting with (1) the former and with (2) the latter, the differences between them can be summarized
as follows:

\begin{itemize}

\item
The event list appearing in (1) is constrained to vary over process traces, whereas the action list
appearing in (2) is unconstrained.
\\This comes as no surprise, since the state machines used as model of computation in \<^cite>\<open>"R5"\<close>
accept any action list as a trace.

\item
The definition of function @{term ipurge_tr_rev}, used in (1), does not implicitly assume that the
noninterference policy be reflexive, even though any policy of practical significance will be such.
On the contrary, the definition of the intransitive purge function used in (2), which is formalized
in \<^cite>\<open>"R2"\<close> as function \<open>c_ipurge\<close>, makes this implicit assumption, as shown by the
consideration that \<open>c_ipurge I D (D x) [x] = [x]\<close> regardless of whether
@{term "(D x, D x) \<in> I"} or not.
\\This is the mathematical reason why the equivalence between CSP noninterference security and
classical noninterference security for deterministic state machines with outputs, proven in
\<^cite>\<open>"R2"\<close>, is subordinated to the assumption that the noninterference policy be reflexive.

\item
The equality of action outputs appearing in (2) is replaced in (1) by the equality of accepted and
refused events.

\end{itemize}

The binding of the universal quantification over domains contained in (1) does not constitute an
actual difference, since in (2) the purge function is only applied to domains in the range of the
event-domain map, and its output matches the entire input action list, thus rendering the equation
trivial, for domains allowed to be affected by any event domain.
\<close>

subsection "The Inductive Unwinding Theorem for deterministic and trace set processes"

text \<open>
Here below are the proofs of specific variants of the Inductive Unwinding Theorem applying to
deterministic processes and trace set processes \<^cite>\<open>"R3"\<close>. The variant for deterministic processes
is derived, following the above proof of the general form of the theorem, from the Ipurge Unwinding
Theorem for deterministic processes \<^cite>\<open>"R3"\<close>. Then, the variant for trace set processes is inferred
from the variant for deterministic processes.

Similarly to what happens for the Ipurge Unwinding Theorem, the refusals union closure assumption
that characterizes the general form of the Inductive Unwinding Theorem is replaced by the assumption
that the process actually be deterministic in the variant for deterministic processes, and by the
assumption that the set of traces actually be such in the variant for trace set processes. Moreover,
these variants involve accepted events only, in accordance with the fact that in deterministic
processes, refused events are completely specified by accepted events (cf. \<^cite>\<open>"R4"\<close>, \<^cite>\<open>"R2"\<close>).

\null
\<close>

lemma d_inductive_unwinding_1:
  assumes
    D: "deterministic P" and
    S: "secure P I D"
  shows "\<forall>xs \<in> traces P. \<forall>u \<in> range D \<inter> (-I) `` range D.
    next_dom_events P D u (ipurge_tr_rev I D u xs) = next_dom_events P D u xs"
proof (rule ballI)+
  fix xs u
  from D and S have "\<forall>u \<in> range D \<inter> (- I) `` range D. \<forall>xs ys.
    xs \<in> traces P \<and> ys \<in> traces P \<and>
      ipurge_tr_rev I D u xs = ipurge_tr_rev I D u ys \<longrightarrow>
    next_dom_events P D u xs = next_dom_events P D u ys"
   by (simp add: d_ipurge_unwinding d_weakly_future_consistent_def rel_ipurge_def)
  moreover assume "u \<in> range D \<inter> (- I) `` range D"
  ultimately have "\<forall>xs ys.
    xs \<in> traces P \<and> ys \<in> traces P \<and>
      ipurge_tr_rev I D u xs = ipurge_tr_rev I D u ys \<longrightarrow>
    next_dom_events P D u xs = next_dom_events P D u ys" ..
  hence
   "ipurge_tr_rev I D u xs \<in> traces P \<and> xs \<in> traces P \<and>
      ipurge_tr_rev I D u (ipurge_tr_rev I D u xs) = ipurge_tr_rev I D u xs \<longrightarrow>
    next_dom_events P D u (ipurge_tr_rev I D u xs) = next_dom_events P D u xs"
    by blast
  moreover assume xs: "xs \<in> traces P"
  moreover from S and xs have "ipurge_tr_rev I D u xs \<in> traces P"
    by (rule ipurge_tr_rev_trace)
  moreover have
   "ipurge_tr_rev I D u (ipurge_tr_rev I D u xs) = ipurge_tr_rev I D u xs"
    by (rule ipurge_tr_rev_idem)
  ultimately show
   "next_dom_events P D u (ipurge_tr_rev I D u xs) = next_dom_events P D u xs"
    by simp
qed

lemma d_inductive_unwinding_2:
  assumes
    D: "deterministic P" and
    S: "\<forall>xs \<in> traces P. \<forall>u \<in> range D \<inter> (-I) `` range D.
      next_dom_events P D u (ipurge_tr_rev I D u xs) = next_dom_events P D u xs"
  shows "secure P I D"
proof (simp add: d_ipurge_unwinding [OF D] d_weakly_future_consistent_def rel_ipurge_def,
 rule ballI, (rule allI)+, rule impI, (erule conjE)+)
  fix u xs ys
  assume "xs \<in> traces P"
  with S have "\<forall>u \<in> range D \<inter> (-I) `` range D.
    next_dom_events P D u (ipurge_tr_rev I D u xs) = next_dom_events P D u xs" ..
  moreover assume A: "u \<in> range D \<inter> (- I) `` range D"
  ultimately have B:
   "next_dom_events P D u (ipurge_tr_rev I D u xs) = next_dom_events P D u xs" ..
  assume "ys \<in> traces P"
  with S have "\<forall>u \<in> range D \<inter> (-I) `` range D.
    next_dom_events P D u (ipurge_tr_rev I D u ys) = next_dom_events P D u ys" ..
  hence
   "next_dom_events P D u (ipurge_tr_rev I D u ys) = next_dom_events P D u ys"
   using A ..
  moreover assume "ipurge_tr_rev I D u xs = ipurge_tr_rev I D u ys"
  ultimately show "next_dom_events P D u xs = next_dom_events P D u ys"
   using B by simp
qed

theorem d_inductive_unwinding:
 "deterministic P \<Longrightarrow>
  secure P I D =
  (\<forall>xs \<in> traces P. \<forall>u \<in> range D \<inter> (-I) `` range D.
    next_dom_events P D u (ipurge_tr_rev I D u xs) = next_dom_events P D u xs)"
by (rule iffI, rule d_inductive_unwinding_1, assumption+, rule d_inductive_unwinding_2)

theorem ts_inductive_unwinding:
  assumes T: "trace_set T"
  shows "secure (ts_process T) I D =
    (\<forall>xs \<in> T. \<forall>u \<in> range D \<inter> (-I) `` range D. \<forall>x \<in> D -` {u}.
      (ipurge_tr_rev I D u xs @ [x] \<in> T) = (xs @ [x] \<in> T))"
    (is "secure ?P I D = _")
proof (subst d_inductive_unwinding, rule ts_process_d [OF T],
 simp add: next_dom_events_def ts_process_next_events [OF T] set_eq_iff,
 rule iffI, (rule ballI)+, (rule_tac [2] ballI)+, rule_tac [2] allI)
  fix xs u x
  assume A: "\<forall>xs \<in> traces ?P. \<forall>u \<in> range D \<inter> (- I) `` range D.
    \<forall>x. (u = D x \<and> ipurge_tr_rev I D u xs @ [x] \<in> T) = (u = D x \<and> xs @ [x] \<in> T)"
  assume "xs \<in> T"
  moreover have "traces ?P = T" using T by (rule ts_process_traces)
  ultimately have "xs \<in> traces ?P" by simp
  with A have "\<forall>u \<in> range D \<inter> (- I) `` range D.
    \<forall>x. (u = D x \<and> ipurge_tr_rev I D u xs @ [x] \<in> T) =
      (u = D x \<and> xs @ [x] \<in> T)" ..
  moreover assume "u \<in> range D \<inter> (- I) `` range D"
  ultimately have
   "\<forall>x. (u = D x \<and> ipurge_tr_rev I D u xs @ [x] \<in> T) =
      (u = D x \<and> xs @ [x] \<in> T)" ..
  hence "(u = D x \<and> ipurge_tr_rev I D u xs @ [x] \<in> T) =
    (u = D x \<and> xs @ [x] \<in> T)" ..
  moreover assume "x \<in> D -` {u}"
  hence "u = D x" by simp
  ultimately show "(ipurge_tr_rev I D u xs @ [x] \<in> T) = (xs @ [x] \<in> T)" by simp
next
  fix xs u x
  assume A: "\<forall>xs \<in> T. \<forall>u \<in> range D \<inter> (- I) `` range D.
    \<forall>x \<in> D -` {u}. (ipurge_tr_rev I D u xs @ [x] \<in> T) = (xs @ [x] \<in> T)"
  assume "xs \<in> traces ?P"
  moreover have "traces ?P = T" using T by (rule ts_process_traces)
  ultimately have "xs \<in> T" by simp
  with A have "\<forall>u \<in> range D \<inter> (- I) `` range D.
    \<forall>x \<in> D -` {u}. (ipurge_tr_rev I D u xs @ [x] \<in> T) = (xs @ [x] \<in> T)" ..
  moreover assume "u \<in> range D \<inter> (- I) `` range D"
  ultimately have B:
   "\<forall>x \<in> D -` {u}. (ipurge_tr_rev I D u xs @ [x] \<in> T) = (xs @ [x] \<in> T)" ..
  show "(u = D x \<and> ipurge_tr_rev I D u xs @ [x] \<in> T) =
    (u = D x \<and> xs @ [x] \<in> T)"
  proof (cases "D x = u", simp_all)
    case True
    hence "x \<in> D -` {u}" by simp
    with B show "(ipurge_tr_rev I D u xs @ [x] \<in> T) = (xs @ [x] \<in> T)" ..
  qed
qed

end


theory KategorischerImperativ
imports Maxime SchleierNichtwissen
begin

section\<open>Kategorischer Imperativ\<close>
text\<open>In diesem Abschnitt werden wir den kategorischen Imperativ modellieren.\<close>

text\<open>
Wir haben mit der goldenen Regel bereits definiert,
wann für eine gegebene Welt und eine gegebene Maxime, eine Handlungsabsicht moralisch ist:

 \<^item> \<^term_type>\<open>moralisch ::
     'welt \<Rightarrow> ('person, 'welt) maxime \<Rightarrow> ('person, 'welt) handlungsabsicht \<Rightarrow> bool\<close>

Effektiv testet die goldene Regel eine Handlungsabsicht.

Nach meinem Verständnis generalisiert Kant mit dem Kategorischen Imperativ diese Regel,
indem die Maxime nicht mehr als gegeben angenommen wird,
sondern die Maxime selbst getestet wird.
Sei die Welt weiterhin gegeben,
dann müsste der kategorische Imperativ folgende Typsignatur haben:

  \<^item> \<^typ>\<open>'welt \<Rightarrow> ('person, 'welt) maxime \<Rightarrow> bool\<close>

Eine Implementierung muss dann über alle möglichen Handlungsabsichten allquantifizieren.

Grob gesagt: Die goldene Regel urteilt über eine Handlungsabsicht gegeben eine Maxime,
der kategorische Imperativ urteilt über die Maxime an sich.

Ich behaupte, der kategorischer Imperativ lässt sich wie folgt umformulieren:

  \<^item> Handle nur nach derjenigen Maxime, durch die du zugleich wollen kannst,
    dass sie ein allgemeines Gesetz werde.
  \<^item> Handle nur nach derjenigen Maxime, durch die du zugleich wollen kannst,
    dass sie jeder befolgt, im Sinne der goldenen Regel.
  \<^item> Handle nur nach derjenigen Maxime, durch die du zugleich wollen kannst,
    dass sie (Handlung und Maxime) moralisch ist.
  \<^item> Wenn es jemanden gibt der nach einer Maxime handeln will,
    dann muss diese Handlung nach der Maxime moralisch sein.
  \<^item> Für jede Handlungsabsicht muss gelten:
    Wenn jemand nach einer Handlungsabsicht handeln würde (getestet durch die Maxime),
    dann muss diese Handlung moralisch sein (getestet durch die Maxime).

Daraus ergibt sich diese Formalisierung:

Für eine bestimmte Handlungsabsicht:
Wenn es eine Person gibt für die diese Handlungsabsicht moralisch ist,
dann muss diese Handlungsabsicht auch für alle moralisch (im Sinne der goldenen Regel) sein.
\<close>
definition kategorischer_imperativ_auf
  :: \<open>('person, 'welt) handlungsabsicht \<Rightarrow> 'welt \<Rightarrow> ('person, 'welt) maxime \<Rightarrow> bool\<close>
where
  \<open>kategorischer_imperativ_auf ha welt m \<equiv>
     (\<exists>ich. ausfuehrbar ich welt ha \<and> okay m ich (handeln ich welt ha)) \<longrightarrow> moralisch welt m ha\<close>

text\<open>
Wir beschränken uns auf die \<^const>\<open>ausfuehrbar\<close>en Handlungsabsichten um pathologische
Grenzfälle (welche keinen Rückschluss auf moralische Gesinnung lassen) auszuschließen.

Für alle möglichen (wohlgeformten) Handlungsabsichten muss dies nun gelten:
\<close>
definition kategorischer_imperativ
  :: \<open>('person, 'welt) wp_swap \<Rightarrow> 'welt \<Rightarrow> ('person, 'welt) maxime \<Rightarrow> bool\<close>
where
  \<open>kategorischer_imperativ wps welt m \<equiv>
    \<forall>ha. wohlgeformte_handlungsabsicht wps welt ha \<longrightarrow>
          kategorischer_imperativ_auf ha welt m\<close>

text\<open>Damit hat \<^term_type>\<open>kategorischer_imperativ wps :: 'welt \<Rightarrow> ('person, 'welt) maxime \<Rightarrow> bool\<close>
die gewünschte Typsignatur.

Wir haben die interne Hilfsdefinition \<^const>\<open>kategorischer_imperativ_auf\<close> eingeführt
um den kategorischen Imperativ nur für eine Teilmenge aller Handlungen besser
diskutieren zu können.

Leider fehlen mir nicht-triviale Beispiele von Maximen welche den kategorischen Imperativ uneingeschränkt
auf allen Handlungsabsichten erfüllen.
\<close>

text\<open>Die Vorbedingung \<^term>\<open>ausfuehrbar ich welt ha\<close> in \<^const>\<open>kategorischer_imperativ_auf\<close>
wirkt etwas holprig.
Wir brauchen sie aber, um pathologische Grenzfälle auszuschließen.
Beispielsweise ist von-sich-selbst stehlen eine (nicht ausführbare) No-Op.
No-ops sind normalerweise nicht böse.
Stehlen ist schon böse.
Dieser Grenzfall in dem Stehlen zur no-op wird versteckt also den Charakter der
Handlungsabsicht und muss daher ausgeschlossen werden.
Da Handlungen partiell sind, ist von-sich-selbst-stehlen auch also nicht ausführbar modelliert,
da Stehlen bedeutet "jemand anderen etwas wegnehmen" und im Grenzfall "von sich selbst stehlen"
nicht definiert ist.
\<close>

text\<open>In der Definition \<^const>\<open>kategorischer_imperativ\<close> ist \<^const>\<open>wohlgeformte_handlungsabsicht\<close>
ein technisch notwendiges Implementierungsdetail um nicht-wohlgeformte Handlungen
auszuschließen.\<close>

text\<open>Minimal andere Formulierung:\<close>
lemma
\<open>kategorischer_imperativ wps welt m \<longleftrightarrow>
  (\<forall>ha.
    (\<exists>p.
        wohlgeformte_handlungsabsicht wps welt ha \<and>
        ausfuehrbar p welt ha \<and>
        okay m p (handeln p welt ha))
    \<longrightarrow> moralisch welt m ha)\<close>
  unfolding kategorischer_imperativ_def kategorischer_imperativ_auf_def
  apply(simp)
  by blast

text\<open>Der Existenzquantor lässt sich auch in einen Allquantor umschreiben:\<close>
lemma
\<open>kategorischer_imperativ wps welt m \<longleftrightarrow>
  (\<forall>ha ich.
      wohlgeformte_handlungsabsicht wps welt ha \<and> ausfuehrbar ich welt ha \<and>
      okay m ich (handeln ich welt ha) \<longrightarrow> moralisch welt m ha)\<close>
  apply(simp add: kategorischer_imperativ_def kategorischer_imperativ_auf_def)
  by blast

text\<open>Vergleich zu \<^const>\<open>moralisch\<close>.
Wenn eine Handlung moralisch ist, dann impliziert diese Handlung die Kernforderung des
\<^const>\<open>kategorischer_imperativ\<close>.
Wenn die Handlungsabsicht für mich okay ist, ist sie auch für alle anderen okay.\<close>
lemma \<open>moralisch welt m ha \<Longrightarrow>
        kategorischer_imperativ_auf ha welt m\<close>
  by(simp add: moralisch_simp kategorischer_imperativ_auf_def)

text\<open>Die andere Richtung gilt nicht,
z.B. ist die Maxime die immer False zurückgibt ein Gegenbeispiel.\<close>
beispiel
  \<open>m = Maxime (\<lambda>_ _. False) \<Longrightarrow>
   kategorischer_imperativ_auf ha welt m \<longrightarrow> moralisch welt m ha
     \<Longrightarrow> False\<close>
  by(simp add: kategorischer_imperativ_auf_def moralisch_simp)

text\<open>Der \<^const>\<open>kategorischer_imperativ\<close> lässt sich auch wie folgt umformulieren.
Für jede Handlungsabsicht:
  wenn ich so handeln würde muss es auch okay sein, wenn zwei beliebige
  Personen so handeln, wobei einer Täter und einer Opfer ist.\<close>
lemma kategorischer_imperativ_simp:
  \<open>kategorischer_imperativ wps welt m \<longleftrightarrow>
    (\<forall>ha p1 p2 ich.
      wohlgeformte_handlungsabsicht wps welt ha \<and> ausfuehrbar ich welt ha \<and>
      okay m ich (handeln ich welt ha)
      \<longrightarrow> okay m p1 (handeln p2 welt ha))\<close>
  apply(simp add: kategorischer_imperativ_def kategorischer_imperativ_auf_def moralisch_simp)
  by blast

(*<*)
text\<open>Introduction rules\<close>
lemma kategorischer_imperativI:
  \<open>(\<And>ha ich p1 p2. wohlgeformte_handlungsabsicht wps welt ha \<Longrightarrow>
                   ausfuehrbar ich welt ha \<Longrightarrow>
                   okay m ich (handeln ich welt ha) \<Longrightarrow> okay m p1 (handeln p2 welt ha)
                )
      \<Longrightarrow> kategorischer_imperativ wps welt m\<close>
  by(auto simp add: kategorischer_imperativ_simp)

lemma kategorischer_imperativ_aufI:
  \<open>(\<And>ich p1 p2. ausfuehrbar ich welt ha
      \<Longrightarrow> okay m ich (handeln ich welt ha) \<Longrightarrow> okay m p1 (handeln p2 welt ha))
      \<Longrightarrow> kategorischer_imperativ_auf ha welt m\<close>
  by(auto simp add: kategorischer_imperativ_auf_def moralisch_simp)
(*>*)

text\<open>Um den \<^const>\<open>kategorischer_imperativ_auf\<close> einer Handlungsabsicht zu zeigen muss
entweder die Handlungsabsicht moralisch sein,
oder es darf keine Person geben, die diese Handlung auch tatsächlich
unter gegebener Maxime ausführen würde:\<close>
lemma kategorischer_imperativ_auf2:
  \<open>moralisch welt m ha \<or> \<not>(\<exists> p. ausfuehrbar p welt ha \<and> okay m p (handeln p welt ha))
      \<longleftrightarrow> kategorischer_imperativ_auf ha welt m\<close>
  by(auto simp add: kategorischer_imperativ_auf_def moralisch_simp)

text\<open>Für Beispiele wird es einfacher zu zeigen, dass eine Maxime nicht den
kategorischen Imperativ erfüllt, wenn wir direkt ein Beispiel angeben.\<close>
(*insbesondere weil ich das proof document als outline baue und man den beweis,
also das Gegenbeispiel, nicht sieht.*)
definition \<open>kategorischer_imperativ_gegenbeispiel wps welt m ha ich p1 p2 \<equiv>
wohlgeformte_handlungsabsicht wps welt ha \<and>
       ausfuehrbar ich welt ha \<and> okay m ich (handeln ich welt ha) \<and>
      \<not> okay m p1 (handeln p2 welt ha)\<close>

lemma \<open>kategorischer_imperativ_gegenbeispiel wps welt m ha ich p1 p2 \<Longrightarrow>
  \<not> kategorischer_imperativ wps welt m\<close>
  apply(simp add: kategorischer_imperativ_simp kategorischer_imperativ_gegenbeispiel_def)
  apply(rule_tac x=\<open>ha\<close> in exI, simp)
  by blast

subsection\<open>Triviale Maximen die den Kategorischen Imperativ immer Erfüllen\<close>
text\<open>
Die Maxime die keine Handlung erlaubt (weil immer False) erfüllt den kategorischen
Imperativ:\<close>
beispiel \<open>kategorischer_imperativ wps welt (Maxime (\<lambda>ich h. False))\<close>
  by(simp add: kategorischer_imperativ_simp)

text\<open>Allerdings kann mit so einer Maxime nie etwas moralisch sein.\<close>
beispiel \<open>\<not> moralisch welt (Maxime (\<lambda>ich h. False)) h\<close>
  by(simp add: moralisch_simp)

text\<open>Die Maxime die jede Handlung erlaubt (weil immer True) erfüllt den kategorischen
Imperativ:\<close>
beispiel \<open>kategorischer_imperativ wps welt (Maxime (\<lambda>ich h. True))\<close>
  by(simp add: kategorischer_imperativ_simp)

text\<open>Allerdings ist mit so einer Maxime alles moralisch.\<close>
beispiel \<open>moralisch welt (Maxime (\<lambda>ich h. True)) h\<close>
  by(simp add: moralisch_simp)

subsection\<open>Zusammenhang Goldene Regel\<close>
text\<open>
Mit der goldenen Regel konnten wir wie folgt moralische Entscheidungen treffen:
@{thm goldene_regel}

In Worten:
Wenn eine Handlungsabsicht moralisch ist (nach goldener Regel)
und es okay ist für mich diese Handlung auszuführen,
dann ist es auch für mich okay, wenn jeder andere diese Handlung mit mir als Opfer ausführt.

Der kategorische Imperativ hebt diese eine Abstraktionsebene höher.
Wenn eine Maxime den kategorischen Imperativ erfüllt
und es okay ist für mich eine Handlung nach dieser Maxime auszuführen (wie in der goldenen Regel),
dann ist diese Handlungsabsicht allgemein moralisch.
Die goldene Regel konnte nur folgern, dass eine Handlungsabsicht auch okay ist wenn ich das
Opfer wäre, der kategorisch Imperativ schließt, dass eine Handlungsabsicht allgemein moralisch
sein muss, wobei beliebige Personen (nicht nur ich) Täter und Opfer sein können.
\<close>

lemma \<open>kategorischer_imperativ wps welt m \<Longrightarrow>
  wohlgeformte_handlungsabsicht wps welt ha \<Longrightarrow>
   ausfuehrbar ich welt ha \<Longrightarrow>
  okay m ich (handeln ich welt ha) \<Longrightarrow> moralisch welt m ha\<close>
  by(auto simp add: kategorischer_imperativ_simp moralisch_simp)

text\<open>
In Worten:
Wenn eine Maxime den kategorischen Imperativ erfüllt
und es für eine beliebige (wohlgeformte) Handlung auszuführen für mich okay ist diese auszuführen,
dann ist diese Handlung moralisch..
\<close>

subsection\<open>Maximen die den Kategorischen Imperativ immer Erfüllen\<close>

text\<open>Wenn eine Maxime jede Handlungsabsicht als moralisch bewertet,
erfüllt diese Maxime den kategorischen Imperativ.
Da diese Maxime jede Handlung erlaubt, ist es dennoch eine wohl ungeeignete Maxime.\<close>
lemma \<open>\<forall>ha. moralisch welt maxime ha \<Longrightarrow> kategorischer_imperativ wps welt maxime\<close>
  apply(cases \<open>maxime\<close>, rename_tac m)
  by(simp add: kategorischer_imperativ_simp moralisch_simp)

text\<open>Eine Maxime die das ich und die Handlung ignoriert erfüllt den kategorischen Imperativ.\<close>
lemma blinde_maxime_katimp:
  \<open>kategorischer_imperativ wps welt (Maxime (\<lambda>ich h. m))\<close>
  apply(rule kategorischer_imperativI)
  by(simp)

text\<open>Eine Maxime welche das \<^term>\<open>ich::'person\<close> ignoriert,
also nur die Handlung global betrachtet, erfüllt den kategorischen Imperativ
(mit einigen weiteren Annahmen).\<close>
theorem globale_maxime_katimp:
  fixes P :: \<open>'welt handlung \<Rightarrow> bool\<close>
  assumes mhg: \<open>\<forall>p. maxime_und_handlungsabsicht_generalisieren wps welt (Maxime (\<lambda>ich::'person. P)) ha p\<close>
    and maxime_erlaubt_untaetigkeit: \<open>\<forall>p. ist_noop (handeln p welt ha) \<longrightarrow> okay (Maxime (\<lambda>ich::'person. P)) p (handeln p welt ha)\<close>
    and kom: \<open>wpsm_kommutiert (Maxime (\<lambda>ich::'person. P)) wps welt\<close>
    and wps_sym:
    \<open>\<forall>p1 p2 welt. wps p1 p2 welt = wps p2 p1 welt\<close>
    and wps_id:
    \<open>\<forall>p1 p2 welt. wps p1 p2 (wps p1 p2 welt) = welt\<close>
    and wfh: \<open>wohlgeformte_handlungsabsicht wps welt ha\<close>
  shows \<open>kategorischer_imperativ_auf ha welt (Maxime (\<lambda>ich::'person. P))\<close>
proof(rule kategorischer_imperativ_aufI, simp)
  fix ich p2 :: \<open>'person\<close>
  assume ausfuehrbarich: \<open>ausfuehrbar ich welt ha\<close>
    and okayich: \<open>P (handeln ich welt ha)\<close>

  from wps_id wps_sym have wpsid_swapped: \<open>wps_id wps welt\<close>
    by(simp add: wps_id_def)

  obtain h where h: \<open>ha = Handlungsabsicht h\<close>
    by(cases \<open>ha\<close>, blast)

  show \<open>P (handeln p2 welt ha)\<close>
  proof(cases \<open>\<not> ausfuehrbar p2 welt ha\<close>)
    case True
    assume \<open>\<not> ausfuehrbar p2 welt ha\<close>
    hence \<open>ist_noop (handeln p2 welt ha)\<close> using nicht_ausfuehrbar_ist_noop by fast
    with maxime_erlaubt_untaetigkeit show \<open>P (handeln p2 welt ha)\<close> by simp
  next
    case False
    assume \<open>\<not> \<not> ausfuehrbar p2 welt ha\<close>
    with wohlgeformte_handlungsabsicht_ausfuehrbar[OF wfh]
    have mhg_pre: \<open>ausfuehrbar ich (wps p2 ich welt) (Handlungsabsicht h)\<close> using h by blast

    from ausfuehrbarich mhg_pre[simplified h] mhg[simplified maxime_und_handlungsabsicht_generalisieren_def h] okayich[simplified h]
    have
      \<open>P (handeln ich (wps p2 ich welt) ha)\<close>
      by(auto simp add: h)
    with wps_sym have
      \<open>P (handeln ich (wps ich p2 welt) ha)\<close>
      by(simp)
    with wfh_wpsm_kommutiert_simp[OF wpsid_swapped wfh kom] show \<open>P (handeln p2 welt ha)\<close>
      by(simp add: h)
  qed
qed

subsection\<open>Ausführbarer Beispielgenerator\<close>
text\<open>Gegeben sei eine Welt, sowie eine Maxime, und eine Liste von Handlungsabsichten.
Wir wollen nun wissen ob die Maxime und Handlungsabsichten wohlgeformt sind,
und wenn ja, ob die Maxime auf diesen Handlungsabsichten den kategorischen Imperativ erfüllt,
und wie die Handlungen bewertet werden.\<close>

(*<*)
text\<open>List comprehension syntax is sometime hard. Here is an example.\<close>
value\<open>[(x,y). x \<leftarrow> xs, y \<leftarrow> ys, x \<noteq> y]\<close>
(*>*)

definition alle_moeglichen_handlungen
  :: \<open>'welt \<Rightarrow> ('person::enum, 'welt) handlungsabsicht \<Rightarrow> 'welt handlung list\<close>
where
  \<open>alle_moeglichen_handlungen welt ha \<equiv> [handeln p welt ha. p \<leftarrow> (Enum.enum::'person list)]\<close>

lemma set_alle_moeglichen_handlungen:
  \<open>set (alle_moeglichen_handlungen welt ha) = {handeln p welt ha | p. True}\<close>
  apply(simp add: alle_moeglichen_handlungen_def)
  apply(simp add: enum_class.enum_UNIV)
  by blast

(*TODO: Um den Namespace nicht zu verschmutzen prefixe ich alles mit bsp_*)
(*TODO: ich habe bsp_world entfernt. Dokumentieren, dass das immer nur fuer eine fixe world ist,
da sonst nicht ausfuehrbar*)
record ('person, 'welt) beipiel =
  bsp_erfuellte_maxime :: \<open>bool\<close>
  bsp_erlaubte_handlungen :: \<open>('person, 'welt) handlungsabsicht list\<close>
  bsp_verbotene_handlungen :: \<open>('person, 'welt) handlungsabsicht list\<close>
  bsp_uneindeutige_handlungen :: \<open>('person, 'welt) handlungsabsicht list\<close>

definition erzeuge_beispiel
  :: \<open>('person::enum, 'welt) wp_swap \<Rightarrow> 'welt \<Rightarrow>
      ('person, 'welt) handlungsabsicht list \<Rightarrow> ('person, 'welt) maxime
      \<Rightarrow> ('person, 'welt) beipiel option\<close>
  where
\<open>erzeuge_beispiel wps welt has m \<equiv>
  if (\<exists>h\<in> (\<Union>ha \<in> set has. set (alle_moeglichen_handlungen welt ha)). \<not>wohlgeformte_maxime_auf h wps m)
     \<or> (\<exists>ha\<in>set has. \<not> wohlgeformte_handlungsabsicht wps welt ha)
  then None
  else Some
   \<lparr>
     bsp_erfuellte_maxime = if \<forall>ha\<in>set has. kategorischer_imperativ_auf ha welt m then True else False,
     bsp_erlaubte_handlungen = [ha\<leftarrow>has. kategorischer_imperativ_auf ha welt m \<and> moralisch welt m ha],
     bsp_verbotene_handlungen = [ha\<leftarrow>has. kategorischer_imperativ_auf ha welt m \<and> \<not> moralisch welt m ha],
     bsp_uneindeutige_handlungen = [ha\<leftarrow>has. \<not> kategorischer_imperativ_auf ha welt m]
   \<rparr>\<close>

(*<*)
text\<open>I think the following definition leads to more efficient evaluation.
And it allows reasoning about one \<^typ>\<open>('person, 'welt) handlungsabsicht\<close> in isolation.\<close>
definition erzeuge_beispiel_alt1
  :: \<open>('person::enum, 'welt) wp_swap \<Rightarrow> 'welt \<Rightarrow>
      ('person, 'welt) handlungsabsicht \<Rightarrow> ('person, 'welt) maxime
      \<Rightarrow> ('person, 'welt) beipiel option\<close>
  where
\<open>erzeuge_beispiel_alt1 wps welt ha m \<equiv>
  if (\<exists>h\<in>set (alle_moeglichen_handlungen welt ha). \<not>wohlgeformte_maxime_auf h wps m)
     \<or> \<not> wohlgeformte_handlungsabsicht wps welt ha
  then None
  else Some
  (if kategorischer_imperativ_auf ha welt m
   then
   \<lparr>
     bsp_erfuellte_maxime = True,
     bsp_erlaubte_handlungen = if moralisch welt m ha then [ha] else [],
     bsp_verbotene_handlungen = if \<not> moralisch welt m ha then [ha] else [],
     bsp_uneindeutige_handlungen = []
   \<rparr>
   else
   \<lparr>
     bsp_erfuellte_maxime = False,
     bsp_erlaubte_handlungen = [],
     bsp_verbotene_handlungen = [],
     bsp_uneindeutige_handlungen = [ha]
   \<rparr>
  )\<close>

fun beispiel_merge
  :: \<open>('person, 'welt) beipiel \<Rightarrow> ('person, 'welt) beipiel \<Rightarrow> ('person, 'welt) beipiel\<close>
where
  \<open>beispiel_merge
    \<lparr> bsp_erfuellte_maxime=t1,
      bsp_erlaubte_handlungen=e1, bsp_verbotene_handlungen=v1, bsp_uneindeutige_handlungen=u1 \<rparr>
    \<lparr> bsp_erfuellte_maxime=t2,
      bsp_erlaubte_handlungen=e2, bsp_verbotene_handlungen=v2, bsp_uneindeutige_handlungen=u2 \<rparr>
  = \<lparr> bsp_erfuellte_maxime = t1 \<and> t2,
      bsp_erlaubte_handlungen= e1 @ e2,
      bsp_verbotene_handlungen= v1 @ v2,
      bsp_uneindeutige_handlungen= u1 @ u2
    \<rparr>\<close>

lemma beispiel_merge_distrib:
  \<open>beispiel_merge (beispiel_merge a b) c = beispiel_merge a (beispiel_merge b c)\<close>
  apply(case_tac \<open>a\<close>, case_tac \<open>b\<close>, case_tac \<open>c\<close>)
  apply(simp)
  done

text\<open>Combines \<^typ>\<open>'a option\<close>, but if one of them is \<^const>\<open>None\<close>,
the whole result is \<^const>\<open>None\<close>. This is different from library's \<^const>\<open>combine_options\<close>.\<close>
definition merge_options :: \<open>('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'a option \<Rightarrow> 'a option \<Rightarrow> 'a option\<close> where
  \<open>merge_options f x y \<equiv>
           (case x of None \<Rightarrow> None | Some x \<Rightarrow> (case y of None \<Rightarrow> None | Some y \<Rightarrow> Some (f x y)))\<close>

lemma merge_options_simps:
  \<open>merge_options f None b = None\<close>
  \<open>merge_options f a None = None\<close>
   apply(simp add: merge_options_def)+
  apply(cases \<open>a\<close>, simp_all)
  done

lemma merge_options_distrib:
  \<open>merge_options beispiel_merge (merge_options beispiel_merge a b) c
    = merge_options beispiel_merge a (merge_options beispiel_merge b c)\<close>
  by(simp add: merge_options_def beispiel_merge_distrib split: option.split)

definition erzeuge_beispiel_alt_start :: \<open>('person, 'welt) beipiel option\<close> where
  \<open>erzeuge_beispiel_alt_start \<equiv> Some
    \<lparr> bsp_erfuellte_maxime=True,
      bsp_erlaubte_handlungen=[], bsp_verbotene_handlungen=[], bsp_uneindeutige_handlungen=[] \<rparr>\<close>

definition erzeuge_beispiel_alt
  :: \<open>('person::enum, 'welt) wp_swap \<Rightarrow> 'welt \<Rightarrow>
      ('person, 'welt) handlungsabsicht list \<Rightarrow> ('person, 'welt) maxime
      \<Rightarrow> ('person, 'welt) beipiel option\<close>
  where
\<open>erzeuge_beispiel_alt wps welt has m
  \<equiv> fold
      (\<lambda>ha acc. merge_options beispiel_merge acc (erzeuge_beispiel_alt1 wps welt ha m))
      has
      erzeuge_beispiel_alt_start
  \<close>

lemma erzeuge_beispiel_alt_start_neutral:
  \<open>merge_options beispiel_merge erzeuge_beispiel_alt_start bsp = bsp\<close>
  apply(cases \<open>bsp\<close>)
   apply(simp add: merge_options_def split:option.split)
  apply(rename_tac bsp2, case_tac \<open>bsp2\<close>)
  apply(simp add: merge_options_def erzeuge_beispiel_alt_start_def)
  done

lemma erzeuge_beispiel1_alt:
  \<open>erzeuge_beispiel_alt1 wps welt ha m = erzeuge_beispiel wps welt [ha] m\<close>
  by(simp add: erzeuge_beispiel_def erzeuge_beispiel_alt1_def)

lemma erzeuge_beispiel_cons:
  \<open>erzeuge_beispiel wps welt (ha # has) m
    = merge_options beispiel_merge (erzeuge_beispiel wps welt [ha] m) (erzeuge_beispiel wps welt has m)\<close>
  unfolding erzeuge_beispiel_def
  apply(simp only: merge_options_simps split: if_split)
  apply(intro conjI impI) (*64 subgoals*)
                      apply(simp_all only:, simp_all) (*slow*)
             (*12 subgoals left*)
             apply(blast | simp add: merge_options_def)+
  done

lemma fold_merge_options_pullout:
  \<open>fold (\<lambda>ha acc. merge_options beispiel_merge acc (f ha)) has
         (merge_options beispiel_merge start start2)
    = merge_options beispiel_merge start
          (fold (\<lambda>ha acc. merge_options beispiel_merge acc (f ha)) has start2)\<close>
  apply(induction \<open>has\<close> arbitrary: \<open>start\<close> \<open>start2\<close>)
   apply(simp; fail)
  apply(simp add: merge_options_distrib)
  done

lemma erzeuge_beispiel_alt_induct_helper:
  \<open>merge_options beispiel_merge start (erzeuge_beispiel wps welt has m)
    = fold (\<lambda>ha acc. merge_options beispiel_merge acc (erzeuge_beispiel_alt1 wps welt ha m)) has start\<close>
  apply(induction \<open>has\<close> arbitrary: \<open>start\<close>)
   apply(simp add: erzeuge_beispiel_def merge_options_def split: option.split)
   apply(clarsimp, rename_tac bsp)
   apply(case_tac \<open>bsp\<close>, simp; fail)
  apply(rename_tac ha has start)
  apply(simp)
  apply(subst erzeuge_beispiel_cons)
  apply(simp)
  apply(simp add: erzeuge_beispiel1_alt)
  apply(simp add: fold_merge_options_pullout)
  done

lemma erzeuge_beispiel_alt_helper:
  \<open>erzeuge_beispiel wps welt has m
    = fold
      (\<lambda>ha acc. merge_options beispiel_merge acc(erzeuge_beispiel_alt1 wps welt ha m))
      has
      erzeuge_beispiel_alt_start\<close>
  apply(subst erzeuge_beispiel_alt_induct_helper[symmetric])
  apply(simp add: erzeuge_beispiel_alt_start_neutral)
  done

text\<open>The following looks like a perfect code equation.
But for some reasons, the document builds faster when not making this a \<^verbatim>\<open>[code]\<close>.\<close>
lemma erzeuge_beispiel_alt:
  \<open>erzeuge_beispiel = erzeuge_beispiel_alt\<close>
  by(simp add: fun_eq_iff erzeuge_beispiel_alt_def erzeuge_beispiel_alt_helper)

datatype ('person, 'welt) erzeuge_beiespiel_cache = ErzeugeBeispielCache
  (ebc_ha: \<open>('person, 'welt) handlungsabsicht\<close>)
  (ebc_katimp: \<open>bool\<close>)
  (ebc_moralisch: \<open>bool\<close>)

definition \<open>erzeuge_beispiel_code wps welt has m \<equiv>
  if (\<exists>h\<in> (\<Union>ha \<in> set has. set (alle_moeglichen_handlungen welt ha)). \<not>wohlgeformte_maxime_auf h wps m)
     \<or> (\<exists>ha\<in>set has. \<not> wohlgeformte_handlungsabsicht wps welt ha)
  then None
  else Some
  (let cache = [ErzeugeBeispielCache ha (kategorischer_imperativ_auf ha welt m) (moralisch welt m ha). ha\<leftarrow>has] in
   \<lparr>
     bsp_erfuellte_maxime = \<forall>ki\<in>set (map ebc_katimp cache). ki,
     bsp_erlaubte_handlungen = [ebc_ha c. c\<leftarrow>cache, ebc_katimp c \<and> ebc_moralisch c],
     bsp_verbotene_handlungen = [ebc_ha c. c\<leftarrow>cache, ebc_katimp c \<and> \<not> ebc_moralisch c],
     bsp_uneindeutige_handlungen = [ebc_ha c. c\<leftarrow>cache, \<not> ebc_katimp c]
   \<rparr>)\<close>

lemma erzeuge_beispiel_code[code]:
  \<open>erzeuge_beispiel = erzeuge_beispiel_code\<close>
  apply(simp add: fun_eq_iff erzeuge_beispiel_def erzeuge_beispiel_code_def)
  apply(simp add: comp_def)
  apply(subst erzeuge_beiespiel_cache.sel)+ (*why u no simp*)
  apply(simp add: concat_map_if)
  done
(*>*)

(*TODO*)
text\<open>
Das Ergebnis von \<^const>\<open>erzeuge_beispiel\<close> ließt sich wie folgt.
  \<^item> Wenn \<^const>\<open>bsp_erfuellte_maxime\<close> einen \<^const>\<open>Some\<close> term enthält ist der
    \<^const>\<open>kategorischer_imperativ_auf\<close> den Handlungen erfüllt
  \<^item> Die \<^const>\<open>bsp_erlaubte_handlungen\<close> und \<^const>\<open>bsp_verbotene_handlungen\<close> entspricht
    quasi dem allgemeinen Gesetz, welches besagt, welche Handlungen erlaubt oder verboten sind.
\<close>

text\<open>\<^const>\<open>erzeuge_beispiel\<close> erzeugt genau dann ein Beispiel, wenn alles wohlgeformt ist.\<close>
lemma \<open>(\<exists>bsp. erzeuge_beispiel wps welt has m = Some bsp) \<longleftrightarrow>
  (\<forall> ha \<in> set has. wohlgeformte_handlungsabsicht wps welt ha) \<and>
  (\<forall> h \<in> set [h. ha \<leftarrow> has, h \<leftarrow> alle_moeglichen_handlungen welt ha]. wohlgeformte_maxime_auf h wps m)\<close>
  apply(rule iffI)
   apply(simp add: erzeuge_beispiel_def split: if_split_asm; fail)
  apply(simp add: erzeuge_beispiel_def)
  done

(*<*)
(*thx lars: https://stackoverflow.com/questions/74337244/turning-a-valuesimp-example-into-a-lemma-with-functions-in-them/74394525#74394525*)
ML\<open>
val technique = Nbe.dynamic_conv; (*Code_Simp.dynamic_conv is slow*)
fun beispiel_conv ctxt =
  Conv.arg_conv (Conv.arg1_conv (technique ctxt) then_conv Conv.arg_conv (technique ctxt))

fun beispiel_tac ctxt =
  HEADGOAL (CONVERSION (beispiel_conv ctxt) THEN_ALL_NEW (resolve_tac ctxt @{thms refl}))
\<close>

method_setup beispiel_tac = \<open>Scan.succeed (SIMPLE_METHOD o beispiel_tac)\<close>
(*>*)

beispiel
  \<open>erzeuge_beispiel swap (\<lambda>p::person. 0::int) [Handlungsabsicht (\<lambda>p w. Some w)] (Maxime (\<lambda>ich w. True))
  =
  Some
  \<lparr>
   bsp_erfuellte_maxime = True,
   bsp_erlaubte_handlungen = [Handlungsabsicht (\<lambda>p w. Some w)],
   bsp_verbotene_handlungen = [],
   bsp_uneindeutige_handlungen = []
  \<rparr>\<close>
  by beispiel_tac

text\<open>Der Nachteil von \<^const>\<open>erzeuge_beispiel\<close> ist,
dass der resultierende Record viele Funktionen enthält,
welche eigentlich nicht geprintet werden können.
Allerdings ist dies vermutlich die einzige (sinnvolle, einfache) Art eine Handlungsabsicht
darzustellen.

Es wäre einfacher, nur die Handlung (also die \<^typ>\<open>'welt handlung\<close>,
nur die Welt vorher und nachher, ohne Absicht) aufzuschreiben.
Allerdings erzeugt das ohne die Absicht (i.e. \<^typ>\<open> ('person, 'welt) handlungsabsicht\<close>)
sehr viel Unfug, da z.B. pathologische Grenzfälle
(wie z.B. sich-selsbt-bestehlen, oder die-welt-die-zufällig-im-ausgangszustand-ist-resetten)
dazu, dass diese no-op Handlungen verboten sind, da die dahinterliegende Absicht schlecht ist.
Wenn wir allerdings nur die Ergebnisse einer solchen Handlung (ohne die Absicht) aufschreiben
kommt heraus: Nichtstun ist verboten.

Glücklicherweise hat Lars uns 4 Zeilen ML geschrieben, welche \<^const>\<open>erzeuge_beispiel\<close> als
ausführbares Beispiel benutzbar macht und dabei es auch erlaubt die Funktionen richtig
zu printen, solange diese einen Namen haben.\<close>

subsection\<open>Kombination vom Maximen\<close>
text\<open>Die folgenden Lemmata über Konjunktion, Disjunktion, und Negation von Maximen werden
leider etwas kompliziert.
Wir führen eine Hilfsdefinition ein, welche besagt, ob es einen Fall gibt
in dem die Handlungsabsicht tatsächlich ausführbar ist und die Maxime erfüllt.
Dabei werden gezielt die pathologischen Grenzfälle ausgeklammert,
in denen die Handlungsabsicht nicht ausführbar ist und in einer No-Op resultieren würde.\<close>
(*TODO: in die kat imp definition folden!*)
definition ex_erfuellbare_instanz
  :: \<open>('person, 'welt) maxime \<Rightarrow> 'welt \<Rightarrow> ('person, 'welt) handlungsabsicht \<Rightarrow> bool\<close>
where
  \<open>ex_erfuellbare_instanz m welt ha \<equiv>
      \<exists>ich. ausfuehrbar ich welt ha \<and> okay m ich (handeln ich welt ha)\<close>

subsubsection\<open>Konjunktion\<close>

lemma MaximeConjI:
  \<open>kategorischer_imperativ_auf ha welt m1 \<and> kategorischer_imperativ_auf ha welt m2 \<Longrightarrow>
  kategorischer_imperativ_auf ha welt (MaximeConj m1 m2)\<close>
  apply(cases \<open>m1\<close>, cases \<open>m2\<close>, simp)
  apply(simp add: kategorischer_imperativ_auf_def moralisch_simp okay_MaximeConj)
  apply blast
  done

text\<open>Die Rückrichtung gilt nur, wenn wir annehmen, dass es auch einen Fall gibt
in dem die \<^const>\<open>MaximeConj\<close> auch erfüllbar ist:\<close>
lemma MaximeConjD:
  \<open>ex_erfuellbare_instanz (MaximeConj m1 m2) welt ha \<Longrightarrow>
    kategorischer_imperativ_auf ha welt (MaximeConj m1 m2) \<Longrightarrow>
    kategorischer_imperativ_auf ha welt m1 \<and> kategorischer_imperativ_auf ha welt m2\<close>
  apply(simp add: ex_erfuellbare_instanz_def kategorischer_imperativ_auf_def)
  apply(simp add: moralisch_MaximeConj)
  done

text\<open>Wenn wir \<^const>\<open>ex_erfuellbare_instanz\<close> annehmen, dann verhält sich \<^const>\<open>MaximeConj\<close>
im \<^const>\<open>kategorischer_imperativ_auf\<close> wie eine normale Konjunktion.\<close>
lemma MaximeConj:
  \<open>ex_erfuellbare_instanz (MaximeConj m1 m2) welt ha \<Longrightarrow>
    kategorischer_imperativ_auf ha welt (MaximeConj m1 m2) \<longleftrightarrow>
    kategorischer_imperativ_auf ha welt m1 \<and> kategorischer_imperativ_auf ha welt m2\<close>
  by(auto intro: MaximeConjI dest: MaximeConjD)

lemma kategorischer_imperativ_auf_MaximeConj_comm:
  \<open>kategorischer_imperativ_auf ha welt (MaximeConj m1 m2)
   \<longleftrightarrow> kategorischer_imperativ_auf ha welt (MaximeConj m2 m1)\<close>
  by(auto simp add: kategorischer_imperativ_auf_def moralisch_simp okay_MaximeConj)

lemma kategorischer_imperativ_auf_MaximeConj_True:
  \<open>kategorischer_imperativ_auf ha welt (MaximeConj m1 (Maxime (\<lambda>_ _. True)))
  \<longleftrightarrow> kategorischer_imperativ_auf ha welt m1\<close>
  by(simp add: kategorischer_imperativ_auf_def moralisch_simp okay_MaximeConj)

text\<open>Achtung: Folgendes lemma ist das Gegenteil, was man von einer Konjunktion erwarten würde.
Normalerweise ist \<^term>\<open>a \<and> False = False\<close>.
Bei \<^const>\<open>MaximeConj\<close> ist dies aber \<^const>\<open>True\<close>!
Dies liegt daran, dass \<^term>\<open>Maxime (\<lambda>_ _. False)\<close> keine Handlung erlaubt,
und damit als pathologischen Grenzfall den kategorischen Imperativ erfüllt.\<close>
lemma kategorischer_imperativ_auf_MaximeConj_False:
  \<open>kategorischer_imperativ_auf ha welt (MaximeConj m1 (Maxime (\<lambda>_ _. False)))\<close>
  by(simp add: kategorischer_imperativ_auf_def moralisch_simp okay_MaximeConj)

subsubsection\<open>Disjunktion\<close>

text\<open>Für \<^const>\<open>MaximeDisj\<close> müssen wir generell annehmen,
dass einer der Fälle erfüllbar ist.\<close>
lemma kategorischer_imperativ_auf_MaximeDisjI:
\<open>(ex_erfuellbare_instanz m1 welt ha \<and> kategorischer_imperativ_auf ha welt m1) \<or>
 (ex_erfuellbare_instanz m2 welt ha \<and> kategorischer_imperativ_auf ha welt m2) \<Longrightarrow>
  kategorischer_imperativ_auf ha welt (MaximeDisj m1 m2)\<close>
  apply(simp add: ex_erfuellbare_instanz_def kategorischer_imperativ_auf_def okay_MaximeDisj)
  apply(erule disjE)
   apply(auto intro: moralisch_MaximeDisjI)
  done
text\<open>Die Rückrichtung gilt leider nicht.\<close>

text\<open>Die Annahmen sind leider sehr stark:\<close>
lemma
  \<open>ex_erfuellbare_instanz m welt ha \<and> kategorischer_imperativ_auf ha welt m
  \<Longrightarrow>
  moralisch welt m ha\<close>
  by (simp add: ex_erfuellbare_instanz_def kategorischer_imperativ_auf_def)

text\<open>Wenn wir die Annahme stärker machen gilt auch folgendes:\<close>
lemma kategorischer_imperativ_auf_MaximeDisjI_from_conj:
  \<open>kategorischer_imperativ_auf ha welt m1 \<and> kategorischer_imperativ_auf ha welt m2 \<Longrightarrow>
  kategorischer_imperativ_auf ha welt (MaximeDisj m1 m2)\<close>
  apply(simp add: kategorischer_imperativ_auf_def moralisch_simp okay_MaximeDisj)
  by blast

text\<open>Als Introduction rule eignet sich vermutlich folgendes besser,
weil es auch erlaubt,
dass eine Handlungsabsicht nicht ausführbar ist oder von keiner Maxime erfüllbar ist.\<close>
lemma kategorischer_imperativ_auf_MaximeDisjI2:
\<open>(ex_erfuellbare_instanz m1 welt ha \<and> kategorischer_imperativ_auf ha welt m1) \<or>
 (ex_erfuellbare_instanz m2 welt ha \<and> kategorischer_imperativ_auf ha welt m2) \<or>
 (\<not> ex_erfuellbare_instanz (MaximeDisj m1 m2) welt ha)
\<Longrightarrow>
  kategorischer_imperativ_auf ha welt (MaximeDisj m1 m2)\<close>
  apply(simp add: ex_erfuellbare_instanz_def kategorischer_imperativ_auf_def okay_MaximeDisj)
  apply(elim disjE)
  by(auto intro: moralisch_MaximeDisjI)

text\<open>Die vorherige Introduction Rule lässt sich wie folgt erklären.
Mindestens eine der \<^const>\<open>ex_erfuellbare_instanz\<close>Fälle muss immer zutreffen:\<close>
lemma
  \<open>ex_erfuellbare_instanz m1 welt ha \<or>
   ex_erfuellbare_instanz m2 welt ha \<or>
   \<not> ex_erfuellbare_instanz (MaximeDisj m1 m2) welt ha\<close>
  by(auto simp add: ex_erfuellbare_instanz_def okay_MaximeDisj)
text\<open>Wenn wir also mental den \<^const>\<open>ex_erfuellbare_instanz\<close> Teil ausblenden,
dann liest sich obige Introduction Rule wie folgt:
\<^term>\<open>kategorischer_imperativ_auf ha welt m1 \<or> kategorischer_imperativ_auf ha welt m2
\<Longrightarrow> kategorischer_imperativ_auf ha welt (MaximeDisj m1 m2)\<close>.
Dies ist genau die Disjunktions Introduction Rule die ich gerne hätte.
Die gesamte Regel ist leider leicht komplizierter,
da der entsprechende Oder-Fall immer mit dem entsprechenden \<^const>\<open>ex_erfuellbare_instanz\<close>
gepaart auftreten muss.
\<close>

text\<open>Eine gewöhnliche Introduction Rule (ohne die \<^const>\<open>ex_erfuellbare_instanz\<close> Teile)
gilt leider nicht.\<close>
beispiel
  \<open>ha = Handlungsabsicht (\<lambda>p w. Some w) \<Longrightarrow>
   m1 = Maxime ((\<lambda>p h. False)(Bob := \<lambda>h. True)) \<Longrightarrow>
   welt = (0::int) \<Longrightarrow>
   kategorischer_imperativ_auf ha welt m1 \<Longrightarrow>
    \<not> kategorischer_imperativ_auf ha welt (MaximeDisj m1 m2)\<close>
  apply(simp)
  apply(thin_tac \<open>_ = _\<close>)+
  apply(code_simp)
  done

text\<open>Zumindest gelten folgende Regeln welche einer gewöhnlichen Disjuntions Introduction
ähnlich sehen (mit leicht stärkeren Annahmen):\<close>
lemma
\<open>(ex_erfuellbare_instanz m1 welt ha \<and> kategorischer_imperativ_auf ha welt m1)
  \<Longrightarrow> kategorischer_imperativ_auf ha welt (MaximeDisj m1 m2)\<close>
\<open>moralisch welt m1 ha
  \<Longrightarrow> kategorischer_imperativ_auf ha welt (MaximeDisj m1 m2)\<close>
   apply (meson kategorischer_imperativ_auf_MaximeDisjI2)
  by (simp add: kategorischer_imperativ_auf_def moralisch_MaximeDisj1 kategorischer_imperativ_auf_MaximeDisjI2)

lemma moralisch_kategorischer_imperativ_auf_MaximeDisjI:
  \<open>moralisch welt m1 ha \<Longrightarrow>
  kategorischer_imperativ_auf ha welt (MaximeDisj m1 m2)\<close>
  by(simp add: kategorischer_imperativ_auf_def moralisch_simp okay_MaximeDisj)

lemma kategorischer_imperativ_auf_MaximeDisj_comm:
  \<open>kategorischer_imperativ_auf ha welt (MaximeDisj m1 m2)
   \<longleftrightarrow> kategorischer_imperativ_auf ha welt (MaximeDisj m2 m1)\<close>
  by(auto simp add: kategorischer_imperativ_auf_def moralisch_simp okay_MaximeDisj)

text\<open>Für die Grenzfälle einer Disjunktion mit \<^const>\<open>True\<close> und \<^const>\<open>False\<close>
verhält sich \<^const>\<open>MaximeDisj\<close> wie erwartet.\<close>
lemma kategorischer_imperativ_auf_MaximeDisj_True:
  \<open>kategorischer_imperativ_auf ha welt (MaximeDisj m1 (Maxime (\<lambda>_ _. True)))\<close>
  by(simp add: kategorischer_imperativ_auf_def moralisch_simp okay_MaximeDisj)
lemma kategorischer_imperativ_auf_MaximeDisj_False:
  \<open>kategorischer_imperativ_auf ha welt (MaximeDisj m1 (Maxime (\<lambda>_ _. False)))
  \<longleftrightarrow> kategorischer_imperativ_auf ha welt m1\<close>
  by(simp add: kategorischer_imperativ_auf_def moralisch_simp okay_MaximeDisj)

text\<open>Die Negation verhält sich wie erwartet.\<close>
lemma kategorischer_imperativ_auf_Maxime_DeMorgan:
\<open>kategorischer_imperativ_auf ha welt (MaximeNot (MaximeConj m1 m2))
  \<longleftrightarrow>
  kategorischer_imperativ_auf ha welt (MaximeDisj (MaximeNot m1) (MaximeNot m2))\<close>
  by (simp add: kategorischer_imperativ_auf_def moralisch_DeMorgan okay_DeMorgan)

lemma kategorischer_imperativ_auf_MaximeNot_double:
  \<open>kategorischer_imperativ_auf ha welt (MaximeNot (MaximeNot m))
    \<longleftrightarrow> kategorischer_imperativ_auf ha welt m\<close>
  by(simp add: kategorischer_imperativ_auf_def moralisch_simp okay_MaximeNot)

end


(*  Title:      HOL/SPARK/SPARK.thy
    Author:     Stefan Berghofer
    Copyright:  secunet Security Networks AG

Declaration of proof functions for SPARK/Ada verification environment.
*)

theory SPARK
imports SPARK_Setup
begin

text \<open>Bitwise logical operators\<close>

spark_proof_functions
  bit__and (integer, integer) : integer = "(AND)"
  bit__or (integer, integer) : integer = "(OR)"
  bit__xor (integer, integer) : integer = "(XOR)"

lemmas [simp] =
  OR_upper [of _ 8, simplified zle_diff1_eq [symmetric], simplified]
  OR_upper [of _ 8, simplified]
  OR_upper [of _ 16, simplified zle_diff1_eq [symmetric], simplified]
  OR_upper [of _ 16, simplified]
  OR_upper [of _ 32, simplified zle_diff1_eq [symmetric], simplified]
  OR_upper [of _ 32, simplified]
  OR_upper [of _ 64, simplified zle_diff1_eq [symmetric], simplified]
  OR_upper [of _ 64, simplified]

lemmas [simp] =
  XOR_upper [of _ 8, simplified zle_diff1_eq [symmetric], simplified]
  XOR_upper [of _ 8, simplified]
  XOR_upper [of _ 16, simplified zle_diff1_eq [symmetric], simplified]
  XOR_upper [of _ 16, simplified]
  XOR_upper [of _ 32, simplified zle_diff1_eq [symmetric], simplified]
  XOR_upper [of _ 32, simplified]
  XOR_upper [of _ 64, simplified zle_diff1_eq [symmetric], simplified]
  XOR_upper [of _ 64, simplified]

lemma bit_not_spark_eq:
  "NOT (word_of_int x :: ('a::len) word) =
  word_of_int (2 ^ LENGTH('a) - 1 - x)"
  by (simp flip: mask_eq_exp_minus_1 add: of_int_mask_eq not_eq_complement)

lemmas [simp] =
  bit_not_spark_eq [where 'a=8, simplified]
  bit_not_spark_eq [where 'a=16, simplified]
  bit_not_spark_eq [where 'a=32, simplified]
  bit_not_spark_eq [where 'a=64, simplified]

text \<open>Minimum and maximum\<close>

spark_proof_functions
  integer__min = "min :: int \<Rightarrow> int \<Rightarrow> int"
  integer__max = "max :: int \<Rightarrow> int \<Rightarrow> int"

end