(*  Title:      HOL/MicroJava/BV/JType.thy
    Author:     Tobias Nipkow, Gerwin Klein
    Copyright   2000 TUM
*)

section {* The Java Type System as Semilattice *}

theory JType
imports "../DFA/Semilattices" "../J/WellForm"
begin

definition super :: "'a prog \<Rightarrow> cname \<Rightarrow> cname" where
  "super G C == fst (the (class G C))"

lemma superI:
  "G \<turnstile> C \<prec>C1 D \<Longrightarrow> super G C = D"
  by (unfold super_def) (auto dest: subcls1D)

definition is_ref :: "ty \<Rightarrow> bool" where
  "is_ref T == case T of PrimT t \<Rightarrow> False | RefT r \<Rightarrow> True"

definition sup :: "'c prog \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> ty err" where
  "sup G T1 T2 ==
  case T1 of PrimT P1 \<Rightarrow> (case T2 of PrimT P2 \<Rightarrow>
                         (if P1 = P2 then OK (PrimT P1) else Err) | RefT R \<Rightarrow> Err)
           | RefT R1 \<Rightarrow> (case T2 of PrimT P \<Rightarrow> Err | RefT R2 \<Rightarrow>
  (case R1 of NullT \<Rightarrow> (case R2 of NullT \<Rightarrow> OK NT | ClassT C \<Rightarrow> OK (Class C))
            | ClassT C \<Rightarrow> (case R2 of NullT \<Rightarrow> OK (Class C)
                           | ClassT D \<Rightarrow> OK (Class (exec_lub (subcls1 G) (super G) C D)))))"

definition subtype :: "'c prog \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> bool" where
  "subtype G T1 T2 == G \<turnstile> T1 \<preceq> T2"

definition is_ty :: "'c prog \<Rightarrow> ty \<Rightarrow> bool" where
  "is_ty G T == case T of PrimT P \<Rightarrow> True | RefT R \<Rightarrow>
               (case R of NullT \<Rightarrow> True | ClassT C \<Rightarrow> (C, Object) \<in> (subcls1 G)^*)"

abbreviation "types G == Collect (is_type G)"

definition esl :: "'c prog \<Rightarrow> ty esl" where
  "esl G == (types G, subtype G, sup G)"

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

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

lemma is_tyI:
  "\<lbrakk> is_type G T; ws_prog G \<rbrakk> \<Longrightarrow> is_ty G T"
  by (auto simp add: is_ty_def intro: subcls_C_Object
           split: ty.splits ref_ty.splits)

lemma is_type_conv:
  "ws_prog G \<Longrightarrow> is_type G T = is_ty G T"
proof
  assume "is_type G T" "ws_prog G"
  thus "is_ty G T"
    by (rule is_tyI)
next
  assume wf: "ws_prog G" and
         ty: "is_ty G T"

  show "is_type G T"
  proof (cases T)
    case PrimT
    thus ?thesis by simp
  next
    fix R assume R: "T = RefT R"
    with wf
    have "R = ClassT Object \<Longrightarrow> ?thesis" by simp
    moreover
    from R wf ty
    have "R \<noteq> ClassT Object \<Longrightarrow> ?thesis"
     by (auto simp add: is_ty_def is_class_def split_tupled_all
               elim!: subcls1.cases
               elim: converse_rtranclE
               split: ref_ty.splits)
    ultimately
    show ?thesis by blast
  qed
qed

lemma order_widen:
  "acyclic (subcls1 G) \<Longrightarrow> order (subtype G)"
  apply (unfold Semilat.order_def lesub_def subtype_def)
  apply (auto intro: widen_trans)
  apply (case_tac x)
   apply (case_tac y)
    apply (auto simp add: PrimT_PrimT)
   apply (case_tac y)
    apply simp
  apply simp
  apply (rename_tac ref_ty ref_tya, case_tac ref_ty)
   apply (case_tac ref_tya)
    apply simp
   apply simp
  apply (case_tac ref_tya)
   apply simp
  apply simp
  apply (auto dest: acyclic_impl_antisym_rtrancl antisymD)
  done

lemma wf_converse_subcls1_impl_acc_subtype:
  "wf ((subcls1 G)^-1) \<Longrightarrow> acc (subtype G)"
apply (unfold Semilat.acc_def lesssub_def)
apply (drule_tac p = "((subcls1 G)^-1) - Id" in wf_subset)
 apply auto
apply (drule wf_trancl)
apply (simp add: wf_eq_minimal)
apply clarify
apply (unfold lesub_def subtype_def)
apply (rename_tac M T)
apply (case_tac "EX C. Class C : M")
 prefer 2
 apply (case_tac T)
  apply (fastforce simp add: PrimT_PrimT2)
 apply simp
 apply (rename_tac ref_ty)
 apply (subgoal_tac "ref_ty = NullT")
  apply simp
  apply (rule_tac x = NT in bexI)
   apply (rule allI)
   apply (rule impI, erule conjE)
   apply (drule widen_RefT)
   apply clarsimp
   apply (case_tac t)
    apply simp
   apply simp
  apply simp
 apply (case_tac ref_ty)
  apply simp
 apply simp
apply (erule_tac x = "{C. Class C : M}" in allE)
apply auto
apply (rename_tac D)
apply (rule_tac x = "Class D" in bexI)
 prefer 2
 apply assumption
apply clarify
apply (frule widen_RefT)
apply (erule exE)
apply (case_tac t)
 apply simp
apply simp
apply (insert rtrancl_r_diff_Id [symmetric, of "subcls1 G"])
apply simp
apply (erule rtrancl.cases)
 apply blast
apply (drule rtrancl_converseI)
apply (subgoal_tac "(subcls1 G - Id)^-1 = (subcls1 G)^-1 - Id")
 prefer 2
 apply (simp add: converse_Int) apply safe[1]
apply simp
apply (blast intro: rtrancl_into_trancl2)
done

lemma closed_err_types:
  "\<lbrakk> ws_prog G; single_valued (subcls1 G); acyclic (subcls1 G) \<rbrakk>
  \<Longrightarrow> closed (err (types G)) (lift2 (sup G))"
  apply (unfold closed_def plussub_def lift2_def sup_def)
  apply (auto split: err.split)
  apply (drule is_tyI, assumption)
  apply (auto simp add: is_ty_def is_type_conv simp del: is_type.simps
              split: ty.split ref_ty.split)
  apply (blast dest!: is_lub_exec_lub is_lubD is_ubD intro!: is_ubI superI)
  done

lemma sup_subtype_greater:
  "\<lbrakk> ws_prog G; single_valued (subcls1 G); acyclic (subcls1 G);
      is_type G t1; is_type G t2; sup G t1 t2 = OK s \<rbrakk>
  \<Longrightarrow> subtype G t1 s \<and> subtype G t2 s"
proof -
  assume ws_prog:       "ws_prog G"
  assume single_valued: "single_valued (subcls1 G)"
  assume acyclic:       "acyclic (subcls1 G)"

  { fix c1 c2
    assume is_class: "is_class G c1" "is_class G c2"
    with ws_prog
    obtain
      "G \<turnstile> c1 \<preceq>C Object"
      "G \<turnstile> c2 \<preceq>C Object"
      by (blast intro: subcls_C_Object)
    with ws_prog single_valued
    obtain u where
      "is_lub ((subcls1 G)^* ) c1 c2 u"
      by (blast dest: single_valued_has_lubs)
    moreover
    note acyclic
    moreover
    have "\<forall>x y. G \<turnstile> x \<prec>C1 y \<longrightarrow> super G x = y"
      by (blast intro: superI)
    ultimately
    have "G \<turnstile> c1 \<preceq>C exec_lub (subcls1 G) (super G) c1 c2 \<and>
          G \<turnstile> c2 \<preceq>C exec_lub (subcls1 G) (super G) c1 c2"
      by (simp add: exec_lub_conv) (blast dest: is_lubD is_ubD)
  } note this [simp]

  assume "is_type G t1" "is_type G t2" "sup G t1 t2 = OK s"
  thus ?thesis
    apply (unfold sup_def subtype_def)
    apply (cases s)
    apply (auto split: ty.split_asm ref_ty.split_asm split_if_asm)
    done
qed

lemma sup_subtype_smallest:
  "\<lbrakk> ws_prog G; single_valued (subcls1 G); acyclic (subcls1 G);
      is_type G a; is_type G b; is_type G c;
      subtype G a c; subtype G b c; sup G a b = OK d \<rbrakk>
  \<Longrightarrow> subtype G d c"
proof -
  assume ws_prog:       "ws_prog G"
  assume single_valued: "single_valued (subcls1 G)"
  assume acyclic:       "acyclic (subcls1 G)"

  { fix c1 c2 D
    assume is_class: "is_class G c1" "is_class G c2"
    assume le: "G \<turnstile> c1 \<preceq>C D" "G \<turnstile> c2 \<preceq>C D"
    from ws_prog is_class
    obtain
      "G \<turnstile> c1 \<preceq>C Object"
      "G \<turnstile> c2 \<preceq>C Object"
      by (blast intro: subcls_C_Object)
    with ws_prog single_valued
    obtain u where
      lub: "is_lub ((subcls1 G)^*) c1 c2 u"
      by (blast dest: single_valued_has_lubs)
    with acyclic
    have "exec_lub (subcls1 G) (super G) c1 c2 = u"
      by (blast intro: superI exec_lub_conv)
    moreover
    from lub le
    have "G \<turnstile> u \<preceq>C D"
      by (simp add: is_lub_def is_ub_def)
    ultimately
    have "G \<turnstile> exec_lub (subcls1 G) (super G) c1 c2 \<preceq>C D"
      by blast
  } note this [intro]

  have [dest!]:
    "\<And>C T. G \<turnstile> Class C \<preceq> T \<Longrightarrow> \<exists>D. T=Class D \<and> G \<turnstile> C \<preceq>C D"
    by (frule widen_Class, auto)

  assume "is_type G a" "is_type G b" "is_type G c"
         "subtype G a c" "subtype G b c" "sup G a b = OK d"
  thus ?thesis
    by (auto simp add: subtype_def sup_def
             split: ty.split_asm ref_ty.split_asm split_if_asm)
qed

lemma sup_exists:
  "\<lbrakk> subtype G a c; subtype G b c; sup G a b = Err \<rbrakk> \<Longrightarrow> False"
  by (auto simp add: PrimT_PrimT PrimT_PrimT2 sup_def subtype_def
           split: ty.splits ref_ty.splits)

lemma err_semilat_JType_esl_lemma:
  "\<lbrakk> ws_prog G; single_valued (subcls1 G); acyclic (subcls1 G) \<rbrakk>
  \<Longrightarrow> err_semilat (esl G)"
proof -
  assume ws_prog:   "ws_prog G"
  assume single_valued: "single_valued (subcls1 G)"
  assume acyclic:   "acyclic (subcls1 G)"

  hence "order (subtype G)"
    by (rule order_widen)
  moreover
  from ws_prog single_valued acyclic
  have "closed (err (types G)) (lift2 (sup G))"
    by (rule closed_err_types)
  moreover

  from ws_prog single_valued acyclic
  have
    "(\<forall>x\<in>err (types G). \<forall>y\<in>err (types G). x <=_(Err.le (subtype G)) x +_(lift2 (sup G)) y) \<and>
     (\<forall>x\<in>err (types G). \<forall>y\<in>err (types G). y <=_(Err.le (subtype G)) x +_(lift2 (sup G)) y)"
    by (auto simp add: lesub_def plussub_def Err.le_def lift2_def sup_subtype_greater split: err.split)

  moreover

  from ws_prog single_valued acyclic
  have
    "\<forall>x\<in>err (types G). \<forall>y\<in>err (types G). \<forall>z\<in>err (types G).
    x <=_(Err.le (subtype G)) z \<and> y <=_(Err.le (subtype G)) z \<longrightarrow> x +_(lift2 (sup G)) y <=_(Err.le (subtype G)) z"
    by (unfold lift2_def plussub_def lesub_def Err.le_def)
       (auto intro: sup_subtype_smallest sup_exists split: err.split)

  ultimately

  show ?thesis
    by (unfold esl_def semilat_def Err.sl_def) auto
qed

lemma single_valued_subcls1:
  "ws_prog G \<Longrightarrow> single_valued (subcls1 G)"
  by (auto simp add: ws_prog_def unique_def single_valued_def
    intro: subcls1I elim!: subcls1.cases)

theorem err_semilat_JType_esl:
  "ws_prog G \<Longrightarrow> err_semilat (esl G)"
  by (frule acyclic_subcls1, frule single_valued_subcls1, rule err_semilat_JType_esl_lemma)

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

(*
 * 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/Monad_WP/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


section {* UTP variables *}

theory utp_urel_laws
  imports "utp_rel"
begin

subsection {* Unrestriction Laws *}

lemma unrest_iuvar [unrest]: (*legacy assumes 1:"mwb_lens x"*)
  "out\<alpha> \<sharp> $x"
  by (simp add: out\<alpha>_def, transfer, auto)

lemma unrest_ouvar [unrest]: (*legacy need assumes 1:"mwb_lens x"*)
  "in\<alpha> \<sharp> $x\<acute>"
  by (simp add: in\<alpha>_def, transfer, auto)

lemma unrest_semir_undash [unrest]:
  fixes x :: "('a, '\<alpha>) uvar"
  assumes "$x \<sharp> P"
  shows "$x \<sharp> P ;; Q"
  using assms by transfer (rel_auto)

lemma unrest_semir_dash [unrest]:
  fixes x :: "('a, '\<alpha>) uvar"
  assumes "$x\<acute> \<sharp> Q"
  shows "$x\<acute> \<sharp> P ;; Q"
  using assms by transfer (rel_auto)

lemma unrest_cond [unrest]:
  "\<lbrakk> x \<sharp> P; x \<sharp> b; x \<sharp> Q \<rbrakk> \<Longrightarrow> x \<sharp> P \<triangleleft> b \<triangleright> Q "
  unfolding cond_def
  by transfer' (rel_auto)

lemma unrest_in\<alpha>_var [unrest]:
  "\<lbrakk> mwb_lens x; in\<alpha> \<sharp> (P :: ('\<alpha>, '\<beta>) rel) \<rbrakk> \<Longrightarrow> $x \<sharp> P"
  by (pred_auto, simp add: in\<alpha>_def, blast, metis in\<alpha>_def lens.select_convs(2) old.prod.case)

lemma unrest_out\<alpha>_var [unrest]:
  "\<lbrakk> mwb_lens x; out\<alpha> \<sharp> (P :: ('\<alpha>, '\<beta>) rel) \<rbrakk> \<Longrightarrow> $x\<acute> \<sharp> P"
  by (pred_auto, simp add: out\<alpha>_def, blast, metis lens.select_convs(2) old.prod.case out\<alpha>_def)

lemma in\<alpha>_uvar [simp]: "vwb_lens in\<alpha>"
  by (unfold_locales, auto simp add: in\<alpha>_def)

lemma out\<alpha>_uvar [simp]: "vwb_lens out\<alpha>"
  by (unfold_locales, auto simp add: out\<alpha>_def)

lemma unrest_pre_out\<alpha> [unrest]: "out\<alpha> \<sharp> \<lceil>b\<rceil>\<^sub><"
  by (transfer, auto simp add: out\<alpha>_def)

lemma unrest_post_in\<alpha> [unrest]: "in\<alpha> \<sharp> \<lceil>b\<rceil>\<^sub>>"
  by (transfer, auto simp add: in\<alpha>_def)

lemma unrest_pre_in_var [unrest]:
  "x \<sharp> p1 \<Longrightarrow> $x \<sharp> \<lceil>p1\<rceil>\<^sub><"
  by (transfer, simp)

lemma unrest_post_out_var [unrest]:
  "x \<sharp> p1 \<Longrightarrow> $x\<acute> \<sharp> \<lceil>p1\<rceil>\<^sub>>"
  by (transfer, simp)

lemma unrest_convr_out\<alpha> [unrest]:
  "in\<alpha> \<sharp> p \<Longrightarrow> out\<alpha> \<sharp> p\<^sup>-"
  by (transfer, auto simp add: in\<alpha>_def out\<alpha>_def)

lemma unrest_convr_in\<alpha> [unrest]:
  "out\<alpha> \<sharp> p \<Longrightarrow> in\<alpha> \<sharp> p\<^sup>-"
  by (transfer, auto simp add: in\<alpha>_def out\<alpha>_def)

lemma unrest_in_rel_var_res [unrest]:
  "vwb_lens x \<Longrightarrow> $x \<sharp> (P \<restriction>\<^sub>\<alpha> x)"
  by (simp add: rel_var_res_def unrest)

lemma unrest_out_rel_var_res [unrest]:
  "vwb_lens x \<Longrightarrow> $x\<acute> \<sharp> (P \<restriction>\<^sub>\<alpha> x)"
  by (simp add: rel_var_res_def unrest)

subsection {* Substitution laws *}

lemma subst_seq_left [usubst]:
  "out\<alpha> \<sharp> \<sigma> \<Longrightarrow> \<sigma> \<dagger> (P ;; Q) = (\<sigma> \<dagger> P) ;; Q"
  by transfer (rel_auto, (metis (no_types, lifting) Pair_inject surjective_pairing)+)

lemma subst_seq_right [usubst]:
  "in\<alpha> \<sharp> \<sigma> \<Longrightarrow> \<sigma> \<dagger> (P ;; Q) = P ;; (\<sigma> \<dagger> Q)"
  by transfer (rel_auto, (metis (no_types, lifting) Pair_inject surjective_pairing)+)

text {* The following laws support substitution in heterogeneous relations for polymorphically
  types literal expressions. These cannot be supported more generically due to limitations
  in HOL's type system. The laws are presented in a slightly strange way so as to be as
  general as possible. *}

lemma bool_seqr_laws [usubst]:
  fixes x :: "(bool \<Longrightarrow> '\<alpha>)"
  shows
    "\<And> P Q \<sigma>. \<sigma>($x \<mapsto>\<^sub>s true) \<dagger> (P ;; Q) = \<sigma> \<dagger> (P\<lbrakk>true/$x\<rbrakk> ;; Q)"
    "\<And> P Q \<sigma>. \<sigma>($x \<mapsto>\<^sub>s false) \<dagger> (P ;; Q) = \<sigma> \<dagger> (P\<lbrakk>false/$x\<rbrakk> ;; Q)"
    "\<And> P Q \<sigma>. \<sigma>($x\<acute> \<mapsto>\<^sub>s true) \<dagger> (P ;; Q) = \<sigma> \<dagger> (P ;; Q\<lbrakk>true/$x\<acute>\<rbrakk>)"
    "\<And> P Q \<sigma>. \<sigma>($x\<acute> \<mapsto>\<^sub>s false) \<dagger> (P ;; Q) = \<sigma> \<dagger> (P ;; Q\<lbrakk>false/$x\<acute>\<rbrakk>)"
    by (transfer, rel_auto)+

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

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

lemma usubst_condr [usubst]:
  "\<sigma> \<dagger> ( P \<triangleleft> b \<triangleright> Q) = (\<sigma> \<dagger> P \<triangleleft> \<sigma> \<dagger> b \<triangleright> \<sigma> \<dagger> Q)"
  unfolding cond_def
  by rel_auto

lemma subst_skip_r [usubst]:
  "out\<alpha> \<sharp> \<sigma> \<Longrightarrow> \<sigma> \<dagger> II = \<langle>\<lfloor>\<sigma>\<rfloor>\<^sub>s\<rangle>\<^sub>a"
  by (rel_simp, (metis (mono_tags, lifting) prod.sel(1) sndI surjective_pairing)+)

lemma usubst_upd_in_comp [usubst]:
  "\<sigma>(&in\<alpha>:x \<mapsto>\<^sub>s v) = \<sigma>($x \<mapsto>\<^sub>s v)"
  by (simp add: fst_lens_def in\<alpha>_def in_var_def)

lemma usubst_upd_out_comp [usubst]:
  "\<sigma>(&out\<alpha>:x \<mapsto>\<^sub>s v) = \<sigma>($x\<acute> \<mapsto>\<^sub>s v)"
  by (simp add: out\<alpha>_def out_var_def snd_lens_def)

lemma subst_lift_upd [usubst]:
  fixes x :: "('a, '\<alpha>) uvar"
  shows "\<lceil>\<sigma>(x \<mapsto>\<^sub>s v)\<rceil>\<^sub>s = \<lceil>\<sigma>\<rceil>\<^sub>s($x \<mapsto>\<^sub>s \<lceil>v\<rceil>\<^sub><)"
  by (simp add: alpha , simp add: fst_lens_def in\<alpha>_def in_var_def)

lemma subst_drop_upd [usubst]:
  fixes x :: "('a, '\<alpha>) uvar"
  shows "\<lfloor>\<sigma>($x \<mapsto>\<^sub>s v)\<rfloor>\<^sub>s = \<lfloor>\<sigma>\<rfloor>\<^sub>s(x \<mapsto>\<^sub>s \<lfloor>v\<rfloor>\<^sub><)"
  by  (pred_simp , simp add: in\<alpha>_def prod.case_eq_if)

lemma subst_lift_pre [usubst]: "\<lceil>\<sigma>\<rceil>\<^sub>s \<dagger> \<lceil>b\<rceil>\<^sub>< = \<lceil>\<sigma> \<dagger> b\<rceil>\<^sub><"
  by (metis apply_subst_ext fst_lens_def fst_vwb_lens in\<alpha>_def)

lemma unrest_usubst_lift_in [unrest]:
  "x \<sharp> P \<Longrightarrow> $x \<sharp> \<lceil>P\<rceil>\<^sub>s"
  by (pred_simp, auto simp add: unrest_usubst_def in\<alpha>_def)

lemma unrest_usubst_lift_out [unrest]:
  fixes x :: "('a, '\<alpha>) uvar"
  shows "$x\<acute> \<sharp> \<lceil>P\<rceil>\<^sub>s"
  by (pred_simp, auto simp add: unrest_usubst_def in\<alpha>_def)

subsection {* Relation laws *}

text {* Homogeneous relations form a quantale. This allows us to import a large number of laws
        from Struth and Armstrong's Kleene Algebra theory~\cite{Armstrong2015}. *}

abbreviation truer :: "'\<alpha> hrel" ("true\<^sub>h") where
"truer \<equiv> true"

abbreviation falser :: "'\<alpha> hrel" ("false\<^sub>h") where
"falser \<equiv> false"

lemma drop_pre_inv [simp]: "\<lbrakk> out\<alpha> \<sharp> p \<rbrakk> \<Longrightarrow> \<lceil>\<lfloor>p\<rfloor>\<^sub><\<rceil>\<^sub>< = p"
  by (pred_simp, auto simp add: out\<alpha>_def lens_create_def fst_lens_def prod.case_eq_if)

text {* Quantale laws for relations *}

lemma seq_Sup_distl: "P ;; (\<Sqinter> A) = (\<Sqinter> Q\<in>A. P ;; Q)"
  by (transfer, rel_auto)

lemma seq_Sup_distr: "(\<Sqinter> A) ;; Q = (\<Sqinter> P\<in>A. P ;; Q)"
  by (transfer, auto)

lemma seq_UINF_distl: "P ;; (\<Sqinter> Q\<in>A \<bullet> F(Q)) = (\<Sqinter> Q\<in>A \<bullet> P ;; F(Q))"
  by (simp add: USUP_as_Sup_collect seq_Sup_distl)

lemma seq_UINF_distr: "(\<Sqinter> P\<in>A \<bullet> F(P)) ;; Q = (\<Sqinter> P\<in>A \<bullet> F(P) ;; Q)"
  by  (simp add: USUP_as_Sup_collect seq_Sup_distr)

lemma impl_seqr_mono: "\<lbrakk> `P \<Rightarrow> Q`; `R \<Rightarrow> S` \<rbrakk> \<Longrightarrow> `(P ;; R) \<Rightarrow> (Q ;; S)`"
  by transfer (pred_blast)

lemma seqr_mono:
  "\<lbrakk> P\<^sub>1 \<sqsubseteq> P\<^sub>2; Q\<^sub>1 \<sqsubseteq> Q\<^sub>2 \<rbrakk> \<Longrightarrow> (P\<^sub>1 ;; Q\<^sub>1) \<sqsubseteq> (P\<^sub>2 ;; Q\<^sub>2)"
  by transfer (rel_blast)

lemma seqr_monotonic:
  "\<lbrakk> mono P; mono Q \<rbrakk> \<Longrightarrow> mono (\<lambda> X. P X ;; Q X)"
  by (simp add: mono_def, transfer ,rel_blast)

lemma cond_mono:
  "\<lbrakk> P\<^sub>1 \<sqsubseteq> P\<^sub>2; Q\<^sub>1 \<sqsubseteq> Q\<^sub>2 \<rbrakk> \<Longrightarrow> (P\<^sub>1 \<triangleleft> b \<triangleright> Q\<^sub>1) \<sqsubseteq> (P\<^sub>2 \<triangleleft> b \<triangleright> Q\<^sub>2)"
  unfolding cond_def
  by transfer (rel_auto)

lemma cond_monotonic:
  "\<lbrakk> mono P; mono Q \<rbrakk> \<Longrightarrow> mono (\<lambda> X. P X \<triangleleft> b \<triangleright> Q X)"
  unfolding cond_def
  by (simp add: mono_def, rel_blast)

lemma spec_refine:
  "Q \<sqsubseteq> (P \<and> R) \<Longrightarrow> (P \<Rightarrow> Q) \<sqsubseteq> R"
  by (rel_auto)

lemma cond_skip: "out\<alpha> \<sharp> b \<Longrightarrow> (b \<and> II) = (II \<and> b\<^sup>-)"
  by (rel_auto)

lemma assigns_subst [usubst]:
  "\<lceil>\<sigma>\<rceil>\<^sub>s \<dagger> \<langle>\<rho>\<rangle>\<^sub>a = \<langle>\<rho> \<circ> \<sigma>\<rangle>\<^sub>a"
  by transfer (rel_auto)

lemma assigns_r_comp: "(\<langle>\<sigma>\<rangle>\<^sub>a ;; P) = (\<lceil>\<sigma>\<rceil>\<^sub>s \<dagger> P)"
  by transfer rel_auto

lemma assigns_r_feasible:
  "(\<langle>\<sigma>\<rangle>\<^sub>a ;; true) = true"
  by (simp add: assigns_r_comp subst_true)

lemma assign_subst [usubst]:
  "\<lbrakk> mwb_lens x; mwb_lens y \<rbrakk> \<Longrightarrow> [$x \<mapsto>\<^sub>s \<lceil>u\<rceil>\<^sub><] \<dagger> (y :== v) = (x, y :== u, [x \<mapsto>\<^sub>s u] \<dagger> v)"
  by rel_auto

lemma assigns_idem: "mwb_lens x \<Longrightarrow> (x,x :== u,v) = (x :== v)"
  by (simp add: usubst)

lemma assigns_comp: "(\<langle>f\<rangle>\<^sub>a ;; \<langle>g\<rangle>\<^sub>a) = \<langle>g \<circ> f\<rangle>\<^sub>a"
  by (simp add: assigns_r_comp usubst)

lemma assigns_r_conv:
  "bij f \<Longrightarrow> \<langle>f\<rangle>\<^sub>a\<^sup>- = \<langle>inv f\<rangle>\<^sub>a"
  by transfer (rel_auto, simp_all add: bij_is_inj bij_is_surj surj_f_inv_f)

lemma assign_pred_transfer:
  fixes x :: "('a, '\<alpha>) uvar"
  assumes "$x \<sharp> b" "out\<alpha> \<sharp> b"
  shows "(b \<and> x :== v) = (x :== v \<and> b\<^sup>-)"
  using assms by rel_blast

lemma assigns_r_ufunc: "ufunctional \<langle>f\<rangle>\<^sub>a"
  by (rel_auto)

lemma assigns_r_uinj: "inj f \<Longrightarrow> uinj \<langle>f\<rangle>\<^sub>a"
  by (rel_simp, simp add: inj_eq)

lemma assigns_r_swap_uinj:
  "\<lbrakk> vwb_lens x; vwb_lens y; x \<bowtie> y \<rbrakk> \<Longrightarrow> uinj (x,y :== &y,&x)"
  using assigns_r_uinj swap_usubst_inj by auto

lemma skip_r_unfold:
  "vwb_lens x \<Longrightarrow> II = ($x\<acute> =\<^sub>u $x \<and> II\<restriction>\<^sub>\<alpha>x)"
  by (rel_auto, metis mwb_lens.put_put vwb_lens_mwb vwb_lens_wb wb_lens.get_put)

lemma skip_ra_unfold:
  "II\<^bsub>x;y\<^esub> = ($x\<acute> =\<^sub>u $x \<and> II\<^bsub>y\<^esub>)"
  by (rel_auto)

lemma skip_res_as_ra:
  "\<lbrakk> vwb_lens y; x +\<^sub>L y \<approx>\<^sub>L 1\<^sub>L; x \<bowtie> y \<rbrakk> \<Longrightarrow> II\<restriction>\<^sub>\<alpha>x = II\<^bsub>y\<^esub>"
  apply (rel_auto)
  apply (metis (no_types, lifting) lens_indep_def)
  apply (metis vwb_lens.put_eq)
done

lemma assign_unfold:
  "vwb_lens x \<Longrightarrow> (x :== v) = ($x\<acute> =\<^sub>u \<lceil>v\<rceil>\<^sub>< \<and> II\<restriction>\<^sub>\<alpha>x)"
  apply (rel_auto, auto simp add: comp_def)
  using vwb_lens.put_eq by fastforce

lemma seqr_and_distr_ufunc:
  "ufunctional P \<Longrightarrow> (P ;; (Q \<and> R)) = ((P ;; Q) \<and> (P ;; R))"
  by rel_auto

lemma seqr_and_distl_uinj:
  "uinj R \<Longrightarrow> ((P \<and> Q) ;; R) = ((P ;; R) \<and> (Q ;; R))"
  by (rel_auto)

theorem precond_equiv:
  "P = (P ;; true) \<longleftrightarrow> (out\<alpha> \<sharp> P)"
  by (rel_auto)

theorem postcond_equiv:
  "P = (true ;; P) \<longleftrightarrow> (in\<alpha> \<sharp> P)"
  by (rel_auto)

lemma precond_right_unit: "out\<alpha> \<sharp> p \<Longrightarrow> (p ;; true) = p"
  by (metis precond_equiv)

lemma postcond_left_unit: "in\<alpha> \<sharp> p \<Longrightarrow> (true ;; p) = p"
  by (metis postcond_equiv)

theorem precond_left_zero:
  assumes "out\<alpha> \<sharp> p" "p \<noteq> false"
  shows "(true ;; p) = true"
  using assms
  apply (simp add: out\<alpha>_def upred_defs)
  apply (transfer, auto simp add: relcomp_unfold, rule ext, auto)
  apply (rename_tac p b)
  apply (subgoal_tac "\<exists> b1 b2. p (b1, b2)")
  apply (auto)
done

subsection {* Converse laws *}

lemma convr_invol [simp]: "p\<^sup>-\<^sup>- = p"
  by pred_auto

lemma lit_convr [simp]: "\<guillemotleft>v\<guillemotright>\<^sup>- = \<guillemotleft>v\<guillemotright>"
  by pred_auto

lemma uivar_convr [simp]:
  fixes x :: "('a, '\<alpha>) uvar"
  shows "($x)\<^sup>- = $x\<acute>"
  by pred_auto

lemma uovar_convr [simp]:
  fixes x :: "('a, '\<alpha>) uvar"
  shows "($x\<acute>)\<^sup>- = $x"
  by pred_auto

lemma uop_convr [simp]: "(uop f u)\<^sup>- = uop f (u\<^sup>-)"
  by (pred_auto)

lemma bop_convr [simp]: "(bop f u v)\<^sup>- = bop f (u\<^sup>-) (v\<^sup>-)"
  by (pred_auto)

lemma eq_convr [simp]: "(p =\<^sub>u q)\<^sup>- = (p\<^sup>- =\<^sub>u q\<^sup>-)"
  by (pred_auto)

lemma not_convr [simp]: "(\<not> p)\<^sup>- = (\<not> p\<^sup>-)"
  by (pred_auto)

lemma disj_convr [simp]: "(p \<or> q)\<^sup>- = (q\<^sup>- \<or> p\<^sup>-)"
  by (pred_auto)

lemma conj_convr [simp]: "(p \<and> q)\<^sup>- = (q\<^sup>- \<and> p\<^sup>-)"
  by (pred_auto)

lemma seqr_convr [simp]: "(p ;; q)\<^sup>- = (q\<^sup>- ;; p\<^sup>-)"
  by rel_auto

lemma pre_convr [simp]: "\<lceil>p\<rceil>\<^sub><\<^sup>- = \<lceil>p\<rceil>\<^sub>>"
  by (rel_auto)

lemma post_convr [simp]: "\<lceil>p\<rceil>\<^sub>>\<^sup>- = \<lceil>p\<rceil>\<^sub><"
  by (rel_auto)

theorem seqr_pre_transfer: "in\<alpha> \<sharp> q \<Longrightarrow> ((P \<and> q) ;; R) = (P ;; (q\<^sup>- \<and> R))"
  by (rel_auto)

theorem seqr_pre_transfer':
  "((P \<and> \<lceil>q\<rceil>\<^sub>>) ;; R) = (P ;; (\<lceil>q\<rceil>\<^sub>< \<and> R))"
  by (rel_auto)

theorem seqr_post_out: "in\<alpha> \<sharp> r \<Longrightarrow> (P ;; (Q \<and> r)) = ((P ;; Q) \<and> r)"
  by (rel_blast)

lemma seqr_post_var_out:
  fixes x :: "(bool, '\<alpha>) uvar"
  shows "(P ;; (Q \<and> $x\<acute>)) = ((P ;; Q) \<and> $x\<acute>)"
  by (rel_auto)

theorem seqr_post_transfer: "out\<alpha> \<sharp> q \<Longrightarrow> (P ;; (q \<and> R)) = ((P \<and> q\<^sup>-) ;; R)"
  by (simp add: seqr_pre_transfer unrest_convr_in\<alpha>)

lemma seqr_pre_out: "out\<alpha> \<sharp> p \<Longrightarrow> ((p \<and> Q) ;; R) = (p \<and> (Q ;; R))"
  by (rel_blast)

lemma seqr_pre_var_out:
  fixes x :: "(bool, '\<alpha>) uvar"
  shows "(($x \<and> P) ;; Q) = ($x \<and> (P ;; Q))"
  by (rel_auto)

lemma seqr_true_lemma:
  "(P = (\<not> ((\<not> P) ;; true))) = (P = (P ;; true))"
  by rel_auto

lemma seqr_to_conj: "\<lbrakk> out\<alpha> \<sharp> P; in\<alpha> \<sharp> Q \<rbrakk> \<Longrightarrow> (P ;; Q) = (P \<and> Q)"
  by (metis postcond_left_unit seqr_pre_out utp_pred.inf_top.right_neutral)

lemma shEx_lift_seq_1 [uquant_lift]:
  "((\<^bold>\<exists> x \<bullet> P x) ;; Q) = (\<^bold>\<exists> x \<bullet> (P x ;; Q))"
  by pred_auto

lemma shEx_lift_seq_2 [uquant_lift]:
  "(P ;; (\<^bold>\<exists> x \<bullet> Q x)) = (\<^bold>\<exists> x \<bullet> (P ;; Q x))"
  by pred_auto

subsection {* Relational unrestriction *}

text {* Relational unrestriction states that a variable is unchanged by a relation. Eventually
  I'd also like to have it state that the relation also does not depend on the variable's
  initial value, but I'm not sure how to state that yet. For now we represent this by
  the parametric healthiness condition RID. *}

definition RID :: "('a, '\<alpha>) uvar \<Rightarrow> '\<alpha> hrel \<Rightarrow> '\<alpha> hrel"
where "RID x P = ((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> P) \<and> $x\<acute> =\<^sub>u $x)"

declare RID_def [urel_defs]

lemma RID_idem:
  "mwb_lens x \<Longrightarrow> RID(x)(RID(x)(P)) = RID(x)(P)"
  by (rel_auto)

lemma RID_mono:
  "P \<sqsubseteq> Q \<Longrightarrow> RID(x)(P) \<sqsubseteq> RID(x)(Q)"
  by (rel_auto)

lemma RID_skip_r:
  "vwb_lens x \<Longrightarrow> RID(x)(II) = II"
  apply (rel_auto) using vwb_lens.put_eq by fastforce

lemma RID_disj:
  "RID(x)(P \<or> Q) = (RID(x)(P) \<or> RID(x)(Q))"
  by (rel_auto)

lemma RID_conj:
  "vwb_lens x \<Longrightarrow> RID(x)(RID(x)(P) \<and> RID(x)(Q)) = (RID(x)(P) \<and> RID(x)(Q))"
  by (rel_auto)

lemma RID_assigns_r_diff:
  "\<lbrakk> vwb_lens x; x \<sharp> \<sigma> \<rbrakk> \<Longrightarrow> RID(x)(\<langle>\<sigma>\<rangle>\<^sub>a) = \<langle>\<sigma>\<rangle>\<^sub>a"
  apply (rel_auto)
  apply (metis vwb_lens.put_eq)
  apply (metis vwb_lens_wb wb_lens.get_put wb_lens_weak weak_lens.put_get)
done

lemma RID_assign_r_same:
  "vwb_lens x \<Longrightarrow> RID(x)(x :== v) = II"
  apply (rel_auto)
  using vwb_lens.put_eq apply fastforce
done

lemma RID_seq_left:
  assumes "vwb_lens x"
  shows "RID(x)(RID(x)(P) ;; Q) = (RID(x)(P) ;; RID(x)(Q))"
proof -
  have "RID(x)(RID(x)(P) ;; Q) = ((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> ((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> P) \<and> $x\<acute> =\<^sub>u $x) ;; Q) \<and> $x\<acute> =\<^sub>u $x)"
    by (simp add: RID_def usubst)
  also from assms have "... = ((((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> P) \<and> (\<exists> $x \<bullet> $x\<acute> =\<^sub>u $x)) ;; (\<exists> $x\<acute> \<bullet> Q)) \<and> $x\<acute> =\<^sub>u $x)"
    by (rel_auto)
  also from assms have "... = (((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> P) ;; (\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> Q)) \<and> $x\<acute> =\<^sub>u $x)"
    apply (rel_auto)
    apply (metis vwb_lens.put_eq)
    apply (metis mwb_lens.put_put vwb_lens_mwb)
  done
  also from assms have "... = ((((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> P) \<and> $x\<acute> =\<^sub>u $x) ;; (\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> Q)) \<and> $x\<acute> =\<^sub>u $x)"
    by (rel_simp, metis (full_types) mwb_lens.put_put vwb_lens_def wb_lens_weak weak_lens.put_get)
  also have "... = ((((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> P) \<and> $x\<acute> =\<^sub>u $x) ;; ((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> Q) \<and> $x\<acute> =\<^sub>u $x)) \<and> $x\<acute> =\<^sub>u $x)"
    by (rel_simp, fastforce)
  also have "... = ((((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> P) \<and> $x\<acute> =\<^sub>u $x) ;; ((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> Q) \<and> $x\<acute> =\<^sub>u $x)))"
    by (rel_auto)
  also have "... = (RID(x)(P) ;; RID(x)(Q))"
    by (rel_auto)
  finally show ?thesis .
qed

lemma RID_seq_right:
  assumes "vwb_lens x"
  shows "RID(x)(P ;; RID(x)(Q)) = (RID(x)(P) ;; RID(x)(Q))"
proof -
  have "RID(x)(P ;; RID(x)(Q)) = ((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> P ;; ((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> Q) \<and> $x\<acute> =\<^sub>u $x)) \<and> $x\<acute> =\<^sub>u $x)"
    by (simp add: RID_def usubst)
  also from assms have "... = (((\<exists> $x \<bullet>  P) ;; (\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> Q) \<and> (\<exists> $x\<acute> \<bullet> $x\<acute> =\<^sub>u $x)) \<and> $x\<acute> =\<^sub>u $x)"
    by (rel_auto)
  also from assms have "... = (((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> P) ;; (\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> Q)) \<and> $x\<acute> =\<^sub>u $x)"
    apply (rel_auto)
    apply (metis vwb_lens.put_eq)
    apply (metis mwb_lens.put_put vwb_lens_mwb)
  done
  also from assms have "... = ((((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> P) \<and> $x\<acute> =\<^sub>u $x) ;; (\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> Q)) \<and> $x\<acute> =\<^sub>u $x)"
    by (rel_simp, metis (full_types) mwb_lens.put_put vwb_lens_def wb_lens_weak weak_lens.put_get)
  also have "... = ((((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> P) \<and> $x\<acute> =\<^sub>u $x) ;; ((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> Q) \<and> $x\<acute> =\<^sub>u $x)) \<and> $x\<acute> =\<^sub>u $x)"
    by (rel_simp, fastforce)
  also have "... = ((((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> P) \<and> $x\<acute> =\<^sub>u $x) ;; ((\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> Q) \<and> $x\<acute> =\<^sub>u $x)))"
    by (rel_auto)
  also have "... = (RID(x)(P) ;; RID(x)(Q))"
    by (rel_auto)
  finally show ?thesis .
qed

definition unrest_relation :: "('a, '\<alpha>) uvar \<Rightarrow> '\<alpha> hrel \<Rightarrow> bool" (infix "\<sharp>\<sharp>" 20)
where "(x \<sharp>\<sharp> P) \<longleftrightarrow> (P = RID(x)(P))"

declare unrest_relation_def [urel_defs]

lemma skip_r_runrest [unrest]:
  "vwb_lens x \<Longrightarrow> x \<sharp>\<sharp> II"
  by (simp add: RID_skip_r unrest_relation_def)

lemma assigns_r_runrest:
  "\<lbrakk> vwb_lens x; x \<sharp> \<sigma> \<rbrakk> \<Longrightarrow> x \<sharp>\<sharp> \<langle>\<sigma>\<rangle>\<^sub>a"
  by (simp add: RID_assigns_r_diff unrest_relation_def)

lemma seq_r_runrest [unrest]:
  assumes "vwb_lens x" "x \<sharp>\<sharp> P" "x \<sharp>\<sharp> Q"
  shows "x \<sharp>\<sharp> (P ;; Q)"
  by (metis RID_seq_left assms unrest_relation_def)

lemma false_runrest [unrest]: "x \<sharp>\<sharp> false"
  by (rel_auto)

lemma and_runrest [unrest]: "\<lbrakk> vwb_lens x; x \<sharp>\<sharp> P; x \<sharp>\<sharp> Q \<rbrakk> \<Longrightarrow> x \<sharp>\<sharp> (P \<and> Q)"
  by (metis RID_conj unrest_relation_def)

lemma or_runrest [unrest]: "\<lbrakk> x \<sharp>\<sharp> P; x \<sharp>\<sharp> Q \<rbrakk> \<Longrightarrow> x \<sharp>\<sharp> (P \<or> Q)"
  by (simp add: RID_disj unrest_relation_def)

subsection {* Alphabet laws *}

lemma aext_cond [alpha]:
  "(P \<triangleleft> b \<triangleright> Q) \<oplus>\<^sub>p a = ((P \<oplus>\<^sub>p a) \<triangleleft>(b \<oplus>\<^sub>p a)\<triangleright>(Q \<oplus>\<^sub>p a))"
  by (rel_auto)

lemma aext_seq [alpha]:
  "wb_lens a \<Longrightarrow> ((P ;; Q) \<oplus>\<^sub>p (a \<times>\<^sub>L a)) = ((P \<oplus>\<^sub>p (a \<times>\<^sub>L a)) ;; (Q \<oplus>\<^sub>p (a \<times>\<^sub>L a)))"
  by (rel_simp, metis wb_lens_weak weak_lens.put_get)

end