(*<*)theory Axioms imports Overloading "../Setup" begin(*>*)

subsection \<open>Axioms\<close>

text \<open>Attaching axioms to our classes lets us reason on the level of
classes.  The results will be applicable to all types in a class, just
as in axiomatic mathematics.

\begin{warn}
Proofs in this section use structured \emph{Isar} proofs, which are not
covered in this tutorial; but see \<^cite>\<open>"Nipkow-TYPES02"\<close>.%
\end{warn}\<close>

subsubsection \<open>Semigroups\<close>

text\<open>We specify \emph{semigroups} as subclass of \<^class>\<open>plus\<close>:\<close>

class semigroup = plus +
  assumes assoc: "(x \<oplus> y) \<oplus> z = x \<oplus> (y \<oplus> z)"

text \<open>\noindent This @{command class} specification requires that
all instances of \<^class>\<open>semigroup\<close> obey @{fact "assoc:"}~@{prop
[source] "\<And>x y z :: 'a::semigroup. (x \<oplus> y) \<oplus> z = x \<oplus> (y \<oplus> z)"}.

We can use this class axiom to derive further abstract theorems
relative to class \<^class>\<open>semigroup\<close>:\<close>

lemma assoc_left:
  fixes x y z :: "'a::semigroup"
  shows "x \<oplus> (y \<oplus> z) = (x \<oplus> y) \<oplus> z"
  using assoc by (rule sym)

text \<open>\noindent The \<^class>\<open>semigroup\<close> constraint on type \<^typ>\<open>'a\<close> restricts instantiations of \<^typ>\<open>'a\<close> to types of class
\<^class>\<open>semigroup\<close> and during the proof enables us to use the fact
@{fact assoc} whose type parameter is itself constrained to class
\<^class>\<open>semigroup\<close>.  The main advantage of classes is that theorems
can be proved in the abstract and freely reused for each instance.

On instantiation, we have to give a proof that the given operations
obey the class axioms:\<close>

instantiation nat :: semigroup
begin

instance proof

txt \<open>\noindent The proof opens with a default proof step, which for
instance judgements invokes method @{method intro_classes}.\<close>

  fix m n q :: nat
  show "(m \<oplus> n) \<oplus> q = m \<oplus> (n \<oplus> q)"
    by (induct m) simp_all
qed

end

text \<open>\noindent Again, the interesting things enter the stage with
parametric types:\<close>

instantiation prod :: (semigroup, semigroup) semigroup
begin

instance proof
  fix p\<^sub>1 p\<^sub>2 p\<^sub>3 :: "'a::semigroup \<times> 'b::semigroup"
  show "p\<^sub>1 \<oplus> p\<^sub>2 \<oplus> p\<^sub>3 = p\<^sub>1 \<oplus> (p\<^sub>2 \<oplus> p\<^sub>3)"
    by (cases p\<^sub>1, cases p\<^sub>2, cases p\<^sub>3) (simp add: assoc)

txt \<open>\noindent Associativity of product semigroups is established
using the hypothetical associativity @{fact assoc} of the type
components, which holds due to the \<^class>\<open>semigroup\<close> constraints
imposed on the type components by the @{command instance} proposition.
Indeed, this pattern often occurs with parametric types and type
classes.\<close>

qed

end

subsubsection \<open>Monoids\<close>

text \<open>We define a subclass \<open>monoidl\<close> (a semigroup with a
left-hand neutral) by extending \<^class>\<open>semigroup\<close> with one additional
parameter \<open>neutral\<close> together with its property:\<close>

class monoidl = semigroup +
  fixes neutral :: "'a" ("\<zero>")
  assumes neutl: "\<zero> \<oplus> x = x"

text \<open>\noindent Again, we prove some instances, by providing
suitable parameter definitions and proofs for the additional
specifications.\<close>

instantiation nat :: monoidl
begin

definition
  neutral_nat_def: "\<zero> = (0::nat)"

instance proof
  fix n :: nat
  show "\<zero> \<oplus> n = n"
    unfolding neutral_nat_def by simp
qed

end

text \<open>\noindent In contrast to the examples above, we here have both
specification of class operations and a non-trivial instance proof.

This covers products as well:
\<close>

instantiation prod :: (monoidl, monoidl) monoidl
begin

definition
  neutral_prod_def: "\<zero> = (\<zero>, \<zero>)"

instance proof
  fix p :: "'a::monoidl \<times> 'b::monoidl"
  show "\<zero> \<oplus> p = p"
    by (cases p) (simp add: neutral_prod_def neutl)
qed

end

text \<open>\noindent Fully-fledged monoids are modelled by another
subclass which does not add new parameters but tightens the
specification:\<close>

class monoid = monoidl +
  assumes neutr: "x \<oplus> \<zero> = x"

text \<open>\noindent Corresponding instances for \<^typ>\<open>nat\<close> and products
are left as an exercise to the reader.\<close>

subsubsection \<open>Groups\<close>

text \<open>\noindent To finish our small algebra example, we add a \<open>group\<close> class:\<close>

class group = monoidl +
  fixes inv :: "'a \<Rightarrow> 'a" ("\<div> _" [81] 80)
  assumes invl: "\<div> x \<oplus> x = \<zero>"

text \<open>\noindent We continue with a further example for abstract
proofs relative to type classes:\<close>

lemma left_cancel:
  fixes x y z :: "'a::group"
  shows "x \<oplus> y = x \<oplus> z \<longleftrightarrow> y = z"
proof
  assume "x \<oplus> y = x \<oplus> z"
  then have "\<div> x \<oplus> (x \<oplus> y) = \<div> x \<oplus> (x \<oplus> z)" by simp
  then have "(\<div> x \<oplus> x) \<oplus> y = (\<div> x \<oplus> x) \<oplus> z" by (simp add: assoc)
  then show "y = z" by (simp add: invl neutl)
next
  assume "y = z"
  then show "x \<oplus> y = x \<oplus> z" by simp
qed

text \<open>\noindent Any \<open>group\<close> is also a \<open>monoid\<close>; this
can be made explicit by claiming an additional subclass relation,
together with a proof of the logical difference:\<close>

instance group \<subseteq> monoid
proof
  fix x
  from invl have "\<div> x \<oplus> x = \<zero>" .
  then have "\<div> x \<oplus> (x \<oplus> \<zero>) = \<div> x \<oplus> x"
    by (simp add: neutl invl assoc [symmetric])
  then show "x \<oplus> \<zero> = x" by (simp add: left_cancel)
qed

text \<open>\noindent The proof result is propagated to the type system,
making \<open>group\<close> an instance of \<open>monoid\<close> by adding an
additional edge to the graph of subclass relation; see also
Figure~\ref{fig:subclass}.

\begin{figure}[htbp]
 \begin{center}
   \small
   \unitlength 0.6mm
   \begin{picture}(40,60)(0,0)
     \put(20,60){\makebox(0,0){\<open>semigroup\<close>}}
     \put(20,40){\makebox(0,0){\<open>monoidl\<close>}}
     \put(00,20){\makebox(0,0){\<open>monoid\<close>}}
     \put(40,00){\makebox(0,0){\<open>group\<close>}}
     \put(20,55){\vector(0,-1){10}}
     \put(15,35){\vector(-1,-1){10}}
     \put(25,35){\vector(1,-3){10}}
   \end{picture}
   \hspace{8em}
   \begin{picture}(40,60)(0,0)
     \put(20,60){\makebox(0,0){\<open>semigroup\<close>}}
     \put(20,40){\makebox(0,0){\<open>monoidl\<close>}}
     \put(00,20){\makebox(0,0){\<open>monoid\<close>}}
     \put(40,00){\makebox(0,0){\<open>group\<close>}}
     \put(20,55){\vector(0,-1){10}}
     \put(15,35){\vector(-1,-1){10}}
     \put(05,15){\vector(3,-1){30}}
   \end{picture}
   \caption{Subclass relationship of monoids and groups:
      before and after establishing the relationship
      \<open>group \<subseteq> monoid\<close>;  transitive edges are left out.}
   \label{fig:subclass}
 \end{center}
\end{figure}
\<close>

subsubsection \<open>Inconsistencies\<close>

text \<open>The reader may be wondering what happens if we attach an
inconsistent set of axioms to a class. So far we have always avoided
to add new axioms to HOL for fear of inconsistencies and suddenly it
seems that we are throwing all caution to the wind. So why is there no
problem?

The point is that by construction, all type variables in the axioms of
a \isacommand{class} are automatically constrained with the class
being defined (as shown for axiom @{thm[source]refl} above). These
constraints are always carried around and Isabelle takes care that
they are never lost, unless the type variable is instantiated with a
type that has been shown to belong to that class. Thus you may be able
to prove \<^prop>\<open>False\<close> from your axioms, but Isabelle will remind you
that this theorem has the hidden hypothesis that the class is
non-empty.

Even if each individual class is consistent, intersections of
(unrelated) classes readily become inconsistent in practice. Now we
know this need not worry us.\<close>

subsubsection\<open>Syntactic Classes and Predefined Overloading\<close>

text \<open>In our algebra example, we have started with a \emph{syntactic
class} \<^class>\<open>plus\<close> which only specifies operations but no axioms; it
would have been also possible to start immediately with class \<^class>\<open>semigroup\<close>, specifying the \<open>\<oplus>\<close> operation and associativity at
the same time.

Which approach is more appropriate depends.  Usually it is more
convenient to introduce operations and axioms in the same class: then
the type checker will automatically insert the corresponding class
constraints whenever the operations occur, reducing the need of manual
annotations.  However, when operations are decorated with popular
syntax, syntactic classes can be an option to re-use the syntax in
different contexts; this is indeed the way most overloaded constants
in HOL are introduced, of which the most important are listed in
Table~\ref{tab:overloading} in the appendix.  Section
\ref{sec:numeric-classes} covers a range of corresponding classes
\emph{with} axioms.

Further note that classes may contain axioms but \emph{no} operations.
An example is class \<^class>\<open>finite\<close> from theory \<^theory>\<open>HOL.Finite_Set\<close>
which specifies a type to be finite: @{lemma [source] "finite (UNIV :: 'a::finite
set)" by (fact finite_UNIV)}.\<close>

(*<*)end(*>*)


(* author:wzh *)

theory Chapter5
  imports Main

begin
lemma "\<not> surj (f :: 'a \<Rightarrow> 'a set)"
proof
  assume 0: "surj f"
  from 0 have 1: "\<forall> y. \<exists> x. y = f x" by (simp add: surj_def)
  from 1 have 2: "\<exists> a. {x. x \<notin> f x} = f a" by blast
  from 2 show "False" by blast
qed

lemma "\<not> surj (f :: 'a \<Rightarrow> 'a set)"
proof
  assume "surj f"
  from this have "\<exists> a. {x. x \<notin> f x} = f a" by (auto simp: surj_def)
  from this show "False" by blast
qed

lemma "\<not> surj (f :: 'a \<Rightarrow> 'a set)"
proof
  assume "surj f"
  hence "\<exists> a. {x. x \<notin> f x} = f a" by (auto simp: surj_def)
  thus "False" by blast
qed

lemma
  fixes f :: "'a \<Rightarrow> 'a set"
  assumes s: "surj f"
  shows "False"
proof -
  have "\<exists> a. {x. x \<notin> f x} = f a " using s
    by(auto simp: surj_def)
  thus "False" by blast
qed

lemma "\<not> surj (f :: 'a \<Rightarrow> 'a set)"
proof
  assume "surj f"
  hence "\<exists> a. {x. x \<notin> f x} = f a" by(auto simp: surj_def)
  then obtain a where "{x. x \<notin> f x} = f a" by blast
  hence "(a \<notin> f a) = (a \<in> f a)" by blast
  thus "False" by blast
qed

lemma
  fixes a b :: int assumes "b dvd (a+b)" shows "b dvd a"
proof -
  have "\<exists> k'. a = b*k'" if asm: "a+b = b*k" for k
  proof
    show "a = b*(k-1)" using asm by (simp add: algebra_simps)
  qed
  then show ?thesis using assms by (auto simp add: dvd_def)
  qed

value "0 - 1::nat"

lemma "length (tl xs) = length xs - 1"
proof (cases xs)
  case Nil
  thus ?thesis by simp
next
  case (Cons y ys)
  thus ?thesis by simp
qed

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"

lemma "ev n \<Longrightarrow> evn n"
proof(induction rule: ev.induct)
  case ev0
  show ?case by simp
next
  case evSS
  thus ?case by simp
qed

end


theory Simplificacion4
imports Main
begin

subsection{* Distinción de casos *}

text {* Ejemplos de distinción automática de casos con if *}
lemma "P (if A then s else t)
       = ((A \<longrightarrow> P(s)) \<and> (\<not>A \<longrightarrow> P(t)))"
apply simp
done

lemma "(if A then B else False)
       = (A \<and> B)"
apply simp
done

lemma "(if A then B else C)
       = ((A \<longrightarrow> B) \<and> (\<not>A \<longrightarrow> C))"
apply simp
done

text {* Ejemplos de distinción no automática de casos con case *}

lemma "P (case e of 0 \<Rightarrow> a | Suc n \<Rightarrow> b)
       = ((e = 0 \<longrightarrow> P(a)) \<and> (\<forall> n. e = Suc n \<longrightarrow> P(b)))"
apply (simp split: nat.split)
done

lemma "P (case xs of [] \<Rightarrow> a | (y#ys) \<Rightarrow> b)
       = ((xs = [] \<longrightarrow> P a ) \<and> ((\<exists>y ys. xs = y # ys) \<longrightarrow> P b))"
apply (simp split: list.split)
done

lemma "1 \<le> (case ns of [] \<Rightarrow> 1 | n#_ \<Rightarrow> Suc n)"
apply (simp split: list.split)
done

lemma "P (case t of (x,y) \<Rightarrow> f x y)
       = (\<forall> x y. t = (x,y) \<longrightarrow> P (f x y))"
apply (simp split: prod.split)
done

text {* Ejemplos de distinción no automática de casos con let *}

lemma "P (let (x,y) = t in f x y)
       = (\<forall> x y. t = (x,y) \<longrightarrow> P (f x y))"
apply (simp split: prod.split)
done

section {* Simplificación en aritmética lineal *}

text {* Ejemplo de simplificación con las reglas de la aritmética
  lineal. *}
lemma "\<lbrakk> (x::nat) \<le> y+z
       ; z+x < y \<rbrakk>
       \<Longrightarrow> x < y"
apply simp
done

end


theory week06A_demo imports Main begin

\<comment> \<open> ----------------------------------------------------------------\<close>

text \<open>a recursive data type: \<close>
datatype ('a,'b) tree = Tip | Node "('a,'b) tree" 'b "('a,'b) tree"

print_theorems

text \<open> distinctness of constructors automatic: \<close>
lemma "Tip ~= Node l x r" by simp

text \<open> case syntax, case distinction manual \<close>
lemma "(1::nat) \<le> (case t of Tip \<Rightarrow> 1 | Node l x r \<Rightarrow> x+1)"
  apply(case_tac t)
  apply auto
  done

text \<open> partial cases and dummy patterns: \<close>
term "case t of Node _ b _ => b"

text \<open> partial case maps to 'undefined': \<close>
lemma "(case Tip of Node _ _ _ => 0) = undefined" by simp

text \<open> nested case and default pattern: \<close>
term "case t of Node (Node _ _ _) x Tip => 0 | _ => 1"

text \<open> infinitely branching: \<close>
datatype 'a inftree = Tp | Nd 'a "nat \<Rightarrow> 'a inftree"

text \<open> mutually recursive \<close>
datatype
  ty = Integer | Real | RefT ref
  and
  ref = Class | Array ty

\<comment> \<open> ----------------------------------------------------------------\<close>

text \<open> primitive recursion \<close>

primrec
  app :: "'a list => 'a list => 'a list"
where
  "app Nil ys = ys" |
  "app (Cons x xs) ys = Cons x (app xs ys)"

print_theorems

primrec
  rv :: "'a list => 'a list"
where
  "rv [] = []" |
  "rv (x#xs) = app (rv xs) [x]"
print_theorems

text \<open> on trees \<close>
primrec
  mirror :: "('a,'b) tree => ('a,'b) tree"
where
  "mirror Tip = Tip" |
  "mirror (Node l x r) = Node (mirror r) x (mirror l)"

print_theorems

text \<open> mutual recursion \<close>
primrec
  has_int :: "ty \<Rightarrow> bool" and
  has_int_ref :: "ref \<Rightarrow> bool"
where
  "has_int Integer       = True" |
  "has_int Real          = False" |
  "has_int (RefT T)      = has_int_ref T" |

  "has_int_ref Class     = False" |
  "has_int_ref (Array T) = has_int T"

\<comment> \<open> ----------------------------------------------------------------\<close>

text \<open> structural induction \<close>

text \<open> discovering lemmas needed to prove a theorem \<close>

lemma app_nil: "app xs [] = xs"
  apply (induct xs)
   apply auto
  done

lemma app_app: "app (app xs ys ) zs = app xs (app ys zs)"
  apply (induct xs)
   apply auto
  done

lemma rv_app: "rv (app xs ys) = app (rv ys) (rv xs)"
  apply (induct xs arbitrary: ys)
   apply (simp add: app_nil)
  apply (auto simp: app_app)
  done

theorem rv_rv: "rv (rv xs) = xs"
  apply (induct xs)
  apply (auto simp:rv_app)
  done

text \<open> induction heuristics \<close>

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

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

lemma "itrev xs [] = rev xs"
  apply (induct xs)
  apply simp
  apply (clarsimp simp: itrev_rev_app)
  done

\<comment> \<open> ----------------------------------------------------------------\<close>

primrec
  lsum :: "nat list \<Rightarrow> nat"
where
  "lsum [] = 0" |
  "lsum (x#xs) = x + lsum xs"

lemma lsm_app:"lsum (xs @ ys) = lsum xs + lsum ys"
  apply (induct xs arbitrary:ys)
   apply auto
  done

lemma
  "2 * lsum [0 ..< Suc n] = n * (n + 1)"
  apply (induct n)
   apply (auto simp:lsm_app)
  done

lemma
  "lsum (replicate n a) = n * a"
  apply (induct n)
   apply simp_all
  done

text \<open> tail recursive version: \<close>

primrec
  lsumT :: "nat list \<Rightarrow> nat \<Rightarrow> nat"
where
  "lsumT [] s = s" |
  "lsumT (x # xs) s = lsumT xs x+s"

lemma lsum_a:
  "lsumT xs x = x + lsum xs"
  apply (induct xs arbitrary: x)
   apply auto
  done

lemma lsum_correct:
  "lsumT xs 0 = lsum xs"
  apply (auto simp:lsum_a)
  done

end


section \<open>Load Balancing\<close>

theory Approx_LB_Hoare
  imports Complex_Main "HOL-Hoare.Hoare_Logic"
begin

text \<open>This is a formalization of the load balancing algorithms and proofs
in the book by Kleinberg and Tardos \<^cite>\<open>"KleinbergT06"\<close>.\<close>

hide_const (open) sorted

(* TODO: mv *)

lemma sum_le_card_Max: "\<lbrakk> finite A; A \<noteq> {} \<rbrakk> \<Longrightarrow> sum f A \<le> card A * Max (f ` A)"
proof(induction A rule: finite_ne_induct)
  case (singleton x)
  then show ?case by simp
next
  case (insert x F)
  then show ?case by (auto simp: max_def order.trans[of "sum f F" "card F * Max (f ` F)"])
qed

lemma Max_const[simp]: "\<lbrakk> finite A; A \<noteq> {} \<rbrakk> \<Longrightarrow> Max ((\<lambda>_. c) ` A) = c"
using Max_in image_is_empty by blast

abbreviation Max\<^sub>0 :: "nat set \<Rightarrow> nat" where
"Max\<^sub>0 N \<equiv> (if N={} then 0 else Max N)"

fun f_Max\<^sub>0 :: "(nat \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> nat" where
  "f_Max\<^sub>0 f 0 = 0"
| "f_Max\<^sub>0 f (Suc x) = max (f (Suc x)) (f_Max\<^sub>0 f x)"

lemma f_Max\<^sub>0_equiv: "f_Max\<^sub>0 f n = Max\<^sub>0 (f ` {1..n})"
  by (induction n) (auto simp: not_le atLeastAtMostSuc_conv)

lemma f_Max\<^sub>0_correct:
  "\<forall>x \<in> {1..m}. T x \<le> f_Max\<^sub>0 T m"
  "m > 0 \<Longrightarrow> \<exists>x \<in> {1..m}. T x = f_Max\<^sub>0 T m"
   apply (induction m)
     apply simp_all
   apply (metis atLeastAtMost_iff le_Suc_eq max.cobounded1 max.coboundedI2)
  subgoal for m by (cases \<open>m = 0\<close>) (auto simp: max_def)
  done

lemma f_Max\<^sub>0_mono:
  "y \<le> T x \<Longrightarrow> f_Max\<^sub>0 (T (x := y)) m \<le> f_Max\<^sub>0 T m"
  "T x \<le> y \<Longrightarrow> f_Max\<^sub>0 T m \<le> f_Max\<^sub>0 (T (x := y)) m"
  by (induction m) auto

lemma f_Max\<^sub>0_out_of_range [simp]:
  "x \<notin> {1..k} \<Longrightarrow> f_Max\<^sub>0 (T (x := y)) k = f_Max\<^sub>0 T k"
  by (induction k) auto

lemma fun_upd_f_Max\<^sub>0:
  assumes "x \<in> {1..m}" "T x \<le> y"
  shows "f_Max\<^sub>0 (T (x := y)) m = max y (f_Max\<^sub>0 T m)"
  using assms by (induction m) auto

locale LoadBalancing = (* Load Balancing *)
  fixes t :: "nat \<Rightarrow> nat"
    and m :: nat
    and n :: nat
  assumes m_gt_0: "m > 0"
begin

subsection \<open>Formalization of a Correct Load Balancing\<close>

subsubsection \<open>Definition\<close>

definition lb :: "(nat \<Rightarrow> nat) \<Rightarrow> (nat \<Rightarrow> nat set) \<Rightarrow> nat \<Rightarrow> bool" where
  "lb T A j = ((\<forall>x \<in> {1..m}. \<forall>y \<in> {1..m}. x \<noteq> y \<longrightarrow> A x \<inter> A y = {}) \<comment> \<open>No job is assigned to more than one machine\<close>
             \<and> (\<Union>x \<in> {1..m}. A x) = {1..j} \<comment> \<open>Every job is assigned\<close>
             \<and> (\<forall>x \<in> {1..m}. (\<Sum>j \<in> A x. t j) = T x) \<comment> \<open>The processing times sum up to the correct load\<close>)"

abbreviation makespan :: "(nat \<Rightarrow> nat) \<Rightarrow> nat" where
  "makespan T \<equiv> f_Max\<^sub>0 T m"

lemma makespan_def': "makespan T = Max (T ` {1..m})"
  using m_gt_0 by (simp add: f_Max\<^sub>0_equiv)
(*
lemma makespan_correct:
  "\<forall>x \<in> {1..m}. T x \<le> makespan T m"
  "m > 0 \<Longrightarrow> \<exists>x \<in> {1..m}. T x = makespan T m"
   apply (induction m)
     apply simp_all
   apply (metis atLeastAtMost_iff le_Suc_eq max.cobounded1 max.coboundedI2)
  subgoal for m by (cases \<open>m = 0\<close>) (auto simp: max_def)
  done

lemma no_machines_lb_iff_no_jobs: "lb T A j 0 \<longleftrightarrow> j = 0"
  unfolding lb_def by auto

lemma machines_if_jobs: "\<lbrakk> lb T A j m; j > 0 \<rbrakk> \<Longrightarrow> m > 0"
  using no_machines_lb_iff_no_jobs by (cases m) auto
*)

lemma makespan_correct:
  "\<forall>x \<in> {1..m}. T x \<le> makespan T"
  "\<exists>x \<in> {1..m}. T x = makespan T"
  using f_Max\<^sub>0_correct m_gt_0 by auto

lemma lbE:
  assumes "lb T A j"
  shows "\<forall>x \<in> {1..m}. \<forall>y \<in> {1..m}. x \<noteq> y \<longrightarrow> A x \<inter> A y = {}"
        "(\<Union>x \<in> {1..m}. A x) = {1..j}"
        "\<forall>x \<in> {1..m}. (\<Sum>y \<in> A x. t y) = T x"
  using assms unfolding lb_def by blast+

lemma lbI:
  assumes "\<forall>x \<in> {1..m}. \<forall>y \<in> {1..m}. x \<noteq> y \<longrightarrow> A x \<inter> A y = {}"
          "(\<Union>x \<in> {1..m}. A x) = {1..j}"
          "\<forall>x \<in> {1..m}. (\<Sum>y \<in> A x. t y) = T x"
  shows "lb T A j" using assms unfolding lb_def by blast

lemma A_lb_finite [simp]:
  assumes "lb T A j" "x \<in> {1..m}"
  shows "finite (A x)"
  by (metis lbE(2) assms finite_UN finite_atLeastAtMost)

text \<open>If \<open>A x\<close> is pairwise disjoint for all \<open>x \<in> {1..m}\<close>, then the the sum over the sums of the
      individual \<open>A x\<close> is equal to the sum over the union of all \<open>A x\<close>.\<close>
lemma sum_sum_eq_sum_Un:
  fixes A :: "nat \<Rightarrow> nat set"
  assumes "\<forall>x \<in> {1..m}. \<forall>y \<in> {1..m}. x \<noteq> y \<longrightarrow> A x \<inter> A y = {}"
      and "\<forall>x \<in> {1..m}. finite (A x)"
  shows "(\<Sum>x \<in> {1..m}. (\<Sum>y \<in> A x. t y)) = (\<Sum>x \<in> (\<Union>y \<in> {1..m}. A y). t x)"
  using assms
proof (induction m)
  case (Suc m)
  have FINITE: "finite (\<Union>x \<in> {1..m}. A x)" "finite (A (Suc m))"
    using Suc.prems(2) by auto
  have "\<forall>x \<in> {1..m}. A x \<inter> A (Suc m) = {}"
    using Suc.prems(1) by simp
  then have DISJNT: "(\<Union>x \<in> {1..m}. A x) \<inter> (A (Suc m)) = {}" using Union_disjoint by blast
  have "(\<Sum>x \<in> (\<Union>y \<in> {1..m}. A y). t x) + (\<Sum>x \<in> A (Suc m). t x)
      = (\<Sum>x \<in> ((\<Union>y \<in> {1..m}. A y) \<union> A (Suc m)). t x)"
    using sum.union_disjoint[OF FINITE DISJNT, symmetric] .
  also have "... = (\<Sum>x \<in> (\<Union>y \<in> {1..Suc m}. A y). t x)"
    by (metis UN_insert image_Suc_lessThan image_insert inf_sup_aci(5) lessThan_Suc)
  finally show ?case using Suc by auto
qed simp

text \<open>If \<open>T\<close> and \<open>A\<close> are a correct load balancing for \<open>j\<close> jobs and \<open>m\<close> machines,
      then the sum of the loads has to be equal to the sum of the processing times of the jobs\<close>
lemma lb_impl_job_sum:
  assumes "lb T A j"
  shows "(\<Sum>x \<in> {1..m}. T x) = (\<Sum>x \<in> {1..j}. t x)"
proof -
  note lbrules = lbE[OF assms]
  from assms have FINITE: "\<forall>x \<in> {1..m}. finite (A x)" by simp
  have "(\<Sum>x \<in> {1..m}. T x) = (\<Sum>x \<in> {1..m}. (\<Sum>y \<in> A x. t y))"
    using lbrules(3) by simp
  also have "... = (\<Sum>x \<in> {1..j}. t x)"
    using sum_sum_eq_sum_Un[OF lbrules(1) FINITE]
    unfolding lbrules(2) .
  finally show ?thesis .
qed

subsubsection \<open>Lower Bounds for the Makespan\<close>

text \<open>If \<open>T\<close> and \<open>A\<close> are a correct load balancing for \<open>j\<close> jobs and \<open>m\<close> machines, then the processing time
      of any job \<open>x \<in> {1..j}\<close> is a lower bound for the load of some machine \<open>y \<in> {1..m}\<close>\<close>
lemma job_lower_bound_machine:
  assumes "lb T A j" "x \<in> {1..j}"
  shows "\<exists>y \<in> {1..m}. t x \<le> T y"
proof -
  note lbrules = lbE[OF assms(1)]
  have "\<exists>y \<in> {1..m}. x \<in> A y" using lbrules(2) assms(2) by blast
  then obtain y where y_def: "y \<in> {1..m}" "x \<in> A y" ..
  moreover have "finite (A y)" using assms(1) y_def(1) by simp
  ultimately have "t x \<le> (\<Sum>x \<in> A y. t x)" using lbrules(1) member_le_sum by fast
  also have "... = T y" using lbrules(3) y_def(1) by blast
  finally show ?thesis using y_def(1) by blast
qed

text \<open>As the load of any machine is a lower bound for the makespan, the processing time
      of any job \<open>x \<in> {1..j}\<close> has to also be a lower bound for the makespan.
      Follows from @{thm [source] job_lower_bound_machine} and @{thm [source] makespan_correct}.\<close>
lemma job_lower_bound_makespan:
  assumes "lb T A j" "x \<in> {1..j}"
  shows "t x \<le> makespan T"
  by (meson job_lower_bound_machine[OF assms] makespan_correct(1) le_trans)

text \<open>The makespan over \<open>j\<close> jobs is a lower bound for the makespan of any correct load balancing for \<open>j\<close> jobs.\<close>
lemma max_job_lower_bound_makespan:
  assumes "lb T A j"
  shows "Max\<^sub>0 (t ` {1..j}) \<le> makespan T"
  using job_lower_bound_makespan[OF assms] by fastforce

lemma job_dist_lower_bound_makespan:
  assumes "lb T A j"
  shows "(\<Sum>x \<in> {1..j}. t x) / m \<le> makespan T"
proof -
  have "(\<Sum>x \<in> {1..j}. t x) \<le> m * makespan T"
    using assms lb_impl_job_sum[symmetric]
      and sum_le_card_Max[of "{1..m}"] m_gt_0 by (simp add: makespan_def')
  then have "real (\<Sum>x \<in> {1..j}. t x) \<le> real m * real (makespan T)"
    using of_nat_mono by fastforce
  then show ?thesis by (simp add: field_simps m_gt_0)
qed

subsection \<open>The Greedy Approximation Algorithm\<close>

text \<open>This function will perform a linear scan from \<open>k \<in> {1..m}\<close> and return the index of the machine with minimum load assuming \<open>m > 0\<close>\<close>
fun min_arg :: "(nat \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> nat" where
  "min_arg T 0 = 1"
| "min_arg T (Suc x) =
   (let k = min_arg T x
    in if T (Suc x) < T k then (Suc x) else k)"

lemma min_correct:
  "\<forall>x \<in> {1..m}. T (min_arg T m) \<le> T x"
  by (induction m) (auto simp: Let_def le_Suc_eq, force)

lemma min_in_range:
  "k > 0 \<Longrightarrow> (min_arg T k) \<in> {1..k}"
  by (induction k) (auto simp: Let_def, force+)

lemma add_job:
  assumes "lb T A j" "x \<in> {1..m}"
  shows "lb (T (x := T x + t (Suc j))) (A (x := A x \<union> {Suc j})) (Suc j)"
    (is \<open>lb ?T ?A _\<close>)
proof -
  note lbrules = lbE[OF assms(1)]

  \<comment> \<open>Rule 1: @{term ?A} pairwise disjoint\<close>
  have NOTIN: "\<forall>i \<in> {1..m}. Suc j \<notin> A i" using lbrules(2) assms(2) by force
  with lbrules(1) have "\<forall>i \<in> {1..m}. i \<noteq> x \<longrightarrow> A i \<inter> (A x \<union> {Suc j}) = {}"
    using assms(2) by blast
  then have 1: "\<forall>x \<in> {1..m}. \<forall>y \<in> {1..m}. x \<noteq> y \<longrightarrow> ?A x \<inter> ?A y = {}"
    using lbrules(1) by simp

  \<comment> \<open>Rule 2: @{term ?A} contains all jobs\<close>
  have "(\<Union>y \<in> {1..m}. ?A y) = (\<Union>y \<in> {1..m}. A y) \<union> {Suc j}"
    using UNION_fun_upd assms(2) by auto
  also have "... = {1..Suc j}" unfolding lbrules(2) by auto
  finally have 2: "(\<Union>y \<in> {1..m}. ?A y) = {1..Suc j}" .

  \<comment> \<open>Rule 3: @{term ?A} sums to @{term ?T}\<close>
  have "(\<Sum>i \<in> ?A x. t i) = (\<Sum>i \<in> A x \<union> {Suc j}. t i)" by simp
  moreover have "A x \<inter> {Suc j} = {}" using NOTIN assms(2) by blast
  moreover have "finite (A x)" "finite {Suc j}" using assms by simp+
  ultimately have "(\<Sum>i \<in> ?A x. t i) = (\<Sum>i \<in> A x. t i) + (\<Sum>i \<in> {Suc j}. t i)"
    using sum.union_disjoint by simp
  also have "... = T x + t (Suc j)" using lbrules(3) assms(2) by simp
  finally have "(\<Sum>i \<in> ?A x. t i) = ?T x" by simp
  then have 3: "\<forall>i \<in> {1..m}. (\<Sum>j \<in> ?A i. t j) = ?T i"
    using lbrules(3) assms(2) by simp

  from lbI[OF 1 2 3] show ?thesis .
qed

lemma makespan_mono:
  "y \<le> T x \<Longrightarrow> makespan (T (x := y)) \<le> makespan T"
  "T x \<le> y \<Longrightarrow> makespan T \<le> makespan (T (x := y))"
  using f_Max\<^sub>0_mono by auto

lemma smaller_optimum:
  assumes "lb T A (Suc j)"
  shows "\<exists>T' A'. lb T' A' j \<and> makespan T' \<le> makespan T"
proof -
  note lbrules = lbE[OF assms]
  have "\<exists>x \<in> {1..m}. Suc j \<in> A x" using lbrules(2) by auto
  then obtain x where x_def: "x \<in> {1..m}" "Suc j \<in> A x" ..
  let ?T = "T (x := T x - t (Suc j))"
  let ?A = "A (x := A x - {Suc j})"

  \<comment> \<open>Rule 1: @{term ?A} pairwise disjoint\<close>
  from lbrules(1) have "\<forall>i \<in> {1..m}. i \<noteq> x \<longrightarrow> A i \<inter> (A x - {Suc j}) = {}"
    using x_def(1) by blast
  then have 1: "\<forall>x \<in> {1..m}. \<forall>y \<in> {1..m}. x \<noteq> y \<longrightarrow> ?A x \<inter> ?A y = {}"
    using lbrules(1) by auto

  \<comment> \<open>Rule 2: @{term ?A} contains all jobs\<close>
  have NOTIN: "\<forall>i \<in> {1..m}. i \<noteq> x \<longrightarrow> Suc j \<notin> A i" using lbrules(1) x_def by blast
  then have "(\<Union>y \<in> {1..m}. ?A y) = (\<Union>y \<in> {1..m}. A y) - {Suc j}"
    using UNION_fun_upd x_def by auto
  also have "... = {1..j}" unfolding lbrules(2) by auto
  finally have 2: "(\<Union>y \<in> {1..m}. ?A y) = {1..j}" .

  \<comment> \<open>Rule 3: @{term ?A} sums to @{term ?T}\<close>
  have "(\<Sum>i \<in> A x - {Suc j}. t i) = (\<Sum>i \<in> A x. t i) - t (Suc j)"
    by (simp add: sum_diff1_nat x_def(2))
  also have "... = T x - t (Suc j)" using lbrules(3) x_def(1) by simp
  finally have "(\<Sum>i \<in> ?A x. t i) = ?T x" by simp
  then have 3: "\<forall>i \<in> {1..m}. (\<Sum>j \<in> ?A i. t j) = ?T i"
    using lbrules(3) x_def(1) by simp

  \<comment> \<open>@{term makespan} is not larger\<close>
  have "lb ?T ?A j \<and> makespan ?T \<le> makespan T"
    using lbI[OF 1 2 3] makespan_mono(1) by force
  then show ?thesis by blast
qed

text \<open>If the processing time \<open>y\<close> does not contribute to the makespan, we can ignore it.\<close>
lemma remove_small_job:
  assumes "makespan (T (x := T x + y)) \<noteq> T x + y"
  shows   "makespan (T (x := T x + y)) = makespan T"
proof -
  let ?T = "T (x := T x + y)"
  have NOT_X: "makespan ?T \<noteq> ?T x" using assms(1) by simp
  then have "\<exists>i \<in> {1..m}. makespan ?T = ?T i \<and> i \<noteq> x"
    using makespan_correct(2) by metis
  then obtain i where i_def: "i \<in> {1..m}" "makespan ?T = ?T i" "i \<noteq> x" by blast
  then have "?T i = T i" using NOT_X by simp
  moreover from this have "makespan T = T i"
    by (metis i_def(1,2) antisym_conv le_add1 makespan_mono(2) makespan_correct(1))
  ultimately show ?thesis using i_def(2) by simp
qed

lemma greedy_makespan_no_jobs [simp]:
  "makespan (\<lambda>_. 0) = 0"
  using m_gt_0 by (simp add: makespan_def')

lemma min_avg: "m * T (min_arg T m) \<le> (\<Sum>i \<in> {1..m}. T i)"
           (is \<open>_ * ?T \<le> ?S\<close>)
proof -
  have "(\<Sum>_ \<in> {1..m}. ?T) \<le> ?S"
    using sum_mono[of \<open>{1..m}\<close> \<open>\<lambda>_. ?T\<close> T]
      and min_correct by blast
  then show ?thesis by simp
qed

definition inv\<^sub>1 :: "(nat \<Rightarrow> nat) \<Rightarrow> (nat \<Rightarrow> nat set) \<Rightarrow> nat \<Rightarrow> bool" where
  "inv\<^sub>1 T A j = (lb T A j \<and> j \<le> n \<and> (\<forall>T' A'. lb T' A' j \<longrightarrow> makespan T \<le> 2 * makespan T'))"

lemma inv\<^sub>1E:
  assumes "inv\<^sub>1 T A j"
  shows "lb T A j" "j \<le> n"
        "lb T' A' j \<Longrightarrow> makespan T \<le> 2 * makespan T'"
  using assms unfolding inv\<^sub>1_def by blast+

lemma inv\<^sub>1I:
  assumes "lb T A j" "j \<le> n" "\<forall>T' A'. lb T' A' j \<longrightarrow> makespan T \<le> 2 * makespan T'"
  shows "inv\<^sub>1 T A j" using assms unfolding inv\<^sub>1_def by blast

lemma inv\<^sub>1_step:
  assumes "inv\<^sub>1 T A j" "j < n"
  shows "inv\<^sub>1 (T ((min_arg T m) := T (min_arg T m) + t (Suc j)))
              (A ((min_arg T m) := A (min_arg T m) \<union> {Suc j})) (Suc j)"
    (is \<open>inv\<^sub>1 ?T ?A _\<close>)
proof -
  note invrules = inv\<^sub>1E[OF assms(1)]
  \<comment> \<open>Greedy is correct\<close>
  have LB: "lb ?T ?A (Suc j)"
    using add_job[OF invrules(1) min_in_range[OF m_gt_0]] by blast
  \<comment> \<open>Greedy maintains approximation factor\<close>
  have MK: "\<forall>T' A'. lb T' A' (Suc j) \<longrightarrow> makespan ?T \<le> 2 * makespan T'"
  proof rule+
    fix T\<^sub>1 A\<^sub>1 assume "lb T\<^sub>1 A\<^sub>1 (Suc j)"
    from smaller_optimum[OF this]
    obtain T\<^sub>0 A\<^sub>0 where "lb T\<^sub>0 A\<^sub>0 j" "makespan T\<^sub>0 \<le> makespan T\<^sub>1" by blast
    then have IH: "makespan T \<le> 2 * makespan T\<^sub>1"
      using invrules(3) by force
    show "makespan ?T \<le> 2 * makespan T\<^sub>1"
    proof (cases \<open>makespan ?T = T (min_arg T m) + t (Suc j)\<close>)
      case True
      have "m * T (min_arg T m) \<le> (\<Sum>i \<in> {1..m}. T i)" by (rule min_avg)
      also have "... = (\<Sum>i \<in> {1..j}. t i)" by (rule lb_impl_job_sum[OF invrules(1)])
      finally have "real m * T (min_arg T m) \<le> (\<Sum>i \<in> {1..j}. t i)"
        by (auto dest: of_nat_mono)
      with m_gt_0 have "T (min_arg T m) \<le> (\<Sum>i \<in> {1..j}. t i) / m"
        by (simp add: field_simps)
      then have "T (min_arg T m) \<le> makespan T\<^sub>1"
        using job_dist_lower_bound_makespan[OF \<open>lb T\<^sub>0 A\<^sub>0 j\<close>]
          and \<open>makespan T\<^sub>0 \<le> makespan T\<^sub>1\<close> by linarith
      moreover have "t (Suc j) \<le> makespan T\<^sub>1"
        using job_lower_bound_makespan[OF \<open>lb T\<^sub>1 A\<^sub>1 (Suc j)\<close>] by simp
      ultimately show ?thesis unfolding True by simp
    next
      case False show ?thesis using remove_small_job[OF False] IH by simp
    qed
  qed
  from inv\<^sub>1I[OF LB _ MK] show ?thesis using assms(2) by simp
qed

definition sorted :: "nat \<Rightarrow> bool" where
  "sorted j = (\<forall>x \<in> {1..j}. \<forall>y \<in> {1..x}. t x \<le> t y)"

lemma sorted_smaller [simp]: "\<lbrakk> sorted j; j \<ge> j' \<rbrakk> \<Longrightarrow> sorted j'"
  unfolding sorted_def by simp

lemma j_gt_m_pigeonhole:
  assumes "lb T A j" "j > m"
  shows "\<exists>x \<in> {1..j}. \<exists>y \<in> {1..j}. \<exists>z \<in> {1..m}. x \<noteq> y \<and> x \<in> A z \<and> y \<in> A z"
proof -
  have "\<forall>x \<in> {1..j}. \<exists>y \<in> {1..m}. x \<in> A y"
    using lbE(2)[OF assms(1)] by blast
  then have "\<exists>f. \<forall>x \<in> {1..j}. x \<in> A (f x) \<and> f x \<in> {1..m}" by metis
  then obtain f where f_def: "\<forall>x \<in> {1..j}. x \<in> A (f x) \<and> f x \<in> {1..m}" ..
  then have "card (f ` {1..j}) \<le> card {1..m}"
    by (meson card_mono finite_atLeastAtMost image_subset_iff)
  also have "... < card {1..j}" using assms(2) by simp
  finally have "card (f ` {1..j}) < card {1..j}" .
  then have "\<not> inj_on f {1..j}" using pigeonhole by blast
  then have "\<exists>x \<in> {1..j}. \<exists>y \<in> {1..j}. x \<noteq> y \<and> f x = f y"
    unfolding inj_on_def by blast
  then show ?thesis using f_def by metis
qed

text \<open>If \<open>T\<close> and \<open>A\<close> are a correct load balancing for \<open>j\<close> jobs and \<open>m\<close> machines with \<open>j > m\<close>,
      and the jobs are sorted in descending order, then there exists a machine \<open>x \<in> {1..m}\<close>
      whose load is at least twice as large as the processing time of job \<open>j\<close>.\<close>
lemma sorted_job_lower_bound_machine:
  assumes "lb T A j" "j > m" "sorted j"
  shows "\<exists>x \<in> {1..m}. 2 * t j \<le> T x"
proof -
  \<comment> \<open>Step 1: Obtaining the jobs\<close>
  note lbrules = lbE[OF assms(1)]
  obtain j\<^sub>1 j\<^sub>2 x where *:
    "j\<^sub>1 \<in> {1..j}" "j\<^sub>2 \<in> {1..j}" "x \<in> {1..m}" "j\<^sub>1 \<noteq> j\<^sub>2" "j\<^sub>1 \<in> A x" "j\<^sub>2 \<in> A x"
    using j_gt_m_pigeonhole[OF assms(1,2)] by blast

  \<comment> \<open>Step 2: Jobs contained in sum\<close>
  have "finite (A x)" using assms(1) *(3) by simp
  then have SUM: "(\<Sum>i \<in> A x. t i) = t j\<^sub>1 + t j\<^sub>2 + (\<Sum>i \<in> A x - {j\<^sub>1} - {j\<^sub>2}. t i)"
    using *(4-6) by (simp add: sum.remove)

  \<comment> \<open>Step 3: Proof of lower bound\<close>
  have "t j \<le> t j\<^sub>1" "t j \<le> t j\<^sub>2"
    using assms(3) *(1-2) unfolding sorted_def by auto
  then have "2 * t j \<le> t j\<^sub>1 + t j\<^sub>2" by simp
  also have "... \<le> (\<Sum>i \<in> A x. t i)" unfolding SUM by simp
  finally have "2 * t j \<le> T x" using lbrules(3) *(3) by simp
  then show ?thesis using *(3) by blast
qed

text \<open>Reasoning analogous to @{thm [source] job_lower_bound_makespan}.\<close>
lemma sorted_job_lower_bound_makespan:
  assumes "lb T A j" "j > m" "sorted j"
  shows "2 * t j \<le> makespan T"
proof -
  obtain x where x_def: "x \<in> {1..m}" "2 * t j \<le> T x"
    using sorted_job_lower_bound_machine[OF assms] ..
  with makespan_correct(1) have "T x \<le> makespan T" by blast
  with x_def(2) show ?thesis by simp
qed

lemma min_zero:
  assumes "x \<in> {1..k}" "T x = 0"
  shows "T (min_arg T k) = 0"
  using assms(1)
proof (induction k)
  case (Suc k)
  show ?case proof (cases \<open>x = Suc k\<close>)
    case True
    then show ?thesis using assms(2) by (simp add: Let_def)
  next
    case False
    with Suc have "T (min_arg T k) = 0" by simp
    then show ?thesis by simp
  qed
qed simp

lemma min_zero_index:
  assumes "x \<in> {1..k}" "T x = 0"
  shows "min_arg T k \<le> x"
  using assms(1)
proof (induction k)
  case (Suc k)
  show ?case proof (cases \<open>x = Suc k\<close>)
    case True
    then show ?thesis using min_in_range[of "Suc k"] by simp
  next
    case False
    with Suc.prems have "x \<in> {1..k}" by simp
    from min_zero[OF this, of T] assms(2) Suc.IH[OF this]
    show ?thesis by simp
  qed
qed simp

definition inv\<^sub>2 :: "(nat \<Rightarrow> nat) \<Rightarrow> (nat \<Rightarrow> nat set) \<Rightarrow> nat \<Rightarrow> bool" where
  "inv\<^sub>2 T A j = (lb T A j \<and> j \<le> n
                \<and> (\<forall>T' A'. lb T' A' j \<longrightarrow> makespan T \<le> 3 / 2 * makespan T')
                \<and> (\<forall>x > j. T x = 0)
                \<and> (j \<le> m \<longrightarrow> makespan T = Max\<^sub>0 (t ` {1..j})))"

lemma inv\<^sub>2E:
  assumes "inv\<^sub>2 T A j"
  shows "lb T A j" "j \<le> n"
        "lb T' A' j \<Longrightarrow> makespan T \<le> 3 / 2 * makespan T'"
        "\<forall>x > j. T x = 0" "j \<le> m \<Longrightarrow> makespan T = Max\<^sub>0 (t ` {1..j})"
  using assms unfolding inv\<^sub>2_def by blast+

lemma inv\<^sub>2I:
  assumes "lb T A j" "j \<le> n"
          "\<forall>T' A'. lb T' A' j \<longrightarrow> makespan T \<le> 3 / 2 * makespan T'"
          "\<forall>x > j. T x = 0"
          "j \<le> m \<Longrightarrow> makespan T = Max\<^sub>0 (t ` {1..j})"
  shows "inv\<^sub>2 T A j"
  unfolding inv\<^sub>2_def using assms by blast

lemma inv\<^sub>2_step:
  assumes "sorted n" "inv\<^sub>2 T A j" "j < n"
  shows "inv\<^sub>2 (T (min_arg T m := T(min_arg T m) + t(Suc j)))
              (A (min_arg T m := A(min_arg T m) \<union> {Suc j})) (Suc j)"
    (is \<open>inv\<^sub>2 ?T ?A _\<close>)
proof (cases \<open>Suc j > m\<close>)
  case True note invrules = inv\<^sub>2E[OF assms(2)]
  \<comment> \<open>Greedy is correct\<close>
  have LB: "lb ?T ?A (Suc j)"
    using add_job[OF invrules(1) min_in_range[OF m_gt_0]] by blast
  \<comment> \<open>Greedy maintains approximation factor\<close>
  have MK: "\<forall>T' A'. lb T' A' (Suc j) \<longrightarrow> makespan ?T \<le> 3 / 2 * makespan T'"
  proof rule+
    fix T\<^sub>1 A\<^sub>1 assume "lb T\<^sub>1 A\<^sub>1 (Suc j)"
    from smaller_optimum[OF this]
    obtain T\<^sub>0 A\<^sub>0 where "lb T\<^sub>0 A\<^sub>0 j" "makespan T\<^sub>0 \<le> makespan T\<^sub>1" by blast
    then have IH: "makespan T \<le> 3 / 2 * makespan T\<^sub>1"
      using invrules(3) by force
    show "makespan ?T \<le> 3 / 2 * makespan T\<^sub>1"
    proof (cases \<open>makespan ?T = T (min_arg T m) + t (Suc j)\<close>)
      case True
      have "m * T (min_arg T m) \<le> (\<Sum>i \<in> {1..m}. T i)" by (rule min_avg)
      also have "... = (\<Sum>i \<in> {1..j}. t i)" by (rule lb_impl_job_sum[OF invrules(1)])
      finally have "real m * T (min_arg T m) \<le> (\<Sum>i \<in> {1..j}. t i)"
        by (auto dest: of_nat_mono)
      with m_gt_0 have "T (min_arg T m) \<le> (\<Sum>i \<in> {1..j}. t i) / m"
        by (simp add: field_simps)
      then have "T (min_arg T m) \<le> makespan T\<^sub>1"
        using job_dist_lower_bound_makespan[OF \<open>lb T\<^sub>0 A\<^sub>0 j\<close>]
          and \<open>makespan T\<^sub>0 \<le> makespan T\<^sub>1\<close> by linarith
      moreover have "2 * t (Suc j) \<le> makespan T\<^sub>1"
        using sorted_job_lower_bound_makespan[OF \<open>lb T\<^sub>1 A\<^sub>1 (Suc j)\<close> \<open>Suc j > m\<close>]
          and assms(1,3) by simp
      ultimately show ?thesis unfolding True by simp
    next
      case False show ?thesis using remove_small_job[OF False] IH by simp
    qed
  qed
  have "\<forall>x > Suc j. ?T x = 0"
    using invrules(4) min_in_range[OF m_gt_0, of T] True by simp
  with inv\<^sub>2I[OF LB _ MK] show ?thesis using assms(3) True by simp
next
  case False
  then have IN_RANGE: "Suc j \<in> {1..m}" by simp
  note invrules = inv\<^sub>2E[OF assms(2)]
  then have "T (Suc j) = 0" by blast

  \<comment> \<open>Greedy is correct\<close>
  have LB: "lb ?T ?A (Suc j)"
    using add_job[OF invrules(1) min_in_range[OF m_gt_0]] by blast

  \<comment> \<open>Greedy is trivially optimal\<close>
  from IN_RANGE \<open>T (Suc j) = 0\<close> have "min_arg T m \<le> Suc j"
    using min_zero_index by blast
  with invrules(4) have EMPTY: "\<forall>x > Suc j. ?T x = 0" by simp
  from IN_RANGE \<open>T (Suc j) = 0\<close> have "T (min_arg T m) = 0"
    using min_zero by blast
  with fun_upd_f_Max\<^sub>0[OF min_in_range[OF m_gt_0]] invrules(5) False
  have TRIV: "makespan ?T = Max\<^sub>0 (t ` {1..Suc j})" unfolding f_Max\<^sub>0_equiv[symmetric] by simp
  have MK: "\<forall>T' A'. lb T' A' (Suc j) \<longrightarrow> makespan ?T \<le> 3 / 2 * makespan T'"
    by (auto simp: TRIV[folded f_Max\<^sub>0_equiv]
            dest!: max_job_lower_bound_makespan[folded f_Max\<^sub>0_equiv])

  from inv\<^sub>2I[OF LB _ MK EMPTY TRIV] show ?thesis using assms(3) by simp
qed

lemma sorted_greedy_approximation:
"sorted n \<Longrightarrow> VARS T A i j
{True}
T := (\<lambda>_. 0);
A := (\<lambda>_. {});
j := 0;
WHILE j < n INV {inv\<^sub>2 T A j} DO
  i := min_arg T m;
  j := (Suc j);
  A := A (i := A(i) \<union> {j});
  T := T (i := T(i) + t j)
OD
{lb T A n \<and> (\<forall>T' A'. lb T' A' n \<longrightarrow> makespan T \<le> 3 / 2 * makespan T')}"
proof (vcg, goal_cases)
  case (1 T A i j)
  then show ?case by (simp add: lb_def inv\<^sub>2_def)
next
  case (2 T A i j)
  then show ?case using inv\<^sub>2_step by simp
next
  case (3 T A i j)
  then show ?case unfolding inv\<^sub>2_def by force
qed

end (* LoadBalancing *)

end (* Theory *)


(*  Title:      Logical_Relations.thy
    Author:     Peter Gammie
*)

header {* Pitts's method for solving recursive domain predicates *}
(*<*)

theory Logical_Relations
imports
  Basis
begin

(*>*)
text{*

We adopt the general theory of \citet{PittsAM:relpod} for solving
recursive domain predicates. This is based on the idea of
\emph{minimal invariants} that \citet[Def 2]{DBLP:conf/mfps/Pitts93}
ascribes ``essentially to D. Scott''.

Ideally we would like to do the proofs once and use Pitts's
\emph{relational structures}. Unfortunately it seems we need
higher-order polymorphism (type functions) to make this work (but see
\citet{Huffman:MonadTransformers:2012}). Here we develop three
versions, one for each of our applications. The proofs are similar
(but not quite identical) in all cases.

We begin by defining an \emph{admissible} set (aka an \emph{inclusive
predicate}) to be one that contains @{term "\<bottom>"} and is closed under
countable chains:

*}

definition admS :: "'a::pcpo set set" where
  "admS \<equiv> { R :: 'a set. \<bottom> \<in> R \<and> adm (\<lambda>x. x \<in> R) }"

typedef ('a::pcpo) admS = "{ x::'a::pcpo set . x \<in> admS }"
  morphisms unlr mklr unfolding admS_def by fastforce

text{*

These sets form a complete lattice.

*}
(*<*)

lemma admSI [intro]:
  "\<lbrakk> \<bottom> \<in> R; adm (\<lambda>x. x \<in> R) \<rbrakk> \<Longrightarrow> R \<in> admS"
unfolding admS_def by simp

lemma bottom_in_unlr [simp]:
  "\<bottom> \<in> unlr R"
using admS.unlr [of R] by (simp add: admS_def)

lemma adm_unlr [simp]:
  "adm (\<lambda>x. x \<in> unlr R)"
using admS.unlr [of R] by (simp add: admS_def)

lemma adm_cont_unlr [intro, simp]:
  "cont f \<Longrightarrow> adm (\<lambda>x. f x \<in> unlr r)"
by (erule adm_subst) simp

declare admS.mklr_inverse[simp add]

instantiation admS :: (pcpo) order
begin

definition
  "x \<le> y \<equiv> unlr x \<subseteq> unlr y"

definition
  "x < y \<equiv> unlr x \<subset> unlr y"

instance
apply default
apply (auto simp add: less_eq_admS_def less_admS_def admS.unlr_inject)
done

end

lemma mklr_leq [iff]: "\<lbrakk> x \<in> admS; y \<in> admS \<rbrakk> \<Longrightarrow> (mklr x \<le> mklr y) \<longleftrightarrow> (x \<le> y)"
  unfolding less_eq_admS_def by simp

lemma unlr_leq: "(unlr x \<le> unlr y) \<longleftrightarrow> (x \<le> y)"
  unfolding less_eq_admS_def by simp

instantiation admS :: (pcpo) lattice
begin

definition
  "inf f g \<equiv> mklr (unlr f \<inter> unlr g)"

definition
  "sup f g = mklr (unlr f \<union> unlr g)"

lemma unlr_inf: "unlr (inf x y) = unlr x \<inter> unlr y"
  unfolding inf_admS_def by (simp add: admS_def)

lemma unlr_sup: "unlr (sup x y) = unlr x \<union> unlr y"
  unfolding sup_admS_def by (simp add: admS_def)

instance
apply intro_classes
apply (auto simp: less_eq_admS_def unlr_inf unlr_sup)
done

end

instantiation admS :: (pcpo) bounded_lattice
begin

definition
  "bot_admS \<equiv> mklr {\<bottom>}"

lemma unlr_bot[simp]:
  "unlr bot = {\<bottom>}"
  by (simp add: admS_def bot_admS_def)

definition
  "top_admS \<equiv> mklr UNIV"

instance
proof
  fix x :: "'a admS"
  show "bot \<le> x" by (simp add: bot_admS_def less_eq_admS_def admS_def)
next
  fix x :: "'a admS"
  show "x \<le> top" by (simp add: top_admS_def less_eq_admS_def admS_def)
qed

end

instantiation admS :: (pcpo) complete_lattice
begin

definition
  "Inf A \<equiv> mklr (Inf (unlr ` A))"

definition
  "Sup (A::'a admS set) = Inf {y. \<forall>x\<in>A. x \<le> y}"

lemma mklr_Inf: "unlr (Inf A) = Inf (unlr ` A)"
  unfolding Inf_admS_def by (simp add: admS_def)

lemma INT_admS_bot [simp]:
  "(\<Inter>R. unlr R) = {\<bottom>}"
by (auto, metis singletonE unlr_bot)

instance
apply default
apply (auto simp add:
 less_eq_admS_def mklr_Inf Sup_admS_def
 Inf_admS_def bot_admS_def top_admS_def admS_def)
done

end
(*>*)

subsection{* Sets of vectors *}

text{*

The simplest case involves the recursive definition of a set of
vectors over a single domain. This involves taking the fixed point of
a functor where the \emph{positive} (covariant) occurrences of the
recursion variable are separated from the \emph{negative}
(contravariant) ones. (See \S\ref{sec:por} etc. for examples.)

By dually ordering the negative uses of the recursion variable the
functor is made monotonic with respect to the order on the domain
@{typ "'d"}. Here the type constructor @{typ "'a dual"} yields a type
with the same elements as @{typ "'a"} but with the reverse order. The
functions @{term "dual"} and @{term "undual"} mediate the isomorphism.

*}

type_synonym 'd lf_rep = "'d admS dual \<times> 'd admS \<Rightarrow> 'd set"
type_synonym 'd lf = "'d admS dual \<times> 'd admS \<Rightarrow> 'd admS"

text{*

The predicate @{term "eRSV"} encodes our notion of relation.  (This is
Pitts's @{text "e : R \<subset> S"}.) We model a vector as a function from
some index type @{typ "'i"} to the domain @{typ "'d"}. Note that the
minimal invariant is for the domain @{typ "'d"} only.

*}

abbreviation
  eRSV :: "('d::pcpo \<rightarrow> 'd) \<Rightarrow> ('i::type \<Rightarrow> 'd) admS dual \<Rightarrow> ('i \<Rightarrow> 'd) admS \<Rightarrow> bool"
where
  "eRSV e R S \<equiv> \<forall>d \<in> unlr (undual R). (\<lambda>x. e\<cdot>(d x)) \<in> unlr S"

text{*

In general we can also assume that @{term "e"} here is strict, but we
do not need to do so for our examples.

Our locale captures the key ingredients in Pitts's scheme:
\begin{itemize}

\item that the function @{term "\<delta>"} is a minimal invariant;

\item that the functor defining the relation is suitably monotonic; and

\item that the functor is closed with respect to the minimal invariant.

\end{itemize}

*}

locale DomSolV =
  fixes \<delta> :: "('d::pcpo \<rightarrow> 'd) \<rightarrow> 'd \<rightarrow> 'd"
  fixes F :: "('i::type \<Rightarrow> 'd::pcpo) lf"
  assumes min_inv_ID: "fix\<cdot>\<delta> = ID"
  assumes monoF: "mono F"
  assumes eRSV_deltaF:
      "\<And>(e :: 'd \<rightarrow> 'd) (R :: ('i \<Rightarrow> 'd) admS dual) (S :: ('i \<Rightarrow> 'd) admS).
          eRSV e R S \<Longrightarrow> eRSV (\<delta>\<cdot>e) (dual (F (dual S, undual R))) (F (R, S))"
(*<*)
context DomSolV
begin

definition
  sym_lr :: "('i \<Rightarrow> 'd) admS dual \<times> ('i \<Rightarrow> 'd) admS
          \<Rightarrow> ('i \<Rightarrow> 'd) admS dual \<times> ('i \<Rightarrow> 'd) admS"
where
  "sym_lr \<equiv> \<lambda>(rm, rp). (dual (F (dual rp, undual rm)), F (rm, rp))"

lemma sym_lr_mono:
  shows "mono sym_lr"
  unfolding sym_lr_def
  apply (rule monoI)
  using monoF
  apply (simp add: split_def monoD)
  apply (rule monoD[OF monoF])
  apply (simp add: undual_leq fst_mono snd_mono)
  done

abbreviation
  f_lim :: "('i \<Rightarrow> 'd) admS dual \<times> ('i \<Rightarrow> 'd) admS"
where
  "f_lim \<equiv> lfp sym_lr"

definition
  delta_neg :: "('i \<Rightarrow> 'd) admS dual"
where
  "delta_neg = fst f_lim"

definition
  delta_pos :: "('i \<Rightarrow> 'd) admS"
where
  "delta_pos = snd f_lim"

lemma delta:
  "(delta_neg, delta_pos) = f_lim"
  apply (cases f_lim)
  apply (simp add: delta_neg_def delta_pos_def)
  done

lemma delta_neg_sol:
  "delta_neg = dual (F (dual delta_pos, undual delta_neg))"
  apply (simp add: delta_neg_def delta_pos_def sym_lr_def split_def)
  apply (subst lfp_unfold)
   apply (rule monoI)
   apply (auto simp: less_eq_dual_def less_eq_prod_def
              split: split_split
              intro: monoD[OF monoF])
  done

lemma delta_pos_neg_least:
  assumes rm: "rm \<le> F (dual rp, rm)"
  assumes rp: "F (dual rm, rp) \<le> rp"
  shows "delta_neg \<le> dual rm"
    and "delta_pos \<le> rp"
proof -
  from rm rp
  have "(delta_neg, delta_pos) \<le> (dual rm, rp)"
    apply (subst delta)
    apply (rule lfp_lowerbound)
    apply (simp add: sym_lr_def)
    done
  thus "delta_neg \<le> dual rm" and "delta_pos \<le> rp"
    by (simp_all add: undual_leq)
qed

lemma delta_eq:
  "undual delta_neg = delta_pos"
proof(rule antisym)
  show "delta_pos \<le> undual delta_neg"
    apply (rule delta_pos_neg_least(2)[where rm="delta_pos"])
     apply (simp_all add: delta_pos_sol[symmetric])
    by (subst delta_neg_sol, simp)
next
  let ?P = "\<lambda>x. eRSV x (delta_neg) (delta_pos)"
  have "?P (fix\<cdot>\<delta>)"
    apply (rule fix_ind)
      apply simp
     apply (simp add: inst_fun_pcpo[symmetric])
    apply clarsimp
    apply (drule eRSV_deltaF[where R=delta_neg and S=delta_pos])
    apply simp
    apply (subst delta_pos_sol)
    apply (subst (asm) delta_neg_sol)
    apply force
    done
  with min_inv_ID
  show "undual delta_neg \<le> delta_pos"
    by (fastforce simp: unlr_leq[symmetric])
qed
(*>*)
text{*

From these assumptions we can show that there is a unique object that
is a solution to the recursive equation specified by @{term "F"}.

*}

definition "delta \<equiv> delta_pos"

lemma delta_sol: "delta = F (dual delta, delta)"
(*<*)
unfolding delta_def
by (subst delta_eq[symmetric], simp, rule delta_pos_sol)
(*>*)

lemma delta_unique:
  assumes r: "F (dual r, r) = r"
  shows "r = delta"
(*<*)
unfolding delta_def
proof(rule antisym)
  show "delta_pos \<le> r"
    using assms delta_pos_neg_least[where rm=r and rp=r] by simp
next
  have "delta_neg \<le> dual r"
    using assms delta_pos_neg_least[where rm=r and rp=r] by simp
  hence "r \<le> undual delta_neg" by (simp add: less_eq_dual_def)
  thus "r \<le> delta_pos"
    using delta_eq by simp
qed
(*>*)

end

text{*

We use this to show certain functions are not PCF-definable in
\S\ref{sec:pcfdefinability}.

*}

subsection{* Relations between domains and syntax *}

text{*

\label{sec:synlr}

To show computational adequacy (\S\ref{sec:compad}) we need to relate
elements of a domain to their syntactic counterparts. An advantage of
Pitts's technique is that this is straightforward to do.

*}

definition synlr :: "('d::pcpo \<times> 'a::type) set set" where
  "synlr \<equiv> { R :: ('d \<times> 'a) set. \<forall>a. { d. (d, a) \<in> R } \<in> admS }"

typedef ('d::pcpo, 'a::type) synlr = "{ x::('d \<times> 'a) set. x \<in> synlr }"
  morphisms unsynlr mksynlr unfolding synlr_def by fastforce

text{*

An alternative representation (suggested by Brian Huffman) is to
directly use the type @{typ "'a \<Rightarrow> 'b admS"} as this is automatically
a complete lattice. However we end up fighting the automatic methods a
lot.

*}

(*<*)

lemma bottom_in_unsynlr [simp]:
  "(\<bottom>, a) \<in> unsynlr R"
  using synlr.unsynlr [of R] by (simp add: synlr_def admS_def)

lemma adm_unsynlr [simp]:
  "adm (\<lambda>x. (x, a) \<in> unsynlr R)"
  using synlr.unsynlr[of R] by (simp add: synlr_def admS_def)

lemma adm_cont_unsynlr [intro, simp]:
  "cont f \<Longrightarrow> adm (\<lambda>x. (f x, a) \<in> unsynlr r)"
  by (erule adm_subst) simp

declare synlr.mksynlr_inverse[simp add]

text{* Lattice machinery. *}

instantiation synlr :: (pcpo, type) order
begin

definition
  "x \<le> y \<equiv> unsynlr x \<le> unsynlr y"

definition
  "x < y \<equiv> unsynlr x < unsynlr y"

instance
apply default
apply (auto simp add: less_eq_synlr_def less_synlr_def synlr.unsynlr_inject)
done

end

lemma mksynlr_leq [iff]: "\<lbrakk> x \<in> synlr; y \<in> synlr \<rbrakk> \<Longrightarrow> (mksynlr x \<le> mksynlr y) \<longleftrightarrow> (x \<le> y)"
  unfolding less_eq_synlr_def by simp

lemma unsynlr_leq: "(unsynlr x \<le> unsynlr y) \<longleftrightarrow> (x \<le> y)"
  unfolding less_eq_synlr_def by simp

instantiation synlr :: (pcpo, type) lattice
begin

definition
  "inf f g \<equiv> mksynlr (unsynlr f \<inter> unsynlr g)"

definition
  "sup f g = mksynlr (unsynlr f \<union> unsynlr g)"

lemma unsynlr_inf: "unsynlr (inf x y) = unsynlr x \<inter> unsynlr y"
  unfolding inf_synlr_def by (simp add: admS_def synlr_def)

lemma unsynlr_sup: "unsynlr (sup x y) = unsynlr x \<union> unsynlr y"
  unfolding sup_synlr_def by (simp add: admS_def synlr_def)

instance
apply intro_classes
apply (auto simp: less_eq_synlr_def unsynlr_inf unsynlr_sup)
done

end

instantiation synlr :: (pcpo, type) bounded_lattice
begin

definition
  "bot_synlr \<equiv> mksynlr ({\<bottom>} \<times> UNIV)"

lemma unsynlr_bot[simp]:
  "unsynlr bot = {\<bottom>} \<times> UNIV"
  by (simp add: admS_def synlr_def bot_synlr_def)

definition
  "top_synlr \<equiv> mksynlr UNIV"

instance
proof
  fix x :: "('a, 'b) synlr"
  show "bot \<le> x" by (auto simp: bot_synlr_def less_eq_synlr_def admS_def synlr_def)
next
  fix x :: "('a, 'b) synlr"
  show "x \<le> top" by (auto simp: top_synlr_def less_eq_synlr_def admS_def synlr_def)
qed

end

instantiation synlr :: (pcpo, type) complete_lattice
begin

definition
  "Inf A \<equiv> mksynlr (Inf (unsynlr ` A))"

definition
  "Sup (A::('a,'b) synlr set) = Inf {y. \<forall>x\<in>A. x \<le> y}"

lemma mksynlr_Inf: "unsynlr (Inf A) = Inf (unsynlr ` A)"
  unfolding Inf_synlr_def by (simp add: admS_def synlr_def)

lemma INT_synlr_bot [simp]:
  "(\<Inter>R. unsynlr R) = {\<bottom>} \<times> UNIV"
apply auto
apply (drule spec[of _ "mksynlr ({\<bottom>} \<times> UNIV)"])
apply (metis bot_synlr_def mem_Sigma_iff singletonE unsynlr_bot)
done

instance
apply default
apply (auto simp add: less_eq_synlr_def mksynlr_Inf Sup_synlr_def)
apply (auto simp add: Inf_synlr_def bot_synlr_def top_synlr_def)
done

end

(*>*)
text{*

Again we define functors on @{typ "('d, 'a) synlr"}.

*}

type_synonym ('d, 'a) synlf_rep = "('d, 'a) synlr dual \<times> ('d, 'a) synlr \<Rightarrow> ('d \<times> 'a) set"
type_synonym ('d, 'a) synlf = "('d, 'a) synlr dual \<times> ('d, 'a) synlr \<Rightarrow> ('d, 'a) synlr"

text{*

We capture our relations as before. Note we need the inclusion @{term
"e"} to be strict for our example.

*}

abbreviation
  eRSS :: "('d::pcpo \<rightarrow> 'd) \<Rightarrow> ('d, 'a::type) synlr dual \<Rightarrow> ('d, 'a) synlr \<Rightarrow> bool"
where
  "eRSS e R S \<equiv> \<forall>(d, a) \<in> unsynlr (undual R). (e\<cdot>d, a) \<in> unsynlr S"

locale DomSolSyn =
  fixes \<delta> :: "('d::pcpo \<rightarrow> 'd) \<rightarrow> 'd \<rightarrow> 'd"
  fixes F :: "('d::pcpo, 'a::type) synlf"
  assumes min_inv_ID: "fix\<cdot>\<delta> = ID"
  assumes min_inv_strict: "\<And>r. \<delta>\<cdot>r\<cdot>\<bottom> = \<bottom>"
  assumes monoF: "mono F"
  assumes eRS_deltaF:
      "\<And>(e :: 'd \<rightarrow> 'd) (R :: ('d, 'a) synlr dual) (S :: ('d, 'a) synlr).
          \<lbrakk> e\<cdot>\<bottom> = \<bottom>; eRSS e R S \<rbrakk> \<Longrightarrow> eRSS (\<delta>\<cdot>e) (dual (F (dual S, undual R))) (F (R, S))"
(*<*)

context DomSolSyn
begin

definition
  sym_lr :: "('d, 'a) synlr dual \<times> ('d, 'a) synlr
          \<Rightarrow> ('d, 'a) synlr dual \<times> ('d, 'a) synlr"
where
  "sym_lr \<equiv> \<lambda>(rm, rp). (dual (F (dual rp, undual rm)), F (rm, rp))"

lemma sym_lr_mono:
  shows "mono sym_lr"
  unfolding sym_lr_def
  apply (rule monoI)
  using monoF
  apply (simp add: split_def monoD)
  apply (rule monoD[OF monoF])
  apply (simp add: undual_leq fst_mono snd_mono)
  done

abbreviation
  f_lim :: "('d, 'a) synlr dual \<times> ('d, 'a) synlr"
where
  "f_lim \<equiv> lfp sym_lr"

definition
  delta_neg :: "('d, 'a) synlr dual"
where
  "delta_neg = fst f_lim"

definition
  delta_pos :: "('d, 'a) synlr"
where
  "delta_pos = snd f_lim"

lemma delta:
  "(delta_neg, delta_pos) = f_lim"
  apply (cases f_lim)
  apply (simp add: delta_neg_def delta_pos_def)
  done

lemma delta_neg_sol:
  "delta_neg = dual (F (dual delta_pos, undual delta_neg))"
  apply (simp add: delta_neg_def delta_pos_def sym_lr_def split_def)
  apply (subst lfp_unfold)
   apply (rule monoI)
   apply (auto simp: less_eq_dual_def less_eq_prod_def
              split: split_split
              intro: monoD[OF monoF])
  done

lemma delta_pos_sol:
  "delta_pos = F (delta_neg, delta_pos)"
  apply (simp add: delta_neg_def delta_pos_def sym_lr_def split_def)
  apply (subst lfp_unfold)
   apply (rule monoI)
   apply (auto simp: less_eq_dual_def less_eq_prod_def
              split: split_split
              intro: monoD[OF monoF])
  done

lemma delta_pos_neg_least:
  assumes rm: "rm \<le> F (dual rp, rm)"
  assumes rp: "F (dual rm, rp) \<le> rp"
  shows "delta_neg \<le> dual rm"
    and "delta_pos \<le> rp"
proof -
  from rm rp
  have "(delta_neg, delta_pos) \<le> (dual rm, rp)"
    apply (subst delta)
    apply (rule lfp_lowerbound)
    apply (simp add: sym_lr_def)
    done
  thus "delta_neg \<le> dual rm" and "delta_pos \<le> rp"
    by (simp_all add: undual_leq)
qed

lemma delta_eq:
  "undual delta_neg = delta_pos"
proof(rule antisym)
  show "delta_pos \<le> undual delta_neg"
    apply (rule delta_pos_neg_least(2)[where rm="delta_pos"])
     apply (simp_all add: delta_pos_sol[symmetric])
    apply (subst delta_neg_sol) back
    apply simp
    done
next
  let ?P = "\<lambda>x. x\<cdot>\<bottom> = \<bottom> \<and> eRSS x (delta_neg) (delta_pos)"
  have "?P (fix\<cdot>\<delta>)"
    apply (rule fix_ind)
      apply simp
     apply simp
    apply clarsimp
    apply (drule (1) eRS_deltaF[where R=delta_neg and S=delta_pos])
    apply (simp add: min_inv_strict)
    apply (subst delta_pos_sol)
    apply (subst delta_neg_sol)
    apply force
    done
  with min_inv_ID
  show "undual delta_neg \<le> delta_pos"
    by (fastforce simp: unsynlr_leq[symmetric])
qed

definition
  "delta \<equiv> delta_pos"

lemma delta_sol:
  "delta = F (dual delta, delta)"
  unfolding delta_def
  apply (subst delta_eq[symmetric]) back
  apply simp
  apply (rule delta_pos_sol)
  done

lemma delta_unique:
  assumes r: "F (dual r, r) = r"
  shows "r = delta"
unfolding delta_def
proof(rule antisym)
  show "delta_pos \<le> r"
    using assms delta_pos_neg_least[where rm=r and rp=r] by simp
next
  have "delta_neg \<le> dual r"
    using assms delta_pos_neg_least[where rm=r and rp=r] by simp
  hence "r \<le> undual delta_neg" by (simp add: less_eq_dual_def)
  thus "r \<le> delta_pos"
    using delta_eq by simp
qed

end

(*>*)
text{*

Again, from these assumptions we can construct the unique solution to
the recursive equation specified by @{term "F"}.

*}

subsection{* Relations between pairs of domains *}

text{*

Following \citet{DBLP:conf/icalp/Reynolds74} and
\citet{DBLP:journals/tcs/Filinski07}, we want to relate two pairs of
mutually-recursive domains. Each of the pairs represents a (monadic)
computation and value space.

*}

type_synonym ('am, 'bm, 'av, 'bv) lr_pair = "('am \<times> 'bm) admS \<times> ('av \<times> 'bv) admS"

type_synonym ('am, 'bm, 'av, 'bv) lf_pair_rep =
  "('am, 'bm, 'av, 'bv) lr_pair dual \<times> ('am, 'bm, 'av, 'bv) lr_pair \<Rightarrow> (('am \<times> 'bm) set \<times> ('av \<times> 'bv) set)"

type_synonym ('am, 'bm, 'av, 'bv) lf_pair =
  "('am, 'bm, 'av, 'bv) lr_pair dual \<times> ('am, 'bm, 'av, 'bv) lr_pair \<Rightarrow> (('am \<times> 'bm) admS \<times> ('av \<times> 'bv) admS)"

text{*

The inclusions need to be strict to get our example through.

*}

abbreviation
  eRSP :: "(('am::pcpo \<rightarrow> 'am) \<times> ('av::pcpo \<rightarrow> 'av))
       \<Rightarrow> (('bm::pcpo \<rightarrow> 'bm) \<times> ('bv::pcpo \<rightarrow> 'bv))
       \<Rightarrow> (('am \<times> 'bm) admS \<times> ('av \<times> 'bv) admS) dual
       \<Rightarrow> ('am \<times> 'bm) admS \<times> ('av \<times> 'bv) admS
       \<Rightarrow> bool"
where
  "eRSP ea eb R S \<equiv>
     (\<forall>(am, bm) \<in> unlr (fst (undual R)). (fst ea\<cdot>am, fst eb\<cdot>bm) \<in> unlr (fst S))
   \<and> (\<forall>(av, bv) \<in> unlr (snd (undual R)). (snd ea\<cdot>av, snd eb\<cdot>bv) \<in> unlr (snd S))"

locale DomSolP =
  fixes ad :: "(('am::pcpo \<rightarrow> 'am) \<times> ('av::pcpo \<rightarrow> 'av)) \<rightarrow> (('am \<rightarrow> 'am) \<times> ('av \<rightarrow> 'av))"
  fixes bd :: "(('bm::pcpo \<rightarrow> 'bm) \<times> ('bv::pcpo \<rightarrow> 'bv)) \<rightarrow> (('bm \<rightarrow> 'bm) \<times> ('bv \<rightarrow> 'bv))"
  fixes F :: "('am, 'bm, 'av, 'bv) lf_pair"
  assumes monoF: "mono F"
  assumes ad_ID: "fix\<cdot>ad = (ID, ID)"
  assumes bd_ID: "fix\<cdot>bd = (ID, ID)"
  assumes ad_strict: "\<And>r. fst (ad\<cdot>r)\<cdot>\<bottom> = \<bottom>" "\<And>r. snd (ad\<cdot>r)\<cdot>\<bottom> = \<bottom>"
  assumes bd_strict: "\<And>r. fst (bd\<cdot>r)\<cdot>\<bottom> = \<bottom>" "\<And>r. snd (bd\<cdot>r)\<cdot>\<bottom> = \<bottom>"
  assumes eRSP_deltaF:
    "\<lbrakk> eRSP ea eb R S; fst ea\<cdot>\<bottom> = \<bottom>; snd ea\<cdot>\<bottom> = \<bottom>; fst eb\<cdot>\<bottom> = \<bottom>; snd ea\<cdot>\<bottom> = \<bottom> \<rbrakk>
      \<Longrightarrow> eRSP (ad\<cdot>ea) (bd\<cdot>eb) (dual (F (dual S, undual R))) (F (R, S))"
(*<*)

context DomSolP
begin

definition
  sym_lr :: "('am, 'bm, 'av, 'bv) lr_pair dual \<times> ('am, 'bm, 'av, 'bv) lr_pair
          \<Rightarrow> ('am, 'bm, 'av, 'bv) lr_pair dual \<times> ('am, 'bm, 'av, 'bv) lr_pair"
where
  "sym_lr \<equiv> \<lambda>(rm, rp). (dual (F (dual rp, undual rm)), F (rm, rp))"

lemma sym_lr_mono:
  shows "mono sym_lr"
  unfolding sym_lr_def
  apply (rule monoI)
  using monoF
  apply (simp add: split_def monoD)
  apply (rule monoD[OF monoF])
  apply (simp add: undual_leq fst_mono snd_mono)
  done

abbreviation
  f_lim :: "('am, 'bm, 'av, 'bv) lr_pair dual \<times> ('am, 'bm, 'av, 'bv) lr_pair"
where
  "f_lim \<equiv> lfp sym_lr"

definition
  delta_neg :: "('am, 'bm, 'av, 'bv) lr_pair dual"
where
  "delta_neg = fst f_lim"

definition
  delta_pos :: "('am, 'bm, 'av, 'bv) lr_pair"
where
  "delta_pos = snd f_lim"

lemma delta:
  "(delta_neg, delta_pos) = f_lim"
  apply (cases f_lim)
  apply (simp add: delta_neg_def delta_pos_def)
  done

lemma delta_neg_sol:
  "delta_neg = dual (F (dual delta_pos, undual delta_neg))"
  apply (simp add: delta_neg_def delta_pos_def sym_lr_def split_def)
  apply (subst lfp_unfold)
   apply (rule monoI)
   apply (auto simp: less_eq_dual_def
              split: split_split
              intro: monoD[OF monoF])
  done

lemma delta_pos_sol:
  "delta_pos = F (delta_neg, delta_pos)"
  apply (simp add: delta_neg_def delta_pos_def sym_lr_def split_def)
  apply (subst lfp_unfold)
   apply (rule monoI)
   apply (auto simp: less_eq_dual_def
              split: split_split
              intro: monoD[OF monoF])
  done

lemma delta_pos_neg_least:
  assumes rm: "rm \<le> F (dual rp, rm)"
  assumes rp: "F (dual rm, rp) \<le> rp"
  shows "delta_neg \<le> dual rm"
    and "delta_pos \<le> rp"
proof -
  from rm rp
  have "(delta_neg, delta_pos) \<le> (dual rm, rp)"
    apply (subst delta)
    apply (rule lfp_lowerbound)
    apply (simp add: sym_lr_def)
    done
  thus "delta_neg \<le> dual rm" and "delta_pos \<le> rp"
    by (simp_all add: undual_leq)
qed

lemma delta_eq:
  "undual delta_neg = delta_pos"
proof(rule antisym)
  show "delta_pos \<le> undual delta_neg"
    apply (rule delta_pos_neg_least(2)[where rm="delta_pos"])
     apply (simp_all add: delta_pos_sol[symmetric])
    apply (subst delta_neg_sol) back
    apply simp
    done
next
  let ?P = "\<lambda>(ea, eb). eRSP ea eb (delta_neg) (delta_pos) \<and> fst ea\<cdot>\<bottom> = \<bottom> \<and> snd ea\<cdot>\<bottom> = \<bottom> \<and> fst eb\<cdot>\<bottom> = \<bottom> \<and> snd eb\<cdot>\<bottom> = \<bottom>"
  have "?P (fix\<cdot>ad, fix\<cdot>bd)"
    apply (rule parallel_fix_ind)
      apply simp
     apply simp
    using ad_strict bd_strict
    apply clarsimp
    apply (cut_tac ea="(a, b)" and eb="(aa, ba)" in eRSP_deltaF[where R=delta_neg and S=delta_pos])
    apply simp_all
    apply (simp add: delta_pos_sol[symmetric])
    apply (subst delta_neg_sol)
    apply simp
    apply (subst delta_neg_sol)
    apply simp
    done
  hence "?P ((ID, ID), (ID, ID))" by (simp only: ad_ID bd_ID)
  thus "undual delta_neg \<le> delta_pos"
    by (fastforce simp: unlr_leq[symmetric] less_eq_prod_def)
qed

definition
  "delta \<equiv> delta_pos"

lemma delta_sol:
  "delta = F (dual delta, delta)"
  unfolding delta_def
  apply (subst delta_eq[symmetric]) back
  apply simp
  apply (rule delta_pos_sol)
  done

lemma delta_unique:
  assumes r: "F (dual r, r) = r"
  shows "r = delta"
unfolding delta_def
proof(rule antisym)
  show "delta_pos \<le> r"
    using assms delta_pos_neg_least[where rm=r and rp=r] by simp
next
  have "delta_neg \<le> dual r"
    using assms delta_pos_neg_least[where rm=r and rp=r] by simp
  hence "r \<le> undual delta_neg" by (simp add: less_eq_dual_def)
  thus "r \<le> delta_pos"
    using delta_eq by simp
qed

end
(*>*)

text{*

We use this solution to relate the direct and continuation semantics
for PCF in \S\ref{sec:continuations}.

*}
(*<*)

end
(*>*)


(*  Title:      HOL/Nonstandard_Analysis/HLog.thy
    Author:     Jacques D. Fleuriot
    Copyright:  2000, 2001 University of Edinburgh
*)

section \<open>Logarithms: Non-Standard Version\<close>

theory HLog
  imports HTranscendental
begin

definition powhr :: "hypreal \<Rightarrow> hypreal \<Rightarrow> hypreal"  (infixr "powhr" 80)
  where [transfer_unfold]: "x powhr a = starfun2 (powr) x a"

definition hlog :: "hypreal \<Rightarrow> hypreal \<Rightarrow> hypreal"
  where [transfer_unfold]: "hlog a x = starfun2 log a x"

lemma powhr: "(star_n X) powhr (star_n Y) = star_n (\<lambda>n. (X n) powr (Y n))"
  by (simp add: powhr_def starfun2_star_n)

lemma powhr_one_eq_one [simp]: "\<And>a. 1 powhr a = 1"
  by transfer simp

lemma powhr_mult: "\<And>a x y. 0 < x \<Longrightarrow> 0 < y \<Longrightarrow> (x * y) powhr a = (x powhr a) * (y powhr a)"
  by transfer (simp add: powr_mult)

lemma powhr_gt_zero [simp]: "\<And>a x. 0 < x powhr a \<longleftrightarrow> x \<noteq> 0"
  by transfer simp

lemma powhr_not_zero [simp]: "\<And>a x. x powhr a \<noteq> 0 \<longleftrightarrow> x \<noteq> 0"
  by transfer simp

lemma powhr_divide: "\<And>a x y. 0 \<le> x \<Longrightarrow> 0 \<le> y \<Longrightarrow> (x / y) powhr a = (x powhr a) / (y powhr a)"
  by transfer (rule powr_divide)

lemma powhr_add: "\<And>a b x. x powhr (a + b) = (x powhr a) * (x powhr b)"
  by transfer (rule powr_add)

lemma powhr_powhr: "\<And>a b x. (x powhr a) powhr b = x powhr (a * b)"
  by transfer (rule powr_powr)

lemma powhr_powhr_swap: "\<And>a b x. (x powhr a) powhr b = (x powhr b) powhr a"
  by transfer (rule powr_powr_swap)

lemma powhr_minus: "\<And>a x. x powhr (- a) = inverse (x powhr a)"
  by transfer (rule powr_minus)

lemma powhr_minus_divide: "x powhr (- a) = 1 / (x powhr a)"
  by (simp add: divide_inverse powhr_minus)

lemma powhr_less_mono: "\<And>a b x. a < b \<Longrightarrow> 1 < x \<Longrightarrow> x powhr a < x powhr b"
  by transfer simp

lemma powhr_less_cancel: "\<And>a b x. x powhr a < x powhr b \<Longrightarrow> 1 < x \<Longrightarrow> a < b"
  by transfer simp

lemma powhr_less_cancel_iff [simp]: "1 < x \<Longrightarrow> x powhr a < x powhr b \<longleftrightarrow> a < b"
  by (blast intro: powhr_less_cancel powhr_less_mono)

lemma powhr_le_cancel_iff [simp]: "1 < x \<Longrightarrow> x powhr a \<le> x powhr b \<longleftrightarrow> a \<le> b"
  by (simp add: linorder_not_less [symmetric])

lemma hlog: "hlog (star_n X) (star_n Y) = star_n (\<lambda>n. log (X n) (Y n))"
  by (simp add: hlog_def starfun2_star_n)

lemma hlog_starfun_ln: "\<And>x. ( *f* ln) x = hlog (( *f* exp) 1) x"
  by transfer (rule log_ln)

lemma powhr_hlog_cancel [simp]: "\<And>a x. 0 < a \<Longrightarrow> a \<noteq> 1 \<Longrightarrow> 0 < x \<Longrightarrow> a powhr (hlog a x) = x"
  by transfer simp

lemma hlog_powhr_cancel [simp]: "\<And>a y. 0 < a \<Longrightarrow> a \<noteq> 1 \<Longrightarrow> hlog a (a powhr y) = y"
  by transfer simp

lemma hlog_mult:
  "\<And>a x y. 0 < a \<Longrightarrow> a \<noteq> 1 \<Longrightarrow> 0 < x \<Longrightarrow> 0 < y \<Longrightarrow> hlog a (x * y) = hlog a x + hlog a y"
  by transfer (rule log_mult)

lemma hlog_as_starfun: "\<And>a x. 0 < a \<Longrightarrow> a \<noteq> 1 \<Longrightarrow> hlog a x = ( *f* ln) x / ( *f* ln) a"
  by transfer (simp add: log_def)

lemma hlog_eq_div_starfun_ln_mult_hlog:
  "\<And>a b x. 0 < a \<Longrightarrow> a \<noteq> 1 \<Longrightarrow> 0 < b \<Longrightarrow> b \<noteq> 1 \<Longrightarrow> 0 < x \<Longrightarrow>
    hlog a x = (( *f* ln) b / ( *f* ln) a) * hlog b x"
  by transfer (rule log_eq_div_ln_mult_log)

lemma powhr_as_starfun: "\<And>a x. x powhr a = (if x = 0 then 0 else ( *f* exp) (a * ( *f* real_ln) x))"
  by transfer (simp add: powr_def)

lemma HInfinite_powhr:
  "x \<in> HInfinite \<Longrightarrow> 0 < x \<Longrightarrow> a \<in> HFinite - Infinitesimal \<Longrightarrow> 0 < a \<Longrightarrow> x powhr a \<in> HInfinite"
  by (auto intro!: starfun_ln_ge_zero starfun_ln_HInfinite
        HInfinite_HFinite_not_Infinitesimal_mult2 starfun_exp_HInfinite
      simp add: order_less_imp_le HInfinite_gt_zero_gt_one powhr_as_starfun zero_le_mult_iff)

lemma hlog_hrabs_HInfinite_Infinitesimal:
  "x \<in> HFinite - Infinitesimal \<Longrightarrow> a \<in> HInfinite \<Longrightarrow> 0 < a \<Longrightarrow> hlog a \<bar>x\<bar> \<in> Infinitesimal"
  apply (frule HInfinite_gt_zero_gt_one)
   apply (auto intro!: starfun_ln_HFinite_not_Infinitesimal
      HInfinite_inverse_Infinitesimal Infinitesimal_HFinite_mult2
      simp add: starfun_ln_HInfinite not_Infinitesimal_not_zero
      hlog_as_starfun divide_inverse)
  done

lemma hlog_HInfinite_as_starfun: "a \<in> HInfinite \<Longrightarrow> 0 < a \<Longrightarrow> hlog a x = ( *f* ln) x / ( *f* ln) a"
  by (rule hlog_as_starfun) auto

lemma hlog_one [simp]: "\<And>a. hlog a 1 = 0"
  by transfer simp

lemma hlog_eq_one [simp]: "\<And>a. 0 < a \<Longrightarrow> a \<noteq> 1 \<Longrightarrow> hlog a a = 1"
  by transfer (rule log_eq_one)

lemma hlog_inverse: "0 < a \<Longrightarrow> a \<noteq> 1 \<Longrightarrow> 0 < x \<Longrightarrow> hlog a (inverse x) = - hlog a x"
  by (rule add_left_cancel [of "hlog a x", THEN iffD1]) (simp add: hlog_mult [symmetric])

lemma hlog_divide: "0 < a \<Longrightarrow> a \<noteq> 1 \<Longrightarrow> 0 < x \<Longrightarrow> 0 < y \<Longrightarrow> hlog a (x / y) = hlog a x - hlog a y"
  by (simp add: hlog_mult hlog_inverse divide_inverse)

lemma hlog_less_cancel_iff [simp]:
  "\<And>a x y. 1 < a \<Longrightarrow> 0 < x \<Longrightarrow> 0 < y \<Longrightarrow> hlog a x < hlog a y \<longleftrightarrow> x < y"
  by transfer simp

lemma hlog_le_cancel_iff [simp]: "1 < a \<Longrightarrow> 0 < x \<Longrightarrow> 0 < y \<Longrightarrow> hlog a x \<le> hlog a y \<longleftrightarrow> x \<le> y"
  by (simp add: linorder_not_less [symmetric])

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_sort_nat_BubSortPermutes
  imports "../../Test_Base"
begin

datatype ('a, 'b) pair = pair2 "'a" "'b"

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun le :: "Nat => Nat => bool" where
  "le (Z) y = True"
| "le (S z) (Z) = False"
| "le (S z) (S x2) = le z x2"

fun elem :: "'a => 'a list => bool" where
  "elem x (nil2) = False"
| "elem x (cons2 z xs) = ((z = x) | (elem x xs))"

fun deleteBy :: "('a => ('a => bool)) => 'a => 'a list =>
                 'a list" where
  "deleteBy x y (nil2) = nil2"
| "deleteBy x y (cons2 y2 ys) =
     (if (x y) y2 then ys else cons2 y2 (deleteBy x y ys))"

fun isPermutation :: "'a list => 'a list => bool" where
  "isPermutation (nil2) (nil2) = True"
| "isPermutation (nil2) (cons2 z x2) = False"
| "isPermutation (cons2 x3 xs) y =
     ((elem x3 y) &
        (isPermutation
           xs (deleteBy (% (x4 :: 'a) => % (x5 :: 'a) => (x4 = x5)) x3 y)))"

fun bubble :: "Nat list => (bool, (Nat list)) pair" where
  "bubble (nil2) = pair2 False (nil2)"
| "bubble (cons2 y (nil2)) = pair2 False (cons2 y (nil2))"
| "bubble (cons2 y (cons2 y2 xs)) =
     (if le y y2 then
        (case bubble (cons2 y2 xs) of
           pair2 b22 ys22 => pair2 b22 (cons2 y ys22))
        else
        (case bubble (cons2 y xs) of
           pair2 b2 ys2 => pair2 True (cons2 y2 ys2)))"

(*fun did not finish the proof*)
function bubsort :: "Nat list => Nat list" where
  "bubsort x =
   (case bubble x of pair2 b1 ys => (if b1 then bubsort ys else x))"
  by pat_completeness auto

theorem property0 :
  "isPermutation (bubsort xs) xs"
  oops

end


section \<open>Lens Instances\<close>

theory Lens_Instances
  imports Lens_Order Lens_Symmetric "HOL-Eisbach.Eisbach"
  keywords "alphabet" "statespace" :: "thy_defn"
begin

text \<open>In this section we define a number of concrete instantiations of the lens locales, including
  functions lenses, list lenses, and record lenses.\<close>

subsection \<open>Function Lens\<close>

text \<open>A function lens views the valuation associated with a particular domain element @{typ "'a"}.
      We require that range type of a lens function has cardinality of at least 2; this ensures
      that properties of independence are provable.\<close>

definition fun_lens :: "'a \<Rightarrow> ('b::two \<Longrightarrow> ('a \<Rightarrow> 'b))" where
[lens_defs]: "fun_lens x = \<lparr> lens_get = (\<lambda> f. f x), lens_put = (\<lambda> f u. f(x := u)) \<rparr>"

lemma fun_vwb_lens: "vwb_lens (fun_lens x)"
  by (unfold_locales, simp_all add: fun_lens_def)

text \<open>Two function lenses are independent if and only if the domain elements are different.\<close>

lemma fun_lens_indep:
  "fun_lens x \<bowtie> fun_lens y \<longleftrightarrow> x \<noteq> y"
proof -
  obtain u v :: "'a::two" where "u \<noteq> v"
    using two_diff by auto
  thus ?thesis
    by (auto simp add: fun_lens_def lens_indep_def)
qed

subsection \<open>Function Range Lens\<close>

text \<open>The function range lens allows us to focus on a particular region of a function's range.\<close>

definition fun_ran_lens :: "('c \<Longrightarrow> 'b) \<Rightarrow> (('a \<Rightarrow> 'b) \<Longrightarrow> '\<alpha>) \<Rightarrow> (('a \<Rightarrow> 'c) \<Longrightarrow> '\<alpha>)" where
[lens_defs]: "fun_ran_lens X Y = \<lparr> lens_get = \<lambda> s. get\<^bsub>X\<^esub> \<circ> get\<^bsub>Y\<^esub> s
                                 , lens_put = \<lambda> s v. put\<^bsub>Y\<^esub> s (\<lambda> x::'a. put\<^bsub>X\<^esub> (get\<^bsub>Y\<^esub> s x) (v x)) \<rparr>"

lemma fun_ran_mwb_lens: "\<lbrakk> mwb_lens X; mwb_lens Y \<rbrakk> \<Longrightarrow> mwb_lens (fun_ran_lens X Y)"
  by (unfold_locales, auto simp add: fun_ran_lens_def)

lemma fun_ran_wb_lens: "\<lbrakk> wb_lens X; wb_lens Y \<rbrakk> \<Longrightarrow> wb_lens (fun_ran_lens X Y)"
  by (unfold_locales, auto simp add: fun_ran_lens_def)

lemma fun_ran_vwb_lens: "\<lbrakk> vwb_lens X; vwb_lens Y \<rbrakk> \<Longrightarrow> vwb_lens (fun_ran_lens X Y)"
  by (unfold_locales, auto simp add: fun_ran_lens_def)

subsection \<open>Map Lens\<close>

text \<open>The map lens allows us to focus on a particular region of a partial function's range. It
  is only a mainly well-behaved lens because it does not satisfy the PutGet law when the view
  is not in the domain.\<close>

definition map_lens :: "'a \<Rightarrow> ('b \<Longrightarrow> ('a \<rightharpoonup> 'b))" where
[lens_defs]: "map_lens x = \<lparr> lens_get = (\<lambda> f. the (f x)), lens_put = (\<lambda> f u. f(x \<mapsto> u)) \<rparr>"

lemma map_mwb_lens: "mwb_lens (map_lens x)"
  by (unfold_locales, simp_all add: map_lens_def)

lemma source_map_lens: "\<S>\<^bsub>map_lens x\<^esub> = {f. x \<in> dom(f)}"
  by (force simp add: map_lens_def lens_source_def)

subsection \<open>List Lens\<close>

text \<open>The list lens allows us to view a particular element of a list. In order to show it is mainly
  well-behaved we need to define to additional list functions. The following function adds
  a number undefined elements to the end of a list.\<close>

definition list_pad_out :: "'a list \<Rightarrow> nat \<Rightarrow> 'a list" where
"list_pad_out xs k = xs @ replicate (k + 1 - length xs) undefined"

text \<open>The following function is like @{term "list_update"} but it adds additional elements to the
  list if the list isn't long enough first.\<close>

definition list_augment :: "'a list \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a list" where
"list_augment xs k v = (list_pad_out xs k)[k := v]"

text \<open>The following function is like @{term nth} but it expressly returns @{term undefined} when
  the list isn't long enough.\<close>

definition nth' :: "'a list \<Rightarrow> nat \<Rightarrow> 'a" where
"nth' xs i = (if (length xs > i) then xs ! i else undefined)"

text \<open>We can prove some additional laws about list update and append.\<close>

lemma list_update_append_lemma1: "i < length xs \<Longrightarrow> xs[i := v] @ ys = (xs @ ys)[i := v]"
  by (simp add: list_update_append)

lemma list_update_append_lemma2: "i < length ys \<Longrightarrow> xs @ ys[i := v] = (xs @ ys)[i + length xs := v]"
  by (simp add: list_update_append)

text \<open>We can also prove some laws about our new operators.\<close>

lemma nth'_0 [simp]: "nth' (x # xs) 0 = x"
  by (simp add: nth'_def)

lemma nth'_Suc [simp]: "nth' (x # xs) (Suc n) = nth' xs n"
  by (simp add: nth'_def)

lemma list_augment_0 [simp]:
  "list_augment (x # xs) 0 y = y # xs"
  by (simp add: list_augment_def list_pad_out_def)

lemma list_augment_Suc [simp]:
  "list_augment (x # xs) (Suc n) y = x # list_augment xs n y"
  by (simp add: list_augment_def list_pad_out_def)

lemma list_augment_twice:
  "list_augment (list_augment xs i u) j v = (list_pad_out xs (max i j))[i:=u, j:=v]"
  apply (auto simp add: list_augment_def list_pad_out_def list_update_append_lemma1 replicate_add[THEN sym] max_def)
  apply (metis Suc_le_mono add.commute diff_diff_add diff_le_mono le_add_diff_inverse2)
done

lemma list_augment_last [simp]:
  "list_augment (xs @ [y]) (length xs) z = xs @ [z]"
  by (induct xs, simp_all)

lemma list_augment_idem [simp]:
  "i < length xs \<Longrightarrow> list_augment xs i (xs ! i) = xs"
  by (simp add: list_augment_def list_pad_out_def)

text \<open>We can now prove that @{term list_augment} is commutative for different (arbitrary) indices.\<close>

lemma list_augment_commute:
  "i \<noteq> j \<Longrightarrow> list_augment (list_augment \<sigma> j v) i u = list_augment (list_augment \<sigma> i u) j v"
  by (simp add: list_augment_twice list_update_swap max.commute)

text \<open>We can also prove that we can always retrieve an element we have added to the list, since
  @{term list_augment} extends the list when necessary. This isn't true of @{term list_update}. \<close>

lemma nth_list_augment: "list_augment xs k v ! k = v"
  by (simp add: list_augment_def list_pad_out_def)

lemma nth'_list_augment: "nth' (list_augment xs k v) k = v"
  by (auto simp add: nth'_def nth_list_augment list_augment_def list_pad_out_def)

text \<open> The length is expanded if not already long enough, or otherwise left as it is. \<close>

lemma length_list_augment_1: "k \<ge> length xs \<Longrightarrow> length (list_augment xs k v) = Suc k"
  by (simp add: list_augment_def list_pad_out_def)

lemma length_list_augment_2: "k < length xs \<Longrightarrow> length (list_augment xs k v) = length xs"
  by (simp add: list_augment_def list_pad_out_def)

text \<open>We also have it that @{term list_augment} cancels itself.\<close>

lemma list_augment_same_twice: "list_augment (list_augment xs k u) k v = list_augment xs k v"
  by (simp add: list_augment_def list_pad_out_def)

lemma nth'_list_augment_diff: "i \<noteq> j \<Longrightarrow> nth' (list_augment \<sigma> i v) j = nth' \<sigma> j"
  by (auto simp add: list_augment_def list_pad_out_def nth_append nth'_def)

text \<open>Finally we can create the list lenses, of which there are three varieties. One that allows
  us to view an index, one that allows us to view the head, and one that allows us to view the tail.
  They are all mainly well-behaved lenses.\<close>

definition list_lens :: "nat \<Rightarrow> ('a::two \<Longrightarrow> 'a list)" where
[lens_defs]: "list_lens i = \<lparr> lens_get = (\<lambda> xs. nth' xs i)
                            , lens_put = (\<lambda> xs x. list_augment xs i x) \<rparr>"

abbreviation hd_lens ("hd\<^sub>L") where "hd_lens \<equiv> list_lens 0"

definition tl_lens :: "'a list \<Longrightarrow> 'a list" ("tl\<^sub>L") where
[lens_defs]: "tl_lens = \<lparr> lens_get = (\<lambda> xs. tl xs)
                        , lens_put = (\<lambda> xs xs'. hd xs # xs') \<rparr>"

lemma list_mwb_lens: "mwb_lens (list_lens x)"
  by (unfold_locales, simp_all add: list_lens_def nth'_list_augment list_augment_same_twice)

text \<open> The set of constructible sources is precisely those where the length is greater than the
  given index. \<close>

lemma source_list_lens: "\<S>\<^bsub>list_lens i\<^esub> = {xs. length xs > i}"
  apply (auto simp add: lens_source_def list_lens_def)
   apply (metis length_list_augment_1 length_list_augment_2 lessI not_less)
  apply (metis list_augment_idem)
  done

lemma tail_lens_mwb:
  "mwb_lens tl\<^sub>L"
  by (unfold_locales, simp_all add: tl_lens_def)

lemma source_tail_lens: "\<S>\<^bsub>tl\<^sub>L\<^esub> = {xs. xs \<noteq> []}"
  using list.exhaust_sel by (auto simp add: tl_lens_def lens_source_def)

text \<open>Independence of list lenses follows when the two indices are different.\<close>

lemma list_lens_indep:
  "i \<noteq> j \<Longrightarrow> list_lens i \<bowtie> list_lens j"
  by (simp add: list_lens_def lens_indep_def list_augment_commute nth'_list_augment_diff)

lemma hd_tl_lens_indep [simp]:
  "hd\<^sub>L \<bowtie> tl\<^sub>L"
  apply (rule lens_indepI)
    apply (simp_all add: list_lens_def tl_lens_def)
    apply (metis hd_conv_nth hd_def length_greater_0_conv list.case(1) nth'_def nth'_list_augment)
   apply (metis (full_types) hd_conv_nth hd_def length_greater_0_conv list.case(1) nth'_def)
  apply (metis One_nat_def diff_Suc_Suc diff_zero length_0_conv length_list_augment_1 length_tl linorder_not_less list.exhaust list.sel(2) list.sel(3) list_augment_0 not_less_zero)
done

lemma hd_tl_lens_pbij: "pbij_lens (hd\<^sub>L +\<^sub>L tl\<^sub>L)"
  by (unfold_locales, auto simp add: lens_defs)

subsection \<open>Record Field Lenses\<close>

text \<open>We also add support for record lenses. Every record created can yield a lens for each field.
  These cannot be created generically and thus must be defined case by case as new records are
  created. We thus create a new Isabelle outer syntax command \textbf{alphabet} which enables this.
  We first create syntax that allows us to obtain a lens from a given field using the internal
  record syntax translations.\<close>

abbreviation (input) "fld_put f \<equiv> (\<lambda> \<sigma> u. f (\<lambda>_. u) \<sigma>)"

syntax
  "_FLDLENS" :: "id \<Rightarrow> logic"  ("FLDLENS _")
translations
  "FLDLENS x" => "\<lparr> lens_get = x, lens_put = CONST fld_put (_update_name x) \<rparr>"

text \<open> We also allow the extraction of the "base lens", which characterises all the fields added
  by a record without the extension. \<close>

syntax
  "_BASELENS" :: "id \<Rightarrow> logic"  ("BASELENS _")

abbreviation (input) "base_lens t e m \<equiv> \<lparr> lens_get = t, lens_put = \<lambda> s v. e v (m s) \<rparr>"

ML \<open>
  fun baselens_tr [Free (name, _)] =
    let
      val extend = Free (name ^ ".extend", dummyT);
      val truncate = Free (name ^ ".truncate", dummyT);
      val more = Free (name ^ ".more", dummyT);
    in
      Const (@{const_syntax "base_lens"}, dummyT) $ truncate $ extend $ more
    end
  | baselens_tr _ = raise Match;
\<close>

parse_translation \<open>[(@{syntax_const "_BASELENS"}, K baselens_tr)]\<close>

text \<open>We also introduce the \textbf{alphabet} command that creates a record with lenses for each field.
  For each field a lens is created together with a proof that it is very well-behaved, and for each
  pair of lenses an independence theorem is generated. Alphabets can also be extended which yields
  sublens proofs between the extension field lens and record extension lenses. \<close>

ML_file \<open>Lens_Lib.ML\<close>
ML_file \<open>Lens_Record.ML\<close>

text \<open>The following theorem attribute stores splitting theorems for alphabet types which which is useful
  for proof automation.\<close>

named_theorems alpha_splits

subsection \<open>Locale State Spaces \<close>

text \<open> Alternative to the alphabet command, we also introduce the statespace command, which
  implements Schirmer and Wenzel's locale-based approach to state space modelling~\cite{Schirmer2009}.

  It has the advantage of allowing multiple inheritance of state spaces, and also variable names are
  fully internalised with the locales. The approach is also far simpler than record-based state
  spaces.

  It has the disadvantage that variables may not be fully polymorphic, unlike for the
  alphabet command. This makes it in general unsuitable for UTP theory alphabets. \<close>

ML_file \<open>Lens_Statespace.ML\<close>

subsection \<open>Type Definition Lens\<close>

text \<open> Every type defined by a \<^bold>\<open>typedef\<close> command induces a partial bijective lens constructed
  using the abstraction and representation functions. \<close>

context type_definition
begin

definition typedef_lens :: "'b \<Longrightarrow> 'a" ("typedef\<^sub>L") where
[lens_defs]: "typedef\<^sub>L = \<lparr> lens_get = Abs, lens_put = (\<lambda> s. Rep) \<rparr>"

lemma pbij_typedef_lens [simp]: "pbij_lens typedef\<^sub>L"
  by (unfold_locales, simp_all add: lens_defs Rep_inverse)

lemma source_typedef_lens: "\<S>\<^bsub>typedef\<^sub>L\<^esub> = A"
  using Rep_cases by (auto simp add: lens_source_def lens_defs Rep)

lemma bij_typedef_lens_UNIV: "A = UNIV \<Longrightarrow> bij_lens typedef\<^sub>L"
  by (auto intro: pbij_vwb_is_bij_lens simp add: mwb_UNIV_src_is_vwb_lens source_typedef_lens)

end

subsection \<open>Mapper Lenses\<close>

definition lmap_lens ::
  "(('\<alpha> \<Rightarrow> '\<beta>) \<Rightarrow> ('\<gamma> \<Rightarrow> '\<delta>)) \<Rightarrow>
   (('\<beta> \<Rightarrow> '\<alpha>) \<Rightarrow> '\<delta> \<Rightarrow> '\<gamma>) \<Rightarrow>
   ('\<gamma> \<Rightarrow> '\<alpha>) \<Rightarrow>
   ('\<beta> \<Longrightarrow> '\<alpha>) \<Rightarrow>
   ('\<delta> \<Longrightarrow> '\<gamma>)" where
  [lens_defs]:
  "lmap_lens f g h l = \<lparr>
  lens_get = f (get\<^bsub>l\<^esub>),
  lens_put = g o (put\<^bsub>l\<^esub>) o h \<rparr>"

text \<open>
  The parse translation below yields a heterogeneous mapping lens for any
  record type. This achieved through the utility function above that
  constructs a functorial lens. This takes as input a heterogeneous mapping
  function that lifts a function on a record's extension type to an update
  on the entire record, and also the record's ``more'' function. The first input
  is given twice as it has different polymorphic types, being effectively
  a type functor construction which are not explicitly supported by HOL. We note
  that the \<open>more_update\<close> function does something similar to the extension lifting,
  but is not precisely suitable here since it only considers homogeneous functions,
  namely of type \<open>'a \<Rightarrow> 'a\<close> rather than \<open>'a \<Rightarrow> 'b\<close>.
\<close>

syntax
  "_lmap" :: "id \<Rightarrow> logic" ("lmap[_]")

ML \<open>
  fun lmap_tr [Free (name, _)] =
    let
      val extend = Free (name ^ ".extend", dummyT);
      val truncate = Free (name ^ ".truncate", dummyT);
      val more = Free (name ^ ".more", dummyT);
      val map_ext = Abs ("f", dummyT,
                    Abs ("r", dummyT,
                      extend $ (truncate $ Bound 0) $ (Bound 1 $ (more $ (Bound 0)))))

    in
      Const (@{const_syntax "lmap_lens"}, dummyT) $ map_ext $ map_ext $ more
    end
  | lmap_tr _ = raise Match;
\<close>

parse_translation \<open>[(@{syntax_const "_lmap"}, K lmap_tr)]\<close>

subsection \<open>Lens Interpretation\<close>

named_theorems lens_interp_laws

locale lens_interp = interp
begin
declare meta_interp_law [lens_interp_laws]
declare all_interp_law [lens_interp_laws]
declare exists_interp_law [lens_interp_laws]

end

subsection \<open> Tactic \<close>

text \<open> A simple tactic for simplifying lens expressions \<close>

declare split_paired_all [alpha_splits]

method lens_simp = (simp add: alpha_splits lens_defs prod.case_eq_if)

end