theory Elections
imports Preference_Profiles
begin

text \<open>
  An election consists of a finite set of agents and a finite non-empty
  set of alternatives.
\<close>
locale election =
  fixes agents :: "'agent set" and alts :: "'alt set"
  assumes finite_agents [simp, intro]: "finite agents"
  assumes finite_alts [simp, intro]: "finite alts"
  assumes nonempty_agents [simp]: "agents \<noteq> {}"
  assumes nonempty_alts [simp]: "alts \<noteq> {}"
begin

abbreviation "is_pref_profile \<equiv> pref_profile_wf agents alts"

lemma finite_total_preorder_on_iff' [simp]:
  "finite_total_preorder_on alts R \<longleftrightarrow> total_preorder_on alts R"
  by (simp add: finite_total_preorder_on_iff)

lemma pref_profile_wfI' [intro?]:
  "(\<And>i. i \<in> agents \<Longrightarrow> total_preorder_on alts (R i)) \<Longrightarrow>
   (\<And>i. i \<notin> agents \<Longrightarrow> R i = (\<lambda>_ _. False)) \<Longrightarrow> is_pref_profile R"
  by (simp add: pref_profile_wf_def)

lemma is_pref_profile_update [simp,intro]:
  assumes "is_pref_profile R" "total_preorder_on alts Ri'" "i \<in> agents"
  shows   "is_pref_profile (R(i := Ri'))"
  using assms by (auto intro!: pref_profile_wf.wf_update)

lemma election [simp,intro]: "election agents alts"
  by (rule election_axioms)

context
  fixes R assumes R: "total_preorder_on alts R"
begin

interpretation R: total_preorder_on alts R by fact

lemma Max_wrt_prefs_finite: "finite (Max_wrt R)"
  unfolding R.Max_wrt_preorder by simp

lemma Max_wrt_prefs_nonempty: "Max_wrt R \<noteq> {}"
  using R.Max_wrt_nonempty by simp

lemma maximal_imp_preferred:
  "x \<in> alts \<Longrightarrow> Max_wrt R \<subseteq> preferred_alts R x"
  using R.total
  by (auto simp: R.Max_wrt_total_preorder preferred_alts_def strongly_preferred_def)

end

end

end


header {* Safety-Property Model-Checker\label{sec:find_path} *}
theory Find_Path
imports
  "../CAVA_Automata/Digraph"
  "../CAVA_Automata/CAVA_Base/CAVA_Code_Target"
begin
  section {* Finding Path to Error *}
  text {*
    This function searches a graph and a set of start nodes for a reachable
    node that satisfies some property, and returns a path to such a node iff it
    exists.
    *}
  definition "find_path E U0 P \<equiv> do {
    ASSERT (finite U0);
    ASSERT (finite (E\<^sup>*``U0));
    SPEC (\<lambda>p. case p of
      Some (p,v) \<Rightarrow> \<exists>u0\<in>U0. path E u0 p v \<and> P v \<and> (\<forall>v\<in>set p. \<not> P v)
    | None \<Rightarrow> \<forall>u0\<in>U0. \<forall>v\<in>E\<^sup>*``{u0}. \<not>P v)
    }"

  lemma find_path_ex_rule:
    assumes "finite U0"
    assumes "finite (E\<^sup>*``U0)"
    assumes "\<exists>v\<in>E\<^sup>*``U0. P v"
    shows "find_path E U0 P \<le> SPEC (\<lambda>r.
      \<exists>p v. r = Some (p,v) \<and> P v \<and> (\<forall>v\<in>set p. \<not>P v) \<and> (\<exists>u0\<in>U0. path E u0 p v))"
    unfolding find_path_def
    using assms
    by (fastforce split: option.splits)

  subsection {* Nontrivial Paths *}

  definition "find_path1 E u0 P \<equiv> do {
    ASSERT (finite (E\<^sup>*``{u0}));
    SPEC (\<lambda>p. case p of
      Some (p,v) \<Rightarrow> path E u0 p v \<and> P v \<and> p\<noteq>[]
    | None \<Rightarrow> \<forall>v\<in>E\<^sup>+``{u0}. \<not>P v)}"

  lemma (in -) find_path1_ex_rule:
    assumes "finite (E\<^sup>*``{u0})"
    assumes "\<exists>v\<in>E\<^sup>+``{u0}. P v"
    shows "find_path1 E u0 P \<le> SPEC (\<lambda>r.
      \<exists>p v. r = Some (p,v) \<and> p\<noteq>[] \<and> P v \<and> path E u0 p v)"
    unfolding find_path1_def
    using assms
    by (fastforce split: option.splits)

end


text \<open>This theory imports both univariate and multivariate polynomials and thereby
  causes several overlaps in notation of polynomials.\<close>

theory More_Min_Int_Poly
  imports
    Algebraic_Numbers.Min_Int_Poly
    "HOL-Computational_Algebra.Computational_Algebra"
    More_Polynomial_HLW
begin

lemma min_int_poly_squarefree [intro]:
  fixes x :: "'a :: {field_char_0, field_gcd}"
  shows "squarefree (min_int_poly x)"
  by (rule irreducible_imp_squarefree) auto

lemma min_int_poly_conv_Gcd:
  fixes x :: "'a :: {field_char_0, field_gcd}"
  assumes "algebraic x"
  shows "min_int_poly x = Gcd {p. p \<noteq> 0 \<and> p represents x}"
proof (rule sym, rule Gcd_eqI, (safe)?)
  fix p assume p: "\<And>q. q \<in> {p. p \<noteq> 0 \<and> p represents x} \<Longrightarrow> p dvd q"
  show "p dvd min_int_poly x"
    using assms by (intro p) auto
next
  fix p assume p: "p \<noteq> 0" "p represents x"
  have "min_int_poly x represents x"
    using assms by auto
  hence "poly (gcd (of_int_poly (min_int_poly x)) (of_int_poly p)) x = 0"
    using p by (intro poly_gcd_eq_0I) auto
  hence "ipoly (gcd (min_int_poly x) p) x = 0"
    by (subst (asm) gcd_of_int_poly) auto
  hence "gcd (min_int_poly x) p represents x"
    using p unfolding represents_def by auto

  have "min_int_poly x dvd gcd (min_int_poly x) p \<or> is_unit (gcd (min_int_poly x) p)"
    by (intro irreducibleD') auto
  moreover from \<open>gcd (min_int_poly x) p represents x\<close> have "\<not>is_unit (gcd (min_int_poly x) p)"
    by (auto simp: represents_def)
  ultimately have "min_int_poly x dvd gcd (min_int_poly x) p"
    by blast
  also have "\<dots> dvd p"
    by blast
  finally show "min_int_poly x dvd p" .
qed auto

end


theory Examples1
imports Examples
begin

section {* Use of Locales in Theories and Proofs
  \label{sec:interpretation} *}

text {*
  Locales can be interpreted in the contexts of theories and
  structured proofs.  These interpretations are dynamic, too.
  Conclusions of locales will be propagated to the current theory or
  the current proof context.%
\footnote{Strictly speaking, only interpretation in theories is
  dynamic since it is not possible to change locales or the locale
  hierarchy from within a proof.}
  The focus of this section is on
  interpretation in theories, but we will also encounter
  interpretations in proofs, in
  Section~\ref{sec:local-interpretation}.

  As an example, consider the type of integers @{typ int}.  The
  relation @{term "op \<le>"} is a total order over @{typ int}.  We start
  with the interpretation that @{term "op \<le>"} is a partial order.  The
  facilities of the interpretation command are explored gradually in
  three versions.
  *}

subsection {* First Version: Replacement of Parameters Only
  \label{sec:po-first} *}

text {*
  The command \isakeyword{interpretation} is for the interpretation of
  locale in theories.  In the following example, the parameter of locale
  @{text partial_order} is replaced by @{term "op \<le> :: int \<Rightarrow> int \<Rightarrow>
  bool"} and the locale instance is interpreted in the current
  theory. *}

  interpretation %visible int: partial_order "op \<le> :: int \<Rightarrow> int \<Rightarrow> bool"
txt {* \normalsize
  The argument of the command is a simple \emph{locale expression}
  consisting of the name of the interpreted locale, which is
  preceded by the qualifier @{text "int:"} and succeeded by a
  white-space-separated list of terms, which provide a full
  instantiation of the locale parameters.  The parameters are referred
  to by order of declaration, which is also the order in which
  \isakeyword{print\_locale} outputs them.  The locale has only a
  single parameter, hence the list of instantiation terms is a
  singleton.

  The command creates the goal
  @{subgoals [display]} which can be shown easily:
 *}
    by unfold_locales auto

text {*  The effect of the command is that instances of all
  conclusions of the locale are available in the theory, where names
  are prefixed by the qualifier.  For example, transitivity for @{typ
  int} is named @{thm [source] int.trans} and is the following
  theorem:
  @{thm [display, indent=2] int.trans}
  It is not possible to reference this theorem simply as @{text
  trans}.  This prevents unwanted hiding of existing theorems of the
  theory by an interpretation. *}

subsection {* Second Version: Replacement of Definitions *}

text {* Not only does the above interpretation qualify theorem names.
  The prefix @{text int} is applied to all names introduced in locale
  conclusions including names introduced in definitions.  The
  qualified name @{text int.less} is short for
  the interpretation of the definition, which is @{term int.less}.
  Qualified name and expanded form may be used almost
  interchangeably.%
\footnote{Since @{term "op \<le>"} is polymorphic, for @{term int.less} a
  more general type will be inferred than for @{text int.less} which
  is over type @{typ int}.}
  The latter is preferred on output, as for example in the theorem
  @{thm [source] int.less_le_trans}: @{thm [display, indent=2]
  int.less_le_trans}
  Both notations for the strict order are not satisfactory.  The
  constant @{term "op <"} is the strict order for @{typ int}.
  In order to allow for the desired replacement, interpretation
  accepts \emph{equations} in addition to the parameter instantiation.
  These follow the locale expression and are indicated with the
  keyword \isakeyword{where}.  This is the revised interpretation:
  *}
end


(*  Title:      HOL/Library/Predicate_Compile_Alternative_Defs.thy
    Author:     Lukas Bulwahn, TU Muenchen
*)

theory Predicate_Compile_Alternative_Defs
  imports Main
begin

section \<open>Common constants\<close>

declare HOL.if_bool_eq_disj[code_pred_inline]

declare bool_diff_def[code_pred_inline]
declare inf_bool_def[abs_def, code_pred_inline]
declare less_bool_def[abs_def, code_pred_inline]
declare le_bool_def[abs_def, code_pred_inline]

lemma min_bool_eq [code_pred_inline]: "(min :: bool => bool => bool) == (op &)"
by (rule eq_reflection) (auto simp add: fun_eq_iff min_def)

lemma [code_pred_inline]:
  "((A::bool) ~= (B::bool)) = ((A & ~ B) | (B & ~ A))"
by fast

setup \<open>Predicate_Compile_Data.ignore_consts [@{const_name Let}]\<close>

section \<open>Pairs\<close>

setup \<open>Predicate_Compile_Data.ignore_consts [@{const_name fst}, @{const_name snd}, @{const_name case_prod}]\<close>

section \<open>Filters\<close>

(*TODO: shouldn't this be done by typedef? *)
setup \<open>Predicate_Compile_Data.ignore_consts [@{const_name Abs_filter}, @{const_name Rep_filter}]\<close>

section \<open>Bounded quantifiers\<close>

declare Ball_def[code_pred_inline]
declare Bex_def[code_pred_inline]

section \<open>Operations on Predicates\<close>

lemma Diff[code_pred_inline]:
  "(A - B) = (%x. A x \<and> \<not> B x)"
  by (simp add: fun_eq_iff)

lemma subset_eq[code_pred_inline]:
  "(P :: 'a => bool) < (Q :: 'a => bool) == ((\<exists>x. Q x \<and> (\<not> P x)) \<and> (\<forall> x. P x --> Q x))"
  by (rule eq_reflection) (auto simp add: less_fun_def le_fun_def)

lemma set_equality[code_pred_inline]:
  "A = B \<longleftrightarrow> (\<forall>x. A x \<longrightarrow> B x) \<and> (\<forall>x. B x \<longrightarrow> A x)"
  by (auto simp add: fun_eq_iff)

section \<open>Setup for Numerals\<close>

setup \<open>Predicate_Compile_Data.ignore_consts [@{const_name numeral}]\<close>
setup \<open>Predicate_Compile_Data.keep_functions [@{const_name numeral}]\<close>
setup \<open>Predicate_Compile_Data.ignore_consts [@{const_name Char}]\<close>
setup \<open>Predicate_Compile_Data.keep_functions [@{const_name Char}]\<close>

setup \<open>Predicate_Compile_Data.ignore_consts [@{const_name divide}, @{const_name modulo}, @{const_name times}]\<close>

section \<open>Arithmetic operations\<close>

subsection \<open>Arithmetic on naturals and integers\<close>

definition plus_eq_nat :: "nat => nat => nat => bool"
where
  "plus_eq_nat x y z = (x + y = z)"

definition minus_eq_nat :: "nat => nat => nat => bool"
where
  "minus_eq_nat x y z = (x - y = z)"

definition plus_eq_int :: "int => int => int => bool"
where
  "plus_eq_int x y z = (x + y = z)"

definition minus_eq_int :: "int => int => int => bool"
where
  "minus_eq_int x y z = (x - y = z)"

definition subtract
where
  [code_unfold]: "subtract x y = y - x"

setup \<open>
let
  val Fun = Predicate_Compile_Aux.Fun
  val Input = Predicate_Compile_Aux.Input
  val Output = Predicate_Compile_Aux.Output
  val Bool = Predicate_Compile_Aux.Bool
  val iio = Fun (Input, Fun (Input, Fun (Output, Bool)))
  val ioi = Fun (Input, Fun (Output, Fun (Input, Bool)))
  val oii = Fun (Output, Fun (Input, Fun (Input, Bool)))
  val ooi = Fun (Output, Fun (Output, Fun (Input, Bool)))
  val plus_nat = Core_Data.functional_compilation @{const_name plus} iio
  val minus_nat = Core_Data.functional_compilation @{const_name "minus"} iio
  fun subtract_nat compfuns (_ : typ) =
    let
      val T = Predicate_Compile_Aux.mk_monadT compfuns @{typ nat}
    in
      absdummy @{typ nat} (absdummy @{typ nat}
        (Const (@{const_name "If"}, @{typ bool} --> T --> T --> T) $
          (@{term "op > :: nat => nat => bool"} $ Bound 1 $ Bound 0) $
          Predicate_Compile_Aux.mk_empty compfuns @{typ nat} $
          Predicate_Compile_Aux.mk_single compfuns
          (@{term "op - :: nat => nat => nat"} $ Bound 0 $ Bound 1)))
    end
  fun enumerate_addups_nat compfuns (_ : typ) =
    absdummy @{typ nat} (Predicate_Compile_Aux.mk_iterate_upto compfuns @{typ "nat * nat"}
    (absdummy @{typ natural} (@{term "Pair :: nat => nat => nat * nat"} $
      (@{term "nat_of_natural"} $ Bound 0) $
      (@{term "op - :: nat => nat => nat"} $ Bound 1 $ (@{term "nat_of_natural"} $ Bound 0))),
      @{term "0 :: natural"}, @{term "natural_of_nat"} $ Bound 0))
  fun enumerate_nats compfuns  (_ : typ) =
    let
      val (single_const, _) = strip_comb (Predicate_Compile_Aux.mk_single compfuns @{term "0 :: nat"})
      val T = Predicate_Compile_Aux.mk_monadT compfuns @{typ nat}
    in
      absdummy @{typ nat} (absdummy @{typ nat}
        (Const (@{const_name If}, @{typ bool} --> T --> T --> T) $
          (@{term "op = :: nat => nat => bool"} $ Bound 0 $ @{term "0::nat"}) $
          (Predicate_Compile_Aux.mk_iterate_upto compfuns @{typ nat} (@{term "nat_of_natural"},
            @{term "0::natural"}, @{term "natural_of_nat"} $ Bound 1)) $
            (single_const $ (@{term "op + :: nat => nat => nat"} $ Bound 1 $ Bound 0))))
    end
in
  Core_Data.force_modes_and_compilations @{const_name plus_eq_nat}
    [(iio, (plus_nat, false)), (oii, (subtract_nat, false)), (ioi, (subtract_nat, false)),
     (ooi, (enumerate_addups_nat, false))]
  #> Predicate_Compile_Fun.add_function_predicate_translation
       (@{term "plus :: nat => nat => nat"}, @{term "plus_eq_nat"})
  #> Core_Data.force_modes_and_compilations @{const_name minus_eq_nat}
       [(iio, (minus_nat, false)), (oii, (enumerate_nats, false))]
  #> Predicate_Compile_Fun.add_function_predicate_translation
      (@{term "minus :: nat => nat => nat"}, @{term "minus_eq_nat"})
  #> Core_Data.force_modes_and_functions @{const_name plus_eq_int}
    [(iio, (@{const_name plus}, false)), (ioi, (@{const_name subtract}, false)),
     (oii, (@{const_name subtract}, false))]
  #> Predicate_Compile_Fun.add_function_predicate_translation
       (@{term "plus :: int => int => int"}, @{term "plus_eq_int"})
  #> Core_Data.force_modes_and_functions @{const_name minus_eq_int}
    [(iio, (@{const_name minus}, false)), (oii, (@{const_name plus}, false)),
     (ioi, (@{const_name minus}, false))]
  #> Predicate_Compile_Fun.add_function_predicate_translation
      (@{term "minus :: int => int => int"}, @{term "minus_eq_int"})
end
\<close>

subsection \<open>Inductive definitions for ordering on naturals\<close>

inductive less_nat
where
  "less_nat 0 (Suc y)"
| "less_nat x y ==> less_nat (Suc x) (Suc y)"

lemma less_nat[code_pred_inline]:
  "x < y = less_nat x y"
apply (rule iffI)
apply (induct x arbitrary: y)
apply (case_tac y) apply (auto intro: less_nat.intros)
apply (case_tac y)
apply (auto intro: less_nat.intros)
apply (induct rule: less_nat.induct)
apply auto
done

inductive less_eq_nat
where
  "less_eq_nat 0 y"
| "less_eq_nat x y ==> less_eq_nat (Suc x) (Suc y)"

lemma [code_pred_inline]:
"x <= y = less_eq_nat x y"
apply (rule iffI)
apply (induct x arbitrary: y)
apply (auto intro: less_eq_nat.intros)
apply (case_tac y) apply (auto intro: less_eq_nat.intros)
apply (induct rule: less_eq_nat.induct)
apply auto done

section \<open>Alternative list definitions\<close>

subsection \<open>Alternative rules for \<open>length\<close>\<close>

definition size_list' :: "'a list => nat"
where "size_list' = size"

lemma size_list'_simps:
  "size_list' [] = 0"
  "size_list' (x # xs) = Suc (size_list' xs)"
by (auto simp add: size_list'_def)

declare size_list'_simps[code_pred_def]
declare size_list'_def[symmetric, code_pred_inline]

subsection \<open>Alternative rules for \<open>list_all2\<close>\<close>

lemma list_all2_NilI [code_pred_intro]: "list_all2 P [] []"
by auto

lemma list_all2_ConsI [code_pred_intro]: "list_all2 P xs ys ==> P x y ==> list_all2 P (x#xs) (y#ys)"
by auto

code_pred [skip_proof] list_all2
proof -
  case list_all2
  from this show thesis
    apply -
    apply (case_tac xb)
    apply (case_tac xc)
    apply auto
    apply (case_tac xc)
    apply auto
    done
qed

subsection \<open>Alternative rules for membership in lists\<close>

declare in_set_member[code_pred_inline]

lemma member_intros [code_pred_intro]:
  "List.member (x#xs) x"
  "List.member xs x \<Longrightarrow> List.member (y#xs) x"
by(simp_all add: List.member_def)

code_pred List.member
  by(auto simp add: List.member_def elim: list.set_cases)

code_identifier constant member_i_i
   \<rightharpoonup> (SML) "List.member_i_i"
  and (OCaml) "List.member_i_i"
  and (Haskell) "List.member_i_i"
  and (Scala) "List.member_i_i"

code_identifier constant member_i_o
   \<rightharpoonup> (SML) "List.member_i_o"
  and (OCaml) "List.member_i_o"
  and (Haskell) "List.member_i_o"
  and (Scala) "List.member_i_o"

section \<open>Setup for String.literal\<close>

setup \<open>Predicate_Compile_Data.ignore_consts [@{const_name "STR"}]\<close>

section \<open>Simplification rules for optimisation\<close>

lemma [code_pred_simp]: "\<not> False == True"
by auto

lemma [code_pred_simp]: "\<not> True == False"
by auto

lemma less_nat_k_0 [code_pred_simp]: "less_nat k 0 == False"
unfolding less_nat[symmetric] by auto

end


(* Author: Johannes Hölzl <hoelzl@in.tum.de> *)

section \<open>Probabilistic Guarded Command Language (pGCL)\<close>

theory PGCL
  imports "../Markov_Decision_Process"
begin

subsection \<open>Syntax\<close>

datatype 's pgcl =
    Skip
  | Abort
  | Assign "'s \<Rightarrow> 's"
  | Seq "'s pgcl" "'s pgcl"
  | Par "'s pgcl" "'s pgcl"
  | If "'s \<Rightarrow> bool" "'s pgcl" "'s pgcl"
  | Prob "bool pmf" "'s pgcl" "'s pgcl"
  | While "'s \<Rightarrow> bool" "'s pgcl"

subsection \<open>Denotational Semantics\<close>

primrec wp :: "'s pgcl \<Rightarrow> ('s \<Rightarrow> ennreal) \<Rightarrow> ('s \<Rightarrow> ennreal)" where
  "wp Skip f          = f"
| "wp Abort f         = (\<lambda>_. 0)"
| "wp (Assign u) f    = f \<circ> u"
| "wp (Seq c\<^sub>1 c\<^sub>2) f    = wp c\<^sub>1 (wp c\<^sub>2 f)"
| "wp (If b c\<^sub>1 c\<^sub>2) f   = (\<lambda>s. if b s then wp c\<^sub>1 f s else wp c\<^sub>2 f s)"
| "wp (Par c\<^sub>1 c\<^sub>2) f    = wp c\<^sub>1 f \<sqinter> wp c\<^sub>2 f"
| "wp (Prob p c\<^sub>1 c\<^sub>2) f = (\<lambda>s. pmf p True * wp c\<^sub>1 f s + pmf p False * wp c\<^sub>2 f s)"
| "wp (While b c) f   = lfp (\<lambda>X s. if b s then wp c X s else f s)"

lemma wp_mono: "mono (wp c)"
  by (induction c)
     (auto simp: mono_def le_fun_def intro: order_trans le_infI1 le_infI2
           intro!: add_mono mult_left_mono lfp_mono[THEN le_funD])

abbreviation det :: "'s pgcl \<Rightarrow> 's \<Rightarrow> ('s pgcl \<times> 's) pmf set" ("\<lless> _, _ \<ggreater>") where
  "det c s \<equiv> {return_pmf (c, s)}"

subsection \<open>Operational Semantics\<close>

fun step :: "('s pgcl \<times> 's) \<Rightarrow> ('s pgcl \<times> 's) pmf set" where
  "step (Skip, s)        = \<lless>Skip, s\<ggreater>"
| "step (Abort, s)       = \<lless>Abort, s\<ggreater>"
| "step (Assign u, s)    = \<lless>Skip, u s\<ggreater>"
| "step (Seq c\<^sub>1 c\<^sub>2, s)    = (map_pmf (\<lambda>(p1', s'). (if p1' = Skip then c\<^sub>2 else Seq p1' c\<^sub>2, s'))) ` step (c\<^sub>1, s)"
| "step (If b c\<^sub>1 c\<^sub>2, s)   = (if b s then \<lless>c\<^sub>1, s\<ggreater> else \<lless>c\<^sub>2, s\<ggreater>)"
| "step (Par c\<^sub>1 c\<^sub>2, s)    = \<lless>c\<^sub>1, s\<ggreater> \<union> \<lless>c\<^sub>2, s\<ggreater>"
| "step (Prob p c\<^sub>1 c\<^sub>2, s) = {map_pmf (\<lambda>b. if b then (c\<^sub>1, s) else (c\<^sub>2, s)) p}"
| "step (While b c, s)   = (if b s then \<lless>Seq c (While b c), s\<ggreater> else \<lless>Skip, s\<ggreater>)"

lemma step_finite: "finite (step x)"
  by (induction x rule: step.induct) simp_all

lemma step_non_empty: "step x \<noteq> {}"
  by (induction x rule: step.induct) simp_all

interpretation step: Markov_Decision_Process step
  proof qed (rule step_non_empty)

definition rF :: "('s \<Rightarrow> ennreal) \<Rightarrow> (('s pgcl \<times> 's) stream \<Rightarrow> ennreal) \<Rightarrow> ('s pgcl \<times> 's) stream \<Rightarrow> ennreal" where
  "rF f F \<omega> = (if fst (shd \<omega>) = Skip then f (snd (shd \<omega>)) else F (stl \<omega>))"

abbreviation r :: "('s \<Rightarrow> ennreal) \<Rightarrow> ('s pgcl \<times> 's) stream \<Rightarrow> ennreal" where
  "r f \<equiv> lfp (rF f)"

lemma continuous_rF: "sup_continuous (rF f)"
  unfolding rF_def[abs_def]
  by (auto simp: sup_continuous_def fun_eq_iff SUP_sup_distrib [symmetric] image_comp
           split: prod.splits pgcl.splits)

lemma mono_rF: "mono (rF f)"
  using continuous_rF by (rule sup_continuous_mono)

lemma r_unfold: "r f \<omega> = (if fst (shd \<omega>) = Skip then f (snd (shd \<omega>)) else r f (stl \<omega>))"
  by (subst lfp_unfold[OF mono_rF]) (simp add: rF_def)

lemma mono_r: "F \<le> G \<Longrightarrow> r F \<omega> \<le> r G \<omega>"
  by (rule le_funD[of _ _ \<omega>], rule lfp_mono)
     (auto intro!: lfp_mono simp: rF_def le_fun_def max.coboundedI2)

lemma measurable_rF:
  assumes F[measurable]: "F \<in> borel_measurable step.St"
  shows "rF f F \<in> borel_measurable step.St"
  unfolding rF_def[abs_def]
  apply measurable
  apply (rule measurable_compose[OF measurable_shd])
  apply measurable []
  apply (rule measurable_compose[OF measurable_stl])
  apply measurable []
  apply (rule predE)
  apply (rule measurable_compose[OF measurable_shd])
  apply measurable
  done

lemma measurable_r[measurable]: "r f \<in> borel_measurable step.St"
  using continuous_rF measurable_rF by (rule borel_measurable_lfp)

lemma mono_r': "mono (\<lambda>F s. \<Sqinter>D\<in>step s. \<integral>\<^sup>+ t. (if fst t = Skip then f (snd t) else F t) \<partial>measure_pmf D)"
  by (auto intro!: monoI le_funI INF_mono[OF bexI] nn_integral_mono simp: le_fun_def)

lemma E_inf_r:
  "step.E_inf s (r f) =
    lfp (\<lambda>F s. \<Sqinter>D\<in>step s. \<integral>\<^sup>+ t. (if fst t = Skip then f (snd t) else F t) \<partial>measure_pmf D) s"
proof -
  have "step.E_inf s (r f) =
    lfp (\<lambda>F s. \<Sqinter>D\<in>step s. \<integral>\<^sup>+ t. (if fst t = Skip then f (snd t) else F t) \<partial>measure_pmf D) s"
    unfolding rF_def[abs_def]
  proof (rule step.E_inf_lfp[THEN fun_cong])
    let ?F = "\<lambda>t x. (if fst t = Skip then f (snd t) else x)"
    show "(\<lambda>(s, x). ?F s x) \<in> borel_measurable (count_space UNIV \<Otimes>\<^sub>M borel)"
      apply (simp add: measurable_split_conv split_beta')
      apply (intro borel_measurable_max borel_measurable_const measurable_If predE
         measurable_compose[OF measurable_snd] measurable_compose[OF measurable_fst])
      apply measurable
      done
    show "\<And>s. sup_continuous (?F s)"
      by (auto simp: sup_continuous_def SUP_sup_distrib[symmetric] split: prod.split pgcl.split)
    show "\<And>F cfg. (\<integral>\<^sup>+\<omega>. ?F (state cfg) (F \<omega>) \<partial>step.T cfg) =
      ?F (state cfg) (nn_integral (step.T cfg) F)"
      by (auto simp: split: pgcl.split prod.split)
  qed (rule step_finite)
  then show ?thesis
    by simp
qed

lemma E_inf_r_unfold:
  "step.E_inf s (r f) = (\<Sqinter>D\<in>step s. \<integral>\<^sup>+ t. (if fst t = Skip then f (snd t) else step.E_inf t (r f)) \<partial>measure_pmf D)"
  unfolding E_inf_r by (simp add: lfp_unfold[OF mono_r'])

lemma E_inf_r_induct[consumes 1, case_names step]:
  assumes "P s y"
  assumes *: "\<And>F s y. P s y \<Longrightarrow>
    (\<And>s y. P s y \<Longrightarrow> F s \<le> y) \<Longrightarrow> (\<And>s. F s \<le> step.E_inf s (r f)) \<Longrightarrow>
    (\<Sqinter>D\<in>step s. \<integral>\<^sup>+ t. (if fst t = Skip then f (snd t) else F t) \<partial>measure_pmf D) \<le> y"
  shows "step.E_inf s (r f) \<le> y"
  using \<open>P s y\<close>
  unfolding E_inf_r
proof (induction arbitrary: s y rule: lfp_ordinal_induct[OF mono_r'[where f=f]])
  case (1 F) with *[of s y F] show ?case
    unfolding le_fun_def E_inf_r[where f=f, symmetric] by simp
qed (auto intro: SUP_least)

lemma E_inf_Skip: "step.E_inf (Skip, s) (r f) = f s"
  by (subst E_inf_r_unfold) simp

lemma E_inf_Seq:
  assumes [simp]: "\<And>x. 0 \<le> f x"
  shows "step.E_inf (Seq a b, s) (r f) = step.E_inf (a, s) (r (\<lambda>s. step.E_inf (b, s) (r f)))"
proof (rule antisym)
  show "step.E_inf (Seq a b, s) (r f) \<le> step.E_inf (a, s) (r (\<lambda>s. step.E_inf (b, s) (r f)))"
  proof (coinduction arbitrary: a s rule: E_inf_r_induct)
    case step then show ?case
      by (rewrite in "_ \<le> \<hole>" E_inf_r_unfold)
         (force intro!: INF_mono[OF bexI] nn_integral_mono intro: le_infI2
                simp: E_inf_Skip image_comp)
  qed
  show "step.E_inf (a, s) (r (\<lambda>s. step.E_inf (b, s) (r f))) \<le> step.E_inf (Seq a b, s) (r f)"
  proof (coinduction arbitrary: a s rule: E_inf_r_induct)
    case step then show ?case
      by (rewrite in "_ \<le> \<hole>" E_inf_r_unfold)
         (force intro!: INF_mono[OF bexI] nn_integral_mono intro: le_infI2
                simp: E_inf_Skip image_comp)
   qed
qed

lemma E_inf_While:
  "step.E_inf (While g c, s) (r f) =
    lfp (\<lambda>F s. if g s then step.E_inf (c, s) (r F) else f s) s"
proof (rule antisym)
  have E_inf_While_step: "step.E_inf (While g c, s) (r f) =
    (if g s then step.E_inf (c, s) (r (\<lambda>s. step.E_inf (While g c, s) (r f))) else f s)" for f s
    by (rewrite E_inf_r_unfold) (simp add: min_absorb1 E_inf_Seq)

  have "mono (\<lambda>F s. if g s then step.E_inf (c, s) (r F) else f s)" (is "mono ?F")
    by (auto intro!: mono_r step.E_inf_mono simp: mono_def le_fun_def max.coboundedI2)
  then show "lfp ?F s \<le> step.E_inf (While g c, s) (r f)"
  proof (induction arbitrary: s rule: lfp_ordinal_induct[consumes 1])
    case mono then show ?case
      by (rewrite E_inf_While_step) (auto intro!: step.E_inf_mono mono_r le_funI)
  qed (auto intro: SUP_least)

  define w where "w F s = (\<Sqinter>D\<in>step s. \<integral>\<^sup>+ t. (if fst t = Skip then if g (snd t) then F (c, snd t) else f (snd t) else F t) \<partial>measure_pmf D)"
    for F s
  have "mono w"
    by (auto simp: w_def mono_def le_fun_def intro!: INF_mono[OF bexI] nn_integral_mono) []

  define d where "d = c"
  define t where "t = Seq d (While g c)"
  then have "(t = While g c \<and> d = c \<and> g s) \<or> t = Seq d (While g c)"
    by auto
  then have "step.E_inf (t, s) (r f) \<le> lfp w (d, s)"
  proof (coinduction arbitrary: t d s rule: E_inf_r_induct)
    case (step F t d s)
    from step(1)
    show ?case
    proof (elim conjE disjE)
      { fix s have "\<not> g s \<Longrightarrow> F (While g c, s) \<le> f s"
          using step(3)[of "(While g c, s)"] by (simp add: E_inf_While_step) }
      note [simp] = this
      assume "t = Seq d (While g c)" then show ?thesis
        by (rewrite lfp_unfold[OF \<open>mono w\<close>])
           (auto simp: max.absorb2 w_def intro!: INF_mono[OF bexI] nn_integral_mono step)
    qed (auto intro!: step)
  qed
  also have "lfp w = lfp (\<lambda>F s. step.E_inf s (r (\<lambda>s. if g s then F (c, s) else f s)))"
    unfolding E_inf_r w_def
    by (rule lfp_lfp[symmetric]) (auto simp: le_fun_def intro!: INF_mono[OF bexI] nn_integral_mono)
  finally have "step.E_inf (While g c, s) (r f) \<le> (if g s then \<dots> (c, s) else f s)"
    unfolding t_def d_def by (rewrite E_inf_r_unfold) simp
  also have "\<dots> = lfp ?F s"
    by (rewrite lfp_rolling[symmetric, of "\<lambda>F s. if g s then F (c, s) else f s"  "\<lambda>F s. step.E_inf s (r F)"])
       (auto simp: mono_def le_fun_def sup_apply[abs_def] if_distrib[of "max 0"] max.coboundedI2 max.absorb2
                intro!: step.E_inf_mono mono_r cong del: if_weak_cong)
  finally show "step.E_inf (While g c, s) (r f) \<le> \<dots>"
    .
qed

subsection \<open>Equate Both Semantics\<close>

lemma E_inf_r_eq_wp: "step.E_inf (c, s) (r f) = wp c f s"
proof (induction c arbitrary: f s)
  case Skip then show ?case
    by (simp add: E_inf_Skip)
next
  case Abort then show ?case
  proof (intro antisym)
    have "lfp (\<lambda>F s. \<Sqinter>D\<in>step s. \<integral>\<^sup>+ t. (if fst t = Skip then f (snd t) else F t) \<partial>measure_pmf D) \<le>
      (\<lambda>s. if \<exists>t. s = (Abort, t) then 0 else \<top>)"
      by (intro lfp_lowerbound) (auto simp: le_fun_def)
    then show "step.E_inf (Abort, s) (r f) \<le> wp Abort f s"
      by (auto simp: E_inf_r le_fun_def split: if_split_asm)
  qed simp
next
  case Assign then show ?case
    by (rewrite E_inf_r_unfold) (simp add: min_absorb1)
next
  case (If b c1 c2) then show ?case
    by (rewrite E_inf_r_unfold) auto
next
  case (Prob p c1 c2) then show ?case
    apply (rewrite E_inf_r_unfold)
    apply auto
    apply (rewrite nn_integral_measure_pmf_support[of "UNIV::bool set"])
    apply (auto simp: UNIV_bool ac_simps)
    done
next
  case (Par c1 c2) then show ?case
    by (rewrite E_inf_r_unfold) (auto intro: inf.commute)
next
  case (Seq c1 c2) then show ?case
    by (simp add: E_inf_Seq)
next
  case (While g c) then show ?case
    apply (simp add: E_inf_While)
    apply (rewrite While)
    apply auto
    done
qed

end


theory Intercala
imports Main
begin

section {* Ejemplo de función recursiva no primitiva recursiva *}

text {* (intercala x ys) es la lista obtenida intercalando x entre los
  elementos de ys. Por ejemplo,
     intercala a [x,y,z] = [x, a, y, a, z]" by simp
*}
fun intercala :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "intercala a []       = []"
| "intercala a [x]      = [x]"
| "intercala a (x#y#zs) = x # a # intercala a (y#zs)"

value "intercala a [x,y,z]"
lemma "intercala a [x,y,z] = [x, a, y, a, z]" by simp

end


section \<open> Extensional Mereology \<close>

(*<*)
theory EM
  imports MM
begin
(*>*)

text \<open> Extensional mereology adds to ground mereology the axiom of strong supplementation.\footnote{
See \<^cite>\<open>"simons_parts:_1987"\<close> p. 29, \<^cite>\<open>"varzi_parts_1996"\<close> p. 262 and \<^cite>\<open>"casati_parts_1999"\<close>
p. 39-40.} \<close>

locale EM = M +
  assumes strong_supplementation:
    "\<not> P x y \<Longrightarrow> (\<exists>z. P z x \<and> \<not> O z y)"
begin

text \<open> Strong supplementation entails weak supplementation.\footnote{See \<^cite>\<open>"simons_parts:_1987"\<close>
p. 29 and \<^cite>\<open>"casati_parts_1999"\<close> p. 40.} \<close>

lemma weak_supplementation: "PP x y \<Longrightarrow> (\<exists>z. P z y \<and> \<not> O z x)"
proof -
  assume "PP x y"
  hence "\<not> P y x" by (rule proper_implies_not_part)
  thus "\<exists>z. P z y \<and> \<not> O z x" by (rule strong_supplementation)
qed

end

text \<open> So minimal mereology is a subtheory of extensional mereology.\footnote{\<^cite>\<open>"casati_parts_1999"\<close> p. 40.} \<close>

sublocale EM \<subseteq> MM
proof
  fix y x
  show "PP y x \<Longrightarrow> \<exists>z. P z x \<and> \<not> O z y" using weak_supplementation.
qed

text \<open> Strong supplementation also entails the proper parts principle.\footnote{See \<^cite>\<open>"simons_parts:_1987"\<close>
pp. 28-9 and \<^cite>\<open>"varzi_parts_1996"\<close> p. 263.} \<close>

context EM
begin

lemma proper_parts_principle:
"(\<exists>z. PP z x) \<Longrightarrow> (\<forall>z. PP z x \<longrightarrow> P z y) \<Longrightarrow> P x y"
proof -
  assume "\<exists>z. PP z x"
  then obtain v where v: "PP v x"..
  hence "P v x" by (rule proper_implies_part)
  assume antecedent: "\<forall>z. PP z x \<longrightarrow> P z y"
  hence "PP v x \<longrightarrow> P v y"..
  hence "P v y" using \<open>PP v x\<close>..
  with \<open>P v x\<close> have "P v x \<and> P v y"..
  hence "\<exists>v. P v x \<and> P v y"..
  with overlap_eq have "O x y"..
  show "P x y"
  proof (rule ccontr)
    assume "\<not> P x y"
    hence "\<exists>z. P z x \<and> \<not> O z y"
      by (rule strong_supplementation)
    then obtain z where z: "P z x \<and> \<not> O z y"..
    hence "P z x"..
    moreover have "z \<noteq> x"
    proof
      assume "z = x"
      moreover from z have "\<not> O z y"..
      ultimately have "\<not> O x y" by (rule subst)
      thus "False"  using \<open>O x y\<close>..
    qed
    ultimately have "P z x \<and> z \<noteq> x"..
    with nip_eq have "PP z x"..
    from antecedent have "PP z x \<longrightarrow> P z y"..
    hence "P z y" using \<open>PP z x\<close>..
    hence "O z y" by (rule part_implies_overlap)
    from z have "\<not> O z y"..
    thus "False" using \<open>O z y\<close>..
  qed
qed

text \<open> Which with antisymmetry entails the extensionality of proper parthood.\footnote{See
\<^cite>\<open>"simons_parts:_1987"\<close> p. 28, \<^cite>\<open>"varzi_parts_1996"\<close> p. 263 and \<^cite>\<open>"casati_parts_1999"\<close>
p. 40.} \<close>

theorem proper_part_extensionality:
"(\<exists>z. PP z x \<or> PP z y) \<Longrightarrow> x = y \<longleftrightarrow> (\<forall>z. PP z x \<longleftrightarrow> PP z y)"
proof -
  assume antecedent: "\<exists>z. PP z x \<or> PP z y"
  show "x = y \<longleftrightarrow> (\<forall>z. PP z x \<longleftrightarrow> PP z y)"
  proof
    assume "x = y"
    moreover have "\<forall>z. PP z x \<longleftrightarrow> PP z x" by simp
    ultimately show "\<forall>z. PP z x \<longleftrightarrow> PP z y" by (rule subst)
  next
    assume right: "\<forall>z. PP z x \<longleftrightarrow> PP z y"
    have "\<forall>z. PP z x \<longrightarrow> P z y"
    proof
      fix z
      show "PP z x \<longrightarrow> P z y"
      proof
        assume "PP z x"
        from right have "PP z x \<longleftrightarrow> PP z y"..
        hence "PP z y" using \<open>PP z x\<close>..
        thus "P z y" by (rule proper_implies_part)
      qed
    qed
    have "\<forall>z. PP z y \<longrightarrow> P z x"
    proof
      fix z
      show "PP z y \<longrightarrow> P z x"
      proof
        assume "PP z y"
        from right have "PP z x \<longleftrightarrow> PP z y"..
        hence "PP z x" using \<open>PP z y\<close>..
        thus "P z x" by (rule proper_implies_part)
      qed
    qed
    from antecedent obtain z where z: "PP z x \<or> PP z y"..
    thus "x = y"
    proof (rule disjE)
      assume "PP z x"
      hence "\<exists>z. PP z x"..
      hence "P x y" using \<open>\<forall>z. PP z x \<longrightarrow> P z y\<close>
        by (rule proper_parts_principle)
      from right have "PP z x \<longleftrightarrow> PP z y"..
      hence "PP z y" using \<open>PP z x\<close>..
      hence "\<exists>z. PP z y"..
      hence "P y x" using \<open>\<forall>z. PP z y \<longrightarrow> P z x\<close>
        by (rule proper_parts_principle)
      with \<open>P x y\<close> show "x = y"
        by (rule part_antisymmetry)
    next
      assume "PP z y"
      hence "\<exists>z. PP z y"..
      hence "P y x" using \<open>\<forall>z. PP z y \<longrightarrow> P z x\<close>
        by (rule proper_parts_principle)
      from right have "PP z x \<longleftrightarrow> PP z y"..
      hence "PP z x" using \<open>PP z y\<close>..
      hence "\<exists>z. PP z x"..
      hence "P x y" using \<open>\<forall>z. PP z x \<longrightarrow> P z y\<close>
          by (rule proper_parts_principle)
      thus "x = y"
        using \<open>P y x\<close> by (rule part_antisymmetry)
    qed
  qed
qed

text \<open> It also follows from strong supplementation that parthood is definable in terms of overlap.\footnote{
See \<^cite>\<open>"parsons_many_2014"\<close> p. 4.}  \<close>

lemma part_overlap_eq: "P x y \<longleftrightarrow> (\<forall>z. O z x \<longrightarrow> O z y)"
proof
  assume "P x y"
  show "(\<forall>z. O z x \<longrightarrow> O z y)"
  proof
    fix z
    show "O z x \<longrightarrow> O z y"
    proof
      assume "O z x"
      with \<open>P x y\<close> show "O z y"
        by (rule overlap_monotonicity)
    qed
  qed
next
  assume right: "\<forall>z. O z x \<longrightarrow> O z y"
  show "P x y"
  proof (rule ccontr)
    assume "\<not> P x y"
    hence "\<exists>z. P z x \<and> \<not> O z y"
      by (rule strong_supplementation)
    then obtain z where z: "P z x \<and> \<not> O z y"..
    hence "\<not> O z y"..
    from right have "O z x \<longrightarrow> O z y"..
    moreover from z have "P z x"..
    hence "O z x" by (rule part_implies_overlap)
    ultimately have "O z y"..
    with \<open>\<not> O z y\<close> show "False"..
  qed
qed

text \<open> Which entails the extensionality of overlap. \<close>

theorem overlap_extensionality: "x = y \<longleftrightarrow> (\<forall>z. O z x \<longleftrightarrow> O z y)"
proof
  assume "x = y"
  moreover have "\<forall>z. O z x \<longleftrightarrow> O z x"
  proof
    fix z
    show "O z x \<longleftrightarrow> O z x"..
  qed
  ultimately show "\<forall>z. O z x \<longleftrightarrow> O z y"
    by (rule subst)
next
  assume right: "\<forall>z. O z x \<longleftrightarrow> O z y"
  have "\<forall>z. O z y \<longrightarrow> O z x"
  proof
    fix z
    from right have "O z x \<longleftrightarrow> O z y"..
    thus "O z y \<longrightarrow> O z x"..
  qed
  with part_overlap_eq have "P y x"..
  have "\<forall>z. O z x \<longrightarrow> O z y"
  proof
    fix z
    from right have "O z x \<longleftrightarrow> O z y"..
    thus "O z x \<longrightarrow> O z y"..
  qed
  with part_overlap_eq have "P x y"..
  thus "x = y"
    using \<open>P y x\<close> by (rule part_antisymmetry)
qed

end

(*<*) end (*>*)


section \<open> Alphabetised Predicates \<close>

theory utp_pred
imports
  utp_expr_funcs
  utp_subst
  utp_meta_subst
  utp_tactics
  utp_lift_parser
  utp_lift_pretty
begin

text \<open> In this theory we begin to create an Isabelle version of the alphabetised predicate calculus
  that is described in Chapter 1 of the UTP book~\cite{Hoare&98}. \<close>

subsection \<open> Predicate type and syntax \<close>

text \<open> An alphabetised predicate is a simply a boolean valued expression. \<close>

type_synonym '\<alpha> upred = "(bool, '\<alpha>) uexpr"

translations
  (type) "'\<alpha> upred" <= (type) "(bool, '\<alpha>) uexpr"

text \<open> We want to remain as close as possible to the mathematical UTP syntax, but also
        want to be conservative with HOL. For this reason we chose not to steal syntax
        from HOL, but where possible use polymorphism to allow selection of the appropriate
        operator (UTP vs. HOL). Thus we will first remove the standard syntax for conjunction,
        disjunction, and negation, and replace these with adhoc overloaded definitions. We
        similarly use polymorphic constants for the other predicate calculus operators. \<close>

purge_notation
  conj (infixr "\<and>" 35) and
  disj (infixr "\<or>" 30) and
  Not ("\<not> _" [40] 40)

consts
  uconj  :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<and>" 35)
  udisj  :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<or>" 30)
  uimpl  :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<Rightarrow>" 25)
  uiff   :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<Leftrightarrow>" 25)
  unot   :: "'a \<Rightarrow> 'a" ("\<not> _" [40] 40)
  uex    :: "('a \<Longrightarrow> '\<alpha>) \<Rightarrow> 'p \<Rightarrow> 'p"
  uall   :: "('a \<Longrightarrow> '\<alpha>) \<Rightarrow> 'p \<Rightarrow> 'p"

adhoc_overloading
  uconj conj and
  udisj disj and
  unot Not

utp_const
  uex(0) uall(0) unot uconj udisj uimpl uiff

abbreviation shEx :: "['\<beta> \<Rightarrow>'\<alpha> upred] \<Rightarrow> '\<alpha> upred" where
"shEx P \<equiv> \<guillemotleft>Ex\<guillemotright> |> uabs P"

abbreviation shAll :: "['\<beta> \<Rightarrow>'\<alpha> upred] \<Rightarrow> '\<alpha> upred" where
"shAll P \<equiv> \<guillemotleft>All\<guillemotright> |> uabs P"

utp_const shEx shAll

text \<open> We set up two versions of each of the quantifiers: @{const uex} / @{const uall} and
        @{const shEx} / @{const shAll}. The former pair allows quantification of UTP variables,
        whilst the latter allows quantification of HOL variables in concert with the literal
        expression constructor @{term "\<guillemotleft>x\<guillemotright>"}. Both varieties will be needed at various points.
        Syntactically they are distinguished by a boldface quantifier
        for the HOL versions (achieved by the "bold" escape in Isabelle). \<close>

nonterminal idt_list

syntax
  "_idt_el"  :: "idt \<Rightarrow> idt_list" ("_")
  "_idt_list" :: "idt \<Rightarrow> idt_list \<Rightarrow> idt_list" ("(_,/ _)" [0, 1])
  "_uex"     :: "salpha \<Rightarrow> logic \<Rightarrow> logic" ("\<exists> _ \<bullet> _" [0, 10] 10)
  "_uall"    :: "salpha \<Rightarrow> logic \<Rightarrow> logic" ("\<forall> _ \<bullet> _" [0, 10] 10)
  "_shEx"   :: "pttrn \<Rightarrow> logic \<Rightarrow> logic"   ("\<^bold>\<exists> _ \<bullet> _" [0, 10] 10)
  "_shAll"  :: "pttrn \<Rightarrow> logic \<Rightarrow> logic"   ("\<^bold>\<forall> _ \<bullet> _" [0, 10] 10)
  "_shBEx"  :: "pttrn \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic"   ("\<^bold>\<exists> _ \<in> _ \<bullet> _" [0, 0, 10] 10)
  "_shBAll" :: "pttrn \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic"   ("\<^bold>\<forall> _ \<in> _ \<bullet> _" [0, 0, 10] 10)
  "_shGAll" :: "pttrn \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic"   ("\<^bold>\<forall> _ | _ \<bullet> _" [0, 0, 10] 10)
  "_shGtAll" :: "idt \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("\<^bold>\<forall> _ > _ \<bullet> _" [0, 0, 10] 10)
  "_shLtAll" :: "idt \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("\<^bold>\<forall> _ < _ \<bullet> _" [0, 0, 10] 10)
  "_uvar_res" :: "logic \<Rightarrow> salpha \<Rightarrow> logic" (infixl "\<restriction>\<^sub>v" 90)

translations
  "_uex x P"                   == "CONST uex x P"
  "_uex (_salphaset (_salphamk (x +\<^sub>L y))) P"  <= "_uex (x +\<^sub>L y) P"
  "_uall x P"                  == "CONST uall x P"
  "_uall (_salphaset (_salphamk (x +\<^sub>L y))) P"  <= "_uall (x +\<^sub>L y) P"
  "_shEx x P"                 == "CONST shEx (\<lambda> x. P)"
  "\<^bold>\<exists> x \<in> A \<bullet> P"                => "\<^bold>\<exists> x \<bullet> \<guillemotleft>x\<guillemotright> \<in>\<^sub>u A \<and> P"
  "_shAll x P"                == "CONST shAll (\<lambda> x. P)"
  "\<^bold>\<forall> x \<in> A \<bullet> P"                => "\<^bold>\<forall> x \<bullet> \<guillemotleft>x\<guillemotright> \<in>\<^sub>u A \<Rightarrow> P"
  "\<^bold>\<forall> x | P \<bullet> Q"                => "\<^bold>\<forall> x \<bullet> P \<Rightarrow> Q"
  "\<^bold>\<forall> x > y \<bullet> P"                => "\<^bold>\<forall> x \<bullet> CONST bop CONST less y \<guillemotleft>x\<guillemotright> \<Rightarrow> P"
  "\<^bold>\<forall> x < y \<bullet> P"                => "\<^bold>\<forall> x \<bullet> CONST bop CONST less \<guillemotleft>x\<guillemotright> y \<Rightarrow> P"

  "_UTP (_uex x P)"            <= "_uex x (_UTP P)"
  "_UTP (_uall x P)"           <= "_uall x (_UTP P)"
  "_UTP (_shEx x P)"            <= "_shEx x (_UTP P)"
  "_UTP (_shAll x P)"           <= "_shAll x (_UTP P)"

subsection \<open> Predicate operators \<close>

text \<open> We chose to maximally reuse definitions and laws built into HOL. For this reason,
        when introducing the core operators we proceed by lifting operators from the
        polymorphic algebraic hierarchy of HOL. Thus the initial definitions take
        place in the context of type class instantiations. We first introduce our own
        class called \emph{refine} that will add the refinement operator syntax to
        the HOL partial order class. \<close>

purge_notation ref_by (infix "\<sqsubseteq>" 50)

class refine = order

abbreviation refineBy :: "'a::refine \<Rightarrow> 'a \<Rightarrow> bool"  (infix "\<sqsubseteq>" 50) where
"P \<sqsubseteq> Q \<equiv> less_eq Q P"

text \<open> Since, on the whole, lattices in UTP are the opposite way up to the standard definitions
        in HOL, we syntactically invert the lattice operators. This is the one exception where
        we do steal HOL syntax, but I think it makes sense for UTP. Indeed we make this
        inversion for all of the lattice operators. \<close>

purge_notation Lattices.inf (infixl "\<sqinter>" 70)
notation Lattices.inf (infixl "\<squnion>" 70)
purge_notation Lattices.sup (infixl "\<squnion>" 65)
notation Lattices.sup (infixl "\<sqinter>" 65)

purge_notation Inf ("\<Sqinter>_" [900] 900)
notation Inf ("\<Squnion>_" [900] 900)
purge_notation Sup ("\<Squnion>_" [900] 900)
notation Sup ("\<Sqinter>_" [900] 900)

purge_notation Orderings.bot ("\<bottom>")
notation Orderings.bot ("\<top>")
purge_notation Orderings.top ("\<top>")
notation Orderings.top ("\<bottom>")

purge_syntax
  "_INF1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Sqinter>_./ _)" [0, 10] 10)
  "_INF"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Sqinter>_\<in>_./ _)" [0, 0, 10] 10)
  "_SUP1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Squnion>_./ _)" [0, 10] 10)
  "_SUP"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Squnion>_\<in>_./ _)" [0, 0, 10] 10)

syntax
  "_INF1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Squnion>_./ _)" [0, 10] 10)
  "_INF"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Squnion>_\<in>_./ _)" [0, 0, 10] 10)
  "_SUP1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Sqinter>_./ _)" [0, 10] 10)
  "_SUP"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Sqinter>_\<in>_./ _)" [0, 0, 10] 10)

text \<open> We trivially instantiate our refinement class \<close>

instance uexpr :: (order, type) refine ..

\<comment> \<open> Configure transfer law for refinement for the fast relational tactics. \<close>

theorem upred_ref_iff [uexpr_transfer_laws]:
"(P \<sqsubseteq> Q) = (\<forall>b. \<lbrakk>Q\<rbrakk>\<^sub>e b \<longrightarrow> \<lbrakk>P\<rbrakk>\<^sub>e b)"
  apply (transfer)
  apply (clarsimp)
  done

text \<open> Next we introduce the lattice operators, which is again done by lifting. \<close>

instantiation uexpr :: (lattice, type) lattice
begin
  lift_definition sup_uexpr :: "('a, 'b) uexpr \<Rightarrow> ('a, 'b) uexpr \<Rightarrow> ('a, 'b) uexpr"
  is "\<lambda>P Q A. Lattices.sup (P A) (Q A)" .
  lift_definition inf_uexpr :: "('a, 'b) uexpr \<Rightarrow> ('a, 'b) uexpr \<Rightarrow> ('a, 'b) uexpr"
  is "\<lambda>P Q A. Lattices.inf (P A) (Q A)" .
instance
  by (intro_classes) (transfer, auto)+
end

instantiation uexpr :: (bounded_lattice, type) bounded_lattice
begin
  lift_definition bot_uexpr :: "('a, 'b) uexpr" is "\<lambda> A. Orderings.bot" .
  lift_definition top_uexpr :: "('a, 'b) uexpr" is "\<lambda> A. Orderings.top" .
instance
  by (intro_classes) (transfer, auto)+
end

lemma top_uexpr_rep_eq [simp]:
  "\<lbrakk>Orderings.bot\<rbrakk>\<^sub>e b = False"
  by (transfer, auto)

lemma bot_uexpr_rep_eq [simp]:
  "\<lbrakk>Orderings.top\<rbrakk>\<^sub>e b = True"
  by (transfer, auto)

instance uexpr :: (distrib_lattice, type) distrib_lattice
  by (intro_classes) (transfer, rule ext, auto simp add: sup_inf_distrib1)

text \<open> Finally we show that predicates form a Boolean algebra (under the lattice operators),
  a complete lattice, a completely distribute lattice, and a complete boolean algebra. This
  equip us with a very complete theory for basic logical propositions. \<close>

instance uexpr :: (boolean_algebra, type) boolean_algebra
  apply (intro_classes, unfold uexpr_defs; transfer, rule ext)
    apply (simp_all add: sup_inf_distrib1 diff_eq)
  done

instantiation uexpr :: (complete_lattice, type) complete_lattice
begin
  lift_definition Inf_uexpr :: "('a, 'b) uexpr set \<Rightarrow> ('a, 'b) uexpr"
  is "\<lambda> PS A. INF P\<in>PS. P(A)" .
  lift_definition Sup_uexpr :: "('a, 'b) uexpr set \<Rightarrow> ('a, 'b) uexpr"
  is "\<lambda> PS A. SUP P\<in>PS. P(A)" .
instance
  by (intro_classes)
     (transfer, auto intro: INF_lower SUP_upper simp add: INF_greatest SUP_least)+
end

instance uexpr :: (complete_distrib_lattice, type) complete_distrib_lattice
  by (intro_classes; transfer; auto simp add: INF_SUP_set)

instance uexpr :: (complete_boolean_algebra, type) complete_boolean_algebra ..

text \<open> From the complete lattice, we can also define and give syntax for the fixed-point operators.
  Like the lattice operators, these are reversed in UTP. \<close>

syntax
  "_mu" :: "pttrn \<Rightarrow> logic \<Rightarrow> logic" ("\<mu> _ \<bullet> _" [0, 10] 10)
  "_nu" :: "pttrn \<Rightarrow> logic \<Rightarrow> logic" ("\<nu> _ \<bullet> _" [0, 10] 10)

notation gfp ("\<mu>")
notation lfp ("\<nu>")

translations
  "\<nu> X \<bullet> P" == "CONST lfp (\<lambda> X. P)"
  "\<mu> X \<bullet> P" == "CONST gfp (\<lambda> X. P)"

text \<open> With the lattice operators defined, we can proceed to give definitions for the
        standard predicate operators in terms of them. \<close>

definition "true_upred  = (Orderings.top :: '\<alpha> upred)"
definition "false_upred = (Orderings.bot :: '\<alpha> upred)"
definition "conj_upred  = (Lattices.inf :: '\<alpha> upred \<Rightarrow> '\<alpha> upred \<Rightarrow> '\<alpha> upred)"
definition "disj_upred  = (Lattices.sup :: '\<alpha> upred \<Rightarrow> '\<alpha> upred \<Rightarrow> '\<alpha> upred)"
definition "not_upred   = (uminus :: '\<alpha> upred \<Rightarrow> '\<alpha> upred)"
definition "diff_upred  = (minus :: '\<alpha> upred \<Rightarrow> '\<alpha> upred \<Rightarrow> '\<alpha> upred)"

abbreviation Conj_upred :: "'\<alpha> upred set \<Rightarrow> '\<alpha> upred" ("\<And>_" [900] 900) where
"\<And> A \<equiv> \<Squnion> A"

abbreviation Disj_upred :: "'\<alpha> upred set \<Rightarrow> '\<alpha> upred" ("\<Or>_" [900] 900) where
"\<Or> A \<equiv> \<Sqinter> A"

notation
  conj_upred (infixr "\<and>\<^sub>p" 35) and
  disj_upred (infixr "\<or>\<^sub>p" 30)

text \<open> Perhaps slightly confusingly, the UTP infimum is the HOL supremum and vice-versa. This is
  because, again, in UTP the lattice is inverted due to the definition of refinement and a desire
  to have miracle at the top, and abort at the bottom. \<close>

lift_definition UINFIMUM :: "'a set \<Rightarrow> ('a \<Rightarrow> ('b::complete_lattice, 's) uexpr) \<Rightarrow> ('b, 's) uexpr"
is "\<lambda> A F b. Sup {\<lbrakk>F x\<rbrakk>\<^sub>e b | x. x \<in> A}" .

lift_definition USUPREMUM :: "'a set \<Rightarrow> ('a \<Rightarrow> ('b::complete_lattice, 's) uexpr) \<Rightarrow> ('b, 's) uexpr"
is "\<lambda> A F b. Inf {\<lbrakk>F x\<rbrakk>\<^sub>e b | x. x \<in> A}" .

update_uexpr_rep_eq_thms

syntax
  "_USup"     :: "pttrn \<Rightarrow> logic \<Rightarrow> logic"                   ("\<And> _ \<bullet> _" [0, 10] 10)
  "_USup"     :: "pttrn \<Rightarrow> logic \<Rightarrow> logic"                   ("\<Squnion> _ \<bullet> _" [0, 10] 10)
  "_USup_mem" :: "pttrn \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic"          ("\<And> _\<in>_ \<bullet> _" [0, 0, 10] 10)
  "_USup_mem" :: "pttrn \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic"          ("\<Squnion> _\<in>_ \<bullet> _" [0, 0, 10] 10)
  "_UInf"     :: "pttrn \<Rightarrow> logic \<Rightarrow> logic"                   ("\<Or> _ \<bullet> _" [0, 10] 10)
  "_UInf"     :: "pttrn \<Rightarrow> logic \<Rightarrow> logic"                   ("\<Sqinter> _ \<bullet> _" [0, 10] 10)
  "_UInf_mem" :: "pttrn \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic"          ("\<Or> _\<in>_ \<bullet> _" [0, 10] 10)
  "_UInf_mem" :: "pttrn \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic"          ("\<Sqinter> _\<in>_ \<bullet> _" [0, 10] 10)

translations
  "\<Sqinter> x \<in> A \<bullet> F" == "CONST UINFIMUM A (\<lambda> x. F)"
  "\<Sqinter> x \<bullet> F"     == "\<Sqinter> x \<in> CONST UNIV \<bullet> F"
  "\<Squnion> x \<in> A \<bullet> F" == "CONST USUPREMUM A (\<lambda> x. F)"
  "\<Squnion> x \<bullet> F"     == "\<Squnion> x \<in> CONST UNIV \<bullet> F"

text \<open> We also define the other predicate operators \<close>

lift_definition impl::"'\<alpha> upred \<Rightarrow> '\<alpha> upred \<Rightarrow> '\<alpha> upred" is
"\<lambda> P Q A. P A \<longrightarrow> Q A" .

lift_definition iff_upred ::"'\<alpha> upred \<Rightarrow> '\<alpha> upred \<Rightarrow> '\<alpha> upred" is
"\<lambda> P Q A. P A \<longleftrightarrow> Q A" .

lift_definition ex :: "('a \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<alpha> upred \<Rightarrow> '\<alpha> upred" is
"\<lambda> x P b. (\<exists> v. P(put\<^bsub>x\<^esub> b v))" .

lift_definition all :: "('a \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<alpha> upred \<Rightarrow> '\<alpha> upred" is
"\<lambda> x P b. (\<forall> v. P(put\<^bsub>x\<^esub> b v))" .

lift_definition scex :: "'s scene \<Rightarrow> 's upred \<Rightarrow> 's upred" is
"\<lambda> a P b. \<exists> b'. P(b \<oplus>\<^sub>S b' on a)" .

lift_definition scall :: "'s scene \<Rightarrow> 's upred \<Rightarrow> 's upred" is
"\<lambda> a P b. \<forall> b'. P(b \<oplus>\<^sub>S b' on a)" .

text \<open> We define the following operator which is dual of existential quantification. It hides the
  valuation of variables other than $x$ through existential quantification. \<close>

lift_definition var_res :: "'\<alpha> upred \<Rightarrow> ('a \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<alpha> upred" is
"\<lambda> P x b. \<exists> b'. P (b' \<oplus>\<^sub>L b on x)" .

translations
  "_uvar_res P a" \<rightleftharpoons> "CONST var_res P a"

text \<open> We have to add a u subscript to the closure operator as I don't want to override the syntax
        for HOL lists (we'll be using them later). \<close>

lift_definition closure::"'\<alpha> upred \<Rightarrow> '\<beta> upred" ("[_]\<^sub>u") is
"\<lambda> P A. \<forall>A'. P A'" .

lift_definition taut :: "'\<alpha> upred \<Rightarrow> bool" ("`_`")
is "\<lambda> P. \<forall> A. P A" .

declare taut_def [uexpr_transfer_laws]

text \<open> The following function extracts the characteristic set of a predicate \<close>

lift_definition upred_set :: "'a upred \<Rightarrow> 'a set" ("\<lbrakk>_\<rbrakk>\<^sub>p") is
"\<lambda> P. Collect P" .

text \<open> Configuration for UTP tactics \<close>

update_uexpr_rep_eq_thms \<comment> \<open> Reread @{text rep_eq} theorems. \<close>

declare utp_pred.taut.rep_eq [upred_defs]

adhoc_overloading
  utrue "true_upred" and
  ufalse "false_upred" and
  unot "not_upred" and
  uconj "conj_upred" and
  udisj "disj_upred" and
  uimpl impl and
  uiff iff_upred and
  uex ex and
  uall all

syntax
  "_uneq"       :: "logic \<Rightarrow> logic \<Rightarrow> logic" (infixl "\<noteq>\<^sub>u" 50)
  "_unmem"      :: "('a, '\<alpha>) uexpr \<Rightarrow> ('a set, '\<alpha>) uexpr \<Rightarrow> (bool, '\<alpha>) uexpr" (infix "\<notin>\<^sub>u" 50)

translations
  "x \<noteq>\<^sub>u y" == "CONST unot (x =\<^sub>u y)"
  "x \<notin>\<^sub>u A" == "CONST unot (CONST bop (\<in>) x A)"

declare true_upred_def [upred_defs]
declare false_upred_def [upred_defs]
declare conj_upred_def [upred_defs]
declare disj_upred_def [upred_defs]
declare not_upred_def [upred_defs]
declare diff_upred_def [upred_defs]
declare par_subst_def [upred_defs]
declare subst_del_def [upred_defs]
declare unrest_usubst_def [upred_defs]
declare uexpr_defs [upred_defs]

lemma true_alt_def: "true = \<guillemotleft>True\<guillemotright>"
  by (pred_auto)

declare true_alt_def[THEN sym,simp]
declare false_alt_def[THEN sym,simp]

lemma upred_set_eqI: "\<lbrakk>p\<rbrakk>\<^sub>p = \<lbrakk>q\<rbrakk>\<^sub>p \<Longrightarrow> p = q"
  by (metis eq_iff mem_Collect_eq upred_ref_iff upred_set.rep_eq)

subsection \<open> Unrestriction Laws \<close>

lemma unrest_allE:
  "\<lbrakk> \<Sigma> \<sharp> P; P = true \<Longrightarrow> Q; P = false \<Longrightarrow> Q \<rbrakk> \<Longrightarrow> Q"
  by (pred_auto)

lemma unrest_true [unrest]: "x \<sharp> true"
  by (pred_auto)

lemma unrest_false [unrest]: "x \<sharp> false"
  by (pred_auto)

lemma unrest_conj [unrest]: "\<lbrakk> x \<sharp> (P :: '\<alpha> upred); x \<sharp> Q \<rbrakk> \<Longrightarrow> x \<sharp> P \<and> Q"
  by (pred_auto)

lemma unrest_disj [unrest]: "\<lbrakk> x \<sharp> (P :: '\<alpha> upred); x \<sharp> Q \<rbrakk> \<Longrightarrow> x \<sharp> P \<or> Q"
  by (pred_auto)

lemma unrest_UINF_mem [unrest]:
  "\<lbrakk>(\<And> i. i \<in> A \<Longrightarrow> x \<sharp> P(i)) \<rbrakk> \<Longrightarrow> x \<sharp> (\<Sqinter> i\<in>A \<bullet> P(i))"
  by (pred_simp, metis)

lemma unrest_USUP_mem [unrest]:
  "\<lbrakk>(\<And> i. i \<in> A \<Longrightarrow> x \<sharp> P(i)) \<rbrakk> \<Longrightarrow> x \<sharp> (\<Squnion> i\<in>A \<bullet> P(i))"
  by (pred_simp, metis)

lemma unrest_impl [unrest]: "\<lbrakk> x \<sharp> P; x \<sharp> Q \<rbrakk> \<Longrightarrow> x \<sharp> P \<Rightarrow> Q"
  by (pred_auto)

lemma unrest_iff [unrest]: "\<lbrakk> x \<sharp> P; x \<sharp> Q \<rbrakk> \<Longrightarrow> x \<sharp> P \<Leftrightarrow> Q"
  by (pred_auto)

lemma unrest_not [unrest]: "x \<sharp> (P :: '\<alpha> upred) \<Longrightarrow> x \<sharp> (\<not> P)"
  by (pred_auto)

text \<open> The sublens proviso can be thought of as membership below. \<close>

lemma unrest_ex_in [unrest]:
  "\<lbrakk> mwb_lens y; x \<subseteq>\<^sub>L y \<rbrakk> \<Longrightarrow> x \<sharp> (\<exists> y \<bullet> P)"
  by (pred_auto)

declare sublens_refl [simp]
declare lens_plus_ub [simp]
declare lens_plus_right_sublens [simp]
declare comp_wb_lens [simp]
declare comp_mwb_lens [simp]
declare plus_mwb_lens [simp]

lemma unrest_ex_diff [unrest]:
  assumes "x \<bowtie> y" "y \<sharp> P"
  shows "y \<sharp> (\<exists> x \<bullet> P)"
  using assms lens_indep_comm
  by (rel_auto, fastforce+)

lemma unrest_all_in [unrest]:
  "\<lbrakk> mwb_lens y; x \<subseteq>\<^sub>L y \<rbrakk> \<Longrightarrow> x \<sharp> (\<forall> y \<bullet> P)"
  by (pred_auto)

lemma unrest_all_diff [unrest]:
  assumes "x \<bowtie> y" "y \<sharp> P"
  shows "y \<sharp> (\<forall> x \<bullet> P)"
  using assms
  by (pred_simp, simp_all add: lens_indep_comm)

lemma unrest_var_res_diff [unrest]:
  assumes "x \<bowtie> y"
  shows "y \<sharp> (P \<restriction>\<^sub>v x)"
  using assms by (pred_auto)

lemma unrest_var_res_in [unrest]:
  assumes "mwb_lens x" "y \<subseteq>\<^sub>L x" "y \<sharp> P"
  shows "y \<sharp> (P \<restriction>\<^sub>v x)"
  using assms
  apply (pred_auto)
   apply fastforce
  apply (metis (no_types, lifting) mwb_lens_weak weak_lens.put_get)
  done

lemma unrest_shEx [unrest]:
  assumes "\<And> y. x \<sharp> P(y)"
  shows "x \<sharp> (\<^bold>\<exists> y \<bullet> P(y))"
  using assms by (pred_auto)

lemma unrest_shAll [unrest]:
  assumes "\<And> y. x \<sharp> P(y)"
  shows "x \<sharp> (\<^bold>\<forall> y \<bullet> P(y))"
  using assms by (pred_auto)

lemma unrest_closure [unrest]:
  "x \<sharp> [P]\<^sub>u"
  by (pred_auto)

subsection \<open> Used-by laws \<close>

lemma usedBy_not [unrest]:
  "\<lbrakk> x \<natural> P \<rbrakk> \<Longrightarrow> x \<natural> (\<not> P)"
  by (pred_simp)

lemma usedBy_conj [unrest]:
  "\<lbrakk> x \<natural> P; x \<natural> Q \<rbrakk> \<Longrightarrow> x \<natural> (P \<and> Q)"
  by (pred_simp)

lemma usedBy_disj [unrest]:
  "\<lbrakk> x \<natural> P; x \<natural> Q \<rbrakk> \<Longrightarrow> x \<natural> (P \<or> Q)"
  by (pred_simp)

lemma usedBy_impl [unrest]:
  "\<lbrakk> x \<natural> P; x \<natural> Q \<rbrakk> \<Longrightarrow> x \<natural> (P \<Rightarrow> Q)"
  by (pred_simp)

lemma usedBy_iff [unrest]:
  "\<lbrakk> x \<natural> P; x \<natural> Q \<rbrakk> \<Longrightarrow> x \<natural> (P \<Leftrightarrow> Q)"
  by (pred_simp)

subsection \<open> Substitution Laws \<close>

text \<open> Substitution is monotone \<close>

lemma subst_mono: "P \<sqsubseteq> Q \<Longrightarrow> (\<sigma> \<dagger> P) \<sqsubseteq> (\<sigma> \<dagger> Q)"
  by (pred_auto)

lemma subst_true [usubst]: "\<sigma> \<dagger> true = true"
  by (pred_auto)

lemma subst_not [usubst]: "\<sigma> \<dagger> (\<not> P) = (\<not> \<sigma> \<dagger> P)"
  by (pred_auto)

lemma subst_impl [usubst]: "\<sigma> \<dagger> (P \<Rightarrow> Q) = (\<sigma> \<dagger> P \<Rightarrow> \<sigma> \<dagger> Q)"
  by (pred_auto)

lemma subst_iff [usubst]: "\<sigma> \<dagger> (P \<Leftrightarrow> Q) = (\<sigma> \<dagger> P \<Leftrightarrow> \<sigma> \<dagger> Q)"
  by (pred_auto)

lemma subst_disj [usubst]: "\<sigma> \<dagger> (P \<or> Q) = (\<sigma> \<dagger> P \<or> \<sigma> \<dagger> Q)"
  by (pred_auto)

lemma subst_conj [usubst]: "\<sigma> \<dagger> (P \<and> Q) = (\<sigma> \<dagger> P \<and> \<sigma> \<dagger> Q)"
  by (pred_auto)

lemma subst_sup [usubst]: "\<sigma> \<dagger> (P \<sqinter> Q) = (\<sigma> \<dagger> P \<sqinter> \<sigma> \<dagger> Q)"
  by (pred_auto)

lemma subst_inf [usubst]: "\<sigma> \<dagger> (P \<squnion> Q) = (\<sigma> \<dagger> P \<squnion> \<sigma> \<dagger> Q)"
  by (pred_auto)

lemma subst_UINF [usubst]: "\<sigma> \<dagger> (\<Sqinter> i\<in>A \<bullet> P(i)) = (\<Sqinter> i\<in>A \<bullet> \<sigma> \<dagger> P(i))"
  by (pred_auto)

lemma subst_USUP [usubst]: "\<sigma> \<dagger> (\<Squnion> i\<in>A \<bullet> P(i)) = (\<Squnion> i\<in>A \<bullet> \<sigma> \<dagger> P(i))"
  by (pred_auto)

lemma subst_closure [usubst]: "\<sigma> \<dagger> [P]\<^sub>u = [P]\<^sub>u"
  by (pred_auto)

lemma subst_shEx [usubst]: "\<sigma> \<dagger> (\<^bold>\<exists> x \<bullet> P(x)) = (\<^bold>\<exists> x \<bullet> \<sigma> \<dagger> P(x))"
  by (pred_auto)

lemma subst_shAll [usubst]: "\<sigma> \<dagger> (\<^bold>\<forall> x \<bullet> P(x)) = (\<^bold>\<forall> x \<bullet> \<sigma> \<dagger> P(x))"
  by (pred_auto)

text \<open> TODO: Generalise the quantifier substitution laws to n-ary substitutions \<close>

lemma subst_ex_same [usubst]:
  "mwb_lens x \<Longrightarrow> \<sigma>(x \<mapsto>\<^sub>s v) \<dagger> (\<exists> x \<bullet> P) = \<sigma> \<dagger> (\<exists> x \<bullet> P)"
  by (pred_auto)

lemma subst_ex_same' [usubst]:
  "mwb_lens x \<Longrightarrow> \<sigma>(x \<mapsto>\<^sub>s v) \<dagger> (\<exists> &x \<bullet> P) = \<sigma> \<dagger> (\<exists> &x \<bullet> P)"
  by (pred_auto)

lemma subst_ex_indep [usubst]:
  assumes "x \<bowtie> y" "y \<sharp> v"
  shows "(\<exists> y \<bullet> P)\<lbrakk>v/x\<rbrakk> = (\<exists> y \<bullet> P\<lbrakk>v/x\<rbrakk>)"
  using assms
  apply (pred_auto)
  using lens_indep_comm apply fastforce+
  done

lemma subst_ex_unrest [usubst]:
  "x \<sharp>\<^sub>s \<sigma> \<Longrightarrow> \<sigma> \<dagger> (\<exists> x \<bullet> P) = (\<exists> x \<bullet> \<sigma> \<dagger> P)"
  by (pred_auto)

lemma subst_all_same [usubst]:
  "mwb_lens x \<Longrightarrow> \<sigma>(x \<mapsto>\<^sub>s v) \<dagger> (\<forall> x \<bullet> P) = \<sigma> \<dagger> (\<forall> x \<bullet> P)"
  by (simp add: id_subst subst_unrest unrest_all_in)

lemma subst_all_indep [usubst]:
  assumes "x \<bowtie> y" "y \<sharp> v"
  shows "(\<forall> y \<bullet> P)\<lbrakk>v/x\<rbrakk> = (\<forall> y \<bullet> P\<lbrakk>v/x\<rbrakk>)"
  using assms
  by (pred_simp, simp_all add: lens_indep_comm)

lemma msubst_true [usubst]: "true\<lbrakk>x\<rightarrow>v\<rbrakk> = true"
  by (pred_auto)

lemma msubst_false [usubst]: "false\<lbrakk>x\<rightarrow>v\<rbrakk> = false"
  by (pred_auto)
lemma msubst_not [usubst]: "(\<not> P(x))\<lbrakk>x\<rightarrow>v\<rbrakk> = (\<not> ((P x)\<lbrakk>x\<rightarrow>v\<rbrakk>))"
  by (pred_auto)

lemma msubst_not_2 [usubst]: "(\<not> P x y)\<lbrakk>(x,y)\<rightarrow>v\<rbrakk> = (\<not> ((P x y)\<lbrakk>(x,y)\<rightarrow>v\<rbrakk>))"
  by (pred_auto)+

lemma msubst_disj [usubst]: "(P(x) \<or> Q(x))\<lbrakk>x\<rightarrow>v\<rbrakk> = ((P(x))\<lbrakk>x\<rightarrow>v\<rbrakk> \<or> (Q(x))\<lbrakk>x\<rightarrow>v\<rbrakk>)"
  by (pred_auto)

lemma msubst_disj_2 [usubst]: "(P x y \<or> Q x y)\<lbrakk>(x,y)\<rightarrow>v\<rbrakk> = ((P x y)\<lbrakk>(x,y)\<rightarrow>v\<rbrakk> \<or> (Q x y)\<lbrakk>(x,y)\<rightarrow>v\<rbrakk>)"
  by (pred_auto)+

lemma msubst_conj [usubst]: "(P(x) \<and> Q(x))\<lbrakk>x\<rightarrow>v\<rbrakk> = ((P(x))\<lbrakk>x\<rightarrow>v\<rbrakk> \<and> (Q(x))\<lbrakk>x\<rightarrow>v\<rbrakk>)"
  by (pred_auto)

lemma msubst_conj_2 [usubst]: "(P x y \<and> Q x y)\<lbrakk>(x,y)\<rightarrow>v\<rbrakk> = ((P x y)\<lbrakk>(x,y)\<rightarrow>v\<rbrakk> \<and> (Q x y)\<lbrakk>(x,y)\<rightarrow>v\<rbrakk>)"
  by (pred_auto)+

lemma msubst_implies [usubst]:
  "(P x \<Rightarrow> Q x)\<lbrakk>x\<rightarrow>v\<rbrakk> = ((P x)\<lbrakk>x\<rightarrow>v\<rbrakk> \<Rightarrow> (Q x)\<lbrakk>x\<rightarrow>v\<rbrakk>)"
  by (pred_auto)

lemma msubst_implies_2 [usubst]:
  "(P x y \<Rightarrow> Q x y)\<lbrakk>(x,y)\<rightarrow>v\<rbrakk> = ((P x y)\<lbrakk>(x,y)\<rightarrow>v\<rbrakk> \<Rightarrow> (Q x y)\<lbrakk>(x,y)\<rightarrow>v\<rbrakk>)"
  by (pred_auto)+

lemma msubst_shAll [usubst]:
  "(\<^bold>\<forall> x \<bullet> P x y)\<lbrakk>y\<rightarrow>v\<rbrakk> = (\<^bold>\<forall> x \<bullet> (P x y)\<lbrakk>y\<rightarrow>v\<rbrakk>)"
  by (pred_auto)

lemma msubst_shAll_2 [usubst]:
  "(\<^bold>\<forall> x \<bullet> P x y z)\<lbrakk>(y,z)\<rightarrow>v\<rbrakk> = (\<^bold>\<forall> x \<bullet> (P x y z)\<lbrakk>(y,z)\<rightarrow>v\<rbrakk>)"
  by (pred_auto)+

subsection \<open> Sandbox for conjectures \<close>

definition utp_sandbox :: "'\<alpha> upred \<Rightarrow> bool" ("TRY'(_')") where
"TRY(P) = (P = undefined)"

translations
  "P" <= "CONST utp_sandbox P"

end