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>\<open>"Hoare&98"\<close>. \<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, opaque_lifting) 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


header {* Implementation of Dijkstra's-Algorithm using Automatic Determinization *}
theory Dijkstra_Impl_Adet
imports
  Dijkstra
  GraphSpec
  HashGraphImpl
  "../Collections/Refine_Dflt_ICF"
  "~~/src/HOL/Library/Code_Target_Numeral"
begin

subsection {* Setup *}

subsubsection {* Infinity *}
definition infty_rel_internal_def:
  "infty_rel R \<equiv> {(Num a, Num a')| a a'. (a,a')\<in>R} \<union> {(Infty,Infty)}"
lemma infty_rel_def[refine_rel_defs]:
  "\<langle>R\<rangle>infty_rel = {(Num a, Num a')| a a'. (a,a')\<in>R} \<union> {(Infty,Infty)}"
  unfolding infty_rel_internal_def relAPP_def by simp

lemma infty_relI:
  "(Infty,Infty)\<in>\<langle>R\<rangle>infty_rel"
  "(a,a')\<in>R \<Longrightarrow> (Num a, Num a')\<in>\<langle>R\<rangle>infty_rel"
  unfolding infty_rel_def by auto

lemma infty_relE:
  assumes "(x,x')\<in>\<langle>R\<rangle>infty_rel"
  obtains "x=Infty" and "x'=Infty"
  | a a' where "x=Num a" and "x'=Num a'" and "(a,a')\<in>R"
  using assms
  unfolding infty_rel_def
  by auto

lemma infty_rel_simps[simp]:
  "(Infty,x')\<in>\<langle>R\<rangle>infty_rel \<longleftrightarrow> x'=Infty"
  "(x,Infty)\<in>\<langle>R\<rangle>infty_rel \<longleftrightarrow> x=Infty"
  "(Num a, Num a')\<in>\<langle>R\<rangle>infty_rel \<longleftrightarrow> (a,a')\<in>R"
  unfolding infty_rel_def by auto

lemma infty_rel_sv[relator_props]:
  "single_valued R \<Longrightarrow> single_valued (\<langle>R\<rangle>infty_rel)"
  unfolding infty_rel_def
  by (auto intro: single_valuedI dest: single_valuedD)

lemma infty_rel_id[simp, relator_props]: "\<langle>Id\<rangle>infty_rel = Id"
  apply rule
  apply (auto elim: infty_relE) []
  apply safe
  apply (case_tac b) by auto

consts i_infty :: "interface \<Rightarrow> interface"
lemmas [autoref_rel_intf] = REL_INTFI[of infty_rel i_infty]

lemma autoref_infty[param,autoref_rules]:
  "(Infty,Infty)\<in>\<langle>R\<rangle>infty_rel"
  "(Num,Num)\<in>R\<rightarrow>\<langle>R\<rangle>infty_rel"
  "(case_infty,case_infty)\<in>Rr\<rightarrow>(R\<rightarrow>Rr)\<rightarrow>\<langle>R\<rangle>infty_rel\<rightarrow>Rr"
  "(rec_infty,rec_infty)\<in>Rr\<rightarrow>(R\<rightarrow>Rr)\<rightarrow>\<langle>R\<rangle>infty_rel\<rightarrow>Rr"
  unfolding infty_rel_def
  by (auto dest: fun_relD)

definition [simp]: "is_Infty x \<equiv> case x of Infty \<Rightarrow> True | _ \<Rightarrow> False"

context begin interpretation autoref_syn .
lemma pat_is_Infty[autoref_op_pat]:
  "x=Infty \<equiv> (OP is_Infty :::\<^sub>i \<langle>I\<rangle>\<^sub>ii_infty \<rightarrow>\<^sub>i i_bool)$x"
  "Infty=x \<equiv> (OP is_Infty :::\<^sub>i \<langle>I\<rangle>\<^sub>ii_infty \<rightarrow>\<^sub>i i_bool)$x"
  by (auto intro!: eq_reflection split: infty.splits)
end

lemma autoref_is_Infty[autoref_rules]:
  "(is_Infty, is_Infty)\<in>\<langle>R\<rangle>infty_rel \<rightarrow> bool_rel"
  by (auto split: infty.splits)

definition "infty_eq eq v1 v2 \<equiv>
  case (v1,v2) of
    (Infty,Infty) \<Rightarrow> True
  | (Num a1, Num a2) \<Rightarrow> eq a1 a2
  | _ \<Rightarrow> False"

lemma infty_eq_autoref[autoref_rules (overloaded)]:
  "\<lbrakk> GEN_OP eq op= (R\<rightarrow>R\<rightarrow>bool_rel) \<rbrakk>
  \<Longrightarrow> (infty_eq eq,op=)\<in>\<langle>R\<rangle>infty_rel\<rightarrow>\<langle>R\<rangle>infty_rel\<rightarrow>bool_rel"
  unfolding infty_eq_def[abs_def]
  by (auto split: infty.splits dest: fun_relD elim!: infty_relE)

lemma infty_eq_expand[autoref_struct_expand]: "op = = infty_eq op="
  by (auto intro!: ext simp: infty_eq_def split: infty.splits)

context begin interpretation autoref_syn .
lemma infty_val_autoref[autoref_rules]:
  "\<lbrakk>SIDE_PRECOND (x\<noteq>Infty); (xi,x)\<in>\<langle>R\<rangle>infty_rel\<rbrakk>
  \<Longrightarrow> (val xi,(OP val ::: \<langle>R\<rangle>infty_rel \<rightarrow> R) $ x)\<in>R"
  apply (cases x)
  apply (auto elim: infty_relE)
  done
end

definition infty_plus where
  "infty_plus pl a b \<equiv> case (a,b) of (Num a, Num b) \<Rightarrow> Num (pl a b) | _ \<Rightarrow> Infty "

lemma infty_plus_param[param]:
  "(infty_plus,infty_plus) \<in> (R\<rightarrow>R\<rightarrow>R) \<rightarrow> \<langle>R\<rangle>infty_rel \<rightarrow> \<langle>R\<rangle>infty_rel \<rightarrow> \<langle>R\<rangle>infty_rel"
  unfolding infty_plus_def[abs_def]
  by parametricity

lemma infty_plus_eq_plus: "infty_plus op+ = op+"
  unfolding infty_plus_def[abs_def]
  by (auto intro!: ext split: infty.split)

lemma infty_plus_autoref[autoref_rules]:
  "GEN_OP pl op+ (R\<rightarrow>R\<rightarrow>R)
  \<Longrightarrow> (infty_plus pl,op+) \<in> \<langle>R\<rangle>infty_rel \<rightarrow> \<langle>R\<rangle>infty_rel \<rightarrow> \<langle>R\<rangle>infty_rel"
  apply (fold infty_plus_eq_plus)
  apply simp
  apply parametricity
  done

subsubsection {* Graph *}
consts i_graph :: "interface \<Rightarrow> interface \<Rightarrow> interface"

definition graph_more_rel_internal_def:
  "graph_more_rel Rm Rv Rw \<equiv> { (g,g').
    (graph.nodes g, graph.nodes g')\<in>\<langle>Rv\<rangle>set_rel
  \<and> (graph.edges g, graph.edges g')\<in>\<langle>\<langle>Rv,\<langle>Rw,Rv\<rangle>prod_rel\<rangle>prod_rel\<rangle>set_rel
  \<and> (graph.more g, graph.more g')\<in>Rm}"

lemma graph_more_rel_def[refine_rel_defs]:
  "\<langle>Rm,Rv,Rw\<rangle>graph_more_rel \<equiv> { (g,g').
    (graph.nodes g, graph.nodes g')\<in>\<langle>Rv\<rangle>set_rel
  \<and> (graph.edges g, graph.edges g')\<in>\<langle>\<langle>Rv,\<langle>Rw,Rv\<rangle>prod_rel\<rangle>prod_rel\<rangle>set_rel
  \<and> (graph.more g, graph.more g')\<in>Rm}"
  unfolding relAPP_def graph_more_rel_internal_def by simp

abbreviation "graph_rel \<equiv> \<langle>unit_rel\<rangle>graph_more_rel"
lemmas graph_rel_def = graph_more_rel_def[where Rm=unit_rel, simplified]

lemma graph_rel_id[simp]: "\<langle>Id,Id\<rangle>graph_rel = Id"
  unfolding graph_rel_def by auto

lemma graph_more_rel_sv[relator_props]:
  "\<lbrakk>single_valued Rm; single_valued Rv; single_valued Rw\<rbrakk>
  \<Longrightarrow> single_valued (\<langle>Rm,Rv,Rw\<rangle>graph_more_rel)"
  unfolding graph_more_rel_def
  apply (rule single_valuedI, clarsimp)
  apply (rule graph.equality)
  apply (erule (1) single_valuedD[rotated], tagged_solver)+
  done

lemma [autoref_itype]:
  "graph.nodes ::\<^sub>i \<langle>Iv,Iw\<rangle>\<^sub>ii_graph \<rightarrow>\<^sub>i \<langle>Iv\<rangle>\<^sub>ii_set"
  by simp_all

thm is_map_to_sorted_list_def

definition "nodes_to_list g \<equiv> it_to_sorted_list (\<lambda>_ _. True) (graph.nodes g)"
lemma nodes_to_list_itype[autoref_itype]: "nodes_to_list ::\<^sub>i \<langle>Iv,Iw\<rangle>\<^sub>ii_graph \<rightarrow>\<^sub>i \<langle>\<langle>Iv\<rangle>\<^sub>ii_list\<rangle>\<^sub>ii_nres" by simp
lemma nodes_to_list_pat[autoref_op_pat]: "it_to_sorted_list (\<lambda>_ _. True) (graph.nodes g) \<equiv> nodes_to_list g"
  unfolding nodes_to_list_def by simp

definition "succ_to_list g v \<equiv> it_to_sorted_list (\<lambda>_ _. True) (Graph.succ g v)"
lemma succ_to_list_itype[autoref_itype]:
  "succ_to_list ::\<^sub>i \<langle>Iv,Iw\<rangle>\<^sub>ii_graph \<rightarrow>\<^sub>i Iv \<rightarrow>\<^sub>i \<langle>\<langle>\<langle>Iw,Iv\<rangle>\<^sub>ii_prod\<rangle>\<^sub>ii_list\<rangle>\<^sub>ii_nres" by simp
lemma succ_to_list_pat[autoref_op_pat]: "it_to_sorted_list (\<lambda>_ _. True) (Graph.succ g v) \<equiv> succ_to_list g v"
  unfolding succ_to_list_def by simp

context graph begin
  definition rel_def_internal: "rel Rv Rw \<equiv> br \<alpha> invar O \<langle>Rv,Rw\<rangle>graph_rel"
  lemma rel_def: "\<langle>Rv,Rw\<rangle>rel \<equiv> br \<alpha> invar O \<langle>Rv,Rw\<rangle>graph_rel"
    unfolding relAPP_def rel_def_internal by simp

  lemma rel_sv[relator_props]:
    "\<lbrakk>single_valued Rv; single_valued Rw\<rbrakk> \<Longrightarrow> single_valued (\<langle>Rv,Rw\<rangle>rel)"
    unfolding rel_def
    by tagged_solver

  lemmas [autoref_rel_intf] = REL_INTFI[of rel i_graph]
end

lemma (in graph_nodes_it) autoref_nodes_it[autoref_rules]:
  assumes ID: "PREFER_id Rv"
  shows "(\<lambda>s. RETURN (it_to_list nodes_it s),nodes_to_list) \<in> \<langle>Rv,Rw\<rangle>rel \<rightarrow> \<langle>\<langle>Rv\<rangle>list_rel\<rangle>nres_rel"
  unfolding nodes_to_list_def[abs_def]
proof (intro fun_relI nres_relI)
  fix s s'
  from ID have [simp]: "Rv = Id" by simp

  assume "(s,s')\<in>\<langle>Rv,Rw\<rangle>rel"
  hence INV: "invar s" and [simp]: "nodes s' = nodes (\<alpha> s)" unfolding rel_def
    by (auto simp add: br_def graph_rel_def)

  obtain l where
    [simp]: "distinct l" "nodes (\<alpha> s) = set l" "it_to_list nodes_it s = l"
    unfolding it_to_list_def
    by (metis nodes_it_correct[OF INV, unfolded set_iterator_def set_iterator_genord_def]
      foldli_snoc_id self_append_conv2)

  show "RETURN (it_to_list nodes_it s)
          \<le> \<Down> (\<langle>Rv\<rangle>list_rel) (it_to_sorted_list (\<lambda>_ _. True) (nodes s'))"
    by (simp add: it_to_sorted_list_def)
qed

lemma (in graph_succ_it) autoref_succ_it[autoref_rules]:
  assumes ID: "PREFER_id Rv" "PREFER_id Rw"
  shows "(\<lambda>s v. RETURN (it_to_list (\<lambda>s. succ_it s v) s),succ_to_list)
    \<in> \<langle>Rv,Rw\<rangle>rel \<rightarrow> Rv \<rightarrow> \<langle>\<langle>\<langle>Rw,Rv\<rangle>prod_rel\<rangle>list_rel\<rangle>nres_rel"
  unfolding succ_to_list_def[abs_def]
proof (intro fun_relI nres_relI)
  fix s s' v v'
  from ID have [simp]: "Rv = Id" "Rw=Id" by simp_all

  assume "(v,v')\<in>Rv" hence [simp]: "v'=v" by simp

  assume "(s,s')\<in>\<langle>Rv,Rw\<rangle>rel"
  hence INV: "invar s" and [simp]: "Graph.succ s' = Graph.succ (\<alpha> s)" unfolding rel_def
    by (auto simp add: br_def graph_rel_def succ_def)

  obtain l where
    [simp]: "distinct l" "succ (\<alpha> s) v = set l" "it_to_list (\<lambda>s. succ_it s v) s = l"
    unfolding it_to_list_def
    by (metis succ_it_correct[OF INV, unfolded set_iterator_def set_iterator_genord_def]
      foldli_snoc_id self_append_conv2)

  show "RETURN (it_to_list (\<lambda>s. succ_it s v) s)
          \<le> \<Down> (\<langle>\<langle>Rw,Rv\<rangle>prod_rel\<rangle>list_rel) (it_to_sorted_list (\<lambda>_ _. True) (succ s' v'))"
    by (simp add: it_to_sorted_list_def)
qed

subsection {* Refinement *}

locale dijkstraC =
  g!: StdGraph g_ops +
  mr!: StdMap mr_ops +
  qw!: StdUprio qw_ops
  for g_ops :: "('V,'W::weight,'G,'moreg) graph_ops_scheme"
  and mr_ops :: "('V, (('V,'W) path \<times> 'W), 'mr,'more_mr) map_ops_scheme"
  and qw_ops :: "('V ,'W infty,'qw,'more_qw) uprio_ops_scheme"
begin
end

locale dijkstraC_fixg = dijkstraC g_ops mr_ops qw_ops +
  Dijkstra ga v0
  for g_ops :: "('V,'W::weight,'G,'moreg) graph_ops_scheme"
  and mr_ops :: "('V, (('V,'W) path \<times> 'W), 'mr,'more_mr) map_ops_scheme"
  and qw_ops :: "('V ,'W infty,'qw,'more_qw) uprio_ops_scheme"
  and ga::"('V,'W) graph" and "v0"::'V and g :: 'G+
  assumes ga_trans: "(g,ga)\<in>br g.\<alpha> g.invar"
begin
  abbreviation "v_rel \<equiv> Id :: ('V\<times>'V) set"
  abbreviation "w_rel \<equiv> Id :: ('W\<times>'W) set"

  definition i_node :: interface where "i_node \<equiv> undefined"
  definition i_weight :: interface where "i_weight \<equiv> undefined"

  lemmas [autoref_rel_intf] = REL_INTFI[of v_rel i_node]
  lemmas [autoref_rel_intf] = REL_INTFI[of w_rel i_weight]

  lemma weight_plus_autoref[autoref_rules]:
    "(0,0) \<in> w_rel"
    "(op+,op+) \<in> w_rel \<rightarrow> w_rel \<rightarrow> w_rel"
    "(op+,op+) \<in> \<langle>w_rel\<rangle>infty_rel \<rightarrow> \<langle>w_rel\<rangle>infty_rel \<rightarrow> \<langle>w_rel\<rangle>infty_rel"
    "(op<,op<) \<in> \<langle>w_rel\<rangle>infty_rel \<rightarrow> \<langle>w_rel\<rangle>infty_rel \<rightarrow> bool_rel"
    by simp_all

  lemma [autoref_rules]: "(g,ga)\<in>\<langle>v_rel,w_rel\<rangle>g.rel" using ga_trans
    by (simp add: g.rel_def)

  lemma [autoref_rules]: "(v0,v0)\<in>v_rel" by simp

  term mpath_weight'
  lemma [autoref_rules]:
    "(mpath_weight',mpath_weight')
      \<in> \<langle>\<langle>v_rel\<times>\<^sub>rw_rel\<times>\<^sub>rv_rel\<rangle>list_rel\<times>\<^sub>rw_rel\<rangle>option_rel \<rightarrow> \<langle>w_rel\<rangle>infty_rel"
    "(mpath', mpath')
      \<in> \<langle>\<langle>v_rel\<times>\<^sub>rw_rel\<times>\<^sub>rv_rel\<rangle>list_rel\<times>\<^sub>rw_rel\<rangle>option_rel
        \<rightarrow> \<langle>\<langle>v_rel\<times>\<^sub>rw_rel\<times>\<^sub>rv_rel\<rangle>list_rel\<rangle>option_rel"
    by auto

  term mdinit

  lemmas [autoref_tyrel] =
    ty_REL[where R=v_rel]
    ty_REL[where R=w_rel]
    ty_REL[where R="\<langle>w_rel\<rangle>infty_rel"]
    ty_REL[where R="\<langle>v_rel,\<langle>w_rel\<rangle>infty_rel\<rangle>qw.rel"]
    ty_REL[where R="\<langle>v_rel,\<langle>v_rel\<times>\<^sub>rw_rel\<times>\<^sub>rv_rel\<rangle>list_rel\<times>\<^sub>rw_rel\<rangle>mr.rel"]
    ty_REL[where R="\<langle>v_rel\<times>\<^sub>rw_rel\<times>\<^sub>rv_rel\<rangle>list_rel"]

  lemmas [autoref_op_pat] = uprio_pats[where 'e = 'V and 'a = "'W infty"]

  schematic_lemma cdijkstra_refines_aux:
    shows "(?c::?'c,
      mdijkstra
    ) \<in> ?R"
    unfolding mdijkstra_def mdinit_def mpop_min_def[abs_def]
      mupdate_def

    using [[goals_limit = 1]]

    apply (fold op_map_empty_def[where 'a="'V" and 'b = "('V\<times>'W\<times>'V) list \<times> 'W"])
    apply (fold op_uprio_empty_def[where 'a="'V" and 'b = "'W infty"])

    (*using [[autoref_trace_intf_unif]]*)
    using [[autoref_trace_failed_id]]

    apply (autoref_monadic (plain,trace))
    done

end

context dijkstraC
begin

  concrete_definition cdijkstra for g ?v0.0
    uses dijkstraC_fixg.cdijkstra_refines_aux
    [of g_ops mr_ops qw_ops]

    term cdijkstra
end

context dijkstraC_fixg
begin

  term cdijkstra
  term mdijkstra

  lemma cdijkstra_refines:
    "RETURN (cdijkstra g v0) \<le> \<Down>(build_rel mr.\<alpha> mr.invar) mdijkstra"
    apply (rule cdijkstra.refine[THEN nres_relD, simplified])
    apply unfold_locales
    done

  theorem cdijkstra_correct:
    shows
    "weighted_graph.is_shortest_path_map ga v0 (\<alpha>r (mr.\<alpha> (cdijkstra g v0)))"
    (is ?G1)
    and "mr.invar (cdijkstra g v0)" (is ?G2)
    and "res_invarm (mr.\<alpha> (cdijkstra g v0))" (is ?G3)
  proof -
    note cdijkstra_refines
    also note mdijkstra_refines
    finally have Z: "RETURN (cdijkstra g v0) \<le>
      \<Down>(build_rel (\<alpha>r \<circ> mr.\<alpha>) (\<lambda>m. mr.invar m \<and> res_invarm (mr.\<alpha> m)))
        dijkstra'"
      apply (subst (asm) conc_fun_chain)
      apply rule
      apply (simp only: br_chain)
      done
    also note dijkstra'_refines[simplified]
    also note dijkstra_correct
    finally show ?G1 ?G2 ?G3
      by (auto elim: RETURN_ref_SPECD simp: refine_rel_defs)
  qed

end

theorem (in dijkstraC) cdijkstra_correct:
  assumes INV: "g.invar g"
  assumes V0: "v0 \<in> nodes (g.\<alpha> g)"
  assumes nonneg_weights: "\<And>v w v'. (v,w,v')\<in>edges (g.\<alpha> g) \<Longrightarrow> 0\<le>w"
  shows
  "weighted_graph.is_shortest_path_map (g.\<alpha> g) v0
      (Dijkstra.\<alpha>r (mr.\<alpha> (cdijkstra g v0)))" (is ?G1)
  and "Dijkstra.res_invarm (mr.\<alpha> (cdijkstra g v0))" (is ?G2)
proof -
  interpret hlgv!: valid_graph "g.\<alpha> g" using g.valid INV .

  interpret dc: dijkstraC_fixg g_ops mr_ops qw_ops "g.\<alpha> g" v0
    apply unfold_locales
    apply (simp_all
      add: hlg.finite INV V0 hlg_ops_def nonneg_weights refine_rel_defs)
    done

  from dc.cdijkstra_correct show ?G1 ?G2 by auto
qed

text {*
  Example instantiation with HashSet.based graph,
  red-black-tree based result map, and finger-tree based priority queue.
*}
setup Locale_Code.open_block
interpretation hrf!: dijkstraC hlg_ops rm_ops aluprioi_ops
  by unfold_locales
setup Locale_Code.close_block

definition "hrf_dijkstra \<equiv> hrf.cdijkstra"
lemmas hrf_dijkstra_correct = hrf.cdijkstra_correct[folded hrf_dijkstra_def]

export_code hrf_dijkstra in SML
export_code hrf_dijkstra in OCaml
export_code hrf_dijkstra in Haskell
export_code hrf_dijkstra in Scala

definition hrfn_dijkstra :: "(nat,nat) hlg \<Rightarrow> _"
  where "hrfn_dijkstra \<equiv> hrf_dijkstra"

export_code hrfn_dijkstra in SML

lemmas hrfn_dijkstra_correct =
  hrf_dijkstra_correct[where ?'a = nat and ?'b = nat, folded hrfn_dijkstra_def]

end


(*  Title:      HOL/BNF_Least_Fixpoint.thy
    Author:     Dmitriy Traytel, TU Muenchen
    Author:     Lorenz Panny, TU Muenchen
    Author:     Jasmin Blanchette, TU Muenchen
    Copyright   2012, 2013, 2014

Least fixpoint (datatype) operation on bounded natural functors.
*)

section \<open>Least Fixpoint (Datatype) Operation on Bounded Natural Functors\<close>

theory BNF_Least_Fixpoint
imports BNF_Fixpoint_Base
keywords
  "datatype" :: thy_defn and
  "datatype_compat" :: thy_defn
begin

lemma subset_emptyI: "(\<And>x. x \<in> A \<Longrightarrow> False) \<Longrightarrow> A \<subseteq> {}"
  by blast

lemma image_Collect_subsetI: "(\<And>x. P x \<Longrightarrow> f x \<in> B) \<Longrightarrow> f ` {x. P x} \<subseteq> B"
  by blast

lemma Collect_restrict: "{x. x \<in> X \<and> P x} \<subseteq> X"
  by auto

lemma prop_restrict: "\<lbrakk>x \<in> Z; Z \<subseteq> {x. x \<in> X \<and> P x}\<rbrakk> \<Longrightarrow> P x"
  by auto

lemma underS_I: "\<lbrakk>i \<noteq> j; (i, j) \<in> R\<rbrakk> \<Longrightarrow> i \<in> underS R j"
  unfolding underS_def by simp

lemma underS_E: "i \<in> underS R j \<Longrightarrow> i \<noteq> j \<and> (i, j) \<in> R"
  unfolding underS_def by simp

lemma underS_Field: "i \<in> underS R j \<Longrightarrow> i \<in> Field R"
  unfolding underS_def Field_def by auto

lemma ex_bij_betw: "|A| \<le>o (r :: 'b rel) \<Longrightarrow> \<exists>f B :: 'b set. bij_betw f B A"
  by (subst (asm) internalize_card_of_ordLeq) (auto dest!: iffD2[OF card_of_ordIso ordIso_symmetric])

lemma bij_betwI':
  "\<lbrakk>\<And>x y. \<lbrakk>x \<in> X; y \<in> X\<rbrakk> \<Longrightarrow> (f x = f y) = (x = y);
    \<And>x. x \<in> X \<Longrightarrow> f x \<in> Y;
    \<And>y. y \<in> Y \<Longrightarrow> \<exists>x \<in> X. y = f x\<rbrakk> \<Longrightarrow> bij_betw f X Y"
  unfolding bij_betw_def inj_on_def by blast

lemma surj_fun_eq:
  assumes surj_on: "f ` X = UNIV" and eq_on: "\<forall>x \<in> X. (g1 \<circ> f) x = (g2 \<circ> f) x"
  shows "g1 = g2"
proof (rule ext)
  fix y
  from surj_on obtain x where "x \<in> X" and "y = f x" by blast
  thus "g1 y = g2 y" using eq_on by simp
qed

lemma Card_order_wo_rel: "Card_order r \<Longrightarrow> wo_rel r"
  unfolding wo_rel_def card_order_on_def by blast

lemma Cinfinite_limit: "\<lbrakk>x \<in> Field r; Cinfinite r\<rbrakk> \<Longrightarrow> \<exists>y \<in> Field r. x \<noteq> y \<and> (x, y) \<in> r"
  unfolding cinfinite_def by (auto simp add: infinite_Card_order_limit)

lemma Card_order_trans:
  "\<lbrakk>Card_order r; x \<noteq> y; (x, y) \<in> r; y \<noteq> z; (y, z) \<in> r\<rbrakk> \<Longrightarrow> x \<noteq> z \<and> (x, z) \<in> r"
  unfolding card_order_on_def well_order_on_def linear_order_on_def
    partial_order_on_def preorder_on_def trans_def antisym_def by blast

lemma Cinfinite_limit2:
  assumes x1: "x1 \<in> Field r" and x2: "x2 \<in> Field r" and r: "Cinfinite r"
  shows "\<exists>y \<in> Field r. (x1 \<noteq> y \<and> (x1, y) \<in> r) \<and> (x2 \<noteq> y \<and> (x2, y) \<in> r)"
proof -
  from r have trans: "trans r" and total: "Total r" and antisym: "antisym r"
    unfolding card_order_on_def well_order_on_def linear_order_on_def
      partial_order_on_def preorder_on_def by auto
  obtain y1 where y1: "y1 \<in> Field r" "x1 \<noteq> y1" "(x1, y1) \<in> r"
    using Cinfinite_limit[OF x1 r] by blast
  obtain y2 where y2: "y2 \<in> Field r" "x2 \<noteq> y2" "(x2, y2) \<in> r"
    using Cinfinite_limit[OF x2 r] by blast
  show ?thesis
  proof (cases "y1 = y2")
    case True with y1 y2 show ?thesis by blast
  next
    case False
    with y1(1) y2(1) total have "(y1, y2) \<in> r \<or> (y2, y1) \<in> r"
      unfolding total_on_def by auto
    thus ?thesis
    proof
      assume *: "(y1, y2) \<in> r"
      with trans y1(3) have "(x1, y2) \<in> r" unfolding trans_def by blast
      with False y1 y2 * antisym show ?thesis by (cases "x1 = y2") (auto simp: antisym_def)
    next
      assume *: "(y2, y1) \<in> r"
      with trans y2(3) have "(x2, y1) \<in> r" unfolding trans_def by blast
      with False y1 y2 * antisym show ?thesis by (cases "x2 = y1") (auto simp: antisym_def)
    qed
  qed
qed

lemma Cinfinite_limit_finite:
  "\<lbrakk>finite X; X \<subseteq> Field r; Cinfinite r\<rbrakk> \<Longrightarrow> \<exists>y \<in> Field r. \<forall>x \<in> X. (x \<noteq> y \<and> (x, y) \<in> r)"
proof (induct X rule: finite_induct)
  case empty thus ?case unfolding cinfinite_def using ex_in_conv[of "Field r"] finite.emptyI by auto
next
  case (insert x X)
  then obtain y where y: "y \<in> Field r" "\<forall>x \<in> X. (x \<noteq> y \<and> (x, y) \<in> r)" by blast
  then obtain z where z: "z \<in> Field r" "x \<noteq> z \<and> (x, z) \<in> r" "y \<noteq> z \<and> (y, z) \<in> r"
    using Cinfinite_limit2[OF _ y(1) insert(5), of x] insert(4) by blast
  show ?case
    apply (intro bexI ballI)
    apply (erule insertE)
    apply hypsubst
    apply (rule z(2))
    using Card_order_trans[OF insert(5)[THEN conjunct2]] y(2) z(3)
    apply blast
    apply (rule z(1))
    done
qed

lemma insert_subsetI: "\<lbrakk>x \<in> A; X \<subseteq> A\<rbrakk> \<Longrightarrow> insert x X \<subseteq> A"
  by auto

lemmas well_order_induct_imp = wo_rel.well_order_induct[of r "\<lambda>x. x \<in> Field r \<longrightarrow> P x" for r P]

lemma meta_spec2:
  assumes "(\<And>x y. PROP P x y)"
  shows "PROP P x y"
  by (rule assms)

lemma nchotomy_relcomppE:
  assumes "\<And>y. \<exists>x. y = f x" "(r OO s) a c" "\<And>b. r a (f b) \<Longrightarrow> s (f b) c \<Longrightarrow> P"
  shows P
proof (rule relcompp.cases[OF assms(2)], hypsubst)
  fix b assume "r a b" "s b c"
  moreover from assms(1) obtain b' where "b = f b'" by blast
  ultimately show P by (blast intro: assms(3))
qed

lemma predicate2D_vimage2p: "\<lbrakk>R \<le> vimage2p f g S; R x y\<rbrakk> \<Longrightarrow> S (f x) (g y)"
  unfolding vimage2p_def by auto

lemma ssubst_Pair_rhs: "\<lbrakk>(r, s) \<in> R; s' = s\<rbrakk> \<Longrightarrow> (r, s') \<in> R"
  by (rule ssubst)

lemma all_mem_range1:
  "(\<And>y. y \<in> range f \<Longrightarrow> P y) \<equiv> (\<And>x. P (f x)) "
  by (rule equal_intr_rule) fast+

lemma all_mem_range2:
  "(\<And>fa y. fa \<in> range f \<Longrightarrow> y \<in> range fa \<Longrightarrow> P y) \<equiv> (\<And>x xa. P (f x xa))"
  by (rule equal_intr_rule) fast+

lemma all_mem_range3:
  "(\<And>fa fb y. fa \<in> range f \<Longrightarrow> fb \<in> range fa \<Longrightarrow> y \<in> range fb \<Longrightarrow> P y) \<equiv> (\<And>x xa xb. P (f x xa xb))"
  by (rule equal_intr_rule) fast+

lemma all_mem_range4:
  "(\<And>fa fb fc y. fa \<in> range f \<Longrightarrow> fb \<in> range fa \<Longrightarrow> fc \<in> range fb \<Longrightarrow> y \<in> range fc \<Longrightarrow> P y) \<equiv>
   (\<And>x xa xb xc. P (f x xa xb xc))"
  by (rule equal_intr_rule) fast+

lemma all_mem_range5:
  "(\<And>fa fb fc fd y. fa \<in> range f \<Longrightarrow> fb \<in> range fa \<Longrightarrow> fc \<in> range fb \<Longrightarrow> fd \<in> range fc \<Longrightarrow>
     y \<in> range fd \<Longrightarrow> P y) \<equiv>
   (\<And>x xa xb xc xd. P (f x xa xb xc xd))"
  by (rule equal_intr_rule) fast+

lemma all_mem_range6:
  "(\<And>fa fb fc fd fe ff y. fa \<in> range f \<Longrightarrow> fb \<in> range fa \<Longrightarrow> fc \<in> range fb \<Longrightarrow> fd \<in> range fc \<Longrightarrow>
     fe \<in> range fd \<Longrightarrow> ff \<in> range fe \<Longrightarrow> y \<in> range ff \<Longrightarrow> P y) \<equiv>
   (\<And>x xa xb xc xd xe xf. P (f x xa xb xc xd xe xf))"
  by (rule equal_intr_rule) (fastforce, fast)

lemma all_mem_range7:
  "(\<And>fa fb fc fd fe ff fg y. fa \<in> range f \<Longrightarrow> fb \<in> range fa \<Longrightarrow> fc \<in> range fb \<Longrightarrow> fd \<in> range fc \<Longrightarrow>
     fe \<in> range fd \<Longrightarrow> ff \<in> range fe \<Longrightarrow> fg \<in> range ff \<Longrightarrow> y \<in> range fg \<Longrightarrow> P y) \<equiv>
   (\<And>x xa xb xc xd xe xf xg. P (f x xa xb xc xd xe xf xg))"
  by (rule equal_intr_rule) (fastforce, fast)

lemma all_mem_range8:
  "(\<And>fa fb fc fd fe ff fg fh y. fa \<in> range f \<Longrightarrow> fb \<in> range fa \<Longrightarrow> fc \<in> range fb \<Longrightarrow> fd \<in> range fc \<Longrightarrow>
     fe \<in> range fd \<Longrightarrow> ff \<in> range fe \<Longrightarrow> fg \<in> range ff \<Longrightarrow> fh \<in> range fg \<Longrightarrow> y \<in> range fh \<Longrightarrow> P y) \<equiv>
   (\<And>x xa xb xc xd xe xf xg xh. P (f x xa xb xc xd xe xf xg xh))"
  by (rule equal_intr_rule) (fastforce, fast)

lemmas all_mem_range = all_mem_range1 all_mem_range2 all_mem_range3 all_mem_range4 all_mem_range5
  all_mem_range6 all_mem_range7 all_mem_range8

lemma pred_fun_True_id: "NO_MATCH id p \<Longrightarrow> pred_fun (\<lambda>x. True) p f = pred_fun (\<lambda>x. True) id (p \<circ> f)"
  unfolding fun.pred_map unfolding comp_def id_def ..

ML_file \<open>Tools/BNF/bnf_lfp_util.ML\<close>
ML_file \<open>Tools/BNF/bnf_lfp_tactics.ML\<close>
ML_file \<open>Tools/BNF/bnf_lfp.ML\<close>
ML_file \<open>Tools/BNF/bnf_lfp_compat.ML\<close>
ML_file \<open>Tools/BNF/bnf_lfp_rec_sugar_more.ML\<close>
ML_file \<open>Tools/BNF/bnf_lfp_size.ML\<close>

ML_file \<open>Tools/datatype_simprocs.ML\<close>

simproc_setup datatype_no_proper_subterm
  ("(x :: 'a :: size) = y") = \<open>K Datatype_Simprocs.no_proper_subterm_simproc\<close>

end


(*  Title:      HOL/MicroJava/BV/EffectMono.thy
    Author:     Gerwin Klein
    Copyright   2000 Technische Universitaet Muenchen
*)

section {* Monotonicity of eff and app *}

theory EffectMono
imports Effect
begin

lemma PrimT_PrimT: "(G \<turnstile> xb \<preceq> PrimT p) = (xb = PrimT p)"
  by (auto elim: widen.cases)

lemma sup_loc_some [rule_format]:
"\<forall>y n. (G \<turnstile> b <=l y) \<longrightarrow> n < length y \<longrightarrow> y!n = OK t \<longrightarrow>
  (\<exists>t. b!n = OK t \<and> (G \<turnstile> (b!n) <=o (y!n)))"
proof (induct b)
  case Nil
  show ?case by simp
next
  case (Cons a list)
  show ?case
  proof (clarsimp simp add: list_all2_Cons1 sup_loc_def Listn.le_def lesub_def)
    fix z zs n
    assume *:
      "G \<turnstile> a <=o z" "list_all2 (sup_ty_opt G) list zs"
      "n < Suc (length list)" "(z # zs) ! n = OK t"

    show "(\<exists>t. (a # list) ! n = OK t) \<and> G \<turnstile>(a # list) ! n <=o OK t"
    proof (cases n)
      case 0
      with * show ?thesis by (simp add: sup_ty_opt_OK)
    next
      case Suc
      with Cons *
      show ?thesis by (simp add: sup_loc_def Listn.le_def lesub_def)
    qed
  qed
qed

lemma all_widen_is_sup_loc:
"\<forall>b. length a = length b \<longrightarrow>
     (\<forall>(x, y)\<in>set (zip a b). G \<turnstile> x \<preceq> y) = (G \<turnstile> (map OK a) <=l (map OK b))"
 (is "\<forall>b. length a = length b \<longrightarrow> ?Q a b" is "?P a")
proof (induct "a")
  show "?P []" by simp

  fix l ls assume Cons: "?P ls"

  show "?P (l#ls)"
  proof (intro allI impI)
    fix b
    assume "length (l # ls) = length (b::ty list)"
    with Cons
    show "?Q (l # ls) b" by - (cases b, auto)
  qed
qed

lemma append_length_n [rule_format]:
"\<forall>n. n \<le> length x \<longrightarrow> (\<exists>a b. x = a@b \<and> length a = n)"
proof (induct x)
  case Nil
  show ?case by simp
next
  case (Cons l ls)

  show ?case
  proof (intro allI impI)
    fix n
    assume l: "n \<le> length (l # ls)"

    show "\<exists>a b. l # ls = a @ b \<and> length a = n"
    proof (cases n)
      assume "n=0" thus ?thesis by simp
    next
      fix n' assume s: "n = Suc n'"
      with l have  "n' \<le> length ls" by simp
      hence "\<exists>a b. ls = a @ b \<and> length a = n'" by (rule Cons [rule_format])
      then obtain a b where "ls = a @ b" "length a = n'" by iprover
      with s have "l # ls = (l#a) @ b \<and> length (l#a) = n" by simp
      thus ?thesis by blast
    qed
  qed
qed

lemma rev_append_cons:
"n < length x \<Longrightarrow> \<exists>a b c. x = (rev a) @ b # c \<and> length a = n"
proof -
  assume n: "n < length x"
  hence "n \<le> length x" by simp
  hence "\<exists>a b. x = a @ b \<and> length a = n" by (rule append_length_n)
  then obtain r d where x: "x = r@d" "length r = n" by iprover
  with n have "\<exists>b c. d = b#c" by (simp add: neq_Nil_conv)
  then obtain b c where "d = b#c" by iprover
  with x have "x = (rev (rev r)) @ b # c \<and> length (rev r) = n" by simp
  thus ?thesis by blast
qed

lemma sup_loc_length_map:
  "G \<turnstile> map f a <=l map g b \<Longrightarrow> length a = length b"
proof -
  assume "G \<turnstile> map f a <=l map g b"
  hence "length (map f a) = length (map g b)" by (rule sup_loc_length)
  thus ?thesis by simp
qed

lemmas [iff] = not_Err_eq

lemma app_mono:
"\<lbrakk>G \<turnstile> s <=' s'; app i G m rT pc et s'\<rbrakk> \<Longrightarrow> app i G m rT pc et s"
proof -

  { fix s1 s2
    assume G:   "G \<turnstile> s2 <=s s1"
    assume app: "app i G m rT pc et (Some s1)"

    note [simp] = sup_loc_length sup_loc_length_map

    have "app i G m rT pc et (Some s2)"
    proof (cases i)
      case Load

      from G Load app
      have "G \<turnstile> snd s2 <=l snd s1" by (auto simp add: sup_state_conv)

      with G Load app show ?thesis
        by (cases s2) (auto simp add: sup_state_conv dest: sup_loc_some)
    next
      case Store
      with G app show ?thesis
        by (cases s2) (auto simp add: sup_loc_Cons2 sup_state_conv)
    next
      case LitPush
      with G app show ?thesis by (cases s2) (auto simp add: sup_state_conv)
    next
      case New
      with G app show ?thesis by (cases s2) (auto simp add: sup_state_conv)
    next
      case Getfield
      with app G show ?thesis
        by (cases s2) (clarsimp simp add: sup_state_Cons2, rule widen_trans)
    next
      case (Putfield vname cname)

      with app
      obtain vT oT ST LT b
        where s1: "s1 = (vT # oT # ST, LT)" and
                  "field (G, cname) vname = Some (cname, b)"
                  "is_class G cname" and
              oT: "G\<turnstile> oT\<preceq> (Class cname)" and
              vT: "G\<turnstile> vT\<preceq> b" and
              xc: "Ball (set (match G NullPointer pc et)) (is_class G)"
        by force
      moreover
      from s1 G
      obtain vT' oT' ST' LT'
        where s2:  "s2 = (vT' # oT' # ST', LT')" and
              oT': "G\<turnstile> oT' \<preceq> oT" and
              vT': "G\<turnstile> vT' \<preceq> vT"
        by - (cases s2, simp add: sup_state_Cons2, elim exE conjE, simp)
      moreover
      from vT' vT
      have "G \<turnstile> vT' \<preceq> b" by (rule widen_trans)
      moreover
      from oT' oT
      have "G\<turnstile> oT' \<preceq> (Class cname)" by (rule widen_trans)
      ultimately
      show ?thesis by (auto simp add: Putfield xc)
    next
      case Checkcast
      with app G show ?thesis
        by (cases s2) (auto intro!: widen_RefT2 simp add: sup_state_Cons2)
    next
      case Return
      with app G show ?thesis
        by (cases s2) (auto simp add: sup_state_Cons2, rule widen_trans)
    next
      case Pop
      with app G show ?thesis
        by (cases s2) (clarsimp simp add: sup_state_Cons2)
    next
      case Dup
      with app G show ?thesis
        by (cases s2) (clarsimp simp add: sup_state_Cons2,
            auto dest: sup_state_length)
    next
      case Dup_x1
      with app G show ?thesis
        by (cases s2) (clarsimp simp add: sup_state_Cons2,
            auto dest: sup_state_length)
    next
      case Dup_x2
      with app G show ?thesis
        by (cases s2) (clarsimp simp add: sup_state_Cons2,
            auto dest: sup_state_length)
    next
      case Swap
      with app G show ?thesis
        by (cases s2) (auto simp add: sup_state_Cons2)
    next
      case IAdd
      with app G show ?thesis
        by (cases s2) (auto simp add: sup_state_Cons2 PrimT_PrimT)
    next
      case Goto
      with app show ?thesis by simp
    next
      case Ifcmpeq
      with app G show ?thesis
        by (cases s2) (auto simp add: sup_state_Cons2 PrimT_PrimT widen_RefT2)
    next
      case (Invoke cname mname list)

      with app
      obtain apTs X ST LT mD' rT' b' where
        s1: "s1 = (rev apTs @ X # ST, LT)" and
        l:  "length apTs = length list" and
        c:  "is_class G cname" and
        C:  "G \<turnstile> X \<preceq> Class cname" and
        w:  "\<forall>(x, y) \<in> set (zip apTs list). G \<turnstile> x \<preceq> y" and
        m:  "method (G, cname) (mname, list) = Some (mD', rT', b')" and
        x:  "\<forall>C \<in> set (match_any G pc et). is_class G C"
        by (simp del: not_None_eq, elim exE conjE) (rule that)

      obtain apTs' X' ST' LT' where
        s2: "s2 = (rev apTs' @ X' # ST', LT')" and
        l': "length apTs' = length list"
      proof -
        from l s1 G
        have "length list < length (fst s2)"
          by simp
        hence "\<exists>a b c. (fst s2) = rev a @ b # c \<and> length a = length list"
          by (rule rev_append_cons [rule_format])
        thus ?thesis
          by (cases s2) (elim exE conjE, simp, rule that)
      qed

      from l l'
      have "length (rev apTs') = length (rev apTs)" by simp

      from this s1 s2 G
      obtain
        G': "G \<turnstile> (apTs',LT') <=s (apTs,LT)" and
        X : "G \<turnstile>  X' \<preceq> X" and "G \<turnstile> (ST',LT') <=s (ST,LT)"
        by (simp add: sup_state_rev_fst sup_state_append_fst sup_state_Cons1)

      with C
      have C': "G \<turnstile> X' \<preceq> Class cname"
        by - (rule widen_trans, auto)

      from G'
      have "G \<turnstile> map OK apTs' <=l map OK apTs"
        by (simp add: sup_state_conv)
      also
      from l w
      have "G \<turnstile> map OK apTs <=l map OK list"
        by (simp add: all_widen_is_sup_loc)
      finally
      have "G \<turnstile> map OK apTs' <=l map OK list" .

      with l'
      have w': "\<forall>(x, y) \<in> set (zip apTs' list). G \<turnstile> x \<preceq> y"
        by (simp add: all_widen_is_sup_loc)

      from Invoke s2 l' w' C' m c x
      show ?thesis
        by (simp del: split_paired_Ex) blast
    next
      case Throw
      with app G show ?thesis
        by (cases s2, clarsimp simp add: sup_state_Cons2 widen_RefT2)
    qed
  } note this [simp]

  assume "G \<turnstile> s <=' s'" "app i G m rT pc et s'"
  thus ?thesis by (cases s, cases s', auto)
qed

lemmas [simp del] = split_paired_Ex

lemma eff'_mono:
"\<lbrakk> app i G m rT pc et (Some s2); G \<turnstile> s1 <=s s2 \<rbrakk> \<Longrightarrow>
  G \<turnstile> eff' (i,G,s1) <=s eff' (i,G,s2)"
proof (cases s1, cases s2)
  fix a1 b1 a2 b2
  assume s: "s1 = (a1,b1)" "s2 = (a2,b2)"
  assume app2: "app i G m rT pc et (Some s2)"
  assume G: "G \<turnstile> s1 <=s s2"

  note [simp] = eff_def

  with G have "G \<turnstile> (Some s1) <=' (Some s2)" by simp
  from this app2
  have app1: "app i G m rT pc et (Some s1)" by (rule app_mono)

  show ?thesis
  proof (cases i)
    case (Load n)

    with s app1
    obtain y where
       y:  "n < length b1" "b1 ! n = OK y" by clarsimp

    from Load s app2
    obtain y' where
       y': "n < length b2" "b2 ! n = OK y'" by clarsimp

    from G s
    have "G \<turnstile> b1 <=l b2" by (simp add: sup_state_conv)

    with y y'
    have "G \<turnstile> y \<preceq> y'"
      by - (drule sup_loc_some, simp+)

    with Load G y y' s app1 app2
    show ?thesis by (clarsimp simp add: sup_state_conv)
  next
    case Store
    with G s app1 app2
    show ?thesis
      by (clarsimp simp add: sup_state_conv sup_loc_update)
  next
    case LitPush
    with G s app1 app2
    show ?thesis
      by (clarsimp simp add: sup_state_Cons1)
  next
    case New
    with G s app1 app2
    show ?thesis
      by (clarsimp simp add: sup_state_Cons1)
  next
    case Getfield
    with G s app1 app2
    show ?thesis
      by (clarsimp simp add: sup_state_Cons1)
  next
    case Putfield
    with G s app1 app2
    show ?thesis
      by (clarsimp simp add: sup_state_Cons1)
  next
    case Checkcast
    with G s app1 app2
    show ?thesis
      by (clarsimp simp add: sup_state_Cons1)
  next
    case (Invoke cname mname list)

    with s app1
    obtain a X ST where
      s1: "s1 = (a @ X # ST, b1)" and
      l:  "length a = length list"
      by (simp, elim exE conjE, simp (no_asm_simp))

    from Invoke s app2
    obtain a' X' ST' where
      s2: "s2 = (a' @ X' # ST', b2)" and
      l': "length a' = length list"
      by (simp, elim exE conjE, simp (no_asm_simp))

    from l l'
    have lr: "length a = length a'" by simp

    from lr G s1 s2
    have "G \<turnstile> (ST, b1) <=s (ST', b2)"
      by (simp add: sup_state_append_fst sup_state_Cons1)

    moreover

    obtain b1' b2' where eff':
      "b1' = snd (eff' (i,G,s1))"
      "b2' = snd (eff' (i,G,s2))" by simp

    from Invoke G s eff' app1 app2
    obtain "b1 = b1'" "b2 = b2'" by simp

    ultimately

    have "G \<turnstile> (ST, b1') <=s (ST', b2')" by simp

    with Invoke G s app1 app2 eff' s1 s2 l l'
    show ?thesis
      by (clarsimp simp add: sup_state_conv)
  next
    case Return
    with G
    show ?thesis
      by simp
  next
    case Pop
    with G s app1 app2
    show ?thesis
      by (clarsimp simp add: sup_state_Cons1)
  next
    case Dup
    with G s app1 app2
    show ?thesis
      by (clarsimp simp add: sup_state_Cons1)
  next
    case Dup_x1
    with G s app1 app2
    show ?thesis
      by (clarsimp simp add: sup_state_Cons1)
  next
    case Dup_x2
    with G s app1 app2
    show ?thesis
      by (clarsimp simp add: sup_state_Cons1)
  next
    case Swap
    with G s app1 app2
    show ?thesis
      by (clarsimp simp add: sup_state_Cons1)
  next
    case IAdd
    with G s app1 app2
    show ?thesis
      by (clarsimp simp add: sup_state_Cons1)
  next
    case Goto
    with G s app1 app2
    show ?thesis by simp
  next
    case Ifcmpeq
    with G s app1 app2
    show ?thesis
      by (clarsimp simp add: sup_state_Cons1)
  next
    case Throw
    with G
    show ?thesis
      by simp
  qed
qed

lemmas [iff del] = not_Err_eq

end


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

(*
 * Facts about recursive functions with measure parameter.
 * Any recursive functions from AutoCorres are monotonic in the measure,
 * which allows us to use the "measure_call" mechanism for calling them.
 *)
theory MonadMono
imports
  NonDetMonadEx
  "Lib.OptionMonadWP"
begin

(*
 * Call function f by returning all of its possible results.
 * The call succeeds if any measure value succeeds.
 *)
definition "measure_call f \<equiv>
    \<lambda>s. ({(r', s'). \<exists>m. (r', s') \<in> fst (f m s)}, \<forall>m. snd (f m s))"

(*
 * monad_mono gives preconditions for functions so that measure_call will
 * return meaningful results.
 *
 * The preconditions are:
 *
 * - If the measure is increased, the function never returns fewer
 *   results. (Monotonicity condition)
 *
 * - If the function succeeds with some measure, it will not fail with
 *   a larger measure, and will return exactly the same results.
 *
 * The monotonicity condition is technically not needed, but all our
 * functions satisfy it anyway and it makes intermediate proofs easier.
 *)
definition "monad_mono f \<equiv>
     (\<forall>(x :: nat) y s. x < y \<longrightarrow>
         (fst (f x s) \<subseteq> fst (f y s) \<and>
          (\<not> snd (f x s) \<longrightarrow> \<not> snd (f y s) \<and> fst (f x s) = fst (f y s))))"

(* Basic monad_mono lemmas *)
lemma monad_mono_incl: "\<lbrakk> monad_mono f; \<not> snd (f m s) \<rbrakk> \<Longrightarrow> fst (f m' s) \<subseteq> fst (f m s)"
  using less_linear[where x = m and y = m']
  by (auto simp: monad_mono_def)

(* wp rules for function calls *)
lemma call_all_valid [wp]:
    "\<lbrakk> \<forall> m. valid P (x m) Q; monad_mono x \<rbrakk> \<Longrightarrow> valid P (measure_call x) Q"
  apply (clarsimp simp: valid_def measure_call_def monad_mono_def)
  by blast

lemma call_all_validNF [wp]:
    "\<lbrakk>  validNF P (x m) Q; monad_mono x \<rbrakk> \<Longrightarrow> validNF P (measure_call x) Q"
  apply (clarsimp simp: measure_call_def validNF_def valid_def no_fail_def)
  apply (metis in_mono split_conv monad_mono_incl)
  done

(* Alternative definition of monad_mono, suitable for induction *)
definition "monad_mono_step f m \<equiv>
  (\<forall>s. fst (f m s) \<subseteq> fst (f (Suc m) s) \<and>
       (\<not> snd (f m s) \<longrightarrow> \<not> snd (f (Suc m) s) \<and> fst (f m s) = fst (f (Suc m) s)))"

lemma monad_mono_alt_def: "monad_mono f = (\<forall>m. monad_mono_step f m)"
  apply (rule iffI)
   apply (fastforce simp: monad_mono_def monad_mono_step_def)
  apply (unfold monad_mono_def monad_mono_step_def)
  apply clarify
  apply (subst (asm) atomize_all[symmetric])+
  proof -
    fix x y :: nat
    fix s
    assume suc: "\<And>m s. fst (f m s) \<subseteq> fst (f (Suc m) s) \<and>
              (\<not> snd (f m s) \<longrightarrow> \<not> snd (f (Suc m) s) \<and> fst (f m s) = fst (f (Suc m) s))"
       and less: "x < y"
    thus "fst (f x s) \<subseteq> fst (f y s) \<and>
          (\<not> snd (f x s) \<longrightarrow> \<not> snd (f y s) \<and> fst (f x s) = fst (f y s))"
      apply (induct x)
       apply (induct y)
        apply blast
       apply blast
      (* induct bureaucracy... *)
      proof -
        fix x :: nat
        assume less: "Suc x < y"
        thus "fst (f (Suc x) s) \<subseteq> fst (f y s) \<and>
           (\<not> snd (f (Suc x) s) \<longrightarrow> \<not> snd (f y s) \<and> fst (f (Suc x) s) = fst (f y s))"
          apply (induct y)
           apply blast
          apply (case_tac "Suc x < y")
           using suc apply blast
          apply (case_tac "Suc x = y")
           using suc apply blast
          apply simp
          done
       qed
  qed

lemmas monad_mono_step = iffD2[OF monad_mono_alt_def, rule_format]

lemma monad_mono_step_const: "monad_mono_step (\<lambda>_. f) m"
  by (simp add: monad_mono_step_def)

(* nondet_monad rules *)
lemma monad_mono_step_in_monad:
  "\<lbrakk> monad_mono_step f m; (r', s') \<in> fst (f m s) \<rbrakk> \<Longrightarrow> (r', s') \<in> fst (f (Suc m) s)"
  apply (clarsimp simp: monad_mono_step_def)
  apply blast
  done

lemma monad_mono_step_snd_monad:
  "\<lbrakk> monad_mono_step f m; \<not> snd (f m s) \<rbrakk> \<Longrightarrow> \<not> snd (f (Suc m) s)"
  by (clarsimp simp: monad_mono_step_def)

lemma monad_mono_step_bexI:
  "\<lbrakk> monad_mono_step f m; (r', s') \<in> fst (f m s); P r' s' \<rbrakk> \<Longrightarrow> \<exists>(r', s') \<in> fst (f (Suc m) s). P r' s'"
  apply (drule (1) monad_mono_step_in_monad)
  apply force
  done

lemma monad_mono_stepI [intro]:
  "\<lbrakk> \<And>s r' s'. (r', s') \<in> fst (f m s) \<Longrightarrow> (r', s') \<in> fst (f (Suc m) s);
     \<And>s. \<not> snd (f m s) \<Longrightarrow> \<not> snd (f (Suc m) s);
     \<And>s r' s'. \<lbrakk> \<not> snd (f m s); \<not> snd (f (Suc m) s); (r', s') \<in> fst (f (Suc m) s) \<rbrakk>
                \<Longrightarrow> (r', s') \<in> fst (f m s)
   \<rbrakk> \<Longrightarrow> monad_mono_step f m"
  apply (clarsimp simp: monad_mono_step_def)
  apply fast
  done

lemma monad_mono_step_bind:
  "\<lbrakk> monad_mono_step f m; \<And>x. monad_mono_step (\<lambda>m. g m x) m \<rbrakk>
   \<Longrightarrow> monad_mono_step (\<lambda>m. (f m) >>= (g m)) m"
  apply atomize
  apply rule
    apply (monad_eq)
    apply (metis monad_mono_step_in_monad)
   apply (monad_eq simp: Ball_def)
   apply (metis monad_mono_step_def)
  apply (monad_eq simp: Ball_def)
  apply (unfold monad_mono_step_def)
  apply blast
  done

lemma monad_mono_step_bindE:
  "\<lbrakk> monad_mono_step f m; \<And>x. monad_mono_step (\<lambda>m. g m x) m \<rbrakk>
   \<Longrightarrow> monad_mono_step (\<lambda>m. (f m) >>=E (g m)) m"
  apply (unfold bindE_def)
  apply (rule monad_mono_step_bind)
   apply simp
  apply (monad_eq simp: monad_mono_step_def NonDetMonad.lift_def
      split: sum.splits)
  done

lemma monad_mono_step_liftE:
  "monad_mono_step f m \<Longrightarrow> monad_mono_step (\<lambda>m. liftE (f m)) m"
  apply (unfold liftE_def)
  apply (erule monad_mono_step_bind)
  apply (rule monad_mono_step_const)
  done

lemma monad_mono_step_handleE':
  "\<lbrakk> monad_mono_step f m; \<And>x. monad_mono_step (\<lambda>m. g m x) m \<rbrakk>
   \<Longrightarrow> monad_mono_step (\<lambda>m. f m <handle2> g m) m"
  apply atomize
  apply rule
    apply (monad_eq)
    apply (metis monad_mono_step_in_monad)
   apply (monad_eq simp: Ball_def)
   apply (metis monad_mono_step_def)
  apply (monad_eq simp: Ball_def)
  apply (fastforce simp: monad_mono_step_def)
  done

lemma monad_mono_step_handleE:
  "\<lbrakk> monad_mono_step f m; \<And>x. monad_mono_step (\<lambda>m. g m x) m \<rbrakk>
   \<Longrightarrow> monad_mono_step (\<lambda>m. f m <handle> g m) m"
  by (simp add: handleE_def monad_mono_step_handleE')

lemma monad_mono_step_condition:
  "\<lbrakk> monad_mono_step f m; monad_mono_step g m \<rbrakk>
   \<Longrightarrow> monad_mono_step (\<lambda>m. condition C (f m) (g m)) m"
  apply rule
    apply (monad_eq simp: monad_mono_step_def, blast)+
  done

lemma fst_whileLoop_is_exs_valid:
  "((a, b) \<in> fst (whileLoop C B i s)) = \<lbrace> \<lambda>s'. s' = s \<rbrace> whileLoop C B i \<exists>\<lbrace> \<lambda>rv s. rv = a \<and> s = b \<rbrace>"
  by (clarsimp simp: exs_valid_def Bex_def)

lemma not_snd_whileLoop_is_validNF:
  "(\<not> snd (whileLoop C B i s)) = \<lbrace> \<lambda>s'. s' = s \<rbrace> whileLoop C B i \<lbrace> \<lambda>_ _. True \<rbrace>!"
  by (clarsimp simp: validNF_alt_def)

lemma monad_mono_step_whileLoop:
  assumes body_mono: "\<And>x. monad_mono_step (\<lambda>m. B m x) m"
  shows "monad_mono_step (\<lambda>m. whileLoop C (B m) i) m"
proof -
  {
    fix a b s
    have "(a, b) \<in> fst (whileLoop C (B m) i s) \<Longrightarrow>
             (a, b) \<in> fst (whileLoop C (B (Suc m)) i s)"
      apply (clarsimp simp: fst_whileLoop_is_exs_valid)
      apply (subst (asm) exs_valid_whileLoop_complete [symmetric])
      apply (erule exE | erule conjE)+
      apply (rule_tac T=T and R=R in exs_valid_whileLoop)
         apply clarsimp
        apply (cut_tac x=r in body_mono)
        apply (clarsimp simp: monad_mono_step_def exs_valid_def split_def)
        apply blast
       apply simp
      apply blast
      done
  }
  note A = this

  {
    fix a b s
    have "\<lbrakk> \<not> snd (whileLoop C (B m) i s);
                  (a, b) \<in> fst (whileLoop C (B (Suc m)) i s) \<rbrakk>
              \<Longrightarrow> (a, b) \<in> fst (whileLoop C (B m) i s)"
      apply (clarsimp simp: fst_whileLoop_is_exs_valid)
      apply (subst (asm) exs_valid_whileLoop_complete [symmetric])
      apply (subst (asm) not_snd_whileLoop_complete)
      apply (erule exE | erule conjE)+
      apply (rule_tac T="\<lambda>r s. T r s \<and> I r s" and R=Ra in exs_valid_whileLoop)
         apply simp
        apply (cut_tac x=r in body_mono)
        apply (clarsimp simp: monad_mono_step_def exs_valid_def split_def Bex_def)
        apply metis
       apply simp
      apply (clarsimp simp: exs_valid_def Bex_def)
      done
  }
  note B = this

  {
    fix i s
    have "\<lbrakk>\<not> snd (whileLoop C (B m) i s) \<rbrakk> \<Longrightarrow>
                  \<not> snd (whileLoop C (B (Suc m)) i s)"
      apply (subst (asm) not_snd_whileLoop_complete)
      apply (erule exE | erule conjE)+
      apply (rule_tac I="I" and R=R in not_snd_whileLoop)
        apply clarsimp
       apply (cut_tac x=r in body_mono)
       apply (clarsimp simp: monad_mono_step_def validNF_alt_def)
       apply blast
      apply simp
      done
  }
  note C = this

  show ?thesis
    apply (clarsimp simp: monad_mono_step_def)
    apply (metis prod.exhaust subsetI subset_antisym A B C)
    done
qed

lemma monad_mono_step_whileLoopE:
  "\<lbrakk> \<And>x. monad_mono_step (\<lambda>m. B m x) m \<rbrakk>
   \<Longrightarrow> monad_mono_step (\<lambda>m. whileLoopE C (B m) i) m"
  apply (unfold whileLoopE_def)
  apply (subgoal_tac "\<And>x. monad_mono_step (\<lambda>m. lift (B m) x) m")
  apply (erule monad_mono_step_whileLoop)
  apply (unfold lift_def)
  apply rule
    apply (clarsimp split: prod.splits sum.splits)
    apply (fastforce dest: monad_mono_step_in_monad)
   apply (clarsimp split: prod.splits sum.splits simp: monad_mono_step_def)+
  done

(* measure_call for the option monad. *)
definition "measure_ocall f \<equiv> \<lambda>s. f (SOME m. f m s \<noteq> None) s"

definition "option_monad_mono f \<equiv>
  \<forall>(x :: nat) y s. x < y \<longrightarrow>
    (case f y s of None \<Rightarrow> f x s = None
                 | Some r \<Rightarrow> f x s = None \<or> f x s = Some r)"

lemma option_monad_mono_eq:
  "(\<And>m. f m = gets_the (f' m)) \<Longrightarrow> monad_mono f = option_monad_mono f'"
  apply (clarsimp simp: monad_mono_def option_monad_mono_def gets_the_def
    gets_def get_def assert_opt_def return_def fail_def bind_def' split: option.splits)
  apply (rule iff_allI iff_impI)+
  apply (rule_tac t = "\<forall>r. f' x s = Some r \<longrightarrow> (\<exists>r'. f' y s = Some r') \<and> (\<forall>r'. f' y s = Some r' \<longrightarrow> r = r')"
              and s = "\<forall>r. f' x s = Some r \<longrightarrow> f' y s = Some r" in subst)
   apply (force intro: iff_allI iff_impI)
  apply (rule iffI)
   apply (metis (hide_lams, no_types) option.exhaust)
  apply force
  done

lemma measure_ocall_ovalid [wp]:
    "\<lbrakk> \<forall> m. ovalid P (x m) Q; option_monad_mono x \<rbrakk> \<Longrightarrow> ovalid P (measure_ocall x) Q"
  by (clarsimp simp: ovalid_def measure_ocall_def option_monad_mono_def)

lemma measure_ocall_ovalidNF [wp]:
    "\<lbrakk> ovalidNF P (x m) Q; option_monad_mono x \<rbrakk> \<Longrightarrow> ovalidNF P (measure_ocall x) Q"
  apply (clarsimp simp: measure_ocall_def option_monad_mono_def ovalidNF_def)
  apply (rule_tac a = m in someI2)
   apply simp
  apply (metis (lifting, full_types) linorder_neqE_nat option.distinct(1) option.simps(5))
  done

end


(* Name is wrong, we do not have time here.
  But I should probably add it...
*)

theory Big_StepT_Ex
  imports Big_StepT "~~/src/HOL/Library/Simps_Case_Conv"
begin
function (sequential, domintros) big_step_function :: "(com \<times> state) \<Rightarrow> state" where
  "big_step_function (SKIP,s) = s" |
  "big_step_function (x ::= a,s) = s(x := aval a s)" |
  "big_step_function (c1;;c2, s1) = big_step_function (c2, big_step_function (c1,s1))" |
  "big_step_function (IF b \<noteq>0 THEN c1 ELSE c2, s) = (if s b \<noteq> 0 then big_step_function (c1,s) else big_step_function (c2,s))" |
  "big_step_function (WHILE b \<noteq>0 DO c,s) = (if s b \<noteq> 0 then big_step_function (c;; WHILE b \<noteq>0 DO c, s) else s)"
  by pat_completeness auto

print_theorems
(* Soundness and partial termination *)
lemma "(c,s) \<Rightarrow>\<^bsup>t\<^esup> s' \<Longrightarrow> big_step_function_dom (c,s) \<and> big_step_function (c,s) = s'"
  by (induction s t s' rule: big_step_t_induct)
    (auto simp add: big_step_function.domintros big_step_function.psimps)

(* Partial completeness? *)

(* Total termination not possible (WHILE b\<noteq>0 DO b ::= b+1). Therefore sadly no code equations *)

(* Instead, explicitly partial function: *)

partial_function (option) big_step_ex :: "(com\<times> state) \<Rightarrow> state option" where
  "big_step_ex cs = (case cs of (SKIP,s) \<Rightarrow> Some s | (x ::= a,s) \<Rightarrow> Some (s(x := aval a s))
    | (c1;;c2, s1) \<Rightarrow> Option.bind (big_step_ex (c1,s1)) (\<lambda>s. big_step_ex (c2, s))
    | (IF b \<noteq>0 THEN c1 ELSE c2, s) \<Rightarrow> (if s b \<noteq> 0 then big_step_ex (c1,s) else big_step_ex (c2,s))
    | (WHILE b \<noteq>0 DO c,s) \<Rightarrow> (if s b \<noteq> 0 then big_step_ex (c;; WHILE b \<noteq>0 DO c, s) else Some s))"

thm big_step_ex.simps
simps_of_case big_step_ex_simps[simp,code]: big_step_ex.simps

lemma big_step_ex_sound:"(c,s) \<Rightarrow>\<^bsup>t\<^esup> s' \<Longrightarrow> big_step_ex (c,s) = Some s'"
  by (induction s t s' rule: big_step_t_induct) auto

(* Horrible completeness proof *)

lemma WhileTrue': "\<lbrakk> s1 b \<noteq> 0; (c;; WHILE b \<noteq>0 DO c, s1) \<Rightarrow>\<^bsup> y \<^esup> s3; 1+y=z  \<rbrakk>
    \<Longrightarrow> (WHILE b \<noteq>0 DO c, s1) \<Rightarrow>\<^bsup> z \<^esup> s3" by auto
lemma WhileFalse': "\<lbrakk> s b = 0; s=s' \<rbrakk> \<Longrightarrow> (WHILE b \<noteq>0 DO c,s) \<Rightarrow>\<^bsup> Suc (Suc 0) \<^esup> s'"
  by auto

lemma assumes"big_step_ex (c,s) = Some s'" shows "\<exists>t . (c,s) \<Rightarrow>\<^bsup>t\<^esup> s'"
proof (induction arbitrary: t rule: big_step_ex.raw_induct[OF _ assms])
  case (1 big_step_ex cs csa)
  obtain c s where cs[simp]: "cs = (c,s)" by force

  consider "c = SKIP" "s = csa"
    | x a where "c = (x ::= a)" "csa = (s(x := aval a s))"
    | c1 c2 where "c = (c1;; c2)" "Some csa = Option.bind (big_step_ex (c1, s)) (\<lambda>s. big_step_ex (c2, s))"
    | b c1 c2 where "c = (IF b\<noteq>0 THEN c1 ELSE c2)"
      "Some csa = (if s b \<noteq> 0 then big_step_ex (c1, s) else big_step_ex (c2, s))"
    | b cb where  "c = (WHILE b\<noteq>0 DO cb)"
        "Some csa = (if s b \<noteq> 0 then big_step_ex (cb;; WHILE b\<noteq>0 DO cb, s) else Some s)"
    using 1(2)
    by (smt (verit, del_insts) case_prod_conv com.exhaust com.simps(25) com.simps(26) com.simps(27) com.simps(28) com.simps(29) cs option.inject)

  then show ?case
  proof(cases)
    case 1
    then show ?thesis by simp
  next
    case 2
    show ?thesis
      apply (subst cs) apply (subst 2(1)) apply (subst 2(2)) apply (rule exI)
      by (rule big_step_t.Assign)
  next
    case 3
    obtain s' where step: "big_step_ex (c1, s) = Some s'" "big_step_ex (c2, s') = Some csa"
      using "3"(2) by fastforce
    show ?thesis
      apply (rule exI) apply (subst cs) apply (subst 3(1))
      apply (rule Seq'[of _  _ _ s'])
      using 1(1)[OF step(1)] apply (rule exE_some) apply simp
      using 1(1)[OF step(2)] apply (rule exE_some) apply simp
      done
  next
    case 4
    have t: "big_step_ex (c1, s) = Some csa" if "s b \<noteq> 0"
      by (simp add: "4"(2) that)
    have f: "big_step_ex (c2, s) = Some csa" if "s b = 0"
      by (simp add: "4"(2) that)
    show ?thesis
    proof(subst cs, subst 4(1), cases "s b \<noteq> 0")
      case True
      show "\<exists>t. (IF b\<noteq>0 THEN c1 ELSE c2, s) \<Rightarrow>\<^bsup> t \<^esup> csa"
        apply (rule exI) apply (rule big_step_t.IfTrue)
          apply (fact True)
        using 1(1)[OF t, OF True] apply (rule exE_some) apply simp
        by simp
    next
      case False
      hence F: "s b = 0" by simp
      show "\<exists>t. (IF b\<noteq>0 THEN c1 ELSE c2, s) \<Rightarrow>\<^bsup> t \<^esup> csa"
        apply (rule exI) apply (rule big_step_t.IfFalse)
          apply (fact F)
        using 1(1)[OF f, OF F] apply (rule exE_some) apply simp
        by simp
    qed
  next
    case 5
    then show ?thesis
    proof(cases "s b \<noteq> 0")
      case True
      hence u: "big_step_ex (cb;; WHILE b\<noteq>0 DO cb, s) = Some csa"
        using "5"(2) by force
      show ?thesis apply (rule exI) apply (subst cs) apply (subst 5)
        apply (rule WhileTrue')
          apply (fact True)
        using 1(1)[OF u] apply (rule exE_some) apply simp
        by simp
    next
      case False
      hence False: "s b = 0" by simp
      show ?thesis apply (rule exI) apply (subst cs) apply (subst 5)
         apply (rule WhileFalse')
         apply (fact False)
        using "5"(2)
        by (metis False option.inject)

    qed
  qed
qed

end