theory Sort_Descending
imports Main
begin

section\<open>sorting descending\<close>
  context linorder
  begin
  fun sorted_descending :: "'a list \<Rightarrow> bool" where
    "sorted_descending [] \<longleftrightarrow> True" |
    "sorted_descending (a#as) \<longleftrightarrow> (\<forall>x \<in> set as. a \<ge> x) \<and> sorted_descending as"

  definition sort_descending_key :: "('b \<Rightarrow> 'a) \<Rightarrow> 'b list \<Rightarrow> 'b list" where
    "sort_descending_key f xs \<equiv> rev (sort_key f xs)"
  end
  lemma sorted_descending_Cons: "sorted_descending (x#xs) \<longleftrightarrow> sorted_descending xs \<and> (\<forall>y\<in>set xs. y \<le> x)"
  by(induction xs) auto

  lemma sorted_descending_tail: "sorted_descending (xs@[x]) \<longleftrightarrow> sorted_descending xs \<and> (\<forall>y\<in>set xs. x \<le> y)"
  by(induction xs) auto

  lemma sorted_descending_append: "sorted_descending (xs @ ys) =
    (sorted_descending xs \<and> sorted_descending ys \<and> (\<forall>x\<in>set xs. \<forall>y\<in>set ys. x \<ge> y))"
  by(induction xs) auto

  lemma sorted_descending: "sorted_descending (rev xs) \<longleftrightarrow> sorted xs"
  apply(induction xs)
   apply(simp)
  apply(simp add: sorted_Cons sorted_descending_tail)
  done
  lemma sorted_descending_alt: "sorted_descending xs \<longleftrightarrow> sorted (rev xs)"
    using sorted_descending[of "rev xs"] unfolding rev_rev_ident .

  lemma sort_descending: "sorted_descending (sort_descending_key (\<lambda>x. x) xs)"
    by(simp add: sort_descending_key_def sorted_descending)

  lemma sort_descending_key_distinct: "distinct xs \<Longrightarrow> distinct (sort_descending_key f xs)"
    by(simp add: sort_descending_key_def)

  lemma sorted_descending_sort_descending_key: "sorted_descending (map f (sort_descending_key f xs))"
    apply(simp add: sort_descending_key_def)
    using sorted_descending by (metis rev_map sorted_sort_key)

  lemma sorted_descending_split: "sorted_descending (map f l) \<Longrightarrow>
  	\<exists>m n. l = m @ n \<and> (\<forall>e \<in> set m. f (hd l) = f e) \<and> (\<forall>e \<in> set n. f e < f (hd l))"
  proof(induction l)
  	case Nil thus ?case by simp
  next
  	case (Cons a as)
  	from Cons(2) have IHm: "sorted_descending (map f as)" by simp
  	note mIH = Cons(1)[OF this]
  	thus ?case (is ?kees)
  	proof(cases as)
  		case Nil
  		show ?kees unfolding Nil by force
  	next
  		case (Cons aa ass)
  		show ?kees
  		proof(cases "f a = f aa")
  			case True
  			from mIH obtain m n where mn: "as = m @ n" "(\<forall>e\<in>set m. f a = f e)" "(\<forall>e\<in>set n. f e < f a)"
  				using True local.Cons by auto
  			have "a # as = a # m @ n" using mn(1) by simp
  			moreover have "\<forall>e\<in>set (a # m). f (hd (a # m)) = f e" unfolding list.sel(1) using True mn(2) using Cons by auto
  			ultimately show "\<exists>m n. a # as = m @ n \<and> (\<forall>e\<in>set m. f (hd (a # as)) = f e) \<and>
  				(\<forall>e\<in>set n. f e < f (hd (a # as)))" using mn(3) by (metis append.simps(2) list.sel(1))
  		next
  			case False
  			from Cons.prems have "\<forall>y\<in>set (map f as). y < f a"
  				unfolding list.map(2)
  				unfolding sorted_descending_Cons
  				unfolding set_map
  				unfolding local.Cons
  				using False
  				by auto
  			then have "\<forall>e\<in>set as. f e < f a" by simp
  			moreover have "a # as = [a] @ as \<and> (\<forall>e\<in>set [a]. f (hd [a]) = f e)" by simp
  			ultimately show ?kees by (metis list.sel(1))
  		qed
  	qed
  qed

  lemma sort_descending_set_inv[simp]: "set (sort_descending_key k t) = set t"
  	by (simp add: sort_descending_key_def)

end


(*  Title:      HOL/HOLCF/Tutorial/Fixrec_ex.thy
    Author:     Brian Huffman
*)

section {* Fixrec package examples *}

theory Fixrec_ex
imports HOLCF
begin

subsection {* Basic @{text fixrec} examples *}

text {*
  Fixrec patterns can mention any constructor defined by the domain
  package, as well as any of the following built-in constructors:
  Pair, spair, sinl, sinr, up, ONE, TT, FF.
*}

text {* Typical usage is with lazy constructors. *}

fixrec down :: "'a u \<rightarrow> 'a"
where "down\<cdot>(up\<cdot>x) = x"

text {* With strict constructors, rewrite rules may require side conditions. *}

fixrec from_sinl :: "'a \<oplus> 'b \<rightarrow> 'a"
where "x \<noteq> \<bottom> \<Longrightarrow> from_sinl\<cdot>(sinl\<cdot>x) = x"

text {* Lifting can turn a strict constructor into a lazy one. *}

fixrec from_sinl_up :: "'a u \<oplus> 'b \<rightarrow> 'a"
where "from_sinl_up\<cdot>(sinl\<cdot>(up\<cdot>x)) = x"

text {* Fixrec also works with the HOL pair constructor. *}

fixrec down2 :: "'a u \<times> 'b u \<rightarrow> 'a \<times> 'b"
where "down2\<cdot>(up\<cdot>x, up\<cdot>y) = (x, y)"

subsection {* Examples using @{text fixrec_simp} *}

text {* A type of lazy lists. *}

domain 'a llist = lNil | lCons (lazy 'a) (lazy "'a llist")

text {* A zip function for lazy lists. *}

text {* Notice that the patterns are not exhaustive. *}

fixrec
  lzip :: "'a llist \<rightarrow> 'b llist \<rightarrow> ('a \<times> 'b) llist"
where
  "lzip\<cdot>(lCons\<cdot>x\<cdot>xs)\<cdot>(lCons\<cdot>y\<cdot>ys) = lCons\<cdot>(x, y)\<cdot>(lzip\<cdot>xs\<cdot>ys)"
| "lzip\<cdot>lNil\<cdot>lNil = lNil"

text {* @{text fixrec_simp} is useful for producing strictness theorems. *}
text {* Note that pattern matching is done in left-to-right order. *}

lemma lzip_stricts [simp]:
  "lzip\<cdot>\<bottom>\<cdot>ys = \<bottom>"
  "lzip\<cdot>lNil\<cdot>\<bottom> = \<bottom>"
  "lzip\<cdot>(lCons\<cdot>x\<cdot>xs)\<cdot>\<bottom> = \<bottom>"
by fixrec_simp+

text {* @{text fixrec_simp} can also produce rules for missing cases. *}

lemma lzip_undefs [simp]:
  "lzip\<cdot>lNil\<cdot>(lCons\<cdot>y\<cdot>ys) = \<bottom>"
  "lzip\<cdot>(lCons\<cdot>x\<cdot>xs)\<cdot>lNil = \<bottom>"
by fixrec_simp+

subsection {* Pattern matching with bottoms *}

text {*
  As an alternative to using @{text fixrec_simp}, it is also possible
  to use bottom as a constructor pattern.  When using a bottom
  pattern, the right-hand-side must also be bottom; otherwise, @{text
  fixrec} will not be able to prove the equation.
*}

fixrec
  from_sinr_up :: "'a \<oplus> 'b\<^sub>\<bottom> \<rightarrow> 'b"
where
  "from_sinr_up\<cdot>\<bottom> = \<bottom>"
| "from_sinr_up\<cdot>(sinr\<cdot>(up\<cdot>x)) = x"

text {*
  If the function is already strict in that argument, then the bottom
  pattern does not change the meaning of the function.  For example,
  in the definition of @{term from_sinr_up}, the first equation is
  actually redundant, and could have been proven separately by
  @{text fixrec_simp}.
*}

text {*
  A bottom pattern can also be used to make a function strict in a
  certain argument, similar to a bang-pattern in Haskell.
*}

fixrec
  seq :: "'a \<rightarrow> 'b \<rightarrow> 'b"
where
  "seq\<cdot>\<bottom>\<cdot>y = \<bottom>"
| "x \<noteq> \<bottom> \<Longrightarrow> seq\<cdot>x\<cdot>y = y"

subsection {* Skipping proofs of rewrite rules *}

text {* Another zip function for lazy lists. *}

text {*
  Notice that this version has overlapping patterns.
  The second equation cannot be proved as a theorem
  because it only applies when the first pattern fails.
*}

fixrec
  lzip2 :: "'a llist \<rightarrow> 'b llist \<rightarrow> ('a \<times> 'b) llist"
where
  "lzip2\<cdot>(lCons\<cdot>x\<cdot>xs)\<cdot>(lCons\<cdot>y\<cdot>ys) = lCons\<cdot>(x, y)\<cdot>(lzip2\<cdot>xs\<cdot>ys)"
| (unchecked) "lzip2\<cdot>xs\<cdot>ys = lNil"

text {*
  Usually fixrec tries to prove all equations as theorems.
  The "unchecked" option overrides this behavior, so fixrec
  does not attempt to prove that particular equation.
*}

text {* Simp rules can be generated later using @{text fixrec_simp}. *}

lemma lzip2_simps [simp]:
  "lzip2\<cdot>(lCons\<cdot>x\<cdot>xs)\<cdot>lNil = lNil"
  "lzip2\<cdot>lNil\<cdot>(lCons\<cdot>y\<cdot>ys) = lNil"
  "lzip2\<cdot>lNil\<cdot>lNil = lNil"
by fixrec_simp+

lemma lzip2_stricts [simp]:
  "lzip2\<cdot>\<bottom>\<cdot>ys = \<bottom>"
  "lzip2\<cdot>(lCons\<cdot>x\<cdot>xs)\<cdot>\<bottom> = \<bottom>"
by fixrec_simp+

subsection {* Mutual recursion with @{text fixrec} *}

text {* Tree and forest types. *}

domain 'a tree = Leaf (lazy 'a) | Branch (lazy "'a forest")
and    'a forest = Empty | Trees (lazy "'a tree") "'a forest"

text {*
  To define mutually recursive functions, give multiple type signatures
  separated by the keyword @{text "and"}.
*}

fixrec
  map_tree :: "('a \<rightarrow> 'b) \<rightarrow> ('a tree \<rightarrow> 'b tree)"
and
  map_forest :: "('a \<rightarrow> 'b) \<rightarrow> ('a forest \<rightarrow> 'b forest)"
where
  "map_tree\<cdot>f\<cdot>(Leaf\<cdot>x) = Leaf\<cdot>(f\<cdot>x)"
| "map_tree\<cdot>f\<cdot>(Branch\<cdot>ts) = Branch\<cdot>(map_forest\<cdot>f\<cdot>ts)"
| "map_forest\<cdot>f\<cdot>Empty = Empty"
| "ts \<noteq> \<bottom> \<Longrightarrow>
    map_forest\<cdot>f\<cdot>(Trees\<cdot>t\<cdot>ts) = Trees\<cdot>(map_tree\<cdot>f\<cdot>t)\<cdot>(map_forest\<cdot>f\<cdot>ts)"

lemma map_tree_strict [simp]: "map_tree\<cdot>f\<cdot>\<bottom> = \<bottom>"
by fixrec_simp

lemma map_forest_strict [simp]: "map_forest\<cdot>f\<cdot>\<bottom> = \<bottom>"
by fixrec_simp

(*
  Theorems generated:
  @{text map_tree_def}  @{thm map_tree_def}
  @{text map_forest_def}  @{thm map_forest_def}
  @{text map_tree.unfold}  @{thm map_tree.unfold}
  @{text map_forest.unfold}  @{thm map_forest.unfold}
  @{text map_tree.simps}  @{thm map_tree.simps}
  @{text map_forest.simps}  @{thm map_forest.simps}
  @{text map_tree_map_forest.induct}  @{thm map_tree_map_forest.induct}
*)

subsection {* Looping simp rules *}

text {*
  The defining equations of a fixrec definition are declared as simp
  rules by default.  In some cases, especially for constants with no
  arguments or functions with variable patterns, the defining
  equations may cause the simplifier to loop.  In these cases it will
  be necessary to use a @{text "[simp del]"} declaration.
*}

fixrec
  repeat :: "'a \<rightarrow> 'a llist"
where
  [simp del]: "repeat\<cdot>x = lCons\<cdot>x\<cdot>(repeat\<cdot>x)"

text {*
  We can derive other non-looping simp rules for @{const repeat} by
  using the @{text subst} method with the @{text repeat.simps} rule.
*}

lemma repeat_simps [simp]:
  "repeat\<cdot>x \<noteq> \<bottom>"
  "repeat\<cdot>x \<noteq> lNil"
  "repeat\<cdot>x = lCons\<cdot>y\<cdot>ys \<longleftrightarrow> x = y \<and> repeat\<cdot>x = ys"
by (subst repeat.simps, simp)+

lemma llist_case_repeat [simp]:
  "llist_case\<cdot>z\<cdot>f\<cdot>(repeat\<cdot>x) = f\<cdot>x\<cdot>(repeat\<cdot>x)"
by (subst repeat.simps, simp)

text {*
  For mutually-recursive constants, looping might only occur if all
  equations are in the simpset at the same time.  In such cases it may
  only be necessary to declare @{text "[simp del]"} on one equation.
*}

fixrec
  inf_tree :: "'a tree" and inf_forest :: "'a forest"
where
  [simp del]: "inf_tree = Branch\<cdot>inf_forest"
| "inf_forest = Trees\<cdot>inf_tree\<cdot>(Trees\<cdot>inf_tree\<cdot>Empty)"

subsection {* Using @{text fixrec} inside locales *}

locale test =
  fixes foo :: "'a \<rightarrow> 'a"
  assumes foo_strict: "foo\<cdot>\<bottom> = \<bottom>"
begin

fixrec
  bar :: "'a u \<rightarrow> 'a"
where
  "bar\<cdot>(up\<cdot>x) = foo\<cdot>x"

lemma bar_strict: "bar\<cdot>\<bottom> = \<bottom>"
by fixrec_simp

end

end


(* Author: Tobias Nipkow *)

section "Definite Initialization Analysis"

theory Vars imports Com
begin

subsection "The Variables in an Expression"

text{* We need to collect the variables in both arithmetic and boolean
expressions. For a change we do not introduce two functions, e.g.\ @{text
avars} and @{text bvars}, but we overload the name @{text vars}
via a \emph{type class}, a device that originated with Haskell: *}

class vars =
fixes vars :: "'a \<Rightarrow> vname set"

text{* This defines a type class ``vars'' with a single
function of (coincidentally) the same name. Then we define two separated
instances of the class, one for @{typ aexp} and one for @{typ bexp}: *}

instantiation aexp :: vars
begin

fun vars_aexp :: "aexp \<Rightarrow> vname set" where
"vars (N n) = {}" |
"vars (V x) = {x}" |
"vars (Plus a\<^sub>1 a\<^sub>2) = vars a\<^sub>1 \<union> vars a\<^sub>2"

instance ..

end

value "vars (Plus (V ''x'') (V ''y''))"

instantiation bexp :: vars
begin

fun vars_bexp :: "bexp \<Rightarrow> vname set" where
"vars (Bc v) = {}" |
"vars (Not b) = vars b" |
"vars (And b\<^sub>1 b\<^sub>2) = vars b\<^sub>1 \<union> vars b\<^sub>2" |
"vars (Less a\<^sub>1 a\<^sub>2) = vars a\<^sub>1 \<union> vars a\<^sub>2"

instance ..

end

value "vars (Less (Plus (V ''z'') (V ''y'')) (V ''x''))"

abbreviation
  eq_on :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a set \<Rightarrow> bool"
 ("(_ =/ _/ on _)" [50,0,50] 50) where
"f = g on X == \<forall> x \<in> X. f x = g x"

lemma aval_eq_if_eq_on_vars[simp]:
  "s\<^sub>1 = s\<^sub>2 on vars a \<Longrightarrow> aval a s\<^sub>1 = aval a s\<^sub>2"
apply(induction a)
apply simp_all
done

lemma bval_eq_if_eq_on_vars:
  "s\<^sub>1 = s\<^sub>2 on vars b \<Longrightarrow> bval b s\<^sub>1 = bval b s\<^sub>2"
proof(induction b)
  case (Less a1 a2)
  hence "aval a1 s\<^sub>1 = aval a1 s\<^sub>2" and "aval a2 s\<^sub>1 = aval a2 s\<^sub>2" by simp_all
  thus ?case by simp
qed simp_all

fun lvars :: "com \<Rightarrow> vname set" where
"lvars SKIP = {}" |
"lvars (x::=e) = {x}" |
"lvars (c1;;c2) = lvars c1 \<union> lvars c2" |
"lvars (IF b THEN c1 ELSE c2) = lvars c1 \<union> lvars c2" |
"lvars (WHILE b DO c) = lvars c"

fun rvars :: "com \<Rightarrow> vname set" where
"rvars SKIP = {}" |
"rvars (x::=e) = vars e" |
"rvars (c1;;c2) = rvars c1 \<union> rvars c2" |
"rvars (IF b THEN c1 ELSE c2) = vars b \<union> rvars c1 \<union> rvars c2" |
"rvars (WHILE b DO c) = vars b \<union> rvars c"

instantiation com :: vars
begin

definition "vars_com c = lvars c \<union> rvars c"

instance ..

end

lemma vars_com_simps[simp]:
  "vars SKIP = {}"
  "vars (x::=e) = {x} \<union> vars e"
  "vars (c1;;c2) = vars c1 \<union> vars c2"
  "vars (IF b THEN c1 ELSE c2) = vars b \<union> vars c1 \<union> vars c2"
  "vars (WHILE b DO c) = vars b \<union> vars c"
by(auto simp: vars_com_def)

lemma finite_avars[simp]: "finite(vars(a::aexp))"
by(induction a) simp_all

lemma finite_bvars[simp]: "finite(vars(b::bexp))"
by(induction b) simp_all

lemma finite_lvars[simp]: "finite(lvars(c))"
by(induction c) simp_all

lemma finite_rvars[simp]: "finite(rvars(c))"
by(induction c) simp_all

lemma finite_cvars[simp]: "finite(vars(c::com))"
by(simp add: vars_com_def)

end


theory Induction_Demo
imports Main
begin

(* HINT FOR ONLINE DEMO
   Start your first proof attempt with
   itrev xs [] = rev xs
   then generalize by introducing ys, and finally quantify over ys.
   Each generalization should be motivated by the previous failed
   proof attempt.
*)

fun itrev :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"itrev [] ys = ys" |
"itrev (x#xs) ys = itrev xs (x#ys)"

lemma "itrev xs ys = rev xs @ ys"
apply(induction xs arbitrary: ys)
apply(auto)
done

subsection{* Computation Induction *}

fun sep :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"sep a [] = []" |
"sep a [x] = [x]" |
"sep a (x#y#zs) = x # a # sep a (y#zs)"

lemma "map f (sep a xs) = sep (f a) (map f xs)"
apply(induction a xs rule: sep.induct)
apply auto
done

end


theory Chapter4
imports "HOL-IMP.ASM"
begin

inductive star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"  for r where
refl:  "star r x x" |
step:  "r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"

lemma star_trans: "star r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"
  apply(induction rule: star.induct)
   apply(assumption)
  apply(metis step)
done

text{*
\section*{Chapter 4}

\exercise
Start from the data type of binary trees defined earlier:
*}

(* Proof Automation *)
lemma "\<forall>x. \<exists>y. x=y"
  by auto

lemma "A \<subseteq> B \<inter> C \<Longrightarrow> A \<subseteq> B \<union> C"
  by auto

lemma "\<lbrakk>\<forall>xs \<in> A. \<exists>ys. xs = ys @ ys; us \<in> A\<rbrakk> \<Longrightarrow> \<exists>n. length us = n + n"
  by fastforce

lemma "\<lbrakk> \<forall> x y. T x y \<or> T y x;
        \<forall> x y. A x y \<and> A y x \<longrightarrow> x = y;
        \<forall> x y. T x y \<longrightarrow> A x y \<rbrakk>
        \<Longrightarrow> \<forall> x y. A x y \<longrightarrow> T x y"
  by blast

lemma "\<lbrakk> xs @ ys = ys @ xs; length xs = length ys \<rbrakk> \<Longrightarrow> xs = ys"
  (* sledgehammer *)
  by (metis append_eq_conv_conj)

lemma "\<lbrakk> (a::nat) \<le> x + b; 2*x < c \<rbrakk> \<Longrightarrow> 2*a + 1 \<le> 2*b + c"
  by arith

lemma "\<lbrakk> (a::nat) \<le> b; b \<le> c; c \<le> d; d \<le> e \<rbrakk> \<Longrightarrow> a \<le> e"
  by(blast intro: le_trans)

thm conjI[OF refl[of "a"] refl[of "b"]]

(*Forward Reasoning with Suc_leD: Suc m \<le> n \<Longrightarrow> m \<le> n*)
lemma "Suc(Suc(Suc a)) \<le> b \<Longrightarrow> a \<le> b"
  by(blast dest: Suc_leD)

inductive ev :: "nat \<Rightarrow> bool" where
ev0: "ev 0" |
evSS: "ev n \<Longrightarrow> ev (Suc (Suc n))"

fun evn :: "nat \<Rightarrow> bool" where
"evn 0 = True" |
"evn (Suc 0) = False" |
"evn (Suc(Suc n)) = evn n"

(* Proof of lemma in forward direction *)
thm evSS[OF evSS[OF ev0]]
(* Proof of lemma in backward direction  *)
lemma "ev(Suc(Suc(Suc(Suc 0))))"
  apply(rule evSS)
  apply(rule evSS)
  apply(rule ev0)
  done

(* Rule induction *)
lemma "ev m \<Longrightarrow> evn m"
  apply(induction rule: ev.induct)
   apply(simp_all)
  done

(* evn.induct sets up three subgoals corresponding to the 3 equations of evn *)
lemma "evn n \<Longrightarrow> ev n"
  apply(induction n rule: evn.induct)
    apply(simp_all add: ev0 evSS)
  done

declare ev.intros[simp,intro]

datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"

text{*
An @{typ "int tree"} is ordered if for every @{term "Node l i r"} in the tree,
@{text l} and @{text r} are ordered
and all values in @{text l} are @{text "< i"}
and all values in @{text r} are @{text "> i"}.
Define a function that returns the elements in a tree and one
the tests if a tree is ordered:
*}

fun set :: "'a tree \<Rightarrow> 'a set"  where
"set Tip = {}" |
"set (Node l v r) = (set l) \<union> {v} \<union> (set r)"

fun ord :: "int tree \<Rightarrow> bool"  where
"ord Tip = True" |
"ord (Node l v r) = ((\<forall>x \<in> set l. x \<le> v) \<and> (\<forall>x \<in> set r. v \<le> x) \<and> ord l \<and> ord r)"

text{* Hint: use quantifiers.

Define a function @{text ins} that inserts an element into an ordered @{typ "int tree"}
while maintaining the order of the tree. If the element is already in the tree, the
same tree should be returned.
*}

fun ins :: "int \<Rightarrow> int tree \<Rightarrow> int tree"  where
"ins x Tip = (Node Tip x Tip)" |
"ins x (Node l v r) = (if x = v then Node l v r
                       else if x < v then Node (ins x l) v r
                       else Node l v (ins x r))"

text{* Prove correctness of @{const ins}: *}

lemma set_ins [simp]: "set(ins x t) = {x} \<union> set t"
  apply(induction t)
  apply(auto)
  done

theorem ord_ins: "ord t \<Longrightarrow> ord(ins i t)"
  apply(induction t arbitrary: i)
  apply(auto)
  done

text{*
\endexercise

\exercise
Formalize the following definition of palindromes
\begin{itemize}
\item The empty list and a singleton list are palindromes.
\item If @{text xs} is a palindrome, so is @{term "a # xs @ [a]"}.
\end{itemize}
as an inductive predicate
*}

inductive palindrome :: "'a list \<Rightarrow> bool" where
palinEmpty: "palindrome []" |
palinSingle: "palindrome [x]" |
palinSS: "palindrome xs ==> palindrome (a # xs @ [a])"

text {* and prove *}

lemma "palindrome xs \<Longrightarrow> rev xs = xs"
  apply(induction rule: palindrome.induct)
    apply(auto)
  done

text{*
\endexercise

\exercise
We could also have defined @{const star} as follows:
*}

inductive star' :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
refl': "star' r x x" |
step': "star' r x y \<Longrightarrow> r y z \<Longrightarrow> star' r x z"

text{*
The single @{text r} step is performer after rather than before the @{text star'}
steps. Prove
*}

lemma "star' r x y \<Longrightarrow> star r x y"
  apply(induction rule: star'.induct)
   apply (simp add: star.refl)
  by (metis star.simps star_trans)

lemma "star r x y \<Longrightarrow> star' r x y"
  apply(induction rule: star.induct)
  by (auto intro: refl')

text{*
You may need lemmas. Note that rule induction fails
if the assumption about the inductive predicate
is not the first assumption.
\endexercise

\exercise\label{exe:iter}
Analogous to @{const star}, give an inductive definition of the @{text n}-fold iteration
of a relation @{text r}: @{term "iter r n x y"} should hold if there are @{text x\<^sub>0}, \dots, @{text x\<^sub>n}
such that @{prop"x = x\<^sub>0"}, @{prop"x\<^sub>n = y"} and @{text"r x\<^bsub>i\<^esub> x\<^bsub>i+1\<^esub>"} for
all @{prop"i < n"}:
*}

inductive iter :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
iter0: "iter r 0 x x" |
iterS: "r x y \<Longrightarrow> iter r n y z \<Longrightarrow> iter r (Suc n) x z"

text{*
Correct and prove the following claim:
*}

lemma "star r x y \<Longrightarrow> \<exists>n. iter r n x y"
  apply(induction rule: star.induct)
   apply(auto intro: iter0 iterS)
  done

text{*
\endexercise

\exercise\label{exe:cfg}
A context-free grammar can be seen as an inductive definition where each
nonterminal $A$ is an inductively defined predicate on lists of terminal
symbols: $A(w)$ mans that $w$ is in the language generated by $A$.
For example, the production $S \to aSb$ can be viewed as the implication
@{prop"S w \<Longrightarrow> S (a # w @ [b])"} where @{text a} and @{text b} are terminal symbols,
i.e., elements of some alphabet. The alphabet can be defined as a datatype:
*}

datatype alpha = a | b

text{*
If you think of @{const a} and @{const b} as ``@{text "("}'' and  ``@{text ")"}'',
the following two grammars both generate strings of balanced parentheses
(where $\varepsilon$ is the empty word):
\[
\begin{array}{r@ {\quad}c@ {\quad}l}
S &\to& \varepsilon \quad\mid\quad aSb \quad\mid\quad SS \\
T &\to& \varepsilon \quad\mid\quad TaTb
\end{array}
\]
Define them as inductive predicates and prove their equivalence:
*}

inductive S :: "alpha list \<Rightarrow> bool" where
S0: "S []" |
aSb: "S w \<Longrightarrow> S (a # w @ [b])" |
SS: "S w \<Longrightarrow> S x \<Longrightarrow> S (w @ x)"

inductive T :: "alpha list \<Rightarrow> bool" where
T0: "T []" |
TaTb: "T w \<Longrightarrow> T x \<Longrightarrow> T (w @ [a] @ x @ [b])"

lemma TS: "T w \<Longrightarrow> S w"
  apply(induction rule: T.induct)
   apply(auto intro: S0 aSb SS)
  done

lemma TT: "T x \<Longrightarrow> T w \<Longrightarrow> T (w @ x)"
  apply(induction rule: T.induct)
   apply(simp)
  by (metis TaTb append.assoc)

lemma ST: "S w \<Longrightarrow> T w"
  apply(induction rule: S.induct)
    apply(simp add: T0)
   apply (metis T.simps append.left_neutral append_Cons)
  apply(simp add: TT)
  done

corollary SeqT: "S w \<longleftrightarrow> T w"
  by(auto simp add: TS ST)

text{*
\endexercise
*}
(* your definition/proof here *)
text{*
\exercise
In Chapter 3 we defined a recursive evaluation function
@{text "aval ::"} @{typ "aexp \<Rightarrow> state \<Rightarrow> val"}.
Define an inductive evaluation predicate and prove that it agrees with
the recursive function:
*}

inductive aval_rel :: "aexp \<Rightarrow> state \<Rightarrow> val \<Rightarrow> bool" where
avalN: "aval_rel (N n) s n" |
avalV: "aval_rel (V x) s (s x)" |
avalPlus: "aval_rel a1 s x \<Longrightarrow> aval_rel a2 s y \<Longrightarrow> aval_rel (Plus a1 a2) s (x+y)"

lemma aval_rel_aval: "aval_rel x s v \<Longrightarrow> aval x s = v"
  apply(induction rule: aval_rel.induct)
  by (auto)

lemma aval_aval_rel: "aval x s = v \<Longrightarrow> aval_rel x s v"
  apply(induction x arbitrary: v)
    apply(auto intro: avalN avalV avalPlus)
  done

corollary "aval_rel x s v \<longleftrightarrow> aval x s = v"
  using aval_aval_rel aval_rel_aval by blast

text{*
\endexercise

\exercise
Consider the stack machine from Chapter~3
and recall the concept of \concept{stack underflow}
from Exercise~\ref{exe:stack-underflow}.
Define an inductive predicate
*}

inductive ok :: "nat \<Rightarrow> instr list \<Rightarrow> nat \<Rightarrow> bool" where
ok_0: "ok n [] n" |
ok_LDI: "ok n is n' \<Longrightarrow> ok n (is @ [LOADI k]) (Suc n')" |
ok_LD: "ok n is n' \<Longrightarrow> ok n (is @ [LOAD k]) (Suc n')" |
ok_ADD: "ok n is (Suc (Suc n')) \<Longrightarrow> ok n (is @ [ADD]) (Suc n')"

text{*
such that @{text "ok n is n'"} means that with any initial stack of length
@{text n} the instructions @{text "is"} can be executed
without stack underflow and that the final stack has length @{text n'}.

Using the introduction rules for @{const ok},
prove the following special cases: *}

lemma "ok 0 [LOAD x] (Suc 0)"
  by (metis append_Nil ok_0 ok_LD)

lemma "ok 0 [LOAD x, LOADI v, ADD] (Suc 0)"
  by (metis append_Cons append_Nil ok_0 ok_ADD ok_LD ok_LDI)

lemma "ok (Suc (Suc 0)) [LOAD x, ADD, ADD, LOAD y] (Suc (Suc 0))"
  by (metis append_Cons append_Nil ok_0 ok_ADD ok_LD)

text {* Prove that @{text ok} correctly computes the final stack size: *}

lemma "\<lbrakk>ok n is n'; length stk = n\<rbrakk> \<Longrightarrow> length (exec is s stk) = n'"
  apply(induction arbitrary: stk rule: ok.induct)
     apply(auto)
  by (smt (z3) add_is_0 add_left_cancel exec1.elims instr.distinct(3) instr.distinct(5) length_Cons list.size(3) not_one_le_zero plus_1_eq_Suc zero_less_one_class.zero_le_one)

text {*
Lemma @{thm [source] length_Suc_conv} may come in handy.

Prove that instruction sequences generated by @{text comp}
cannot cause stack underflow: \ @{text "ok n (comp a) ?"} \ for
some suitable value of @{text "?"}.
\endexercise
*}

lemma ok_append: "ok n' x n'' \<Longrightarrow> ok n y n' \<Longrightarrow> ok n (y @ x) n''"
  apply(induction rule: ok.induct)
     apply simp
    apply (metis append.assoc ok_LDI)
  apply (metis append.assoc ok_LD)
  by (metis append_eq_appendI ok_ADD)

theorem "ok n (comp x) (Suc n)"
  apply(induction x arbitrary: n)
    apply (metis append_self_conv2 comp.simps(1) ok.simps)
   apply (metis append_Nil comp.simps(2) ok.simps)
  apply(auto intro: ok_ADD ok_append)
  done

end


(*
    File:        Poset.thy
    Time-stamp:  <2015-12-20T16:14:07Z>
    Author:      JRF
    Web:         http://jrf.cocolog-nifty.com/software/2016/01/post.html
    Logic Image: ZF (of Isabelle2015)
*)

theory Poset imports ZF FinCard begin

definition poset :: "[[i,i]=>o, i]=>o" where
"poset(R, P) == (ALL x: P. R(x, x)) &
  (ALL x: P. ALL y: P. R(x, y) & R(y, x) --> x = y) &
  (ALL x: P. ALL y: P. ALL z: P. R(x, y) & R(y, z) --> R(x, z))"

definition chain :: "[[i,i]=>o, i]=>o" where
"chain(R, P) == poset(R, P)
   & (ALL x: P. ALL y: P. R(x, y) | R(y, x))"

definition invrel :: "[[i, i]=>o, i, i]=>o" where
"invrel(R, x, y) == R(y, x)"

definition least :: "[[i,i]=>o, i, i]=>o" where
"least(R, P, x) == x: P & (ALL y: P. R(x, y))"

definition greatest :: "[[i,i]=>o, i, i]=>o" where
"greatest(R, P, x) == x: P & (ALL y: P. R(y, x))"

definition minimal :: "[[i, i]=>o, i, i]=>o" where
"minimal(R, P, x) == x: P & (ALL y: P. R(y, x) --> y = x)"

definition maximal :: "[[i, i]=>o, i, i]=>o" where
"maximal(R, P, x) == x: P & (ALL y: P. R(x, y) --> y = x)"

definition downset :: "[[i, i]=>o, i, i]=>i" where
"downset(R, P, x) == {y: P. R(y, x)}"

definition upset :: "[[i, i]=>o, i, i]=>i" where
"upset(R, P, x) == {y: P. R(x, y)}"

definition upperbound :: "[[i, i]=>o, i, i]=>i" where
"upperbound(R, P, S) == {x: P. ALL y: S. R(y, x)}"

definition lowerbound :: "[[i, i]=>o, i, i]=>i" where
"lowerbound(R, P, S) == {x: P. ALL y: S. R(x, y)}"

(** poset **)
lemma posetI:
  "[| !!x. x: P ==> R(x, x);
      !!x y. [| x: P; y: P; R(x, y); R(y, x) |] ==> x = y;
      !!x y z. [| x: P; y: P; z: P; R(x, y); R(y, z) |] ==> R(x, z)
   |] ==> poset(R, P)"
apply (unfold poset_def)
apply blast
done

lemma poset_reflD:
  "[| poset(R, P); x: P |] ==> R(x, x)"
apply (unfold poset_def)
apply blast
done

lemma poset_antisymD:
  "[| poset(R, P); R(x, y); R(y, x); x: P; y: P |] ==> x = y"
apply (unfold poset_def)
apply blast
done

lemma poset_transD:
  "[| poset(R, P); R(x, y); R(y, z); x: P; y: P; z: P |] ==> R(x, z)"
apply (unfold poset_def)
apply blast
done

lemma poset_subset:
  "[| S <= P; poset(R, P) |] ==> poset(R, S)"
apply (rule posetI)
apply (drule subsetD, assumption)
apply (erule poset_reflD, assumption)
apply (erule poset_antisymD, assumption+)
apply (erule subsetD, assumption)+
apply (erule poset_transD, assumption+)
apply (erule subsetD, assumption)+
done

lemma poset_invrel_iff:
  "poset(invrel(R), P) <-> poset(R, P)"
apply (unfold poset_def invrel_def)
apply blast
done

(** chain **)
lemma chainI:
  "[| poset(R, P); !!x y. [| x: P; y: P |] ==> R(x, y) | R(y, x) |]
      ==> chain(R, P)"
apply (unfold chain_def)
apply blast
done

lemma chain_imp_poset:
    "chain(R, P) ==> poset(R, P)"
apply (unfold chain_def)
apply blast
done

lemmas chainD1 = chain_imp_poset

lemma chainD2:
  "[| chain(R, P); x: P; y: P |] ==> R(x, y) | R(y, x)"
apply (unfold chain_def)
apply blast
done

lemma chain_subset:
    "[| S <= P; chain(R, P) |] ==> chain(R, S)"
apply (blast intro: chainI poset_subset dest: chainD1 chainD2)
done

lemma chain_invrel_iff:
  "chain(invrel(R), P) <-> chain(R, P)"
apply (unfold chain_def invrel_def)
apply (simp add: poset_invrel_iff)
apply blast
done

(** least/greatest **)
lemma leastI:
  "[| !!y. y: P ==> R(x, y); x: P |] ==> least(R, P, x)"
apply (unfold least_def)
apply blast
done

lemma leastD1:
  "least(R, P, x) ==> x: P"
apply (unfold least_def)
apply blast
done

lemma leastD2:
  "[| least(R, P, x); y: P |] ==> R(x, y)"
apply (unfold least_def)
apply blast
done

lemma least_unique:
  "[| least(R, P, x); least(R, P, y); poset(R, P) |] ==> x = y"
apply (erule poset_antisymD)
apply (erule leastD2, erule leastD1)
apply (erule leastD2, erule leastD1)
apply (erule leastD1)
apply (erule leastD1)
done

lemma least_subset:
  "[| S <= P; least(R, P, x); x: S |] ==> least(R, S, x)"
apply (rule leastI)
apply (drule subsetD)
apply (drule_tac [2] leastD2)
by assumption+

lemma Finite_non_empty_chain_has_least_element:
  assumes major: "Finite(P)"
  and prem1: "chain(R, P)"
  and prem2: "P ~= 0"
  shows "EX x. least(R, P, x)"
apply (rule prem2 [THEN rev_mp])
apply (rule prem1 [THEN rev_mp])
apply (rule major [THEN Finite_into_Fin, THEN Fin_induct])
apply blast
apply (intro impI)
apply (case_tac "y = 0")
apply hypsubst
apply (rule exI)
apply (rule leastI)
apply (rule_tac [2] singletonI)
apply (erule singletonE)
apply hypsubst
apply (erule chain_imp_poset [THEN poset_reflD])
apply (rule singletonI)
apply (drule mp [THEN mp])
apply (rule chain_subset)
apply (rule subset_consI)
apply assumption+
apply (erule exE)
apply (frule chainD2)
apply (rule consI1)
apply (rule consI2)
apply (erule leastD1)
apply (erule disjE)
apply (rename_tac [2] v)
apply (rule_tac x="x" in exI)
apply (rule_tac [2] x="v" in exI)
apply (rule_tac [2] leastI)
apply (rule leastI)
apply (rule_tac [4] consI2)
apply safe
apply (erule chain_imp_poset [THEN poset_reflD])
apply (erule_tac [2] chain_imp_poset [THEN poset_transD])
prefer 2 apply assumption
apply (rule_tac [4] consI2)
apply (erule_tac [5] consI2)
apply (erule_tac [2] leastD2)
apply (erule_tac [5] leastD2)
apply (assumption | (rule consI1 leastD1))+
done

lemma least_invrel_iff:
    "least(invrel(R), P, x) <-> greatest(R, P, x)"
apply (unfold least_def greatest_def invrel_def)
apply (rule iff_refl)
done

lemma greatest_invrel_iff:
    "greatest(invrel(R), P, x) <-> least(R, P, x)"
apply (unfold least_def greatest_def invrel_def)
apply (rule iff_refl)
done

(** minimal/maximal **)
lemma minimalI:
  "[| !!y. [| y: P;  R(y, x) |] ==> y = x; x: P |] ==> minimal(R, P, x)"
apply (unfold minimal_def)
apply blast
done

lemma minimalD1:
  "minimal(R, P, x) ==> x: P"
apply (unfold minimal_def)
apply blast
done

lemma minimalD2:
  "[| minimal(R, P, x); R(y, x); y: P |] ==> y = x"
apply (unfold minimal_def)
apply blast
done

lemma minimal_subset:
  "[| S <= P; minimal(R, P, x); x: S |] ==> minimal(R, S, x)"
apply (rule minimalI)
apply (erule minimalD2)
apply assumption
apply (erule subsetD)
apply assumption+
done

lemma least_imp_minimal:
  "[| least(R, P, x); poset(R, P) |] ==> minimal(R, P, x)"
apply (rule minimalI)
apply (erule poset_antisymD)
apply (erule_tac [2] leastD2)
apply (assumption | (erule leastD1))+
done

lemma chain_minimal_imp_least:
  "[| minimal(R, P, x); chain(R, P) |] ==> least(R, P, x)"
apply (rule leastI)
apply (rule chainD2 [THEN disjE])
apply assumption
apply (erule minimalD1)
apply assumption+
apply (drule minimalD2)
apply assumption+
apply hypsubst
apply (erule chainD1 [THEN poset_reflD], assumption)
apply (erule minimalD1)
done

lemma minimal_invrel_iff:
    "minimal(invrel(R), P, x) <-> maximal(R, P, x)"
apply (unfold minimal_def maximal_def invrel_def)
apply (rule iff_refl)
done

lemma maximal_invrel_iff:
    "maximal(invrel(R), P, x) <-> minimal(R, P, x)"
apply (unfold minimal_def maximal_def invrel_def)
apply (rule iff_refl)
done

(** upset/downset **)
lemma upsetI:
  "[| y: P; R(x, y) |] ==> y: upset(R, P, x)"
apply (unfold upset_def)
apply blast
done

lemma upsetE:
  "[| y: upset(R, P, x); [| y: P; R(x, y) |] ==> Q |] ==> Q"
apply (unfold upset_def)
apply blast
done

lemma upset_subset:
    "upset(R, P, x) <= P"
apply (blast elim!: upsetE)
done

lemma least_upset:
  "[| poset(R, P); x: P |] ==> least(R, upset(R, P, x), x)"
apply (rule leastI)
apply (erule upsetE)
apply (assumption | (rule upsetI) | (erule poset_reflD))+
done

lemma upset_invrel_eq:
    "upset(invrel(R), P, x) = downset(R, P, x)"
apply (unfold downset_def upset_def invrel_def)
apply (rule refl)
done

lemma downset_invrel_eq:
    "downset(invrel(R), P, x) = upset(R, P, x)"
apply (unfold downset_def upset_def invrel_def)
apply (rule refl)
done

(** upperbound/lowerbound **)
lemma upperboundI:
  "[| x: P; !!y. y: S ==> R(y, x) |] ==> x: upperbound(R, P, S)"
apply (unfold upperbound_def)
apply blast
done

lemma upperboundE:
  "[| x: upperbound(R, P, S); [| x: P; ALL y: S. R(y, x) |] ==> Q |] ==> Q"
apply (unfold upperbound_def)
apply blast
done

lemma upperbound_invrel_eq:
    "upperbound(invrel(R), P, S) = lowerbound(R, P, S)"
apply (unfold lowerbound_def upperbound_def invrel_def)
apply (rule refl)
done

lemma lowerbound_invrel_eq:
    "lowerbound(invrel(R), P, S) = upperbound(R, P, S)"
apply (unfold lowerbound_def upperbound_def invrel_def)
apply (rule refl)
done

(** Prove symmetric theorems **)
lemma greatestI:
  "[| !!y. y: P ==> R(y, x); x: P |] ==> greatest(R, P, x)"
apply (unfold greatest_def)
apply blast
done

lemma greatestD1:
  "greatest(R, P, x) ==> x: P"
apply (unfold greatest_def)
apply blast
done

lemma greatestD2:
  "[| greatest(R, P, x); y: P |] ==> R(y, x)"
apply (unfold greatest_def)
apply blast
done

lemma greatest_unique:
  "[| greatest(R, P, x); greatest(R, P, y); poset(R, P) |] ==> x = y"
apply (simp only: least_invrel_iff [THEN iff_sym])
apply (subst (asm) poset_invrel_iff [THEN iff_sym])
apply (erule least_unique)
apply assumption+
done

lemma greatest_subset:
  "[| S <= P; greatest(R, P, x); x: S |] ==> greatest(R, S, x)"
apply (rule greatestI)
apply (drule subsetD)
apply (drule_tac [2] greatestD2)
by assumption+

lemma Finite_non_empty_chain_has_greatest_element:
  assumes major: "Finite(P)"
  and prem1: "chain(R, P)"
  and prem2: "P ~= 0"
  shows "EX x. greatest(R, P, x)"
apply (insert major prem1 prem2)
apply (simp only: least_invrel_iff [THEN iff_sym])
apply (subst (asm) chain_invrel_iff [THEN iff_sym])
apply (rule Finite_non_empty_chain_has_least_element)
apply assumption+
done

lemma maximalI:
  "[| !!y. [| y: P;  R(x, y) |] ==> y = x; x: P |] ==> maximal(R, P, x)"
apply (unfold maximal_def)
apply blast
done

lemma maximalD1:
  "maximal(R, P, x) ==> x: P"
apply (unfold maximal_def)
apply blast
done

lemma maximalD2:
  "[| maximal(R, P, x); R(x, y); y: P |] ==> y = x"
apply (unfold maximal_def)
apply blast
done

lemma maximal_subset:
  "[| S <= P; maximal(R, P, x); x: S |] ==> maximal(R, S, x)"
apply (rule maximalI)
apply (erule maximalD2)
apply assumption
apply (erule subsetD)
apply assumption+
done

lemma greatest_imp_maximal:
  "[| greatest(R, P, x); poset(R, P) |] ==> maximal(R, P, x)"
apply (rule maximalI)
apply (erule poset_antisymD)
apply (erule_tac [1] greatestD2)
apply (assumption | (erule greatestD1))+
done

lemma chain_maximal_imp_greatest:
  "[| maximal(R, P, x); chain(R, P) |] ==> greatest(R, P, x)"
apply (simp only: least_invrel_iff [THEN iff_sym])
apply (simp only: minimal_invrel_iff [THEN iff_sym])
apply (subst (asm) chain_invrel_iff [THEN iff_sym])
apply (rule chain_minimal_imp_least)
apply assumption+
done

lemma downsetI:
  "[| y: P; R(y, x) |] ==> y: downset(R, P, x)"
apply (unfold downset_def)
apply blast
done

lemma downsetE:
  "[| y: downset(R, P, x); [| y: P; R(y, x) |] ==> Q |] ==> Q"
apply (unfold downset_def)
apply blast
done

lemma downset_subset:
    "downset(R, P, x) <= P"
apply (blast elim!: downsetE)
done

lemma greatest_downset:
  "[| poset(R, P); x: P |] ==> greatest(R, downset(R, P, x), x)"
apply (rule greatestI)
apply (erule downsetE)
apply (assumption | (rule downsetI) | (erule poset_reflD))+
done

lemma lowerboundI:
  "[| x: P; !!y. y: S ==> R(x, y) |] ==> x: lowerbound(R, P, S)"
apply (unfold lowerbound_def)
apply blast
done

lemma lowerboundE:
  "[| x: lowerbound(R, P, S); [| x: P; ALL y: S. R(x, y) |] ==> Q |] ==> Q"
apply (unfold lowerbound_def)
apply blast
done

end


text\<open> 12 November 2021: Exercises for Homework 10 in CS 511 \<close>
text\<open> Your task to remove the invocations of the pre-defined method
      'blast' by an equivalent sequence of 'apply' steps \<close>

theory HW10_solution
  imports Main
begin

text\<open> 'blast' is invoked four times, once in the proof of each of
      lemmas E1, F1, G1, and H1 below \<close>

(* lemma E1 is the same in Exercise 2.3.9 (e), page 161, in [LCS] *)
lemma E1 : "\<forall> x. (P x \<or> Q x) \<Longrightarrow> (\<forall> x. P x) \<or> (\<exists> x. Q x)"
  apply clarify
  apply (erule_tac x="x" in allE)
  apply (erule disjE)
   apply assumption
  apply (erule notE)
  apply (rule_tac x="x" in exI)
  apply assumption
  done

(* lemma F1 is the same in Exercise 2.3.9 (f), page 161, in [LCS] *)
lemma F1 : "\<forall> x. \<exists> y. (P x \<or> Q y) \<Longrightarrow> \<exists> y. \<forall> x. (P x \<or> Q y)"
  apply (rule exCI , rule allI)
  apply (erule_tac x="x" in allE)
  apply (rotate_tac 1, erule exE)
  apply (erule_tac x="y" in allE)
  apply (erule disjE, rule disjI1, assumption)
  apply (rule disjI2, erule notE, rule allI)
  apply (rule disjI2, assumption)
  done

(* lemma G1 is the same in Exercise 2.3.9 (g), page 161, in [LCS] *)
lemma G1 : "\<forall> x. (\<not> P x \<and> Q x) \<Longrightarrow> (\<forall> x. P x \<longrightarrow> Q x)"
  apply (rule allI)
  apply (rule impI)
  apply (erule_tac x="x" in  allE)
  apply (erule conjE)
  apply assumption
  done

(* lemma H1 is the same in Exercise 2.3.9 (h), page 161, in [LCS] *)
lemma H1 : "\<forall> x. (P x \<and> Q x) \<Longrightarrow> (\<forall> x. P x \<longrightarrow> Q x)"
  apply (rule allI)
  apply (rule impI)
  apply (erule_tac x="x" in allE)
  apply (erule conjE)
  apply assumption
  done

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)
 *)

chapter "Distinct Proposition"

theory Distinct_Prop
imports
  "Word_Lib/HOL_Lemmas"
  "~~/src/HOL/Library/Prefix_Order"
begin

primrec
  distinct_prop :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a list \<Rightarrow> bool)"
where
  "distinct_prop P [] = True"
| "distinct_prop P (x # xs) = ((\<forall>y\<in>set xs. P x y) \<and> distinct_prop P xs)"

primrec
  distinct_sets :: "'a set list \<Rightarrow> bool"
where
  "distinct_sets [] = True"
| "distinct_sets (x#xs) = (x \<inter> \<Union>set xs = {} \<and> distinct_sets xs)"

lemma distinct_prop_map:
  "distinct_prop P (map f xs) = distinct_prop (\<lambda>x y. P (f x) (f y)) xs"
  by (induct xs) auto

lemma distinct_prop_append:
  "distinct_prop P (xs @ ys) =
    (distinct_prop P xs \<and> distinct_prop P ys \<and> (\<forall>x \<in> set xs. \<forall>y \<in> set ys. P x y))"
  by (induct xs arbitrary: ys) (auto simp: conj_comms ball_Un)

lemma distinct_prop_distinct:
  "\<lbrakk> distinct xs; \<And>x y. \<lbrakk> x \<in> set xs; y \<in> set xs; x \<noteq> y \<rbrakk> \<Longrightarrow> P x y \<rbrakk> \<Longrightarrow> distinct_prop P xs"
  by (induct xs) auto

lemma distinct_prop_True [simp]:
  "distinct_prop (\<lambda>x y. True) xs"
  by (induct xs, auto)

lemma distinct_prefix:
  "\<lbrakk> distinct xs; ys \<le> xs \<rbrakk> \<Longrightarrow> distinct ys"
  apply (induct xs arbitrary: ys; clarsimp)
  apply (case_tac ys; clarsimp)
  by (fastforce simp: less_eq_list_def dest: set_mono_prefix)

lemma distinct_sets_prop:
  "distinct_sets xs = distinct_prop (\<lambda>x y. x \<inter> y = {}) xs"
  by (induct xs) auto

lemma distinct_take_strg:
  "distinct xs \<longrightarrow> distinct (take n xs)"
  by simp

lemma distinct_prop_prefixE:
  "\<lbrakk> distinct_prop P ys; prefix xs ys \<rbrakk> \<Longrightarrow> distinct_prop P xs"
  apply (induct xs arbitrary: ys; clarsimp)
  apply (case_tac ys; clarsimp)
  by (fastforce dest: set_mono_prefix)

lemma distinct_sets_union_sub:
  "\<lbrakk>x \<in> A; distinct_sets [A,B]\<rbrakk> \<Longrightarrow> A \<union> B - {x} = A - {x} \<union> B"
  by (auto simp: distinct_sets_def)

lemma distinct_sets_append:
  "distinct_sets (xs @ ys) \<Longrightarrow> distinct_sets xs \<and> distinct_sets ys"
  apply (subst distinct_sets_prop)+
  apply (subst (asm) distinct_sets_prop)
  apply (subst (asm) distinct_prop_append)
  apply clarsimp
  done

lemma distinct_sets_append1:
  "distinct_sets (xs @ ys) \<Longrightarrow> distinct_sets xs"
  by (drule distinct_sets_append, simp)

lemma distinct_sets_append2:
  "distinct_sets (xs @ ys) \<Longrightarrow> distinct_sets ys"
  by (drule distinct_sets_append, simp)

lemma distinct_sets_append_Cons:
  "distinct_sets (xs @ a # ys) \<Longrightarrow> distinct_sets (xs @ ys)"
  apply (subst distinct_sets_prop)+
  apply (subst (asm) distinct_sets_prop)
  apply (subst distinct_prop_append)
  apply (subst (asm) distinct_prop_append)
  apply clarsimp
  done

lemma distinct_sets_append_Cons_disjoint:
  "distinct_sets (xs @ a # ys) \<Longrightarrow>  a \<inter> \<Union>set xs = {} "
  apply (subst (asm) distinct_sets_prop)
  apply (subst (asm) distinct_prop_append)
  apply (subst Int_commute)
  apply (subst Union_disjoint)
  apply clarsimp
  done

lemma distinct_prop_take:
  "\<lbrakk>distinct_prop P xs; i < length xs\<rbrakk> \<Longrightarrow> distinct_prop P (take i xs)"
  by (metis take_is_prefix distinct_prop_prefixE)

lemma distinct_sets_take:
  "\<lbrakk>distinct_sets xs; i < length xs\<rbrakk> \<Longrightarrow> distinct_sets (take i xs)"
  by (simp add: distinct_sets_prop distinct_prop_take)

lemma distinct_prop_take_Suc:
  "\<lbrakk>distinct_prop P xs; i < length xs\<rbrakk> \<Longrightarrow> distinct_prop P (take (Suc i) xs)"
  by (metis distinct_prop_take not_less take_all)

lemma distinct_sets_take_Suc:
  "\<lbrakk>distinct_sets xs; i < length xs\<rbrakk> \<Longrightarrow> distinct_sets (take (Suc i) xs)"
  by (simp add: distinct_sets_prop distinct_prop_take_Suc)

lemma distinct_prop_rev:
  "distinct_prop P (rev xs) = distinct_prop (\<lambda>y x. P x y) xs"
  by (induct xs) (auto simp: distinct_prop_append)

lemma distinct_sets_rev [simp]:
  "distinct_sets (rev xs) = distinct_sets xs"
  apply (unfold distinct_sets_prop)
  apply (subst distinct_prop_rev)
  apply (subst Int_commute)
  apply clarsimp
  done

lemma distinct_sets_drop:
  "\<lbrakk>distinct_sets xs; i < length xs\<rbrakk> \<Longrightarrow> distinct_sets (drop i xs)"
  apply (cases "i=0", simp)
  apply (subst distinct_sets_rev [symmetric])
  apply (subst rev_drop)
  apply (subst distinct_sets_take, simp_all)
  done

lemma distinct_sets_drop_Suc:
  "\<lbrakk>distinct_sets xs; i < length xs\<rbrakk> \<Longrightarrow> distinct_sets (drop (Suc i) xs)"
  apply (subst distinct_sets_rev [symmetric])
  apply (subst rev_drop)
  apply (subst distinct_sets_take, simp_all)
  done

lemma distinct_sets_take_nth:
  "\<lbrakk>distinct_sets xs; i < length xs; x \<in> set (take i xs)\<rbrakk> \<Longrightarrow> x \<inter> xs ! i = {}"
  apply (drule (1) distinct_sets_take_Suc)
  apply (subst (asm) take_Suc_conv_app_nth, assumption)
  apply (unfold distinct_sets_prop)
  apply (subst (asm) distinct_prop_append)
  apply clarsimp
  done

lemma distinct_sets_drop_nth:
  "\<lbrakk>distinct_sets xs; i < length xs; x \<in> set (drop (Suc i) xs)\<rbrakk> \<Longrightarrow> x \<inter> xs ! i = {}"
  apply (drule (1) distinct_sets_drop)
  apply (subst (asm) drop_Suc_nth, assumption)
  apply fastforce
  done

lemma distinct_sets_append_distinct:
  "\<lbrakk>x \<in> set xs; y \<in> set ys; distinct_sets (xs @ ys)\<rbrakk> \<Longrightarrow> x \<inter> y = {}"
  unfolding distinct_sets_prop by (clarsimp simp: distinct_prop_append)

lemma distinct_sets_update:
 "\<lbrakk>a \<subseteq> xs ! i; distinct_sets xs; i < length xs\<rbrakk> \<Longrightarrow> distinct_sets (xs[i := a])"
  apply (subst distinct_sets_prop)
  apply (subst (asm) distinct_sets_prop)
  apply (subst upd_conv_take_nth_drop, simp)
  apply (subst distinct_prop_append)
  apply (intro conjI)
    apply (erule (1) distinct_prop_take)
   apply (rule conjI|clarsimp)+
    apply (fold distinct_sets_prop)
    apply (drule (1) distinct_sets_drop)
    apply (subst (asm) drop_Suc_nth, assumption)
    apply fastforce
   apply (drule (1) distinct_sets_drop)
   apply (subst (asm) drop_Suc_nth, assumption)
   apply clarsimp
  apply clarsimp
  apply (rule conjI)
   apply (drule (2) distinct_sets_take_nth)
   apply blast
  apply clarsimp
  apply (thin_tac "P \<subseteq> Q" for P Q)
  apply (subst (asm) id_take_nth_drop, assumption)
  apply (drule distinct_sets_append_Cons)
  apply (erule (2) distinct_sets_append_distinct)
  done

lemma distinct_sets_map_update:
  "\<lbrakk>distinct_sets (map f xs); i < length xs; f a \<subseteq> f(xs ! i)\<rbrakk>
  \<Longrightarrow> distinct_sets (map f (xs[i := a]))"
  by (metis distinct_sets_update length_map map_update nth_map)

lemma Union_list_update:
  "\<lbrakk>i < length xs; distinct_sets (map f xs)\<rbrakk>
  \<Longrightarrow> (\<Union>x\<in>set (xs [i := a]). f x) = (\<Union>x\<in>set xs. f x) - f (xs ! i) \<union> f a"
  apply (induct xs arbitrary: i; clarsimp)
  apply (case_tac i; (clarsimp, fastforce))
  done

lemma fst_enumerate:
  "i < length xs \<Longrightarrow> fst (enumerate n xs ! i) = i + n"
  by (metis add.commute fst_conv nth_enumerate_eq)

lemma snd_enumerate:
  "i < length xs \<Longrightarrow> snd (enumerate n xs ! i) = xs ! i"
  by (metis nth_enumerate_eq snd_conv)

lemma enumerate_member:
  assumes "i < length xs"
  shows "(n + i, xs ! i) \<in> set (enumerate n xs)"
proof -
  have pair_unpack: "\<And>a b x. ((a, b) = x) = (a = fst x \<and> b = snd x)" by fastforce
  from assms have "(n + i, xs ! i) = enumerate n xs ! i"
    by (auto simp: fst_enumerate snd_enumerate pair_unpack)
  with assms show ?thesis by simp
qed

lemma distinct_prop_nth:
  "\<lbrakk> distinct_prop P ls; n < n'; n' < length ls \<rbrakk> \<Longrightarrow> P (ls ! n) (ls ! n')"
  apply (induct ls arbitrary: n n'; simp)
  apply (case_tac n'; simp)
  apply (case_tac n; simp)
  done

end


section \<open> Predicate Calculus Laws \<close>

theory utp_pred_laws
  imports utp_pred
begin

subsection \<open> Propositional Logic \<close>

text \<open> Showing that predicates form a Boolean Algebra (under the predicate operators as opposed to
  the lattice operators) gives us many useful laws. \<close>

interpretation boolean_algebra diff_upred not_upred conj_upred "(\<le>)" "(<)"
  disj_upred false_upred true_upred
  by (unfold_locales; pred_auto)

lemma taut_true [simp]: "`true`"
  by (pred_auto)

lemma taut_false [simp]: "`false` = False"
  by (pred_auto)

lemma taut_conj_elim [elim!]:
  "\<lbrakk> `A \<and> B`; \<lbrakk> `A`; `B` \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by (rel_auto)

lemma taut_refine_impl: "\<lbrakk> Q \<sqsubseteq> P; `P` \<rbrakk> \<Longrightarrow> `Q`"
  by (rel_auto)

lemma taut_shEx_elim:
  "\<lbrakk> `(\<^bold>\<exists> x \<bullet> P x)`; \<And> x. \<Sigma> \<sharp> P x; \<And> x. `P x` \<Longrightarrow> Q  \<rbrakk> \<Longrightarrow> Q"
  by (rel_blast)

text \<open> Linking refinement and HOL implication \<close>

lemma refine_prop_intro:
  assumes "\<Sigma> \<sharp> P" "\<Sigma> \<sharp> Q" "`Q` \<Longrightarrow> `P`"
  shows "P \<sqsubseteq> Q"
  using assms
  by (pred_auto)

lemma taut_not: "\<Sigma> \<sharp> P \<Longrightarrow> (\<not> `P`) = `\<not> P`"
  by (rel_auto)

lemma taut_shAll_intro:
  "\<forall> x. `P x` \<Longrightarrow> `\<^bold>\<forall> x \<bullet> P x`"
  by (rel_auto)

lemma taut_shAll_intro_2:
  "\<forall> x y. `P x y` \<Longrightarrow> `\<^bold>\<forall> (x, y) \<bullet> P x y`"
  by (rel_auto)

lemma taut_impl_intro:
  "\<lbrakk> \<Sigma> \<sharp> P; `P` \<Longrightarrow> `Q` \<rbrakk> \<Longrightarrow> `P \<Rightarrow> Q`"
  by (rel_auto)

lemma upred_eval_taut:
  "`P\<lbrakk>\<guillemotleft>b\<guillemotright>/&\<^bold>v\<rbrakk>` = \<lbrakk>P\<rbrakk>\<^sub>eb"
  by (pred_auto)

lemma refBy_order: "P \<sqsubseteq> Q = `Q \<Rightarrow> P`"
  by (pred_auto)

lemma conj_idem [simp]: "((P::'\<alpha> upred) \<and> P) = P"
  by (pred_auto)

lemma disj_idem [simp]: "((P::'\<alpha> upred) \<or> P) = P"
  by (pred_auto)

lemma conj_comm: "((P::'\<alpha> upred) \<and> Q) = (Q \<and> P)"
  by (pred_auto)

lemma disj_comm: "((P::'\<alpha> upred) \<or> Q) = (Q \<or> P)"
  by (pred_auto)

lemma conj_subst: "P = R \<Longrightarrow> ((P::'\<alpha> upred) \<and> Q) = (R \<and> Q)"
  by (pred_auto)

lemma conj_assoc:"(((P::'\<alpha> upred) \<and> Q) \<and> S) = (P \<and> (Q \<and> S))"
  by (pred_auto)

lemma disj_assoc:"(((P::'\<alpha> upred) \<or> Q) \<or> S) = (P \<or> (Q \<or> S))"
  by (pred_auto)

lemma conj_disj_abs:"((P::'\<alpha> upred) \<and> (P \<or> Q)) = P"
  by (pred_auto)

lemma disj_conj_abs:"((P::'\<alpha> upred) \<or> (P \<and> Q)) = P"
  by (pred_auto)

lemma conj_disj_distr:"((P::'\<alpha> upred) \<and> (Q \<or> R)) = ((P \<and> Q) \<or> (P \<and> R))"
  by (pred_auto)

lemma disj_conj_distr:"((P::'\<alpha> upred) \<or> (Q \<and> R)) = ((P \<or> Q) \<and> (P \<or> R))"
  by (pred_auto)

lemma true_disj_zero [simp]:
  "(P \<or> true) = true" "(true \<or> P) = true"
  by (pred_auto)+

lemma true_conj_zero [simp]:
  "(P \<and> false) = false" "(false \<and> P) = false"
  by (pred_auto)+

lemma false_sup [simp]: "false \<sqinter> P = P" "P \<sqinter> false = P"
  by (pred_auto)+

lemma true_inf [simp]: "true \<squnion> P = P" "P \<squnion> true = P"
  by (pred_auto)+

lemma imp_vacuous [simp]: "(false \<Rightarrow> u) = true"
  by (pred_auto)

lemma imp_true [simp]: "(p \<Rightarrow> true) = true"
  by (pred_auto)

lemma true_imp [simp]: "(true \<Rightarrow> p) = p"
  by (pred_auto)

lemma impl_mp1 [simp]: "(P \<and> (P \<Rightarrow> Q)) = (P \<and> Q)"
  by (pred_auto)

lemma impl_mp2 [simp]: "((P \<Rightarrow> Q) \<and> P) = (Q \<and> P)"
  by (pred_auto)

lemma impl_adjoin: "((P \<Rightarrow> Q) \<and> R) = ((P \<and> R \<Rightarrow> Q \<and> R) \<and> R)"
  by (pred_auto)

lemma impl_refine_intro:
  "\<lbrakk> Q\<^sub>1 \<sqsubseteq> P\<^sub>1; P\<^sub>2 \<sqsubseteq> (P\<^sub>1 \<and> Q\<^sub>2) \<rbrakk> \<Longrightarrow> (P\<^sub>1 \<Rightarrow> P\<^sub>2) \<sqsubseteq> (Q\<^sub>1 \<Rightarrow> Q\<^sub>2)"
  by (pred_auto)

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

lemma impl_disjI: "\<lbrakk> `P \<Rightarrow> R`; `Q \<Rightarrow> R` \<rbrakk> \<Longrightarrow> `(P \<or> Q) \<Rightarrow> R`"
  by (rel_auto)

lemma conditional_iff:
  "(P \<Rightarrow> Q) = (P \<Rightarrow> R) \<longleftrightarrow> `P \<Rightarrow> (Q \<Leftrightarrow> R)`"
  by (pred_auto)

lemma p_and_not_p [simp]: "(P \<and> \<not> P) = false"
  by (pred_auto)

lemma p_or_not_p [simp]: "(P \<or> \<not> P) = true"
  by (pred_auto)

lemma p_imp_p [simp]: "(P \<Rightarrow> P) = true"
  by (pred_auto)

lemma p_iff_p [simp]: "(P \<Leftrightarrow> P) = true"
  by (pred_auto)

lemma p_imp_false [simp]: "(P \<Rightarrow> false) = (\<not> P)"
  by (pred_auto)

lemma not_conj_deMorgans [simp]: "(\<not> ((P::'\<alpha> upred) \<and> Q)) = ((\<not> P) \<or> (\<not> Q))"
  by (pred_auto)

lemma not_disj_deMorgans [simp]: "(\<not> ((P::'\<alpha> upred) \<or> Q)) = ((\<not> P) \<and> (\<not> Q))"
  by (pred_auto)

lemma conj_disj_not_abs [simp]: "((P::'\<alpha> upred) \<and> ((\<not>P) \<or> Q)) = (P \<and> Q)"
  by (pred_auto)

lemma subsumption1:
  "`P \<Rightarrow> Q` \<Longrightarrow> (P \<or> Q) = Q"
  by (pred_auto)

lemma subsumption2:
  "`Q \<Rightarrow> P` \<Longrightarrow> (P \<or> Q) = P"
  by (pred_auto)

lemma neg_conj_cancel1: "(\<not> P \<and> (P \<or> Q)) = (\<not> P \<and> Q :: '\<alpha> upred)"
  by (pred_auto)

lemma neg_conj_cancel2: "(\<not> Q \<and> (P \<or> Q)) = (\<not> Q \<and> P :: '\<alpha> upred)"
  by (pred_auto)

lemma double_negation [simp]: "(\<not> \<not> (P::'\<alpha> upred)) = P"
  by (pred_auto)

lemma true_not_false [simp]: "true \<noteq> false" "false \<noteq> true"
  by (pred_auto)+

lemma closure_conj_distr: "([P]\<^sub>u \<and> [Q]\<^sub>u) = [P \<and> Q]\<^sub>u"
  by (pred_auto)

lemma closure_imp_distr: "`[P \<Rightarrow> Q]\<^sub>u \<Rightarrow> [P]\<^sub>u \<Rightarrow> [Q]\<^sub>u`"
  by (pred_auto)

lemma true_iff [simp]: "(P \<Leftrightarrow> true) = P"
  by (pred_auto)

lemma taut_iff_eq:
  "`P \<Leftrightarrow> Q` \<longleftrightarrow> (P = Q)"
  by (pred_auto)

lemma impl_alt_def: "(P \<Rightarrow> Q) = (\<not> P \<or> Q)"
  by (pred_auto)

subsection \<open> Lattice laws \<close>

lemma uinf_or:
  fixes P Q :: "'\<alpha> upred"
  shows "(P \<sqinter> Q) = (P \<or> Q)"
  by (pred_auto)

lemma usup_and:
  fixes P Q :: "'\<alpha> upred"
  shows "(P \<squnion> Q) = (P \<and> Q)"
  by (pred_auto)

lemma UINF_alt_def:
  "(\<Sqinter> i | A(i) \<bullet> P(i)) = (\<Sqinter> i \<bullet> A(i) \<and> P(i))"
  by (rel_auto)

lemma USUP_true [simp]: "(\<Squnion> P | F(P) \<bullet> true) = true"
  by (pred_auto)

lemma UINF_mem_UNIV [simp]: "(\<Sqinter> x\<in>UNIV \<bullet> P(x)) = (\<Sqinter> x \<bullet> P(x))"
  by (pred_auto)

lemma USUP_mem_UNIV [simp]: "(\<Squnion> x\<in>UNIV \<bullet> P(x)) = (\<Squnion> x \<bullet> P(x))"
  by (pred_auto)

lemma USUP_false [simp]: "(\<Squnion> i \<bullet> false) = false"
  by (pred_simp)

lemma USUP_mem_false [simp]: "I \<noteq> {} \<Longrightarrow> (\<Squnion> i\<in>I \<bullet> false) = false"
  by (rel_simp)

lemma USUP_where_false [simp]: "(\<Squnion> i | false \<bullet> P(i)) = true"
  by (rel_auto)

lemma UINF_true [simp]: "(\<Sqinter> i \<bullet> true) = true"
  by (pred_simp)

lemma UINF_ind_const [simp]:
  "(\<Sqinter> i \<bullet> P) = P"
  by (rel_auto)

lemma UINF_mem_true [simp]: "A \<noteq> {} \<Longrightarrow> (\<Sqinter> i\<in>A \<bullet> true) = true"
  by (pred_auto)

lemma UINF_false [simp]: "(\<Sqinter> i | P(i) \<bullet> false) = false"
  by (pred_auto)

lemma UINF_where_false [simp]: "(\<Sqinter> i | false \<bullet> P(i)) = false"
  by (rel_auto)

lemma UINF_cong_eq:
  "\<lbrakk> \<And> x. P\<^sub>1(x) = P\<^sub>2(x); \<And> x. `P\<^sub>1(x) \<Rightarrow> Q\<^sub>1(x) =\<^sub>u Q\<^sub>2(x)` \<rbrakk> \<Longrightarrow>
        (\<Sqinter> x | P\<^sub>1(x) \<bullet> Q\<^sub>1(x)) = (\<Sqinter> x | P\<^sub>2(x) \<bullet> Q\<^sub>2(x))"
 by (unfold UINF_def, pred_simp, metis)

lemma UINF_as_Sup: "(\<Sqinter> P \<in> \<P> \<bullet> P) = \<Sqinter> \<P>"
  apply (simp add: upred_defs bop.rep_eq lit.rep_eq Sup_uexpr_def)
  apply (pred_simp)
  apply (rule cong[of "Sup"])
   apply (auto)
  done

lemma UINF_as_Sup_collect: "(\<Sqinter>P\<in>A \<bullet> f(P)) = (\<Sqinter>P\<in>A. f(P))"
  apply (simp add: upred_defs bop.rep_eq lit.rep_eq Sup_uexpr_def)
  apply (pred_simp)
  apply (simp add: Setcompr_eq_image)
  done

lemma UINF_as_Sup_collect': "(\<Sqinter>P \<bullet> f(P)) = (\<Sqinter>P. f(P))"
  apply (simp add: upred_defs bop.rep_eq lit.rep_eq Sup_uexpr_def)
  apply (pred_simp)
  apply (simp add: full_SetCompr_eq)
  done

lemma UINF_as_Sup_image: "(\<Sqinter> P | \<guillemotleft>P\<guillemotright> \<in>\<^sub>u \<guillemotleft>A\<guillemotright> \<bullet> f(P)) = \<Sqinter> (f ` A)"
  apply (simp add: upred_defs bop.rep_eq lit.rep_eq Sup_uexpr_def)
  apply (pred_simp)
  apply (rule cong[of "Sup"])
   apply (auto)
  done

lemma USUP_as_Inf: "(\<Squnion> P \<in> \<P> \<bullet> P) = \<Squnion> \<P>"
  apply (simp add: upred_defs bop.rep_eq lit.rep_eq Inf_uexpr_def)
  apply (pred_simp)
  apply (rule cong[of "Inf"])
   apply (auto)
  done

lemma USUP_as_Inf_collect: "(\<Squnion>P\<in>A \<bullet> f(P)) = (\<Squnion>P\<in>A. f(P))"
  apply (pred_simp)
  apply (simp add: Setcompr_eq_image)
  done

lemma USUP_as_Inf_collect': "(\<Squnion>P \<bullet> f(P)) = (\<Squnion>P. f(P))"
  apply (simp add: upred_defs bop.rep_eq lit.rep_eq Sup_uexpr_def)
  apply (pred_simp)
  apply (simp add: full_SetCompr_eq)
  done

lemma USUP_as_Inf_image: "(\<Squnion> P \<in> \<P> \<bullet> f(P)) = \<Squnion> (f ` \<P>)"
  apply (simp add: upred_defs bop.rep_eq lit.rep_eq Inf_uexpr_def)
  apply (pred_simp)
  apply (rule cong[of "Inf"])
   apply (auto)
  done

lemma USUP_image_eq [simp]: "USUP (\<lambda>i. \<guillemotleft>i\<guillemotright> \<in>\<^sub>u \<guillemotleft>f ` A\<guillemotright>) g = (\<Squnion> i\<in>A \<bullet> g(f(i)))"
  by (pred_simp, rule_tac cong[of Inf Inf], auto)

lemma UINF_image_eq [simp]: "UINF (\<lambda>i. \<guillemotleft>i\<guillemotright> \<in>\<^sub>u \<guillemotleft>f ` A\<guillemotright>) g = (\<Sqinter> i\<in>A \<bullet> g(f(i)))"
  by (pred_simp, rule_tac cong[of Sup Sup], auto)

lemma subst_continuous [usubst]: "\<sigma> \<dagger> (\<Sqinter> A) = (\<Sqinter> {\<sigma> \<dagger> P | P. P \<in> A})"
  by (simp add: UINF_as_Sup[THEN sym] usubst setcompr_eq_image)

lemma not_UINF: "(\<not> (\<Sqinter> i\<in>A\<bullet> P(i))) = (\<Squnion> i\<in>A\<bullet> \<not> P(i))"
  by (pred_auto)

lemma not_USUP: "(\<not> (\<Squnion> i\<in>A\<bullet> P(i))) = (\<Sqinter> i\<in>A\<bullet> \<not> P(i))"
  by (pred_auto)

lemma not_UINF_ind: "(\<not> (\<Sqinter> i \<bullet> P(i))) = (\<Squnion> i \<bullet> \<not> P(i))"
  by (pred_auto)

lemma not_USUP_ind: "(\<not> (\<Squnion> i \<bullet> P(i))) = (\<Sqinter> i \<bullet> \<not> P(i))"
  by (pred_auto)

lemma UINF_empty [simp]: "(\<Sqinter> i \<in> {} \<bullet> P(i)) = false"
  by (pred_auto)

lemma UINF_insert [simp]: "(\<Sqinter> i\<in>insert x xs \<bullet> P(i)) = (P(x) \<sqinter> (\<Sqinter> i\<in>xs \<bullet> P(i)))"
  apply (pred_simp)
  apply (subst Sup_insert[THEN sym])
  apply (rule_tac cong[of Sup Sup])
   apply (auto)
  done

lemma UINF_atLeast_first:
  "P(n) \<sqinter> (\<Sqinter> i \<in> {Suc n..} \<bullet> P(i)) = (\<Sqinter> i \<in> {n..} \<bullet> P(i))"
proof -
  have "insert n {Suc n..} = {n..}"
    by (auto)
  thus ?thesis
    by (metis UINF_insert)
qed

lemma UINF_atLeast_Suc:
  "(\<Sqinter> i \<in> {Suc m..} \<bullet> P(i)) = (\<Sqinter> i \<in> {m..} \<bullet> P(Suc i))"
  by (rel_simp, metis (full_types) Suc_le_D not_less_eq_eq)

lemma USUP_empty [simp]: "(\<Squnion> i \<in> {} \<bullet> P(i)) = true"
  by (pred_auto)

lemma USUP_insert [simp]: "(\<Squnion> i\<in>insert x xs \<bullet> P(i)) = (P(x) \<squnion> (\<Squnion> i\<in>xs \<bullet> P(i)))"
  apply (pred_simp)
  apply (subst Inf_insert[THEN sym])
  apply (rule_tac cong[of Inf Inf])
   apply (auto)
  done

lemma USUP_atLeast_first:
  "(P(n) \<and> (\<Squnion> i \<in> {Suc n..} \<bullet> P(i))) = (\<Squnion> i \<in> {n..} \<bullet> P(i))"
proof -
  have "insert n {Suc n..} = {n..}"
    by (auto)
  thus ?thesis
    by (metis USUP_insert conj_upred_def)
qed

lemma USUP_atLeast_Suc:
  "(\<Squnion> i \<in> {Suc m..} \<bullet> P(i)) = (\<Squnion> i \<in> {m..} \<bullet> P(Suc i))"
  by (rel_simp, metis (full_types) Suc_le_D not_less_eq_eq)

lemma conj_UINF_dist:
  "(P \<and> (\<Sqinter> Q\<in>S \<bullet> F(Q))) = (\<Sqinter> Q\<in>S \<bullet> P \<and> F(Q))"
  by (simp add: upred_defs bop.rep_eq lit.rep_eq, pred_auto)

lemma conj_UINF_ind_dist:
  "(P \<and> (\<Sqinter> Q \<bullet> F(Q))) = (\<Sqinter> Q \<bullet> P \<and> F(Q))"
  by pred_auto

lemma disj_UINF_dist:
  "S \<noteq> {} \<Longrightarrow> (P \<or> (\<Sqinter> Q\<in>S \<bullet> F(Q))) = (\<Sqinter> Q\<in>S \<bullet> P \<or> F(Q))"
  by (simp add: upred_defs bop.rep_eq lit.rep_eq, pred_auto)

lemma conj_USUP_dist:
  "S \<noteq> {} \<Longrightarrow> (P \<and> (\<Squnion> Q\<in>S \<bullet> F(Q))) = (\<Squnion> Q\<in>S \<bullet> P \<and> F(Q))"
  by (subst uexpr_eq_iff, auto simp add: conj_upred_def USUP.rep_eq inf_uexpr.rep_eq bop.rep_eq lit.rep_eq)

lemma USUP_conj_USUP [simp]: "((\<Squnion> P \<in> A \<bullet> F(P)) \<and> (\<Squnion> P \<in> A \<bullet> G(P))) = (\<Squnion> P \<in> A \<bullet> F(P) \<and> G(P))"
  by (simp add: upred_defs bop.rep_eq lit.rep_eq, pred_auto)

lemma UINF_all_cong [cong]:
  assumes "\<And> P. F(P) = G(P)"
  shows "(\<Sqinter> P \<bullet> F(P)) = (\<Sqinter> P \<bullet> G(P))"
  by (simp add: UINF_as_Sup_collect assms)

lemma UINF_cong:
  assumes "\<And> P. P \<in> A \<Longrightarrow> F(P) = G(P)"
  shows "(\<Sqinter> P\<in>A \<bullet> F(P)) = (\<Sqinter> P\<in>A \<bullet> G(P))"
  by (simp add: UINF_as_Sup_collect assms)

lemma USUP_all_cong:
  assumes "\<And> P. F(P) = G(P)"
  shows "(\<Squnion> P \<bullet> F(P)) = (\<Squnion> P \<bullet> G(P))"
  by (simp add: assms)

lemma USUP_cong:
  assumes "\<And> P. P \<in> A \<Longrightarrow> F(P) = G(P)"
  shows "(\<Squnion> P\<in>A \<bullet> F(P)) = (\<Squnion> P\<in>A \<bullet> G(P))"
  by (simp add: USUP_as_Inf_collect assms)

lemma UINF_subset_mono: "A \<subseteq> B \<Longrightarrow> (\<Sqinter> P\<in>B \<bullet> F(P)) \<sqsubseteq> (\<Sqinter> P\<in>A \<bullet> F(P))"
  by (simp add: SUP_subset_mono UINF_as_Sup_collect)

lemma USUP_subset_mono: "A \<subseteq> B \<Longrightarrow> (\<Squnion> P\<in>A \<bullet> F(P)) \<sqsubseteq> (\<Squnion> P\<in>B \<bullet> F(P))"
  by (simp add: INF_superset_mono USUP_as_Inf_collect)

lemma UINF_impl: "(\<Sqinter> P\<in>A \<bullet> F(P) \<Rightarrow> G(P)) = ((\<Squnion> P\<in>A \<bullet> F(P)) \<Rightarrow> (\<Sqinter> P\<in>A \<bullet> G(P)))"
  by (pred_auto)

lemma USUP_is_forall: "(\<Squnion> x \<bullet> P(x)) = (\<^bold>\<forall> x \<bullet> P(x))"
  by (pred_simp)

lemma USUP_ind_is_forall: "(\<Squnion> x\<in>A \<bullet> P(x)) = (\<^bold>\<forall> x\<in>\<guillemotleft>A\<guillemotright> \<bullet> P(x))"
  by (pred_auto)

lemma UINF_is_exists: "(\<Sqinter> x \<bullet> P(x)) = (\<^bold>\<exists> x \<bullet> P(x))"
  by (pred_simp)

lemma UINF_all_nats [simp]:
  fixes P :: "nat \<Rightarrow> '\<alpha> upred"
  shows "(\<Sqinter> n \<bullet> \<Sqinter> i\<in>{0..n} \<bullet> P(i)) = (\<Sqinter> n \<bullet> P(n))"
  by (pred_auto)

lemma USUP_all_nats [simp]:
  fixes P :: "nat \<Rightarrow> '\<alpha> upred"
  shows "(\<Squnion> n \<bullet> \<Squnion> i\<in>{0..n} \<bullet> P(i)) = (\<Squnion> n \<bullet> P(n))"
  by (pred_auto)

lemma UINF_upto_expand_first:
  "m < n \<Longrightarrow> (\<Sqinter> i \<in> {m..<n} \<bullet> P(i)) = ((P(m) :: '\<alpha> upred) \<or> (\<Sqinter> i \<in> {Suc m..<n} \<bullet> P(i)))"
  apply (rel_auto) using Suc_leI le_eq_less_or_eq by auto

lemma UINF_upto_expand_last:
  "(\<Sqinter> i \<in> {0..<Suc(n)} \<bullet> P(i)) = ((\<Sqinter> i \<in> {0..<n} \<bullet> P(i)) \<or> P(n))"
  apply (rel_auto)
  using less_SucE by blast

lemma UINF_Suc_shift: "(\<Sqinter> i \<in> {Suc 0..<Suc n} \<bullet> P(i)) = (\<Sqinter> i \<in> {0..<n} \<bullet> P(Suc i))"
  apply (rel_simp)
  apply (rule cong[of Sup], auto)
  using less_Suc_eq_0_disj by auto

lemma USUP_upto_expand_first:
  "(\<Squnion> i \<in> {0..<Suc(n)} \<bullet> P(i)) = (P(0) \<and> (\<Squnion> i \<in> {1..<Suc(n)} \<bullet> P(i)))"
  apply (rel_auto)
  using not_less by auto

lemma USUP_Suc_shift: "(\<Squnion> i \<in> {Suc 0..<Suc n} \<bullet> P(i)) = (\<Squnion> i \<in> {0..<n} \<bullet> P(Suc i))"
  apply (rel_simp)
  apply (rule cong[of Inf], auto)
  using less_Suc_eq_0_disj by auto

lemma UINF_list_conv:
  "(\<Sqinter> i \<in> {0..<length(xs)} \<bullet> f (xs ! i)) = foldr (\<or>) (map f xs) false"
  apply (induct xs)
   apply (rel_auto)
  apply (simp add: UINF_upto_expand_first UINF_Suc_shift)
  done

lemma USUP_list_conv:
  "(\<Squnion> i \<in> {0..<length(xs)} \<bullet> f (xs ! i)) = foldr (\<and>) (map f xs) true"
  apply (induct xs)
   apply (rel_auto)
  apply (simp_all add: USUP_upto_expand_first USUP_Suc_shift)
  done

lemma UINF_refines:
  "\<lbrakk> \<And> i. i\<in>I \<Longrightarrow> P \<sqsubseteq> Q i \<rbrakk> \<Longrightarrow> P \<sqsubseteq> (\<Sqinter> i\<in>I \<bullet> Q i)"
  by (simp add: UINF_as_Sup_collect, metis SUP_least)

lemma UINF_refines':
  assumes "\<And> i. P \<sqsubseteq> Q(i)"
  shows "P \<sqsubseteq> (\<Sqinter> i \<bullet> Q(i))"
  using assms
  apply (rel_auto) using Sup_le_iff by fastforce

lemma UINF_pred_lit_eq [simp]:
  "(\<Sqinter> x | \<guillemotleft>x = v\<guillemotright> \<bullet> P(x)) = (P v)"
  by (pred_auto)

subsection \<open> Equality laws \<close>

lemma eq_upred_refl [simp]: "(x =\<^sub>u x) = true"
  by (pred_auto)

lemma eq_upred_sym: "(x =\<^sub>u y) = (y =\<^sub>u x)"
  by (pred_auto)

lemma eq_cong_left:
  assumes "vwb_lens x" "$x \<sharp> Q" "$x\<acute> \<sharp> Q" "$x \<sharp> R" "$x\<acute> \<sharp> R"
  shows "(($x\<acute> =\<^sub>u $x \<and> Q) = ($x\<acute> =\<^sub>u $x \<and> R)) \<longleftrightarrow> (Q = R)"
  using assms
  by (pred_simp, (meson mwb_lens_def vwb_lens_mwb weak_lens_def)+)

lemma conj_eq_in_var_subst:
  fixes x :: "('a \<Longrightarrow> '\<alpha>)"
  assumes "vwb_lens x"
  shows "(P \<and> $x =\<^sub>u v) = (P\<lbrakk>v/$x\<rbrakk> \<and> $x =\<^sub>u v)"
  using assms
  by (pred_simp, (metis vwb_lens_wb wb_lens.get_put)+)

lemma conj_eq_out_var_subst:
  fixes x :: "('a \<Longrightarrow> '\<alpha>)"
  assumes "vwb_lens x"
  shows "(P \<and> $x\<acute> =\<^sub>u v) = (P\<lbrakk>v/$x\<acute>\<rbrakk> \<and> $x\<acute> =\<^sub>u v)"
  using assms
  by (pred_simp, (metis vwb_lens_wb wb_lens.get_put)+)

lemma conj_pos_var_subst:
  assumes "vwb_lens x"
  shows "($x \<and> Q) = ($x \<and> Q\<lbrakk>true/$x\<rbrakk>)"
  using assms
  by (pred_auto, metis (full_types) vwb_lens_wb wb_lens.get_put, metis (full_types) vwb_lens_wb wb_lens.get_put)

lemma conj_neg_var_subst:
  assumes "vwb_lens x"
  shows "(\<not> $x \<and> Q) = (\<not> $x \<and> Q\<lbrakk>false/$x\<rbrakk>)"
  using assms
  by (pred_auto, metis (full_types) vwb_lens_wb wb_lens.get_put, metis (full_types) vwb_lens_wb wb_lens.get_put)

lemma upred_eq_true [simp]: "(p =\<^sub>u true) = p"
  by (pred_auto)

lemma upred_eq_false [simp]: "(p =\<^sub>u false) = (\<not> p)"
  by (pred_auto)

lemma upred_true_eq [simp]: "(true =\<^sub>u p) = p"
  by (pred_auto)

lemma upred_false_eq [simp]: "(false =\<^sub>u p) = (\<not> p)"
  by (pred_auto)

lemma conj_var_subst:
  assumes "vwb_lens x"
  shows "(P \<and> var x =\<^sub>u v) = (P\<lbrakk>v/x\<rbrakk> \<and> var x =\<^sub>u v)"
  using assms
  by (pred_simp, (metis (full_types) vwb_lens_def wb_lens.get_put)+)

subsection \<open> HOL Variable Quantifiers \<close>

lemma shEx_unbound [simp]: "(\<^bold>\<exists> x \<bullet> P) = P"
  by (pred_auto)

lemma shEx_bool [simp]: "shEx P = (P True \<or> P False)"
  by (pred_simp, metis (full_types))

lemma shEx_commute: "(\<^bold>\<exists> x \<bullet> \<^bold>\<exists> y \<bullet> P x y) = (\<^bold>\<exists> y \<bullet> \<^bold>\<exists> x \<bullet> P x y)"
  by (pred_auto)

lemma shEx_cong: "\<lbrakk> \<And> x. P x = Q x \<rbrakk> \<Longrightarrow> shEx P = shEx Q"
  by (pred_auto)

lemma shEx_insert: "(\<^bold>\<exists> x \<in> insert\<^sub>u y A \<bullet> P(x)) = (P(x)\<lbrakk>x\<rightarrow>y\<rbrakk> \<or> (\<^bold>\<exists> x \<in> A \<bullet> P(x)))"
  by (pred_auto)

lemma shEx_one_point: "(\<^bold>\<exists> x \<bullet> \<guillemotleft>x\<guillemotright> =\<^sub>u v \<and> P(x)) = P(x)\<lbrakk>x\<rightarrow>v\<rbrakk>"
  by (rel_auto)

lemma shAll_unbound [simp]: "(\<^bold>\<forall> x \<bullet> P) = P"
  by (pred_auto)

lemma shAll_bool [simp]: "shAll P = (P True \<and> P False)"
  by (pred_simp, metis (full_types))

lemma shAll_cong: "\<lbrakk> \<And> x. P x = Q x \<rbrakk> \<Longrightarrow> shAll P = shAll Q"
  by (pred_auto)

text \<open> Quantifier lifting \<close>

named_theorems uquant_lift

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

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

subsection \<open> Case Splitting \<close>

lemma eq_split_subst:
  assumes "vwb_lens x"
  shows "(P = Q) \<longleftrightarrow> (\<forall> v. P\<lbrakk>\<guillemotleft>v\<guillemotright>/x\<rbrakk> = Q\<lbrakk>\<guillemotleft>v\<guillemotright>/x\<rbrakk>)"
  using assms
  by (pred_auto, metis vwb_lens_wb wb_lens.source_stability)

lemma eq_split_substI:
  assumes "vwb_lens x" "\<And> v. P\<lbrakk>\<guillemotleft>v\<guillemotright>/x\<rbrakk> = Q\<lbrakk>\<guillemotleft>v\<guillemotright>/x\<rbrakk>"
  shows "P = Q"
  using assms(1) assms(2) eq_split_subst by blast

lemma taut_split_subst:
  assumes "vwb_lens x"
  shows "`P` \<longleftrightarrow> (\<forall> v. `P\<lbrakk>\<guillemotleft>v\<guillemotright>/x\<rbrakk>`)"
  using assms
  by (pred_auto, metis vwb_lens_wb wb_lens.source_stability)

lemma eq_split:
  assumes "`P \<Rightarrow> Q`" "`Q \<Rightarrow> P`"
  shows "P = Q"
  using assms
  by (pred_auto)

lemma subst_bool_split:
  assumes "vwb_lens x"
  shows "`P` = `(P\<lbrakk>false/x\<rbrakk> \<and> P\<lbrakk>true/x\<rbrakk>)`"
proof -
  from assms have "`P` = (\<forall> v. `P\<lbrakk>\<guillemotleft>v\<guillemotright>/x\<rbrakk>`)"
    by (subst taut_split_subst[of x], auto)
  also have "... = (`P\<lbrakk>\<guillemotleft>True\<guillemotright>/x\<rbrakk>` \<and> `P\<lbrakk>\<guillemotleft>False\<guillemotright>/x\<rbrakk>`)"
    by (metis (mono_tags, lifting))
  also have "... = `(P\<lbrakk>false/x\<rbrakk> \<and> P\<lbrakk>true/x\<rbrakk>)`"
    by (pred_auto)
  finally show ?thesis .
qed

lemma subst_eq_replace:
  fixes x :: "('a \<Longrightarrow> '\<alpha>)"
  shows "(p\<lbrakk>u/x\<rbrakk> \<and> u =\<^sub>u v) = (p\<lbrakk>v/x\<rbrakk> \<and> u =\<^sub>u v)"
  by (pred_auto)

subsection \<open> UTP Quantifiers \<close>

lemma exists_twice: "mwb_lens x \<Longrightarrow> (\<exists> x \<bullet> \<exists> x \<bullet> P) = (\<exists> x \<bullet> P)"
  by (pred_auto)

lemma all_twice: "mwb_lens x \<Longrightarrow> (\<forall> x \<bullet> \<forall> x \<bullet> P) = (\<forall> x \<bullet> P)"
  by (pred_auto)

lemma exists_sub: "\<lbrakk> mwb_lens y; x \<subseteq>\<^sub>L y \<rbrakk> \<Longrightarrow> (\<exists> x \<bullet> \<exists> y \<bullet> P) = (\<exists> y \<bullet> P)"
  by (pred_auto)

lemma all_sub: "\<lbrakk> mwb_lens y; x \<subseteq>\<^sub>L y \<rbrakk> \<Longrightarrow> (\<forall> x \<bullet> \<forall> y \<bullet> P) = (\<forall> y \<bullet> P)"
  by (pred_auto)

lemma ex_commute:
  assumes "x \<bowtie> y"
  shows "(\<exists> x \<bullet> \<exists> y \<bullet> P) = (\<exists> y \<bullet> \<exists> x \<bullet> P)"
  using assms
  apply (pred_auto)
  using lens_indep_comm apply fastforce+
  done

lemma all_commute:
  assumes "x \<bowtie> y"
  shows "(\<forall> x \<bullet> \<forall> y \<bullet> P) = (\<forall> y \<bullet> \<forall> x \<bullet> P)"
  using assms
  apply (pred_auto)
  using lens_indep_comm apply fastforce+
  done

lemma ex_equiv:
  assumes "x \<approx>\<^sub>L y"
  shows "(\<exists> x \<bullet> P) = (\<exists> y \<bullet> P)"
  using assms
  by (pred_simp, metis (no_types, lifting) lens.select_convs(2))

lemma all_equiv:
  assumes "x \<approx>\<^sub>L y"
  shows "(\<forall> x \<bullet> P) = (\<forall> y \<bullet> P)"
  using assms
  by (pred_simp, metis (no_types, lifting) lens.select_convs(2))

lemma ex_zero:
  "(\<exists> \<emptyset> \<bullet> P) = P"
  by (pred_auto)

lemma all_zero:
  "(\<forall> \<emptyset> \<bullet> P) = P"
  by (pred_auto)

lemma ex_plus:
  "(\<exists> y;x \<bullet> P) = (\<exists> x \<bullet> \<exists> y \<bullet> P)"
  by (pred_auto)

lemma all_plus:
  "(\<forall> y;x \<bullet> P) = (\<forall> x \<bullet> \<forall> y \<bullet> P)"
  by (pred_auto)

lemma closure_all:
  "[P]\<^sub>u = (\<forall> \<Sigma> \<bullet> P)"
  by (pred_auto)

lemma unrest_as_exists:
  "vwb_lens x \<Longrightarrow> (x \<sharp> P) \<longleftrightarrow> ((\<exists> x \<bullet> P) = P)"
  by (pred_simp, metis vwb_lens.put_eq)

lemma ex_mono: "P \<sqsubseteq> Q \<Longrightarrow> (\<exists> x \<bullet> P) \<sqsubseteq> (\<exists> x \<bullet> Q)"
  by (pred_auto)

lemma ex_weakens: "wb_lens x \<Longrightarrow> (\<exists> x \<bullet> P) \<sqsubseteq> P"
  by (pred_simp, metis wb_lens.get_put)

lemma all_mono: "P \<sqsubseteq> Q \<Longrightarrow> (\<forall> x \<bullet> P) \<sqsubseteq> (\<forall> x \<bullet> Q)"
  by (pred_auto)

lemma all_strengthens: "wb_lens x \<Longrightarrow> P \<sqsubseteq> (\<forall> x \<bullet> P)"
  by (pred_simp, metis wb_lens.get_put)

lemma ex_unrest: "x \<sharp> P \<Longrightarrow> (\<exists> x \<bullet> P) = P"
  by (pred_auto)

lemma all_unrest: "x \<sharp> P \<Longrightarrow> (\<forall> x \<bullet> P) = P"
  by (pred_auto)

lemma not_ex_not: "\<not> (\<exists> x \<bullet> \<not> P) = (\<forall> x \<bullet> P)"
  by (pred_auto)

lemma ex_conj_contr_left: "x \<sharp> P \<Longrightarrow> (\<exists> x \<bullet> P \<and> Q) = (P \<and> (\<exists> x \<bullet> Q))"
  by (pred_auto)

lemma ex_conj_contr_right: "x \<sharp> Q \<Longrightarrow> (\<exists> x \<bullet> P \<and> Q) = ((\<exists> x \<bullet> P) \<and> Q)"
  by (pred_auto)

subsection \<open> Variable Restriction \<close>

lemma var_res_all:
  "P \<restriction>\<^sub>v \<Sigma> = P"
  by (rel_auto)

lemma var_res_twice:
  "mwb_lens x \<Longrightarrow> P \<restriction>\<^sub>v x \<restriction>\<^sub>v x = P \<restriction>\<^sub>v x"
  by (pred_auto)

subsection \<open> Conditional laws \<close>

lemma cond_def:
  "(P \<triangleleft> b \<triangleright> Q) = ((b \<and> P) \<or> ((\<not> b) \<and> Q))"
  by (pred_auto)

lemma cond_idem [simp]:"(P \<triangleleft> b \<triangleright> P) = P" by (pred_auto)

lemma cond_true_false [simp]: "true \<triangleleft> b \<triangleright> false = b" by (pred_auto)

lemma cond_symm:"(P \<triangleleft> b \<triangleright> Q) = (Q \<triangleleft> \<not> b \<triangleright> P)" by (pred_auto)

lemma cond_assoc: "((P \<triangleleft> b \<triangleright> Q) \<triangleleft> c \<triangleright> R) = (P \<triangleleft> b \<and> c \<triangleright> (Q \<triangleleft> c \<triangleright> R))" by (pred_auto)

lemma cond_unit_T [simp]:"(P \<triangleleft> true \<triangleright> Q) = P" by (pred_auto)

lemma cond_unit_F [simp]:"(P \<triangleleft> false \<triangleright> Q) = Q" by (pred_auto)

lemma cond_conj_not: "((P \<triangleleft> b \<triangleright> Q) \<and> (\<not> b)) = (Q \<and> (\<not> b))"
  by (rel_auto)

lemma cond_and_T_integrate:
  "((P \<and> b) \<or> (Q \<triangleleft> b \<triangleright> R)) = ((P \<or> Q) \<triangleleft> b \<triangleright> R)"
  by (pred_auto)

lemma cond_L6: "(P \<triangleleft> b \<triangleright> (Q \<triangleleft> b \<triangleright> R)) = (P \<triangleleft> b \<triangleright> R)" by (pred_auto)

lemma cond_L7: "(P \<triangleleft> b \<triangleright> (P \<triangleleft> c \<triangleright> Q)) = (P \<triangleleft> b \<or> c \<triangleright> Q)" by (pred_auto)

lemma cond_and_distr: "((P \<and> Q) \<triangleleft> b \<triangleright> (R \<and> S)) = ((P \<triangleleft> b \<triangleright> R) \<and> (Q \<triangleleft> b \<triangleright> S))" by (pred_auto)

lemma cond_imp_distr:
"((P \<Rightarrow> Q) \<triangleleft> b \<triangleright> (R \<Rightarrow> S)) = ((P \<triangleleft> b \<triangleright> R) \<Rightarrow> (Q \<triangleleft> b \<triangleright> S))" by (pred_auto)

lemma cond_eq_distr:
"((P \<Leftrightarrow> Q) \<triangleleft> b \<triangleright> (R \<Leftrightarrow> S)) = ((P \<triangleleft> b \<triangleright> R) \<Leftrightarrow> (Q \<triangleleft> b \<triangleright> S))" by (pred_auto)

lemma cond_conj_distr:"(P \<and> (Q \<triangleleft> b \<triangleright> S)) = ((P \<and> Q) \<triangleleft> b \<triangleright> (P \<and> S))" by (pred_auto)

lemma cond_disj_distr:"(P \<or> (Q \<triangleleft> b \<triangleright> S)) = ((P \<or> Q) \<triangleleft> b \<triangleright> (P \<or> S))" by (pred_auto)

lemma cond_neg: "\<not> (P \<triangleleft> b \<triangleright> Q) = ((\<not> P) \<triangleleft> b \<triangleright> (\<not> Q))" by (pred_auto)

lemma cond_conj: "P \<triangleleft> b \<and> c \<triangleright> Q = (P \<triangleleft> c \<triangleright> Q) \<triangleleft> b \<triangleright> Q"
  by (pred_auto)

lemma spec_cond_dist: "(P \<Rightarrow> (Q \<triangleleft> b \<triangleright> R)) = ((P \<Rightarrow> Q) \<triangleleft> b \<triangleright> (P \<Rightarrow> R))"
  by (pred_auto)

lemma cond_USUP_dist: "(\<Squnion> P\<in>S \<bullet> F(P)) \<triangleleft> b \<triangleright> (\<Squnion> P\<in>S \<bullet> G(P)) = (\<Squnion> P\<in>S \<bullet> F(P) \<triangleleft> b \<triangleright> G(P))"
  by (pred_auto)

lemma cond_UINF_dist: "(\<Sqinter> P\<in>S \<bullet> F(P)) \<triangleleft> b \<triangleright> (\<Sqinter> P\<in>S \<bullet> G(P)) = (\<Sqinter> P\<in>S \<bullet> F(P) \<triangleleft> b \<triangleright> G(P))"
  by (pred_auto)

lemma cond_var_subst_left:
  assumes "vwb_lens x"
  shows "(P\<lbrakk>true/x\<rbrakk> \<triangleleft> var x \<triangleright> Q) = (P \<triangleleft> var x \<triangleright> Q)"
  using assms by (pred_auto, metis (full_types) vwb_lens_wb wb_lens.get_put)

lemma cond_var_subst_right:
  assumes "vwb_lens x"
  shows "(P \<triangleleft> var x \<triangleright> Q\<lbrakk>false/x\<rbrakk>) = (P \<triangleleft> var x \<triangleright> Q)"
  using assms by (pred_auto, metis (full_types) vwb_lens.put_eq)

lemma cond_var_split:
  "vwb_lens x \<Longrightarrow> (P\<lbrakk>true/x\<rbrakk> \<triangleleft> var x \<triangleright> P\<lbrakk>false/x\<rbrakk>) = P"
  by (rel_simp, (metis (full_types) vwb_lens.put_eq)+)

lemma cond_assign_subst:
  "vwb_lens x \<Longrightarrow> (P \<triangleleft> utp_expr.var x =\<^sub>u v \<triangleright> Q) = (P\<lbrakk>v/x\<rbrakk> \<triangleleft> utp_expr.var x =\<^sub>u v \<triangleright> Q)"
  apply (rel_simp) using vwb_lens.put_eq by force

lemma conj_conds:
  "(P1 \<triangleleft> b \<triangleright> Q1 \<and> P2 \<triangleleft> b \<triangleright> Q2) = (P1 \<and> P2) \<triangleleft> b \<triangleright> (Q1 \<and> Q2)"
  by pred_auto

lemma disj_conds:
  "(P1 \<triangleleft> b \<triangleright> Q1 \<or> P2 \<triangleleft> b \<triangleright> Q2) = (P1 \<or> P2) \<triangleleft> b \<triangleright> (Q1 \<or> Q2)"
  by pred_auto

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)"
  by (rel_auto)

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

subsection \<open> Additional Expression Laws \<close>

lemma le_pred_refl [simp]:
  fixes x :: "('a::preorder, '\<alpha>) uexpr"
  shows "(x \<le>\<^sub>u x) = true"
  by (pred_auto)

lemma uzero_le_laws [simp]:
  "(0 :: ('a::{linordered_semidom}, '\<alpha>) uexpr) \<le>\<^sub>u numeral x = true"
  "(1 :: ('a::{linordered_semidom}, '\<alpha>) uexpr) \<le>\<^sub>u numeral x = true"
  "(0 :: ('a::{linordered_semidom}, '\<alpha>) uexpr) \<le>\<^sub>u 1 = true"
  by (pred_simp)+

lemma unumeral_le_1 [simp]:
  assumes "(numeral i :: 'a::{numeral,ord}) \<le> numeral j"
  shows "(numeral i :: ('a, '\<alpha>) uexpr) \<le>\<^sub>u numeral j = true"
  using assms by (pred_auto)

lemma unumeral_le_2 [simp]:
  assumes "(numeral i :: 'a::{numeral,linorder}) > numeral j"
  shows "(numeral i :: ('a, '\<alpha>) uexpr) \<le>\<^sub>u numeral j = false"
  using assms by (pred_auto)

lemma uset_laws [simp]:
  "x \<in>\<^sub>u {}\<^sub>u = false"
  "x \<in>\<^sub>u {m..n}\<^sub>u = (m \<le>\<^sub>u x \<and> x \<le>\<^sub>u n)"
  by (pred_auto)+

lemma ulit_eq [simp]: "x = y \<Longrightarrow> (\<guillemotleft>x\<guillemotright> =\<^sub>u \<guillemotleft>y\<guillemotright>) = true"
  by (rel_auto)

lemma ulit_neq [simp]: "x \<noteq> y \<Longrightarrow> (\<guillemotleft>x\<guillemotright> =\<^sub>u \<guillemotleft>y\<guillemotright>) = false"
  by (rel_auto)

lemma uset_mems [simp]:
  "x \<in>\<^sub>u {y}\<^sub>u = (x =\<^sub>u y)"
  "x \<in>\<^sub>u A \<union>\<^sub>u B = (x \<in>\<^sub>u A \<or> x \<in>\<^sub>u B)"
  "x \<in>\<^sub>u A \<inter>\<^sub>u B = (x \<in>\<^sub>u A \<and> x \<in>\<^sub>u B)"
  by (rel_auto)+

subsection \<open> Refinement By Observation \<close>

text \<open> Function to obtain the set of observations of a predicate \<close>

definition obs_upred :: "'\<alpha> upred \<Rightarrow> '\<alpha> set" ("\<lbrakk>_\<rbrakk>\<^sub>o")
where [upred_defs]: "\<lbrakk>P\<rbrakk>\<^sub>o = {b. \<lbrakk>P\<rbrakk>\<^sub>eb}"

lemma obs_upred_refine_iff:
  "P \<sqsubseteq> Q \<longleftrightarrow> \<lbrakk>Q\<rbrakk>\<^sub>o \<subseteq> \<lbrakk>P\<rbrakk>\<^sub>o"
  by (pred_auto)

text \<open> A refinement can be demonstrated by considering only the observations of the predicates
  which are relevant, i.e. not unrestricted, for them. In other words, if the alphabet can
  be split into two disjoint segments, $x$ and $y$, and neither predicate refers to $y$ then
  only $x$ need be considered when checking for observations. \<close>

lemma refine_by_obs:
  assumes "x \<bowtie> y" "bij_lens (x +\<^sub>L y)" "y \<sharp> P" "y \<sharp> Q" "{v. `P\<lbrakk>\<guillemotleft>v\<guillemotright>/x\<rbrakk>`} \<subseteq> {v. `Q\<lbrakk>\<guillemotleft>v\<guillemotright>/x\<rbrakk>`}"
  shows "Q \<sqsubseteq> P"
  using assms(3-5)
  apply (simp add: obs_upred_refine_iff subset_eq)
  apply (pred_simp)
  apply (rename_tac b)
  apply (drule_tac x="get\<^bsub>x\<^esub>b" in spec)
  apply (auto simp add: assms)
   apply (metis assms(1) assms(2) bij_lens.axioms(2) bij_lens_axioms_def lens_override_def lens_override_plus)+
  done

subsection \<open> Cylindric Algebra \<close>

lemma C1: "(\<exists> x \<bullet> false) = false"
  by (pred_auto)

lemma C2: "wb_lens x \<Longrightarrow> `P \<Rightarrow> (\<exists> x \<bullet> P)`"
  by (pred_simp, metis wb_lens.get_put)

lemma C3: "mwb_lens x \<Longrightarrow> (\<exists> x \<bullet> (P \<and> (\<exists> x \<bullet> Q))) = ((\<exists> x \<bullet> P) \<and> (\<exists> x \<bullet> Q))"
  by (pred_auto)

lemma C4a: "x \<approx>\<^sub>L y \<Longrightarrow> (\<exists> x \<bullet> \<exists> y \<bullet> P) = (\<exists> y \<bullet> \<exists> x \<bullet> P)"
  by (pred_simp, metis (no_types, lifting) lens.select_convs(2))+

lemma C4b: "x \<bowtie> y \<Longrightarrow> (\<exists> x \<bullet> \<exists> y \<bullet> P) = (\<exists> y \<bullet> \<exists> x \<bullet> P)"
  using ex_commute by blast

lemma C5:
  fixes x :: "('a \<Longrightarrow> '\<alpha>)"
  shows "(&x =\<^sub>u &x) = true"
  by (pred_auto)

lemma C6:
  assumes "wb_lens x" "x \<bowtie> y" "x \<bowtie> z"
  shows "(&y =\<^sub>u &z) = (\<exists> x \<bullet> &y =\<^sub>u &x \<and> &x =\<^sub>u &z)"
  using assms
  by (pred_simp, (metis lens_indep_def)+)

lemma C7:
  assumes "weak_lens x" "x \<bowtie> y"
  shows "((\<exists> x \<bullet> &x =\<^sub>u &y \<and> P) \<and> (\<exists> x \<bullet> &x =\<^sub>u &y \<and> \<not> P)) = false"
  using assms
  by (pred_simp, simp add: lens_indep_sym)

end