(* Martin Kleppmann, University of Cambridge
   Victor B. F. Gomes, University of Cambridge
   Dominic P. Mulligan, Arm Research, Cambridge
   Alastair Beresford, University of Cambridge
*)

section\<open>Abstract OpSet\<close>

text\<open>In this section, we define a general-purpose OpSet abstraction that is not
specific to any one particular datatype. We develop a library of useful lemmas
that we can build upon later when reasoning about a specific datatype.\<close>

theory OpSet
  imports Main
begin

subsection\<open>OpSet definition\<close>

text\<open>An OpSet is a set of (ID, operation) pairs with an associated total order
on IDs (represented here with the \isa{linorder} typeclass), and satisfying the
following properties:
\begin{enumerate}
\item The ID is unique (that is, if any two pairs in the set have the same ID,
then their operation is also the same).
\item If the operation references the IDs of any other operations, those
referenced IDs are less than that of the operation itself, according to the
total order on IDs. To avoid assuming anything about the structure of operations
here, we use a function \isa{deps} that returns the set of dependent IDs for a
given operation. This requirement is a weak expression of causality: an operation
can only depend on causally prior operations, and by making the total order on
IDs a linear extension of the causal order, we can easily ensure that any
referenced IDs are less than that of the operation itself.
\item The OpSet is finite (but we do not assume any particular maximum size).
\end{enumerate}\<close>

locale opset =
  fixes opset :: "('oid::{linorder} \<times> 'oper) set"
    and deps  :: "'oper \<Rightarrow> 'oid set"
  assumes unique_oid: "(oid, op1) \<in> opset \<Longrightarrow> (oid, op2) \<in> opset \<Longrightarrow> op1 = op2"
    and ref_older: "(oid, oper) \<in> opset \<Longrightarrow> ref \<in> deps oper \<Longrightarrow> ref < oid"
    and finite_opset: "finite opset"

text\<open>We prove that any subset of an OpSet is also a valid OpSet. This is the
case because, although an operation can depend on causally prior operations,
the OpSet does not require those prior operations to actually exist. This weak
assumption makes the OpSet model more general and simplifies reasoning about
OpSets.\<close>

lemma opset_subset:
  assumes "opset Y deps"
    and "X \<subseteq> Y"
  shows "opset X deps"
proof
  fix oid op1 op2
  assume "(oid, op1) \<in> X" and "(oid, op2) \<in> X"
  thus "op1 = op2"
    using assms by (meson opset.unique_oid subsetD)
next
  fix oid oper ref
  assume "(oid, oper) \<in> X" and "ref \<in> deps oper"
  thus "ref < oid"
    using assms by (meson opset.ref_older rev_subsetD)
next
  show "finite X"
    using assms opset.finite_opset finite_subset by blast
qed

lemma opset_insert:
  assumes "opset (insert x ops) deps"
  shows "opset ops deps"
  using assms opset_subset by blast

lemma opset_sublist:
  assumes "opset (set (xs @ ys @ zs)) deps"
  shows "opset (set (xs @ zs)) deps"
proof -
  have "set (xs @ zs) \<subseteq> set (xs @ ys @ zs)"
    by auto
  thus "opset (set (xs @ zs)) deps"
    using assms opset_subset by blast
qed

subsection\<open>Helper lemmas about lists\<close>

text\<open>Some general-purpose lemas about lists and sets that are helpful for
subsequent proofs.\<close>

lemma distinct_rem_mid:
  assumes "distinct (xs @ [x] @ ys)"
  shows "distinct (xs @ ys)"
  using assms by (induction ys rule: rev_induct, simp_all)

lemma distinct_fst_append:
  assumes "x \<in> set (map fst xs)"
    and "distinct (map fst (xs @ ys))"
  shows "x \<notin> set (map fst ys)"
  using assms by (induction ys, force+)

lemma distinct_set_remove_last:
  assumes "distinct (xs @ [x])"
  shows "set xs = set (xs @ [x]) - {x}"
  using assms by force

lemma distinct_set_remove_mid:
  assumes "distinct (xs @ [x] @ ys)"
  shows "set (xs @ ys) = set (xs @ [x] @ ys) - {x}"
  using assms by force

lemma distinct_list_split:
  assumes "distinct xs"
    and "xs = xa @ x # ya"
    and "xs = xb @ x # yb"
  shows "xa = xb \<and> ya = yb"
  using assms proof(induction xs arbitrary: xa xb x)
  fix xa xb x
  assume "[] = xa @ x # ya"
  thus "xa = xb \<and> ya = yb"
    by auto
next
  fix a xs xa xb x
  assume IH: "\<And>xa xb x. distinct xs \<Longrightarrow> xs = xa @ x # ya \<Longrightarrow> xs = xb @ x # yb \<Longrightarrow> xa = xb \<and> ya = yb"
    and "distinct (a # xs)" and "a # xs = xa @ x # ya" and "a # xs = xb @ x # yb"
  thus "xa = xb \<and> ya = yb"
    by(case_tac xa; case_tac xb) auto
qed

lemma distinct_append_swap:
  assumes "distinct (xs @ ys)"
  shows "distinct (ys @ xs)"
  using assms by (induction ys, auto)

lemma append_subset:
  assumes "set xs = set (ys @ zs)"
  shows "set ys \<subseteq> set xs" and "set zs \<subseteq> set xs"
  by (metis Un_iff assms set_append subsetI)+

lemma append_set_rem_last:
  assumes "set (xs @ [x]) = set (ys @ [x] @ zs)"
    and "distinct (xs @ [x])" and "distinct (ys @ [x] @ zs)"
  shows "set xs = set (ys @ zs)"
proof -
  have "distinct xs"
    using assms distinct_append by blast
  moreover from this have "set xs = set (xs @ [x]) - {x}"
    by (meson assms distinct_set_remove_last)
  moreover have "distinct (ys @ zs)"
    using assms distinct_rem_mid by simp
  ultimately show "set xs = set (ys @ zs)"
    using assms distinct_set_remove_mid by metis
qed

lemma distinct_map_fst_remove1:
  assumes "distinct (map fst xs)"
  shows "distinct (map fst (remove1 x xs))"
  using assms proof(induction xs)
  case Nil
  then show "distinct (map fst (remove1 x []))"
    by simp
next
  case (Cons a xs)
  hence IH: "distinct (map fst (remove1 x xs))"
    by simp
  then show "distinct (map fst (remove1 x (a # xs)))"
  proof(cases "a = x")
    case True
    then show ?thesis
      using Cons.prems by auto
  next
    case False
    moreover have "fst a \<notin> fst ` set (remove1 x xs)"
      by (metis (no_types, lifting) Cons.prems distinct.simps(2) image_iff
          list.simps(9) notin_set_remove1 set_map)
    ultimately show ?thesis
      using IH by auto
  qed
qed

subsection\<open>The \isa{spec-ops} predicate\<close>

text\<open>The \isa{spec-ops} predicate describes a list of (ID, operation) pairs that
corresponds to the linearisation of an OpSet, and which we use for sequentially
interpreting the OpSet. A list satisfies \isa{spec-ops} iff it is sorted in ascending
order of IDs, if the IDs are unique, and if every operation's dependencies have
lower IDs than the operation itself. A list is implicitly finite in Isabelle/HOL.
These requirements correspond to the OpSet definition above, and indeed we prove
later that every OpSet has a linearisation that satisfies \isa{spec-ops}.\<close>

definition spec_ops :: "('oid::{linorder} \<times> 'oper) list \<Rightarrow> ('oper \<Rightarrow> 'oid set) \<Rightarrow> bool" where
  "spec_ops ops deps \<equiv> (sorted (map fst ops) \<and> distinct (map fst ops) \<and>
           (\<forall>oid oper ref. (oid, oper) \<in> set ops \<and> ref \<in> deps oper \<longrightarrow> ref < oid))"

lemma spec_ops_empty:
  shows "spec_ops [] deps"
  by (simp add: spec_ops_def)

lemma spec_ops_distinct:
  assumes "spec_ops ops deps"
  shows "distinct ops"
  using assms distinct_map spec_ops_def by blast

lemma spec_ops_distinct_fst:
  assumes "spec_ops ops deps"
  shows "distinct (map fst ops)"
  using assms by (simp add: spec_ops_def)

lemma spec_ops_sorted:
  assumes "spec_ops ops deps"
  shows "sorted (map fst ops)"
  using assms by (simp add: spec_ops_def)

lemma spec_ops_rem_cons:
  assumes "spec_ops (x # xs) deps"
  shows "spec_ops xs deps"
proof -
  have "sorted (map fst (x # xs))" and "distinct (map fst (x # xs))"
    using assms spec_ops_def by blast+
  moreover from this have "sorted (map fst xs)"
    by simp
  moreover have "\<forall>oid oper ref. (oid, oper) \<in> set xs \<and> ref \<in> deps oper \<longrightarrow> ref < oid"
    by (meson assms set_subset_Cons spec_ops_def subsetCE)
  ultimately show "spec_ops xs deps"
    by (simp add: spec_ops_def)
qed

lemma spec_ops_rem_last:
  assumes "spec_ops (xs @ [x]) deps"
  shows "spec_ops xs deps"
proof -
  have "sorted (map fst (xs @ [x]))" and "distinct (map fst (xs @ [x]))"
    using assms spec_ops_def by blast+
  moreover from this have "sorted (map fst xs)" and "distinct xs"
    by (auto simp add: sorted_append distinct_butlast distinct_map)
  moreover have "\<forall>oid oper ref. (oid, oper) \<in> set xs \<and> ref \<in> deps oper \<longrightarrow> ref < oid"
    by (metis assms butlast_snoc in_set_butlastD spec_ops_def)
  ultimately show "spec_ops xs deps"
    by (simp add: spec_ops_def)
qed

lemma spec_ops_remove1:
  assumes "spec_ops xs deps"
  shows "spec_ops (remove1 x xs) deps"
  using assms distinct_map_fst_remove1 spec_ops_def
  by (metis notin_set_remove1 sorted_map_remove1 spec_ops_def)

lemma spec_ops_ref_less:
  assumes "spec_ops xs deps"
    and "(oid, oper) \<in> set xs"
    and "r \<in> deps oper"
  shows "r < oid"
  using assms spec_ops_def by force

lemma spec_ops_ref_less_last:
  assumes "spec_ops (xs @ [(oid, oper)]) deps"
    and "r \<in> deps oper"
  shows "r < oid"
  using assms spec_ops_ref_less by fastforce

lemma spec_ops_id_inc:
  assumes "spec_ops (xs @ [(oid, oper)]) deps"
    and "x \<in> set (map fst xs)"
  shows "x < oid"
proof -
  have "sorted ((map fst xs) @ (map fst [(oid, oper)]))"
    using assms(1) by (simp add: spec_ops_def)
  hence "\<forall>i \<in> set (map fst xs). i \<le> oid"
    by (simp add: sorted_append)
  moreover have "distinct ((map fst xs) @ (map fst [(oid, oper)]))"
    using assms(1) by (simp add: spec_ops_def)
  hence "\<forall>i \<in> set (map fst xs). i \<noteq> oid"
    by auto
  ultimately show "x < oid"
    using assms(2) le_neq_trans by auto
qed

lemma spec_ops_add_last:
  assumes "spec_ops xs deps"
    and "\<forall>i \<in> set (map fst xs). i < oid"
    and "\<forall>ref \<in> deps oper. ref < oid"
  shows "spec_ops (xs @ [(oid, oper)]) deps"
proof -
  have "sorted ((map fst xs) @ [oid])"
    using assms sorted_append spec_ops_sorted by fastforce
  moreover have "distinct ((map fst xs) @ [oid])"
    using assms spec_ops_distinct_fst by fastforce
  moreover have "\<forall>oid oper ref. (oid, oper) \<in> set xs \<and> ref \<in> deps oper \<longrightarrow> ref < oid"
    using assms(1) spec_ops_def by fastforce
  hence "\<forall>i opr r. (i, opr) \<in> set (xs @ [(oid, oper)]) \<and> r \<in> deps opr \<longrightarrow> r < i"
    using assms(3) by auto
  ultimately show "spec_ops (xs @ [(oid, oper)]) deps"
    by (simp add: spec_ops_def)
qed

lemma spec_ops_add_any:
  assumes "spec_ops (xs @ ys) deps"
    and "\<forall>i \<in> set (map fst xs). i < oid"
    and "\<forall>i \<in> set (map fst ys). oid < i"
    and "\<forall>ref \<in> deps oper. ref < oid"
  shows "spec_ops (xs @ [(oid, oper)] @ ys) deps"
  using assms proof(induction ys rule: rev_induct)
  case Nil
  then show "spec_ops (xs @ [(oid, oper)] @ []) deps"
    by (simp add: spec_ops_add_last)
next
  case (snoc y ys)
  have IH: "spec_ops (xs @ [(oid, oper)] @ ys) deps"
  proof -
    from snoc have "spec_ops (xs @ ys) deps"
      by (metis append_assoc spec_ops_rem_last)
    thus "spec_ops (xs @ [(oid, oper)] @ ys) deps"
      using assms(2) snoc by auto
  qed
  obtain yi yo where y_pair: "y = (yi, yo)"
    by force
  have oid_yi: "oid < yi"
    by (simp add: snoc.prems(3) y_pair)
  have yi_biggest: "\<forall>i \<in> set (map fst (xs @ [(oid, oper)] @ ys)). i < yi"
  proof -
    have "\<forall>i \<in> set (map fst xs). i < yi"
      using oid_yi assms(2) less_trans by blast
    moreover have "\<forall>i \<in> set (map fst ys). i < yi"
      by (metis UnCI append_assoc map_append set_append snoc.prems(1) spec_ops_id_inc y_pair)
    ultimately show ?thesis
      using oid_yi by auto
  qed
  have "sorted (map fst (xs @ [(oid, oper)] @ ys @ [y]))"
  proof -
    from IH have "sorted (map fst (xs @ [(oid, oper)] @ ys))"
      using spec_ops_def by blast
    hence "sorted (map fst (xs @ [(oid, oper)] @ ys) @ [yi])"
      using yi_biggest
      by (simp add: sorted_append dual_order.strict_implies_order)
    thus "sorted (map fst (xs @ [(oid, oper)] @ ys @ [y]))"
      by (simp add: y_pair)
  qed
  moreover have "distinct (map fst (xs @ [(oid, oper)] @ ys @ [y]))"
  proof -
    have "distinct (map fst (xs @ [(oid, oper)] @ ys) @ [yi])"
      using IH yi_biggest spec_ops_def
      by (metis distinct.simps(2) distinct1_rotate order_less_irrefl rotate1.simps(2))
    thus "distinct (map fst (xs @ [(oid, oper)] @ ys @ [y]))"
      by (simp add: y_pair)
  qed
  moreover have "\<forall>i opr r. (i, opr) \<in> set (xs @ [(oid, oper)] @ ys @ [y])
                     \<and> r \<in> deps opr \<longrightarrow> r < i"
  proof -
    have "\<forall>i opr r. (i, opr) \<in> set (xs @ [(oid, oper)] @ ys) \<and> r \<in> deps opr \<longrightarrow> r < i"
      by (meson IH spec_ops_def)
    moreover have "\<forall>ref. ref \<in> deps yo \<longrightarrow> ref < yi"
      by (metis spec_ops_ref_less append_is_Nil_conv last_appendR last_in_set last_snoc
          list.simps(3) snoc.prems(1) y_pair)
    ultimately show ?thesis
      using y_pair by auto
  qed
  ultimately show "spec_ops (xs @ [(oid, oper)] @ ys @ [y]) deps"
    using spec_ops_def by blast
qed

lemma spec_ops_split:
  assumes "spec_ops xs deps"
    and "oid \<notin> set (map fst xs)"
  shows "\<exists>pre suf. xs = pre @ suf \<and>
            (\<forall>i \<in> set (map fst pre). i < oid) \<and>
            (\<forall>i \<in> set (map fst suf). oid < i)"
  using assms proof(induction xs rule: rev_induct)
  case Nil
  then show ?case by force
next
  case (snoc x xs)
  obtain xi xr where y_pair: "x = (xi, xr)"
    by force
  obtain pre suf where IH: "xs = pre @ suf \<and>
               (\<forall>a\<in>set (map fst pre). a < oid) \<and>
               (\<forall>a\<in>set (map fst suf). oid < a)"
    by (metis UnCI map_append set_append snoc spec_ops_rem_last)
  then show ?case
  proof(cases "xi < oid")
    case xi_less: True
    have "\<forall>x \<in> set (map fst (pre @ suf)). x < xi"
      using IH spec_ops_id_inc snoc.prems(1) y_pair by metis
    hence "\<forall>x \<in> set suf. fst x < xi"
      by simp
    hence "\<forall>x \<in> set suf. fst x < oid"
      using xi_less by auto
    hence "suf = []"
      using IH last_in_set by fastforce
    hence "xs @ [x] = (pre @ [(xi, xr)]) @ [] \<and>
              (\<forall>a\<in>set (map fst ((pre @ [(xi, xr)]))). a < oid) \<and>
              (\<forall>a\<in>set (map fst []). oid < a)"
      by (simp add: IH xi_less y_pair)
    then show ?thesis by force
  next
    case False
    hence "oid < xi" using snoc.prems(2) y_pair by auto
    hence "xs @ [x] = pre @ (suf @ [(xi, xr)]) \<and>
              (\<forall>i \<in> set (map fst pre). i < oid) \<and>
              (\<forall>i \<in> set (map fst (suf @ [(xi, xr)])). oid < i)"
      by (simp add: IH y_pair)
    then show ?thesis by blast
  qed
qed

lemma spec_ops_exists_base:
  assumes "finite ops"
    and "\<And>oid op1 op2. (oid, op1) \<in> ops \<Longrightarrow> (oid, op2) \<in> ops \<Longrightarrow> op1 = op2"
    and "\<And>oid oper ref. (oid, oper) \<in> ops \<Longrightarrow> ref \<in> deps oper \<Longrightarrow> ref < oid"
  shows "\<exists>op_list. set op_list = ops \<and> spec_ops op_list deps"
  using assms proof(induct ops rule: Finite_Set.finite_induct_select)
  case empty
  then show "\<exists>op_list. set op_list = {} \<and> spec_ops op_list deps"
    by (simp add: spec_ops_empty)
next
  case (select subset)
  from this obtain op_list where "set op_list = subset" and "spec_ops op_list deps"
    using assms by blast
  moreover obtain oid oper where select: "(oid, oper) \<in> ops - subset"
    using select.hyps(1) by auto
  moreover from this have "\<And>op2. (oid, op2) \<in> ops \<Longrightarrow> op2 = oper"
    using assms(2) by auto
  hence "oid \<notin> fst ` subset"
    by (metis (no_types, lifting) DiffD2 select image_iff prod.collapse psubsetD select.hyps(1))
  from this obtain pre suf
    where "op_list = pre @ suf"
      and "\<forall>i \<in> set (map fst pre). i < oid"
      and "\<forall>i \<in> set (map fst suf). oid < i"
    using spec_ops_split calculation by (metis (no_types, lifting) set_map)
  moreover have "set (pre @ [(oid, oper)] @ suf) = insert (oid, oper) subset"
    using calculation by auto
  moreover have "spec_ops (pre @ [(oid, oper)] @ suf) deps"
    using calculation spec_ops_add_any assms(3) by (metis DiffD1)
  ultimately show ?case by blast
qed

text\<open>We prove that for any given OpSet, a \isa{spec-ops} linearisation exists:\<close>

lemma spec_ops_exists:
  assumes "opset ops deps"
  shows "\<exists>op_list. set op_list = ops \<and> spec_ops op_list deps"
proof -
  have "finite ops"
    using assms opset.finite_opset by force
  moreover have "\<And>oid op1 op2. (oid, op1) \<in> ops \<Longrightarrow> (oid, op2) \<in> ops \<Longrightarrow> op1 = op2"
    using assms opset.unique_oid by force
  moreover have "\<And>oid oper ref. (oid, oper) \<in> ops \<Longrightarrow> ref \<in> deps oper \<Longrightarrow> ref < oid"
    using assms opset.ref_older by force
  ultimately show "\<exists>op_list. set op_list = ops \<and> spec_ops op_list deps"
    by (simp add: spec_ops_exists_base)
qed

lemma spec_ops_oid_unique:
  assumes "spec_ops op_list deps"
    and "(oid, op1) \<in> set op_list"
    and "(oid, op2) \<in> set op_list"
  shows "op1 = op2"
  using assms proof(induction op_list, simp)
  case (Cons x op_list)
  have "distinct (map fst (x # op_list))"
    using Cons.prems(1) spec_ops_def by blast
  hence notin: "fst x \<notin> set (map fst op_list)"
    by simp
  then show "op1 = op2"
  proof(cases "fst x = oid")
    case True
    then show "op1 = op2"
      using Cons.prems notin by (metis Pair_inject in_set_zipE set_ConsD zip_map_fst_snd)
  next
    case False
    then have "(oid, op1) \<in> set op_list" and "(oid, op2) \<in> set op_list"
      using Cons.prems by auto
    then show "op1 = op2"
      using Cons.IH Cons.prems(1) spec_ops_rem_cons by blast
  qed
qed

text\<open>Conversely, for any given \isa{spec-ops} list, the set of pairs in the
list is an OpSet:\<close>

lemma spec_ops_is_opset:
  assumes "spec_ops op_list deps"
  shows "opset (set op_list) deps"
proof -
  have "\<And>oid op1 op2. (oid, op1) \<in> set op_list \<Longrightarrow> (oid, op2) \<in> set op_list \<Longrightarrow> op1 = op2"
    using assms spec_ops_oid_unique by fastforce
  moreover have "\<And>oid oper ref. (oid, oper) \<in> set op_list \<Longrightarrow> ref \<in> deps oper \<Longrightarrow> ref < oid"
    by (meson assms spec_ops_ref_less)
  moreover have "finite (set op_list)"
    by simp
  ultimately show "opset (set op_list) deps"
    by (simp add: opset_def)
qed

subsection\<open>The \isa{crdt-ops} predicate\<close>

text\<open>Like \isa{spec-ops}, the \isa{crdt-ops} predicate describes the linearisation of
an OpSet into a list. Like \isa{spec-ops}, it requires IDs to be unique. However,
its other properties are different: \isa{crdt-ops} does not require operations to
appear in sorted order, but instead, whenever any operation references the
ID of a prior operation, that prior operation must appear previously in the
\isa{crdt-ops} list. Thus, the order of operations is partially constrained:
operations must appear in causal order, but concurrent operations can be
ordered arbitrarily.

This list describes the operation sequence in the order it is typically applied to
an operation-based CRDT. Applying operations in the order they appear in
\isa{crdt-ops} requires that concurrent operations commute. For any \isa{crdt-ops}
operation sequence, there is a permutation that satisfies the \isa{spec-ops}
predicate. Thus, to check whether a CRDT satisfies its sequential specification,
we can prove that interpreting any \isa{crdt-ops} operation sequence with the
commutative operation interpretation results in the same end result as
interpreting the \isa{spec-ops} permutation of that operation sequence with the
sequential operation interpretation.\<close>

inductive crdt_ops :: "('oid::{linorder} \<times> 'oper) list \<Rightarrow> ('oper \<Rightarrow> 'oid set) \<Rightarrow> bool" where
  "crdt_ops [] deps" |
  "\<lbrakk>crdt_ops xs deps;
    oid \<notin> set (map fst xs);
    \<forall>ref \<in> deps oper. ref \<in> set (map fst xs) \<and> ref < oid
   \<rbrakk> \<Longrightarrow> crdt_ops (xs @ [(oid, oper)]) deps"

inductive_cases crdt_ops_last: "crdt_ops (xs @ [x]) deps"

lemma crdt_ops_intro:
  assumes "\<And>r. r \<in> deps oper \<Longrightarrow> r \<in> fst ` set xs \<and> r < oid"
    and "oid \<notin> fst ` set xs"
    and "crdt_ops xs deps"
  shows "crdt_ops (xs @ [(oid, oper)]) deps"
  using assms crdt_ops.simps by force

lemma crdt_ops_rem_last:
  assumes "crdt_ops (xs @ [x]) deps"
  shows "crdt_ops xs deps"
  using assms crdt_ops.cases snoc_eq_iff_butlast by blast

lemma crdt_ops_ref_less:
  assumes "crdt_ops xs deps"
    and "(oid, oper) \<in> set xs"
    and "r \<in> deps oper"
  shows "r < oid"
  using assms by (induction rule: crdt_ops.induct, auto)

lemma crdt_ops_ref_less_last:
  assumes "crdt_ops (xs @ [(oid, oper)]) deps"
    and "r \<in> deps oper"
  shows "r < oid"
  using assms crdt_ops_ref_less by fastforce

lemma crdt_ops_distinct_fst:
  assumes "crdt_ops xs deps"
  shows "distinct (map fst xs)"
  using assms proof (induction xs rule: List.rev_induct, simp)
  case (snoc x xs)
  hence "distinct (map fst xs)"
    using crdt_ops_last by blast
  moreover have "fst x \<notin> set (map fst xs)"
    using snoc by (metis crdt_ops_last fstI image_set)
  ultimately show "distinct (map fst (xs @ [x]))"
    by simp
qed

lemma crdt_ops_distinct:
  assumes "crdt_ops xs deps"
  shows "distinct xs"
  using assms crdt_ops_distinct_fst distinct_map by blast

lemma crdt_ops_unique_last:
  assumes "crdt_ops (xs @ [(oid, oper)]) deps"
  shows "oid \<notin> set (map fst xs)"
  using assms crdt_ops.cases by blast

lemma crdt_ops_unique_mid:
  assumes "crdt_ops (xs @ [(oid, oper)] @ ys) deps"
  shows "oid \<notin> set (map fst xs) \<and> oid \<notin> set (map fst ys)"
  using assms proof(induction ys rule: rev_induct)
  case Nil
  then show "oid \<notin> set (map fst xs) \<and> oid \<notin> set (map fst [])"
    by (metis crdt_ops_unique_last Nil_is_map_conv append_Nil2 empty_iff empty_set)
next
  case (snoc y ys)
  obtain yi yr where y_pair: "y = (yi, yr)"
    by fastforce
  have IH: "oid \<notin> set (map fst xs) \<and> oid \<notin> set (map fst ys)"
    using crdt_ops_rem_last snoc by (metis append_assoc)
  have "(xs @ (oid, oper) # ys) @ [(yi, yr)] = xs @ (oid, oper) # ys @ [(yi, yr)]"
    by simp
  hence "yi \<notin> set (map fst (xs @ (oid, oper) # ys))"
    using crdt_ops_unique_last by (metis append_Cons append_self_conv2 snoc.prems y_pair)
  thus "oid \<notin> set (map fst xs) \<and> oid \<notin> set (map fst (ys @ [y]))"
    using IH y_pair by auto
qed

lemma crdt_ops_ref_exists:
  assumes "crdt_ops (pre @ (oid, oper) # suf) deps"
    and "ref \<in> deps oper"
  shows "ref \<in> fst ` set pre"
  using assms proof(induction suf rule: List.rev_induct)
  case Nil thus ?case
    by (metis crdt_ops_last prod.sel(2))
next
  case (snoc x xs) thus ?case
    using crdt_ops.cases by force
qed

lemma crdt_ops_no_future_ref:
  assumes "crdt_ops (xs @ [(oid, oper)] @ ys) deps"
  shows "\<And>ref. ref \<in> deps oper \<Longrightarrow> ref \<notin> fst ` set ys"
proof -
  from assms(1) have "\<And>ref. ref \<in> deps oper \<Longrightarrow> ref \<in> set (map fst xs)"
    by (simp add: crdt_ops_ref_exists)
  moreover have "distinct (map fst (xs @ [(oid, oper)] @ ys))"
    using assms crdt_ops_distinct_fst by blast
  ultimately have "\<And>ref. ref \<in> deps oper \<Longrightarrow> ref \<notin> set (map fst ([(oid, oper)] @ ys))"
    using distinct_fst_append by metis
  thus "\<And>ref. ref \<in> deps oper \<Longrightarrow> ref \<notin> fst ` set ys"
    by simp
qed

lemma crdt_ops_reorder:
  assumes "crdt_ops (xs @ [(oid, oper)] @ ys) deps"
    and "\<And>op2 r. op2 \<in> snd ` set ys \<Longrightarrow> r \<in> deps op2 \<Longrightarrow> r \<noteq> oid"
  shows "crdt_ops (xs @ ys @ [(oid, oper)]) deps"
  using assms proof(induction ys rule: rev_induct)
  case Nil
  then show "crdt_ops (xs @ [] @ [(oid, oper)]) deps"
    using crdt_ops_rem_last by auto
next
  case (snoc y ys)
  then obtain yi yo where y_pair: "y = (yi, yo)"
    by fastforce
  have IH: "crdt_ops (xs @ ys @ [(oid, oper)]) deps"
  proof -
    have "crdt_ops (xs @ [(oid, oper)] @ ys) deps"
      by (metis snoc(2) append.assoc crdt_ops_rem_last)
    thus "crdt_ops (xs @ ys @ [(oid, oper)]) deps"
      using snoc.IH snoc.prems(2) by auto
  qed
  have "crdt_ops (xs @ ys @ [y]) deps"
  proof -
    have "yi \<notin> fst ` set (xs @ [(oid, oper)] @ ys)"
      by (metis y_pair append_assoc crdt_ops_unique_last set_map snoc.prems(1))
    hence "yi \<notin> fst ` set (xs @ ys)"
      by auto
    moreover have "\<And>r. r \<in> deps yo \<Longrightarrow> r \<in> fst ` set (xs @ ys) \<and> r < yi"
    proof -
      have "\<And>r. r \<in> deps yo \<Longrightarrow> r \<noteq> oid"
        using snoc.prems(2) y_pair by fastforce
      moreover have "\<And>r. r \<in> deps yo \<Longrightarrow> r \<in> fst ` set (xs @ [(oid, oper)] @ ys)"
        by (metis y_pair append_assoc snoc.prems(1) crdt_ops_ref_exists)
      moreover have "\<And>r. r \<in> deps yo \<Longrightarrow> r < yi"
        using crdt_ops_ref_less snoc.prems(1) y_pair by fastforce
      ultimately show "\<And>r. r \<in> deps yo \<Longrightarrow> r \<in> fst ` set (xs @ ys) \<and> r < yi"
        by simp
    qed
    moreover from IH have "crdt_ops (xs @ ys) deps"
      using crdt_ops_rem_last by force
    ultimately show "crdt_ops (xs @ ys @ [y]) deps"
      using y_pair crdt_ops_intro by (metis append.assoc)
  qed
  moreover have "oid \<notin> fst ` set (xs @ ys @ [y])"
    using crdt_ops_unique_mid by (metis (no_types, lifting) UnE image_Un
        image_set set_append snoc.prems(1))
  moreover have "\<And>r. r \<in> deps oper \<Longrightarrow> r \<in> fst ` set (xs @ ys @ [y])"
    using crdt_ops_ref_exists
    by (metis UnCI append_Cons image_Un set_append snoc.prems(1))
  moreover have "\<And>r. r \<in> deps oper \<Longrightarrow> r < oid"
    using IH crdt_ops_ref_less by fastforce
  ultimately show "crdt_ops (xs @ (ys @ [y]) @ [(oid, oper)]) deps"
    using crdt_ops_intro by (metis append_assoc)
qed

lemma crdt_ops_rem_middle:
  assumes "crdt_ops (xs @ [(oid, ref)] @ ys) deps"
    and "\<And>op2 r. op2 \<in> snd ` set ys \<Longrightarrow> r \<in> deps op2 \<Longrightarrow> r \<noteq> oid"
  shows "crdt_ops (xs @ ys) deps"
  using assms crdt_ops_rem_last crdt_ops_reorder append_assoc by metis

lemma crdt_ops_independent_suf:
  assumes "spec_ops (xs @ [(oid, oper)]) deps"
    and "crdt_ops (ys @ [(oid, oper)] @ zs) deps"
    and "set (xs @ [(oid, oper)]) = set (ys @ [(oid, oper)] @ zs)"
  shows "\<And>op2 r. op2 \<in> snd ` set zs \<Longrightarrow> r \<in> deps op2 \<Longrightarrow> r \<noteq> oid"
proof -
  have "\<And>op2 r. op2 \<in> snd ` set xs \<Longrightarrow> r \<in> deps op2 \<Longrightarrow> r < oid"
  proof -
    from assms(1) have "\<And>i. i \<in> fst ` set xs \<Longrightarrow> i < oid"
      using spec_ops_id_inc by fastforce
    moreover have "\<And>i2 op2 r. (i2, op2) \<in> set xs \<Longrightarrow> r \<in> deps op2 \<Longrightarrow> r < i2"
      using assms(1) spec_ops_ref_less spec_ops_rem_last by fastforce
    ultimately show "\<And>op2 r. op2 \<in> snd ` set xs \<Longrightarrow> r \<in> deps op2 \<Longrightarrow> r < oid"
      by fastforce
  qed
  moreover have "set zs \<subseteq> set xs"
  proof -
    have "distinct (xs @ [(oid, oper)])" and "distinct (ys @ [(oid, oper)] @ zs)"
      using assms spec_ops_distinct crdt_ops_distinct by blast+
    hence "set xs = set (ys @ zs)"
      by (meson append_set_rem_last assms(3))
    then show "set zs \<subseteq> set xs"
      using append_subset(2) by simp
  qed
  ultimately show "\<And>op2 r. op2 \<in> snd ` set zs \<Longrightarrow> r \<in> deps op2 \<Longrightarrow> r \<noteq> oid"
    by fastforce
qed

lemma crdt_ops_reorder_spec:
  assumes "spec_ops (xs @ [x]) deps"
    and "crdt_ops (ys @ [x] @ zs) deps"
    and "set (xs @ [x]) = set (ys @ [x] @ zs)"
  shows "crdt_ops (ys @ zs @ [x]) deps"
  using assms proof -
  obtain oid oper where x_pair: "x = (oid, oper)" by force
  hence "\<And>op2 r. op2 \<in> snd ` set zs \<Longrightarrow> r \<in> deps op2 \<Longrightarrow> r \<noteq> oid"
    using assms crdt_ops_independent_suf by fastforce
  thus "crdt_ops (ys @ zs @ [x]) deps"
    using assms(2) crdt_ops_reorder x_pair by metis
qed

lemma crdt_ops_rem_spec:
  assumes "spec_ops (xs @ [x]) deps"
    and "crdt_ops (ys @ [x] @ zs) deps"
    and "set (xs @ [x]) = set (ys @ [x] @ zs)"
  shows "crdt_ops (ys @ zs) deps"
  using assms crdt_ops_rem_last crdt_ops_reorder_spec append_assoc by metis

lemma crdt_ops_rem_penultimate:
  assumes "crdt_ops (xs @ [(i1, r1)] @ [(i2, r2)]) deps"
    and "\<And>r. r \<in> deps r2 \<Longrightarrow> r \<noteq> i1"
  shows "crdt_ops (xs @ [(i2, r2)]) deps"
proof -
  have "crdt_ops (xs @ [(i1, r1)]) deps"
    using assms(1) crdt_ops_rem_last by force
  hence "crdt_ops xs deps"
    using crdt_ops_rem_last by force
  moreover have "distinct (map fst (xs @ [(i1, r1)] @ [(i2, r2)]))"
    using assms(1) crdt_ops_distinct_fst by blast
  hence "i2 \<notin> set (map fst xs)"
    by auto
  moreover have "crdt_ops ((xs @ [(i1, r1)]) @ [(i2, r2)]) deps"
    using assms(1) by auto
  hence "\<And>r. r \<in> deps r2 \<Longrightarrow> r \<in> fst ` set (xs @ [(i1, r1)])"
    using crdt_ops_ref_exists by metis
  hence "\<And>r. r \<in> deps r2 \<Longrightarrow> r \<in> set (map fst xs)"
    using assms(2) by auto
  moreover have "\<And>r. r \<in> deps r2 \<Longrightarrow> r < i2"
    using assms(1) crdt_ops_ref_less by fastforce
  ultimately show "crdt_ops (xs @ [(i2, r2)]) deps"
    by (simp add: crdt_ops_intro)
qed

lemma crdt_ops_spec_ops_exist:
  assumes "crdt_ops xs deps"
  shows "\<exists>ys. set xs = set ys \<and> spec_ops ys deps"
  using assms proof(induction xs rule: List.rev_induct)
  case Nil
  then show "\<exists>ys. set [] = set ys \<and> spec_ops ys deps"
    by (simp add: spec_ops_empty)
next
  case (snoc x xs)
  hence IH: "\<exists>ys. set xs = set ys \<and> spec_ops ys deps"
    using crdt_ops_rem_last by blast
  then obtain ys oid ref
    where "set xs = set ys" and "spec_ops ys deps" and "x = (oid, ref)"
    by force
  moreover have "\<exists>pre suf. ys = pre@suf \<and>
                       (\<forall>i \<in> set (map fst pre). i < oid) \<and>
                       (\<forall>i \<in> set (map fst suf). oid < i)"
  proof -
    have "oid \<notin> set (map fst xs)"
      using calculation(3) crdt_ops_unique_last snoc.prems by force
    hence "oid \<notin> set (map fst ys)"
      by (simp add: calculation(1))
    thus ?thesis
      using spec_ops_split \<open>spec_ops ys deps\<close> by blast
  qed
  from this obtain pre suf where "ys = pre @ suf" and
    "\<forall>i \<in> set (map fst pre). i < oid" and
    "\<forall>i \<in> set (map fst suf). oid < i" by force
  moreover have "set (xs @ [(oid, ref)]) = set (pre @ [(oid, ref)] @ suf)"
    using crdt_ops_distinct calculation snoc.prems by simp
  moreover have "spec_ops (pre @ [(oid, ref)] @ suf) deps"
  proof -
    have "\<forall>r \<in> deps ref. r < oid"
      using calculation(3) crdt_ops_ref_less_last snoc.prems by fastforce
    hence "spec_ops (pre @ [(oid, ref)] @ suf) deps"
      using spec_ops_add_any calculation by metis
    thus ?thesis by simp
  qed
  ultimately show "\<exists>ys. set (xs @ [x]) = set ys \<and> spec_ops ys deps"
    by blast
qed

end


(* Title: Isomorphisms Betweeen Predicates, Sets and Relations *}
   Author: Victor Gomes, Georg Struth
   Maintainer: Victor Gomes <victor.gomes@cl.cam.ac.uk>
               Georg Struth <g.struth@sheffield.ac.uk>
*)

section \<open>Isomorphisms Between Predicates, Sets and Relations\<close>

theory P2S2R
imports Main

begin

notation relcomp (infixl ";" 70)
notation inf (infixl "\<sqinter>" 70)
notation sup (infixl "\<squnion>" 65)
notation Id_on ("s2r")
notation Domain ("r2s")
notation Collect ("p2s")

definition rel_n :: "'a rel \<Rightarrow> 'a rel" where
  "rel_n  \<equiv> (\<lambda>X. Id \<inter> - X)"

lemma subid_meet: "R \<subseteq> Id \<Longrightarrow> S \<subseteq> Id \<Longrightarrow> R \<inter> S = R ; S"
  by blast

subsection\<open>Isomorphism Between Sets and Relations\<close>

lemma srs: "r2s \<circ> s2r = id"
  by auto

lemma rsr: "R \<subseteq> Id \<Longrightarrow> s2r (r2s R) = R"
  by (auto simp: Id_def Id_on_def Domain_def)

lemma s2r_inj: "inj s2r"
  by (metis Domain_Id_on injI)

lemma r2s_inj: "R \<subseteq> Id \<Longrightarrow> S \<subseteq> Id \<Longrightarrow> r2s R = r2s S \<Longrightarrow> R = S"
  by (metis rsr)

lemma s2r_surj: "\<forall>R \<subseteq> Id. \<exists>A. R = s2r A"
  using rsr by auto

lemma r2s_surj: "\<forall>A. \<exists>R \<subseteq> Id. A = r2s R"
  by (metis Domain_Id_on Id_onE pair_in_Id_conv subsetI)

lemma s2r_union_hom: "s2r (A \<union> B) = s2r A \<union> s2r B"
  by (simp add: Id_on_def)

lemma s2r_inter_hom: "s2r (A \<inter> B) = s2r A \<inter> s2r B"
  by (auto simp: Id_on_def)

lemma s2r_inter_hom_var: "s2r (A \<inter> B) = s2r A ; s2r B"
  by (auto simp: Id_on_def)

lemma s2r_compl_hom: "s2r (- A) = rel_n (s2r A)"
  by (auto simp add: rel_n_def)

lemma r2s_union_hom: "r2s (R \<union> S) = r2s R \<union> r2s S"
  by auto

lemma r2s_inter_hom: "R \<subseteq> Id \<Longrightarrow> S \<subseteq> Id \<Longrightarrow> r2s (R \<inter> S) = r2s R \<inter> r2s S"
  by auto

lemma r2s_inter_hom_var: "R \<subseteq> Id \<Longrightarrow> S \<subseteq> Id \<Longrightarrow> r2s (R ; S) = r2s R \<inter> r2s S"
  by (metis r2s_inter_hom subid_meet)

lemma r2s_ad_hom: "R \<subseteq> Id \<Longrightarrow> r2s (rel_n R) = - r2s R"
  by (metis r2s_surj rsr s2r_compl_hom)

subsection \<open>Isomorphism Between Predicates and Sets\<close>

type_synonym 'a pred = "'a \<Rightarrow> bool"

definition s2p :: "'a set \<Rightarrow> 'a pred" where
  "s2p S = (\<lambda>x. x \<in> S)"

lemma sps [simp]: "s2p \<circ> p2s = id"
  by (intro ext, simp add: s2p_def)

lemma psp [simp]: "p2s \<circ> s2p = id"
  by (intro ext, simp add: s2p_def)

lemma s2p_bij: "bij s2p"
  using o_bij psp sps by blast

lemma p2s_bij: "bij p2s"
  using o_bij psp sps by blast

lemma s2p_compl_hom: "s2p (- A) = - (s2p A)"
  by (metis Collect_mem_eq comp_eq_dest_lhs id_apply sps uminus_set_def)

lemma s2p_inter_hom: "s2p (A \<inter> B) = (s2p A) \<sqinter> (s2p B)"
  by (metis Collect_mem_eq comp_eq_dest_lhs id_apply inf_set_def sps)

lemma s2p_union_hom: "s2p (A \<union> B) = (s2p A) \<squnion> (s2p B)"
  by (auto simp: s2p_def)

lemma p2s_neg_hom: "p2s (- P) = - (p2s P)"
  by fastforce

lemma p2s_conj_hom: "p2s (P \<sqinter> Q) = p2s P \<inter> p2s Q"
  by blast

lemma p2s_disj_hom: "p2s (P \<squnion> Q) = p2s P \<union> p2s Q"
  by blast

subsection \<open>Isomorphism Between Predicates and Relations\<close>

definition p2r :: "'a pred \<Rightarrow> 'a rel" where
  "p2r P = {(s,s) |s. P s}"

definition r2p :: "'a rel \<Rightarrow> 'a pred" where
  "r2p R = (\<lambda>x. x \<in> Domain R)"

lemma p2r_subid: "p2r P \<subseteq> Id"
  by (simp add: p2r_def subset_eq)

lemma p2s2r: "p2r = s2r \<circ> p2s"
proof (intro ext)
  fix P :: "'a pred"
  have "{(a, a) |a. P a} = {(b, a). b = a \<and> P b}"
    by blast
  thus "p2r P = (s2r \<circ> p2s) P"
    by (simp add: Id_on_def' p2r_def)
qed

lemma r2s2p: "r2p = s2p \<circ> r2s"
  by (intro ext, simp add: r2p_def s2p_def)

lemma prp [simp]: "r2p \<circ> p2r = id"
  by (intro ext, simp add: p2s2r r2p_def)

lemma rpr: "R \<subseteq> Id \<Longrightarrow> p2r (r2p R) = R"
  by (metis comp_apply id_apply p2s2r psp r2s2p rsr)

lemma p2r_inj: "inj p2r"
  by (metis comp_eq_dest_lhs id_apply injI prp)

lemma r2p_inj: "R \<subseteq> Id \<Longrightarrow> S \<subseteq> Id \<Longrightarrow> r2p R = r2p S \<Longrightarrow> R = S"
  by (metis rpr)

lemma p2r_surj: "\<forall> R \<subseteq> Id. \<exists>P. R = p2r P"
  using rpr by auto

lemma r2p_surj: "\<forall>P. \<exists>R \<subseteq> Id. P = r2p R"
  by (metis comp_apply id_apply p2r_subid prp)

lemma p2r_neg_hom: "p2r (- P) = rel_n (p2r P)"
  by (simp add: p2s2r p2s_neg_hom s2r_compl_hom)

lemma p2r_conj_hom [simp]: "p2r P \<inter> p2r Q = p2r (P \<sqinter> Q)"
  by (simp add: p2s2r p2s_conj_hom s2r_inter_hom)

lemma p2r_conj_hom_var [simp]: "p2r P ; p2r Q = p2r (P \<sqinter> Q)"
  by (simp add: p2s2r p2s_conj_hom s2r_inter_hom_var)

lemma p2r_id_neg [simp]: "Id \<inter> - p2r p = p2r (-p)"
  by (auto simp: p2r_def)

lemma p2r_disj_hom [simp]: "p2r P \<union> p2r Q = p2r (P \<squnion> Q)"
  by (simp add: p2s2r p2s_disj_hom s2r_union_hom)

lemma r2p_ad_hom: "R \<subseteq> Id \<Longrightarrow> r2p (rel_n R) = - (r2p R)"
  by (simp add: r2s2p r2s_ad_hom s2p_compl_hom)

lemma r2p_inter_hom: "R \<subseteq> Id \<Longrightarrow> S \<subseteq> Id \<Longrightarrow> r2p (R \<inter> S) = (r2p R) \<sqinter> (r2p S)"
  by (simp add: r2s2p r2s_inter_hom s2p_inter_hom)

lemma r2p_inter_hom_var: "R \<subseteq> Id \<Longrightarrow> S \<subseteq> Id \<Longrightarrow> r2p (R ; S) = (r2p R) \<sqinter> (r2p S)"
  by (simp add: r2s2p r2s_inter_hom_var s2p_inter_hom)

lemma rel_to_pred_union_hom: "R \<subseteq> Id \<Longrightarrow> S \<subseteq> Id \<Longrightarrow> r2p (R \<union> S) = (r2p R) \<squnion> (r2p S)"
  by (simp add: Domain_Un_eq r2s2p s2p_union_hom)

end


theory a1
imports Main
begin

section "Question 1: Lambda-Calculus"

text {* submit as part of a .txt or .pdf file *}

section "Question 2: Higher Order Unification"

text {* submit as part of a .txt or .pdf file *}

section "Question 3: Propositional Logic"

lemma prop_a:
  "B \<longrightarrow> (B \<or> A)"
  apply (rule impI)
  apply (rule disjI1)
  apply assumption
  done

lemma prop_b:
  "(A = True) = A"
  apply (rule iffI)
  apply (erule iffE)
  apply (erule impE)
  apply (erule impE)
  apply (rule TrueI)
  apply assumption
  apply (erule impE)
  apply assumption+
  apply (rule iffI)
  apply (rule TrueI)
  apply assumption
  done

lemma prop_c:
  "(A = False) = (\<not> A)"
  apply (rule iffI)
  apply (erule iffE)
  apply (rule notI)
  apply (erule impE)
  apply assumption+
  apply (rule iffI)
  apply (erule notE)
  apply assumption+
  apply (rule ccontr)
  apply assumption
  done

lemma prop_d: "P \<longrightarrow> \<not>\<not>P"
  apply (rule impI)
  apply (rule notI)
  apply (erule notE)
  apply assumption
  done

lemma prop_e: "\<not>\<not>P \<longrightarrow> P"
  apply (rule impI)
  apply (case_tac P)
  apply assumption
  apply (erule notE)
  apply assumption
  done

text {*
Which of the above statements are provable only in a classical logic?
e
*}

section "Question 4: Higher Order Logic"

lemma hol_a:
  "(\<forall>x. P x) \<or> (\<forall>x. Q x) \<longrightarrow> (\<forall>x. P x \<or> Q x)"
  apply (rule impI)
  apply (rule allI)
  apply (erule disjE)
  apply (rule disjI1)
  apply (erule spec)
  apply (rule disjI2)
  apply (erule spec)
  done

lemma hol_b:
  "(\<forall>P. P) = False"
  apply (rule iffI)
  apply (erule_tac x=False in allE)
  apply assumption
  apply (erule FalseE)
  done

lemma hol_c:
  "(\<forall>x. Q x = P x) \<and> ((\<exists>x. P x) \<longrightarrow> C) \<and> (\<exists>x. Q x) \<longrightarrow> C"
  apply (rule impI)
  apply (erule conjE)+
  apply (erule impE)
  apply (erule exE)
  apply (erule_tac x=x in allE)
  apply (rule_tac x=x in exI)
  apply (erule iffE)
  apply (erule impE)
  apply assumption+
  done

lemma hol_d:
  "(\<forall>x. \<not> (R x) \<longrightarrow> R (M x)) \<Longrightarrow> (\<forall>x. \<not> R (M x) \<longrightarrow> R x)"
  apply (rule allI)
  apply (rule impI)
  apply (erule_tac x=x in allE)
  apply (rule classical)
  apply (erule impE)
  apply assumption
  apply (erule notE)
  apply assumption
  done

lemma hol_e:
  "\<lbrakk>(\<forall>x. \<not> (R x) \<longrightarrow> R (M x)); (\<exists>x. R x)\<rbrakk> \<Longrightarrow> (\<exists>x. R x \<and> R (M (M x)))"
  apply (erule exE)
  apply (rule classical)
  apply (rule_tac x=x in exI)
  apply (rule conjI)
  apply (erule_tac x=x in allE)
  apply assumption
  apply (erule notE)
  apply (rule classical)
  apply (erule notE)
  apply (rule classical)
  apply (rule exI)
  apply (rule conjI)
  apply  assumption
  apply (rule classical)
  apply (erule notE)
  apply (rule_tac x="M x" in exI)
  apply (rule conjI)
  apply (erule_tac x="M x" in allE)
  apply (rule classical)
  apply (erule impE)
  apply assumption
  apply (erule notE)
  apply assumption
  apply (erule allE)
  apply (erule impE)
  apply assumption+
  done

text {*
Formalise and prove the following statement using only the proof methods and rules as earlier in this question.

If every poor person has a rich mother, then there is a rich person
with a rich grandmother.
*}

lemma "\<forall>x. \<not> rich x \<longrightarrow> rich (M x) \<Longrightarrow> \<exists>x. rich x \<longrightarrow> rich (M (M x))"
  apply (erule allE)
  apply (rule classical)
  apply (erule impE)
  apply (rule notI)
  apply (erule notE)
  apply (rule exI)
  apply (rule impI)
  apply assumption
  apply (rule exI)
  apply (erule notE)
  apply (rule exI)
  apply (rule impI)
  apply assumption
  done

end


text\<open> 21 October 2021: Exercise for Homework Assignment 07 in CS 511 \<close>
text\<open> Your task to remove the invocations of the pre-defined method
      'blast' by an equivalent sequence of 'apply' steps \<close>

theory HW07_solution
  imports Main
begin

text\<open> 'blast' is invoked three times, once in the proof of each of
      lemmas B1, C1, and D1 below \<close>

(* The proof of the next lemma is just an example of how to use the
   rules for manipulating quantifiers *)
lemma preliminary : " (\<exists>z. P z) \<and> Q \<longrightarrow> (\<exists>y. P y \<and> Q)"
apply (rule impI)
apply (erule conjE)
apply (erule exE)
apply (rule_tac x="z" in exI)
apply (rule conjI)
apply assumption+
done

(* Lemma A1 is the same in Exercise 2.3.9 (a), page 161, in [LCS] *)
lemma A1 : "(\<exists>x. S \<longrightarrow> Q x) \<Longrightarrow> S \<longrightarrow> (\<exists>x. Q x)"
  apply (erule exE)
  apply (rule impI)
  apply (erule impE)
   apply assumption
  apply (rule_tac x="x" in exI)
  apply assumption
  done

(* Lemma A2 is the same as lemma A1 but with a different proof *)
lemma A2 : "(\<exists>x. S \<longrightarrow> Q x) \<Longrightarrow> S \<longrightarrow> (\<exists>x. Q x)"
  apply clarify
  apply (rule_tac x="x" in exI)
  apply assumption
  done

(* Lemma B1 is the same in Exercise 2.3.9 (b), page 161, in [LCS] *)
lemma B1 : "S \<longrightarrow> (\<exists>x. Q x) \<Longrightarrow> (\<exists>x. S \<longrightarrow> Q x)"
  by blast

text \<open>
lemma B1_by_Mattia : "S \<longrightarrow> (\<exists>x. Q x) \<Longrightarrow> (\<exists>x. S \<longrightarrow> Q x)"
	apply(rule_tac x="x" in exI)  (* Sledgehammer fails or says it is unprovable *)
	apply(rule impI)
	apply(erule impE)
	 apply assumption
	apply(erule exE)
\<close>
text\<open> Note: Copying in the secondary windows/panels works via the keyboard shortcuts
  Ctrl+c or Ctrl+INSERT, while jEdit menu actions always refer to the primary windown/panel. \<close>

text\<open> The proof below consists of 'apply' steps only. The inserted comment
      after every step is the resulting 'proof state'. This proof is not
      the shortest or the most elegant, but understanding every step is a
      good exercise for how to apply the available pre-defined rules. \<close>
lemma B2 : "S \<longrightarrow> (\<exists>x. Q x) \<Longrightarrow> (\<exists>x. S \<longrightarrow> Q x)"
  apply (rule exCI)
(* S \<longrightarrow> (\<exists>x. Q x) \<Longrightarrow> \<forall>x. \<not> (S \<longrightarrow> Q x) \<Longrightarrow> S \<longrightarrow> Q ?a *)
  apply (erule impE)
(*  1. \<forall>x. \<not> (S \<longrightarrow> Q x) \<Longrightarrow> S
    2. \<forall>x. \<not> (S \<longrightarrow> Q x) \<Longrightarrow> \<exists>x. Q x \<Longrightarrow> S \<longrightarrow> Q ?a *)
   apply (erule allE)
(*  1. \<not> (S \<longrightarrow> Q ?x5) \<Longrightarrow> S
    2. \<forall>x. \<not> (S \<longrightarrow> Q x) \<Longrightarrow> \<exists>x. Q x \<Longrightarrow> S \<longrightarrow> Q ?a *)
   apply (rule contrapos_np)
(*  1. \<not> (S \<longrightarrow> Q ?x5) \<Longrightarrow> \<not> ?Q7
    2. \<not> (S \<longrightarrow> Q ?x5) \<Longrightarrow> \<not> S \<Longrightarrow> ?Q7
    3. \<forall>x. \<not> (S \<longrightarrow> Q x) \<Longrightarrow> \<exists>x. Q x \<Longrightarrow> S \<longrightarrow> Q ?a *)
    apply assumption
(*  1. \<not> (S \<longrightarrow> Q ?x5) \<Longrightarrow> \<not> S \<Longrightarrow> S \<longrightarrow> Q ?x5
    2. \<forall>x. \<not> (S \<longrightarrow> Q x) \<Longrightarrow> \<exists>x. Q x \<Longrightarrow> S \<longrightarrow> Q ?a *)
   apply (rule impI)
(*  1. \<not> (S \<longrightarrow> Q ?x5) \<Longrightarrow> \<not> S \<Longrightarrow> S \<Longrightarrow> Q ?x5
    2. \<forall>x. \<not> (S \<longrightarrow> Q x) \<Longrightarrow> \<exists>x. Q x \<Longrightarrow> S \<longrightarrow> Q ?a *)
   apply (erule notE)+
(*  1. S \<Longrightarrow> S
    2. \<forall>x. \<not> (S \<longrightarrow> Q x) \<Longrightarrow> \<exists>x. Q x \<Longrightarrow> S \<longrightarrow> Q ?a *)
   apply assumption
(*  1. \<forall>x. \<not> (S \<longrightarrow> Q x) \<Longrightarrow> \<exists>x. Q x \<Longrightarrow> S \<longrightarrow> Q ?a *)
  apply (rule impI)
(*  1. \<forall>x. \<not> (S \<longrightarrow> Q x) \<Longrightarrow> \<exists>x. Q x \<Longrightarrow> S \<Longrightarrow> Q ?a *)
  apply (rule notE)
(*  1. \<forall>x. \<not> (S \<longrightarrow> Q x) \<Longrightarrow> \<exists>x. Q x \<Longrightarrow> S \<Longrightarrow> \<not> ?P18
    2. \<forall>x. \<not> (S \<longrightarrow> Q x) \<Longrightarrow> \<exists>x. Q x \<Longrightarrow> S \<Longrightarrow> ?P18 *)
   apply (rule notI)
(*  1. \<forall>x. \<not> (S \<longrightarrow> Q x) \<Longrightarrow> \<exists>x. Q x \<Longrightarrow> S \<Longrightarrow> ?P18 \<Longrightarrow> False
    2. \<forall>x. \<not> (S \<longrightarrow> Q x) \<Longrightarrow> \<exists>x. Q x \<Longrightarrow> S \<Longrightarrow> ?P18 *)
   apply (erule FalseE)
(*  1. \<forall>x. \<not> (S \<longrightarrow> Q x) \<Longrightarrow> \<exists>x. Q x \<Longrightarrow> S \<Longrightarrow> False *)
  apply (rule contrapos_np)
(*  1. \<forall>x. \<not> (S \<longrightarrow> Q x) \<Longrightarrow> \<exists>x. Q x \<Longrightarrow> S \<Longrightarrow> \<not> ?Q24
    2. \<forall>x. \<not> (S \<longrightarrow> Q x) \<Longrightarrow> \<exists>x. Q x \<Longrightarrow> S \<Longrightarrow> \<not> False \<Longrightarrow> ?Q24 *)
   apply (rule notI)
(*  1. \<forall>x. \<not> (S \<longrightarrow> Q x) \<Longrightarrow> \<exists>x. Q x \<Longrightarrow> S \<Longrightarrow> ?Q24 \<Longrightarrow> False
    2. \<forall>x. \<not> (S \<longrightarrow> Q x) \<Longrightarrow> \<exists>x. Q x \<Longrightarrow> S \<Longrightarrow> \<not> False \<Longrightarrow> ?Q24 *)
   apply (erule notE)
(*  1. \<forall>x. \<not> (S \<longrightarrow> Q x) \<Longrightarrow> \<exists>x. Q x \<Longrightarrow> S \<Longrightarrow> ?P29
    2. \<forall>x. \<not> (S \<longrightarrow> Q x) \<Longrightarrow> \<exists>x. Q x \<Longrightarrow> S \<Longrightarrow> \<not> False \<Longrightarrow> \<not> ?P29 *)
   apply assumption
(*  1. \<forall>x. \<not> (S \<longrightarrow> Q x) \<Longrightarrow> \<exists>x. Q x \<Longrightarrow> S \<Longrightarrow> \<not> False \<Longrightarrow> \<not> (\<forall>x. \<not> (S \<longrightarrow> Q x)) *)
  apply (rule notI)
(*  1. \<forall>x. \<not> (S \<longrightarrow> Q x) \<Longrightarrow> \<exists>x. Q x \<Longrightarrow> S \<Longrightarrow> \<not> False \<Longrightarrow> \<forall>x. \<not> (S \<longrightarrow> Q x) \<Longrightarrow> False *)
  apply (erule exE)
(*  1. \<And>x. \<forall>x. \<not> (S \<longrightarrow> Q x) \<Longrightarrow> S \<Longrightarrow> \<not> False \<Longrightarrow> \<forall>x. \<not> (S \<longrightarrow> Q x) \<Longrightarrow> Q x \<Longrightarrow> False *)
  apply (erule notE)
(*  1. \<And>x. \<forall>x. \<not> (S \<longrightarrow> Q x) \<Longrightarrow> S \<Longrightarrow> \<forall>x. \<not> (S \<longrightarrow> Q x) \<Longrightarrow> Q x \<Longrightarrow> False *)
  apply (erule allE)+
(*  1. \<And>x. S \<Longrightarrow> Q x \<Longrightarrow> \<not> (S \<longrightarrow> Q (?x37 x)) \<Longrightarrow> \<not> (S \<longrightarrow> Q (?x39 x)) \<Longrightarrow> False *)
  apply (erule notE)+
(*  1. \<And>x. S \<Longrightarrow> Q x \<Longrightarrow> S \<longrightarrow> Q (?x39 x) *)
  apply (rule impI)
(*  1. \<And>x. S \<Longrightarrow> Q x \<Longrightarrow> S \<Longrightarrow> Q (?x39 x) *)
  apply assumption
(* No subgoals! *)
  done
(* Lemma C1 is the same in Exercise 2.3.9 (c), page 161, in [LCS] *)
lemma C1 : "(\<exists>x. P x) \<longrightarrow> S \<Longrightarrow> \<forall>x. (P x \<longrightarrow> S)"
  by blast
text\<open> The proof below consists of 'apply' steps only. \<close>
lemma C2 : "(\<exists>x. P x) \<longrightarrow> S \<Longrightarrow> \<forall>x. (P x \<longrightarrow> S)"
  apply (rule allI)
  apply (rule impI)
  apply (erule impE)
  apply (rule_tac x="x" in exI)
   apply assumption+
  done

(* Lemma D1 is the same in Exercise 2.3.9 (d), page 161, in [LCS] *)
lemma D1 : " (\<forall>x. P x) \<longrightarrow> S \<Longrightarrow> \<exists>x. (P x \<longrightarrow> S)"
  by blast
text\<open> The proof below consists of 'apply' steps. The inserted comment
      after every step is the resulting 'proof state'. This proof is not
      the shortest or the most elegant, but understanding every step is a
      good exercise for how to apply the available pre-defined rules. \<close>
lemma D2 : " (\<forall>x. P x) \<longrightarrow> S \<Longrightarrow> \<exists>x. (P x \<longrightarrow> S)"
  apply (rule exCI)
(* 1. (\<forall>x. P x) \<longrightarrow> S \<Longrightarrow> \<forall>x. \<not> (P x \<longrightarrow> S) \<Longrightarrow> P ?a \<longrightarrow> S *)
  apply (erule impE)
(*  1. \<forall>x. \<not> (P x \<longrightarrow> S) \<Longrightarrow> \<forall>x. P x
    2. \<forall>x. \<not> (P x \<longrightarrow> S) \<Longrightarrow> S \<Longrightarrow> P ?a \<longrightarrow> S *)
   apply (rule allI)
(*  1. \<And>x. \<forall>x. \<not> (P x \<longrightarrow> S) \<Longrightarrow> P x
    2. \<forall>x. \<not> (P x \<longrightarrow> S) \<Longrightarrow> S \<Longrightarrow> P ?a \<longrightarrow> S *)
   apply (erule_tac x="x" in allE)
(*  1. \<And>x. \<not> (P x \<longrightarrow> S) \<Longrightarrow> P x
    2. \<forall>x. \<not> (P x \<longrightarrow> S) \<Longrightarrow> S \<Longrightarrow> P ?a \<longrightarrow> S *)
   apply  (rule contrapos_np)
(*  1. \<And>x. \<not> (P x \<longrightarrow> S) \<Longrightarrow> \<not> ?Q8 x
    2. \<And>x. \<not> (P x \<longrightarrow> S) \<Longrightarrow> \<not> P x \<Longrightarrow> ?Q8 x
    3. \<forall>x. \<not> (P x \<longrightarrow> S) \<Longrightarrow> S \<Longrightarrow> P ?a \<longrightarrow> S *)
    apply assumption
(*  1. \<And>x. \<not> (P x \<longrightarrow> S) \<Longrightarrow> \<not> P x \<Longrightarrow> P x \<longrightarrow> S
    2. \<forall>x. \<not> (P x \<longrightarrow> S) \<Longrightarrow> S \<Longrightarrow> P ?a \<longrightarrow> S *)
   apply (rule impI)
(*  1. \<And>x. \<not> (P x \<longrightarrow> S) \<Longrightarrow> \<not> P x \<Longrightarrow> P x \<Longrightarrow> S
    2. \<forall>x. \<not> (P x \<longrightarrow> S) \<Longrightarrow> S \<Longrightarrow> P ?a \<longrightarrow> S *)
   apply (erule notE)
(*  1. \<And>x. \<not> P x \<Longrightarrow> P x \<Longrightarrow> P x \<longrightarrow> S
    2. \<forall>x. \<not> (P x \<longrightarrow> S) \<Longrightarrow> S \<Longrightarrow> P ?a \<longrightarrow> S *)
   apply (rule impI)
(*  1. \<And>x. \<not> P x \<Longrightarrow> P x \<Longrightarrow> P x \<Longrightarrow> S
    2. \<forall>x. \<not> (P x \<longrightarrow> S) \<Longrightarrow> S \<Longrightarrow> P ?a \<longrightarrow> S *)
   apply (erule notE)
(*  1. \<And>x. P x \<Longrightarrow> P x \<Longrightarrow> P x
    2. \<forall>x. \<not> (P x \<longrightarrow> S) \<Longrightarrow> S \<Longrightarrow> P ?a \<longrightarrow> S *)
   apply assumption
(*  1. \<forall>x. \<not> (P x \<longrightarrow> S) \<Longrightarrow> S \<Longrightarrow> P ?a \<longrightarrow> S *)
  apply (rule impI)
(*  1. \<forall>x. \<not> (P x \<longrightarrow> S) \<Longrightarrow> S \<Longrightarrow> P ?a \<Longrightarrow> S *)
  apply assumption
(* No subgoals! *)
  done
end


(*  Title:      HOL/Lattice/Lattice.thy
    Author:     Markus Wenzel, TU Muenchen
*)

section {* Lattices *}

theory Lattice imports Bounds begin

subsection {* Lattice operations *}

text {*
  A \emph{lattice} is a partial order with infimum and supremum of any
  two elements (thus any \emph{finite} number of elements have bounds
  as well).
*}

class lattice =
  assumes ex_inf: "\<exists>inf. is_inf x y inf"
  assumes ex_sup: "\<exists>sup. is_sup x y sup"

text {*
  The @{text \<sqinter>} (meet) and @{text \<squnion>} (join) operations select such
  infimum and supremum elements.
*}

definition
  meet :: "'a::lattice \<Rightarrow> 'a \<Rightarrow> 'a"  (infixl "&&" 70) where
  "x && y = (THE inf. is_inf x y inf)"
definition
  join :: "'a::lattice \<Rightarrow> 'a \<Rightarrow> 'a"  (infixl "||" 65) where
  "x || y = (THE sup. is_sup x y sup)"

notation (xsymbols)
  meet  (infixl "\<sqinter>" 70) and
  join  (infixl "\<squnion>" 65)

text {*
  Due to unique existence of bounds, the lattice operations may be
  exhibited as follows.
*}

lemma meet_equality [elim?]: "is_inf x y inf \<Longrightarrow> x \<sqinter> y = inf"
proof (unfold meet_def)
  assume "is_inf x y inf"
  then show "(THE inf. is_inf x y inf) = inf"
    by (rule the_equality) (rule is_inf_uniq [OF _ `is_inf x y inf`])
qed

lemma meetI [intro?]:
    "inf \<sqsubseteq> x \<Longrightarrow> inf \<sqsubseteq> y \<Longrightarrow> (\<And>z. z \<sqsubseteq> x \<Longrightarrow> z \<sqsubseteq> y \<Longrightarrow> z \<sqsubseteq> inf) \<Longrightarrow> x \<sqinter> y = inf"
  by (rule meet_equality, rule is_infI) blast+

lemma join_equality [elim?]: "is_sup x y sup \<Longrightarrow> x \<squnion> y = sup"
proof (unfold join_def)
  assume "is_sup x y sup"
  then show "(THE sup. is_sup x y sup) = sup"
    by (rule the_equality) (rule is_sup_uniq [OF _ `is_sup x y sup`])
qed

lemma joinI [intro?]: "x \<sqsubseteq> sup \<Longrightarrow> y \<sqsubseteq> sup \<Longrightarrow>
    (\<And>z. x \<sqsubseteq> z \<Longrightarrow> y \<sqsubseteq> z \<Longrightarrow> sup \<sqsubseteq> z) \<Longrightarrow> x \<squnion> y = sup"
  by (rule join_equality, rule is_supI) blast+

text {*
  \medskip The @{text \<sqinter>} and @{text \<squnion>} operations indeed determine
  bounds on a lattice structure.
*}

lemma is_inf_meet [intro?]: "is_inf x y (x \<sqinter> y)"
proof (unfold meet_def)
  from ex_inf obtain inf where "is_inf x y inf" ..
  then show "is_inf x y (THE inf. is_inf x y inf)"
    by (rule theI) (rule is_inf_uniq [OF _ `is_inf x y inf`])
qed

lemma meet_greatest [intro?]: "z \<sqsubseteq> x \<Longrightarrow> z \<sqsubseteq> y \<Longrightarrow> z \<sqsubseteq> x \<sqinter> y"
  by (rule is_inf_greatest) (rule is_inf_meet)

lemma meet_lower1 [intro?]: "x \<sqinter> y \<sqsubseteq> x"
  by (rule is_inf_lower) (rule is_inf_meet)

lemma meet_lower2 [intro?]: "x \<sqinter> y \<sqsubseteq> y"
  by (rule is_inf_lower) (rule is_inf_meet)

lemma is_sup_join [intro?]: "is_sup x y (x \<squnion> y)"
proof (unfold join_def)
  from ex_sup obtain sup where "is_sup x y sup" ..
  then show "is_sup x y (THE sup. is_sup x y sup)"
    by (rule theI) (rule is_sup_uniq [OF _ `is_sup x y sup`])
qed

lemma join_least [intro?]: "x \<sqsubseteq> z \<Longrightarrow> y \<sqsubseteq> z \<Longrightarrow> x \<squnion> y \<sqsubseteq> z"
  by (rule is_sup_least) (rule is_sup_join)

lemma join_upper1 [intro?]: "x \<sqsubseteq> x \<squnion> y"
  by (rule is_sup_upper) (rule is_sup_join)

lemma join_upper2 [intro?]: "y \<sqsubseteq> x \<squnion> y"
  by (rule is_sup_upper) (rule is_sup_join)

subsection {* Duality *}

text {*
  The class of lattices is closed under formation of dual structures.
  This means that for any theorem of lattice theory, the dualized
  statement holds as well; this important fact simplifies many proofs
  of lattice theory.
*}

instance dual :: (lattice) lattice
proof
  fix x' y' :: "'a::lattice dual"
  show "\<exists>inf'. is_inf x' y' inf'"
  proof -
    have "\<exists>sup. is_sup (undual x') (undual y') sup" by (rule ex_sup)
    then have "\<exists>sup. is_inf (dual (undual x')) (dual (undual y')) (dual sup)"
      by (simp only: dual_inf)
    then show ?thesis by (simp add: dual_ex [symmetric])
  qed
  show "\<exists>sup'. is_sup x' y' sup'"
  proof -
    have "\<exists>inf. is_inf (undual x') (undual y') inf" by (rule ex_inf)
    then have "\<exists>inf. is_sup (dual (undual x')) (dual (undual y')) (dual inf)"
      by (simp only: dual_sup)
    then show ?thesis by (simp add: dual_ex [symmetric])
  qed
qed

text {*
  Apparently, the @{text \<sqinter>} and @{text \<squnion>} operations are dual to each
  other.
*}

theorem dual_meet [intro?]: "dual (x \<sqinter> y) = dual x \<squnion> dual y"
proof -
  from is_inf_meet have "is_sup (dual x) (dual y) (dual (x \<sqinter> y))" ..
  then have "dual x \<squnion> dual y = dual (x \<sqinter> y)" ..
  then show ?thesis ..
qed

theorem dual_join [intro?]: "dual (x \<squnion> y) = dual x \<sqinter> dual y"
proof -
  from is_sup_join have "is_inf (dual x) (dual y) (dual (x \<squnion> y))" ..
  then have "dual x \<sqinter> dual y = dual (x \<squnion> y)" ..
  then show ?thesis ..
qed

subsection {* Algebraic properties \label{sec:lattice-algebra} *}

text {*
  The @{text \<sqinter>} and @{text \<squnion>} operations have the following
  characteristic algebraic properties: associative (A), commutative
  (C), and absorptive (AB).
*}

theorem meet_assoc: "(x \<sqinter> y) \<sqinter> z = x \<sqinter> (y \<sqinter> z)"
proof
  show "x \<sqinter> (y \<sqinter> z) \<sqsubseteq> x \<sqinter> y"
  proof
    show "x \<sqinter> (y \<sqinter> z) \<sqsubseteq> x" ..
    show "x \<sqinter> (y \<sqinter> z) \<sqsubseteq> y"
    proof -
      have "x \<sqinter> (y \<sqinter> z) \<sqsubseteq> y \<sqinter> z" ..
      also have "\<dots> \<sqsubseteq> y" ..
      finally show ?thesis .
    qed
  qed
  show "x \<sqinter> (y \<sqinter> z) \<sqsubseteq> z"
  proof -
    have "x \<sqinter> (y \<sqinter> z) \<sqsubseteq> y \<sqinter> z" ..
    also have "\<dots> \<sqsubseteq> z" ..
    finally show ?thesis .
  qed
  fix w assume "w \<sqsubseteq> x \<sqinter> y" and "w \<sqsubseteq> z"
  show "w \<sqsubseteq> x \<sqinter> (y \<sqinter> z)"
  proof
    show "w \<sqsubseteq> x"
    proof -
      have "w \<sqsubseteq> x \<sqinter> y" by fact
      also have "\<dots> \<sqsubseteq> x" ..
      finally show ?thesis .
    qed
    show "w \<sqsubseteq> y \<sqinter> z"
    proof
      show "w \<sqsubseteq> y"
      proof -
        have "w \<sqsubseteq> x \<sqinter> y" by fact
        also have "\<dots> \<sqsubseteq> y" ..
        finally show ?thesis .
      qed
      show "w \<sqsubseteq> z" by fact
    qed
  qed
qed

theorem join_assoc: "(x \<squnion> y) \<squnion> z = x \<squnion> (y \<squnion> z)"
proof -
  have "dual ((x \<squnion> y) \<squnion> z) = (dual x \<sqinter> dual y) \<sqinter> dual z"
    by (simp only: dual_join)
  also have "\<dots> = dual x \<sqinter> (dual y \<sqinter> dual z)"
    by (rule meet_assoc)
  also have "\<dots> = dual (x \<squnion> (y \<squnion> z))"
    by (simp only: dual_join)
  finally show ?thesis ..
qed

theorem meet_commute: "x \<sqinter> y = y \<sqinter> x"
proof
  show "y \<sqinter> x \<sqsubseteq> x" ..
  show "y \<sqinter> x \<sqsubseteq> y" ..
  fix z assume "z \<sqsubseteq> y" and "z \<sqsubseteq> x"
  then show "z \<sqsubseteq> y \<sqinter> x" ..
qed

theorem join_commute: "x \<squnion> y = y \<squnion> x"
proof -
  have "dual (x \<squnion> y) = dual x \<sqinter> dual y" ..
  also have "\<dots> = dual y \<sqinter> dual x"
    by (rule meet_commute)
  also have "\<dots> = dual (y \<squnion> x)"
    by (simp only: dual_join)
  finally show ?thesis ..
qed

theorem meet_join_absorb: "x \<sqinter> (x \<squnion> y) = x"
proof
  show "x \<sqsubseteq> x" ..
  show "x \<sqsubseteq> x \<squnion> y" ..
  fix z assume "z \<sqsubseteq> x" and "z \<sqsubseteq> x \<squnion> y"
  show "z \<sqsubseteq> x" by fact
qed

theorem join_meet_absorb: "x \<squnion> (x \<sqinter> y) = x"
proof -
  have "dual x \<sqinter> (dual x \<squnion> dual y) = dual x"
    by (rule meet_join_absorb)
  then have "dual (x \<squnion> (x \<sqinter> y)) = dual x"
    by (simp only: dual_meet dual_join)
  then show ?thesis ..
qed

text {*
  \medskip Some further algebraic properties hold as well.  The
  property idempotent (I) is a basic algebraic consequence of (AB).
*}

theorem meet_idem: "x \<sqinter> x = x"
proof -
  have "x \<sqinter> (x \<squnion> (x \<sqinter> x)) = x" by (rule meet_join_absorb)
  also have "x \<squnion> (x \<sqinter> x) = x" by (rule join_meet_absorb)
  finally show ?thesis .
qed

theorem join_idem: "x \<squnion> x = x"
proof -
  have "dual x \<sqinter> dual x = dual x"
    by (rule meet_idem)
  then have "dual (x \<squnion> x) = dual x"
    by (simp only: dual_join)
  then show ?thesis ..
qed

text {*
  Meet and join are trivial for related elements.
*}

theorem meet_related [elim?]: "x \<sqsubseteq> y \<Longrightarrow> x \<sqinter> y = x"
proof
  assume "x \<sqsubseteq> y"
  show "x \<sqsubseteq> x" ..
  show "x \<sqsubseteq> y" by fact
  fix z assume "z \<sqsubseteq> x" and "z \<sqsubseteq> y"
  show "z \<sqsubseteq> x" by fact
qed

theorem join_related [elim?]: "x \<sqsubseteq> y \<Longrightarrow> x \<squnion> y = y"
proof -
  assume "x \<sqsubseteq> y" then have "dual y \<sqsubseteq> dual x" ..
  then have "dual y \<sqinter> dual x = dual y" by (rule meet_related)
  also have "dual y \<sqinter> dual x = dual (y \<squnion> x)" by (simp only: dual_join)
  also have "y \<squnion> x = x \<squnion> y" by (rule join_commute)
  finally show ?thesis ..
qed

subsection {* Order versus algebraic structure *}

text {*
  The @{text \<sqinter>} and @{text \<squnion>} operations are connected with the
  underlying @{text \<sqsubseteq>} relation in a canonical manner.
*}

theorem meet_connection: "(x \<sqsubseteq> y) = (x \<sqinter> y = x)"
proof
  assume "x \<sqsubseteq> y"
  then have "is_inf x y x" ..
  then show "x \<sqinter> y = x" ..
next
  have "x \<sqinter> y \<sqsubseteq> y" ..
  also assume "x \<sqinter> y = x"
  finally show "x \<sqsubseteq> y" .
qed

theorem join_connection: "(x \<sqsubseteq> y) = (x \<squnion> y = y)"
proof
  assume "x \<sqsubseteq> y"
  then have "is_sup x y y" ..
  then show "x \<squnion> y = y" ..
next
  have "x \<sqsubseteq> x \<squnion> y" ..
  also assume "x \<squnion> y = y"
  finally show "x \<sqsubseteq> y" .
qed

text {*
  \medskip The most fundamental result of the meta-theory of lattices
  is as follows (we do not prove it here).

  Given a structure with binary operations @{text \<sqinter>} and @{text \<squnion>}
  such that (A), (C), and (AB) hold (cf.\
  \S\ref{sec:lattice-algebra}).  This structure represents a lattice,
  if the relation @{term "x \<sqsubseteq> y"} is defined as @{term "x \<sqinter> y = x"}
  (alternatively as @{term "x \<squnion> y = y"}).  Furthermore, infimum and
  supremum with respect to this ordering coincide with the original
  @{text \<sqinter>} and @{text \<squnion>} operations.
*}

subsection {* Example instances *}

subsubsection {* Linear orders *}

text {*
  Linear orders with @{term minimum} and @{term maximum} operations
  are a (degenerate) example of lattice structures.
*}

definition
  minimum :: "'a::linear_order \<Rightarrow> 'a \<Rightarrow> 'a" where
  "minimum x y = (if x \<sqsubseteq> y then x else y)"
definition
  maximum :: "'a::linear_order \<Rightarrow> 'a \<Rightarrow> 'a" where
  "maximum x y = (if x \<sqsubseteq> y then y else x)"

lemma is_inf_minimum: "is_inf x y (minimum x y)"
proof
  let ?min = "minimum x y"
  from leq_linear show "?min \<sqsubseteq> x" by (auto simp add: minimum_def)
  from leq_linear show "?min \<sqsubseteq> y" by (auto simp add: minimum_def)
  fix z assume "z \<sqsubseteq> x" and "z \<sqsubseteq> y"
  with leq_linear show "z \<sqsubseteq> ?min" by (auto simp add: minimum_def)
qed

lemma is_sup_maximum: "is_sup x y (maximum x y)"      (* FIXME dualize!? *)
proof
  let ?max = "maximum x y"
  from leq_linear show "x \<sqsubseteq> ?max" by (auto simp add: maximum_def)
  from leq_linear show "y \<sqsubseteq> ?max" by (auto simp add: maximum_def)
  fix z assume "x \<sqsubseteq> z" and "y \<sqsubseteq> z"
  with leq_linear show "?max \<sqsubseteq> z" by (auto simp add: maximum_def)
qed

instance linear_order \<subseteq> lattice
proof
  fix x y :: "'a::linear_order"
  from is_inf_minimum show "\<exists>inf. is_inf x y inf" ..
  from is_sup_maximum show "\<exists>sup. is_sup x y sup" ..
qed

text {*
  The lattice operations on linear orders indeed coincide with @{term
  minimum} and @{term maximum}.
*}

theorem meet_mimimum: "x \<sqinter> y = minimum x y"
  by (rule meet_equality) (rule is_inf_minimum)

theorem meet_maximum: "x \<squnion> y = maximum x y"
  by (rule join_equality) (rule is_sup_maximum)

subsubsection {* Binary products *}

text {*
  The class of lattices is closed under direct binary products (cf.\
  \S\ref{sec:prod-order}).
*}

lemma is_inf_prod: "is_inf p q (fst p \<sqinter> fst q, snd p \<sqinter> snd q)"
proof
  show "(fst p \<sqinter> fst q, snd p \<sqinter> snd q) \<sqsubseteq> p"
  proof -
    have "fst p \<sqinter> fst q \<sqsubseteq> fst p" ..
    moreover have "snd p \<sqinter> snd q \<sqsubseteq> snd p" ..
    ultimately show ?thesis by (simp add: leq_prod_def)
  qed
  show "(fst p \<sqinter> fst q, snd p \<sqinter> snd q) \<sqsubseteq> q"
  proof -
    have "fst p \<sqinter> fst q \<sqsubseteq> fst q" ..
    moreover have "snd p \<sqinter> snd q \<sqsubseteq> snd q" ..
    ultimately show ?thesis by (simp add: leq_prod_def)
  qed
  fix r assume rp: "r \<sqsubseteq> p" and rq: "r \<sqsubseteq> q"
  show "r \<sqsubseteq> (fst p \<sqinter> fst q, snd p \<sqinter> snd q)"
  proof -
    have "fst r \<sqsubseteq> fst p \<sqinter> fst q"
    proof
      from rp show "fst r \<sqsubseteq> fst p" by (simp add: leq_prod_def)
      from rq show "fst r \<sqsubseteq> fst q" by (simp add: leq_prod_def)
    qed
    moreover have "snd r \<sqsubseteq> snd p \<sqinter> snd q"
    proof
      from rp show "snd r \<sqsubseteq> snd p" by (simp add: leq_prod_def)
      from rq show "snd r \<sqsubseteq> snd q" by (simp add: leq_prod_def)
    qed
    ultimately show ?thesis by (simp add: leq_prod_def)
  qed
qed

lemma is_sup_prod: "is_sup p q (fst p \<squnion> fst q, snd p \<squnion> snd q)"  (* FIXME dualize!? *)
proof
  show "p \<sqsubseteq> (fst p \<squnion> fst q, snd p \<squnion> snd q)"
  proof -
    have "fst p \<sqsubseteq> fst p \<squnion> fst q" ..
    moreover have "snd p \<sqsubseteq> snd p \<squnion> snd q" ..
    ultimately show ?thesis by (simp add: leq_prod_def)
  qed
  show "q \<sqsubseteq> (fst p \<squnion> fst q, snd p \<squnion> snd q)"
  proof -
    have "fst q \<sqsubseteq> fst p \<squnion> fst q" ..
    moreover have "snd q \<sqsubseteq> snd p \<squnion> snd q" ..
    ultimately show ?thesis by (simp add: leq_prod_def)
  qed
  fix r assume "pr": "p \<sqsubseteq> r" and qr: "q \<sqsubseteq> r"
  show "(fst p \<squnion> fst q, snd p \<squnion> snd q) \<sqsubseteq> r"
  proof -
    have "fst p \<squnion> fst q \<sqsubseteq> fst r"
    proof
      from "pr" show "fst p \<sqsubseteq> fst r" by (simp add: leq_prod_def)
      from qr show "fst q \<sqsubseteq> fst r" by (simp add: leq_prod_def)
    qed
    moreover have "snd p \<squnion> snd q \<sqsubseteq> snd r"
    proof
      from "pr" show "snd p \<sqsubseteq> snd r" by (simp add: leq_prod_def)
      from qr show "snd q \<sqsubseteq> snd r" by (simp add: leq_prod_def)
    qed
    ultimately show ?thesis by (simp add: leq_prod_def)
  qed
qed

instance prod :: (lattice, lattice) lattice
proof
  fix p q :: "'a::lattice \<times> 'b::lattice"
  from is_inf_prod show "\<exists>inf. is_inf p q inf" ..
  from is_sup_prod show "\<exists>sup. is_sup p q sup" ..
qed

text {*
  The lattice operations on a binary product structure indeed coincide
  with the products of the original ones.
*}

theorem meet_prod: "p \<sqinter> q = (fst p \<sqinter> fst q, snd p \<sqinter> snd q)"
  by (rule meet_equality) (rule is_inf_prod)

theorem join_prod: "p \<squnion> q = (fst p \<squnion> fst q, snd p \<squnion> snd q)"
  by (rule join_equality) (rule is_sup_prod)

subsubsection {* General products *}

text {*
  The class of lattices is closed under general products (function
  spaces) as well (cf.\ \S\ref{sec:fun-order}).
*}

lemma is_inf_fun: "is_inf f g (\<lambda>x. f x \<sqinter> g x)"
proof
  show "(\<lambda>x. f x \<sqinter> g x) \<sqsubseteq> f"
  proof
    fix x show "f x \<sqinter> g x \<sqsubseteq> f x" ..
  qed
  show "(\<lambda>x. f x \<sqinter> g x) \<sqsubseteq> g"
  proof
    fix x show "f x \<sqinter> g x \<sqsubseteq> g x" ..
  qed
  fix h assume hf: "h \<sqsubseteq> f" and hg: "h \<sqsubseteq> g"
  show "h \<sqsubseteq> (\<lambda>x. f x \<sqinter> g x)"
  proof
    fix x
    show "h x \<sqsubseteq> f x \<sqinter> g x"
    proof
      from hf show "h x \<sqsubseteq> f x" ..
      from hg show "h x \<sqsubseteq> g x" ..
    qed
  qed
qed

lemma is_sup_fun: "is_sup f g (\<lambda>x. f x \<squnion> g x)"   (* FIXME dualize!? *)
proof
  show "f \<sqsubseteq> (\<lambda>x. f x \<squnion> g x)"
  proof
    fix x show "f x \<sqsubseteq> f x \<squnion> g x" ..
  qed
  show "g \<sqsubseteq> (\<lambda>x. f x \<squnion> g x)"
  proof
    fix x show "g x \<sqsubseteq> f x \<squnion> g x" ..
  qed
  fix h assume fh: "f \<sqsubseteq> h" and gh: "g \<sqsubseteq> h"
  show "(\<lambda>x. f x \<squnion> g x) \<sqsubseteq> h"
  proof
    fix x
    show "f x \<squnion> g x \<sqsubseteq> h x"
    proof
      from fh show "f x \<sqsubseteq> h x" ..
      from gh show "g x \<sqsubseteq> h x" ..
    qed
  qed
qed

instance "fun" :: (type, lattice) lattice
proof
  fix f g :: "'a \<Rightarrow> 'b::lattice"
  show "\<exists>inf. is_inf f g inf" by rule (rule is_inf_fun) (* FIXME @{text "from \<dots> show \<dots> .."} does not work!? unification incompleteness!? *)
  show "\<exists>sup. is_sup f g sup" by rule (rule is_sup_fun)
qed

text {*
  The lattice operations on a general product structure (function
  space) indeed emerge by point-wise lifting of the original ones.
*}

theorem meet_fun: "f \<sqinter> g = (\<lambda>x. f x \<sqinter> g x)"
  by (rule meet_equality) (rule is_inf_fun)

theorem join_fun: "f \<squnion> g = (\<lambda>x. f x \<squnion> g x)"
  by (rule join_equality) (rule is_sup_fun)

subsection {* Monotonicity and semi-morphisms *}

text {*
  The lattice operations are monotone in both argument positions.  In
  fact, monotonicity of the second position is trivial due to
  commutativity.
*}

theorem meet_mono: "x \<sqsubseteq> z \<Longrightarrow> y \<sqsubseteq> w \<Longrightarrow> x \<sqinter> y \<sqsubseteq> z \<sqinter> w"
proof -
  {
    fix a b c :: "'a::lattice"
    assume "a \<sqsubseteq> c" have "a \<sqinter> b \<sqsubseteq> c \<sqinter> b"
    proof
      have "a \<sqinter> b \<sqsubseteq> a" ..
      also have "\<dots> \<sqsubseteq> c" by fact
      finally show "a \<sqinter> b \<sqsubseteq> c" .
      show "a \<sqinter> b \<sqsubseteq> b" ..
    qed
  } note this [elim?]
  assume "x \<sqsubseteq> z" then have "x \<sqinter> y \<sqsubseteq> z \<sqinter> y" ..
  also have "\<dots> = y \<sqinter> z" by (rule meet_commute)
  also assume "y \<sqsubseteq> w" then have "y \<sqinter> z \<sqsubseteq> w \<sqinter> z" ..
  also have "\<dots> = z \<sqinter> w" by (rule meet_commute)
  finally show ?thesis .
qed

theorem join_mono: "x \<sqsubseteq> z \<Longrightarrow> y \<sqsubseteq> w \<Longrightarrow> x \<squnion> y \<sqsubseteq> z \<squnion> w"
proof -
  assume "x \<sqsubseteq> z" then have "dual z \<sqsubseteq> dual x" ..
  moreover assume "y \<sqsubseteq> w" then have "dual w \<sqsubseteq> dual y" ..
  ultimately have "dual z \<sqinter> dual w \<sqsubseteq> dual x \<sqinter> dual y"
    by (rule meet_mono)
  then have "dual (z \<squnion> w) \<sqsubseteq> dual (x \<squnion> y)"
    by (simp only: dual_join)
  then show ?thesis ..
qed

text {*
  \medskip A semi-morphisms is a function @{text f} that preserves the
  lattice operations in the following manner: @{term "f (x \<sqinter> y) \<sqsubseteq> f x
  \<sqinter> f y"} and @{term "f x \<squnion> f y \<sqsubseteq> f (x \<squnion> y)"}, respectively.  Any of
  these properties is equivalent with monotonicity.
*}

theorem meet_semimorph:
  "(\<And>x y. f (x \<sqinter> y) \<sqsubseteq> f x \<sqinter> f y) \<equiv> (\<And>x y. x \<sqsubseteq> y \<Longrightarrow> f x \<sqsubseteq> f y)"
proof
  assume morph: "\<And>x y. f (x \<sqinter> y) \<sqsubseteq> f x \<sqinter> f y"
  fix x y :: "'a::lattice"
  assume "x \<sqsubseteq> y"
  then have "x \<sqinter> y = x" ..
  then have "x = x \<sqinter> y" ..
  also have "f \<dots> \<sqsubseteq> f x \<sqinter> f y" by (rule morph)
  also have "\<dots> \<sqsubseteq> f y" ..
  finally show "f x \<sqsubseteq> f y" .
next
  assume mono: "\<And>x y. x \<sqsubseteq> y \<Longrightarrow> f x \<sqsubseteq> f y"
  show "\<And>x y. f (x \<sqinter> y) \<sqsubseteq> f x \<sqinter> f y"
  proof -
    fix x y
    show "f (x \<sqinter> y) \<sqsubseteq> f x \<sqinter> f y"
    proof
      have "x \<sqinter> y \<sqsubseteq> x" .. then show "f (x \<sqinter> y) \<sqsubseteq> f x" by (rule mono)
      have "x \<sqinter> y \<sqsubseteq> y" .. then show "f (x \<sqinter> y) \<sqsubseteq> f y" by (rule mono)
    qed
  qed
qed

lemma join_semimorph:
  "(\<And>x y. f x \<squnion> f y \<sqsubseteq> f (x \<squnion> y)) \<equiv> (\<And>x y. x \<sqsubseteq> y \<Longrightarrow> f x \<sqsubseteq> f y)"
proof
  assume morph: "\<And>x y. f x \<squnion> f y \<sqsubseteq> f (x \<squnion> y)"
  fix x y :: "'a::lattice"
  assume "x \<sqsubseteq> y" then have "x \<squnion> y = y" ..
  have "f x \<sqsubseteq> f x \<squnion> f y" ..
  also have "\<dots> \<sqsubseteq> f (x \<squnion> y)" by (rule morph)
  also from `x \<sqsubseteq> y` have "x \<squnion> y = y" ..
  finally show "f x \<sqsubseteq> f y" .
next
  assume mono: "\<And>x y. x \<sqsubseteq> y \<Longrightarrow> f x \<sqsubseteq> f y"
  show "\<And>x y. f x \<squnion> f y \<sqsubseteq> f (x \<squnion> y)"
  proof -
    fix x y
    show "f x \<squnion> f y \<sqsubseteq> f (x \<squnion> y)"
    proof
      have "x \<sqsubseteq> x \<squnion> y" .. then show "f x \<sqsubseteq> f (x \<squnion> y)" by (rule mono)
      have "y \<sqsubseteq> x \<squnion> y" .. then show "f y \<sqsubseteq> f (x \<squnion> y)" by (rule mono)
    qed
  qed
qed

end


(*  Title:      Open Induction
    Author:     Mizuhito Ogawa
                Christian Sternagel <c.sternagel@gmail.com>
    Maintainer: Christian Sternagel
    License:    LGPL
*)

section \<open>Open Induction\<close>

theory Open_Induction
imports Restricted_Predicates
begin

subsection \<open>(Greatest) Lower Bounds and Chains\<close>

text \<open>
  A set \<open>B\<close> has the \emph{lower bound} \<open>x\<close> iff \<open>x\<close> is
  less than or equal to every element of \<open>B\<close>.
\<close>
definition "lb P B x \<longleftrightarrow> (\<forall>y\<in>B. P\<^sup>=\<^sup>= x y)"

lemma lbI [Pure.intro]:
  "(\<And>y. y \<in> B \<Longrightarrow> P\<^sup>=\<^sup>= x y) \<Longrightarrow> lb P B x"
by (auto simp: lb_def)

text \<open>
  A set \<open>B\<close> has the \emph{greatest lower bound} \<open>x\<close> iff \<open>x\<close> is
  a lower bound of \<open>B\<close> \emph{and} less than or equal to every
  other lower bound of \<open>B\<close>.
\<close>
definition "glb P B x \<longleftrightarrow> lb P B x \<and> (\<forall>y. lb P B y \<longrightarrow> P\<^sup>=\<^sup>= y x)"

lemma glbI [Pure.intro]:
  "lb P B x \<Longrightarrow> (\<And>y. lb P B y \<Longrightarrow> P\<^sup>=\<^sup>= y x) \<Longrightarrow> glb P B x"
by (auto simp: glb_def)

text \<open>Antisymmetric relations have unique glbs.\<close>
lemma glb_unique:
  "antisymp_on P A \<Longrightarrow> x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> glb P B x \<Longrightarrow> glb P B y \<Longrightarrow> x = y"
by (auto simp: glb_def antisymp_on_def)

context pred_on
begin

lemma chain_glb:
  assumes "transp_on (\<sqsubset>) A"
  shows "chain C \<Longrightarrow> glb (\<sqsubset>) C x \<Longrightarrow> x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> y \<sqsubset> x \<Longrightarrow> chain ({y} \<union> C)"
using assms [unfolded transp_on_def]
unfolding chain_def glb_def lb_def
by (cases "C = {}") blast+

subsection \<open>Open Properties\<close>

definition "open Q \<longleftrightarrow> (\<forall>C. chain C \<and> C \<noteq> {} \<and> (\<exists>x\<in>A. glb (\<sqsubset>) C x \<and> Q x) \<longrightarrow> (\<exists>y\<in>C. Q y))"

lemma openI [Pure.intro]:
  "(\<And>C. chain C \<Longrightarrow> C \<noteq> {} \<Longrightarrow> \<exists>x\<in>A. glb (\<sqsubset>) C x \<and> Q x \<Longrightarrow> \<exists>y\<in>C. Q y) \<Longrightarrow> open Q"
by (auto simp: open_def)

lemma open_glb:
  "\<lbrakk>chain C; C \<noteq> {}; open Q; \<forall>x\<in>C. \<not> Q x; x \<in> A; glb (\<sqsubset>) C x\<rbrakk> \<Longrightarrow> \<not> Q x"
by (auto simp: open_def)

subsection \<open>Downward Completeness\<close>

text \<open>
  A relation \<open>\<sqsubset>\<close> is \emph{downward-complete} iff
  every non-empty \<open>\<sqsubset>\<close>-chain has a greatest lower bound.
\<close>
definition "downward_complete \<longleftrightarrow> (\<forall>C. chain C \<and> C \<noteq> {} \<longrightarrow> (\<exists>x\<in>A. glb (\<sqsubset>) C x))"

lemma downward_completeI [Pure.intro]:
  assumes "\<And>C. chain C \<Longrightarrow> C \<noteq> {} \<Longrightarrow> \<exists>x\<in>A. glb (\<sqsubset>) C x"
  shows "downward_complete"
using assms by (auto simp: downward_complete_def)

end

abbreviation "open_on P Q A \<equiv> pred_on.open A P Q"
abbreviation "dc_on P A \<equiv> pred_on.downward_complete A P"
lemmas open_on_def = pred_on.open_def
  and dc_on_def = pred_on.downward_complete_def

lemma dc_onI [Pure.intro]:
  assumes "\<And>C. chain_on P C A \<Longrightarrow> C \<noteq> {} \<Longrightarrow> \<exists>x\<in>A. glb P C x"
  shows "dc_on P A"
using assms by (auto simp: dc_on_def)

lemma open_onI [Pure.intro]:
  "(\<And>C. chain_on P C A \<Longrightarrow> C \<noteq> {} \<Longrightarrow> \<exists>x\<in>A. glb P C x \<and> Q x \<Longrightarrow> \<exists>y\<in>C. Q y) \<Longrightarrow> open_on P Q A"
by (auto simp: open_on_def)

lemma chain_on_reflclp:
  "chain_on P\<^sup>=\<^sup>= A C \<longleftrightarrow> chain_on P A C"
by (auto simp: pred_on.chain_def)

lemma lb_reflclp:
  "lb P\<^sup>=\<^sup>= B x \<longleftrightarrow> lb P B x"
by (auto simp: lb_def)

lemma glb_reflclp:
  "glb P\<^sup>=\<^sup>= B x \<longleftrightarrow> glb P B x"
by (auto simp: glb_def lb_reflclp)

lemma dc_on_reflclp:
  "dc_on P\<^sup>=\<^sup>= A \<longleftrightarrow> dc_on P A"
by (auto simp: dc_on_def chain_on_reflclp glb_reflclp)

subsection \<open>The Open Induction Principle\<close>

lemma open_induct_on [consumes 4, case_names less]:
  assumes qo: "qo_on P A" and "dc_on P A" and "open_on P Q A"
    and "x \<in> A"
    and ind: "\<And>x. \<lbrakk>x \<in> A; \<And>y. \<lbrakk>y \<in> A; strict P y x\<rbrakk> \<Longrightarrow> Q y\<rbrakk> \<Longrightarrow> Q x"
  shows "Q x"
proof (rule ccontr)
  assume "\<not> Q x"
  let ?B = "{x\<in>A. \<not> Q x}"
  have "?B \<subseteq> A" by blast
  interpret B: pred_on ?B P .
  from B.Hausdorff obtain M
    where chain: "B.chain M"
    and max: "\<And>C. B.chain C \<Longrightarrow> M \<subseteq> C \<Longrightarrow> M = C" by (auto simp: B.maxchain_def)
  then have "M \<subseteq> ?B" by (auto simp: B.chain_def)
  show False
  proof (cases "M = {}")
    assume "M = {}"
    moreover have "B.chain {x}" using \<open>x \<in> A\<close> and \<open>\<not> Q x\<close> by (simp add: B.chain_def)
    ultimately show False using max by blast
  next
    interpret A: pred_on A P .
    assume "M \<noteq> {}"
    have "A.chain M" using chain by (auto simp: A.chain_def B.chain_def)
    moreover with \<open>dc_on P A\<close> and \<open>M \<noteq> {}\<close> obtain m
      where "m \<in> A" and "glb P M m" by (auto simp: A.downward_complete_def)
    ultimately have "\<not> Q m" and "m \<in> ?B"
      using A.open_glb [OF _ \<open>M \<noteq> {}\<close> \<open>open_on P Q A\<close> _ _ \<open>glb P M m\<close>]
      and \<open>M \<subseteq> ?B\<close> by auto
    from ind [OF \<open>m \<in> A\<close>] and \<open>\<not> Q m\<close> obtain y
      where "y \<in> A" and "strict P y m" and "\<not> Q y" by blast
    then have "P y m" and "y \<in> ?B" by simp+
    from transp_on_subset [OF \<open>?B \<subseteq> A\<close> qo_on_imp_transp_on [OF qo]]
      have "transp_on P ?B" .
    from B.chain_glb [OF this chain \<open>glb P M m\<close> \<open>m \<in> ?B\<close> \<open>y \<in> ?B\<close> \<open>P y m\<close>]
      have "B.chain ({y} \<union> M)" .
    then show False
      using \<open>glb P M m\<close> and \<open>strict P y m\<close> by (cases "y \<in> M") (auto dest: max simp: glb_def lb_def)
  qed
qed

subsection \<open>Open Induction on Universal Domains\<close>

text \<open>Open induction on quasi-orders (i.e., @{class preorder}).\<close>
lemma (in preorder) dc_open_induct [consumes 2, case_names less]:
  assumes "dc_on (\<le>) UNIV"
    and "open_on (\<le>) Q UNIV"
    and "\<And>x. (\<And>y. y < x \<Longrightarrow> Q y) \<Longrightarrow> Q x"
  shows "Q x"
proof -
  have "qo_on (\<le>) UNIV" by (auto simp: qo_on_def transp_on_def reflp_on_def dest: order_trans)
  from open_induct_on [OF this assms(1,2)]
    show "Q x" using assms(3) unfolding less_le_not_le by blast
qed

subsection \<open>Type Class of Downward Complete Orders\<close>

class dcorder = preorder +
  assumes dc_on_UNIV: "dc_on (\<le>) UNIV"
begin

text \<open>Open induction on downward-complete orders.\<close>
lemmas open_induct [consumes 1, case_names less] = dc_open_induct [OF dc_on_UNIV]

end

end


section \<open>Rank Annotated Tree\<close>

theory RankAnnotatedTree
imports Main

begin

subsection \<open>Type definition and operations\<close>

datatype 'a rtree = Leaf ("\<langle>/ \<rangle>")| Node "'a rtree" nat 'a "'a rtree" ("(1\<langle> _,/ _,/ _,/ _ \<rangle>)")

fun num_nodes :: "'a rtree \<Rightarrow> nat" where
"num_nodes \<langle>\<rangle> = 0" |
"num_nodes \<langle>l, _, _, r\<rangle> = 1 + num_nodes l + num_nodes r"

value  "num_nodes \<langle>\<langle>\<langle>\<langle>\<rangle>, 0, 3, \<langle>\<rangle>\<rangle> , 1, 4, \<langle>\<langle>\<rangle>, 0, 5, \<langle>\<rangle>\<rangle>\<rangle>, 3, 6::nat, \<langle>\<langle>\<langle>\<rangle>, 0, 7,\<langle>\<rangle>\<rangle>, 1, 8, \<langle>\<langle>\<rangle>, 0, 9,\<langle>\<rangle>\<rangle>\<rangle>\<rangle>"

fun set_rtree :: "'a rtree \<Rightarrow> 'a set" where
  "set_rtree \<langle>\<rangle> = {}"
| "set_rtree \<langle>l,n,x,r\<rangle> = set_rtree l \<union> set_rtree r \<union> {x}"

fun rbst :: "('a::linorder) rtree \<Rightarrow> bool" where
"rbst \<langle>\<rangle> = True" |
"rbst \<langle>l, n, x, r\<rangle> = ((\<forall>a \<in> set_rtree l. a < x) \<and> (\<forall>a \<in> set_rtree r. x < a) \<and> rbst l \<and> rbst r \<and> n = num_nodes l)"

value "rbst \<langle>\<langle>\<langle>\<langle>\<rangle>, 0, 3, \<langle>\<rangle>\<rangle> , 1, 4, \<langle>\<langle>\<rangle>, 0, 5, \<langle>\<rangle>\<rangle>\<rangle>, 3, 6::nat, \<langle>\<langle>\<langle>\<rangle>, 0, 7,\<langle>\<rangle>\<rangle>, 1, 8, \<langle>\<langle>\<rangle>, 0, 9,\<langle>\<rangle>\<rangle>\<rangle>\<rangle>"
value "rbst \<langle>\<langle>\<langle>\<langle>\<rangle>, 0, 3, \<langle>\<rangle>\<rangle> , 2, 4, \<langle>\<langle>\<rangle>, 0, 5, \<langle>\<rangle>\<rangle>\<rangle>, 3, 6::nat, \<langle>\<langle>\<langle>\<rangle>, 0, 7,\<langle>\<rangle>\<rangle>, 1, 8, \<langle>\<langle>\<rangle>, 0, 9,\<langle>\<rangle>\<rangle>\<rangle>\<rangle>"

lemma set_rtree_rbst: "rbst \<langle>l, n, x, r\<rangle> \<Longrightarrow> a \<in> set_rtree \<langle>l, n, x, r\<rangle> \<Longrightarrow> a < x \<Longrightarrow> a \<in> set_rtree l"
  by force

fun rins :: "'a::linorder \<Rightarrow> 'a rtree \<Rightarrow> 'a rtree" where
"rins a \<langle>\<rangle> = \<langle>\<langle>\<rangle>, 0, a, \<langle>\<rangle>\<rangle>" |
"rins a \<langle>l, n, x, r\<rangle> = (if a \<in> set_rtree \<langle>l, n, x, r\<rangle> then \<langle>l, n, x, r\<rangle>
                      else if a < x then \<langle>rins a l, n + 1, x, r\<rangle>
                      else \<langle>l, n, x, rins a r\<rangle>)"

value "rins 9 \<langle>\<langle>\<langle>\<langle>\<rangle>, 0, 3, \<langle>\<rangle>\<rangle> , 1, 4, \<langle>\<langle>\<rangle>, 0, 5, \<langle>\<rangle>\<rangle>\<rangle>, 3, 6::nat, \<langle>\<langle>\<langle>\<rangle>, 0, 7,\<langle>\<rangle>\<rangle>, 1, 8, \<langle>\<rangle>\<rangle>\<rangle>"

lemma rins_set[simp]: "set_rtree (rins x t) = insert x (set_rtree t)"
  by (induction t arbitrary: x rule: set_rtree.induct) auto

lemma num_nodes_rins_notin[simp]: "x \<notin> set_rtree t \<Longrightarrow> rbst t \<Longrightarrow> num_nodes (rins x t) = 1 + num_nodes t"
  by (induction t rule: rbst.induct) simp+

lemma rins_invar[simp]: "x \<notin> set_rtree t \<Longrightarrow> rbst t \<Longrightarrow> rbst (rins x t)"
proof (induction t rule: rbst.induct)
  case 1
  then show ?case by simp
next
  case (2 l n a r)
  then show ?case
    by auto
qed

lemma rins_invar_in[simp]: "x \<in> set_rtree t \<Longrightarrow> rbst t \<Longrightarrow> rbst (rins x t)"
  using rbst.elims(2) by force

subsection \<open>Inorder traversal and getting rank\<close>

fun inorder:: "'a rtree \<Rightarrow> 'a list" where
"inorder \<langle>\<rangle> = []" |
"inorder \<langle>l, _, x, r\<rangle> = inorder l  @ (x # inorder r)"

value  "inorder \<langle>\<langle>\<langle>\<langle>\<rangle>, 0, 3, \<langle>\<rangle>\<rangle> , 1, 4, \<langle>\<langle>\<rangle>, 0, 5, \<langle>\<rangle>\<rangle>\<rangle>, 3, 6::nat, \<langle>\<langle>\<langle>\<rangle>, 0, 7,\<langle>\<rangle>\<rangle>, 1, 8, \<langle>\<langle>\<rangle>, 0, 9,\<langle>\<rangle>\<rangle>\<rangle>\<rangle>"

fun rank:: "'a::linorder \<Rightarrow> 'a rtree \<Rightarrow> nat" where
"rank a \<langle>\<rangle> = 0" |
"rank a \<langle>l, n, x, r\<rangle> = (if a = x then n
                       else if a > x then 1 + n + rank a r
                       else rank a l)"

value  "rank 9 \<langle>\<langle>\<langle>\<langle>\<rangle>, 0, 3, \<langle>\<rangle>\<rangle> , 1, 4, \<langle>\<langle>\<rangle>, 0, 5, \<langle>\<rangle>\<rangle>\<rangle>, 3, 6::nat, \<langle>\<langle>\<langle>\<rangle>, 0, 7,\<langle>\<rangle>\<rangle>, 1, 8, \<langle>\<langle>\<rangle>, 0, 9,\<langle>\<rangle>\<rangle>\<rangle>\<rangle>"

definition "at_index i l x \<equiv> i < length l \<and> l!i=x"

lemma num_nodes_inorder[simp]: "num_nodes t = length (inorder t)"
  by (induction t) simp+

lemma set_rtree_inorder_in[simp]:"x \<in> set_rtree t \<longleftrightarrow> x \<in> set(inorder t)"
  by (induction t) auto

lemma inorder_index: "rbst t \<Longrightarrow> a \<in> set_rtree t \<Longrightarrow> at_index (rank a t) (inorder t) a"
proof (induction t)
  case Leaf
  then show ?case by simp
next
  case (Node l n x r)
  then show ?case
  proof (cases "a = x")
    case True
    hence "rank a \<langle>l, n, x, r\<rangle> = n"
      by simp
    have "n = num_nodes l"
      using Node.prems(1) rbst.simps(2) by blast
    then have "... = length (inorder l)"
      by simp
    then show ?thesis using True by (auto split: if_splits simp add: \<open>n = num_nodes l\<close> at_index_def)
  next
    case False
    then show ?thesis
    proof (cases "a > x")
      case True
      hence "rank a \<langle>l, n, x, r\<rangle> = 1 + n + rank a r"
        using Node.prems(2) by auto
      from True have "a \<in> set_rtree r"
        using Node.prems(1) Node.prems(2) order_less_imp_not_less by fastforce
      then show ?thesis using True
        apply (auto split: if_splits simp add: at_index_def)
         apply (metis Node.IH(2) Node.prems(1) \<open>a \<in> set_rtree r\<close> at_index_def nat_add_left_cancel_less num_nodes_inorder rbst.simps(2))
        by (metis (no_types, lifting) Node.IH(2) Node.prems(1) \<open>a \<in> RankAnnotatedTree.set_rtree r\<close> add_Suc_right add_diff_cancel_left' at_index_def not_add_less1 nth_Cons_Suc nth_append num_nodes_inorder rbst.simps(2))
    next
      case False
      hence "rank a \<langle>l, n, x, r\<rangle> = rank a l" using \<open>a \<noteq> x\<close>
        using Node.prems(2) by auto
      from False \<open>a \<noteq>x\<close> have "a \<in> set_rtree l"
        by (meson Node.prems(1) Node.prems(2) antisym_conv3 set_rtree_rbst)
      then show ?thesis using False \<open>a \<noteq> x\<close>
        apply (auto split: if_splits simp add: at_index_def)
         apply (metis Node.IH(1) Node.prems(1) \<open>a \<in> RankAnnotatedTree.set_rtree l\<close> at_index_def less_Suc_eq rbst.simps(2) trans_less_add1)
        by (metis Node.IH(1) Node.prems(1) \<open>a \<in> RankAnnotatedTree.set_rtree l\<close> at_index_def nth_append rbst.simps(2))
    qed
  qed

qed

subsection \<open>Selection in a rank annotated tree\<close>

fun sel:: "nat \<Rightarrow> 'a::linorder rtree \<Rightarrow>'a" where
"sel _ \<langle>\<rangle> = undefined" |
"sel i \<langle>l, n, x, r\<rangle> = (if i = n then x
                      else if i < n then sel i l
                      else sel (i - n - 1) r)"

value  "sel 5 \<langle>\<langle>\<langle>\<langle>\<rangle>, 0, 3, \<langle>\<rangle>\<rangle> , 1, 4, \<langle>\<langle>\<rangle>, 0, 5, \<langle>\<rangle>\<rangle>\<rangle>, 3, 6::nat, \<langle>\<langle>\<langle>\<rangle>, 0, 7,\<langle>\<rangle>\<rangle>, 1, 8, \<langle>\<langle>\<rangle>, 0, 9,\<langle>\<rangle>\<rangle>\<rangle>\<rangle>"

lemma sel_in_set_rtree:"\<And> i. sel i t = a \<Longrightarrow> a \<noteq> undefined \<Longrightarrow> a \<in> set_rtree t"
proof(induction t)
  case Leaf
  then show ?case
    by simp
next
  case (Node l n x r)
  then show ?case
  proof (cases "i = n")
    case True
    then show ?thesis
      using Node.prems(1) by auto
  next
    case False
    then show ?thesis
    proof (cases "i<n")
      case True
      hence "sel i \<langle>l, n, x, r\<rangle> = sel i l"
        by simp
      then show ?thesis using Node.IH
        using Node.prems(1) Node.prems(2) by auto
    next
      case False
      hence "sel i \<langle>l, n, x, r\<rangle> = sel (i-n-1) r" using \<open>i\<noteq>n\<close>
        by simp
      then show ?thesis using \<open>i\<noteq>n\<close>
        using Node.IH(2) Node.prems(1) Node.prems(2) by auto
    qed
  qed
qed

lemma select_correct: "rbst t \<Longrightarrow> i < length (inorder t) \<Longrightarrow> sel i t = inorder t!i"
proof (induction t arbitrary: i)
  case Leaf
  then show ?case
    by simp
next
  case (Node l n x r)
  then show ?case
  proof (cases "i = n")
    case True
    then show ?thesis
      using Node.prems(1) by auto
  next
    case False
    then show ?thesis
    proof (cases "i < n")
      case True
      then show ?thesis
        by (metis False Node.IH(1) Node.prems(1) inorder.simps(2) nth_append num_nodes_inorder rbst.simps(2) sel.simps(2))
    next
      case False
      then have "sel i \<langle>l, n, x, r\<rangle> = sel (i - n - 1) r" using \<open>i \<noteq> n\<close>
        by simp
      moreover have "i - n - 1 < length (inorder r)" using False \<open>i \<noteq> n\<close>
        using Node.prems(1) Node.prems(2) by force
      moreover have "sel (i - n - 1) r = inorder r ! (i - n - 1)" using False \<open>i \<noteq> n\<close> Node.IH
        using Node.prems(1) calculation(2) rbst.simps(2) by blast
      then show ?thesis using False \<open>i \<noteq> n\<close>
        by (metis Node.prems(1) antisym_conv3 calculation(1) inorder.simps(2) nth_Cons_pos nth_append num_nodes_inorder rbst.simps(2) zero_less_diff)
    qed
  qed
qed

lemma rank_sel_id: "rbst t \<Longrightarrow> i < length (inorder t) \<Longrightarrow> rank (sel i t) t = i"
proof (induction t arbitrary: i)
  case Leaf
  then show ?case by simp
next
  case (Node l n x r)
  then show ?case using select_correct
    apply auto
       apply (simp add: order_less_not_sym select_correct)
    by fastforce+
qed

lemma set_rtree_set_inorder_eq[simp]: "rbst t \<Longrightarrow> set_rtree t = set(inorder t)"
  by auto

lemma card_set_rtree[simp]: "rbst t \<Longrightarrow> num_nodes t = card (set_rtree t)"
proof (induction t rule:rtree.induct)
  case Leaf
  then show ?case by simp
next
  case (Node l n a r)
  have a_not_in:"a \<notin> set_rtree l \<and> a \<notin> set_rtree r"
    by (metis Node.prems not_less_iff_gr_or_eq rbst.simps(2))
  then show ?case using card_def Node.IH a_not_in apply auto
    using Node.prems card_Un_disjoint by fastforce
qed

fun rmerge :: "'a::linorder rtree \<Rightarrow> 'a rtree \<Rightarrow> 'a rtree" where
"rmerge t \<langle>\<rangle> = t" |
"rmerge t \<langle>l, _, a, r\<rangle> = rins a (rmerge (rmerge t r) l)"

lemma rmerge_inv[simp]: "rbst u \<Longrightarrow> rbst t \<Longrightarrow> rbst (rmerge t u)"
  proof (induction u arbitrary: t rule: rmerge.induct)
    case (1 t)
    then show ?case by simp
  next
    case (2 t l n a r)
    then show ?case using 2 apply auto
      by (meson rins_invar rins_invar_in)
  qed

lemma rmerge_set[simp]: "rbst u \<Longrightarrow> rbst t \<Longrightarrow> set_rtree (rmerge t u) = set_rtree t \<union> set_rtree u"
  by (induction u arbitrary: t rule: rmerge.induct) auto

lemma card_rmerge[simp]:
  assumes "rbst t" and "rbst u"
  shows "card (set_rtree (rmerge t u)) = card (set_rtree t \<union> set_rtree u)"
using assms proof (induction u arbitrary: t rule:rtree.induct)
  case Leaf
  then show ?case by simp
next
  case (Node l n x r)
  then show ?case
    by (cases "x \<in> set_rtree t")(metis Node.prems(1) Node.prems(2) rmerge_set)+
qed

fun rdel :: "'a::linorder \<Rightarrow> 'a rtree \<Rightarrow> 'a rtree" where
"rdel x \<langle>\<rangle> = \<langle>\<rangle>" |
"rdel x \<langle>l, n, a, r\<rangle> = (if x \<in> set_rtree \<langle>l, n, a, r\<rangle> then
  (if x < a then \<langle>rdel x l, n-1, a, r\<rangle> else
    (if x > a then \<langle>l, n, a, rdel x r\<rangle> else
      rmerge l r))
  else \<langle>l, n, a, r\<rangle>)"

value  "rdel 5 \<langle>\<langle>\<langle>\<langle>\<rangle>, 0, 3, \<langle>\<rangle>\<rangle> , 1, 4, \<langle>\<langle>\<rangle>, 0, 5, \<langle>\<rangle>\<rangle>\<rangle>, 3, 6::nat, \<langle>\<langle>\<langle>\<rangle>, 0, 7,\<langle>\<rangle>\<rangle>, 1, 8, \<langle>\<langle>\<rangle>, 0, 9,\<langle>\<rangle>\<rangle>\<rangle>\<rangle>"
value  "rdel 6 \<langle>\<langle>\<langle>\<langle>\<rangle>, 0, 3, \<langle>\<rangle>\<rangle> , 1, 4, \<langle>\<langle>\<rangle>, 0, 5, \<langle>\<rangle>\<rangle>\<rangle>, 3, 6::nat, \<langle>\<langle>\<langle>\<rangle>, 0, 7,\<langle>\<rangle>\<rangle>, 1, 8, \<langle>\<langle>\<rangle>, 0, 9,\<langle>\<rangle>\<rangle>\<rangle>\<rangle>"
value  "rdel 10 \<langle>\<langle>\<langle>\<langle>\<rangle>, 0, 3, \<langle>\<rangle>\<rangle> , 1, 4, \<langle>\<langle>\<rangle>, 0, 5, \<langle>\<rangle>\<rangle>\<rangle>, 3, 6::nat, \<langle>\<langle>\<langle>\<rangle>, 0, 7,\<langle>\<rangle>\<rangle>, 1, 8, \<langle>\<langle>\<rangle>, 0, 9,\<langle>\<rangle>\<rangle>\<rangle>\<rangle>
  = \<langle>\<langle>\<langle>\<langle>\<rangle>, 0, 3, \<langle>\<rangle>\<rangle> , 1, 4, \<langle>\<langle>\<rangle>, 0, 5, \<langle>\<rangle>\<rangle>\<rangle>, 3, 6::nat, \<langle>\<langle>\<langle>\<rangle>, 0, 7,\<langle>\<rangle>\<rangle>, 1, 8, \<langle>\<langle>\<rangle>, 0, 9,\<langle>\<rangle>\<rangle>\<rangle>\<rangle>"

lemma rdel_set[simp]:"rbst t \<Longrightarrow> set_rtree (rdel x t) = (set_rtree t) - {x}"
proof (induction t arbitrary: x rule:rtree.induct)
  case Leaf
  then show ?case by simp
next
  case (Node l n a r)
  then show ?case apply auto
    apply fastforce
    apply fastforce
       apply (metis Un_iff rmerge_set  set_rtree_inorder_in)
    apply (metis Un_iff not_less_iff_gr_or_eq rmerge_set set_rtree_inorder_in)
    apply (metis Un_iff rmerge_set set_rtree_inorder_in)
    by (metis Un_iff rmerge_set set_rtree_inorder_in)
qed

lemma rdel_inv: "rbst t \<Longrightarrow> rbst (rdel x t)"
proof (induct t rule: rtree.induct)
  case Leaf
  then show ?case by simp
next
  case ind:(Node l n a r)
  then show ?case
  proof (cases "x \<in> set_rtree \<langle>l, n, a, r\<rangle>")
    case in_tree:True
    then show ?thesis
    proof (cases "x = a")
      case True
      then show ?thesis using ind rmerge_inv by auto
    next
      case x_neq_a:False
      then show ?thesis
      proof (cases "x < a")
        case True
        have "rbst (rdel x l)" using ind by simp
        moreover have "set_rtree (rdel x l) = set_rtree l - {x}"
          by (meson ind.prems rbst.simps(2) rdel_set)
        moreover have x_in_l: "x \<in> set_rtree l" using in_tree x_neq_a ind.prems True set_rtree_rbst
          by blast
        moreover have "card (set_rtree l - {x}) = n - 1"
          by (metis card_Diff_singleton card_set_rtree ind.prems rbst.simps(2) x_in_l)
        moreover have "length (inorder (rdel x l)) = n - 1" using ind rbst.simps x_in_l apply auto
          by (metis One_nat_def calculation(4) card_set_rtree num_nodes_inorder rdel_set)
        then show ?thesis using ind apply auto
            apply (metis Diff_iff rdel_set set_rtree_set_inorder_eq)
          using order.asym apply blast
          using True by blast
      next
        case x_geq_a: False
        have x_in_r: "x \<in> set_rtree r" using ind in_tree x_neq_a x_geq_a by auto
        then show ?thesis using ind in_tree x_in_r x_geq_a x_neq_a rbst.simps apply auto
          by (metis Diff_iff rdel_set set_rtree_set_inorder_eq)
      qed
    qed
  next
    case False
    then show ?thesis using ind by auto
  qed
qed

end