(*
(C) Copyright Andreas Viktor Hess, DTU, 2015-2020

All Rights Reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

- Redistributions of source code must retain the above copyright
  notice, this list of conditions and the following disclaimer.

- Redistributions in binary form must reproduce the above copyright
  notice, this list of conditions and the following disclaimer in the
  documentation and/or other materials provided with the distribution.

- Neither the name of the copyright holder nor the names of its
  contributors may be used to endorse or promote products
  derived from this software without specific prior written
  permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)

(*  Title:      Example_Keyserver.thy
    Author:     Andreas Viktor Hess, DTU
*)

section \<open>The Keyserver Example\<close>
text \<open>\label{sec:Example-Keyserver}\<close>
theory Example_Keyserver
imports "../Stateful_Compositionality"
begin

declare [[code_timing]]

subsection \<open>Setup\<close>
subsubsection \<open>Datatypes and functions setup\<close>
datatype ex_lbl = Label1 ("\<one>") | Label2 ("\<two>")

datatype ex_atom =
  Agent | Value | Attack | PrivFunSec
| Bot

datatype ex_fun =
  ring | valid | revoked | events | beginauth nat | endauth nat | pubkeys | seen
| invkey | tuple | tuple' | attack nat
| sign | crypt | update | pw
| encodingsecret | pubkey nat
| pubconst ex_atom nat

type_synonym ex_type = "(ex_fun, ex_atom) term_type"
type_synonym ex_var = "ex_type \<times> nat"

lemma ex_atom_UNIV:
  "(UNIV::ex_atom set) = {Agent, Value, Attack, PrivFunSec, Bot}"
by (auto intro: ex_atom.exhaust)

instance ex_atom::finite
by intro_classes (metis ex_atom_UNIV finite.emptyI finite.insertI)

lemma ex_lbl_UNIV:
  "(UNIV::ex_lbl set) = {Label1, Label2}"
by (auto intro: ex_lbl.exhaust)

type_synonym ex_term = "(ex_fun, ex_var) term"
type_synonym ex_terms = "(ex_fun, ex_var) terms"

primrec arity::"ex_fun \<Rightarrow> nat" where
  "arity ring = 2"
| "arity valid = 3"
| "arity revoked = 3"
| "arity events = 1"
| "arity (beginauth _) = 3"
| "arity (endauth _) = 3"
| "arity pubkeys = 2"
| "arity seen = 2"
| "arity invkey = 2"
| "arity tuple = 2"
| "arity tuple' = 2"
| "arity (attack _) = 0"
| "arity sign = 2"
| "arity crypt = 2"
| "arity update = 4"
| "arity pw = 2"
| "arity (pubkey _) = 0"
| "arity encodingsecret = 0"
| "arity (pubconst _ _) = 0"

fun public::"ex_fun \<Rightarrow> bool" where
  "public (pubkey _) = False"
| "public encodingsecret = False"
| "public _ = True"

fun Ana\<^sub>c\<^sub>r\<^sub>y\<^sub>p\<^sub>t::"ex_term list \<Rightarrow> (ex_term list \<times> ex_term list)" where
  "Ana\<^sub>c\<^sub>r\<^sub>y\<^sub>p\<^sub>t [k,m] = ([Fun invkey [Fun encodingsecret [], k]], [m])"
| "Ana\<^sub>c\<^sub>r\<^sub>y\<^sub>p\<^sub>t _ = ([], [])"

fun Ana\<^sub>s\<^sub>i\<^sub>g\<^sub>n::"ex_term list \<Rightarrow> (ex_term list \<times> ex_term list)" where
  "Ana\<^sub>s\<^sub>i\<^sub>g\<^sub>n [k,m] = ([], [m])"
| "Ana\<^sub>s\<^sub>i\<^sub>g\<^sub>n _ = ([], [])"

fun Ana::"ex_term \<Rightarrow> (ex_term list \<times> ex_term list)" where
  "Ana (Fun tuple T) = ([], T)"
| "Ana (Fun tuple' T) = ([], T)"
| "Ana (Fun sign T) = Ana\<^sub>s\<^sub>i\<^sub>g\<^sub>n T"
| "Ana (Fun crypt T) = Ana\<^sub>c\<^sub>r\<^sub>y\<^sub>p\<^sub>t T"
| "Ana _ = ([], [])"

subsubsection \<open>Keyserver example: Locale interpretation\<close>
lemma assm1:
  "Ana t = (K,M) \<Longrightarrow> fv\<^sub>s\<^sub>e\<^sub>t (set K) \<subseteq> fv t"
  "Ana t = (K,M) \<Longrightarrow> (\<And>g S'. Fun g S' \<sqsubseteq> t \<Longrightarrow> length S' = arity g)
                \<Longrightarrow> k \<in> set K \<Longrightarrow> Fun f T' \<sqsubseteq> k \<Longrightarrow> length T' = arity f"
  "Ana t = (K,M) \<Longrightarrow> K \<noteq> [] \<or> M \<noteq> [] \<Longrightarrow> Ana (t \<cdot> \<delta>) = (K \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<delta>, M \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<delta>)"
by (rule Ana.cases[of "t"], auto elim!: Ana\<^sub>c\<^sub>r\<^sub>y\<^sub>p\<^sub>t.elims Ana\<^sub>s\<^sub>i\<^sub>g\<^sub>n.elims)+

lemma assm2: "Ana (Fun f T) = (K, M) \<Longrightarrow> set M \<subseteq> set T"
by (rule Ana.cases[of "Fun f T"]) (auto elim!: Ana\<^sub>c\<^sub>r\<^sub>y\<^sub>p\<^sub>t.elims Ana\<^sub>s\<^sub>i\<^sub>g\<^sub>n.elims)

lemma assm6: "0 < arity f \<Longrightarrow> public f" by (cases f) simp_all

global_interpretation im: intruder_model arity public Ana
  defines wf\<^sub>t\<^sub>r\<^sub>m = "im.wf\<^sub>t\<^sub>r\<^sub>m"
by unfold_locales (metis assm1(1), metis assm1(2),rule Ana.simps, metis assm2, metis assm1(3))

type_synonym ex_strand_step = "(ex_fun,ex_var) strand_step"
type_synonym ex_strand = "(ex_fun,ex_var) strand"

subsubsection \<open>Typing function\<close>
definition \<Gamma>\<^sub>v::"ex_var \<Rightarrow> ex_type" where
  "\<Gamma>\<^sub>v v = (if (\<forall>t \<in> subterms (fst v). case t of
                (TComp f T) \<Rightarrow> arity f > 0 \<and> arity f = length T
              | _ \<Rightarrow> True)
           then fst v else TAtom Bot)"

fun \<Gamma>::"ex_term \<Rightarrow> ex_type" where
  "\<Gamma> (Var v) = \<Gamma>\<^sub>v v"
| "\<Gamma> (Fun (attack _) _) = TAtom Attack"
| "\<Gamma> (Fun (pubkey _) _) = TAtom Value"
| "\<Gamma> (Fun encodingsecret _) = TAtom PrivFunSec"
| "\<Gamma> (Fun (pubconst \<tau> _) _) = TAtom \<tau>"
| "\<Gamma> (Fun f T) = TComp f (map \<Gamma> T)"

subsubsection \<open>Locale interpretation: typed model\<close>
lemma assm7: "arity c = 0 \<Longrightarrow> \<exists>a. \<forall>X. \<Gamma> (Fun c X) = TAtom a" by (cases c) simp_all

lemma assm8: "0 < arity f \<Longrightarrow> \<Gamma> (Fun f X) = TComp f (map \<Gamma> X)" by (cases f) simp_all

lemma assm9: "infinite {c. \<Gamma> (Fun c []) = TAtom a \<and> public c}"
proof -
  let ?T = "(range (pubconst a))::ex_fun set"
  have *:
      "\<And>x y::nat. x \<in> UNIV \<Longrightarrow> y \<in> UNIV \<Longrightarrow> (pubconst a x = pubconst a y) = (x = y)"
      "\<And>x::nat. x \<in> UNIV \<Longrightarrow> pubconst a x \<in> ?T"
      "\<And>y::ex_fun. y \<in> ?T \<Longrightarrow> \<exists>x \<in> UNIV. y = pubconst a x"
    by auto
  have "?T \<subseteq> {c. \<Gamma> (Fun c []) = TAtom a \<and> public c}" by auto
  moreover have "\<exists>f::nat \<Rightarrow> ex_fun. bij_betw f UNIV ?T"
    using bij_betwI'[OF *] by blast
  hence "infinite ?T" by (metis nat_not_finite bij_betw_finite)
  ultimately show ?thesis using infinite_super by blast
qed

lemma assm10: "TComp f T \<sqsubseteq> \<Gamma> t \<Longrightarrow> arity f > 0"
proof (induction rule: \<Gamma>.induct)
  case (1 x)
  hence *: "TComp f T \<sqsubseteq> \<Gamma>\<^sub>v x" by simp
  hence "\<Gamma>\<^sub>v x \<noteq> TAtom Bot" unfolding \<Gamma>\<^sub>v_def by force
  hence "\<forall>t \<in> subterms (fst x). case t of
            (TComp f T) \<Rightarrow> arity f > 0 \<and> arity f = length T
          | _ \<Rightarrow> True"
    unfolding \<Gamma>\<^sub>v_def by argo
  thus ?case using * unfolding \<Gamma>\<^sub>v_def by fastforce
qed auto

lemma assm11: "im.wf\<^sub>t\<^sub>r\<^sub>m (\<Gamma> (Var x))"
proof -
  have "im.wf\<^sub>t\<^sub>r\<^sub>m (\<Gamma>\<^sub>v x)" unfolding \<Gamma>\<^sub>v_def im.wf\<^sub>t\<^sub>r\<^sub>m_def by auto
  thus ?thesis by simp
qed

lemma assm12: "\<Gamma> (Var (\<tau>, n)) = \<Gamma> (Var (\<tau>, m))"
apply (cases "\<forall>t \<in> subterms \<tau>. case t of
                (TComp f T) \<Rightarrow> arity f > 0 \<and> arity f = length T
              | _ \<Rightarrow> True")
by (auto simp add: \<Gamma>\<^sub>v_def)

lemma Ana_const: "arity c = 0 \<Longrightarrow> Ana (Fun c T) = ([], [])"
by (cases c) simp_all

lemma Ana_subst': "Ana (Fun f T) = (K,M) \<Longrightarrow> Ana (Fun f T \<cdot> \<delta>) = (K \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<delta>,M \<cdot>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<delta>)"
by (cases f) (auto elim!: Ana\<^sub>c\<^sub>r\<^sub>y\<^sub>p\<^sub>t.elims Ana\<^sub>s\<^sub>i\<^sub>g\<^sub>n.elims)

global_interpretation tm: typed_model' arity public Ana \<Gamma>
by (unfold_locales, unfold wf\<^sub>t\<^sub>r\<^sub>m_def[symmetric])
   (metis assm7, metis assm8, metis assm9, metis assm10, metis assm11, metis assm6,
    metis assm12, metis Ana_const, metis Ana_subst')

subsubsection \<open>Locale interpretation: labeled stateful typed model\<close>
global_interpretation stm: labeled_stateful_typed_model' arity public Ana \<Gamma> tuple \<one> \<two>
by standard (rule arity.simps, metis Ana_subst', metis assm12, metis Ana_const, simp)

type_synonym ex_stateful_strand_step = "(ex_fun,ex_var) stateful_strand_step"
type_synonym ex_stateful_strand = "(ex_fun,ex_var) stateful_strand"

type_synonym ex_labeled_stateful_strand_step =
  "(ex_fun,ex_var,ex_lbl) labeled_stateful_strand_step"

type_synonym ex_labeled_stateful_strand =
  "(ex_fun,ex_var,ex_lbl) labeled_stateful_strand"

subsection \<open>Theorem: Type-flaw resistance of the keyserver example from the CSF18 paper\<close>
abbreviation "PK n \<equiv> Var (TAtom Value,n)"
abbreviation "A n \<equiv> Var (TAtom Agent,n)"
abbreviation "X n \<equiv> (TAtom Agent,n)"

abbreviation "ringset t \<equiv> Fun ring [Fun encodingsecret [], t]"
abbreviation "validset t t' \<equiv> Fun valid [Fun encodingsecret [], t, t']"
abbreviation "revokedset t t' \<equiv> Fun revoked [Fun encodingsecret [], t, t']"
abbreviation "eventsset \<equiv> Fun events [Fun encodingsecret []]"

(* Note: We will use S\<^sub>k\<^sub>s as a constraint, but it actually represents all steps that might occur
         in the protocol *)
abbreviation S\<^sub>k\<^sub>s::"(ex_fun,ex_var) stateful_strand_step list" where
  "S\<^sub>k\<^sub>s \<equiv> [
    insert\<langle>Fun (attack 0) [], eventsset\<rangle>,
    delete\<langle>PK 0, validset (A 0) (A 0)\<rangle>,
    \<forall>(TAtom Agent,0)\<langle>PK 0 not in revokedset (A 0) (A 0)\<rangle>,
    \<forall>(TAtom Agent,0)\<langle>PK 0 not in validset (A 0) (A 0)\<rangle>,
    insert\<langle>PK 0, validset (A 0) (A 0)\<rangle>,
    insert\<langle>PK 0, ringset (A 0)\<rangle>,
    insert\<langle>PK 0, revokedset (A 0) (A 0)\<rangle>,
    select\<langle>PK 0, validset (A 0) (A 0)\<rangle>,
    select\<langle>PK 0, ringset (A 0)\<rangle>,
    receive\<langle>Fun invkey [Fun encodingsecret [], PK 0]\<rangle>,
    receive\<langle>Fun sign [Fun invkey [Fun encodingsecret [], PK 0], Fun tuple' [A 0, PK 0]]\<rangle>,
    send\<langle>Fun invkey [Fun encodingsecret [], PK 0]\<rangle>,
    send\<langle>Fun sign [Fun invkey [Fun encodingsecret [], PK 0], Fun tuple' [A 0, PK 0]]\<rangle>
]"

theorem "stm.tfr\<^sub>s\<^sub>s\<^sub>t S\<^sub>k\<^sub>s"
proof -
  let ?M = "concat (map subterms_list (trms_list\<^sub>s\<^sub>s\<^sub>t S\<^sub>k\<^sub>s@map (pair' tuple) (setops_list\<^sub>s\<^sub>s\<^sub>t S\<^sub>k\<^sub>s)))"
  have "comp_tfr\<^sub>s\<^sub>s\<^sub>t arity Ana \<Gamma> tuple ?M S\<^sub>k\<^sub>s" by eval
  thus ?thesis by (rule stm.tfr\<^sub>s\<^sub>s\<^sub>t_if_comp_tfr\<^sub>s\<^sub>s\<^sub>t)
qed

subsection \<open>Theorem: Type-flaw resistance of the keyserver examples from the ESORICS18 paper\<close>
abbreviation "signmsg t t' \<equiv> Fun sign [t, t']"
abbreviation "cryptmsg t t' \<equiv> Fun crypt [t, t']"
abbreviation "invkeymsg t \<equiv> Fun invkey [Fun encodingsecret [], t]"
abbreviation "updatemsg a b c d \<equiv> Fun update [a,b,c,d]"
abbreviation "pwmsg t t' \<equiv> Fun pw [t, t']"

abbreviation "beginauthset n t t' \<equiv> Fun (beginauth n) [Fun encodingsecret [], t, t']"
abbreviation "endauthset n t t' \<equiv> Fun (endauth n) [Fun encodingsecret [], t, t']"
abbreviation "pubkeysset t \<equiv> Fun pubkeys [Fun encodingsecret [], t]"
abbreviation "seenset t \<equiv> Fun seen [Fun encodingsecret [], t]"

declare [[coercion "Var::ex_var \<Rightarrow> ex_term"]]
declare [[coercion_enabled]]

(* Note: S'\<^sub>k\<^sub>s contains the (slightly over-approximated) steps that can occur in the
         reachable constraints of \<P>\<^sub>k\<^sub>s,\<^sub>1 and \<P>\<^sub>k\<^sub>s,\<^sub>2 modulo variable renaming *)
definition S'\<^sub>k\<^sub>s::"ex_labeled_stateful_strand_step list" where
  "S'\<^sub>k\<^sub>s \<equiv> [
\<^cancel>\<open>constraint steps from the first protocol (duplicate steps are ignored)\<close>

    \<^cancel>\<open>rule R^1_1\<close>
    \<langle>\<one>, send\<langle>invkeymsg (PK 0)\<rangle>\<rangle>,
    \<langle>\<star>, \<langle>PK 0 in validset (A 0) (A 1)\<rangle>\<rangle>,
    \<langle>\<one>, receive\<langle>Fun (attack 0) []\<rangle>\<rangle>,

    \<^cancel>\<open>rule R^2_1\<close>
    \<langle>\<one>, send\<langle>signmsg (invkeymsg (PK 0)) (Fun tuple' [A 0, PK 0])\<rangle>\<rangle>,
    \<langle>\<star>, \<langle>PK 0 in validset (A 0) (A 1)\<rangle>\<rangle>,
    \<langle>\<star>, \<forall>X 0, X 1\<langle>PK 0 not in validset (Var (X 0)) (Var (X 1))\<rangle>\<rangle>,
    \<langle>\<one>, \<forall>X 0, X 1\<langle>PK 0 not in revokedset (Var (X 0)) (Var (X 1))\<rangle>\<rangle>,
    \<langle>\<star>, \<langle>PK 0 not in beginauthset 0 (A 0) (A 1)\<rangle>\<rangle>,

    \<^cancel>\<open>rule R^3_1\<close>
    \<langle>\<star>, \<langle>PK 0 in beginauthset 0 (A 0) (A 1)\<rangle>\<rangle>,
    \<langle>\<star>, \<langle>PK 0 in endauthset 0 (A 0) (A 1)\<rangle>\<rangle>,

    \<^cancel>\<open>rule R^4_1\<close>
    \<langle>\<star>, receive\<langle>PK 0\<rangle>\<rangle>,
    \<langle>\<star>, receive\<langle>invkeymsg (PK 0)\<rangle>\<rangle>,

    \<^cancel>\<open>rule R^5_1\<close>
    \<langle>\<one>, insert\<langle>PK 0, ringset (A 0)\<rangle>\<rangle>,
    \<langle>\<star>, insert\<langle>PK 0, validset (A 0) (A 1)\<rangle>\<rangle>,
    \<langle>\<star>, insert\<langle>PK 0, beginauthset 0 (A 0) (A 1)\<rangle>\<rangle>,
    \<langle>\<star>, insert\<langle>PK 0, endauthset 0 (A 0) (A 1)\<rangle>\<rangle>,

    \<^cancel>\<open>rule R^6_1\<close>
    \<langle>\<one>, select\<langle>PK 0, ringset (A 0)\<rangle>\<rangle>,
    \<langle>\<one>, delete\<langle>PK 0, ringset (A 0)\<rangle>\<rangle>,

    \<^cancel>\<open>rule R^7_1\<close>
    \<langle>\<star>, \<langle>PK 0 not in endauthset 0 (A 0) (A 1)\<rangle>\<rangle>,
    \<langle>\<star>, delete\<langle>PK 0, validset (A 0) (A 1)\<rangle>\<rangle>,
    \<langle>\<one>, insert\<langle>PK 0, revokedset (A 0) (A 1)\<rangle>\<rangle>,

    \<^cancel>\<open>rule R^8_1\<close>
    \<^cancel>\<open>nothing new\<close>

    \<^cancel>\<open>rule R^9_1\<close>
    \<langle>\<one>, send\<langle>PK 0\<rangle>\<rangle>,

    \<^cancel>\<open>rule R^10_1\<close>
    \<langle>\<one>, send\<langle>Fun (attack 0) []\<rangle>\<rangle>,

\<^cancel>\<open>constraint steps from the second protocol (duplicate steps are ignored)\<close>
    \<^cancel>\<open>rule R^2_1\<close>
    \<langle>\<two>, send\<langle>invkeymsg (PK 0)\<rangle>\<rangle>,
    \<langle>\<star>, \<langle>PK 0 in validset (A 0) (A 1)\<rangle>\<rangle>,
    \<langle>\<two>, receive\<langle>Fun (attack 1) []\<rangle>\<rangle>,

    \<^cancel>\<open>rule R^2_2\<close>
    \<langle>\<two>, send\<langle>cryptmsg (PK 0) (updatemsg (A 0) (A 1) (PK 1) (pwmsg (A 0) (A 1)))\<rangle>\<rangle>,
    \<langle>\<two>, select\<langle>PK 0, pubkeysset (A 0)\<rangle>\<rangle>,
    \<langle>\<two>, \<forall>X 0\<langle>PK 0 not in pubkeysset (Var (X 0))\<rangle>\<rangle>,
    \<langle>\<two>, \<forall>X 0\<langle>PK 0 not in seenset (Var (X 0))\<rangle>\<rangle>,

    \<^cancel>\<open>rule R^3_2\<close>
    \<langle>\<star>, \<langle>PK 0 in beginauthset 1 (A 0) (A 1)\<rangle>\<rangle>,
    \<langle>\<star>, \<langle>PK 0 in endauthset 1 (A 0) (A 1)\<rangle>\<rangle>,

    \<^cancel>\<open>rule R^4_2\<close>
    \<langle>\<star>, receive\<langle>PK 0\<rangle>\<rangle>,
    \<langle>\<star>, receive\<langle>invkeymsg (PK 0)\<rangle>\<rangle>,

    \<^cancel>\<open>rule R^5_2\<close>
    \<langle>\<two>, select\<langle>PK 0, pubkeysset (A 0)\<rangle>\<rangle>,
    \<langle>\<star>, insert\<langle>PK 0, beginauthset 1 (A 0) (A 1)\<rangle>\<rangle>,
    \<langle>\<two>, receive\<langle>cryptmsg (PK 0) (updatemsg (A 0) (A 1) (PK 1) (pwmsg (A 0) (A 1)))\<rangle>\<rangle>,

    \<^cancel>\<open>rule R^6_2\<close>
    \<langle>\<star>, \<langle>PK 0 not in endauthset 1 (A 0) (A 1)\<rangle>\<rangle>,
    \<langle>\<star>, insert\<langle>PK 0, validset (A 0) (A 1)\<rangle>\<rangle>,
    \<langle>\<star>, insert\<langle>PK 0, endauthset 1 (A 0) (A 1)\<rangle>\<rangle>,
    \<langle>\<two>, insert\<langle>PK 0, seenset (A 0)\<rangle>\<rangle>,

    \<^cancel>\<open>rule R^7_2\<close>
    \<langle>\<two>, receive\<langle>pwmsg (A 0) (A 1)\<rangle>\<rangle>,

    \<^cancel>\<open>rule R^8_2\<close>
    \<^cancel>\<open>nothing new\<close>

    \<^cancel>\<open>rule R^9_2\<close>
    \<langle>\<two>, insert\<langle>PK 0, pubkeysset (A 0)\<rangle>\<rangle>,

    \<^cancel>\<open>rule R^10_2\<close>
    \<langle>\<two>, send\<langle>Fun (attack 1) []\<rangle>\<rangle>
]"

theorem "stm.tfr\<^sub>s\<^sub>s\<^sub>t (unlabel S'\<^sub>k\<^sub>s)"
proof -
  let ?S = "unlabel S'\<^sub>k\<^sub>s"
  let ?M = "concat (map subterms_list (trms_list\<^sub>s\<^sub>s\<^sub>t ?S@map (pair' tuple) (setops_list\<^sub>s\<^sub>s\<^sub>t ?S)))"
  have "comp_tfr\<^sub>s\<^sub>s\<^sub>t arity Ana \<Gamma> tuple ?M ?S" by eval
  thus ?thesis by (rule stm.tfr\<^sub>s\<^sub>s\<^sub>t_if_comp_tfr\<^sub>s\<^sub>s\<^sub>t)
qed

subsection \<open>Theorem: The steps of the keyserver protocols from the ESORICS18 paper satisfy the conditions for parallel composition\<close>
theorem
  fixes S f
  defines "S \<equiv> [PK 0, invkeymsg (PK 0), Fun encodingsecret []]@concat (
                map (\<lambda>s. [s, Fun tuple [PK 0, s]])
                    [validset (A 0) (A 1), beginauthset 0 (A 0) (A 1), endauthset 0 (A 0) (A 1),
                     beginauthset 1 (A 0) (A 1), endauthset 1 (A 0) (A 1)])@
                [A 0]"
    and "f \<equiv> \<lambda>M. {t \<cdot> \<delta> | t \<delta>. t \<in> M \<and> tm.wt\<^sub>s\<^sub>u\<^sub>b\<^sub>s\<^sub>t \<delta> \<and> im.wf\<^sub>t\<^sub>r\<^sub>m\<^sub>s (subst_range \<delta>) \<and> fv (t \<cdot> \<delta>) = {}}"
    and "Sec \<equiv> (f (set S)) - {m. im.intruder_synth {} m}"
  shows "stm.par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t S'\<^sub>k\<^sub>s Sec"
proof -
  let ?N = "\<lambda>P. concat (map subterms_list (trms_list\<^sub>s\<^sub>s\<^sub>t P@map (pair' tuple) (setops_list\<^sub>s\<^sub>s\<^sub>t P)))"
  let ?M = "\<lambda>l. ?N (proj_unl l S'\<^sub>k\<^sub>s)"
  have "comp_par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t public arity Ana \<Gamma> tuple S'\<^sub>k\<^sub>s ?M S"
    unfolding S_def by eval
  thus ?thesis
    using stm.par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t_if_comp_par_comp\<^sub>l\<^sub>s\<^sub>s\<^sub>t[of S'\<^sub>k\<^sub>s ?M S]
    unfolding Sec_def f_def wf\<^sub>t\<^sub>r\<^sub>m_def[symmetric] by blast
qed

end


(*<*)
theory CJDDLplus
  imports Main
begin
nitpick_params[user_axioms=true, show_all, expect=genuine, format = 3]
(*>*)

section \<open>Introduction\<close>
text\<open>\noindent{We present an encoding of an ambitious ethical theory ---Alan Gewirth's "Principle of Generic Consistency (PGC)"---
in Isabelle/HOL. The PGC has stirred much attention in philosophy and ethics \<^cite>\<open>"Beyleveld"\<close> and has been proposed as a
potential means to bound the impact of artificial general intelligence (AGI) \<^cite>\<open>"Kornai"\<close>.
With our contribution we make a first, important step towards formally assessing the PGC and its potential applications in AI.
Our formalisation utilises the shallow semantical embedding approach \<^cite>\<open>"J23"\<close>
and adapts a recent embedding of dyadic deontic logic in HOL \<^cite>\<open>"C71"\<close> \<^cite>\<open>"BenzmuellerDDL"\<close>.
}\<close>

section \<open>Semantic Embedding of Carmo and Jones' Dyadic Deontic Logic (DDL) augmented with Kaplanian contexts\<close>

text\<open>\noindent{We introduce a modification of the semantic embedding developed by Benzm\"uller et al. \<^cite>\<open>"C71"\<close> \<^cite>\<open>"BenzmuellerDDL"\<close>
for the Dyadic Deontic Logic originally presented by Carmo and Jones \<^cite>\<open>"CJDDL"\<close>. We extend this embedding
to a two-dimensional semantics as originally presented by David Kaplan \<^cite>\<open>"Kaplan1979"\<close> \<^cite>\<open>"Kaplan1989"\<close>.}\<close>

subsection \<open>Definition of Types\<close>

typedecl w   \<comment> \<open>  Type for possible worlds (Kaplan's "circumstances of evaluation" or "counterfactual situations")  \<close>
typedecl e   \<comment> \<open>  Type for individuals (entities eligible to become agents) \<close>
typedecl c   \<comment> \<open>  Type for Kaplanian "contexts of use" \<close>
type_synonym wo = "w\<Rightarrow>bool" \<comment> \<open>  contents/propositions are identified with their truth-sets \<close>
type_synonym cwo = "c\<Rightarrow>wo"  \<comment> \<open>  sentence meaning (Kaplan's "character") is a function from contexts to contents \<close>
type_synonym m = "cwo"      \<comment> \<open>  we use the letter 'm' for characters (reminiscent of "meaning") \<close>

subsection \<open>Semantic Characterisation of DDL\<close> (*cf. original Carmo and Jones Paper @{cite "CJDDL"} p.290ff*)

subsubsection \<open>Basic Set Operations\<close>
abbreviation subset::"wo\<Rightarrow>wo\<Rightarrow>bool" (infix "\<sqsubseteq>" 46) where "\<alpha> \<sqsubseteq> \<beta> \<equiv> \<forall>w. \<alpha> w  \<longrightarrow> \<beta> w"
abbreviation intersection::"wo\<Rightarrow>wo\<Rightarrow>wo" (infixr "\<sqinter>" 48) where "\<alpha> \<sqinter> \<beta> \<equiv> \<lambda>x. \<alpha> x \<and> \<beta> x"
abbreviation union::"wo\<Rightarrow>wo\<Rightarrow>wo" (infixr "\<squnion>" 48) where "\<alpha> \<squnion> \<beta> \<equiv> \<lambda>x. \<alpha> x \<or> \<beta> x"
abbreviation complement::"wo\<Rightarrow>wo" ("\<sim>_"[45]46) where "\<sim>\<alpha> \<equiv> \<lambda>x. \<not>\<alpha> x"
abbreviation instantiated::"wo\<Rightarrow>bool" ("\<I>_"[45]46) where "\<I> \<phi> \<equiv> \<exists>x. \<phi> x"
abbreviation setEq::"wo\<Rightarrow>wo\<Rightarrow>bool" (infix "=\<^sub>s" 46) where "\<alpha> =\<^sub>s \<beta> \<equiv> \<forall>x. \<alpha> x \<longleftrightarrow> \<beta> x"
abbreviation univSet :: "wo" ("\<top>") where "\<top> \<equiv> \<lambda>w. True"
abbreviation emptySet :: "wo" ("\<bottom>") where "\<bottom> \<equiv> \<lambda>w. False"

subsubsection \<open>Set-Theoretic Conditions for DDL\<close>

consts
av::"w\<Rightarrow>wo"   \<comment> \<open> set of worlds that are open alternatives (aka. actual versions) of w \<close>
pv::"w\<Rightarrow>wo"   \<comment> \<open> set of worlds that are possible alternatives (aka. potential versions) of w \<close>
ob::"wo\<Rightarrow>wo\<Rightarrow>bool" \<comment> \<open> set of propositions which are obligatory in a given context (of type wo)  \<close>

axiomatization where
sem_3a: "\<forall>w. \<I>(av w)" and \<comment> \<open>  av is serial: in every situation there is always an open alternative \<close>
sem_4a: "\<forall>w. av w \<sqsubseteq> pv w" and \<comment> \<open>  open alternatives are possible alternatives \<close>
sem_4b: "\<forall>w. pv w w" and \<comment> \<open>  pv is reflexive: every situation is a possible alternative to itself \<close>
sem_5a: "\<forall>X. \<not>(ob X \<bottom>)" and \<comment> \<open>  contradictions cannot be obligatory \<close>
sem_5b: "\<forall>X Y Z. (X \<sqinter> Y) =\<^sub>s (X \<sqinter> Z) \<longrightarrow> (ob X Y \<longleftrightarrow> ob X Z)" and
sem_5c: "\<forall>X Y Z. \<I>(X \<sqinter> Y \<sqinter> Z) \<and> ob X Y \<and> ob X Z \<longrightarrow> ob X (Y \<sqinter> Z)" and
sem_5d: "\<forall>X Y Z. (Y \<sqsubseteq> X \<and> ob X Y \<and> X \<sqsubseteq> Z) \<longrightarrow> ob Z ((Z \<sqinter> (\<sim>X)) \<squnion> Y)" and
sem_5e: "\<forall>X Y Z. Y \<sqsubseteq> X \<and> ob X Z \<and> \<I>(Y \<sqinter> Z) \<longrightarrow> ob Y Z"

lemma True nitpick[satisfy] oops \<comment> \<open> model found: axioms are consistent \<close>

subsubsection \<open>Verifying Semantic Conditions\<close>

lemma sem_5b1: "ob X Y \<longrightarrow> ob X (Y \<sqinter> X)" by (metis (no_types, lifting) sem_5b)
lemma sem_5b2: "(ob X (Y \<sqinter> X) \<longrightarrow> ob X Y)" by (metis (no_types, lifting) sem_5b)
lemma sem_5ab: "ob X Y \<longrightarrow> \<I>(X \<sqinter> Y)" by (metis (full_types) sem_5a sem_5b)
lemma sem_5bd1: "Y \<sqsubseteq> X \<and> ob X Y \<and> X \<sqsubseteq> Z \<longrightarrow> ob Z ((\<sim>X) \<squnion> Y)" using sem_5b sem_5d by smt
lemma sem_5bd2: "ob X Y \<and> X \<sqsubseteq> Z \<longrightarrow> ob Z ((Z \<sqinter> (\<sim>X)) \<squnion> Y)"  using sem_5b sem_5d  by (smt sem_5b1)
lemma sem_5bd3: "ob X Y \<and> X \<sqsubseteq> Z \<longrightarrow> ob Z ((\<sim>X) \<squnion> Y)"  by (smt sem_5bd2 sem_5b)
lemma sem_5bd4: "ob X Y \<and> X \<sqsubseteq> Z \<longrightarrow> ob Z ((\<sim>X) \<squnion> (X \<sqinter>  Y))" using sem_5bd3 by auto
lemma sem_5bcd: "(ob X Z \<and> ob Y Z) \<longrightarrow> ob (X \<squnion> Y) Z" using sem_5b sem_5c sem_5d oops

(* 5e and 5ab justify redefinition of @{cite "O\<langle>\<phi>|\<sigma>\<rangle>"} as (ob A B)*)
lemma "ob A B \<longleftrightarrow>  (\<I>(A \<sqinter> B) \<and> (\<forall>X. X \<sqsubseteq> A \<and> \<I>(X \<sqinter> B) \<longrightarrow> ob X B))" using sem_5e sem_5ab by blast

subsection \<open>(Shallow) Semantic Embedding of DDL\<close>

subsubsection \<open>Basic Propositional Logic\<close>
abbreviation pand::"m\<Rightarrow>m\<Rightarrow>m" (infixr"\<^bold>\<and>" 51) where "\<phi>\<^bold>\<and>\<psi> \<equiv> \<lambda>c w. (\<phi> c w)\<and>(\<psi> c w)"
abbreviation por::"m\<Rightarrow>m\<Rightarrow>m" (infixr"\<^bold>\<or>" 50) where "\<phi>\<^bold>\<or>\<psi> \<equiv> \<lambda>c w. (\<phi> c w)\<or>(\<psi> c w)"
abbreviation pimp::"m\<Rightarrow>m\<Rightarrow>m" (infix"\<^bold>\<rightarrow>" 49) where "\<phi>\<^bold>\<rightarrow>\<psi> \<equiv> \<lambda>c w. (\<phi> c w)\<longrightarrow>(\<psi> c w)"
abbreviation pequ::"m\<Rightarrow>m\<Rightarrow>m" (infix"\<^bold>\<leftrightarrow>" 48) where "\<phi>\<^bold>\<leftrightarrow>\<psi> \<equiv> \<lambda>c w. (\<phi> c w)\<longleftrightarrow>(\<psi> c w)"
abbreviation pnot::"m\<Rightarrow>m" ("\<^bold>\<not>_" [52]53) where "\<^bold>\<not>\<phi> \<equiv> \<lambda>c w. \<not>(\<phi> c w)"

subsubsection \<open>Modal Operators\<close>
abbreviation cjboxa :: "m\<Rightarrow>m" ("\<^bold>\<box>\<^sub>a_" [52]53) where "\<^bold>\<box>\<^sub>a\<phi> \<equiv> \<lambda>c w. \<forall>v. (av w) v \<longrightarrow> (\<phi> c v)"
abbreviation cjdiaa :: "m\<Rightarrow>m" ("\<^bold>\<diamond>\<^sub>a_" [52]53) where "\<^bold>\<diamond>\<^sub>a\<phi> \<equiv> \<lambda>c w. \<exists>v. (av w) v \<and> (\<phi> c v)"
abbreviation cjboxp :: "m\<Rightarrow>m" ("\<^bold>\<box>\<^sub>p_" [52]53) where "\<^bold>\<box>\<^sub>p\<phi> \<equiv> \<lambda>c w. \<forall>v. (pv w) v \<longrightarrow> (\<phi> c v)"
abbreviation cjdiap :: "m\<Rightarrow>m" ("\<^bold>\<diamond>\<^sub>p_" [52]53) where "\<^bold>\<diamond>\<^sub>p\<phi> \<equiv> \<lambda>c w. \<exists>v. (pv w) v \<and> (\<phi> c v)"
abbreviation cjtaut :: "m" ("\<^bold>\<top>") where "\<^bold>\<top> \<equiv> \<lambda>c w. True"
abbreviation cjcontr :: "m" ("\<^bold>\<bottom>") where "\<^bold>\<bottom> \<equiv> \<lambda>c w. False"

subsubsection \<open>Deontic Operators\<close>
abbreviation cjod :: "m\<Rightarrow>m\<Rightarrow>m" ("\<^bold>O\<langle>_|_\<rangle>"54) where "\<^bold>O\<langle>\<phi>|\<sigma>\<rangle> \<equiv> \<lambda>c w. ob (\<sigma> c) (\<phi> c)"
abbreviation cjoa :: "m\<Rightarrow>m" ("\<^bold>O\<^sub>a_" [53]54) where "\<^bold>O\<^sub>a\<phi> \<equiv> \<lambda>c w. (ob (av w)) (\<phi> c) \<and> (\<exists>x. (av w) x \<and> \<not>(\<phi> c x))"
abbreviation cjop :: "m\<Rightarrow>m" ("\<^bold>O\<^sub>i_" [53]54) where "\<^bold>O\<^sub>i\<phi> \<equiv> \<lambda>c w. (ob (pv w)) (\<phi> c) \<and> (\<exists>x. (pv w) x \<and> \<not>(\<phi> c x))"

subsubsection \<open>Logical Validity (Classical)\<close>
abbreviation modvalidctx :: "m\<Rightarrow>c\<Rightarrow>bool" ("\<lfloor>_\<rfloor>\<^sup>M") where "\<lfloor>\<phi>\<rfloor>\<^sup>M \<equiv> \<lambda>c. \<forall>w. \<phi> c w" \<comment> \<open> context-dependent modal validity \<close>
abbreviation modvalid :: "m\<Rightarrow>bool" ("\<lfloor>_\<rfloor>") where "\<lfloor>\<phi>\<rfloor> \<equiv> \<forall>c. \<lfloor>\<phi>\<rfloor>\<^sup>M c" \<comment> \<open> general modal validity (modally valid in each context) \<close>

(*
If we introduce the alternative definition of logical validity below (from Kaplan's LD) instead of the previous one,
we can prove valid most of the following theorems excepting only CJ_7 and CJ_8 and the necessitation rule.

consts World::"c\<Rightarrow>w"  \<comment> \<open> function retrieving the world corresponding to context c (Kaplanian contexts are world-centered) \<close>
abbreviation ldtruectx::"m\<Rightarrow>c\<Rightarrow>bool" ("\<lfloor>_\<rfloor>\<^sub>_") where "\<lfloor>\<phi>\<rfloor>\<^sub>c \<equiv> \<phi> c (World c)" \<comment> \<open>  truth in the given context \<close>
abbreviation ldvalid::"m\<Rightarrow>bool" ("\<lfloor>_\<rfloor>") where "\<lfloor>\<phi>\<rfloor> \<equiv> \<forall>c. \<lfloor>\<phi>\<rfloor>\<^sub>c"    \<comment> \<open>  LD validity (true in every context) \<close>
*)

subsection \<open>Verifying the Embedding\<close>

subsubsection \<open>Avoiding Modal Collapse\<close>
lemma "\<lfloor>P \<^bold>\<rightarrow> \<^bold>O\<^sub>aP\<rfloor>" nitpick oops \<comment> \<open> (actual) deontic modal collapse is countersatisfiable \<close>
lemma "\<lfloor>P \<^bold>\<rightarrow> \<^bold>O\<^sub>iP\<rfloor>" nitpick oops \<comment> \<open> (ideal) deontic modal collapse is countersatisfiable \<close>
lemma "\<lfloor>P \<^bold>\<rightarrow> \<^bold>\<box>\<^sub>aP\<rfloor>" nitpick oops \<comment> \<open> alethic modal collapse is countersatisfiable (implies all other necessity operators) \<close>

subsubsection \<open>Necessitation Rule\<close>
lemma NecDDLa: "\<lfloor>A\<rfloor> \<Longrightarrow> \<lfloor>\<^bold>\<box>\<^sub>aA\<rfloor>"  by simp (* Valid only using classical (not LD) validity*)
lemma NecDDLp:  "\<lfloor>A\<rfloor> \<Longrightarrow> \<lfloor>\<^bold>\<box>\<^sub>pA\<rfloor>" by simp (* Valid only using classical (not LD) validity*)

subsubsection \<open>Lemmas for Semantic Conditions\<close> (* extracted from Benzmüller et al. paper @{cite "BenzmuellerDDL"}*)

abbreviation mboxS5 :: "m\<Rightarrow>m" ("\<^bold>\<box>\<^sup>S\<^sup>5_" [52]53) where "\<^bold>\<box>\<^sup>S\<^sup>5\<phi> \<equiv> \<lambda>c w. \<forall>v. \<phi> c v"
abbreviation mdiaS5 :: "m\<Rightarrow>m" ("\<^bold>\<diamond>\<^sup>S\<^sup>5_" [52]53) where "\<^bold>\<diamond>\<^sup>S\<^sup>5\<phi> \<equiv> \<lambda>c w. \<exists>v. \<phi> c v"

lemma C_2: "\<lfloor>\<^bold>O\<langle>A | B\<rangle> \<^bold>\<rightarrow> \<^bold>\<diamond>\<^sup>S\<^sup>5(B \<^bold>\<and> A)\<rfloor>" by (simp add: sem_5ab)
lemma C_3:  "\<lfloor>((\<^bold>\<diamond>\<^sup>S\<^sup>5(A \<^bold>\<and> B \<^bold>\<and> C)) \<^bold>\<and> \<^bold>O\<langle>B|A\<rangle> \<^bold>\<and> \<^bold>O\<langle>C|A\<rangle>) \<^bold>\<rightarrow> \<^bold>O\<langle>(B \<^bold>\<and> C)| A\<rangle>\<rfloor>" by (simp add: sem_5c)
lemma C_4: "\<lfloor>(\<^bold>\<box>\<^sup>S\<^sup>5(A \<^bold>\<rightarrow> B) \<^bold>\<and> \<^bold>\<diamond>\<^sup>S\<^sup>5(A \<^bold>\<and> C) \<^bold>\<and> \<^bold>O\<langle>C|B\<rangle>) \<^bold>\<rightarrow> \<^bold>O\<langle>C|A\<rangle>\<rfloor>" using sem_5e by blast
lemma C_5: "\<lfloor>\<^bold>\<box>\<^sup>S\<^sup>5(A \<^bold>\<leftrightarrow> B) \<^bold>\<rightarrow> (\<^bold>O\<langle>C|A\<rangle> \<^bold>\<rightarrow> \<^bold>O\<langle>C|B\<rangle>)\<rfloor>" using C_2 sem_5e by blast
lemma C_6: "\<lfloor>\<^bold>\<box>\<^sup>S\<^sup>5(C \<^bold>\<rightarrow> (A \<^bold>\<leftrightarrow> B)) \<^bold>\<rightarrow> (\<^bold>O\<langle>A|C\<rangle> \<^bold>\<leftrightarrow> \<^bold>O\<langle>B|C\<rangle>)\<rfloor>" by (metis sem_5b)
lemma C_7: "\<lfloor>\<^bold>O\<langle>B|A\<rangle> \<^bold>\<rightarrow> \<^bold>\<box>\<^sup>S\<^sup>5\<^bold>O\<langle>B|A\<rangle>\<rfloor>" by blast
lemma C_8: "\<lfloor>\<^bold>O\<langle>B|A\<rangle> \<^bold>\<rightarrow> \<^bold>O\<langle>A \<^bold>\<rightarrow> B| \<^bold>\<top>\<rangle>\<rfloor>" using sem_5bd4 by presburger

subsubsection \<open>Verifying Axiomatic Characterisation\<close>

text\<open>\noindent{The following theorems have been taken from the original Carmo and Jones' paper (\<^cite>\<open>"CJDDL"\<close> p.293ff).}\<close>

lemma CJ_3: "\<lfloor>\<^bold>\<box>\<^sub>pA \<^bold>\<rightarrow> \<^bold>\<box>\<^sub>aA\<rfloor>" by (simp add: sem_4a)
lemma CJ_4: "\<lfloor>\<^bold>\<not>\<^bold>O\<langle>\<^bold>\<bottom>|A\<rangle>\<rfloor>" by (simp add: sem_5a)

lemma CJ_5: "\<lfloor>(\<^bold>O\<langle>B|A\<rangle> \<^bold>\<and> \<^bold>O\<langle>C|A\<rangle>) \<^bold>\<rightarrow> \<^bold>O\<langle>B\<^bold>\<and>C|A\<rangle>\<rfloor>" nitpick oops \<comment> \<open> countermodel found \<close>
lemma CJ_5_minus: "\<lfloor>\<^bold>\<diamond>\<^sup>S\<^sup>5(A \<^bold>\<and> B \<^bold>\<and> C) \<^bold>\<and> (\<^bold>O\<langle>B|A\<rangle> \<^bold>\<and> \<^bold>O\<langle>C|A\<rangle>) \<^bold>\<rightarrow> \<^bold>O\<langle>B\<^bold>\<and>C|A\<rangle>\<rfloor>" by (simp add: sem_5c)

lemma CJ_6: "\<lfloor>\<^bold>O\<langle>B|A\<rangle> \<^bold>\<rightarrow> \<^bold>O\<langle>B|A\<^bold>\<and>B\<rangle>\<rfloor>" by (smt C_2 C_4)
lemma CJ_7: "\<lfloor>A \<^bold>\<leftrightarrow> B\<rfloor> \<longrightarrow> \<lfloor>\<^bold>O\<langle>C|A\<rangle> \<^bold>\<leftrightarrow> \<^bold>O\<langle>C|B\<rangle>\<rfloor>" using sem_5ab sem_5e by blast (* Valid only using classical (not Kaplan's indexical) validity*)
lemma CJ_8: "\<lfloor>C \<^bold>\<rightarrow> (A \<^bold>\<leftrightarrow> B)\<rfloor> \<longrightarrow> \<lfloor>\<^bold>O\<langle>A|C\<rangle> \<^bold>\<leftrightarrow> \<^bold>O\<langle>B|C\<rangle>\<rfloor>" using C_6 by simp (* Valid only using classical (not Kaplan's indexical) validity*)

lemma CJ_9a: "\<lfloor>\<^bold>\<diamond>\<^sub>p\<^bold>O\<langle>B|A\<rangle> \<^bold>\<rightarrow> \<^bold>\<box>\<^sub>p\<^bold>O\<langle>B|A\<rangle>\<rfloor>" by simp
lemma CJ_9p: "\<lfloor>\<^bold>\<diamond>\<^sub>a\<^bold>O\<langle>B|A\<rangle> \<^bold>\<rightarrow> \<^bold>\<box>\<^sub>a\<^bold>O\<langle>B|A\<rangle>\<rfloor>" by simp
lemma CJ_9_var_a: "\<lfloor>\<^bold>O\<langle>B|A\<rangle> \<^bold>\<rightarrow> \<^bold>\<box>\<^sub>a\<^bold>O\<langle>B|A\<rangle>\<rfloor>" by simp
lemma CJ_9_var_b: "\<lfloor>\<^bold>O\<langle>B|A\<rangle> \<^bold>\<rightarrow> \<^bold>\<box>\<^sub>p\<^bold>O\<langle>B|A\<rangle>\<rfloor>" by simp

lemma CJ_11a: "\<lfloor>(\<^bold>O\<^sub>aA \<^bold>\<and> \<^bold>O\<^sub>aB) \<^bold>\<rightarrow> \<^bold>O\<^sub>a(A \<^bold>\<and> B)\<rfloor>" nitpick oops \<comment> \<open>  countermodel found \<close>
lemma CJ_11a_var: "\<lfloor>\<^bold>\<diamond>\<^sub>a(A \<^bold>\<and> B) \<^bold>\<and> (\<^bold>O\<^sub>aA \<^bold>\<and> \<^bold>O\<^sub>aB) \<^bold>\<rightarrow> \<^bold>O\<^sub>a(A \<^bold>\<and> B)\<rfloor>" using sem_5c by auto

lemma CJ_11p: "\<lfloor>(\<^bold>O\<^sub>iA \<^bold>\<and> \<^bold>O\<^sub>iB) \<^bold>\<rightarrow> \<^bold>O\<^sub>i(A \<^bold>\<and> B)\<rfloor>" nitpick oops \<comment> \<open>  countermodel found \<close>
lemma CJ_11p_var: "\<lfloor>\<^bold>\<diamond>\<^sub>p(A \<^bold>\<and> B) \<^bold>\<and> (\<^bold>O\<^sub>iA \<^bold>\<and> \<^bold>O\<^sub>iB) \<^bold>\<rightarrow> \<^bold>O\<^sub>i(A \<^bold>\<and> B)\<rfloor>" using sem_5c by auto

lemma CJ_12a: "\<lfloor>\<^bold>\<box>\<^sub>aA \<^bold>\<rightarrow> (\<^bold>\<not>\<^bold>O\<^sub>aA \<^bold>\<and> \<^bold>\<not>\<^bold>O\<^sub>a(\<^bold>\<not>A))\<rfloor>" using sem_5ab by blast (*using C_2 by blast *)
lemma CJ_12p: "\<lfloor>\<^bold>\<box>\<^sub>pA \<^bold>\<rightarrow> (\<^bold>\<not>\<^bold>O\<^sub>iA \<^bold>\<and> \<^bold>\<not>\<^bold>O\<^sub>i(\<^bold>\<not>A))\<rfloor>" using sem_5ab by blast (*using C_2 by blast*)

lemma CJ_13a: "\<lfloor>\<^bold>\<box>\<^sub>a(A \<^bold>\<leftrightarrow> B) \<^bold>\<rightarrow> (\<^bold>O\<^sub>aA \<^bold>\<leftrightarrow> \<^bold>O\<^sub>aB)\<rfloor>" using sem_5b by metis (*using C_6 by blast *)
lemma CJ_13p: "\<lfloor>\<^bold>\<box>\<^sub>p(A \<^bold>\<leftrightarrow> B) \<^bold>\<rightarrow> (\<^bold>O\<^sub>iA \<^bold>\<leftrightarrow> \<^bold>O\<^sub>iB)\<rfloor>" using sem_5b by metis (*using C_6 by blast *)

lemma CJ_O_O: "\<lfloor>\<^bold>O\<langle>B|A\<rangle> \<^bold>\<rightarrow> \<^bold>O\<langle>A \<^bold>\<rightarrow> B|\<^bold>\<top>\<rangle>\<rfloor>" using sem_5bd4 by presburger

text\<open>\noindent{An ideal obligation which is actually possible both to fulfill and to violate entails an actual obligation (\<^cite>\<open>"CJDDL"\<close> p.319).}\<close>
lemma CJ_Oi_Oa: "\<lfloor>(\<^bold>O\<^sub>iA \<^bold>\<and> \<^bold>\<diamond>\<^sub>aA \<^bold>\<and> \<^bold>\<diamond>\<^sub>a(\<^bold>\<not>A)) \<^bold>\<rightarrow> \<^bold>O\<^sub>aA\<rfloor>" using sem_5e sem_4a by blast

text\<open>\noindent{Bridge relations between conditional obligations and actual/ideal obligations:}\<close>
lemma CJ_14a: "\<lfloor>\<^bold>O\<langle>B|A\<rangle> \<^bold>\<and> \<^bold>\<box>\<^sub>aA \<^bold>\<and> \<^bold>\<diamond>\<^sub>aB \<^bold>\<and> \<^bold>\<diamond>\<^sub>a\<^bold>\<not>B \<^bold>\<rightarrow> \<^bold>O\<^sub>aB\<rfloor>" using sem_5e by blast
lemma CJ_14p: "\<lfloor>\<^bold>O\<langle>B|A\<rangle> \<^bold>\<and> \<^bold>\<box>\<^sub>pA \<^bold>\<and> \<^bold>\<diamond>\<^sub>pB \<^bold>\<and> \<^bold>\<diamond>\<^sub>p\<^bold>\<not>B \<^bold>\<rightarrow> \<^bold>O\<^sub>iB\<rfloor>" using sem_5e by blast

lemma CJ_15a: "\<lfloor>(\<^bold>O\<langle>B|A\<rangle> \<^bold>\<and> \<^bold>\<diamond>\<^sub>a(A \<^bold>\<and> B) \<^bold>\<and> \<^bold>\<diamond>\<^sub>a(A \<^bold>\<and> \<^bold>\<not>B)) \<^bold>\<rightarrow>  \<^bold>O\<^sub>a(A \<^bold>\<rightarrow> B)\<rfloor>" using CJ_O_O sem_5e by fastforce (*using CJ_O_O CJ_14a by blast*)
lemma CJ_15p: "\<lfloor>(\<^bold>O\<langle>B|A\<rangle> \<^bold>\<and> \<^bold>\<diamond>\<^sub>p(A \<^bold>\<and> B) \<^bold>\<and> \<^bold>\<diamond>\<^sub>p(A \<^bold>\<and> \<^bold>\<not>B)) \<^bold>\<rightarrow>  \<^bold>O\<^sub>i(A \<^bold>\<rightarrow> B)\<rfloor>" using CJ_O_O sem_5e by fastforce (*using CJ_O_O CJ_14p by blast*)

(*<*)
end
(*>*)


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

theory WordSetup (* part of non-AFP Word_Lib *)
imports
  Word_Lemmas_64_Internal
  Distinct_Prop
begin

(* Distinct_Prop lemmas that need word lemmas: *)

lemma distinct_prop_enum:
  "\<lbrakk> \<And>x y. \<lbrakk> x \<le> stop; y \<le> stop; x \<noteq> y \<rbrakk> \<Longrightarrow> P x y \<rbrakk>
     \<Longrightarrow> distinct_prop P [0 :: 'a :: len word .e. stop]"
  apply (simp add: upto_enum_def distinct_prop_map del: upt.simps)
  apply (rule distinct_prop_distinct)
   apply simp
  apply (simp add: less_Suc_eq_le del: upt.simps)
  apply (erule_tac x="of_nat x" in meta_allE)
  apply (erule_tac x="of_nat y" in meta_allE)
  apply (frule_tac y=x in unat_le)
  apply (frule_tac y=y in unat_le)
  apply (erule word_unat.Rep_cases)+
  apply (simp add: toEnum_of_nat[OF unat_lt2p]
                   word_le_nat_alt)
  done

lemma distinct_prop_enum_step:
  "\<lbrakk> \<And>x y. \<lbrakk> x \<le> stop div step; y \<le> stop div step; x \<noteq> y \<rbrakk> \<Longrightarrow> P (x * step) (y * step) \<rbrakk>
     \<Longrightarrow> distinct_prop P [0, step .e. stop]"
  apply (simp add: upto_enum_step_def distinct_prop_map)
  apply (rule distinct_prop_enum)
  apply simp
  done

end


(*  Title:       Lift
    Authors:     Jasmin Blanchette, Andrei Popescu, Dmitriy Traytel
    Maintainer:  Dmitriy Traytel <traytel at inf.ethz.ch>
*)

section \<open>Adding New Live Variables\<close>

(*<*)
theory Lift
  imports "HOL-Library.BNF_Axiomatization"
begin
(*>*)

unbundle cardinal_syntax

declare [[bnf_internals]]
bnf_axiomatization (dead 'p, Fset1: 'a1, Fset2: 'a2) F
  [wits: "'a1 \<Rightarrow> 'a2 \<Rightarrow> ('p, 'a1, 'a2) F"]
  for map: Fmap rel: Frel
type_synonym ('p, 'a1, 'a2, 'a3, 'a4) F' = "('p, 'a3, 'a4) F"

abbreviation F'map :: "('a1 \<Rightarrow> 'b1) \<Rightarrow> ('a2 \<Rightarrow> 'b2) \<Rightarrow> ('a3 \<Rightarrow> 'b3) \<Rightarrow> ('a4 \<Rightarrow> 'b4) \<Rightarrow> ('p, 'a1, 'a2, 'a3, 'a4) F' \<Rightarrow> ('p, 'b1, 'b2, 'b3, 'b4) F'" where
  "F'map f1 f2 f3 f4 \<equiv> Fmap f3 f4"

abbreviation F'set1 :: "('p, 'a1, 'a2, 'a3, 'a4) F' \<Rightarrow> 'a1 set" where
  "F'set1 \<equiv> \<lambda>_. {}"

abbreviation F'set2 :: "('p, 'a1, 'a2, 'a3, 'a4) F' \<Rightarrow> 'a2 set" where
  "F'set2 \<equiv> \<lambda>_. {}"

abbreviation F'set3 :: "('p, 'a1, 'a2, 'a3, 'a4) F' \<Rightarrow> 'a3 set" where
  "F'set3 \<equiv> Fset1"

abbreviation F'set4 :: "('p, 'a1, 'a2, 'a3, 'a4) F' \<Rightarrow> 'a4 set" where
  "F'set4 \<equiv> Fset2"

abbreviation F'bd where
  "F'bd \<equiv> bd_F"

theorem F'map_id: "F'map id id id id = id"
  by (rule F.map_id0)

theorem F'map_comp:
  "F'map (f1 o g1) (f2 o g2) (f3 o g3) (f4 o g4) = F'map f1 f2 f3 f4 o F'map g1 g2 g3 g4"
  by (rule F.map_comp0)

theorem F'map_cong:
  "\<lbrakk>\<And>z. z \<in> F'set1 x \<Longrightarrow> f1 z = g1 z; \<And>z. z \<in> F'set2 x \<Longrightarrow> f2 z = g2 z;
   \<And>z. z \<in> F'set3 x \<Longrightarrow> f3 z = g3 z; \<And>z. z \<in> F'set4 x \<Longrightarrow> f4 z = g4 z\<rbrakk>
  \<Longrightarrow> F'map f1 f2 f3 f4 x = F'map g1 g2 g3 g4 x"
  apply (tactic \<open>BNF_Util.rtac @{context} @{thm F.map_cong0} 1 THEN REPEAT_DETERM_N 2 (assume_tac @{context} 1)\<close>)
   apply assumption+
  done

theorem F'set1_natural: "F'set1 o F'map f1 f2 f3 f4 = image f1 o F'set1"
  by (tactic \<open>BNF_Comp_Tactics.empty_natural_tac @{context}\<close>)

theorem F'set2_natural: "F'set2 o F'map f1 f2 f3 f4 = image f2 o F'set2"
  by (tactic \<open>BNF_Comp_Tactics.empty_natural_tac @{context}\<close>)

theorem F'set3_natural: "F'set3 o F'map f1 f2 f3 f4 = image f3 o F'set3"
  by (rule F.set_map0(1))

theorem F'set4_natural: "F'set4 o F'map f1 f2 f3 f4 = image f4 o F'set4"
  by (rule F.set_map0(2))

theorem F'bd_card_order: "card_order bd_F"
  by (rule F.bd_card_order)

theorem F'bd_cinfinite: "cinfinite bd_F"
  by (rule F.bd_cinfinite)

theorem F'set1_bd: "|F'set1 x| \<le>o F'bd"
  by (tactic \<open>BNF_Comp_Tactics.mk_lift_set_bd_tac @{context} @{thm F.bd_Card_order}\<close>)

theorem F'set3_bd: "|F'set3 (x :: ('c, 'a, 'd) F)| \<le>o (F'bd :: 'c bd_type_F rel)"
  by (rule F.set_bd(1))

theorem F'set4_bd: "|F'set4 (x :: ('c, 'a, 'd) F)| \<le>o (F'bd :: 'c bd_type_F rel)"
  by (rule F.set_bd(2))

abbreviation F'in :: "'a1 set \<Rightarrow> 'a2 set \<Rightarrow> 'a3 set \<Rightarrow> 'a4 set \<Rightarrow> (('p, 'a1, 'a2, 'a3, 'a4) F') set" where
  "F'in A1 A2 A3 A4 \<equiv> {x. F'set1 x \<subseteq> A1 \<and> F'set2 x \<subseteq> A2 \<and> F'set3 x \<subseteq> A3 \<and> F'set4 x \<subseteq> A4}"

definition F'rel where
  "F'rel R1 R2 R3 R4 = (BNF_Def.Grp (F'in (Collect (case_prod R1)) (Collect (case_prod R2)) (Collect (case_prod R3)) (Collect (case_prod R4))) (F'map fst fst fst fst))^--1 OO
                      (BNF_Def.Grp (F'in (Collect (case_prod R1)) (Collect (case_prod R2)) (Collect (case_prod R3)) (Collect (case_prod R4))) (F'map snd snd snd snd))"

lemmas F'rel_unfold = trans[OF F'rel_def[unfolded eqTrueI[OF empty_subsetI] simp_thms(22)]
    trans[OF OO_Grp_cong[OF refl] sym[OF F.rel_compp_Grp]]]

bnf F': "('p, 'a1, 'a2, 'a3, 'a4) F'"
  map: F'map
  sets: F'set1 F'set2 F'set3 F'set4
  bd: "F'bd :: 'p bd_type_F rel"
  wits: wit_F
  rel: F'rel
  plugins del: lifting transfer
  apply -
  apply (rule F'map_id)
  apply (rule F'map_comp)
  apply (erule F'map_cong) apply assumption+
  apply (rule F'set1_natural)
  apply (rule F'set2_natural)
  apply (rule F'set3_natural)
  apply (rule F'set4_natural)
  apply (rule F'bd_card_order)
  apply (rule F'bd_cinfinite)
  apply (rule F'set1_bd)
  apply (rule F'set2_bd)
  apply (rule F'set3_bd)
  apply (rule F'set4_bd)
  apply (unfold F'rel_unfold F.rel_compp[symmetric] eq_OO) [1] apply (rule order_refl)
  apply (rule F'rel_def[unfolded OO_Grp_alt mem_Collect_eq])
  apply (erule F.wit emptyE)+
  done

(*<*)
end
(*>*)


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2005         |
            |              Februaru 2006                |
            |                 March 2007  (modified)    |
            |                 August 2007  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory FNF_F_sf_par
imports FNF_F_sf_induct FNF_F_sf_ext
begin

(*  The following simplification rules are deleted in this theory file *)
(*  because they unexpectly rewrite UnionT and InterT.                 *)
(*                  disj_not1: (~ P | Q) = (P --> Q)                   *)

declare disj_not1 [simp del]

(*  The following simplification rules are deleted in this theory file *)
(*       P (if Q then x else y) = ((Q --> P x) & (~ Q --> P y))        *)

declare split_if  [split del]

(*****************************************************************

         1. full sequentialization for Parallel (P1 |[X]| DIV)
         2. full sequentialization for Parallel (P1 |[X]| SKIP)
         3. full sequentialization for Parallel (P1 |[X]| P2)

 *****************************************************************)

(*============================================================*
 |                                                            |
 |                Parallel (P |[X]| DIV)                      |
 |                                                            |
 *============================================================*)

definition
  Pfun_Parallel_DIV :: "'a set => (('p,'a) proc => ('p,'a) proc)"
  where
  Pfun_Parallel_DIV_def :
    "Pfun_Parallel_DIV X == (%P1. P1 |[X]| DIV)"

definition
  SP_step_Parallel_DIV ::
   "'a set => ('a set => ('a => ('p,'a) proc) => ('p,'a) proc => ('a => ('p,'a) proc) => ('p,'a) proc)"
  where
  SP_step_Parallel_DIV_def :
    "SP_step_Parallel_DIV X == (%A1 Pf1 Q1 SPf.
                               (? :(A1-X) -> SPf) [+] DIV)"

definition
  fsfF_Parallel_DIV :: "'a set => ('p,'a) proc => ('p,'a) proc"
  where
  fsfF_Parallel_DIV_def :
    "fsfF_Parallel_DIV X == (%P1.
       (fsfF_induct1 (Pfun_Parallel_DIV X)
                     (SP_step_Parallel_DIV X) P1))"

(*------------------------------------------------------------*
 |                        in fsfF_proc                        |
 *------------------------------------------------------------*)

lemma fsfF_Parallel_DIV_in:
    "P1 : fsfF_proc
     ==> fsfF_Parallel_DIV X P1 : fsfF_proc"
apply (simp add: fsfF_Parallel_DIV_def)
apply (rule fsfF_induct1_in)
apply (simp_all add: SP_step_Parallel_DIV_def
                     fsfF_proc.intros)
done

(*------------------------------------------------------------*
 |             syntactical transformation to fsfF             |
 *------------------------------------------------------------*)

lemma cspF_fsfF_Parallel_DIV_eqF:
    "P1 |[X]| DIV =F fsfF_Parallel_DIV X P1"
apply (simp add: fsfF_Parallel_DIV_def)
apply (rule cspF_rw_right)
apply (rule cspF_fsfF_induct1_eqF[THEN cspF_sym])
apply (simp_all add: Pfun_Parallel_DIV_def
                     SP_step_Parallel_DIV_def)
apply (rule cspF_Dist_nonempty, simp)

apply (rule cspF_rw_left)
apply (rule cspF_SKIP_or_DIV_or_STOP_Parallel_Ext_choice)
apply (simp)
apply (rule cspF_rw_left)
apply (rule cspF_SKIP_DIV)
apply (simp)
apply (rule cspF_decompo | rule cspF_reflex | simp)+
done

(*============================================================*
 |                                                            |
 |                Parallel (P |[X]| SKIP)                     |
 |                                                            |
 *============================================================*)

definition
  Pfun_Parallel_SKIP :: "'a set => (('p,'a) proc => ('p,'a) proc)"
  where
  Pfun_Parallel_SKIP_def :
    "Pfun_Parallel_SKIP X == (%P1. P1 |[X]| SKIP)"

definition
  SP_step_Parallel_SKIP ::
   "'a set => ('a set => ('a => ('p,'a) proc) => ('p,'a) proc =>
     ('a => ('p,'a) proc) => ('p,'a) proc)"
  where
  SP_step_Parallel_SKIP_def :
    "SP_step_Parallel_SKIP X == (%A1 Pf1 Q1 SPf.
                                (? :(A1-X) -> SPf) [+] Q1)"

definition
  fsfF_Parallel_SKIP  :: "'a set => ('p,'a) proc => ('p,'a) proc"
  where
  fsfF_Parallel_SKIP_def :
    "fsfF_Parallel_SKIP X == (%P1.
       (fsfF_induct1 (Pfun_Parallel_SKIP X)
                     (SP_step_Parallel_SKIP X) P1))"

(*------------------------------------------------------------*
 |                        in fsfF_proc                        |
 *------------------------------------------------------------*)

lemma fsfF_Parallel_SKIP_in:
    "P1 : fsfF_proc
     ==> fsfF_Parallel_SKIP X P1 : fsfF_proc"
apply (simp add: fsfF_Parallel_SKIP_def)
apply (rule fsfF_induct1_in)
apply (simp_all add: SP_step_Parallel_SKIP_def
                     fsfF_proc.intros)
done

(*------------------------------------------------------------*
 |             syntactical transformation to fsfF             |
 *------------------------------------------------------------*)

lemma cspF_fsfF_Parallel_SKIP_eqF:
    "P1 |[X]| SKIP =F fsfF_Parallel_SKIP X P1"
apply (simp add: fsfF_Parallel_SKIP_def)
apply (rule cspF_rw_right)
apply (rule cspF_fsfF_induct1_eqF[THEN cspF_sym])
apply (simp_all add: Pfun_Parallel_SKIP_def
                     SP_step_Parallel_SKIP_def)

apply (rule cspF_Dist_nonempty, simp)

apply (rule cspF_rw_left)
apply (rule cspF_SKIP_or_DIV_or_STOP_Parallel_Ext_choice)
apply (simp)
apply (simp)
apply (rule cspF_decompo | rule cspF_reflex | simp)+
done

(*============================================================*
 |                                                            |
 |              Parallel (P |[X]| SKIP or DIV)                |
 |                                                            |
 *============================================================*)

definition
  fsfF_Parallel_SKIP_DIV  :: "'a set => ('p,'a) proc => ('p,'a) proc => ('p,'a) proc"

where
  fsfF_Parallel_SKIP_DIV_def :
    "fsfF_Parallel_SKIP_DIV X P1 P2 ==
        if (P2 = SKIP) then fsfF_Parallel_SKIP X P1
        else if (P2 = DIV) then fsfF_Parallel_DIV X P1
        else (P1 |[X]| P2)"

(*------------------------------------------------------------*
 |                        in fsfF_proc                        |
 *------------------------------------------------------------*)

lemma fsfF_Parallel_SKIP_DIV_in:
    "[| P1 : fsfF_proc ; P2 = SKIP | P2 = DIV |]
     ==> fsfF_Parallel_SKIP_DIV X P1 P2 : fsfF_proc"
apply (simp add: fsfF_Parallel_SKIP_DIV_def)
apply (erule disjE)
apply (simp add: fsfF_Parallel_SKIP_in)
apply (simp add: fsfF_Parallel_DIV_in)
done

(*------------------------------------------------------------*
 |             syntactical transformation to fsfF             |
 *------------------------------------------------------------*)

lemma cspF_fsfF_Parallel_SKIP_DIV_eqF:
    "P1 |[X]| P2 =F fsfF_Parallel_SKIP_DIV X P1 P2"
apply (simp add: fsfF_Parallel_SKIP_DIV_def)
apply (simp split: split_if)
apply (intro conjI impI)
apply (simp add: cspF_fsfF_Parallel_DIV_eqF)
apply (simp add: cspF_fsfF_Parallel_SKIP_eqF)
done

lemmas cspF_fsfF_Parallel_SKIP_DIV_eqF_sym =
       cspF_fsfF_Parallel_SKIP_DIV_eqF[THEN cspF_sym]

(*============================================================*
 |                                                            |
 |            Genaralized Parallel (P |[X]| Q)                |
 |                                                            |
 *============================================================*)

definition
  Pfun_Parallel :: "'a set => (('p,'a) proc => ('p,'a) proc => ('p,'a) proc)"
  where
  Pfun_Parallel_def :
    "Pfun_Parallel X == (%P1 P2. P1 |[X]| P2)"

definition
  SP_step_Parallel ::
   "'a set =>
    ('a set => ('a => ('p,'a) proc) => ('p,'a) proc =>
     'a set => ('a => ('p,'a) proc) => ('p,'a) proc =>
    ('a => ('p,'a) proc) => ('a => ('p,'a) proc) => ('a => ('p,'a) proc) => ('p,'a) proc)"
  where
  SP_step_Parallel_def :
    "SP_step_Parallel X == (%A1 Pf1 Q1 A2 Pf2 Q2 SPf SPf1 SPf2.
    (if (Q1 = STOP & Q2 = STOP) then
     ((? a:((X Int A1 Int A2) Un (A1 - X) Un (A2 - X))
          -> (if (a : X) then (SPf a)
                 else if (a : A1 & a : A2)
                      then ((SPf1 a) |~|seq (SPf2 a))
                 else if (a : A1) then (SPf1 a)
                 else (SPf2 a))) [+] STOP)
    else if (Q1 = STOP) then
    (((? a:((X Int A1 Int A2) Un (A1 - X) Un (A2 - X))
        -> (if (a : X) then (SPf a)
               else if (a : A1 & a : A2)
                    then ((SPf1 a) |~|seq (SPf2 a))
               else if (a : A1) then (SPf1 a)
               else (SPf2 a))) [+] STOP)
     [>seq
     (fsfF_Parallel_SKIP_DIV X (((? :A1 -> Pf1) [+] Q1)) Q2))

    else if (Q2 = STOP) then
    (((? a:((X Int A1 Int A2) Un (A1 - X) Un (A2 - X))
        -> (if (a : X) then (SPf a)
               else if (a : A1 & a : A2)
                    then ((SPf1 a) |~|seq (SPf2 a))
               else if (a : A1) then (SPf1 a)
               else (SPf2 a))) [+] STOP)
     [>seq
     (fsfF_Parallel_SKIP_DIV X (((? :A2 -> Pf2) [+] Q2)) Q1))

   else
    (((? a:((X Int A1 Int A2) Un (A1 - X) Un (A2 - X))
        -> (if (a : X) then (SPf a)
               else if (a : A1 & a : A2)
                    then ((SPf1 a) |~|seq (SPf2 a))
               else if (a : A1) then (SPf1 a)
               else (SPf2 a))) [+] STOP)
     [>seq
     ((fsfF_Parallel_SKIP_DIV X
             (((? :A2 -> Pf2) [+] Q2)) Q1) |~|seq
      (fsfF_Parallel_SKIP_DIV X
             (((? :A1 -> Pf1) [+] Q1)) Q2)))))"

definition
  fsfF_Parallel  :: "('p,'a) proc => 'a set => ('p,'a) proc => ('p,'a) proc"
                          ("(1_ /|[_]|seq _)" [76,0,77] 76)
  where
  fsfF_Parallel_def :
    "P1 |[X]|seq P2 ==
       (fsfF_induct2 (Pfun_Parallel X) (SP_step_Parallel X) P1 P2)"

(*------------------------------------------------------------*
 |                        in fsfF_proc                        |
 *------------------------------------------------------------*)

lemma fsfF_Parallel_in_lm:
  "[| ALL a:A1. Pf1 a : fsfF_proc;
      ALL a:A2. Pf2 a : fsfF_proc;
      ALL a:A1 Int A2. SPf a : fsfF_proc;
      ALL a:A1. SPf1 a : fsfF_proc;
      ALL a:A2. SPf2 a : fsfF_proc;
      Q1 = SKIP | Q1 = DIV | Q1 = STOP; Q2 = SKIP | Q2 = DIV | Q2 = STOP |]
   ==> SP_step_Parallel X A1 Pf1 Q1 A2 Pf2 Q2 SPf SPf1 SPf2 : fsfF_proc"
apply (simp_all add: SP_step_Parallel_def)

(* Q1 = STOP & Q2 = STOP *)
apply (case_tac "Q1 = STOP & Q2 = STOP")
apply (simp)
apply (rule fsfF_proc.intros)
apply (rule ballI)
apply (simp split: split_if)
apply (intro conjI ballI impI)
apply (simp_all)
apply (simp add: fsfF_Int_choice_in)

(* Q1 = STOP *)
apply (subgoal_tac "~ (Q1 = STOP & Q2 = STOP)")
apply (simp (no_asm_simp))
apply (case_tac "Q1 = STOP")
apply (simp)
apply (rule fsfF_Timeout_in)

apply (rule fsfF_proc.intros)
apply (rule ballI)
apply (simp split: split_if)
apply (intro conjI ballI impI)
apply (simp_all)
apply (simp add: fsfF_Int_choice_in)
apply (rule fsfF_Parallel_SKIP_DIV_in)

apply (simp add: fsfF_proc.intros)
apply (simp)

(* Q2 = STOP *)
apply (case_tac "Q2 = STOP")
apply (simp)
apply (rule fsfF_Timeout_in)

apply (rule fsfF_proc.intros)
apply (rule ballI)
apply (simp split: split_if)
apply (intro conjI ballI impI)
apply (simp_all)
apply (simp add: fsfF_Int_choice_in)
apply (rule fsfF_Parallel_SKIP_DIV_in)
apply (simp add: fsfF_proc.intros)
apply (simp)

(* Q1 = SKIP | DIV , Q2 = SKIP | DIV *)
apply (rule fsfF_Timeout_in)

apply (rule fsfF_proc.intros)
apply (rule ballI)
apply (simp split: split_if)
apply (intro conjI ballI impI)
apply (simp_all)
apply (simp add: fsfF_Int_choice_in)

apply (rule fsfF_Int_choice_in)
apply (rule fsfF_Parallel_SKIP_DIV_in)
apply (simp add: fsfF_proc.intros)
apply (simp)

apply (rule fsfF_Parallel_SKIP_DIV_in)
apply (simp add: fsfF_proc.intros)
apply (simp)
done

(*------------------------------------*
 |                 in                 |
 *------------------------------------*)

lemma fsfF_Parallel_in:
    "[| P1 : fsfF_proc ; P2 : fsfF_proc |]
     ==> P1 |[X]|seq P2 : fsfF_proc"
apply (simp add: fsfF_Parallel_def)
apply (rule fsfF_induct2_in)
apply (simp_all)
apply (simp add: fsfF_Parallel_in_lm)
done

(*------------------------------------------------------------*
 |             syntactical transformation to fsfF             |
 *------------------------------------------------------------*)

lemma cspF_fsfF_Parallel_eqF:
    "P1 |[X]| P2 =F P1 |[X]|seq P2"
apply (simp add: fsfF_Parallel_def)
apply (rule cspF_rw_right)
apply (rule cspF_fsfF_induct2_eqF[THEN cspF_sym])
apply (simp_all add: Pfun_Parallel_def)
apply (rule cspF_Dist_nonempty, simp)
apply (rule cspF_Dist_nonempty, simp)

apply (simp add: SP_step_Parallel_def)

(* Q1 = STOP & Q2 = STOP *)
apply (case_tac "Q1 = STOP & Q2 = STOP")
apply (simp)

apply (rule cspF_rw_right)
apply (rule cspF_unit)

apply (rule cspF_rw_left)
apply (rule cspF_decompo)
apply (simp)
apply (rule cspF_unit)
apply (rule cspF_unit)

apply (rule cspF_rw_left)
apply (rule cspF_step)
apply (rule cspF_decompo)
apply (simp)

apply (simp split: split_if)
apply (intro conjI impI)
apply (simp)

apply (rule cspF_rw_left, rule cspF_IF)+

apply (rule cspF_rw_right)
apply (rule cspF_fsfF_Int_choice_eqF[THEN cspF_sym])

 apply (rule cspF_decompo)
 apply (rule cspF_decompo)
 apply (simp)
 apply (simp)
 apply (rule cspF_rw_right)
 apply (rule cspF_unit)
 apply (rule cspF_reflex)

 apply (rule cspF_decompo)
 apply (simp)
 apply (simp)
 apply (rule cspF_rw_right)
 apply (rule cspF_unit)
 apply (rule cspF_reflex)
 apply (rule cspF_reflex)

apply (rule cspF_rw_left, rule cspF_IF)+
apply (rule cspF_rw_right)
 apply (rule cspF_decompo)
 apply (simp)
 apply (rule cspF_reflex)
 apply (rule cspF_unit)
 apply (rule cspF_reflex)

apply (rule cspF_rw_left, rule cspF_IF)+
apply (rule cspF_rw_right)
 apply (rule cspF_decompo)
 apply (simp)
 apply (rule cspF_unit)
 apply (rule cspF_reflex)
 apply (rule cspF_reflex)

apply (rule cspF_rw_left, rule cspF_IF)+
apply (rule cspF_rw_right)
 apply (rule cspF_decompo)
 apply (simp)
 apply (rule cspF_unit)
 apply (rule cspF_reflex)
 apply (rule cspF_reflex)

(* Q1 = STOP *)
apply (simp (no_asm_simp))
apply (case_tac "Q1 = STOP")
apply (simp)

apply (rule cspF_rw_left)
apply (rule cspF_decompo)
apply (simp)
apply (rule cspF_Ext_choice_unit)
apply (rule cspF_reflex)

apply (rule cspF_rw_left)
apply (rule cspF_SKIP_or_DIV_resolve)
apply (fast)

apply (rule cspF_rw_right)
apply (rule cspF_fsfF_Timeout_eqF[THEN cspF_sym])
apply (rule cspF_decompo)
apply (rule cspF_decompo)

apply (rule cspF_rw_right)
apply (rule cspF_unit)
apply (rule cspF_decompo)
apply (simp)

(* IF --> if *)
apply (simp split: split_if)
apply (intro conjI impI)
apply (simp)

apply (rule cspF_rw_left, rule cspF_IF)+
apply (rule cspF_rw_right)
apply (rule cspF_fsfF_Int_choice_eqF[THEN cspF_sym])

 apply (rule cspF_decompo)
 apply (simp)
 apply (rule cspF_rw_right)
 apply (rule cspF_decompo)
 apply (simp)
 apply (rule cspF_unit)
 apply (rule cspF_reflex)
 apply (rule cspF_reflex)

apply (rule cspF_rw_left, rule cspF_IF)+
 apply (rule cspF_reflex)

apply (rule cspF_rw_left, rule cspF_IF)+
apply (rule cspF_rw_right)
 apply (rule cspF_decompo)
 apply (simp)
 apply (rule cspF_unit)
 apply (rule cspF_reflex)
 apply (rule cspF_reflex)

apply (rule cspF_rw_left, rule cspF_IF)+
apply (rule cspF_rw_right)
 apply (rule cspF_decompo)
 apply (simp)
 apply (rule cspF_unit)
 apply (rule cspF_reflex)
 apply (rule cspF_reflex)

apply (rule cspF_reflex)

apply (rule cspF_rw_right)
apply (rule cspF_fsfF_Parallel_SKIP_DIV_eqF[THEN cspF_sym])
apply (rule cspF_rw_right)
 apply (rule cspF_decompo)
 apply (simp)
 apply (rule cspF_unit)
 apply (rule cspF_reflex)
 apply (rule cspF_reflex)

(* Q2 = STOP *)
apply (case_tac "Q2 = STOP")
apply (simp)

apply (rule cspF_rw_left)
apply (rule cspF_decompo)
apply (simp)
apply (rule cspF_reflex)
apply (rule cspF_unit)

apply (rule cspF_rw_left)
apply (rule cspF_SKIP_or_DIV_resolve)
apply (simp)
apply (rule cspF_rw_right)
apply (rule cspF_fsfF_Timeout_eqF[THEN cspF_sym])
apply (rule cspF_decompo)
apply (rule cspF_decompo)

apply (rule cspF_rw_right)
apply (rule cspF_unit)
apply (rule cspF_decompo)
apply (simp)

(* IF --> if *)
apply (simp split: split_if)
apply (intro conjI impI)
apply (simp)

apply (rule cspF_rw_left, rule cspF_IF)+
apply (rule cspF_rw_right)
apply (rule cspF_fsfF_Int_choice_eqF[THEN cspF_sym])

 apply (rule cspF_decompo)
 apply (rule cspF_rw_right)
 apply (rule cspF_decompo)
 apply (simp)
 apply (rule cspF_reflex)
 apply (rule cspF_unit)
 apply (rule cspF_reflex)
 apply (rule cspF_reflex)

apply (rule cspF_rw_left, rule cspF_IF)+
apply (rule cspF_rw_right)
 apply (rule cspF_decompo)
 apply (simp)
 apply (rule cspF_reflex)
 apply (rule cspF_unit)
 apply (rule cspF_reflex)

apply (rule cspF_rw_left, rule cspF_IF)+
 apply (rule cspF_reflex)

apply (rule cspF_rw_left, rule cspF_IF)+
 apply (rule cspF_reflex)

apply (rule cspF_reflex)

apply (rule cspF_rw_right)
apply (rule cspF_fsfF_Parallel_SKIP_DIV_eqF[THEN cspF_sym])
apply (rule cspF_rw_right)
 apply (rule cspF_decompo)
 apply (simp)
 apply (rule cspF_unit)
 apply (rule cspF_reflex)
 apply (rule cspF_commut)

(* DIV or SKIP *)
apply (simp)

apply (rule cspF_rw_left)
apply (rule cspF_SKIP_or_DIV_resolve)
apply (simp)
apply (simp)
apply (rule cspF_rw_right)
apply (rule cspF_fsfF_Timeout_eqF[THEN cspF_sym])
apply (rule cspF_decompo)
apply (rule cspF_decompo)

apply (rule cspF_rw_right)
apply (rule cspF_unit)
apply (rule cspF_decompo)
apply (simp)

(* IF --> if *)
apply (simp split: split_if)
apply (intro conjI impI)
apply (simp)

apply (rule cspF_rw_left, rule cspF_IF)+
apply (rule cspF_rw_right)
apply (rule cspF_fsfF_Int_choice_eqF[THEN cspF_sym])
apply (rule cspF_reflex)

apply (rule cspF_rw_left, rule cspF_IF)+
apply (rule cspF_reflex)

apply (rule cspF_rw_left, rule cspF_IF)+
apply (rule cspF_reflex)

apply (rule cspF_rw_left, rule cspF_IF)+
apply (rule cspF_reflex)

apply (rule cspF_reflex)

apply (rule cspF_rw_right)
apply (rule cspF_fsfF_Int_choice_eqF[THEN cspF_sym])
apply (rule cspF_decompo)

 apply (rule cspF_rw_right)
 apply (rule cspF_fsfF_Parallel_SKIP_DIV_eqF[THEN cspF_sym])
 apply (rule cspF_commut)
 apply (rule cspF_rw_right)
 apply (rule cspF_fsfF_Parallel_SKIP_DIV_eqF[THEN cspF_sym])
 apply (rule cspF_reflex)

(* congruence *)

apply (simp add: SP_step_Parallel_def)

apply (simp split: split_if)
apply (intro conjI impI)

apply (rule cspF_decompo, simp)
apply (rule cspF_decompo, simp)
apply (simp split: split_if)
apply (intro conjI impI)
apply (simp_all)
apply (rule cspF_rw_left, rule cspF_fsfF_Int_choice_eqF[THEN cspF_sym])
apply (rule cspF_rw_right, rule cspF_fsfF_Int_choice_eqF[THEN cspF_sym])
apply (rule cspF_decompo)
apply (simp_all)

apply (rule cspF_rw_left,  rule cspF_fsfF_Timeout_eqF[THEN cspF_sym])
apply (rule cspF_rw_right, rule cspF_fsfF_Timeout_eqF[THEN cspF_sym])
apply (rule cspF_Timeout_cong)
apply (rule cspF_decompo, simp)
apply (rule cspF_decompo, simp)
apply (simp split: split_if)
apply (intro conjI impI)
apply (simp_all)
apply (rule cspF_rw_left, rule cspF_fsfF_Int_choice_eqF[THEN cspF_sym])
apply (rule cspF_rw_right, rule cspF_fsfF_Int_choice_eqF[THEN cspF_sym])
apply (rule cspF_decompo)
apply (simp_all)

apply (rule cspF_rw_left,  rule cspF_fsfF_Timeout_eqF[THEN cspF_sym])
apply (rule cspF_rw_right, rule cspF_fsfF_Timeout_eqF[THEN cspF_sym])
apply (rule cspF_Timeout_cong)
apply (rule cspF_decompo, simp)
apply (rule cspF_decompo, simp)
apply (simp split: split_if)
apply (intro conjI impI)
apply (simp_all)
apply (rule cspF_rw_left, rule cspF_fsfF_Int_choice_eqF[THEN cspF_sym])
apply (rule cspF_rw_right, rule cspF_fsfF_Int_choice_eqF[THEN cspF_sym])
apply (rule cspF_decompo)
apply (simp_all)

apply (rule cspF_rw_left,  rule cspF_fsfF_Timeout_eqF[THEN cspF_sym])
apply (rule cspF_rw_right, rule cspF_fsfF_Timeout_eqF[THEN cspF_sym])
apply (rule cspF_Timeout_cong)
apply (rule cspF_decompo, simp)
apply (rule cspF_decompo, simp)
apply (simp split: split_if)
apply (intro conjI impI)
apply (simp_all)
apply (rule cspF_rw_left, rule cspF_fsfF_Int_choice_eqF[THEN cspF_sym])
apply (rule cspF_rw_right, rule cspF_fsfF_Int_choice_eqF[THEN cspF_sym])
apply (rule cspF_decompo)
apply (simp_all)
done

(****************** to add them again ******************)

declare split_if    [split]
declare disj_not1   [simp]

end