section \<open> Concurrent Programming \<close>

theory utp_concurrency
  imports
    utp_hoare
    utp_rel
    utp_tactics
    utp_theory
begin

text \<open> In this theory we describe the UTP scheme for concurrency, \emph{parallel-by-merge},
  which provides a general parallel operator parametrised by a ``merge predicate'' that explains
  how to merge the after states of the composed predicates. It can thus be applied to many languages
  and concurrency schemes, with this theory providing a number of generic laws. The operator is
  explained in more detail in Chapter 7 of the UTP book~\cite{Hoare&98}. \<close>

subsection \<open> Variable Renamings \<close>

text \<open> In parallel-by-merge constructions, a merge predicate defines the behaviour following execution of
  of parallel processes, $P \parallel Q$, as a relation that merges the output of $P$ and $Q$. In order
  to achieve this we need to separate the variable values output from $P$ and $Q$, and in addition the
  variable values before execution. The following three constructs do these separations. The initial
  state-space before execution is @{typ "'\<alpha>"}, the final state-space after the first parallel process
  is @{typ "'\<beta>\<^sub>0"}, and the final state-space for the second is @{typ "'\<beta>\<^sub>1"}. These three functions
  lift variables on these three state-spaces, respectively.
\<close>

alphabet ('\<alpha>, '\<beta>\<^sub>0, '\<beta>\<^sub>1) mrg =
  mrg_prior :: "'\<alpha>"
  mrg_left  :: "'\<beta>\<^sub>0"
  mrg_right  :: "'\<beta>\<^sub>1"

definition pre_uvar :: "('a \<Longrightarrow> '\<alpha>) \<Rightarrow> ('a \<Longrightarrow> ('\<alpha>, '\<beta>\<^sub>0, '\<beta>\<^sub>1) mrg)" where
[upred_defs]: "pre_uvar x = x ;\<^sub>L mrg_prior"

definition left_uvar :: "('a \<Longrightarrow> '\<beta>\<^sub>0) \<Rightarrow> ('a \<Longrightarrow> ('\<alpha>, '\<beta>\<^sub>0, '\<beta>\<^sub>1) mrg)" where
[upred_defs]: "left_uvar x = x ;\<^sub>L mrg_left"

definition right_uvar :: "('a \<Longrightarrow> '\<beta>\<^sub>1) \<Rightarrow> ('a \<Longrightarrow> ('\<alpha>, '\<beta>\<^sub>0, '\<beta>\<^sub>1) mrg)" where
[upred_defs]: "right_uvar x = x ;\<^sub>L mrg_right"

text \<open> We set up syntax for the three variable classes using a subscript $<$, $0$-$x$, and $1$-$x$,
  respectively. \<close>

syntax
  "_svarpre"   :: "svid \<Rightarrow> svid" ("_\<^sub><" [995] 995)
  "_svarleft"  :: "svid \<Rightarrow> svid" ("0-_" [995] 995)
  "_svarright" :: "svid \<Rightarrow> svid" ("1-_" [995] 995)

translations
  "_svarpre x"   == "CONST pre_uvar x"
  "_svarleft x"  == "CONST left_uvar x"
  "_svarright x" == "CONST right_uvar x"
  "_svarpre \<Sigma>"   <= "CONST pre_uvar 1\<^sub>L"
  "_svarleft \<Sigma>"  <= "CONST left_uvar 1\<^sub>L"
  "_svarright \<Sigma>" <= "CONST right_uvar 1\<^sub>L"

text \<open> We proved behavedness closure properties about the lenses. \<close>

lemma left_uvar [simp]: "vwb_lens x \<Longrightarrow> vwb_lens (left_uvar x)"
  by (simp add: left_uvar_def )

lemma right_uvar [simp]: "vwb_lens x \<Longrightarrow> vwb_lens (right_uvar x)"
  by (simp add: right_uvar_def)

lemma pre_uvar [simp]: "vwb_lens x \<Longrightarrow> vwb_lens (pre_uvar x)"
  by (simp add: pre_uvar_def)

lemma left_uvar_mwb [simp]: "mwb_lens x \<Longrightarrow> mwb_lens (left_uvar x)"
  by (simp add: left_uvar_def )

lemma pre_uvar_mwb [simp]: "mwb_lens x \<Longrightarrow> mwb_lens (pre_uvar x)"
  by (simp add: pre_uvar_def)

text \<open> We prove various independence laws about the variable classes. \<close>

lemma left_uvar_indep_right_uvar [simp]:
  "left_uvar x \<bowtie> right_uvar y"
  by (simp add: left_uvar_def right_uvar_def lens_comp_assoc[THEN sym])

lemma left_uvar_indep_pre_uvar [simp]:
  "left_uvar x \<bowtie> pre_uvar y"
  by (simp add: left_uvar_def pre_uvar_def)

lemma left_uvar_indep_left_uvar [simp]:
  "x \<bowtie> y \<Longrightarrow> left_uvar x \<bowtie> left_uvar y"
  by (simp add: left_uvar_def)

lemma right_uvar_indep_left_uvar [simp]:
  "right_uvar x \<bowtie> left_uvar y"
  by (simp add: lens_indep_sym)

lemma right_uvar_indep_pre_uvar [simp]:
  "right_uvar x \<bowtie> pre_uvar y"
  by (simp add: right_uvar_def pre_uvar_def)

lemma right_uvar_indep_right_uvar [simp]:
  "x \<bowtie> y \<Longrightarrow> right_uvar x \<bowtie> right_uvar y"
  by (simp add: right_uvar_def)

lemma pre_uvar_indep_left_uvar [simp]:
  "pre_uvar x \<bowtie> left_uvar y"
  by (simp add: lens_indep_sym)

lemma pre_uvar_indep_right_uvar [simp]:
  "pre_uvar x \<bowtie> right_uvar y"
  by (simp add: lens_indep_sym)

lemma pre_uvar_indep_pre_uvar [simp]:
  "x \<bowtie> y \<Longrightarrow> pre_uvar x \<bowtie> pre_uvar y"
  by (simp add: pre_uvar_def)

subsection \<open> Merge Predicates \<close>

text \<open> A merge predicate is a relation whose input has three parts: the prior variables, the output
  variables of the left predicate, and the output of the right predicate. \<close>

type_synonym '\<alpha> merge = "(('\<alpha>, '\<alpha>, '\<alpha>) mrg, '\<alpha>) urel"

text \<open> skip is the merge predicate which ignores the output of both parallel predicates \<close>

definition skip\<^sub>m :: "'\<alpha> merge" where
[upred_defs]: "skip\<^sub>m = ($\<^bold>v\<acute> =\<^sub>u $\<^bold>v\<^sub><)"

text \<open> swap is a predicate that the swaps the left and right indices; it is used to specify
        commutativity of the parallel operator \<close>

definition swap\<^sub>m :: "(('\<alpha>, '\<beta>, '\<beta>) mrg) hrel" where
[upred_defs]: "swap\<^sub>m = (0-\<^bold>v,1-\<^bold>v) := (&1-\<^bold>v,&0-\<^bold>v)"

text \<open> A symmetric merge is one for which swapping the order of the merged concurrent predicates
  has no effect. We represent this by the following healthiness condition that states that
  @{term "swap\<^sub>m"} is a left-unit. \<close>

abbreviation SymMerge :: "'\<alpha> merge \<Rightarrow> '\<alpha> merge" where
"SymMerge(M) \<equiv> (swap\<^sub>m ;; M)"

subsection \<open> Separating Simulations \<close>

text \<open> U0 and U1 are relations modify the variables of the input state-space such that they become
  indexed with $0$ and $1$, respectively. \<close>

definition U0 :: "('\<beta>\<^sub>0, ('\<alpha>, '\<beta>\<^sub>0, '\<beta>\<^sub>1) mrg) urel" where
[upred_defs]: "U0 = ($0-\<^bold>v\<acute> =\<^sub>u $\<^bold>v)"

definition U1 :: "('\<beta>\<^sub>1, ('\<alpha>, '\<beta>\<^sub>0, '\<beta>\<^sub>1) mrg) urel" where
[upred_defs]: "U1 = ($1-\<^bold>v\<acute> =\<^sub>u $\<^bold>v)"

lemma U0_swap: "(U0 ;; swap\<^sub>m) = U1"
  by (rel_auto)

lemma U1_swap: "(U1 ;; swap\<^sub>m) = U0"
  by (rel_auto)

text \<open> As shown below, separating simulations can also be expressed using the following two
  alphabet extrusions \<close>

definition U0\<alpha> where [upred_defs]: "U0\<alpha> = (1\<^sub>L \<times>\<^sub>L mrg_left)"

definition U1\<alpha> where [upred_defs]: "U1\<alpha> = (1\<^sub>L \<times>\<^sub>L mrg_right)"

text \<open> We then create the following intuitive syntax for separating simulations. \<close>

abbreviation U0_alpha_lift ("\<lceil>_\<rceil>\<^sub>0") where "\<lceil>P\<rceil>\<^sub>0 \<equiv> P \<oplus>\<^sub>p U0\<alpha>"

abbreviation U1_alpha_lift ("\<lceil>_\<rceil>\<^sub>1") where "\<lceil>P\<rceil>\<^sub>1 \<equiv> P \<oplus>\<^sub>p U1\<alpha>"

text \<open> @{term "\<lceil>P\<rceil>\<^sub>0"} is predicate $P$ where all variables are indexed by $0$, and
  @{term "\<lceil>P\<rceil>\<^sub>1"} is where all variables are indexed by $1$. We can thus equivalently express separating
  simulations using alphabet extrusion. \<close>

lemma U0_as_alpha: "(P ;; U0) = \<lceil>P\<rceil>\<^sub>0"
  by (rel_auto)

lemma U1_as_alpha: "(P ;; U1) = \<lceil>P\<rceil>\<^sub>1"
  by (rel_auto)

lemma U0\<alpha>_vwb_lens [simp]: "vwb_lens U0\<alpha>"
  by (simp add: U0\<alpha>_def id_vwb_lens prod_vwb_lens)

lemma U1\<alpha>_vwb_lens [simp]: "vwb_lens U1\<alpha>"
  by (simp add: U1\<alpha>_def id_vwb_lens prod_vwb_lens)

lemma U0\<alpha>_indep_right_uvar [simp]: "vwb_lens x \<Longrightarrow> U0\<alpha> \<bowtie> out_var (right_uvar x)"
  by (force intro: plus_pres_lens_indep fst_snd_lens_indep lens_indep_left_comp
            simp add: U0\<alpha>_def right_uvar_def out_var_def prod_as_plus lens_comp_assoc[THEN sym])

lemma U1\<alpha>_indep_left_uvar [simp]: "vwb_lens x \<Longrightarrow> U1\<alpha> \<bowtie> out_var (left_uvar x)"
  by (force intro: plus_pres_lens_indep fst_snd_lens_indep lens_indep_left_comp
            simp add: U1\<alpha>_def left_uvar_def out_var_def prod_as_plus lens_comp_assoc[THEN sym])

lemma U0_alpha_lift_bool_subst [usubst]:
  "\<sigma>($0-x\<acute> \<mapsto>\<^sub>s true) \<dagger> \<lceil>P\<rceil>\<^sub>0 = \<sigma> \<dagger> \<lceil>P\<lbrakk>true/$x\<acute>\<rbrakk>\<rceil>\<^sub>0"
  "\<sigma>($0-x\<acute> \<mapsto>\<^sub>s false) \<dagger> \<lceil>P\<rceil>\<^sub>0 = \<sigma> \<dagger> \<lceil>P\<lbrakk>false/$x\<acute>\<rbrakk>\<rceil>\<^sub>0"
  by (pred_auto+)

lemma U1_alpha_lift_bool_subst [usubst]:
  "\<sigma>($1-x\<acute> \<mapsto>\<^sub>s true) \<dagger> \<lceil>P\<rceil>\<^sub>1 = \<sigma> \<dagger> \<lceil>P\<lbrakk>true/$x\<acute>\<rbrakk>\<rceil>\<^sub>1"
  "\<sigma>($1-x\<acute> \<mapsto>\<^sub>s false) \<dagger> \<lceil>P\<rceil>\<^sub>1 = \<sigma> \<dagger> \<lceil>P\<lbrakk>false/$x\<acute>\<rbrakk>\<rceil>\<^sub>1"
  by (pred_auto+)

lemma U0_alpha_out_var [alpha]: "\<lceil>$x\<acute>\<rceil>\<^sub>0 = $0-x\<acute>"
  by (rel_auto)

lemma U1_alpha_out_var [alpha]: "\<lceil>$x\<acute>\<rceil>\<^sub>1 = $1-x\<acute>"
  by (rel_auto)

lemma U0_skip [alpha]: "\<lceil>II\<rceil>\<^sub>0 = ($0-\<^bold>v\<acute> =\<^sub>u $\<^bold>v)"
  by (rel_auto)

lemma U0_seqr [alpha]: "\<lceil>P ;; Q\<rceil>\<^sub>0 = P ;; \<lceil>Q\<rceil>\<^sub>0"
  by (rel_auto)

lemma U1_seqr [alpha]: "\<lceil>P ;; Q\<rceil>\<^sub>1 = P ;; \<lceil>Q\<rceil>\<^sub>1"
  by (rel_auto)

lemma U0\<alpha>_comp_in_var [alpha]: "(in_var x) ;\<^sub>L U0\<alpha> = in_var x"
  by (simp add: U0\<alpha>_def alpha_in_var in_var_prod_lens pre_uvar_def)

lemma U0\<alpha>_comp_out_var [alpha]: "(out_var x) ;\<^sub>L U0\<alpha> = out_var (left_uvar x)"
  by (simp add: U0\<alpha>_def alpha_out_var id_wb_lens left_uvar_def out_var_prod_lens)

lemma U1\<alpha>_comp_in_var [alpha]: "(in_var x) ;\<^sub>L U1\<alpha> = in_var x"
  by (simp add: U1\<alpha>_def alpha_in_var in_var_prod_lens pre_uvar_def)

lemma U1\<alpha>_comp_out_var [alpha]: "(out_var x) ;\<^sub>L U1\<alpha> = out_var (right_uvar x)"
  by (simp add: U1\<alpha>_def alpha_out_var id_wb_lens right_uvar_def out_var_prod_lens)

subsection \<open> Associative Merges \<close>

text \<open> Associativity of a merge means that if we construct a three way merge from a two way merge
  and then rotate the three inputs of the merge to the left, then we get exactly the same three
  way merge back.

  We first construct the operator that constructs the three way merge by effectively wiring up
  the two way merge in an appropriate way.
\<close>

definition ThreeWayMerge :: "'\<alpha> merge \<Rightarrow> (('\<alpha>, '\<alpha>, ('\<alpha>, '\<alpha>, '\<alpha>) mrg) mrg, '\<alpha>) urel" ("\<^bold>M3'(_')") where
[upred_defs]: "ThreeWayMerge M = (($0-\<^bold>v\<acute> =\<^sub>u $0-\<^bold>v \<and> $1-\<^bold>v\<acute> =\<^sub>u $1-0-\<^bold>v \<and> $\<^bold>v\<^sub><\<acute> =\<^sub>u $\<^bold>v\<^sub><) ;; M ;; U0 \<and> $1-\<^bold>v\<acute> =\<^sub>u $1-1-\<^bold>v \<and> $\<^bold>v\<^sub><\<acute> =\<^sub>u $\<^bold>v\<^sub><) ;; M"

text \<open> The next definition rotates the inputs to a three way merge to the left one place. \<close>

abbreviation rotate\<^sub>m where "rotate\<^sub>m \<equiv> (0-\<^bold>v,1-0-\<^bold>v,1-1-\<^bold>v) := (&1-0-\<^bold>v,&1-1-\<^bold>v,&0-\<^bold>v)"

text \<open> Finally, a merge is associative if rotating the inputs does not effect the output. \<close>

definition AssocMerge :: "'\<alpha> merge \<Rightarrow> bool" where
[upred_defs]: "AssocMerge M = (rotate\<^sub>m ;; \<^bold>M3(M) = \<^bold>M3(M))"

subsection \<open> Parallel Operators \<close>

text \<open> We implement the following useful abbreviation for separating of two parallel processes and
  copying of the before variables, all to act as input to the merge predicate. \<close>

abbreviation par_sep (infixr "\<parallel>\<^sub>s" 85) where
"P \<parallel>\<^sub>s Q \<equiv> (P ;; U0) \<and> (Q ;; U1) \<and> $\<^bold>v\<^sub><\<acute> =\<^sub>u $\<^bold>v"

text \<open> The following implementation of parallel by merge is less general than the book version, in
  that it does not properly partition the alphabet into two disjoint segments. We could actually
  achieve this specifying lenses into the larger alphabet, but this would complicate the definition
  of programs. May reconsider later. \<close>

definition
  par_by_merge :: "('\<alpha>, '\<beta>) urel \<Rightarrow> (('\<alpha>, '\<beta>, '\<gamma>) mrg, '\<delta>) urel \<Rightarrow> ('\<alpha>, '\<gamma>) urel \<Rightarrow> ('\<alpha>, '\<delta>) urel"
  ("_ \<parallel>\<^bsub>_\<^esub> _" [85,0,86] 85)
where [upred_defs]: "P \<parallel>\<^bsub>M\<^esub> Q = (P \<parallel>\<^sub>s Q ;; M)"

lemma par_by_merge_alt_def: "P \<parallel>\<^bsub>M\<^esub> Q = (\<lceil>P\<rceil>\<^sub>0 \<and> \<lceil>Q\<rceil>\<^sub>1 \<and> $\<^bold>v\<^sub><\<acute> =\<^sub>u $\<^bold>v) ;; M"
  by (simp add: par_by_merge_def U0_as_alpha U1_as_alpha)

lemma shEx_pbm_left: "((\<^bold>\<exists> x \<bullet> P x) \<parallel>\<^bsub>M\<^esub> Q) = (\<^bold>\<exists> x \<bullet> (P x \<parallel>\<^bsub>M\<^esub> Q))"
  by (rel_auto)

lemma shEx_pbm_right: "(P \<parallel>\<^bsub>M\<^esub> (\<^bold>\<exists> x \<bullet> Q x)) = (\<^bold>\<exists> x \<bullet> (P \<parallel>\<^bsub>M\<^esub> Q x))"
  by (rel_auto)

subsection \<open> Unrestriction Laws \<close>

lemma unrest_in_par_by_merge [unrest]:
  "\<lbrakk> $x \<sharp> P; $x\<^sub>< \<sharp> M; $x \<sharp> Q \<rbrakk> \<Longrightarrow> $x \<sharp> P \<parallel>\<^bsub>M\<^esub> Q"
  by (rel_auto, fastforce+)

lemma unrest_out_par_by_merge [unrest]:
  "\<lbrakk> $x\<acute> \<sharp> M \<rbrakk> \<Longrightarrow> $x\<acute> \<sharp> P \<parallel>\<^bsub>M\<^esub> Q"
  by (rel_auto)

subsection \<open> Substitution laws \<close>

text \<open> Substitution is a little tricky because when we push the expression through the composition
  operator the alphabet of the expression must also change. Consequently for now we only support
  literal substitution, though this could be generalised with suitable alphabet coercsions. We
  need quite a number of variants to support this which are below. \<close>

lemma U0_seq_subst: "(P ;; U0)\<lbrakk>\<guillemotleft>v\<guillemotright>/$0-x\<acute>\<rbrakk> = (P\<lbrakk>\<guillemotleft>v\<guillemotright>/$x\<acute>\<rbrakk> ;; U0)"
  by (rel_auto)

lemma U1_seq_subst: "(P ;; U1)\<lbrakk>\<guillemotleft>v\<guillemotright>/$1-x\<acute>\<rbrakk> = (P\<lbrakk>\<guillemotleft>v\<guillemotright>/$x\<acute>\<rbrakk> ;; U1)"
  by (rel_auto)

lemma lit_pbm_subst [usubst]:
  fixes x :: "(_ \<Longrightarrow> '\<alpha>)"
  shows
    "\<And> P Q M \<sigma>. \<sigma>($x \<mapsto>\<^sub>s \<guillemotleft>v\<guillemotright>) \<dagger> (P \<parallel>\<^bsub>M\<^esub> Q) = \<sigma> \<dagger> ((P\<lbrakk>\<guillemotleft>v\<guillemotright>/$x\<rbrakk>) \<parallel>\<^bsub>M\<lbrakk>\<guillemotleft>v\<guillemotright>/$x\<^sub><\<rbrakk>\<^esub> (Q\<lbrakk>\<guillemotleft>v\<guillemotright>/$x\<rbrakk>))"
    "\<And> P Q M \<sigma>. \<sigma>($x\<acute> \<mapsto>\<^sub>s \<guillemotleft>v\<guillemotright>) \<dagger> (P \<parallel>\<^bsub>M\<^esub> Q) = \<sigma> \<dagger> (P \<parallel>\<^bsub>M\<lbrakk>\<guillemotleft>v\<guillemotright>/$x\<acute>\<rbrakk>\<^esub> Q)"
  by (rel_auto)+

lemma bool_pbm_subst [usubst]:
  fixes x :: "(_ \<Longrightarrow> '\<alpha>)"
  shows
    "\<And> P Q M \<sigma>. \<sigma>($x \<mapsto>\<^sub>s false) \<dagger> (P \<parallel>\<^bsub>M\<^esub> Q) = \<sigma> \<dagger> ((P\<lbrakk>false/$x\<rbrakk>) \<parallel>\<^bsub>M\<lbrakk>false/$x\<^sub><\<rbrakk>\<^esub> (Q\<lbrakk>false/$x\<rbrakk>))"
    "\<And> P Q M \<sigma>. \<sigma>($x \<mapsto>\<^sub>s true) \<dagger> (P \<parallel>\<^bsub>M\<^esub> Q) = \<sigma> \<dagger> ((P\<lbrakk>true/$x\<rbrakk>) \<parallel>\<^bsub>M\<lbrakk>true/$x\<^sub><\<rbrakk>\<^esub> (Q\<lbrakk>true/$x\<rbrakk>))"
    "\<And> P Q M \<sigma>. \<sigma>($x\<acute> \<mapsto>\<^sub>s false) \<dagger> (P \<parallel>\<^bsub>M\<^esub> Q) = \<sigma> \<dagger> (P \<parallel>\<^bsub>M\<lbrakk>false/$x\<acute>\<rbrakk>\<^esub> Q)"
    "\<And> P Q M \<sigma>. \<sigma>($x\<acute> \<mapsto>\<^sub>s true) \<dagger> (P \<parallel>\<^bsub>M\<^esub> Q) = \<sigma> \<dagger> (P \<parallel>\<^bsub>M\<lbrakk>true/$x\<acute>\<rbrakk>\<^esub> Q)"
  by (rel_auto)+

lemma zero_one_pbm_subst [usubst]:
  fixes x :: "(_ \<Longrightarrow> '\<alpha>)"
  shows
    "\<And> P Q M \<sigma>. \<sigma>($x \<mapsto>\<^sub>s 0) \<dagger> (P \<parallel>\<^bsub>M\<^esub> Q) = \<sigma> \<dagger> ((P\<lbrakk>0/$x\<rbrakk>) \<parallel>\<^bsub>M\<lbrakk>0/$x\<^sub><\<rbrakk>\<^esub> (Q\<lbrakk>0/$x\<rbrakk>))"
    "\<And> P Q M \<sigma>. \<sigma>($x \<mapsto>\<^sub>s 1) \<dagger> (P \<parallel>\<^bsub>M\<^esub> Q) = \<sigma> \<dagger> ((P\<lbrakk>1/$x\<rbrakk>) \<parallel>\<^bsub>M\<lbrakk>1/$x\<^sub><\<rbrakk>\<^esub> (Q\<lbrakk>1/$x\<rbrakk>))"
    "\<And> P Q M \<sigma>. \<sigma>($x\<acute> \<mapsto>\<^sub>s 0) \<dagger> (P \<parallel>\<^bsub>M\<^esub> Q) = \<sigma> \<dagger> (P \<parallel>\<^bsub>M\<lbrakk>0/$x\<acute>\<rbrakk>\<^esub> Q)"
    "\<And> P Q M \<sigma>. \<sigma>($x\<acute> \<mapsto>\<^sub>s 1) \<dagger> (P \<parallel>\<^bsub>M\<^esub> Q) = \<sigma> \<dagger> (P \<parallel>\<^bsub>M\<lbrakk>1/$x\<acute>\<rbrakk>\<^esub> Q)"
  by (rel_auto)+

lemma numeral_pbm_subst [usubst]:
  fixes x :: "(_ \<Longrightarrow> '\<alpha>)"
  shows
    "\<And> P Q M \<sigma>. \<sigma>($x \<mapsto>\<^sub>s numeral n) \<dagger> (P \<parallel>\<^bsub>M\<^esub> Q) = \<sigma> \<dagger> ((P\<lbrakk>numeral n/$x\<rbrakk>) \<parallel>\<^bsub>M\<lbrakk>numeral n/$x\<^sub><\<rbrakk>\<^esub> (Q\<lbrakk>numeral n/$x\<rbrakk>))"
    "\<And> P Q M \<sigma>. \<sigma>($x\<acute> \<mapsto>\<^sub>s numeral n) \<dagger> (P \<parallel>\<^bsub>M\<^esub> Q) = \<sigma> \<dagger> (P \<parallel>\<^bsub>M\<lbrakk>numeral n/$x\<acute>\<rbrakk>\<^esub> Q)"
  by (rel_auto)+

subsection \<open> Parallel-by-merge laws \<close>

lemma par_by_merge_false [simp]:
  "P \<parallel>\<^bsub>false\<^esub> Q = false"
  by (rel_auto)

lemma par_by_merge_left_false [simp]:
  "false \<parallel>\<^bsub>M\<^esub> Q = false"
  by (rel_auto)

lemma par_by_merge_right_false [simp]:
  "P \<parallel>\<^bsub>M\<^esub> false = false"
  by (rel_auto)

lemma par_by_merge_seq_add: "(P \<parallel>\<^bsub>M\<^esub> Q) ;; R = (P \<parallel>\<^bsub>M ;; R\<^esub> Q)"
  by (simp add: par_by_merge_def seqr_assoc)

text \<open> A skip parallel-by-merge yields a skip whenever the parallel predicates are both feasible. \<close>

lemma par_by_merge_skip:
  assumes "P ;; true = true" "Q ;; true = true"
  shows "P \<parallel>\<^bsub>skip\<^sub>m\<^esub> Q = II"
  using assms by (rel_auto)

lemma skip_merge_swap: "swap\<^sub>m ;; skip\<^sub>m = skip\<^sub>m"
  by (rel_auto)

lemma par_sep_swap: "P \<parallel>\<^sub>s Q ;; swap\<^sub>m = Q \<parallel>\<^sub>s P"
  by (rel_auto)

text \<open> Parallel-by-merge commutes when the merge predicate is unchanged by swap \<close>

lemma par_by_merge_commute_swap:
  shows "P \<parallel>\<^bsub>M\<^esub> Q = Q \<parallel>\<^bsub>swap\<^sub>m ;; M\<^esub> P"
proof -
  have "Q \<parallel>\<^bsub>swap\<^sub>m ;; M\<^esub> P = ((((Q ;; U0) \<and> (P ;; U1) \<and> $\<^bold>v\<^sub><\<acute> =\<^sub>u $\<^bold>v) ;; swap\<^sub>m) ;; M)"
    by (simp add: par_by_merge_def seqr_assoc)
  also have "... = (((Q ;; U0 ;; swap\<^sub>m) \<and> (P ;; U1 ;; swap\<^sub>m) \<and> $\<^bold>v\<^sub><\<acute> =\<^sub>u $\<^bold>v) ;; M)"
    by (rel_auto)
  also have "... = (((Q ;; U1) \<and> (P ;; U0) \<and> $\<^bold>v\<^sub><\<acute> =\<^sub>u $\<^bold>v) ;; M)"
    by (simp add: U0_swap U1_swap)
  also have "... = P \<parallel>\<^bsub>M\<^esub> Q"
    by (simp add: par_by_merge_def utp_pred_laws.inf.left_commute)
  finally show ?thesis ..
qed

theorem par_by_merge_commute:
  assumes "M is SymMerge"
  shows "P \<parallel>\<^bsub>M\<^esub> Q = Q \<parallel>\<^bsub>M\<^esub> P"
  by (metis Healthy_if assms par_by_merge_commute_swap)

lemma par_by_merge_mono_1:
  assumes "P\<^sub>1 \<sqsubseteq> P\<^sub>2"
  shows "P\<^sub>1 \<parallel>\<^bsub>M\<^esub> Q \<sqsubseteq> P\<^sub>2 \<parallel>\<^bsub>M\<^esub> Q"
  using assms by (rel_auto)

lemma par_by_merge_mono_2:
  assumes "Q\<^sub>1 \<sqsubseteq> Q\<^sub>2"
  shows "(P \<parallel>\<^bsub>M\<^esub> Q\<^sub>1) \<sqsubseteq> (P \<parallel>\<^bsub>M\<^esub> Q\<^sub>2)"
  using assms by (rel_blast)

lemma par_by_merge_mono:
  assumes "P\<^sub>1 \<sqsubseteq> P\<^sub>2" "Q\<^sub>1 \<sqsubseteq> Q\<^sub>2"
  shows "P\<^sub>1 \<parallel>\<^bsub>M\<^esub> Q\<^sub>1 \<sqsubseteq> P\<^sub>2 \<parallel>\<^bsub>M\<^esub> Q\<^sub>2"
  by (meson assms dual_order.trans par_by_merge_mono_1 par_by_merge_mono_2)

theorem par_by_merge_assoc:
  assumes "M is SymMerge" "AssocMerge M"
  shows "(P \<parallel>\<^bsub>M\<^esub> Q) \<parallel>\<^bsub>M\<^esub> R = P \<parallel>\<^bsub>M\<^esub> (Q \<parallel>\<^bsub>M\<^esub> R)"
proof -
  have "(P \<parallel>\<^bsub>M\<^esub> Q) \<parallel>\<^bsub>M\<^esub> R = ((P ;; U0) \<and> (Q ;; U0 ;; U1) \<and> (R ;; U1 ;; U1) \<and> $\<^bold>v\<^sub><\<acute> =\<^sub>u $\<^bold>v) ;; \<^bold>M3(M)"
    by (rel_blast)
  also have "... = ((P ;; U0) \<and> (Q ;; U0 ;; U1) \<and> (R ;; U1 ;; U1) \<and> $\<^bold>v\<^sub><\<acute> =\<^sub>u $\<^bold>v) ;; rotate\<^sub>m ;; \<^bold>M3(M)"
    using AssocMerge_def assms(2) by force
  also have "... = ((Q ;; U0) \<and> (R ;; U0 ;; U1) \<and> (P ;; U1 ;; U1) \<and> $\<^bold>v\<^sub><\<acute> =\<^sub>u $\<^bold>v) ;; \<^bold>M3(M)"
    by (rel_blast)
  also have "... = (Q \<parallel>\<^bsub>M\<^esub> R) \<parallel>\<^bsub>M\<^esub> P"
    by (rel_blast)
  also have "... = P \<parallel>\<^bsub>M\<^esub> (Q \<parallel>\<^bsub>M\<^esub> R)"
    by (simp add: assms(1) par_by_merge_commute)
  finally show ?thesis .
qed

theorem par_by_merge_choice_left:
  "(P \<sqinter> Q) \<parallel>\<^bsub>M\<^esub> R = (P \<parallel>\<^bsub>M\<^esub> R) \<sqinter> (Q \<parallel>\<^bsub>M\<^esub> R)"
  by (rel_auto)

theorem par_by_merge_choice_right:
  "P \<parallel>\<^bsub>M\<^esub> (Q \<sqinter> R) = (P \<parallel>\<^bsub>M\<^esub> Q) \<sqinter> (P \<parallel>\<^bsub>M\<^esub> R)"
  by (rel_auto)

theorem par_by_merge_or_left:
  "(P \<or> Q) \<parallel>\<^bsub>M\<^esub> R = (P \<parallel>\<^bsub>M\<^esub> R \<or> Q \<parallel>\<^bsub>M\<^esub> R)"
  by (rel_auto)

theorem par_by_merge_or_right:
  "P \<parallel>\<^bsub>M\<^esub> (Q \<or> R) = (P \<parallel>\<^bsub>M\<^esub> Q \<or> P \<parallel>\<^bsub>M\<^esub> R)"
  by (rel_auto)

theorem par_by_merge_USUP_mem_left:
  "(\<Sqinter> i\<in>I \<bullet> P(i)) \<parallel>\<^bsub>M\<^esub> Q = (\<Sqinter> i\<in>I \<bullet> P(i) \<parallel>\<^bsub>M\<^esub> Q)"
  by (rel_auto)

theorem par_by_merge_USUP_ind_left:
  "(\<Sqinter> i \<bullet> P(i)) \<parallel>\<^bsub>M\<^esub> Q = (\<Sqinter> i \<bullet> P(i) \<parallel>\<^bsub>M\<^esub> Q)"
  by (rel_auto)

theorem par_by_merge_USUP_mem_right:
  "P \<parallel>\<^bsub>M\<^esub> (\<Sqinter> i\<in>I \<bullet> Q(i)) = (\<Sqinter> i\<in>I \<bullet> P \<parallel>\<^bsub>M\<^esub> Q(i))"
  by (rel_auto)

theorem par_by_merge_USUP_ind_right:
  "P \<parallel>\<^bsub>M\<^esub> (\<Sqinter> i \<bullet> Q(i)) = (\<Sqinter> i \<bullet> P \<parallel>\<^bsub>M\<^esub> Q(i))"
  by (rel_auto)

subsection \<open> Example: Simple State-Space Division \<close>

text \<open> The following merge predicate divides the state space using a pair of independent lenses. \<close>

definition StateMerge :: "('a \<Longrightarrow> '\<alpha>) \<Rightarrow> ('b \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<alpha> merge" ("M[_|_]\<^sub>\<sigma>") where
[upred_defs]: "M[a|b]\<^sub>\<sigma> = ($\<^bold>v\<acute> =\<^sub>u ($\<^bold>v\<^sub>< \<oplus> $0-\<^bold>v on &a) \<oplus> $1-\<^bold>v on &b)"

lemma swap_StateMerge: "a \<bowtie> b \<Longrightarrow> (swap\<^sub>m ;; M[a|b]\<^sub>\<sigma>) = M[b|a]\<^sub>\<sigma>"
  by (rel_auto, simp_all add: lens_indep_comm)

abbreviation StateParallel :: "'\<alpha> hrel \<Rightarrow> ('a \<Longrightarrow> '\<alpha>) \<Rightarrow> ('b \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<alpha> hrel \<Rightarrow> '\<alpha> hrel" ("_ |_|_|\<^sub>\<sigma> _" [85,0,0,86] 86)
where "P |a|b|\<^sub>\<sigma> Q \<equiv> P \<parallel>\<^bsub>M[a|b]\<^sub>\<sigma>\<^esub> Q"

lemma StateParallel_commute: "a \<bowtie> b \<Longrightarrow> P |a|b|\<^sub>\<sigma> Q = Q |b|a|\<^sub>\<sigma> P"
  by (metis par_by_merge_commute_swap swap_StateMerge)

lemma StateParallel_form:
  "P |a|b|\<^sub>\<sigma> Q = (\<^bold>\<exists> (st\<^sub>0, st\<^sub>1) \<bullet> P\<lbrakk>\<guillemotleft>st\<^sub>0\<guillemotright>/$\<^bold>v\<acute>\<rbrakk> \<and> Q\<lbrakk>\<guillemotleft>st\<^sub>1\<guillemotright>/$\<^bold>v\<acute>\<rbrakk> \<and> $\<^bold>v\<acute> =\<^sub>u ($\<^bold>v \<oplus> \<guillemotleft>st\<^sub>0\<guillemotright> on &a) \<oplus> \<guillemotleft>st\<^sub>1\<guillemotright> on &b)"
  by (rel_auto)

lemma StateParallel_form':
  assumes "vwb_lens a" "vwb_lens b" "a \<bowtie> b"
  shows "P |a|b|\<^sub>\<sigma> Q = {&a,&b}:[(P \<restriction>\<^sub>v {$\<^bold>v,$a\<acute>}) \<and> (Q \<restriction>\<^sub>v {$\<^bold>v,$b\<acute>})]"
  using assms
  apply (simp add: StateParallel_form, rel_auto)
     apply (metis vwb_lens_wb wb_lens_axioms_def wb_lens_def)
    apply (metis vwb_lens_wb wb_lens.get_put)
   apply (simp add: lens_indep_comm)
  apply (metis (no_types, hide_lams) lens_indep_comm vwb_lens_wb wb_lens_def weak_lens.put_get)
  done

text \<open> We can frame all the variables that the parallel operator refers to \<close>

lemma StateParallel_frame:
  assumes "vwb_lens a" "vwb_lens b" "a \<bowtie> b"
  shows "{&a,&b}:[P |a|b|\<^sub>\<sigma> Q] = P |a|b|\<^sub>\<sigma> Q"
  using assms
  apply (simp add: StateParallel_form, rel_auto)
  using lens_indep_comm apply fastforce+
  done

text \<open> Parallel Hoare logic rule. This employs something similar to separating conjunction in
  the postcondition, but we explicitly require that the two conjuncts only refer to variables
  on the left and right of the parallel composition explicitly. \<close>

theorem StateParallel_hoare [hoare]:
  assumes "\<lbrace>c\<rbrace>P\<lbrace>d\<^sub>1\<rbrace>\<^sub>u" "\<lbrace>c\<rbrace>Q\<lbrace>d\<^sub>2\<rbrace>\<^sub>u" "a \<bowtie> b" "a \<natural> d\<^sub>1" "b \<natural> d\<^sub>2"
  shows "\<lbrace>c\<rbrace>P |a|b|\<^sub>\<sigma> Q\<lbrace>d\<^sub>1 \<and> d\<^sub>2\<rbrace>\<^sub>u"
proof -
  \<comment> \<open> Parallelise the specification \<close>
  from assms(4,5)
  have 1:"(\<lceil>c\<rceil>\<^sub>< \<Rightarrow> \<lceil>d\<^sub>1 \<and> d\<^sub>2\<rceil>\<^sub>>) \<sqsubseteq> (\<lceil>c\<rceil>\<^sub>< \<Rightarrow> \<lceil>d\<^sub>1\<rceil>\<^sub>>) |a|b|\<^sub>\<sigma> (\<lceil>c\<rceil>\<^sub>< \<Rightarrow> \<lceil>d\<^sub>2\<rceil>\<^sub>>)" (is "?lhs \<sqsubseteq> ?rhs")
    by (simp add: StateParallel_form, rel_auto, metis assms(3) lens_indep_comm)
  \<comment> \<open> Prove Hoare rule by monotonicity of parallelism \<close>
  have 2:"?rhs \<sqsubseteq> P |a|b|\<^sub>\<sigma> Q"
  proof (rule par_by_merge_mono)
    show "(\<lceil>c\<rceil>\<^sub>< \<Rightarrow> \<lceil>d\<^sub>1\<rceil>\<^sub>>) \<sqsubseteq> P"
      using assms(1) hoare_r_def by auto
    show "(\<lceil>c\<rceil>\<^sub>< \<Rightarrow> \<lceil>d\<^sub>2\<rceil>\<^sub>>) \<sqsubseteq> Q"
      using assms(2) hoare_r_def by auto
  qed
  show ?thesis
    unfolding hoare_r_def using 1 2 order_trans by auto
qed

text \<open> Specialised version of the above law where an invariant expression referring to variables
  outside the frame is preserved. \<close>

theorem StateParallel_frame_hoare [hoare]:
  assumes "vwb_lens a" "vwb_lens b" "a \<bowtie> b" "a \<natural> d\<^sub>1" "b \<natural> d\<^sub>2" "a \<sharp> c\<^sub>1" "b \<sharp> c\<^sub>1" "\<lbrace>c\<^sub>1 \<and> c\<^sub>2\<rbrace>P\<lbrace>d\<^sub>1\<rbrace>\<^sub>u" "\<lbrace>c\<^sub>1 \<and> c\<^sub>2\<rbrace>Q\<lbrace>d\<^sub>2\<rbrace>\<^sub>u"
  shows "\<lbrace>c\<^sub>1 \<and> c\<^sub>2\<rbrace>P |a|b|\<^sub>\<sigma> Q\<lbrace>c\<^sub>1 \<and> d\<^sub>1 \<and> d\<^sub>2\<rbrace>\<^sub>u"
proof -
  have "\<lbrace>c\<^sub>1 \<and> c\<^sub>2\<rbrace>{&a,&b}:[P |a|b|\<^sub>\<sigma> Q]\<lbrace>c\<^sub>1 \<and> d\<^sub>1 \<and> d\<^sub>2\<rbrace>\<^sub>u"
    by (auto intro!: frame_hoare_r' StateParallel_hoare simp add: assms unrest plus_vwb_lens)
  thus ?thesis
    by (simp add: StateParallel_frame assms)
qed

end


(*
    This file is a part of IsarMathLib -
    a library of formalized mathematics written for Isabelle/Isar.

    Copyright (C) 2019-2022 Slawomir Kolodynski

    This program is free software; Redistribution and use in source and binary forms,
    with or without modification, are permitted provided that the following conditions are met:

   1. Redistributions of source code must retain the above copyright notice,
   this list of conditions and the following disclaimer.
   2. 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.
   3. The name of the author may not be used to endorse or promote products
   derived from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``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 AUTHOR 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. *)

section \<open> Topology and neighborhoods \<close>

theory Topology_ZF_4a imports Topology_ZF_4
begin

text\<open> This theory considers the relations between topology and systems of neighborhood filters. \<close>

subsection\<open> Neighborhood systems \<close>

text\<open> The standard way of defining a topological space is by specifying a collection
of sets that we consider "open" (see the \<open>Topology_ZF\<close> theory).
An alternative of this approach is to define a collection of neighborhoods for each point of
the space.  \<close>

text\<open> We define a neighborhood system as a function that takes each point $x\in X$ and assigns it
  a collection of subsets of $X$ which is called the neighborhoods of $x$.
  The neighborhoods of a point $x$ form a filter that satisfies an additional
  axiom that for every neighborhood $N$ of $x$ we can find another one $U$ such that $N$
  is a neighborhood of every point of $U$. \<close>

definition
  IsNeighSystem ("_ {is a neighborhood system on} _" 90)
  where "\<M> {is a neighborhood system on} X \<equiv> (\<M> : X\<rightarrow>Pow(Pow(X))) \<and>
  (\<forall>x\<in>X. (\<M>`(x) {is a filter on} X) \<and> (\<forall>N\<in>\<M>`(x). x\<in>N \<and> (\<exists>U\<in>\<M>`(x).\<forall>y\<in>U.(N\<in>\<M>`(y)) ) ))"

text\<open> A neighborhood system on $X$ consists of collections of subsets of $X$. \<close>

lemma neighborhood_subset:
  assumes "\<M> {is a neighborhood system on} X" and "x\<in>X" and "N\<in>\<M>`(x)"
  shows "N\<subseteq>X" and "x\<in>N"
proof -
  from \<open>\<M> {is a neighborhood system on} X\<close> have "\<M> : X\<rightarrow>Pow(Pow(X))"
    unfolding IsNeighSystem_def by simp
  with \<open>x\<in>X\<close> have "\<M>`(x) \<in> Pow(Pow(X))" using apply_funtype by blast
  with \<open>N\<in>\<M>`(x)\<close> show "N\<subseteq>X" by blast
  from assms show "x\<in>N" using IsNeighSystem_def by simp
qed

text\<open>Some sources (like Wikipedia) use a bit different definition of neighborhood systems
where the $U$ is required to be contained in $N$. The next lemma shows that this stronger version
can be recovered from our definition. \<close>

lemma neigh_def_stronger:
  assumes "\<M> {is a neighborhood system on} X" and "x\<in>X" and "N\<in>\<M>`(x)"
  shows "\<exists>U\<in>\<M>`(x).U\<subseteq>N \<and> (\<forall>y\<in>U.(N\<in>\<M>`(y)))"
proof -
  from assms obtain W where "W\<in>\<M>`(x)" and areNeigh:"\<forall>y\<in>W.(N\<in>\<M>`(y))"
    using  IsNeighSystem_def by blast
  let ?U = "N\<inter>W"
  from assms \<open>W\<in>\<M>`(x)\<close> have "?U \<in> \<M>`(x)"
    unfolding IsNeighSystem_def IsFilter_def by blast
  moreover have "?U\<subseteq>N" by blast
  moreover from areNeigh have "\<forall>y\<in>?U.(N\<in>\<M>`(y))" by auto
  ultimately show ?thesis by auto
qed

subsection\<open> From a neighborhood system to topology \<close>

text\<open>Given a neighborhood system $\{\mathcal{M}_x\}_{x\in X}$ we can define a topology on $X$.
Namely, we consider a subset of $X$ open if $U \in \mathcal{M}_x$ for every element $x$ of $U$. \<close>

text\<open>The collection of sets defined as above is indeed a topology. \<close>

theorem topology_from_neighs:
  assumes "\<M> {is a neighborhood system on} X"
  defines Tdef: "T \<equiv> {U\<in>Pow(X). \<forall>x\<in>U. U \<in> \<M>`(x)}"
  shows "T {is a topology}" and "\<Union>T = X"
proof -
  { fix \<UU> assume "\<UU> \<in> Pow(T)"
    have "\<Union>\<UU> \<in> T"
    proof -
      from \<open>\<UU> \<in> Pow(T)\<close> Tdef have "\<Union>\<UU> \<in> Pow(X)" by blast
      moreover
      { fix x assume "x \<in> \<Union>\<UU>"
        then obtain U where "U\<in>\<UU>" and "x\<in>U" by blast
        with assms \<open>\<UU> \<in> Pow(T)\<close>
        have "U \<in> \<M>`(x)" and "U \<subseteq> \<Union>\<UU>" and  "\<M>`(x) {is a filter on} X"
          unfolding IsNeighSystem_def by auto
        with \<open>\<Union>\<UU> \<in> Pow(X)\<close> have "\<Union>\<UU> \<in> \<M>`(x)" unfolding IsFilter_def
          by simp
      }
      ultimately show "\<Union>\<UU> \<in> T" using Tdef by blast
    qed
  }
  moreover
  { fix U V assume "U\<in>T" and "V\<in>T"
    have "U\<inter>V \<in> T"
    proof -
      from Tdef \<open>U\<in>T\<close>  \<open>U\<in>T\<close> have "U\<inter>V \<in> Pow(X)" by auto
      moreover
      { fix x assume "x \<in> U\<inter>V"
        with assms \<open>U\<in>T\<close> \<open>V\<in>T\<close> Tdef have "U \<in> \<M>`(x)" "V \<in> \<M>`(x)" and  "\<M>`(x) {is a filter on} X"
          unfolding IsNeighSystem_def by auto
        then have "U\<inter>V \<in> \<M>`(x)" unfolding IsFilter_def by simp
      }
      ultimately show "U\<inter>V \<in>T" using Tdef by simp
    qed
  }
  ultimately show "T {is a topology}" unfolding IsATopology_def by blast
  from assms show "\<Union>T = X" unfolding IsNeighSystem_def IsFilter_def by blast
qed

text\<open> Some sources (like Wikipedia) define the open sets generated by a neighborhood system
  "as those sets containing a neighborhood of each of their points". The next lemma shows that
  this definition is equivalent to the one we are using.\<close>

lemma topology_from_neighs1:
  assumes "\<M> {is a neighborhood system on} X"
  shows "{U\<in>Pow(X). \<forall>x\<in>U. U \<in> \<M>`(x)} = {U\<in>Pow(X). \<forall>x\<in>U. \<exists>V \<in> \<M>`(x). V\<subseteq>U}"
proof
  let ?T = "{U\<in>Pow(X). \<forall>x\<in>U. U \<in> \<M>`(x)}"
  let ?S = "{U\<in>Pow(X). \<forall>x\<in>U. \<exists>V \<in> \<M>`(x). V\<subseteq>U}"
  show "?S\<subseteq>?T"
  proof -
    { fix U assume "U\<in>?S"
      then have "U\<in>Pow(X)" by simp
      moreover
      from assms \<open>U\<in>?S\<close> \<open>U\<in>Pow(X)\<close> have "\<forall>x\<in>U. U \<in> \<M>`(x)"
        unfolding IsNeighSystem_def IsFilter_def by blast
      ultimately have "U\<in>?T" by auto
    } thus ?thesis by auto
  qed
  show "?T\<subseteq>?S" by auto
qed

subsection\<open>From a topology to a neighborhood system\<close>

text\<open> Once we have a topology $T$ we can define a natural neighborhood system on $X=\bigcup T$.
  In this section we define such neighborhood system and prove its basic properties.  \<close>

text\<open>For a topology $T$ we define a neighborhood system of $T$ as a function that takes an $x\in X=\bigcup T$
and assigns it the collection of supersets of open sets containing $x$.
We call that the "neighborhood system of $T$"\<close>

definition
  NeighSystem ("{neighborhood system of} _" 91)
  where "{neighborhood system of} T \<equiv> { \<langle>x,{N\<in>Pow(\<Union>T).\<exists>U\<in>T.(x\<in>U \<and> U\<subseteq>N)}\<rangle>. x \<in> \<Union>T }"

text\<open>The way we defined the neighborhood system of $T$ means that
  it is a function on $\bigcup T$. \<close>

lemma neigh_fun: shows "({neighborhood system of} T): \<Union>T \<rightarrow> Pow(Pow(\<Union>T))"
proof -
  let ?X = "\<Union>T"
  have "\<forall>x\<in>?X. {N\<in>Pow(?X).\<exists>U\<in>T.(x\<in>U \<and> U\<subseteq>N)} \<in> Pow(Pow(?X))"
    by blast
  then show ?thesis unfolding NeighSystem_def using ZF_fun_from_total
    by simp
qed

text\<open>The value of the neighborhood system of $T$ at $x\in \bigcup T$
  is the collection of supersets of open sets containing $x$.\<close>

lemma neigh_val: assumes "x\<in>\<Union>T"
  shows "({neighborhood system of} T)`(x) = {N\<in>Pow(\<Union>T).\<exists>U\<in>T.(x\<in>U \<and> U\<subseteq>N)}"
  using assms ZF_fun_from_tot_val1 unfolding NeighSystem_def
  by simp

text\<open> The next lemma shows that open sets are members of (what we will prove later to be)
   the natural neighborhood system on $X=\bigcup T$. \<close>

lemma open_are_neighs:
  assumes "U\<in>T" "x\<in>U"
  shows "x \<in> \<Union>T" and "U \<in> {V\<in>Pow(\<Union>T).\<exists>U\<in>T.(x\<in>U \<and> U\<subseteq>V)}"
  using assms by auto

text\<open> Another fact we will need is that for every $x\in X=\bigcup T$ the neighborhoods of $x$
  form a filter \<close>

lemma neighs_is_filter:
  assumes "T {is a topology}" and "x \<in> \<Union>T"
  defines Mdef: "\<M> \<equiv> {neighborhood system of} T"
  shows "\<M>`(x) {is a filter on} (\<Union>T)"
proof -
  let ?X = "\<Union>T"
  let ?\<FF> = "{V\<in>Pow(?X).\<exists>U\<in>T.(x\<in>U \<and> U\<subseteq>V)}"
  have "0\<notin>?\<FF>" by blast
  moreover have "?X\<in>?\<FF>"
  proof -
    from assms \<open>x\<in>?X\<close> have "?X \<in> Pow(?X)" "?X\<in>T" and "x\<in>?X \<and> ?X\<subseteq>?X" using carr_open
      by auto
    hence "\<exists>U\<in>T.(x\<in>U \<and> U\<subseteq>?X)" by auto
    thus ?thesis by auto
  qed
  moreover have "\<forall>A\<in>?\<FF>. \<forall>B\<in>?\<FF>. A\<inter>B \<in> ?\<FF>"
  proof -
    { fix A B assume "A\<in>?\<FF>" "B\<in>?\<FF>"
      then obtain U\<^sub>A U\<^sub>B where "U\<^sub>A\<in>T" "x\<in>U\<^sub>A" "U\<^sub>A\<subseteq>A" "U\<^sub>B\<in>T" "x\<in>U\<^sub>B" "U\<^sub>B\<subseteq>B"
        by auto
      with \<open>T {is a topology}\<close> \<open>A\<in>?\<FF>\<close> \<open>B\<in>?\<FF>\<close> have "A\<inter>B \<in> Pow(?X)" and
        "U\<^sub>A\<inter>U\<^sub>B \<in> T" "x \<in> U\<^sub>A\<inter>U\<^sub>B" "U\<^sub>A\<inter>U\<^sub>B \<subseteq> A\<inter>B" using IsATopology_def
        by auto
      hence "A\<inter>B \<in> ?\<FF>" by blast
    } thus ?thesis by blast
  qed
  moreover have "\<forall>B\<in>?\<FF>. \<forall>C\<in>Pow(?X). B\<subseteq>C \<longrightarrow> C\<in>?\<FF>"
  proof -
    { fix B C assume "B\<in>?\<FF>" "C \<in> Pow(?X)" "B\<subseteq>C"
      then obtain U where "U\<in>T" and "x\<in>U" "U\<subseteq>B" by blast
      with \<open>C \<in> Pow(?X)\<close> \<open>B\<subseteq>C\<close> have "C\<in>?\<FF>" by blast
    } thus ?thesis by auto
  qed
  ultimately have "?\<FF> {is a filter on} ?X" unfolding IsFilter_def by blast
  with Mdef \<open>x\<in>?X\<close> show "\<M>`(x) {is a filter on} ?X" using ZF_fun_from_tot_val1 NeighSystem_def
    by simp
qed

text\<open>The next theorem states that the the natural
  neighborhood system on $X=\bigcup T$ indeed is a neighborhood system. \<close>

theorem neigh_from_topology:
  assumes "T {is a topology}"
  shows "({neighborhood system of} T) {is a neighborhood system on} (\<Union>T)"
proof -
  let ?X = "\<Union>T"
  let ?\<M> = "{neighborhood system of} T"
  have "?\<M> : ?X\<rightarrow>Pow(Pow(?X))"
  proof -
    { fix x assume "x\<in>?X"
      hence "{V\<in>Pow(\<Union>T).\<exists>U\<in>T.(x\<in>U \<and> U\<subseteq>V)} \<in> Pow(Pow(?X))" by auto
    } hence "\<forall>x\<in>?X. {V\<in>Pow(\<Union>T).\<exists>U\<in>T.(x\<in>U \<and> U\<subseteq>V)} \<in> Pow(Pow(?X))" by auto
    then show ?thesis using ZF_fun_from_total NeighSystem_def by simp
  qed
  moreover from assms have "\<forall>x\<in>?X. (?\<M>`(x) {is a filter on} ?X)"
    using neighs_is_filter NeighSystem_def by auto
  moreover have "\<forall>x\<in>?X. \<forall>N\<in>?\<M>`(x). x\<in>N \<and> (\<exists>U\<in>?\<M>`(x).\<forall>y\<in>U.(N\<in>?\<M>`(y)))"
  proof -
    { fix x N assume "x\<in>?X" "N \<in> ?\<M>`(x)"
      let ?\<FF> = "{V\<in>Pow(?X).\<exists>U\<in>T.(x\<in>U \<and> U\<subseteq>V)}"
      from \<open>x\<in>?X\<close> have "?\<M>`(x) = ?\<FF>" using ZF_fun_from_tot_val1 NeighSystem_def
        by simp
      with \<open>N \<in> ?\<M>`(x)\<close> have "N\<in>?\<FF>" by simp
      hence "x\<in>N" by blast
      from \<open>N\<in>?\<FF>\<close> obtain U where "U\<in>T" "x\<in>U" and "U\<subseteq>N" by blast
      with \<open>N\<in>?\<FF>\<close> \<open>?\<M>`(x) = ?\<FF>\<close> have "U \<in> ?\<M>`(x)" by auto
      moreover from assms \<open>U\<in>T\<close>  \<open>U\<subseteq>N\<close> \<open>N\<in>?\<FF>\<close> have  "\<forall>y\<in>U.(N \<in> ?\<M>`(y))"
        using ZF_fun_from_tot_val1 open_are_neighs neighs_is_filter
                NeighSystem_def IsFilter_def by auto
      ultimately have "\<exists>U\<in>?\<M>`(x).\<forall>y\<in>U.(N\<in>?\<M>`(y))" by blast
      with \<open>x\<in>N\<close> have "x\<in>N \<and> (\<exists>U\<in>?\<M>`(x).\<forall>y\<in>U.(N\<in>?\<M>`(y)))" by simp
    } thus ?thesis by auto
  qed
  ultimately show ?thesis unfolding IsNeighSystem_def by blast
qed

text\<open>Any neighborhood of an element of the closure of a subset intersects the subset.\<close>

lemma neigh_inter_nempty:
  assumes "T {is a topology}" "A\<subseteq>\<Union>T" "x \<in> Closure(A,T)" and
  "N \<in> ({neighborhood system of} T)`(x)"
  shows "N\<inter>A \<noteq> 0"
proof -
  let ?X = "\<Union>T"
  from assms(1) have cntx: "topology0(T)"
    unfolding topology0_def by simp
  with assms(2,3) have "x\<in>?X"
    using topology0.Top_3_L11(1) by blast
  with assms(4) obtain U where "U\<in>T" "x\<in>U" and "U\<subseteq>N"
    using neigh_val by auto
  from assms(2,3) cntx \<open>U\<in>T\<close> \<open>x\<in>U\<close> have "A\<inter>U \<noteq> 0"
    using topology0.cl_inter_neigh by simp
  with \<open>U\<subseteq>N\<close> show "N\<inter>A \<noteq> 0" by blast
qed

subsection\<open> Neighborhood systems are 1:1 with topologies \<close>

text\<open>We can create a topology from a neighborhood system and neighborhood system from topology.
  The question is then if we start from a neighborhood system, create a topology from it
  then create the topology's natural neighborhood system, do we get back the neighborhood system
  we started from? Similarly, if we start from a topology, create its neighborhood system and then
  create a topology from that, do we get the original topology? This section provides
  the affirmative answer (for now only for the first question).
  This means that there is a one-to-one correspondence between the set of topologies on a set
  and the set of abstract neighborhood systems on the set. \<close>

text\<open>Each abstract neighborhood of $x$ contains an open neighborhood of $x$.\<close>

lemma open_nei_in_nei:
  assumes "\<M> {is a neighborhood system on} X" "x\<in>X" "N\<in>\<M>`(x)"
  defines Tdef: "T \<equiv> {U\<in>Pow(X). \<forall>x\<in>U. U \<in> \<M>`(x)}"
  shows "N\<in>Pow(X)" and "\<exists>U\<in>T. (x\<in>U \<and> U\<subseteq>N)"
proof -
  from assms(1) have "\<M>:X\<rightarrow>Pow(Pow(X))" unfolding IsNeighSystem_def
    by simp
  with assms(2,3) show "N\<in>Pow(X)"using apply_funtype by blast
  let ?U = "{y\<in>X. N \<in> \<M>`(y)}"
  have "?U\<in>T"
  proof -
    have "?U \<in> Pow(X)" by auto
    moreover have "\<forall>y\<in>?U. ?U\<in>\<M>`(y)"
    proof -
      { fix y assume "y\<in>?U"
        then have "y\<in>X" and "N\<in>\<M>`(y)" by auto
        with assms(1) obtain V where "V\<in>\<M>`(y)" and "\<forall>z\<in>V. N \<in> \<M>`(z)"
          unfolding IsNeighSystem_def by blast
        with assms(1) \<open>y\<in>X\<close> \<open>V\<in>\<M>`(y)\<close> have "V\<subseteq>?U"
          using neighborhood_subset(1) by blast
        with assms(1) \<open>y\<in>X\<close> \<open>V\<in>\<M>`(y)\<close> \<open>?U \<in> Pow(X)\<close> have "?U\<in>\<M>`(y)"
          unfolding IsNeighSystem_def using is_filter_def_split(5) by blast
      } thus ?thesis by simp
    qed
    ultimately have "?U \<in> {U\<in>Pow(X). \<forall>x\<in>U. U \<in> \<M>`(x)}" by simp
    with assms(4) show "?U\<in>T" by simp
  qed
  moreover from assms(1,2) \<open>N\<in>\<M>`(x)\<close> have "x\<in>?U \<and> ?U \<subseteq> N"
    using neighborhood_subset(2) by auto
  ultimately show "\<exists>U\<in>T. (x\<in>U \<and> U\<subseteq>N)" by (rule witness_exists)
qed

text\<open>In the the next theorem we show that if we start from
  a neighborhood system, create a topology from it, then create it's natural neighborhood system,
  we get back the original neighborhood system.\<close>

theorem nei_top_nei_round_trip:
  assumes "\<M> {is a neighborhood system on} X"
  defines Tdef: "T \<equiv> {U\<in>Pow(X). \<forall>x\<in>U. U \<in> \<M>`(x)}"
  shows "({neighborhood system of} T) = \<M>"
proof -
  let ?M = "{neighborhood system of} T"
  from assms have "T {is a topology}" and "\<Union>T = X" using topology_from_neighs
    by auto
  then have "?M {is a neighborhood system on} X" using neigh_from_topology
    by blast
  with assms(1) have "?M:X\<rightarrow>Pow(Pow(X))" and "\<M>:X\<rightarrow>Pow(Pow(X))"
    unfolding IsNeighSystem_def by auto
  moreover
  { fix x assume "x\<in>X"
    from \<open>\<Union>T = X\<close> \<open>x\<in>X\<close> have I: "?M`(x) = {V\<in>Pow(X).\<exists>U\<in>T.(x\<in>U \<and> U\<subseteq>V)}"
      unfolding NeighSystem_def using ZF_fun_from_tot_val1 by simp
    have "?M`(x) = \<M>`(x)"
    proof
      { fix V assume "V\<in>?M`(x)"
        with I obtain U where "U\<in>T" "x\<in>U" "U\<subseteq>V" by auto
        from assms(2) \<open>U\<in>T\<close> \<open>x\<in>U\<close> have "U \<in> \<M>`(x)" by simp
        from assms(1) \<open>x\<in>X\<close> have "\<M>`(x) {is a filter on} X"
          unfolding IsNeighSystem_def by simp
        with \<open>U \<in> \<M>`(x)\<close> \<open>V\<in>?M`(x)\<close> I \<open>U\<subseteq>V\<close>  have "V \<in> \<M>`(x)"
          unfolding IsFilter_def by simp
      } thus "?M`(x) \<subseteq> \<M>`(x)" by auto
      { fix N assume "N\<in>\<M>`(x)"
        with assms \<open>x\<in>X\<close> \<open>\<Union>T = X\<close> I have "N\<in>?M`(x)" using open_nei_in_nei
          by auto
      } thus "\<M>`(x) \<subseteq> ?M`(x)" by auto
    qed
  } hence "\<forall>x\<in>X. ?M`(x) = \<M>`(x)" by simp
  ultimately show ?thesis by (rule func_eq)
qed

subsection\<open>Set neighborhoods\<close>

text\<open>Some sources (like Metamath) take a somewhat different approach where instead of defining
  the collection of neighborhoods of a point $x\in X$ they define a collection of neighborhoods
  of a subset of $X$ (where $X$ is the carrier of a topology  $T$ (i.e. $X=\bigcup T$).
  In this approach a neighborhood system is a function whose domain is the powerset of $X$, i.e.
  the set of subsets of $X$. The two approaches are equivalent in a sense as
  having a neighborhood system we can create a set neighborhood system and vice versa. \<close>

text\<open>We define a set neighborhood system as a function that takes a subset $A$ of the carrier of the
  topology and assigns it the collection of supersets of all open sets that contain $A$. \<close>

definition
  SetNeighSystem ( "{set neighborhood system of} _" 91)
  where "{set neighborhood system of} T
          \<equiv> {\<langle>A,{N\<in>Pow(\<Union>T). \<exists>U\<in>T. (A\<subseteq>U \<and> U\<subseteq>N)}\<rangle>. A\<in>Pow(\<Union>T)}"

text\<open>Given a set neighborhood system we can recover the (standard)
  neighborhood system by taking the values of the set neighborhood system
  at singletons ${x}$ where $x\in X=\bigcup T$.\<close>

lemma neigh_from_nei: assumes "x\<in>\<Union>T"
  shows "({neighborhood system of} T)`(x) = ({set neighborhood system of} T)`{x}"
  using assms ZF_fun_from_tot_val1
  unfolding NeighSystem_def SetNeighSystem_def
  by simp

text\<open>The set neighborhood system of $T$ is a function mapping subsets of $\bigcup T$
  to collections of subsets of $\bigcup T$. \<close>

lemma nei_fun:
  shows "({set neighborhood system of} T):Pow(\<Union>T) \<rightarrow>Pow(Pow(\<Union>T))"
proof -
  let ?X = "\<Union>T"
  have "\<forall>A\<in>Pow(?X). {N\<in>Pow(?X). \<exists>U\<in>T. (A\<subseteq>U \<and> U\<subseteq>N)} \<in> Pow(Pow(?X))"
    by blast
  then have
    "{\<langle>A,{N\<in>Pow(?X). \<exists>U\<in>T. (A\<subseteq>U \<and> U\<subseteq>N)}\<rangle>. A\<in>Pow(?X)}:Pow(?X)\<rightarrow>Pow(Pow(?X))"
    by (rule ZF_fun_from_total)
  then show ?thesis unfolding SetNeighSystem_def by simp
qed

text\<open>The value of the set neighborhood system of $T$ at subset $A$ of $\bigcup T$
  is the collection of subsets $N$ of $\bigcup T$ for which exists an open subset
  $U\subseteq N$ that contains $A$. \<close>

lemma nei_val: assumes "A \<subseteq> \<Union>T"
  shows
  "({set neighborhood system of} T)`(A) = {N\<in>Pow(\<Union>T). \<exists>U\<in>T. (A\<subseteq>U \<and> U\<subseteq>N)}"
  using assms ZF_fun_from_tot_val1 unfolding SetNeighSystem_def by simp

text\<open>A member of the value of the set neighborhood system of $T$ at $A$ is
  a subset of $\bigcup T$. The interesting part is that we can show it without any
  assumption on $A$. \<close>

lemma nei_val_subset:
  assumes "N \<in> ({set neighborhood system of} T)`(A)"
  shows "A \<subseteq> \<Union>T" and "N \<subseteq> \<Union>T"
proof -
  let ?f = "{set neighborhood system of} T"
  have "?f:Pow(\<Union>T) \<rightarrow>Pow(Pow(\<Union>T))" using nei_fun by simp
  with assms show "A \<subseteq> \<Union>T" using arg_in_domain by blast
  with assms show "N \<subseteq> \<Union>T" using nei_val by simp
qed

text\<open>If $T$ is a topology, then every subset of its carrier (i.e. $\bigcup T$)
  is a (set) neighborhood of the empty set. \<close>

lemma nei_empty: assumes "T {is a topology}" "N \<subseteq> \<Union>T"
  shows "N \<in> ({set neighborhood system of} T)`(0)"
  using assms empty_open nei_val by auto

text\<open>If $T$ is a topology, then the (set) neighborhoods of a nonempty subset of
  $\bigcup T$ form a filter on $X=\bigcup T$.\<close>

theorem nei_filter: assumes "T {is a topology}" "D \<subseteq> (\<Union>T)" "D\<noteq>0"
  shows "({set neighborhood system of} T)`(D) {is a filter on} (\<Union>T)"
proof -
  let ?X = "\<Union>T"
  let ?\<F> = "({set neighborhood system of} T)`(D)"
  from assms(2) have I: "?\<F> = {N\<in>Pow(?X). \<exists>U\<in>T. (D\<subseteq>U \<and> U\<subseteq>N)}"
    using nei_val by simp
  with assms(3) have "0 \<notin> ?\<F>" by auto
  moreover from assms(1,2) I have "?X\<in>?\<F>"
    using carr_open by auto
  moreover from I have "?\<F> \<subseteq> Pow(?X)" by auto
  moreover have "\<forall>A\<in>?\<F>. \<forall>B\<in>?\<F>. A\<inter>B \<in> ?\<F>"
  proof -
    { fix A B assume "A\<in>?\<F>" "B\<in>?\<F>"
      with I obtain U\<^sub>A U\<^sub>B where
        "U\<^sub>A\<in>T" "D\<subseteq>U\<^sub>A" "U\<^sub>A\<subseteq>A" and "U\<^sub>B\<in>T" "D\<subseteq>U\<^sub>B" "U\<^sub>B\<subseteq>B"
        by auto
      let ?U = "U\<^sub>A\<inter>U\<^sub>B"
      from assms(1) \<open>U\<^sub>A\<in>T\<close> \<open>U\<^sub>B\<in>T\<close> \<open>D\<subseteq>U\<^sub>A\<close> \<open>D\<subseteq>U\<^sub>B\<close> \<open>U\<^sub>A\<subseteq>A\<close> \<open>U\<^sub>B\<subseteq>B\<close>
      have "?U \<in> T" "D\<subseteq>?U" "?U \<subseteq> A\<inter>B"
        unfolding IsATopology_def by auto
      with I \<open>A\<in>?\<F>\<close> \<open>B\<in>?\<F>\<close> have "A\<inter>B \<in> ?\<F>" by auto
    } thus ?thesis by simp
  qed
  moreover have "\<forall>B\<in>?\<F>. \<forall>C\<in>Pow(?X). B\<subseteq>C \<longrightarrow> C\<in>?\<F>"
  proof -
    { fix B C assume "B\<in>?\<F>" "C\<in>Pow(?X)" "B\<subseteq>C"
      from I \<open>B\<in>?\<F>\<close> obtain U where "U\<in>T" "D\<subseteq>U" and "U\<subseteq>B"
        by auto
      with \<open>B\<subseteq>C\<close> have "\<exists>U\<in>T. (D\<subseteq>U \<and> U\<subseteq>C)" by blast
      with I \<open>C\<in>Pow(?X)\<close> have "C\<in>?\<F>" by simp
    } thus ?thesis by blast
  qed
  ultimately show "?\<F> {is a filter on} ?X"
    unfolding IsFilter_def by simp
qed

text\<open>If $N$ is a (set) neighborhood of $A$ in $T$, then exist an open set $U$ such that
  $N$ contains $U$ which contains $A$. This is similar to the Metamath's theorem
  with the same name, except that here we do not need assume that $T$ is a topology
  (which is a bit worrying).\<close>

lemma neii2: assumes "N \<in> ({set neighborhood system of} T)`(A)"
  shows "\<exists>U\<in>T. (A\<subseteq>U \<and> U\<subseteq>N)"
proof -
  from assms have "A\<in>Pow(\<Union>T)" using nei_fun arg_in_domain
    by blast
  with assms show ?thesis
    unfolding SetNeighSystem_def using ZF_fun_from_tot_val1
    by simp
qed

text\<open>An open set $U$ covering a set $A$ is a set neighborhood of $A$. \<close>

lemma open_superset_nei: assumes "V\<in>T" "A\<subseteq>V"
  shows "V \<in> ({set neighborhood system of} T)`(A)"
proof -
  from assms have
    "({set neighborhood system of} T)`(A) = {N\<in>Pow(\<Union>T). \<exists>U\<in>T. (A\<subseteq>U \<and> U\<subseteq>N)}"
    using nei_val by blast
  with assms show ?thesis by auto
qed

text\<open>An open set is a set neighborhood of itself.\<close>

corollary open_is_nei: assumes "V\<in>T"
  shows "V \<in> ({set neighborhood system of} T)`(V)"
  using assms open_superset_nei by simp

text\<open>An open neighborhood of $x$ is a set neighborhood of $\{ x\}$. \<close>

corollary open_nei_singl: assumes "V\<in>T" "x\<in>V"
  shows  "V \<in> ({set neighborhood system of} T)`{x}"
  using assms open_superset_nei by simp

text\<open>The Cartesian product of two neighborhoods is a neighborhood in the
  product topology. Similar to the Metamath's theorem with the same name. \<close>

lemma neitx:
  assumes "T {is a topology}" "S {is a topology}" and
  "A \<in> ({set neighborhood system of} T)`(C)" and
  "B \<in> ({set neighborhood system of} S)`(D)"
  shows "A\<times>B \<in> ({set neighborhood system of} (T\<times>\<^sub>tS))`(C\<times>D)"
proof -
  have "A\<times>B \<subseteq> \<Union>(T\<times>\<^sub>tS)"
  proof -
    from assms(3,4) have "A\<times>B \<subseteq> (\<Union>T)\<times>(\<Union>S)"
      using nei_val_subset(2) by blast
    with assms(1,2) show ?thesis using Top_1_4_T1 by simp
  qed
  let ?\<F> = "({set neighborhood system of} (T\<times>\<^sub>tS))`(C\<times>D)"
  { assume "C=0 \<or> D=0"
    with assms(1,2) \<open>A\<times>B \<subseteq> \<Union>(T\<times>\<^sub>tS)\<close> have "A\<times>B \<in> ?\<F>"
      using Top_1_4_T1(1) nei_empty by auto
  }
  moreover
  { assume "C\<noteq>0" "D\<noteq>0"
    from assms(3) obtain U\<^sub>A where
      "U\<^sub>A\<in>T" "C\<subseteq>U\<^sub>A" "U\<^sub>A\<subseteq>A" using neii2 by blast
    from assms(4) obtain U\<^sub>B where
      "U\<^sub>B\<in>S" "D\<subseteq>U\<^sub>B" "U\<^sub>B\<subseteq>B" using neii2 by blast
    from assms(1,2) \<open>U\<^sub>A\<in>T\<close> \<open>U\<^sub>B\<in>S\<close> \<open>C\<subseteq>U\<^sub>A\<close> \<open>D\<subseteq>U\<^sub>B\<close>
    have "U\<^sub>A\<times>U\<^sub>B \<in> T\<times>\<^sub>tS" and "C\<times>D \<subseteq> U\<^sub>A\<times>U\<^sub>B"
      using prod_open_open_prod by auto
    then have "U\<^sub>A\<times>U\<^sub>B \<in> ?\<F>" using open_superset_nei
      by simp
    from \<open>U\<^sub>A\<subseteq>A\<close> \<open>U\<^sub>B\<subseteq>B\<close> have "U\<^sub>A\<times>U\<^sub>B \<subseteq> A\<times>B" by auto
    have "?\<F> {is a filter on} (\<Union>(T\<times>\<^sub>tS))"
    proof -
      from assms(1,2) have "(T\<times>\<^sub>tS) {is a topology}"
        using Top_1_4_T1(1) by simp
      moreover have "C\<times>D \<subseteq> \<Union>(T\<times>\<^sub>tS)"
      proof -
        from assms(3,4) have "C\<times>D \<subseteq> (\<Union>T)\<times>(\<Union>S)"
          using nei_val_subset(1) by blast
        with assms(1,2) show ?thesis using Top_1_4_T1(3) by simp
      qed
      moreover from \<open>C\<noteq>0\<close> \<open>D\<noteq>0\<close> have "C\<times>D \<noteq> 0" by auto
      ultimately show "?\<F> {is a filter on} (\<Union>(T\<times>\<^sub>tS))"
        using nei_filter by simp
    qed
    with \<open>U\<^sub>A\<times>U\<^sub>B \<in> ?\<F>\<close> \<open>A\<times>B \<subseteq> \<Union>(T\<times>\<^sub>tS)\<close> \<open>U\<^sub>A\<times>U\<^sub>B \<subseteq> A\<times>B\<close>
    have "A\<times>B \<in> ?\<F>" using is_filter_def_split(5) by simp
  }
  ultimately show ?thesis by auto
qed

text\<open>Any neighborhood of an element of the closure of a subset intersects the subset.
  This is practically the same as \<open>neigh_inter_nempty\<close>, just formulated in terms
  of set neighborhoods of singletons.
  Compare with Metamath's theorem with the same name.\<close>

lemma neindisj: assumes "T {is a topology}" "A\<subseteq>\<Union>T" "x \<in> Closure(A,T)" and
  "N \<in> ({set neighborhood system of} T)`{x}"
  shows "N\<inter>A \<noteq> 0"
proof -
  let ?X = "\<Union>T"
  from assms(1) have cntx: "topology0(T)"
    unfolding topology0_def by simp
  with assms(2,3) have "x\<in>?X"
    using topology0.Top_3_L11(1) by blast
  with assms show ?thesis using neigh_from_nei neigh_inter_nempty
    by simp
qed

end


theory CK_Machine
  imports "../Nominal"
begin

text {*

  This theory establishes soundness and completeness for a CK-machine
  with respect to a cbv-big-step semantics. The language includes
  functions, recursion, booleans and numbers. In the soundness proof
  the small-step cbv-reduction relation is used in order to get the
  induction through. The type-preservation property is proved for the
  machine and  also for the small- and big-step semantics. Finally,
  the progress property is proved for the small-step semantics.

  The development is inspired by notes about context machines written
  by Roshan James (Indiana University) and also by the lecture notes
  written by Andy Pitts for his semantics course. See

     @{url "http://www.cs.indiana.edu/~rpjames/lm.pdf"}
     @{url "http://www.cl.cam.ac.uk/teaching/2001/Semantics/"}

*}

atom_decl name

nominal_datatype lam =
  VAR "name"
| APP "lam" "lam"
| LAM "\<guillemotleft>name\<guillemotright>lam" ("LAM [_]._")
| NUM "nat"
| DIFF "lam" "lam" ("_ -- _")    (* subtraction *)
| PLUS "lam" "lam" ("_ ++ _")    (* addition *)
| TRUE
| FALSE
| IF "lam" "lam" "lam"
| FIX "\<guillemotleft>name\<guillemotright>lam" ("FIX [_]._")  (* recursion *)
| ZET "lam"                      (* zero test *)
| EQI "lam" "lam"                (* equality test on numbers *)

section {* Capture-Avoiding Substitution *}

nominal_primrec
  subst :: "lam \<Rightarrow> name \<Rightarrow> lam \<Rightarrow> lam"  ("_[_::=_]" [100,100,100] 100)
where
  "(VAR x)[y::=s] = (if x=y then s else (VAR x))"
| "(APP t\<^sub>1 t\<^sub>2)[y::=s] = APP (t\<^sub>1[y::=s]) (t\<^sub>2[y::=s])"
| "x\<sharp>(y,s) \<Longrightarrow> (LAM [x].t)[y::=s] = LAM [x].(t[y::=s])"
| "(NUM n)[y::=s] = NUM n"
| "(t\<^sub>1 -- t\<^sub>2)[y::=s] = (t\<^sub>1[y::=s]) -- (t\<^sub>2[y::=s])"
| "(t\<^sub>1 ++ t\<^sub>2)[y::=s] = (t\<^sub>1[y::=s]) ++ (t\<^sub>2[y::=s])"
| "x\<sharp>(y,s) \<Longrightarrow> (FIX [x].t)[y::=s] = FIX [x].(t[y::=s])"
| "TRUE[y::=s] = TRUE"
| "FALSE[y::=s] = FALSE"
| "(IF t1 t2 t3)[y::=s] = IF (t1[y::=s]) (t2[y::=s]) (t3[y::=s])"
| "(ZET t)[y::=s] = ZET (t[y::=s])"
| "(EQI t1 t2)[y::=s] = EQI (t1[y::=s]) (t2[y::=s])"
apply(finite_guess)+
apply(rule TrueI)+
apply(simp add: abs_fresh)+
apply(fresh_guess)+
done

lemma  subst_eqvt[eqvt]:
  fixes pi::"name prm"
  shows "pi\<bullet>(t1[x::=t2]) = (pi\<bullet>t1)[(pi\<bullet>x)::=(pi\<bullet>t2)]"
by (nominal_induct t1 avoiding: x t2 rule: lam.strong_induct)
   (auto simp add: perm_bij fresh_atm fresh_bij)

lemma fresh_fact:
  fixes z::"name"
  shows "\<lbrakk>z\<sharp>s; (z=y \<or> z\<sharp>t)\<rbrakk> \<Longrightarrow> z\<sharp>t[y::=s]"
by (nominal_induct t avoiding: z y s rule: lam.strong_induct)
   (auto simp add: abs_fresh fresh_prod fresh_atm fresh_nat)

lemma subst_rename:
  assumes a: "y\<sharp>t"
  shows "t[x::=s] = ([(y,x)]\<bullet>t)[y::=s]"
using a
by (nominal_induct t avoiding: x y s rule: lam.strong_induct)
   (auto simp add: calc_atm fresh_atm abs_fresh perm_nat_def)

section {* Evaluation Contexts *}

datatype ctx =
    Hole ("\<box>")
  | CAPPL "ctx" "lam"
  | CAPPR "lam" "ctx"
  | CDIFFL "ctx" "lam"
  | CDIFFR "lam" "ctx"
  | CPLUSL "ctx" "lam"
  | CPLUSR "lam" "ctx"
  | CIF "ctx" "lam" "lam"
  | CZET "ctx"
  | CEQIL "ctx" "lam"
  | CEQIR "lam" "ctx"

text {* The operation of filling a term into a context: *}

fun
  filling :: "ctx \<Rightarrow> lam \<Rightarrow> lam" ("_\<lbrakk>_\<rbrakk>")
where
  "\<box>\<lbrakk>t\<rbrakk> = t"
| "(CAPPL E t')\<lbrakk>t\<rbrakk> = APP (E\<lbrakk>t\<rbrakk>) t'"
| "(CAPPR t' E)\<lbrakk>t\<rbrakk> = APP t' (E\<lbrakk>t\<rbrakk>)"
| "(CDIFFL E t')\<lbrakk>t\<rbrakk> = (E\<lbrakk>t\<rbrakk>) -- t'"
| "(CDIFFR t' E)\<lbrakk>t\<rbrakk> = t' -- (E\<lbrakk>t\<rbrakk>)"
| "(CPLUSL E t')\<lbrakk>t\<rbrakk> = (E\<lbrakk>t\<rbrakk>) ++ t'"
| "(CPLUSR t' E)\<lbrakk>t\<rbrakk> = t' ++ (E\<lbrakk>t\<rbrakk>)"
| "(CIF E t1 t2)\<lbrakk>t\<rbrakk> = IF (E\<lbrakk>t\<rbrakk>) t1 t2"
| "(CZET E)\<lbrakk>t\<rbrakk> = ZET (E\<lbrakk>t\<rbrakk>)"
| "(CEQIL E t')\<lbrakk>t\<rbrakk> = EQI (E\<lbrakk>t\<rbrakk>) t'"
| "(CEQIR t' E)\<lbrakk>t\<rbrakk> = EQI t' (E\<lbrakk>t\<rbrakk>)"

text {* The operation of composing two contexts: *}

fun
 ctx_compose :: "ctx \<Rightarrow> ctx \<Rightarrow> ctx" ("_ \<circ> _")
where
  "\<box> \<circ> E' = E'"
| "(CAPPL E t') \<circ> E' = CAPPL (E \<circ> E') t'"
| "(CAPPR t' E) \<circ> E' = CAPPR t' (E \<circ> E')"
| "(CDIFFL E t') \<circ> E' = CDIFFL (E \<circ> E') t'"
| "(CDIFFR t' E) \<circ> E' = CDIFFR t' (E \<circ> E')"
| "(CPLUSL E t') \<circ> E' = CPLUSL (E \<circ> E') t'"
| "(CPLUSR t' E) \<circ> E' = CPLUSR t' (E \<circ> E')"
| "(CIF E t1 t2) \<circ> E' = CIF (E \<circ> E') t1 t2"
| "(CZET E) \<circ> E' = CZET (E \<circ> E')"
| "(CEQIL E t') \<circ> E' = CEQIL (E \<circ> E') t'"
| "(CEQIR t' E) \<circ> E' = CEQIR t' (E \<circ> E')"

lemma ctx_compose:
  shows "(E1 \<circ> E2)\<lbrakk>t\<rbrakk> = E1\<lbrakk>E2\<lbrakk>t\<rbrakk>\<rbrakk>"
by (induct E1 rule: ctx.induct) (auto)

text {* Composing a list (stack) of contexts. *}

fun
  ctx_composes :: "ctx list \<Rightarrow> ctx" ("_\<down>")
where
    "[]\<down> = \<box>"
  | "(E#Es)\<down> = (Es\<down>) \<circ> E"

section {* The CK-Machine *}

inductive
  val :: "lam\<Rightarrow>bool"
where
  v_LAM[intro]:   "val (LAM [x].e)"
| v_NUM[intro]:   "val (NUM n)"
| v_FALSE[intro]: "val FALSE"
| v_TRUE[intro]:  "val TRUE"

equivariance val

inductive
  machine :: "lam\<Rightarrow>ctx list\<Rightarrow>lam\<Rightarrow>ctx list\<Rightarrow>bool" ("<_,_> \<mapsto> <_,_>")
where
  m1[intro]: "<APP e1 e2,Es> \<mapsto> <e1,(CAPPL \<box> e2)#Es>"
| m2[intro]: "val v \<Longrightarrow> <v,(CAPPL \<box> e2)#Es> \<mapsto> <e2,(CAPPR v \<box>)#Es>"
| m3[intro]: "val v \<Longrightarrow> <v,(CAPPR (LAM [y].e) \<box>)#Es> \<mapsto> <e[y::=v],Es>"
| m4[intro]: "<e1 -- e2, Es> \<mapsto> <e1,(CDIFFL \<box> e2)#Es>"
| m5[intro]: "<NUM n1,(CDIFFL \<box> e2)#Es> \<mapsto> <e2,(CDIFFR (NUM n1) \<box>)#Es>"
| m6[intro]: "<NUM n2,(CDIFFR (NUM n1) \<box>)#Es> \<mapsto> <NUM (n1 - n2),Es>"
| m4'[intro]:"<e1 ++ e2, Es> \<mapsto> <e1,(CPLUSL \<box> e2)#Es>"
| m5'[intro]:"<NUM n1,(CPLUSL \<box> e2)#Es> \<mapsto> <e2,(CPLUSR (NUM n1) \<box>)#Es>"
| m6'[intro]:"<NUM n2,(CPLUSR (NUM n1) \<box>)#Es> \<mapsto> <NUM (n1+n2),Es>"
| m7[intro]: "<IF e1 e2 e3,Es> \<mapsto> <e1,(CIF \<box> e2 e3)#Es>"
| m8[intro]: "<TRUE,(CIF \<box> e1 e2)#Es> \<mapsto> <e1,Es>"
| m9[intro]: "<FALSE,(CIF \<box> e1 e2)#Es> \<mapsto> <e2,Es>"
| mA[intro]: "<FIX [x].t,Es> \<mapsto> <t[x::=FIX [x].t],Es>"
| mB[intro]: "<ZET e,Es> \<mapsto> <e,(CZET \<box>)#Es>"
| mC[intro]: "<NUM 0,(CZET \<box>)#Es> \<mapsto> <TRUE,Es>"
| mD[intro]: "0 < n \<Longrightarrow> <NUM n,(CZET \<box>)#Es> \<mapsto> <FALSE,Es>"
| mE[intro]: "<EQI e1 e2,Es> \<mapsto> <e1,(CEQIL \<box> e2)#Es>"
| mF[intro]: "<NUM n1,(CEQIL \<box> e2)#Es> \<mapsto> <e2,(CEQIR (NUM n1) \<box>)#Es>"
| mG[intro]: "<NUM n,(CEQIR (NUM n) \<box>)#Es> \<mapsto> <TRUE,Es>"
| mH[intro]: "n1\<noteq>n2 \<Longrightarrow> <NUM n1,(CEQIR (NUM n2) \<box>)#Es> \<mapsto> <FALSE,Es>"

inductive
  "machine_star" :: "lam\<Rightarrow>ctx list\<Rightarrow>lam\<Rightarrow>ctx list\<Rightarrow>bool" ("<_,_> \<mapsto>* <_,_>")
where
  ms1[intro]: "<e,Es> \<mapsto>* <e,Es>"
| ms2[intro]: "\<lbrakk><e1,Es1> \<mapsto> <e2,Es2>; <e2,Es2> \<mapsto>* <e3,Es3>\<rbrakk> \<Longrightarrow> <e1,Es1> \<mapsto>* <e3,Es3>"

lemma ms3[intro,trans]:
  assumes a: "<e1,Es1> \<mapsto>* <e2,Es2>" "<e2,Es2> \<mapsto>* <e3,Es3>"
  shows "<e1,Es1> \<mapsto>* <e3,Es3>"
using a by (induct) (auto)

lemma ms4[intro]:
  assumes a: "<e1,Es1> \<mapsto> <e2,Es2>"
  shows "<e1,Es1> \<mapsto>* <e2,Es2>"
using a by (rule ms2) (rule ms1)

section {* The Evaluation Relation (Big-Step Semantics) *}

inductive
  eval :: "lam\<Rightarrow>lam\<Rightarrow>bool" ("_ \<Down> _")
where
  eval_NUM[intro]:  "NUM n \<Down> NUM n"
| eval_DIFF[intro]: "\<lbrakk>t1 \<Down> (NUM n1); t2 \<Down> (NUM n2)\<rbrakk> \<Longrightarrow> t1 -- t2 \<Down> NUM (n1 - n2)"
| eval_PLUS[intro]: "\<lbrakk>t1 \<Down> (NUM n1); t2 \<Down> (NUM n2)\<rbrakk> \<Longrightarrow> t1 ++ t2 \<Down> NUM (n1 + n2)"
| eval_LAM[intro]:  "LAM [x].t \<Down> LAM [x].t"
| eval_APP[intro]:  "\<lbrakk>t1\<Down> LAM [x].t; t2\<Down> t2'; t[x::=t2']\<Down> t'\<rbrakk> \<Longrightarrow> APP t1 t2 \<Down> t'"
| eval_FIX[intro]:  "t[x::= FIX [x].t] \<Down> t' \<Longrightarrow> FIX [x].t \<Down> t'"
| eval_IF1[intro]:  "\<lbrakk>t1 \<Down> TRUE; t2 \<Down> t'\<rbrakk> \<Longrightarrow> IF t1 t2 t3 \<Down> t'"
| eval_IF2[intro]:  "\<lbrakk>t1 \<Down> FALSE; t3 \<Down> t'\<rbrakk> \<Longrightarrow> IF t1 t2 t3 \<Down> t'"
| eval_TRUE[intro]: "TRUE \<Down> TRUE"
| eval_FALSE[intro]:"FALSE \<Down> FALSE"
| eval_ZET1[intro]: "t \<Down> NUM 0 \<Longrightarrow> ZET t \<Down> TRUE"
| eval_ZET2[intro]: "\<lbrakk>t \<Down> NUM n; 0 < n\<rbrakk> \<Longrightarrow> ZET t \<Down> FALSE"
| eval_EQ1[intro]:  "\<lbrakk>t1 \<Down> NUM n; t2 \<Down> NUM n\<rbrakk> \<Longrightarrow> EQI t1 t2 \<Down> TRUE"
| eval_EQ2[intro]:  "\<lbrakk>t1 \<Down> NUM n1; t2 \<Down> NUM n2; n1\<noteq>n2\<rbrakk> \<Longrightarrow> EQI t1 t2 \<Down> FALSE"

declare lam.inject[simp]
inductive_cases eval_elim:
  "APP t1 t2 \<Down> t'"
  "IF t1 t2 t3 \<Down> t'"
  "ZET t \<Down> t'"
  "EQI t1 t2 \<Down> t'"
  "t1 ++ t2 \<Down> t'"
  "t1 -- t2 \<Down> t'"
  "(NUM n) \<Down> t"
  "TRUE \<Down> t"
  "FALSE \<Down> t"
declare lam.inject[simp del]

lemma eval_to:
  assumes a: "t \<Down> t'"
  shows "val t'"
using a by (induct) (auto)

lemma eval_val:
  assumes a: "val t"
  shows "t \<Down> t"
using a by (induct) (auto)

text {* The Completeness Property: *}

theorem eval_implies_machine_star_ctx:
  assumes a: "t \<Down> t'"
  shows "<t,Es> \<mapsto>* <t',Es>"
using a
by (induct arbitrary: Es)
   (metis eval_to machine.intros ms1 ms2 ms3 ms4 v_LAM)+

corollary eval_implies_machine_star:
  assumes a: "t \<Down> t'"
  shows "<t,[]> \<mapsto>* <t',[]>"
using a by (auto dest: eval_implies_machine_star_ctx)

section {* The CBV Reduction Relation (Small-Step Semantics) *}

lemma less_eqvt[eqvt]:
  fixes pi::"name prm"
  and   n1 n2::"nat"
  shows "(pi\<bullet>(n1 < n2)) = ((pi\<bullet>n1) < (pi\<bullet>n2))"
by (simp add: perm_nat_def perm_bool)

inductive
  cbv :: "lam\<Rightarrow>lam\<Rightarrow>bool" ("_ \<longrightarrow>cbv _")
where
  cbv1: "\<lbrakk>val v; x\<sharp>v\<rbrakk> \<Longrightarrow> APP (LAM [x].t) v \<longrightarrow>cbv t[x::=v]"
| cbv2[intro]: "t \<longrightarrow>cbv t' \<Longrightarrow> APP t t2 \<longrightarrow>cbv APP t' t2"
| cbv3[intro]: "t \<longrightarrow>cbv t' \<Longrightarrow> APP t2 t \<longrightarrow>cbv APP t2 t'"
| cbv4[intro]: "t \<longrightarrow>cbv t' \<Longrightarrow> t -- t2 \<longrightarrow>cbv t' -- t2"
| cbv5[intro]: "t \<longrightarrow>cbv t' \<Longrightarrow> t2 -- t \<longrightarrow>cbv t2 -- t'"
| cbv6[intro]: "(NUM n1) -- (NUM n2) \<longrightarrow>cbv NUM (n1 - n2)"
| cbv4'[intro]: "t \<longrightarrow>cbv t' \<Longrightarrow> t ++ t2 \<longrightarrow>cbv t' ++ t2"
| cbv5'[intro]: "t \<longrightarrow>cbv t' \<Longrightarrow> t2 ++ t \<longrightarrow>cbv t2 ++ t'"
| cbv6'[intro]:"(NUM n1) ++ (NUM n2) \<longrightarrow>cbv NUM (n1 + n2)"
| cbv7[intro]: "t \<longrightarrow>cbv t' \<Longrightarrow> IF t t1 t2 \<longrightarrow>cbv IF t' t1 t2"
| cbv8[intro]: "IF TRUE t1 t2 \<longrightarrow>cbv t1"
| cbv9[intro]: "IF FALSE t1 t2 \<longrightarrow>cbv t2"
| cbvA[intro]: "FIX [x].t \<longrightarrow>cbv t[x::=FIX [x].t]"
| cbvB[intro]: "t \<longrightarrow>cbv t' \<Longrightarrow> ZET t \<longrightarrow>cbv ZET t'"
| cbvC[intro]: "ZET (NUM 0) \<longrightarrow>cbv TRUE"
| cbvD[intro]: "0 < n \<Longrightarrow> ZET (NUM n) \<longrightarrow>cbv FALSE"
| cbvE[intro]: "t \<longrightarrow>cbv t' \<Longrightarrow> EQI t t2 \<longrightarrow>cbv EQI t' t2"
| cbvF[intro]: "t \<longrightarrow>cbv t' \<Longrightarrow> EQI t2 t \<longrightarrow>cbv EQI t2 t'"
| cbvG[intro]: "EQI (NUM n) (NUM n) \<longrightarrow>cbv TRUE"
| cbvH[intro]: "n1\<noteq>n2 \<Longrightarrow> EQI (NUM n1) (NUM n2) \<longrightarrow>cbv FALSE"

equivariance cbv
nominal_inductive cbv
 by (simp_all add: abs_fresh fresh_fact)

lemma better_cbv1[intro]:
  assumes a: "val v"
  shows "APP (LAM [x].t) v \<longrightarrow>cbv t[x::=v]"
proof -
  obtain y::"name" where fs: "y\<sharp>(x,t,v)" by (rule exists_fresh, rule fin_supp, blast)
  have "APP (LAM [x].t) v = APP (LAM [y].([(y,x)]\<bullet>t)) v" using fs
    by (auto simp add: lam.inject alpha' fresh_prod fresh_atm)
  also have "\<dots> \<longrightarrow>cbv  ([(y,x)]\<bullet>t)[y::=v]" using fs a by (auto simp add: cbv.eqvt cbv1)
  also have "\<dots> = t[x::=v]" using fs by (simp add: subst_rename[symmetric])
  finally show "APP (LAM [x].t) v \<longrightarrow>cbv t[x::=v]" by simp
qed

inductive
  "cbv_star" :: "lam\<Rightarrow>lam\<Rightarrow>bool" (" _ \<longrightarrow>cbv* _")
where
  cbvs1[intro]: "e \<longrightarrow>cbv* e"
| cbvs2[intro]: "\<lbrakk>e1\<longrightarrow>cbv e2; e2 \<longrightarrow>cbv* e3\<rbrakk> \<Longrightarrow> e1 \<longrightarrow>cbv* e3"

lemma cbvs3[intro,trans]:
  assumes a: "e1 \<longrightarrow>cbv* e2" "e2 \<longrightarrow>cbv* e3"
  shows "e1 \<longrightarrow>cbv* e3"
using a by (induct) (auto)

lemma cbv_in_ctx:
  assumes a: "t \<longrightarrow>cbv t'"
  shows "E\<lbrakk>t\<rbrakk> \<longrightarrow>cbv E\<lbrakk>t'\<rbrakk>"
using a by (induct E) (auto)

lemma machine_implies_cbv_star_ctx:
  assumes a: "<e,Es> \<mapsto> <e',Es'>"
  shows "(Es\<down>)\<lbrakk>e\<rbrakk> \<longrightarrow>cbv* (Es'\<down>)\<lbrakk>e'\<rbrakk>"
using a by (induct) (auto simp add: ctx_compose intro: cbv_in_ctx)

lemma machine_star_implies_cbv_star_ctx:
  assumes a: "<e,Es> \<mapsto>* <e',Es'>"
  shows "(Es\<down>)\<lbrakk>e\<rbrakk> \<longrightarrow>cbv* (Es'\<down>)\<lbrakk>e'\<rbrakk>"
using a
by (induct) (auto dest: machine_implies_cbv_star_ctx)

lemma machine_star_implies_cbv_star:
  assumes a: "<e,[]> \<mapsto>* <e',[]>"
  shows "e \<longrightarrow>cbv* e'"
using a by (auto dest: machine_star_implies_cbv_star_ctx)

lemma cbv_eval:
  assumes a: "t1 \<longrightarrow>cbv t2" "t2 \<Down> t3"
  shows "t1 \<Down> t3"
using a
by (induct arbitrary: t3)
   (auto elim!: eval_elim intro: eval_val)

lemma cbv_star_eval:
  assumes a: "t1 \<longrightarrow>cbv* t2" "t2 \<Down> t3"
  shows "t1 \<Down> t3"
using a by (induct) (auto simp add: cbv_eval)

lemma cbv_star_implies_eval:
  assumes a: "t \<longrightarrow>cbv* v" "val v"
  shows "t \<Down> v"
using a
by (induct)
   (auto simp add: eval_val cbv_star_eval dest: cbvs2)

text {* The Soundness Property *}

theorem machine_star_implies_eval:
  assumes a: "<t1,[]> \<mapsto>* <t2,[]>"
  and     b: "val t2"
  shows "t1 \<Down> t2"
proof -
  from a have "t1 \<longrightarrow>cbv* t2" by (simp add: machine_star_implies_cbv_star)
  then show "t1 \<Down> t2" using b by (simp add: cbv_star_implies_eval)
qed

section {* Typing *}

text {* Types *}

nominal_datatype ty =
  tVAR "string"
| tBOOL
| tINT
| tARR "ty" "ty" ("_ \<rightarrow> _")

declare ty.inject[simp]

lemma ty_fresh:
  fixes x::"name"
  and   T::"ty"
  shows "x\<sharp>T"
by (induct T rule: ty.induct)
   (auto simp add: fresh_string)

text {* Typing Contexts *}

type_synonym tctx = "(name\<times>ty) list"

text {* Sub-Typing Contexts *}

abbreviation
  "sub_tctx" :: "tctx \<Rightarrow> tctx \<Rightarrow> bool" ("_ \<subseteq> _")
where
  "\<Gamma>\<^sub>1 \<subseteq> \<Gamma>\<^sub>2 \<equiv> \<forall>x. x \<in> set \<Gamma>\<^sub>1 \<longrightarrow> x \<in> set \<Gamma>\<^sub>2"

text {* Valid Typing Contexts *}

inductive
  valid :: "tctx \<Rightarrow> bool"
where
  v1[intro]: "valid []"
| v2[intro]: "\<lbrakk>valid \<Gamma>; x\<sharp>\<Gamma>\<rbrakk>\<Longrightarrow> valid ((x,T)#\<Gamma>)"

equivariance valid

lemma valid_elim[dest]:
  assumes a: "valid ((x,T)#\<Gamma>)"
  shows "x\<sharp>\<Gamma> \<and> valid \<Gamma>"
using a by (cases) (auto)

lemma valid_insert:
  assumes a: "valid (\<Delta>@[(x,T)]@\<Gamma>)"
  shows "valid (\<Delta> @ \<Gamma>)"
using a
by (induct \<Delta>)
   (auto simp add:  fresh_list_append fresh_list_cons dest!: valid_elim)

lemma fresh_set:
  shows "y\<sharp>xs = (\<forall>x\<in>set xs. y\<sharp>x)"
by (induct xs) (simp_all add: fresh_list_nil fresh_list_cons)

lemma context_unique:
  assumes a1: "valid \<Gamma>"
  and     a2: "(x,T) \<in> set \<Gamma>"
  and     a3: "(x,U) \<in> set \<Gamma>"
  shows "T = U"
using a1 a2 a3
by (induct) (auto simp add: fresh_set fresh_prod fresh_atm)

section {* The Typing Relation *}

inductive
  typing :: "tctx \<Rightarrow> lam \<Rightarrow> ty \<Rightarrow> bool" ("_ \<turnstile> _ : _")
where
  t_VAR[intro]:  "\<lbrakk>valid \<Gamma>; (x,T)\<in>set \<Gamma>\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> VAR x : T"
| t_APP[intro]:  "\<lbrakk>\<Gamma> \<turnstile> t\<^sub>1 : T\<^sub>1\<rightarrow>T\<^sub>2; \<Gamma> \<turnstile> t\<^sub>2 : T\<^sub>1\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> APP t\<^sub>1 t\<^sub>2 : T\<^sub>2"
| t_LAM[intro]:  "\<lbrakk>x\<sharp>\<Gamma>; (x,T\<^sub>1)#\<Gamma> \<turnstile> t : T\<^sub>2\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> LAM [x].t : T\<^sub>1 \<rightarrow> T\<^sub>2"
| t_NUM[intro]:  "\<Gamma> \<turnstile> (NUM n) : tINT"
| t_DIFF[intro]: "\<lbrakk>\<Gamma> \<turnstile> t\<^sub>1 : tINT; \<Gamma> \<turnstile> t\<^sub>2 : tINT\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> t\<^sub>1 -- t\<^sub>2 : tINT"
| t_PLUS[intro]: "\<lbrakk>\<Gamma> \<turnstile> t\<^sub>1 : tINT; \<Gamma> \<turnstile> t\<^sub>2 : tINT\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> t\<^sub>1 ++ t\<^sub>2 : tINT"
| t_TRUE[intro]:  "\<Gamma> \<turnstile> TRUE : tBOOL"
| t_FALSE[intro]: "\<Gamma> \<turnstile> FALSE : tBOOL"
| t_IF[intro]:    "\<lbrakk>\<Gamma> \<turnstile> t1 : tBOOL; \<Gamma> \<turnstile> t2 : T; \<Gamma> \<turnstile> t3 : T\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> IF t1 t2 t3 : T"
| t_ZET[intro]:   "\<Gamma> \<turnstile> t : tINT \<Longrightarrow> \<Gamma> \<turnstile> ZET t : tBOOL"
| t_EQI[intro]:   "\<lbrakk>\<Gamma> \<turnstile> t1 : tINT; \<Gamma> \<turnstile> t2 : tINT\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> EQI t1 t2 : tBOOL"
| t_FIX[intro]:   "\<lbrakk>x\<sharp>\<Gamma>; (x,T)#\<Gamma> \<turnstile> t : T\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> FIX [x].t : T"

declare lam.inject[simp]
inductive_cases typing_inversion[elim]:
  "\<Gamma> \<turnstile> t\<^sub>1 -- t\<^sub>2 : T"
  "\<Gamma> \<turnstile> t\<^sub>1 ++ t\<^sub>2 : T"
  "\<Gamma> \<turnstile> IF t1 t2 t3 : T"
  "\<Gamma> \<turnstile> ZET t : T"
  "\<Gamma> \<turnstile> EQI t1 t2 : T"
  "\<Gamma> \<turnstile> APP t1 t2 : T"
  "\<Gamma> \<turnstile> TRUE : T"
  "\<Gamma> \<turnstile> FALSE : T"
  "\<Gamma> \<turnstile> NUM n : T"
declare lam.inject[simp del]

equivariance typing
nominal_inductive typing
  by (simp_all add: abs_fresh ty_fresh)

lemma t_LAM_inversion[dest]:
  assumes ty: "\<Gamma> \<turnstile> LAM [x].t : T"
  and     fc: "x\<sharp>\<Gamma>"
  shows "\<exists>T\<^sub>1 T\<^sub>2. T = T\<^sub>1 \<rightarrow> T\<^sub>2 \<and> (x,T\<^sub>1)#\<Gamma> \<turnstile> t : T\<^sub>2"
using ty fc
by (cases rule: typing.strong_cases)
   (auto simp add: alpha lam.inject abs_fresh ty_fresh)

lemma t_FIX_inversion[dest]:
  assumes ty: "\<Gamma> \<turnstile> FIX [x].t : T"
  and     fc: "x\<sharp>\<Gamma>"
  shows "(x,T)#\<Gamma> \<turnstile> t : T"
using ty fc
by (cases rule: typing.strong_cases)
   (auto simp add: alpha lam.inject abs_fresh ty_fresh)

section {* The Type-Preservation Property for the CBV Reduction Relation *}

lemma weakening:
  fixes \<Gamma>1 \<Gamma>2::"tctx"
  assumes a: "\<Gamma>1 \<turnstile> t : T"
  and     b: "valid \<Gamma>2"
  and     c: "\<Gamma>1 \<subseteq> \<Gamma>2"
  shows "\<Gamma>2 \<turnstile> t : T"
using a b c
by (nominal_induct \<Gamma>1 t T avoiding: \<Gamma>2 rule: typing.strong_induct)
   (auto | atomize)+

lemma type_substitution_aux:
  assumes a: "(\<Delta>@[(x,T')]@\<Gamma>) \<turnstile> e : T"
  and     b: "\<Gamma> \<turnstile> e' : T'"
  shows "(\<Delta>@\<Gamma>) \<turnstile> e[x::=e'] : T"
using a b
proof (nominal_induct "\<Delta>@[(x,T')]@\<Gamma>" e T avoiding: x e' \<Delta> rule: typing.strong_induct)
  case (t_VAR y T x e' \<Delta>)
  then have a1: "valid (\<Delta>@[(x,T')]@\<Gamma>)"
       and  a2: "(y,T) \<in> set (\<Delta>@[(x,T')]@\<Gamma>)"
       and  a3: "\<Gamma> \<turnstile> e' : T'" .
  from a1 have a4: "valid (\<Delta>@\<Gamma>)" by (rule valid_insert)
  { assume eq: "x=y"
    from a1 a2 have "T=T'" using eq by (auto intro: context_unique)
    with a3 have "\<Delta>@\<Gamma> \<turnstile> VAR y[x::=e'] : T" using eq a4 by (auto intro: weakening)
  }
  moreover
  { assume ineq: "x\<noteq>y"
    from a2 have "(y,T) \<in> set (\<Delta>@\<Gamma>)" using ineq by simp
    then have "\<Delta>@\<Gamma> \<turnstile> VAR y[x::=e'] : T" using ineq a4 by auto
  }
  ultimately show "\<Delta>@\<Gamma> \<turnstile> VAR y[x::=e'] : T" by blast
qed (auto | force simp add: fresh_list_append fresh_list_cons)+

corollary type_substitution:
  assumes a: "(x,T')#\<Gamma> \<turnstile> e : T"
  and     b: "\<Gamma> \<turnstile> e' : T'"
  shows "\<Gamma> \<turnstile> e[x::=e'] : T"
using a b
by (auto intro: type_substitution_aux[where \<Delta>="[]",simplified])

theorem cbv_type_preservation:
  assumes a: "t \<longrightarrow>cbv t'"
  and     b: "\<Gamma> \<turnstile> t : T"
  shows "\<Gamma> \<turnstile> t' : T"
using a b
apply(nominal_induct avoiding: \<Gamma> T rule: cbv.strong_induct)
apply(auto elim!: typing_inversion dest: t_LAM_inversion simp add: type_substitution)
apply(frule t_FIX_inversion)
apply(auto simp add: type_substitution)
done

corollary cbv_star_type_preservation:
  assumes a: "t \<longrightarrow>cbv* t'"
  and     b: "\<Gamma> \<turnstile> t : T"
  shows "\<Gamma> \<turnstile> t' : T"
using a b
by (induct) (auto intro: cbv_type_preservation)

section {* The Type-Preservation Property for the Machine and Evaluation Relation *}

theorem machine_type_preservation:
  assumes a: "<t,[]> \<mapsto>* <t',[]>"
  and     b: "\<Gamma> \<turnstile> t : T"
  shows "\<Gamma> \<turnstile> t' : T"
proof -
  from a have "t \<longrightarrow>cbv* t'" by (simp add: machine_star_implies_cbv_star)
  then show "\<Gamma> \<turnstile> t' : T" using b by (simp add: cbv_star_type_preservation)
qed

theorem eval_type_preservation:
  assumes a: "t \<Down> t'"
  and     b: "\<Gamma> \<turnstile> t : T"
  shows "\<Gamma> \<turnstile> t' : T"
proof -
  from a have "<t,[]> \<mapsto>* <t',[]>" by (simp add: eval_implies_machine_star)
  then show "\<Gamma> \<turnstile> t' : T" using b by (simp add: machine_type_preservation)
qed

text {* The Progress Property *}

lemma canonical_tARR[dest]:
  assumes a: "[] \<turnstile> t : T1 \<rightarrow> T2"
  and     b: "val t"
  shows "\<exists>x t'. t = LAM [x].t'"
using b a by (induct) (auto)

lemma canonical_tINT[dest]:
  assumes a: "[] \<turnstile> t : tINT"
  and     b: "val t"
  shows "\<exists>n. t = NUM n"
using b a
by (induct) (auto simp add: fresh_list_nil)

lemma canonical_tBOOL[dest]:
  assumes a: "[] \<turnstile> t : tBOOL"
  and     b: "val t"
  shows "t = TRUE \<or> t = FALSE"
using b a
by (induct) (auto simp add: fresh_list_nil)

theorem progress:
  assumes a: "[] \<turnstile> t : T"
  shows "(\<exists>t'. t \<longrightarrow>cbv t') \<or> (val t)"
using a
by (induct \<Gamma>\<equiv>"[]::tctx" t T)
   (auto dest!: canonical_tINT intro!: cbv.intros gr0I)

end